home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 10 / Fresh_Fish_10_2352.bin / new / dev / obero / oberon / projectoberonsrc / obp.mod (.txt) < prev    next >
Oberon Text  |  1994-10-17  |  31KB  |  944 lines
  1. Syntax10.Scn.Fnt
  2. MODULE Compiler;   (*NW 7.6.87 / 21.8.92 / 14.12.93*)
  3.     IMPORT SYSTEM, Texts, TextFrames, Viewers, Oberon, OBS, OBT, OBC, OBE, OBH;
  4.     CONST NofCases = 128; ModNameLen = 20; MaxRecs = 32;
  5.         RecDescSize = 8; AdrSize = 4; ProcSize = 4; PtrSize = 4;
  6.         XParOrg = 12; LParOrg = 8; LDataSize = 2000H;
  7.         (*symbol values*)
  8.             times = 1; slash = 2; div = 3; mod = 4;
  9.             and = 5; plus = 6; minus = 7; or = 8; eql = 9;
  10.             neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
  11.             in = 15; is = 16; arrow = 17; period = 18; comma = 19;
  12.             colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24;
  13.             of = 25; then = 26; do = 27; to = 28; lparen = 29;
  14.             lbrak = 30; lbrace = 31; not = 32; becomes = 33; number = 34;
  15.             nil = 35; string = 36; ident = 37; semicolon = 38; bar = 39;
  16.             end = 40; else = 41; elsif = 42; until = 43; if = 44;
  17.             case = 45; while = 46; repeat = 47; loop = 48; with = 49;
  18.             exit = 50; return = 51; for = 52; by = 53;
  19.             array = 54; record = 55; pointer = 56;
  20.             begin = 57; const = 58; type = 59; var = 60; procedure = 61;
  21.             import = 62; module = 63;
  22.         (*object and item modes*)
  23.             Var = 1; Ind = 3; Con = 8; Stk = 9; Stk0 = 10; Fld = 13; Typ = 14;
  24.             LProc = 15; SProc = 16; CProc = 17; IProc = 18; Mod = 19;
  25.         (*structure forms*)
  26.             Undef = 0; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6; Real = 7; LReal = 8; Set = 9; String = 10;
  27.             NilTyp = 11; NoTyp = 12; Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
  28.             intSet = {4 .. 6}; labeltyps = {3 .. 6};
  29.     VAR W: Texts.Writer;
  30.             sym, nofrecs: INTEGER;
  31.             newSF: BOOLEAN;
  32.             dsize: LONGINT;
  33.             LoopLevel, ExitNo: INTEGER;
  34.             LoopExit: ARRAY 16 OF INTEGER;
  35.     PROCEDURE^ Type(VAR typ: OBT.Struct);
  36.     PROCEDURE^ FormalType(VAR typ: OBT.Struct);
  37.     PROCEDURE^ Expression(VAR x: OBT.Item);
  38.     PROCEDURE^ Block(VAR dsize: LONGINT);
  39.     PROCEDURE CheckSym(s: INTEGER);
  40.     BEGIN
  41.         IF sym = s THEN OBS.Get(sym) ELSE OBS.Mark(s) END
  42.     END CheckSym;
  43.     PROCEDURE qualident(VAR x: OBT.Item);
  44.         VAR mnolev: INTEGER; obj: OBT.Object;
  45.     BEGIN (*sym = ident*)
  46.         OBT.Find(obj, mnolev); OBS.Get(sym);
  47.         IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
  48.             OBS.Get(sym); mnolev := SHORT(-obj.a0);
  49.             IF sym = ident THEN
  50.                 OBT.FindImport(obj, obj); OBS.Get(sym)
  51.             ELSE OBS.Mark(10); obj := NIL
  52.             END
  53.         END ;
  54.         x.lev := mnolev; x.obj := obj;
  55.         IF obj # NIL THEN
  56.             x.mode := obj.mode; x.typ := obj.typ; x.a0 := obj.a0; x.a1 := obj.a1
  57.         ELSE OBS.Mark(0); x.mode := Var;
  58.             x.typ := OBT.undftyp; x.a0 := 0; x.obj := NIL
  59.         END
  60.     END qualident;
  61.     PROCEDURE ConstExpression(VAR x: OBT.Item);
  62.     BEGIN Expression(x);
  63.         IF x.mode # Con THEN
  64.             OBS.Mark(50); x.mode := Con; x.typ := OBT.inttyp; x.a0 := 1
  65.         END
  66.     END ConstExpression;
  67.     PROCEDURE NewStr(form: INTEGER): OBT.Struct;
  68.         VAR typ: OBT.Struct;
  69.     BEGIN NEW(typ);
  70.         typ.form := form; typ.mno := 0; typ.size := 4; typ.ref := 0;
  71.         typ.BaseTyp := OBT.undftyp; typ.strobj := NIL; RETURN typ
  72.     END NewStr;
  73.     PROCEDURE CheckMark(VAR mk: BOOLEAN);
  74.     BEGIN OBS.Get(sym);
  75.         IF sym = times THEN
  76.             IF OBC.level = 0 THEN mk := TRUE ELSE mk := FALSE; OBS.Mark(47) END ;
  77.             OBS.Get(sym)
  78.         ELSE mk := FALSE
  79.         END
  80.     END CheckMark;
  81.     PROCEDURE CheckUndefPointerTypes;
  82.         VAR obj: OBT.Object;
  83.     BEGIN obj := OBT.topScope.next;
  84.         WHILE obj # NIL DO
  85.             IF obj.mode = Undef THEN OBS.Mark(48) END ;
  86.             obj := obj.next
  87.         END
  88.     END CheckUndefPointerTypes;
  89.     PROCEDURE RecordType(VAR typ: OBT.Struct);
  90.         VAR adr, size: LONGINT;
  91.             fld, fld0, fld1: OBT.Object;
  92.             ftyp, btyp: OBT.Struct;
  93.             base: OBT.Item;
  94.     BEGIN adr := 0; typ := NewStr(Record); typ.BaseTyp := NIL; typ.extlev := 0;
  95.         IF sym = lparen THEN
  96.             OBS.Get(sym); (*record extension*)
  97.             IF sym = ident THEN
  98.                 qualident(base);
  99.                 IF (base.mode = Typ) & (base.typ.form = Record) THEN
  100.                     typ.BaseTyp := base.typ; typ.extlev := base.typ.extlev + 1; adr := base.typ.size
  101.                 ELSE OBS.Mark(52)
  102.                 END
  103.             ELSE OBS.Mark(10)
  104.             END ;
  105.             CheckSym(rparen)
  106.         END ;
  107.         OBT.OpenScope(0); fld := NIL; fld1 := OBT.topScope;
  108.         LOOP
  109.             IF sym = ident THEN
  110.                 LOOP
  111.                     IF sym = ident THEN
  112.                         IF typ.BaseTyp # NIL THEN
  113.                             OBT.FindField(typ.BaseTyp, fld0);
  114.                             IF fld0 # NIL THEN OBS.Mark(1) END
  115.                         END ;
  116.                         OBT.Insert(OBS.name, fld); CheckMark(fld.marked); fld.mode := Fld
  117.                     ELSE OBS.Mark(10)
  118.                     END ;
  119.                     IF sym = comma THEN OBS.Get(sym)
  120.                     ELSIF sym = ident THEN OBS.Mark(19)
  121.                     ELSE EXIT
  122.                     END
  123.                 END ;
  124.                 CheckSym(colon); Type(ftyp); size := ftyp.size; btyp := ftyp;
  125.                 WHILE btyp.form = Array DO btyp := btyp.BaseTyp END ;
  126.                 IF btyp.size >= 4 THEN INC(adr, (-adr) MOD 4)
  127.                 ELSIF btyp.size = 2 THEN INC(adr, adr MOD 2)
  128.                 END ;
  129.                 WHILE fld1.next # NIL DO
  130.                     fld1 := fld1.next; fld1.typ := ftyp; fld1.a0 := adr; INC(adr, size)
  131.                 END
  132.             END ;
  133.             IF sym = semicolon THEN OBS.Get(sym)
  134.             ELSIF sym = ident THEN OBS.Mark(38)
  135.             ELSE EXIT
  136.             END
  137.         END ;
  138.         typ.size := (-adr) MOD 4 + adr; typ.mno := 0; typ.link := OBT.topScope.next;
  139.         CheckUndefPointerTypes; OBT.CloseScope;
  140.         IF OBC.level = 0 THEN INC(dsize, (-dsize) MOD 4 + 4); typ.adr := -dsize END ;
  141.         OBC.RegisterRecType(typ)
  142.     END RecordType;
  143.     PROCEDURE ArrayType(VAR typ: OBT.Struct);
  144.         VAR x: OBT.Item; f, n: INTEGER;
  145.     BEGIN typ := NewStr(Array); ConstExpression(x); f := x.typ.form;
  146.         IF f IN intSet THEN
  147.             IF x.a0 <= 0 THEN x.a0 := 1; OBS.Mark(63) END
  148.         ELSE OBS.Mark(51); x.a0 := 1
  149.         END ;
  150.         IF sym = of THEN OBS.Get(sym); Type(typ.BaseTyp)
  151.         ELSIF sym = comma THEN OBS.Get(sym); ArrayType(typ.BaseTyp)
  152.         ELSE OBS.Mark(34)
  153.         END ;
  154.         typ.size := x.a0 * typ.BaseTyp.size
  155.     END ArrayType;
  156.     PROCEDURE FormalParameters(VAR resTyp: OBT.Struct; VAR psize: LONGINT);
  157.         VAR mode: SHORTINT;
  158.             adr, size: LONGINT; res: OBT.Item;
  159.             par, par1: OBT.Object; typ: OBT.Struct;
  160.     BEGIN par1 := OBT.topScope; adr := 0;
  161.         IF (sym = ident) OR (sym = var) THEN
  162.             LOOP
  163.                 IF sym = var THEN OBS.Get(sym); mode := Ind ELSE mode := Var END ;
  164.                 LOOP
  165.                     IF sym = ident THEN
  166.                         OBT.Insert(OBS.name, par); OBS.Get(sym); par.mode := mode
  167.                     ELSE OBS.Mark(10)
  168.                     END ;
  169.                     IF sym = comma THEN OBS.Get(sym)
  170.                     ELSIF sym = ident THEN OBS.Mark(19)
  171.                     ELSIF sym = var THEN OBS.Mark(19); OBS.Get(sym)
  172.                     ELSE EXIT
  173.                     END
  174.                 END ;
  175.                 CheckSym(colon); FormalType(typ);
  176.                 IF mode = Ind THEN (*VAR param*)
  177.                     IF typ.form = Record THEN size := RecDescSize
  178.                     ELSIF typ.form = DynArr THEN size := typ.size
  179.                     ELSE size := AdrSize
  180.                     END
  181.                 ELSE size := (-typ.size) MOD 4 + typ.size
  182.                 END ;
  183.                 WHILE par1.next # NIL DO
  184.                     par1 := par1.next; par1.typ := typ; DEC(adr, size); par1.a0 := adr
  185.                 END ;
  186.                 IF sym = semicolon THEN OBS.Get(sym)
  187.                 ELSIF sym = ident THEN OBS.Mark(38)
  188.                 ELSE EXIT
  189.                 END
  190.             END
  191.         END ;
  192.         psize := psize - adr; par := OBT.topScope.next;
  193.         WHILE par # NIL DO INC(par.a0, psize); par := par.next END ;
  194.         CheckSym(rparen);
  195.         IF sym = colon THEN
  196.             OBS.Get(sym); resTyp := OBT.undftyp;
  197.             IF sym = ident THEN qualident(res);
  198.                 IF res.mode = Typ THEN
  199.                     IF (res.typ.form <= ProcTyp) & (res.typ.form # NoTyp) THEN resTyp := res.typ
  200.                     ELSE OBS.Mark(54)
  201.                     END
  202.                 ELSE OBS.Mark(52)
  203.                 END
  204.             ELSE OBS.Mark(10)
  205.             END
  206.         ELSE resTyp := OBT.notyp
  207.         END
  208.     END FormalParameters;
  209.     PROCEDURE ProcType(VAR typ: OBT.Struct);
  210.         VAR psize: LONGINT;
  211.     BEGIN typ := NewStr(ProcTyp); typ.size := ProcSize;
  212.         IF sym = lparen THEN
  213.             OBS.Get(sym); OBT.OpenScope(OBC.level); psize := XParOrg;
  214.             FormalParameters(typ.BaseTyp, psize); typ.link := OBT.topScope.next;
  215.             OBT.CloseScope
  216.         ELSE typ.BaseTyp := OBT.notyp; typ.link := NIL
  217.         END
  218.     END ProcType;
  219.     PROCEDURE HasPtr(typ: OBT.Struct): BOOLEAN;
  220.         VAR fld: OBT.Object;
  221.     BEGIN
  222.         IF typ.form = Pointer THEN RETURN TRUE
  223.         ELSIF typ.form = Array THEN RETURN HasPtr(typ.BaseTyp)
  224.         ELSIF typ.form = Record THEN
  225.             IF (typ.BaseTyp # NIL) & HasPtr(typ.BaseTyp) THEN RETURN TRUE END ;
  226.             fld := typ.link;
  227.             WHILE fld # NIL DO
  228.                 IF (fld.name = "") OR HasPtr(fld.typ) THEN RETURN TRUE END ;
  229.                 fld := fld.next
  230.             END
  231.         END ;
  232.         RETURN FALSE
  233.     END HasPtr;
  234.     PROCEDURE SetPtrBase(ptyp, btyp: OBT.Struct);
  235.     BEGIN
  236.         IF (btyp.form = Record) OR (btyp.form = Array) & ~HasPtr(btyp.BaseTyp) THEN
  237.             ptyp.BaseTyp := btyp
  238.         ELSE ptyp.BaseTyp := OBT.undftyp; OBS.Mark(57)
  239.         END
  240.     END SetPtrBase;
  241.     PROCEDURE Type(VAR typ