TP3/shell/Runtime.mod

IMPLEMENTATION MODULE Runtime ;

(* 8086 runtime library, assembled byte by byte.  Each little emitter below is
   one 8086 instruction; the ModR/M byte is spelled out in the comment so the
   encoding can be checked by hand against an 8086 table.  This is the same
   approach the compiler itself takes in Compiler.mod (Ebyte/Eword/EmCall),
   so the library needs no external assembler and no binary artifact in the
   tree - RT_Build assembles it every run, which is why the entry offsets are
   known exactly and are not guesses.

   Memory model: a .COM image, so CS = DS = ES = SS = 0 and the whole thing
   lives in one 64K segment.  The runtime occupies offsets 0..RT_Size-1, the
   generated program follows, and the program's globals follow at
   RT_Size + 1000H.  Runtime data therefore sits at fixed low offsets.

   Calling conventions, matching Compiler.IoCall:
     WrInt/WrChar/WrBool/WrReal  one 16-bit value on the stack (caller pops)
     RdInt/RdChar/RdBool         one address on the stack (caller pops)
     WrLn/RdLn/StackChk          nothing
     InitMem                     AX = offset of the program header word block
     ProgEnd/Halt                nothing; exits with code 0
   All entries preserve BP and SP, and every register except the documented
   result, so they can be called from the middle of an expression. *)

FROM SYSTEM IMPORT BYTE ;

CONST
   MaxRt  = 4096 ;
   MaxLbl = 64 ;
   MaxFix = 400 ;
   MaxNm  = 15 ;

   (* offsets inside the runtime's own data block *)
   D_NUM   = 0 ;      (* 8 bytes, decimal conversion scratch *)
   D_TRUE  = 8 ;      (* "TRUE$" *)
   D_FALSE = 14 ;     (* "FALSE$" *)
   D_CRLF  = 21 ;     (* CR LF '$' *)
   D_REAL  = 24 ;     (* "?REAL?" - reals are not formatted yet *)
   D_END   = 31 ;

TYPE
   LblRec = RECORD
      nm  : ARRAY [0..MaxNm] OF CHAR ;
      off : CARDINAL ;
   END ;

   FixRec = RECORD
      kind  : CARDINAL ;     (* 0 = rel8, 1 = rel16, 2 = data address *)
      place : CARDINAL ;     (* offset of the displacement/address field *)
      nm    : ARRAY [0..MaxNm] OF CHAR ;
      val   : CARDINAL ;
   END ;

VAR
   rt     : ARRAY [0..MaxRt - 1] OF BYTE ;
   rpos   : CARDINAL ;
   lbl    : ARRAY [0..MaxLbl - 1] OF LblRec ;
   ltop   : CARDINAL ;
   fix    : ARRAY [0..MaxFix - 1] OF FixRec ;
   nfix   : CARDINAL ;
   dataAt : CARDINAL ;
   built  : BOOLEAN ;
   entNm  : ARRAY [0..13] OF ARRAY [0..MaxNm] OF CHAR ;

(* ---------------------------------------------------------------- *)
(*  name helpers                                                     *)
(* ---------------------------------------------------------------- *)

PROCEDURE StrEq (a, b : ARRAY OF CHAR ) : BOOLEAN ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE (i <= HIGH (a)) AND (i <= HIGH (b)) DO
      IF a [i] # b [i] THEN
         RETURN FALSE
      END ;
      INC (i)
   END ;
   RETURN TRUE
END StrEq ;

PROCEDURE SetStr (VAR dst : ARRAY OF CHAR ; src : ARRAY OF CHAR ) ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE (i <= HIGH (dst)) AND (i <= HIGH (src)) DO
      dst [i] := src [i] ;
      INC (i)
   END ;
   IF i <= HIGH (dst) THEN
      dst [i] := 0C
   END
END SetStr ;

(* ---------------------------------------------------------------- *)
(*  primitive emitters                                               *)
(* ---------------------------------------------------------------- *)

PROCEDURE B (b : CARDINAL ) ;
(* emit exactly ONE byte.  A two-byte opcode must be written as two B calls -
   B masks to 100H, so B (8BE4H) would silently emit just E4. *)
BEGIN
   IF rpos >= MaxRt THEN
      RETURN                            (* blob is oversized: drop the byte *)
   END ;
   rt [rpos] := VAL (BYTE, b MOD 100H) ;
   INC (rpos)
END B ;

PROCEDURE W (w : CARDINAL ) ;
BEGIN
   B (w MOD 100H) ;
   B ((w DIV 100H) MOD 100H)           (* little endian *)
END W ;

PROCEDURE M (nm : ARRAY OF CHAR ) ;
(* mark: nm is the current offset *)
BEGIN
   IF ltop < MaxLbl THEN
      SetStr (lbl [ltop].nm, nm) ;
      lbl [ltop].off := rpos ;
      INC (ltop)
   END
END M ;

PROCEDURE AddFix (kind, place : CARDINAL ; nm : ARRAY OF CHAR ; val : CARDINAL ) ;
BEGIN
   IF nfix < MaxFix THEN
      fix [nfix].kind := kind ;
      fix [nfix].place := place ;
      fix [nfix].val := val ;
      SetStr (fix [nfix].nm, nm) ;
      INC (nfix)
   END
END AddFix ;

PROCEDURE LblOff (nm : ARRAY OF CHAR ) : CARDINAL ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE i < ltop DO
      IF StrEq (lbl [i].nm, nm) THEN
         RETURN lbl [i].off
      END ;
      INC (i)
   END ;
   RETURN 0
END LblOff ;

PROCEDURE J8 (nm : ARRAY OF CHAR ) ;
BEGIN
   B (0EBH) ;                          (* JMP rel8 *)
   AddFix (0, rpos, nm, 0) ;
   B (0)
END J8 ;

PROCEDURE C8 (nm : ARRAY OF CHAR ) ;
BEGIN
   B (0E8H) ;                          (* CALL rel16 *)
   AddFix (1, rpos, nm, 0) ;
   W (0)
END C8 ;

PROCEDURE Jcc (code : CARDINAL ; nm : ARRAY OF CHAR ) ;
BEGIN
   B (code) ;                          (* Jcc rel8 *)
   AddFix (0, rpos, nm, 0) ;
   B (0)
END Jcc ;

PROCEDURE Dd (delta : CARDINAL ) ;
(* emit a 16-bit address into the runtime's data block; the value is only
   known once the data block has been placed, so it is a fixup *)
BEGIN
   AddFix (2, rpos, "", delta) ;
   W (0)
END Dd ;

(* --- 8-bit / 16-bit register and memory forms, one instruction each --- *)

(*  THE 16-BIT ModR/M EFFECTIVE-ADDRESS TABLE, MEASURED NOT REMEMBERED.
    Every address form below was confirmed by EXECUTING it on a real 8086
    (qemu-system-i386) with a probe that stores a marker through the candidate
    encoding and then reports which physical address received it; see
    tests/probe/modrm19.s.  The mod=11 column is not an address at all -- it
    names a register -- so it is confirmed instead by asking GNU as to
    ENCODE the eight register moves and checking FCML's decode of the result
    (tests/probe/modrm11.py, which also carries the hand-checking anchors).

    Do not "fix" any of these from memory.  The version that comes to mind is
    wrong in exactly the cells called out below, and every one of those
    mistakes shipped as code that decoded cleanly:

       r/m   mod=00        mod=01          mod=10          mod=11
       000   [BX+SI]       [BX+SI]+disp    [BX+SI]+disp    AX
       001   [BX+DI]       [BX+DI]+disp    [BX+DI]+disp    CX
       010   [BP+SI]       [BP+SI]+disp    [BP+SI]+disp    DX
       011   [BP+DI]       [BP+DI]+disp    [BP+DI]+disp    BX
       100   [SI]          [SI]+disp       [SI]+disp       SP
       101   [DI]          [DI]+disp       [DI]+disp       BP
       110   disp16        [BP]+disp       [BP]+disp       SI
       111   [BX]          [BX]+disp       [BX]+disp       DI

    "disp" is disp8 for mod=01 and disp16 for mod=10.

    In mod=11 BOTH fields name a register and BOTH use the same list,
    AX CX DX BX SP BP SI DI -- the reg field and the r/m field do not
    differ, and there is no second BX at code 7.  The memorable version
    drops AX off the front and invents a duplicate BX at the end, which
    shifts every code down by one; that is precisely how MovSiBx and
    CmpSiBx came to be written "89 DC" and "39 DC", which are MOV SP,BX
    and CMP SP,BX.  Note what the shifted table gets right by luck: SP is
    at 100 either way, so the mistake is invisible until you check a
    register below it.  rm=100 is SP, and SI is rm=110, not rm=100.

    And reg/rm swap direction with the opcode, which is the other trap:
       88 /r  MOV r/m8,r8    89 /r  MOV r/m16,r16    reg is the SOURCE
       8A /r  MOV r8,r/m8    8B /r  MOV r16,r/m16    reg is the TARGET
    So ModRM C6 names "DH and AL" either way, but 88 C6 is DH:=AL while
    8A C6 is AL:=DH.  The 8-bit register list is also its own, and it is not
    the word list:
       000 001 010 011 100 101 110 111  =  AL CL DL BL AH CH DH BH
    The two lists agree at every code except 100, where the byte form is AH
    and the word form is SP.  Reading the same ModRM byte as the other size
    silently swaps AH for SP, and 88 C2 is DL:=AL while 88 17 is [BX]<-DL.

    The word-form list, and the four anchors nobody writes by hand:
       83 C4 08   ADD SP, 8    rm=100 -> SP
       83 C6 02   ADD SI, 2    rm=110 -> SI
       8B EC      MOV BP, SP   reg=101 rm=100
       8B E5      MOV SP, BP   reg=100 rm=101
    Asking "which register is rm=100?" and answering SI is the single most
    common error in this file's history.

    Concrete recipes for opcode 8r / 9r (r/m = rm, 16-bit form):
       mod=00 rm=110 -> 06  <disp16>     the only direct form
       mod=00 rm=111 -> 07  = [BX]       2 bytes
       mod=00 rm=101 -> 05  = [DI]       2 bytes
       mod=01 rm=110 -> 46  disp8        = [BP]+disp8
       mod=01 rm=111 -> 47  disp8        = [BX]+disp8
       mod=01 rm=101 -> 45  disp8        = [DI]+disp8
    There is no [SP] form in 16-bit mode: SIB bytes are 386-only.  Anything
    wanting the top of the stack has to go through BP. *)


PROCEDURE PushBp ; BEGIN B (55H) END PushBp ;
PROCEDURE PopBp  ; BEGIN B (5DH) END PopBp ;
PROCEDURE MovBpSp ; BEGIN B (8BH) ; B (0ECH) END MovBpSp ;  (* 8B EC: MOV BP,SP *)
PROCEDURE MovSpBp ; BEGIN B (89H) ; B (0ECH) END MovSpBp ;  (* 89 EC: MOV SP,BP *)
PROCEDURE LeaveR ; BEGIN B (0C9H) END LeaveR ;
PROCEDURE RetR   ; BEGIN B (0C3H) END RetR ;
PROCEDURE Int21  ; BEGIN B (0CDH) ; B (21H) END Int21 ;
PROCEDURE PushDs ; BEGIN B (1EH) END PushDs ;
PROCEDURE PopEs  ; BEGIN B (7H) END PopEs ;

PROCEDURE PushAx ; BEGIN B (50H) END PushAx ;
PROCEDURE PopAx  ; BEGIN B (58H) END PopAx ;
PROCEDURE PushBx ; BEGIN B (53H) END PushBx ;
PROCEDURE PopBx  ; BEGIN B (5BH) END PopBx ;
PROCEDURE PushCx ; BEGIN B (51H) END PushCx ;
PROCEDURE PopCx  ; BEGIN B (59H) END PopCx ;
PROCEDURE PushDx ; BEGIN B (52H) END PushDx ;
PROCEDURE PopDx  ; BEGIN B (5AH) END PopDx ;
PROCEDURE PushDi ; BEGIN B (57H) END PushDi ;
PROCEDURE PopDi  ; BEGIN B (5FH) END PopDi ;

PROCEDURE XorAxAx ; BEGIN B (31H) ; B (0C0H) END XorAxAx ;  (* 11 000 000 *)
PROCEDURE XorCxCx ; BEGIN B (31H) ; B (0C9H) END XorCxCx ;  (* 11 001 001 *)
PROCEDURE XorDxDx ; BEGIN B (31H) ; B (0D2H) END XorDxDx ;  (* 11 010 010 *)
PROCEDURE XorDiDi ; BEGIN B (31H) ; B (0FFH) END XorDiDi ;  (* 11 111 111 *)

PROCEDURE IncCx ; BEGIN B (41H) END IncCx ;
PROCEDURE IncSi ; BEGIN B (46H) END IncSi ;
PROCEDURE DecSi ; BEGIN B (4EH) END DecSi ;
PROCEDURE AddDi2 ; BEGIN B (83H) ; B (0C7H) ; B (2) END AddDi2 ;  (* 11 000 111 *)

PROCEDURE CmpAl (v : CARDINAL ) ; BEGIN B (3CH) ; B (v) END CmpAl ;
PROCEDURE CmpAx0 ; BEGIN B (83H) ; B (0F8H) ; B (0) END CmpAx0 ;
PROCEDURE CmpCx0 ; BEGIN B (83H) ; B (0F9H) ; B (0) END CmpCx0 ;
PROCEDURE CmpArgW0 ;
(* CMP WORD PTR [BP+2],0 - the one 16-bit argument of a BOOLEAN entry.
   [SP] cannot be encoded in 16-bit mode, so borrow BP for the three
   instructions and hand SP back untouched before the caller pops the
   argument.  (Was 83 7C 24 00 00, which decodes as CMP WORD [SI+24h],0.)
   The imm8 of the 83 form is sign-extended to 16 bits, so 0 really is a
   16-bit zero. *)
BEGIN
   B (8BH) ; B (0ECH) ;                 (* MOV BP,SP          *)
   B (83H) ; B (7EH) ; B (2) ; B (0) ;  (* CMP WORD [BP+2],0  *)
   B (89H) ; B (0ECH)                   (* MOV SP,BP          *)
END CmpArgW0 ;

PROCEDURE CmpSiBx ; BEGIN B (39H) ; B (0DEH) END CmpSiBx ;  (* 39 DE: CMP SI,BX *)
PROCEDURE CmpCxDx ; BEGIN B (39H) ; B (0D1H) END CmpCxDx ;  (* 11 010 001 *)
PROCEDURE CmpDiCx ; BEGIN B (39H) ; B (0CFH) END CmpDiCx ;  (* 11 001 111 *)

PROCEDURE AddDl (v : CARDINAL ) ; BEGIN B (80H) ; B (0C2H) ; B (v) END AddDl ;
PROCEDURE SubAl (v : CARDINAL ) ; BEGIN B (2CH) ; B (v) END SubAl ;
PROCEDURE NegAx ; BEGIN B (0F7H) ; B (0D8H) END NegAx ;
PROCEDURE NegDi ; BEGIN B (0F7H) ; B (0DFH) END NegDi ;
PROCEDURE DivCx ; BEGIN B (0F7H) ; B (0F1H) END DivCx ;   (* 11 110 001 *)
PROCEDURE MulBx ; BEGIN B (0F7H) ; B (0E3H) END MulBx ;   (* 11 100 011 *)

PROCEDURE MovAh (v : CARDINAL ) ; BEGIN B (0B4H) ; B (v) END MovAh ;
PROCEDURE MovDl (v : CARDINAL ) ; BEGIN B (0B2H) ; B (v) END MovDl ;
PROCEDURE MovBxV (v : CARDINAL ) ; BEGIN B (0BBH) ; W (v) END MovBxV ;
PROCEDURE MovCxV (v : CARDINAL ) ; BEGIN B (0B9H) ; W (v) END MovCxV ;
PROCEDURE MovDxV (v : CARDINAL ) ; BEGIN B (0BAH) ; W (v) END MovDxV ;
PROCEDURE MovBxD (delta : CARDINAL ) ; BEGIN B (0BBH) ; Dd (delta) END MovBxD ;
PROCEDURE MovDxD (delta : CARDINAL ) ; BEGIN B (0BAH) ; Dd (delta) END MovDxD ;

PROCEDURE MovSiAx  ; BEGIN B (8BH) ; B (0F0H) END MovSiAx ;  (* 8B F0: MOV SI,AX *)
PROCEDURE MovAxDi  ; BEGIN B (8BH) ; B (0C7H) END MovAxDi ;   (* 11 000 111 *)
PROCEDURE MovCxSi6 ; BEGIN B (8BH) ; B (4CH) ; B (6) END MovCxSi6 ;
PROCEDURE MovDxSi2 ; BEGIN B (8BH) ; B (54H) ; B (2) END MovDxSi2 ;
(* The program header is a block of words laid out by the compiler:
      +0  hdrFlag   1 = image is valid
      +2  hdrCS     end of the generated code, in bytes
      +4  hdrDS     base of the data area     <- initmem wants these two
      +6  hdrHeap   end of the data area      <-
      +8  hdrMax    max open files
   initmem must read the words the COMPILER WRITES, and those are +4 (hdrDS,
   the data base) and +6 (hdrHeap, the data end).  It used to read +8, which
   is hdrMax -- and the compiler patches that to 0 -- so CX came out as 0,
   "cmp cx,dx / jbe im_done" fired immediately, and initmem silently zeroed
   nothing at all.  A 3-byte instruction, so no entry offset moved either
   way; only the header offset in the byte changed.  Nothing caught it
   because the loop was well formed - it just did nothing.  The cross-check
   that would have: tests/run_com_tests.sh now asserts the runtime's SI-relative
   reads against the same header offsets it verifies the words at. *)
PROCEDURE MovDxSi4 ; BEGIN B (8BH) ; B (54H) ; B (4) END MovDxSi4 ;
PROCEDURE MovAxBp4 ; BEGIN B (8BH) ; B (46H) ; B (4) END MovAxBp4 ;  (* AX:=[BP+4] *)
PROCEDURE MovBxBp4 ; BEGIN B (8BH) ; B (5EH) ; B (4) END MovBxBp4 ;  (* BX:=[BP+4] *)
PROCEDURE MovAlDh  ; BEGIN B (8AH) ; B (0C6H) END MovAlDh ;  (* 8A C6: AL:=DH *)
PROCEDURE MovDlSi  ; BEGIN B (8AH) ; B (14H) END MovDlSi ;
PROCEDURE MovDlArg ; BEGIN B (8AH) ; B (56H) ; B (2) END MovDlArg ;  (* DL:=[BP+2] *)

PROCEDURE StDiAx   ; BEGIN B (89H) ; B (5H) END StDiAx ;    (* 89 05: [DI]:=AX *)
PROCEDURE StDiBx   ; BEGIN B (89H) ; B (1DH) END StDiBx ;   (* 89 1D: [DI]:=BX *)
PROCEDURE StBxCx   ; BEGIN B (89H) ; B (0FH) END StBxCx ;   (* 89 0F: [BX]:=CX *)
PROCEDURE StSiDl   ; BEGIN B (88H) ; B (14H) END StSiDl ;   (* 88 14: [SI]:=DL *)
PROCEDURE StBxDl   ; BEGIN B (88H) ; B (17H) END StBxDl ;   (* 88 17: [BX]:=DL *)
PROCEDURE MovDhAl  ; BEGIN B (88H) ; B (0C6H) END MovDhAl ;
PROCEDURE MovDlAl  ; BEGIN B (88H) ; B (0C2H) END MovDlAl ;
PROCEDURE MovSiBx  ; BEGIN B (89H) ; B (0DEH) END MovSiBx ;  (* 89 DE: MOV SI,BX *)
PROCEDURE MovDiDx  ; BEGIN B (89H) ; B (0D7H) END MovDiDx ;
PROCEDURE MovDiAx  ; BEGIN B (89H) ; B (0C7H) END MovDiAx ;
PROCEDURE AddDiAx  ; BEGIN B (1H) ; B (0C7H) END AddDiAx ;
PROCEDURE IncBx    ; BEGIN B (43H) END IncBx ;
PROCEDURE MovAlBx  ; BEGIN B (8AH) ; B (07H) END MovAlBx ;  (* 8A 07: AL:=[BX] *)
PROCEDURE MovClBx  ; BEGIN B (8AH) ; B (0FH) END MovClBx ;  (* 8A 0F: CL:=[BX] *)
PROCEDURE JmpBx    ; BEGIN B (0FFH) ; B (0E3H) END JmpBx ;  (* FF E3: JMP BX *)
(* JE 74  JNE 75  JB 72  JBE 76  JGE 7D *)
PROCEDURE Je8  (nm : ARRAY OF CHAR ) ; BEGIN Jcc (74H, nm) END Je8 ;
PROCEDURE Jne8 (nm : ARRAY OF CHAR ) ; BEGIN Jcc (75H, nm) END Jne8 ;
PROCEDURE Jb8  (nm : ARRAY OF CHAR ) ; BEGIN Jcc (72H, nm) END Jb8 ;
PROCEDURE Jbe8 (nm : ARRAY OF CHAR ) ; BEGIN Jcc (76H, nm) END Jbe8 ;
PROCEDURE Jge8 (nm : ARRAY OF CHAR ) ; BEGIN Jcc (7DH, nm) END Jge8 ;
PROCEDURE Ja8  (nm : ARRAY OF CHAR ) ; BEGIN Jcc (77H, nm) END Ja8 ;
PROCEDURE Jcxz8 (nm : ARRAY OF CHAR ) ; BEGIN Jcc (0E3H, nm) END Jcxz8 ;
PROCEDURE Loop8 (nm : ARRAY OF CHAR ) ; BEGIN Jcc (0E2H, nm) END Loop8 ;

(* ---------------------------------------------------------------- *)
(*  the entries                                                      *)
(* ---------------------------------------------------------------- *)

PROCEDURE EmitInitMem ;
(* AX = offset of the program header.  The header holds, at +4 the base of
   the program's data area and at +8 its end, so the globals can be zeroed -
   Pascal leaves them undefined, TP3's runtime clears them.  Also makes
   ES = DS so that any string instruction in the library would work. *)
BEGIN
   M ("initmem") ;
   MovSiAx ;               (* SI = AX = the header offset the caller passed *)
   MovDxSi4 ;              (* DX = [SI+4] = hdrDS  = data base *)
   MovCxSi6 ;              (* CX = [SI+6] = hdrHeap = data end   *)
   CmpCxDx ;
   Jbe8 ("im_done") ;
   MovDiDx ;               (* DI = data base *)
   M ("im_zero") ;
   XorAxAx ;               (* AX = 0: the value written into every global.
                             The caller passes the header offset in AX, so
                             without this the "zeroing" loop would write the
                             header offset into all of them. *)
   StDiAx ;
   AddDi2 ;
   CmpDiCx ;
   Jb8 ("im_zero") ;
   M ("im_done") ;
   PushDs ; PopEs ;
   RetR
END EmitInitMem ;

PROCEDURE EmitEnd ;
(* progend and halt are the same code: the compiler already zeroes AX for
   progend, and a HALT argument is discarded at compile time, so both leave
   with exit code 0. *)
BEGIN
   M ("progend") ;
   M ("halt") ;
   XorAxAx ;
   MovAh (4CH) ;
   Int21 ;
   RetR
END EmitEnd ;

PROCEDURE EmitStackChk ;
(* called from every procedure prologue.  Range and stack checking are not
   compiled in yet, so this must do nothing at all - in particular it must
   not touch a register, because the call site is in the middle of a
   partially evaluated expression. *)
BEGIN
   M ("stackchk") ;
   RetR
END EmitStackChk ;

PROCEDURE EmitGetCh ;
(* AL = next character, 1Ah at end of input.  INT 21h AH=08h reads without
   echoing, so a redirected stdin behaves the same as a keyboard. *)
BEGIN
   M ("getch") ;
   MovAh (8) ;
   Int21 ;
   RetR
END EmitGetCh ;

PROCEDURE EmitWrInt ;
(* one signed 16-bit value on the stack.  Div CX gives the remainder in DX,
   which is turned into a digit and stored backwards from the end of the
   scratch area, then printed forwards. *)
BEGIN
   M ("wrint") ;
   PushBp ; MovBpSp ;
   MovAxBp4 ;
   CmpAx0 ;
   Jge8 ("wi_pos") ;
   PushAx ;
   MovDl (ORD ("-")) ; MovAh (2) ; Int21 ;
   PopAx ;
   NegAx ;
   M ("wi_pos") ;
   MovCxV (10) ;
   MovBxD (D_NUM + 8) ;    (* BX = one past the last digit *)
   MovSiBx ;
   M ("wi_dig") ;
   XorDxDx ;
   DivCx ;
   AddDl (ORD ("0")) ;
   DecSi ;
   StSiDl ;
   CmpAx0 ;
   Jne8 ("wi_dig") ;
   M ("wi_out") ;
   CmpSiBx ;
   Je8 ("wi_done") ;
   MovDlSi ;
   MovAh (2) ; Int21 ;
   IncSi ;
   J8 ("wi_out") ;
   M ("wi_done") ;
   MovSpBp ; PopBp ; RetR
END EmitWrInt ;

PROCEDURE EmitWrChar ;
(* the low byte of the one 16-bit argument, which sits above the return
   address.  There is no [SP] addressing in 16-bit mode, so BP stands in for
   the stack pointer and is handed straight back before the RET. *)
BEGIN
   M ("wrchar") ;
   MovBpSp ;
   MovDlArg ;
   MovSpBp ;
   MovAh (2) ;
   Int21 ;
   RetR
END EmitWrChar ;

PROCEDURE EmitWrInl ;
(* Write an inline string literal - TP3 TPSRC4 "xwrtinl".

   The compiler emits

       CALL wrtinl      <length byte> <character>...

   so the return address on the stack points at the length byte that follows
   the call.  POP BX takes that address, CX picks up the length, and the
   routine finishes with JMP BX - returning to just past the last character.
   That is the whole trick: the literal is self-delimiting, so it needs no
   terminator, no length table and no space in the data segment, and it costs
   the code stream only the characters themselves (TPSRC10 "estring" emits
   exactly <length byte><chars> for the same reason).

   Consequently this entry has NO stack argument, unlike WrInt/WrChar: the
   return address has already been consumed by the POP. *)
BEGIN
   M ("wrtinl") ;
   PopBx ;                           (* BX := address of the length byte *)
   XorCxCx ;
   MovClBx ;                         (* CX := length *)
   IncBx ;                           (* BX -> first character *)
   MovAh (2) ;                       (* INT 21h/02h: put character, AL *)
   Jcxz8 ("wn_end") ;                (* empty string -> nothing to do *)
   M ("wn_loop") ;
   MovAlBx ;                         (* AL := next character *)
   Int21 ;                           (* (preserves every register but AL) *)
   IncBx ;
   Loop8 ("wn_loop") ;
   M ("wn_end") ;
   JmpBx                             (* resume past the string; no RET here,
                                       the return address is already gone *)
END EmitWrInl ;

PROCEDURE EmitWrBool ;
BEGIN
   M ("wrbool") ;
   CmpArgW0 ;
   Jne8 ("wb_t") ;
   MovDxD (D_FALSE) ;
   J8 ("wb_o") ;
   M ("wb_t") ;
   MovDxD (D_TRUE) ;
   M ("wb_o") ;
   MovAh (9) ;
   Int21 ;
   RetR
END EmitWrBool ;

PROCEDURE EmitWrLn ;
BEGIN
   M ("wrln") ;
   MovDxD (D_CRLF) ;
   MovAh (9) ;
   Int21 ;
   RetR
END EmitWrLn ;

PROCEDURE EmitWrReal ;
(* the 6-byte real is on the stack but is not formatted: the compiler does
   not yet load real operands into a form the runtime could read.  A visible
   marker beats printing the mantissa as an integer. *)
BEGIN
   M ("wrreal") ;
   MovDxD (D_REAL) ;
   MovAh (9) ;
   Int21 ;
   RetR
END EmitWrReal ;

PROCEDURE EmitRdInt ;
(* address on the stack; skips leading blanks, takes an optional sign, then
   digits, stopping *before* the delimiter so the following TU_RdLn throws
   away the rest of the line.  Sign in CX, value in DI. *)
BEGIN
   M ("rdint") ;
   PushBp ; MovBpSp ;
   PushAx ; PushBx ; PushCx ; PushDx ; PushDi ;
   M ("ri_skip") ;
   C8 ("getch") ;
   CmpAl (ORD (" ")) ; Je8 ("ri_skip") ;
   CmpAl (9) ;         Je8 ("ri_skip") ;
   CmpAl (13) ;        Je8 ("ri_skip") ;
   CmpAl (10) ;        Je8 ("ri_skip") ;
   XorCxCx ;
   CmpAl (ORD ("-")) ;
   Jne8 ("ri_nos") ;
   IncCx ;
   C8 ("getch") ;
   J8 ("ri_dig0") ;
   M ("ri_nos") ;
   CmpAl (ORD ("+")) ;
   Jne8 ("ri_dig0") ;
   C8 ("getch") ;
   M ("ri_dig0") ;
   XorDiDi ;
   M ("ri_dig") ;
   CmpAl (ORD ("0")) ;
   Jb8 ("ri_done") ;
   CmpAl (ORD ("9")) ;
   Ja8 ("ri_done") ;
   SubAl (ORD ("0")) ;
   MovDhAl ;                (* keep the digit across the multiply *)
   MovAxDi ;
   MovBxV (10) ;
   MulBx ;                  (* DX:AX := DI * 10 *)
   MovDiAx ;
   MovAh (0) ;
   MovAlDh ;
   AddDiAx ;
   C8 ("getch") ;
   J8 ("ri_dig") ;
   M ("ri_done") ;
   CmpCx0 ;
   Je8 ("ri_st") ;
   NegDi ;
   M ("ri_st") ;
   MovBxBp4 ;
   StDiBx ;
   PopDi ; PopDx ; PopCx ; PopBx ; PopAx ;
   MovSpBp ; PopBp ; RetR
END EmitRdInt ;

PROCEDURE EmitRdChar ;
BEGIN
   M ("rdchar") ;
   PushBp ; MovBpSp ;
   PushAx ; PushBx ;
   C8 ("getch") ;
   MovDlAl ;
   MovBxBp4 ;
   StBxDl ;
   PopBx ; PopAx ;
   MovSpBp ; PopBp ; RetR
END EmitRdChar ;

PROCEDURE EmitRdBool ;
(* one character, classified the way TP3 does: T/t/Y/y/1 true, anything else
   false. *)
BEGIN
   M ("rdbool") ;
   PushBp ; MovBpSp ;
   PushAx ; PushBx ; PushCx ;
   C8 ("getch") ;
   XorCxCx ;
   CmpAl (ORD ("T")) ; Je8 ("rb_t") ;
   CmpAl (ORD ("t")) ; Je8 ("rb_t") ;
   CmpAl (ORD ("Y")) ; Je8 ("rb_t") ;
   CmpAl (ORD ("y")) ; Je8 ("rb_t") ;
   CmpAl (ORD ("1")) ; Je8 ("rb_t") ;
   J8 ("rb_s") ;
   M ("rb_t") ;
   IncCx ;
   M ("rb_s") ;
   MovBxBp4 ;
   StBxCx ;
   PopCx ; PopBx ; PopAx ;
   MovSpBp ; PopBp ; RetR
END EmitRdBool ;

PROCEDURE EmitRdLn ;
(* discard the rest of the line, including the terminator *)
BEGIN
   M ("rdln") ;
   PushAx ;
   M ("rl_loop") ;
   C8 ("getch") ;
   CmpAl (13) ; Je8 ("rl_e") ;
   CmpAl (10) ; Je8 ("rl_e") ;
   CmpAl (26) ; Je8 ("rl_e") ;          (* ^Z: end of input *)
   J8 ("rl_loop") ;
   M ("rl_e") ;
   PopAx ;
   RetR
END EmitRdLn ;

PROCEDURE EmitData ;
BEGIN
   dataAt := rpos ;
   (* 8 bytes of scratch, never read before written *)
   B (0) ; B (0) ; B (0) ; B (0) ; B (0) ; B (0) ; B (0) ; B (0) ;
   B (ORD ("T")) ; B (ORD ("R")) ; B (ORD ("U")) ; B (ORD ("E")) ; B (ORD ("$")) ;
   B (ORD ("F")) ; B (ORD ("A")) ; B (ORD ("L")) ; B (ORD ("S")) ;
   B (ORD ("E")) ; B (ORD ("$")) ;
   B (13) ; B (10) ; B (ORD ("$")) ;
   B (ORD ("?")) ; B (ORD ("R")) ; B (ORD ("E")) ; B (ORD ("A")) ;
   B (ORD ("L")) ; B (ORD ("?")) ;
   WHILE rpos < dataAt + D_END DO
      B (0)
   END
END EmitData ;

PROCEDURE FixUp ;
VAR i, t, rel : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE i < nfix DO
      IF fix [i].kind = 2 THEN
         t := (dataAt + fix [i].val) MOD 10000H ;
         rt [fix [i].place] := VAL (BYTE, t MOD 100H) ;
         rt [fix [i].place + 1] := VAL (BYTE, (t DIV 100H) MOD 100H)
      ELSE
         t := LblOff (fix [i].nm) ;
         IF fix [i].kind = 0 THEN
            (* rel8 is measured from the end of the instruction, i.e. one
               byte past the displacement field *)
            rel := (t + 100H - (fix [i].place + 1)) MOD 100H ;
            rt [fix [i].place] := VAL (BYTE, rel)
         ELSE
            rel := (t + 10000H - (fix [i].place + 2)) MOD 10000H ;
            rt [fix [i].place] := VAL (BYTE, rel MOD 100H) ;
            rt [fix [i].place + 1] := VAL (BYTE, (rel DIV 100H) MOD 100H)
         END
      END ;
      INC (i)
   END
END FixUp ;

(* ---------------------------------------------------------------- *)
(*  public interface                                                 *)
(* ---------------------------------------------------------------- *)

PROCEDURE RT_Build ;
BEGIN
   IF built THEN
      RETURN
   END ;
   rpos := 0 ; ltop := 0 ; nfix := 0 ; dataAt := 0 ;
   EmitInitMem ;
   EmitEnd ;
   EmitStackChk ;
   EmitWrInt ; EmitWrChar ; EmitWrBool ; EmitWrReal ; EmitWrLn ;
   EmitWrInl ;
   EmitRdInt ; EmitRdChar ; EmitRdBool ; EmitRdLn ;
   EmitGetCh ;
   EmitData ;
   FixUp ;
   SetStr (entNm [0], "initmem") ;
   SetStr (entNm [1], "progend") ;
   SetStr (entNm [2], "stackchk") ;
   SetStr (entNm [3], "wrint") ;
   SetStr (entNm [4], "wrchar") ;
   SetStr (entNm [5], "wrbool") ;
   SetStr (entNm [6], "wrreal") ;
   SetStr (entNm [7], "wrln") ;
   SetStr (entNm [8], "rdint") ;
   SetStr (entNm [9], "rdchar") ;
   SetStr (entNm [10], "rdbool") ;
   SetStr (entNm [11], "rdln") ;
   SetStr (entNm [12], "halt") ;
   SetStr (entNm [13], "wrtinl") ;
   built := TRUE
END RT_Build ;

PROCEDURE RT_Size () : CARDINAL ;
BEGIN
   IF NOT built THEN
      RT_Build ()
   END ;
   RETURN rpos
END RT_Size ;

PROCEDURE RT_Byte (i : CARDINAL ) : BYTE ;
BEGIN
   IF NOT built THEN
      RT_Build ()
   END ;
   IF i >= rpos THEN
      RETURN 0
   END ;
   RETURN rt [i]
END RT_Byte ;

PROCEDURE RT_Entry (i : CARDINAL ) : CARDINAL ;
BEGIN
   IF NOT built THEN
      RT_Build ()
   END ;
   IF i > 13 THEN
      RETURN 0
   END ;
   RETURN LblOff (entNm [i])
END RT_Entry ;

PROCEDURE RT_CodeEnd () : CARDINAL ;
BEGIN
   IF NOT built THEN
      RT_Build ()
   END ;
   RETURN dataAt
END RT_CodeEnd ;

END Runtime.