home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC3.3 / M2RA.MOD < prev    next >
Encoding:
Text File  |  1992-05-29  |  23.3 KB  |  385 lines  |  [TEXT/MEDT]
  1.                     CASE ORD(ch) OF
  2.                            2: ReadChar(f, ch); conval.Ch := ch;
  3.                          | 3: ReadWord(f, conval.I);
  4.                          | 5: ReadWord(f, conval.D0); ReadWord(f, conval.D1);
  5.                          | 9: ReadWord(f, conval.D0); ReadWord(f, conval.D1);
  6.                               ReadWord(f, conval.D2); ReadWord(f, conval.D3);
  7.                          ELSE
  8.                            Mark(86);
  9.                          END;
  10. (* V2.6 *)               IF typ = cardtyp THEN typ := inttyp;
  11. (* V2.6 *)                 IF conval.I < 0 THEN Mark(87) END
  12. (* V2.6 *)               END
  13.               | string : class := Const; ReadWord(f, s); typ := Struct[s];
  14.                          conval.D2 := id; ReadId;
  15.                          AllocString(conval.D2, conval.D0, conval.D1);
  16.               | type   : class := Typ; ReadWord(f, s); typ := Struct[s];
  17.                          IF typ^.strobj = NIL THEN typ^.strobj := newobj END;
  18.                          ReadWord(f, m); mod := GlbMod[m]^.right
  19.               | proc, func : class := Proc;
  20.                          IF block = func THEN ReadWord(f, s); typ := Struct[s]
  21.                            ELSE typ := notyp
  22.                          END;
  23.                          ALLOCATE(pd, SIZE(PDesc));
  24.                          ReadWord(f, pd^.num); ReadWord(f, pd^.lev);
  25.                          ReadWord(f, pd^.adr); ReadWord(f, pd^.size);
  26.                          pd^.forward := FALSE; pd^.exp := FALSE;
  27.                          (* pd^.extern := TRUE; pd^.link := 0; *)
  28.                          firstLocal := NIL; firstParam := Params^.next;
  29.                          Params^.next := NIL; lastPar := Params;
  30.                          pmod := GlbMod[0]^.right^.modno
  31.               | svc, svcfunc: class := Code;
  32.                          IF block = svcfunc THEN ReadWord(f, s); typ := Struct[s]
  33.                            ELSE typ := notyp
  34.                          END;
  35.                          ReadWord(f, cnum); std := NonStand;
  36.                          firstArg := Params^.next;
  37.                          Params^.next := NIL; lastPar := Params
  38.               END;
  39.               name := id; ReadId; exported := TRUE;
  40.               obj := Insert(GlbMod[m]^.right, newobj);
  41.               IF obj = newobj THEN (*new object*)
  42.                 GlbMod[m]^.last^.next := newobj; GlbMod[m]^.last := newobj;
  43.                 IF (class = Const) & (typ^.form = Enum) THEN
  44.                   conval.prev := typ^.ConstLink; typ^.ConstLink := newobj
  45.                 END;
  46.                 MarkHeap
  47.               ELSE
  48.                 IF obj^.class = Typ THEN Struct[s] := obj^.typ END;
  49.                 Reset
  50.               END
  51.             END
  52.           ELSIF block < STR THEN block := block - CMP;
  53.             IF block > field THEN err := TRUE; Mark(86); EXIT END;
  54.             IF block = field THEN
  55.               ALLOCATE(newobj, SIZE(Object));
  56.               WITH newobj^ DO
  57.                 class := Field; next := NIL;
  58.                 ReadWord(f, s); typ := Struct[s];
  59.                 ReadWord(f, offset); name := id; ReadId;
  60.                 newobj := Insert(Fields, newobj)
  61.               END;
  62.               Fields^.last^.next := newobj; Fields^.last := newobj
  63.             ELSE (*parameter*)
  64.               ALLOCATE(newpar, SIZE(Parameter));
  65.               WITH newpar^ DO
  66.                 next := NIL; ReadWord(f, s); typ := Struct[s];
  67.                 varpar := block = parref;
  68.                 lastPar^.next := newpar; lastPar := newpar
  69.               END
  70.             END
  71.           ELSIF block < CTL THEN block := block - STR;
  72.             IF block > opaque THEN err := TRUE; Mark(86); EXIT END;
  73.             ALLOCATE(newstr, SIZE(Structure));
  74.             WITH newstr^ DO
  75.               strobj := NIL; ReadWord(f, size); ref := 0;
  76.               CASE block OF
  77.                 enum    : form := Enum; ReadWord(f, NofConst);
  78.                           ConstLink := NIL
  79.               | range   : form := Range;
  80.                           ReadWord(f, s); RBaseTyp := Struct[s];
  81.                           ReadWord(f, min); ReadWord(f, max);
  82.                           AllocBounds(min, max, size, BndAdr);
  83. (* V2.6 *)                IF RBaseTyp = cardtyp THEN RBaseTyp := inttyp;
  84. (* V2.6 *)                  IF (min < 0) OR (max < 0) THEN Mark(87) END
  85. (* V2.6 *)                END
  86.               | pointer : form := Pointer; PBaseTyp := NIL;
  87.                           BaseId := 0;
  88.                           MarkHeap
  89.               | set     : form := Set; ReadWord(f, s);
  90.                           SBaseTyp := Struct[s];
  91. (* V2.6 *)                IF SBaseTyp = cardtyp THEN SBaseTyp := inttyp END
  92.               | procTyp, funcTyp : form := ProcTyp;
  93.                           IF block = funcTyp THEN
  94.                             ReadWord(f, s); resTyp := Struct[s]
  95.                           ELSE resTyp := notyp
  96.                           END;
  97.                           firstPar := Params^.next;
  98.                           Params^.next := NIL; lastPar := Params
  99.               | array   : form := Array; ReadWord(f, s);
  100.                           ElemTyp := Struct[s]; dyn := FALSE;
  101.                           ReadWord(f, s); IndexTyp := Struct[s]
  102.               | dynarr  : form := Array; ReadWord(f, s);
  103.                           ElemTyp := Struct[s]; dyn := TRUE;
  104.                           IndexTyp := NIL
  105.               | record  : form := Record;
  106.                           firstFld := Fields^.right; Fields^.right := NIL;
  107.                           Fields^.next := NIL; Fields^.last := Fields
  108.               | opaque  : form := Opaque
  109.               END
  110.             END;
  111.             IF CurStr > maxS THEN err := TRUE; Mark(98); EXIT END;
  112.             Struct[CurStr] := newstr;
  113.             CurStr := CurStr + 1
  114.           ELSIF block < 0 THEN block := block - CTL;
  115.             IF block = linkage THEN ReadWord(f, s); ReadWord(f, p);
  116.               IF Struct[p]^.PBaseTyp # NIL THEN
  117.                 Reset
  118.               ELSE Struct[p]^.PBaseTyp := Struct[s];
  119. (* V2.6 *)      IF Struct[p]^.PBaseTyp = cardtyp THEN
  120. (* V2.6 *)        Struct[p]^.PBaseTyp := inttyp
  121. (* V2.6 *)      END;
  122.                 MarkHeap
  123.               END
  124.             ELSIF block = ModTag THEN (*main module*) ReadWord(f, m)
  125.             ELSIF block = anchor THEN
  126.               ALLOCATE(newobj, SIZE(Object));
  127.               WITH newobj^ DO
  128.                 class := Module; typ := NIL; left := NIL; right := NIL;
  129.                 ALLOCATE(key, SIZE(Key));
  130.                 ReadWord(f, key^.k0); ReadWord(f, key^.k1); ReadWord(f, key^.k2);
  131.                 firstObj := NIL; root := NIL; name := id; ReadId
  132.               END;
  133.               IF CurMod > maxM THEN Mark(96); EXIT END;
  134.               ALLOCATE(GlbMod[CurMod], SIZE(Object));
  135.               MarkHeap;
  136.               WITH GlbMod[CurMod]^ DO
  137.                 class := Header; kind := Module; typ := NIL;
  138.                 next := NIL; left := NIL; last := GlbMod[CurMod];
  139.                 obj := ModList^.next; (*find mod*)
  140.                 WHILE (obj # NIL) & (Diff(obj^.name, newobj^.name) # 0) DO
  141.                   obj := obj^.next
  142.                 END;
  143.                 IF obj # NIL THEN GlbMod[CurMod]^.right := obj;
  144.                   IF (CurMod = 0) & (obj = mainmod) THEN
  145.                     (*newobj is own definition module*)
  146.                     obj^.key^ := newobj^.key^
  147.                   ELSIF (obj^.key^.k0 # newobj^.key^.k0)
  148.                      OR (obj^.key^.k1 # newobj^.key^.k1)
  149.                      OR (obj^.key^.k2 # newobj^.key^.k2) THEN Mark(85)
  150.                   ELSIF (CurMod = 0) & (obj^.firstObj # NIL) THEN
  151.                     CurMod := 1; EXIT (*module already loaded*)
  152.                   END;
  153.                   Reset
  154.                 ELSE GlbMod[CurMod]^.right := newobj;
  155.                   newobj^.next := NIL; newobj^.modno := ModNo; INC(ModNo);
  156.                   ModList^.last^.next := newobj; ModList^.last := newobj;
  157.                   MarkHeap
  158.                 END
  159.               END;
  160.               CurMod := CurMod + 1
  161.             ELSIF block = RefTag THEN
  162.               ReadWord(f, adr); ReadWord(f, pno); EXIT
  163.             ELSE err := TRUE; Mark(86); EXIT
  164.             END
  165.           ELSE (*line block*) err := TRUE; Mark(86); EXIT
  166.           END
  167.         END;
  168.         IF NOT err & (CurMod # 0) THEN hdr := GlbMod[0];
  169.           hdr^.right^.root := hdr^.right^.right;
  170.           (*leave hdr^.right.right for later searches*)
  171.           hdr^.right^.firstObj := hdr^.next
  172.         ELSE hdr := NIL
  173.         END
  174.       ELSE Mark(86); hdr := NIL
  175.       END;
  176.       Close(f)
  177.     ELSE Mark(88); hdr := NIL
  178.     END
  179.   END InRef;
  180.  
  181.   PROCEDURE WriteId(i: INTEGER);
  182.     VAR L: INTEGER;
  183.   BEGIN L := ORD(IdBuf[i]);
  184.     REPEAT WriteChar(RefFile, IdBuf[i]); INC(i); DEC(L)
  185.     UNTIL L = 0
  186.   END WriteId;
  187.  
  188.   PROCEDURE OpenRef;
  189.     VAR obj: ObjPtr;
  190.   BEGIN WriteWord(RefFile, REFFILE);
  191.     obj := ModList^.next;
  192.     WHILE obj # NIL DO
  193.       WriteWord(RefFile, CTL+anchor);
  194.       WITH obj^ DO WriteWord(RefFile, key^.k0);
  195.         WriteWord(RefFile, key^.k1); WriteWord(RefFile, key^.k2);
  196.         WriteId(name)
  197.       END;
  198.       obj := obj^.next
  199.     END;
  200.     CurStr := minS;
  201.     oldPos := 0D
  202.   END OpenRef;
  203.  
  204.   PROCEDURE OutPar(prm: ParPtr);
  205.   BEGIN
  206.     WHILE prm # NIL DO (*out param*)
  207.       WITH prm^ DO
  208.         IF varpar THEN WriteWord(RefFile, CMP+parref)
  209.           ELSE WriteWord(RefFile, CMP+par)
  210.         END;
  211.         WriteWord(RefFile, typ^.ref)
  212.       END;
  213.       prm := prm^.next
  214.     END
  215.   END OutPar;
  216.  
  217.   PROCEDURE OutStr(str: StrPtr);
  218.     VAR obj: ObjPtr; par: ParPtr;
  219.  
  220.     PROCEDURE OutFldStrs(fld: ObjPtr);
  221.     BEGIN
  222.       WHILE fld # NIL DO
  223.         IF fld^.typ^.ref = 0 THEN OutStr(fld^.typ) END;
  224.         fld := fld^.next
  225.       END
  226.     END OutFldStrs;
  227.  
  228.     PROCEDURE OutFlds(fld: ObjPtr);
  229.     BEGIN
  230.       WHILE fld # NIL DO
  231.         WITH fld^ DO
  232.           WriteWord(RefFile, CMP+field); WriteWord(RefFile, typ^.ref);
  233.           WriteWord(RefFile, offset); WriteId(name)
  234.         END;
  235.         fld := fld^.next
  236.       END
  237.     END OutFlds;
  238.  
  239.   BEGIN
  240.     WITH str^ DO
  241.       CASE form OF
  242.         Enum    : WriteWord(RefFile, STR+enum); WriteWord(RefFile, size);
  243.                   WriteWord(RefFile, NofConst)
  244.       | Range   : IF RBaseTyp^.ref = 0 THEN OutStr(RBaseTyp) END;
  245.                   WriteWord(RefFile, STR+range); WriteWord(RefFile, size);
  246.                   WriteWord(RefFile, RBaseTyp^.ref);
  247.                   WriteWord(RefFile, min); WriteWord(RefFile, max)
  248.       | Pointer : ALLOCATE(obj, SIZE(Object));
  249.                   WITH obj^ DO left := NIL; next := NIL;
  250.                     class := Temp; typ := PBaseTyp; baseref := CurStr;
  251.                     Temps^.last^.next := obj; Temps^.last := obj
  252.                   END;
  253.                   WriteWord(RefFile, STR+pointer); WriteWord(RefFile, size)
  254.       | Set     : IF SBaseTyp^.ref = 0 THEN OutStr(SBaseTyp) END;
  255.                   WriteWord(RefFile, STR+set); WriteWord(RefFile, size);
  256.                   WriteWord(RefFile, SBaseTyp^.ref)
  257.       | ProcTyp : par := firstPar;
  258.                   WHILE par # NIL DO (*out param structure*)
  259.                     IF par^.typ^.ref = 0 THEN OutStr(par^.typ) END;
  260.                     par := par^.next
  261.                   END;
  262.                   OutPar(firstPar);
  263.                   IF resTyp # notyp THEN
  264.                     IF resTyp^.ref = 0 THEN OutStr(resTyp) END;
  265.                     WriteWord(RefFile, STR+funcTyp); WriteWord(RefFile, size);
  266.                     WriteWord(RefFile, resTyp^.ref)
  267.                   ELSE WriteWord(RefFile, STR+procTyp); WriteWord(RefFile, size)
  268.                   END
  269.       | Array   : IF ElemTyp^.ref = 0 THEN OutStr(ElemTyp) END;
  270.                   IF dyn THEN WriteWord(RefFile, STR+dynarr);
  271.                     WriteWord(RefFile, size); WriteWord(RefFile, ElemTyp^.ref)
  272.                   ELSE
  273.                     IF IndexTyp^.ref = 0 THEN OutStr(IndexTyp) END;
  274.                     WriteWord(RefFile, STR+array); WriteWord(RefFile, size);
  275.                     WriteWord(RefFile, ElemTyp^.ref);
  276.                     WriteWord(RefFile, IndexTyp^.ref)
  277.                   END
  278.       | Record  : OutFldStrs(firstFld); OutFlds(firstFld);
  279.                   WriteWord(RefFile, STR+record); WriteWord(RefFile, size)
  280.       | Opaque  : WriteWord(RefFile, STR+opaque); WriteWord(RefFile, size)
  281.       END;
  282.       ref := CurStr; CurStr := CurStr + 1
  283.     END
  284.   END OutStr;
  285.  
  286.   PROCEDURE OutExt(str: StrPtr);
  287.     VAR obj: ObjPtr; par: ParPtr;
  288.  
  289.     PROCEDURE OutFlds(fld: ObjPtr);
  290.     BEGIN
  291.       WHILE fld # NIL DO
  292.         IF fld^.typ^.ref = 0 THEN OutExt(fld^.typ) END;
  293.         fld := fld^.next
  294.       END
  295.     END OutFlds;
  296.  
  297.   BEGIN
  298.     WITH str^ DO
  299.       CASE form OF
  300.         Range   : IF RBaseTyp^.ref = 0 THEN OutExt(RBaseTyp) END
  301.       | Set     : IF SBaseTyp^.ref = 0 THEN OutExt(SBaseTyp) END
  302.       | ProcTyp : par := firstPar;
  303.                   WHILE par # NIL DO
  304.                     IF par^.typ^.ref = 0 THEN OutExt(par^.typ) END;
  305.                     par := par^.next
  306.                   END;
  307.                   IF (resTyp # notyp) & (resTyp^.ref = 0) THEN OutExt(resTyp) END
  308.       | Array   : IF ElemTyp^.ref = 0 THEN OutExt(ElemTyp) END;
  309.                   IF NOT dyn THEN OutExt(IndexTyp) END
  310.       | Record  : OutFlds(firstFld)
  311.       | Enum, Pointer, Opaque :
  312.       END;
  313.       IF (strobj # NIL) & (strobj^.mod^.modno # 0) THEN
  314.         IF ref = 0 THEN OutStr(str) END;
  315.         IF form = Enum THEN obj := ConstLink;
  316.           WHILE obj # NIL DO
  317.             WriteWord(RefFile, OBJ+const);
  318.             WriteWord(RefFile, ref);
  319.             WriteWord(RefFile, strobj^.mod^.modno);
  320.             WriteChar(RefFile, 2C); WriteChar(RefFile, obj^.conval.Ch);
  321.             WriteId(obj^.name);
  322.             obj := obj^.conval.prev
  323.           END
  324.         END;
  325.         WriteWord(RefFile, OBJ+type);
  326.         WriteWord(RefFile, ref);
  327.         WriteWord(RefFile, strobj^.mod^.modno);
  328.         WriteId(strobj^.name)
  329.       END
  330.     END
  331.   END OutExt;
  332.  
  333.   PROCEDURE OutObj(obj: ObjPtr);
  334.     VAR par: ParPtr;
  335.   BEGIN
  336.     WITH obj^ DO
  337.       CASE class OF
  338.         Module : WriteWord(RefFile, OBJ+module); WriteWord(RefFile, modno)
  339.       | Proc   : par := firstParam;
  340.                  WHILE par # NIL DO
  341.                    IF par^.typ^.ref = 0 THEN OutExt(par^.typ) END;
  342.                    par := par^.next
  343.                  END;
  344.                  IF (typ # notyp) & (typ^.ref = 0) THEN OutExt(typ) END;
  345.                  par := firstParam;
  346.                  WHILE par # NIL DO (*out param structure*)
  347.                    IF par^.typ^.ref = 0 THEN OutStr(par^.typ) END;
  348.                    par := par^.next
  349.                  END;
  350.                  IF (typ # notyp) & (typ^.ref = 0) THEN OutStr(typ) END;
  351.                  OutPar(firstParam);
  352.                  IF typ # notyp THEN
  353.                    WriteWord(RefFile, OBJ+func); WriteWord(RefFile, typ^.ref)
  354.                  ELSE WriteWord(RefFile, OBJ+proc)
  355.                  END;
  356.                  WriteWord(RefFile, pd^.num); WriteWord(RefFile, pd^.lev);
  357.                  WriteWord(RefFile, pd^.adr); WriteWord(RefFile, pd^.size)
  358.       | Code   : par := firstArg;
  359.                  WHILE par # NIL DO
  360.                    IF par^.typ^.ref = 0 THEN OutExt(par^.typ) END;
  361.                    par := par^.next
  362.                  END;
  363.                  IF (typ # notyp) & (typ^.ref = 0) THEN OutExt(typ) END;
  364.                  par := firstArg;
  365.                  WHILE par # NIL DO (*out param structure*)
  366.                    IF par^.typ^.ref = 0 THEN OutStr(par^.typ) END;
  367.                    par := par^.next
  368.                  END;
  369.                  IF (typ # notyp) & (typ^.ref = 0) THEN OutStr(typ) END;
  370.                  OutPar(firstArg);
  371.                  IF typ # notyp THEN
  372.                    WriteWord(RefFile, OBJ+svcfunc); WriteWord(RefFile, typ^.ref)
  373.                  ELSE WriteWord(RefFile, OBJ+svc)
  374.                  END;
  375.                  WriteWord(RefFile, cnum)
  376.       | Const  : IF typ^.ref = 0 THEN OutExt(typ) END;
  377.                  IF typ^.ref = 0 THEN OutStr(typ) END;
  378.                  IF typ^.form = String THEN WriteWord(RefFile, OBJ+string);
  379.                    WriteWord(RefFile, typ^.ref); WriteId(conval.D2)
  380.                  ELSE WriteWord(RefFile, OBJ+const);
  381.                    WriteWord(RefFile, typ^.ref);
  382.                    WriteWord(RefFile, 0); (*main*)
  383.                    WriteChar(RefFile, CHR((typ^.size + 1) MOD 256));
  384.                    CASE typ^.size OF
  385.                      1: WriteChar(RefF