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