home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 2 / goldfish_vol2_cd1.bin / files / dev / obero / oberon-a / source / oc / ocs.mod < prev    next >
Text File  |  1994-09-03  |  24KB  |  834 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: OCS.mod $
  4.   Description: Implements the lexical scanner and error reporting
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 4.10 $
  8.       $Author: fjc $
  9.         $Date: 1994/09/03 14:35:10 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1994, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. ***************************************************************************)
  19.  
  20. MODULE OCS;
  21.  
  22. (*
  23. ** $C= CaseChk       $I= IndexChk  $L= LongAdr   $N= NilChk
  24. ** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
  25. ** $V= OvflChk       $Z= ZeroVars
  26. *)
  27.  
  28. IMPORT Files, IO := StdIO, Str := Strings, OCRev, OCG, SYS := SYSTEM;
  29.  
  30. (* --- Exported objects ------------------------------------------------- *)
  31.  
  32. (* Symbols *)
  33.  
  34. CONST
  35.   null * =  0;  times * =  1;  slash * =  2;  div * =  3;  mod * =  4;
  36.   and * =  5;  plus * =  6;  minus * =  7;  or * =  8;  eql * =  9;
  37.   neq * = 10; lss * = 11;  leq * = 12;  gtr * = 13;  geq * = 14; in * = 15;
  38.   is * = 16; arrow * = 17;  period * = 18;  comma * = 19; colon * = 20;
  39.   upto * = 21; rparen * = 22;  rbrak * = 23;  rbrace * = 24; of * = 25;
  40.   then * = 26; do * = 27;  to * = 28;  lparen * = 29; lbrak * = 30;
  41.   lbrace * = 31;  not * = 32;  becomes * = 33;  number * = 34; nil * = 35;
  42.   string * = 36; ident * = 37;  semicolon * = 38;  bar * = 39; end * = 40;
  43.   else * = 41; elsif * = 42;  until * = 43;  if * = 44; case * = 45;
  44.   while * = 46; repeat * = 47; loop * = 48;  with * = 49; exit * = 50;
  45.   return * = 51; array * = 52; record * = 53;  pointer * = 54;
  46.   cpointer * = 55; bpointer * = 56; begin * = 57; const * = 58;
  47.   type * = 59; var * = 60; procedure * = 61; import * = 62;
  48.   module * = 63; libcall * = 64; eof * = 65; by * = 66; for * = 67;
  49.  
  50. CONST
  51.   maxStrLen = 256;
  52.  
  53. (* name, numtyp, intval, realval, lrlval are implicit results of Get () *)
  54.  
  55. VAR
  56.   numtyp *  : INTEGER; (* 1 = char, 2 = integer, 3 = real, 4 = longreal *)
  57.   intval *  : LONGINT;
  58.   realval * : REAL;
  59.   lrlval *  : LONGREAL;
  60.   scanerr * : BOOLEAN;
  61.   name *    : ARRAY maxStrLen OF CHAR;
  62.  
  63.   (* compiler switches *)
  64.  
  65.   allowGlobalSwitches *, portableCode *, copyDynArray *, typeCheck *,
  66.   overflowCheck *, indexCheck *, rangeCheck *, caseCheck *, zeroVars *,
  67.   longVars *, nilCheck *, returnCheck *, garbageCollect *, stackCheck*,
  68.   saveAllRegs*, saveRegs*
  69.   (*createObj * *)
  70.     : BOOLEAN;
  71.  
  72.   binErrFile * : BOOLEAN;
  73.  
  74. (* --- Local objects ---------------------------------------------------- *)
  75.  
  76. CONST
  77.   KW = 43; (* size of hash table *)
  78.   maxDig = 32;
  79.   DigitString = "0123456789ABCDEF";
  80.  
  81.   (* Default compiler switches *)
  82.  
  83.   DefPortableCode = TRUE; DefCopyDynArray = TRUE; DefTypeCheck = TRUE;
  84.   DefOverflowCheck = TRUE; DefIndexCheck = TRUE; DefRangeCheck = TRUE;
  85.   DefCaseCheck = TRUE; DefZeroVars = FALSE; DefLongVars = FALSE;
  86.   DefNilCheck = TRUE; DefReturnCheck = TRUE; DefGarbageCollect = TRUE;
  87.   DefStackCheck = TRUE; DefSaveAllRegs = FALSE; DefSaveRegs = FALSE;
  88.   (*DefCreateObj = TRUE;*)
  89.  
  90. VAR
  91.   R         : Files.Rider;
  92.   W         : Files.Rider;
  93.   ch        : CHAR; (* current character *)
  94.   lastpos   : LONGINT; (* error position in file *)
  95.   i         : INTEGER;
  96.   keyTab    : ARRAY KW OF
  97.     RECORD
  98.       symb, alt, alt2  : INTEGER;
  99.       id   : ARRAY 12 OF CHAR;
  100.     END; (* Ptr *)
  101.   errorFile : Files.File;
  102.   Digit : ARRAY 17 OF CHAR;
  103.   line, col : INTEGER;
  104.   bumpLine : BOOLEAN;
  105.   filename : ARRAY 32 OF CHAR;
  106.  
  107.  
  108. (*------------------------------------*)
  109. (* $D- disable copying of open arrays *)
  110. PROCEDURE WriteStr (s : ARRAY OF CHAR);
  111.  
  112. BEGIN (* WriteStr *)
  113.   Files.WriteBytes (W, s, SYS.STRLEN (s));
  114. END WriteStr;
  115.  
  116. (*------------------------------------*)
  117. PROCEDURE WriteInt (i : LONGINT);
  118.  
  119.   (*------------------------------------*)
  120.   PROCEDURE WriteDigit (i : LONGINT);
  121.  
  122.   BEGIN (* WriteDigit *)
  123.     IF i > 0 THEN
  124.       WriteDigit (i DIV 10);
  125.       Files.Write (W, Digit [i MOD 10]);
  126.     END; (* IF *)
  127.   END WriteDigit;
  128.  
  129. BEGIN (* WriteInt *)
  130.   IF i = 0 THEN
  131.     Files.Write (W, "0");
  132.   ELSE
  133.     IF i < 0 THEN
  134.       Files.Write (W, "-");
  135.     END; (* IF *)
  136.     WriteDigit (ABS (i));
  137.   END; (* ELSE *)
  138. END WriteInt;
  139.  
  140. (*------------------------------------*)
  141. PROCEDURE Mark * (n : INTEGER);
  142.  
  143.   (* CONST name = "Mark"; *)
  144.  
  145.   VAR pos : LONGINT;
  146.  
  147. BEGIN (* Mark *)
  148.   scanerr := TRUE; pos := Files.Pos (R);
  149.  
  150.   (*
  151.   IF OCG.Trace THEN
  152.     OCG.WriteStr ("Mark: line "); OCG.WriteInt (line);
  153.     OCG.WriteStr (", col "); OCG.WriteInt (col);
  154.     OCG.WriteStr (": err = "); OCG.WriteInt (n);
  155.     OCG.WriteStr ("\n");
  156.     lastpos := pos
  157.   ELSIF OCG.Verbose OR (lastpos # pos) THEN
  158.   *)
  159.     IF pos > (lastpos + 4) THEN
  160.       IF binErrFile THEN
  161.         IF errorFile # NIL THEN
  162.           Files.WriteBytes (W, line, 2);
  163.           Files.WriteBytes (W, col, 2);
  164.           Files.WriteBytes (W, n, 2);
  165.         END
  166.       ELSE
  167.         IF errorFile # NIL THEN
  168.           WriteStr (" line "); WriteInt (line);
  169.           WriteStr (", col "); WriteInt (col);
  170.           WriteStr (": err = "); WriteInt (n);
  171.           Files.Write (W, 0AX);
  172.         END
  173.       END;
  174.       lastpos := pos
  175.     END
  176.   (* END *)
  177. END Mark;
  178.  
  179. (*------------------------------------*)
  180. PROCEDURE GetCh ();
  181.  
  182. BEGIN (* GetCh *)
  183.   IF bumpLine THEN
  184.     INC (line); col := 0; bumpLine := FALSE;
  185.     (*IF OCG.Trace THEN
  186.       IF ~OCG.Verbose THEN IO.WriteInt (line); IO.Write (0DX) END
  187.     ELSIF OCG.Verbose OR ((line MOD 10) = 0) THEN*)
  188.     IF ~OCG.Verbose & ((line MOD 10) = 0) THEN
  189.       IO.WriteInt (line); IO.Write (0DX)
  190.     END
  191.   END;
  192.  
  193.   Files.Read (R, ch);
  194.  
  195.   IF ch = 0AX THEN bumpLine := TRUE
  196.   ELSIF ch = 09X THEN INC (col, 8)
  197.   ELSE INC (col)
  198.   END;
  199.  
  200.   IF (*OCG.Trace &*) OCG.Verbose THEN
  201.       IO.WriteF2 ("%ld:%ld\r", LONG (line), LONG (col))
  202.   END
  203. END GetCh;
  204.  
  205. (*------------------------------------*)
  206. PROCEDURE Hval (ch : CHAR) : INTEGER;
  207.  
  208.   VAR d : INTEGER;
  209.  
  210. BEGIN (* Hval *)
  211.   d := ORD (ch) - 30H; (* d >= 0 *)
  212.   IF d >= 10 THEN
  213.     IF (d >= 17) & (d < 23) THEN
  214.       DEC (d, 7);
  215.     ELSE
  216.       d := 0;
  217.       Mark (2);
  218.     END; (* ELSE *)
  219.   END; (* IF *)
  220.   RETURN d
  221. END Hval;
  222.  
  223. (*------------------------------------*)
  224. PROCEDURE String (VAR sym : INTEGER; startCh : CHAR);
  225.  
  226.   VAR i, j, val : INTEGER;
  227.  
  228. BEGIN (* String *)
  229.   i := 0;
  230.   LOOP
  231.     GetCh ();
  232.     IF ch = startCh THEN EXIT
  233.     ELSIF ch < " " THEN Mark (3); EXIT
  234.     END;
  235.  
  236.     IF ~portableCode THEN (* process escaped chars in string or char *)
  237.       IF ch = 5CX THEN
  238.         GetCh (); IF ch < " " THEN Mark (3); EXIT END;
  239.         CASE ch OF
  240.           "b" : ch := 08X | (* BS *)
  241.           "e" : ch := 1BX | (* ESC *)
  242.           "f" : ch := 0CX | (* FF *)
  243.           "n" : ch := 0AX | (* LF *)
  244.           "0", "o" : ch := 00X | (* NUL*)
  245.           "r" : ch := 0DX | (* CR *)
  246.           "t" : ch := 09X | (* HT *)
  247.           "v" : ch := 0BX | (* VT *)
  248.           "x" : (* hexadecimal value *)
  249.             GetCh (); IF ch < " " THEN Mark (3); EXIT END;
  250.             val := Hval (ch) * 16;
  251.             GetCh (); IF ch < " " THEN Mark (3); EXIT END;
  252.             val := val + Hval (ch);
  253.             ch := CHR (val);
  254.           |
  255.         ELSE (* insert following character = do nothing *)
  256.         END;
  257.       END;
  258.     END; (* IF *)
  259.  
  260.     IF i < maxStrLen - 1 THEN
  261.       name [i] := ch;
  262.       INC (i)
  263.     ELSE
  264.       Mark (212); i := 0
  265.     END;
  266.   END; (* LOOP *)
  267.   GetCh ();
  268.   sym := string;
  269.   name [i] := 0X;
  270.   intval := i
  271. END String;
  272.  
  273. (*------------------------------------*)
  274. PROCEDURE Identifier (VAR sym : INTEGER);
  275.  
  276.   VAR i, k : INTEGER;
  277.  
  278. BEGIN (* Identifier *)
  279.   i := 0; k := 0;
  280.   REPEAT
  281.     IF i < (maxStrLen - 1) THEN
  282.       name [i] := ch; INC (i);
  283.       (*$V- ignore overflows*)
  284.       INC (k, ORD (ch));
  285.       (*$V+*)
  286.     END; (* IF *)
  287.     GetCh ();
  288.   UNTIL (ch < "0") OR (ch > "9") & (CAP (ch) < "A") OR (CAP (ch) > "Z");
  289.  
  290.   name [i] := 0X;
  291.   (*$V- ignore overflows*)
  292.   k := (k + i) MOD KW; (* hash function *)
  293.   (*$V=*)
  294.  
  295.   IF (keyTab [k].symb # 0) & (keyTab [k].id = name) THEN
  296.     sym := keyTab [k].symb;
  297.   ELSE
  298.     i := k; k := keyTab [i].alt;
  299.     IF (keyTab [k].symb # 0) & (keyTab [k].id = name) THEN
  300.       sym := keyTab [k].symb;
  301.     ELSE
  302.       k := keyTab [i].alt2;
  303.       IF (keyTab [k].symb # 0) & (keyTab [k].id = name) THEN
  304.         sym := keyTab [k].symb;
  305.       ELSE
  306.         sym := ident;
  307.       END
  308.     END
  309.   END
  310. END Identifier;
  311.  
  312. (*------------------------------------*)
  313. PROCEDURE TenL (e : INTEGER) : LONGREAL;
  314.  
  315.   VAR result : LONGREAL;
  316.  
  317. BEGIN (* TenL *)
  318.   result := 1.0;
  319.   WHILE e > 0 DO result := result * 10.0; DEC (e) END;
  320.   RETURN result
  321. END TenL;
  322.  
  323. (*------------------------------------*)
  324. PROCEDURE Ten (e : INTEGER) : REAL;
  325.  
  326.   VAR result : REAL;
  327.  
  328. BEGIN (* Ten *)
  329.   result := 1.0;
  330.   WHILE e > 0 DO result := result * 10.0; DEC (e) END;
  331.   RETURN result
  332. END Ten;
  333.  
  334. (*------------------------------------*)
  335. PROCEDURE Number;
  336.  
  337.   VAR
  338.     i, j, h, d, e, n : INTEGER;
  339.     x, f : REAL;
  340.     y, g : LONGREAL;
  341.     lastCh : CHAR;
  342.     neg : BOOLEAN;
  343.     dig : ARRAY maxDig OF CHAR;
  344.  
  345.   (*------------------------------------*)
  346.   PROCEDURE ReadScaleFactor ();
  347.  
  348.   BEGIN (* ReadScaleFactor *)
  349.     GetCh ();
  350.     IF ch = "-" THEN
  351.       neg := TRUE;
  352.       GetCh ();
  353.     ELSE
  354.       neg := FALSE;
  355.       IF ch = "+" THEN GetCh () END;
  356.     END; (* ELSE *)
  357.     IF ("0" <= ch) & (ch <= "9") THEN
  358.       REPEAT
  359.         e := e * 10 + ORD (ch) - 30H;
  360.         GetCh ();
  361.       UNTIL (ch < "0") OR ("9" < ch);
  362.     ELSE
  363.       Mark (2);
  364.     END; (* ELSE *)
  365.   END ReadScaleFactor;
  366.  
  367. BEGIN (* Number *)
  368.   i := 0;
  369.   REPEAT
  370.     dig [i] := ch; INC (i); GetCh ();
  371.   UNTIL (ch < "0") OR ("9" < ch) & (CAP (ch) < "A") OR ("Z" < CAP (ch));
  372.   lastCh := ch; j := 0;
  373.   WHILE (j < i - 1) & (dig [j] = "0") DO INC (j) END;
  374.   IF ch = "." THEN
  375.     GetCh ();
  376.     IF ch = "." THEN lastCh := 0X; ch := 7FX; END;
  377.   END; (* IF *)
  378.   IF lastCh = "." THEN (* decimal point *)
  379.     h := i;
  380.     WHILE ("0" <= ch) & (ch <= "9") DO (* read fraction *)
  381.       IF i < maxDig THEN dig [i] := ch; INC (i) END;
  382.       GetCh ();
  383.     END; (* WHILE *)
  384.     IF ch = "D" THEN (* LONGREAL *)
  385.       y := 0; g := 1; e := 0;
  386.       WHILE j < h DO y := y * 10 + (ORD (dig [j]) - 30H); INC (j) END;
  387.       WHILE j < i DO
  388.         g := g / 10; y := (ORD (dig [j]) - 30H) * g + y; INC (j)
  389.       END;
  390.       ReadScaleFactor ();
  391.       IF neg THEN
  392.         IF e <= OCG.MaxLExp THEN y := y / TenL (e) ELSE y := 0 END;
  393.       ELSIF e > 0 THEN
  394.         IF e <= OCG.MaxLExp THEN y := TenL (e) * y
  395.         ELSE y := 0; Mark (203)
  396.         END
  397.       END; (* ELSE *)
  398.       numtyp := 4; lrlval := y;
  399.     ELSE
  400.       x := 0; f := 1; e := 0;
  401.       WHILE j < h DO x := x * 10 + (ORD (dig [j]) - 30H); INC (j) END;
  402.       WHILE j < i DO
  403.         f := f / 10; x := (ORD (dig [j]) - 30H) * f + x; INC (j)
  404.       END;
  405.       IF ch = "E" THEN ReadScaleFactor() END;
  406.       IF neg THEN
  407.         IF e <= OCG.MaxExp THEN x := x / Ten (e) ELSE x := 0 END;
  408.       ELSE
  409.         IF e <= OCG.MaxExp THEN x := Ten (e) * x
  410.         ELSE x := 0; Mark (203)
  411.         END;
  412.       END; (* ELSE *)
  413.       numtyp := 3; realval := x;
  414.     END; (* ELSE *)
  415.   ELSE (* Integer *)
  416.     lastCh := dig [i - 1]; intval := 0;
  417.     IF lastCh = "H" THEN (* hex number *)
  418.       IF j < (i - 1) THEN
  419.         DEC (i); intval := Hval (dig [j]); INC (j);
  420.         IF i - j <= 7 THEN
  421.           IF (i - j = 7) & (intval >= 8) THEN DEC (intval, 16) END;
  422.           WHILE j < i DO
  423.             intval := Hval (dig [j]) + intval * 10H; INC (j)
  424.           END;
  425.         ELSE
  426.           Mark (203)
  427.         END; (* ELSE *)
  428.       END; (* IF *)
  429.     ELSIF lastCh = "X" THEN (* character code in hex *)
  430.       DEC (i);
  431.       WHILE j < i DO
  432.         intval := Hval (dig [j]) + intval * 10H; INC (j);
  433.         IF intval > OCG.MaxChar THEN Mark (203); intval := 0 END;
  434.       END; (* WHILE *)
  435.     ELSE (* decimal *)
  436.       WHILE j < i DO
  437.         d := ORD (dig [j]) - 30H;
  438.         IF d < 10 THEN
  439.           IF intval <= (MAX (LONGINT) - d) DIV 10 THEN
  440.             intval := intval * 10 + d;
  441.           ELSE
  442.             Mark (203); intval := 0;
  443.           END;
  444.         ELSE
  445.           Mark (2); intval := 0;
  446.         END; (* ELSE *)
  447.         INC (j);
  448.       END; (* WHILE *)
  449.     END; (* ELSE *)
  450.     IF lastCh = "X" THEN numtyp := 1 ELSE numtyp := 2 END;
  451.   END; (* ELSE *)
  452. END Number;
  453.  
  454. (*------------------------------------*)
  455. PROCEDURE Get * (VAR sym : INTEGER);
  456.  
  457.   VAR
  458.     s : INTEGER;
  459.  
  460.   (*------------------------------------*)
  461.   PROCEDURE Comment (); (* do not read after end of file *)
  462.  
  463.     VAR swCh : CHAR; sw : BOOLEAN; cline, ccol : INTEGER;
  464.  
  465.   BEGIN (* Comment *)
  466.     cline := line; ccol := col;
  467.     GetCh ();
  468.     LOOP
  469.       LOOP
  470.         WHILE ch = "(" DO
  471.           GetCh ();
  472.           IF ch = "*" THEN Comment (); END;
  473.         END; (* WHILE *)
  474.         WHILE ch = "$" DO
  475.           GetCh ();
  476.           IF ch # "*" THEN
  477.             swCh := ch; GetCh ();
  478.             IF ch = "=" THEN
  479.               IF (swCh = "P") OR (swCh = "G") THEN
  480.                 IF allowGlobalSwitches THEN
  481.                   IF swCh = "P" THEN portableCode := DefPortableCode
  482.                   ELSIF swCh = "G" THEN garbageCollect := DefGarbageCollect
  483.                   END
  484.                 ELSE
  485.                   IO.WriteStr (" !! Invalid location for global compiler switch\n")
  486.                 END
  487.               ELSE
  488.                 CASE swCh OF
  489.                   "D" : copyDynArray := DefCopyDynArray
  490.                   |
  491.                   "T" : typeCheck := DefTypeCheck
  492.                   |
  493.                   "V" : overflowCheck := DefOverflowCheck
  494.                   |
  495.                   "I" : indexCheck := DefIndexCheck
  496.                   |
  497.                   "R" : rangeCheck := DefRangeCheck
  498.                   |
  499.                   "C" : caseCheck := DefCaseCheck
  500.                   |
  501.                   "L" : longVars := DefLongVars
  502.                   |
  503.                   "N" : nilCheck := DefNilCheck
  504.                   |
  505.                   "r" : returnCheck := DefReturnCheck
  506.                   |
  507.                   "S" : stackCheck := DefStackCheck
  508.                   |
  509.                   "Z" : zeroVars := DefZeroVars
  510.                   |
  511.                   "A" : saveAllRegs := DefSaveAllRegs
  512.                   |
  513.                   "s" : saveRegs := DefSaveRegs
  514.                   |
  515.                 ELSE
  516.                   IO.WriteStr (" !! Unrecognised compiler switch\n")
  517.                 END; (* CASE swCh *)
  518.               END; (* ELSE *)
  519.             ELSIF (ch = "+") OR (ch = "-") THEN
  520.               sw := (ch = "+");
  521.               IF (swCh = "P") OR (swCh = "G") THEN
  522.                 IF allowGlobalSwitches THEN
  523.                   IF swCh = "P" THEN portableCode := sw
  524.                   ELSIF swCh = "G" THEN garbageCollect := sw
  525.                   END
  526.                 ELSE
  527.                   IO.WriteStr (" !! Invalid location for global compiler switch\n")
  528.                 END
  529.               ELSE
  530.                 CASE swCh OF
  531.                   "D" : copyDynArray := sw
  532.                   |
  533.                   "T" : typeCheck := sw
  534.                   |
  535.                   "V" : overflowCheck := sw
  536.                   |
  537.                   "I" : indexCheck := sw
  538.                   |
  539.                   "R" : rangeCheck := sw
  540.                   |
  541.                   "C" : caseCheck := sw
  542.                   |
  543.                   "L" : longVars := sw
  544.                   |
  545.                   "N" : nilCheck := sw
  546.                   |
  547.                   "r" : returnCheck := sw
  548.                   |
  549.                   "S" : stackCheck := sw
  550.                   |
  551.                   "Z" : zeroVars := sw
  552.                   |
  553.                   "A" : saveAllRegs := sw
  554.                   |
  555.                   "s" : saveRegs := sw
  556.                   |
  557.                 ELSE
  558.                   IO.WriteStr (" !! Unrecognised compiler switch\n")
  559.                 END; (* CASE swCh *)
  560.               END; (* ELSE *)
  561.             END; (* IF *)
  562.           END; (* IF *)
  563.         END; (* WHILE *)
  564.         IF ch = "*" THEN GetCh (); EXIT; END;
  565.         IF ch = 0X THEN EXIT; END;
  566.         GetCh ();
  567.       END; (* LOOP *)
  568.       IF ch = ")" THEN GetCh (); EXIT; END;
  569.       IF ch = 0X THEN line := cline; col := ccol; Mark (5); EXIT; END;
  570.     END; (* LOOP *)
  571.   END Comment;
  572.  
  573. BEGIN (* Get *)
  574.   LOOP (* ignore control characters (and spaces) *)
  575.     IF ch <= " " THEN
  576.       IF ch = 0X THEN
  577.         ch := " "; EXIT;
  578.       ELSE
  579.         GetCh ();
  580.       END; (* ELSE *)
  581.     ELSIF ch > 7FX THEN
  582.       GetCh ();
  583.     ELSE
  584.       EXIT;
  585.     END; (* ELSE *)
  586.   END; (* LOOP *)
  587.   CASE ch OF (* " " <= ch <= 7FX *)
  588.     " " : s := eof; ch := 0X;
  589.     |
  590.     5CX, "!", "$", "%", "?", "@", "_", "`" : s := null; GetCh ();
  591.     |
  592.     22X, "'" : String (s, ch);
  593.     |
  594.     "#" : s := neq; GetCh ();
  595.     |
  596.     "&" : s := and; GetCh ();
  597.     |
  598.     "(" :
  599.       GetCh ();
  600.       IF ch = "*" THEN Comment (); Get (s) ELSE s := lparen; END;
  601.     |
  602.     ")" : s := rparen; GetCh ();
  603.     |
  604.     "*" : s := times; GetCh ();
  605.     |
  606.     "+" : s := plus; GetCh ();
  607.     |
  608.     "," : s := comma; GetCh ();
  609.     |
  610.     "-" : s := minus; GetCh ();
  611.     |
  612.     "." :
  613.       GetCh ();
  614.       IF ch = "." THEN GetCh (); s := upto; ELSE s := period; END;
  615.     |
  616.     "/" : s := slash; GetCh ();
  617.     |
  618.     "0" .. "9" : Number (); s := number;
  619.     |
  620.     ":" :
  621.       GetCh ();
  622.       IF ch = "=" THEN GetCh (); s := becomes ELSE s := colon END;
  623.     |
  624.     ";" : s := semicolon; GetCh ();
  625.     |
  626.     "<" :
  627.       GetCh ();
  628.       IF ch = "=" THEN GetCh (); s := leq; ELSE s := lss; END;
  629.     |
  630.     "=" : s := eql; GetCh ();
  631.     |
  632.     ">" :
  633.       GetCh ();
  634.       IF ch = "=" THEN GetCh (); s := geq; ELSE s := gtr; END;
  635.     |
  636.     "A" .. "Z" : Identifier (s);
  637.     |
  638.     "[" : s := lbrak; GetCh ();
  639.     |
  640.     "]" : s := rbrak; GetCh ();
  641.     |
  642.     "^" : s := arrow; GetCh ();
  643.     |
  644.     "a" .. "z" : Identifier (s);
  645.     |
  646.     "{" : s := lbrace; GetCh ();
  647.     |
  648.     "}" : s := rbrace; GetCh ();
  649.     |
  650.     "|" : s := bar; GetCh ();
  651.     |
  652.     "~" : s := not; GetCh ();
  653.     |
  654.     7FX : s := upto; GetCh ();
  655.     |
  656.   ELSE
  657.     Mark (1001); Mark (ORD (ch))
  658.   END; (* CASE ch *)
  659.   sym := s;
  660. END Get;
  661.  
  662. (*------------------------------------*)
  663. PROCEDURE Init * (source : Files.File);
  664.  
  665. BEGIN (* Init *)
  666.   ch := " "; scanerr := FALSE; lastpos := -1;
  667.   Files.Set (R, source, 0);
  668.   line := 1; col := 0; bumpLine := FALSE;
  669. END Init;
  670.  
  671. (*------------------------------------*)
  672. (* $D- disable copying of open arrays *)
  673. PROCEDURE StartModule * (name : ARRAY OF CHAR);
  674.  
  675.   VAR res : LONGINT; tag : ARRAY 5 OF CHAR;
  676.  
  677. BEGIN (* StartModule *)
  678.   COPY (name, filename); Str.Append (filename, ".err");
  679.   Files.Delete (filename, res);
  680.   errorFile := Files.New (filename);
  681.   IF errorFile = NIL THEN
  682.     IO.WriteF1 (" !! Could not open error file %s\n", SYS.ADR (filename));
  683.     HALT (20)
  684.   END;
  685.   Files.Set (W, errorFile, 0);
  686.   IF binErrFile THEN
  687.     (* Output error file tag 'OAER' *)
  688.     tag := "OAER"; Files.WriteBytes (W, tag, 4)
  689.   ELSE
  690.     WriteStr (OCRev.vers); WriteStr (" : compilation error listing\n");
  691.     WriteStr ("---------------------------------------------------------------------------\n\n");
  692.     WriteStr ("Module: "); WriteStr (name); Files.Write (W, 0AX);
  693.   END;
  694.  
  695.   allowGlobalSwitches := TRUE; portableCode := DefPortableCode;
  696.   copyDynArray := DefCopyDynArray; typeCheck := DefTypeCheck;
  697.   overflowCheck := DefOverflowCheck; indexCheck := DefIndexCheck;
  698.   rangeCheck := DefRangeCheck; caseCheck := DefCaseCheck;
  699.   zeroVars := DefZeroVars; longVars := DefLongVars; nilCheck := DefNilCheck;
  700.   returnCheck := DefReturnCheck; garbageCollect := DefGarbageCollect;
  701.   stackCheck := DefStackCheck; saveAllRegs := DefSaveAllRegs;
  702.   saveRegs := DefSaveRegs;
  703.   (*createObj := DefCreateObj;*)
  704. END StartModule;
  705.  
  706. (*------------------------------------*)
  707. PROCEDURE ResetProcSwitches * ();
  708.  
  709. BEGIN (* ResetProcSwitches *)
  710.   copyDynArray := DefCopyDynArray; returnCheck := DefReturnCheck;
  711.   saveAllRegs := DefSaveAllRegs; saveRegs := DefSaveRegs
  712. END ResetProcSwitches;
  713.  
  714. (*------------------------------------*)
  715. PROCEDURE EndModule * ();
  716.  
  717. BEGIN (* EndModule *)
  718.   IF scanerr THEN
  719.     IO.WriteF1 (" >> Error file : %s\n", SYS.ADR (filename));
  720.     Files.Register (errorFile)
  721.   ELSE Files.Purge (errorFile)
  722.   END;
  723.   errorFile := NIL; filename := "";
  724.   Files.Set (R, NIL, 0); Files.Set (W, NIL, 0);
  725. END EndModule;
  726.  
  727. (*------------------------------------*)
  728. (* $D- disable copying of open arrays *)
  729. PROCEDURE EnterKW (sym : INTEGER; name : ARRAY OF CHAR);
  730.  
  731.   VAR j, k : INTEGER;
  732.  
  733. BEGIN (* EnterKW *)
  734.   (*$V- ignore overflows*)
  735.   j := 0; k := 0;
  736.   REPEAT
  737.     INC (k, ORD (name [j]));
  738.     INC (j);
  739.   UNTIL name [j] = 0X;
  740.   k := (k + j) MOD KW; (* hash function *)
  741.   (*$V=*)
  742.  
  743.   IF keyTab [k].symb # 0 THEN
  744.     j := k;
  745.     REPEAT INC (k) UNTIL keyTab [k].symb = 0;
  746.     IF keyTab [j].alt = 0 THEN
  747.       keyTab [j].alt := k
  748.     ELSIF keyTab [j].alt2 = 0 THEN
  749.       keyTab [j].alt2 := k
  750.     ELSE
  751.       IO.WriteStr (" !! Invalid keyword table\n");
  752.       HALT (20)
  753.     END; (* ELSE *)
  754.   END; (* IF *)
  755.  
  756.   keyTab [k].symb := sym; COPY (name, keyTab [k].id)
  757. END EnterKW;
  758.  
  759. (*------------------------------------*)
  760. PROCEDURE* CloseErrorFile ();
  761.  
  762. BEGIN (* CloseErrorFile *)
  763.   IF errorFile # NIL THEN Files.Purge (errorFile); errorFile := NIL END;
  764. END CloseErrorFile;
  765.  
  766. BEGIN (* OCS *)
  767.   Digit := DigitString; errorFile := NIL; filename := "";
  768.   SYS.SETCLEANUP (CloseErrorFile);
  769.  
  770.   EnterKW (do, "DO"); EnterKW (if, "IF"); EnterKW (in, "IN");
  771.   EnterKW (is, "IS"); EnterKW (of, "OF"); EnterKW (or, "OR");
  772.   EnterKW (end, "END"); EnterKW (mod, "MOD"); EnterKW (nil, "NIL");
  773.   EnterKW (var, "VAR"); EnterKW (else, "ELSE"); EnterKW (exit, "EXIT");
  774.   EnterKW (then, "THEN"); EnterKW (with, "WITH"); EnterKW (array, "ARRAY");
  775.   EnterKW (begin, "BEGIN"); EnterKW (const, "CONST");
  776.   EnterKW (elsif, "ELSIF"); EnterKW (until, "UNTIL");
  777.   EnterKW (while, "WHILE"); EnterKW (record, "RECORD");
  778.   EnterKW (repeat, "REPEAT"); EnterKW (return, "RETURN");
  779.   EnterKW (procedure, "PROCEDURE"); EnterKW (to, "TO");
  780.   EnterKW (div, "DIV"); EnterKW (loop, "LOOP"); EnterKW (type, "TYPE");
  781.   EnterKW (import, "IMPORT"); EnterKW (module, "MODULE");
  782.   EnterKW (pointer, "POINTER"); EnterKW (case, "CASE");
  783.   EnterKW (cpointer, "CPOINTER"); EnterKW (bpointer, "BPOINTER");
  784.   EnterKW (libcall, "LIBCALL"); EnterKW (by, "BY");
  785.   EnterKW (for, "FOR");
  786.  
  787.   binErrFile := TRUE
  788. END OCS.
  789.  
  790. (***************************************************************************
  791.  
  792.   $Log: OCS.mod $
  793.   Revision 4.10  1994/09/03  14:35:10  fjc
  794.   - Imports version string from OCRev instead of OCV.
  795.  
  796.   Revision 4.9  1994/08/02  00:42:11  fjc
  797.   - Exported stackCheck.
  798.   - Changed to write 'OAER' tag to error file.
  799.  
  800.   Revision 4.8  1994/07/26  18:28:34  fjc
  801.   - Make stackCheck a global switch.
  802.  
  803.   Revision 4.7  1994/07/25  00:44:05  fjc
  804.   - Changed GetCh().
  805.  
  806.   Revision 4.6  1994/07/23  15:52:11  fjc
  807.   - Renamed newCheck to nilCheck.
  808.  
  809.   Revision 4.5  1994/07/22  14:00:09  fjc
  810.   - Changed to stop reporting multiple errors at the same
  811.     location.
  812.   - Implemented saveAllRegs compiler switch.
  813.  
  814.   Revision 4.4  1994/07/10  12:47:03  fjc
  815.   - Changed to use new SETCLEANUP format.
  816.   - Commented out tracing code.
  817.   - Added $G and $S compiler switches.
  818.   - Changed $Z to be a global compiler switch.
  819.  
  820.   Revision 4.3  1994/06/17  18:01:12  fjc
  821.   - Implemented binary error files.
  822.  
  823.   Revision 4.2  1994/06/10  13:08:45  fjc
  824.   - Fixed infinite loop bug in String() when processing
  825.     escaped characters.
  826.   - Removed support for multi-line strings, this is now
  827.     handled in Compiler.Factor() by concatenating strings.
  828.  
  829.   Revision 4.1  1994/06/01  09:33:44  fjc
  830.   - Bumped version number
  831.  
  832. ***************************************************************************)
  833.  
  834.