Trurl-based/Dev0/Mod/CPT.txt

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