Trurl-based/Dev/Mod/CPT.txt

   1 MODULE DevCPT;
   2
   3         (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPT.odc *)
   4         (* DO NOT EDIT *)
   5
   6         IMPORT DevCPM;
   7
   8         CONST
   9                 MaxIdLen = 256;
  10
  11         TYPE
  12                 Name* = ARRAY MaxIdLen OF SHORTCHAR;
  13                 String* = POINTER TO ARRAY OF SHORTCHAR;
  14                 Const* = POINTER TO ConstDesc;
  15                 Object* = POINTER TO ObjDesc;
  16                 Struct* = POINTER TO StrDesc;
  17                 Node* = POINTER TO NodeDesc;
  18                 ConstExt* = String;
  19                 LinkList* = POINTER TO LinkDesc;
  20
  21                 ConstDesc* = RECORD
  22                         ext*: ConstExt; (* string or code for code proc (longstring in utf8) *)
  23                         intval*: INTEGER;       (* constant value or adr, proc par size, text position or least case label *)
  24                         intval2*: INTEGER;      (* string length (#char, incl 0X), proc var size or larger case label *)
  25                         setval*: SET;   (* constant value, procedure body present or "ELSE" present in case *)
  26                         realval*: REAL; (* real or longreal constant value *)
  27                         link*: Const    (* chain of constants present in obj file *)
  28                 END ;
  29
  30                 LinkDesc* = RECORD
  31                         offset*, linkadr*: INTEGER;
  32                         next*: LinkList;
  33                 END;
  34
  35                 ObjDesc* = RECORD
  36                         left*, right*, link*, scope*: Object;
  37                         name*: String;  (* name = null OR name^ # "" *)
  38                         leaf*: BOOLEAN;
  39                         sysflag*: BYTE;
  40                         mode*, mnolev*: BYTE;   (* mnolev < 0 -> mno = -mnolev *)
  41                         vis*: BYTE;     (* internal, external, externalR, inPar, outPar *)
  42                         history*: BYTE; (* relevant if name # "" *)
  43                         used*, fpdone*: BOOLEAN;
  44                         fprint*: INTEGER;
  45                         typ*: Struct;   (* actual type, changed in with statements *)
  46                         ptyp*: Struct;  (* original type if typ is changed *)
  47                         conval*: Const;
  48                         adr*, num*: INTEGER;    (* mthno *)
  49                         links*: LinkList;
  50                         nlink*: Object; (* link for name list, declaration order for methods, library link for imp obj *)
  51                         library*, entry*: String;       (* library name, entry name *)
  52                         modifiers*: POINTER TO ARRAY OF String; (* additional interface strings *)
  53                         linkadr*: INTEGER;      (* used in ofront *)
  54                         red: BOOLEAN;
  55                 END ;
  56
  57                 StrDesc* = RECORD
  58                         form*, comp*, mno*, extlev*: BYTE;
  59                         ref*, sysflag*: SHORTINT;
  60                         n*, size*, align*, txtpos*: INTEGER;    (* align is alignment for records and len offset for dynarrs *)
  61                         untagged*, allocated*, pbused*, pvused*, exp*, fpdone, idfpdone: BOOLEAN;
  62                         attribute*: BYTE;
  63                         idfp, pbfp*, pvfp*:INTEGER;
  64                         BaseTyp*: Struct;
  65                         link*, strobj*: Object;
  66                         ext*: ConstExt  (* id string for interface records *)
  67                 END ;
  68
  69                 NodeDesc* = RECORD
  70                         left*, right*, link*: Node;
  71                         class*, subcl*, hint*: BYTE;
  72                         readonly*: BOOLEAN;
  73                         typ*: Struct;
  74                         obj*: Object;
  75                         conval*: Const
  76                 END ;
  77
  78         CONST
  79                 maxImps = 127;  (* must be <= MAX(SHORTINT) *)
  80                 maxStruct = DevCPM.MaxStruct;   (* must be < MAX(INTEGER) DIV 2 *)
  81                 FirstRef = 32;
  82                 FirstRef0 = 16; (* correction for version 0 *)
  83                 actVersion = 1;
  84
  85         VAR
  86                 topScope*: Object;
  87                 undftyp*, bytetyp*, booltyp*, char8typ*, int8typ*, int16typ*, int32typ*,
  88                 real32typ*, real64typ*, settyp*, string8typ*, niltyp*, notyp*, sysptrtyp*,
  89                 anytyp*, anyptrtyp*, char16typ*, string16typ*, int64typ*,
  90                 restyp*, iunktyp*, punktyp*, guidtyp*,
  91                 intrealtyp*, lreal64typ*, lint64typ*, lchar16typ*: Struct;
  92                 nofGmod*: BYTE; (*nof imports*)
  93                 GlbMod*: ARRAY maxImps OF Object;       (* .right = first object, .name = module import name (not alias) *)
  94                 SelfName*: Name;        (* name of module being compiled *)
  95                 SYSimported*: BOOLEAN;
  96                 processor*, impProc*: SHORTINT;
  97                 libName*: Name; (* library alias of module being compiled *)
  98                 null*: String;  (* "" *)
  99
 100         CONST
 101                 (* object modes *)
 102                 Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
 103                 SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20;
 104
 105                 (* structure forms *)
 106                 Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
 107                 Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
 108                 Pointer = 13; ProcTyp = 14; Comp = 15;
 109                 AnyPtr = 14; AnyRec = 15;       (* sym file only *)
 110                 Char16 = 16; String16 = 17; Int64 = 18;
 111                 Res = 20; IUnk = 21; PUnk = 22; Guid = 23;
 112
 113                 (* composite structure forms *)
 114                 Basic = 1; Array = 2; DynArr = 3; Record = 4;
 115
 116                 (*function number*)
 117                 assign = 0;
 118                 haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
 119                 entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
 120                 shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
 121                 inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
 122                 lchrfn = 33; lentierfcn = 34; typfn = 36; bitsfn = 37; bytesfn = 38;
 123
 124                 (*SYSTEM function number*)
 125                 adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
 126                 getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
 127                 bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31;
 128                 thisrecfn = 45; thisarrfn = 46;
 129
 130                 (* COM function number *)
 131                 validfn = 40; iidfn = 41; queryfn = 42;
 132
 133                 (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
 134                 newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
 135
 136                 (* procedure flags (conval.setval) *)
 137                 isHidden = 29;
 138
 139                 (* module visibility of objects *)
 140                 internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
 141
 142                 (* history of imported objects *)
 143                 inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5;
 144
 145                 (* sysflags *)
 146                 inBit = 2; outBit = 4; interface = 10;
 147
 148                 (* symbol file items *)
 149                 Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22;
 150                 Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30;
 151                 Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40;
 152                 Shdutptr = 41; Slib = 42; Sentry = 43; Sinpar = 25; Soutpar = 26;
 153                 Slimrec = 25; Sabsrec = 26; Sextrec = 27; Slimpro = 31; Sabspro = 32; Semppro = 33; Sextpro = 34; Simpo = 22;
 154
 155         TYPE
 156                 ImpCtxt = RECORD
 157                         nextTag, reffp: INTEGER;
 158                         nofr, minr, nofm: SHORTINT;
 159                         self: BOOLEAN;
 160                         ref: ARRAY maxStruct OF Struct;
 161                         old: ARRAY maxStruct OF Object;
 162                         pvfp: ARRAY maxStruct OF INTEGER;       (* set only if old # NIL *)
 163                         glbmno: ARRAY maxImps OF BYTE   (* index is local mno *)
 164                 END ;
 165
 166                 ExpCtxt = RECORD
 167                         reffp: INTEGER;
 168                         ref: SHORTINT;
 169                         nofm: BYTE;
 170                         locmno: ARRAY maxImps OF BYTE   (* index is global mno *)
 171                 END ;
 172
 173         VAR
 174                 universe, syslink, comlink, infinity: Object;
 175                 impCtxt: ImpCtxt;
 176                 expCtxt: ExpCtxt;
 177                 nofhdfld: INTEGER;
 178                 sfpresent, symExtended, symNew: BOOLEAN;
 179                 version: INTEGER;
 180                 symChanges: INTEGER;
 181                 portable: BOOLEAN;
 182                 depth: INTEGER;
 183
 184
 185         PROCEDURE err(n: SHORTINT);
 186         BEGIN DevCPM.err(n)
 187         END err;
 188
 189         PROCEDURE NewConst*(): Const;
 190                 VAR const: Const;
 191         BEGIN NEW(const); RETURN const
 192         END NewConst;
 193
 194         PROCEDURE NewObj*(): Object;
 195                 VAR obj: Object;
 196         BEGIN NEW(obj); obj.name := null; RETURN obj
 197         END NewObj;
 198
 199         PROCEDURE NewStr*(form, comp: BYTE): Struct;
 200                 VAR typ: Struct;
 201         BEGIN NEW(typ); typ.form := form; typ.comp := comp; typ.ref := maxStruct; (* ref >= maxStruct: not exported yet *)
 202                 typ.txtpos := DevCPM.errpos; typ.size := -1; typ.BaseTyp := undftyp; RETURN typ
 203         END NewStr;
 204
 205         PROCEDURE NewNode*(class: BYTE): Node;
 206                 VAR node: Node;
 207         BEGIN
 208                 NEW(node); node.class := class; RETURN node
 209         END NewNode;
 210 (*
 211         PROCEDURE NewExt*(): ConstExt;
 212                 VAR ext: ConstExt;
 213         BEGIN NEW(ext); RETURN ext
 214         END NewExt;
 215 *)
 216         PROCEDURE NewName* ((*IN*) name: ARRAY OF SHORTCHAR): String;
 217                 VAR i: INTEGER; p: String;
 218         BEGIN
 219                 i := 0; WHILE name[i] # 0X DO INC(i) END;
 220                 IF i > 0 THEN NEW(p, i + 1); p^ := name$; RETURN p
 221                 ELSE RETURN null
 222                 END
 223         END NewName;
 224
 225         PROCEDURE OpenScope*(level: BYTE; owner: Object);
 226                 VAR head: Object;
 227         BEGIN head := NewObj();
 228                 head.mode := Head; head.mnolev := level; head.link := owner;
 229                 IF owner # NIL THEN owner.scope := head END ;
 230                 head.left := topScope; head.right := NIL; head.scope := NIL; topScope := head
 231         END OpenScope;
 232
 233         PROCEDURE CloseScope*;
 234         BEGIN topScope := topScope.left
 235         END CloseScope;
 236
 237         PROCEDURE Init*(opt: SET);
 238         BEGIN
 239                 topScope := universe; OpenScope(0, NIL); SYSimported := FALSE;
 240                 GlbMod[0] := topScope; nofGmod := 1;
 241                 sfpresent := TRUE;      (* !!! *)
 242                 symChanges := 0;
 243                 infinity.conval.intval := DevCPM.ConstNotAlloc;
 244                 depth := 0
 245         END Init;
 246
 247         PROCEDURE Open* (name: Name);
 248         BEGIN
 249                 SelfName := name$; topScope.name := NewName(name);
 250         END Open;
 251
 252         PROCEDURE Close*;
 253                 VAR i: SHORTINT;
 254         BEGIN   (* garbage collection *)
 255                 CloseScope;
 256                 i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END ;
 257                 i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END
 258         END Close;
 259
 260         PROCEDURE SameType* (x, y: Struct): BOOLEAN;
 261         BEGIN
 262                 RETURN (x = y) OR (x.form = y.form) & ~(x.form IN {Pointer, ProcTyp, Comp}) OR (x = undftyp) OR (y = undftyp)
 263         END SameType;
 264
 265         PROCEDURE EqualType* (x, y: Struct): BOOLEAN;
 266                 VAR xp, yp: Object; n: INTEGER;
 267         BEGIN
 268                 n := 0;
 269                 WHILE (n < 100) & (x # y)
 270                         & (((x.comp = DynArr) & (y.comp = DynArr) & (x.sysflag = y.sysflag))
 271                                 OR ((x.form = Pointer) & (y.form = Pointer))
 272                                 OR ((x.form = ProcTyp) & (y.form = ProcTyp))) DO
 273                         IF x.form = ProcTyp THEN
 274                                 IF x.sysflag # y.sysflag THEN RETURN FALSE END;
 275                                 xp := x.link; yp := y.link;
 276                                 INC(depth);
 277                                 WHILE (xp # NIL) & (yp # NIL) & (xp.mode = yp.mode) & (xp.sysflag = yp.sysflag)
 278                                                 & (xp.vis = yp.vis) & (depth < 100) & EqualType(xp.typ, yp.typ) DO
 279                                         xp := xp.link; yp := yp.link
 280                                 END;
 281                                 DEC(depth);
 282                                 IF (xp # NIL) OR (yp # NIL) THEN RETURN FALSE END
 283                         END;
 284                         x := x.BaseTyp; y := y.BaseTyp; INC(n)
 285                 END;
 286                 RETURN SameType(x, y)
 287         END EqualType;
 288
 289         PROCEDURE Extends* (x, y: Struct): BOOLEAN;
 290         BEGIN
 291                 IF (x.form = Pointer) & (y.form = Pointer) THEN x := x.BaseTyp; y := y.BaseTyp END;
 292                 IF (x.comp = Record) & (y.comp = Record) THEN
 293                         IF (y = anytyp) & ~x.untagged THEN RETURN TRUE END;
 294                         WHILE (x # NIL) & (x # undftyp) & (x # y) DO x := x.BaseTyp END
 295                 END;
 296                 RETURN (x # NIL) & EqualType(x, y)
 297         END Extends;
 298
 299         PROCEDURE Includes* (xform, yform: INTEGER): BOOLEAN;
 300         BEGIN
 301                 CASE xform OF
 302                 | Char16: RETURN yform IN {Char8, Char16, Int8}
 303                 | Int16: RETURN yform IN {Char8, Int8, Int16}
 304                 | Int32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32}
 305                 | Int64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64}
 306                 | Real32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32}
 307                 | Real64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32, Real64}
 308                 | String16: RETURN yform IN {String8, String16}
 309                 ELSE RETURN xform = yform
 310                 END
 311         END Includes;
 312
 313         PROCEDURE FindImport*(VAR name: Name; mod: Object; VAR res: Object);
 314                 VAR obj: Object; (* i: INTEGER; n: Name; *)
 315         BEGIN obj := mod.scope.right;
 316                 LOOP
 317                         IF obj = NIL THEN EXIT END ;
 318                         IF name < obj.name^ THEN obj := obj.left
 319                         ELSIF name > obj.name^ THEN obj := obj.right
 320                         ELSE (*found*)
 321                                 IF (obj.mode = Typ) & (obj.vis = internal) THEN obj := NIL
 322                                 ELSE obj.used := TRUE
 323                                 END ;
 324                                 EXIT
 325                         END
 326                 END ;
 327                 res := obj;
 328 (*      bh: checks usage of non Unicode WinApi functions and types
 329                 IF (res # NIL) & (mod.scope.library # NIL)
 330                                 & ~(DevCPM.interface IN DevCPM.options)
 331                                 & (SelfName # "Kernel") & (SelfName # "HostPorts") THEN
 332                         n := name + "W";
 333                         FindImport(n, mod, obj);
 334                         IF obj # NIL THEN
 335                                 DevCPM.err(733)
 336                         ELSE
 337                                 i := LEN(name$);
 338                                 IF name[i - 1] = "A" THEN
 339                                         n[i - 1] := "W"; n[i] := 0X;
 340                                         FindImport(n, mod, obj);
 341                                         IF obj # NIL THEN
 342                                                 DevCPM.err(734)
 343                                         END
 344                                 END
 345                         END
 346                 END;
 347 *)
 348         END FindImport;
 349
 350         PROCEDURE Find*(VAR name: Name; VAR res: Object);
 351                 VAR obj, head: Object;
 352         BEGIN head := topScope;
 353                 LOOP obj := head.right;
 354                         LOOP
 355                                 IF obj = NIL THEN EXIT END ;
 356                                 IF name < obj.name^ THEN obj := obj.left
 357                                 ELSIF name > obj.name^ THEN obj := obj.right
 358                                 ELSE (* found, obj.used not set for local objects *) EXIT
 359                                 END
 360                         END ;
 361                         IF obj # NIL THEN EXIT END ;
 362                         head := head.left;
 363                         IF head = NIL THEN EXIT END
 364                 END ;
 365                 res := obj
 366         END Find;
 367
 368         PROCEDURE FindFld (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object);
 369                 VAR obj: Object;
 370         BEGIN
 371                 WHILE (typ # NIL) & (typ # undftyp) DO obj := typ.link;
 372                         WHILE obj # NIL DO
 373                                 IF name < obj.name^ THEN obj := obj.left
 374                                 ELSIF name > obj.name^ THEN obj := obj.right
 375                                 ELSE (*found*) res := obj; RETURN
 376                                 END
 377                         END ;
 378                         typ := typ.BaseTyp
 379                 END;
 380                 res := NIL
 381         END FindFld;
 382
 383         PROCEDURE FindField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object);
 384         BEGIN
 385                 FindFld(name, typ, res);
 386                 IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END
 387         END FindField;
 388
 389         PROCEDURE FindBaseField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object);
 390         BEGIN
 391                 FindFld(name, typ.BaseTyp, res);
 392                 IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END
 393         END FindBaseField;
 394
 395 (*
 396         PROCEDURE Rotated (y: Object; name: String): Object;
 397                 VAR c, gc: Object;
 398         BEGIN
 399                 IF name^ < y.name^ THEN
 400                         c := y.left;
 401                         IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c
 402                         ELSE gc := c.right; c.right := gc.left; gc.left := c
 403                         END;
 404                         y.left := gc
 405                 ELSE
 406                         c := y.right;
 407                         IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c
 408                         ELSE gc := c.right; c.right := gc.left; gc.left := c
 409                         END;
 410                         y.right := gc
 411                 END;
 412                 RETURN gc
 413         END Rotated;
 414
 415         PROCEDURE InsertIn (obj, scope: Object; VAR old: Object);
 416                 VAR gg, g, p, x: Object; name, sname: String;
 417         BEGIN
 418                 sname := scope.name; scope.name := null;
 419                 gg := scope; g := gg; p := g; x := p.right; name := obj.name;
 420                 WHILE x # NIL DO
 421                         IF (x.left # NIL) & (x.right # NIL) & x.left.red & x.right.red THEN
 422                                 x.red := TRUE; x.left.red := FALSE; x.right.red := FALSE;
 423                                 IF p.red THEN
 424                                         g.red := TRUE;
 425                                         IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END;
 426                                         x := Rotated(gg, name); x.red := FALSE
 427                                 END
 428                         END;
 429                         gg := g; g := p; p := x;
 430                         IF name^ < x.name^ THEN x := x.left
 431                         ELSIF name^ > x.name^ THEN x := x.right
 432                         ELSE old := x; scope.right.red := FALSE; scope.name := sname; RETURN
 433                         END
 434                 END;
 435                 x := obj; old := NIL;
 436                 IF name^ < p.name^ THEN p.left := x ELSE p.right := x END;
 437                 x.red := TRUE;
 438                 IF p.red THEN
 439                         g.red := TRUE;
 440                         IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END;
 441                         x := Rotated(gg, name);
 442                         x.red := FALSE
 443                 END;
 444                 scope.right.red := FALSE; scope.name := sname
 445         END InsertIn;
 446 *)
 447         PROCEDURE InsertIn (obj, scope: Object; VAR old: Object);
 448                 VAR ob0, ob1: Object; left: BOOLEAN; name: String;
 449         BEGIN
 450                 ASSERT((scope # NIL) & (scope.mode = Head), 100);
 451                 ob0 := scope; ob1 := scope.right; left := FALSE; name := obj.name;
 452                 WHILE ob1 # NIL DO
 453                         IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE
 454                         ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE
 455                         ELSE old := ob1; RETURN
 456                         END
 457                 END;
 458                 IF left THEN ob0.left := obj ELSE ob0.right := obj END ;
 459                 obj.left := NIL; obj.right := NIL; old := NIL
 460         END InsertIn;
 461
 462         PROCEDURE Insert* (VAR name: Name; VAR obj: Object);
 463                 VAR old: Object;
 464         BEGIN
 465                 obj := NewObj(); obj.leaf := TRUE;
 466                 obj.name := NewName(name);
 467                 obj.mnolev := topScope.mnolev;
 468                 InsertIn(obj, topScope, old);
 469                 IF old # NIL THEN err(1) END    (*double def*)
 470         END Insert;
 471
 472         PROCEDURE InsertThisField (obj: Object; typ: Struct; VAR old: Object);
 473                 VAR ob0, ob1: Object; left: BOOLEAN; name: String;
 474         BEGIN
 475                 IF typ.link = NIL THEN typ.link := obj
 476                 ELSE
 477                         ob1 := typ.link; name := obj.name;
 478                         REPEAT
 479                                 IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE
 480                                 ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE
 481                                 ELSE old := ob1; RETURN
 482                                 END
 483                         UNTIL ob1 = NIL;
 484                         IF left THEN ob0.left := obj ELSE ob0.right := obj END
 485                 END
 486         END InsertThisField;
 487
 488         PROCEDURE InsertField* (VAR name: Name; typ: Struct; VAR obj: Object);
 489                 VAR old: Object;
 490         BEGIN
 491                 obj := NewObj(); obj.leaf := TRUE;
 492                 obj.name := NewName(name);
 493                 InsertThisField(obj, typ, old);
 494                 IF old # NIL THEN err(1) END    (*double def*)
 495         END InsertField;
 496
 497
 498 (*-------------------------- Fingerprinting --------------------------*)
 499
 500         PROCEDURE FPrintName(VAR fp: INTEGER; VAR name: ARRAY OF SHORTCHAR);
 501                 VAR i: SHORTINT; ch: SHORTCHAR;
 502         BEGIN i := 0;
 503                 REPEAT ch := name[i]; DevCPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X
 504         END FPrintName;
 505
 506         PROCEDURE ^IdFPrint*(typ: Struct);
 507
 508         PROCEDURE FPrintSign*(VAR fp: INTEGER; result: Struct; par: Object);
 509         (* depends on assignment compatibility of params only *)
 510         BEGIN
 511                 IdFPrint(result); DevCPM.FPrint(fp, result.idfp);
 512                 WHILE par # NIL DO
 513                         DevCPM.FPrint(fp, par.mode); IdFPrint(par.typ); DevCPM.FPrint(fp, par.typ.idfp);
 514                         IF (par.mode = VarPar) & (par.vis # 0) THEN DevCPM.FPrint(fp, par.vis) END;     (* IN / OUT *)
 515                         IF par.sysflag # 0 THEN DevCPM.FPrint(fp, par.sysflag) END;
 516                         (* par.name and par.adr not considered *)
 517                         par := par.link
 518                 END
 519         END FPrintSign;
 520
 521         PROCEDURE IdFPrint*(typ: Struct);       (* idfp codifies assignment compatibility *)
 522                 VAR btyp: Struct; strobj: Object; idfp: INTEGER; f, c: SHORTINT;
 523         BEGIN
 524                 IF ~typ.idfpdone THEN
 525                         typ.idfpdone := TRUE;   (* may be recursive, temporary idfp is 0 in that case *)
 526                         idfp := 0; f := typ.form; c := typ.comp; DevCPM.FPrint(idfp, f); DevCPM.FPrint(idfp, c);
 527                         btyp := typ.BaseTyp; strobj := typ.strobj;
 528                         IF (strobj # NIL) & (strobj.name # null) THEN
 529                                 FPrintName(idfp, GlbMod[typ.mno].name^); FPrintName(idfp, strobj.name^)
 530                         END ;
 531                         IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN
 532                                 IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp)
 533                         ELSIF c = Array THEN IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp); DevCPM.FPrint(idfp, typ.n)
 534                         ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ.link)
 535                         END ;
 536                         typ.idfp := idfp
 537                 END
 538         END IdFPrint;
 539
 540         PROCEDURE FPrintStr*(typ: Struct);
 541                 VAR f, c: SHORTINT; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: INTEGER;
 542
 543                 PROCEDURE ^FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);
 544
 545                 PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: INTEGER);  (* modifies pvfp only *)
 546                         VAR i, j, n: INTEGER; btyp: Struct;
 547                 BEGIN
 548                         IF typ.comp = Record THEN FPrintFlds(typ.link, adr, FALSE)
 549                         ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n;
 550                                 WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
 551                                 IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN
 552                                         j := nofhdfld; FPrintHdFld(btyp, fld, adr);
 553                                         IF j # nofhdfld THEN i := 1;
 554                                                 WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO  (* !!! *)
 555                                                         INC(adr, btyp.size); FPrintHdFld(btyp, fld, adr); INC(i)
 556                                                 END
 557                                         END
 558                                 END
 559                         ELSIF DevCPM.ExpHdPtrFld &
 560                                 ((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN   (* !!! *)
 561                                 DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld)
 562                         ELSIF DevCPM.ExpHdUtPtrFld &
 563                                 ((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN  (* !!! *)
 564                                 DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld);
 565                                 IF typ.form = Pointer THEN DevCPM.FPrint(pvfp, typ.sysflag) ELSE DevCPM.FPrint(pvfp, fld.sysflag) END
 566                         ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN
 567                                 DevCPM.FPrint(pvfp, ProcTyp); DevCPM.FPrint(pvfp, adr); INC(nofhdfld)
 568                         END
 569                 END FPrintHdFld;
 570
 571                 PROCEDURE FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);      (* modifies pbfp and pvfp *)
 572                 BEGIN
 573                         WHILE (fld # NIL) & (fld.mode = Fld) DO
 574                                 IF (fld.vis # internal) & visible THEN
 575                                         DevCPM.FPrint(pvfp, fld.vis); FPrintName(pvfp, fld.name^); DevCPM.FPrint(pvfp, fld.adr);
 576                                         DevCPM.FPrint(pbfp, fld.vis); FPrintName(pbfp, fld.name^); DevCPM.FPrint(pbfp, fld.adr);
 577                                         FPrintStr(fld.typ); DevCPM.FPrint(pbfp, fld.typ.pbfp); DevCPM.FPrint(pvfp, fld.typ.pvfp)
 578                                 ELSE FPrintHdFld(fld.typ, fld, fld.adr + adr)
 579                                 END ;
 580                                 fld := fld.link
 581                         END
 582                 END FPrintFlds;
 583
 584                 PROCEDURE FPrintTProcs(obj: Object);    (* modifies pbfp and pvfp *)
 585                         VAR fp: INTEGER;
 586                 BEGIN
 587                         IF obj # NIL THEN
 588                                 FPrintTProcs(obj.left);
 589                                 IF obj.mode = TProc THEN
 590                                         IF obj.vis # internal THEN
 591                                                 fp := 0;
 592                                                 IF obj.vis = externalR THEN DevCPM.FPrint(fp, externalR) END;
 593                                                 IF limAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, limAttr)
 594                                                 ELSIF absAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, absAttr)
 595                                                 ELSIF empAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, empAttr)
 596                                                 ELSIF extAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, extAttr)
 597                                                 END;
 598                                                 DevCPM.FPrint(fp, TProc); DevCPM.FPrint(fp, obj.num);
 599                                                 FPrintSign(fp, obj.typ, obj.link); FPrintName(fp, obj.name^);
 600                                                 IF obj.entry # NIL THEN FPrintName(fp, obj.entry^) END;
 601                                                 DevCPM.FPrint(pvfp, fp); DevCPM.FPrint(pbfp, fp)
 602                                         ELSIF DevCPM.ExpHdTProc THEN
 603                                                 DevCPM.FPrint(pvfp, TProc); DevCPM.FPrint(pvfp, obj.num)
 604                                         END
 605                                 END;
 606                                 FPrintTProcs(obj.right)
 607                         END
 608                 END FPrintTProcs;
 609
 610         BEGIN
 611                 IF ~typ.fpdone THEN
 612                         IdFPrint(typ); pbfp := typ.idfp;
 613                         IF typ.sysflag # 0 THEN DevCPM.FPrint(pbfp, typ.sysflag) END;
 614                         IF typ.ext # NIL THEN FPrintName(pbfp, typ.ext^) END;
 615                         IF typ.attribute # 0 THEN DevCPM.FPrint(pbfp, typ.attribute) END;
 616                         pvfp := pbfp; typ.pbfp := pbfp; typ.pvfp := pvfp;       (* initial fprints may be used recursively *)
 617                         typ.fpdone := TRUE;
 618                         f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
 619                         IF f = Pointer THEN
 620                                 strobj := typ.strobj; bstrobj := btyp.strobj;
 621                                 IF (strobj = NIL) OR (strobj.name = null) OR (bstrobj = NIL) OR (bstrobj.name = null) THEN
 622                                         FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); pvfp := pbfp
 623                                 (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *)
 624                                 END
 625                         ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *)
 626                         ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pvfp); pvfp := pbfp
 627                         ELSE (* c = Record *)
 628                                 IF btyp # NIL THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); DevCPM.FPrint(pvfp, btyp.pvfp) END ;
 629                                 DevCPM.FPrint(pvfp, typ.size); DevCPM.FPrint(pvfp, typ.align); DevCPM.FPrint(pvfp, typ.n);
 630                                 nofhdfld := 0; FPrintFlds(typ.link, 0, TRUE);
 631                                 FPrintTProcs(typ.link); (* DevCPM.FPrint(pvfp, pbfp); *) strobj := typ.strobj;
 632                                 IF (strobj = NIL) OR (strobj.name = null) THEN pbfp := pvfp END
 633                         END ;
 634                         typ.pbfp := pbfp; typ.pvfp := pvfp
 635                 END
 636         END FPrintStr;
 637
 638         PROCEDURE FPrintObj*(obj: Object);
 639                 VAR fprint: INTEGER; f, m: SHORTINT; rval: SHORTREAL; ext: ConstExt; mod: Object; r: REAL; x: INTEGER;
 640         BEGIN
 641                 IF ~obj.fpdone THEN
 642                         fprint := 0; obj.fpdone := TRUE;
 643                         DevCPM.FPrint(fprint, obj.mode);
 644                         IF obj.mode = Con THEN
 645                                 f := obj.typ.form; DevCPM.FPrint(fprint, f);
 646                                 CASE f OF
 647                                 | Bool, Char8, Char16, Int8, Int16, Int32:
 648                                         DevCPM.FPrint(fprint, obj.conval.intval)
 649                                 | Int64:
 650                                         x := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4294967296.0));
 651                                         r := obj.conval.realval + obj.conval.intval - x * 4294967296.0;
 652                                         IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END;
 653                                         DevCPM.FPrint(fprint, SHORT(ENTIER(r)));
 654                                         DevCPM.FPrint(fprint, x)
 655                                 | Set:
 656                                         DevCPM.FPrintSet(fprint, obj.conval.setval)
 657                                 | Real32:
 658                                         rval := SHORT(obj.conval.realval); DevCPM.FPrintReal(fprint, rval)
 659                                 | Real64:
 660                                         DevCPM.FPrintLReal(fprint, obj.conval.realval)
 661                                 | String8, String16:
 662                                         FPrintName(fprint, obj.conval.ext^)
 663                                 | NilTyp:
 664                                 ELSE err(127)
 665                                 END
 666                         ELSIF obj.mode = Var THEN
 667                                 DevCPM.FPrint(fprint, obj.vis); FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp)
 668                         ELSIF obj.mode IN {XProc, IProc}  THEN
 669                                 FPrintSign(fprint, obj.typ, obj.link)
 670                         ELSIF obj.mode = CProc THEN
 671                                 FPrintSign(fprint, obj.typ, obj.link); ext := obj.conval.ext;
 672                                 m := ORD(ext^[0]); f := 1; DevCPM.FPrint(fprint, m);
 673                                 WHILE f <= m DO DevCPM.FPrint(fprint, ORD(ext^[f])); INC(f) END
 674                         ELSIF obj.mode = Typ THEN
 675                                 FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp)
 676                         END ;
 677                         IF obj.sysflag < 0 THEN DevCPM.FPrint(fprint, obj.sysflag) END;
 678                         IF obj.mode IN {LProc, XProc, CProc, Var, Typ, Con} THEN
 679                                 IF obj.library # NIL THEN
 680                                         FPrintName(fprint, obj.library^)
 681                                 ELSIF obj.mnolev < 0 THEN
 682                                         mod := GlbMod[-obj.mnolev];
 683                                         IF (mod.library # NIL) THEN
 684                                                 FPrintName(fprint, mod.library^)
 685                                         END
 686                                 ELSIF obj.mnolev = 0 THEN
 687                                         IF libName # "" THEN FPrintName(fprint, libName) END
 688                                 END;
 689                                 IF obj.entry # NIL THEN FPrintName(fprint, obj.entry^) END
 690                         END;
 691                         obj.fprint := fprint
 692                 END
 693         END FPrintObj;
 694
 695         PROCEDURE FPrintErr* (obj: Object; errno: SHORTINT);    (* !!! *)
 696         BEGIN
 697                 IF errno = 249 THEN
 698                         DevCPM.LogWLn; DevCPM.LogWStr("  ");
 699                         DevCPM.LogWStr(GlbMod[-obj.mnolev].name^);
 700                         DevCPM.LogW("."); DevCPM.LogWStr(obj.name^);
 701                         DevCPM.LogWStr(" is not consistently imported");
 702                         err(249)
 703                 ELSIF obj = NIL THEN    (* changed module sys flags *)
 704                         IF ~symNew & sfpresent THEN
 705                                 DevCPM.LogWLn; DevCPM.LogWStr("  changed library flag")
 706                         END
 707                 ELSIF obj.mnolev = 0 THEN       (* don't report changes in imported modules *)
 708                         IF sfpresent THEN
 709                                 IF symChanges < 20 THEN
 710                                         DevCPM.LogWLn; DevCPM.LogWStr("  "); DevCPM.LogWStr(obj.name^);
 711                                         IF errno = 250 THEN DevCPM.LogWStr(" is no longer in symbol file")
 712                                         ELSIF errno = 251 THEN DevCPM.LogWStr(" is redefined internally ")
 713                                         ELSIF errno = 252 THEN DevCPM.LogWStr(" is redefined")
 714                                         ELSIF errno = 253 THEN DevCPM.LogWStr(" is new in symbol file")
 715                                         END
 716                                 ELSIF symChanges = 20 THEN
 717                                         DevCPM.LogWLn; DevCPM.LogWStr("  ...")
 718                                 END;
 719                                 INC(symChanges)
 720                         ELSIF (errno = 253) & ~symExtended THEN
 721                                 DevCPM.LogWLn;
 722                                 DevCPM.LogWStr("  new symbol file")
 723                         END
 724                 END;
 725                 IF errno = 253 THEN symExtended := TRUE ELSE symNew := TRUE END
 726         END FPrintErr;
 727
 728 (*-------------------------- Import --------------------------*)
 729
 730         PROCEDURE InName(VAR name: String);
 731                 VAR i: SHORTINT; ch: SHORTCHAR; n: Name;
 732         BEGIN i := 0;
 733                 REPEAT
 734                         DevCPM.SymRCh(ch); n[i] := ch; INC(i)
 735                 UNTIL ch = 0X;
 736                 IF i > 1 THEN NEW(name, i); name^ := n$ ELSE name := null END
 737         END InName;
 738
 739         PROCEDURE InMod(tag: INTEGER; VAR mno: BYTE);   (* mno is global *)
 740                 VAR head: Object; name: String; mn: INTEGER; i: BYTE; lib: String;
 741         BEGIN
 742                 IF tag = 0 THEN mno := impCtxt.glbmno[0]
 743                 ELSIF tag > 0 THEN
 744                         lib := NIL;
 745                         IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END;
 746                         ASSERT(tag = Smname);
 747                         InName(name);
 748                         IF (name^ = SelfName) & ~impCtxt.self & ~(DevCPM.interface IN DevCPM.options) THEN err(154) END ;
 749                         i := 0;
 750                         WHILE (i < nofGmod) & (name^ # GlbMod[i].name^) DO INC(i) END ;
 751                         IF i < nofGmod THEN mno := i    (*module already present*)
 752                         ELSE
 753                                 head := NewObj(); head.mode := Head; head.name := name;
 754                                 mno := nofGmod; head.mnolev := SHORT(SHORT(-mno));
 755                                 head.library := lib;
 756                                 IF nofGmod < maxImps THEN
 757                                         GlbMod[mno] := head; INC(nofGmod)
 758                                 ELSE err(227)
 759                                 END
 760                         END ;
 761                         impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm)
 762                 ELSE
 763                         mno := impCtxt.glbmno[-tag]
 764                 END
 765         END InMod;
 766
 767         PROCEDURE InConstant(f: INTEGER; conval: Const);
 768                 VAR ch, ch1: SHORTCHAR; ext, t: ConstExt; rval: SHORTREAL; r, s: REAL; i, x, y: INTEGER; str: Name;
 769         BEGIN
 770                 CASE f OF
 771                 | Byte, Char8, Bool:
 772                         DevCPM.SymRCh(ch); conval.intval := ORD(ch)
 773                 | Char16:
 774                         DevCPM.SymRCh(ch); conval.intval := ORD(ch);
 775                         DevCPM.SymRCh(ch); conval.intval := conval.intval + ORD(ch) * 256
 776                 | Int8, Int16, Int32:
 777                         conval.intval := DevCPM.SymRInt()
 778                 | Int64:
 779                         DevCPM.SymRCh(ch); x := 0; y := 1; r := 0; s := 268435456 (*2^28*);
 780                         WHILE (y < 268435456 (*2^28*)) & (ch >= 80X) DO
 781                                 x := x + (ORD(ch) - 128) * y; y := y * 128; DevCPM.SymRCh(ch)
 782                         END;
 783                         WHILE ch >= 80X DO r := r + (ORD(ch) - 128) * s; s := s * 128; DevCPM.SymRCh(ch) END;
 784                         conval.realval := r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s;
 785                         conval.intval := SHORT(ENTIER(r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s - conval.realval))
 786                 | Set:
 787                         DevCPM.SymRSet(conval.setval)
 788                 | Real32:
 789                         DevCPM.SymRReal(rval); conval.realval := rval;
 790                         conval.intval := DevCPM.ConstNotAlloc
 791                 | Real64:
 792                         DevCPM.SymRLReal(conval.realval);
 793                         conval.intval := DevCPM.ConstNotAlloc
 794                 | String8, String16:
 795                         i := 0;
 796                         REPEAT
 797                                 DevCPM.SymRCh(ch);
 798                                 IF i < LEN(str) - 1 THEN str[i] := ch
 799                                 ELSIF i = LEN(str) - 1 THEN str[i] := 0X; NEW(ext, 2 * LEN(str)); ext^ := str$; ext[i] := ch
 800                                 ELSIF i < LEN(ext^) - 1 THEN ext[i] := ch
 801                                 ELSE t := ext; t[i] := 0X; NEW(ext, 2 * LEN(t^)); ext^ := t^$; ext[i] := ch
 802                                 END;
 803                                 INC(i)
 804                         UNTIL ch = 0X;
 805                         IF i < LEN(str) THEN NEW(ext, i); ext^ := str$ END;
 806                         conval.ext := ext; conval.intval := DevCPM.ConstNotAlloc;
 807                         IF f = String8 THEN conval.intval2 := i
 808                         ELSE
 809                                 i := 0; y := 0;
 810                                 REPEAT DevCPM.GetUtf8(ext^, x, i); INC(y) UNTIL x = 0;
 811                                 conval.intval2 := y
 812                         END
 813 (*
 814                         ext := NewExt(); conval.ext := ext; i := 0;
 815                         REPEAT
 816                                 DevCPM.SymRCh(ch); ext^[i] := ch; INC(i)
 817                         UNTIL ch = 0X;
 818                         conval.intval2 := i;
 819                         conval.intval := DevCPM.ConstNotAlloc
 820                 | String16:
 821                         ext := NewExt(); conval.ext := ext; i := 0;
 822                         REPEAT
 823                                 DevCPM.SymRCh(ch); ext^[i] := ch; INC(i);
 824                                 DevCPM.SymRCh(ch1); ext^[i] := ch1; INC(i)
 825                         UNTIL (ch = 0X) & (ch1 = 0X);
 826                         conval.intval2 := i;
 827                         conval.intval := DevCPM.ConstNotAlloc
 828 *)
 829                 | NilTyp:
 830                         conval.intval := 0
 831 (*
 832                 | Guid:
 833                         ext := NewExt(); conval.ext := ext; i := 0;
 834                         WHILE i < 16 DO
 835                                 DevCPM.SymRCh(ch); ext^[i] := ch; INC(i)
 836                         END;
 837                         ext[16] := 0X;
 838                         conval.intval2 := 16;
 839                         conval.intval := DevCPM.ConstNotAlloc;
 840 *)
 841                 END
 842         END InConstant;
 843
 844         PROCEDURE ^InStruct(VAR typ: Struct);
 845
 846         PROCEDURE InSign(mno: BYTE; VAR res: Struct; VAR par: Object);
 847                 VAR last, new: Object; tag: INTEGER;
 848         BEGIN
 849                 InStruct(res);
 850                 tag := DevCPM.SymRInt(); last := NIL;
 851                 WHILE tag # Send DO
 852                         new := NewObj(); new.mnolev := SHORT(SHORT(-mno));
 853                         IF last = NIL THEN par := new ELSE last.link := new END ;
 854                         IF tag = Ssys THEN
 855                                 new.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt();
 856                                 IF ODD(new.sysflag DIV inBit) THEN new.vis := inPar
 857                                 ELSIF ODD(new.sysflag DIV inBit) THEN new.vis := outPar
 858                                 END
 859                         END;
 860                         IF tag = Svalpar THEN new.mode := Var
 861                         ELSE new.mode := VarPar;
 862                                 IF tag = Sinpar THEN new.vis := inPar
 863                                 ELSIF tag = Soutpar THEN new.vis := outPar
 864                                 END
 865                         END ;
 866                         InStruct(new.typ); new.adr := DevCPM.SymRInt(); InName(new.name);
 867                         last := new; tag := DevCPM.SymRInt()
 868                 END
 869         END InSign;
 870
 871         PROCEDURE InFld(): Object;      (* first number in impCtxt.nextTag, mno set outside *)
 872                 VAR tag: INTEGER; obj: Object;
 873         BEGIN
 874                 tag := impCtxt.nextTag; obj := NewObj();
 875                 IF tag <= Srfld THEN
 876                         obj.mode := Fld;
 877                         IF tag = Srfld THEN obj.vis := externalR ELSE obj.vis := external END ;
 878                         InStruct(obj.typ); InName(obj.name);
 879                         obj.adr := DevCPM.SymRInt()
 880                 ELSE
 881                         obj.mode := Fld;
 882                         IF tag = Shdptr THEN obj.name := NewName(DevCPM.HdPtrName)
 883                         ELSIF tag = Shdutptr THEN obj.name := NewName(DevCPM.HdUtPtrName);      (* !!! *)
 884                                 obj.sysflag := 1
 885                         ELSIF tag = Ssys THEN
 886                                 obj.name := NewName(DevCPM.HdUtPtrName); obj.sysflag := SHORT(SHORT(DevCPM.SymRInt()))
 887                         ELSE obj.name := NewName(DevCPM.HdProcName)
 888                         END;
 889                         obj.typ := undftyp; obj.vis := internal;
 890                         obj.adr := DevCPM.SymRInt()
 891                 END;
 892                 RETURN obj
 893         END InFld;
 894
 895         PROCEDURE InTProc(mno: BYTE): Object;   (* first number in impCtxt.nextTag *)
 896                 VAR tag: INTEGER; obj: Object;
 897         BEGIN
 898                 tag := impCtxt.nextTag;
 899                 obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno));
 900                 IF tag = Shdtpro THEN
 901                         obj.mode := TProc; obj.name := NewName(DevCPM.HdTProcName);
 902                         obj.link := NewObj();   (* dummy, easier in Browser *)
 903                         obj.typ := undftyp; obj.vis := internal;
 904                         obj.num := DevCPM.SymRInt()
 905                 ELSE
 906                         obj.vis := external;
 907                         IF tag = Simpo THEN obj.vis := externalR; tag := DevCPM.SymRInt() END;
 908                         obj.mode := TProc; obj.conval := NewConst(); obj.conval.intval := -1;
 909                         IF tag = Sentry THEN InName(obj.entry); tag := DevCPM.SymRInt() END;
 910                         InSign(mno, obj.typ, obj.link); InName(obj.name);
 911                         obj.num := DevCPM.SymRInt();
 912                         IF tag = Slimpro THEN INCL(obj.conval.setval, limAttr)
 913                         ELSIF tag = Sabspro THEN INCL(obj.conval.setval, absAttr)
 914                         ELSIF tag = Semppro THEN INCL(obj.conval.setval, empAttr)
 915                         ELSIF tag = Sextpro THEN INCL(obj.conval.setval, extAttr)
 916                         END
 917                 END ;
 918                 RETURN obj
 919         END InTProc;
 920
 921         PROCEDURE InStruct(VAR typ: Struct);
 922                 VAR mno: BYTE; ref: SHORTINT; tag: INTEGER; name: String;
 923                         t: Struct; obj, last, fld, old, dummy: Object;
 924         BEGIN
 925                 tag := DevCPM.SymRInt();
 926                 IF tag # Sstruct THEN
 927                         tag := -tag;
 928                         IF (version = 0) & (tag >= FirstRef0) THEN tag := tag + FirstRef - FirstRef0 END;       (* correction for new FirstRef *)
 929                         typ := impCtxt.ref[tag]
 930                 ELSE
 931                         ref := impCtxt.nofr; INC(impCtxt.nofr);
 932                         IF ref < impCtxt.minr THEN impCtxt.minr := ref END ;
 933                         tag := DevCPM.SymRInt();
 934                         InMod(tag, mno); InName(name); obj := NewObj();
 935                         IF name = null THEN
 936                                 IF impCtxt.self THEN old := NIL (* do not insert type desc anchor here, but in OPL *)
 937                                 ELSE obj.name := NewName("@"); InsertIn(obj, GlbMod[mno], old(*=NIL*)); obj.name := null
 938                                 END ;
 939                                 typ := NewStr(Undef, Basic)
 940                         ELSE obj.name := name; InsertIn(obj, GlbMod[mno], old);
 941                                 IF old # NIL THEN       (* recalculate fprints to compare with old fprints *)
 942                                         FPrintObj(old); impCtxt.pvfp[ref] := old.typ.pvfp;
 943                                         IF impCtxt.self THEN    (* do not overwrite old typ *)
 944                                                 typ := NewStr(Undef, Basic)
 945                                         ELSE    (* overwrite old typ for compatibility reason *)
 946                                                 typ := old.typ; typ.link := NIL; typ.sysflag := 0; typ.ext := NIL;
 947                                                 typ.fpdone := FALSE; typ.idfpdone := FALSE
 948                                         END
 949                                 ELSE typ := NewStr(Undef, Basic)
 950                                 END
 951                         END ;
 952                         impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; typ.ref := SHORT(ref + maxStruct);
 953                         (* ref >= maxStruct: not exported yet, ref used for err 155 *)
 954                         typ.mno := mno; typ.allocated := TRUE;
 955                         typ.strobj := obj; obj.mode := Typ; obj.typ := typ;
 956                         obj.mnolev := SHORT(SHORT(-mno)); obj.vis := internal; (* name not visible here *)
 957                         tag := DevCPM.SymRInt();
 958                         IF tag = Ssys THEN
 959                                 typ.sysflag := SHORT(DevCPM.SymRInt()); tag := DevCPM.SymRInt()
 960                         END;
 961                         typ.untagged := typ.sysflag > 0;
 962                         IF tag = Slib THEN
 963                                 InName(obj.library); tag := DevCPM.SymRInt()
 964                         END;
 965                         IF tag = Sentry THEN
 966                                 InName(obj.entry); tag := DevCPM.SymRInt()
 967                         END;
 968                         IF tag = String8 THEN
 969                                 InName(typ.ext); tag := DevCPM.SymRInt()
 970                         END;
 971                         CASE tag OF
 972                         | Sptr:
 973                                 typ.form := Pointer; typ.size := DevCPM.PointerSize; typ.n := 0; InStruct(typ.BaseTyp)
 974                         | Sarr:
 975                                 typ.form := Comp; typ.comp := Array; InStruct(typ.BaseTyp); typ.n := DevCPM.SymRInt();
 976                                 typ.size := typ.n * typ.BaseTyp.size    (* !!! *)
 977                         | Sdarr:
 978                                 typ.form := Comp; typ.comp := DynArr; InStruct(typ.BaseTyp);
 979                                 IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1
 980                                 ELSE typ.n := 0
 981                                 END ;
 982                                 typ.size := DevCPM.DArrSizeA + DevCPM.DArrSizeB * typ.n;        (* !!! *)
 983                                 IF typ.untagged THEN typ.size := DevCPM.PointerSize END
 984                         | Srec, Sabsrec, Slimrec, Sextrec:
 985                                 typ.form := Comp; typ.comp := Record; InStruct(typ.BaseTyp);
 986                                 (* correction by ETH 18.1.96 *)
 987                                 IF typ.BaseTyp = notyp THEN typ.BaseTyp := NIL END;
 988                                 typ.extlev := 0; t := typ.BaseTyp;
 989                                 WHILE (t # NIL) & (t.comp = Record) DO INC(typ.extlev); t := t.BaseTyp END;
 990                                 typ.size := DevCPM.SymRInt(); typ.align := DevCPM.SymRInt();
 991                                 typ.n := DevCPM.SymRInt();
 992                                 IF tag = Sabsrec THEN typ.attribute := absAttr
 993                                 ELSIF tag = Slimrec THEN typ.attribute := limAttr
 994                                 ELSIF tag = Sextrec THEN typ.attribute := extAttr
 995                                 END;
 996                                 impCtxt.nextTag := DevCPM.SymRInt(); last := NIL;
 997                                 WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro)
 998                                                 OR (impCtxt.nextTag = Shdutptr) OR (impCtxt.nextTag = Ssys) DO
 999                                         fld := InFld(); fld.mnolev := SHORT(SHORT(-mno));
1000                                         IF last # NIL THEN last.link := fld END ;
1001                                         last := fld;
1002                                         InsertThisField(fld, typ, dummy);
1003                                         impCtxt.nextTag := DevCPM.SymRInt()
1004                                 END ;
1005                                 WHILE impCtxt.nextTag # Send DO fld := InTProc(mno);
1006                                         InsertThisField(fld, typ, dummy);
1007                                         impCtxt.nextTag := DevCPM.SymRInt()
1008                                 END
1009                         | Spro:
1010                                 typ.form := ProcTyp; typ.size := DevCPM.ProcSize; InSign(mno, typ.BaseTyp, typ.link)
1011                         | Salias:
1012                                 InStruct(t);
1013                                 typ.form := t.form; typ.comp := Basic; typ.size := t.size;
1014                                 typ.pbfp := t.pbfp; typ.pvfp := t.pvfp; typ.fpdone := TRUE;
1015                                 typ.idfp := t.idfp; typ.idfpdone := TRUE; typ.BaseTyp := t
1016                         END ;
1017                         IF ref = impCtxt.minr THEN
1018                                 WHILE ref < impCtxt.nofr DO
1019                                         t := impCtxt.ref[ref]; FPrintStr(t);
1020                                         obj := t.strobj;        (* obj.typ.strobj = obj, else obj.fprint differs (alias) *)
1021                                         IF obj.name # null THEN FPrintObj(obj) END ;
1022                                         old := impCtxt.old[ref];
1023                                         IF old # NIL THEN t.strobj := old;      (* restore strobj *)
1024                                                 IF impCtxt.self THEN
1025                                                         IF old.mnolev < 0 THEN
1026                                                                 IF old.history # inconsistent THEN
1027                                                                         IF old.fprint # obj.fprint THEN old.history := pbmodified
1028                                                                         ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified
1029                                                                         END
1030                                                                 (* ELSE remain inconsistent *)
1031                                                                 END
1032                                                         ELSIF old.fprint # obj.fprint THEN old.history := pbmodified
1033                                                         ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified
1034                                                         ELSIF old.vis = internal THEN old.history := same       (* may be changed to "removed" in InObj *)
1035                                                         ELSE old.history := inserted    (* may be changed to "same" in InObj *)
1036                                                         END
1037                                                 ELSE
1038                                                         (* check private part, delay error message until really used *)
1039                                                         IF impCtxt.pvfp[ref] # t.pvfp THEN old.history := inconsistent END ;
1040                                                         IF old.fprint # obj.fprint THEN FPrintErr(old, 249) END
1041                                                 END
1042                                         ELSIF impCtxt.self THEN obj.history := removed
1043                                         ELSE obj.history := same
1044                                         END ;
1045                                         INC(ref)
1046                                 END ;
1047                                 impCtxt.minr := maxStruct
1048                         END
1049                 END
1050         END InStruct;
1051
1052         PROCEDURE InObj(mno: BYTE): Object;     (* first number in impCtxt.nextTag *)
1053                 VAR ch: SHORTCHAR; obj, old: Object; typ: Struct;
1054                         tag, i, s: INTEGER; ext: ConstExt;
1055         BEGIN
1056                 tag := impCtxt.nextTag;
1057                 IF tag = Stype THEN
1058                         InStruct(typ); obj := typ.strobj;
1059                         IF ~impCtxt.self THEN obj.vis := external END   (* type name visible now, obj.fprint already done *)
1060                 ELSE
1061                         obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno)); obj.vis := external;
1062                         IF tag = Ssys THEN obj.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt() END;
1063                         IF tag = Slib THEN
1064                                 InName(obj.library); tag := DevCPM.SymRInt()
1065                         END;
1066                         IF tag = Sentry THEN
1067                                 InName(obj.entry); tag := DevCPM.SymRInt()
1068                         END;
1069                         IF tag >= Sxpro THEN
1070                                 IF obj.conval = NIL THEN obj.conval := NewConst() END;
1071                                 obj.conval.intval := -1;
1072                                 InSign(mno, obj.typ, obj.link);
1073                                 CASE tag OF
1074                                 | Sxpro: obj.mode := XProc
1075                                 | Sipro: obj.mode := IProc
1076                                 | Scpro: obj.mode := CProc;
1077                                         s := DevCPM.SymRInt();
1078                                         NEW(ext, s + 1); obj.conval.ext := ext;
1079                                         ext^[0] := SHORT(CHR(s)); i := 1;
1080                                         WHILE i <= s DO DevCPM.SymRCh(ext^[i]); INC(i) END
1081                                 END
1082                         ELSIF tag = Salias THEN
1083                                 obj.mode := Typ; InStruct(obj.typ)
1084                         ELSIF (tag = Svar) OR (tag = Srvar) THEN
1085                                 obj.mode := Var;
1086                                 IF tag = Srvar THEN obj.vis := externalR END ;
1087                                 InStruct(obj.typ)
1088                         ELSE    (* Constant *)
1089                                 obj.conval := NewConst(); InConstant(tag, obj.conval);
1090                                 IF (tag = Int8) OR (tag = Int16) THEN tag := Int32 END;
1091                                 obj.mode := Con; obj.typ := impCtxt.ref[tag];
1092                         END ;
1093                         InName(obj.name)
1094                 END ;
1095                 FPrintObj(obj);
1096                 IF (obj.mode = Var) & ((obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null)) THEN
1097                         (* compute a global fingerprint to avoid structural type equivalence for anonymous types *)
1098                         DevCPM.FPrint(impCtxt.reffp, obj.typ.ref - maxStruct)
1099                 END ;
1100                 IF tag # Stype THEN
1101                         InsertIn(obj, GlbMod[mno], old);
1102                         IF impCtxt.self THEN
1103                                 IF old # NIL THEN
1104                                         (* obj is from old symbol file, old is new declaration *)
1105                                         IF old.vis = internal THEN old.history := removed
1106                                         ELSE FPrintObj(old); FPrintStr(old.typ);        (* FPrint(obj) already called *)
1107                                                 IF obj.fprint # old.fprint THEN old.history := pbmodified
1108                                                 ELSIF obj.typ.pvfp # old.typ.pvfp THEN old.history := pvmodified
1109                                                 ELSE old.history := same
1110                                                 END
1111                                         END
1112                                 ELSE obj.history := removed     (* OutObj not called if mnolev < 0 *)
1113                                 END
1114                         (* ELSE old = NIL, or file read twice, consistent, OutObj not called *)
1115                         END
1116                 ELSE    (* obj already inserted in InStruct *)
1117                         IF impCtxt.self THEN    (* obj.mnolev = 0 *)
1118                                 IF obj.vis = internal THEN obj.history := removed
1119                                 ELSIF obj.history = inserted THEN obj.history := same
1120                                 END
1121                         (* ELSE OutObj not called for obj with mnolev < 0 *)
1122                         END
1123                 END ;
1124                 RETURN obj
1125         END InObj;
1126
1127         PROCEDURE Import*(aliasName: Name; VAR name: Name; VAR done: BOOLEAN);
1128                 VAR obj, h: Object; mno: BYTE; tag, p: INTEGER; lib: String;    (* done used in Browser *)
1129         BEGIN
1130                 IF name = "SYSTEM" THEN
1131                         SYSimported := TRUE;
1132                         p := processor;
1133                         IF (p < 10) OR (p > 30) THEN p := DevCPM.sysImp END;
1134                         INCL(DevCPM.options, p);        (* for sysflag handling *)
1135                         Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := syslink; obj.typ := notyp;
1136                         h := NewObj(); h.mode := Head; h.right := syslink; obj.scope := h
1137                 ELSIF name = "COM" THEN
1138                         IF DevCPM.comAware IN DevCPM.options THEN
1139                                 INCL(DevCPM.options, DevCPM.com);       (* for sysflag handling *)
1140                                 Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := comlink; obj.typ := notyp;
1141                                 h := NewObj(); h.mode := Head; h.right := comlink; obj.scope := h;
1142                         ELSE err(151)
1143                         END;
1144                 ELSIF name = "JAVA" THEN
1145                         INCL(DevCPM.options, DevCPM.java)
1146                 ELSE
1147                         impCtxt.nofr := FirstRef; impCtxt.minr := maxStruct; impCtxt.nofm := 0;
1148                         impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0;
1149                         DevCPM.OldSym(name, done);
1150                         IF done THEN
1151                                 lib := NIL;
1152                                 impProc := SHORT(DevCPM.SymRInt());
1153                                 IF (impProc # 0) & (processor # 0) & (impProc # processor) THEN err(151) END;
1154                                 DevCPM.checksum := 0;   (* start checksum here to avoid problems with proc id fixup *)
1155                                 tag := DevCPM.SymRInt();
1156                                 IF tag < Smname THEN version := tag; tag := DevCPM.SymRInt()
1157                                 ELSE version := 0
1158                                 END;
1159                                 IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END;
1160                                 InMod(tag, mno);
1161                                 IF (name[0] # "@") & (GlbMod[mno].name^ # name) THEN    (* symbol file name conflict *)
1162                                         GlbMod[mno] := NIL; nofGmod := mno; DEC(impCtxt.nofm);
1163                                         DevCPM.CloseOldSym; done := FALSE
1164                                 END;
1165                         END;
1166                         IF done THEN
1167                                 GlbMod[mno].library := lib;
1168                                 impCtxt.nextTag := DevCPM.SymRInt();
1169                                 WHILE ~DevCPM.eofSF() DO
1170                                         obj := InObj(mno); impCtxt.nextTag := DevCPM.SymRInt()
1171                                 END ;
1172                                 Insert(aliasName, obj);
1173                                 obj.mode := Mod; obj.scope := GlbMod[mno](*.right*);
1174                                 GlbMod[mno].link := obj;
1175                                 obj.mnolev  := SHORT(SHORT(-mno)); obj.typ := notyp;
1176                                 DevCPM.CloseOldSym
1177                         ELSIF impCtxt.self THEN
1178                                 sfpresent := FALSE
1179                         ELSE err(152)   (*sym file not found*)
1180                         END
1181                 END
1182         END Import;
1183
1184 (*-------------------------- Export --------------------------*)
1185
1186         PROCEDURE OutName(VAR name: ARRAY OF SHORTCHAR);
1187                 VAR i: SHORTINT; ch: SHORTCHAR;
1188         BEGIN i := 0;
1189                 REPEAT ch := name[i]; DevCPM.SymWCh(ch); INC(i) UNTIL ch = 0X
1190         END OutName;
1191
1192         PROCEDURE OutMod(mno: SHORTINT);
1193                 VAR mod: Object;
1194         BEGIN
1195                 IF expCtxt.locmno[mno] < 0 THEN (* new mod *)
1196                         mod := GlbMod[mno];
1197                         IF mod.library # NIL THEN
1198                                 DevCPM.SymWInt(Slib); OutName(mod.library^)
1199                         END;
1200                         DevCPM.SymWInt(Smname);
1201                         expCtxt.locmno[mno] := expCtxt.nofm; INC(expCtxt.nofm);
1202                         OutName(mod.name^)
1203                 ELSE DevCPM.SymWInt(-expCtxt.locmno[mno])
1204                 END
1205         END OutMod;
1206
1207         PROCEDURE ^OutStr(typ: Struct);
1208         PROCEDURE ^OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);
1209
1210         PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: INTEGER);
1211                 VAR i, j, n: INTEGER; btyp: Struct;
1212         BEGIN
1213                 IF typ.comp = Record THEN OutFlds(typ.link, adr, FALSE)
1214                 ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n;
1215                         WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
1216                         IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN
1217                                 j := nofhdfld; OutHdFld(btyp, fld, adr);
1218                                 IF j # nofhdfld THEN i := 1;
1219                                         WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO  (* !!! *)
1220                                                 INC(adr, btyp.size); OutHdFld(btyp, fld, adr); INC(i)
1221                                         END
1222                                 END
1223                         END
1224                 ELSIF DevCPM.ExpHdPtrFld &
1225                         ((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN   (* !!! *)
1226                         DevCPM.SymWInt(Shdptr); DevCPM.SymWInt(adr); INC(nofhdfld)
1227                 ELSIF DevCPM.ExpHdUtPtrFld &
1228                         ((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN  (* !!! *)
1229                         DevCPM.SymWInt(Ssys);   (* DevCPM.SymWInt(Shdutptr); *)
1230                         IF typ.form = Pointer THEN n := typ.sysflag ELSE n := fld.sysflag END;
1231                         DevCPM.SymWInt(n);
1232                         DevCPM.SymWInt(adr); INC(nofhdfld);
1233                         IF n > 1 THEN portable := FALSE END     (* hidden untagged pointer are portable *)
1234                 ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN
1235                         DevCPM.SymWInt(Shdpro); DevCPM.SymWInt(adr); INC(nofhdfld)
1236                 END
1237         END OutHdFld;
1238
1239         PROCEDURE OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);
1240         BEGIN
1241                 WHILE (fld # NIL) & (fld.mode = Fld) DO
1242                         IF (fld.vis # internal) & visible THEN
1243                                 IF fld.vis = externalR THEN DevCPM.SymWInt(Srfld) ELSE DevCPM.SymWInt(Sfld) END ;
1244                                 OutStr(fld.typ); OutName(fld.name^); DevCPM.SymWInt(fld.adr)
1245                         ELSE OutHdFld(fld.typ, fld, fld.adr + adr)
1246                         END ;
1247                         fld := fld.link
1248                 END
1249         END OutFlds;
1250
1251         PROCEDURE OutSign(result: Struct; par: Object);
1252         BEGIN
1253                 OutStr(result);
1254                 WHILE par # NIL DO
1255                         IF par.sysflag # 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(par.sysflag) END;
1256                         IF par.mode = Var THEN DevCPM.SymWInt(Svalpar)
1257                         ELSIF par.vis = inPar THEN DevCPM.SymWInt(Sinpar)
1258                         ELSIF par.vis = outPar THEN DevCPM.SymWInt(Soutpar)
1259                         ELSE DevCPM.SymWInt(Svarpar)
1260                         END ;
1261                         OutStr(par.typ);
1262                         DevCPM.SymWInt(par.adr);
1263                         OutName(par.name^); par := par.link
1264                 END ;
1265                 DevCPM.SymWInt(Send)
1266         END OutSign;
1267
1268         PROCEDURE OutTProcs(typ: Struct; obj: Object);
1269                 VAR bObj: Object;
1270         BEGIN
1271                 IF obj # NIL THEN
1272                         IF obj.mode = TProc THEN
1273 (*
1274                                 IF (typ.BaseTyp # NIL) & (obj.num < typ.BaseTyp.n) & (obj.vis = internal) & (obj.scope # NIL) THEN
1275                                         FindBaseField(obj.name^, typ, bObj);
1276                                         ASSERT((bObj # NIL) & (bObj.num = obj.num));
1277                                         IF bObj.vis # internal THEN DevCPM.Mark(109, typ.txtpos) END
1278                                         (* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *)
1279                                 END;
1280 *)
1281                                 IF obj.vis # internal THEN
1282                                         IF obj.vis = externalR THEN DevCPM.SymWInt(Simpo) END;
1283                                         IF obj.entry # NIL THEN
1284                                                 DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE
1285                                         END;
1286                                         IF limAttr IN obj.conval.setval THEN DevCPM.SymWInt(Slimpro)
1287                                         ELSIF absAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sabspro)
1288                                         ELSIF empAttr IN obj.conval.setval THEN DevCPM.SymWInt(Semppro)
1289                                         ELSIF extAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sextpro)
1290                                         ELSE DevCPM.SymWInt(Stpro)
1291                                         END;
1292                                         OutSign(obj.typ, obj.link); OutName(obj.name^);
1293                                         DevCPM.SymWInt(obj.num)
1294                                 ELSIF DevCPM.ExpHdTProc THEN
1295                                         DevCPM.SymWInt(Shdtpro);
1296                                         DevCPM.SymWInt(obj.num)
1297                                 END
1298                         END;
1299                         OutTProcs(typ, obj.left);
1300                         OutTProcs(typ, obj.right)
1301                 END
1302         END OutTProcs;
1303
1304         PROCEDURE OutStr(typ: Struct);  (* OPV.TypeAlloc already applied *)
1305                 VAR strobj: Object;
1306         BEGIN
1307                 IF typ.ref < expCtxt.ref THEN DevCPM.SymWInt(-typ.ref)
1308                 ELSE
1309                         DevCPM.SymWInt(Sstruct);
1310                         typ.ref := expCtxt.ref; INC(expCtxt.ref);
1311                         IF expCtxt.ref >= maxStruct THEN err(228) END ;
1312                         OutMod(typ.mno); strobj := typ.strobj;
1313                         IF (strobj # NIL) & (strobj.name # null) THEN OutName(strobj.name^);
1314                                 CASE strobj.history OF
1315                                 | pbmodified: FPrintErr(strobj, 252)
1316                                 | pvmodified: FPrintErr(strobj, 251)
1317                                 | inconsistent: FPrintErr(strobj, 249)
1318                                 ELSE (* checked in OutObj or correct indirect export *)
1319                                 END
1320                         ELSE DevCPM.SymWCh(0X)  (* anonymous => never inconsistent, pvfp influences the client fp *)
1321                         END;
1322                         IF typ.sysflag # 0 THEN (* !!! *)
1323                                 DevCPM.SymWInt(Ssys); DevCPM.SymWInt(typ.sysflag);
1324                                 IF typ.sysflag > 0 THEN portable := FALSE END
1325                         END;
1326                         IF strobj # NIL THEN
1327                                 IF strobj.library # NIL THEN
1328                                         DevCPM.SymWInt(Slib); OutName(strobj.library^); portable := FALSE
1329                                 END;
1330                                 IF strobj.entry # NIL THEN
1331                                         DevCPM.SymWInt(Sentry); OutName(strobj.entry^); portable := FALSE
1332                                 END
1333                         END;
1334                         IF typ.ext # NIL THEN
1335                                 DevCPM.SymWInt(String8); OutName(typ.ext^); portable := FALSE
1336                         END;
1337                         CASE typ.form OF
1338                         | Pointer:
1339                                 DevCPM.SymWInt(Sptr); OutStr(typ.BaseTyp)
1340                         | ProcTyp:
1341                                 DevCPM.SymWInt(Spro); OutSign(typ.BaseTyp, typ.link)
1342                         | Comp:
1343                                 CASE typ.comp OF
1344                                 | Array:
1345                                         DevCPM.SymWInt(Sarr); OutStr(typ.BaseTyp); DevCPM.SymWInt(typ.n)
1346                                 | DynArr:
1347                                         DevCPM.SymWInt(Sdarr); OutStr(typ.BaseTyp)
1348                                 | Record:
1349                                         IF typ.attribute = limAttr THEN DevCPM.SymWInt(Slimrec)
1350                                         ELSIF typ.attribute = absAttr THEN DevCPM.SymWInt(Sabsrec)
1351                                         ELSIF typ.attribute = extAttr THEN DevCPM.SymWInt(Sextrec)
1352                                         ELSE DevCPM.SymWInt(Srec)
1353                                         END;
1354                                         IF typ.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ.BaseTyp) END ;
1355                                         (* BaseTyp should be Notyp, too late to change *)
1356                                         DevCPM.SymWInt(typ.size); DevCPM.SymWInt(typ.align); DevCPM.SymWInt(typ.n);
1357                                         nofhdfld := 0; OutFlds(typ.link, 0, TRUE);
1358 (*
1359                                         IF nofhdfld > DevCPM.MaxHdFld THEN DevCPM.Mark(223, typ.txtpos) END ;   (* !!! *)
1360 *)
1361                                         OutTProcs(typ, typ.link); DevCPM.SymWInt(Send)
1362                                 END
1363                         ELSE    (* alias structure *)
1364                                 DevCPM.SymWInt(Salias); OutStr(typ.BaseTyp)
1365                         END
1366                 END
1367         END OutStr;
1368
1369         PROCEDURE OutConstant(obj: Object);
1370                 VAR f, i: SHORTINT; rval: SHORTREAL; a, b, c: INTEGER; r: REAL;
1371         BEGIN
1372                 f := obj.typ.form;
1373 (*
1374                 IF obj.typ = guidtyp THEN f := Guid END;
1375 *)
1376                 IF f = Int32 THEN
1377                         IF (obj.conval.intval >= -128) & (obj.conval.intval <= -127) THEN f := Int8
1378                         ELSIF (obj.conval.intval >= -32768) & (obj.conval.intval <= -32767) THEN f := Int16
1379                         END
1380                 END;
1381                 DevCPM.SymWInt(f);
1382                 CASE f OF
1383                 | Bool, Char8:
1384                         DevCPM.SymWCh(SHORT(CHR(obj.conval.intval)))
1385                 | Char16:
1386                         DevCPM.SymWCh(SHORT(CHR(obj.conval.intval MOD 256)));
1387                         DevCPM.SymWCh(SHORT(CHR(obj.conval.intval DIV 256)))
1388                 | Int8, Int16, Int32:
1389                         DevCPM.SymWInt(obj.conval.intval)
1390                 | Int64:
1391                         IF ABS(obj.conval.realval + obj.conval.intval) <= MAX(INTEGER) THEN
1392                                 a := SHORT(ENTIER(obj.conval.realval + obj.conval.intval)); b := -1; c := -1
1393                         ELSIF ABS(obj.conval.realval + obj.conval.intval) <= 1125899906842624.0 (*2^50*) THEN
1394                                 a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) /  2097152.0 (*2^21*)));
1395                                 b := SHORT(ENTIER(obj.conval.realval + obj.conval.intval - a * 2097152.0 (*2^21*))); c := -1
1396                         ELSE
1397                                 a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4398046511104.0 (*2^42*)));
1398                                 r := obj.conval.realval + obj.conval.intval - a * 4398046511104.0 (*2^42*);
1399                                 b := SHORT(ENTIER(r /  2097152.0 (*2^21*)));
1400                                 c := SHORT(ENTIER(r - b * 2097152.0 (*2^21*)))
1401                         END;
1402                         IF c >= 0 THEN
1403                                 DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128;
1404                                 DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128;
1405                                 DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128)))
1406                         END;
1407                         IF b >= 0 THEN
1408                                 DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128;
1409                                 DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128;
1410                                 DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128)))
1411                         END;
1412                         DevCPM.SymWInt(a)
1413                 | Set:
1414                         DevCPM.SymWSet(obj.conval.setval)
1415                 | Real32:
1416                         rval := SHORT(obj.conval.realval); DevCPM.SymWReal(rval)
1417                 | Real64:
1418                         DevCPM.SymWLReal(obj.conval.realval)
1419                 | String8, String16:
1420                         OutName(obj.conval.ext^)
1421                 | NilTyp:
1422 (*
1423                 | Guid:
1424                         i := 0;
1425                         WHILE i < 16 DO DevCPM.SymWCh(obj.conval.ext[i]); INC(i) END
1426 *)
1427                 ELSE err(127)
1428                 END
1429         END OutConstant;
1430
1431         PROCEDURE OutObj(obj: Object);
1432                 VAR i, j: SHORTINT; ext: ConstExt;
1433         BEGIN
1434                 IF obj # NIL THEN
1435                         OutObj(obj.left);
1436                         IF obj.mode IN {Con, Typ, Var, LProc, XProc, CProc, IProc} THEN
1437                                 IF obj.history = removed THEN FPrintErr(obj, 250)
1438                                 ELSIF obj.vis # internal THEN
1439                                         CASE obj.history OF
1440                                         | inserted: FPrintErr(obj, 253)
1441                                         | same: (* ok *)
1442                                         | pbmodified:
1443                                                 IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 252) END
1444                                         | pvmodified:
1445                                                 IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 251) END
1446                                         END ;
1447                                         IF obj.sysflag < 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(obj.sysflag); portable := FALSE END;
1448                                         IF obj.mode IN {LProc, XProc, CProc, Var, Con} THEN
1449                                                 (* name alias for types handled in OutStr *)
1450                                                 IF obj.library # NIL THEN
1451                                                         DevCPM.SymWInt(Slib); OutName(obj.library^); portable := FALSE
1452                                                 END;
1453                                                 IF obj.entry # NIL THEN
1454                                                         DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE
1455                                                 END
1456                                         END;
1457                                         CASE obj.mode OF
1458                                         | Con:
1459                                                 OutConstant(obj); OutName(obj.name^)
1460                                         | Typ:
1461                                                 IF obj.typ.strobj = obj THEN DevCPM.SymWInt(Stype); OutStr(obj.typ)
1462                                                 ELSE DevCPM.SymWInt(Salias); OutStr(obj.typ); OutName(obj.name^)
1463                                                 END
1464                                         | Var:
1465                                                 IF obj.vis = externalR THEN DevCPM.SymWInt(Srvar) ELSE DevCPM.SymWInt(Svar) END ;
1466                                                 OutStr(obj.typ); OutName(obj.name^);
1467                                                 IF (obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null) THEN
1468                                                         (* compute fingerprint to avoid structural type equivalence *)
1469                                                         DevCPM.FPrint(expCtxt.reffp, obj.typ.ref)
1470                                                 END
1471                                         | XProc:
1472                                                 DevCPM.SymWInt(Sxpro); OutSign(obj.typ, obj.link); OutName(obj.name^)
1473                                         | IProc:
1474                                                 DevCPM.SymWInt(Sipro); OutSign(obj.typ, obj.link); OutName(obj.name^)
1475                                         | CProc:
1476                                                 DevCPM.SymWInt(Scpro); OutSign(obj.typ, obj.link); ext := obj.conval.ext;
1477                                                 j := ORD(ext^[0]); i := 1; DevCPM.SymWInt(j);
1478                                                 WHILE i <= j DO DevCPM.SymWCh(ext^[i]); INC(i) END ;
1479                                                 OutName(obj.name^); portable := FALSE
1480                                         END
1481                                 END
1482                         END ;
1483                         OutObj(obj.right)
1484                 END
1485         END OutObj;
1486
1487         PROCEDURE Export*(VAR ext, new: BOOLEAN);
1488                         VAR i: SHORTINT; nofmod: BYTE; done: BOOLEAN; old: Object; oldCSum: INTEGER;
1489         BEGIN
1490                 symExtended := FALSE; symNew := FALSE; nofmod := nofGmod;
1491                 Import("@self", SelfName, done); nofGmod := nofmod;
1492                 oldCSum := DevCPM.checksum;
1493                 ASSERT(GlbMod[0].name^ = SelfName);
1494                 IF DevCPM.noerr THEN    (* ~DevCPM.noerr => ~done *)
1495                         DevCPM.NewSym(SelfName);
1496                         IF DevCPM.noerr THEN
1497                                 DevCPM.SymWInt(0);      (* portable symfile *)
1498                                 DevCPM.checksum := 0;   (* start checksum here to avoid problems with proc id fixup *)
1499                                 DevCPM.SymWInt(actVersion);
1500                                 old := GlbMod[0]; portable := TRUE;
1501                                 IF libName # "" THEN
1502                                         DevCPM.SymWInt(Slib); OutName(libName); portable := FALSE;
1503                                         IF done & ((old.library = NIL) OR (old.library^ # libName)) THEN
1504                                                 FPrintErr(NIL, 252)
1505                                         END
1506                                 ELSIF done & (old.library # NIL) THEN FPrintErr(NIL, 252)
1507                                 END;
1508                                 DevCPM.SymWInt(Smname); OutName(SelfName);
1509                                 expCtxt.reffp := 0; expCtxt.ref := FirstRef;
1510                                 expCtxt.nofm := 1; expCtxt.locmno[0] := 0;
1511                                 i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END ;
1512                                 OutObj(topScope.right);
1513                                 ext := sfpresent & symExtended;
1514                                 new := ~sfpresent OR symNew OR (DevCPM.checksum # oldCSum);
1515                                 IF DevCPM.noerr & ~portable THEN
1516                                         DevCPM.SymReset;
1517                                         DevCPM.SymWInt(processor)       (* nonportable symfile *)
1518                                 END;
1519                                 IF DevCPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN
1520                                         new := TRUE
1521                                 END ;
1522                                 IF ~DevCPM.noerr THEN DevCPM.DeleteNewSym END
1523                                 (* DevCPM.RegisterNewSym is called in OP2 after writing the object file *)
1524                         END
1525                 END
1526         END Export;     (* no new symbol file if ~DevCPM.noerr *)
1527
1528
1529         PROCEDURE InitStruct(VAR typ: Struct; form: BYTE);
1530         BEGIN
1531                 typ := NewStr(form, Basic); typ.ref := form; typ.size := 1; typ.allocated := TRUE;
1532                 typ.strobj := NewObj(); typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE;
1533                 typ.idfp := form; typ.idfpdone := TRUE
1534         END InitStruct;
1535
1536         PROCEDURE EnterBoolConst(name: Name; val: INTEGER);
1537                 VAR obj: Object;
1538         BEGIN
1539                 Insert(name, obj); obj.conval := NewConst();
1540                 obj.mode := Con; obj.typ := booltyp; obj.conval.intval := val
1541         END EnterBoolConst;
1542
1543         PROCEDURE EnterRealConst(name: Name; val: REAL; VAR obj: Object);
1544         BEGIN
1545                 Insert(name, obj); obj.conval := NewConst();
1546                 obj.mode := Con; obj.typ := real32typ; obj.conval.realval := val
1547         END EnterRealConst;
1548
1549         PROCEDURE EnterTyp(name: Name; form: BYTE; size: SHORTINT; VAR res: Struct);
1550                 VAR obj: Object; typ: Struct;
1551         BEGIN
1552                 Insert(name, obj);
1553                 typ := NewStr(form, Basic); obj.mode := Typ; obj.typ := typ; obj.vis := external;
1554                 typ.strobj := obj; typ.size := size; typ.ref := form; typ.allocated := TRUE;
1555                 typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE;
1556                 typ.idfp := form; typ.idfpdone := TRUE; res := typ
1557         END EnterTyp;
1558
1559         PROCEDURE EnterProc(name: Name; num: SHORTINT);
1560                 VAR obj: Object;
1561         BEGIN Insert(name, obj);
1562                 obj.mode := SProc; obj.typ := notyp; obj.adr := num
1563         END EnterProc;
1564
1565         PROCEDURE EnterAttr(name: Name; num: SHORTINT);
1566                 VAR obj: Object;
1567         BEGIN Insert(name, obj);
1568                 obj.mode := Attr; obj.adr := num
1569         END EnterAttr;
1570
1571         PROCEDURE EnterTProc(ptr, rec: Struct; name: Name; num, typ: SHORTINT);
1572                 VAR obj, par: Object;
1573         BEGIN
1574                 InsertField(name, rec, obj);
1575                 obj.mnolev := -128;     (* for correct implement only behaviour *)
1576                 obj.mode := TProc; obj.num := num; obj.conval := NewConst();
1577                 obj.conval.setval := obj.conval.setval + {newAttr};
1578                 IF typ = 0 THEN (* FINALIZE, RELEASE *)
1579                         obj.typ := notyp; obj.vis := externalR;
1580                         INCL(obj.conval.setval, empAttr)
1581                 ELSIF typ = 1 THEN      (* QueryInterface *)
1582                         par := NewObj(); par.name := NewName("int"); par.mode := VarPar; par.vis := outPar;
1583                         par.sysflag := 8; par.adr := 16; par.typ := punktyp;
1584                         par.link := obj.link; obj.link := par;
1585                         par := NewObj(); par.name := NewName("iid"); par.mode := VarPar; par.vis := inPar;
1586                         par.sysflag := 16; par.adr := 12; par.typ := guidtyp;
1587                         par.link := obj.link; obj.link := par;
1588                         obj.typ := restyp; obj.vis := external;
1589                         INCL(obj.conval.setval, extAttr)
1590                 ELSIF typ = 2 THEN      (* AddRef, Release *)
1591                         obj.typ := notyp; obj.vis := externalR;
1592                         INCL(obj.conval.setval, isHidden);
1593                         INCL(obj.conval.setval, extAttr)
1594                 END;
1595                 par := NewObj(); par.name := NewName("this"); par.mode := Var;
1596                 par.adr := 8; par.typ := ptr;
1597                 par.link := obj.link; obj.link := par;
1598         END EnterTProc;
1599
1600         PROCEDURE EnterHdField(VAR root: Object; offs: SHORTINT);
1601                 VAR obj: Object;
1602         BEGIN
1603                 obj := NewObj(); obj.mode := Fld;
1604                 obj.name := NewName(DevCPM.HdPtrName); obj.typ := undftyp; obj.adr := offs;
1605                 obj.link := root; root := obj
1606         END EnterHdField;
1607
1608 BEGIN
1609         NEW(null, 1); null^ := "";
1610         topScope := NIL; OpenScope(0, NIL); DevCPM.errpos := 0;
1611         InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp);
1612         InitStruct(string8typ, String8); InitStruct(niltyp, NilTyp); niltyp.size := DevCPM.PointerSize;
1613         InitStruct(string16typ, String16);
1614         undftyp.BaseTyp := undftyp;
1615
1616         (*initialization of module SYSTEM*)
1617 (*
1618         EnterTyp("BYTE", Byte, 1, bytetyp);
1619         EnterProc("NEW", sysnewfn);
1620 *)
1621         EnterTyp("PTR", Pointer, DevCPM.PointerSize, sysptrtyp);
1622         EnterProc("ADR", adrfn);
1623         EnterProc("TYP", typfn);
1624         EnterProc("CC", ccfn);
1625         EnterProc("LSH", lshfn);
1626         EnterProc("ROT", rotfn);
1627         EnterProc("GET", getfn);
1628         EnterProc("PUT", putfn);
1629         EnterProc("GETREG", getrfn);
1630         EnterProc("PUTREG", putrfn);
1631         EnterProc("BIT", bitfn);
1632         EnterProc("VAL", valfn);
1633         EnterProc("MOVE", movefn);
1634         EnterProc("THISRECORD", thisrecfn);
1635         EnterProc("THISARRAY", thisarrfn);
1636         syslink := topScope.right; topScope.right := NIL;
1637
1638         (* initialization of module COM *)
1639         EnterProc("ID", iidfn);
1640         EnterProc("QUERY", queryfn);
1641         EnterTyp("RESULT", Int32, 4, restyp);
1642         restyp.ref := Res;
1643         EnterTyp("GUID", Guid, 16, guidtyp);
1644         guidtyp.form := Comp; guidtyp.comp := Array; guidtyp.n := 16;
1645         EnterTyp("IUnknown^", IUnk, 12, iunktyp);
1646         iunktyp.form := Comp; iunktyp.comp := Record; iunktyp.n := 3;
1647         iunktyp.attribute := absAttr;
1648 (*
1649         EnterHdField(iunktyp.link, 12);
1650 *)
1651         iunktyp.BaseTyp := NIL; iunktyp.align := 4;
1652         iunktyp.sysflag := interface; iunktyp.untagged := TRUE;
1653         NEW(iunktyp.ext, 40); iunktyp.ext^ := "{00000000-0000-0000-C000-000000000046}";
1654         EnterTyp("IUnknown", PUnk, DevCPM.PointerSize, punktyp);
1655         punktyp.form := Pointer; punktyp.BaseTyp := iunktyp;
1656         punktyp.sysflag := interface; punktyp.untagged := TRUE;
1657         EnterTProc(punktyp, iunktyp, "QueryInterface", 0, 1);
1658         EnterTProc(punktyp, iunktyp, "AddRef", 1, 2);
1659         EnterTProc(punktyp, iunktyp, "Release", 2, 2);
1660         comlink := topScope.right; topScope.right := NIL;
1661
1662         universe := topScope;
1663         EnterProc("LCHR", lchrfn);
1664         EnterProc("LENTIER", lentierfcn);
1665         EnterTyp("ANYREC", AnyRec, 0, anytyp);
1666         anytyp.form := Comp; anytyp.comp := Record; anytyp.n := 1;
1667         anytyp.BaseTyp := NIL; anytyp.extlev := -1;     (* !!! *)
1668         anytyp.attribute := absAttr;
1669         EnterTyp("ANYPTR", AnyPtr, DevCPM.PointerSize, anyptrtyp);
1670         anyptrtyp.form := Pointer; anyptrtyp.BaseTyp := anytyp;
1671         EnterTProc(anyptrtyp, anytyp, "FINALIZE", 0, 0);
1672         EnterTProc(anyptrtyp, iunktyp, "RELEASE", 1, 0);
1673         EnterProc("VALID", validfn);
1674
1675         EnterTyp("SHORTCHAR", Char8, 1, char8typ);
1676         string8typ.BaseTyp := char8typ;
1677         EnterTyp("CHAR", Char16, 2, char16typ);
1678         EnterTyp("LONGCHAR", Char16, 2, lchar16typ);
1679         string16typ.BaseTyp := char16typ;
1680         EnterTyp("SET", Set, 4, settyp);
1681         EnterTyp("BYTE", Int8, 1, int8typ);
1682         guidtyp.BaseTyp := int8typ;
1683         EnterTyp("SHORTINT", Int16, 2, int16typ);
1684         EnterTyp("INTEGER",  Int32, 4, int32typ);
1685         EnterTyp("LONGINT", Int64, 8, int64typ);
1686         EnterTyp("LARGEINT", Int64, 8, lint64typ);
1687         EnterTyp("SHORTREAL", Real32, 4, real32typ);
1688         EnterTyp("REAL", Real64, 8, real64typ);
1689         EnterTyp("LONGREAL", Real64, 8, lreal64typ);
1690         EnterTyp("BOOLEAN", Bool, 1, booltyp);
1691         EnterBoolConst("FALSE", 0);     (* 0 and 1 are compiler internal representation only *)
1692         EnterBoolConst("TRUE",  1);
1693         EnterRealConst("INF", DevCPM.InfReal, infinity);
1694         EnterProc("HALT", haltfn);
1695         EnterProc("NEW", newfn);
1696         EnterProc("ABS", absfn);
1697         EnterProc("CAP", capfn);
1698         EnterProc("ORD", ordfn);
1699         EnterProc("ENTIER", entierfn);
1700         EnterProc("ODD", oddfn);
1701         EnterProc("MIN", minfn);
1702         EnterProc("MAX", maxfn);
1703         EnterProc("CHR", chrfn);
1704         EnterProc("SHORT", shortfn);
1705         EnterProc("LONG", longfn);
1706         EnterProc("SIZE", sizefn);
1707         EnterProc("INC", incfn);
1708         EnterProc("DEC", decfn);
1709         EnterProc("INCL", inclfn);
1710         EnterProc("EXCL", exclfn);
1711         EnterProc("LEN", lenfn);
1712         EnterProc("COPY", copyfn);
1713         EnterProc("ASH", ashfn);
1714         EnterProc("ASSERT", assertfn);
1715 (*
1716         EnterProc("ADR", adrfn);
1717         EnterProc("TYP", typfn);
1718 *)
1719         EnterProc("BITS", bitsfn);
1720         EnterAttr("ABSTRACT", absAttr);
1721         EnterAttr("LIMITED", limAttr);
1722         EnterAttr("EMPTY", empAttr);
1723         EnterAttr("EXTENSIBLE", extAttr);
1724         NEW(intrealtyp); intrealtyp^ := real64typ^;
1725         impCtxt.ref[Undef] := undftyp; impCtxt.ref[Byte] := bytetyp;
1726         impCtxt.ref[Bool] := booltyp;  impCtxt.ref[Char8] := char8typ;
1727         impCtxt.ref[Int8] := int8typ;  impCtxt.ref[Int16] := int16typ;
1728         impCtxt.ref[Int32] := int32typ;  impCtxt.ref[Real32] := real32typ;
1729         impCtxt.ref[Real64] := real64typ;  impCtxt.ref[Set] := settyp;
1730         impCtxt.ref[String8] := string8typ; impCtxt.ref[NilTyp] := niltyp;
1731         impCtxt.ref[NoTyp] := notyp; impCtxt.ref[Pointer] := sysptrtyp;
1732         impCtxt.ref[AnyPtr] := anyptrtyp; impCtxt.ref[AnyRec] := anytyp;
1733         impCtxt.ref[Char16] := char16typ; impCtxt.ref[String16] := string16typ;
1734         impCtxt.ref[Int64] := int64typ;
1735         impCtxt.ref[IUnk] := iunktyp; impCtxt.ref[PUnk] := punktyp;
1736         impCtxt.ref[Guid] := guidtyp; impCtxt.ref[Res] := restyp;
1737 END DevCPT.
1738
1739 Objects:
1740
1741     mode  | adr    conval  link     scope    leaf
1742    ------------------------------------------------
1743     Undef |                                         Not used
1744     Var   | vadr           next              regopt Glob or loc var or proc value parameter
1745     VarPar| vadr           next              regopt Var parameter (vis = 0 | inPar | outPar)
1746     Con   |        val                              Constant
1747     Fld   | off            next                     Record field
1748     Typ   |                                         Named type
1749     LProc | entry  sizes   firstpar scope    leaf   Local procedure, entry adr set in back-end
1750     XProc | entry  sizes   firstpar scope    leaf   External procedure, entry adr set in back-end
1751     SProc | fno    sizes                            Standard procedure
1752     CProc |        code    firstpar scope           Code procedure
1753     IProc | entry  sizes            scope    leaf   Interrupt procedure, entry adr set in back-end
1754     Mod   |                         scope           Module
1755     Head  | txtpos         owner    firstvar        Scope anchor
1756     TProc | entry  sizes   firstpar scope    leaf   Bound procedure, mthno = obj.num
1757
1758                 Structures:
1759
1760     form    comp  | n      BaseTyp   link     mno  txtpos   sysflag
1761         ----------------------------------------------------------------------------------
1762     Undef   Basic |
1763     Byte    Basic |
1764     Bool    Basic |
1765     Char8   Basic |
1766     Int8    Basic |
1767     Int16   Basic |
1768     Int32   Basic |
1769     Real32  Basic |
1770     Real64  Basic |
1771     Set     Basic |
1772     String8 Basic |
1773     NilTyp  Basic |
1774     NoTyp   Basic |
1775     Pointer Basic |        PBaseTyp           mno  txtpos   sysflag
1776     ProcTyp Basic |        ResTyp    params   mno  txtpos   sysflag
1777     Comp    Array | nofel  ElemTyp            mno  txtpos   sysflag
1778     Comp    DynArr| dim    ElemTyp            mno  txtpos   sysflag
1779     Comp    Record| nofmth RBaseTyp  fields   mno  txtpos   sysflag
1780     Char16  Basic |
1781     String16Basic |
1782     Int64   Basic |
1783
1784 Nodes:
1785
1786 design   = Nvar|Nvarpar|Nfield|Nderef|Nindex|Nguard|Neguard|Ntype|Nproc.
1787 expr     = design|Nconst|Nupto|Nmop|Ndop|Ncall.
1788 nextexpr = NIL|expr.
1789 ifstat   = NIL|Nif.
1790 casestat = Ncaselse.
1791 sglcase  = NIL|Ncasedo.
1792 stat     = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat|
1793            Nloop|Nexit|Nreturn|Nwith|Ntrap.
1794
1795
1796               class     subcl     obj      left      right     link
1797               ---------------------------------------------------------
1798
1799 design        Nvar                var                          nextexpr
1800               Nvarpar             varpar                       nextexpr
1801               Nfield              field    design              nextexpr
1802               Nderef    ptr/str            design              nextexpr
1803               Nindex                       design    expr      nextexpr
1804               Nguard                       design              nextexpr (typ = guard type)
1805               Neguard                      design              nextexpr (typ = guard type)
1806               Ntype               type                         nextexpr
1807               Nproc     normal    proc                         nextexpr
1808                         super     proc                         nextexpr
1809
1810
1811 expr          design
1812               Nconst              const                                 (val = node.conval)
1813               Nupto                        expr      expr      nextexpr
1814               Nmop      not                expr                nextexpr
1815                         minus              expr                nextexpr
1816                         is        tsttype  expr                nextexpr
1817                         conv               expr                nextexpr
1818                         abs                expr                nextexpr
1819                         cap                expr                nextexpr
1820                         odd                expr                nextexpr
1821                         bit                expr                nextexpr {x}
1822                         adr                expr                nextexpr SYSTEM.ADR
1823                         typ                expr                nextexpr SYSTEM.TYP
1824                         cc                 Nconst              nextexpr SYSTEM.CC
1825                         val                expr                nextexpr SYSTEM.VAL
1826               Ndop      times              expr      expr      nextexpr
1827                         slash              expr      expr      nextexpr
1828                         div                expr      expr      nextexpr
1829                         mod                expr      expr      nextexpr
1830                         and                expr      expr      nextexpr
1831                         plus               expr      expr      nextexpr
1832                         minus              expr      expr      nextexpr
1833                         or                 expr      expr      nextexpr
1834                         eql                expr      expr      nextexpr
1835                         neq                expr      expr      nextexpr
1836                         lss                expr      expr      nextexpr
1837                         leq                expr      expr      nextexpr
1838                         grt                expr      expr      nextexpr
1839                         geq                expr      expr      nextexpr
1840                         in                 expr      expr      nextexpr
1841                         ash                expr      expr      nextexpr
1842                         msk                expr      Nconst    nextexpr
1843                         len                design    Nconst    nextexpr
1844                         min                expr      expr      nextexpr MIN
1845                         max                expr      expr      nextexpr MAX
1846                         bit                expr      expr      nextexpr SYSTEM.BIT
1847                         lsh                expr      expr      nextexpr SYSTEM.LSH
1848                         rot                expr      expr      nextexpr SYSTEM.ROT
1849               Ncall               fpar     design    nextexpr  nextexpr
1850               Ncomp                        stat      expr      nextexpr
1851
1852 nextexpr      NIL
1853               expr
1854
1855 ifstat        NIL
1856               Nif                          expr      stat      ifstat
1857
1858 casestat      Ncaselse                     sglcase   stat           (minmax = node.conval)
1859
1860 sglcase       NIL
1861               Ncasedo                      Nconst    stat      sglcase
1862
1863 stat          NIL
1864               Ninittd                                          stat     (of node.typ)
1865               Nenter              proc     stat      stat      stat     (proc=NIL for mod)
1866               Nassign   assign             design    expr      stat
1867                         newfn              design    nextexp   stat
1868                         incfn              design    expr      stat
1869                         decfn              design    expr      stat
1870                         inclfn             design    expr      stat
1871                         exclfn             design    expr      stat
1872                         copyfn             design    expr      stat
1873                         getfn              design    expr      stat     SYSTEM.GET
1874                         putfn              expr      expr      stat     SYSTEM.PUT
1875                         getrfn             design    Nconst    stat     SYSTEM.GETREG
1876                         putrfn             Nconst    expr      stat     SYSTEM.PUTREG
1877                         sysnewfn           design    expr      stat     SYSTEM.NEW
1878                         movefn             expr      expr      stat     SYSTEM.MOVE
1879                                                                         (right.link = 3rd par)
1880               Ncall               fpar     design    nextexpr  stat
1881               Nifelse                      ifstat    stat      stat
1882               Ncase                        expr      casestat  stat
1883               Nwhile                       expr      stat      stat
1884               Nrepeat                      stat      expr      stat
1885               Nloop                        stat                stat
1886               Nexit                                            stat
1887               Nreturn             proc     nextexpr            stat     (proc = NIL for mod)
1888               Nwith                        ifstat    stat      stat
1889               Ntrap                                  expr      stat
1890               Ncomp                        stat      stat      stat