home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / language / oberon / potsrc / src / mod / coch < prev    next >
Encoding:
Text File  |  1995-01-22  |  9.5 KB  |  266 lines
  1. MODULE COCH;    (*NW 7.6.87 / 19.7.92 *) (* DT 19 10 1993 21:07 *)
  2.  
  3.   IMPORT COCS, COCT, COCD, COCQ, COCP;  
  4.   
  5.   CONST  
  6.    (*object and item modes*)  
  7.     Var   =  1; Ind   =  3; Con   =  8; Stk   =  9; Reg   = 11; Fld   = 12;
  8.         Typ = 13; LProc = 14; XProc = 15;  CProc = 17; IProc = 18; Mod   = 19;
  9.   
  10.    (*structure forms*)  
  11.     Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;  
  12.     Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;  
  13.     Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;  
  14.   
  15.   PROCEDURE StartLinStmt*(VAR x: COCT.Item): INTEGER;  
  16.     VAR qoffs: INTEGER;
  17.   BEGIN qoffs := x.qoffs; COCQ.Link(x); 
  18.     IF x.qoffs = 0 THEN COCQ.Dummy END; 
  19.     RETURN qoffs  
  20.   END StartLinStmt;  
  21.  
  22.   PROCEDURE StopLinStmt*(VAR x: COCT.Item; qoffs: INTEGER);     
  23.     VAR np: INTEGER;
  24.   BEGIN COCQ.Unlink(x); x.qoffs := qoffs  
  25.   END StopLinStmt;  
  26.  
  27.   PROCEDURE DynArrBnd(ftyp, atyp: COCT.Struct; varpar: BOOLEAN);  
  28.     VAR f: INTEGER; 
  29.   BEGIN (* ftyp.form = DynArr *)  
  30.     IF varpar & (ftyp.BaseTyp.form = Byte) THEN  (* byte array *)
  31.       IF atyp.form # DynArr THEN  
  32.         IF (atyp.form # Array) OR (atyp.BaseTyp.form > SInt) THEN COCS.Mark(-1) END;  
  33.       ELSE atyp := atyp.BaseTyp;  
  34.         IF atyp.form # DynArr THEN  
  35.           IF atyp.form > SInt THEN COCS.Mark(-1) END  
  36.         ELSE COCS.Mark(-1);  
  37.           REPEAT atyp := atyp.BaseTyp UNTIL atyp.form # DynArr
  38.         END 
  39.       END  
  40.     ELSE  
  41.       LOOP f := atyp.form;  
  42.         IF (f # Array) & (f # DynArr) THEN COCS.Mark(66); EXIT END ;  
  43.         ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp;  
  44.         IF ftyp.form # DynArr THEN  
  45.           IF ftyp # atyp THEN COCS.Mark(67) END ;  
  46.           EXIT  
  47.         END  
  48.       END  
  49.     END  
  50.   END DynArrBnd;  
  51.   
  52.   PROCEDURE CompareParLists*(x, y: COCT.Object);  
  53.     VAR xt, yt: COCT.Struct;  
  54.   BEGIN  
  55.     WHILE x # NIL DO  
  56.       IF y # NIL THEN  
  57.         xt := x.typ; yt := y.typ;  
  58.         WHILE (xt.form = DynArr) & (yt.form = DynArr) DO  
  59.           xt := xt.BaseTyp; yt := yt.BaseTyp  
  60.         END ;  
  61.         IF x.mode # y.mode THEN COCS.Mark(115)  
  62.         ELSIF xt # yt THEN  
  63.           IF (xt.form = ProcTyp) & (yt.form = ProcTyp) THEN  
  64.             CompareParLists(xt.link, yt.link)  
  65.           ELSE COCS.Mark(115)  
  66.           END  
  67.         END ;  
  68.         y := y.next  
  69.       ELSE COCS.Mark(116)  
  70.       END ;  
  71.       x := x.next  
  72.     END ;  
  73.     IF (y # NIL) & (y.mode <= Ind) & (y.intval = 1) THEN COCS.Mark(117) END  
  74.   END CompareParLists;  
  75.   
  76.   PROCEDURE AssignPrefix*(VAR x: COCT.Item);
  77.   BEGIN 
  78.     IF x.mode >= Con THEN COCS.Mark(56)
  79.     ELSIF (x.mode = Var) & (x.mnolev < 0) THEN COCS.Mark(-3)
  80.     END;
  81.     COCP.AssignPfx(x, COCT.typchk)
  82.   END AssignPrefix;
  83.   
  84.   PROCEDURE Assign*(VAR x, y: COCT.Item);  
  85.     VAR f, g, L: INTEGER;
  86.         p, q: COCT.Struct;  
  87.   BEGIN IF y.mode = Typ THEN COCS.Mark(126) END;
  88.         f := x.typ.form; g := y.typ.form;  
  89.     CASE f OF  
  90.       Undef, String:  
  91.     | Byte: IF ~(g IN {Undef, Byte, Char, SInt}) THEN COCS.Mark(113) END
  92.     | Bool, Char, SInt, Set: IF g # f THEN COCS.Mark(113) END 
  93.     | Int:  IF ~(g IN {SInt, Int}) THEN  COCS.Mark(113) END
  94.     | LInt: IF ~(g IN {SInt .. LInt}) THEN COCS.Mark(113) END
  95.     | Real: IF ~(g IN {SInt .. Real}) THEN COCS.Mark(113) END
  96.     | LReal:IF ~(g IN {SInt .. LReal}) THEN COCS.Mark(113) END
  97.     | Pointer:  
  98.       IF (x.typ = y.typ) OR (g = NilTyp) THEN (* OK *)      
  99.       ELSIF g = Pointer THEN        
  100.         p := x.typ.BaseTyp; q := y.typ.BaseTyp;        
  101.         IF (p.form = Record) & (q.form = Record) THEN        
  102.           WHILE (q # p) & (q # NIL) DO q := q.BaseTyp END ;        
  103.           IF q = NIL THEN COCS.Mark(113) END        
  104.         ELSE COCS.Mark(113)        
  105.         END        
  106.       ELSE COCS.Mark(113)        
  107.       END        
  108.     | Array: 
  109.       IF x.typ = y.typ THEN (* OK *)
  110.       ELSIF (g = String) & (x.typ.BaseTyp = COCT.chartyp) THEN        
  111.         L := SHORT(y.intval MOD 100H) + 1;
  112.         IF L > x.typ.n THEN COCS.Mark(114) 
  113.         ELSIF L + COCD.Overhead < x.typ.n THEN COCS.Mark(244)
  114.         END
  115.       ELSE COCS.Mark(113)        
  116.       END        
  117.     | DynArr: 
  118.       IF (g = String) & (x.typ.BaseTyp.form = Char) THEN (* OK *)
  119.       ELSIF y.mode > Ind THEN COCS.Mark(59)          
  120.       ELSE DynArrBnd(x.typ, y.typ, FALSE)          
  121.       END           
  122.     | Record: 
  123.       IF x.typ # y.typ THEN        
  124.         IF g = Record THEN        
  125.           q := y.typ.BaseTyp;        
  126.           WHILE (q # NIL) & (q # x.typ) DO q := q.BaseTyp END ;        
  127.           IF q = NIL THEN COCS.Mark(113) END        
  128.         ELSE COCS.Mark(113)        
  129.         END        
  130.       END
  131.     | ProcTyp:  
  132.       IF (x.typ = y.typ) OR (y.typ = COCT.niltyp) THEN (* OK *)
  133.       ELSIF (y.mode = XProc) OR (y.mode = IProc) THEN        
  134.         (*procedure y to proc. variable x; check compatibility*)        
  135.         IF x.typ.BaseTyp = y.typ THEN        
  136.           CompareParLists(x.typ.link, y.obj.dsc)
  137.         ELSE COCS.Mark(118)        
  138.         END        
  139.       ELSIF y.mode = LProc THEN COCS.Mark(119)        
  140.       ELSE COCS.Mark(111)        
  141.       END        
  142.     | NoTyp, NilTyp: COCS.Mark(111)  
  143.         END;
  144.     COCP.AssignSfx(x,y)
  145.   END Assign;  
  146.   
  147.   PROCEDURE PrepCall*(VAR x: COCT.Item; VAR fpar: COCT.Object): INTEGER;  
  148.     VAR qoffs: INTEGER;
  149.   BEGIN qoffs := x.qoffs; COCQ.Link(x); COCP.ParamListPfx;
  150.     IF (x.mode = LProc) OR (x.mode = XProc) OR (x.mode = CProc) THEN  
  151.       fpar := x.obj.dsc  
  152.     ELSIF (x.typ # NIL) & (x.typ.form = ProcTyp) THEN  
  153.       fpar := x.typ.link  
  154.     ELSE COCS.Mark(121); fpar := NIL; x.typ := COCT.undftyp  
  155.     END;
  156.     RETURN qoffs
  157.   END PrepCall;  
  158.  
  159.   PROCEDURE ParamPrefix*(f: COCT.Object);
  160.   BEGIN COCP.ParamPfx(f)
  161.   END ParamPrefix;
  162.   
  163.   PROCEDURE Param*(VAR ap: COCT.Item; f: COCT.Object);  
  164.     
  165.     VAR q: COCT.Struct; fp: COCT.Item;  
  166.  
  167.     PROCEDURE ValParam(VAR x,y: COCT.Item);
  168.       VAR f, g: INTEGER; L: INTEGER; p: COCT.Struct;
  169.     BEGIN 
  170.             IF y.mode = Typ THEN COCS.Mark(126) END;
  171.             f := x.typ.form; g := y.typ.form;  
  172.       CASE f OF  
  173.         Undef, String:  
  174.       | Byte: IF ~(g IN {Undef, Byte, Char, SInt}) THEN COCS.Mark(113) END
  175.       | Bool, Char, SInt, Set: IF g # f THEN COCS.Mark(113) END 
  176.       | Int:  IF ~(g IN {SInt, Int}) THEN  COCS.Mark(113) END
  177.       | LInt: IF ~(g IN {SInt .. LInt}) THEN COCS.Mark(113) END
  178.       | Real: IF ~(g IN {SInt .. Real}) THEN COCS.Mark(113) END
  179.       | LReal:IF ~(g IN {SInt .. LReal}) THEN COCS.Mark(113) END
  180.       | Pointer:  
  181.         IF (x.typ = y.typ) OR (g = NilTyp) THEN (* OK *)      
  182.         ELSIF g = Pointer THEN        
  183.           p := x.typ.BaseTyp; q := y.typ.BaseTyp;        
  184.           IF (p.form = Record) & (q.form = Record) THEN        
  185.             WHILE (q # p) & (q # NIL) DO q := q.BaseTyp END ;        
  186.             IF q = NIL THEN COCS.Mark(113) END        
  187.           ELSE COCS.Mark(113)        
  188.           END        
  189.         ELSE COCS.Mark(113)        
  190.         END        
  191.       | Array: 
  192.         IF x.typ = y.typ THEN (* OK *)
  193.         ELSIF (g = String) & (x.typ.BaseTyp = COCT.chartyp) THEN        
  194.           L := SHORT(y.intval MOD 100H) + 1;
  195.           IF L > x.typ.n THEN COCS.Mark(114) 
  196.           ELSIF L + COCD.Overhead < x.typ.n THEN COCS.Mark(244)
  197.           END
  198.         ELSE COCS.Mark(113)        
  199.         END        
  200.       | DynArr: 
  201.         IF (g = String) & (x.typ.BaseTyp.form = Char) THEN (* OK *)
  202.         ELSIF y.mode > Ind THEN COCS.Mark(59)          
  203.         ELSE DynArrBnd(x.typ, y.typ, FALSE)          
  204.         END           
  205.       | Record: 
  206.         IF x.typ # y.typ THEN        
  207.           IF g = Record THEN        
  208.             q := y.typ.BaseTyp;        
  209.             WHILE (q # NIL) & (q # x.typ) DO q := q.BaseTyp END ;        
  210.             IF q = NIL THEN COCS.Mark(113) END        
  211.           ELSE COCS.Mark(113)        
  212.           END        
  213.         END
  214.       | ProcTyp:  
  215.         IF (x.typ = y.typ) OR (y.typ = COCT.niltyp) THEN (* OK *)
  216.         ELSIF (y.mode = XProc) OR (y.mode = IProc) THEN        
  217.           (*procedure y to proc. variable x; check compatibility*)        
  218.           IF x.typ.BaseTyp = y.typ THEN        
  219.             CompareParLists(x.typ.link, y.obj.dsc)
  220.           ELSE COCS.Mark(118)        
  221.           END        
  222.         ELSIF y.mode = LProc THEN COCS.Mark(119)        
  223.         ELSE COCS.Mark(111)        
  224.         END        
  225.       | NoTyp, NilTyp: COCS.Mark(111)  
  226.       END  
  227.     END ValParam;
  228.  
  229.   BEGIN fp.mode := Stk; fp.typ := f.typ;  
  230.     IF f.mode = Ind THEN (*VAR parameter*)  
  231.       IF ap.mode >= Con THEN COCS.Mark(122) END ;  
  232.       IF fp.typ.form = DynArr THEN  
  233.         DynArrBnd(fp.typ, ap.typ, TRUE)
  234.       ELSIF (f.typ.form = Record) & (ap.typ.form = Record) THEN  
  235.         q := ap.typ;  
  236.         WHILE (q # f.typ) & (q # NIL) DO q := q.BaseTyp END ;  
  237.         IF q = NIL THEN COCS.Mark(111) END 
  238.       ELSIF (ap.typ = f.typ) OR ((f.typ.form = Byte) & (ap.typ.form IN {Char, SInt})) THEN  
  239.       ELSE COCS.Mark(123)  
  240.       END  
  241.     ELSE ValParam(fp, ap)  
  242.     END;
  243.     COCP.ParamSfx(ap, f)
  244.   END Param;  
  245.  
  246.   PROCEDURE NextParam*;
  247.   BEGIN COCP.NextParam 
  248.   END NextParam;
  249.   
  250.   PROCEDURE Call*(VAR x: COCT.Item; qoffs: INTEGER);  
  251.   BEGIN COCP.ParamListSfx; COCQ.Unlink(x); x.qoffs := qoffs;
  252.     IF (x.mode < Con) & (x.typ # COCT.undftyp) THEN x.typ := x.typ.BaseTyp
  253.     ELSIF ~(x.mode IN {LProc .. IProc}) THEN COCS.Mark(121)
  254.     END;
  255.         IF x.typ # COCT.notyp THEN x.mode := Reg END
  256.   END Call;  
  257.  
  258.   PROCEDURE Trap*(num: SHORTINT);
  259.     VAR x: COCT.Item; qoffs: INTEGER;
  260.   BEGIN IF num >= 20H THEN HALT(20H) END;
  261.     x.intval := num;
  262.     qoffs := StartLinStmt(x); COCP.Trap(x); StopLinStmt(x, qoffs)
  263.   END Trap;
  264.  
  265. END COCH.  
  266.