1 MODULE Meta;
3 (* THIS IS TEXT COPY OF BlackBox 1.6-rc System/Mod/Meta.odc *)
4 (* DO NOT EDIT *)
6 IMPORT SYSTEM, Kernel;
8 CONST
9 (** result codes for object classes, type classes, visibility classes **)
10 undef* = 0;
12 (** object classes **)
13 typObj* = 2; varObj* = 3; procObj* = 4; fieldObj* = 5; modObj* = 6; parObj* = 7;
15 (** type classes **)
16 boolTyp* = 1; sCharTyp* = 2; charTyp* = 3;
17 byteTyp* = 4; sIntTyp* = 5; intTyp* = 6;
18 sRealTyp* = 7; realTyp* = 8; setTyp* = 9;
19 longTyp* = 10; anyRecTyp* = 11; anyPtrTyp* = 12;
20 sysPtrTyp = 13;
21 procTyp* = 16; recTyp* = 17; arrTyp* = 18; ptrTyp* = 19;
23 (** record attributes **)
24 final* = 0; extensible* = 1; limited* = 2; abstract* = 3;
26 (** visibility **)
27 hidden* = 1; readOnly* = 2; private = 3; exported* = 4;
28 value* = 10; in* = 11; out* = 12; var* = 13;
30 (* scanner modes *)
31 modScan = 1; globScan = 2; recVarScan = 3; recTypeScan = 4;
33 TYPE
34 Name* = ARRAY 256 OF CHAR;
36 Value* = ABSTRACT RECORD END; (* to be extended once with a single field of any type *)
38 ArrayPtr = POINTER TO Array;
40 Item* = RECORD (Value)
41 obj-: INTEGER; (* typObj, varObj, procObj, fieldObj, modObj, parObj *)
42 typ-: INTEGER; (* typObj, varObj, fieldObj, parObj: type; else: 0 *)
43 vis-: INTEGER; (* varObj, procObj, fieldObj, parObj: vis; else: 0 *)
44 adr-: INTEGER; (* varObj, procObj: adr; fieldObj: offs; parObj: num; else: 0 *)
45 mod: Kernel.Module; (* static varObj, procObj, modObj: mod; else: NIL *)
46 desc: Kernel.Type; (* typObj, varObj, fieldObj, parObj: struct; procObj: sig; else: NIL *)
47 ptr: ArrayPtr; (* # NIL => item valid; dynamic varObj: ptr; else: dummy *)
48 ext: Kernel.ItemExt (* all method calls forwarded if # NIL *)
49 END;
51 Scanner* = RECORD
52 this-: Item;
53 eos-: BOOLEAN; (* end of scan *)
54 mode: INTEGER; (* modScan, globScan, recVarScan, recTypeScan *)
55 base: INTEGER; (* recVarScan, recTypeScan: base level index *)
56 vis: INTEGER; (* recVarScan: record vis *)
57 adr: INTEGER; (* recVarScan: record adr *)
58 idx: INTEGER; (* globScan, recVarScan, recTypeScan: object index *)
59 desc: Kernel.Type; (* recVarScan, recTypeScan: record desc *)
60 mod: Kernel.Module; (* modScan: next mod; globScan, recVarScan: source mod *)
61 obj: Kernel.Object (* globScan, recVarScan, recTypeScan: actual object *)
62 END;
64 LookupFilter* = PROCEDURE (IN path: ARRAY OF CHAR; OUT i: Item; OUT done: BOOLEAN);
66 FilterHook = POINTER TO RECORD
67 next: FilterHook;
68 filter: LookupFilter
69 END;
71 Array = EXTENSIBLE RECORD
72 w0, w1, w2: INTEGER; (* gc header *)
73 len: ARRAY 16 OF INTEGER (* dynamic array length table *)
74 END;
76 SStringPtr = POINTER TO ARRAY [1] OF SHORTCHAR;
77 StringPtr = POINTER TO ARRAY [1] OF CHAR;
79 VAR
80 dummy: ArrayPtr; (* dummy object for item.ptr *)
81 filterHook: FilterHook;
84 (* preconditions:
85 ASSERT(i.ptr # NIL, 20); (* invalid item *)
86 ASSERT(i.typ >= recTyp, 21); (* wrong type *)
87 ASSERT(i.obj = varObj, 22); (* wrong object class *)
88 ASSERT((i.mod = NIL) OR (i.mod.refcnt >= 0), 23); (* unloaded object module *)
89 ASSERT(i.desc.mod.refcnt >= 0, 24); (* unloaded type module *)
90 ASSERT(d.id DIV 16 MOD 16 = 1, 25); (* value not extended once *)
91 ASSERT(d.fields.num = 1, 26); (* not a single value field *)
92 ASSERT(i.vis = exported, 27); (* write protected destination *)
93 ASSERT(type.desc.base[t.id DIV 16 MOD 16] = t, 28); (* wrong pointer type *)
94 ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29); (* unexported type *)
95 ASSERT(type.desc.id DIV 4 MOD 4 < limited, 30); (* limited or abstract type *)
96 ASSERT(i.ext = NIL, 31); (* unsupported extension *)
97 *)
100 PROCEDURE DescOf (IN x: ANYREC): Kernel.Type;
101 BEGIN
102 RETURN SYSTEM.VAL(Kernel.Type, SYSTEM.TYP(x))
103 END DescOf;
105 PROCEDURE TypOf (struct: Kernel.Type): INTEGER;
106 BEGIN
107 IF SYSTEM.VAL(INTEGER, struct) DIV 256 = 0 THEN
108 RETURN SYSTEM.VAL(INTEGER, struct)
109 ELSE
110 RETURN 16 + struct.id MOD 4
111 END
112 END TypOf;
114 PROCEDURE LenOf (IN i: Item): INTEGER;
115 BEGIN
116 IF i.desc.size # 0 THEN RETURN i.desc.size
117 ELSIF i.ptr = dummy THEN RETURN 0
118 ELSE RETURN i.ptr.len[i.desc.id DIV 16 MOD 16 - 1]
119 END
120 END LenOf;
122 PROCEDURE SizeOf (IN i: Item): INTEGER;
123 VAR el: Item;
124 BEGIN
125 CASE i.typ OF
126 | anyRecTyp: RETURN 0
127 | boolTyp, sCharTyp, byteTyp: RETURN 1
128 | charTyp, sIntTyp: RETURN 2
129 | longTyp, realTyp: RETURN 8
130 | recTyp: RETURN i.desc.size
131 | arrTyp:
132 el.desc := i.desc.base[0]; el.typ := TypOf(el.desc); el.ptr := i.ptr;
133 RETURN LenOf(i) * SizeOf(el)
134 ELSE RETURN 4
135 END
136 END SizeOf;
138 PROCEDURE SignatureOf (IN i: Item): Kernel.Signature;
139 BEGIN
140 IF i.obj = procObj THEN
141 RETURN SYSTEM.VAL(Kernel.Signature, i.desc)
142 ELSE
143 RETURN SYSTEM.VAL(Kernel.Signature, i.desc.base[0])
144 END
145 END SignatureOf;
148 PROCEDURE GetName (IN path: ARRAY OF CHAR; OUT name: ARRAY OF CHAR; VAR i: INTEGER);
149 VAR j: INTEGER; ch: CHAR;
150 BEGIN
151 j := 0; ch := path[i];
152 WHILE (j < LEN(name) - 1) & ((ch >= "0") & (ch <= "9") OR (CAP(ch) >= "A") & (CAP(ch) <= "Z")
153 OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_")) DO
154 name[j] := ch; INC(i); INC(j); ch := path[i]
155 END;
156 IF (ch = 0X) OR (ch = ".") OR (ch = "[") OR (ch = "^") THEN name[j] := 0X
157 ELSE name[0] := 0X
158 END
159 END GetName;
161 PROCEDURE LegalName (IN name: ARRAY OF CHAR): BOOLEAN;
162 VAR i: INTEGER; ch: CHAR;
163 BEGIN
164 i := 0; ch := name[0];
165 WHILE (i < LEN(name) - 1) & ((ch >= "0") & (ch <= "9") OR (CAP(ch) >= "A") & (CAP(ch) <= "Z")
166 OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_")) DO
167 INC(i); ch := name[i]
168 END;
169 RETURN (i > 0) & (ch = 0X)
170 END LegalName;
173 (* ---------- Item properties ---------- *)
175 PROCEDURE (VAR i: Item) Valid* (): BOOLEAN, NEW;
176 BEGIN
177 IF i.ext # NIL THEN RETURN i.ext.Valid() END;
178 RETURN (i.ptr # NIL) & ((i.mod = NIL) OR (i.mod.refcnt >= 0)) & ((i.typ < recTyp) OR (i.desc.mod.refcnt >= 0))
179 END Valid;
181 PROCEDURE (VAR i: Item) GetTypeName* (OUT mod, type: Name), NEW;
182 VAR n: Kernel.Name;
183 BEGIN
184 ASSERT(i.ext = NIL, 31);
185 ASSERT(i.ptr # NIL, 20);
186 ASSERT(i.typ >= recTyp, 21);
187 ASSERT(i.desc.mod.refcnt >= 0, 24);
188 mod := i.desc.mod.name$;
189 Kernel.GetTypeName(i.desc, n);
190 type := n$
191 END GetTypeName;
193 PROCEDURE (VAR i: Item) BaseTyp* (): INTEGER, NEW;
194 BEGIN
195 IF i.ext # NIL THEN RETURN i.ext.BaseTyp() END;
196 ASSERT(i.ptr # NIL, 20);
197 ASSERT(i.typ IN {arrTyp, recTyp, ptrTyp}, 21);
198 RETURN TypOf(i.desc.base[0])
199 END BaseTyp;
201 PROCEDURE (VAR i: Item) Level* (): INTEGER, NEW;
202 BEGIN
203 ASSERT(i.ext = NIL, 31);
204 ASSERT(i.ptr # NIL, 20);
205 ASSERT(i.typ IN {recTyp, arrTyp}, 21);
206 RETURN i.desc.id DIV 16 MOD 16
207 END Level;
209 PROCEDURE (VAR i: Item) Attribute* (): INTEGER, NEW;
210 BEGIN
211 ASSERT(i.ext = NIL, 31);
212 ASSERT(i.ptr # NIL, 20);
213 ASSERT(i.typ = recTyp, 21);
214 RETURN i.desc.id DIV 4 MOD 4
215 END Attribute;
217 PROCEDURE (VAR i: Item) Size* (): INTEGER, NEW;
218 BEGIN
219 IF i.ext # NIL THEN RETURN i.ext.Size() END;
220 ASSERT(i.ptr # NIL, 20);
221 ASSERT(i.typ # undef, 21);
222 RETURN SizeOf(i)
223 END Size;
225 PROCEDURE (VAR arr: Item) Len* (): INTEGER, NEW;
226 BEGIN
227 IF arr.ext # NIL THEN RETURN arr.ext.Len() END;
228 ASSERT(arr.ptr # NIL, 20);
229 ASSERT(arr.typ = arrTyp, 21);
230 RETURN LenOf(arr)
231 END Len;
233 (* ---------- Item generation ---------- *)
235 PROCEDURE SetUndef (VAR i: Item);
236 BEGIN
237 i.typ := undef; i.obj := undef; i.vis := undef;
238 i.adr := undef; i.mod := NIL; i.desc := NIL; i.ptr := NIL; i.ext := NIL;
239 END SetUndef;
241 PROCEDURE SetItem (VAR i: Item; obj: Kernel.Object; mod: Kernel.Module);
242 VAR t: Kernel.Type;
243 BEGIN
244 i.obj := obj.id MOD 16;
245 i.vis := obj.id DIV 16 MOD 16;
246 IF i.obj = procObj THEN
247 i.typ := undef; i.desc := SYSTEM.VAL(Kernel.Type, obj.struct);
248 i.adr := mod.procBase + obj.offs; i.mod := mod
249 ELSE
250 i.typ := TypOf(obj.struct); i.desc := obj.struct;
251 IF i.obj = varObj THEN i.adr := mod.varBase + obj.offs; i.mod := mod
252 ELSIF i.obj = fieldObj THEN i.adr := obj.offs; i.mod := NIL
253 ELSE i.adr := undef; i.mod := NIL
254 END
255 END;
256 i.ext := NIL
257 END SetItem;
259 PROCEDURE SetMod (VAR i: Item; mod: Kernel.Module);
260 BEGIN
261 i.obj := modObj; i.typ := undef; i.vis := undef;
262 i.adr := undef; i.mod := mod; i.desc := NIL; i.ptr := dummy; i.ext := NIL
263 END SetMod;
266 PROCEDURE GetItem* (obj: ANYPTR; OUT i: Item);
267 BEGIN
268 ASSERT(obj # NIL, 28);
269 i.obj := varObj; i.typ := recTyp; i.vis := exported;
270 i.adr := SYSTEM.ADR(obj^); i.ptr := SYSTEM.VAL(ArrayPtr, obj);
271 i.mod := NIL; i.desc := Kernel.TypeOf(obj); i.ext := NIL
272 END GetItem;
274 PROCEDURE Lookup* (IN name: ARRAY OF CHAR; OUT mod: Item);
275 VAR m: Kernel.Module; done: BOOLEAN; filter: FilterHook;
276 BEGIN
277 done := FALSE; filter := filterHook;
278 WHILE ~done & (filter # NIL) DO filter.filter(name, mod, done); filter := filter.next END;
279 IF ~done & LegalName(name) THEN
280 m := Kernel.ThisMod(name);
281 IF m # NIL THEN SetMod(mod, m)
282 ELSE SetUndef(mod)
283 END
284 ELSE SetUndef(mod)
285 END
286 END Lookup;
288 PROCEDURE (VAR in: Item) Lookup* (IN name: ARRAY OF CHAR; VAR i: Item), NEW;
289 VAR obj: Kernel.Object; o, v, lev, j, a: INTEGER; m: Kernel.Module; n: Kernel.Name;
290 BEGIN
291 IF in.ext # NIL THEN in.ext.Lookup(name, i); RETURN END;
292 ASSERT(in.ptr # NIL, 20);
293 IF LegalName(name) THEN
294 IF in.obj = modObj THEN
295 n := SHORT(name$);
296 obj := Kernel.ThisObject(in.mod, n);
297 IF obj # NIL THEN
298 SetItem(i, obj, in.mod); i.ptr := dummy;
299 IF (i.vis = hidden) OR (i.obj < typObj) THEN SetUndef(i) END
300 ELSE SetUndef(i)
301 END
302 ELSIF in.typ = recTyp THEN
303 ASSERT(in.desc.mod.refcnt >= 0, 24);
304 lev := in.desc.id DIV 16 MOD 16; j := 0;
305 n := SHORT(name$);
306 REPEAT
307 obj := Kernel.ThisField(in.desc.base[j], n); INC(j)
308 UNTIL (obj # NIL) OR (j > lev);
309 IF obj # NIL THEN
310 o := in.obj; a := in.adr; v := in.vis; m := in.mod;
311 SetItem(i, obj, m); i.ptr := in.ptr;
312 IF i.vis # hidden THEN
313 IF o = varObj THEN
314 i.obj := varObj; INC(i.adr, a); i.mod := m;
315 IF v < i.vis THEN i.vis := v END
316 END
317 ELSE SetUndef(i)
318 END
319 ELSE SetUndef(i)
320 END
321 ELSE HALT(21)
322 END
323 ELSE SetUndef(i)
324 END
325 END Lookup;
327 PROCEDURE (VAR i: Item) GetBaseType* (VAR base: Item), NEW;
328 VAR n: INTEGER;
329 BEGIN
330 ASSERT(i.ext = NIL, 31);
331 ASSERT(i.ptr # NIL, 20);
332 ASSERT(i.typ IN {arrTyp, recTyp, ptrTyp}, 21); n := 0;
333 IF i.typ = recTyp THEN n := i.desc.id DIV 16 MOD 16 - 1 END;
334 IF n >= 0 THEN
335 base.obj := typObj; base.vis := undef; base.adr := undef;
336 base.mod := NIL; base.ptr := dummy; base.ext := NIL;
337 base.desc := i.desc.base[n];
338 base.typ := TypOf(base.desc)
339 ELSE
340 SetUndef(base)
341 END
342 END GetBaseType;
344 PROCEDURE (VAR rec: Item) GetThisBaseType* (level: INTEGER; VAR base: Item), NEW;
345 BEGIN
346 ASSERT(rec.ext = NIL, 31);
347 ASSERT(rec.ptr # NIL, 20);
348 ASSERT(rec.typ = recTyp, 21);
349 ASSERT((level >= 0) & (level < 16), 28);
350 IF level <= rec.desc.id DIV 16 MOD 16 THEN
351 base.obj := typObj; base.vis := undef; base.adr := undef;
352 base.mod := NIL; base.ptr := dummy; base.ext := NIL;
353 base.desc := rec.desc.base[level];
354 base.typ := TypOf(base.desc)
355 ELSE
356 SetUndef(base)
357 END
358 END GetThisBaseType;
360 PROCEDURE (VAR proc: Item) NumParam* (): INTEGER, NEW;
361 VAR sig: Kernel.Signature;
362 BEGIN
363 ASSERT(proc.ext = NIL, 31);
364 ASSERT(proc.ptr # NIL, 20);
365 ASSERT((proc.obj = procObj) OR (proc.typ = procTyp), 21);
366 sig := SignatureOf(proc);
367 IF sig # NIL THEN RETURN sig.num ELSE RETURN -1 END
368 END NumParam;
370 PROCEDURE (VAR proc: Item) GetParam* (n: INTEGER; VAR par: Item), NEW;
371 VAR sig: Kernel.Signature;
372 BEGIN
373 ASSERT(proc.ext = NIL, 31);
374 ASSERT(proc.ptr # NIL, 20);
375 ASSERT((proc.obj = procObj) OR (proc.typ = procTyp), 21);
376 sig := SignatureOf(proc);
377 IF (sig # NIL) & (n >= 0) & (n < sig.num) THEN
378 par.obj := parObj; par.adr := n;
379 par.vis := sig.par[n].id MOD 16;
380 par.mod := NIL; par.ptr := dummy; par.ext := NIL;
381 par.desc := sig.par[n].struct; par.typ := TypOf(par.desc)
382 ELSE
383 SetUndef(par)
384 END
385 END GetParam;
387 PROCEDURE (VAR proc: Item) GetParamName* (n: INTEGER; OUT name: Name), NEW;
388 VAR sig: Kernel.Signature; mod: Kernel.Module; nm: Kernel.Name;
389 BEGIN
390 ASSERT(proc.ext = NIL, 31);
391 ASSERT(proc.ptr # NIL, 20);
392 IF proc.obj = procObj THEN mod := proc.mod
393 ELSE ASSERT(proc.typ = procTyp, 21); mod := proc.desc.mod
394 END;
395 ASSERT(mod.refcnt >= 0, 23);
396 sig := SignatureOf(proc);
397 IF (sig # NIL) & (n >= 0) & (n < sig.num) THEN
398 Kernel.GetObjName(mod, SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(sig.par[n]) - 8), nm);
399 name := nm$
400 ELSE
401 name := ""
402 END
403 END GetParamName;
405 PROCEDURE (VAR proc: Item) GetReturnType* (VAR type: Item), NEW;
406 VAR sig: Kernel.Signature;
407 BEGIN
408 ASSERT(proc.ext = NIL, 31);
409 ASSERT(proc.ptr # NIL, 20);
410 ASSERT((proc.obj = procObj) OR (proc.typ = procTyp), 21);
411 sig := SignatureOf(proc);
412 IF sig # NIL THEN
413 type.obj := typObj; type.vis := undef; type.adr := undef;
414 type.mod := NIL; type.ptr := dummy; type.ext := NIL;
415 type.desc := sig.retStruct; type.typ := TypOf(type.desc)
416 ELSE
417 SetUndef(type)
418 END
419 END GetReturnType;
421 PROCEDURE (VAR rec: Item) Is* (IN type: Value): BOOLEAN, NEW;
422 VAR d: Kernel.Type;
423 BEGIN
424 ASSERT(rec.ext = NIL, 31);
425 ASSERT(rec.ptr # NIL, 20);
426 ASSERT(rec.typ = recTyp, 21);
427 WITH type: Item DO
428 ASSERT(type.ptr # NIL, 20);
429 ASSERT(type.typ = recTyp, 21);
430 d := type.desc
431 ELSE
432 d := DescOf(type); (* type of value rec *)
433 ASSERT(d.id DIV 16 MOD 16 = 1, 25); (* level of type = 1*)
434 ASSERT(d.fields.num = 1, 26); (* one field in type *)
435 d := d.fields.obj[0].struct; (* type of field *)
436 ASSERT(SYSTEM.VAL(INTEGER, d) DIV 256 # 0, 21); (* type is structured *)
437 IF d.id MOD 4 = 3 THEN d := d.base[0] END (* deref ptr *)
438 END;
439 RETURN rec.desc.base[d.id DIV 16 MOD 16] = d (* rec IS d *)
440 END Is;
442 PROCEDURE (VAR ptr: Item) Deref* (VAR ref: Item), NEW;
443 BEGIN
444 IF ptr.ext # NIL THEN ptr.ext.Deref(ref); RETURN END;
445 ASSERT(ptr.ptr # NIL, 20);
446 ASSERT(ptr.typ IN {sysPtrTyp, anyPtrTyp, ptrTyp}, 21);
447 ASSERT(ptr.obj = varObj, 22);
448 ASSERT((ptr.mod = NIL) OR (ptr.mod.refcnt >= 0), 23);
449 SYSTEM.GET(ptr.adr, ref.adr);
450 IF ref.adr # 0 THEN
451 IF ptr.typ # ptrTyp THEN ref.typ := recTyp
452 ELSE ref.desc := ptr.desc.base[0]; ref.typ := TypOf(ref.desc)
453 END;
454 ref.obj := varObj; ref.mod := NIL; ref.vis := exported; (* !!! *)
455 ref.ptr := SYSTEM.VAL(ArrayPtr, ref.adr);
456 IF ref.typ = recTyp THEN
457 ref.desc := DescOf(ref.ptr^); (* dynamic type *)
458 ELSIF ref.typ = arrTyp THEN
459 ref.adr := SYSTEM.ADR(ref.ptr.len[ref.desc.id DIV 16 MOD 16]); (* descriptor offset *)
460 ELSE HALT(100)
461 END
462 ELSE SetUndef(ref)
463 END
464 END Deref;
466 PROCEDURE (VAR arr: Item) Index* (index: INTEGER; VAR elem: Item), NEW;
467 BEGIN
468 IF arr.ext # NIL THEN arr.ext.Index(index, elem); RETURN END;
469 ASSERT(arr.ptr # NIL, 20);
470 ASSERT(arr.typ = arrTyp, 21);
471 ASSERT(arr.obj = varObj, 22);
472 IF (index >= 0) & (index < LenOf(arr)) THEN
473 elem.obj := varObj; elem.vis := arr.vis;
474 elem.mod := arr.mod; elem.ptr := arr.ptr; elem.ext := NIL;
475 elem.desc := arr.desc.base[0]; elem.typ := TypOf(elem.desc);
476 elem.adr := arr.adr + index * SizeOf(elem)
477 ELSE
478 SetUndef(elem)
479 END
480 END Index;
482 PROCEDURE LookupPath* (IN path: ARRAY OF CHAR; OUT i: Item);
483 VAR j, n: INTEGER; name: Name; ch: CHAR; done: BOOLEAN; filter: FilterHook;
484 BEGIN
485 done := FALSE; filter := filterHook;
486 WHILE ~done & (filter # NIL) DO filter.filter(path, i, done); filter := filter.next END;
487 IF ~done THEN
488 j := 0;
489 GetName(path, name, j);
490 Lookup(name, i);
491 IF (i.obj = modObj) & (path[j] = ".") THEN
492 INC(j); GetName(path, name, j);
493 i.Lookup(name, i); ch := path[j]; INC(j);
494 WHILE (i.obj = varObj) & (ch # 0X) DO
495 IF i.typ = ptrTyp THEN i.Deref(i) END;
496 IF ch = "." THEN
497 GetName(path, name, j);
498 IF i.typ = recTyp THEN i.Lookup(name, i) ELSE SetUndef(i) END
499 ELSIF ch = "[" THEN
500 n := 0; ch := path[j]; INC(j);
501 WHILE (ch >= "0") & (ch <= "9") DO n := 10 * n + ORD(ch) - ORD("0"); ch := path[j]; INC(j) END;
502 IF (ch = "]") & (i.typ = arrTyp) THEN i.Index(n, i) ELSE SetUndef(i) END
503 END;
504 ch := path[j]; INC(j)
505 END
506 END
507 END
508 END LookupPath;
510 (* ---------- Scanner ---------- *)
512 PROCEDURE (VAR s: Scanner) ConnectToMods*, NEW;
513 BEGIN
514 SetUndef(s.this);
515 s.this.ptr := dummy;
516 s.mod := Kernel.modList;
517 s.mode := modScan;
518 s.eos := FALSE
519 END ConnectToMods;
521 PROCEDURE (VAR s: Scanner) ConnectTo* (IN obj: Item), NEW;
522 BEGIN
523 ASSERT(obj.ptr # NIL, 20);
524 SetUndef(s.this); s.vis := obj.vis;
525 s.this.ptr := obj.ptr; s.mod := obj.mod; s.idx := 0;
526 IF obj.obj = modObj THEN
527 ASSERT(s.mod.refcnt >= 0, 23);
528 s.mode := globScan
529 ELSIF obj.typ = recTyp THEN
530 ASSERT(obj.desc.mod.refcnt >= 0, 24);
531 s.desc := obj.desc; s.base := 0;
532 IF obj.obj = varObj THEN s.mode := recVarScan; s.adr := obj.adr
533 ELSE s.mode := recTypeScan
534 END
535 ELSE HALT(21)
536 END;
537 s.eos := FALSE
538 END ConnectTo;
540 PROCEDURE (VAR s: Scanner) Scan*, NEW;
541 VAR desc: Kernel.Type;
542 BEGIN
543 ASSERT(s.this.ptr # NIL, 20);
544 IF s.mode = modScan THEN
545 IF s.mod # NIL THEN SetMod(s.this, s.mod); s.mod := s.mod.next
546 ELSE SetUndef(s.this); s.eos := TRUE
547 END
548 ELSIF s.mode = globScan THEN
549 ASSERT(s.mod.refcnt >= 0, 23);
550 REPEAT
551 IF s.idx >= s.mod.export.num THEN SetUndef(s.this); s.eos := TRUE; RETURN END;
552 s.obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(s.mod.export.obj[s.idx]));
553 SetItem(s.this, s.obj, s.mod); INC(s.idx)
554 UNTIL (s.this.obj IN {procObj, varObj, typObj}) & (s.this.vis # hidden)
555 ELSE
556 ASSERT(s.desc.mod.refcnt >= 0, 24);
557 desc := s.desc.base[s.base];
558 REPEAT
559 WHILE s.idx >= desc.fields.num DO
560 IF desc = s.desc THEN SetUndef(s.this); s.eos := TRUE; RETURN END;
561 INC(s.base); desc := s.desc.base[s.base]; s.idx := 0
562 END;
563 s.obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(desc.fields.obj[s.idx]));
564 SetItem(s.this, s.obj, s.mod); INC(s.idx)
565 UNTIL s.this.vis # hidden;
566 IF s.mode = recVarScan THEN
567 s.this.obj := varObj; INC(s.this.adr, s.adr); s.this.mod := s.mod;
568 IF s.vis < s.this.vis THEN s.this.vis := s.vis END
569 END
570 END
571 END Scan;
573 PROCEDURE (VAR s: Scanner) GetObjName* (OUT name: Name), NEW;
574 VAR mod: Kernel.Module; n: Kernel.Name;
575 BEGIN
576 ASSERT(s.this.ptr # NIL, 20);
577 IF s.mode = modScan THEN
578 name := s.this.mod.name$ (* mf 24.08.2004 *)
579 ELSE
580 IF s.mode = globScan THEN mod := s.mod
581 ELSE mod := s.desc.base[s.base].mod
582 END;
583 ASSERT(mod.refcnt >= 0, 23);
584 Kernel.GetObjName(mod, s.obj, n);
585 name := n$;
586 END
587 END GetObjName;
589 PROCEDURE (VAR s: Scanner) Level* (): INTEGER, NEW;
590 BEGIN
591 ASSERT(s.this.ptr # NIL, 20);
592 ASSERT(s.mode >= recVarScan, 22);
593 RETURN s.base
594 END Level;
596 (* ---------- access to item values ---------- *)
598 PROCEDURE ValToItem (IN x: Value; VAR i: Item);
599 VAR desc: Kernel.Type;
600 BEGIN
601 desc := DescOf(x);
602 ASSERT(desc.id DIV 16 MOD 16 = 1, 25); (* level of x = 1*)
603 ASSERT(desc.fields.num = 1, 26); (* one field in x *)
604 i.desc := desc.fields.obj[0].struct;
605 i.typ := TypOf(i.desc); i.obj := varObj; i.ext := NIL; i.vis := exported;
606 i.ptr := dummy; i.adr := SYSTEM.ADR(x)
607 END ValToItem;
609 PROCEDURE^ EqualSignature (a, b: Kernel.Signature): BOOLEAN;
611 PROCEDURE EqualType (a, b: Kernel.Type): BOOLEAN;
612 BEGIN
613 LOOP
614 IF a = b THEN RETURN TRUE END;
615 IF (SYSTEM.VAL(INTEGER, a) DIV 256 = 0)
616 OR (SYSTEM.VAL(INTEGER, b) DIV 256 = 0)
617 OR (a.id MOD 4 # b.id MOD 4) THEN RETURN FALSE END;
618 CASE a.id MOD 4 OF
619 | recTyp - 16: RETURN FALSE
620 | arrTyp - 16: IF (a.size # 0) OR (b.size # 0) THEN RETURN FALSE END
621 | procTyp - 16: RETURN EqualSignature(SYSTEM.VAL(Kernel.Signature, a.base[0]),
622 SYSTEM.VAL(Kernel.Signature, b.base[0]))
623 ELSE (* ptrTyp *)
624 END;
625 a := a.base[0]; b := b.base[0]
626 END
627 END EqualType;
629 PROCEDURE EqualSignature (a, b: Kernel.Signature): BOOLEAN;
630 VAR i: INTEGER;
631 BEGIN
632 IF (a.num # b.num) OR ~EqualType(a.retStruct, b.retStruct) THEN RETURN FALSE END;
633 i := 0;
634 WHILE i < a.num DO
635 IF (a.par[i].id MOD 256 # b.par[i].id MOD 256)
636 OR ~EqualType(a.par[i].struct, b.par[i].struct) THEN RETURN FALSE END;
637 INC(i)
638 END;
639 RETURN TRUE
640 END EqualSignature;
642 PROCEDURE Copy (IN a, b: Item; OUT ok: BOOLEAN); (* b := a *)
643 VAR n: INTEGER; at, bt: Item;
644 BEGIN
645 ok := FALSE;
646 IF a.obj = procObj THEN
647 IF (b.typ # procTyp)
648 OR ~EqualSignature(SignatureOf(a), SignatureOf(b)) THEN RETURN END;
649 SYSTEM.PUT(b.adr, a.adr);
650 ELSE (* a.obj = varObj *)
651 IF a.typ # b.typ THEN RETURN END;
652 IF a.typ >= recTyp THEN
653 IF a.typ = ptrTyp THEN
654 at.desc := a.desc.base[0]; at.typ := TypOf(at.desc); at.ptr := dummy; at.ext := NIL;
655 bt.desc := b.desc.base[0]; bt.typ := TypOf(bt.desc); bt.ptr := dummy; bt.ext := NIL;
656 SYSTEM.GET(a.adr, n);
657 IF (at.typ = recTyp) & (n # 0) THEN
658 SYSTEM.GET(SYSTEM.VAL(INTEGER, n) - 4, at.desc); (* dynamic type *)
659 at.desc := at.desc.base[bt.desc.id DIV 16 MOD 16] (* projection to b *)
660 END
661 ELSE at := a; bt := b
662 END;
663 WHILE (at.typ = arrTyp) & (bt.typ = arrTyp) DO
664 IF LenOf(at) # LenOf(bt) THEN RETURN END;
665 at.desc := at.desc.base[0]; at.typ := TypOf(at.desc);
666 bt.desc := bt.desc.base[0]; bt.typ := TypOf(bt.desc)
667 END;
668 IF (at.desc # bt.desc) &
669 ~((at.typ = procTyp) & (bt.typ = procTyp)
670 & EqualSignature(SignatureOf(at), SignatureOf(bt))) THEN RETURN END
671 END;
672 SYSTEM.MOVE(a.adr, b.adr, SizeOf(b))
673 END;
674 ok := TRUE
675 END Copy;
677 PROCEDURE (VAR proc: Item) Call* (OUT ok: BOOLEAN), NEW;
678 VAR p: Kernel.Command; sig: Kernel.Signature;
679 BEGIN
680 IF proc.ext # NIL THEN proc.ext.Call(ok); RETURN END;
681 ASSERT(proc.ptr # NIL, 20);
682 IF proc.obj = procObj THEN
683 p := SYSTEM.VAL(Kernel.Command, proc.adr)
684 ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22);
685 SYSTEM.GET(proc.adr, p)
686 END;
687 ASSERT((proc.mod = NIL) OR (proc.mod.refcnt >= 0), 23);
688 sig := SignatureOf(proc);
689 IF (sig.retStruct = NIL) & (sig.num = 0) & (p # NIL) THEN p(); ok := TRUE
690 ELSE ok := FALSE
691 END
692 END Call;
694 PROCEDURE PutParam (IN par: Item; sig: Kernel.Signature; p: INTEGER;
695 VAR data: ARRAY OF INTEGER; VAR n: INTEGER;
696 OUT ok: BOOLEAN); (* check & assign a parameter *)
697 VAR mode, fTyp, aTyp, padr, i: INTEGER; fDesc, aDesc: Kernel.Type;
698 l: LONGINT; s: SHORTINT; b: BYTE;
699 BEGIN
700 ok := FALSE;
701 ASSERT(par.ext = NIL, 31);
702 ASSERT(par.ptr # NIL, 20);
703 ASSERT(par.obj = varObj, 22);
704 ASSERT((par.mod = NIL) OR (par.mod.refcnt >= 0), 23);
705 mode := sig.par[p].id MOD 16;
706 IF mode >= out THEN ASSERT(par.vis = exported, 27) END;
707 fDesc := sig.par[p].struct;
708 fTyp := TypOf(fDesc);
709 aDesc := par.desc;
710 aTyp := TypOf(aDesc);
711 padr := par.adr;
712 IF (fTyp = recTyp) OR (fTyp = anyRecTyp) THEN
713 IF (aTyp # recTyp)
714 OR (mode = value) & (aDesc # fDesc)
715 OR (fTyp = recTyp) & (aDesc.base[fDesc.id DIV 16 MOD 16] # fDesc) THEN RETURN END;
716 data[n] := padr; INC(n);
717 data[n] := SYSTEM.VAL(INTEGER, aDesc); INC(n)
718 ELSIF fTyp = arrTyp THEN
719 data[n] := padr; INC(n);
720 IF fDesc.size # 0 THEN data[n] := SizeOf(par); INC(n) END;
721 WHILE (TypOf(fDesc) = arrTyp) & (TypOf(aDesc) = arrTyp) DO
722 IF aDesc.size # 0 THEN i := aDesc.size (* actual static size *)
723 ELSE i := par.ptr.len[aDesc.id DIV 16 MOD 16 - 1] (* actual dynamic size *)
724 END;
725 IF fDesc.size = 0 THEN data[n] := i; INC(n)
726 ELSIF fDesc.size # i THEN RETURN
727 END;
728 fDesc := fDesc.base[0]; aDesc := aDesc.base[0]
729 END;
730 IF fDesc # aDesc THEN RETURN END
731 ELSIF fTyp >= anyPtrTyp THEN (* pointer *)
732 IF fTyp = ptrTyp THEN
733 fDesc := fDesc.base[0]; (* formal base type *)
734 IF (mode = value) & (TypOf(fDesc) = recTyp) THEN
735 IF (aTyp # ptrTyp) & (aTyp # anyPtrTyp) THEN RETURN END;
736 SYSTEM.GET(padr, i); SYSTEM.GET(i - 4, aDesc); (* dynamic record type *)
737 aDesc := aDesc.base[fDesc.id DIV 16 MOD 16] (* projection *)
738 ELSE
739 IF aTyp # ptrTyp THEN RETURN END;
740 aDesc := aDesc.base[0]; (* actual base type *)
741 WHILE (TypOf(fDesc) = arrTyp) & (TypOf(aDesc) = arrTyp) DO
742 IF fDesc.size # aDesc.size THEN RETURN END;
743 fDesc := fDesc.base[0]; aDesc := aDesc.base[0]
744 END
745 END;
746 IF fDesc # aDesc THEN RETURN END
747 ELSIF fTyp = anyPtrTyp THEN
748 IF (aTyp # anyPtrTyp) & ((aTyp # ptrTyp) OR (TypOf(aDesc.base[0]) # recTyp)) THEN RETURN END
749 ELSIF fTyp = procTyp THEN
750 IF (aTyp # procTyp) OR (fDesc.size # aDesc.size) THEN RETURN END (* same fingerprint *)
751 END;
752 IF mode = value THEN SYSTEM.GET(padr, data[n]); INC(n)
753 ELSE data[n] := padr; INC(n)
754 END
755 ELSE (* basic type *)
756 IF fTyp # aTyp THEN RETURN END;
757 IF mode = value THEN
758 CASE SizeOf(par) OF
759 | 1: SYSTEM.GET(padr, b); data[n] := b; INC(n)
760 | 2: SYSTEM.GET(padr, s); data[n] := s; INC(n)
761 | 4: SYSTEM.GET(padr, i); data[n] := i; INC(n)
762 | 8: SYSTEM.GET(padr, l); data[n] := SHORT(l); INC(n); data[n] := SHORT(l DIV 100000000L); INC(n)
763 END
764 ELSE (* var par *)
765 data[n] := padr; INC(n)
766 END
767 END;
768 ok := TRUE
769 END PutParam;
771 PROCEDURE GetResult (ret: LONGINT; VAR dest: Item; sig: Kernel.Signature;
772 OUT ok: BOOLEAN); (* assign return value *)
773 VAR x: Item; i: INTEGER; s: SHORTINT; b: BYTE;
774 BEGIN
775 ASSERT(dest.ext = NIL, 31);
776 ASSERT(dest.ptr # NIL, 20);
777 ASSERT(dest.obj = varObj, 22);
778 ASSERT((dest.mod = NIL) OR (dest.mod.refcnt >= 0), 23);
779 ASSERT(dest.vis = exported, 27);
780 x.desc := sig.retStruct; x.typ := TypOf(x.desc);
781 x.obj := varObj; x.ptr := dummy;
782 CASE TypOf(sig.retStruct) OF
783 | boolTyp, sCharTyp, byteTyp: b := SHORT(SHORT(SHORT(ret))); x.adr := SYSTEM.ADR(b);
784 | charTyp, sIntTyp: s := SHORT(SHORT(ret)); x.adr := SYSTEM.ADR(s);
785 | longTyp, realTyp: x.adr := SYSTEM.ADR(ret);
786 | intTyp, sRealTyp, setTyp, anyPtrTyp, procTyp, ptrTyp: i := SHORT(ret); x.adr := SYSTEM.ADR(i);
787 END;
788 Copy(x, dest, ok)
789 END GetResult;
791 PROCEDURE (VAR proc: Item) ParamCall* (IN par: ARRAY OF Item; VAR dest: Item;
792 OUT ok: BOOLEAN), NEW;
793 VAR n, p, adr, padr: INTEGER; ret: LONGINT;
794 data: ARRAY 256 OF INTEGER; sig: Kernel.Signature;
795 BEGIN
796 ok := TRUE;
797 ASSERT(proc.ext = NIL, 31);
798 ASSERT(proc.ptr # NIL, 20);
799 IF proc.obj = procObj THEN adr := proc.adr
800 ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22);
801 SYSTEM.GET(proc.adr, adr);
802 IF adr = 0 THEN ok := FALSE; RETURN END
803 END;
804 ASSERT((proc.mod = NIL) OR (proc.mod.refcnt >= 0), 23);
805 sig := SignatureOf(proc);
806 ASSERT((sig # NIL) & (LEN(par) >= sig.num), 32);
807 n := 0; p := 0;
808 WHILE ok & (p < sig.num) DO (* check & assign parameters *)
809 PutParam(par[p], sig, p, data, n, ok);
810 INC(p)
811 END;
812 IF ok THEN
813 ret := Kernel.Call(adr, sig, data, n);
814 IF sig.retStruct # NIL THEN GetResult(ret, dest, sig, ok) END
815 END
816 END ParamCall;
818 PROCEDURE (VAR proc: Item) ParamCallVal* (IN par: ARRAY OF POINTER TO Value; VAR dest: Value;
819 OUT ok: BOOLEAN), NEW;
820 TYPE IP = POINTER TO Item;
821 VAR n, p, adr, padr: INTEGER; ret: LONGINT; x: Item;
822 data: ARRAY 256 OF INTEGER; sig: Kernel.Signature;
823 BEGIN
824 ok := TRUE;
825 ASSERT(proc.ext = NIL, 31);
826 ASSERT(proc.ptr # NIL, 20);
827 IF proc.obj = procObj THEN adr := proc.adr
828 ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22);
829 SYSTEM.GET(proc.adr, adr);
830 IF adr = 0 THEN ok := FALSE; RETURN END
831 END;
832 ASSERT((proc.mod = NIL) OR (proc.mod.refcnt >= 0), 23);
833 sig := SignatureOf(proc);
834 ASSERT((sig # NIL) & (LEN(par) >= sig.num), 32);
835 n := 0; p := 0;
836 WHILE ok & (p < sig.num) DO (* check & assign parameters *)
837 IF par[p] IS IP THEN
838 PutParam(par[p](IP)^, sig, p, data, n, ok)
839 ELSE
840 ValToItem(par[p]^, x);
841 PutParam(x, sig, p, data, n, ok)
842 END;
843 INC(p)
844 END;
845 IF ok THEN
846 ret := Kernel.Call(adr, sig, data, n);
847 IF sig.retStruct # NIL THEN
848 WITH dest: Item DO
849 GetResult(ret, dest, sig, ok)
850 ELSE
851 ValToItem(dest, x);
852 GetResult(ret, x, sig, ok)
853 END
854 END
855 END
856 END ParamCallVal;
858 PROCEDURE (VAR var: Item) GetVal* (VAR x: Value; OUT ok: BOOLEAN), NEW;
859 VAR xi: Item;
860 BEGIN
861 ASSERT(var.ext = NIL, 31);
862 ASSERT(var.ptr # NIL, 20);
863 ASSERT(var.obj IN {varObj, procObj}, 22);
864 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
865 WITH x: Item DO
866 ASSERT(x.ptr # NIL, 20);
867 ASSERT(x.obj = varObj, 22);
868 ASSERT((x.mod = NIL) OR (x.mod.refcnt >= 0), 23);
869 ASSERT(x.vis = exported, 27);
870 Copy(var, x, ok)
871 ELSE
872 ValToItem(x, xi); Copy(var, xi, ok)
873 END
874 END GetVal;
876 PROCEDURE (VAR var: Item) PutVal* (IN x: Value; OUT ok: BOOLEAN), NEW;
877 VAR xi: Item;
878 BEGIN
879 ASSERT(var.ext = NIL, 31);
880 ASSERT(var.ptr # NIL, 20);
881 ASSERT(var.obj = varObj, 22);
882 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
883 ASSERT(var.vis = exported, 27);
884 WITH x: Item DO
885 ASSERT(x.ptr # NIL, 20);
886 ASSERT(x.obj IN {varObj, procObj}, 22);
887 ASSERT((x.mod = NIL) OR (x.mod.refcnt >= 0), 23);
888 Copy(x, var, ok)
889 ELSE
890 ValToItem(x, xi); Copy(xi, var, ok)
891 END
892 END PutVal;
894 PROCEDURE (VAR var: Item) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW;
895 VAR i, n: INTEGER; p: StringPtr;
896 BEGIN
897 IF var.ext # NIL THEN var.ext.GetStringVal(x, ok); RETURN END;
898 ASSERT(var.ptr # NIL, 20);
899 ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = charTyp), 21);
900 ASSERT(var.obj = varObj, 22);
901 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
902 p := SYSTEM.VAL(StringPtr, var.adr); i := 0; n := LenOf(var);
903 WHILE (i < n) & (p[i] # 0X) DO INC(i) END;
904 IF (i < n) & (i < LEN(x)) THEN x := p^$; ok := TRUE
905 ELSE x := ""; ok := FALSE
906 END
907 END GetStringVal;
909 PROCEDURE (VAR var: Item) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW;
910 VAR i, n: INTEGER; p: SStringPtr;
911 BEGIN
912 IF var.ext # NIL THEN var.ext.GetSStringVal(x, ok); RETURN END;
913 ASSERT(var.ptr # NIL, 20);
914 ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = sCharTyp), 21);
915 ASSERT(var.obj = varObj, 22);
916 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
917 p := SYSTEM.VAL(SStringPtr, var.adr); i := 0; n := LenOf(var);
918 WHILE (i < n) & (p[i] # 0X) DO INC(i) END;
919 IF (i < n) & (i < LEN(x)) THEN x := p^$; ok := TRUE
920 ELSE x := ""; ok := FALSE
921 END
922 END GetSStringVal;
924 PROCEDURE (VAR var: Item) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW;
925 VAR i: INTEGER; p: StringPtr;
926 BEGIN
927 IF var.ext # NIL THEN var.ext.PutStringVal(x, ok); RETURN END;
928 ASSERT(var.ptr # NIL, 20);
929 ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = charTyp), 21);
930 ASSERT(var.obj = varObj, 22);
931 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
932 ASSERT(var.vis = exported, 27);
933 p := SYSTEM.VAL(StringPtr, var.adr); i := 0;
934 WHILE (i < LEN(x)) & (x[i] # 0X) DO INC(i) END;
935 IF (i < LEN(x)) & (i < LenOf(var)) THEN p^ := x$; ok := TRUE
936 ELSE ok := FALSE
937 END
938 END PutStringVal;
940 PROCEDURE (VAR var: Item) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW;
941 VAR i: INTEGER; p: SStringPtr;
942 BEGIN
943 IF var.ext # NIL THEN var.ext.PutSStringVal(x, ok); RETURN END;
944 ASSERT(var.ptr # NIL, 20);
945 ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = sCharTyp), 21);
946 ASSERT(var.obj = varObj, 22);
947 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
948 ASSERT(var.vis = exported, 27);
949 p := SYSTEM.VAL(SStringPtr, var.adr); i := 0;
950 WHILE (i < LEN(x)) & (x[i] # 0X) DO INC(i) END;
951 IF (i < LEN(x)) & (i < LenOf(var)) THEN p^ := x$; ok := TRUE
952 ELSE ok := FALSE
953 END
954 END PutSStringVal;
956 PROCEDURE (VAR var: Item) PtrVal* (): ANYPTR, NEW;
957 VAR p: ANYPTR;
958 BEGIN
959 IF var.ext # NIL THEN RETURN var.ext.PtrVal() END;
960 ASSERT(var.ptr # NIL, 20);
961 ASSERT(var.typ IN {anyPtrTyp, ptrTyp}, 21);
962 ASSERT(var.obj = varObj, 22);
963 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
964 SYSTEM.GET(var.adr, p);
965 RETURN p
966 END PtrVal;
968 PROCEDURE (VAR var: Item) PutPtrVal* (x: ANYPTR), NEW;
969 VAR vt, xt: Kernel.Type;
970 BEGIN
971 IF var.ext # NIL THEN var.ext.PutPtrVal(x); RETURN END;
972 ASSERT(var.ptr # NIL, 20);
973 ASSERT(var.typ IN {anyPtrTyp, ptrTyp}, 21);
974 ASSERT(var.obj = varObj, 22);
975 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
976 ASSERT(var.vis = exported, 27);
977 IF (x # NIL) & (var.typ = ptrTyp) THEN
978 vt := var.desc.base[0]; xt := Kernel.TypeOf(x);
979 ASSERT(xt.base[vt.id DIV 16 MOD 16] = vt, 28); (* xt IS vt *)
980 END;
981 SYSTEM.PUT(var.adr, x)
982 END PutPtrVal;
984 PROCEDURE (VAR var: Item) IntVal* (): INTEGER, NEW;
985 VAR sc: SHORTCHAR; ch: CHAR; s: BYTE; i: SHORTINT; x: INTEGER;
986 BEGIN
987 IF var.ext # NIL THEN RETURN var.ext.IntVal() END;
988 ASSERT(var.ptr # NIL, 20);
989 ASSERT(var.obj = varObj, 22);
990 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
991 IF var.typ = sCharTyp THEN SYSTEM.GET(var.adr, sc); x := ORD(sc)
992 ELSIF var.typ = charTyp THEN SYSTEM.GET(var.adr, ch); x := ORD(ch)
993 ELSIF var.typ = byteTyp THEN SYSTEM.GET(var.adr, s); x := s
994 ELSIF var.typ = sIntTyp THEN SYSTEM.GET(var.adr, i); x := i
995 ELSIF var.typ = intTyp THEN SYSTEM.GET(var.adr, x)
996 ELSE HALT(21)
997 END;
998 RETURN x
999 END IntVal;
1001 PROCEDURE (VAR var: Item) PutIntVal* (x: INTEGER), NEW;
1002 BEGIN
1003 IF var.ext # NIL THEN var.ext.PutIntVal(x); RETURN END;
1004 ASSERT(var.ptr # NIL, 20);
1005 ASSERT(var.obj = varObj, 22);
1006 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1007 ASSERT(var.vis = exported, 27);
1008 IF var.typ = sCharTyp THEN SYSTEM.PUT(var.adr, SHORT(CHR(x)))
1009 ELSIF var.typ = charTyp THEN SYSTEM.PUT(var.adr, CHR(x))
1010 ELSIF var.typ = byteTyp THEN SYSTEM.PUT(var.adr, SHORT(SHORT(x)))
1011 ELSIF var.typ = sIntTyp THEN SYSTEM.PUT(var.adr, SHORT(x))
1012 ELSIF var.typ = intTyp THEN SYSTEM.PUT(var.adr, x)
1013 ELSE HALT(21)
1014 END
1015 END PutIntVal;
1017 PROCEDURE (VAR var: Item) RealVal* (): REAL, NEW;
1018 VAR r: SHORTREAL; x: REAL;
1019 BEGIN
1020 IF var.ext # NIL THEN RETURN var.ext.RealVal() END;
1021 ASSERT(var.ptr # NIL, 20);
1022 ASSERT(var.obj = varObj, 22);
1023 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1024 IF var.typ = sRealTyp THEN SYSTEM.GET(var.adr, r); x := r
1025 ELSIF var.typ = realTyp THEN SYSTEM.GET(var.adr, x)
1026 ELSE HALT(21)
1027 END;
1028 RETURN x
1029 END RealVal;
1031 PROCEDURE (VAR var: Item) PutRealVal* (x: REAL), NEW;
1032 BEGIN
1033 IF var.ext # NIL THEN var.ext.PutRealVal(x); RETURN END;
1034 ASSERT(var.ptr # NIL, 20);
1035 ASSERT(var.obj = varObj, 22);
1036 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1037 ASSERT(var.vis = exported, 27);
1038 IF var.typ = sRealTyp THEN SYSTEM.PUT(var.adr, SHORT(x))
1039 ELSIF var.typ = realTyp THEN SYSTEM.PUT(var.adr, x)
1040 ELSE HALT(21)
1041 END
1042 END PutRealVal;
1044 PROCEDURE (VAR var: Item) LongVal* (): LONGINT, NEW;
1045 VAR x: LONGINT;
1046 BEGIN
1047 IF var.ext # NIL THEN RETURN var.ext.LongVal() END;
1048 ASSERT(var.ptr # NIL, 20);
1049 ASSERT(var.typ = longTyp, 21);
1050 ASSERT(var.obj = varObj, 22);
1051 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1052 SYSTEM.GET(var.adr, x);
1053 RETURN x
1054 END LongVal;
1056 PROCEDURE (VAR var: Item) PutLongVal* (x: LONGINT), NEW;
1057 BEGIN
1058 IF var.ext # NIL THEN var.ext.PutLongVal(x); RETURN END;
1059 ASSERT(var.ptr # NIL, 20);
1060 ASSERT(var.typ = longTyp, 21);
1061 ASSERT(var.obj = varObj, 22);
1062 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1063 ASSERT(var.vis = exported, 27);
1064 SYSTEM.PUT(var.adr, x)
1065 END PutLongVal;
1067 PROCEDURE (VAR var: Item) CharVal* (): CHAR, NEW;
1068 VAR x: CHAR; s: SHORTCHAR;
1069 BEGIN
1070 IF var.ext # NIL THEN RETURN var.ext.CharVal() END;
1071 ASSERT(var.ptr # NIL, 20);
1072 ASSERT(var.obj = varObj, 22);
1073 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1074 IF var.typ = sCharTyp THEN SYSTEM.GET(var.adr, s); x := s
1075 ELSIF var.typ = charTyp THEN SYSTEM.GET(var.adr, x)
1076 ELSE HALT(21)
1077 END;
1078 RETURN x
1079 END CharVal;
1081 PROCEDURE (VAR var: Item) PutCharVal* (x: CHAR), NEW;
1082 BEGIN
1083 IF var.ext # NIL THEN var.ext.PutCharVal(x); RETURN END;
1084 ASSERT(var.ptr # NIL, 20);
1085 ASSERT(var.obj = varObj, 22);
1086 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1087 ASSERT(var.vis = exported, 27);
1088 IF var.typ = sCharTyp THEN SYSTEM.PUT(var.adr, SHORT(x))
1089 ELSIF var.typ = charTyp THEN SYSTEM.PUT(var.adr, x)
1090 ELSE HALT(21)
1091 END
1092 END PutCharVal;
1094 PROCEDURE (VAR var: Item) BoolVal* (): BOOLEAN, NEW;
1095 VAR x: BOOLEAN;
1096 BEGIN
1097 IF var.ext # NIL THEN RETURN var.ext.BoolVal() END;
1098 ASSERT(var.ptr # NIL, 20);
1099 ASSERT(var.typ = boolTyp, 21);
1100 ASSERT(var.obj = varObj, 22);
1101 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1102 SYSTEM.GET(var.adr, x);
1103 RETURN x
1104 END BoolVal;
1106 PROCEDURE (VAR var: Item) PutBoolVal* (x: BOOLEAN), NEW;
1107 BEGIN
1108 IF var.ext # NIL THEN var.ext.PutBoolVal(x); RETURN END;
1109 ASSERT(var.ptr # NIL, 20);
1110 ASSERT(var.typ = boolTyp, 21);
1111 ASSERT(var.obj = varObj, 22);
1112 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1113 ASSERT(var.vis = exported, 27);
1114 SYSTEM.PUT(var.adr, x)
1115 END PutBoolVal;
1117 PROCEDURE (VAR var: Item) SetVal* (): SET, NEW;
1118 VAR x: SET;
1119 BEGIN
1120 IF var.ext # NIL THEN RETURN var.ext.SetVal() END;
1121 ASSERT(var.ptr # NIL, 20);
1122 ASSERT(var.typ = setTyp, 21);
1123 ASSERT(var.obj = varObj, 22);
1124 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1125 SYSTEM.GET(var.adr, x);
1126 RETURN x
1127 END SetVal;
1129 PROCEDURE (VAR var: Item) PutSetVal* (x: SET), NEW;
1130 BEGIN
1131 IF var.ext # NIL THEN var.ext.PutSetVal(x); RETURN END;
1132 ASSERT(var.ptr # NIL, 20);
1133 ASSERT(var.typ = setTyp, 21);
1134 ASSERT(var.obj = varObj, 22);
1135 ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
1136 ASSERT(var.vis = exported, 27);
1137 SYSTEM.PUT(var.adr, x)
1138 END PutSetVal;
1140 PROCEDURE (VAR type: Item) New* (): ANYPTR, NEW;
1141 VAR p: ANYPTR; i, n, id: INTEGER; d: Kernel.Directory; desc: Kernel.Type;
1142 BEGIN
1143 ASSERT(type.ext = NIL, 31);
1144 ASSERT(type.ptr # NIL, 20);
1145 desc := type.desc;
1146 IF type.typ = ptrTyp THEN desc := desc.base[0] END;
1147 ASSERT(TypOf(desc) = recTyp, 21);
1148 ASSERT(desc.mod.refcnt >= 0, 24);
1149 i := 0; d := type.desc.mod.export; n := d.num; id := type.desc.id DIV 256;
1150 WHILE (i < n) & (d.obj[i].id DIV 256 # id) DO INC(i) END;
1151 ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29);
1152 ASSERT(desc.id DIV 4 MOD 4 < limited, 30);
1153 Kernel.NewObj(p, desc);
1154 RETURN p
1155 END New;
1157 PROCEDURE (VAR val: Item) Copy* (): ANYPTR, NEW;
1158 VAR p: ANYPTR; i, n, id: INTEGER; d: Kernel.Directory;
1159 BEGIN
1160 ASSERT(val.ext = NIL, 31);
1161 ASSERT(val.ptr # NIL, 20);
1162 ASSERT(val.typ = recTyp, 21);
1163 ASSERT(val.obj = varObj, 22);
1164 ASSERT(val.desc.mod.refcnt >= 0, 24);
1165 i := 0; d := val.desc.mod.export; n := d.num; id := val.desc.id DIV 256;
1166 WHILE (i < n) & (d.obj[i].id DIV 256 # id) DO INC(i) END;
1167 ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29);
1168 ASSERT(val.desc.id DIV 4 MOD 4 < limited, 30);
1169 Kernel.NewObj(p, val.desc);
1170 SYSTEM.MOVE(val.adr, p, val.desc.size);
1171 RETURN p
1172 END Copy;
1174 PROCEDURE (VAR rec: Item) CallWith* (proc: PROCEDURE(VAR rec, par: ANYREC); VAR par: ANYREC), NEW;
1175 BEGIN
1176 ASSERT(rec.ext = NIL, 31);
1177 ASSERT(rec.ptr # NIL, 20);
1178 ASSERT(rec.typ = recTyp, 21);
1179 ASSERT(rec.obj = varObj, 22);
1180 ASSERT((rec.mod = NIL) OR (rec.mod.refcnt >= 0), 23);
1181 proc(SYSTEM.THISRECORD(rec.adr, SYSTEM.VAL(INTEGER, rec.desc)), par)
1182 END CallWith;
1185 PROCEDURE InstallFilter* (filter: LookupFilter);
1186 VAR h: FilterHook;
1187 BEGIN
1188 ASSERT(filter # NIL, 20);
1189 NEW(h); h.filter := filter; h.next := filterHook; filterHook := h
1190 END InstallFilter;
1192 PROCEDURE UninstallFilter* (filter: LookupFilter);
1193 VAR h, a: FilterHook;
1194 BEGIN
1195 ASSERT(filter # NIL, 20);
1196 h := filterHook; a := NIL;
1197 WHILE (h # NIL) & (h.filter # filter) DO a := h; h := h.next END;
1198 IF h # NIL THEN
1199 IF a = NIL THEN filterHook := h.next ELSE a.next := h.next END
1200 END
1201 END UninstallFilter;
1203 PROCEDURE GetThisItem* (IN attr: ANYREC; OUT i: Item);
1204 BEGIN
1205 WITH attr: Kernel.ItemAttr DO
1206 i.obj := attr.obj; i.vis := attr.vis; i.typ := attr.typ; i.adr := attr.adr;
1207 i.mod := attr.mod; i.desc := attr.desc; i.ptr := attr.ptr; i.ext := attr.ext;
1208 IF i.ptr = NIL THEN i.ptr := dummy END
1209 END
1210 END GetThisItem;
1212 BEGIN
1213 NEW(dummy)
1214 END Meta.