1 MODULE Stores;
3 (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Stores.odc *)
4 (* DO NOT EDIT *)
6 IMPORT SYSTEM, Kernel, Dialog, Strings, Files;
8 CONST
9 (** Alien.cause, Reader.TurnIntoAlien cause - flagged by internalization procs **)
10 alienVersion* = 1; alienComponent* = 2;
11 (** Alien.cause - internally detected **)
12 inconsistentVersion* = -1; inconsistentType* = -2;
13 moduleFileNotFound* = -3; invalidModuleFile* = -4;
14 inconsModuleVersion* = -5; typeNotFound* = -6;
16 dictLineLen = 32; (* length of type & elem dict lines *)
18 newBase = 0F0X; (* new base type (level = 0), i.e. not yet in dict *)
19 newExt = 0F1X; (* new extension type (level = 1), i.e. not yet in dict *)
20 oldType = 0F2X; (* old type, i.e. already in dict *)
22 nil = 080X; (* nil store *)
23 link = 081X; (* link to another elem in same file *)
24 store = 082X; (* general store *)
25 elem = 083X; (* elem store *)
26 newlink = 084X; (* link to another non-elem store in same file *)
28 minVersion = 0; maxStoreVersion = 0;
30 elemTName = "Stores.ElemDesc"; (* type of pre-1.3 elems *)
31 modelTName = "Models.ModelDesc"; (* the only known family of pre-1.3 elems *)
33 inited = TRUE; anonymousDomain = FALSE; (* values to be used when calling NewDomain *)
35 compatible = TRUE;
38 TYPE
39 TypeName* = ARRAY 64 OF CHAR;
40 TypePath* = ARRAY 16 OF TypeName;
41 OpName* = ARRAY 32 OF CHAR;
43 Domain* = POINTER TO LIMITED RECORD
44 sequencer: ANYPTR;
45 dlink: Domain;
46 initialized, copyDomain: BOOLEAN;
47 level, copyera, nextElemId: INTEGER;
48 sDict: StoreDict;
49 cleaner: TrapCleaner;
50 s: Store (* used for CopyOf *)
51 END;
53 Operation* = POINTER TO ABSTRACT RECORD END;
55 Store* = POINTER TO ABSTRACT RECORD
56 dlink: Domain;
57 era, id: INTEGER; (* externalization era and id *)
58 isElem: BOOLEAN (* to preserve file format: is this an elem in the old sense? *)
59 END;
62 AlienComp* = POINTER TO LIMITED RECORD
63 next-: AlienComp
64 END;
66 AlienPiece* = POINTER TO LIMITED RECORD (AlienComp)
67 pos-, len-: INTEGER
68 END;
70 AlienPart* = POINTER TO LIMITED RECORD (AlienComp)
71 store-: Store
72 END;
74 Alien* = POINTER TO LIMITED RECORD (Store)
75 path-: TypePath; (** the type this store would have if it were not an alien **)
76 cause-: INTEGER; (** # 0, the cause that turned this store into an alien **)
77 file-: Files.File; (** base file holding alien pieces **)
78 comps-: AlienComp (** the constituent components of this alien store **)
79 END;
81 ReaderState = RECORD
82 next: INTEGER; (* position of next store in current level *)
83 end: INTEGER (* position just after last read store *)
84 END;
86 WriterState = RECORD
87 linkpos: INTEGER (* address of threading link *)
88 END;
90 TypeDict = POINTER TO RECORD
91 next: TypeDict;
92 org: INTEGER; (* origin id of this dict line *)
93 type: ARRAY dictLineLen OF TypeName; (* type[org] .. type[org + dictLineLen - 1] *)
94 baseId: ARRAY dictLineLen OF INTEGER
95 END;
97 StoreDict = POINTER TO RECORD
98 next: StoreDict;
99 org: INTEGER; (* origin id of this dict line *)
100 elem: ARRAY dictLineLen OF Store (* elem[org] .. elem[org + dictLineLen - 1] *)
101 END;
103 Reader* = RECORD
104 rider-: Files.Reader;
105 cancelled-: BOOLEAN; (** current Internalize has been cancelled **)
106 readAlien-: BOOLEAN; (** at least one alien read since ConnectTo **)
107 cause: INTEGER;
108 nextTypeId, nextElemId, nextStoreId: INTEGER; (* next id of non-dict type, "elem", store *)
109 tDict, tHead: TypeDict; (* mapping (id <-> type) - self-organizing list *)
110 eDict, eHead: StoreDict; (* mapping (id -> elem) - self-organizing list *)
111 sDict, sHead: StoreDict; (* mapping (id -> store) - self-organizing list *)
112 st: ReaderState;
113 noDomain: BOOLEAN;
114 store: Store
115 END;
117 Writer* = RECORD
118 rider-: Files.Writer;
119 writtenStore-: Store;
120 era: INTEGER; (* current externalization era *)
121 noDomain: BOOLEAN; (* no domain encountered yet *)
122 modelType: Kernel.Type;
123 domain: Domain; (* domain of current era *)
124 nextTypeId, nextElemId, nextStoreId: INTEGER; (* next id of non-dict type or elem *)
125 tDict, tHead: TypeDict; (* mapping (id -> type) - self-organizing list *)
126 st: WriterState
127 END;
129 TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner)
130 d: Domain
131 END;
133 VAR
134 nextEra: INTEGER; (* next externalization era *)
135 thisTypeRes: INTEGER; (* side-effect res code of ThisType *)
136 logReports: BOOLEAN;
139 (** Cleaner **)
141 PROCEDURE (c: TrapCleaner) Cleanup;
142 BEGIN
143 c.d.level := 0;
144 c.d.sDict := NIL;
145 c.d.s := NIL
146 END Cleanup;
148 PROCEDURE (d: Domain) SetSequencer* (sequencer: ANYPTR), NEW;
149 BEGIN
150 ASSERT(d.sequencer = NIL);
151 d.sequencer := sequencer
152 END SetSequencer;
154 PROCEDURE (d: Domain) GetSequencer*(): ANYPTR, NEW;
155 BEGIN
156 RETURN d.sequencer
157 END GetSequencer;
160 PROCEDURE^ Report* (IN msg, p0, p1, p2: ARRAY OF CHAR);
162 PROCEDURE^ (VAR rd: Reader) SetPos* (pos: INTEGER), NEW;
163 PROCEDURE^ (VAR rd: Reader) ReadVersion* (min, max: INTEGER; OUT version: INTEGER), NEW;
164 PROCEDURE^ (VAR rd: Reader) ReadSChar* (OUT x: SHORTCHAR), NEW;
165 PROCEDURE^ (VAR rd: Reader) ReadInt* (OUT x: INTEGER), NEW;
166 PROCEDURE^ (VAR rd: Reader) ReadXString* (OUT x: ARRAY OF CHAR), NEW;
167 PROCEDURE^ (VAR rd: Reader) ReadStore* (OUT x: Store), NEW;
169 PROCEDURE^ (VAR wr: Writer) SetPos* (pos: INTEGER), NEW;
170 PROCEDURE^ (VAR wr: Writer) WriteVersion* (version: INTEGER), NEW;
171 PROCEDURE^ (VAR wr: Writer) WriteSChar* (x: SHORTCHAR), NEW;
172 PROCEDURE^ (VAR wr: Writer) WriteInt* (x: INTEGER), NEW;
173 PROCEDURE^ (VAR wr: Writer) WriteXString* (IN x: ARRAY OF CHAR), NEW;
174 PROCEDURE^ (VAR wr: Writer) WriteStore* (x: Store), NEW;
176 PROCEDURE^ Join* (s0, s1: Store);
179 (** Operation **)
181 PROCEDURE (op: Operation) Do* (), NEW, ABSTRACT;
184 (** Store **)
186 PROCEDURE NewDomain (initialized: BOOLEAN): Domain;
187 VAR d: Domain;
188 BEGIN
189 NEW(d); d.level := 0; d.sDict := NIL; d.cleaner := NIL;
190 d.initialized := initialized; d.copyDomain := FALSE;
191 RETURN d
192 END NewDomain;
194 PROCEDURE DomainOf (s: Store): Domain;
195 VAR d, p, q, r: Domain;
196 BEGIN
197 d := s.dlink;
198 IF (d # NIL) & (d.dlink # NIL) THEN
199 p := NIL; q := d; r := q.dlink;
200 WHILE r # NIL DO q.dlink := p; p := q; q := r; r := q.dlink END;
201 d := q;
202 WHILE p # NIL DO q := p; p := q.dlink; q.dlink := d END;
203 s.dlink := d
204 END;
205 RETURN d
206 END DomainOf;
208 PROCEDURE (s: Store) Domain*(): Domain, NEW;
209 VAR d: Domain;
210 BEGIN
211 d := DomainOf(s);
212 IF (d # NIL) & ~d.initialized THEN d := NIL END;
213 RETURN d
214 END Domain;
216 PROCEDURE (s: Store) CopyFrom- (source: Store), NEW, EMPTY;
218 PROCEDURE (s: Store) Internalize- (VAR rd: Reader), NEW, EXTENSIBLE;
219 VAR thisVersion: INTEGER;
220 BEGIN
221 rd.ReadVersion(minVersion, maxStoreVersion, thisVersion);
222 IF ~rd.cancelled & s.isElem THEN
223 rd.ReadVersion(minVersion, maxStoreVersion, thisVersion)
224 (* works since maxStoreVersion = maxElemVersion = 0 in pre-1.3 *)
225 END
226 END Internalize;
228 PROCEDURE (s: Store) ExternalizeAs- (VAR s1: Store), NEW, EMPTY;
230 PROCEDURE (s: Store) Externalize- (VAR wr: Writer), NEW, EXTENSIBLE;
231 BEGIN
232 wr.WriteVersion(maxStoreVersion);
233 IF s.isElem THEN wr.WriteVersion(maxStoreVersion) END
234 END Externalize;
237 (** Alien **)
239 PROCEDURE^ CopyOf* (s: Store): Store;
241 PROCEDURE (a: Alien) CopyFrom- (source: Store);
242 VAR s, c, cp: AlienComp; piece: AlienPiece; part: AlienPart;
243 BEGIN
244 WITH source: Alien DO
245 a.path := source.path;
246 a.cause := source.cause;
247 a.file := source.file;
248 a.comps := NIL;
249 s := source.comps; cp := NIL;
250 WHILE s # NIL DO
251 WITH s: AlienPiece DO
252 NEW(piece); c := piece;
253 piece.pos := s.pos; piece.len := s.len
254 | s: AlienPart DO
255 NEW(part); c := part;
256 IF s.store # NIL THEN part.store := CopyOf(s.store); Join(part.store, a) END
257 END;
258 IF cp # NIL THEN cp.next := c ELSE a.comps := c END;
259 cp := c;
260 s := s.next
261 END
262 END
263 END CopyFrom;
265 PROCEDURE (a: Alien) Internalize- (VAR rd: Reader);
266 BEGIN
267 HALT(100)
268 END Internalize;
270 PROCEDURE (a: Alien) Externalize- (VAR w: Writer);
271 BEGIN
272 HALT(100)
273 END Externalize;
276 (* types *)
278 PROCEDURE GetThisTypeName (t: Kernel.Type; VAR type: TypeName);
279 VAR i, j: INTEGER; ch: CHAR; name: Kernel.Name;
280 BEGIN
281 Kernel.GetTypeName(t, name); type := t.mod.name$;
282 i := 0; ch := type[0]; WHILE ch # 0X DO INC(i); ch := type[i] END;
283 type[i] := "."; INC(i);
284 j := 0; REPEAT ch := name[j]; type[i] := ch; INC(i); INC(j) UNTIL ch = 0X;
285 IF compatible THEN
286 IF type[i-2] = "^" THEN (* for backward compatibility *)
287 type[i-2] := "D"; type[i-1] := "e"; type[i] := "s"; type[i+1] := "c"; type[i+2] := 0X
288 END
289 END
290 END GetThisTypeName;
292 PROCEDURE ThisType (type: TypeName): Kernel.Type;
293 VAR m: Kernel.Module; t: Kernel.Type; i, j: INTEGER; ch: CHAR;
294 typ: Kernel.Name; mod: ARRAY 256 OF CHAR; res: INTEGER; str: ARRAY 256 OF CHAR;
295 BEGIN
296 ASSERT(type # "", 20);
297 i := 0; ch := type[0];
298 WHILE (ch # ".") & (ch # 0X) DO mod[i] := SHORT(ch); INC(i); ch := type[i] END;
299 ASSERT(ch = ".", 21);
300 mod[i] := 0X; INC(i);
301 m := Kernel.ThisMod(mod);
302 IF m # NIL THEN
303 j := 0; REPEAT ch := type[i]; typ[j] := SHORT(ch); INC(i); INC(j) UNTIL ch = 0X;
304 t := Kernel.ThisType(m, typ);
305 IF (t = NIL) & (j >= 5) THEN (* try pointer type *)
306 IF (typ[j-5] = "D") & (typ[j-4] = "e") & (typ[j-3] = "s") & (typ[j-2] = "c") THEN
307 typ[j-5] := "^"; typ[j-4] := 0X;
308 t := Kernel.ThisType(m, typ)
309 END
310 END;
311 IF t = NIL THEN thisTypeRes := typeNotFound END
312 ELSE
313 t := NIL;
314 Kernel.GetLoaderResult(res, str, str, str);
315 CASE res OF
316 | Kernel.fileNotFound: thisTypeRes := moduleFileNotFound
317 | Kernel.syntaxError: thisTypeRes := invalidModuleFile
318 | Kernel.objNotFound: thisTypeRes := inconsModuleVersion
319 | Kernel.illegalFPrint: thisTypeRes := inconsModuleVersion
320 | Kernel.cyclicImport: thisTypeRes := invalidModuleFile (* cyclic import ... *)
321 ELSE thisTypeRes := invalidModuleFile
322 END
323 END;
324 RETURN t
325 END ThisType;
327 PROCEDURE SameType (IN x, y: TypeName): BOOLEAN;
328 VAR i: INTEGER;
329 BEGIN
330 IF x = y THEN RETURN TRUE
331 ELSE
332 i := 0; WHILE x[i] = y[i] DO INC(i) END;
333 RETURN
334 (x[i] = "^") & (x[i+1] = 0X) & (y[i] = "D") & (y[i+1] = "e") & (y[i+2] = "s") & (y[i+3] = "c") & (y[i+4] = 0X)
335 OR (y[i] = "^") & (y[i+1] = 0X) & (x[i] = "D") & (x[i+1] = "e") & (x[i+2] = "s") & (x[i+3] = "c") & (x[i+4] = 0X)
336 END
337 END SameType;
339 PROCEDURE SamePath (t: Kernel.Type; VAR path: TypePath): BOOLEAN;
340 (* check whether t coincides with path *)
341 VAR tn: TypeName; i, n: INTEGER;
342 BEGIN
343 i := -1; n := Kernel.LevelOf(t);
344 REPEAT
345 GetThisTypeName(t.base[n], tn);
346 DEC(n); INC(i)
347 UNTIL (n < 0) OR ~SameType(tn, path[i]);
348 RETURN SameType(tn, path[i])
349 END SamePath;
351 PROCEDURE NewStore (t: Kernel.Type): Store;
352 VAR p: ANYPTR;
353 BEGIN
354 ASSERT(t # NIL, 20);
355 Kernel.NewObj(p, t); ASSERT(p # NIL, 100);
356 ASSERT(p IS Store, 21);
357 RETURN p(Store)
358 END NewStore;
361 (* type dictionary *)
363 PROCEDURE GetThisType (VAR d: TypeDict; id: INTEGER; VAR type: TypeName);
364 (* pre: (id, t) IN dict *)
365 VAR h, p: TypeDict; org, k: INTEGER;
366 BEGIN
367 k := id MOD dictLineLen; org := id - k;
368 h := NIL; p := d; WHILE p.org # org DO h := p; p := p.next END;
369 IF h # NIL THEN h.next := p.next; p.next := d; d := p END;
370 type := p.type[k];
371 ASSERT(type # "", 100)
372 END GetThisType;
374 PROCEDURE ThisId (VAR d: TypeDict; t: TypeName): INTEGER;
375 (* pre: t # "" *)
376 (* post: res = id if (t, id) in dict, res = -1 else *)
377 VAR h, p: TypeDict; k, id: INTEGER;
378 BEGIN
379 h := NIL; p := d; id := -1;
380 WHILE (p # NIL) & (id < 0) DO
381 k := 0; WHILE (k < dictLineLen) & (p.type[k, 0] # 0X) & (p.type[k] # t) DO INC(k) END;
382 IF (k < dictLineLen) & (p.type[k, 0] # 0X) THEN id := p.org + k
383 ELSE h := p; p := p.next
384 END
385 END;
386 IF (id >= 0) & (h # NIL) THEN h.next := p.next; p.next := d; d := p END;
387 RETURN id
388 END ThisId;
390 PROCEDURE ThisBaseId (VAR d: TypeDict; id: INTEGER): INTEGER;
391 (* post: res = id if base(t) # NIL, res = -1 if base(t) = NIL; res >= 0 => T(res) = base(t) *)
392 VAR h, p: TypeDict; k, org, baseId: INTEGER;
393 BEGIN
394 k := id MOD dictLineLen; org := id - k;
395 h := NIL; p := d; WHILE p.org # org DO h := p; p := p.next END;
396 IF h # NIL THEN h.next := p.next; p.next := d; d := p END;
397 baseId := p.baseId[k];
398 RETURN baseId
399 END ThisBaseId;
401 PROCEDURE AddType (VAR d, h: TypeDict; id: INTEGER; type: TypeName);
402 VAR k: INTEGER;
403 BEGIN
404 k := id MOD dictLineLen;
405 IF (h = NIL) OR ((k = 0) & (h.org # id)) THEN
406 NEW(h); h.org := id - k; h.next := d; d := h
407 END;
408 h.type[k] := type; h.baseId[k] := -1
409 END AddType;
411 PROCEDURE AddBaseId (h: TypeDict; id, baseId: INTEGER);
412 VAR k: INTEGER;
413 BEGIN
414 k := id MOD dictLineLen;
415 h.baseId[k] := baseId
416 END AddBaseId;
418 PROCEDURE InitTypeDict (VAR d, h: TypeDict; VAR nextID: INTEGER);
419 BEGIN
420 d := NIL; h := NIL; nextID := 0
421 END InitTypeDict;
424 (* store dictionary - used to maintain referential sharing *)
426 PROCEDURE ThisStore (VAR d: StoreDict; id: INTEGER): Store;
427 (* pre: (id, s) IN dict *)
428 VAR h, p: StoreDict; s: Store; k, org: INTEGER;
429 BEGIN
430 k := id MOD dictLineLen; org := id - k;
431 h := NIL; p := d; WHILE p.org # org DO h := p; p := p.next END;
432 IF h # NIL THEN h.next := p.next; p.next := d; d := p END;
433 s := p.elem[k];
434 ASSERT(s # NIL, 100);
435 RETURN s
436 END ThisStore;
438 PROCEDURE AddStore (VAR d, h: StoreDict; s: Store);
439 VAR k: INTEGER;
440 BEGIN
441 k := s.id MOD dictLineLen;
442 IF (h = NIL) OR ((k = 0) & (h.org # s.id)) THEN
443 NEW(h); h.org := s.id - k; h.next := d; d := h
444 END;
445 h.elem[k] := s
446 END AddStore;
448 PROCEDURE InitStoreDict (VAR d, h: StoreDict; VAR nextID: INTEGER);
449 BEGIN
450 d := NIL; h := NIL; nextID := 0
451 END InitStoreDict;
454 (* support for type mapping *)
456 PROCEDURE ReadPath (VAR rd: Reader; VAR path: TypePath);
457 VAR h: TypeDict; id, extId: INTEGER; i: INTEGER; kind: SHORTCHAR;
459 PROCEDURE AddPathComp (VAR rd: Reader);
460 BEGIN
461 IF h # NIL THEN AddBaseId(h, extId, rd.nextTypeId) END;
462 AddType(rd.tDict, rd.tHead, rd.nextTypeId, path[i]);
463 h := rd.tHead; extId := rd.nextTypeId
464 END AddPathComp;
466 BEGIN
467 h := NIL; i := 0; rd.ReadSChar(kind);
468 WHILE kind = newExt DO
469 rd.ReadXString(path[i]);
470 AddPathComp(rd); INC(rd.nextTypeId);
471 IF path[i] # elemTName THEN INC(i) END;
472 rd.ReadSChar(kind)
473 END;
474 IF kind = newBase THEN
475 rd.ReadXString(path[i]);
476 AddPathComp(rd); INC(rd.nextTypeId); INC(i)
477 ELSE
478 ASSERT(kind = oldType, 100);
479 rd.ReadInt(id);
480 IF h # NIL THEN AddBaseId(h, extId, id) END;
481 REPEAT
482 GetThisType(rd.tDict, id, path[i]); id := ThisBaseId(rd.tDict, id);
483 IF path[i] # elemTName THEN INC(i) END
484 UNTIL id = -1
485 END;
486 path[i] := ""
487 END ReadPath;
489 PROCEDURE WritePath (VAR wr: Writer; VAR path: TypePath);
490 VAR h: TypeDict; id, extId: INTEGER; i, n: INTEGER;
491 BEGIN
492 h := NIL;
493 n := 0; WHILE path[n] # "" DO INC(n) END;
494 i := 0;
495 WHILE i < n DO
496 id := ThisId(wr.tDict, path[i]);
497 IF id >= 0 THEN
498 IF h # NIL THEN AddBaseId(h, extId, id) END;
499 wr.WriteSChar(oldType); wr.WriteInt(id); n := i
500 ELSE
501 IF i + 1 < n THEN wr.WriteSChar(newExt) ELSE wr.WriteSChar(newBase) END;
502 wr.WriteXString(path[i]);
503 IF h # NIL THEN AddBaseId(h, extId, wr.nextTypeId) END;
504 AddType(wr.tDict, wr.tHead, wr.nextTypeId, path[i]);
505 h := wr.tHead; extId := wr.nextTypeId;
506 INC(wr.nextTypeId);
507 IF path[i] = modelTName THEN
508 id := ThisId(wr.tDict, elemTName); ASSERT(id < 0, 100); ASSERT(i + 2 = n, 101);
509 wr.WriteSChar(newExt); wr.WriteXString(elemTName);
510 IF h # NIL THEN AddBaseId(h, extId, wr.nextTypeId) END;
511 AddType(wr.tDict, wr.tHead, wr.nextTypeId, elemTName);
512 h := wr.tHead; extId := wr.nextTypeId;
513 INC(wr.nextTypeId)
514 END
515 END;
516 INC(i)
517 END
518 END WritePath;
520 PROCEDURE WriteType (VAR wr: Writer; t: Kernel.Type);
521 VAR path: TypePath; n, i: INTEGER;
522 BEGIN
523 i := 0; n := Kernel.LevelOf(t);
524 WHILE n >= 0 DO
525 GetThisTypeName(t.base[n], path[i]);
526 DEC(n); INC(i)
527 END;
528 path[i] := "";
529 WritePath(wr, path)
530 END WriteType;
533 (* support for alien mapping *)
535 PROCEDURE InternalizeAlien (VAR rd: Reader; VAR comps: AlienComp; down, pos, len: INTEGER);
536 VAR h, p: AlienComp; piece: AlienPiece; part: AlienPart; file: Files.File;
537 next, end, max: INTEGER;
538 BEGIN
539 file := rd.rider.Base(); max := file.Length();
540 end := pos + len; h := NIL;
541 IF down # 0 THEN next := down ELSE next := end END;
542 WHILE pos < end DO
543 ASSERT(end <= max, 100);
544 IF pos < next THEN
545 NEW(piece); piece.pos := pos; piece.len := next - pos;
546 p := piece; pos := next
547 ELSE
548 ASSERT(pos = next, 101);
549 rd.SetPos(next);
550 NEW(part); rd.ReadStore(part.store);
551 ASSERT(rd.st.end > next, 102);
552 p := part; pos := rd.st.end;
553 IF rd.st.next > 0 THEN
554 ASSERT(rd.st.next > next, 103); next := rd.st.next
555 ELSE next := end
556 END
557 END;
558 IF h = NIL THEN comps := p ELSE h.next := p END;
559 h := p
560 END;
561 ASSERT(pos = end, 104);
562 rd.SetPos(end)
563 END InternalizeAlien;
565 PROCEDURE ExternalizePiece (VAR wr: Writer; file: Files.File; p: AlienPiece);
566 VAR r: Files.Reader; w: Files.Writer; b: BYTE; l, len: INTEGER;
567 BEGIN
568 l := file.Length(); len := p.len;
569 ASSERT(0 <= p.pos, 100); ASSERT(p.pos <= l, 101);
570 ASSERT(0 <= len, 102); ASSERT(len <= l - p.pos, 103);
571 r := file.NewReader(NIL); r.SetPos(p.pos);
572 w := wr.rider;
573 WHILE len # 0 DO r.ReadByte(b); w.WriteByte(b); DEC(len) END
574 END ExternalizePiece;
576 PROCEDURE ExternalizeAlien (VAR wr: Writer; file: Files.File; comps: AlienComp);
577 VAR p: AlienComp;
578 BEGIN
579 p := comps;
580 WHILE p # NIL DO
581 WITH p: AlienPiece DO
582 ExternalizePiece(wr, file, p)
583 | p: AlienPart DO
584 wr.WriteStore(p.store)
585 END;
586 p := p.next
587 END
588 END ExternalizeAlien;
591 (** Reader **)
593 PROCEDURE (VAR rd: Reader) ConnectTo* (f: Files.File), NEW;
594 (** pre: rd.rider = NIL OR f = NIL **)
595 BEGIN
596 IF f = NIL THEN
597 rd.rider := NIL
598 ELSE
599 ASSERT(rd.rider = NIL, 20);
600 rd.rider := f.NewReader(rd.rider); rd.SetPos(0);
601 InitTypeDict(rd.tDict, rd.tHead, rd.nextTypeId);
602 InitStoreDict(rd.eDict, rd.eHead, rd.nextElemId);
603 InitStoreDict(rd.sDict, rd.sHead, rd.nextStoreId);
604 rd.noDomain := TRUE
605 END;
606 rd.readAlien := FALSE
607 END ConnectTo;
609 PROCEDURE (VAR rd: Reader) SetPos* (pos: INTEGER), NEW;
610 BEGIN
611 rd.rider.SetPos(pos)
612 END SetPos;
614 PROCEDURE (VAR rd: Reader) Pos* (): INTEGER, NEW;
615 BEGIN
616 RETURN rd.rider.Pos()
617 END Pos;
619 PROCEDURE (VAR rd: Reader) ReadBool* (OUT x: BOOLEAN), NEW;
620 VAR b: BYTE;
621 BEGIN
622 rd.rider.ReadByte(b); x := b # 0
623 END ReadBool;
625 PROCEDURE (VAR rd: Reader) ReadSChar* (OUT x: SHORTCHAR), NEW;
626 BEGIN
627 rd.rider.ReadByte(SYSTEM.VAL(BYTE, x))
628 END ReadSChar;
630 PROCEDURE (VAR rd: Reader) ReadXChar* (OUT x: CHAR), NEW;
631 VAR c: SHORTCHAR;
632 BEGIN
633 rd.rider.ReadByte(SYSTEM.VAL(BYTE,c)); x := c
634 END ReadXChar;
636 PROCEDURE (VAR rd: Reader) ReadChar* (OUT x: CHAR), NEW;
637 VAR le: ARRAY 2 OF BYTE; (* little endian, big endian *)
638 BEGIN
639 rd.rider.ReadBytes(le, 0, 2);
640 x := CHR(le[0] MOD 256 + (le[1] MOD 256) * 256)
641 END ReadChar;
643 PROCEDURE (VAR rd: Reader) ReadByte* (OUT x: BYTE), NEW;
644 BEGIN
645 rd.rider.ReadByte(x)
646 END ReadByte;
648 PROCEDURE (VAR rd: Reader) ReadSInt* (OUT x: SHORTINT), NEW;
649 VAR le, be: ARRAY 2 OF BYTE; (* little endian, big endian *)
650 BEGIN
651 rd.rider.ReadBytes(le, 0, 2);
652 IF Kernel.littleEndian THEN
653 x := SYSTEM.VAL(SHORTINT, le)
654 ELSE
655 be[0] := le[1]; be[1] := le[0];
656 x := SYSTEM.VAL(SHORTINT, be)
657 END
658 END ReadSInt;
660 PROCEDURE (VAR rd: Reader) ReadXInt* (OUT x: INTEGER), NEW;
661 VAR le, be: ARRAY 2 OF BYTE; (* little endian, big endian *)
662 BEGIN
663 rd.rider.ReadBytes(le, 0, 2);
664 IF Kernel.littleEndian THEN
665 x := SYSTEM.VAL(SHORTINT, le)
666 ELSE
667 be[0] := le[1]; be[1] := le[0];
668 x := SYSTEM.VAL(SHORTINT, be)
669 END
670 END ReadXInt;
672 PROCEDURE (VAR rd: Reader) ReadInt* (OUT x: INTEGER), NEW;
673 VAR le, be: ARRAY 4 OF BYTE; (* little endian, big endian *)
674 BEGIN
675 rd.rider.ReadBytes(le, 0, 4);
676 IF Kernel.littleEndian THEN
677 x := SYSTEM.VAL(INTEGER, le)
678 ELSE
679 be[0] := le[3]; be[1] := le[2]; be[2] := le[1]; be[3] := le[0];
680 x := SYSTEM.VAL(INTEGER, be)
681 END
682 END ReadInt;
684 PROCEDURE (VAR rd: Reader) ReadLong* (OUT x: LONGINT), NEW;
685 VAR le, be: ARRAY 8 OF BYTE; (* little endian, big endian *)
686 BEGIN
687 rd.rider.ReadBytes(le, 0, 8);
688 IF Kernel.littleEndian THEN
689 x := SYSTEM.VAL(LONGINT, le)
690 ELSE
691 be[0] := le[7]; be[1] := le[6]; be[2] := le[5]; be[3] := le[4];
692 be[4] := le[3]; be[5] := le[2]; be[6] := le[1]; be[7] := le[0];
693 x := SYSTEM.VAL(LONGINT, be)
694 END
695 END ReadLong;
697 PROCEDURE (VAR rd: Reader) ReadSReal* (OUT x: SHORTREAL), NEW;
698 VAR le, be: ARRAY 4 OF BYTE; (* little endian, big endian *)
699 BEGIN
700 rd.rider.ReadBytes(le, 0, 4);
701 IF Kernel.littleEndian THEN
702 x := SYSTEM.VAL(SHORTREAL, le)
703 ELSE
704 be[0] := le[3]; be[1] := le[2]; be[2] := le[1]; be[3] := le[0];
705 x := SYSTEM.VAL(SHORTREAL, be)
706 END
707 END ReadSReal;
709 PROCEDURE (VAR rd: Reader) ReadXReal* (OUT x: REAL), NEW;
710 VAR le, be: ARRAY 4 OF BYTE; (* little endian, big endian *)
711 BEGIN
712 rd.rider.ReadBytes(le, 0, 4);
713 IF Kernel.littleEndian THEN
714 x := SYSTEM.VAL(SHORTREAL, le)
715 ELSE
716 be[0] := le[3]; be[1] := le[2]; be[2] := le[1]; be[3] := le[0];
717 x := SYSTEM.VAL(SHORTREAL, be)
718 END
719 END ReadXReal;
721 PROCEDURE (VAR rd: Reader) ReadReal* (OUT x: REAL), NEW;
722 VAR le, be: ARRAY 8 OF BYTE; (* little endian, big endian *)
723 BEGIN
724 rd.rider.ReadBytes(le, 0, 8);
725 IF Kernel.littleEndian THEN
726 x := SYSTEM.VAL(REAL, le)
727 ELSE
728 be[0] := le[7]; be[1] := le[6]; be[2] := le[5]; be[3] := le[4];
729 be[4] := le[3]; be[5] := le[2]; be[6] := le[1]; be[7] := le[0];
730 x := SYSTEM.VAL(REAL, be)
731 END
732 END ReadReal;
734 PROCEDURE (VAR rd: Reader) ReadSet* (OUT x: SET), NEW;
735 VAR le, be: ARRAY 4 OF BYTE; (* little endian, big endian *)
736 BEGIN
737 rd.rider.ReadBytes(le, 0, 4);
738 IF Kernel.littleEndian THEN
739 x := SYSTEM.VAL(SET, le)
740 ELSE
741 be[0] := le[3]; be[1] := le[2]; be[2] := le[1]; be[3] := le[0];
742 x := SYSTEM.VAL(SET, be)
743 END
744 END ReadSet;
746 PROCEDURE (VAR rd: Reader) ReadSString* (OUT x: ARRAY OF SHORTCHAR), NEW;
747 VAR i: INTEGER; ch: SHORTCHAR;
748 BEGIN
749 i := 0; REPEAT rd.ReadSChar(ch); x[i] := ch; INC(i) UNTIL ch = 0X
750 END ReadSString;
752 PROCEDURE (VAR rd: Reader) ReadXString* (OUT x: ARRAY OF CHAR), NEW;
753 VAR i: INTEGER; ch: CHAR;
754 BEGIN
755 i := 0; REPEAT rd.ReadXChar(ch); x[i] := ch; INC(i) UNTIL ch = 0X
756 END ReadXString;
758 PROCEDURE (VAR rd: Reader) ReadString* (OUT x: ARRAY OF CHAR), NEW;
759 VAR i: INTEGER; ch: CHAR;
760 BEGIN
761 i := 0; REPEAT rd.ReadChar(ch); x[i] := ch; INC(i) UNTIL ch = 0X
762 END ReadString;
764 PROCEDURE AlienReport (cause: INTEGER);
765 VAR s, e: ARRAY 32 OF CHAR;
766 BEGIN
767 CASE cause OF
768 | alienVersion: s := "#System:AlienVersion"
769 | alienComponent: s := "#System:AlienComponent"
770 | inconsistentVersion: s := "#System:InconsistentVersion"
771 ELSE s := "#System:UnknownCause"
772 END;
773 Strings.IntToString(cause, e);
774 Report("#System:AlienCause ^0 ^1 ^2", s, e, "")
775 END AlienReport;
777 PROCEDURE AlienTypeReport (cause: INTEGER; t: ARRAY OF CHAR);
778 VAR s: ARRAY 64 OF CHAR;
779 BEGIN
780 CASE cause OF
781 | inconsistentType: s := "#System:InconsistentType ^0"
782 | moduleFileNotFound: s := "#System:CodeFileNotFound ^0"
783 | invalidModuleFile: s := "#System:InvalidCodeFile ^0"
784 | inconsModuleVersion: s := "#System:InconsistentModuleVersion ^0"
785 | typeNotFound: s := "#System:TypeNotFound ^0"
786 END;
787 Report(s, t, "", "")
788 END AlienTypeReport;
790 PROCEDURE (VAR rd: Reader) TurnIntoAlien* (cause: INTEGER), NEW;
791 BEGIN
792 ASSERT(cause > 0, 20);
793 rd.cancelled := TRUE; rd.readAlien := TRUE; rd.cause := cause;
794 AlienReport(cause)
795 END TurnIntoAlien;
797 PROCEDURE (VAR rd: Reader) ReadVersion* (min, max: INTEGER; OUT version: INTEGER), NEW;
798 VAR v: BYTE;
799 BEGIN
800 rd.ReadByte(v); version := v;
801 IF (version < min) OR (version > max) THEN
802 rd.TurnIntoAlien(alienVersion)
803 END
804 END ReadVersion;
806 PROCEDURE (VAR rd: Reader) ReadStore* (OUT x: Store), NEW;
807 VAR a: Alien; t: Kernel.Type;
808 len, pos, pos1, id, comment, next, down, downPos, nextTypeId, nextElemId, nextStoreId: INTEGER;
809 kind: SHORTCHAR; path: TypePath; type: TypeName;
810 save: ReaderState;
811 BEGIN
812 rd.ReadSChar(kind);
813 IF kind = nil THEN
814 rd.ReadInt(comment); rd.ReadInt(next);
815 rd.st.end := rd.Pos();
816 IF (next > 0) OR ((next = 0) & ODD(comment)) THEN rd.st.next := rd.st.end + next ELSE rd.st.next := 0 END;
817 x := NIL
818 ELSIF kind = link THEN
819 rd.ReadInt(id); rd.ReadInt(comment); rd.ReadInt(next);
820 rd.st.end := rd.Pos();
821 IF (next > 0) OR ((next = 0) & ODD(comment)) THEN rd.st.next := rd.st.end + next ELSE rd.st.next := 0 END;
822 x := ThisStore(rd.eDict, id)
823 ELSIF kind = newlink THEN
824 rd.ReadInt(id); rd.ReadInt(comment); rd.ReadInt(next);
825 rd.st.end := rd.Pos();
826 IF (next > 0) OR ((next = 0) & ODD(comment)) THEN rd.st.next := rd.st.end + next ELSE rd.st.next := 0 END;
827 x := ThisStore(rd.sDict, id)
828 ELSIF (kind = store) OR (kind = elem) THEN
829 IF kind = elem THEN
830 id := rd.nextElemId; INC(rd.nextElemId)
831 ELSE
832 id := rd.nextStoreId; INC(rd.nextStoreId)
833 END;
834 ReadPath(rd, path); type := path[0];
835 nextTypeId := rd.nextTypeId; nextElemId := rd.nextElemId; nextStoreId := rd.nextStoreId;
836 rd.ReadInt(comment);
837 pos1 := rd.Pos();
838 rd.ReadInt(next); rd.ReadInt(down); rd.ReadInt(len);
839 pos := rd.Pos();
840 IF next > 0 THEN rd.st.next := pos1 + next + 4 ELSE rd.st.next := 0 END;
841 IF down > 0 THEN downPos := pos1 + down + 8 ELSE downPos := 0 END;
842 rd.st.end := pos + len;
843 rd.cause := 0;
844 ASSERT(len >= 0, 101);
845 IF next # 0 THEN
846 ASSERT(rd.st.next > pos1, 102);
847 IF down # 0 THEN
848 ASSERT(downPos < rd.st.next, 103)
849 END
850 END;
851 IF down # 0 THEN
852 ASSERT(downPos > pos1, 104);
853 ASSERT(downPos < rd.st.end, 105)
854 END;
855 t := ThisType(type);
856 IF t # NIL THEN
857 x := NewStore(t); x.isElem := kind = elem
858 ELSE
859 rd.cause := thisTypeRes; AlienTypeReport(rd.cause, type);
860 x := NIL
861 END;
862 IF x # NIL THEN
863 IF SamePath(t, path) THEN
864 IF kind = elem THEN
865 x.id := id; AddStore(rd.eDict, rd.eHead, x)
866 ELSE
867 x.id := id; AddStore(rd.sDict, rd.sHead, x)
868 END;
869 save := rd.st; rd.cause := 0; rd.cancelled := FALSE;
870 x.Internalize(rd);
871 rd.st := save;
872 IF rd.cause # 0 THEN x := NIL
873 ELSIF (rd.Pos() # rd.st.end) OR rd.rider.eof THEN
874 rd.cause := inconsistentVersion; AlienReport(rd.cause);
875 x := NIL
876 END
877 ELSE
878 rd.cause := inconsistentType; AlienTypeReport(rd.cause, type);
879 x := NIL
880 END
881 END;
883 IF x # NIL THEN
884 IF rd.noDomain THEN
885 rd.store := x;
886 rd.noDomain := FALSE
887 ELSE
888 Join(rd.store, x)
889 END
890 ELSE (* x is an alien *)
891 rd.SetPos(pos);
892 ASSERT(rd.cause # 0, 107);
893 NEW(a); a.path := path; a.cause := rd.cause; a.file := rd.rider.Base();
894 IF rd.noDomain THEN
895 rd.store := a;
896 rd.noDomain := FALSE
897 ELSE
898 Join(rd.store, a)
899 END;
900 IF kind = elem THEN
901 a.id := id; AddStore(rd.eDict, rd.eHead, a)
902 ELSE
903 a.id := id; AddStore(rd.sDict, rd.sHead, a)
904 END;
905 save := rd.st;
906 rd.nextTypeId := nextTypeId; rd.nextElemId := nextElemId; rd.nextStoreId := nextStoreId;
907 InternalizeAlien(rd, a.comps, downPos, pos, len);
908 rd.st := save;
909 x := a;
910 ASSERT(rd.Pos() = rd.st.end, 108);
911 rd.cause := 0; rd.cancelled := FALSE; rd.readAlien := TRUE
912 END
913 ELSE
914 pos := rd.Pos();
915 HALT(20)
916 END
917 END ReadStore;
920 (** Writer **)
922 PROCEDURE (VAR wr: Writer) ConnectTo* (f: Files.File), NEW;
923 (** pre: wr.rider = NIL OR f = NIL **)
924 BEGIN
925 IF f = NIL THEN
926 wr.rider := NIL
927 ELSE
928 ASSERT(wr.rider = NIL, 20);
929 wr.rider := f.NewWriter(wr.rider); wr.SetPos(f.Length());
930 wr.era := nextEra; INC(nextEra);
931 wr.noDomain := TRUE;
932 wr.modelType := ThisType(modelTName);
933 InitTypeDict(wr.tDict, wr.tHead, wr.nextTypeId);
934 wr.nextElemId := 0; wr.nextStoreId := 0;
935 wr.st.linkpos := -1
936 END;
937 wr.writtenStore := NIL
938 END ConnectTo;
940 PROCEDURE (VAR wr: Writer) SetPos* (pos: INTEGER), NEW;
941 BEGIN
942 wr.rider.SetPos(pos)
943 END SetPos;
945 PROCEDURE (VAR wr: Writer) Pos* (): INTEGER, NEW;
946 BEGIN
947 RETURN wr.rider.Pos()
948 END Pos;
950 PROCEDURE (VAR wr: Writer) WriteBool* (x: BOOLEAN), NEW;
951 BEGIN
952 IF x THEN wr.rider.WriteByte(1) ELSE wr.rider.WriteByte(0) END
953 END WriteBool;
955 PROCEDURE (VAR wr: Writer) WriteSChar* (x: SHORTCHAR), NEW;
956 BEGIN
957 wr.rider.WriteByte(SYSTEM.VAL(BYTE, x))
958 END WriteSChar;
960 PROCEDURE (VAR wr: Writer) WriteXChar* (x: CHAR), NEW;
961 VAR c: SHORTCHAR;
962 BEGIN
963 c := SHORT(x); wr.rider.WriteByte(SYSTEM.VAL(BYTE, c))
964 END WriteXChar;
966 PROCEDURE (VAR wr: Writer) WriteChar* (x: CHAR), NEW;
967 TYPE a = ARRAY 2 OF BYTE;
968 VAR le, be: a; (* little endian, big endian *)
969 BEGIN
970 IF Kernel.littleEndian THEN
971 le := SYSTEM.VAL(a, x)
972 ELSE
973 be := SYSTEM.VAL(a, x);
974 le[0] := be[1]; le[1] := be[0]
975 END;
976 wr.rider.WriteBytes(le, 0, 2)
977 END WriteChar;
979 PROCEDURE (VAR wr: Writer) WriteByte* (x: BYTE), NEW;
980 BEGIN
981 wr.rider.WriteByte(x)
982 END WriteByte;
984 PROCEDURE (VAR wr: Writer) WriteSInt* (x: SHORTINT), NEW;
985 TYPE a = ARRAY 2 OF BYTE;
986 VAR le, be: a; (* little endian, big endian *)
987 BEGIN
988 IF Kernel.littleEndian THEN
989 le := SYSTEM.VAL(a, x)
990 ELSE
991 be := SYSTEM.VAL(a, x);
992 le[0] := be[1]; le[1] := be[0]
993 END;
994 wr.rider.WriteBytes(le, 0, 2)
995 END WriteSInt;
997 PROCEDURE (VAR wr: Writer) WriteXInt* (x: INTEGER), NEW;
998 TYPE a = ARRAY 2 OF BYTE;
999 VAR y: SHORTINT; le, be: a; (* little endian, big endian *)
1000 BEGIN
1001 y := SHORT(x);
1002 IF Kernel.littleEndian THEN
1003 le := SYSTEM.VAL(a, y)
1004 ELSE
1005 be := SYSTEM.VAL(a, y);
1006 le[0] := be[1]; le[1] := be[0]
1007 END;
1008 wr.rider.WriteBytes(le, 0, 2)
1009 END WriteXInt;
1011 PROCEDURE (VAR wr: Writer) WriteInt* (x: INTEGER), NEW;
1012 TYPE a = ARRAY 4 OF BYTE;
1013 VAR le, be: a; (* little endian, big endian *)
1014 BEGIN
1015 IF Kernel.littleEndian THEN
1016 le := SYSTEM.VAL(a, x)
1017 ELSE
1018 be := SYSTEM.VAL(a, x);
1019 le[0] := be[3]; le[1] := be[2]; le[2] := be[1]; le[3] := be[0]
1020 END;
1021 wr.rider.WriteBytes(le, 0, 4)
1022 END WriteInt;
1024 PROCEDURE (VAR wr: Writer) WriteLong* (x: LONGINT), NEW;
1025 TYPE a = ARRAY 8 OF BYTE;
1026 VAR le, be: a; (* little endian, big endian *)
1027 BEGIN
1028 IF Kernel.littleEndian THEN
1029 le := SYSTEM.VAL(a, x)
1030 ELSE
1031 be := SYSTEM.VAL(a, x);
1032 le[0] := be[7]; le[1] := be[6]; le[2] := be[5]; le[3] := be[4];
1033 le[4] := be[3]; le[5] := be[2]; le[6] := be[1]; le[7] := be[0]
1034 END;
1035 wr.rider.WriteBytes(le, 0, 8)
1036 END WriteLong;
1038 PROCEDURE (VAR wr: Writer) WriteSReal* (x: SHORTREAL), NEW;
1039 TYPE a = ARRAY 4 OF BYTE;
1040 VAR le, be: a; (* little endian, big endian *)
1041 BEGIN
1042 IF Kernel.littleEndian THEN
1043 le := SYSTEM.VAL(a, x)
1044 ELSE
1045 be := SYSTEM.VAL(a, x);
1046 le[0] := be[3]; le[1] := be[2]; le[2] := be[1]; le[3] := be[0]
1047 END;
1048 wr.rider.WriteBytes(le, 0, 4)
1049 END WriteSReal;
1051 PROCEDURE (VAR wr: Writer) WriteXReal* (x: REAL), NEW;
1052 TYPE a = ARRAY 4 OF BYTE;
1053 VAR y: SHORTREAL; le, be: a; (* little endian, big endian *)
1054 BEGIN
1055 y := SHORT(x);
1056 IF Kernel.littleEndian THEN
1057 le := SYSTEM.VAL(a, y)
1058 ELSE
1059 be := SYSTEM.VAL(a, y);
1060 le[0] := be[3]; le[1] := be[2]; le[2] := be[1]; le[3] := be[0]
1061 END;
1062 wr.rider.WriteBytes(le, 0, 4)
1063 END WriteXReal;
1065 PROCEDURE (VAR wr: Writer) WriteReal* (x: REAL), NEW;
1066 TYPE a = ARRAY 8 OF BYTE;
1067 VAR le, be: a; (* little endian, big endian *)
1068 BEGIN
1069 IF Kernel.littleEndian THEN
1070 le := SYSTEM.VAL(a, x)
1071 ELSE
1072 be := SYSTEM.VAL(a, x);
1073 le[0] := be[7]; le[1] := be[6]; le[2] := be[5]; le[3] := be[4];
1074 le[4] := be[3]; le[5] := be[2]; le[6] := be[1]; le[7] := be[0]
1075 END;
1076 wr.rider.WriteBytes(le, 0, 8)
1077 END WriteReal;
1079 PROCEDURE (VAR wr: Writer) WriteSet* (x: SET), NEW;
1080 (* SIZE(SET) = 4 *)
1081 TYPE a = ARRAY 4 OF BYTE;
1082 VAR le, be: a; (* little endian, big endian *)
1083 BEGIN
1084 IF Kernel.littleEndian THEN
1085 le := SYSTEM.VAL(a, x)
1086 ELSE
1087 be := SYSTEM.VAL(a, x);
1088 le[0] := be[3]; le[1] := be[2]; le[2] := be[1]; le[3] := be[0]
1089 END;
1090 wr.rider.WriteBytes(le, 0, 4)
1091 END WriteSet;
1093 PROCEDURE (VAR wr: Writer) WriteSString* (IN x: ARRAY OF SHORTCHAR), NEW;
1094 VAR i: INTEGER; ch: SHORTCHAR;
1095 BEGIN
1096 i := 0; ch := x[0]; WHILE ch # 0X DO wr.WriteSChar(ch); INC(i); ch := x[i] END;
1097 wr.WriteSChar(0X)
1098 END WriteSString;
1100 PROCEDURE (VAR wr: Writer) WriteXString* (IN x: ARRAY OF CHAR), NEW;
1101 VAR i: INTEGER; ch: CHAR;
1102 BEGIN
1103 i := 0; ch := x[0]; WHILE ch # 0X DO wr.WriteXChar(ch); INC(i); ch := x[i] END;
1104 wr.WriteSChar(0X)
1105 END WriteXString;
1107 PROCEDURE (VAR wr: Writer) WriteString* (IN x: ARRAY OF CHAR), NEW;
1108 VAR i: INTEGER; ch: CHAR;
1109 BEGIN
1110 i := 0; ch := x[0]; WHILE ch # 0X DO wr.WriteChar(ch); INC(i); ch := x[i] END;
1111 wr.WriteChar(0X)
1112 END WriteString;
1114 PROCEDURE (VAR wr: Writer) WriteVersion* (version: INTEGER), NEW;
1115 BEGIN
1116 wr.WriteByte(SHORT(SHORT(version)))
1117 END WriteVersion;
1119 PROCEDURE (VAR wr: Writer) WriteStore* (x: Store), NEW;
1120 VAR t: Kernel.Type; pos1, pos2, pos: INTEGER;
1121 save: WriterState;
1122 BEGIN
1123 ASSERT(wr.rider # NIL, 20);
1124 IF x # NIL THEN
1125 IF wr.noDomain THEN
1126 wr.domain := x.Domain(); wr.noDomain := FALSE
1127 ELSE ASSERT(x.Domain() = wr.domain, 21)
1128 END;
1129 x.ExternalizeAs(x); IF x = NIL THEN wr.writtenStore := NIL; RETURN END
1130 END;
1131 IF wr.st.linkpos > 0 THEN (* link to previous block's <next> or up block's <down> *)
1132 pos := wr.Pos();
1133 IF pos - wr.st.linkpos = 4 THEN
1134 (* hack to resolve ambiguity between next = 0 because of end-of-chain, or because of offset = 0.
1135 above guard holds only if for the latter case.
1136 ASSUMPTION:
1137 this can happen only if linkpos points to a next (not a down)
1138 and there is a comment byte just before
1139 *)
1140 wr.SetPos(wr.st.linkpos - 4); wr.WriteInt(1); wr.WriteInt(pos - wr.st.linkpos - 4)
1141 ELSE
1142 wr.SetPos(wr.st.linkpos); wr.WriteInt(pos - wr.st.linkpos - 4)
1143 END;
1144 wr.SetPos(pos)
1145 END;
1146 IF x = NIL THEN
1147 wr.WriteSChar(nil);
1148 wr.WriteInt(0); (* <comment> *)
1149 wr.st.linkpos := wr.Pos();
1150 wr.WriteInt(0) (* <next> *)
1151 ELSIF x.era >= wr.era THEN
1152 ASSERT(x.era = wr.era, 23);
1153 IF x.isElem THEN wr.WriteSChar(link) ELSE wr.WriteSChar(newlink) END;
1154 wr.WriteInt(x.id);
1155 wr.WriteInt(0); (* <comment> *)
1156 wr.st.linkpos := wr.Pos();
1157 wr.WriteInt(0) (* <next> *)
1158 ELSE
1159 x.era := wr.era;
1160 WITH x: Alien DO
1161 IF x.isElem THEN
1162 wr.WriteSChar(elem); x.id := wr.nextElemId; INC(wr.nextElemId)
1163 ELSE
1164 wr.WriteSChar(store); x.id := wr.nextStoreId; INC(wr.nextStoreId)
1165 END;
1166 WritePath(wr, x.path)
1167 ELSE
1168 t := Kernel.TypeOf(x);
1169 x.isElem := t.base[1] = wr.modelType;
1170 IF x.isElem THEN
1171 wr.WriteSChar(elem); x.id := wr.nextElemId; INC(wr.nextElemId)
1172 ELSE
1173 wr.WriteSChar(store); x.id := wr.nextStoreId; INC(wr.nextStoreId)
1174 END;
1175 WriteType(wr, t)
1176 END;
1177 wr.WriteInt(0); (* <comment> *)
1178 pos1 := wr.Pos(); wr.WriteInt(0); wr.WriteInt(0); (* <next>, <down> *)
1179 pos2 := wr.Pos(); wr.WriteInt(0); (* <len> *)
1180 save := wr.st; (* push current writer state; switch to structured *)
1181 wr.st.linkpos := pos1 + 4;
1182 WITH x: Alien DO ExternalizeAlien(wr, x.file, x.comps)
1183 ELSE
1184 x.Externalize(wr)
1185 END;
1186 wr.st := save; (* pop writer state *)
1187 wr.st.linkpos := pos1;
1188 pos := wr.Pos();
1189 wr.SetPos(pos2); wr.WriteInt(pos - pos2 - 4); (* patch <len> *)
1190 wr.SetPos(pos)
1191 END;
1192 wr.writtenStore := x
1193 END WriteStore;
1196 (** miscellaneous **)
1198 PROCEDURE Report* (IN msg, p0, p1, p2: ARRAY OF CHAR);
1199 BEGIN
1200 IF logReports THEN
1201 Dialog.ShowParamMsg(msg, p0, p1, p2)
1202 END
1203 END Report;
1205 PROCEDURE BeginCloning (d: Domain);
1206 BEGIN
1207 ASSERT(d # NIL, 20);
1208 INC(d.level);
1209 IF d.level = 1 THEN
1210 d.copyera := nextEra; INC(nextEra); d.nextElemId := 0;
1211 IF d.cleaner = NIL THEN NEW(d.cleaner); d.cleaner.d := d END;
1212 Kernel.PushTrapCleaner(d.cleaner)
1213 END
1214 END BeginCloning;
1216 PROCEDURE EndCloning (d: Domain);
1217 BEGIN
1218 ASSERT(d # NIL, 20);
1219 DEC(d.level);
1220 IF d.level = 0 THEN
1221 d.sDict := NIL;
1222 Kernel.PopTrapCleaner(d.cleaner);
1223 d.s := NIL
1224 END
1225 END EndCloning;
1227 PROCEDURE CopyOf* (s: Store): Store;
1228 VAR h: Store; c: StoreDict; d: Domain; k, org: INTEGER;
1229 BEGIN
1230 ASSERT(s # NIL, 20);
1232 d := DomainOf(s);
1233 IF d = NIL THEN d := NewDomain(anonymousDomain); s.dlink := d; d.copyDomain := TRUE END;
1235 BeginCloning(d);
1236 IF s.era >= d.copyera THEN (* s has already been copied *)
1237 ASSERT(s.era = d.copyera, 21);
1238 k := s.id MOD dictLineLen; org := s.id - k;
1239 c := d.sDict;
1240 WHILE (c # NIL) & (c.org # org) DO c := c.next END;
1241 ASSERT((c # NIL) & (c.elem[k] # NIL), 100);
1242 h := c.elem[k]
1243 ELSE
1244 s.era := d.copyera;
1245 s.id := d.nextElemId; INC(d.nextElemId);
1246 Kernel.NewObj(h, Kernel.TypeOf(s));
1247 k := s.id MOD dictLineLen;
1248 IF k = 0 THEN NEW(c); c.org := s.id; c.next := d.sDict; d.sDict := c
1249 ELSE c := d.sDict
1250 END;
1251 ASSERT((c # NIL) & (c.org = s.id - k) & (c.elem[k] = NIL), 101);
1252 c.elem[k] := h;
1253 IF d.s = NIL THEN d.s := h ELSE Join(h, d.s) END;
1254 h.CopyFrom(s)
1255 END;
1256 EndCloning(d);
1257 RETURN h
1258 END CopyOf;
1260 PROCEDURE ExternalizeProxy* (s: Store): Store;
1261 BEGIN
1262 IF s # NIL THEN s.ExternalizeAs(s) END;
1263 RETURN s
1264 END ExternalizeProxy;
1266 PROCEDURE InitDomain* (s: Store);
1267 VAR d: Domain;
1268 BEGIN
1269 ASSERT(s # NIL, 20);
1270 d := DomainOf(s);
1271 IF d = NIL THEN d := NewDomain(inited); s.dlink := d
1272 ELSE d.initialized := TRUE
1273 END
1274 END InitDomain;
1276 PROCEDURE Join* (s0, s1: Store);
1277 VAR d0, d1: Domain;
1278 BEGIN
1279 ASSERT(s0 # NIL, 20); ASSERT(s1 # NIL, 21);
1280 d0 := DomainOf(s0); d1 := DomainOf(s1);
1281 IF (d0 = NIL) & (d1 = NIL) THEN
1282 s0.dlink := NewDomain(anonymousDomain); s1.dlink := s0.dlink
1283 ELSIF d0 = NIL THEN
1284 s0.dlink := d1; d1.copyDomain := FALSE
1285 ELSIF d1 = NIL THEN
1286 s1.dlink := d0; d0.copyDomain := FALSE
1287 ELSIF d0 # d1 THEN
1288 ASSERT(~d0.initialized OR ~d1.initialized, 22);
1289 (* PRE 22 s0.Domain() = NIL OR s1.Domain() = NIL OR s0.Domain() = s1.Domain() *)
1290 IF ~d0.initialized & (d0.level = 0) THEN d0.dlink := d1; d1.copyDomain := FALSE
1291 ELSIF ~d1.initialized & (d1.level = 0) THEN d1.dlink := d0; d0.copyDomain := FALSE
1292 ELSE HALT(100)
1293 END
1294 END
1295 END Join;
1297 PROCEDURE Joined* (s0, s1: Store): BOOLEAN;
1298 VAR d0, d1: Domain;
1299 BEGIN
1300 ASSERT(s0 # NIL, 20); ASSERT(s1 # NIL, 21);
1301 d0 := DomainOf(s0); d1 := DomainOf(s1);
1302 RETURN (s0 = s1) OR ((d0 = d1) & (d0 # NIL))
1303 END Joined;
1305 PROCEDURE Unattached* (s: Store): BOOLEAN;
1306 BEGIN
1307 ASSERT(s # NIL, 20);
1308 RETURN (s.dlink = NIL) OR s.dlink.copyDomain
1309 END Unattached;
1311 BEGIN
1312 nextEra := 1; logReports := FALSE
1313 END Stores.