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