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