home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / language / oberon / potsrc / src / mod / coct < prev    next >
Encoding:
Text File  |  1995-05-06  |  22.9 KB  |  744 lines
  1. MODULE COCT;  (*NW 28.5.87 / 5.3.91*) (* DVD 15 08 1993 15:33 *)
  2.  
  3.     IMPORT Files, COCS;
  4.  
  5.     CONST maxImps = 64; SFtag = 0FBX; firstStr = 16;
  6.             maxStr = 80; maxUDP = 16; maxMod = 32; maxParLev = 16; maxFldLev = 16;
  7.             NotYetExp = 0; PrivExp = -1;
  8.  
  9.         (* name resolution modes *)
  10.             ordObj = 0; stdObj = 1; sysObj = 2;
  11.  
  12.         (*object modes*)
  13.             Var = 1; Ind = 3; Con = 8; Fld = 12; Typ = 13;
  14.             XProc = 15; SProc = 16; CProc = 17; Mod = 19; Head = 20;
  15.  
  16.         (*structure forms*)
  17.             Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  18.             Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  19.             Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
  20.  
  21.     TYPE
  22.         Object* = POINTER TO ObjDesc;
  23.         Struct* = POINTER TO StrDesc;
  24.  
  25.         ObjDesc* = RECORD
  26.             dsc*, next*: Object;
  27.             typ*:  Struct;
  28.             mnolev*: INTEGER; (* name resolution mode for all types, level for heads, mno for modules *)
  29.             intval*: LONGINT; fltval*: LONGREAL; (* for modules and constants *)
  30.             mode*: SHORTINT;
  31.             marked*: BOOLEAN;
  32.             name*: ARRAY 32 OF CHAR;
  33.         END ;
  34.  
  35.         StrDesc* = RECORD
  36.             form*: SHORTINT;
  37.             mno*, ref*: INTEGER;
  38.             n*: LONGINT;
  39.             descr*: INTEGER; (* number of type descriptor for arrays and records; -1 = no descriptor *)
  40.             BaseTyp*: Struct;
  41.             link*, strobj*: Object
  42.         END;
  43.         (* size  field is thrown away because it's value isn't  needed
  44.             at compile time; at runtime sizeof(<typename>) is  sufficient *)
  45.  
  46.         Item* = RECORD
  47.             mode*: SHORTINT;
  48.             mnolev*: INTEGER;
  49.             intval*:LONGINT; fltval*:LONGREAL; (* for constants *)
  50.             qoffs*:INTEGER;  (* offset in SSeq *)
  51.             typ*: Struct;
  52.             obj*: Object
  53.         END;
  54.  
  55. (* pOt Cymbol File BNF
  56.  
  57. CymFile ::= SFtag ModuleAnchor Objects UndPtrs.
  58.  ModuleAnchor ::= 22 key:4 name.
  59.  Objects ::= {Object}.
  60.  Object ::= Con | Typ | Var | XProc | CProc.
  61.     Con ::= 1 (Byte|Bool|Char|SInt|Int|LInt|Set|Real|LReal|String|NilTyp) name:asciiz.
  62.      Byte ::= int:1.
  63.      Bool ::= int:1.
  64.      Char ::= int:1.
  65.      SInt ::= int:1.
  66.      Int ::= int:2.
  67.      LInt ::= int:4.
  68.      Set ::= int:4
  69.      Real ::= flt:4.
  70.      LReal ::= flt:8.
  71.      String ::= int:1 :asciiz.
  72.      NilType ::= .
  73.     Typ  ::= Str [2 ref mno name:asciiz].
  74.      Str ::= [[ModuleAnchor] (Pointer|ProcTyp|Array|DynArr|Record) [(2|3) strno mno name:asciiz]].
  75.         Pointer ::= 8 (ref | Undef) mno.
  76.         ProcTyp ::= Str(ret) Parameters 9 ref mno.
  77.          Parameters ::=  13 {Str (14|15) ref name:asciiz}.
  78.         Array ::= Str(base) 10 ref mno descr:2 n:4.
  79.         DynArr ::= Str(base) 11 ref mno.
  80.         Record ::= [Str(base)] Fields 12 ref mno descr:2.
  81.          Fields ::= [16] {(Str 17 ref name)|Fields|18}.
  82.     Var ::= Str 4 ref name.
  83.     XProc ::= Str(ret) Parameters 5 ref name.
  84.     CProc ::= Str(ret) Parameters 7 ref name.
  85.  UndPtrs ::=  {Str(base) 20 ref ref(base)}.
  86. *)
  87.  
  88.     VAR topScope*: Object;
  89.         undftyp*, bytetyp*, booltyp*, chartyp*, sinttyp*, inttyp*, linttyp*,
  90.         realtyp*, lrltyp*, settyp*, stringtyp*, niltyp*, notyp*: Struct;
  91.         nofGmod*: INTEGER;   (*nof imports*)
  92.         GlbMod*:  ARRAY maxImps OF Object;
  93.  
  94.         level*: INTEGER;
  95.         wasderef*: Object;
  96.         typchk*: BOOLEAN;
  97.  
  98.         universe, syslink: Object;
  99.         strno, udpinx: INTEGER;  (*for export*)
  100.         nofExp: SHORTINT;
  101.         SR: Files.Rider;
  102.         undPtr: ARRAY maxUDP OF Struct;
  103.  
  104.     PROCEDURE Init*;
  105.         VAR imod,iudp: INTEGER;
  106.     BEGIN
  107.         topScope := universe; level := 0; strno := 0; udpinx := 0; nofGmod := 0;
  108.         imod := 0; WHILE imod # maxImps DO GlbMod[imod] := NIL; INC(imod) END;
  109.         iudp := 0; WHILE iudp # maxUDP DO undPtr[iudp] := NIL; INC(iudp) END
  110.     END Init;
  111.  
  112.     PROCEDURE Close*;
  113.         VAR i: INTEGER;
  114.     BEGIN i := 0; WHILE i # maxImps DO GlbMod[i] := NIL; INC(i) END;
  115.         i := 0; WHILE i # maxUDP DO undPtr[i] := NIL; INC(i) END
  116.     END Close;
  117.  
  118.     PROCEDURE FindImport*(mod: Object; VAR res: Object);
  119.         VAR obj: Object;
  120.     BEGIN obj := mod.dsc;
  121.         WHILE (obj # NIL) & (obj.name # COCS.name) DO obj := obj.next END ;
  122.         IF (obj # NIL) & (obj.mode = Typ) & (~obj.marked) THEN obj := NIL END ;
  123.         res := obj
  124.     END FindImport;
  125.  
  126.     PROCEDURE Find*(VAR res: Object; VAR level: INTEGER);
  127.         VAR obj, head: Object;
  128.     BEGIN head := topScope;
  129.         LOOP obj := head.next; (* go up by levels *)
  130.             WHILE (obj # NIL) & (obj.name # COCS.name) DO obj := obj.next END ;
  131.             IF obj # NIL THEN level := SHORT(head.mnolev); EXIT END ;
  132.             head := head.dsc;
  133.             IF head = NIL THEN level := 0; EXIT END
  134.         END;
  135.         res := obj
  136.     END Find;
  137.  
  138.     PROCEDURE FindObj*(obj: Object; VAR level: INTEGER);
  139.         VAR head, cur: Object;
  140.     BEGIN head := topScope;
  141.         LOOP cur := head.next;
  142.             WHILE (cur # NIL) & (cur # obj) DO cur := cur.next END;
  143.             IF cur # NIL THEN level := SHORT(head.mnolev); EXIT END;
  144.             head := head.dsc;
  145.             IF head = NIL THEN level := 0; EXIT END
  146.         END
  147.     END FindObj;
  148.  
  149.     PROCEDURE FindField*(typ: Struct; VAR res: Object);
  150.         VAR obj: Object;
  151.     BEGIN (*typ.form = Record*)
  152.         LOOP obj := typ.link;
  153.             WHILE (obj # NIL) & (obj.name # COCS.name) DO obj := obj.next END ;
  154.             IF obj # NIL THEN EXIT END ;
  155.             typ := typ.BaseTyp;
  156.             IF typ = NIL THEN EXIT END
  157.         END ;
  158.         res := obj
  159.     END FindField;
  160.  
  161.     PROCEDURE Insert*(VAR name: ARRAY OF CHAR; VAR res: Object);
  162.         VAR obj, new: Object;
  163.     BEGIN obj := topScope;
  164.         WHILE (obj.next # NIL) & (obj.next.name # name) DO obj := obj.next END ;
  165.         IF obj.next = NIL THEN NEW(new);
  166.             new.dsc := NIL; new.next := NIL;
  167.             COPY(name, new.name); new.mnolev := ordObj;
  168.             obj.next := new; res := new
  169.         ELSE res := obj.next;
  170.             IF obj.next.mode # Undef THEN COCS.Mark(1) END
  171.         END
  172.     END Insert;
  173.  
  174.     PROCEDURE Remove*(del: Object);
  175.         VAR obj: Object;
  176.     BEGIN obj := topScope;
  177.         WHILE obj.next # del DO obj := obj.next END ;
  178.         obj.next := del.next
  179.     END Remove;
  180.  
  181.     PROCEDURE OpenScope*(level: INTEGER; VAR name: ARRAY OF CHAR);
  182.         VAR head: Object;
  183.     BEGIN NEW(head);
  184.         head.mode := Head; head.mnolev := level; COPY(name, head.name);
  185.         head.typ := NIL; head.dsc := topScope; head.next := NIL;
  186.         topScope := head
  187.     END OpenScope;
  188.  
  189.     PROCEDURE CloseScope*;
  190.     BEGIN topScope := topScope.dsc
  191.     END CloseScope;
  192.  
  193.     PROCEDURE HasPtr*(typ: Struct): BOOLEAN;
  194.         VAR fld: Object;
  195.     BEGIN
  196.         IF typ.form = Pointer THEN RETURN TRUE
  197.         ELSIF typ.form IN {Array, DynArr} THEN RETURN HasPtr(typ.BaseTyp)
  198.         ELSIF typ.form = Record THEN
  199.             IF (typ.BaseTyp # NIL) & HasPtr(typ.BaseTyp) THEN RETURN TRUE END;
  200.             fld := typ.link;
  201.             WHILE fld # NIL DO
  202.                 IF (fld.name = "") OR HasPtr(fld.typ) THEN RETURN TRUE END;
  203.                 fld := fld.next
  204.             END
  205.         END;
  206.         RETURN FALSE
  207.     END HasPtr;
  208.  
  209.     PROCEDURE IsParam*(obj: Object): BOOLEAN;
  210.     BEGIN RETURN (obj # NIL) & (obj.mode <= Ind) & (obj.intval = 1)
  211.     END IsParam;
  212.  
  213.     PROCEDURE VarMode*(VAR x: Item);
  214.     BEGIN
  215.         IF IsParam(x.obj) THEN
  216.             CASE x.typ.form OF
  217.                 Undef .. ProcTyp:
  218.             | Array: x.mode := Ind
  219.             | DynArr:
  220.                 IF x.typ.BaseTyp = bytetyp THEN x.mode := Var
  221.                 ELSE x.mode := Ind
  222.                 END;
  223.                 x.intval := 0
  224.             | Record: x.mode := Ind
  225.             END
  226.         END
  227.     END VarMode;
  228.  
  229.  (*---------------------- import ------------------------*)
  230.  
  231.     PROCEDURE ReadInt(VAR i: INTEGER);
  232.     BEGIN Files.ReadBytes(SR, i, SIZE(INTEGER))
  233.     END ReadInt;
  234.  
  235.     PROCEDURE ReadXInt(VAR k: LONGINT);
  236.         VAR i: INTEGER;
  237.     BEGIN Files.ReadBytes(SR, i, SIZE(INTEGER)); k := i
  238.     END ReadXInt;
  239.  
  240.     PROCEDURE ReadLInt(VAR k: LONGINT);
  241.     BEGIN Files.ReadBytes(SR, k, SIZE(LONGINT))
  242.     END ReadLInt;
  243.  
  244.     PROCEDURE ReadXReal(VAR lr: LONGREAL);
  245.         VAR r: REAL;
  246.     BEGIN Files.ReadBytes(SR, r, SIZE(REAL)); lr := r
  247.     END ReadXReal;
  248.  
  249.     PROCEDURE ReadLReal(VAR lr: LONGREAL);
  250.     BEGIN Files.ReadBytes(SR, lr, SIZE(LONGREAL))
  251.     END ReadLReal;
  252.  
  253.     PROCEDURE ReadId(VAR id: ARRAY OF CHAR);
  254.         VAR i: INTEGER; ch: CHAR;
  255.     BEGIN i := 0;
  256.         REPEAT Files.Read(SR, ch); id[i] := ch; INC(i)
  257.         UNTIL ch = 0X
  258.     END ReadId;
  259.  
  260.     PROCEDURE Import*(VAR name, self, FileName: ARRAY OF CHAR);
  261.         VAR i, j, m, s, class: INTEGER; k: LONGINT;
  262.                 nofLmod, strno, parlev, fldlev: INTEGER;
  263.                 obj, ob0: Object;
  264.                 typ: Struct;
  265.                 ch, ch1, ch2: CHAR;
  266.                 si: SHORTINT;
  267.                 xval: REAL; yval: LONGREAL;
  268.                 SymFile: Files.File;
  269.                 modname: ARRAY 32 OF CHAR;
  270.                 LocMod:  ARRAY maxMod OF Object;
  271.                 struct:  ARRAY maxStr OF Struct;
  272.                 lastpar: ARRAY maxParLev OF Object;
  273.                 lastfld: ARRAY maxFldLev OF Object;
  274.  
  275.         PROCEDURE reversedList(p: Object): Object;
  276.             VAR q, r: Object;
  277.         BEGIN q := NIL;
  278.             WHILE p # NIL DO
  279.                 r := p.next; p.next := q; q := p; p := r
  280.             END ;
  281.             RETURN q
  282.         END reversedList;
  283.  
  284.     BEGIN nofLmod := 0; strno := firstStr;
  285.         parlev := -1; fldlev := -1;
  286.         IF FileName = "Cym.SYSTEM" THEN
  287.             Insert(name, obj); obj.mode := Mod; obj.dsc := syslink;
  288.             obj.mnolev := 0; obj.typ := notyp
  289.         ELSE SymFile := Files.Old(FileName);
  290.             IF SymFile # NIL THEN
  291.                 Files.Set(SR, SymFile, 0); Files.Read(SR, ch);
  292.                 IF ch = SFtag THEN
  293.                     struct[Undef] := undftyp; struct[Byte] := bytetyp;
  294.                     struct[Bool] := booltyp;  struct[Char] := chartyp;
  295.                     struct[SInt] := sinttyp;  struct[Int] := inttyp;
  296.                     struct[LInt] := linttyp;  struct[Real] := realtyp;
  297.                     struct[LReal] := lrltyp;  struct[Set] := settyp;
  298.                     struct[String] := stringtyp; struct[NilTyp] := niltyp; struct[NoTyp] := notyp;
  299.                     LOOP (*read next item from symbol file*)
  300.                         Files.Read(SR, ch); class := ORD(ch);
  301.                         IF SR.eof THEN EXIT END ;
  302.                         CASE class OF
  303.                             0: COCS.Mark(151)
  304.                         | 1..7: (*object*) NEW(obj); m := 0;
  305.                             Files.Read(SR, ch); s := ORD(ch); obj.typ := struct[s];
  306.                             CASE class OF
  307.                                 1: obj.mode := Con;
  308.                                         CASE obj.typ.form OF
  309.                                             2,4: Files.Read(SR, si); obj.intval := si
  310.                                         | 1,3: Files.Read(SR, ch); obj.intval := ORD(ch)
  311.                                         | 5: ReadXInt(obj.intval)
  312.                                         | 6,9: ReadLInt(obj.intval) (* longint and set *)
  313.                                         | 7: ReadXReal(obj.fltval)
  314.                                         | 8: ReadLReal(obj.fltval)
  315.                                         | 10: Files.Read(SR, si); obj.intval := LONG(LONG(si)); (*String constant is referenced by name only *)
  316.                                                   REPEAT Files.Read(SR, ch) UNTIL ch = 0X;
  317.                                         | 11: (*NIL*)
  318.                                         END
  319.                             |2,3: obj.mode := Typ; Files.Read(SR, ch); m := ORD(ch);
  320.                                         IF obj.typ.strobj = NIL THEN obj.typ.strobj := obj END;
  321.                                         obj.marked := class = 2
  322.                             |4: obj.mode := Var; obj.intval := 0
  323.                             |5,6,7: IF class # 7 THEN obj.mode := XProc ELSE obj.mode := CProc END;
  324.                                         obj.dsc := reversedList(lastpar[parlev]); DEC(parlev)
  325.                             END ;
  326.                             ReadId(obj.name); ob0 := LocMod[m];
  327.                             WHILE (ob0.next # NIL) & (ob0.next.name # obj.name) DO ob0 := ob0.next END ;
  328.                             IF ob0.next = NIL THEN ob0.next := obj; obj.next := NIL  (*insert object*)
  329.                             ELSIF obj.mode = Typ THEN struct[s] := ob0.next.typ
  330.                             END
  331.                         | 8..12: (*structure*)
  332.                             NEW(typ); typ.strobj := NIL; typ.ref := 0;
  333.                             Files.Read(SR, ch); typ.BaseTyp := struct[ORD(ch)];
  334.                             Files.Read(SR, ch); typ.mno := SHORT(LocMod[ORD(ch)].mnolev);
  335.                             CASE class OF
  336.                                  8: typ.form := Pointer; typ.n := 0
  337.                             |  9: typ.form := ProcTyp;
  338.                                         typ.link := reversedList(lastpar[parlev]); DEC(parlev)
  339.                             | 10: typ.form := Array; ReadInt(typ.descr); ReadLInt(typ.n)
  340.                             | 11: typ.form := DynArr (* DynArr is a reference *)
  341.                             | 12: typ.form := Record; typ.n := 0;
  342.                                         typ.link := reversedList(lastfld[fldlev]); DEC(fldlev);
  343.                                         IF typ.BaseTyp = notyp THEN typ.BaseTyp := NIL; typ.n := 0
  344.                                         ELSE typ.n := typ.BaseTyp.n + 1
  345.                                         END ;
  346.                                         ob0 := typ.link;
  347.                                         WHILE ob0 # NIL DO
  348.                                             ob0.mnolev := SHORT(typ.n);
  349.                                             ob0 := ob0.next
  350.                                         END;
  351.                                         ReadInt(typ.descr)
  352.                             END ;
  353.                             struct[strno] := typ; INC(strno)
  354.                         | 13: (*parameter list start*)
  355.                             IF parlev < maxParLev-1 THEN INC(parlev); lastpar[parlev] := NIL
  356.                             ELSE COCS.Mark(229)
  357.                             END
  358.                         | 14, 15: (*parameter*)
  359.                             NEW(obj);
  360.                             IF class = 14 THEN obj.mode := Var ELSE obj.mode := Ind END;
  361.                             obj.intval := 1;
  362.                             Files.Read(SR, ch); obj.typ := struct[ORD(ch)];
  363.                             ReadId(obj.name);
  364.                             obj.dsc := NIL; obj.next := lastpar[parlev]; lastpar[parlev] := obj
  365.                         | 16: (*start field list*)
  366.                             IF fldlev < maxFldLev-1 THEN INC(fldlev); lastfld[fldlev] := NIL
  367.                             ELSE COCS.Mark(229)
  368.                             END
  369.                         | 17: (*field*)
  370.                             NEW(obj); obj.mode := Fld;
  371.                             Files.Read(SR, ch); obj.typ := struct[ORD(ch)];
  372.                             ReadId(obj.name); obj.marked := TRUE;
  373.                             obj.dsc := NIL; obj.next := lastfld[fldlev]; lastfld[fldlev] := obj
  374.                         | 18: (*hidden pointer field*) (* to make it possible to apply HasPtr(...) call *)
  375.                             NEW(obj); obj.mode := Fld;
  376.                             obj.name := ""; obj.typ := notyp; obj.marked := FALSE;
  377.                             obj.dsc := NIL; obj.next := lastfld[fldlev]; lastfld[fldlev] := obj
  378.                         | 19: (*hidden procedure field*)
  379.                             (*nothing*)
  380.                         | 20: (*fixup pointer typ*)
  381.                             Files.Read(SR, ch); typ := struct[ORD(ch)];
  382.                             Files.Read(SR, ch1);
  383.                             IF typ.BaseTyp = undftyp THEN typ.BaseTyp := struct[ORD(ch1)] END
  384.                         | 21, 23, 24: COCS.Mark(151); EXIT
  385.                         | 22: (*module anchor*)
  386.                             ReadLInt(k); ReadId(modname);
  387.                             IF modname = self THEN COCS.Mark(49) END;
  388.                             i := 0;
  389.                             WHILE (i < nofGmod) & (modname # GlbMod[i].name) DO INC(i) END ;
  390.                             IF i < nofGmod THEN (*module already present*)
  391.                                 IF k # GlbMod[i].intval THEN COCS.Mark(150) END ;
  392.                                 obj := GlbMod[i]
  393.                             ELSE NEW(obj);
  394.                                 IF nofGmod < maxImps THEN GlbMod[nofGmod] := obj; INC(nofGmod)
  395.                                 ELSE COCS.Mark(227)
  396.                                 END ;
  397.                                 obj.mode := NotYetExp; COPY(modname, obj.name);
  398.                                 obj.intval := k; obj.mnolev := nofGmod; obj.next := NIL
  399.                             END ;
  400.                             IF nofLmod < maxMod THEN LocMod[nofLmod] := obj; INC(nofLmod)
  401.                             ELSE COCS.Mark(227)
  402.                             END
  403.                         END
  404.                     END (*LOOP*);
  405.                     Insert(name, obj);
  406.                     obj.mode := Mod; obj.dsc := LocMod[0].next;
  407.                     obj.mnolev := LocMod[0].mnolev; obj.typ := notyp
  408.                 ELSE COCS.Mark(151)
  409.                 END;
  410.                 Files.Close(SymFile)
  411.             ELSE COCS.Mark(152)   (*sym file not found*)
  412.             END
  413.         END
  414.     END Import;
  415.  
  416.     (*---------------------- export ------------------------*)
  417.  
  418.     PROCEDURE WriteByte(i: INTEGER);
  419.     BEGIN Files.Write(SR, CHR(i))
  420.     END WriteByte;
  421.  
  422.     PROCEDURE WriteInt(l: LONGINT);
  423.         VAR i: INTEGER;
  424.     BEGIN i:= SHORT(l); Files.WriteBytes(SR, i, SIZE(INTEGER))
  425.     END WriteInt;
  426.  
  427.     PROCEDURE WriteLInt(k: LONGINT);
  428.     BEGIN Files.WriteBytes(SR, k, SIZE(LONGINT))
  429.     END WriteLInt;
  430.  
  431.     PROCEDURE WriteReal(lr: LONGREAL);
  432.         VAR r: REAL;
  433.     BEGIN r := SHORT(lr); Files.WriteBytes(SR, r, SIZE(REAL))
  434.     END WriteReal;
  435.  
  436.     PROCEDURE WriteLReal(r: LONGREAL);
  437.     BEGIN Files.WriteBytes(SR, r, SIZE(LONGREAL))
  438.     END  WriteLReal;
  439.  
  440.     PROCEDURE WriteId(VAR name: ARRAY OF CHAR);
  441.         VAR ch: CHAR; i: INTEGER;
  442.     BEGIN i := 0;
  443.         REPEAT ch := name[i]; Files.Write(SR, ch); INC(i)
  444.         UNTIL ch = 0X
  445.     END WriteId;
  446.  
  447.     PROCEDURE^ OutStr(typ: Struct; visible: BOOLEAN);
  448.  
  449.     PROCEDURE OutPars(par: Object; visible: BOOLEAN);
  450.     BEGIN
  451.         IF visible THEN
  452.             WriteByte(13);
  453.             WHILE (par # NIL) & (par.mode <= Ind) & (par.intval = 1) DO
  454.                 OutStr(par.typ, visible);
  455.                 IF par.mode = Var THEN WriteByte(14) ELSE WriteByte(15) END ;
  456.                 WriteByte(par.typ.ref); WriteId(par.name);
  457.                 par := par.next
  458.             END
  459.         ELSE
  460.             WHILE (par # NIL) & (par.mode <= Ind) & (par.intval = 1) DO
  461.                 OutStr(par.typ, visible); par := par.next
  462.             END
  463.         END
  464.     END OutPars;
  465.  
  466.     PROCEDURE OutFlds(fld: Object; visible: BOOLEAN);
  467.         VAR m: INTEGER; mod: Object;
  468.     BEGIN
  469.         IF visible THEN
  470.             WriteByte(16);
  471.             WHILE fld # NIL DO
  472.                 IF fld.marked THEN
  473.                     OutStr(fld.typ, TRUE);
  474.                     WriteByte(17); WriteByte(fld.typ.ref); WriteId(fld.name)
  475.                 ELSE
  476.                     OutStr(fld.typ, FALSE);
  477.                     IF HasPtr(fld.typ) THEN
  478.                         WriteByte(18) (* remember: if HasPtr(...) then insert into pointer list *)
  479.                     END
  480.                 END;
  481.                 fld := fld.next
  482.             END
  483.         ELSE WHILE fld # NIL DO OutStr(fld.typ, FALSE); fld := fld.next END
  484.         END
  485.     END OutFlds;
  486.  
  487.     PROCEDURE OutStr(typ: Struct; visible: BOOLEAN);
  488.         VAR m, em, r: INTEGER; btyp: Struct; mod: Object;
  489.     BEGIN
  490.         IF visible & (typ.ref <= 0) THEN
  491.             m := typ.mno; btyp := typ.BaseTyp;
  492.             IF m > 0 THEN mod := GlbMod[m-1]; em := mod.mode;
  493.                 IF (em = NotYetExp) OR (em = PrivExp) THEN
  494.                     GlbMod[m-1].mode := nofExp; m := nofExp; INC(nofExp);
  495.                     WriteByte(22); WriteLInt(mod.intval); WriteId(mod.name)
  496.                 ELSE m := em
  497.                 END
  498.             END;
  499.             CASE typ.form OF Undef .. NoTyp:
  500.             | Pointer: WriteByte(8);
  501.                 IF btyp.ref > 0 THEN WriteByte(btyp.ref)
  502.                 ELSE WriteByte(Undef);
  503.                     IF udpinx < maxUDP THEN undPtr[udpinx] := typ; INC(udpinx) ELSE COCS.Mark(224) END
  504.                 END ;
  505.                 WriteByte(m)
  506.             | ProcTyp: OutStr(btyp, TRUE); OutPars(typ.link, TRUE);
  507.                 WriteByte(9); WriteByte(btyp.ref); WriteByte(m)
  508.             | Array: OutStr(btyp, TRUE);
  509.                 WriteByte(10); WriteByte(btyp.ref); WriteByte(m);
  510.                 WriteInt(typ.descr); WriteLInt(typ.n)
  511.             | DynArr: OutStr(btyp, TRUE);
  512.                 WriteByte(11); WriteByte(btyp.ref); WriteByte(m)
  513.             | Record:
  514.                 IF btyp = NIL THEN r := NoTyp
  515.                 ELSE OutStr(btyp, TRUE); r := btyp.ref
  516.                 END ;
  517.                 OutFlds(typ.link, TRUE); WriteByte(12); WriteByte(r); WriteByte(m);
  518.                 WriteInt(typ.descr)
  519.             END;
  520.             IF typ.strobj # NIL THEN
  521.                 IF typ.strobj.marked THEN WriteByte(2) ELSE WriteByte(3) END;
  522.                 WriteByte(strno); WriteByte(m); WriteId(typ.strobj.name)
  523.             END ;
  524.             typ.ref := strno; INC(strno);
  525.             IF strno > maxStr THEN COCS.Mark(228) END
  526.         ELSIF ~visible & (typ.ref = 0) THEN
  527.             m := typ.mno; btyp := typ.BaseTyp;
  528.             IF (m > 0) THEN mod := GlbMod[m-1];
  529.                 IF mod.mode = NotYetExp THEN mod.mode := PrivExp END
  530.             END;
  531.             CASE typ.form OF Undef .. NoTyp:
  532.             | Pointer:
  533.                 IF btyp.ref = 0 THEN
  534.                     IF udpinx < maxUDP THEN undPtr[udpinx] := typ; INC(udpinx)
  535.                     ELSE COCS.Mark(224)
  536.                     END
  537.                 END;
  538.             | ProcTyp: OutStr(btyp, FALSE); OutPars(typ.link, FALSE);
  539.             | Array: OutStr(btyp, FALSE);
  540.             | DynArr: OutStr(btyp, FALSE);
  541.             | Record:
  542.                 IF btyp # NIL THEN OutStr(btyp, FALSE) END;
  543.                 OutFlds(typ.link, FALSE)
  544.             END;
  545.             typ.ref := -1
  546.         END
  547.     END OutStr;
  548.  
  549.     PROCEDURE OutPtrFixup(typ: Struct; visible: BOOLEAN);
  550.     BEGIN
  551.         OutStr(typ.BaseTyp, visible);
  552.         IF visible THEN
  553.             WriteByte(20); WriteByte(typ.ref); WriteByte(typ.BaseTyp.ref)
  554.         END
  555.     END OutPtrFixup;
  556.  
  557.     PROCEDURE OutObjs;
  558.         VAR obj: Object;
  559.             f: INTEGER; xval: REAL; yval: LONGREAL;
  560.     BEGIN obj := topScope.next;
  561.         WHILE obj # NIL DO
  562.             IF obj.marked THEN
  563.                 IF obj.mode = Con THEN
  564.                     WriteByte(1); f := obj.typ.form; WriteByte(f);
  565.                     CASE f OF
  566.                         Undef:
  567.                     | Byte, Bool, Char, SInt: WriteByte(SHORT(obj.intval))
  568.                     | Int: WriteInt(SHORT(obj.intval))
  569.                     | LInt, Set: WriteLInt(obj.intval)
  570.                     | Real: WriteReal(SHORT(obj.fltval))
  571.                     | LReal:  WriteLReal(obj.fltval)
  572.                     | String: WriteByte(SHORT(obj.intval MOD 100H)); WriteByte(0)
  573.                     | NilTyp:
  574.                     END;
  575.                     WriteId(obj.name)
  576.                 ELSIF obj.mode = Typ THEN
  577.                     OutStr(obj.typ, TRUE);
  578.                     IF (obj.typ.strobj # obj) & (obj.typ.strobj # NIL) THEN
  579.                         WriteByte(2); WriteByte(obj.typ.ref); WriteByte(0); WriteId(obj.name)
  580.                     END
  581.                 ELSIF obj.mode = Var THEN
  582.                     OutStr(obj.typ, TRUE); WriteByte(4);
  583.                     WriteByte(obj.typ.ref); WriteId(obj.name)
  584.                 ELSIF obj.mode = XProc THEN
  585.                     OutStr(obj.typ, TRUE); OutPars(obj.dsc, TRUE); WriteByte(5);
  586.                     WriteByte(obj.typ.ref); WriteId(obj.name)
  587.                 ELSIF obj.mode = CProc THEN
  588.                     OutStr(obj.typ, TRUE); OutPars(obj.dsc, TRUE); WriteByte(7);
  589.                     WriteByte(obj.typ.ref); WriteId(obj.name)
  590.                 END
  591.             END ;
  592.             obj := obj.next
  593.         END
  594.     END OutObjs;
  595.  
  596.     PROCEDURE Export*(VAR name, TmpFileName, FileName: ARRAY OF CHAR;
  597.             VAR newSF: BOOLEAN; VAR key: LONGINT);
  598.         VAR i: INTEGER;
  599.             ch, ch0, ch1: CHAR;
  600.             oldkey: LONGINT;
  601.             typ: Struct;
  602.             oldFile, newFile: Files.File;
  603.             oldSR: Files.Rider;
  604.             res: INTEGER;
  605.     BEGIN newFile := Files.New(TmpFileName);
  606.         IF newFile # NIL THEN
  607.             Files.Set(SR, newFile, 0); Files.Write(SR, SFtag); strno := firstStr;
  608.             WriteByte(22); WriteLInt(key); WriteId(name); nofExp := 1;
  609.             OutObjs; i := 0;
  610.             WHILE i < udpinx DO
  611.                 typ := undPtr[i]; OutPtrFixup(typ, typ.ref > 0);
  612.                 undPtr[i] := NIL; INC(i)
  613.             END ;
  614.             IF ~COCS.scanerr THEN
  615.                 oldFile := Files.Old(FileName);
  616.                 IF oldFile # NIL THEN (*compare*)
  617.                     Files.Set(oldSR, oldFile, 2); Files.ReadBytes(oldSR, oldkey, SIZE(LONGINT));
  618.                     Files.Set(SR, newFile, 2+SIZE(LONGINT));
  619.                     REPEAT Files.Read(oldSR, ch0); Files.Read(SR, ch1)
  620.                     UNTIL (ch0 # ch1) OR SR.eof;
  621.                     IF oldSR.eof & SR.eof THEN (*equal*) newSF := FALSE;  key := oldkey
  622.                     ELSIF ~newSF THEN COCS.Mark(155)
  623.                     END;
  624.                     Files.Close(oldFile)
  625.                 ELSE newSF := TRUE
  626.                 END
  627.             ELSE newSF := FALSE
  628.             END;
  629.             IF newSF THEN
  630.                 Files.Register(newFile); Files.Delete(FileName, res);
  631.                 Files.Rename(TmpFileName, FileName, res)
  632.             ELSE Files.Close(newFile); Files.Delete(TmpFileName, res)
  633.             END;
  634.             IF res > 1 THEN HALT(21H) END
  635.         ELSE HALT(21H)
  636.         END
  637.     END Export;
  638.  
  639.     (*------------------------ initialization ------------------------*)
  640.  
  641.     PROCEDURE InitStruct(VAR typ: Struct; f: SHORTINT);
  642.     BEGIN NEW(typ); typ.form := f; typ.ref := f;
  643.     END InitStruct;
  644.  
  645.     PROCEDURE EnterConst(name: ARRAY OF CHAR; value: INTEGER);
  646.         VAR obj: Object;
  647.     BEGIN Insert(name, obj); obj.mode := Con; obj.typ := booltyp; obj.intval := value;
  648.         obj.mnolev := stdObj
  649.     END EnterConst;
  650.  
  651.     PROCEDURE EnterTyp(name: ARRAY OF CHAR; form: SHORTINT; VAR res: Struct);
  652.         VAR obj: Object; typ: Struct;
  653.     BEGIN Insert(name, obj);
  654.         NEW(typ); obj.mode := Typ; obj.typ := typ; obj.marked := TRUE;
  655.         obj.mnolev := stdObj;
  656.         typ.form := form; typ.strobj := obj;
  657.         typ.mno := 0; typ.ref := form; res := typ
  658.     END EnterTyp;
  659.  
  660.     PROCEDURE EnterProc(name: ARRAY OF CHAR; num: INTEGER);
  661.         VAR obj: Object;
  662.     BEGIN Insert(name, obj); obj.mode := SProc; obj.typ := notyp; obj.intval := num;
  663.         obj.mnolev := stdObj
  664.     END EnterProc;
  665.  
  666.     PROCEDURE EnterSysTyp(name: ARRAY OF CHAR; form: SHORTINT; VAR res: Struct);
  667.         VAR obj: Object; typ: Struct;
  668.     BEGIN Insert(name, obj);
  669.         NEW(typ); obj.mode := Typ; obj.typ := typ; obj.marked := TRUE;
  670.         obj.mnolev := sysObj;
  671.         typ.form := form; typ.strobj := obj;
  672.         typ.mno := 0; typ.ref := form; res := typ
  673.     END EnterSysTyp;
  674.  
  675.     PROCEDURE EnterSysProc(name: ARRAY OF CHAR; num: INTEGER);
  676.         VAR obj: Object;
  677.     BEGIN Insert(name, obj); obj.mode := SProc; obj.typ := notyp; obj.intval := num;
  678.         obj.mnolev := sysObj
  679.     END EnterSysProc;
  680.  
  681.     PROCEDURE OpenGlobalScope;
  682.         VAR name: ARRAY 1 OF CHAR;
  683.     BEGIN
  684.         name[0] := 0X;
  685.         OpenScope(0, name)
  686.     END OpenGlobalScope;
  687.  
  688. BEGIN topScope := NIL;
  689.     InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp);
  690.     InitStruct(stringtyp, String); InitStruct(niltyp, NilTyp);
  691.     OpenGlobalScope;
  692.  
  693.     (*initialization of module SYSTEM*)
  694.     EnterSysProc("LSH", 22);
  695.     EnterSysProc("ROT", 23);
  696.     EnterSysProc("ADR",  9);
  697.     EnterSysProc("OVFL",15);
  698.     EnterSysProc("GET", 24);
  699.     EnterSysProc("PUT", 25);
  700.     EnterSysProc("BIT", 26);
  701.     EnterSysProc("VAL", 27);
  702.     EnterSysProc("NEW", 28);
  703.     EnterSysProc("MOVE",30);
  704.     EnterSysProc("CC",  2);
  705.     EnterSysTyp("BYTE", Byte, bytetyp);
  706.     syslink := topScope.next;
  707.     universe := topScope; topScope.next := NIL;
  708.  
  709.     EnterTyp("CHAR", Char, chartyp);
  710.     EnterTyp("SET", Set, settyp);
  711.     EnterTyp("REAL", Real, realtyp);
  712.     EnterTyp("INTEGER", Int, inttyp);
  713.     EnterTyp("LONGINT",  LInt, linttyp);
  714.     EnterTyp("LONGREAL", LReal, lrltyp);
  715.     EnterTyp("SHORTINT", SInt, sinttyp);
  716.     EnterTyp("BOOLEAN", Bool, booltyp);
  717.     EnterProc("INC",   16);
  718.     EnterProc("DEC",   17);
  719.     EnterConst("FALSE", 0);
  720.     EnterConst("TRUE",  1);
  721.     EnterProc("HALT",   0);
  722.     EnterProc("NEW",    1);
  723.     EnterProc("ABS",    3);
  724.     EnterProc("CAP",    4);
  725.     EnterProc("ORD",    5);
  726.     EnterProc("ENTIER", 6);
  727.     EnterProc("SIZE",   7);
  728.     EnterProc("ODD",    8);
  729.     EnterProc("MIN",   10);
  730.     EnterProc("MAX",   11);
  731.     EnterProc("CHR",   12);
  732.     EnterProc("SHORT", 13);
  733.     EnterProc("LONG",  14);
  734.     EnterProc("INCL",  18);
  735.     EnterProc("EXCL",  19);
  736.     EnterProc("LEN",   20);
  737.     EnterProc("ASH",   21);
  738.     EnterProc("COPY",  29);
  739.  
  740.  (* a better place *)
  741.     NEW(wasderef);
  742.     typchk := TRUE
  743. END COCT.
  744.