home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 02 / pasinter.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-02-12  |  41.4 KB  |  1,855 lines
  1. PROGRAM PasInter;
  2.  
  3. USES Crt;
  4.  
  5. LABEL 1,2;
  6.  
  7. CONST
  8.   MaxBound     = 500;
  9.   MaxLong      = 500;      (* Org. 1000 *)
  10.   MaxReal      = 500;      (* """"""""" *)
  11.   MaxSet       = 200;
  12.   MaxFiles     = 4;
  13.   MaxTextFiles = -1;
  14.   CodeMax      = 2666;     (* GROESSE DES CODEARRAYS *)
  15.   PCMax        = 2300;
  16.   MaxStk       = 1500;      (* MAXIMALE GROESSE VON STACK UND HEAP *)
  17.   MaxStr       = 2000;      (* GROESSE DES STOREARRAYS *)
  18.   MaxString    = 2000;
  19.   BeginCode    = 3;
  20.   InputAdr     = 5;
  21.   OutputAdr    = 7;
  22.   MaxPCode     = 74;
  23.  
  24. TYPE
  25.   Long_Integer = LongInt;                 (* fuer Turbo Pascal 4.0 *)
  26.   ALFA     = PACKED ARRAY[1..10] OF CHAR; (* Fuer Turbo Pascal 4.0 *)
  27.   Bounds   = RECORD lB,uB: INTEGER END;
  28.   Alpha    = PACKED ARRAY[1..8] OF CHAR;
  29.  
  30.   KEl      = ^KElem;
  31.   KElem    = RECORD
  32.                DBGPos: INTEGER;
  33.                Next  : KEl;
  34.              END;
  35.  
  36.   SetRange = 0..127;
  37.   Sets     = SET OF SetRange;
  38.   CharRange= 0..127;
  39.   DataType = (UnDef,Int,Reel,IsBool,SetT,Adr,Mark,IsChar,Long);
  40.   Address  = -1..MaxStr;
  41.   Beta     = PACKED ARRAY[1..25] OF CHAR;
  42.   CodeRec  = RECORD OP1,P1,Q1: INTEGER END;
  43.   CodeArray= ARRAY[0..CodeMax] OF CodeRec;
  44.   StoreRec = PACKED RECORD CASE DataType OF
  45.                Int   : (VI:INTEGER);
  46.                Reel  : (VR:REAL);
  47.                IsBool: (VB:BOOLEAN);
  48.                SetT  : (VS:Sets);
  49.                IsChar: (VC:CHAR);
  50.                Adr   : (VA:INTEGER);
  51.                Long  : (VL:Long_Integer);
  52.                Mark  : (VM:INTEGER);
  53.              END;
  54.   FileRec  = FILE OF StoreRec;
  55.   FileStore= ARRAY[1..MaxFiles] OF FileRec;
  56.   FileRange= 1..4;
  57.   TextFileRange= -4..-1;
  58.  
  59. VAR
  60.   Code: CodeArray;
  61.   PC  : 0..PCMax;
  62.   OP,
  63.   P,Q : INTEGER;
  64.   HelpRec: CodeRec;
  65.  
  66.   Files  : FileStore;
  67.   TextFiles                      : ARRAY[-4..-1] OF TEXT;
  68.   IsTextOpen,IsTextEoF,IsTextEoLn: ARRAY[-4..-1] OF BOOLEAN;
  69.   IsOpen,IsEoF,IsEoLn            : ARRAY[1..MaxFiles] OF BOOLEAN;
  70.   FreeFiles                      : PACKED ARRAY[FileRange] OF BOOLEAN;
  71.   FreeTextFiles                  : PACKED ARRAY[TextFileRange] OF BOOLEAN;
  72.  
  73.   Store        : ARRAY[0..MaxStr] OF StoreRec;
  74.   MP,SP, EP,NP : INTEGER;
  75.   InterPreting : BOOLEAN;
  76.   PCode        : TEXT;
  77.  
  78.   PCo    : ARRAY[CharRange] OF ALFA;
  79.   MakeOp : ARRAY[CharRange] OF INTEGER;
  80.   SPTable: ARRAY[0..29] OF ALFA;
  81.  
  82.   AD,AD1,Handle: INTEGER;
  83.   B            : BOOLEAN;
  84.   i,j,i1,i2    : INTEGER;
  85.   c            : CHAR;
  86.   Keller       : KEl;
  87.   DebugTable   : ARRAY[1..100] OF Alpha;
  88.   DebugPos     : INTEGER; (* POS IN DEBTABLE *)
  89.  
  90.   Bound     : Bounds;
  91.   BoundPos  : INTEGER;
  92.   BoundTable: ARRAY[1..MaxBound] OF Bounds;
  93.  
  94.   LongTable : ARRAY[1..MaxLong] OF Long_Integer;
  95.   LongPos   : INTEGER;
  96.  
  97.   RealTable : ARRAY[1..MaxReal] OF REAL;
  98.   RealPos   : INTEGER;
  99.  
  100.   SetTable  : ARRAY[1..MaxSet] OF Sets;
  101.   SetPos    : INTEGER;
  102.  
  103.   StringPos : INTEGER;
  104.  
  105.  
  106. PROCEDURE Push (VAR k: KEl; Pos: INTEGER);
  107.  
  108. VAR k1: KEl;
  109.  
  110. BEGIN
  111.   New(k1);
  112.   WITH k1^ DO BEGIN
  113.     DBGPos := Pos;  Next := k
  114.   END;
  115.   k := k1;
  116. END;
  117.  
  118.  
  119. PROCEDURE Pop (VAR k: KEl);
  120.  
  121. VAR k1: KEl;
  122.  
  123. BEGIN
  124.   k1 := k;  k := k^.Next;  Dispose(k1);
  125. END;
  126.  
  127.  
  128. PROCEDURE WriteKeller (k: KEl);
  129.  
  130. BEGIN
  131.   IF k <> NIL THEN BEGIN
  132.     WriteLn;  WriteLn;
  133.     WriteLn('Laufzeit-Fehler in ',DebugTable[k^.DBGPos]); k := k^.Next;
  134.     WHILE k <> NIL DO BEGIN
  135.       WriteLn('    Aufgerufen von ',DebugTable[k^.DBGPos]); k := k^.Next
  136.     END;
  137.   END;
  138. END;
  139.  
  140.  
  141. PROCEDURE Load;
  142.  
  143. CONST
  144.   MaxLabel = 1850;
  145.  
  146. TYPE
  147.   LabKind = (IsEnt,IsDef);
  148.   LabRange= 0..MaxLabel;
  149.   LabDat  = RECORD
  150.               Val: INTEGER;
  151.               St : LabKind;
  152.             END;
  153.  
  154. VAR
  155.   MCP,i     : INTEGER;
  156.   Word      : ARRAY[1..10] OF CHAR;
  157.   ch        : CHAR;
  158.   LabelTab  : ARRAY[LabRange] OF LabDat;
  159.   LabelValue: INTEGER;
  160.  
  161.  
  162.   PROCEDURE Init;
  163.  
  164.   VAR i: INTEGER;
  165.  
  166.   BEGIN
  167.     PCo[ 0] := 'lod       '; PCo[ 1] := 'ldo       ';
  168.     PCo[ 2] := 'str       '; PCo[ 3] := 'sro       ';
  169.     PCo[ 4] := 'lda       '; PCo[ 5] := 'lao       ';
  170.     PCo[ 6] := 'sto       '; PCo[ 7] := 'ldc       ';
  171.     PCo[ 8] := '...       '; PCo[ 9] := 'ind       ';
  172.     PCo[10] := 'inc       '; PCo[11] := 'mst       ';
  173.     PCo[12] := 'cup       '; PCo[13] := 'ent       ';
  174.     PCo[14] := 'ret       '; PCo[15] := 'csp       ';
  175.     PCo[16] := 'ixa       '; PCo[17] := 'equ       ';
  176.     PCo[18] := 'neq       '; PCo[19] := 'geq       ';
  177.     PCo[20] := 'grt       '; PCo[21] := 'leq       ';
  178.     PCo[22] := 'les       '; PCo[23] := 'ujp       ';
  179.     PCo[24] := 'fjp       '; PCo[25] := 'xjp       ';
  180.     PCo[26] := 'chk       '; PCo[27] := 'eof       ';
  181.     PCo[28] := 'adi       '; PCo[29] := 'adr       ';
  182.     PCo[30] := 'sbi       '; PCo[31] := 'sbr       ';
  183.     PCo[32] := 'sgs       '; PCo[33] := 'flt       ';
  184.     PCo[34] := 'flo       '; PCo[35] := 'trc       ';
  185.     PCo[36] := 'ngi       '; PCo[37] := 'ngr       ';
  186.     PCo[38] := 'sqi       '; PCo[39] := 'sqr       ';
  187.     PCo[40] := 'abi       '; PCo[41] := 'abr       ';
  188.     PCo[42] := 'not       '; PCo[43] := 'and       ';
  189.     PCo[44] := 'ior       '; PCo[45] := 'dif       ';
  190.     PCo[46] := 'int       '; PCo[47] := 'uni       ';
  191.     PCo[48] := 'inn       '; PCo[49] := 'mod       ';
  192.     PCo[50] := 'odd       '; PCo[51] := 'mpi       ';
  193.     PCo[52] := 'mpr       '; PCo[53] := 'dvi       ';
  194.     PCo[54] := 'dvr       '; PCo[55] := 'mov       ';
  195.     PCo[56] := 'lca       '; PCo[57] := 'dec       ';
  196.     PCo[58] := 'stp       '; PCo[59] := 'ord       ';
  197.     PCo[60] := 'chr       '; PCo[61] := 'ujc       ';
  198.     PCo[62] := 'adl       '; PCo[63] := 'sbl       ';
  199.     PCo[64] := 'dvl       '; PCo[65] := 'mdl       ';
  200.     PCo[66] := 'ilo       '; PCo[67] := 'ilt       ';
  201.     PCo[68] := 'mpl       '; PCo[69] := 'ngl       ';
  202.     PCo[70] := 'lfo       '; PCo[71] := 'lft       ';
  203.     PCo[72] := 'dbg       '; PCo[73] := 'pop       ';
  204.     SPTable[ 0] := 'get       '; SPTable[ 1] := 'put       ';
  205.     SPTable[ 2] := 'rst       '; SPTable[ 3] := 'rln       ';
  206.     SPTable[ 4] := 'new       '; SPTable[ 5] := 'wln       ';
  207.     SPTable[ 6] := 'wrs       '; SPTable[ 7] := 'eln       ';
  208.     SPTable[ 8] := 'wri       '; SPTable[ 9] := 'wrr       ';
  209.     SPTable[10] := 'wrc       '; SPTable[11] := 'rdi       ';
  210.     SPTable[12] := 'rdr       '; SPTable[13] := 'rdc       ';
  211.     SPTable[14] := 'sin       '; SPTable[15] := 'cos       ';
  212.     SPTable[16] := 'exp       '; SPTable[17] := 'log       ';
  213.     SPTable[18] := 'sqt       '; SPTable[19] := 'atn       ';
  214.     SPTable[20] := 'sav       '; SPTable[21] := 'rdl       ';
  215.     SPTable[22] := 'wrl       '; SPTable[23] := 'gmd       ';
  216.     SPTable[24] := 'bio       '; SPTable[25] := 'xbi       ';
  217.     SPTable[26] := 'rwr       '; SPTable[27] := 'res       ';
  218.     SPTable[28] := 'cls       '; SPTable[29] := 'rnd       ';
  219.     MakeOp[ 0] := 123;  MakeOp[ 1] :=  75;
  220.     MakeOp[ 2] :=  81;  MakeOp[ 3] :=  87;
  221.     MakeOp[ 6] :=  93;  MakeOp[ 9] :=  99;
  222.     MakeOp[10] := 105;  MakeOp[26] :=  111;
  223.     MakeOp[57] := 117;  MakeOp[59] :=  129;
  224.     PC := BeginCode;
  225.     StringPos := MaxStk+1;
  226.     FOR i := 1 TO 10 DO Word[i] := ' ';
  227.     FOR i := 0 TO MaxLabel DO
  228.       WITH LabelTab[i] DO BEGIN Val := -1; St := IsEnt END;
  229.   END;
  230.  
  231.  
  232.   PROCEDURE Error1 (No: INTEGER);
  233.  
  234.   VAR c: CHAR;
  235.  
  236.   BEGIN
  237.     WriteLn;  Write('*** Fehler: ');
  238.     CASE No OF
  239.       1: WriteLn('doppelte Marke');
  240.       2: WriteLn('Ueberlauf der Real-Tabelle');
  241.       3: WriteLn('illegales Zeichen');
  242.       4: WriteLn('Ueberlauf der Set-Tabelle');
  243.       5: WriteLn('Ueberlauf der Long-Tabelle');
  244.       6: WriteLn('illegaler P-Code');
  245.       7: WriteLn('Ueberlauf der Indexgrenzen-Tabelle');
  246.       8: WriteLn('Ueberlauf der String-Tabelle');
  247.     END;
  248.     WriteLn;  WriteLn('>> Abbruch <<');  WriteLn('Taste druecken...');
  249.     REPEAT UNTIL KeyPressed;  Halt;
  250.   END;
  251.  
  252.  
  253.   PROCEDURE Update (x: LabRange);
  254.  
  255.   VAR
  256.     IsActual,Succ: -1..PCMax;
  257.     EndList      : BOOLEAN;
  258.  
  259.   BEGIN
  260.     IF LabelTab[x].St = IsDef THEN Error1(1)
  261.     ELSE BEGIN
  262.       IF LabelTab[x].Val <> -1 THEN BEGIN
  263.         IsActual := LabelTab[x].Val;  EndList := FALSE;
  264.         WHILE NOT EndList DO
  265.           WITH Code[IsActual] DO BEGIN
  266.             Succ := Q1;  Q1 := LabelValue;
  267.             IF Succ=-1 THEN EndList := TRUE
  268.             ELSE IsActual := Succ
  269.           END;
  270.       END;
  271.       LabelTab[x].St := IsDef;
  272.       LabelTab[x].Val := LabelValue;
  273.     END;
  274.   END;
  275.  
  276.  
  277.   PROCEDURE Assemble;  FORWARD;
  278.  
  279.  
  280.   PROCEDURE Generate;
  281.  
  282.   VAR
  283.     x     : INTEGER;
  284.     Weiter: BOOLEAN;
  285.  
  286.   BEGIN
  287.     Weiter := TRUE;
  288.     WHILE Weiter DO BEGIN
  289.       Read(PCode,ch);
  290.       CASE ch OF
  291.         'i' : ReadLn(PCode);
  292.         'l' : BEGIN
  293.                 Read(PCode,x);
  294.                 IF NOT Eoln(PCode) THEN Read(PCode,ch);
  295.                 IF ch = '=' THEN Read(PCode,LabelValue)
  296.                 ELSE LabelValue := PC;
  297.                 Update(x);  ReadLn(PCode);
  298.               END;
  299.         'q' : BEGIN Weiter := FALSE;  ReadLn(PCode); END;
  300.         ' ' : BEGIN Read(PCode,ch);  Assemble END
  301.       END;
  302.     END
  303.   END;
  304.  
  305.  
  306.   PROCEDURE Assemble;
  307.  
  308.   LABEL 1;
  309.  
  310.   VAR
  311.     Name     : ALFA;
  312.     B,Found  : BOOLEAN;
  313.     r        : REAL;
  314.     s        : Sets;
  315.     LongKonst: Long_Integer;
  316.     c1       : CHAR;
  317.     i,j,s1,
  318.     lB,uB    : INTEGER;
  319.     ProcName : Alpha;
  320.  
  321.  
  322.     FUNCTION DBIndex (VAR Name: Alpha): INTEGER;
  323.  
  324.     VAR Found: BOOLEAN; i,Erg: INTEGER;
  325.  
  326.     BEGIN
  327.       Found := FALSE;  i := 1;
  328.       WHILE NOT Found AND (i <= DebugPos) DO BEGIN
  329.         Found := DebugTable[i] = Name;
  330.         i := i+1
  331.       END;
  332.       IF NOT Found THEN BEGIN
  333.         DebugPos := DebugPos+1;
  334.         DebugTable[DebugPos] := Name;
  335.         Erg := DebugPos;
  336.       END
  337.       ELSE Erg := i-1;
  338.       DBIndex := Erg
  339.     END;
  340.  
  341.  
  342.     PROCEDURE FindQ (x: LabRange);
  343.  
  344.     BEGIN
  345.       CASE LabelTab[x].St OF
  346.         IsEnt: BEGIN
  347.                  Q := LabelTab[x].Val;
  348.                  LabelTab[x].Val := PC;
  349.                END;
  350.         IsDef: Q := LabelTab[x].Val;
  351.       END;
  352.     END;
  353.  
  354.  
  355.     PROCEDURE FindLabel;
  356.  
  357.     VAR x: LabRange;
  358.  
  359.     BEGIN
  360.       WHILE (ch <> 'l') AND NOT Eoln(PCode) DO Read(PCode,ch);
  361.       Read(PCode,x);  FindQ(x)
  362.     END;
  363.  
  364.  
  365.     PROCEDURE GetName;
  366.  
  367.     VAR i : INTEGER;
  368.  
  369.     BEGIN
  370.       Word[1] := ch;
  371.       Read(PCode,Word[2],Word[3]);
  372.       IF NOT Eoln(PCode) THEN Read(PCode,ch);
  373. (*
  374.       Pack(Word,1,Name);
  375. *)
  376.       Name := '          ';
  377.       FOR i := 1 TO 10 DO Name[i] := Word[i];
  378.     END;
  379.  
  380.  
  381.     PROCEDURE GetType;
  382.  
  383.     VAR i: INTEGER;
  384.  
  385.     BEGIN
  386.       IF ch <> 'i' THEN BEGIN
  387.         CASE ch OF
  388.           'a' : i := 0;
  389.           'r' : i := 1;
  390.           's' : i := 2;
  391.           'b' : i := 3;
  392.           'c' : i := 4;
  393.           'l' : i := 5;
  394.         END;
  395.         OP := MakeOp[OP]+i;
  396.       END
  397.     END;
  398.  
  399.  
  400.     PROCEDURE LoadConst;
  401.  
  402.     BEGIN
  403.       CASE ch OF
  404.         'i' : BEGIN P := 1; Read(PCode,Q); END;
  405.         'r' : BEGIN
  406.                 OP := 8;  P := 2;
  407.                 Read(PCode,r);
  408.                 IF RealPos < MaxReal THEN RealPos := RealPos+1
  409.                 ELSE Error1(2);
  410.                 RealTable[RealPos] := r;
  411.                 Q := RealPos;
  412.               END;
  413.         'n' : BEGIN P := 0; Q := 0 END;
  414.         'b' : BEGIN P := 3; Read(PCode,Q) END;
  415.         'c' : BEGIN
  416.                 P := 6;
  417.                 REPEAT Read(PCode,ch); UNTIL ch <> ' ';
  418.                 IF ch <> '''' THEN Error1(3);
  419.                 Read(PCode,ch); Q := Ord(ch);
  420.                 Read(PCode,ch);
  421.                 IF ch <> '''' THEN Error1(3);
  422.               END;
  423.         '(' : BEGIN
  424.                 OP := 8; P := 4;
  425.                 s := []; Read(PCode,ch);
  426.                 WHILE ch <> ')' DO BEGIN
  427.                   Read(PCode,s1,ch,ch); s := s+[s1];
  428.                 END;
  429.                 IF SetPos < MaxSet THEN SetPos := SetPos+1
  430.                 ELSE Error1(4);
  431.                 SetTable[SetPos] := s;
  432.                 Q := SetPos;
  433.               END;
  434.         'l' : BEGIN
  435.                 OP := 8;  P := 7;
  436.                 Read(PCode,LongKonst);
  437.                 IF LongPos<MaxLong THEN LongPos := LongPos+1
  438.                 ELSE Error1(5);
  439.                 LongTable[LongPos] := LongKonst;
  440.                 Q := LongPos;
  441.               END;
  442.       END (* CASE *)
  443.     END;
  444.  
  445.  
  446.   BEGIN (* Assemble *)
  447.     ProcName := '        ';  P := 0;  Q := 0;  OP := 0;
  448.     GetName;
  449.     PCo[MaxPCode] := Name;
  450.     WHILE PCo[OP] <> Name DO OP := OP+1;
  451.     IF OP = MaxPCode THEN Error1(6);
  452.     CASE OP OF
  453.       17,18,19,20,21,22:
  454.         BEGIN
  455.           CASE ch OF
  456.             'a' : ;
  457.             'i' : P := 1;
  458.             'r' : P := 2;
  459.             'b' : P := 3;
  460.             's' : P := 4;
  461.             'c' : P := 6;
  462.             'l' : P := 7;
  463.             'm' : BEGIN  P := 5;  Read(PCode,Q);  END
  464.           END
  465.         END;
  466.       0,2:
  467.         BEGIN  GetType;  Read(PCode,P,Q);  END;
  468.       4:
  469.         Read(PCode,P,Q);
  470.       12:
  471.         BEGIN  Read(PCode,P);  FindLabel END;
  472.       11:
  473.         Read(PCode,P);
  474.       14:
  475.         CASE ch OF
  476.           'p' : P := 0;
  477.           'i' : P := 1;
  478.           'r' : P := 2;
  479.           'c' : P := 3;
  480.           'b' : P := 4;
  481.           'a' : P := 5;
  482.           'l' : P := 6;
  483.         END;
  484.       5,16,55:
  485.         Read(PCode,Q);
  486.       1,3,9,10,57:
  487.         BEGIN  GetType;  Read(PCode,Q);  END;
  488.       23,24,25:
  489.         FindLabel;
  490.       13:
  491.         BEGIN  Read(PCode,P);  FindLabel  END;
  492.       15:
  493.         BEGIN
  494.           FOR j := 1 TO 9 DO Read(PCode,ch);
  495.           GetName;
  496.           WHILE Name <> SPTable[Q] DO Q := Q+1;
  497.         END;
  498.       7:
  499.         LoadConst;
  500.       26:
  501.         BEGIN
  502.           GetType;
  503.           Read(PCode,lB,uB);
  504.           IF OP = 111 THEN Q := lB
  505.           ELSE BEGIN
  506.             { SUCHE, OB (LB,UB) SCHON IN TABELLE ... }
  507.             Found := FALSE;  Bound.uB := uB;  Bound.lB := lB;  j := 1;
  508.             WHILE NOT Found AND (j <= BoundPos) DO BEGIN
  509.               Found := (BoundTable[j].uB = Bound.uB) AND
  510.                        (BoundTable[j].lB = Bound.lB);
  511.               j := j+1
  512.             END;
  513.             IF Found THEN Q := j-1
  514.             ELSE BEGIN
  515.               IF BoundPos < MaxBound THEN BoundPos := BoundPos+1
  516.               ELSE Error1(7);
  517.               BoundTable[BoundPos] := Bound;
  518.               Q := BoundPos
  519.             END;
  520.           END;
  521.         END;
  522.       56:
  523.         BEGIN
  524.           WHILE ch <> '''' DO Read(PCode,ch);
  525.           Read(PCode,ch);Q := StringPos;
  526.           WHILE ch <> '''' DO BEGIN
  527.             IF StringPos > MaxString THEN Error1(8);
  528.             Store[StringPos].VC := ch;
  529.             Read(PCode,ch);
  530.             StringPos := StringPos+1
  531.           END;
  532.         END;
  533.       6,59:
  534.         GetType;
  535.       72:               (* DBG *)
  536.         BEGIN
  537.           WHILE ch <> '''' DO Read(PCode,ch);
  538.           Read(PCode,ch);
  539.           i := 1;
  540.           WHILE ch <> '''' DO BEGIN
  541.             ProcName[i] := ch;  i := i+1;
  542.             Read(PCode,ch);
  543.           END;
  544.           P := DBIndex(ProcName);
  545.         END;
  546.     END; (* CASE *)
  547.     WITH Code[PC] DO BEGIN
  548.       OP1 := OP;  P1 := P;  Q1 := Q;
  549.     END;
  550.     PC := PC+1;
  551.     1:
  552.     ReadLn(PCode);
  553.   END;
  554.  
  555.  
  556. BEGIN (* Load *)
  557.   Init;
  558.   Generate;
  559.   PC := 0;
  560.   Generate;
  561. END;
  562.  
  563.  
  564. PROCEDURE PostMortemDump;
  565.  
  566. VAR  s: INTEGER; i: INTEGER; c: CHAR;
  567.  
  568.  
  569.   PROCEDURE PrintStoreEntry;
  570.  
  571.   BEGIN
  572.     Write(s:6);
  573.     IF ABS(Store[s].VI) < MaxInt THEN Write((Store[s].VI):8)
  574.     ELSE Write(' zu gross');
  575.     s := s-1;
  576.     i := i+1;
  577.     IF i = 4 THEN BEGIN  WriteLn; i := 0  END;
  578.   END;
  579.  
  580.  
  581. BEGIN
  582.   WriteLn(' pc =',PC-1:5,' op =',OP:3,' sp =',SP:5,' mp =',MP:5,
  583.           ' np =',NP:5);
  584.   WriteLn('-------------------------------------------------');
  585.   s := SP;  i := 0;
  586.   WHILE s >= 0 DO PrintStoreEntry;
  587.   s := MaxStk;
  588.   WHILE s >= NP DO PrintStoreEntry;
  589. END;
  590.  
  591.  
  592. PROCEDURE ErrorI (No: INTEGER);
  593.  
  594. BEGIN
  595.   WriteLn;  Write('*** Fehler: ');
  596.   CASE No OF
  597.     1: WriteLn('Datei nicht geoeffnet');
  598.     2: WriteLn('Versuch, nach dem Dateiende zu lesen');
  599.     3: WriteLn('ReadLn bei Ausgabe-Datei');
  600.     4: WriteLn('Speicher-Überlauf');
  601.     5: WriteLn('WriteLn bei Eingabe-Datei');
  602.     6: WriteLn('Write bei Eingabe-Datei');
  603.     7: WriteLn('Read bei Ausgabe-Datei');
  604.     8: WriteLn('zuviel offene Dateien');
  605.     9: WriteLn('zuviel offene Text-Dateien');
  606.    10: WriteLn('<, <=, >, >= fuer Adresse');
  607.    11: WriteLn('Mengen-Einschliessung');
  608.    12: WriteLn('illegaler Zeigerwert');
  609.    13: WriteLn('Wert nicht darstellbar');
  610.    14: WriteLn('CASE-Fehler');
  611.   END;
  612.   WriteLn;  WriteKeller(Keller);
  613.   WriteLn('Taste druecken...');
  614.   REPEAT UNTIL KeyPressed;
  615.   PostMortemDump;
  616.   WriteLn('Taste druecken...');
  617.   REPEAT UNTIL KeyPressed;  Halt;
  618. END;
  619.  
  620.  
  621. FUNCTION Basis (NoOfBSt: INTEGER): INTEGER;
  622.  
  623. VAR AD: INTEGER;
  624.  
  625. BEGIN
  626.   AD := MP;
  627.   WHILE NoOfBSt>0 DO BEGIN
  628.     AD := Store[AD+1].VM; NoOfBSt := NoOfBSt-1
  629.   END;
  630.   Basis := AD;
  631. END;
  632.  
  633.  
  634. PROCEDURE CompareBlock;
  635.  
  636. BEGIN
  637.   i1 := Store[SP].VA;
  638.   i2 := Store[SP+1].VA;
  639.   i := 0; B := TRUE;
  640.   WHILE B AND (i <> Q) DO
  641.     IF Store[i1+i].VI=Store[i2+i].VI THEN i := i+1
  642.     ELSE B := FALSE
  643. END;
  644.  
  645.  
  646. PROCEDURE CallStdProcs;
  647.  
  648. VAR Line: BOOLEAN;  i: INTEGER;
  649.  
  650.  
  651.   PROCEDURE ReadI (VAR f: TEXT);
  652.  
  653.   VAR AD: INTEGER;
  654.  
  655.   BEGIN
  656.     AD := Store[SP-1].VA;
  657.     Read(f,Store[AD].VI);
  658. (*
  659.     Store[Store[SP].VA].VC := f^;
  660. *)
  661.     SP := SP-2
  662.   END;
  663.  
  664.  
  665.   PROCEDURE ReadL(VAR f: TEXT);
  666.  
  667.   VAR AD: INTEGER;
  668.  
  669.   BEGIN
  670.     AD := Store[SP-1].VA;
  671.     Read(f,Store[AD].VL);
  672. (*
  673.     Store[Store[SP].VA].VC := f^;
  674. *)
  675.     SP := SP-2
  676.   END;
  677.  
  678.  
  679.   PROCEDURE ReadR (VAR f: TEXT);
  680.  
  681.   VAR AD: INTEGER;
  682.  
  683.   BEGIN
  684.     AD := Store[SP-1].VA;
  685.     Read(f,Store[AD].VR);
  686. (*
  687.     Store[Store[SP].VA].VC := f^;
  688. *)
  689.     SP := SP-2
  690.   END;
  691.  
  692.  
  693.   PROCEDURE ReadC (VAR f: TEXT);
  694.  
  695.   VAR AD: INTEGER;  c: CHAR;
  696.  
  697.   BEGIN
  698.     AD := Store[SP-1].VA;
  699.     Read(f,c);
  700.     Store[AD].VC := c;
  701. (*
  702.     Store[Store[SP].VA].VC) := f^;
  703. *)
  704.     SP := SP-2;
  705.   END;
  706.  
  707.  
  708.   PROCEDURE SPGet;
  709.  
  710.   VAR AD: Address;  FileHandle,i,Offset: INTEGER;
  711.  
  712.   BEGIN
  713.     AD := Store[SP-1].VA; Offset := Store[SP].VI;
  714.     FileHandle := Store[AD+Offset].VI;
  715.     IF NOT IsOpen[FileHandle] THEN
  716.       ErrorI(1)
  717.     ELSE IF Eof(Files[FileHandle]) THEN IsEoF[FileHandle] := TRUE
  718.     ELSE
  719.       FOR i := 1 TO Offset DO
  720.         IF Eof(Files[FileHandle]) THEN ErrorI(2)
  721.         ELSE BEGIN
  722.           Read(Files[FileHandle],Store[AD+i-1]);
  723.           (* Get(Files[FileHandle]); *)
  724.         END;
  725.     SP := SP-2;
  726.   END;
  727.  
  728.  
  729.   PROCEDURE SPPut;
  730.  
  731.   VAR AD: Address; FileHandle,i,Offset: INTEGER;
  732.  
  733.   BEGIN
  734.     AD := Store[SP-1].VA; Offset := Store[SP].VI;
  735.     FileHandle := Store[AD+Offset].VI;
  736.     IF NOT IsOpen[FileHandle] THEN ErrorI(1);
  737.     FOR i := 1 TO Offset DO BEGIN
  738.       Write(Files[FileHandle],Store[AD+i-1]);
  739.       (* PUT(FILES[FILEHANDLE]); *)
  740.     END;
  741.     SP := SP-2
  742.   END;
  743.  
  744.  
  745.   PROCEDURE WriteStr (VAR f: TEXT);
  746.  
  747.   VAR i,j,k: INTEGER;  AD: INTEGER;
  748.  
  749.   BEGIN
  750.     AD := Store[SP-3].VA;
  751.     k := Store[SP-2].VI;
  752.     j := Store[SP-1].VI;
  753.     IF k > j THEN FOR i := 1 TO k-j DO Write(f,' ')
  754.     ELSE j := k;
  755.     FOR i := 0 TO j-1 DO Write(f,Store[AD+i].VC);
  756.     SP := SP-4
  757.   END;
  758.  
  759.  
  760.   PROCEDURE PRST;
  761.  
  762.   BEGIN
  763.     NP := Store[SP].VA;  SP := SP-1
  764.   END;
  765.  
  766.  
  767.   PROCEDURE PRLn;  (* Zeilenende lesen *)
  768.  
  769.   VAR AD: Address; Handle: INTEGER;
  770.  
  771.   BEGIN
  772.     AD := Store[SP].VA; Handle := Store[AD+1].VI;
  773.     CASE Handle OF
  774.       -3 : ErrorI(3);
  775.       -4 : BEGIN
  776.              ReadLn(Input);
  777. (*
  778.              Store[InputAdr].VC := Input^;
  779. *)
  780.            END;
  781.       -2,
  782.       -1 : BEGIN
  783.              ReadLn(TextFiles[Handle]);
  784. (*
  785.              Store[AD].VC := TextFiles[Handle]^;
  786. *)
  787.            END;
  788.     END;
  789.     SP := SP-1;
  790.   END;
  791.  
  792.  
  793.   PROCEDURE PNew;
  794.  
  795.   VAR AD: Address;
  796.  
  797.   BEGIN
  798.     AD := NP-Store[SP].VI;
  799.     IF AD <= EP THEN ErrorI(4);
  800.     NP := AD; AD := Store[SP-1].VA;
  801.     Store[AD].VA := NP;
  802.     SP := SP-2;
  803.   END;
  804.  
  805.  
  806.   PROCEDURE PWLn;  (* Zeilenende schreiben *)
  807.  
  808.   VAR AD: Address;  Handle: INTEGER;
  809.  
  810.   BEGIN
  811.     AD := Store[SP].VA;
  812.     Handle := Store[AD+1].VI;
  813.     CASE Handle OF
  814.       -3 : WriteLn(Output);
  815.       -4 : ErrorI(5);
  816.       -2,
  817.       -1 : WriteLn(TextFiles[Handle]);
  818.     END;
  819.   END;
  820.  
  821.  
  822.   PROCEDURE PWrS;  (* Zeichenkette schreiben *)
  823.  
  824.   VAR AD: Address; Handle: INTEGER;
  825.  
  826.   BEGIN
  827.     AD := Store[SP].VA;
  828.     Handle := Store[AD+1].VI;
  829.     CASE Handle OF
  830.       -3 : WriteStr(Output);
  831.       -4 : ErrorI(6);
  832.       -2,
  833.       -1 : WriteStr(TextFiles[Handle]);
  834.     END;
  835.   END;
  836.  
  837.  
  838.   PROCEDURE PWrI;  (* Integer schreiben *)
  839.  
  840.   VAR AD: Address; Handle: INTEGER;
  841.  
  842.   BEGIN
  843.     AD := Store[SP].VA; Handle := Store[AD+1].VI;
  844.     CASE Handle OF
  845.       -3 : Write(Output,Store[SP-2].VI:Store[SP-1].VI);
  846.       -4 : ErrorI(6);
  847.       -2,
  848.       -1 : Write(TextFiles[Handle],Store[SP-2].VI:Store[SP-1].VI);
  849.     END;
  850.     SP := SP-3;
  851.   END;
  852.  
  853.  
  854.   PROCEDURE PRdI;  (* Integer lesen *)
  855.  
  856.   BEGIN
  857.     Handle := Store[Store[SP].VA+1].VI;
  858.     CASE Handle OF
  859.       -4 : ReadI(Input);
  860.       -3 : ErrorI(7);
  861.       -2,
  862.       -1 : ReadI(TextFiles[Handle]);
  863.     END
  864.   END;
  865.  
  866.  
  867.   PROCEDURE PWrR;  (* Real schreiben *)
  868.  
  869.   VAR AD: Address; Handle: INTEGER;
  870.  
  871.   BEGIN
  872.     AD := Store[SP].VA; Handle := Store[AD+1].VI;
  873.     CASE Handle OF
  874.       -3 : Write(Output,Store[SP-2].VR:Store[SP-1].VI);
  875.       -4 : ErrorI(6);
  876.       -2,
  877.       -1 : Write(TextFiles[Handle],Store[SP-2].VR:Store[SP-1].VI);
  878.     END;
  879.     SP := SP-3;
  880.   END;
  881.  
  882.  
  883.   PROCEDURE PRdR;   (* Real lesen *)
  884.  
  885.   BEGIN
  886.     Handle := Store[Store[SP].VA+1].VI;
  887.     CASE Handle OF
  888.       -4 : ReadR(Input);
  889.       -3 : ErrorI(7);
  890.       -1,
  891.       -2 : ReadR(TextFiles[Handle]);
  892.     END
  893.   END;
  894.  
  895.  
  896.   PROCEDURE PWrC;   (* Char schreiben *)
  897.  
  898.   VAR AD: Address; Handle: INTEGER;
  899.  
  900.   BEGIN
  901.     AD := Store[SP].VA; Handle := Store[AD+1].VI;
  902.     CASE Handle OF
  903.       -3 : Write(Output,Store[SP-2].VC:Store[SP-1].VI);
  904.       -4 : ErrorI(6);
  905.       -2,
  906.       -1 : Write(TextFiles[Handle],Store[SP-2].VC:Store[SP-1].VI);
  907.     END;
  908.     SP := SP-3;
  909.   END;
  910.  
  911.  
  912.   PROCEDURE PRdC;   (* Char lesen *)
  913.  
  914.   BEGIN
  915.     Handle := Store[Store[SP].VA+1].VI;
  916.     CASE Handle OF
  917.       -4 : ReadC(Input);
  918.       -3 : ErrorI(7);
  919.       -1,
  920.       -2 : ReadC(TextFiles[Handle]);
  921.     END
  922.   END;
  923.  
  924.  
  925.   PROCEDURE PWrL;  (* Long-Integer schreiben *)
  926.  
  927.   VAR AD: Address; Handle: INTEGER;
  928.  
  929.   BEGIN
  930.     AD := Store[SP].VA; Handle := Store[AD+1].VI;
  931.     CASE Handle OF
  932.       -3 : Write(Output,Store[SP-2].VL:Store[SP-1].VI);
  933.       -4 : ErrorI(6);
  934.       -2,
  935.       -1 : Write(TextFiles[Handle],Store[SP-2].VL:Store[SP-1].VI);
  936.     END;
  937.     SP := SP-3;
  938.   END;
  939.  
  940.  
  941.   PROCEDURE PRdL;    (* Long-Integer lesen *)
  942.  
  943.   VAR Handle: INTEGER;
  944.  
  945.   BEGIN
  946.     Handle := Store[Store[SP].VA+1].VI;
  947.     CASE Handle OF
  948.       -4 : ReadL(Input);
  949.       -3 : ErrorI(7);
  950.       -1,
  951.       -2 : ReadL(TextFiles[Handle]);
  952.     END;
  953.   END;
  954.  
  955.  
  956.   PROCEDURE SPEoLn;
  957.  
  958.   VAR AD: Address; Offset,FileHandle: INTEGER;
  959.  
  960.   BEGIN
  961.     AD := Store[SP-1].VA; Offset := Store[SP].VI;
  962.     FileHandle := Store[AD+Offset].VI;
  963.     SP := SP-1;
  964.     IF FileHandle < 0 THEN BEGIN   (* TEXTFILE *)
  965.       IsTextEoLn[FileHandle] := Eoln(TextFiles[FileHandle]);
  966.       Store[SP].VB := IsTextEoLn[FileHandle];
  967.     END
  968.     ELSE BEGIN
  969. (*
  970.       IsEoLn[FileHandle] := EoLn(Files[FileHandle]);
  971.       Store[SP].VB := IsEoLn[FileHandle];
  972. *)
  973.     END;
  974.   END;
  975.  
  976.  
  977.   PROCEDURE SPReSetReWrite (CAS: INTEGER);
  978.  
  979.   VAR
  980.     AD: Address;  i,Offset,Handle: INTEGER;
  981.     FName: STRING[80];
  982.     IsTextFile: BOOLEAN;
  983.  
  984.  
  985.     FUNCTION GetHandle (Error: INTEGER): INTEGER;
  986.  
  987.     VAR Handle,i: INTEGER;  Found: BOOLEAN;
  988.  
  989.     BEGIN
  990.       i := 1;
  991.       Found := FALSE;
  992.       WHILE NOT Found AND (i <= 4) DO BEGIN
  993.         IF IsTextFile THEN Found := FreeTextFiles[-i]
  994.         ELSE Found := FreeFiles[i];
  995.         i := i+1
  996.       END;
  997.       IF NOT Found THEN ErrorI(Error); (* NEVER RETURNS *)
  998.       IF IsTextFile THEN BEGIN
  999.         Handle := -i+1;  FreeTextFiles[Handle] := FALSE
  1000.       END
  1001.       ELSE BEGIN
  1002.         Handle := i-1;  FreeFiles[Handle] := FALSE;
  1003.       END;
  1004.       GetHandle := Handle;
  1005.     END;
  1006.  
  1007.  
  1008.   BEGIN
  1009.     AD := Store[SP-2].VA; (* ADRESSE DES STRINGS *)
  1010.     FName := '';
  1011.     FOR i := 1 TO Store[SP-1].VI DO
  1012.       FName := Concat(Fname,Store[AD+i-1].VC);
  1013.     AD := Store[SP-4].VA; Offset := Store[SP-3].VI;
  1014.     IsTextFile := Store[SP].VI=1;
  1015.     CASE IsTextFile OF
  1016.       FALSE : BEGIN
  1017.                 Handle := GetHandle(8);
  1018.                 IsEoLn[Handle] := FALSE; IsEoF[Handle] := FALSE;
  1019.                 IF CAS=1 THEN BEGIN
  1020.                   Assign(Files[Handle],FName);
  1021.                   ReWrite(Files[Handle])
  1022.                 END
  1023.                 ELSE BEGIN
  1024.                    Assign(Files[Handle],FName);
  1025.                    ReSet(Files[Handle]);
  1026.                    IF Eof(Files[Handle]) THEN IsEoF[Handle] := TRUE
  1027.                    ELSE
  1028.                      FOR i := 1 TO Offset DO
  1029.                        IF Eof(Files[Handle]) THEN
  1030.                          ErrorI(2)
  1031.                        ELSE BEGIN
  1032.                          Read(Files[Handle],Store[AD+i-1]);
  1033.                          (* GET(FILES[HANDLE]); *)
  1034.                        END
  1035.                 END;
  1036.                 IsOpen[Handle] := TRUE;
  1037.               END;
  1038.       TRUE  : BEGIN
  1039.                 Handle := GetHandle(9);
  1040.                 IsTextEoLn[Handle] := FALSE;
  1041.                 IsTextEoF[Handle] := FALSE;
  1042.                 IF CAS=1 THEN BEGIN
  1043.                   Assign(TextFiles[Handle],FName);
  1044.                   ReWrite(TextFiles[Handle])
  1045.                 END
  1046.                 ELSE BEGIN
  1047.                   Assign(TextFiles[Handle],FName);
  1048.                   ReSet(TextFiles[Handle]);
  1049.                   IF Eof(TextFiles[Handle]) THEN IsTextEoF[Handle] := TRUE
  1050.                   ELSE ; (* NIX. FILEPUFFER LEER *)
  1051.                 END;
  1052.                 IsTextOpen[Handle] := TRUE;
  1053.               END;
  1054.     END;
  1055.     Store[AD+Offset].VI := Handle; (* FILEHANDLE ZUWEISEN *)
  1056.     SP := SP-5;
  1057.   END;
  1058.  
  1059.  
  1060.   PROCEDURE SPClose;
  1061.  
  1062.   VAR AD: Address; FileHandle,Offset: INTEGER;
  1063.  
  1064.   BEGIN
  1065.     AD := Store[SP-1].VA; Offset := Store[SP].VI;
  1066.     FileHandle := Store[AD+Offset].VI;
  1067.     IF FileHandle < 0 THEN BEGIN (* TEXTFILE *)
  1068.       Close(TextFiles[FileHandle]);
  1069.       IsTextOpen[FileHandle] := FALSE;
  1070.       FreeTextFiles[FileHandle] := TRUE;
  1071.     END
  1072.     ELSE BEGIN
  1073.       Close(Files[FileHandle]);
  1074.       IsOpen[FileHandle] := FALSE;
  1075.       FreeFiles[FileHandle] := TRUE;
  1076.     END;
  1077.     (* UEBERNEHME INDEX FILEHANDLE IN FREILISTE . .... *)
  1078.     SP := SP-2
  1079.   END;
  1080.  
  1081.  
  1082.   PROCEDURE SPRound;
  1083.  
  1084.   BEGIN
  1085.     Store[SP].VI := Round(Store[SP].VR)
  1086.   END;
  1087.  
  1088.  
  1089. (* IN STORE[SP] STEHT DIE FUNKTIONSNUMMER DES GEMDOS-AUFRUFS.
  1090.    ES FOLGT EINE AUFLISTUNG ALLER GEMDOS-FUNKTIONEN:           *)
  1091. (* Fuer andere Betriebssysteme und Compiler entsprechen anpassen! *)
  1092.  
  1093.   PROCEDURE GMD;
  1094. (*
  1095.   VAR
  1096.     sk : INTEGER;
  1097.     C  : CHAR;
  1098.     I,L: INTEGER;
  1099.     SR : STOREREC;
  1100.  
  1101.     PROCEDURE Term; GEMDOS(0);
  1102.     FUNCTION ConIn: CHAR; GEMDOS(1);
  1103.     PROCEDURE ConOut (C: CHAR); GEMDOS(2);
  1104.     FUNCTION AuxIn: CHAR; GEMDOS(3);
  1105.     PROCEDURE AuxOut (C: CHAR); GEMDOS(4);
  1106. *)
  1107.   BEGIN
  1108.     WriteLn('GEMDOS(',Store[SP].VI,') nicht implementiert');
  1109.     Halt;
  1110. (*
  1111.     CASE STORE[SP].VI OF
  1112.       0 : TERM;
  1113.       1 : SR.VC := CONIN;
  1114.       2 : CONOUT(STORE[SP-1].VC);
  1115.       3 : SR.VC := AUXIN;
  1116.       4 : AUXOUT(STORE[SP-1].VC);
  1117.       ELSE:
  1118.           BEGIN
  1119.             WRITELN('GEMDOS(',STORE[SP].VI,') nicht implementiert');
  1120.             HALT
  1121.           END;
  1122.     END;
  1123.     CASE STORE[SP].VI OF
  1124.       1,3 : SK := 0;
  1125.       2,4 : SK := 2;
  1126.     END;
  1127.     SP := SP-SK;
  1128.     STORE[SP] := SR;
  1129. *)
  1130.   END;
  1131.  
  1132.  
  1133. BEGIN (* CallStdProcs *)
  1134.   CASE Q OF
  1135.     0 : SPGet;
  1136.     1 : SPPut;
  1137.     2 : PRST;
  1138.     3 : PRLn;
  1139.     4 : PNew;
  1140.     5 : PWLn;
  1141.     6 : PWrS;
  1142.     7 : SPEoLn;
  1143.     8 : PWrI;
  1144.     9 : PWrR;
  1145.     10: PWrC;
  1146.     11: PRdI;
  1147.     12: PRdR;
  1148.     13: PRdC;
  1149.     14: Store[SP].VR := Sin(Store[SP].VR);
  1150.     15: Store[SP].VR := Cos(Store[SP].VR);
  1151.     16: Store[SP].VR := Exp(Store[SP].VR);
  1152.     17: Store[SP].VR := Ln (Store[SP].VR);
  1153.     18: Store[SP].VR := Sqrt(Store[SP].VR);
  1154.     19: Store[SP].VR := ArcTan(Store[SP].VR);
  1155.     20: BEGIN
  1156.           AD := Store[SP].VA;
  1157.           Store[AD].VA := NP;
  1158.           SP := SP-1
  1159.         END;
  1160.     21: PRdL;
  1161.     22: PWrL;
  1162.     23: GMD;
  1163. (*
  1164.     24: BIO;
  1165.     25: XBI;
  1166.  *)
  1167.     26: SPReSetReWrite(1);
  1168.     27: SPReSetReWrite(0);
  1169.     28: SPClose;
  1170.     29: SPRound;
  1171.   END
  1172. END;
  1173.  
  1174.  
  1175. PROCEDURE PEqu;
  1176.  
  1177. BEGIN
  1178.   SP := SP-1;
  1179.   CASE P OF
  1180.     1: Store[SP].VB := Store[SP].VI=Store[SP+1].VI;
  1181.     0: Store[SP].VB := Store[SP].VA=Store[SP+1].VA;
  1182.     6: Store[SP].VB := Store[SP].VC=Store[SP+1].VC;
  1183.     2: Store[SP].VB := Store[SP].VR=Store[SP+1].VR;
  1184.     3: Store[SP].VB := Store[SP].VB=Store[SP+1].VB;
  1185.     4: Store[SP].VB := Store[SP].VS=Store[SP+1].VS;
  1186.     7: Store[SP].VB := Store[SP].VL=Store[SP+1].VL;
  1187.     5: BEGIN
  1188.          CompareBlock;
  1189.          Store[SP].VB := B;
  1190.        END;
  1191.   END;
  1192. END;
  1193.  
  1194.  
  1195. PROCEDURE PNEq;
  1196.  
  1197. BEGIN
  1198.   SP := SP-1;
  1199.   CASE P OF
  1200.     0: Store[SP].VB := Store[SP].VA <> Store[SP+1].VA;
  1201.     1: Store[SP].VB := Store[SP].VI <> Store[SP+1].VI;
  1202.     6: Store[SP].VB := Store[SP].VC <> Store[SP+1].VC;
  1203.     2: Store[SP].VB := Store[SP].VR <> Store[SP+1].VR;
  1204.     3: Store[SP].VB := Store[SP].VB <> Store[SP+1].VB;
  1205.     4: Store[SP].VB := Store[SP].VS <> Store[SP+1].VS;
  1206.     7: Store[SP].VB := Store[SP].VL <> Store[SP+1].VL;
  1207.     5: BEGIN
  1208.          CompareBlock;
  1209.          Store[SP].VB := NOT B;
  1210.        END;
  1211.   END;
  1212. END;
  1213.  
  1214.  
  1215. PROCEDURE PGEq;
  1216.  
  1217. BEGIN
  1218.   SP := SP-1;
  1219.   CASE P OF
  1220.     0: ErrorI(10);
  1221.     1: Store[SP].VB := Store[SP].VI>=Store[SP+1].VI;
  1222.     6: Store[SP].VB := Store[SP].VC>=Store[SP+1].VC;
  1223.     2: Store[SP].VB := Store[SP].VR>=Store[SP+1].VR;
  1224.     3: Store[SP].VB := Store[SP].VB>=Store[SP+1].VB;
  1225.     4: Store[SP].VB := Store[SP].VS>=Store[SP+1].VS;
  1226.     7: Store[SP].VB := Store[SP].VL>=Store[SP+1].VL;
  1227.     5: BEGIN
  1228.          CompareBlock;
  1229.          Store[SP].VB := B OR (Store[i1+i].VI >= Store[i2+i].VI)
  1230.        END
  1231.   END
  1232. END;
  1233.  
  1234.  
  1235. PROCEDURE PGrT;
  1236.  
  1237. BEGIN
  1238.   SP := SP-1;
  1239.   CASE P OF
  1240.     0: ErrorI(10);
  1241.     1: Store[SP].VB := Store[SP].VI>Store[SP+1].VI;
  1242.     6: Store[SP].VB := Store[SP].VC>Store[SP+1].VC;
  1243.     2: Store[SP].VB := Store[SP].VR>Store[SP+1].VR;
  1244.     3: Store[SP].VB := Store[SP].VB>Store[SP+1].VB;
  1245.     7: Store[SP].VB := Store[SP].VL>Store[SP+1].VL;
  1246.     4: ErrorI(11);
  1247.     5: BEGIN
  1248.          CompareBlock;
  1249.          Store[SP].VB :=  NOT B AND (Store[i1+i].VI > Store[i2+i].VI)
  1250.        END
  1251.   END
  1252. END;
  1253.  
  1254.  
  1255. PROCEDURE PLEq;
  1256.  
  1257. BEGIN
  1258.   SP := SP-1;
  1259.   CASE P OF
  1260.     0: ErrorI(10);
  1261.     1: Store[SP].VB := Store[SP].VI<=Store[SP+1].VI;
  1262.     6: Store[SP].VB := Store[SP].VC<=Store[SP+1].VC;
  1263.     2: Store[SP].VB := Store[SP].VR<=Store[SP+1].VR;
  1264.     3: Store[SP].VB := Store[SP].VB<=Store[SP+1].VB;
  1265.     4: Store[SP].VB := Store[SP].VS<=Store[SP+1].VS;
  1266.     7: Store[SP].VB := Store[SP].VL<=Store[SP+1].VL;
  1267.     5: BEGIN
  1268.          CompareBlock;
  1269.          Store[SP].VB := B OR (Store[i1+i].VI <= Store[i2+i].VI)
  1270.        END;
  1271.   END
  1272. END;
  1273.  
  1274.  
  1275. PROCEDURE PLes;
  1276.  
  1277. BEGIN
  1278.   SP := SP-1;
  1279.   CASE P OF
  1280.     0: ErrorI(10);
  1281.     1: Store[SP].VB := Store[SP].VI<Store[SP+1].VI;
  1282.     6: Store[SP].VB := Store[SP].VC<Store[SP+1].VC;
  1283.     2: Store[SP].VB := Store[SP].VR<Store[SP+1].VR;
  1284.     3: Store[SP].VB := Store[SP].VB<Store[SP+1].VB;
  1285.     7: Store[SP].VB := Store[SP].VL<Store[SP+1].VL;
  1286.     5: BEGIN
  1287.          CompareBlock;
  1288.          Store[SP].VB :=  NOT B AND (Store[i1+i].VI < Store[i2+i].VI)
  1289.        END;
  1290.   END
  1291. END;
  1292.  
  1293.  
  1294. PROCEDURE PUJp;
  1295.  
  1296. BEGIN
  1297.   PC := Q;
  1298. END;
  1299.  
  1300.  
  1301. PROCEDURE PFJp;
  1302.  
  1303. BEGIN
  1304.   IF NOT Store[SP].VB THEN PC := Q;
  1305.   SP := SP-1
  1306. END;
  1307.  
  1308.  
  1309. PROCEDURE PXJp;
  1310.  
  1311. BEGIN
  1312.   PC := Store[SP].VI+Q;
  1313.   SP := SP-1
  1314. END;
  1315.  
  1316.  
  1317. PROCEDURE PChkA;
  1318.  
  1319. BEGIN
  1320.   IF (Store[SP].VA<NP) OR (Store[SP].VA>(MaxStr-Q)) THEN
  1321.     ErrorI(12)
  1322. END;
  1323.  
  1324.  
  1325. PROCEDURE PChk;
  1326.  
  1327. BEGIN
  1328.   IF (Store[SP].VI<BoundTable[Q].lB) OR
  1329.      (Store[SP].VI>BoundTable[Q].uB) THEN
  1330.     ErrorI(13)
  1331. END;
  1332.  
  1333.  
  1334. PROCEDURE PChkB;
  1335.  
  1336. BEGIN
  1337.   IF (Ord(Store[SP].VB)<Ord(FALSE)) OR
  1338.      (Ord(Store[SP].VB)>Ord(TRUE)) THEN
  1339.     ErrorI(13);
  1340. END;
  1341.  
  1342.  
  1343. PROCEDURE PChkC;
  1344.  
  1345. BEGIN
  1346.   IF (Ord(Store[SP].VC)<BoundTable[Q].lB) OR
  1347.      (Ord(Store[SP].VC)>BoundTable[Q].uB) THEN
  1348.     ErrorI(13);
  1349. END;
  1350.  
  1351.  
  1352. PROCEDURE SPEoF;
  1353.  
  1354. VAR AD:Address; FileHandle,Offset:INTEGER;
  1355.  
  1356. BEGIN
  1357.   AD := Store[SP-1].VA; Offset := Store[SP].VI;
  1358.   FileHandle := Store[AD+Offset].VI;
  1359.   SP := SP-1;
  1360.   IF FileHandle < 0 THEN BEGIN  (*TEXTFILE*)
  1361.     IsTextEoF[FileHandle] := Eof(TextFiles[FileHandle]);
  1362.     Store[SP].VB := IsTextEoF[FileHandle]
  1363.   END
  1364.   ELSE Store[SP].VB := IsEoF[FileHandle];
  1365. END;
  1366.  
  1367.  
  1368. PROCEDURE PAdI;
  1369.  
  1370. BEGIN
  1371.   SP := SP-1;
  1372.   Store[SP].VI := Store[SP].VI+Store[SP+1].VI
  1373. END;
  1374.  
  1375.  
  1376. PROCEDURE PAdR;
  1377.  
  1378. BEGIN
  1379.   SP := SP-1;
  1380.   Store[SP].VR := Store[SP].VR+Store[SP+1].VR
  1381. END;
  1382.  
  1383.  
  1384. PROCEDURE PSbI;
  1385.  
  1386. BEGIN
  1387.   SP := SP-1;
  1388.   Store[SP].VI := Store[SP].VI-Store[SP+1].VI
  1389. END;
  1390.  
  1391.  
  1392. PROCEDURE PSbR;
  1393.  
  1394. BEGIN
  1395.   SP := SP-1;
  1396.   Store[SP].VR := Store[SP].VR-Store[SP+1].VR
  1397. END;
  1398.  
  1399.  
  1400. PROCEDURE PAnd;
  1401.  
  1402. BEGIN
  1403.   SP := SP-1;
  1404.   Store[SP].VB := Store[SP].VB AND Store[SP+1].VB
  1405. END;
  1406.  
  1407.  
  1408. PROCEDURE PIOr;
  1409.  
  1410. BEGIN
  1411.   SP := SP-1;
  1412.   Store[SP].VB := Store[SP].VB OR Store[SP+1].VB
  1413. END;
  1414.  
  1415.  
  1416. PROCEDURE PDif;
  1417.  
  1418. BEGIN
  1419.   SP := SP-1;
  1420.   Store[SP].VS := Store[SP].VS-Store[SP+1].VS
  1421. END;
  1422.  
  1423.  
  1424. PROCEDURE PInt;
  1425.  
  1426. BEGIN
  1427.   SP := SP-1;
  1428.   Store[SP].VS := Store[SP].VS*Store[SP+1].VS
  1429. END;
  1430.  
  1431.  
  1432. PROCEDURE PUni;
  1433.  
  1434. BEGIN
  1435.   SP := SP-1;
  1436.   Store[SP].VS := Store[SP].VS+Store[SP+1].VS;
  1437. END;
  1438.  
  1439.  
  1440. PROCEDURE PInN;
  1441.  
  1442. BEGIN
  1443.   SP := SP-1; i := Store[SP].VI;
  1444.   Store[SP].VB := i IN Store[SP+1].VS;
  1445. END;
  1446.  
  1447.  
  1448. PROCEDURE PMod;
  1449.  
  1450. BEGIN
  1451.   SP := SP-1;
  1452.   Store[SP].VI := Store[SP].VI MOD Store[SP+1].VI
  1453. END;
  1454.  
  1455.  
  1456. PROCEDURE POdd;
  1457.  
  1458. BEGIN
  1459.   Store[SP].VB := Odd(Store[SP].VI);
  1460. END;
  1461.  
  1462.  
  1463. PROCEDURE PMpI;
  1464.  
  1465. BEGIN
  1466.   SP := SP-1;
  1467.   Store[SP].VI := Store[SP].VI*Store[SP+1].VI
  1468. END;
  1469.  
  1470.  
  1471. PROCEDURE PMpR;
  1472.  
  1473. BEGIN
  1474.   SP := SP-1;
  1475.   Store[SP].VR := Store[SP].VR*Store[SP+1].VR;
  1476. END;
  1477.  
  1478.  
  1479. PROCEDURE PDvI;
  1480.  
  1481. BEGIN
  1482.   SP := SP-1;
  1483.   Store[SP].VI := Store[SP].VI DIV Store[SP+1].VI
  1484. END;
  1485.  
  1486.  
  1487. PROCEDURE PDvR;
  1488.  
  1489. BEGIN
  1490.   SP := SP-1;
  1491.   Store[SP].VR := Store[SP].VR / Store[SP+1].VR
  1492. END;
  1493.  
  1494.  
  1495. PROCEDURE PMov;
  1496.  
  1497. VAR Quelle, Ziel, i: Address;
  1498.  
  1499. BEGIN
  1500.   Ziel := Store[SP-1].VA;
  1501.   Quelle := Store[SP].VA;
  1502.   SP := SP-2;
  1503.   FOR i := 0 TO Q-1 DO
  1504.     Store[Ziel+i] := Store[Quelle+i];
  1505. END;
  1506.  
  1507.  
  1508. PROCEDURE PLCA;
  1509.  
  1510. BEGIN
  1511.   SP := SP+1;
  1512.   Store[SP].VA := Q;
  1513. END;
  1514.  
  1515.  
  1516. PROCEDURE PDec;
  1517.  
  1518. BEGIN
  1519.   Store[SP].VI := Store[SP].VI-Q;
  1520. END;
  1521.  
  1522.  
  1523. PROCEDURE PDecC;
  1524.  
  1525. VAR i:INTEGER;
  1526.  
  1527. BEGIN
  1528.   WITH Store[SP] DO FOR i := 1 TO Q DO VC := Pred(VC);
  1529. END;
  1530.  
  1531.  
  1532. PROCEDURE PIncC;
  1533.  
  1534. VAR i:INTEGER;
  1535.  
  1536. BEGIN
  1537.   WITH Store[SP] DO FOR i := 1 TO Q DO VC := Succ(VC)
  1538. END;
  1539.  
  1540.  
  1541. PROCEDURE PSTP;
  1542.  
  1543. BEGIN
  1544.   InterPreting := FALSE;
  1545. END;
  1546.  
  1547.  
  1548. PROCEDURE POrdI;
  1549.  
  1550. BEGIN
  1551.   WITH Store[SP] DO VI := Ord(VB);
  1552. END;
  1553.  
  1554.  
  1555. PROCEDURE POrdC;
  1556.  
  1557. BEGIN
  1558.   WITH Store[SP] DO VI := Ord(VC)
  1559. END;
  1560.  
  1561.  
  1562. PROCEDURE PChr;
  1563.  
  1564. BEGIN
  1565.   WITH Store[SP] DO VC := Chr(VI)
  1566. END;
  1567.  
  1568.  
  1569. PROCEDURE PUJC;
  1570.  
  1571. BEGIN
  1572.    ErrorI(14);
  1573. END;
  1574.  
  1575.  
  1576. PROCEDURE PLOD;
  1577.  
  1578. BEGIN
  1579.   AD := Basis(P)+Q;
  1580.   SP := SP+1;
  1581.   Store[SP] := Store[AD]
  1582. END;
  1583.  
  1584.  
  1585. PROCEDURE PLDO;
  1586.  
  1587. BEGIN
  1588.   SP := SP+1;
  1589.   Store[SP] := Store[Q]
  1590. END;
  1591.  
  1592.  
  1593. PROCEDURE PSTR;
  1594.  
  1595. BEGIN
  1596.   Store[Basis(P)+Q] := Store[SP];
  1597.   SP := SP-1
  1598. END;
  1599.  
  1600.  
  1601. PROCEDURE PSRO;
  1602.  
  1603. BEGIN
  1604.   Store[Q] := Store[SP];
  1605.   SP := SP-1;
  1606. END;
  1607.  
  1608.  
  1609. PROCEDURE PLDA;
  1610.  
  1611. BEGIN
  1612.   SP := SP+1;
  1613.   Store[SP].VA := Basis(P)+Q
  1614. END;
  1615.  
  1616.  
  1617. PROCEDURE PLAO;
  1618.  
  1619. BEGIN
  1620.   SP := SP+1;
  1621.   Store[SP].VA := Q
  1622. END;
  1623.  
  1624.  
  1625. PROCEDURE PSTO;
  1626.  
  1627. BEGIN
  1628.   Store[Store[SP-1].VA] := Store[SP];
  1629.   SP := SP-2
  1630. END;
  1631.  
  1632.  
  1633. PROCEDURE PLDC;
  1634.  
  1635. BEGIN
  1636.   SP := SP+1;
  1637.   CASE P OF
  1638.      1 : Store[SP].VI := Q;
  1639.      6 : Store[SP].VC := Chr(Q);
  1640.      3 : Store[SP].VB := (Q=1);
  1641.     ELSE  Store[SP].VA := MaxStr;
  1642.   END
  1643. END;
  1644.  
  1645.  
  1646. PROCEDURE PLCI;
  1647.  
  1648. BEGIN
  1649.   SP := SP+1;
  1650.   CASE P OF
  1651.     2 : Store[SP].VR := RealTable[Q];
  1652.     4 : Store[SP].VS := SetTable[Q];
  1653.     7 : Store[SP].VL := LongTable[Q];
  1654.   END;
  1655. END;
  1656.  
  1657.  
  1658. PROCEDURE NextCase (OP: INTEGER);
  1659.  
  1660. BEGIN
  1661.   CASE OP OF
  1662.    62 : BEGIN SP := SP-1; Store[SP].VL := Store[SP].VL+Store[SP+1].VL END;
  1663.    63 : BEGIN SP := SP-1; Store[SP].VL := Store[SP].VL-Store[SP+1].VL END;
  1664.    64 : BEGIN SP := SP-1; Store[SP].VL := Store[SP].VL DIV Store[SP+1].VL END;
  1665.    65 : BEGIN SP := SP-1; Store[SP].VL := Store[SP].VL MOD Store[SP+1].VL END;
  1666.    68 : BEGIN SP := SP-1; Store[SP].VL := Store[SP].VL*Store[SP+1].VL END;
  1667.    66 : Store[SP-1].VL := Store[SP-1].VI;
  1668.    67 : Store[SP].VL := Store[SP].VI;
  1669.    69 : Store[SP].VL := -Store[SP].VL;
  1670.    70 : Store[SP-1].VR := Store[SP-1].VL;
  1671.    71 : Store[SP].VR := Store[SP].VL;
  1672.    72 : Push(Keller,P);
  1673.    73 : Pop(Keller);
  1674.   END
  1675. END;
  1676.  
  1677.  
  1678. PROCEDURE Init1;
  1679.  
  1680. VAR i: INTEGER;
  1681.  
  1682. BEGIN
  1683.   Keller := NIL;  DebugPos := 1;
  1684.   DebugTable[1] := 'main    ';
  1685.   Push(Keller,1);
  1686.   FOR i := -2 TO -1 DO IsTextOpen[i] := FALSE;
  1687.   FOR i := -4 TO -1 DO IsTextOpen[i] := TRUE; (*INPUT,OUTPUT*)
  1688.   Store[8].VI := -3;
  1689.   Store[6].VI := -4; (* FILEHANDLE FUER INPUT,OUTPUT *)
  1690.   FOR i := 1 TO MaxFiles DO BEGIN
  1691.     IsOpen[i] := FALSE;  IsEoF[i] := TRUE;  IsEoLn[i] := TRUE;
  1692.   END;
  1693.   FOR i := 1 TO 4 DO FreeFiles[i] := TRUE;
  1694.   FOR i := -2 TO -1 DO FreeTextFiles[i] := TRUE;
  1695.   FOR i := -4 TO -3 DO FreeTextFiles[i] := FALSE;
  1696.   BoundPos := 0;  SetPos := 0;  LongPos := 0;  RealPos := 0;
  1697. END;
  1698.  
  1699.  
  1700. PROCEDURE ReadFileName;
  1701.  
  1702. VAR CodeName: STRING[80];
  1703.  
  1704. BEGIN
  1705.   WriteLn;
  1706.   Write('Dateiname ohne Suffix : ');  ReadLn(CodeName);
  1707.   CodeName := Concat(CodeName,'.cod');
  1708.   Assign(PCode,CodeName);
  1709.   ReSet(PCode);
  1710.   (* RESET(PCODE,CODENAME);*)
  1711.   WriteLn;
  1712. END;
  1713.  
  1714.  
  1715. BEGIN
  1716.   WriteLn;
  1717.   WriteLn('PASCOMP  -   PASCAL International P-CODE INTERPRETER  v0.1');
  1718.   WriteLn('             (C) 1987   J.Velmans & PASCAL INT.');
  1719.   WriteLn;
  1720.   ReadFileName;
  1721.   Init1;
  1722.   WriteLn('lese Programm... ');
  1723.   Load;
  1724.   WriteLn('interpretiere Programm... ');
  1725.   WriteLn(Output);
  1726.   PC := 0; SP := -1; MP := 0; NP := MaxStk; EP := 5;
  1727.   InterPreting := TRUE;
  1728.   2:
  1729.   WHILE InterPreting AND NOT KeyPressed DO BEGIN
  1730.     HelpRec := Code[PC];
  1731.     WITH HelpRec DO BEGIN
  1732.       OP := OP1; P := P1; Q := Q1;
  1733.     END;
  1734.     PC := PC+1;
  1735.     CASE OP OF
  1736.       123,124,125,126,127,128,0: PLOD;
  1737.       75,76,77,78,79,80,1      : PLDO;
  1738.       81,82,83,84,85,86,2      : PSTR;
  1739.       87,88,89,90,91,92,3      : PSRO;
  1740.       4                        : PLDA;
  1741.       5                        : PLAO;
  1742.       93,94,95,96,97,98,6      : PSTO;
  1743.       7                        : PLDC;
  1744.       8                        : PLCI;
  1745.       99,100,101,102,103,104,9 : BEGIN
  1746.                                    AD := Store[SP].VA+Q;
  1747.                                    Store[SP] := Store[AD]
  1748.                                  END;
  1749.       105,106,107,108,110,10   : Store[SP].VI := Store[SP].VI+Q;
  1750.       109                      : PIncC;
  1751.       11                       : BEGIN
  1752.                                    Store[SP+2].VM := Basis(P);
  1753.                                    Store[SP+3].VM := MP;
  1754.                                    Store[SP+4].VM := EP;
  1755.                                    SP := SP+5;
  1756.                                  END;
  1757.       12                       : BEGIN
  1758.                                    MP := SP-(P+4);
  1759.                                    Store[MP+4].VM := PC;
  1760.                                    PC := Q
  1761.                                  END;
  1762.       13 : IF P=1 THEN BEGIN
  1763.              SP := MP+Q;
  1764.              IF SP > NP THEN BEGIN
  1765.                WriteLn('Speicher-Ueberlauf: SP=',SP,' NP=',NP,' ',SP>NP);
  1766.                ErrorI(4);
  1767.              END
  1768.            END
  1769.            ELSE BEGIN
  1770.              EP := SP+Q;
  1771.              IF EP > NP THEN ErrorI(4);
  1772.            END;
  1773.       14 : BEGIN
  1774.              CASE P OF
  1775.                0 : SP := MP-1;
  1776.                1,2,3,4,5,6 : SP := MP
  1777.              END;
  1778.              PC  :=  Store[MP+4].VM;
  1779.              EP  :=  Store[MP+3].VM;
  1780.              MP  :=  Store[MP+2].VM;
  1781.            END;
  1782.       15 : CallStdProcs;
  1783.       16 : BEGIN
  1784.              i := Store[SP].VI;
  1785.              SP := SP-1;
  1786.              Store[SP].VA := Q*i+Store[SP].VA
  1787.             END;
  1788.       17 : PEqu;
  1789.       18 : PNEq;
  1790.       19 : PGEq;
  1791.       20 : PGrT;
  1792.       21 : PLEq;
  1793.       22 : PLes;
  1794.       23 : PUJp;
  1795.       24 : PFJp;
  1796.       25 : PXJp;
  1797.       111: PChkA;
  1798.       112,113,116,26 : PChk;
  1799.       114: PChkB;
  1800.       115: PChkC;
  1801.       27 : SPEoF;
  1802.       28 : PAdI;
  1803.       29 : PAdR;
  1804.       30 : PSbI;
  1805.       31 : PSbR;
  1806.       32 : Store[SP].VS := [Store[SP].VI];
  1807.       33 : Store[SP].VR := Store[SP].VI;
  1808.       34 : Store[SP-1].VR := Store[SP-1].VI;
  1809.       35 : Store[SP].VI := Trunc(Store[SP].VR);
  1810.       36 : Store[SP].VI := -Store[SP].VI;
  1811.       37 : Store[SP].VR := -Store[SP].VR;
  1812.       38 : Store[SP].VI := Sqr(Store[SP].VI);
  1813.       39 : Store[SP].VR := Sqr(Store[SP].VR);
  1814.       40 : Store[SP].VI := ABS(Store[SP].VI);
  1815.       41 : Store[SP].VR := ABS(Store[SP].VR);
  1816.       42 : Store[SP].VB := NOT Store[SP].VB;
  1817.       43 : PAnd;
  1818.       44 : PIOr;
  1819.       45 : PDif;
  1820.       46 : PInt;
  1821.       47 : PUni;
  1822.       48 : PInN;
  1823.       49 : PMod;
  1824.       50 : POdd;
  1825.       51 : PMpI;
  1826.       52 : PMpR;
  1827.       53 : PDvI;
  1828.       54 : PDvR;
  1829.       55 : PMov;
  1830.       56 : PLCA;
  1831.       117,118,119,120,122,57 : PDec;
  1832.       121: PDecC;
  1833.       58 : PSTP;
  1834.       59,129,130,131,134: ;
  1835.       132: POrdI;
  1836.       133: POrdC;
  1837.       60 : PChr;
  1838.       61 : PUJC;
  1839.       ELSE   NextCase(OP);
  1840.     END
  1841.   END;
  1842.   IF KeyPressed THEN BEGIN
  1843.     Read(c);
  1844.     IF c = Chr(3) THEN BEGIN (* CTRL-C *)
  1845.       WriteLn;  WriteLn;
  1846.       WriteLn('Abbruch durch Benutzer !');
  1847.     END
  1848.     ELSE GOTO 2
  1849.   END;
  1850.   1:
  1851.   WriteLn;
  1852.   Write('Taste druecken...');
  1853.   REPEAT UNTIL KeyPressed;
  1854. END.
  1855.