nedoPC.org

;  Эмулятор консольных функций BDOS CP/M. Может располагаться в Zero-
;  Page CP/M (т.к имеет размер всего в 255 байтов). Этот код в 256 байт
;  просто подставляется в начало бездисководной CP/M-программы, после
;  чего программа должна стартовать с адреса 0 и сможет работать без
;  CP/M. Если Zero-Page нужна для RST, то можно грузить этот BDOS под
;  вершину ОЗУ (на 7500), а удобнее всего прошить в ПЗУ в области F000.
 
       .Z80
       aseg
       ORG     100H
       
MYBDOS  EQU     75F6H

       public  MYBDOS

MCONIN  EQU     0F803H
MCOUT   EQU     0F809H
MSTAT   EQU     0F812H
XF81B   EQU     0F81BH
WBOOT   EQU     0F86CH

STACK   EQU     076D0H

; ----------------------------------------------

LOOP    MACRO   ADDR
       DEC     BC
       LD      A,B
       OR      C
       JP      NZ,ADDR
       ENDM

; ----------------------------------------------

       .phase  0
       JP      OOO
       DS      2
       JP      MYBDOS

OOO:    LD      HL,WBOOT
       LD      (1),HL

       LD      A,0C3H
       LD      (MYBDOS),A
       LD      HL,XBDOS
       LD      (MYBDOS+1),HL

.comment \
       LD      HL,DATA
       LD      DE,MYBDOS
       LD      BC,@LENGTH
@LDIR:  LD      A,(HL)
       LD      (DE),A
       INC     HL
       INC     DE
       LOOP    @LDIR
\
       JP      100H
DATA:

; ----------------------------------------------

;       .dephase
;       .phase  MYBDOS

XBDOS:  LD      HL,0
       ADD     HL,SP
       LD      (TMPSTK),HL

       LD      SP,STACK
       LD      A,C
       OR      A
       JP      Z,0             ; WBOOT ; функция 0 (WARM BOOT)

       CP      12              ; ф.12 номер версии
       JP      NZ,JJJ_01
       LD      A,22H
RETURN:
       defb    21H             ; LD HL,(TMPSTK)
TMPSTK: DS      2
       LD      SP,HL
       LD      L,A
       LD      H,0
       RET

JJJ_01: LD      HL,RETURN
       PUSH    HL

       LD      C,E
       CP      1
       JP      Z,FCONIN        ; F.1 CONIN
       CP      2
       JP      Z,MCOUT         ; F.2 CONOUT
       CP      6
       JP      Z,FUNC_6        ; F.6 direct I/O
       CP      9
       JP      Z,MSGCPM        ; F.9 MSSG
       CP      10
       JP      Z,FRDBUF        ; F.10 RD_BUFF
       CP      11
       JP      NZ,WBOOT
NSTAT:
       PUSH    HL              ; F.11 STATUS
       LD      HL,COUNT
       LD      A,(HL)
       OR      A
       JP      Z,NSTA_2
       DEC     A
       LD      (HL),A
       XOR     A
;       JP      NSTA_3
       POP     HL
       RET

NSTA_2: INC     HL
       LD      A,(HL)
       OR      A
       JP      NZ,NSTA_1
       CALL    XF81B
       INC     A
       JP      Z,NSTA_3
       DEC     A
       LD      (KBDBUF),A
NSTA_1:
       LD      A,255
NSTA_3: POP     HL
       RET

; -------------------------------------------------

MSGCPM:
;       PUSH    HL              ; надо, если MCOUT в компьютере портит регистры
;       PUSH    BC
       EX      DE,HL
MSGLOO: LD      C,(HL)
       LD      A,'$'
       CP      C
;       JP      Z,POP_BH
       RET     Z
       CALL    MCOUT
       INC     HL
       JP      MSGLOO

POP_BH:
;       POP     BC
;       POP     HL
;       RET

; -------------------------------------------------

COUNT:  defb    255
KBDBUF: defb    0               ; должны идти подряд

; -------------------------------------------------

FUNC_6: INC     E
       JP      NZ,MCOUT
       CALL    MSTAT
       RET     Z
       JP      MCONIN

; -------------------------------------------------

FCONIN:
;       PUSH    HL              ; надо, если MCONIN в компьютере портит регистры
;       PUSH    BC
       LD      HL,COUNT
       LD      (HL),255
       INC     HL              ; KBDBUF
       LD      A,(HL)
       OR      A
       JP      NZ,CONI_2
       CALL    MCONIN
CONI_2: CP      3
       JP      Z,0             ; WBOOT
       LD      C,A
       PUSH    AF
       CALL    MCOUT
       POP     AF
;       POP     BC
;       POP     HL
       RET

; -------------------------------------------------

FRDBUF:
       EX      DE,HL
       LD      C,(HL)          ; BUFF SIZE
       LD      B,0
       INC     HL
RDBLOO:
       CALL    MCONIN
       CP      8
       JP      Z,ZABOJ
       PUSH    BC
       LD      C,A
       CALL    MCOUT
       POP     BC
       CP      13
       JP      Z,RDDONE
       CP      10
       JP      Z,RDDONE
       CP      3
       JP      Z,0             ; WBOOT ; CNTRL-C
       INC     HL
       LD      (HL),A
       INC     B
       LD      A,C
       CP      B               ; конец буфера ?
       JP      NZ,RDBLOO
       LD      B,C
RDDONE:
       INC     DE
       EX      DE,HL
       LD      (HL),B
       RET

; -------------------------------------------------

ZABOJ:  LD      A,B
       OR      A
       JP      Z,RDBLOO
       DEC     B
       DEC     HL
       PUSH    BC
       LD      C,8
       CALL    MCOUT
       LD      C,20H
       CALL    MCOUT
       LD      C,8
       CALL    MCOUT
       POP     BC
       JP      RDBLOO

; -------------------------------------------------

@ENDBDOS        EQU     $

BDSIZE  EQU     $-MYBDOS
@LENGTH EQU     $-MYBDOS

@FREE   EQU     7600H-$
       
       .dephase

if      low $ and 7FH
       rept    80H-(low $ and 7FH)
       defb    255
       ENDM
endif

       END

{********************************************************************}
{*                                                                  *}
{*  Pascal Link-80 version 3.2                                      *}
{*                                                                  *}
{*  Program to produce an INLINE-statement from an M80 REL-file     *}
{*                                                                  *}
{*  Programmed in Turbo Pascal by J.A.C.G. van der Valk             *}
{*  van Langendonckstraat 2 / 3076 SL Rotterdam                     *}
{*                                                                  *}
{*  Copyright 1986 by J.A.C.G. van der Valk                         *}
{*                                                                  *}
{*  Code is donated to public domain for non-commercial use only!   *}
{*  It is prohibited to sell this code (or any part of it) to 3-rd  *}
{*  parties; to use this code code for any commercial gain or to    *}
{*  distribute any program (in any form), developed by use of the   *}
{*  code in this file, on a commercial basis without prior written  *}
{*  permission of the author.                                       *}
{*                                                                  *}
{********************************************************************}

const
    PrtOn=^P; PrtOff=^N; Bell=^G; LF=^J; CR=^M; UP=^K;

type
    symboltype = string[8];
    fnamtype   = string[20];
    anystring  = string[80];
    hextype    = string[2];
    FileRecord = array [0..127] of byte;
    LoadItem   = record
                    typecode: byte;
                    contents: byte;
                 end;
var
    FileBuffer: FileRecord;

    count,              { counter for lay out of .INC file      }
    offset,             { offset for PC-relative code           }
    DataSize,           { size of Data - segment                }
    ProgSize,           { size of Code - segment                }
    ErrorCnt,           { number of fatal errors detected       }
    EntryCnt,           { number of entry sumbols defined       }
    Maxloc,             { maximum for LC on the heap            }
    LC,                 { Location Counter                      }
    Pbase,              { Base for LC in Code Segment           }
    Dbase,              { Base for LC in Data Segment           }
    Tsize,              { Total Size of Code + Data             }
    BitCnt,             { Number of bit* read from .REL-file    }
    ByteCnt,            { Current Byte-number in .REL-file      }
    ExtCnt,             { Counter for external symbol storage   }
    i:       integer;   { general purpose counter               }
                       
    STOP:   boolean;    { Flag for terminating REL-file reading }
    PrtOut: boolean;    { Flag for shadow-output on printer     }
    symbol: symboltype; { symbol in special link items          }
    s:      string[5];  { string for LC in inl-file             }
    fnam:   string[15]; { file - name of .REL file              }
    WrkRec: LoadItem;   { variable for storing temporary  code  }
    c:      char;       { dummy character                       }
                       
    relfil: file;       { .REL - file from M80 assembler        }
    inlfil,             { file for inline statement             }
    fentry,             { file for table of entry points        }
    f:   text;          { file for listing on LST: or CON:      }
    dsk: byte;          { current disk number                   }

label
    9999;               { label to EXIT the program             }

Procedure ClrEos; var i:byte;
begin
   for i:=14 to 24 do
   begin  gotoxy(1,i); clreol end;
end;

Procedure Error(Errno: integer);
begin
   write(Bell,'Error ',Errno:2,' ');

   case Errno of

   0: begin
        writeln('Unsupported Special Link item');
        writeln('please consult the PL80-manual!');
        end;

   1: begin
        writeln('Code size exeeds available workspace');
        writeln('Split source-code if possible!');
        write('Continue anyhow (Y/N)? :');
        read(kbd,c);if Upcase(c)='Y' then writeln('Y') else writeln('N');
        Stop:=(Upcase(c)<>'Y');
      end;

   2: begin
        writeln('COMMON blocks are not supported');
        writeln('please take notice of the PL80-manual!');
        end;

   3: begin
        writeln('Heap-overflow while linking');
        writeln('Check ORG-statements in source-code!');
        Stop:=true;
        end;

   4: begin
        writeln('Heap-overflow on Chaining External : ',symbol);
        writeln('Split source-code if possible!');
        stop:=true end;

   end; { of case Errno}

        ErrorCnt:=ErrorCnt+1;
   end;

procedure Directory(s:fnamtype);
const
    extend = 12;
    setDMA = 26;
    searchFirst = 17;
    searchNext = 18;
var
    FCB                                 : array[0..32] of char;
    directorynamen                      : array[0..3,0..31] of char;
    drivename                           : char;
    dot,index,numlines,directorycode    : integer;
begin
   for index:=1 to length(s) do s[index]:=Upcase(s[lndex]);
   drivename:=chr(Bdos(25)+65);
   if s[2]=':' then
   begin
     drivename:=Upcase(s[1]);
     s:=copy(s,3,255);
   end;
       
   if Length(s)=0 then s:='*.*';
   writeln('Drive : ',drivename);
   if (s[1]='*') and (s[2]='.') then s:='????????'+copy(s,2,255);
   dot:=Pos('.',s);
   if dot>0 then for index:=dot to 8 do Insert(' ',s,dot);
   if (s[9]='.') and (s[10]='*') then s:=copy(s,1,9)+'???';
   if dot>0 then delete(s,9,1); for index:=Length(s) to 10 do s:=s+' ';
   FCB[0]:=chr(ord(drivename)-64);
   for index:=1 to 11 do FCB[index]:=s[index];
   for index:=12 to 32 do FCB[index]:=chr(0);

   bdos(setDMA,addr(directorynamen));
   directorycode:=bdos(searchfirst,addr(FCB));
   numlines:=0;
   if directorycode=255 then writeln('No files *.REL found');

    while directorycode<255 do
    begin
      if directorynamen[directorycode,extend]=chr(0)
      then
      begin
        if numlines>0 then write(' 1 ');
        write(copy(directorynamen[directorycode],2,8), ^.^);
        for index:=9 to 11 do
        write(chr(127 and ord(directorynamen[directorycode,index])));
        numlines:=(numlines+1)mod 5;
        if numlines=0 then writeln;
      end;
      directorycode:=bdos(searchnext);
   end;
   
   if numlines>0 then writeln;
end;

procedure MemWrite(nn:integer;var WrkRec:LoadItem);
    begin
       if nn<=Maxloc then
       move(WrkRec,mem[nn*sizeof(LoadItem)+HeapPtr],sizeof(LoadItem))
       else Error(3);
    end;

procedure MemRead(nn:integer;var WrkRec:LoadItem);
begin
    if nn<= Maxloc then
    move(mem[nn*sizeof(LoadItem)+HeapPtr],WrkRec,sizeof(LoadItem));
end;

Procedure StoreExtrnl(symbol:symboltype);
var
    WrkRec: LoadItem;
    i: byte;
begin
    if (Tsize+(ExtCnt+1)*9) }= Maxloc then Error(4)
    else
    begin
       for i:=0 to 8 do
       begin
         WrkRec.typecode:=3;
         WrkRec.contents:=ord(symbol[i]);
         MemWrite((Tsize+ExtCnt*9+i),WrkRec);
       end;
       ExtCnt:=ExtCnt+1;
    end;
end;

Procedure GetExtrnl(nn:integer;var symbol:symboltype);
var
    WrkRec: LoadItem;
    i: byte;
begin
    for i:=0 to 8 do
    begin
      MemRead((Tsize+ExtCnt*9+i),WrkRec); symbol[i]:=chr(WrkRec.contents);
    end;
end;

Function Hex(b:byte): hextype;
const
    HexTabl: string[16]='0123456789ABCDEF';
begin
   Hex:=HexTabl[(b shr 4)+1] + HexTabl[(b and $OF)+1];
end;
   
procedure center(str:anystring);
var
   i: integer;
begin
   for i:=1 to (80-length(str)) div 2 do write(' ');
   writeln(str);
end;

procedure conout(c:char);       '
const
    Prt: boolean=false;
begin
    if c=PrtOn then Prt:=true
    else if c=PrtOff then Prt:=false
    else
    begin
       Bios(3,ord(c));
       if Prt and (c<>Bell) then Bios(4,ord(c));
    end;
end;

procedure init;
var
     i: integer;
     dummy: real;
begin
    BitCnt:=-1; ByteCnt:=-1; STOP:=False; ErrorCnti=0;
    EntryCnt:=0; ExtCnt:=0; count:=0;
    LC:=0; Pbase:=0; ProgSize:=-1;
    dummy:=memavail;
    if dummy < 0 then dummy:=dummy+65536.0;
    Maxloc:=Trunc(dummy/sizeof(LoadItem))-1;
    conoutptr:=addr(conout);

    { Hello messages }
    ClrScr; writeln;
    center(' P A S C A L   L I N K  -  80 ');
    writeln;
    center('version: 3.2 / dd:17-07-1986');
    center('Programmed by  J.A.C.G. van der Valk');
    center('van Langendonckstraat 2 / 3076  SL  Rotterdam');
    center('Phone : 010 - 4320625');
    writeln;
    center('(c) 1986 by FalconSoft (tm)');
    writeln(LF);
    writeln('Free work space : ',Maxloc:5,' bytes');
    writeln;
    Directory('*.rel');

    dsk:=Bdos(25);            { get current disk }
    { Input requests }
    writeln('Hit <RETURN> to toggle default drive (A/B)',LF);
   
    write('Name of .REL - file to convert 7 : '); readln(fnam);
    for i:=1 to length(fnam) do fnam[i]:=Upcase(fnam[i]);
   
    i:=Pos('.',fnam);
    if i>0 then delete(fnam,i,255);
   
    if (fnam[2]=':') and (Length(fnam)=2) then
    begin
      dsk:=ord(fnam[1])-65;
      if dsk in [0,1] then Bdos(14,dsk);
      fnam:='  ';
    end;

    {$I-}
    assign(relfil,fnam+'.REL'); reset(relfil);
    while IOresult<>0 do
       begin
         ClrEol;
         if (fnam[2]=':') and (Length(fnam)>0) then
            begin
              dsk:=ord(fnam[1])-65;
              if dsk in[0,1] then Bdos(14,d*k);
              fnam:=copy(fnam,3,255);
            end
         else
         if length(Fnam)=0 then
           begin
             if dsk=1 then dsk:=0 else dsk:=1;
             
             Bdos(14,dsk);
             ClrEos; gotoxy(1,14);
             Directory('*.rel');
             writeln('Hit <RETURN> to toggle default drive (A/B)',LF);
             write('Name of .REL - file to convert ? : ');
             readln(fnam);
             ClrEol;
           end
        else
          begin
            ClrEos; gotoxy(1,14); Directory('*.rel');
            writeln('Hit <RETURN> to toggle default drive (A/B)',LF,LF);
            write(Bell,'File ',chr(dsk+65),':',fnam,'.REL not found',CR,UP);
            write('Name of .REL - file to convert 7 : ');
            ClrEol; readln(fnam);
        end;

        for i:=1 to length(fnam) do fnam[i]:*Upcase(fnam[i]);
        i:=Po$('.',fnam);
        if i>0 then delete(fnam,i,255);
        if (fnam[2]=':') and (Length(fnam)=2) then
        begin
          dsk:=ord(fnam[1])-65;
          if dsk in[0,1] then Bdos(14,dsk);
          fnam:='  ';
        end;
        assign(relfil,fnam+'.REL'); reset(relfil);
     end;
     
     {$I+}
     if fnam[2]=':' then fnam:=copy(fnam,3,255);
     { delete drive specification if still present }
     
     ClrEol;
     Bdos(13);     { reset disk system }
     
     Bdos(14,dsk);  { restore previous default drive }
     write('Send output to LST: device also (Y/N)? :');
     read(kbd,c);
     if Upcase(c)='Y' then writeln('Y',PrtOn) else writeln('N');
     writeln;
   end;
   
function getbit: byte;
var
   mask: byte;
begin
   BitCnt:=(BitCnt+1) mod 8;
   if BitCnt=0
   then ByteCnt:=(ByteCnt+1) mod 128;
   if ByteCnt+BitCnt=0 then begin BlockRead(RelFil,FileBuffer,1); end;
   Mask:=128 shr BitCnt;
   if (FileBuffer[Bytecnt] and mask)=0 then Getbit:=0
               else Getbit:=1;
end;

function RelCode:byte;
begin
    relcode:=(GetBit shl 1) + GetBit;
end;

function CtrlField:integer;
begin
   CtrlField:=(GetBit shl 3) + (GetBit shl 2) + (GetBit shl 1) + GetBit;
end;

function GetByte:byte;
var
    i,B: byte;
begin
    B:=0;
    for i:=7 downto 0
    do B:=B+(GetBit shl i);
    Getbyte:*B; end;
    function GetInteger:integer; begin
    GetInteger:=GetByte + Swap(GetByte);
end;

Procedure GetAfield(var yy,nn:integer);
begin
    yy:=RelCode;
    nn:=GetInteger;
end;

Procedure GetBfield(var symbol:symboltype);
var
    i,zzz:byte;
begin
    zzz:=GetBit*4+GetBit*2+GetBit;
    if zzz=0 then zzz:=8;
    symbol:='';
    for i:=1 to zzz do symbol:=symbol+chr(GetByte); end;

Procedure LoadByte;
begin
    WrkRec.typecode:=0;
    WrkRec.contents:=GetByte;
    MemWrite(LC,WrkRec);
    LC:=LC+1;
end;

Procedure LoadProgRel;
var
    x:integer;
begin
    x:=GetInteger+Pbase;
    WrkRec.typecode:=1;
    WrkRec.contents:=lo(x);
    MemWrite(LC,WrkRec);
    WrkRec.contenta:=hi(x);
    MemWrite(LC+1,WrkRec);
    LC:=LC+2;
end;

Procedure LoadDataRel;
var
    x:integer;
begin
    x:=GetInteger+Dbase;
    WrkRec.typecode:=1;
    WrkRec,contents:=lo(x);
    MemWrite(LC,WrkRec);
    WrkRec.contents:=hi(x);
    MemWrite(LC+1,WrkRec);
    LC:=LC+2;
end;

Procedure LoadCommRel;
var
    x:integer;
begin
    x:=GetInteqer;
    LC:=LC+2;
end;

Procedure SpecialLink;
var
   x,yy,nn,nextloc,nextcode: integer;
begin
   Case CtrlField of
   0: begin
      GetBfield(symbol);
      writeln('Entry symbol   --> ',symbol);
   end;
   
   1: begin
        GetBfield(symbol);
        writeln('Select COMMON block      --> ',symbol);
        Error(2);
      end;
     
   2: begin
        GetBfield(symbol);
        writeln('Program Name   -> ',symbol);
      end;
   
   3: begin
        GetBfield(symbol);
        writeln('Request iibrary search   --> ',symbol);
        Error(0);
      end;
   
   4: begin
        GetBfield(symbol);
        writeln('Extension Link item      --> ',symbol);
        Error(0);stop:=true;
      end;
   
   5: begin
       GetAfield(yy,nn); GetBfield(symbol);
       writeln('Define COMMON size       -> ',symbol);
       writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
       Error(0);
   end;
   
   6: begin
        GetAfield(yy,nn); GetBfield(symbol);
        writeln('Chain External --> ',symbol);
       
        case yy of
          1: nn:=nn+Pbase;
          2: nn:=nn+Dbase;
          3: begin nn:=nn+Tsize; Error(2); end;
        end; { of case }
   
        MemRead(nn,WrkRec);
        writeln('loc = $',Hex(hi(nn)),Hex(lo(nn)));
        nextloc:=nn; nextcode:=yy;
        if nn+yy=0 then
        writeln('WARNING: Chain is empty, inspect source code!');
       
        while nextcode+nextloc>0 do
          begin
             nextloc:=WrkRec.contents;
             nextcode:=WrkRec.typecode;
             WrkRec.contents:=lo(ExtCnt); WrkRec.typecode:=2;
             MemWrite(nn,WrkRec);
             MemRead(nn+i,WrkRec);
             nextloc:=nextloc+swap(WrkRec.contents); if nextcode+nextloc>0 then
             writeln('loc = $',hex(hi(nextloc)),hex(lo(nextloc)));
             WrkRec.typecode:=2;
             WrkRec.contents:=hi(ExtCnt);
             MemWrite(nn+1,WrkRec); nn:=nextloc;
             MemRead(nn,WrkRec);
          end;
       
        StoreExtrnl(symbol);
      end;
   
   7: begin
        GetAfield(yy,nn);GetBfield(symbol);
        writeln('Define Entry point       --> ',symbol);
        writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
        case yy of
           1:nn:=nn+Pbase;
           2:nn:=nn+dbase;
           3:begin
               ErrorCnt:=ErrorCnt+1;
               writeln('Error: entry in common block');
             end;
        end; { of case }
       
        if EntryCnt=0 then
           begin
             assign(fentry,fnam+'.ENT'); rewrite(fentry);
             writeln(fentry,'Table of Entry symbols ');
             writeln(fentry,'corresponding to ',fnam,'.INL');
             writeln(fentry);
           end;
       
        write(fentry,symbol);
       
        for x:=1 to 8-length(symbol) do write(fentry,' ');
        writeln(fentry,' = $',hex(hi(nn)),Hex(lo(nn)));
        EntryCnt:= EntryCnt+1;
      end;
       
   8: begin
        getAfield(yy,nn);
        write('External - offset        -> ');
        writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
        Error(0);
      end;
     
   9: begin
        getAfield(yy,nn);
        write('External + offset        --> ');
        writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
        Error(0);
      end;
   
   1O: begin
         getAfield(yy,nn);
         write('Define Size of DATA area  --> ');
         writeln('$',Hex(hi(nn)),Hex(lo(nn)));
         DataSize:=nn;
       end;
     
   11: begin
         GetAfield(yy,nn);
         write('Set Loading LC to ');
         case yy of
            1: write('CSEG');
            2: write('DSEG');
            3: write('COMM');
            end; { of case }
         
         writeln('    --> $',Hex(hi(nn)),Hex(lo(nn)));
         case yy of
            1: LC:=Pbase+nn;
            2: LC:=Dbase+nn;
            3: LC:=Tsize+nn;
         end; { of case }
       end;
   
   12: begin
         getAfield(yy,nn);
         write('Chain Address    --> ');
         writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
         nextloc:=nn; nextcode:=yy;
         while nextcode+nextloc>0 do
           begin
             nextloc:=WrkRec.contents; WrkRec.contents:=LC;
             nextcode:=WrkRec.typecode;
             MemWrite(nn,WrkRec); MemRead(nn+1,WrkRec);
             nextloc:=nextloc+swap(WrkRec.contents);
             writeln('loc = $',hex(hi(nextloc)),hex(lo(nextloc)));
             WrkRec.contents:=LC;
             MemWrite(nn+1,WrkRec);
             nn:=nextloc; MemRead(nn,WrkRec);
           end;
       end;
             
   13: begin
         getAfield(yy,ProgSize);
         writeln('Define PROGRAM Size      --> $',
         Hex(hi(ProgSize)),Hex(lo(ProgSize)));
         Dbase:=ProgSize+3;            { create space for JP ENDofDSEG }
         Tsize:=ProgSize+DataSize;
         if datasize>0 then tsize:=tsize+3;
         if Tsize}Maxloc then Error(1)
         else
           begin
             WrkRec.typecode:=0; WrkRec.contents:=0;
             for x:=0 to Tsize-1 do MemWrite(x,WrkRec);
             { Block-Data space (DS) initialized to null-bytes }
         end;
      end;
     
   14: begin
         getAfield(yy,nn); writeln('END of PROGRAM');
         Bitcnt:=-1;   { forces to next byte boundary }
       end;
           
   15: begin
         Stop:=true;
         writeln('END of FILE');
       end;
   
     end; { of case }

end;

begin                           { main program }
    init;
    While not STOP do
    begin
       if Getbit=0 then loadbyte
       else
       begin
         case relcode of
           0:SpecialLink;
           1:LoadProgRel;
           2:LoadDataRel;
           3:LoadCommRel;
         end; { of case }
       end;
    end;

    writeln(LF,LF,'diagnostics for linkage of file ',fnam,'.REL',LF);
    writeln('Free workspace available : ',Maxloc:5,' bytes');
    if Tsize<Maxloc then
    writeln('Total workspace used     : ',(Tsize+ExtCnt*9):5,' bytes')
    else writeln('Code size exeeds work space');
    writeln('Total code size          : ',Tsize:5,' bytes');
    writeln('Code segment size        : ',Progsize:5,' bytes');
    writeln('Data segment size        : ',Datasize:5,' bytes');
    if Tsize < Maxloc then
    begin
       if ExtCnt > 0 then
       writeln('number of externals      : ',ExtCnt:5)
       else writeln('no externals used');
       if EntryCnt > 0 then
       writeln('number of entry-points   : ',EntryCnt:5)
       else writeln('no entry points defined');
    end;

    LC:=0;
    if EntryCnt>0 then close(fentry);

    if ErrorCnt>0 then
    begin
       writeln(f);
       writeln(ErrorCnt:3,' fatal error(s) detected',LF);
       write('make inline-file anyway (Y/N)? '); read(kbd,c);
       if Upcase(c)<>'Y' then
          begin
            writeln('N');
            if EntryCnt>0 then erase(fentry);
            goto 9999;
          end
       else writeln('Y');
    end
     
    else writeln('no fatal errors detected');
    writeln(PrtOff);
    writeln('creating ',fnam,'.INL...');
    write('Bytes written : ',#27,'.0');
    assign(inlfil,fnam+'.INL');
    rewrite(inlfil);
    write(inlfil,' INLINE({00000} ');
   
    while LC < Tsize do
    begin
      MemRead(LC,WrkRec);
     
      case WrkRec.typecode of
        0: begin
             write(inlfil,'$',Hex(WrkRec.contents));
             LC:=LC+1;
           end;
       
        1: begin
             offset:=WrkRec.contents;
             MemRead(LC+1,WrkRec);
             offset:=offset+swap(WrkRec.contents)-LC;
             if offset>0 then write(inlfil,'*+',offset)
                         else write(inlfil,'*',offset);
             LC:=LC+2;
           end;
       
        2: begin
             ExtCnt:=WrkRec.contents; MemRead(LC+1,WrkRec);
             ExtCnt:=ExtCnt+swap(WrkRec.contents);
             GetExtrnl(ExtCnt,symbol); write(inlfil,symbol);
             LC:=LC+2;
           end;
        else
           begin
           write('Internal error, program aborted'); close(inlfil);erase(inlfil);
           goto 9999;
        end;
       
      end; { of case }
   
       if LC < Tsize then write(inlfil,'/')
          else writeln(inlfil,');');
       if (LC=ProgSize) and (Datasize>0) then
         begin
            writeln(inlfil,'$C3/*+',Tsize-LC-1,'/');
            LC:=LC+3;
            writeln(inlfil,'        { start of DATA segment }');
            Str(LC,s);
             for i:=length(s) to 4 do s:='0'+s;
            write(inlfil,'        {',s,'} ');
            count:=0;
         end;
       count:=(count+1) mod 10;
       if count=0 then
         begin
           writeln(inlfil);
           Str(LC,s);for i:=length(s) to 4
           do s:='0'+s; write(inlfil,'        {',s,'} ');
         end;
       
       write(LC:5,^H,^H,^H,^H,^H);
       end;
       close(inlfil);

9999:
    writeln(#27,'.2');
    close(relfil);
end.