home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / language / oberon / potsrc / src / mod / cocd < prev    next >
Encoding:
Text File  |  1995-01-22  |  10.6 KB  |  314 lines
  1. MODULE COCD; (* DVD 03 09 1993 21:10 *)
  2.  (*module's data and definitions*)
  3.   IMPORT Strings, COCS, COCT, COCQ, COCN, COCY, COCO;
  4.   
  5.   CONST 
  6.     ConstLength = 16384; Overhead* = 2048;
  7.     MaxRecs = 128; MaxExts = 16;
  8.   
  9.    (*object modes*)
  10.     Fld = 12; 
  11.  
  12.    (*structure forms*)
  13.     Undef = 0; Set = 9; String = 10; NoTyp = 12;
  14.     Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
  15.  
  16.   VAR
  17.     PtrSize: LONGINT; (* SYSTEM Dependant *)
  18.  
  19.     constant: ARRAY ConstLength OF CHAR; 
  20.     RecTab: ARRAY MaxRecs OF COCT.Struct;
  21.     conx: LONGINT;
  22.     bofrec, nofrec, recnum: INTEGER;
  23.  
  24.   PROCEDURE Init*;
  25.         VAR iofrec: INTEGER;
  26.   BEGIN conx := 0; bofrec := 0; nofrec := 0; recnum := 0;
  27.         iofrec := 0; WHILE iofrec # MaxRecs DO RecTab[iofrec] := NIL; INC(iofrec) END
  28.   END Init;
  29.  
  30.  (*descriptors and string constants*)
  31.   PROCEDURE AllocString*(VAR s: ARRAY OF CHAR; VAR x: COCT.Item);  
  32.     VAR start, rem: LONGINT; i: INTEGER; ch: CHAR;  
  33.  
  34.     PROCEDURE FindString;
  35.       VAR slen, clen, i: INTEGER;
  36.     BEGIN start := 0; slen := SHORT(Strings.Length(s));
  37.       LOOP
  38.         IF start = conx THEN EXIT END;
  39.         clen := ORD(constant[start]);
  40.         IF slen = clen THEN
  41.           i := slen;
  42.           LOOP
  43.             DEC(i);
  44.             IF i = -1 THEN EXIT END;
  45.             IF constant[start + PtrSize + i] # s[i] THEN EXIT END
  46.           END;
  47.           IF i = -1 THEN EXIT END
  48.         END;
  49.         INC(start, PtrSize + clen + 1); rem := start MOD PtrSize;
  50.         IF rem # 0 THEN INC(start, PtrSize - rem) END
  51.       END
  52.     END FindString;  
  53.             
  54.   BEGIN FindString; INC(x.intval, (start+1)*100H);
  55.     IF start = conx THEN
  56.       i := -1; INC(conx, PtrSize);
  57.       REPEAT INC(i); ch := s[i];
  58.         IF conx >= ConstLength THEN COCS.Mark(230); conx := 0 END ;  
  59.         constant[conx] := ch; INC(conx)  
  60.       UNTIL ch = 0X;
  61.       rem := conx MOD PtrSize; 
  62.       IF rem # 0 THEN
  63.         INC(conx, PtrSize - rem);
  64.         IF conx >= ConstLength THEN COCS.Mark(230); conx := 0 END
  65.       END;
  66.       constant[start] := CHR(i)
  67.     END  
  68.   END AllocString;  
  69.  
  70.   PROCEDURE InitStrings*;  
  71.     VAR s: ARRAY 9 OF CHAR;
  72.       i: LONGINT;
  73.     
  74.     PROCEDURE WriteChar(c: CHAR);
  75.       VAR i: INTEGER;
  76.     BEGIN
  77.       s[0] := "'";
  78.       IF (c = "\") OR (c = "'") OR (c = 22X) THEN
  79.         s[1] := "\"; s[2] := c; i := 3
  80.       ELSIF (0X <= c) & (c <= 1FX) OR (7FX <= c) & (c <= 0FFX) THEN
  81.         s[1] := "\"; s[2] := 0X;
  82.         COCO.PutSeq(s);
  83.         Strings.FromLInt(ORD(c), 8, s); 
  84.         i := 0; WHILE s[i] # 0X DO INC(i) END
  85.       ELSE 
  86.         s[1] := c; i := 2
  87.       END;
  88.       s[i] := "'"; s[i+1] := 0X;
  89.       COCO.PutSeq(s)
  90.     END WriteChar;
  91.  
  92.   BEGIN
  93.     IF conx # 0 THEN  
  94.       COCO.PutSeq("static pOt_CHAR pOt__strcon_buf[0x");
  95.       Strings.FromLInt(conx + Overhead, 16, s); 
  96.       COCO.PutSeq(s); COCO.PutSeq("L]={"); COCO.Wrap;
  97.       COCO.Indent;
  98.       i := 0;
  99.       WHILE i # conx DO WriteChar(constant[i]); INC(i);
  100.         COCO.PutSeq(","); IF i MOD 16 = 0 THEN COCO.Wrap END
  101.       END;
  102.       COCO.PutSeq("0"); COCO.Wrap;
  103.       COCO.Undent;
  104.       COCO.PutSeq("};"); COCO.Wrap
  105.     END  
  106.   END InitStrings;  
  107.   
  108.   PROCEDURE AllocTypDesc*(typ: COCT.Struct);     
  109.   BEGIN typ.descr := recnum; INC(recnum); 
  110.     IF (typ.form = Record) & (typ.n > MaxExts) THEN COCS.Mark(233)  
  111.     ELSIF nofrec < MaxRecs THEN  
  112.       RecTab[nofrec] := typ; INC(nofrec)
  113.     ELSE COCS.Mark(223)  
  114.     END  
  115.   END AllocTypDesc;  
  116.   
  117.   PROCEDURE DeclTypDescs*;
  118.     VAR iofrec: INTEGER; typ: COCT.Struct;
  119.       np: INTEGER; x: COCT.Item;
  120.   BEGIN iofrec := 0;
  121.     WHILE iofrec # nofrec DO
  122.       typ := RecTab[iofrec];
  123.       IF typ.ref # 0 THEN
  124.         COCY.Struct(typ);
  125.         COCO.PutSeq("extern"); COCO.Separate;
  126.         CASE typ.form OF 
  127.           Array:
  128.           CASE typ.BaseTyp.form OF 
  129.             Undef .. Set: COCO.PutSeq("pOt__ArrTypDsc")
  130.           | Pointer, ProcTyp: COCO.PutSeq("pOt__PtrArrTypDsc")
  131.           | String .. NoTyp:
  132.           | Array, Record: COCO.PutSeq("pOt__StrArrTypDsc")
  133.           | DynArr:
  134.           END
  135.         | Record: COCO.PutSeq("pOt__RecTypDsc")
  136.         END; COCO.Separate;
  137.         COCQ.Mark(x); COCN.CTDName(typ, x.qoffs, np); COCQ.Release(x);
  138.         COCO.PutSeq(";"); COCO.Wrap
  139.       END;
  140.       INC(iofrec)
  141.     END
  142.   END DeclTypDescs;
  143.  
  144.   PROCEDURE InitTypDescs*;  
  145.     VAR iofrec: INTEGER; typ: COCT.Struct;
  146.       np: INTEGER; x: COCT.Item; s: ARRAY 9 OF CHAR;
  147.       mode, nstr, nptr, npro, ifld, nfld: INTEGER;
  148.       fld: COCT.Object;
  149.       iext: INTEGER;
  150.       base: COCT.Struct; basetyps: ARRAY MaxExts OF COCT.Struct;
  151.   BEGIN iofrec := bofrec;
  152.     WHILE iofrec # nofrec DO
  153.       typ := RecTab[iofrec];
  154.       COCY.Struct(typ);
  155.       IF COCT.level # 0 THEN COCO.PutSeq("static"); COCO.Separate END;
  156.       CASE typ.form OF 
  157.         Array:
  158.         CASE typ.BaseTyp.form OF 
  159.           Undef .. Set: COCO.PutSeq("pOt__ArrTypDsc"); mode := 1
  160.         | Pointer: COCO.PutSeq("pOt__PtrArrTypDsc"); mode := 2
  161.         | ProcTyp: COCO.PutSeq("pOt__PtrArrTypDsc"); mode := 3
  162.         | String .. NoTyp:
  163.         | Array, Record: COCO.PutSeq("pOt__StrArrTypDsc"); mode := 4
  164.         | DynArr:
  165.         END
  166.       | Record: mode := 0;
  167.         COCO.PutSeq("struct {"); COCO.Wrap; 
  168.         COCO.Indent;
  169.         COCO.PutSeq("pOt_INTEGER mode;"); COCO.Wrap;
  170.         COCO.PutSeq("pOt_LONGINT size;"); COCO.Wrap;
  171.         COCO.PutSeq("pOt_INTEGER extlev, nstr, nptr, npro;"); COCO.Wrap;
  172.         COCO.PutSeq("pOt__RecTypDsc *base_td[pOt__MaxExts];"); COCO.Wrap;
  173.         nstr := 0; nptr := 0; npro := 0; fld := typ.link;
  174.         WHILE fld # NIL DO
  175.           IF fld.name # "" THEN
  176.             IF fld.typ.form IN {Array, Record} THEN INC(nstr)
  177.             ELSIF fld.typ.form = Pointer THEN INC(nptr)
  178.             ELSIF fld.typ.form = ProcTyp THEN INC(npro)
  179.             END
  180.           END;
  181.           fld := fld.next
  182.         END;
  183.         nfld := nstr+nptr+npro;
  184.         IF nfld # 0 THEN
  185.           COCO.PutSeq("struct {pOt_LONGINT poffs; pOt__TypDsc *fld_td;} tab[0x");
  186.           Strings.FromLInt(nstr+nptr+npro, 16, s); COCO.PutSeq(s); COCO.PutSeq("];"); COCO.Wrap
  187.         END;
  188.         COCO.Undent;
  189.         COCO.PutSeq("}")
  190.       END; COCO.Separate;
  191.       COCQ.Mark(x); COCN.CTDName(typ, x.qoffs, np); COCQ.Release(x);
  192.       COCO.PutSeq("= {"); COCO.Wrap;
  193.       COCO.Indent;
  194.       Strings.FromLInt(mode, 10, s); COCO.PutSeq(s); 
  195.       COCO.PutSeq(","); COCO.Wrap;
  196.       CASE typ.form OF
  197.         Array:
  198.         COCO.PutSeq("0x");
  199.         Strings.FromLInt(typ.n, 16, s); COCO.PutSeq(s); COCO.PutSeq("L, ");
  200.         COCQ.Link(x); COCN.CTSize(typ.BaseTyp, x.qoffs, np); COCQ.Unlink(x);
  201.         IF mode = 4 THEN
  202.           COCO.PutSeq(","); COCO.Wrap;
  203.           COCO.PutSeq("(pOt__TypDsc*)&"); COCQ.Link(x); COCN.CTDName(typ.BaseTyp, x.qoffs, np); COCQ.Unlink(x)
  204.         END;
  205.         COCO.Wrap
  206.       | Record:
  207.         COCQ.Link(x); COCN.CTSize(typ, x.qoffs, np); COCQ.Unlink(x); 
  208.         COCO.PutSeq(","); COCO.Wrap;
  209.         COCO.PutSeq("0x"); Strings.FromLInt(typ.n, 16, s); COCO.PutSeq(s); 
  210.         COCO.PutSeq(", ");
  211.         COCO.PutSeq("0x"); Strings.FromLInt(nstr, 16, s); COCO.PutSeq(s); 
  212.         COCO.PutSeq(", ");
  213.         COCO.PutSeq("0x"); Strings.FromLInt(nptr, 16, s); COCO.PutSeq(s); 
  214.         COCO.PutSeq(", ");
  215.         COCO.PutSeq("0x"); Strings.FromLInt(npro, 16, s); COCO.PutSeq(s); 
  216.         COCO.PutSeq(","); COCO.Wrap;
  217.         COCO.PutSeq("{");
  218.         iext := SHORT(typ.n); base := typ.BaseTyp;
  219.         WHILE iext # 0 DO DEC(iext);
  220.           basetyps[iext] := base;
  221.           base := base.BaseTyp
  222.         END;  
  223.         IF typ.n # 0 THEN
  224.           LOOP COCO.PutSeq("(pOt__RecTypDsc*)&"); 
  225.             COCQ.Link(x); COCN.CTDName(basetyps[iext], x.qoffs, np); COCQ.Unlink(x);
  226.             INC(iext); IF iext = SHORT(typ.n) THEN EXIT END;
  227.             COCO.PutSeq(", ")
  228.           END
  229.         END;  
  230.         IF iext # MaxExts THEN
  231.           IF iext = 0 THEN COCO.PutSeq("pOt_NIL"); INC(iext) END;
  232.           WHILE iext # MaxExts DO COCO.PutSeq(", pOt_NIL"); INC(iext) END
  233.         END;
  234.         COCO.PutSeq("}"); 
  235.         IF nfld # 0 THEN COCO.PutSeq(","); COCO.Wrap; 
  236.           COCO.PutSeq("{"); COCO.Wrap;
  237.           COCO.Indent;
  238.           x.mode := Fld; x.mnolev := 0;
  239.           ifld := 0;
  240.           IF nstr # 0 THEN
  241.             fld := typ.link;
  242.             LOOP
  243.               IF (fld.name # "") & (fld.typ.form IN {Array, Record}) THEN
  244.                 COCO.PutSeq("{(pOt_LONGINT)&((");
  245.                 COCQ.Link(x); COCN.CTDenoter(typ, x.qoffs, np); COCQ.Unlink(x);
  246.                 COCO.PutSeq("*)0)->");
  247.                 x.obj := fld; x.typ := fld.typ;
  248.                 COCQ.Link(x); COCN.CObjName(x, x.qoffs, np); COCQ.Unlink(x);
  249.                 COCO.PutSeq(", (pOt__TypDsc*)&");
  250.                 COCQ.Link(x); COCN.CTDName(fld.typ, x.qoffs, np); COCQ.Unlink(x);
  251.                 COCO.PutSeq("}");
  252.                 INC(ifld);
  253.                 IF ifld # nfld THEN COCO.PutSeq(",") END
  254.               END;  
  255.               IF ifld = nstr THEN EXIT END;
  256.               fld := fld.next
  257.             END;
  258.             COCO.Wrap
  259.           END;
  260.           IF nptr # 0 THEN
  261.             INC(nptr, nstr);
  262.             fld := typ.link;
  263.             LOOP
  264.               IF (fld.name # "") & (fld.typ.form = Pointer) THEN
  265.                 COCO.PutSeq("{(pOt_LONGINT)&((");
  266.                 COCQ.Link(x); COCN.CTDenoter(typ, x.qoffs, np); COCQ.Unlink(x);
  267.                 COCO.PutSeq("*)0)->");
  268.                 x.obj := fld; x.typ := fld.typ;
  269.                 COCQ.Link(x); COCN.CObjName(x, x.qoffs, np); COCQ.Unlink(x);
  270.                 COCO.PutSeq(", pOt_NIL}");
  271.                 INC(ifld);
  272.                 IF ifld # nfld THEN COCO.PutSeq(",") END
  273.               END;  
  274.               IF ifld = nptr THEN EXIT END;
  275.               fld := fld.next
  276.             END;
  277.             COCO.Wrap
  278.           END;
  279.           IF npro # 0 THEN
  280.             INC(npro, nptr);
  281.             fld := typ.link;
  282.             LOOP
  283.               IF (fld.name # "") & (fld.typ.form = ProcTyp) THEN
  284.                 COCO.PutSeq("{(pOt_LONGINT)&((");
  285.                 COCQ.Link(x); COCN.CTDenoter(typ, x.qoffs, np); COCQ.Unlink(x);
  286.                 COCO.PutSeq("*)0)->");
  287.                 x.obj := fld; x.typ := fld.typ;
  288.                 COCQ.Link(x); COCN.CObjName(x, x.qoffs, np); COCQ.Unlink(x);
  289.                 COCO.PutSeq(", pOt_NIL}");
  290.                 INC(ifld);
  291.                 IF ifld # nfld THEN COCO.PutSeq(",") END
  292.               END;  
  293.               IF ifld = npro THEN EXIT END;
  294.               fld := fld.next
  295.             END;
  296.             COCO.Wrap
  297.           END;
  298.           COCO.Undent;
  299.           COCO.PutSeq("}")
  300.         END;
  301.         COCO.Wrap
  302.       END;
  303.       COCO.Undent;
  304.       COCO.PutSeq("};"); COCO.Wrap;
  305.       INC(iofrec)
  306.     END;
  307.     IF COCT.level = 0 THEN bofrec := nofrec
  308.     ELSE nofrec := bofrec
  309.     END
  310.   END InitTypDescs;  
  311.  
  312. BEGIN PtrSize := 4
  313. END COCD.  
  314.