home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 5 / DATAFILE_PDCD5.iso / utilities / p / potland / Sources / src / mod / pot < prev    next >
Encoding:
Text File  |  1995-05-07  |  36.8 KB  |  1,153 lines
  1. MODULE POT;   (*NW 7.6.87 / 19.7.92*) (* DT $Date: 1995/01/27 13:46:48 $ *)
  2.   IMPORT OS, Files, Texts, COCS, COCO, COCT, COCE, COCH, COCD, COCC,Throwback;
  3.  
  4.   CONST
  5.     NofCases = 2048; ModNameLen = 31;
  6.    (*symbol values*)
  7.     times = 1; slash = 2; div = 3; mod = 4;
  8.     and = 5; plus = 6; minus = 7; or = 8; eql = 9;
  9.     neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
  10.     in = 15; is = 16; arrow = 17; period = 18; comma = 19;
  11.     colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24;
  12.     of = 25; then = 26; do = 27; to = 28; lparen = 29;
  13.     lbrak = 30; lbrace = 31; not = 32; becomes = 33; number = 34;
  14.     nil = 35; string = 36; ident = 37; semicolon = 38; bar = 39;
  15.     end = 40; else = 41; elsif = 42; until = 43; if = 44;
  16.     case = 45; while = 46; repeat = 47; loop = 48; with = 49;
  17.     exit = 50; return = 51; array = 52; record = 53; pointer = 54;
  18.     begin = 55; const = 56; type = 57; var = 58; procedure = 59;
  19.     import = 60; module = 61;
  20.  
  21.    (*object and item modes*)
  22.     Var = 1; Ind = 3; Con = 8; Fld = 12; Typ = 13;
  23.     LProc = 14; XProc = 15; SProc = 16; CProc = 17; IProc = 18; Mod = 19;
  24.  
  25.    (*structure forms*)
  26.     Undef = 0; Char = 3; SInt = 4; Int = 5; LInt = 6;
  27.     NoTyp = 12;
  28.     Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
  29.  
  30.     intSet = {SInt .. LInt}; labeltyps = {Char .. LInt};
  31.  
  32.   TYPE
  33.      LabelRange = RECORD low, high: LONGINT END;
  34.  
  35.   VAR MaxArrLen: LONGINT; (* SYSTEM dependant *)
  36.     W: Texts.Writer;
  37.     sym: INTEGER;
  38.     symchg, hchg, newSF, newHF: BOOLEAN;
  39.     LoopLevel, LoopNo: INTEGER;
  40.     TmpFName, FName: ARRAY Files.MaxPathLength + 1 OF CHAR;
  41.     CaseTab: ARRAY NofCases OF LabelRange;
  42.     BofCTab: INTEGER;
  43.  
  44.   PROCEDURE^ Type(VAR typ: COCT.Struct);
  45.   PROCEDURE^ FormalType(VAR typ: COCT.Struct);
  46.   PROCEDURE^ Expression(VAR x: COCT.Item);
  47.   PROCEDURE^ Block(proc: COCT.Object);
  48.  
  49.   PROCEDURE CheckSym(s: INTEGER);
  50.   BEGIN
  51.     IF sym = s THEN COCS.Get(sym) ELSE COCS.Mark(s) END
  52.   END CheckSym;
  53.  
  54.   PROCEDURE qualident(VAR x: COCT.Item);
  55.     VAR mnolev: INTEGER; obj: COCT.Object;
  56.   BEGIN (*sym = ident*)
  57.     COCT.Find(obj, mnolev); COCS.Get(sym);
  58.     IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
  59.       COCS.Get(sym); mnolev := -obj.mnolev;
  60.       IF sym = ident THEN
  61.         COCT.FindImport(obj, obj); COCS.Get(sym)
  62.       ELSE COCS.Mark(10); obj := NIL
  63.       END
  64.     END;
  65.     x.mnolev := mnolev; x.obj := obj;
  66.     IF obj # NIL THEN
  67.       x.mode := obj.mode; x.typ := obj.typ;
  68.       x.intval := obj.intval; x.fltval := obj.fltval;
  69.       IF x.mode <= Ind THEN COCT.VarMode(x) END
  70.     ELSE
  71.       COCS.Mark(0);
  72.       x.mode := Var; x.typ := COCT.undftyp; x.obj := NIL
  73.     END
  74.   END qualident;
  75.  
  76.   PROCEDURE ConstExpression(VAR x: COCT.Item);
  77.     VAR qoffs: INTEGER;
  78.   BEGIN
  79.     qoffs := COCE.StartExpr(x);
  80.     Expression(x);
  81.     COCE.StopConstExpr(x, qoffs);
  82.     IF x.mode # Con THEN
  83.       COCS.Mark(50); x.mode := Con; x.typ := COCT.inttyp; x.intval := 1
  84.     ELSIF (x.typ = COCT.stringtyp) & (x.obj # NIL) & (x.mnolev < 0) THEN
  85.       COCS.Mark(221); INC(x.intval, 100H)
  86.     END
  87.   END ConstExpression;
  88.  
  89.   PROCEDURE StringExpression(VAR x: COCT.Item; typ: COCT.Struct);
  90.     VAR qoffs: INTEGER; s: ARRAY 2 OF CHAR;
  91.   BEGIN
  92.     qoffs := COCE.StartExpr(x);
  93.     Expression(x);
  94.     IF (x.mode = Con) & (x.typ.form = Char) THEN
  95.       IF x.intval < 100H THEN
  96.         s[0] := CHR(x.intval); s[1] := 0X;
  97.         COCD.AllocString(s, x);
  98.         IF x.obj # NIL THEN x.obj.intval := x.intval END
  99.       END;
  100.       x.intval := x.intval - (x.intval MOD 100H) + 1;
  101.       x.typ := COCT.stringtyp
  102.     END;
  103.     COCE.StopStringExpr(x, qoffs, typ)
  104.   END StringExpression;
  105.  
  106.   PROCEDURE NewStr(VAR typ: COCT.Struct; form: SHORTINT);
  107.   BEGIN NEW(typ);
  108.     typ.form := form; typ.mno := 0; typ.ref := 0;
  109.     typ.BaseTyp := COCT.undftyp; typ.strobj := NIL
  110.   END NewStr;
  111.  
  112.   PROCEDURE CheckMark(VAR mk: BOOLEAN);
  113.   BEGIN COCS.Get(sym);
  114.     IF sym = times THEN
  115.       IF COCT.level = 0 THEN mk := TRUE ELSE mk := FALSE; COCS.Mark(47) END;
  116.       COCS.Get(sym)
  117.     ELSE mk := FALSE
  118.     END
  119.   END CheckMark;
  120.  
  121.   PROCEDURE CheckUndefPointerTypes;
  122.     VAR obj: COCT.Object;
  123.   BEGIN obj := COCT.topScope.next;
  124.     WHILE obj # NIL DO
  125.       IF obj.mode = Undef THEN COCS.Mark(48) END;
  126.       obj := obj.next
  127.     END
  128.   END CheckUndefPointerTypes;
  129.  
  130.   PROCEDURE RecordType(VAR typ: COCT.Struct);
  131.     VAR fld, fld0, fld1: COCT.Object;
  132.       ftyp: COCT.Struct;
  133.       base: COCT.Item;
  134.       name: ARRAY 1 OF CHAR;
  135.   BEGIN NewStr(typ, Record); typ.BaseTyp := NIL; typ.n := 0;
  136.     IF sym = lparen THEN
  137.       COCS.Get(sym); (*record extension*)
  138.       IF sym = ident THEN
  139.         qualident(base);
  140.         IF (base.mode = Typ) & (base.typ.form = Record) THEN
  141.           typ.BaseTyp := base.typ; typ.n := base.typ.n + 1
  142.         ELSE COCS.Mark(52)
  143.         END
  144.       ELSE COCS.Mark(10)
  145.       END;
  146.       CheckSym(rparen)
  147.     END;
  148.     name := ""; COCT.OpenScope(0, name);
  149.     fld := NIL; fld1 := COCT.topScope;
  150.     LOOP
  151.       IF sym = ident THEN
  152.         LOOP
  153.           IF sym = ident THEN
  154.             IF typ.BaseTyp # NIL THEN
  155.               COCT.FindField(typ.BaseTyp, fld0);
  156.               IF fld0 # NIL THEN COCS.Mark(1) END
  157.             END;
  158.             COCT.Insert(COCS.name, fld); CheckMark(fld.marked); fld.mode := Fld;
  159.             fld.mnolev := SHORT(typ.n)
  160.           ELSE COCS.Mark(10)
  161.           END;
  162.           IF sym = comma THEN COCS.Get(sym)
  163.           ELSIF sym = ident THEN COCS.Mark(19)
  164.           ELSE EXIT
  165.           END
  166.         END;
  167.         CheckSym(colon); Type(ftyp);
  168.         WHILE fld1.next # NIL DO
  169.           fld1 := fld1.next; fld1.typ := ftyp
  170.         END
  171.       END;
  172.       IF sym = semicolon THEN COCS.Get(sym)
  173.       ELSIF sym = ident THEN COCS.Mark(38)
  174.       ELSE EXIT
  175.       END
  176.     END;
  177.     typ.link := COCT.topScope.next;
  178.     CheckUndefPointerTypes; COCT.CloseScope;
  179.     COCD.AllocTypDesc(typ)
  180.   END RecordType;
  181.  
  182.   PROCEDURE ArrayType(VAR typ: COCT.Struct);
  183.     VAR x: COCT.Item; f, n: INTEGER;
  184.   BEGIN NewStr(typ, Array); ConstExpression(x); f := x.typ.form;
  185.     IF f IN intSet THEN
  186.       IF (0 < x.intval) & (x.intval <= MaxArrLen) THEN n := SHORT(x.intval)
  187.       ELSE n := 1; COCS.Mark(63)
  188.       END
  189.     ELSE COCS.Mark(51); n := 1
  190.     END;
  191.     typ.n := n;
  192.     IF sym = of THEN
  193.       COCS.Get(sym); Type(typ.BaseTyp)
  194.     ELSIF sym = comma THEN
  195.       COCS.Get(sym); ArrayType(typ.BaseTyp)
  196.     ELSE COCS.Mark(34)
  197.     END;
  198.     COCD.AllocTypDesc(typ)
  199.   END ArrayType;
  200.  
  201.   PROCEDURE FormalParameters(VAR resTyp: COCT.Struct);
  202.     VAR mode: SHORTINT; res: COCT.Item;
  203.         par, par1: COCT.Object; typ: COCT.Struct;
  204.   BEGIN par1 := COCT.topScope;
  205.     IF (sym = ident) OR (sym = var) THEN
  206.       LOOP
  207.         IF sym = var THEN COCS.Get(sym); mode := Ind ELSE mode := Var END;
  208.         LOOP
  209.           IF sym = ident THEN
  210.             COCT.Insert(COCS.name, par); COCS.Get(sym); par.mode := mode
  211.           ELSE COCS.Mark(10)
  212.           END;
  213.           IF sym = comma THEN COCS.Get(sym)
  214.           ELSIF sym = ident THEN COCS.Mark(19)
  215.           ELSIF sym = var THEN COCS.Mark(19); COCS.Get(sym)
  216.           ELSE EXIT
  217.           END
  218.         END;
  219.         CheckSym(colon); FormalType(typ);
  220.         WHILE par1.next # NIL DO
  221.           par1 := par1.next; par1.typ := typ; par1.intval := 1 (* par mark *)
  222.         END;
  223.         IF sym = semicolon THEN COCS.Get(sym)
  224.         ELSIF sym = ident THEN COCS.Mark(38)
  225.         ELSE EXIT
  226.         END
  227.       END
  228.     END;
  229.     CheckSym(rparen);
  230.     IF sym = colon THEN
  231.       COCS.Get(sym); resTyp := COCT.undftyp;
  232.       IF sym = ident THEN qualident(res);
  233.         IF res.mode = Typ THEN
  234.           IF (res.typ.form <= ProcTyp) & (res.typ.form # NoTyp) THEN resTyp := res.typ ELSE COCS.Mark(54) END
  235.         ELSE COCS.Mark(52)
  236.         END
  237.       ELSE COCS.Mark(10)
  238.       END
  239.     ELSE resTyp := COCT.notyp
  240.     END
  241.   END FormalParameters;
  242.  
  243.   PROCEDURE ProcType(VAR typ: COCT.Struct);
  244.     VAR name: ARRAY 1 OF CHAR;
  245.   BEGIN NewStr(typ, ProcTyp);
  246.     IF sym = lparen THEN
  247.       COCS.Get(sym); name := "";
  248.       COCT.OpenScope(COCT.level, name);
  249.       FormalParameters(typ.BaseTyp); typ.link := COCT.topScope.next;
  250.       COCT.CloseScope
  251.     ELSE typ.BaseTyp := COCT.notyp; typ.link := NIL
  252.     END
  253.   END ProcType;
  254.  
  255.   PROCEDURE SetPtrBase(ptyp, btyp: COCT.Struct);
  256.   BEGIN
  257.     IF (btyp.form = Record) OR (btyp.form = Array) THEN
  258.       ptyp.BaseTyp := btyp
  259.     ELSE ptyp.BaseTyp := COCT.undftyp; COCS.Mark(57)
  260.     END
  261.   END SetPtrBase;
  262.  
  263.   PROCEDURE Type(VAR typ: COCT.Struct);
  264.     VAR lev: INTEGER; obj: COCT.Object; x: COCT.Item;
  265.   BEGIN typ := COCT.undftyp;
  266.     IF sym < lparen THEN COCS.Mark(12);
  267.       REPEAT COCS.Get(sym) UNTIL sym >= lparen
  268.     END;
  269.     IF sym = ident THEN qualident(x);
  270.       IF x.mode = Typ THEN typ := x.typ;
  271.         IF typ = COCT.notyp THEN COCS.Mark(58) END
  272.       ELSE COCS.Mark(52)
  273.       END
  274.     ELSIF sym = array THEN
  275.       COCS.Get(sym); ArrayType(typ)
  276.     ELSIF sym = record THEN
  277.       COCS.Get(sym); RecordType(typ); CheckSym(end)
  278.     ELSIF sym = pointer THEN
  279.       COCS.Get(sym); NewStr(typ, Pointer); typ.link := NIL;
  280.       CheckSym(to);
  281.       IF sym = ident THEN COCT.Find(obj, lev);
  282.         IF obj = NIL THEN (*forward ref*)
  283.           COCT.Insert(COCS.name, obj); typ.BaseTyp := COCT.undftyp;
  284.           obj.mode := Undef; obj.typ := typ; COCS.Get(sym)
  285.         ELSE qualident(x);
  286.           IF x.mode = Typ THEN SetPtrBase(typ, x.typ)
  287.           ELSE typ.BaseTyp := COCT.undftyp; COCS.Mark(52)
  288.           END
  289.         END
  290.       ELSE Type(x.typ); SetPtrBase(typ, x.typ)
  291.       END
  292.     ELSIF sym = procedure THEN
  293.       COCS.Get(sym); ProcType(typ)
  294.     ELSE COCS.Mark(12)
  295.     END;
  296.     IF (sym < semicolon) OR (else < sym) THEN COCS.Mark(15);
  297.       WHILE (sym < ident) OR (else < sym) & (sym < begin) DO
  298.         COCS.Get(sym)
  299.       END
  300.     END
  301.   END Type;
  302.  
  303.   PROCEDURE FormalType(VAR typ: COCT.Struct);
  304.     VAR x: COCT.Item; typ0: COCT.Struct; n: LONGINT;
  305.   BEGIN typ := COCT.undftyp; n := 0;
  306.     WHILE sym = array DO
  307.       COCS.Get(sym); CheckSym(of); INC(n)
  308.     END;
  309.     IF sym = ident THEN qualident(x);
  310.       IF x.mode = Typ THEN typ := x.typ;
  311.         IF typ = COCT.notyp THEN COCS.Mark(58) END
  312.       ELSE COCS.Mark(52)
  313.       END
  314.     ELSIF sym = procedure THEN COCS.Get(sym); ProcType(typ)
  315.     ELSE COCS.Mark(10)
  316.     END;
  317.     WHILE n > 0 DO
  318.       NewStr(typ0, DynArr); typ0.BaseTyp := typ;
  319.       typ0.mno := 0; typ := typ0; DEC(n)
  320.     END
  321.   END FormalType;
  322.  
  323.   PROCEDURE selector(VAR x: COCT.Item);
  324.     VAR fld: COCT.Object; y: COCT.Item; qoffs: INTEGER;
  325.   BEGIN
  326.     qoffs := COCE.StartObj(x);
  327.     LOOP
  328.       IF sym = lbrak THEN COCS.Get(sym);
  329.         LOOP
  330.           IF (x.typ # NIL) & (x.typ.form = Pointer) THEN COCE.DeRef(x) END;
  331.           COCE.IndexPrefix(x); Expression(y); COCE.Index(x, y);
  332.           IF sym = comma THEN COCS.Get(sym) ELSE EXIT END
  333.         END;
  334.         CheckSym(rbrak)
  335.       ELSIF sym = period THEN COCS.Get(sym);
  336.         IF sym = ident THEN
  337.           IF x.typ # NIL THEN
  338.             IF x.typ.form = Pointer THEN COCE.DeRef(x) END;
  339.             IF x.typ.form = Record THEN
  340.               COCT.FindField(x.typ, fld); COCE.Field(x, fld)
  341.             ELSE COCS.Mark(53)
  342.             END
  343.           ELSE COCS.Mark(52)
  344.           END;
  345.           COCS.Get(sym)
  346.         ELSE COCS.Mark(10)
  347.         END
  348.       ELSIF sym = arrow THEN
  349.         COCS.Get(sym); COCE.DeRef(x)
  350.       ELSIF (sym = lparen) & (x.mode < Typ) & (x.typ.form # ProcTyp) THEN
  351.         COCS.Get(sym);
  352.         IF sym = ident THEN
  353.           qualident(y);
  354.           IF y.mode = Typ THEN COCE.TypGuard(x, y)
  355.           ELSE COCS.Mark(52)
  356.           END
  357.         ELSE COCS.Mark(10)
  358.         END;
  359.         CheckSym(rparen)
  360.       ELSE EXIT
  361.       END
  362.     END;
  363.     COCE.StopObj(x, qoffs)
  364.   END selector;
  365.  
  366.   PROCEDURE ActualParameters(fpar: COCT.Object);
  367.     VAR apar: COCT.Item;  qoffs: INTEGER;
  368.   BEGIN
  369.     IF sym # rparen THEN
  370.       LOOP
  371.         IF ~COCT.IsParam(fpar) THEN COCS.Mark(64); Expression(apar)
  372.         ELSE
  373.           COCH.ParamPrefix(fpar);
  374.           IF (fpar.mode = Var) &
  375.                ((fpar.typ.form = Array) OR (fpar.typ.form = DynArr)) &
  376.                  (fpar.typ.BaseTyp.form = Char) THEN
  377.             StringExpression(apar, fpar.typ)
  378.           ELSE Expression(apar)
  379.           END;
  380.           COCH.Param(apar, fpar);
  381.           fpar := fpar.next
  382.         END;
  383.         IF sym = comma THEN COCS.Get(sym)
  384.         ELSIF (lparen <= sym) & (sym <= ident) THEN COCS.Mark(19)
  385.         ELSE EXIT
  386.         END;
  387.         COCH.NextParam
  388.       END
  389.     END;
  390.     IF COCT.IsParam(fpar) THEN COCS.Mark(65) END
  391.   END ActualParameters;
  392.  
  393.   PROCEDURE StandProcCall(VAR x: COCT.Item);
  394.     VAR y: COCT.Item; m, n: INTEGER; qoffs: INTEGER;
  395.   BEGIN m := SHORT(x.intval); n := 0;
  396.     qoffs := COCE.StartExpr(x);
  397.     COCE.TkFct(x, m);
  398.     IF sym = lparen THEN COCS.Get(sym);
  399.       IF sym # rparen THEN
  400.         LOOP
  401.           IF n = 0 THEN
  402.             IF m = 29 THEN StringExpression(x,NIL) ELSE Expression(x) END;
  403.             COCE.StPar1(x, m); n := 1
  404.           ELSIF n = 1 THEN Expression(y); COCE.StPar2(x, y, m); n := 2
  405.           ELSIF n = 2 THEN Expression(y); COCE.StPar3(x, y, m); n := 3
  406.           ELSE COCS.Mark(64); Expression(y)
  407.           END;
  408.           IF sym = comma THEN COCS.Get(sym)
  409.           ELSIF (lparen <= sym) & (sym <= ident) THEN COCS.Mark(19)
  410.           ELSE EXIT
  411.           END
  412.         END;
  413.         CheckSym(rparen)
  414.       ELSE COCS.Get(sym)
  415.       END
  416.     ELSE COCS.Mark(29)
  417.     END;
  418.     COCE.StFct(x, m, n);
  419.     COCE.StopExpr(x,qoffs)
  420.   END StandProcCall;
  421.  
  422.   PROCEDURE Sets(VAR x: COCT.Item);
  423.  
  424.     VAR y: COCT.Item; xqoffs, yqoffs: INTEGER;
  425.  
  426.     PROCEDURE Element(VAR x: COCT.Item);
  427.       VAR e1, e2: COCT.Item; qoffs: INTEGER;
  428.     BEGIN qoffs := COCE.StartExpr(x);
  429.       Expression(e1);
  430.       IF sym = upto THEN
  431.         COCS.Get(sym); COCE.Set10(x, e1); Expression(e2); COCE.Set11(x, e1, e2)
  432.       ELSE COCE.Set00(x, e1)
  433.       END;
  434.       COCE.StopExpr(x,qoffs)
  435.     END Element;
  436.  
  437.   BEGIN
  438.         x.obj := NIL; x.typ := COCT.settyp;
  439.         y.obj := NIL; y.typ := COCT.settyp;
  440.     xqoffs := COCE.StartExpr(x);
  441.     IF sym # rbrace THEN
  442.       Element(x);
  443.       LOOP
  444.         IF sym = comma THEN COCS.Get(sym)
  445.         ELSIF (lparen <= sym) & (sym <= ident) THEN COCS.Mark(19)
  446.         ELSE EXIT
  447.         END;
  448.         yqoffs := COCE.HookExpr(y);
  449.         Element(y); COCE.Op(plus, x, y)  (*x := x+y*)
  450.       END
  451.     ELSE x.mode := Con; x.intval := 0
  452.     END;
  453.     COCE.StopExpr(x, xqoffs);
  454.     CheckSym(rbrace)
  455.   END Sets;
  456.  
  457.   PROCEDURE Factor(VAR x: COCT.Item);
  458.     VAR fpar: COCT.Object; qoffs: INTEGER;
  459.   BEGIN
  460.     IF sym < lparen THEN COCS.Mark(13);
  461.       REPEAT COCS.Get(sym) UNTIL sym >= lparen
  462.     END;
  463.     IF sym = ident THEN
  464.       qualident(x);
  465.       IF x.mode = SProc THEN StandProcCall(x)
  466.       ELSIF x.mode = Con THEN COCE.Const(x)
  467.       ELSE
  468.         selector(x);
  469.         IF sym = lparen THEN
  470.           COCS.Get(sym);
  471.           qoffs := COCH.PrepCall(x, fpar); ActualParameters(fpar);
  472.           COCH.Call(x, qoffs);
  473.           CheckSym(rparen)
  474.         END
  475.       END
  476.     ELSIF sym = number THEN
  477.       COCS.Get(sym);
  478.             x.mode := Con; x.obj := NIL;
  479.       CASE COCS.numtyp OF
  480.         1: x.typ := COCT.chartyp; x.intval := COCS.intval
  481.       | 2: x.intval := COCS.intval; COCE.SetIntType(x)
  482.       | 3: x.typ := COCT.realtyp; x.fltval := COCS.realval
  483.       | 4: x.typ := COCT.lrltyp; x.fltval := COCS.lrlval
  484.       END;
  485.       COCE.Const(x)
  486.     ELSIF sym = string THEN
  487.       x.mode := Con; x.obj := NIL; x.typ := COCT.stringtyp;
  488.             x.intval := COCS.intval;
  489.       COCD.AllocString(COCS.name, x); COCS.Get(sym);
  490.       COCE.Const(x)
  491.     ELSIF sym = nil THEN
  492.       COCS.Get(sym);
  493.             x.mode := Con; x.obj := NIL; x.typ := COCT.niltyp;
  494.             x.intval := 0;
  495.       COCE.Const(x)
  496.     ELSIF sym = lparen THEN
  497.       COCS.Get(sym);
  498.       COCE.SubExprPrefix; Expression(x); COCE.SubExprSuffix;
  499.       CheckSym(rparen)
  500.     ELSIF sym = lbrak THEN
  501.       COCS.Get(sym); COCS.Mark(29);
  502.       COCE.SubExprPrefix; Expression(x); COCE.SubExprSuffix;
  503.       CheckSym(rparen)
  504.     ELSIF sym = lbrace THEN COCS.Get(sym); Sets(x)
  505.     ELSIF sym = not THEN COCS.Get(sym);
  506.       qoffs := COCE.StartExpr(x);
  507.       Factor(x); COCE.MOp(not, x);
  508.       COCE.StopExpr(x, qoffs)
  509.     ELSE COCS.Mark(13); COCS.Get(sym); x.typ := COCT.undftyp; x.mode := Var; x.intval := 0
  510.     END
  511.   END Factor;
  512.  
  513.   PROCEDURE Term(VAR x: COCT.Item);
  514.     VAR y: COCT.Item; mulop: INTEGER; xqoffs, yqoffs: INTEGER;
  515.   BEGIN xqoffs := COCE.StartExpr(x);
  516.     Factor(x);
  517.     WHILE (times <= sym) & (sym <= and) DO
  518.       mulop := sym; COCS.Get(sym);
  519.       IF mulop = and THEN COCE.MOp(and, x) END;
  520.       yqoffs := COCE.HookExpr(y);
  521.       Factor(y); COCE.Op(mulop, x, y)
  522.     END;
  523.     COCE.StopExpr(x, xqoffs)
  524.   END Term;
  525.  
  526.   PROCEDURE SimpleExpression(VAR x: COCT.Item);
  527.     VAR y: COCT.Item; addop: INTEGER; xqoffs, yqoffs: INTEGER;
  528.   BEGIN xqoffs := COCE.StartExpr(x);
  529.     IF sym = minus THEN COCS.Get(sym); Term(x); COCE.MOp(minus, x)
  530.     ELSIF sym = plus THEN COCS.Get(sym); Term(x); COCE.MOp(plus, x)
  531.     ELSE Term(x)
  532.     END;
  533.     WHILE (plus <= sym) & (sym <= or) DO
  534.       addop := sym; COCS.Get(sym);
  535.       IF addop = or THEN COCE.MOp(or, x) END;
  536.       yqoffs := COCE.HookExpr(y);
  537.       Term(y); COCE.Op(addop, x, y)
  538.     END;
  539.     COCE.StopExpr(x, xqoffs)
  540.   END SimpleExpression;
  541.  
  542.   PROCEDURE Expression(VAR x: COCT.Item);
  543.     VAR y: COCT.Item; relation: INTEGER; xqoffs,yqoffs: INTEGER;
  544.   BEGIN
  545.     xqoffs := COCE.StartExpr(x);
  546.     SimpleExpression(x);
  547.     IF (eql <= sym) & (sym <= geq) THEN
  548.       relation := sym; COCS.Get(sym);
  549.       yqoffs := COCE.HookExpr(y);
  550.       SimpleExpression(y); COCE.Op(relation, x, y)
  551.     ELSIF sym = in THEN
  552.       COCS.Get(sym); COCE.InPrefix(x);
  553.       yqoffs := COCE.HookExpr(y);
  554.       SimpleExpression(y); COCE.In(x, y)
  555.     ELSIF sym = is THEN
  556.       IF x.mode >= Typ THEN COCS.Mark(112) END;
  557.       COCS.Get(sym);
  558.       IF sym = ident THEN
  559.         qualident(y);
  560.         IF y.mode = Typ THEN COCE.TypTest(x, y) ELSE COCS.Mark(52) END
  561.       ELSE COCS.Mark(10)
  562.       END
  563.     END;
  564.     COCE.StopExpr(x, xqoffs)
  565.   END Expression;
  566.  
  567.   PROCEDURE ProcedureDeclaration;
  568.     VAR proc, proc1, par: COCT.Object;
  569.       L1: INTEGER;
  570.       mode: SHORTINT; body: BOOLEAN;
  571.   BEGIN proc := NIL; body := TRUE;
  572.     IF (sym # ident) & (COCT.level = 0) THEN
  573.       IF sym = times THEN mode := XProc
  574.       ELSIF sym = arrow THEN (*forward*) mode := XProc; body := FALSE
  575.       ELSIF sym = plus THEN mode := IProc
  576.       ELSIF sym = minus THEN mode := CProc; body := FALSE
  577.       ELSE mode := LProc; COCS.Mark(10)
  578.       END;
  579.       COCS.Get(sym)
  580.     ELSE mode := LProc
  581.     END;
  582.     IF sym = ident THEN
  583.       IF COCT.level = 0 THEN COCT.Find(proc1, L1) ELSE proc1 := NIL END;
  584.       IF (proc1 # NIL) & (proc1.mode = XProc) & (proc1.intval = 0) THEN
  585.         (*there exists a corresponding forward declaration*)
  586.         COCT.Remove(proc1); COCT.Insert(COCS.name, proc);
  587.         CheckMark(proc.marked); mode := XProc
  588.       ELSE
  589.         IF proc1 # NIL THEN COCS.Mark(1); proc1 := NIL END;
  590.         COCT.Insert(COCS.name, proc); CheckMark(proc.marked); proc.intval := 0;
  591.         IF proc.marked & (mode = LProc) THEN mode := XProc END
  592.       END;
  593.       proc.mode := mode; proc.typ := COCT.notyp; proc.dsc := NIL;
  594.       INC(COCT.level); COCT.OpenScope(COCT.level, proc.name);
  595.       IF sym = lparen THEN
  596.         COCS.Get(sym); FormalParameters(proc.typ); proc.dsc := COCT.topScope.next
  597.       END;
  598.       IF proc1 # NIL THEN  (*forward*)
  599.         COCH.CompareParLists(proc.dsc, proc1.dsc);
  600.         IF proc.typ # proc1.typ THEN COCS.Mark(118) END
  601.       END;
  602.       IF mode = CProc THEN
  603.         IF sym = number THEN proc.intval := COCS.intval; COCS.Get(sym) ELSE COCS.Mark(17) END
  604.       END;
  605.       IF body THEN CheckSym(semicolon); COCT.topScope.typ := proc.typ;
  606.         proc.intval := 1; par := proc.dsc;
  607.         Block(proc); proc.dsc := COCT.topScope.next;  (*update*)
  608.         IF sym = ident THEN
  609.           IF COCS.name # proc.name THEN COCS.Mark(4) END;
  610.           COCS.Get(sym)
  611.         ELSE COCS.Mark(10)
  612.         END
  613.       ELSE COCC.ForwardDeclaration(proc)
  614.       END;
  615.       DEC(COCT.level); COCT.CloseScope
  616.     END
  617.   END ProcedureDeclaration;
  618.  
  619.   PROCEDURE CaseLabelList(LabelForm: INTEGER; VAR n: INTEGER);
  620.     VAR x, y: COCT.Item; i, f: INTEGER;
  621.   BEGIN
  622.     IF ~(LabelForm IN labeltyps) THEN COCS.Mark(61) END;
  623.     LOOP ConstExpression(x); f := x.typ.form;
  624.       IF f IN intSet THEN
  625.         IF LabelForm < f THEN COCS.Mark(60) END (*inclusion*)
  626.       ELSIF f # LabelForm THEN COCS.Mark(60) (*CHAR*)
  627.       END;
  628.       IF sym = upto THEN
  629.         COCS.Get(sym); ConstExpression(y);
  630.         IF (y.typ.form # f) &
  631.           (~((f IN intSet) & (y.typ.form IN intSet))) THEN
  632.           COCS.Mark(60)
  633.         END;
  634.         IF y.intval < x.intval THEN COCS.Mark(63); y.intval := x.intval END
  635.       ELSE y := x
  636.       END;
  637.       COCC.CaseLabelList(x,y);
  638.       (*enter label range into ordered CaseTable*)
  639.       i := n;
  640.       IF i < NofCases THEN
  641.         LOOP
  642.           IF i = BofCTab THEN EXIT END;
  643.           IF CaseTab[i-1].low <= y.intval THEN
  644.             IF CaseTab[i-1].high >= x.intval THEN COCS.Mark(62) END;
  645.             EXIT
  646.           END;
  647.           CaseTab[i] := CaseTab[i-1]; DEC(i)
  648.         END;
  649.         CaseTab[i].low := SHORT(x.intval); CaseTab[i].high := SHORT(y.intval);
  650.         INC(n)
  651.       ELSE COCS.Mark(213)
  652.       END;
  653.       IF sym = comma THEN COCS.Get(sym)
  654.       ELSIF (sym = number) OR (sym = ident) THEN COCS.Mark(19)
  655.       ELSE EXIT
  656.       END
  657.     END
  658.   END CaseLabelList;
  659.  
  660.   PROCEDURE StatSeq(thisloop: INTEGER);
  661.     VAR fpar, wobj: COCT.Object; xtyp: COCT.Struct;
  662.         x, y: COCT.Item; nextloop: INTEGER;
  663.         qoffs: INTEGER;
  664.  
  665.     PROCEDURE CasePart;
  666.       VAR x: COCT.Item; prev, n: INTEGER;
  667.     BEGIN n := BofCTab; prev := BofCTab;
  668.       COCC.CasePfx; Expression(x); COCC.CaseSfx; CheckSym(of);
  669.       COCC.OpenScope;
  670.       LOOP
  671.         IF sym < bar THEN
  672.           CaseLabelList(x.typ.form, n);
  673.           BofCTab := n;
  674.           CheckSym(colon); StatSeq(thisloop);
  675.           BofCTab := prev
  676.         END;
  677.         IF sym = bar THEN COCC.CaseBar; COCS.Get(sym) ELSE EXIT END
  678.       END;
  679.       COCC.CaseElse;
  680.       IF sym = else THEN COCS.Get(sym); StatSeq(thisloop)
  681.       ELSE COCH.Trap(16); COCC.TermStmt
  682.       END;
  683.       COCC.CloseScope
  684.     END CasePart;
  685.  
  686.   BEGIN
  687.     LOOP
  688.       IF sym < ident THEN COCS.Mark(14);
  689.         REPEAT COCS.Get(sym) UNTIL sym >= ident
  690.       END;
  691.       IF sym = ident THEN
  692.         qualident(x);
  693.         IF x.mode = SProc THEN
  694.           StandProcCall(x);
  695.           IF x.typ # COCT.notyp THEN COCS.Mark(55) END
  696.         ELSE
  697.           qoffs := COCH.StartLinStmt(x);
  698.           selector(x);
  699.           IF sym = eql THEN COCS.Mark(33); sym := becomes END;
  700.           IF sym = becomes THEN COCS.Get(sym);
  701.             COCH.AssignPrefix(x);
  702.             IF ((x.typ.form = Array) OR (x.typ.form = DynArr)) &
  703.               (x.typ.BaseTyp.form = Char) THEN StringExpression(y, x.typ)
  704.             ELSE Expression(y)
  705.             END;
  706.             COCH.Assign(x, y);
  707.             COCH.StopLinStmt(x, qoffs)
  708.           ELSE COCH.StopLinStmt(x, qoffs); (* function call, no prefices *)
  709.             qoffs := COCH.PrepCall(x, fpar);
  710.             IF sym = lparen THEN
  711.               COCS.Get(sym); ActualParameters(fpar); CheckSym(rparen)
  712.             ELSIF COCT.IsParam(fpar) THEN COCS.Mark(65)
  713.             END;
  714.             COCH.Call(x, qoffs);
  715.             IF x.typ # COCT.notyp THEN COCS.Mark(55) END
  716.           END
  717.         END;
  718.         COCC.TermStmt
  719.       ELSIF sym = if THEN COCS.Get(sym);
  720.         COCC.IfPfx;
  721.                 Expression(x); IF x.typ # COCT.booltyp THEN COCS.Mark(120) END;
  722.                 COCC.IfSfx;
  723.         CheckSym(then); COCC.OpenScope; StatSeq(thisloop);
  724.         WHILE sym = elsif DO COCS.Get(sym);
  725.           COCC.Else;
  726.                     COCC.IfPfx;
  727.                     Expression(x); IF x.typ # COCT.booltyp THEN COCS.Mark(120) END;
  728.                     COCC.IfSfx;
  729.           CheckSym(then); COCC.OpenScope; StatSeq(thisloop)
  730.         END;
  731.         IF sym = else THEN COCS.Get(sym);
  732.           COCC.Else; COCC.OpenScope; StatSeq(thisloop)
  733.         END;
  734.         COCC.CloseScope;
  735.         CheckSym(end)
  736.       ELSIF sym = case THEN
  737.         COCS.Get(sym); CasePart; CheckSym(end)
  738.       ELSIF sym = while THEN COCS.Get(sym);
  739.         COCC.Loop; COCC.OpenScope;
  740.         COCC.LoopCondPfx;
  741.                 Expression(x); IF x.typ # COCT.booltyp THEN COCS.Mark(120) END;
  742.                 COCC.LoopCondSfx(TRUE);
  743.         CheckSym(do); StatSeq(thisloop);
  744.         COCC.CloseScope;
  745.         CheckSym(end)
  746.       ELSIF sym = repeat THEN COCS.Get(sym);
  747.         COCC.Loop; COCC.OpenScope;
  748.         StatSeq(thisloop);
  749.         IF sym = until THEN COCS.Get(sym);
  750.           COCC.LoopCondPfx;
  751.                     Expression(x); IF x.typ # COCT.booltyp THEN COCS.Mark(120) END;
  752.                     COCC.LoopCondSfx(FALSE)
  753.         ELSE COCS.Mark(43)
  754.         END;
  755.         COCC.CloseScope
  756.       ELSIF sym = loop THEN COCS.Get(sym);
  757.         INC(LoopNo); nextloop := LoopNo; INC(LoopLevel);
  758.         COCC.Loop; COCC.OpenScope;
  759.         StatSeq(nextloop);
  760.         COCC.CloseScope;
  761.         COCC.LoopLabel(nextloop);
  762.         DEC(LoopLevel);
  763.         CheckSym(end)
  764.       ELSIF sym = with THEN COCS.Get(sym); x.obj := NIL; xtyp := NIL;
  765.         IF sym = ident THEN
  766.           qualident(x); CheckSym(colon);
  767.           qoffs := COCE.StartObj(x);
  768.           IF sym = ident THEN qualident(y);
  769.             IF y.mode = Typ THEN
  770.               IF x.obj # NIL THEN
  771.                 IF x.typ.form = Pointer THEN COCS.Mark(-2) END;
  772.                 xtyp := x.typ; COCE.TypGuard(x, y); x.obj.typ := x.typ
  773.               ELSE COCS.Mark(130)
  774.               END
  775.             ELSE COCS.Mark(52)
  776.             END
  777.           ELSE COCS.Mark(10)
  778.           END;
  779.           COCE.StopObj(x, qoffs);
  780.           COCC.TermStmt
  781.         ELSE COCS.Mark(10)
  782.         END;
  783.         CheckSym(do);
  784.         IF x.obj # NIL THEN
  785.           COCT.OpenScope(COCT.level, COCT.topScope.name);
  786.           COCT.Insert(x.obj.name, wobj);
  787.           wobj.typ := x.obj.typ; wobj.mode := Ind;
  788.           wobj.intval := x.obj.intval;
  789.  
  790.           COCC.OpenScope;
  791.           COCC.With(x, wobj);
  792.           StatSeq(thisloop);
  793.           COCC.CloseScope;
  794.  
  795.           COCT.CloseScope;
  796.         ELSE StatSeq(thisloop)
  797.         END;
  798.         CheckSym(end);
  799.         IF xtyp # NIL THEN x.obj.typ := xtyp END
  800.       ELSIF sym = exit THEN COCS.Get(sym);
  801.         IF LoopLevel = 0 THEN COCS.Mark(45)
  802.         ELSE COCC.Exit(thisloop)
  803.         END
  804.       ELSIF sym = return THEN COCS.Get(sym);
  805.         IF COCT.level > 0 THEN
  806.           IF sym < semicolon THEN
  807.             x.typ := COCT.topScope.typ; x.mode := Var; x.mnolev := COCT.level;
  808.             qoffs := COCH.StartLinStmt(x);
  809.             COCC.Result(x); COCH.AssignPrefix(x); Expression(y); COCH.Assign(x, y);
  810.             COCH.StopLinStmt(x, qoffs); COCC.TermStmt
  811.           ELSIF COCT.topScope.typ # COCT.notyp THEN COCS.Mark(124)
  812.           END;
  813.           COCC.Return
  814.         ELSE (*return from module body*)
  815.           IF sym < semicolon THEN Expression(x); COCS.Mark(124) END;
  816.           COCC.Return
  817.         END
  818.       END;
  819.       IF sym = semicolon THEN COCS.Get(sym)
  820.       ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN COCS.Mark(38)
  821.       ELSE EXIT
  822.       END
  823.     END
  824.   END StatSeq;
  825.  
  826.   PROCEDURE Block(proc: COCT.Object);
  827.     VAR typ, forward: COCT.Struct;
  828.       obj, first: COCT.Object;
  829.       x: COCT.Item;
  830.       L0: INTEGER;
  831.       mk: BOOLEAN;
  832.       id0: ARRAY 32 OF CHAR;
  833.       big: BOOLEAN;
  834.  
  835.   BEGIN obj := COCT.topScope;
  836.     WHILE obj.next # NIL DO obj := obj.next END;
  837.     LOOP
  838.       IF sym = const THEN
  839.         COCS.Get(sym);
  840.         WHILE sym = ident DO
  841.           COPY(COCS.name, id0); CheckMark(mk);
  842.           IF sym = eql THEN COCS.Get(sym); ConstExpression(x)
  843.           ELSIF sym = becomes THEN COCS.Mark(9); COCS.Get(sym); ConstExpression(x)
  844.           ELSE COCS.Mark(9); obj.mode := Con; obj.typ := COCT.inttyp; obj.intval := 0
  845.           END;
  846.           COCT.Insert(id0, obj); obj.mode := x.mode;
  847.           obj.typ := x.typ; obj.intval := x.intval; obj.fltval := x.fltval; obj.marked := mk;
  848.           CheckSym(semicolon)
  849.         END
  850.       END;
  851.       IF sym = type THEN
  852.         COCS.Get(sym);
  853.         WHILE sym = ident DO
  854.           typ := COCT.undftyp; COCT.Insert(COCS.name, obj); forward := obj.typ;
  855.           obj.mode := Typ; obj.typ := COCT.notyp; CheckMark(obj.marked);
  856.           IF sym = eql THEN COCS.Get(sym); Type(typ)
  857.           ELSIF (sym = becomes) OR (sym = colon) THEN COCS.Mark(9); COCS.Get(sym); Type(typ)
  858.           ELSE COCS.Mark(9)
  859.           END;
  860.           obj.typ := typ;
  861.           IF typ.strobj = NIL THEN typ.strobj := obj END;
  862.           IF forward # NIL THEN (*fixup*) SetPtrBase(forward, typ) END;
  863.           CheckSym(semicolon)
  864.         END
  865.       END;
  866.       IF sym = var THEN
  867.         COCS.Get(sym);
  868.         WHILE sym = ident DO
  869.           COCT.Insert(COCS.name, obj); first := obj; CheckMark(obj.marked); obj.mode := Var;
  870.           LOOP
  871.             IF sym = comma THEN COCS.Get(sym)
  872.             ELSIF sym = ident THEN COCS.Mark(19)
  873.             ELSE EXIT
  874.             END;
  875.             IF sym = ident THEN
  876.               COCT.Insert(COCS.name, obj); CheckMark(obj.marked); obj.mode := Var
  877.             ELSE COCS.Mark(10)
  878.             END
  879.           END;
  880.           CheckSym(colon); Type(typ);
  881.           WHILE first # NIL DO
  882.             first.typ := typ; first.intval := 0;  (* non-parameter mark *)
  883.             first := first.next
  884.           END;
  885.           CheckSym(semicolon)
  886.         END
  887.       END;
  888.       IF (sym < const) OR (sym > var) THEN EXIT END;
  889.     END;
  890.     CheckUndefPointerTypes;
  891.     IF COCT.level = 0 THEN COCC.ModulePrologue
  892.     ELSE big := sym = procedure; COCC.OuterPrologue(proc, big)
  893.     END;
  894.     WHILE sym = procedure DO
  895.       COCS.Get(sym); ProcedureDeclaration; CheckSym(semicolon)
  896.     END;
  897.     IF COCT.level = 0 THEN COCC.BodyPrologue
  898.     ELSE COCC.InnerPrologue(proc, big)
  899.     END;
  900.     IF sym = begin THEN COCS.Get(sym);
  901.       LoopLevel := 0; LoopNo := 0; BofCTab := 0;
  902.       StatSeq(0)
  903.     END;
  904.     CheckSym(end);
  905.     IF COCT.level = 0 THEN COCC.BodyEpilogue
  906.     ELSE COCC.Epilogue(proc, big)
  907.     END
  908.   END Block;
  909.  
  910.   PROCEDURE CompilationUnit(SrcName: ARRAY OF CHAR);
  911.     VAR L0: INTEGER; ch: CHAR;
  912.       time, date, key, tm: LONGINT;
  913.       modid, impid: ARRAY 32 OF CHAR;
  914.       linenum: BOOLEAN;
  915.       res: INTEGER;
  916.       basename: ARRAY 32 OF CHAR;
  917.       trysymfile: Files.File;
  918.  
  919. (* Hacked for RISC OS filename conventions *)
  920.  
  921.     PROCEDURE MakeFileName(path: ARRAY OF CHAR;
  922.                            VAR name, FName: ARRAY OF CHAR; ext: ARRAY OF CHAR);
  923.       VAR i, j: INTEGER; ch: CHAR;
  924.     BEGIN i := 0; 
  925.       j := 0;
  926.       LOOP ch := path[j];
  927.         IF ch = 0X THEN EXIT END;
  928.         FName[i] := ch;
  929.         IF i # Files.MaxPathLength THEN INC(i) END; INC(j)
  930.       END;
  931.       j := 0;        
  932.       LOOP ch := ext[j];
  933.         IF ch = 0X THEN EXIT END;
  934.         FName[i] := ch;
  935.         IF i # Files.MaxPathLength THEN INC(i) END; INC(j)
  936.       END;
  937.       j := 0;
  938.       REPEAT ch := name[j]; FName[i] := ch;
  939.         IF i # Files.MaxPathLength THEN INC(i) END; INC(j)
  940.       UNTIL ch = 0X
  941.     END MakeFileName;
  942.  
  943.   BEGIN tm := OS.Time();
  944.     COCD.Init; COCT.Init;
  945.     OS.GC; (* The right place is here, because at the time of GC it's good to have all pointers initialized *)
  946.     COCS.Open(SrcName);
  947.     COCS.Get(sym);
  948.     Texts.WriteString(W, "  compiling ");
  949.     IF sym = module THEN COCS.Get(sym) ELSE COCS.Mark(16) END;
  950.     IF sym = ident THEN
  951.       Texts.WriteString(W, COCS.name);
  952.       Texts.Append(Files.StdOut, W.buf);
  953.       L0 := 0; ch := COCS.name[0];
  954.       WHILE (ch # 0X) & (L0 # ModNameLen) DO modid[L0] := ch; INC(L0); ch := COCS.name[L0] END;
  955.       modid[L0] := 0X;
  956.       IF ch # 0X THEN COCS.Mark(228) END;
  957.       COCT.OpenScope(0, modid); COCS.Get(sym);
  958.       CheckSym(semicolon);
  959.       IF sym = import THEN
  960.         COCS.Get(sym);
  961.         LOOP
  962.           IF sym = ident THEN
  963.             COPY(COCS.name, impid); COCS.Get(sym);
  964.             IF sym = becomes THEN COCS.Get(sym);
  965.               IF sym = ident THEN
  966.                 COPY(COCS.name, basename);
  967.                 COCS.Get(sym)
  968.               ELSE COCS.Mark(10)
  969.               END
  970.             ELSE COPY(impid, basename);
  971.             END;
  972.             MakeFileName("", basename, FName, "Cym.");
  973.             IF basename # "SYSTEM" THEN
  974.               trysymfile := Files.Old(FName);
  975.               IF trysymfile = NIL THEN
  976.                 MakeFileName("pOtLand:", basename, FName, "Cym.");
  977.               ELSE
  978.                 Files.Close(trysymfile);
  979.               END;
  980.             END;
  981.             COCT.Import(impid, modid, FName)
  982.           ELSE COCS.Mark(10)
  983.           END;
  984.           IF sym = comma THEN COCS.Get(sym)
  985.           ELSIF sym = ident THEN COCS.Mark(19)
  986.           ELSE EXIT
  987.           END
  988.         END;
  989.         CheckSym(semicolon)
  990.       END;
  991.       IF ~COCS.scanerr THEN
  992.         MakeFileName("", modid, FName, "c."); COCO.Open(FName);
  993.         Block(NIL);
  994.         IF sym = ident THEN
  995.           IF COCS.name # modid THEN COCS.Mark(4) END;
  996.           COCS.Get(sym)
  997.         ELSE COCS.Mark(10)
  998.         END;
  999.         IF sym # period THEN COCS.Mark(18) END;
  1000.         IF ~COCS.scanerr THEN
  1001.           Texts.Write(W, " ");
  1002.           Texts.WriteInt(W, COCO.Size(), 6);
  1003.           Texts.Append(Files.StdOut, W.buf);
  1004.           COCO.Close;
  1005.  
  1006.           linenum := COCO.linenum; COCO.linenum := FALSE;
  1007.  
  1008.           MakeFileName("",modid, FName, "hi.");
  1009.           COCO.Open(FName);
  1010.           COCC.InitData;
  1011.           Texts.Write(W, " ");
  1012.           Texts.WriteInt(W, COCO.Size(), 6);
  1013.           Texts.Append(Files.StdOut, W.buf);
  1014.           COCO.Close;
  1015.  
  1016.           MakeFileName("", modid, TmpFName, "TMP.");
  1017.  
  1018.           MakeFileName("", modid, FName, "Cym.");
  1019.           newSF := symchg;
  1020.           OS.GetClock(time, date); key := (date MOD 4000H) * 20000H + time;
  1021.           COCT.Export(modid, TmpFName, FName, newSF, key);
  1022.           IF ~COCS.scanerr THEN
  1023.             IF newSF THEN
  1024.               Texts.WriteString(W, " new symbol file");
  1025.               Texts.Append(Files.StdOut, W.buf)
  1026.             END;
  1027.  
  1028.             COCO.Open(TmpFName);
  1029.             COCC.CExport;
  1030.             Texts.Write(W, " ");
  1031.             Texts.WriteInt(W, COCO.Size(), 6);
  1032.             Texts.Append(Files.StdOut, W.buf);
  1033.             COCO.Close;
  1034.  
  1035.             MakeFileName("", modid, FName, "h.");
  1036.             newHF := hchg;
  1037.             COCC.CommitCExport(TmpFName, FName, newHF);
  1038.             IF ~COCS.scanerr THEN
  1039.               IF newHF THEN
  1040.                 Texts.WriteString(W, " new h-file");
  1041.                 Texts.Append(Files.StdOut, W.buf)
  1042.               END;
  1043.  
  1044.               Texts.WriteString(W, " ");
  1045.               Texts.WriteInt(W, OS.Time() - tm, 6); Texts.WriteLn(W);
  1046.               Texts.Append(Files.StdOut, W.buf)
  1047.             END
  1048.           END;
  1049.  
  1050.           IF COCS.scanerr THEN (* remove the code if errors in exort *)
  1051.             MakeFileName("", modid, FName, "hi.");
  1052.             Files.Delete(FName, res);
  1053.             MakeFileName("", modid, FName, "c.");
  1054.             Files.Delete(FName, res)
  1055.           END;
  1056.  
  1057.           COCO.linenum := linenum
  1058.         ELSE COCO.Purge
  1059.         END
  1060.       END;
  1061.       COCT.CloseScope
  1062.     ELSE COCS.Mark(10)
  1063.     END;
  1064.     COCS.Close; COCT.Close
  1065.   END CompilationUnit;
  1066.  
  1067.   PROCEDURE Compile*;
  1068.     VAR parfile: Texts.Text; srcfile: Files.File;
  1069.       Par: Texts.Reader;
  1070.       i: INTEGER; ch: CHAR;
  1071.   BEGIN
  1072.     OS.GetParFile(FName);
  1073.     Texts.Open(parfile,FName); Texts.OpenReader(Par, parfile, 0);
  1074.     Texts.Read(Par, ch);
  1075.     WHILE ch # 0X DO
  1076.       IF ch = "-" THEN Texts.Read(Par, ch);
  1077.         LOOP
  1078.           CASE CAP(ch) OF
  1079.             "F": COCO.fold := ch = "F"
  1080.           | "H": hchg := ch = "H"
  1081.           | "I": COCE.inxchk := ch = "I"
  1082.           | "L": COCS.linecol := ch = "L"
  1083.           | "M": COCO.macwrap := ch = "M"
  1084.           | "N": COCO.linenum := ch = "N"
  1085.           | "O": COCE.nilchk := ch = "O"
  1086.           | "P": COCC.tempsafe := ch = "P"
  1087.           | "R": COCE.rngchk := ch = "R"
  1088.           | "S": symchg := ch = "S"
  1089.           | "T": COCT.typchk := ch = "T"
  1090.           | "U": COCO.unxwrap := ch = "U"
  1091.           ELSE
  1092.             IF ch > " " THEN
  1093.               Texts.WriteString(W, "wrong parameter -");
  1094.               Texts.Write(W, ch); Texts.WriteLn(W);
  1095.               Texts.Append(Files.StdOut, W.buf)
  1096.             ELSE EXIT
  1097.             END
  1098.           END;
  1099.           Texts.Read(Par, ch)
  1100.         END
  1101.       ELSIF ch > " " THEN i := 0;
  1102.         LOOP
  1103.           IF i = Files.MaxPathLength THEN
  1104.             REPEAT Texts.Read(Par, ch) UNTIL ch <= " ";
  1105.             EXIT
  1106.           END;
  1107.           FName[i] := ch; INC(i);
  1108.           Texts.Read(Par, ch);
  1109.           IF ch <= " " THEN EXIT END
  1110.         END;
  1111.         FName[i] := 0X; srcfile := Files.Old(FName);
  1112.         IF srcfile # NIL THEN Files.Close(srcfile);
  1113.           Throwback.Start();
  1114.           CompilationUnit(FName);
  1115.           Throwback.End();
  1116.         ELSE Texts.WriteString(W, FName);
  1117.           Texts.WriteString(W, " not found"); Texts.WriteLn(W);
  1118.           Texts.Append(Files.StdOut, W.buf)
  1119.         END
  1120.       ELSE Texts.Read(Par, ch)
  1121.       END
  1122.     END;
  1123.     Texts.Close(parfile)
  1124.   END Compile;
  1125.  
  1126. BEGIN MaxArrLen := 7FFFFFFFH; (* SYSTEM Dependant *)
  1127.   symchg := FALSE; hchg := FALSE;
  1128.   Texts.OpenWriter(W);
  1129.   Texts.WriteString(W, "Portable Oberon Translator (Archimedes version) $Revision: 1.33 $ NW 19.7.92 / $Date: 1995/01/27 13:46:48 (Arc 1995/05/06)$ ");
  1130.   Texts.WriteLn(W);
  1131.   Texts.Append(Files.StdOut, W.buf)
  1132. END POT.
  1133.  
  1134. (*
  1135. $Log: pot.mod,v $
  1136. # Revision 1.33  1995/01/27  13:46:48  dvd
  1137. # Code procedures for C functions
  1138. #
  1139. # Revision 1.32  1995/01/25  00:57:44  dvd
  1140. # Uncaught error 120 is fixed.
  1141. #
  1142. # Revision 1.31  1995/01/20  22:01:49  dvd
  1143. # <item>.obj is now initialized to NIL
  1144. #
  1145. # Revision 1.30  1994/12/05  19:37:00  dvd
  1146. # Error reporting is improved.
  1147. #
  1148. # Revision 1.21  1994/10/31  10:02:53  dvd
  1149. # Memory usage is improved by moving explicit call to GC after
  1150. # the initialization of static structures.
  1151. #
  1152. *)
  1153.