src/generic/Dev/Mod/CPR.cp

   1 MODULE DevCPR;
   2
   3   IMPORT Strings, DevCPM, DevCPT;
   4
   5   CONST
   6     MaxIdLen = LEN(DevCPT.Name);
   7
   8     (* symbol values *)
   9     null = 0;
  10     if = 1; then = 2; else = 3; elsif = 4; end = 5;
  11     new = 6; error = 7; ident = 8; plus = 9; minus = 10;
  12     not = 11; and = 12; or = 13; rpar = 14; lpar = 15; defined = 16;
  13     endcom = 17; eof = 18;
  14
  15   TYPE
  16     Context = POINTER TO RECORD
  17       next: Context; (* upper level block *)
  18       alt: BOOLEAN;  (* else branch *)
  19       val: BOOLEAN;  (* condition value, inverted if alt *)
  20       ref: INTEGER   (* ELSIF count *)
  21     END;
  22
  23     Selector = POINTER TO RECORD
  24       next: Selector;
  25       name: DevCPT.Name;
  26       val: BOOLEAN
  27     END;
  28
  29   VAR
  30     ch: CHAR; (* current character *)
  31     name: DevCPT.Name; (* ident *)
  32
  33   VAR
  34     sym: BYTE; (* parser symbol *)
  35     fold: INTEGER; (* condition folding *)
  36     scope: Selector;
  37     top: Context;
  38
  39   PROCEDURE err (n: SHORTINT);
  40   BEGIN DevCPM.err(n)
  41   END err;
  42
  43   PROCEDURE Identifier (VAR sym: BYTE);
  44     VAR i, res: INTEGER; n: ARRAY MaxIdLen OF CHAR;
  45   BEGIN i := 0;
  46     REPEAT
  47       n[i] := ch; INC(i); DevCPM.Get(ch)
  48     UNTIL ~Strings.IsIdent(ch) OR (i = MaxIdLen);
  49     IF i = MaxIdLen THEN err(240); DEC(i) END ;
  50     n[i] := 0X; Strings.StringToUtf8(n, name, res); sym := ident;
  51     IF res = 1 (*truncated*) THEN err(240) END
  52   END Identifier;
  53
  54   PROCEDURE Get (VAR sym: BYTE);
  55   BEGIN
  56     DevCPM.errpos := DevCPM.curpos - 1;
  57     WHILE (ch # DevCPM.Eot) & ((ch <= " ") OR (ch = 0A0X)) DO DevCPM.Get(ch) END;
  58     DevCPM.startpos := DevCPM.curpos - 1;
  59     CASE ch OF
  60     | DevCPM.Eot: sym := eof
  61     | "&": sym := and; DevCPM.Get(ch)
  62     | "(": sym := lpar; DevCPM.Get(ch)
  63     | ")": sym := rpar; DevCPM.Get(ch)
  64     | "*":
  65         sym := null; DevCPM.Get(ch);
  66         IF ch = ">" THEN sym := endcom; DevCPM.Get(ch) END
  67     | "+": sym := plus; DevCPM.Get(ch)
  68     | "-": sym := minus; DevCPM.Get(ch)
  69     | "D": Identifier(sym); IF name = "DEFINED" THEN sym := defined END
  70     | "E": Identifier(sym);
  71         IF name = "END" THEN sym := end
  72         ELSIF name = "ELSE" THEN sym := else
  73         ELSIF name = "ELSIF" THEN sym := elsif
  74         ELSIF name = "ERROR" THEN sym := error
  75         END
  76     | "I": Identifier(sym); IF name = "IF" THEN sym := if END
  77     | "N": Identifier(sym); IF name = "NEW" THEN sym := new END
  78     | "O": Identifier(sym); IF name = "OR" THEN sym := or END
  79     | "T": Identifier(sym); IF name = "THEN" THEN sym := then END
  80     | "A".."C", "J".."M", "P".."S", "U".."Z", "a".."z", "_": Identifier(sym)
  81     | "~": sym := not; DevCPM.Get(ch)
  82     ELSE
  83       IF Strings.IsIdent(ch) THEN Identifier(sym) ELSE sym := null; DevCPM.Get(ch) END
  84     END
  85   END Get;
  86
  87   PROCEDURE New (IN name: DevCPT.Name): Selector;
  88     VAR s: Selector;
  89   BEGIN
  90     s := scope;
  91     WHILE (s.next # NIL) & (s.next.name$ # name$) DO s := s.next END;
  92     IF s.next = NIL THEN NEW(s.next); s.next.name := name$; s.next.val := FALSE
  93     ELSE err(1)
  94     END;
  95     RETURN s.next
  96   END New;
  97
  98   PROCEDURE Old (IN name: DevCPT.Name): Selector;
  99     VAR s: Selector;
 100   BEGIN
 101     s := scope;
 102     WHILE (s.next # NIL) & (s.next.name$ # name$) DO s := s.next END;
 103     IF s.next = NIL THEN
 104       err(0); NEW(s.next); s.next.name := name$; s.next.val := FALSE
 105     END;
 106     RETURN s.next
 107   END Old;
 108
 109   PROCEDURE Find (IN name: DevCPT.Name): Selector;
 110     VAR s: Selector;
 111   BEGIN
 112     s := scope;
 113     WHILE (s.next # NIL) & (s.next.name$ # name$) DO s := s.next END;
 114     RETURN s.next
 115   END Find;
 116
 117   PROCEDURE Set* (IN name: DevCPT.Name; val: BOOLEAN);
 118     VAR s: Selector;
 119   BEGIN
 120     s := scope;
 121     WHILE (s.next # NIL) & (s.next.name$ # name$) DO s := s.next END;
 122     IF s.next = NIL THEN NEW(s.next) END;
 123     s.next.name := name$; s.next.val := val
 124   END Set;
 125
 126   PROCEDURE ^ Expression (VAR x: BOOLEAN);
 127
 128   PROCEDURE Factor (VAR x: BOOLEAN);
 129   BEGIN
 130     IF sym = ident THEN
 131       x := Old(name).val; Get(sym);
 132     ELSIF sym = defined THEN
 133       Get(sym);
 134       IF sym = lpar THEN
 135         Get(sym);
 136         IF sym = ident THEN
 137           x := Find(name) # NIL;
 138           Get(sym)
 139         ELSE err(48)
 140         END;
 141         IF sym # rpar THEN err(23)
 142         ELSE Get(sym)
 143         END
 144       ELSE err(40)
 145       END
 146     ELSIF sym = lpar THEN
 147       Get(sym); Expression(x);
 148       IF sym # rpar THEN err(23)
 149       ELSE Get(sym)
 150       END
 151     ELSIF sym = not THEN
 152       Get(sym); Factor(x); x := ~x
 153     ELSE
 154       x := FALSE;
 155       err(13)
 156     END
 157   END Factor;
 158
 159   PROCEDURE Term (VAR x: BOOLEAN);
 160     VAR y: BOOLEAN;
 161   BEGIN
 162     Factor(x);
 163     WHILE sym = and DO
 164       Get(sym); Factor(y); x := x & y
 165     END
 166   END Term;
 167
 168   PROCEDURE Expression (VAR x: BOOLEAN);
 169     VAR y: BOOLEAN;
 170   BEGIN
 171     Term(x);
 172     WHILE sym = or DO
 173       Get(sym); Term(y); x := x OR y
 174     END
 175   END Expression;
 176
 177   PROCEDURE If (cond: BOOLEAN);
 178     VAR c: Context;
 179   BEGIN
 180     NEW(c); c.next := top; c.alt := FALSE; c.val := cond; c.ref := 0; top := c;
 181     INC(fold)
 182   END If;
 183
 184   PROCEDURE Else;
 185   BEGIN
 186     IF top.alt THEN err(14) (* double ELSE *)
 187     ELSE top.alt := TRUE; top.val := ~top.val;
 188     END
 189   END Else;
 190
 191   PROCEDURE End;
 192     VAR i, ref: INTEGER;
 193   BEGIN
 194     i := 0; ref := top.ref; DEC(fold, ref + 1);
 195     WHILE (top # NIL) & (i <= ref) DO top := top.next; INC(i) END;
 196     IF top = NIL THEN err(51); fold := 0; If(TRUE) END
 197   END End;
 198
 199   PROCEDURE Printable* (): BOOLEAN;
 200     VAR c: Context;
 201   BEGIN
 202     c := top;
 203     WHILE (c # NIL) & c.val DO c := c.next END;
 204     RETURN c = NIL
 205   END Printable;
 206
 207   PROCEDURE Parse*;
 208     VAR val: BOOLEAN; s: Selector;
 209   BEGIN
 210     Get(sym);
 211     IF sym = new THEN
 212       Get(sym);
 213       IF sym = ident THEN
 214         s := New(name); Get(sym);
 215         IF (sym = plus) OR (sym = minus) THEN
 216           s.val := sym = plus; Get(sym)
 217         END
 218       ELSE err(48)
 219       END
 220     ELSIF sym = ident THEN
 221       s := Old(name); Get(sym);
 222       IF (sym = plus) OR (sym = minus) THEN
 223         s.val := sym = plus; Get(sym)
 224       ELSE err(41)
 225       END
 226     ELSIF sym = error THEN
 227       IF Printable() THEN err(501) END; Get(sym)
 228     ELSIF sym = if THEN
 229       Get(sym); Expression(val); If(val);
 230       IF sym = then THEN Get(sym)
 231       ELSE err(27)
 232       END
 233     ELSIF sym = elsif THEN
 234       IF fold <= 1 THEN err(14) END; (* ELSIF without IF *)
 235       Else; Get(sym); Expression(val); If(val); INC(top.ref);
 236       IF sym = then THEN Get(sym)
 237       ELSE err(27)
 238       END
 239     ELSIF sym = else THEN
 240       IF fold <= 1 THEN err(14) END; (* ELSE without IF *)
 241       Else; Get(sym)
 242     ELSIF sym = end THEN
 243       IF fold <= 1 THEN err(14) END; (* END without IF *)
 244       End; Get(sym)
 245     ELSE
 246       err(14)
 247     END;
 248     IF sym # endcom THEN err(5) ELSE DevCPM.errpos := DevCPM.curpos - 1 END
 249   END Parse;
 250
 251   PROCEDURE Check*;
 252   BEGIN
 253     IF fold # 1 THEN err(14) END
 254   END Check;
 255
 256   PROCEDURE Close*;
 257   BEGIN
 258     ch := " "; sym := eof; name := "";
 259     fold := 0; top := NIL; scope := NIL
 260   END Close;
 261
 262   PROCEDURE Init*;
 263     VAR s: Selector;
 264   BEGIN
 265     Close;
 266     If(TRUE);
 267     NEW(scope);
 268     Set("TRUE", TRUE);
 269     Set("FALSE", FALSE)
 270   END Init;
 271
 272 END DevCPR.