1 MODULE DevCPP;
3 (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPP.odc *)
4 (* DO NOT EDIT *)
6 IMPORT
7 DevCPM, DevCPT, DevCPB, DevCPS;
9 CONST
10 anchorVarPar = TRUE;
12 (* numtyp values *)
13 char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7;
15 (*symbol values*)
16 null = 0; times = 1; slash = 2; div = 3; mod = 4;
17 and = 5; plus = 6; minus = 7; or = 8; eql = 9;
18 neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
19 in = 15; is = 16; arrow = 17; dollar = 18; period = 19;
20 comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24;
21 rbrace = 25; of = 26; then = 27; do = 28; to = 29;
22 by = 30; not = 33;
23 lparen = 40; lbrak = 41; lbrace = 42; becomes = 44;
24 number = 45; nil = 46; string = 47; ident = 48; semicolon = 49;
25 bar = 50; end = 51; else = 52; elsif = 53; until = 54;
26 if = 55; case = 56; while = 57; repeat = 58; for = 59;
27 loop = 60; with = 61; exit = 62; return = 63; array = 64;
28 record = 65; pointer = 66; begin = 67; const = 68; type = 69;
29 var = 70; out = 71; procedure = 72; close = 73; import = 74;
30 module = 75; eof = 76;
32 (* object modes *)
33 Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
34 SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20;
36 (* Structure forms *)
37 Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
38 Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
39 Pointer = 13; ProcTyp = 14; Comp = 15;
40 Char16 = 16; String16 = 17; Int64 = 18;
41 intSet = {Int8..Int32, Int64}; charSet = {Char8, Char16};
43 (* composite structure forms *)
44 Basic = 1; Array = 2; DynArr = 3; Record = 4;
46 (*function number*)
47 haltfn = 0; newfn = 1; incfn = 13; sysnewfn = 30;
49 (* nodes classes *)
50 Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
51 Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
52 Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
53 Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
54 Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30;
56 (* node subclasses *)
57 super = 1;
59 (* module visibility of objects *)
60 internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
62 (* procedure flags (conval.setval) *)
63 hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4;
65 (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
66 newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
68 (* case statement flags (conval.setval) *)
69 useTable = 1; useTree = 2;
71 (* sysflags *)
72 nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; som = 20; jstr = -13;
75 TYPE
76 Elem = POINTER TO RECORD
77 next: Elem;
78 struct: DevCPT.Struct;
79 obj, base: DevCPT.Object;
80 pos: INTEGER;
81 name: DevCPT.String
82 END;
85 VAR
86 sym, level: BYTE;
87 LoopLevel: SHORTINT;
88 TDinit, lastTDinit: DevCPT.Node;
89 userList: Elem;
90 recList: Elem;
91 hasReturn: BOOLEAN;
92 numUsafeVarPar, numFuncVarPar: INTEGER;
95 PROCEDURE^ Type(VAR typ: DevCPT.Struct; VAR name: DevCPT.String);
96 PROCEDURE^ Expression(VAR x: DevCPT.Node);
97 PROCEDURE^ Block(VAR procdec, statseq: DevCPT.Node);
99 (* forward type handling *)
101 PROCEDURE IncompleteType (typ: DevCPT.Struct): BOOLEAN;
102 BEGIN
103 IF typ.form = Pointer THEN typ := typ.BaseTyp END;
104 RETURN (typ = DevCPT.undftyp) OR (typ.comp = Record) & (typ.BaseTyp = DevCPT.undftyp)
105 END IncompleteType;
107 PROCEDURE SetType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; name: DevCPT.String);
108 VAR u: Elem;
109 BEGIN
110 IF obj # NIL THEN obj.typ := typ ELSE struct.BaseTyp := typ END;
111 IF name # NIL THEN
112 NEW(u); u.struct := struct; u.obj := obj; u.pos := DevCPM.errpos; u.name := name;
113 u.next := userList; userList := u
114 END
115 END SetType;
117 PROCEDURE CheckAlloc (VAR typ: DevCPT.Struct; dynAllowed: BOOLEAN; pos: INTEGER);
118 BEGIN
119 typ.pvused := TRUE;
120 IF typ.comp = DynArr THEN
121 IF ~dynAllowed THEN DevCPM.Mark(88, pos); typ := DevCPT.undftyp END
122 ELSIF typ.comp = Record THEN
123 IF (typ.attribute = absAttr) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN
124 DevCPM.Mark(193, pos); typ := DevCPT.undftyp
125 END
126 END
127 END CheckAlloc;
129 PROCEDURE CheckRecursiveType (outer, inner: DevCPT.Struct; pos: INTEGER);
130 VAR fld: DevCPT.Object;
131 BEGIN
132 IF outer = inner THEN DevCPM.Mark(58, pos)
133 ELSIF inner.comp IN {Array, DynArr} THEN CheckRecursiveType(outer, inner.BaseTyp, pos)
134 ELSIF inner.comp = Record THEN
135 fld := inner.link;
136 WHILE (fld # NIL) & (fld.mode = Fld) DO
137 CheckRecursiveType(outer, fld.typ, pos);
138 fld := fld.link
139 END;
140 IF inner.BaseTyp # NIL THEN CheckRecursiveType(outer, inner.BaseTyp, pos) END
141 END
142 END CheckRecursiveType;
144 PROCEDURE FixType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER);
145 (* fix forward reference *)
146 VAR t: DevCPT.Struct; f, bf: DevCPT.Object; i: SHORTINT;
147 BEGIN
148 IF obj # NIL THEN
149 IF obj.mode = Var THEN (* variable type *)
150 IF struct # NIL THEN (* receiver type *)
151 IF (typ.form # Pointer) OR (typ.BaseTyp # struct) THEN DevCPM.Mark(180, pos) END;
152 ELSE CheckAlloc(typ, obj.mnolev > level, pos) (* TRUE for parameters *)
153 END
154 ELSIF obj.mode = VarPar THEN (* varpar type *)
155 IF struct # NIL THEN (* varpar receiver type *)
156 IF typ # struct THEN DevCPM.Mark(180, pos) END
157 END
158 ELSIF obj.mode = Fld THEN (* field type *)
159 CheckAlloc(typ, FALSE, pos);
160 CheckRecursiveType(struct, typ, pos)
161 ELSIF obj.mode = TProc THEN (* proc return type *)
162 IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END
163 ELSIF obj.mode = Typ THEN (* alias type *)
164 IF typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *)
165 t := DevCPT.NewStr(typ.form, Basic); i := t.ref;
166 t^ := typ^; t.ref := i; t.strobj := obj; t.mno := 0;
167 t.BaseTyp := typ; typ := t
168 END;
169 IF obj.vis # internal THEN
170 IF typ.comp = Record THEN typ.exp := TRUE
171 ELSIF typ.form = Pointer THEN typ.BaseTyp.exp := TRUE
172 END
173 END
174 ELSE HALT(100)
175 END;
176 obj.typ := typ
177 ELSE
178 IF struct.form = Pointer THEN (* pointer base type *)
179 IF typ.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.sysflag, struct.sysflag)
180 ELSIF typ.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.sysflag, struct.sysflag)
181 ELSE typ := DevCPT.undftyp; DevCPM.Mark(57, pos)
182 END;
183 struct.untagged := struct.sysflag > 0;
184 IF (struct.strobj # NIL) & (struct.strobj.vis # internal) THEN typ.exp := TRUE END;
185 ELSIF struct.comp = Array THEN (* array base type *)
186 CheckAlloc(typ, FALSE, pos);
187 CheckRecursiveType(struct, typ, pos)
188 ELSIF struct.comp = DynArr THEN (* array base type *)
189 CheckAlloc(typ, TRUE, pos);
190 CheckRecursiveType(struct, typ, pos)
191 ELSIF struct.comp = Record THEN (* record base type *)
192 IF typ.form = Pointer THEN typ := typ.BaseTyp END;
193 typ.pvused := TRUE; struct.extlev := SHORT(SHORT(typ.extlev + 1));
194 DevCPM.PropagateRecordSysFlag(typ.sysflag, struct.sysflag);
195 IF (typ.attribute = 0) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN DevCPM.Mark(181, pos)
196 ELSIF (struct.attribute = absAttr) & (typ.attribute # absAttr) THEN DevCPM.Mark(191, pos)
197 ELSIF (typ.attribute = limAttr) & (struct.attribute # limAttr) THEN DevCPM.Mark(197, pos)
198 END;
199 f := struct.link;
200 WHILE f # NIL DO (* check for field name conflicts *)
201 DevCPT.FindField(f.name, typ, bf);
202 IF bf # NIL THEN DevCPM.Mark(1, pos) END;
203 f := f.link
204 END;
205 CheckRecursiveType(struct, typ, pos);
206 struct.untagged := struct.sysflag > 0;
207 ELSIF struct.form = ProcTyp THEN (* proc type return type *)
208 IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END;
209 ELSE HALT(100)
210 END;
211 struct.BaseTyp := typ
212 END
213 END FixType;
215 PROCEDURE CheckForwardTypes;
216 VAR u, next: Elem; progress: BOOLEAN;
217 BEGIN
218 u := userList; userList := NIL;
219 WHILE u # NIL DO
220 next := u.next; DevCPS.name := u.name^$; DevCPT.Find(DevCPS.name, u.base);
221 IF u.base = NIL THEN DevCPM.Mark(0, u.pos)
222 ELSIF u.base.mode # Typ THEN DevCPM.Mark(72, u.pos)
223 ELSE u.next := userList; userList := u (* reinsert *)
224 END;
225 u := next
226 END;
227 REPEAT (* iteration for multy level alias *)
228 u := userList; userList := NIL; progress := FALSE;
229 WHILE u # NIL DO
230 next := u.next;
231 IF IncompleteType(u.base.typ) THEN
232 u.next := userList; userList := u (* reinsert *)
233 ELSE
234 progress := TRUE;
235 FixType(u.struct, u.obj, u.base.typ, u.pos)
236 END;
237 u := next
238 END
239 UNTIL (userList = NIL) OR ~progress;
240 u := userList; (* remaining type relations are cyclic *)
241 WHILE u # NIL DO
242 IF (u.obj = NIL) OR (u.obj.mode = Typ) THEN DevCPM.Mark(58, u.pos) END;
243 u := u.next
244 END;
245 END CheckForwardTypes;
247 PROCEDURE CheckUnimpl (m: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER);
248 VAR obj: DevCPT.Object;
249 BEGIN
250 IF m # NIL THEN
251 IF (m.mode = TProc) & (absAttr IN m.conval.setval) THEN
252 DevCPT.FindField(m.name^, typ, obj);
253 IF (obj = NIL) OR (obj.mode # TProc) OR (absAttr IN obj.conval.setval) THEN
254 DevCPM.Mark(192, pos);
255 DevCPM.LogWLn; DevCPM.LogWStr(" "); DevCPM.LogWStr(m.name^);
256 DevCPM.LogWStr(" not implemented");
257 IF typ.strobj # NIL THEN
258 DevCPM.LogWStr(" in "); DevCPM.LogWStr(typ.strobj.name^)
259 END
260 END
261 END;
262 CheckUnimpl(m.left, typ, pos);
263 CheckUnimpl(m.right, typ, pos)
264 END
265 END CheckUnimpl;
267 PROCEDURE CheckRecords (rec: Elem);
268 VAR b: DevCPT.Struct;
269 BEGIN
270 WHILE rec # NIL DO (* check for unimplemented methods in base type *)
271 b := rec.struct.BaseTyp;
272 WHILE (b # NIL) & (b # DevCPT.undftyp) DO
273 CheckUnimpl(b.link, rec.struct, rec.pos);
274 b := b.BaseTyp
275 END;
276 rec := rec.next
277 END
278 END CheckRecords;
281 PROCEDURE err(n: SHORTINT);
282 BEGIN DevCPM.err(n)
283 END err;
285 PROCEDURE CheckSym(s: SHORTINT);
286 BEGIN
287 IF sym = s THEN DevCPS.Get(sym) ELSE DevCPM.err(s) END
288 END CheckSym;
290 PROCEDURE qualident(VAR id: DevCPT.Object);
291 VAR obj: DevCPT.Object; lev: BYTE;
292 BEGIN (*sym = ident*)
293 DevCPT.Find(DevCPS.name, obj); DevCPS.Get(sym);
294 IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
295 DevCPS.Get(sym);
296 IF sym = ident THEN
297 DevCPT.FindImport(DevCPS.name, obj, obj); DevCPS.Get(sym)
298 ELSE err(ident); obj := NIL
299 END
300 END ;
301 IF obj = NIL THEN err(0);
302 obj := DevCPT.NewObj(); obj.mode := Var; obj.typ := DevCPT.undftyp; obj.adr := 0
303 ELSE lev := obj.mnolev;
304 IF (obj.mode IN {Var, VarPar}) & (lev # level) THEN
305 obj.leaf := FALSE;
306 IF lev > 0 THEN DevCPB.StaticLink(SHORT(SHORT(level-lev)), TRUE) END (* !!! *)
307 END
308 END ;
309 id := obj
310 END qualident;
312 PROCEDURE ConstExpression(VAR x: DevCPT.Node);
313 BEGIN Expression(x);
314 IF x.class # Nconst THEN
315 err(50); x := DevCPB.NewIntConst(1)
316 END
317 END ConstExpression;
319 PROCEDURE CheckMark(obj: DevCPT.Object); (* !!! *)
320 VAR n: INTEGER; mod: ARRAY 256 OF DevCPT.String;
321 BEGIN DevCPS.Get(sym);
322 IF (sym = times) OR (sym = minus) THEN
323 IF (level > 0) OR ~(obj.mode IN {Var, Fld, TProc}) & (sym = minus) THEN err(41) END ;
324 IF sym = times THEN obj.vis := external ELSE obj.vis := externalR END ;
325 DevCPS.Get(sym)
326 ELSE obj.vis := internal
327 END;
328 IF (obj.mode IN {TProc, LProc, XProc, CProc, Var, Typ, Con, Fld}) & (sym = lbrak) THEN
329 DevCPS.Get(sym);
330 IF (sym = number) & (DevCPS.numtyp = char) THEN
331 NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
332 END;
333 IF sym = string THEN
334 IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END;
335 DevCPS.Get(sym); n := 0;
336 IF (sym = comma) & (obj.mode IN {LProc, XProc, CProc, Var, Con}) THEN
337 DevCPS.Get(sym);
338 IF (sym = number) & (DevCPS.numtyp = char) THEN
339 NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
340 END;
341 IF sym = string THEN
342 obj.library := obj.entry; obj.entry := NIL;
343 IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END;
344 DevCPS.Get(sym);
345 ELSE err(string)
346 END
347 END;
348 WHILE sym = comma DO
349 DevCPS.Get(sym);
350 IF (sym = number) & (DevCPS.numtyp = char) THEN
351 NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
352 END;
353 IF sym = string THEN
354 IF n < LEN(mod) THEN mod[n] := DevCPS.str; INC(n)
355 ELSE err(235)
356 END;
357 DevCPS.Get(sym)
358 ELSE err(string)
359 END
360 END;
361 IF n > 0 THEN
362 NEW(obj.modifiers, n);
363 WHILE n > 0 DO DEC(n); obj.modifiers[n] := mod[n] END
364 END
365 ELSE err(string)
366 END;
367 CheckSym(rbrak);
368 IF DevCPM.options * {DevCPM.interface, DevCPM.java} = {} THEN err(225) END
369 END
370 END CheckMark;
372 PROCEDURE CheckSysFlag (VAR sysflag: SHORTINT;
373 GetSF: PROCEDURE(id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT));
374 VAR x: DevCPT.Object; i: SHORTINT;
375 BEGIN
376 sysflag := 0;
377 IF sym = lbrak THEN
378 DevCPS.Get(sym);
379 WHILE (sym = number) OR (sym = ident) OR (sym = string) DO
380 IF sym = number THEN
381 IF DevCPS.numtyp = integer THEN
382 i := SHORT(DevCPS.intval); GetSF("", i, sysflag)
383 ELSE err(225)
384 END
385 ELSIF sym = ident THEN
386 DevCPT.Find(DevCPS.name, x);
387 IF (x # NIL) & (x.mode = Con) & (x.typ.form IN {Int8, Int16, Int32}) THEN
388 i := SHORT(x.conval.intval); GetSF("", i, sysflag)
389 ELSE
390 GetSF(DevCPS.name, 0, sysflag)
391 END
392 ELSE
393 GetSF(DevCPS.str^, 0, sysflag)
394 END;
395 DevCPS.Get(sym);
396 IF (sym = comma) OR (sym = plus) THEN DevCPS.Get(sym) END
397 END;
398 CheckSym(rbrak)
399 END
400 END CheckSysFlag;
402 PROCEDURE Receiver(VAR mode, vis: BYTE; VAR name: DevCPT.Name; VAR typ, rec: DevCPT.Struct);
403 VAR obj: DevCPT.Object; tname: DevCPT.String;
404 BEGIN typ := DevCPT.undftyp; rec := NIL; vis := 0;
405 IF sym = var THEN DevCPS.Get(sym); mode := VarPar;
406 ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar (* ??? *)
407 ELSE mode := Var
408 END ;
409 name := DevCPS.name; CheckSym(ident); CheckSym(colon);
410 IF sym # ident THEN err(ident) END;
411 Type(typ, tname);
412 IF tname = NIL THEN
413 IF typ.form = Pointer THEN rec := typ.BaseTyp ELSE rec := typ END;
414 IF ~((mode = Var) & (typ.form = Pointer) & (rec.comp = Record) OR
415 (mode = VarPar) & (typ.comp = Record)) THEN err(70); rec := NIL END;
416 IF (rec # NIL) & (rec.mno # level) THEN err(72); rec := NIL END
417 ELSE err(0)
418 END;
419 CheckSym(rparen);
420 IF rec = NIL THEN rec := DevCPT.NewStr(Comp, Record); rec.BaseTyp := NIL END
421 END Receiver;
423 PROCEDURE FormalParameters(
424 VAR firstPar: DevCPT.Object; VAR resTyp: DevCPT.Struct; VAR name: DevCPT.String
425 );
426 VAR mode, vis: BYTE; sys: SHORTINT;
427 par, first, last, res, newPar, iidPar: DevCPT.Object; typ: DevCPT.Struct;
428 BEGIN
429 first := NIL; last := firstPar;
430 newPar := NIL; iidPar := NIL;
431 IF (sym = ident) OR (sym = var) OR (sym = in) OR (sym = out) THEN
432 LOOP
433 sys := 0; vis := 0;
434 IF sym = var THEN DevCPS.Get(sym); mode := VarPar
435 ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar
436 ELSIF sym = out THEN DevCPS.Get(sym); mode := VarPar; vis := outPar
437 ELSE mode := Var
438 END ;
439 IF mode = VarPar THEN CheckSysFlag(sys, DevCPM.GetVarParSysFlag) END;
440 IF ODD(sys DIV inBit) THEN vis := inPar
441 ELSIF ODD(sys DIV outBit) THEN vis := outPar
442 END;
443 IF ODD(sys DIV newBit) & (vis # outPar) THEN err(225)
444 ELSIF ODD(sys DIV iidBit) & (vis # inPar) THEN err(225)
445 END;
446 LOOP
447 IF sym = ident THEN
448 DevCPT.Insert(DevCPS.name, par); DevCPS.Get(sym);
449 par.mode := mode; par.link := NIL; par.vis := vis; par.sysflag := SHORT(sys);
450 IF first = NIL THEN first := par END ;
451 IF firstPar = NIL THEN firstPar := par ELSE last.link := par END ;
452 last := par
453 ELSE err(ident)
454 END;
455 IF sym = comma THEN DevCPS.Get(sym)
456 ELSIF sym = ident THEN err(comma)
457 ELSIF sym = var THEN err(comma); DevCPS.Get(sym)
458 ELSE EXIT
459 END
460 END ;
461 CheckSym(colon); Type(typ, name);
462 IF mode # VarPar THEN CheckAlloc(typ, TRUE, DevCPM.errpos) END;
463 IF (mode = VarPar) & (vis = inPar) & (typ.form # Undef) & (typ.form # Comp) & (typ.sysflag = 0) THEN err(177)
464 END;
465 (* typ.pbused is set when parameter type name is parsed *)
466 WHILE first # NIL DO
467 SetType (NIL, first, typ, name);
468 IF DevCPM.com IN DevCPM.options THEN
469 IF ODD(sys DIV newBit) THEN
470 IF (newPar # NIL) OR (typ.form # Pointer) OR (typ.sysflag # interface) THEN err(168) END;
471 newPar := first
472 ELSIF ODD(sys DIV iidBit) THEN
473 IF (iidPar # NIL) OR (typ # DevCPT.guidtyp) THEN err(168) END;
474 iidPar := first
475 END
476 END;
477 first := first.link
478 END;
479 IF sym = semicolon THEN DevCPS.Get(sym)
480 ELSIF sym = ident THEN err(semicolon)
481 ELSE EXIT
482 END
483 END
484 END;
485 CheckSym(rparen);
486 IF (newPar = NIL) # (iidPar = NIL) THEN err(168) END;
487 name := NIL;
488 IF sym = colon THEN
489 DevCPS.Get(sym);
490 Type(resTyp, name);
491 IF resTyp.form = Comp THEN resTyp := DevCPT.undftyp; err(54) END
492 ELSE resTyp := DevCPT.notyp
493 END
494 END FormalParameters;
496 PROCEDURE CheckOverwrite (proc, base: DevCPT.Object; rec: DevCPT.Struct);
497 VAR o, bo: DevCPT.Object;
498 BEGIN
499 IF base # NIL THEN
500 IF base.conval.setval * {absAttr, empAttr, extAttr} = {} THEN err(182) END;
501 IF (proc.link.mode # base.link.mode) OR (proc.link.vis # base.link.vis)
502 OR ~DevCPT.Extends(proc.link.typ, base.link.typ) THEN err(115) END;
503 o := proc.link; bo := base.link;
504 WHILE (o # NIL) & (bo # NIL) DO
505 IF (bo.sysflag # 0) & (o.sysflag = 0) THEN (* propagate sysflags *)
506 o.sysflag := bo.sysflag
507 END;
508 o := o.link; bo := bo.link
509 END;
510 DevCPB.CheckParameters(proc.link.link, base.link.link, FALSE);
511 IF ~DevCPT.Extends(proc.typ, base.typ) THEN err(117) END;
512 IF (base.vis # proc.vis) & ((proc.vis # internal) OR rec.exp) THEN err(183) END;
513 INCL(proc.conval.setval, isRedef)
514 END;
515 END CheckOverwrite;
517 PROCEDURE GetAttributes (proc, base: DevCPT.Object; owner: DevCPT.Struct); (* read method attributes *)
518 VAR attr, battr: SET; o: DevCPT.Object;
519 BEGIN
520 attr := {};
521 IF sym = comma THEN (* read attributes *)
522 DevCPS.Get(sym);
523 IF sym = ident THEN
524 DevCPT.Find(DevCPS.name, o);
525 IF (o # NIL) & (o.mode = SProc) & (o.adr = newfn) THEN
526 IF ~(DevCPM.oberon IN DevCPM.options) THEN INCL(attr, newAttr) ELSE err(178) END;
527 DevCPS.Get(sym);
528 IF sym = comma THEN
529 DevCPS.Get(sym);
530 IF sym = ident THEN DevCPT.Find(DevCPS.name, o) ELSE o := NIL; err(ident) END
531 ELSE o := NIL
532 END
533 END;
534 IF o # NIL THEN
535 IF (o.mode # Attr) OR (o.adr = limAttr) OR (DevCPM.oberon IN DevCPM.options) THEN err(178)
536 ELSE INCL(attr, o.adr)
537 END;
538 DevCPS.Get(sym)
539 END
540 ELSE err(ident)
541 END
542 END;
543 IF (base = NIL) & ~(newAttr IN attr) THEN err(185); INCL(attr, newAttr)
544 ELSIF (base # NIL) & (newAttr IN attr) THEN err(186)
545 END;
546 IF absAttr IN attr THEN
547 IF owner.attribute # absAttr THEN err(190) END;
548 IF (proc.vis = internal) & owner.exp THEN err(179) END
549 END;
550 IF (owner.attribute = 0) OR (owner.attribute = limAttr) THEN
551 IF (empAttr IN attr) & (newAttr IN attr) THEN err(187)
552 (*
553 ELSIF extAttr IN attr THEN err(188)
554 *)
555 END
556 END;
557 IF base # NIL THEN
558 battr := base.conval.setval;
559 IF empAttr IN battr THEN
560 IF absAttr IN attr THEN err(189) END
561 ELSIF ~(absAttr IN battr) THEN
562 IF (absAttr IN attr) OR (empAttr IN attr) THEN err(189) END
563 END
564 END;
565 IF empAttr IN attr THEN
566 IF proc.typ # DevCPT.notyp THEN err(195)
567 ELSE
568 o := proc.link; WHILE (o # NIL) & (o.vis # outPar) DO o := o.link END;
569 IF o # NIL THEN err(195) END
570 END
571 END;
572 IF (owner.sysflag = interface) & ~(absAttr IN attr) THEN err(162) END;
573 proc.conval.setval := attr
574 END GetAttributes;
576 PROCEDURE RecordType(VAR typ: DevCPT.Struct; attr: DevCPT.Object);
577 VAR fld, first, last, base: DevCPT.Object; r: Elem; ftyp: DevCPT.Struct; name: DevCPT.String;
578 BEGIN typ := DevCPT.NewStr(Comp, Record); typ.BaseTyp := NIL;
579 CheckSysFlag(typ.sysflag, DevCPM.GetRecordSysFlag);
580 IF attr # NIL THEN
581 IF ~(DevCPM.oberon IN DevCPM.options) & (attr.adr # empAttr) THEN typ.attribute := SHORT(SHORT(attr.adr))
582 ELSE err(178)
583 END
584 END;
585 IF typ.sysflag = interface THEN
586 IF (DevCPS.str # NIL) & (DevCPS.str[0] = "{") THEN typ.ext := DevCPS.str END;
587 IF typ.attribute # absAttr THEN err(163) END;
588 IF sym # lparen THEN err(160) END
589 END;
590 IF sym = lparen THEN
591 DevCPS.Get(sym); (*record extension*)
592 IF sym = ident THEN
593 Type(ftyp, name);
594 IF ftyp.form = Pointer THEN ftyp := ftyp.BaseTyp END;
595 SetType(typ, NIL, ftyp, name);
596 IF (ftyp.comp = Record) & (ftyp # DevCPT.anytyp) THEN
597 ftyp.pvused := TRUE; typ.extlev := SHORT(SHORT(ftyp.extlev + 1));
598 DevCPM.PropagateRecordSysFlag(ftyp.sysflag, typ.sysflag);
599 IF (ftyp.attribute = 0) OR (ftyp.attribute = limAttr) & (ftyp.mno # 0) THEN err(181)
600 ELSIF (typ.attribute = absAttr) & (ftyp.attribute # absAttr) & ~(DevCPM.java IN DevCPM.options) THEN err(191)
601 ELSIF (ftyp.attribute = limAttr) & (typ.attribute # limAttr) THEN err(197)
602 END
603 ELSIF ftyp # DevCPT.undftyp THEN err(53)
604 END
605 ELSE err(ident)
606 END ;
607 IF typ.attribute # absAttr THEN (* save typ for unimplemented method check *)
608 NEW(r); r.struct := typ; r.pos := DevCPM.errpos; r.next := recList; recList := r
609 END;
610 CheckSym(rparen)
611 END;
612 (*
613 DevCPT.OpenScope(0, NIL);
614 *)
615 first := NIL; last := NIL;
616 LOOP
617 IF sym = ident THEN
618 LOOP
619 IF sym = ident THEN
620 IF (typ.BaseTyp # NIL) & (typ.BaseTyp # DevCPT.undftyp) THEN
621 DevCPT.FindBaseField(DevCPS.name, typ, fld);
622 IF fld # NIL THEN err(1) END
623 END ;
624 DevCPT.InsertField(DevCPS.name, typ, fld);
625 fld.mode := Fld; fld.link := NIL; fld.typ := DevCPT.undftyp;
626 CheckMark(fld);
627 IF first = NIL THEN first := fld END ;
628 IF last = NIL THEN typ.link := fld ELSE last.link := fld END ;
629 last := fld
630 ELSE err(ident)
631 END ;
632 IF sym = comma THEN DevCPS.Get(sym)
633 ELSIF sym = ident THEN err(comma)
634 ELSE EXIT
635 END
636 END ;
637 CheckSym(colon); Type(ftyp, name);
638 CheckAlloc(ftyp, FALSE, DevCPM.errpos);
639 WHILE first # NIL DO
640 SetType(typ, first, ftyp, name); first := first.link
641 END;
642 IF typ.sysflag = interface THEN err(161) END
643 END;
644 IF sym = semicolon THEN DevCPS.Get(sym)
645 ELSIF sym = ident THEN err(semicolon)
646 ELSE EXIT
647 END
648 END;
649 (*
650 IF typ.link # NIL THEN ASSERT(typ.link = DevCPT.topScope.right) END;
651 typ.link := DevCPT.topScope.right; DevCPT.CloseScope;
652 *)
653 typ.untagged := typ.sysflag > 0;
654 DevCPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end)
655 END RecordType;
657 PROCEDURE ArrayType(VAR typ: DevCPT.Struct);
658 VAR x: DevCPT.Node; n: INTEGER; sysflag: SHORTINT; name: DevCPT.String;
659 BEGIN CheckSysFlag(sysflag, DevCPM.GetArraySysFlag);
660 IF sym = of THEN (*dynamic array*)
661 typ := DevCPT.NewStr(Comp, DynArr); typ.mno := 0; typ.sysflag := sysflag;
662 DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name);
663 CheckAlloc(typ.BaseTyp, TRUE, DevCPM.errpos);
664 IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 ELSE typ.n := 0 END
665 ELSE
666 typ := DevCPT.NewStr(Comp, Array); typ.sysflag := sysflag; ConstExpression(x);
667 IF x.typ.form IN {Int8, Int16, Int32} THEN n := x.conval.intval;
668 IF (n <= 0) OR (n > DevCPM.MaxIndex) THEN err(63); n := 1 END
669 ELSE err(42); n := 1
670 END ;
671 typ.n := n;
672 IF sym = of THEN
673 DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name);
674 CheckAlloc(typ.BaseTyp, FALSE, DevCPM.errpos)
675 ELSIF sym = comma THEN
676 DevCPS.Get(sym);
677 IF sym # of THEN ArrayType(typ.BaseTyp) END
678 ELSE err(35)
679 END
680 END;
681 typ.untagged := typ.sysflag > 0
682 END ArrayType;
684 PROCEDURE PointerType(VAR typ: DevCPT.Struct);
685 VAR id: DevCPT.Object; name: DevCPT.String;
686 BEGIN typ := DevCPT.NewStr(Pointer, Basic); CheckSysFlag(typ.sysflag, DevCPM.GetPointerSysFlag);
687 CheckSym(to);
688 Type(typ.BaseTyp, name);
689 SetType(typ, NIL, typ.BaseTyp, name);
690 IF (typ.BaseTyp # DevCPT.undftyp) & (typ.BaseTyp.comp = Basic) THEN
691 typ.BaseTyp := DevCPT.undftyp; err(57)
692 END;
693 IF typ.BaseTyp.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag)
694 ELSIF typ.BaseTyp.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag)
695 END;
696 typ.untagged := typ.sysflag > 0
697 END PointerType;
699 PROCEDURE Type (VAR typ: DevCPT.Struct; VAR name: DevCPT.String); (* name # NIL => forward reference *)
700 VAR id: DevCPT.Object; tname: DevCPT.String;
701 BEGIN
702 typ := DevCPT.undftyp; name := NIL;
703 IF sym < lparen THEN err(12);
704 REPEAT DevCPS.Get(sym) UNTIL sym >= lparen
705 END ;
706 IF sym = ident THEN
707 DevCPT.Find(DevCPS.name, id);
708 IF (id = NIL) OR (id.mode = -1) OR (id.mode = Typ) & IncompleteType(id.typ) THEN (* forward type definition *)
709 name := DevCPT.NewName(DevCPS.name); DevCPS.Get(sym);
710 IF (id = NIL) & (sym = period) THEN (* missing module *)
711 err(0); DevCPS.Get(sym); name := NIL;
712 IF sym = ident THEN DevCPS.Get(sym) END
713 ELSIF sym = record THEN (* wrong attribute *)
714 err(178); DevCPS.Get(sym); name := NIL; RecordType(typ, NIL)
715 END
716 ELSE
717 qualident(id);
718 IF id.mode = Typ THEN
719 IF ~(DevCPM.oberon IN DevCPM.options)
720 & ((id.typ = DevCPT.lreal64typ) OR (id.typ = DevCPT.lint64typ) OR (id.typ = DevCPT.lchar16typ)) THEN
721 err(198)
722 END;
723 typ := id.typ
724 ELSIF id.mode = Attr THEN
725 IF sym = record THEN
726 DevCPS.Get(sym); RecordType(typ, id)
727 ELSE err(12)
728 END
729 ELSE err(52)
730 END
731 END
732 ELSIF sym = array THEN
733 DevCPS.Get(sym); ArrayType(typ)
734 ELSIF sym = record THEN
735 DevCPS.Get(sym); RecordType(typ, NIL)
736 ELSIF sym = pointer THEN
737 DevCPS.Get(sym); PointerType(typ)
738 ELSIF sym = procedure THEN
739 DevCPS.Get(sym); typ := DevCPT.NewStr(ProcTyp, Basic);
740 CheckSysFlag(typ.sysflag, DevCPM.GetProcTypSysFlag);
741 typ.untagged := typ.sysflag > 0;
742 IF sym = lparen THEN
743 DevCPS.Get(sym); DevCPT.OpenScope(level, NIL);
744 FormalParameters(typ.link, typ.BaseTyp, tname); SetType(typ, NIL, typ.BaseTyp, tname); DevCPT.CloseScope
745 ELSE typ.BaseTyp := DevCPT.notyp; typ.link := NIL
746 END
747 ELSE err(12)
748 END ;
749 LOOP
750 IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof)
751 OR (sym = number) OR (sym = comma) OR (sym = string) THEN EXIT END;
752 err(15); IF sym = ident THEN EXIT END;
753 DevCPS.Get(sym)
754 END
755 END Type;
757 PROCEDURE ActualParameters(VAR aparlist: DevCPT.Node; fpar: DevCPT.Object; VAR pre, lastp: DevCPT.Node);
758 VAR apar, last, newPar, iidPar, n: DevCPT.Node;
759 BEGIN
760 aparlist := NIL; last := NIL;
761 IF sym # rparen THEN
762 newPar := NIL; iidPar := NIL;
763 LOOP Expression(apar);
764 IF fpar # NIL THEN
765 IF (apar.typ.form = Pointer) & (fpar.typ.form = Comp) THEN DevCPB.DeRef(apar) END;
766 DevCPB.Param(apar, fpar);
767 IF (fpar.mode = Var) OR (fpar.vis = inPar) THEN DevCPB.CheckBuffering(apar, NIL, fpar, pre, lastp) END;
768 DevCPB.Link(aparlist, last, apar);
769 IF ODD(fpar.sysflag DIV newBit) THEN newPar := apar
770 ELSIF ODD(fpar.sysflag DIV iidBit) THEN iidPar := apar
771 END;
772 IF (newPar # NIL) & (iidPar # NIL) THEN DevCPB.CheckNewParamPair(newPar, iidPar) END;
773 IF anchorVarPar & (fpar.mode = VarPar) & ~(DevCPM.java IN DevCPM.options)
774 OR (DevCPM.allSysVal IN DevCPM.options) (* source output: avoid double evaluation *)
775 & ((fpar.mode = VarPar) & (fpar.typ.comp = Record) & ~fpar.typ.untagged
776 OR (fpar.typ.comp = DynArr) & ~fpar.typ.untagged) THEN
777 n := apar;
778 WHILE n.class IN {Nfield, Nindex, Nguard} DO n := n.left END;
779 IF (n.class = Nderef) & (n.subcl = 0) THEN
780 IF n.left.class = Nguard THEN n := n.left END;
781 DevCPB.CheckVarParBuffering(n.left, pre, lastp)
782 END
783 END;
784 fpar := fpar.link
785 ELSE err(64)
786 END;
787 IF sym = comma THEN DevCPS.Get(sym)
788 ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
789 ELSE EXIT
790 END
791 END
792 END;
793 IF fpar # NIL THEN err(65) END
794 END ActualParameters;
796 PROCEDURE selector(VAR x: DevCPT.Node);
797 VAR obj, proc, p, fpar: DevCPT.Object; y, apar, pre, lastp: DevCPT.Node; typ: DevCPT.Struct; name: DevCPT.Name;
798 BEGIN
799 LOOP
800 IF sym = lbrak THEN DevCPS.Get(sym);
801 LOOP
802 IF (x.typ # NIL) & (x.typ.form = Pointer) THEN DevCPB.DeRef(x) END ;
803 Expression(y); DevCPB.Index(x, y);
804 IF sym = comma THEN DevCPS.Get(sym) ELSE EXIT END
805 END ;
806 CheckSym(rbrak)
807 ELSIF sym = period THEN DevCPS.Get(sym);
808 IF sym = ident THEN name := DevCPS.name; DevCPS.Get(sym);
809 IF x.typ # NIL THEN
810 IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END ;
811 IF x.typ.comp = Record THEN
812 typ := x.typ; DevCPT.FindField(name, typ, obj); DevCPB.Field(x, obj);
813 IF (obj # NIL) & (obj.mode = TProc) THEN
814 IF sym = arrow THEN (* super call *) DevCPS.Get(sym);
815 y := x.left;
816 IF y.class = Nderef THEN y := y.left END ; (* y = record variable *)
817 IF y.obj # NIL THEN
818 proc := DevCPT.topScope; (* find innermost scope which owner is a TProc *)
819 WHILE (proc.link # NIL) & (proc.link.mode # TProc) DO proc := proc.left END ;
820 IF (proc.link = NIL) OR (proc.link.link # y.obj) (* OR (proc.link.name^ # name) *) THEN err(75)
821 END ;
822 typ := y.obj.typ;
823 IF typ.form = Pointer THEN typ := typ.BaseTyp END ;
824 DevCPT.FindBaseField(x.obj.name^, typ, p);
825 IF p # NIL THEN
826 x.subcl := super; x.typ := p.typ; (* correct result type *)
827 IF p.conval.setval * {absAttr, empAttr} # {} THEN err(194) END;
828 IF (p.vis = externalR) & (p.mnolev < 0) & (proc.link.name^ # name) THEN err(196) END;
829 ELSE err(74)
830 END
831 ELSE err(75)
832 END
833 ELSE
834 proc := obj;
835 WHILE (proc.mnolev >= 0) & ~(newAttr IN proc.conval.setval) & (typ.BaseTyp # NIL) DO
836 (* find base method *)
837 typ := typ.BaseTyp; DevCPT.FindField(name, typ, proc);
838 END;
839 IF (proc.vis = externalR) & (proc.mnolev < 0) THEN err(196) END;
840 END ;
841 IF (obj.typ # DevCPT.notyp) & (sym # lparen) THEN err(lparen) END
842 END
843 ELSE err(53)
844 END
845 ELSE err(52)
846 END
847 ELSE err(ident)
848 END
849 ELSIF sym = arrow THEN DevCPS.Get(sym); DevCPB.DeRef(x)
850 ELSIF sym = dollar THEN
851 IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END;
852 DevCPS.Get(sym); DevCPB.StrDeref(x)
853 ELSIF sym = lparen THEN
854 IF (x.obj # NIL) & (x.obj.mode IN {XProc, LProc, CProc, TProc}) THEN typ := x.obj.typ
855 ELSIF x.typ.form = ProcTyp THEN typ := x.typ.BaseTyp
856 ELSIF x.class = Nproc THEN EXIT (* standard procedure *)
857 ELSE typ := NIL
858 END;
859 IF typ # DevCPT.notyp THEN
860 DevCPS.Get(sym);
861 IF typ = NIL THEN (* type guard *)
862 IF sym = ident THEN
863 qualident(obj);
864 IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE)
865 ELSE err(52)
866 END
867 ELSE err(ident)
868 END
869 ELSE (* function call *)
870 pre := NIL; lastp := NIL;
871 DevCPB.PrepCall(x, fpar);
872 IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp)
873 END;
874 ActualParameters(apar, fpar, pre, lastp);
875 DevCPB.Call(x, apar, fpar);
876 IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END;
877 IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
878 END;
879 CheckSym(rparen)
880 ELSE EXIT
881 END
882 (*
883 ELSIF (sym = lparen) & (x.class # Nproc) & (x.typ.form # ProcTyp) &
884 ((x.obj = NIL) OR (x.obj.mode # TProc)) THEN
885 DevCPS.Get(sym);
886 IF sym = ident THEN
887 qualident(obj);
888 IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE)
889 ELSE err(52)
890 END
891 ELSE err(ident)
892 END ;
893 CheckSym(rparen)
894 *)
895 ELSE EXIT
896 END
897 END
898 END selector;
900 PROCEDURE StandProcCall(VAR x: DevCPT.Node);
901 VAR y: DevCPT.Node; m: BYTE; n: SHORTINT;
902 BEGIN m := SHORT(SHORT(x.obj.adr)); n := 0;
903 IF sym = lparen THEN DevCPS.Get(sym);
904 IF sym # rparen THEN
905 LOOP
906 IF n = 0 THEN Expression(x); DevCPB.StPar0(x, m); n := 1
907 ELSIF n = 1 THEN Expression(y); DevCPB.StPar1(x, y, m); n := 2
908 ELSE Expression(y); DevCPB.StParN(x, y, m, n); INC(n)
909 END ;
910 IF sym = comma THEN DevCPS.Get(sym)
911 ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
912 ELSE EXIT
913 END
914 END ;
915 CheckSym(rparen)
916 ELSE DevCPS.Get(sym)
917 END ;
918 DevCPB.StFct(x, m, n)
919 ELSE err(lparen)
920 END ;
921 IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN DevCPT.topScope.link.leaf := FALSE END
922 END StandProcCall;
924 PROCEDURE Element(VAR x: DevCPT.Node);
925 VAR y: DevCPT.Node;
926 BEGIN Expression(x);
927 IF sym = upto THEN
928 DevCPS.Get(sym); Expression(y); DevCPB.SetRange(x, y)
929 ELSE DevCPB.SetElem(x)
930 END
931 END Element;
933 PROCEDURE Sets(VAR x: DevCPT.Node);
934 VAR y: DevCPT.Node;
935 BEGIN
936 IF sym # rbrace THEN
937 Element(x);
938 LOOP
939 IF sym = comma THEN DevCPS.Get(sym)
940 ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
941 ELSE EXIT
942 END ;
943 Element(y); DevCPB.Op(plus, x, y)
944 END
945 ELSE x := DevCPB.EmptySet()
946 END ;
947 CheckSym(rbrace)
948 END Sets;
950 PROCEDURE Factor(VAR x: DevCPT.Node);
951 VAR fpar, id: DevCPT.Object; apar: DevCPT.Node;
952 BEGIN
953 IF sym < not THEN err(13);
954 REPEAT DevCPS.Get(sym) UNTIL sym >= lparen
955 END ;
956 IF sym = ident THEN
957 qualident(id); x := DevCPB.NewLeaf(id); selector(x);
958 IF (x.class = Nproc) & (x.obj.mode = SProc) THEN StandProcCall(x) (* x may be NIL *)
959 (*
960 ELSIF sym = lparen THEN
961 DevCPS.Get(sym); DevCPB.PrepCall(x, fpar);
962 ActualParameters(apar, fpar);
963 DevCPB.Call(x, apar, fpar);
964 CheckSym(rparen);
965 IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
966 *)
967 END
968 ELSIF sym = number THEN
969 CASE DevCPS.numtyp OF
970 char:
971 x := DevCPB.NewIntConst(DevCPS.intval); x.typ := DevCPT.char8typ;
972 IF DevCPS.intval > 255 THEN x.typ := DevCPT.char16typ END
973 | integer: x := DevCPB.NewIntConst(DevCPS.intval)
974 | int64: x := DevCPB.NewLargeIntConst(DevCPS.intval, DevCPS.realval)
975 | real: x := DevCPB.NewRealConst(DevCPS.realval, NIL)
976 | real32: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real32typ)
977 | real64: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real64typ)
978 END ;
979 DevCPS.Get(sym)
980 ELSIF sym = string THEN
981 x := DevCPB.NewString(DevCPS.str, DevCPS.lstr, DevCPS.intval);
982 DevCPS.Get(sym)
983 ELSIF sym = nil THEN
984 x := DevCPB.Nil(); DevCPS.Get(sym)
985 ELSIF sym = lparen THEN
986 DevCPS.Get(sym); Expression(x); CheckSym(rparen)
987 ELSIF sym = lbrak THEN
988 DevCPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen)
989 ELSIF sym = lbrace THEN DevCPS.Get(sym); Sets(x)
990 ELSIF sym = not THEN
991 DevCPS.Get(sym); Factor(x); DevCPB.MOp(not, x)
992 ELSE err(13); DevCPS.Get(sym); x := NIL
993 END ;
994 IF x = NIL THEN x := DevCPB.NewIntConst(1); x.typ := DevCPT.undftyp END
995 END Factor;
997 PROCEDURE Term(VAR x: DevCPT.Node);
998 VAR y: DevCPT.Node; mulop: BYTE;
999 BEGIN Factor(x);
1000 WHILE (times <= sym) & (sym <= and) DO
1001 mulop := sym; DevCPS.Get(sym);
1002 Factor(y); DevCPB.Op(mulop, x, y)
1003 END
1004 END Term;
1006 PROCEDURE SimpleExpression(VAR x: DevCPT.Node);
1007 VAR y: DevCPT.Node; addop: BYTE;
1008 BEGIN
1009 IF sym = minus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(minus, x)
1010 ELSIF sym = plus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(plus, x)
1011 ELSE Term(x)
1012 END ;
1013 WHILE (plus <= sym) & (sym <= or) DO
1014 addop := sym; DevCPS.Get(sym); Term(y);
1015 IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END;
1016 IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) (* OR (x.typ.sysflag = jstr) *) THEN
1017 DevCPB.StrDeref(x)
1018 END;
1019 IF y.typ.form = Pointer THEN DevCPB.DeRef(y) END;
1020 IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) (* OR (y.typ.sysflag = jstr) *) THEN
1021 DevCPB.StrDeref(y)
1022 END;
1023 DevCPB.Op(addop, x, y)
1024 END
1025 END SimpleExpression;
1027 PROCEDURE Expression(VAR x: DevCPT.Node);
1028 VAR y, pre, last: DevCPT.Node; obj: DevCPT.Object; relation: BYTE;
1029 BEGIN SimpleExpression(x);
1030 IF (eql <= sym) & (sym <= geq) THEN
1031 relation := sym; DevCPS.Get(sym); SimpleExpression(y);
1032 pre := NIL; last := NIL;
1033 IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN
1034 DevCPB.StrDeref(x)
1035 END;
1036 IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) THEN
1037 DevCPB.StrDeref(y)
1038 END;
1039 DevCPB.CheckBuffering(x, NIL, NIL, pre, last);
1040 DevCPB.CheckBuffering(y, NIL, NIL, pre, last);
1041 DevCPB.Op(relation, x, y);
1042 IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END
1043 ELSIF sym = in THEN
1044 DevCPS.Get(sym); SimpleExpression(y); DevCPB.In(x, y)
1045 ELSIF sym = is THEN
1046 DevCPS.Get(sym);
1047 IF sym = ident THEN
1048 qualident(obj);
1049 IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, FALSE)
1050 ELSE err(52)
1051 END
1052 ELSE err(ident)
1053 END
1054 END
1055 END Expression;
1057 PROCEDURE ProcedureDeclaration(VAR x: DevCPT.Node);
1058 VAR proc, fwd: DevCPT.Object;
1059 name: DevCPT.Name;
1060 mode: BYTE;
1061 forward: BOOLEAN;
1062 sys: SHORTINT;
1064 PROCEDURE GetCode;
1065 VAR ext: DevCPT.ConstExt; i, n, c: INTEGER; s: ARRAY 256 OF SHORTCHAR;
1066 BEGIN
1067 n := 0;
1068 IF sym = string THEN
1069 NEW(ext, DevCPS.intval);
1070 WHILE DevCPS.str[n] # 0X DO ext[n+1] := DevCPS.str[n]; INC(n) END ;
1071 ext^[0] := SHORT(CHR(n)); DevCPS.Get(sym);
1072 ELSE
1073 LOOP
1074 IF sym = number THEN c := DevCPS.intval; INC(n);
1075 IF (c < 0) OR (c > 255) OR (n = 255) THEN
1076 err(64); c := 1; n := 1
1077 END ;
1078 DevCPS.Get(sym); s[n] := SHORT(CHR(c))
1079 END ;
1080 IF sym = comma THEN DevCPS.Get(sym)
1081 ELSIF sym = number THEN err(comma)
1082 ELSE s[0] := SHORT(CHR(n)); EXIT
1083 END
1084 END;
1085 NEW(ext, n + 1); i := 0;
1086 WHILE i <= n DO ext[i] := s[i]; INC(i) END;
1087 END;
1088 proc.conval.ext := ext;
1089 INCL(proc.conval.setval, hasBody)
1090 END GetCode;
1092 PROCEDURE GetParams;
1093 VAR name: DevCPT.String;
1094 BEGIN
1095 proc.mode := mode; proc.typ := DevCPT.notyp;
1096 proc.sysflag := SHORT(sys);
1097 proc.conval.setval := {};
1098 IF sym = lparen THEN
1099 DevCPS.Get(sym); FormalParameters(proc.link, proc.typ, name);
1100 IF name # NIL THEN err(0) END
1101 END;
1102 CheckForwardTypes; userList := NIL;
1103 IF fwd # NIL THEN
1104 DevCPB.CheckParameters(proc.link, fwd.link, TRUE);
1105 IF ~DevCPT.EqualType(proc.typ, fwd.typ) THEN err(117) END ;
1106 proc := fwd; DevCPT.topScope := proc.scope;
1107 IF mode = IProc THEN proc.mode := IProc END
1108 END
1109 END GetParams;
1111 PROCEDURE Body;
1112 VAR procdec, statseq: DevCPT.Node; c: INTEGER;
1113 BEGIN
1114 c := DevCPM.errpos;
1115 INCL(proc.conval.setval, hasBody);
1116 CheckSym(semicolon); Block(procdec, statseq);
1117 DevCPB.Enter(procdec, statseq, proc); x := procdec;
1118 x.conval := DevCPT.NewConst(); x.conval.intval := c; x.conval.intval2 := DevCPM.startpos;
1119 CheckSym(end);
1120 IF sym = ident THEN
1121 IF DevCPS.name # proc.name^ THEN err(4) END ;
1122 DevCPS.Get(sym)
1123 ELSE err(ident)
1124 END
1125 END Body;
1127 PROCEDURE TProcDecl;
1128 VAR baseProc, o, bo: DevCPT.Object;
1129 objTyp, recTyp: DevCPT.Struct;
1130 objMode, objVis: BYTE;
1131 objName: DevCPT.Name;
1132 pnode: DevCPT.Node;
1133 fwdAttr: SET;
1134 BEGIN
1135 DevCPS.Get(sym); mode := TProc;
1136 IF level > 0 THEN err(73) END;
1137 Receiver(objMode, objVis, objName, objTyp, recTyp);
1138 IF sym = ident THEN
1139 name := DevCPS.name;
1140 DevCPT.FindField(name, recTyp, fwd);
1141 DevCPT.FindBaseField(name, recTyp, baseProc);
1142 IF (baseProc # NIL) & (baseProc.mode # TProc) THEN baseProc := NIL; err(1) END ;
1143 IF fwd = baseProc THEN fwd := NIL END ;
1144 IF (fwd # NIL) & (fwd.mnolev # level) THEN fwd := NIL END ;
1145 IF (fwd # NIL) & (fwd.mode = TProc) & (fwd.conval.setval * {hasBody, absAttr, empAttr} = {}) THEN
1146 (* there exists a corresponding forward declaration *)
1147 proc := DevCPT.NewObj(); proc.leaf := TRUE;
1148 proc.mode := TProc; proc.conval := DevCPT.NewConst();
1149 CheckMark(proc);
1150 IF fwd.vis # proc.vis THEN err(118) END;
1151 fwdAttr := fwd.conval.setval
1152 ELSE
1153 IF fwd # NIL THEN err(1); fwd := NIL END ;
1154 DevCPT.InsertField(name, recTyp, proc);
1155 proc.mode := TProc; proc.conval := DevCPT.NewConst();
1156 CheckMark(proc);
1157 IF recTyp.strobj # NIL THEN (* preserve declaration order *)
1158 o := recTyp.strobj.link;
1159 IF o = NIL THEN recTyp.strobj.link := proc
1160 ELSE
1161 WHILE o.nlink # NIL DO o := o.nlink END;
1162 o.nlink := proc
1163 END
1164 END
1165 END;
1166 INC(level); DevCPT.OpenScope(level, proc);
1167 DevCPT.Insert(objName, proc.link); proc.link.mode := objMode; proc.link.vis := objVis; proc.link.typ := objTyp;
1168 ASSERT(DevCPT.topScope # NIL);
1169 GetParams; (* may change proc := fwd !!! *)
1170 ASSERT(DevCPT.topScope # NIL);
1171 GetAttributes(proc, baseProc, recTyp);
1172 IF (fwd # NIL) & (fwdAttr / proc.conval.setval * {absAttr, empAttr, extAttr} # {}) THEN err(184) END;
1173 CheckOverwrite(proc, baseProc, recTyp);
1174 IF ~forward THEN
1175 IF empAttr IN proc.conval.setval THEN (* insert empty procedure *)
1176 pnode := NIL; DevCPB.Enter(pnode, NIL, proc);
1177 pnode.conval := DevCPT.NewConst();
1178 pnode.conval.intval := DevCPM.errpos;
1179 pnode.conval.intval2 := DevCPM.errpos;
1180 x := pnode;
1181 ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody)
1182 ELSIF ~(absAttr IN proc.conval.setval) THEN Body
1183 END;
1184 proc.adr := 0
1185 ELSE
1186 proc.adr := DevCPM.errpos;
1187 IF proc.conval.setval * {empAttr, absAttr} # {} THEN err(184) END
1188 END;
1189 DEC(level); DevCPT.CloseScope;
1190 ELSE err(ident)
1191 END;
1192 END TProcDecl;
1194 BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; sys := 0;
1195 IF (sym # ident) & (sym # lparen) THEN
1196 CheckSysFlag(sys, DevCPM.GetProcSysFlag);
1197 IF sys # 0 THEN
1198 IF ODD(sys DIV DevCPM.CProcFlag) THEN mode := CProc END
1199 ELSE
1200 IF sym = times THEN (* mode set later in DevCPB.CheckAssign *)
1201 ELSIF sym = arrow THEN forward := TRUE
1202 ELSE err(ident)
1203 END;
1204 DevCPS.Get(sym)
1205 END
1206 END ;
1207 IF sym = lparen THEN TProcDecl
1208 ELSIF sym = ident THEN DevCPT.Find(DevCPS.name, fwd);
1209 name := DevCPS.name;
1210 IF (fwd # NIL) & ((fwd.mnolev # level) OR (fwd.mode = SProc)) THEN fwd := NIL END ;
1211 IF (fwd # NIL) & (fwd.mode IN {LProc, XProc}) & ~(hasBody IN fwd.conval.setval) THEN
1212 (* there exists a corresponding forward declaration *)
1213 proc := DevCPT.NewObj(); proc.leaf := TRUE;
1214 proc.mode := mode; proc.conval := DevCPT.NewConst();
1215 CheckMark(proc);
1216 IF fwd.vis # proc.vis THEN err(118) END
1217 ELSE
1218 IF fwd # NIL THEN err(1); fwd := NIL END ;
1219 DevCPT.Insert(name, proc);
1220 proc.mode := mode; proc.conval := DevCPT.NewConst();
1221 CheckMark(proc);
1222 END ;
1223 IF (proc.vis # internal) & (mode = LProc) THEN mode := XProc END ;
1224 IF (mode # LProc) & (level > 0) THEN err(73) END ;
1225 INC(level); DevCPT.OpenScope(level, proc);
1226 proc.link := NIL; GetParams; (* may change proc := fwd !!! *)
1227 IF mode = CProc THEN GetCode
1228 ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody)
1229 ELSIF ~forward THEN Body; proc.adr := 0
1230 ELSE proc.adr := DevCPM.errpos
1231 END ;
1232 DEC(level); DevCPT.CloseScope
1233 ELSE err(ident)
1234 END
1235 END ProcedureDeclaration;
1237 PROCEDURE CaseLabelList(VAR lab, root: DevCPT.Node; LabelForm: SHORTINT; VAR min, max: INTEGER);
1238 VAR x, y, lastlab: DevCPT.Node; i, f: SHORTINT; xval, yval: INTEGER;
1240 PROCEDURE Insert(VAR n: DevCPT.Node); (* build binary tree of label ranges *) (* !!! *)
1241 BEGIN
1242 IF n = NIL THEN
1243 IF x.hint # 1 THEN n := x END
1244 ELSIF yval < n.conval.intval THEN Insert(n.left)
1245 ELSIF xval > n.conval.intval2 THEN Insert(n.right)
1246 ELSE err(63)
1247 END
1248 END Insert;
1250 BEGIN lab := NIL; lastlab := NIL;
1251 LOOP ConstExpression(x); f := x.typ.form;
1252 IF f IN {Int8..Int32} + charSet THEN xval := x.conval.intval
1253 ELSE err(61); xval := 1
1254 END ;
1255 IF (f IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END;
1256 IF sym = upto THEN
1257 DevCPS.Get(sym); ConstExpression(y); yval := y.conval.intval;
1258 IF (y.typ.form IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END;
1259 IF yval < xval THEN err(63); yval := xval END
1260 ELSE yval := xval
1261 END ;
1262 x.conval.intval2 := yval;
1263 IF xval < min THEN min := xval END;
1264 IF yval > max THEN max := yval END;
1265 IF lab = NIL THEN lab := x; Insert(root)
1266 ELSIF yval < lab.conval.intval - 1 THEN x.link := lab; lab := x; Insert(root)
1267 ELSIF yval = lab.conval.intval - 1 THEN x.hint := 1; Insert(root); lab.conval.intval := xval
1268 ELSIF xval = lab.conval.intval2 + 1 THEN x.hint := 1; Insert(root); lab.conval.intval2 := yval
1269 ELSE
1270 y := lab;
1271 WHILE (y.link # NIL) & (xval > y.link.conval.intval2 + 1) DO y := y.link END;
1272 IF y.link = NIL THEN y.link := x; Insert(root)
1273 ELSIF yval < y.link.conval.intval - 1 THEN x.link := y.link; y.link := x; Insert(root)
1274 ELSIF yval = y.link.conval.intval - 1 THEN x.hint := 1; Insert(root); y.link.conval.intval := xval
1275 ELSIF xval = y.link.conval.intval2 + 1 THEN x.hint := 1; Insert(root); y.link.conval.intval2 := yval
1276 END
1277 END;
1278 IF sym = comma THEN DevCPS.Get(sym)
1279 ELSIF (sym = number) OR (sym = ident) THEN err(comma)
1280 ELSE EXIT
1281 END
1282 END
1283 END CaseLabelList;
1285 PROCEDURE StatSeq(VAR stat: DevCPT.Node);
1286 VAR fpar, id, t, obj: DevCPT.Object; idtyp: DevCPT.Struct; e: BOOLEAN;
1287 s, x, y, z, apar, last, lastif, pre, lastp: DevCPT.Node; pos, p: INTEGER; name: DevCPT.Name;
1289 PROCEDURE CasePart(VAR x: DevCPT.Node);
1290 VAR low, high: INTEGER; e: BOOLEAN; cases, lab, y, lastcase, root: DevCPT.Node;
1291 BEGIN
1292 Expression(x);
1293 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1294 ELSIF x.typ.form = Int64 THEN err(260)
1295 ELSIF ~(x.typ.form IN {Int8..Int32} + charSet) THEN err(125)
1296 END ;
1297 CheckSym(of); cases := NIL; lastcase := NIL; root := NIL;
1298 low := MAX(INTEGER); high := MIN(INTEGER);
1299 LOOP
1300 IF sym < bar THEN
1301 CaseLabelList(lab, root, x.typ.form, low, high);
1302 CheckSym(colon); StatSeq(y);
1303 DevCPB.Construct(Ncasedo, lab, y); DevCPB.Link(cases, lastcase, lab)
1304 END ;
1305 IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END
1306 END;
1307 e := sym = else;
1308 IF e THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ;
1309 DevCPB.Construct(Ncaselse, cases, y); DevCPB.Construct(Ncase, x, cases);
1310 cases.conval := DevCPT.NewConst();
1311 cases.conval.intval := low; cases.conval.intval2 := high;
1312 IF e THEN cases.conval.setval := {1} ELSE cases.conval.setval := {} END;
1313 DevCPB.OptimizeCase(root); cases.link := root (* !!! *)
1314 END CasePart;
1316 PROCEDURE SetPos(x: DevCPT.Node);
1317 BEGIN
1318 x.conval := DevCPT.NewConst(); x.conval.intval := pos
1319 END SetPos;
1321 PROCEDURE CheckBool(VAR x: DevCPT.Node);
1322 BEGIN
1323 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := DevCPB.NewBoolConst(FALSE)
1324 ELSIF x.typ.form # Bool THEN err(120); x := DevCPB.NewBoolConst(FALSE)
1325 END
1326 END CheckBool;
1328 BEGIN stat := NIL; last := NIL;
1329 LOOP x := NIL;
1330 IF sym < ident THEN err(14);
1331 REPEAT DevCPS.Get(sym) UNTIL sym >= ident
1332 END ;
1333 pos := DevCPM.startpos;
1334 IF sym = ident THEN
1335 qualident(id); x := DevCPB.NewLeaf(id); selector(x);
1336 IF sym = becomes THEN
1337 DevCPS.Get(sym); Expression(y);
1338 IF (y.typ.form = Pointer) & (x.typ.form = Comp) THEN DevCPB.DeRef(y) END;
1339 pre := NIL; lastp := NIL;
1340 DevCPB.CheckBuffering(y, x, NIL, pre, lastp);
1341 DevCPB.Assign(x, y);
1342 IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END;
1343 ELSIF sym = eql THEN
1344 err(becomes); DevCPS.Get(sym); Expression(y); DevCPB.Assign(x, y)
1345 ELSIF (x.class = Nproc) & (x.obj.mode = SProc) THEN
1346 StandProcCall(x);
1347 IF (x # NIL) & (x.typ # DevCPT.notyp) THEN err(55) END;
1348 IF (x # NIL) & (x.class = Nifelse) THEN (* error pos for ASSERT *)
1349 SetPos(x.left); SetPos(x.left.right)
1350 END
1351 ELSIF x.class = Ncall THEN err(55)
1352 ELSE
1353 pre := NIL; lastp := NIL;
1354 DevCPB.PrepCall(x, fpar);
1355 IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) END;
1356 IF sym = lparen THEN
1357 DevCPS.Get(sym); ActualParameters(apar, fpar, pre, lastp); CheckSym(rparen)
1358 ELSE apar := NIL;
1359 IF fpar # NIL THEN err(65) END
1360 END ;
1361 DevCPB.Call(x, apar, fpar);
1362 IF x.typ # DevCPT.notyp THEN err(55) END;
1363 IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END;
1364 IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
1365 END
1366 ELSIF sym = if THEN
1367 DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(then); StatSeq(y);
1368 DevCPB.Construct(Nif, x, y); SetPos(x); lastif := x;
1369 WHILE sym = elsif DO
1370 DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y); CheckSym(then); StatSeq(z);
1371 DevCPB.Construct(Nif, y, z); SetPos(y); DevCPB.Link(x, lastif, y)
1372 END ;
1373 pos := DevCPM.startpos;
1374 IF sym = else THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ;
1375 DevCPB.Construct(Nifelse, x, y); CheckSym(end); DevCPB.OptIf(x);
1376 ELSIF sym = case THEN
1377 DevCPS.Get(sym); pos := DevCPM.startpos; CasePart(x); CheckSym(end)
1378 ELSIF sym = while THEN
1379 DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(do); StatSeq(y);
1380 DevCPB.Construct(Nwhile, x, y); CheckSym(end)
1381 ELSIF sym = repeat THEN
1382 DevCPS.Get(sym); StatSeq(x);
1383 IF sym = until THEN DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y)
1384 ELSE err(43)
1385 END ;
1386 DevCPB.Construct(Nrepeat, x, y)
1387 ELSIF sym = for THEN
1388 DevCPS.Get(sym); pos := DevCPM.startpos;
1389 IF sym = ident THEN qualident(id);
1390 IF ~(id.typ.form IN intSet) THEN err(68) END ;
1391 CheckSym(becomes); Expression(y);
1392 x := DevCPB.NewLeaf(id); DevCPB.Assign(x, y); SetPos(x);
1393 CheckSym(to); pos := DevCPM.startpos; Expression(y);
1394 IF y.class # Nconst THEN
1395 DevCPB.GetTempVar("@for", x.left.typ, t);
1396 z := DevCPB.NewLeaf(t); DevCPB.Assign(z, y); SetPos(z); DevCPB.Link(stat, last, z);
1397 y := DevCPB.NewLeaf(t)
1398 ELSE
1399 DevCPB.CheckAssign(x.left.typ, y)
1400 END ;
1401 DevCPB.Link(stat, last, x);
1402 p := DevCPM.startpos;
1403 IF sym = by THEN DevCPS.Get(sym); ConstExpression(z) ELSE z := DevCPB.NewIntConst(1) END ;
1404 x := DevCPB.NewLeaf(id);
1405 IF z.conval.intval > 0 THEN DevCPB.Op(leq, x, y)
1406 ELSIF z.conval.intval < 0 THEN DevCPB.Op(geq, x, y)
1407 ELSE err(63); DevCPB.Op(geq, x, y)
1408 END ;
1409 CheckSym(do); StatSeq(s);
1410 y := DevCPB.NewLeaf(id); DevCPB.StPar1(y, z, incfn); pos := DevCPM.startpos; SetPos(y);
1411 IF s = NIL THEN s := y
1412 ELSE z := s;
1413 WHILE z.link # NIL DO z := z.link END ;
1414 z.link := y
1415 END ;
1416 CheckSym(end); DevCPB.Construct(Nwhile, x, s); pos := p
1417 ELSE err(ident)
1418 END
1419 ELSIF sym = loop THEN
1420 DevCPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel);
1421 DevCPB.Construct(Nloop, x, NIL); CheckSym(end)
1422 ELSIF sym = with THEN
1423 DevCPS.Get(sym); idtyp := NIL; x := NIL;
1424 LOOP
1425 IF sym < bar THEN
1426 pos := DevCPM.startpos;
1427 IF sym = ident THEN
1428 qualident(id); y := DevCPB.NewLeaf(id);
1429 IF (id # NIL) & (id.typ.form = Pointer) & ((id.mode = VarPar) OR ~id.leaf) THEN
1430 err(-302) (* warning 302 *)
1431 END ;
1432 CheckSym(colon);
1433 IF sym = ident THEN qualident(t);
1434 IF t.mode = Typ THEN
1435 IF id # NIL THEN
1436 idtyp := id.typ; DevCPB.TypTest(y, t, FALSE); id.typ := t.typ;
1437 IF id.ptyp = NIL THEN id.ptyp := idtyp END
1438 ELSE err(130)
1439 END
1440 ELSE err(52)
1441 END
1442 ELSE err(ident)
1443 END
1444 ELSE err(ident)
1445 END ;
1446 CheckSym(do); StatSeq(s); DevCPB.Construct(Nif, y, s); SetPos(y);
1447 IF idtyp # NIL THEN
1448 IF id.ptyp = idtyp THEN id.ptyp := NIL END;
1449 id.typ := idtyp; idtyp := NIL
1450 END ;
1451 IF x = NIL THEN x := y; lastif := x ELSE DevCPB.Link(x, lastif, y) END
1452 END;
1453 IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END
1454 END;
1455 e := sym = else; pos := DevCPM.startpos;
1456 IF e THEN DevCPS.Get(sym); StatSeq(s) ELSE s := NIL END ;
1457 DevCPB.Construct(Nwith, x, s); CheckSym(end);
1458 IF e THEN x.subcl := 1 END
1459 ELSIF sym = exit THEN
1460 DevCPS.Get(sym);
1461 IF LoopLevel = 0 THEN err(46) END ;
1462 DevCPB.Construct(Nexit, x, NIL)
1463 ELSIF sym = return THEN DevCPS.Get(sym);
1464 IF sym < semicolon THEN Expression(x) END ;
1465 IF level > 0 THEN DevCPB.Return(x, DevCPT.topScope.link)
1466 ELSE (* not standard Oberon *) DevCPB.Return(x, NIL)
1467 END;
1468 hasReturn := TRUE
1469 END ;
1470 IF x # NIL THEN SetPos(x); DevCPB.Link(stat, last, x) END ;
1471 IF sym = semicolon THEN DevCPS.Get(sym)
1472 ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon)
1473 ELSE EXIT
1474 END
1475 END
1476 END StatSeq;
1478 PROCEDURE Block(VAR procdec, statseq: DevCPT.Node);
1479 VAR typ: DevCPT.Struct;
1480 obj, first, last, o: DevCPT.Object;
1481 x, lastdec: DevCPT.Node;
1482 i: SHORTINT;
1483 rname: DevCPT.Name;
1484 name: DevCPT.String;
1485 rec: Elem;
1487 BEGIN
1488 IF ((sym < begin) OR (sym > var)) & (sym # procedure) & (sym # end) & (sym # close) THEN err(36) END;
1489 first := NIL; last := NIL; userList := NIL; recList := NIL;
1490 LOOP
1491 IF sym = const THEN
1492 DevCPS.Get(sym);
1493 WHILE sym = ident DO
1494 DevCPT.Insert(DevCPS.name, obj);
1495 obj.mode := Con; CheckMark(obj);
1496 obj.typ := DevCPT.int8typ; obj.mode := Var; (* Var to avoid recursive definition *)
1497 IF sym = eql THEN
1498 DevCPS.Get(sym); ConstExpression(x)
1499 ELSIF sym = becomes THEN
1500 err(eql); DevCPS.Get(sym); ConstExpression(x)
1501 ELSE err(eql); x := DevCPB.NewIntConst(1)
1502 END ;
1503 obj.mode := Con; obj.typ := x.typ; obj.conval := x.conval; (* ConstDesc ist not copied *)
1504 CheckSym(semicolon)
1505 END
1506 END ;
1507 IF sym = type THEN
1508 DevCPS.Get(sym);
1509 WHILE sym = ident DO
1510 DevCPT.Insert(DevCPS.name, obj); obj.mode := Typ; obj.typ := DevCPT.undftyp;
1511 CheckMark(obj); obj.mode := -1;
1512 IF sym # eql THEN err(eql) END;
1513 IF (sym = eql) OR (sym = becomes) OR (sym = colon) THEN
1514 DevCPS.Get(sym); Type(obj.typ, name); SetType(NIL, obj, obj.typ, name);
1515 END;
1516 obj.mode := Typ;
1517 IF obj.typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *)
1518 typ := DevCPT.NewStr(obj.typ.form, Basic); i := typ.ref;
1519 typ^ := obj.typ^; typ.ref := i; typ.strobj := NIL; typ.mno := 0; typ.txtpos := DevCPM.errpos;
1520 typ.BaseTyp := obj.typ; obj.typ := typ;
1521 END;
1522 IF obj.typ.strobj = NIL THEN obj.typ.strobj := obj END ;
1523 IF obj.typ.form = Pointer THEN (* !!! *)
1524 typ := obj.typ.BaseTyp;
1525 IF (typ # NIL) & (typ.comp = Record) & (typ.strobj = NIL) THEN
1526 (* pointer to unnamed record: name record as "pointerName^" *)
1527 rname := obj.name^$; i := 0;
1528 WHILE rname[i] # 0X DO INC(i) END;
1529 rname[i] := "^"; rname[i+1] := 0X;
1530 DevCPT.Insert(rname, o); o.mode := Typ; o.typ := typ; typ.strobj := o
1531 END
1532 END;
1533 IF obj.vis # internal THEN
1534 typ := obj.typ;
1535 IF typ.form = Pointer THEN typ := typ.BaseTyp END;
1536 IF typ.comp = Record THEN typ.exp := TRUE END
1537 END;
1538 CheckSym(semicolon)
1539 END
1540 END ;
1541 IF sym = var THEN
1542 DevCPS.Get(sym);
1543 WHILE sym = ident DO
1544 LOOP
1545 IF sym = ident THEN
1546 DevCPT.Insert(DevCPS.name, obj);
1547 obj.mode := Var; obj.link := NIL; obj.leaf := obj.vis = internal; obj.typ := DevCPT.undftyp;
1548 CheckMark(obj);
1549 IF first = NIL THEN first := obj END ;
1550 IF last = NIL THEN DevCPT.topScope.scope := obj ELSE last.link := obj END ;
1551 last := obj
1552 ELSE err(ident)
1553 END ;
1554 IF sym = comma THEN DevCPS.Get(sym)
1555 ELSIF sym = ident THEN err(comma)
1556 ELSE EXIT
1557 END
1558 END ;
1559 CheckSym(colon); Type(typ, name);
1560 CheckAlloc(typ, FALSE, DevCPM.errpos);
1561 WHILE first # NIL DO SetType(NIL, first, typ, name); first := first.link END ;
1562 CheckSym(semicolon)
1563 END
1564 END ;
1565 IF (sym < const) OR (sym > var) THEN EXIT END ;
1566 END ;
1567 CheckForwardTypes;
1568 userList := NIL; rec := recList; recList := NIL;
1569 DevCPT.topScope.adr := DevCPM.errpos;
1570 procdec := NIL; lastdec := NIL;
1571 IF (sym # procedure) & (sym # begin) & (sym # end) & (sym # close) THEN err(37) END;
1572 WHILE sym = procedure DO
1573 DevCPS.Get(sym); ProcedureDeclaration(x);
1574 IF x # NIL THEN
1575 IF lastdec = NIL THEN procdec := x ELSE lastdec.link := x END ;
1576 lastdec := x
1577 END ;
1578 CheckSym(semicolon)
1579 END ;
1580 IF DevCPM.noerr & ~(DevCPM.oberon IN DevCPM.options) THEN CheckRecords(rec) END;
1581 hasReturn := FALSE;
1582 IF (sym # begin) & (sym # end) & (sym # close) THEN err(38) END;
1583 IF sym = begin THEN DevCPS.Get(sym); StatSeq(statseq)
1584 ELSE statseq := NIL
1585 END ;
1586 IF (DevCPT.topScope.link # NIL) & (DevCPT.topScope.link.typ # DevCPT.notyp)
1587 & ~hasReturn & (DevCPT.topScope.link.sysflag = 0) THEN err(133) END;
1588 IF (level = 0) & (TDinit # NIL) THEN
1589 lastTDinit.link := statseq; statseq := TDinit
1590 END
1591 END Block;
1593 PROCEDURE Module*(VAR prog: DevCPT.Node);
1594 VAR impName, aliasName: DevCPT.Name;
1595 procdec, statseq: DevCPT.Node;
1596 c, sf: INTEGER; done: BOOLEAN;
1597 BEGIN
1598 DevCPS.Init; LoopLevel := 0; level := 0; DevCPS.Get(sym);
1599 IF sym = module THEN DevCPS.Get(sym) ELSE err(16) END ;
1600 IF sym = ident THEN
1601 DevCPT.Open(DevCPS.name); DevCPS.Get(sym);
1602 DevCPT.libName := "";
1603 IF sym = lbrak THEN
1604 INCL(DevCPM.options, DevCPM.interface); DevCPS.Get(sym);
1605 IF sym = eql THEN DevCPS.Get(sym)
1606 ELSE INCL(DevCPM.options, DevCPM.noCode)
1607 END;
1608 IF sym = string THEN DevCPT.libName := DevCPS.str^$; DevCPS.Get(sym)
1609 ELSE err(string)
1610 END;
1611 CheckSym(rbrak)
1612 END;
1613 CheckSym(semicolon);
1614 IF sym = import THEN DevCPS.Get(sym);
1615 LOOP
1616 IF sym = ident THEN
1617 aliasName := DevCPS.name$; impName := aliasName$; DevCPS.Get(sym);
1618 IF sym = becomes THEN DevCPS.Get(sym);
1619 IF sym = ident THEN impName := DevCPS.name$; DevCPS.Get(sym) ELSE err(ident) END
1620 END ;
1621 DevCPT.Import(aliasName, impName, done)
1622 ELSE err(ident)
1623 END ;
1624 IF sym = comma THEN DevCPS.Get(sym)
1625 ELSIF sym = ident THEN err(comma)
1626 ELSE EXIT
1627 END
1628 END ;
1629 CheckSym(semicolon)
1630 END ;
1631 IF DevCPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := DevCPM.errpos;
1632 Block(procdec, statseq); DevCPB.Enter(procdec, statseq, NIL); prog := procdec;
1633 prog.conval := DevCPT.NewConst(); prog.conval.intval := c; prog.conval.intval2 := DevCPM.startpos;
1634 IF sym = close THEN DevCPS.Get(sym); StatSeq(prog.link) END;
1635 prog.conval.realval := DevCPM.startpos;
1636 CheckSym(end);
1637 IF sym = ident THEN
1638 IF DevCPS.name # DevCPT.SelfName THEN err(4) END ;
1639 DevCPS.Get(sym)
1640 ELSE err(ident)
1641 END;
1642 IF sym # period THEN err(period) END
1643 END
1644 ELSE err(ident)
1645 END ;
1646 TDinit := NIL; lastTDinit := NIL;
1647 DevCPS.str := NIL
1648 END Module;
1650 END DevCPP.