home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / dtx9203 / naxos / source / nx.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-02-09  |  46.8 KB  |  1,834 lines
  1. (* ====================================================== *)
  2. (*                         NX.PAS                         *)
  3. (*           Naxos-Compiler Vers. 1.01 BETA               *)
  4. (* (C) 1992 DMV-Verlag & K.Peper, A.Zissis, I.Tossounidis *)
  5. (*             Compiler: Turbo Pascal 6.0                 *)
  6. (* ------------------------------------------------------ *)
  7. (*  Naxos basiert in seinen Grundlagen auf dem Software-  *)
  8. (*          Projekt SForth von DOS International          *)
  9. (*     (C) 1987 Volker Everts und DOS International       *)
  10. (*         sowie den Vorgängerprojekten FCC u. MCC        *)
  11. (*   (C) 1989 bis 1992 K.Peper, I.Tossounidis & A.Zissis  *)
  12. (* ====================================================== *)
  13. {$M 65520,0,655350}
  14. {$N+,E+,R-,S-,I-,A+}
  15.  
  16. PROGRAM Naxos;
  17.  
  18. USES
  19.   Crt, Dos;
  20.  
  21. LABEL
  22.   OkMcc ;
  23.  
  24. CONST
  25.   Version  = '1.01 BETA'; { Versionsnummer }
  26.   MaxStack = 100;         { Stack-Ebenen   }
  27.   Empty    = '';          { leerer String  }
  28.   Space    = #32;         { Leerzeichen    }
  29.   NUL      = #0;          { Null-Zeichen   }
  30.   Bel      = #7;          { akust. Signal  }
  31.   CR       = #13;         { Wagenrücklauf  }
  32.   Apost    = #39;         { Hochkomma      }
  33.  
  34. { Typ-Bezeichner im Wörterbuch:         }
  35.   _VAR      = 1;     { Datenvariable    }
  36.   _ARR      = 2;     { Datenarray       }
  37.   _REC      = 3;     { Datenrecord      }
  38.   _FLD      = 4;     { Datenfeld        }
  39.   _STRING   = 5;     { String           }
  40.   _DCONST   = 15;    { Double-Konstante }
  41.   _FCONST   = 16;    { Real-Konst       }
  42.   _CONST    = 10;    { Konstante        }
  43.   _KOLON    = 12;    { Kolon-Def.       }
  44.   _PROC     = 13;    { Prozedur         }
  45.   _VECTOR   = 14;    { Vektor           }
  46.   _IF       = 1;     { IF-Flag          }
  47.   _BEGIN    = 2;     { BEGIN-Flag       }
  48.   _WHILE    = 3;     { WHILE-Flag       }
  49.   _DO       = 4;     { DO-Flag          }
  50.   _CASE     = 5;     { CASE-Flag        }
  51.  
  52.   MaxZeile  = 127;   { max. Zeilenlänge      }
  53.   MaxProg   = $F7FF; { Programmgröße         }
  54.   MaxIFB    = $FFFE; { Inputfile Buffergröße }
  55.   MaxName   = 12;    { Namensgröße           }
  56.  
  57. TYPE
  58.   Memory       = ARRAY[256..MaxProg] OF BYTE; { 62 KByte }
  59.   PMemory      = ^Memory;
  60.   PSYMTAB      = ^SYMTAB;
  61.   SYMTAB       = RECORD
  62.                    Name   : STRING[12];
  63.                    Typ    : BYTE;
  64.                    QFA    : WORD;
  65.                    PAR0,
  66.                    PAR1,
  67.                    PAR2,
  68.                    PAR3   : WORD;
  69.                    QFAlen : WORD;
  70.                    RLink,
  71.                    LLink  : PSYMTAB;
  72.                  END;
  73.   InFileBuf    = ARRAY[0..MaxIFB] OF BYTE;
  74.   IfBTyp       = ^InFileBuf;
  75.   WortTyp      = STRING[16];
  76.   ZeilenTyp    = STRING[MaxZeile];
  77.   HexStr       = STRING[4];
  78.   StackEintrag = RECORD
  79.                    Wert : INTEGER;
  80.                    Typ  : BYTE;
  81.                    Size : BYTE;
  82.                  END;
  83.   StackTyp     = ARRAY[0..MaxStack] OF StackEintrag;
  84.  
  85. VAR
  86.   CRTReg   : BYTE ABSOLUTE $0040:$0049;
  87.   Result   : RECORD
  88.              CASE BOOLEAN OF
  89.                TRUE : ( ErrorPos      : WORD;
  90.                         ErrorWort     : STRING[16] );
  91.                FALSE: ( Main, Here,
  92.                         s0, r0,
  93.                         Zeilen, Bytes : WORD );
  94.              END;
  95.   r0,s0    : WORD;
  96.   XFSize   : LONGINT;   { Inputfilegröße }
  97.   ef       : TEXT;      { LOG.FILE im Shellmodus }
  98.   QFAs     : WORD;      { QuellFileAdresse }
  99.   Outfile  : FILE;      { compilierter Code }
  100.   Zeile,
  101.   LZ       : ZeilenTyp; { Forth-Textzeile   }
  102.   LastTyp,
  103.   WTyp     : BYTE;      { Worttyp    }
  104.   Wort,                 { Forth-Wort }
  105.   VocName,              { Vocabulary }
  106.   Merker,
  107.   Merker2  : WortTyp;   { Merker     }
  108.   IFB      : IfBTyp;  { Input File Buffer }
  109.   IFBP     : WORD;
  110.   IFBMax   : WORD;
  111.   Name     : NameStr;
  112.   Ext      : ExtStr;
  113.   Pfad,
  114.   SysPfad  : DirStr;
  115.   DXName   : STRING;
  116.   DateiName: STRING[MaxZeile]; { Zugriffspfad }
  117.   DMerker  : PSYMTAB;
  118.   Pc,                   { Programmzähler     }
  119.   AdrMerker,            { Merkt Adresse      }
  120.   PcMerker,             { Merkt pc           }
  121.   QFA,                  { QuellfilePtrAdr    }
  122.   PAR0,                 { Parameter 0        }
  123.   PAR1,                 { Parameter 1 = LEN  }
  124.   PAR2,                 { Parameter 2        }
  125.   PAR3,
  126.   Felder,               { Feldakkumulator    }
  127.   Macro,                { Macrogrenze aktuell}
  128.   MacroLim,             { Vorgabe Grenze     }
  129.   SP,                   { Stackpointer       }
  130.   Nummer,               { Zeilennummer       }
  131.   Anfang,               { Anfang Dictionary  }
  132.   Ende,                 { Ende Dictionary    }
  133.   VocAnfang,            { Start Vocabulary   }
  134.   OFCnt,                { OF-Zähler          }
  135.   i,                    { Zählvariable       }
  136.   Mn,                   { Main-Adresse       }
  137.   RecLen   : WORD;      { Datenlänge         }
  138.   FZeiger,              { Zeiger auf gefundenes Wort }
  139.   Zeiger   : pSymtab;   { Zeiger auf aktuelles Definitionswort }
  140.   M        : pMemory;   { Speicherbereich    }
  141.   S        : StackTyp;  { Kontroll-Stack     }
  142.   Root,
  143.   D: PSYMTAB    ;       { Wörterbuch         }
  144.  
  145.   RegFix,               { RegisterPräfix     }
  146.   CaseLit:INTEGER;      { Literal vor OF     }
  147.  
  148.   Sys,                  { System-Befehl      }
  149.   Main,                 { Hauptprogramm      }
  150.   CaseFlag,             { für Case-Anweisung }
  151.   CLitflag,             { CaseLiteralflag    }
  152.   Flagstack,            { Bedingungsstack    }
  153.   Found,                { für Wortsuche      }
  154.   NoCodeFlag,           { speichern ein/aus  }
  155.   Includeflag,          { Nur ein Incl.file  }
  156.   ShortFlag,            { Short-Jump ein/aus }
  157.   Comment,              { Kommentar          }
  158.   MapFlag : BOOLEAN;    { Zur Erzeugung von MAP-Files     } { neu 2.1.92 }
  159.   LineLen : WORD;       { Zeilenlänge                     }
  160.   Sif     : FILE;       { Globales Includefile            }
  161.   InDef   : BOOLEAN;    { In Definition Flag;             }
  162.                         { True zwischen : oder PROC und ; }
  163.   cv      : RECORD
  164.               CASE BOOLEAN OF
  165.                 TRUE : (l      : LONGINT);
  166.                 FALSE: (Lo, Hi : WORD);
  167.               END;
  168.  
  169. FUNCTION BackPos(ch: CHAR; Str: STRING): BYTE;
  170. { Ermittelt Position des letzten Auftretens von ch in str }
  171. VAR
  172.   i: BYTE;
  173. BEGIN
  174.   i := Length(Str);
  175.   WHILE (i > 0) AND (Str[i] <> ch) DO Dec(i);
  176.   BackPos := i;
  177. END;
  178.  
  179. FUNCTION LongLo(x: LONGINT): WORD;
  180. BEGIN
  181.   cv.l   := x;
  182.   LongLo := cv.Lo;
  183. END;
  184.  
  185. FUNCTION LongHi(x: LONGINT): WORD;
  186. BEGIN
  187.   cv.l   := x;
  188.   LongHi := cv.Hi;
  189. END;
  190.  
  191. FUNCTION Hex(n, l: INTEGER): HexStr;
  192. { n in l-stellige Hexzahl wandeln }
  193. VAR
  194.   i, z : INTEGER;
  195.   S    : HexStr;
  196. BEGIN
  197.   S := Empty;
  198.   FOR i := 1 TO l DO BEGIN
  199.     z := n AND 15;            { Ziffer bilden     }
  200.     IF z > 9 THEN z := z + 7;
  201.     S := Chr(z + 48) + S;
  202.     n := n SHR 4;             { Division durch 16 }
  203.   END;
  204.   Hex := S;
  205. END;
  206.  
  207. PROCEDURE Error(nr: BYTE);
  208. { Fehlerbehandlung }
  209. BEGIN
  210.   Result.ErrorPos := IFBP;
  211.   Result.ErrorWort:= Merker;
  212.   Dispose(IFB);
  213.   Dispose(M);
  214.   Halt(100 + nr);
  215. END;
  216.  
  217. PROCEDURE Hilfe;
  218. BEGIN
  219.   WriteLn;
  220.   WriteLn('NAXOS Compiler Version ', Version);
  221.   WriteLn('(C) 1992 DMV-Verlag & Peper, Zissis, Tossounidis');
  222.   WriteLn;
  223.   WriteLn('Aufruf: NX Dateiname  -m -n    ');
  224.   WriteLn;
  225.   WriteLn('        (Parameter sind optional)');
  226.   WriteLn;
  227.   WriteLn('    -m  MAP-Datei erzeugen');
  228.   WriteLn('    -n  Keine Code-Erzeugung');
  229.   WriteLn;
  230.   WriteLn('    (statt "-" ist auch "/" gültig)');
  231.   WriteLn;
  232.   Halt(0);
  233. END;
  234.  
  235. PROCEDURE Init;
  236. { Compiler initialisieren }
  237. VAR
  238.   p, i     : BYTE;
  239.   Option   : STRING[2];
  240.   ch       : CHAR;
  241.   f        : FILE;
  242.   OkL, OkR : BOOLEAN;
  243.   x,
  244.   p1, p2  : pSymtab;
  245. BEGIN
  246.   LZ := Empty;
  247.   { Dateinamen holen }
  248.   DateiName := ParamStr(1);
  249.   IF (DateiName = '?') OR (ParamCount = 0) THEN Hilfe;
  250.   FSplit (DateiName, Pfad, Name, Ext);
  251.   IF Ext = '' THEN Ext := '.FTH';
  252.   { Options-Voreinstellungen }
  253.   SysPfad := GetEnv('NAXOS');
  254.   IF SysPfad <> '' THEN SysPfad := SysPfad + '\';
  255.   NoCodeFlag := FALSE;
  256.   InDef      := FALSE;
  257.   Comment    := FALSE;
  258.   ShortFlag  := TRUE;
  259.   MapFlag    := FALSE;    { ** neu 2.1.92 ** }
  260.   Main       := FALSE;
  261.   Merker     := '';
  262.   Nummer     := 0;
  263.   { Optionen auswerten }
  264.  
  265.   IF ParamCount > 1 THEN FOR i := 2 TO ParamCount DO BEGIN
  266.     Option := ParamStr(i);
  267.     IF Option[1] IN ['/', '-'] THEN BEGIN
  268.       ch := UpCase(Option[2]);
  269.       CASE ch OF
  270.         'N': NoCodeFlag := TRUE;
  271.         'M': MapFlag    := TRUE;
  272.         ELSE Error(18);
  273.       END;
  274.     END ELSE IF Option[1] <> '>' THEN Error(18);
  275.   END;
  276.  
  277.   { Quelltextdatei öffnen }
  278.   Assign(f, Pfad + Name + Ext);
  279.   {$I-} Reset(f, 1); {$I+}
  280.   IF IOResult <> 0 THEN Error(19);
  281.   XFSize      := FileSize(f);
  282.   BlockRead(f, IFB^, XFSize);
  283.   Close(f);
  284.   IFBMax      := XFSize;
  285.   IFBP        := 0;
  286.   { verschiedene Einstellungen }
  287.   Zeile       := Empty;
  288.   Merker      := Empty;
  289.   Wort        := Space;
  290.   Includeflag := TRUE;
  291.   CLitflag    := FALSE;
  292.   Flagstack   := FALSE;
  293.   r0          := $FFFF;
  294.   s0          := $FFFF;
  295.   SP          := 0;
  296.   Nummer      := 0;
  297.   Pc          := 256;
  298.   MacroLim    := 9;
  299.   RegFix      := 0;
  300.   Macro       := MacroLim;
  301.   VocName     := Empty;
  302.   OFCnt       := 0;
  303.   CaseFlag    := FALSE;
  304.   VocAnfang   := 0;
  305.   LineLen     := 0;
  306.   QFAs        := 0;
  307.   FillChar(M^, SizeOf(M^), NUL);
  308.   TextAttr    := $70;
  309.   GotoXY(35, 11);
  310.   Write(Name, '.FTH');
  311.   GotoXY(23, 14);
  312.   Write('└─────────────────┴────────────────┘');
  313.   GotoXY(23, 15);
  314.   Write('0%               50%            100%');
  315.   GotoXY(22, 16);
  316.   TextAttr := $1F;
  317.   Write('  Abbruch mit Strg-Untbr              ');
  318.   TextAttr := $70;
  319.   New(Root);
  320.   Root^.RLink := NIL;
  321.   Root^.LLink := NIL;
  322.   Root^.Name  := 'FFFFFFFFFFFF';
  323.   Root^.Typ   := 254;
  324.   Root^.PAR0  := 0;
  325.   Root^.PAR1  := 0;
  326.   Root^.PAR2  := 0;
  327.   Root^.PAR3  := 0;
  328.   Assign(Sif, SysPfad + 'SYSTEM.DIC');
  329.   {$I-} Reset(Sif, SizeOf(Root^) - 10); {$I+}
  330.   IF IOResult <> 0 THEN Error(25);
  331.   REPEAT
  332.     New(x);
  333.     BlockRead(Sif, x^, 1);
  334.     x^.QFAlen := 0;
  335.     x^.RLink  := NIL;
  336.     x^.LLink  := NIL;
  337.     p1        := Root;
  338.     REPEAT
  339.       p2 := p1;
  340.       IF x^.Name > p1^.Name THEN p1 := p1^.RLink
  341.                             ELSE p1 := p1^.LLink;
  342.     UNTIL p1 = NIL;
  343.     IF x^.Name > p2^.Name THEN p2^.RLink := x
  344.                           ELSE p2^.LLink := x;
  345.   UNTIL EoF(Sif);
  346.   Close(Sif);
  347. END;
  348.  
  349. FUNCTION IneOf : BOOLEAN;
  350. BEGIN
  351.   IF IFBP >= IFBMax THEN IneOf := TRUE
  352.                     ELSE IneOf := FALSE;
  353. END;
  354.  
  355. PROCEDURE InReadLn(VAR S: ZeilenTyp);
  356. BEGIN
  357.   S :='';
  358.   IF NOT(IneOf) THEN BEGIN
  359.     WHILE IFB^[IFBP] = 13 DO Inc(IFBP, 2);
  360.     REPEAT
  361.       S := S + Chr(IFB^[IFBP]);
  362.       Inc(IFBP);
  363.     UNTIL (IFB^[IFBP] = 13) OR (IneOf);
  364.     Inc(IFBP, 2);
  365.   END;
  366. END;
  367.  
  368. FUNCTION Suche(Name: STRING): BOOLEAN; FORWARD;
  369.  
  370. FUNCTION HW1: WortTyp;
  371. { Ein Wort aus Quelltext holen }
  372. CONST
  373.   Balken : STRING[36] = '▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒';
  374. VAR
  375.   p    : BYTE;
  376.   w    : STRING;
  377.   Mist : BOOLEAN;
  378.   Bffr : WORD;
  379. BEGIN
  380.   REPEAT
  381.     IF IneOf THEN BEGIN
  382.       HW1 := Empty;
  383.       Exit;
  384.     END ELSE BEGIN
  385.       w := '';
  386.       WHILE IFB^[IFBP] = 13 DO BEGIN
  387.         IF Comment THEN Error(46);
  388.         Inc(IFBP, 2);
  389.         Inc(Nummer);
  390.       END;
  391.       Bffr := IFBP;
  392.       WHILE (IFB^[IFBP] <> $20) AND (IFB^[IFBP] <> $0D)
  393.         AND (NOT(IneOf)) DO BEGIN
  394.         w := w + Chr(IFB^[IFBP]);
  395.         Inc(IFBP);
  396.       END;
  397.       Inc(IFBP);
  398.     END;
  399.   UNTIL w <> '';
  400.   IF IFB^[IFBP] = $0A THEN BEGIN
  401.     Inc(IFBP);
  402.     Inc(Nummer);
  403.     Balken[0] := Chr(Round((IFBP / IFBMax) * 36));
  404.     GotoXY(23, 13);
  405.     Write(Balken);
  406.   END;
  407.   IF w[1] <> Apost THEN
  408.     FOR p := 1 TO Length(w) DO w[p] := UpCase(w[p]);
  409.   Merker2 := w;
  410.   Merker  := w;
  411.   HW1     := w;
  412.   IF (w = '(') THEN WTyp := 178 ELSE
  413.   IF (w = ')') THEN WTyp := 179 ELSE
  414.   IF NOT Comment THEN Mist := Suche(w);
  415.   IF (WTyp IN [160..165, 177, 181, 191, 192]) THEN
  416.     QFAs := Bffr;
  417. END;
  418.  
  419. FUNCTION HoleWort: WortTyp;
  420. VAR
  421.   wx: WortTyp;
  422. BEGIN
  423.   wx := HW1;
  424.   WHILE (WTyp = 178) DO BEGIN
  425.     Comment := TRUE;
  426.     REPEAT
  427.       wx := HW1;
  428.     UNTIL (WTyp = 179);
  429.     Comment := FALSE;
  430.     wx := HW1;
  431.   END;
  432.   HoleWort := wx;
  433. END;
  434.  
  435. FUNCTION HoleZeichen: CHAR;
  436. { Ein einzelnes Zeichen aus Quelltext holen }
  437. BEGIN
  438.   HoleZeichen := Chr(IFB^[IFBP]);
  439.   Inc(IFBP);
  440. END;
  441.  
  442. PROCEDURE Ob(b:BYTE);
  443. { Ein Byte im Code ablegen }
  444. BEGIN
  445.   M^[Pc] := b;
  446.   Inc(Pc);
  447.   IF Pc > MaxProg THEN Error(3);
  448. END;
  449.  
  450. PROCEDURE Ow(w: WORD);
  451. { Ein Wort im Code ablegen }
  452. BEGIN
  453.   Move(w, M^[Pc], 2);
  454.   Inc(Pc, 2);
  455.   IF Pc > MaxProg THEN Error(3);
  456. END;
  457.  
  458. PROCEDURE Ot(Adr: WORD; w: INTEGER);
  459. { Ein Wort an spezifizierter CodeAdresse ablegen }
  460. BEGIN
  461.   Move(w, M^[Adr], 2);
  462. END;
  463.  
  464. PROCEDURE Otb(Adr: WORD; b: BYTE);
  465. { Ein Byte an spezifizierter CodeAdresse ablegen }
  466. BEGIN
  467.   Move(b, M^[Adr], 1);
  468. END;
  469.  
  470. PROCEDURE Os(S: ZeilenTyp);
  471. { String im Code ablegen }
  472. BEGIN
  473.   FOR i := 0 TO Length(S) DO Ob(Ord(S[i]));
  474. END;
  475.  
  476. PROCEDURE TueCode;
  477. { Inline-Code auswerten }
  478. VAR
  479.   w      : WortTyp;
  480.   Disp   : WORD;
  481.   Fehler : INTEGER;
  482. BEGIN
  483.   REPEAT
  484.     w := HoleWort;
  485.     IF w = Empty THEN Error(7);
  486.     IF w <> ']' THEN BEGIN
  487.       Val(w, Disp, Fehler);
  488.       IF Fehler <> 0 THEN Error(7);
  489.       IF Disp > 255 THEN Ow(Disp) ELSE Ob(Disp);
  490.     END;
  491.   UNTIL w = ']';
  492. END;
  493.  
  494. PROCEDURE Push(p: WORD; Flag, Short: BYTE);
  495. { Adresse und Flag auf Stack ablegen }
  496. BEGIN
  497.   WITH S[SP] DO BEGIN
  498.     Wert := p;
  499.     Typ  := Flag;
  500.     Size := Short;
  501.   END;
  502.   Inc(SP);
  503.   IF SP > MaxStack THEN Error(8);
  504. END;
  505.  
  506. FUNCTION Pop(Flag: BYTE; VAR Short: BYTE): INTEGER;
  507. { Adresse vom Stack holen, Flag prüfen }
  508. BEGIN
  509.   IF SP = 0 THEN Error(9);
  510.   Dec(SP);
  511.   WITH S[SP] DO BEGIN
  512.     Short := Size;
  513.     IF Typ = Flag THEN Pop := Wert ELSE
  514.     CASE Flag OF
  515.       _IF   : Error(10);
  516.       _BEGIN: Error(13);
  517.       _WHILE: Error(14);
  518.       _DO   : Error(15);
  519.       ELSE    Error(0);
  520.     END;
  521.   END;
  522. END;
  523.  
  524. FUNCTION Near(Quelle, Ziel: WORD): INTEGER;
  525. { Near-Sprungdistanz berechnen }
  526. BEGIN
  527.   Near := INTEGER(Ziel - Quelle) - 2;
  528. END;
  529.  
  530. FUNCTION Short(Quelle, Ziel: WORD): BYTE;
  531. { Short-Sprungdistanz berechnen }
  532. VAR
  533.   Disp: INTEGER;
  534. BEGIN
  535.   Disp := Ziel - Quelle - 1;
  536.   IF Abs(Disp) > 127 THEN Error(11);
  537.   Short := Lo(Disp);
  538. END;
  539.  
  540. FUNCTION Suche(Name: STRING): BOOLEAN;
  541. { Namen in Dictionary suchen }
  542. LABEL
  543.   Ok;
  544. VAR
  545.   va, er : INTEGER;
  546.   vd     : LONGINT;
  547.   vf     : RECORD
  548.             CASE BOOLEAN OF
  549.               TRUE  : (r              : DOUBLE);
  550.               FALSE : (p0, p1, p2, p3 : WORD);
  551.             END;
  552.   p1,p2 : pSymtab;
  553.   n     : WortTyp;
  554.   Num   : STRING;
  555.   su    : BOOLEAN;
  556. BEGIN
  557.   n    := Empty;
  558.   Num  := Name;
  559.   Name := Copy(Name, 1, MaxName);
  560.   su   := FALSE;
  561.   p1   := Root;
  562.   REPEAT
  563.     p2 := p1;
  564.     IF Name > p1^.Name THEN p1 := p1^.RLink
  565.                        ELSE p1 := p1^.LLink;
  566.   UNTIL (Name = p2^.Name) OR (p1 = NIL);
  567.   IF Name = p2^.Name THEN BEGIN
  568.     su := TRUE;
  569.     FZeiger := p2;
  570.   END ELSE su := FALSE;
  571.   IF su THEN BEGIN
  572.     QFA     := p2^.QFA;
  573.     LastTyp := WTyp;
  574.     WTyp    := p2^.Typ;
  575.     PAR0    := p2^.PAR0;
  576.     PAR1    := p2^.PAR1;
  577.     PAR2    := p2^.PAR2;
  578.     PAR3    := p2^.PAR3;
  579.   END ELSE BEGIN
  580.     LastTyp := WTyp;
  581.     IF (Name[1] = '''') AND (Name[0] = #3) AND
  582.        (Name[3] = '''') THEN BEGIN
  583.       er := 0;
  584.       vd := Ord(Name[2]);
  585.     END ELSE Val(Name, vd, er);
  586.     WTyp := _CONST;
  587.     IF (er <> 0) AND (Name[1] = '&') THEN BEGIN
  588.       Delete(Name, 1, 1);
  589.       Val(Name, vd, er);
  590.       WTyp := _DCONST;
  591.     END;
  592.     IF er = 0 THEN BEGIN
  593.       PAR0 := LongLo(vd);
  594.       PAR1 := LongHi(vd);
  595.       su   := TRUE;
  596.     END ELSE BEGIN
  597.       IF Num[1] = '%' THEN BEGIN
  598.         Delete(Num, 1, 1);
  599.         Val(Num, vf.r, er);
  600.         IF er = 0 THEN BEGIN
  601.           WTyp := _FCONST;
  602.           PAR0 := vf.p0;
  603.           PAR1 := vf.p1;
  604.           PAR2 := vf.p2;
  605.           PAR3 := vf.p3;
  606.           su   := TRUE;
  607.         END ELSE su := FALSE;
  608.       END;
  609.     END;
  610.   END;
  611. Ok:
  612.   IF NOT(su) THEN BEGIN
  613.     LastTyp := WTyp;
  614.     WTyp    := 255;  { unbekannter Bezeichner }
  615.   END;
  616.   Found := su;
  617.   Suche := su;
  618. END;
  619.  
  620. PROCEDURE TueName;
  621. { Name holen und überprüfen, Header bauen }
  622. VAR
  623.   Name   : WortTyp;
  624.   p1, p2 : PSYMTAB;
  625. BEGIN
  626.   Name := HoleWort;
  627.   IF Name[0] > Chr(MaxName) THEN
  628.     Name[0] := Chr(MaxName);
  629.   IF Name = Empty THEN Error(2);
  630.   IF Found THEN Error(40);
  631.   New(Zeiger);
  632.   Zeiger^.Name  := Name;
  633.   Zeiger^.QFA   := QFAs;
  634.   Zeiger^.RLink := NIL;
  635.   Zeiger^.LLink := NIL;
  636.   Main          := Name = 'MAIN';
  637. END;
  638.  
  639. PROCEDURE TueLink;
  640. VAR
  641.   p1, p2 : PSYMTAB;
  642. BEGIN
  643.   Zeiger^.QFAlen := IFBP - Zeiger^.QFA;
  644.   p1 := Root;
  645.   REPEAT
  646.     p2 := p1;
  647.     IF Zeiger^.Name > p1^.Name THEN p1 := p1^.RLink
  648.                                ELSE p1 := p1^.LLink;
  649.   UNTIL p1 = NIL;
  650.   IF Zeiger^.Name > p2^.Name THEN p2^.RLink := Zeiger
  651.                              ELSE p2^.LLink := Zeiger;
  652. END;
  653.  
  654. PROCEDURE TueSeal;
  655. { Name verstecken }
  656. VAR
  657.   Name: WortTyp;
  658. BEGIN
  659.   Name := HoleWort;
  660.   IF Name = Empty THEN Error(2);
  661.   IF Found THEN BEGIN
  662.     FZeiger^.Name := FZeiger^.Name+#0;  { #0 an Name anhängen }
  663.   END ELSE Error(4);
  664. END;
  665.  
  666. PROCEDURE Branch0(Adr: WORD);
  667. { compiliert bedingten Short- oder Near-Jump rückwärts }
  668. VAR
  669.   Len: INTEGER;
  670. BEGIN
  671.   Len := Near(Pc, Adr);
  672.   IF Abs(Len) < 128 THEN BEGIN
  673.     Ob($73); Ob(Len);     { jnc  disp }
  674.   END ELSE BEGIN
  675.     Ob($72); Ob(03);      { jc   +3   }
  676.     Ob($E9); Ow(Len - 3); { jmp  disp }
  677.   END;
  678. END;
  679.  
  680. PROCEDURE Branch(Adr: WORD);
  681. { compiliert Rückwärtssprung }
  682. VAR
  683.   Len: INTEGER;
  684. BEGIN
  685.   Len := Near(Pc, Adr);
  686.   IF Abs(Len) < 128 THEN BEGIN
  687.     Ob($EB); Ob(Len);   { jmp  disp }
  688.   END ELSE BEGIN
  689.     Ob($E9); Ow(Len);   { jmp  disp }
  690.   END;
  691. END;
  692.  
  693. PROCEDURE TueLiteral(n: INTEGER);
  694. { Literalhandler mit Präfix }
  695. BEGIN
  696.   IF CLitflag THEN CaseLit := n ELSE
  697.   CASE RegFix OF
  698.   1: BEGIN { AX }
  699.        Ob($B8); Ow(n);          { mov ax,n }
  700.        RegFix := 0;
  701.      END;
  702.   2: BEGIN { BX, ADR }
  703.        Ob($BB); Ow(n);          { mov bx,n }
  704.        RegFix := 0;
  705.      END;
  706.   3: BEGIN { DX, TO, ,, }
  707.        Ob($BA); Ow(n);          { mov dx,n }
  708.        RegFix := 0;
  709.      END;
  710.   4: BEGIN { SX }
  711.        Ob($4E); Ob($4E);        { dec si,dec si }
  712.        Ob($C7); Ob($04); Ow(n); { mov [si],n }
  713.      END;
  714.   END;
  715. END;
  716.  
  717. PROCEDURE TueDLiteral(n0, n1: WORD);
  718. { Literalhandler mit Präfix }
  719. BEGIN
  720.   CASE RegFix OF
  721.   1: BEGIN { AX }
  722.        Ob($B8); Ow(n0);          { mov ax,n1 }
  723.        Ob($BA); Ow(n1);          { mov dx,n2 }
  724.        RegFix := 0;
  725.      END;
  726.   4: BEGIN { SX }
  727.        Ob($4E); Ob($4E);         { dec si,dec si }
  728.        Ob($C7); Ob($04); Ow(n1); { mov [si],n }
  729.        Ob($4E); Ob($4E);         { dec si,dec si }
  730.        Ob($C7); Ob($04); Ow(n0); { mov [si],n }
  731.      END;
  732.   ELSE Error(45);
  733.   END;
  734. END;
  735.  
  736. PROCEDURE TueFLiteral(n0, n1, n2, n3: WORD);
  737. VAR
  738.   Merk: WORD;
  739. BEGIN
  740.   Ob($EB); Ob($08);                { JMP SHORT +8 }
  741.   Merk := Pc;
  742.   Ow(n0); Ow(n1); Ow(n2); Ow(n3);  { DATENFELD }
  743.   Ob($DD); Ob($06); Ow(Merk);      { FLD DATENFELD }
  744. END;
  745.  
  746. PROCEDURE TestSemi;
  747. { Semikolonabschluss }
  748. VAR
  749.   w: WortTyp;
  750. BEGIN
  751.   w := HoleWort;
  752.   IF WTyp <> 128 THEN Error(41); { Semikolon erwartet }
  753. END;
  754.  
  755. PROCEDURE TueStringLiteral;
  756. VAR
  757.   z  : CHAR;
  758.   Adr: WORD;
  759. BEGIN
  760.   Ob($E8); Ow(0);            { call disp }
  761.   Adr := Pc;
  762.   Ob(0);                     { countbyte }
  763.   z := HoleZeichen;
  764.   WHILE (z <> '"') AND (z <> Empty) DO BEGIN
  765.     Ob(Ord(z));
  766.     z := HoleZeichen;
  767.     Inc(M^[Adr]);
  768.   END;
  769.   Ob(0);                     { Nullbyte }
  770.   M^[Adr-2] := M^[Adr] + 2;  { disp setzen }
  771.   Ob($5B);                   { pop bx }
  772. END;
  773.  
  774. PROCEDURE Tue_ZIf;
  775. { Leite If über Zeroflag ein }
  776. BEGIN
  777.   IF ShortFlag THEN BEGIN
  778.     Ob($74);               { jz   disp  }
  779.     Push(Pc, _IF, 1);
  780.     Ob(0);
  781.   END ELSE BEGIN
  782.     Ob($75); Ob(03);       { jnz  +3    }
  783.     Ob($E9);               { jmp  disp  }
  784.     Push(Pc, _IF, 2);
  785.     Ow(0);
  786.   END;
  787. END;
  788.  
  789.  
  790. PROCEDURE TueSystem(w: WortTyp);
  791. { SYSTEM-Worte compilieren }
  792. VAR
  793.   nn, Fehlern : INTEGER;
  794.   z           : CHAR;
  795.   Len, Dis    : BYTE;
  796.   Disp, Fehler,
  797.   Adr, Adr1,
  798.   Adr2        : WORD;
  799.   Zgr1, Zgr2  : pSymtab;
  800.   Gefunden    : BOOLEAN;
  801.  
  802. BEGIN
  803.   Sys := TRUE;
  804.   IF WTyp > 127 THEN
  805.   CASE WTyp OF
  806.   { ; }
  807.   128: BEGIN
  808.          Ob($C3);            { ret }
  809.          ShortFlag := TRUE;
  810.          IF SP > 0 THEN CASE S[SP - 1].Typ OF
  811.            _IF   : Error(20);
  812.            _BEGIN: Error(21);
  813.            _WHILE: Error(22);
  814.            _DO   : Error(23);
  815.            ELSE Error(0);
  816.          END;
  817.        END;
  818.   { [  }
  819.   129: TueCode;
  820.   { PC? }
  821.   182: PcMerker := Pc;
  822.   { [PC] }
  823.   183: Ow(PcMerker);
  824.   { IF }
  825.   132: IF ShortFlag THEN BEGIN
  826.          Ob($73);                { jnc  disp  }
  827.          Push(Pc, _IF, 1);
  828.          Ob(0);
  829.        END ELSE BEGIN
  830.          Ob($72); Ob(03);           { jc   +3    }
  831.          Ob($E9);                   { jmp  disp  }
  832.          Push(Pc, _IF, 2);
  833.          Ow(0);
  834.        END;
  835.   { C@IF }
  836.   133: BEGIN
  837.          Ob($8A); Ob($1F);          { move bl,[bx] }
  838.          Ob($84); Ob($DB);          { test bl,bl   }
  839.          Tue_ZIf;
  840.        END;
  841.   { @IF }
  842.   188: BEGIN
  843.          Ob($8B); Ob($1F);          { mov bx,[bx] }
  844.          Ob($85); Ob($DB);          { test bx,bx  }
  845.          Tue_ZIf;
  846.        END;
  847.   { 0=IF }
  848.   189: BEGIN
  849.          Ob($85); Ob($C0);          { test ax,ax }
  850.          Tue_ZIf;
  851.        END;
  852.   { ENDIF, THEN }
  853.   134: BEGIN
  854.          Adr := Pop(_IF, Len);
  855.          IF Len = 1 THEN
  856.            M^[Adr] := Short(Adr, Pc)
  857.          ELSE
  858.            Ot(Adr, Near(Adr, Pc));
  859.        END;
  860.   { ELSE }
  861.   135: IF CLitflag THEN CLitflag := FALSE ELSE BEGIN
  862.          Adr := Pop(_IF, Len);
  863.          IF Len = 1 THEN BEGIN
  864.            M^[Adr] := Short(Adr, Pc + 2);
  865.            Ob($EB);  { jmp disp }
  866.            Push(Pc, _IF, 1);
  867.            Ob(0);
  868.          END ELSE BEGIN
  869.            Ot(Adr, Near(Adr, Pc + 3));
  870.            Ob($E9);  { jmp  disp }
  871.            Push(Pc, _IF, 2);
  872.            Ow(0);
  873.          END;
  874.        END;
  875.   { CASE }
  876.   136: BEGIN
  877.          IF CaseFlag THEN Error(28);
  878.          CaseFlag := TRUE;
  879.          CLitflag := TRUE;
  880.        END;
  881.   { OF }
  882.   137: BEGIN
  883.          CLitflag := FALSE;
  884.          Inc(OFCnt);
  885.          Ob($3D); Ow(CaseLit);   { cmp ax,n    }
  886.          IF ShortFlag THEN BEGIN
  887.            Ob($75);              { jnz disp    }
  888.            Push(Pc, _CASE, 1);
  889.            Ob(0);
  890.          END ELSE BEGIN
  891.            Ob($74); Ob(3);       { jz  +3      }
  892.            Ob($E9);              { jmp disp    }
  893.            Push(Pc, _CASE, 2);
  894.            Ow(0);
  895.          END;
  896.        END;
  897.   { >OF }
  898.   138: BEGIN
  899.          CLitflag := FALSE;
  900.          Inc(OFCnt);
  901.          Ob($3D); Ow(CaseLit);   { cmp ax,n }
  902.          IF ShortFlag THEN BEGIN
  903.            Ob($7E);            { jng disp    }
  904.            Push(Pc, _CASE, 1);
  905.            Ob(0);
  906.          END ELSE BEGIN
  907.            Ob($7F); Ob(3);     { jg  +3      }
  908.            Ob($E9);            { jmp disp    }
  909.            Push(Pc, _CASE, 2);
  910.            Ow(0);
  911.          END;
  912.        END;
  913.   { <OF }
  914.   139: BEGIN
  915.          CLitflag := FALSE;
  916.          Inc(OFCnt);
  917.          Ob($3D); Ow(CaseLit);   { cmp ax,n }
  918.          IF ShortFlag THEN BEGIN
  919.            Ob($7D);              { jnl disp    }
  920.            Push(Pc, _CASE, 1);
  921.            Ob(0);
  922.          END ELSE BEGIN
  923.            Ob($7C); Ob(3);     { jl  +3      }
  924.            Ob($E9);            { jmp disp    }
  925.            Push(Pc, _CASE, 2);
  926.            Ow(0);
  927.          END;
  928.        END;
  929.   { ENDOF, ;; }
  930.   140: BEGIN
  931.          Adr := Pop(_CASE, Len);
  932.          IF Len = 1 THEN BEGIN
  933.            M^[Adr] := Short(Adr, Pc + 2);
  934.            Ob($EB);  { jmp disp }
  935.            Push(Pc, _CASE, 1);
  936.            Ob(0);
  937.          END ELSE BEGIN
  938.            Ot(Adr, Near(Adr, Pc + 3));
  939.            Ob($E9);  { jmp  disp }
  940.            Push(Pc, _CASE, 2);
  941.            Ow(0);
  942.          END;
  943.          CLitflag := TRUE;
  944.        END;
  945.   { ENDCASE }
  946.   141: BEGIN
  947.          FOR i := 1 TO OFCnt DO BEGIN
  948.            Adr := Pop(_CASE, Len);
  949.            IF Len = 1 THEN
  950.              M^[Adr] := Short(Adr, Pc)
  951.            ELSE
  952.              Ot(Adr, Near(Adr, Pc));
  953.          END; { for }
  954.          OFCnt := 0;
  955.          CaseFlag := FALSE;
  956.          CLitflag := FALSE;
  957.        END;
  958.   { MACRO }
  959.   142: Macro := 64;
  960.   { -MACRO }
  961.   143: Macro := MacroLim;
  962.   { FIND }
  963.   144: BEGIN
  964.          w := HoleWort;
  965.          IF NOT Found THEN Error(4);
  966.          TueLiteral(PAR0);
  967.        END;
  968.   { BEGIN }
  969.   145: Push(Pc, _BEGIN, 0);
  970.   { UNTIL }
  971.   146: BEGIN
  972.          Adr := Pop(_BEGIN, Len);
  973.          Branch0(Adr);
  974.        END;
  975.   { WHILE }
  976.   147: IF ShortFlag THEN BEGIN
  977.          Ob($73);             { jnc  disp }
  978.          Push(Pc, _WHILE, 1);
  979.          Ob(0);
  980.        END ELSE BEGIN
  981.          Ob($72); Ob(03);     { jc   +3   }
  982.          Ob($E9);             { jmp  disp }
  983.          Push(Pc, _WHILE, 2);
  984.          Ow(0);
  985.        END;
  986.   { REPEAT }
  987.   148: BEGIN
  988.          Adr1 := Pop(_WHILE, Len);
  989.          Adr := Pop(_BEGIN, Dis);
  990.          Branch(Adr);
  991.          IF Len = 1 THEN
  992.            M^[Adr1] := Short(Adr1, Pc)
  993.          ELSE
  994.            Ot(Adr1, Near(Adr1, Pc));
  995.        END;
  996.   { AGAIN }
  997.   149: BEGIN
  998.          Adr := Pop(_BEGIN, Dis);
  999.          Branch(Adr);
  1000.        END;
  1001.   { DO }
  1002.   150: BEGIN
  1003.          Ob($55);                { push bp    }
  1004.          Ob($51);                { push cx    }
  1005.          Ob($89); Ob($C5);       { mov  bp,ax }
  1006.          Ob($89); Ob($D1);       { mov  cx,dx }
  1007.          Push(Pc, _DO, 0);
  1008.        END;
  1009.   { LOOP }
  1010.   151: BEGIN
  1011.          Ob($41);                { inc cx    }
  1012.          Ob($39); Ob($E9);       { cmp cx,bp }
  1013.          Adr := Pop(_DO, Len);
  1014.          nn := Near(Pc, Adr);
  1015.          IF Abs(nn) < 128 THEN BEGIN
  1016.            Ob($7E); Ob(nn);   { jle adr   }
  1017.          END ELSE BEGIN
  1018.            Ob($7F); Ob(03);     { jg  +3    }
  1019.            Ob($E9); Ow(nn-3);   { jmp adr   } 
  1020.          END; 
  1021.          Ob($59);               { pop cx    }
  1022.          Ob($5D);               { pop BP    }
  1023.        END;
  1024.   { +LOOP }
  1025.   152: BEGIN
  1026.          Ob($03); Ob($C8);        { add cx,ax }
  1027.          Ob($39); Ob($E9);        { cmp cx,bp }
  1028.          Adr := Pop(_DO, Len);
  1029.          nn := Near(Pc, Adr);
  1030.          IF Abs(nn) < 128 THEN BEGIN
  1031.            Ob($7E); Ob(nn);       { jle adr   }
  1032.          END ELSE BEGIN
  1033.            Ob($7F); Ob(03);       { jg  +3    }
  1034.            Ob($E9); Ow(nn-3);     { jmp adr   }  
  1035.          END; 
  1036.          Ob($59);                 { pop cx    }
  1037.          Ob($5D);                 { pop bp    }
  1038.        END;
  1039.   { -LOOP }
  1040.   153: BEGIN
  1041.          Ob($29); Ob($C1);        { sub cx,ax }
  1042.          Ob($39); Ob($E9);        { cmp cx,BP }
  1043.          Adr := Pop(_DO, Len);
  1044.          nn := Near(Pc, Adr);
  1045.          IF Abs(nn) < 128 THEN BEGIN { ** geändert 3.6.89 ** }
  1046.             Ob($7D); Ob(nn);      { jge adr   }
  1047.          END ELSE BEGIN
  1048.            Ob($7C); Ob(03);       { jl  +3    }
  1049.            Ob($E9); Ow(nn - 3);   { jmp adr   } { KP 12.5.91 }
  1050.          END; 
  1051.          Ob($59);                 { pop cx    }
  1052.          Ob($5D);                 { pop BP    }
  1053.        END;
  1054.   { /LOOP }
  1055.   154: BEGIN
  1056.          Adr := Pop(_DO, Len);
  1057.          Ob($03); Ob($C8);            { add  cx,ax }
  1058.          Ob($85); Ob($C0);            { test ax,ax }
  1059.          Ob($79); Ob($07);            { jns  disp  }
  1060.          Ob($39); Ob($E9);            { cmp  cx,bp }
  1061.          Ob($7C); Ob($0A);            { jl   +10   }
  1062.          Ob($E9); Ow(Near(Pc, Adr));  { jmp  adr   }
  1063.          Ob($39); Ob($E9);            { cmp  cx,bp }
  1064.          Ob($7F); Ob(03);             { jg   +3    }
  1065.          Ob($E9); Ow(Near(Pc, Adr));  { jmp  adr   }
  1066.          Ob($59);                     { pop  cx    }
  1067.          Ob($5D);                     { pop  bp    }
  1068.        END;
  1069.   { " }
  1070.   155: TueStringLiteral;
  1071.   { ." }
  1072.   156: BEGIN
  1073.          TueStringLiteral;
  1074.          w := 'TYPE';
  1075.          IF NOT Suche(w) THEN Error(4);
  1076.          Ob($8A); Ob($07);  { mov al,[bx] }
  1077.          Ob($B4); Ob($00);  { mov ah,00   }
  1078.          Ob($43);           { inc bx }
  1079.          Ob($BF); Ow(PAR0); { mov di,[pfa] }
  1080.          Ob($FF); Ob($D7);  { call di }
  1081.        END;
  1082.   { RECLEN }
  1083.   157: BEGIN Ob($B8); Ow(RecLen); END;
  1084.   { OFFSET }
  1085.   158: BEGIN
  1086.          w := HoleWort;
  1087.          IF w = Empty THEN Error(7);
  1088.          Val(w, nn, Fehlern);
  1089.          IF Fehlern <> 0 THEN Error(7);
  1090.          Ob($81); Ob($C3); Ow(nn);  { add bx,nn }
  1091.        END;
  1092.   { (short) }
  1093.   174 : ShortFlag := TRUE;
  1094.   { (long) }
  1095.   175 : ShortFlag := FALSE;
  1096.   { Schweifklammer auf }
  1097.   184: BEGIN
  1098.          Flagstack := TRUE;
  1099.          Ob($55);  { push bp }
  1100.        END;
  1101.   { Schweifklammer zu }
  1102.   185: BEGIN
  1103.          Flagstack := FALSE;
  1104.          Ob($5D);   { pop bx }
  1105.        END;
  1106.   { PUSHF }
  1107.   187: BEGIN
  1108.          IF Flagstack = TRUE THEN BEGIN
  1109.            Ob($D1); Ob($D5); { rcl bp,1 }
  1110.          END;
  1111.        END;
  1112.   { MAKE }
  1113.   160: BEGIN
  1114.          w := HoleWort;
  1115.          IF w = Empty THEN Error(2);
  1116.          IF NOT Found THEN Error(4);
  1117.          Adr1 := PAR0;
  1118.          IF WTyp <> _VECTOR THEN Error(29);
  1119.          w := HoleWort;
  1120.          IF w = Empty THEN Error(2);
  1121.          IF NOT Found THEN Error(4);
  1122.          IF WTyp <> _PROC THEN Error(30);
  1123.          Adr2 := PAR0;
  1124.          Ob($BB); Ow(Adr1);         { mov bx,adr1  }
  1125.          Ob($C6); Ob($07); Ob($E9); { mov [bx],$E9 }
  1126.          Ob($43);                   { inc bx       }
  1127.          Ob($C7); Ob($07);          { mov [bx],cfa }
  1128.          Ow(Near(Adr1, Adr2) - 1);
  1129.        END;
  1130.     ELSE Sys := FALSE;
  1131.   END ELSE Sys := FALSE;
  1132. END;
  1133.  
  1134. PROCEDURE CopyMacro(Strt,Len:WORD);
  1135. { Kopiere len Bytes von cfa nach pc }
  1136. VAR
  1137.   i: WORD;
  1138. BEGIN
  1139.   i := 0;
  1140.   WHILE i < Len  DO BEGIN
  1141.     Ob(M^[Strt]);
  1142.     Inc(Strt);
  1143.     i := i + 1;
  1144.   END;
  1145. END;
  1146.  
  1147. PROCEDURE DoCompile;
  1148. { Compiliere bis Semikolon }
  1149. VAR
  1150.   Len, Adr : WORD;
  1151.   Disp,
  1152.   Fehler   : INTEGER;
  1153.   w        : WortTyp;
  1154.   sxx      : BOOLEAN;
  1155. LABEL
  1156.   Ok;
  1157. BEGIN
  1158.   REPEAT
  1159.     w := HoleWort;
  1160.     IF (WTyp = 181) OR (WTyp = 161) THEN Error(44);
  1161.     IF w = Empty THEN Error(2);
  1162.     TueSystem(w);
  1163.     IF Sys THEN RegFix := 0;
  1164.     IF WTyp = 130 THEN BEGIN
  1165.       RegFix := 2;
  1166.       GOTO Ok;
  1167.     END;
  1168.     IF WTyp = 131 THEN BEGIN
  1169.       RegFix := 3;
  1170.       GOTO Ok;
  1171.     END;
  1172.     IF WTyp = 170 THEN BEGIN
  1173.       RegFix := 1;
  1174.       GOTO Ok;
  1175.     END;
  1176.     IF WTyp = 186 THEN BEGIN
  1177.       RegFix := 4;
  1178.       GOTO Ok;
  1179.     END;
  1180.     IF Sys THEN GOTO Ok;
  1181.  
  1182.     { in Dictionary suchen }
  1183.  
  1184.     IF NOT Found THEN Error(4);
  1185.  
  1186.     IF RegFix <> 0 THEN BEGIN
  1187.       sxx := TRUE;
  1188.       CASE WTyp OF
  1189.         _CONST  : TueLiteral(PAR0);
  1190.         _DCONST : TueDLiteral(PAR0, PAR1);
  1191.         _FCONST : TueFLiteral(PAR0, PAR1, PAR2, PAR3);
  1192.          ELSE IF RegFix <> 4 THEN TueLiteral(PAR0)
  1193.       ELSE BEGIN
  1194.         RegFix := 0;
  1195.         sxx    := FALSE;
  1196.       END;
  1197.     END;
  1198.     IF sxx = TRUE THEN GOTO Ok;
  1199.   END;
  1200.  
  1201.   { Konstante? }
  1202.   IF WTyp = _CONST THEN BEGIN
  1203.     RegFix := 1;
  1204.     TueLiteral(PAR0);
  1205.     GOTO Ok;
  1206.   END;
  1207.   IF WTyp = _DCONST THEN BEGIN
  1208.     RegFix := 1;
  1209.     TueDLiteral(PAR0, PAR1);
  1210.     GOTO Ok;
  1211.   END;
  1212.   IF WTyp = _FCONST THEN BEGIN
  1213.     TueFLiteral(PAR0, PAR1, PAR2, PAR3);
  1214.     GOTO Ok;
  1215.   END;
  1216.  
  1217.   RegFix := 0;
  1218.  
  1219.   { KOLON ? }
  1220.   IF (WTyp = _KOLON) AND (PAR1 < Macro) THEN BEGIN
  1221.     CopyMacro(PAR0, PAR1 - 1);
  1222.     GOTO Ok;
  1223.   END;
  1224.  
  1225.   { DATENSTRUKTUR? }
  1226.   IF WTyp < 10 THEN BEGIN
  1227.     RecLen := PAR1;
  1228.     Ob($BB); Ow(PAR0);  { mov bx,adr }
  1229.     IF WTyp > 4 THEN GOTO Ok;
  1230.     IF PAR2 = 0 THEN GOTO Ok;
  1231.     CopyMacro(PAR2, PAR3 - 1);
  1232.     GOTO Ok;
  1233.   END;
  1234.     
  1235.   { sonst Vector oder Prozedur }
  1236.   Ob($BF); Ow(PAR0); { mov di,cfa }
  1237.   Ob($FF); Ob($D7);  { call di    }
  1238.  
  1239. Ok:
  1240.   UNTIL WTyp = 128;
  1241. END;
  1242.  
  1243. PROCEDURE TueKolon;
  1244. { Colon-Definition compilieren }
  1245. VAR
  1246.   w      : WortTyp;
  1247.   Fehler : INTEGER;
  1248.   cfa1   : WORD;
  1249.   Merker : PSYMTAB;
  1250. BEGIN
  1251.   TueName;        { Header bauen }
  1252.   InDef       := TRUE;
  1253.   Zeiger^.Typ := _KOLON;
  1254.   Merker      := Zeiger;
  1255.   IF Main THEN BEGIN
  1256.     Ot($0102, Pc);
  1257.     Mn := Pc;
  1258.   END;
  1259.   PcMerker := Pc;
  1260.   DoCompile;
  1261.   Merker^.PAR0 := PcMerker;      { cfa }
  1262.   Merker^.PAR1 := Pc - PcMerker; { LEN eintragen }
  1263.   TueLink;
  1264.   InDef := FALSE;
  1265. END;
  1266.  
  1267. PROCEDURE TueProc;
  1268. { Prozedur compilieren }
  1269. VAR
  1270.   w      : WortTyp;
  1271.   Fehler : INTEGER;
  1272.   cfa1   : WORD;
  1273.   Merker : pSymtab;
  1274. BEGIN
  1275.   TueName;        { Header bauen }
  1276.   InDef       := TRUE;
  1277.   Zeiger^.Typ := _PROC;
  1278.   Merker      := Zeiger;
  1279.   IF Main THEN BEGIN
  1280.     Ot($100, $E9);
  1281.     Ot($0101, Pc);
  1282.     Mn := Pc;
  1283.   END;
  1284.  
  1285.   PcMerker := Pc;
  1286.   DoCompile;
  1287.   Merker^.PAR0 := PcMerker;      { CFA-eintragen }
  1288.   Merker^.PAR1 := Pc - PcMerker; { LEN eintragen }
  1289.   TueLink;
  1290.   InDef := FALSE;
  1291. END;
  1292.  
  1293. PROCEDURE TueVariable;
  1294. { Baue Datenstruktur auf }
  1295. LABEL
  1296.   Ok;
  1297. VAR
  1298.   w              : WortTyp;
  1299.   n, Fehler,opa0,
  1300.   opa1,opa2      : INTEGER;
  1301.   DMerker        : PSYMTAB;
  1302.  
  1303.   PROCEDURE TueString;
  1304.   { String-Definition compilieren }
  1305.   VAR
  1306.     z         : CHAR;
  1307.     n, Fehler : INTEGER;
  1308.     w         : WortTyp;
  1309.   BEGIN
  1310.     Zeiger^.Typ := _STRING;
  1311.     DMerker     := Zeiger;
  1312.     { in Codebereich: }
  1313.     PcMerker    := Pc;
  1314.     Ob(0);                             { maxcount }
  1315.     Ob(0);                             { Countinit 0 }
  1316.     DMerker^.PAR0 := PcMerker + 1;     { par0 }
  1317.     IF Merker = 'STRING' THEN BEGIN
  1318.       w := HoleWort;
  1319.       IF WTyp <> 10 THEN Error(7);     { Zahl erwartet }
  1320.       IF PAR0 > 255 THEN Error(35);    { String zu groß }
  1321.       Pc := Pc + PAR0 + 1;
  1322.     END ELSE BEGIN                     { Stringliteral }
  1323.       z := HoleZeichen;
  1324.       IF z = Empty THEN Error(43);     { Stringende fehlt }
  1325.       n := 0;
  1326.       WHILE (z <> '"') AND (z <> Empty) DO BEGIN
  1327.         Ob(Ord(z));
  1328.         z := HoleZeichen;
  1329.         IF n > 255 THEN Error(43);     { Stringende fehlt }
  1330.         Inc(n);
  1331.       END;
  1332.       Ob(0);   { Abschlussbyte }
  1333.       Otb(PcMerker + 1, Lo(n));        { count }
  1334.     END;
  1335.     Otb(PcMerker,Lo(n));               { maxcount }
  1336.     DMerker^.PAR1 := n;
  1337.   END;
  1338.  
  1339.   PROCEDURE TueVarInit ;
  1340.   { Initialisiere Datenstruktur }
  1341.   VAR
  1342.     w               : WortTyp;
  1343.     n, Fehler, Count: WORD;
  1344.  
  1345.     FUNCTION Eval(wo: WortTyp): WORD;
  1346.     VAR
  1347.       t: WORD;
  1348.     BEGIN
  1349.        IF Suche(wo) THEN Eval := PAR0
  1350.                     ELSE Error(7);
  1351.     END;
  1352.  
  1353.   BEGIN
  1354.     DMerker^.PAR2 := 0; { cfa }
  1355.     DMerker^.PAR3 := 0; { codlen }
  1356.     IF Odd(Pc) THEN Pc := Pc + 1;
  1357.     DMerker^.PAR0 := Pc;
  1358.     w             := HoleWort;
  1359.     IF w = Empty THEN Error(7);
  1360.     Count := 0;
  1361.     REPEAT
  1362.       n := Eval(w);
  1363.       Inc(Count);
  1364.       w := HoleWort;
  1365.       IF NOT (( w = ',') OR ( w = 'C,')) THEN Error(43);
  1366.       IF w = ',' THEN BEGIN
  1367.         Inc(Count);
  1368.         Ow(n);
  1369.       END ELSE Ob(Lo(n));
  1370.       w := HoleWort;
  1371.     UNTIL w = ']';
  1372.     DMerker^.PAR1 := Count;
  1373.   END;
  1374.  
  1375.   PROCEDURE TueVarDo;
  1376.   { Compiliere DO: code in VAR }
  1377.   BEGIN
  1378.     PcMerker := Pc;
  1379.     DMerker^.PAR2 := Pc;          { cfa }
  1380.     IF opa2<>0 THEN BEGIN
  1381.       Ob($BF); Ow(opa2);          { mov di,cfa }
  1382.       Ob($FF); Ob($D7);           { call di    }
  1383.     END;
  1384.     DoCompile;
  1385.     DMerker^.PAR3 := Pc - PcMerker; { codlen }
  1386.   END;
  1387.  
  1388. BEGIN  (* TueVariable *)
  1389.   TueName;
  1390.   Zeiger^.Typ := _VAR;
  1391.   DMerker     := Zeiger;
  1392.   w           := HoleWort;
  1393.   IF w = Empty THEN Error(7);
  1394.   IF (WTyp=155) OR (WTyp=164) THEN BEGIN
  1395.     Merker := w;
  1396.     TueString;
  1397.     TestSemi;
  1398.     GOTO Ok;
  1399.   END;
  1400.   IF WTyp = 129 THEN BEGIN
  1401.     TueVarInit;
  1402.     TestSemi;
  1403.     GOTO Ok;
  1404.   END;
  1405.   IF NOT (WTyp = _VAR) THEN Error(36);
  1406.   DMerker^.PAR0 := 0;
  1407.   DMerker^.PAR1 := PAR1;
  1408.   DMerker^.PAR2 := PAR2;
  1409.   DMerker^.PAR3 := PAR3;
  1410.  
  1411.   IF Odd(Pc) THEN Pc := Pc + 1;
  1412.   opa0 := PAR0;
  1413.   opa1 := PAR1;
  1414.   opa2 := PAR2;
  1415.   w := HoleWort;
  1416.   DMerker^.PAR0 := Pc;
  1417.   IF (w = ';') OR (w = 'DO:') THEN BEGIN
  1418.     CopyMacro(opa0, opa1);  { Datenzellen übertragen }
  1419.   END ELSE BEGIN
  1420.     Val(w, n, Fehler);
  1421.     IF Fehler <> 0 THEN Error(7); { Zahl erwartet }
  1422.     DMerker^.PAR1 := opa1 * n;
  1423.     Pc            := Pc + opa1 * n;
  1424.     w             := HoleWort;
  1425.   END;
  1426.   IF w = 'DO:' THEN BEGIN
  1427.     TueVarDo;
  1428.     GOTO Ok; 
  1429.   END;
  1430.   IF WTyp <> 128 THEN Error(41);
  1431. Ok:
  1432.   TueLink;
  1433. END;
  1434.  
  1435. PROCEDURE TueKonstante;
  1436. { Konstanten-Definition compilieren }
  1437. VAR
  1438.   w: WortTyp;
  1439. BEGIN
  1440.   TueName;         { Header bauen }
  1441.   Zeiger^.Typ := _CONST;
  1442.   w := HoleWort;
  1443.   IF WTyp <> _CONST THEN Error(7);
  1444.   Zeiger^.PAR0 := PAR0;
  1445.   TestSemi;
  1446.   TueLink;
  1447. END;
  1448.  
  1449. PROCEDURE TueDKonstante;
  1450. { Konstanten-Definition compilieren }
  1451. VAR
  1452.   w: WortTyp;
  1453. BEGIN
  1454.   TueName;         { Header bauen }
  1455.   Zeiger^.Typ := _DCONST;
  1456.   w := HoleWort;
  1457.   IF (WTyp <> _DCONST) AND (WTyp <> _CONST) THEN Error(7);
  1458.   Zeiger^.PAR0 := PAR0;
  1459.   Zeiger^.PAR1 := PAR1;
  1460.   TestSemi;
  1461.   TueLink;
  1462. END;
  1463.  
  1464. PROCEDURE TueFKonstante;
  1465. { Konstanten-Definition compilieren }
  1466. VAR
  1467.   w: WortTyp;
  1468. BEGIN
  1469.   TueName;         { Header bauen }
  1470.   Zeiger^.Typ := _FCONST;
  1471.   w := HoleWort;
  1472.   IF WTyp <> _FCONST THEN Error(7);
  1473.   Zeiger^.PAR0 := PAR0;
  1474.   Zeiger^.PAR1 := PAR1;
  1475.   Zeiger^.PAR2 := PAR2;
  1476.   Zeiger^.PAR3 := PAR3;
  1477.   TestSemi;
  1478.   TueLink;
  1479. END;
  1480.  
  1481. PROCEDURE TueVektor;
  1482. { Vector-Definition compilieren }
  1483. VAR
  1484.   w: WortTyp;
  1485. BEGIN
  1486.   TueName;            { Header bauen }
  1487.   Zeiger^.Typ  := _VECTOR;
  1488.   Zeiger^.PAR0 := Pc; { cfa }
  1489.   Zeiger^.PAR1 := 5;  { len }
  1490.   Ob($C3);            { ret , Initialwert für Dummy Wort }
  1491.   Ow($00);            { Dummy für Jump-Adresse }
  1492.   TestSemi;
  1493.   TueLink;
  1494. END;
  1495.  
  1496. PROCEDURE TueMake;
  1497. VAR
  1498.   w        : WortTyp;
  1499.   Adr1,
  1500.   Adr2,
  1501.   Typ      : INTEGER;
  1502.   Gefunden : BOOLEAN;
  1503. BEGIN
  1504.   w := HoleWort;
  1505.   IF w = Empty THEN Error(4);
  1506.   IF NOT Found THEN Error(4);
  1507.   Adr1 := PAR0;
  1508.   IF WTyp <> _VECTOR THEN Error(29);
  1509.   w := HoleWort;
  1510.   IF w = Empty THEN Error(4);
  1511.   IF NOT Found THEN Error(4);
  1512.   Adr2 := PAR0;
  1513.   IF WTyp <> _PROC THEN Error(30);
  1514.   Otb(Adr1, $E9);                       { jmp disp }
  1515.   Ot(Succ(Adr1), Pred(Near(Adr1, Adr2)));
  1516. END;
  1517.  
  1518. PROCEDURE TueLabel;
  1519. VAR
  1520.   w        : WortTyp;
  1521.   Adr1,
  1522.   Adr2,
  1523.   Typ      : INTEGER;
  1524.   Gefunden : BOOLEAN;
  1525.   pfa      : WORD;
  1526. BEGIN
  1527.   TueName;
  1528.   Zeiger^.Typ := _VECTOR;
  1529.   w := HoleWort;
  1530.   IF w = Empty THEN Error(4);
  1531.   IF WTyp <> _PROC THEN Error(30);
  1532.   w := HoleWort;
  1533.   IF WTyp <> 10 THEN Error(7);
  1534.   pfa := Zeiger^.PAR0 + PAR0;
  1535.   Ob($E9);                  { jump }
  1536.   Ow(pfa - Pc - 2);         { disp }
  1537.   TueLink;
  1538. END;
  1539.  
  1540. PROCEDURE TueMlimit;
  1541. VAR
  1542.   w: WortTyp;
  1543. BEGIN
  1544.   w := HoleWort;
  1545.   IF WTyp <> 10 THEN Error(7);
  1546.   IF PAR0 <   7 THEN PAR0 := 7;
  1547.   IF PAR0 >  64 THEN PAR0 := 64;
  1548.   MacroLim := PAR0;
  1549.   Macro    := PAR0;
  1550. END;
  1551.  
  1552. PROCEDURE SichereVoc;
  1553. { aktuelles Vocabulary sichern }
  1554. VAR
  1555.   v   : FILE;
  1556.   nam : WortTyp;
  1557.   gri : WORD;
  1558.  
  1559.   PROCEDURE SV(Ptr: PSYMTAB);
  1560.   BEGIN
  1561.     BlockWrite(v, Ptr^, gri);
  1562.     IF Ptr^.LLink <> NIL THEN SV(Ptr^.LLink);
  1563.     IF Ptr^.RLink <> NIL THEN SV(Ptr^.RLink);
  1564.   END;
  1565.  
  1566. BEGIN
  1567.   gri := SizeOf(Root^) - 8;
  1568.   nam := Name + '.DIC';
  1569.   Assign(v, Pfad + nam);
  1570.   ReWrite(v, 1);
  1571.   BlockWrite(v, Pc, 2);
  1572.   SV(Root);
  1573.   Close(v);
  1574. END;
  1575.  
  1576. PROCEDURE TueInclude;
  1577. { Vocabulary einbinden }
  1578. VAR
  1579.   Name, nam : WortTyp;
  1580.   v         : FILE;
  1581.   x, p1, p2 : PSYMTAB;
  1582.   gr, gri   : WORD;
  1583. BEGIN
  1584.   gri := SizeOf(Root^) - 8;
  1585.   IF Includeflag = FALSE THEN Error(38); { nur ein Include }
  1586.   Includeflag := FALSE;
  1587.   nam         := HoleWort;
  1588.   IF nam = Empty THEN Error(2);
  1589.   Name        := nam + '.DIC';
  1590.   Assign(v, Pfad + Name);
  1591.   {$I-} Reset(v, 1); {$I+}
  1592.   IF IOResult <> 0 THEN Error(25);
  1593.   BlockRead(v, gr, 2);
  1594.   REPEAT
  1595.     New(x);
  1596.     BlockRead(v, x^, gri);
  1597.     x^.RLink := NIL;
  1598.     x^.LLink := NIL;
  1599.     p1 := Root;
  1600.     REPEAT
  1601.       p2 := p1;
  1602.       IF x^.Name > p1^.Name THEN p1 := p1^.RLink
  1603.                             ELSE p1 := p1^.LLink;
  1604.     UNTIL p1 = NIL;
  1605.     IF x^.Name > p2^.Name THEN p2^.RLink := x
  1606.                           ELSE p2^.LLink := x;
  1607.   UNTIL EoF(v);
  1608.   Name := nam + '.COM';
  1609.   Assign(v, Pfad + Name);
  1610.   {$I-} Reset(v, 1); {$I+}
  1611.   IF IOResult <> 0 THEN Error(25);
  1612.   BlockRead(v, M^[$100], gr - $100);
  1613.   Pc := gr;
  1614.   Close(v);
  1615. END;
  1616.  
  1617. PROCEDURE MemSizes;
  1618. VAR
  1619.   w : WortTyp;
  1620. BEGIN
  1621.   w := HoleWort;
  1622.   IF WTyp <> 10 THEN Error(7);
  1623.   r0 := PAR0;
  1624.   w  := HoleWort;
  1625.   IF WTyp <> 10 THEN Error(7);
  1626.   s0 := PAR0;
  1627.   IF s0 < 80 THEN s0 := 80;
  1628.   w  := HoleWort;
  1629.   IF WTyp <> 179 THEN Error(1);
  1630. END;
  1631.  
  1632. PROCEDURE Compile(w: WortTyp);
  1633. BEGIN
  1634.   CASE WTyp OF
  1635.   181 : TueKolon;
  1636.   161 : TueProc;
  1637.   162 : TueKonstante;
  1638.   191 : TueDKonstante;
  1639.   192 : TueFKonstante;
  1640.   163 : TueVariable;
  1641.   165 : TueVektor;
  1642.   166 : TueLabel;
  1643.   167 : TueInclude;
  1644.   168 : TueSeal;
  1645.   169 : TueMlimit;
  1646.   160 : TueMake;
  1647.   173 : SichereVoc;
  1648.   174 : ShortFlag := TRUE;
  1649.   175 : ShortFlag := FALSE;
  1650.   190 : MemSizes;
  1651.   ELSE Error(1);
  1652.   END; {case}
  1653. END;
  1654.  
  1655. PROCEDURE DoMap(Ptr:PSYMTAB);
  1656. VAR
  1657.   p1   : pSymtab;
  1658.   n    : STRING;
  1659.   Typ  : BYTE;
  1660.   Adr  : WORD;
  1661.   Used : BYTE;
  1662. BEGIN
  1663.   IF Ptr^.LLink <> NIL THEN DoMap(Ptr^.LLink);
  1664.   IF (Ptr^.Typ < 15) AND (Ptr^.Typ <> 10) THEN
  1665.    IF NOT (Ptr^.Name[BYTE(Ptr^.Name[0])] = #0) THEN
  1666.      WriteLn(ef, ' 0000:', Hex(Ptr^.PAR0, 4),
  1667.              '       ', Ptr^.Name);
  1668.   IF Ptr^.RLink <> NIL THEN DoMap(Ptr^.RLink);
  1669. END;
  1670.  
  1671. BEGIN (* Hauptprogramm *)
  1672.   New(M);
  1673.   New(IFB);
  1674.   Init;
  1675.  
  1676.   { Startcode }
  1677.  
  1678.   Ob($EB); Ob($3E);        { jmp 140            }
  1679.  
  1680.   { Compiler-Bereich }
  1681.  
  1682.   Ow($0000);     { adr $102: MAIN }
  1683.   Ow($0000);     { adr $104: r0   }
  1684.   Ow($FE00);     { adr $106: s0   }
  1685.   Ow($0000);     { adr $108: dp   }
  1686.   Ow($0000);     { adr $10A: frei }
  1687.   Ow($0000);     { adr $10C: frei }
  1688.   Ow($0000);     { adr $10E: frei }
  1689.  
  1690.   { Copyright-Notiz }
  1691.  
  1692.   Ob(13); Ob(10);
  1693.   Os('Naxos-Compiler, Version 1.01 ß/1992 ');
  1694.   Ob(13); Ob(10); Ob(26);
  1695.   Ot($134, 0);                        { Video+MouseByte  Init     }
  1696.   Pc := $13D;                         { Codeanfang      }
  1697.  
  1698.   { Debug- und Overlay-Einsprung }
  1699.   Ob($FF); Ob($D7);                   { call di         }
  1700.   Ob($CB);                            { retf            }
  1701.  
  1702.   { pc = $140: Register retten }
  1703.   Ob($2E); Ob($8C); Ob($1E); Ow($0122);  { mov cs:[122],ds }
  1704.   Ob($2E); Ob($A3); Ow($0110);           { mov cs:[110],ax }
  1705.   Ob($8C); Ob($C8);                      { mov ax,cs       }
  1706.   Ob($8E); Ob($D8);                      { mov ds,ax       }
  1707.   Ob($FA);                               { cli             }
  1708.   Ob($8C); Ob($16); Ow($0126);           { mov [126],ss    }
  1709.   Ob($89); Ob($26); Ow($0118);           { mov [118],sp    }
  1710.   Ob($8C); Ob($06); Ow($0124);           { mov [124],es    }
  1711.   Ob($89); Ob($1E); Ow($0116);           { mov [116],bx    }
  1712.   Ob($5B);                               { pop bx          }
  1713.   Ob($58);                               { pop ax          }
  1714.   Ob($50);                               { push ax         }
  1715.   Ob($53);                               { push bx         }
  1716.   Ob($A3); Ow($0120);                    { mov [110],ax    }
  1717.   Ob($89); Ob($0E); Ow($0112);           { mov [112],cx    }
  1718.   Ob($89); Ob($16); Ow($0114);           { mov [114],dx    }
  1719.   Ob($89); Ob($2E); Ow($011A);           { mov [11A],bp    }
  1720.   Ob($89); Ob($36); Ow($011C);           { mov [11C],si    }
  1721.   Ob($89); Ob($3E); Ow($011E);           { mov [11E],di    }
  1722.   Ob($9C);                               { pushf           }
  1723.   Ob($58);                               { pop ax          }
  1724.   Ob($A3); Ow($0128);                    { mov [128],ax    }
  1725.   Ob($FB);                               { sti             }
  1726.  
  1727.   { INT0 retten }
  1728.   Ob($B8); Ow($3500);                    { mov ax,3500     }
  1729.   Ob($CD); Ob($21);                      { int 21          }
  1730.   Ob($89); Ob($1E); Ow($0130);           { mov [130],bx    }
  1731.   Ob($8C); Ob($06); Ow($0132);           { mov [132],es    }
  1732.  
  1733.   { Videomode retten }
  1734.   Ob($B4); Ob($0F);                      { mov ah,0F       }
  1735.   Ob($CD); Ob($10);                      { int 10          }
  1736.   Ob($2E); Ob($A2); Ow($0134);           { mov cs:[134],al }
  1737.  
  1738.   { Stackmaschine bauen }
  1739.   Ob($FA);                               { cli             }
  1740.   Ob($8C); Ob($C8);                      { mov ax,cs       }
  1741.   Ob($8E); Ob($D8);                      { mov ds,ax       }
  1742.   Ob($8E); Ob($D0);                      { mov ss,ax       }
  1743.   Ob($31); Ob($DB);                      { xor bx,bx       }
  1744.   Ob($FC);                               { cld             }
  1745.   Ob($8B); Ob($26); Ow($0104);           { mov sp,[104]    }
  1746.   Ob($8B); Ob($36); Ow($0106);           { mov si,[106]    }
  1747.   Ob($FB);                               { sti             }
  1748.  
  1749.   { MAIN aufrufen }
  1750.   Ob($8B); Ob($3E); Ow($0102);           { mov di,[102]    }
  1751.   Ob($FF); Ob($D7);                      { call di         }
  1752.  
  1753.   { EXIT-Code: }
  1754.  
  1755.   { Videomode restaurieren }
  1756.   Ob($A0); Ow($0134);                    { mov al,[134]    }
  1757.   Ob($B4); Ob($00);                      { mov ah,00       }
  1758.   Ob($CD); Ob($10);                      { int 10          }
  1759.  
  1760.   Ot($102, Pc);                          { IF NO MAIN      }
  1761.  
  1762.   { INT0 restaurieren }
  1763.   Ob($B8); Ow($2500);                    { mov ax,2500     }
  1764.   Ob($8B); Ob($1E); Ow($0130);           { mov bx,[130]    }
  1765.   Ob($8E); Ob($06); Ow($0132);           { mov es,[132]    }
  1766.   Ob($CD); Ob($21);                      { int 21          }
  1767.  
  1768.   { Exit }
  1769.   Ob($B4); Ob($4C);                      { mov ah,4C       }
  1770.   Ob($A0); Ow($0135);                    { mov al,[135]    }
  1771.   Ob($CD); Ob($21);                      { int 21          }
  1772.  
  1773.   { ... Haupt-Programm verabschiedet }
  1774.  
  1775.   { Compilieren }
  1776.   Wort := HoleWort;
  1777.   IF Wort = Empty THEN GOTO OkMcc;
  1778.   WHILE (Wort <> Empty)  DO BEGIN
  1779.     Compile(Wort);
  1780.     Wort := HoleWort;
  1781.   END;
  1782.   OkMcc:
  1783.  
  1784.   { Compiler-Variablen setzen }
  1785.   Ot($108, Pc);   { Dictionary-Pointer    }
  1786.   IF (r0 <> $FFFF) OR (s0 <> $FFFF) THEN BEGIN
  1787.     IF Odd(Pc) THEN Inc(Pc);
  1788.     s0 := Pc + s0 + 2;
  1789.     r0 := s0 + r0 + 2;
  1790.     Ot($104, r0);
  1791.     Ot($106, s0);
  1792.   END;
  1793.  
  1794.   { COM-File erzeugen }
  1795.   IF NoCodeFlag = FALSE THEN BEGIN
  1796.     Assign(Outfile,Pfad + Name + '.COM');
  1797.     ReWrite(Outfile, Pc - 256);
  1798.     BlockWrite(Outfile, M^[256], 1);
  1799.     Close(Outfile);
  1800.   END;
  1801.  
  1802.   IF MapFlag THEN BEGIN
  1803.      DXName := Name;
  1804.      Assign(ef, Pfad + Name + '.MAP');
  1805.      ReWrite(ef);
  1806.      WHILE (Length(DXName) < 19) DO
  1807.        DXName := DXName + ' ';
  1808.      WriteLn(ef,' Start  Stop   Length Name      ' +
  1809.                 '         Class');
  1810.      WriteLn(ef);
  1811.      WriteLn(ef,' 00100H 0', Hex(Pc, 4), 'H 0',
  1812.                 Hex(Pc - $FF, 4), 'H ', DXName, 'CODE');
  1813.      WriteLn(ef);
  1814.      WriteLn(ef,'  Address         Publics by Value');
  1815.      WriteLn(ef);
  1816.      DoMap(Root);
  1817.      WriteLn(ef);
  1818.      WriteLn(ef, 'Program entry point at 0000:0100');
  1819.      Close(ef);
  1820.   END;
  1821.   Result.Main   := WORD(M^[$102] + 256 * M^[$103]);
  1822.   Result.Here   := WORD(Pc);
  1823.   Result.s0     := WORD(M^[$106] + 256 * M^[$107]);
  1824.   Result.r0     := WORD(M^[$104] + 256 * M^[$105]);
  1825.   Result.Bytes  := WORD(Pc - $100);
  1826.   Result.Zeilen := WORD(Nummer);
  1827.   Dispose(IFB);
  1828.   Dispose(M);
  1829. END.
  1830.  
  1831. (* ------------------------------------------------------ *)
  1832. (*                    Ende von NX.PAS                     *)
  1833.  
  1834.