home *** CD-ROM | disk | FTP | other *** search
- MODULE COCC; (* DVD 04 09 1993 02:01 *) (* Adapted to RISC OS naming conventions *)
- (* Controlling code *)
- IMPORT Strings, Files, COCS, COCT, COCD, COCQ, COCN, COCJ, COCO, COCH, COCY;
-
- CONST
- (*object modes*)
- Var = 1; Ind = 3; Con = 8; Fld = 12; Typ = 13;
- LProc = 14; XProc = 15; SProc = 16; CProc = 17; IProc = 18;
- Mod = 19;
-
- (*structure forms*)
- Byte = 1; Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
-
- (*module export mark*)
- NotYetExp = 0;
-
- (*variable modes*)
- Defi = 0; Refe = 1; Twin = 2; Decl = 3;
-
- (*modifiers*)
- Extern = 0; Static = 1; Interrupt = 2; Typedef = 3;
-
- VAR tempsafe*:BOOLEAN;
-
- PROCEDURE Logo;
- BEGIN COCO.PutComment("This code is generated by pOt."); COCO.Wrap
- END Logo;
-
- PROCEDURE TermStmt*;
- BEGIN COCO.PutSeq(";"); COCO.Wrap
- END TermStmt;
-
- PROCEDURE OpenScope*;
- BEGIN COCO.PutSeq("{"); COCO.Wrap; COCO.Indent
- END OpenScope;
-
- PROCEDURE CloseScope*;
- BEGIN COCO.Undent; COCO.PutSeq("}"); COCO.Wrap
- END CloseScope;
-
- PROCEDURE InitVar(VAR x: COCT.Item);
- VAR np: INTEGER;
- BEGIN
- IF x.typ # COCT.undftyp THEN
- COCQ.Link(x); COCN.CObjName(x, x.qoffs, np);
- IF x.typ.form IN {Pointer, ProcTyp} THEN
- COCQ.Unlink(x); COCO.PutSeq("=pOt_NIL"); TermStmt
- ELSIF x.typ.form IN {Array, Record} THEN
- COCO.PutSeq("pOt__init_var((pOt__TypDsc**)&"); COCQ.Unlink(x);
- COCO.PutSeq(",(pOt__TypDsc*)&");
- COCQ.Link(x); COCN.CTDName(x.typ, x.qoffs, np); COCQ.Unlink(x);
- COCO.PutSeq(")"); TermStmt
- ELSE COCQ.Drop(x)
- END
- END
- END InitVar;
-
- PROCEDURE OuterPrologue*(proc: COCT.Object; big: BOOLEAN);
- VAR obj, firstvar: COCT.Object;
- BEGIN
- obj := COCT.topScope.next; firstvar := NIL;
- WHILE (obj # NIL) & (obj.mode <= Typ) DO
- IF obj.mode = Con THEN COCY.ConstObj(obj, Defi); obj := obj.next
- ELSIF obj.mode = Typ THEN COCY.TypeObj(obj); obj := obj.next
- ELSIF obj.mode <= Ind THEN
- IF big & (firstvar = NIL) THEN firstvar := obj END;
- REPEAT obj := obj.next UNTIL (obj = NIL) OR (obj.mode > Ind)
- END
- END; COCO.Wrap;
- COCD.InitTypDescs; COCO.Wrap;
-
- obj := firstvar;
- COCY.StartVOList;
- WHILE (obj # NIL) & (obj.mode <= Typ) DO
- IF obj.mode <= Ind THEN
- REPEAT COCY.VarObj(obj, Refe); obj := obj.next
- UNTIL (obj = NIL) OR (obj.mode > Ind);
- ELSE obj := obj.next
- END
- END;
- COCY.StopVOList; COCO.Wrap;
-
- IF big THEN COCY.ProcObj(proc, Refe); COCO.Wrap END
- END OuterPrologue;
-
- PROCEDURE ForwardDeclaration*(proc: COCT.Object);
- BEGIN COCY.ProcObj(proc, Refe); COCO.Wrap
- END ForwardDeclaration;
-
- PROCEDURE InnerPrologue*(proc: COCT.Object; big: BOOLEAN);
- VAR firstvar, obj: COCT.Object;
- np: INTEGER; x: COCT.Item;
- nptr, nstr: INTEGER;
- BEGIN COCY.ProcObj(proc, Defi);
- OpenScope;
- IF proc.typ # COCT.notyp THEN COCY.RetObj(proc) END;
- obj := COCT.topScope.next; firstvar := NIL;
- nptr := 0; nstr := 0;
- COCY.StartVOList;
- WHILE (obj # NIL) & (obj.mode <= Typ) DO
- IF obj.mode <= Ind THEN
- IF firstvar = NIL THEN firstvar := obj END;
- REPEAT
- IF obj.mode = Var THEN
- IF obj.typ.form = Pointer THEN INC(nptr)
- ELSIF (obj.typ.form IN {Array .. Record}) & COCT.HasPtr(obj.typ) THEN INC(nstr)
- END
- END;
- IF ~COCT.IsParam(obj) THEN COCY.VarObj(obj, Defi) END;
- IF big THEN COCY.VarObj(obj, Twin) END;
- obj := obj.next
- UNTIL (obj = NIL) OR (obj.mode > Ind);
- ELSE obj := obj.next
- END
- END;
- COCY.StopVOList;
- IF tempsafe & (proc.typ # COCT.notyp) THEN COCY.GCLock
- ELSE COCY.GCNode(nptr, nstr, firstvar)
- END;
- IF firstvar # NIL THEN
- obj := firstvar;
- REPEAT
- IF obj.mode <= Ind THEN
- REPEAT
- COCY.ObjToItem(obj, x);
-
- IF big THEN
- DEC(COCT.level); COCQ.Link(x); COCN.CObjBaseName(x, x.qoffs, np); COCQ.Unlink(x); INC(COCT.level);
- COCO.PutSeq("=");
- INC(COCT.level); COCQ.Link(x); COCN.CObjBaseName(x, x.qoffs, np); COCQ.Unlink(x); DEC(COCT.level);
- TermStmt;
-
- INC(COCT.level); COCQ.Link(x); COCN.CObjBaseName(x, x.qoffs, np); COCQ.Unlink(x); DEC(COCT.level);
- IF x.mode = Var THEN COCO.PutSeq("=&") ELSE COCO.PutSeq("=") END;
- COCQ.Link(x); COCN.CObjBaseName(x, x.qoffs, np); COCQ.Unlink(x);
- TermStmt
- END;
-
- IF ~COCT.IsParam(obj) THEN InitVar(x) END;
-
- obj := obj.next
- UNTIL (obj = NIL) OR (obj.mode > Ind);
- ELSE obj := obj.next
- END
- UNTIL (obj = NIL) OR (obj.mode > Typ)
- END;
- COCO.Wrap
- END InnerPrologue;
-
- PROCEDURE Epilogue*(proc: COCT.Object; big: BOOLEAN);
- VAR obj: COCT.Object;
- np: INTEGER; x: COCT.Item;
- BEGIN
- COCO.Wrap;
- IF proc.typ # COCT.notyp THEN COCH.Trap(17); TermStmt END; (* function without return *)
- COCO.Undent; COCO.PutSeq("pOt__Epilogue:"); TermStmt; COCO.Indent;
- IF big THEN
- obj := COCT.topScope.next;
- WHILE (obj # NIL) & (obj.mode <= Typ) DO
- IF obj.mode <= Ind THEN
- COCY.ObjToItem(obj, x);
- INC(COCT.level); COCQ.Link(x); COCN.CObjBaseName(x, x.qoffs, np); COCQ.Unlink(x); DEC(COCT.level);
- COCO.PutSeq("=");
- DEC(COCT.level); COCQ.Link(x); COCN.CObjBaseName(x, x.qoffs, np); COCQ.Unlink(x); INC(COCT.level);
- TermStmt
- END;
- obj := obj.next
- END
- END;
- IF tempsafe & (proc.typ # COCT.notyp) THEN
- COCO.PutSeq("pOt__gc_enabled=pOt__gc_enabled_prev")
- ELSE
- COCO.PutSeq("pOt__gc_root=(struct pOt__tag_gc_node*)pOt__gc_ptrs.next")
- END;
- TermStmt;
- obj := COCT.topScope.next;
- WHILE COCT.IsParam(obj) DO
- IF (obj.mode = Var) & (obj.typ.form IN {Array .. Record}) THEN
- COCY.ObjToItem(obj, x);
- COCQ.Link(x); COCN.CObjName(x, x.qoffs, np);
- IF (obj.typ.form = DynArr) & (obj.typ.BaseTyp.form = Byte) THEN
- COCO.PutSeq("pOt__rm_byte_arr(")
- ELSE
- COCO.PutSeq("pOt__rm_par((pOt__TypDsc**)")
- END;
- COCQ.Unlink(x);
- COCO.PutSeq(")"); TermStmt
- END;
- obj := obj.next
- END;
-
- IF proc.typ # COCT.notyp THEN
- COCQ.Link(x); COCN.CRetName(x.qoffs, np);
- COCO.PutSeq("return"); COCO.Separate; COCQ.Unlink(x);
- TermStmt
- END;
- CloseScope;
- COCO.Wrap
- END Epilogue;
-
- PROCEDURE ModulePrologue*;
- CONST quote = 22X;
- VAR obj, firstvar: COCT.Object;
- nptr, nstr: INTEGER;
- BEGIN
- obj := COCT.topScope.next;
- Logo; COCO.Wrap;
- COCO.PutSeq("#include <pOtRTL.h>"); COCO.Wrap;
- WHILE (obj # NIL) & (obj.mode = Mod) DO
- IF obj.mnolev # 0 THEN
- COCO.PutSeq("#include "); COCO.PutSeq(quote);
- COCO.PutSeq(COCT.GlbMod[obj.mnolev-1].name); COCO.PutSeq(".h"); COCO.PutSeq(quote); COCO.Wrap
- END;
- obj := obj.next
- END;
- COCO.Wrap;
- COCO.PutSeq("#include "); COCO.PutSeq(quote);
- COCO.PutSeq("hi.");COCO.PutSeq(COCT.topScope.name);COCO.PutSeq(quote); COCO.Wrap;
- COCO.Wrap;
- firstvar := NIL;
- WHILE (obj # NIL) & (obj.mode <= Typ) DO
- IF obj.mode = Con THEN COCY.ConstObj(obj, Defi); obj := obj.next
- ELSIF obj.mode = Typ THEN COCY.TypeObj(obj); obj := obj.next
- ELSIF obj.mode = Var THEN
- IF firstvar = NIL THEN firstvar := obj END;
- REPEAT obj := obj.next UNTIL (obj = NIL) OR (obj.mode # Var);
- END
- END; COCO.Wrap;
- COCD.InitTypDescs; COCO.Wrap;
- nptr := 0; nstr := 0; obj := firstvar;
- COCY.StartVOList;
- WHILE (obj # NIL) & (obj.mode <= Typ) DO
- IF obj.mode = Var THEN
- IF obj.typ.form = Pointer THEN INC(nptr)
- ELSIF (obj.typ.form IN {Array .. Record}) & COCT.HasPtr(obj.typ) THEN INC(nstr)
- END;
- COCY.VarObj(obj, Defi);
- END;
- obj := obj.next
- END;
- COCY.StopVOList; COCO.Wrap;
- COCY.GCNode(nptr, nstr, firstvar); COCO.Wrap
- END ModulePrologue;
-
- PROCEDURE BodyPrologue*;
- VAR np: INTEGER; x: COCT.Item;
- obj: COCT.Object;
- BEGIN COCY.BodyObj(COCT.topScope, Defi);
- OpenScope;
- COCO.PutSeq("static int ");
- COCQ.Link(x); COCN.CBodyFlagName(COCT.topScope, x.qoffs, np); COCQ.Unlink(x);
- COCO.PutSeq("=0;"); COCO.Wrap;
- COCO.PutSeq("if(!");
- COCQ.Link(x); COCN.CBodyFlagName(COCT.topScope, x.qoffs, np); COCQ.Unlink(x);
- COCO.PutSeq(")"); OpenScope;
- COCQ.Link(x); COCN.CBodyFlagName(COCT.topScope, x.qoffs, np); COCQ.Unlink(x);
- COCO.PutSeq("=1"); TermStmt;
- COCO.Wrap;
- obj := COCT.topScope.next;
- WHILE (obj # NIL) & (obj.mode = Mod) DO
- IF obj.mnolev # 0 THEN
- COCQ.Link(x); COCN.CBodyName(obj, x.qoffs, np); COCQ.Unlink(x);
- COCO.PutSeq("()"); TermStmt
- END;
- obj := obj.next
- END;
- COCO.Wrap;
- COCO.PutSeq("pOt__gc_ptrs.next=pOt__gc_root"); TermStmt;
- COCO.PutSeq("pOt__gc_root=(struct pOt__tag_gc_node*)&pOt__gc_strs"); TermStmt;
- COCO.Wrap;
- WHILE (obj # NIL) & (obj.mode <= Typ) DO
- IF (obj.mode <= Ind) & ~COCT.IsParam(obj) THEN
- COCY.ObjToItem(obj, x); InitVar(x)
- END;
- obj := obj.next
- END;
- COCO.Wrap
- END BodyPrologue;
-
- PROCEDURE BodyEpilogue*;
- BEGIN
- COCO.Wrap;
- COCO.Undent; COCO.PutSeq("pOt__Epilogue:"); TermStmt; COCO.Indent;
- CloseScope;
- CloseScope
- END BodyEpilogue;
-
- PROCEDURE Result*(VAR x: COCT.Item);
- VAR np: INTEGER;
- BEGIN COCN.CRetName(x.qoffs, np)
- END Result;
-
- PROCEDURE Return*;
- BEGIN COCO.PutSeq("goto pOt__Epilogue"); TermStmt
- END Return;
-
- PROCEDURE Loop*;
- BEGIN COCO.PutSeq("for(;;)"); COCO.Separate
- END Loop;
-
- PROCEDURE LoopCondPfx*;
- BEGIN COCO.PutSeq("if(")
- END LoopCondPfx;
-
- PROCEDURE LoopCondSfx*(cont: BOOLEAN);
- BEGIN COCO.PutSeq(")"); IF cont THEN COCO.PutSeq("; else") END;
- COCO.Separate; COCO.PutSeq("break"); TermStmt
- END LoopCondSfx;
-
- PROCEDURE LoopLabel*(loopno: INTEGER);
- VAR s: ARRAY 9 OF CHAR;
- BEGIN COCO.Undent;
- COCO.PutSeq("pOt__LoopLabel_");
- Strings.FromLInt(loopno, 16, s); COCO.PutSeq(s); COCO.PutSeq(":");
- TermStmt;
- COCO.Indent
- END LoopLabel;
-
- PROCEDURE With*(x: COCT.Item; wobj: COCT.Object);
- VAR np: INTEGER;
- BEGIN
- COCY.StartVOList;
-
- COCY.VarObj(wobj, Defi);
- COCO.PutSeq("_=");
- COCQ.Link(x); COCN.CObjName(x, x.qoffs, np);
- IF x.mode = Var THEN COCJ.InRef(x); x.mode := Ind END; COCJ.Cast(x);
- COCQ.Unlink(x);
-
- COCY.VarObj(wobj, Defi);
- COCO.PutSeq("=");
- COCY.ObjToItem(wobj,x);
- COCQ.Link(x); COCN.CObjName(x, x.qoffs, np); COCQ.Unlink(x);
- COCO.PutSeq("_");
-
- COCY.StopVOList
- END With;
-
- PROCEDURE Exit*(loopno:INTEGER);
- VAR s: ARRAY 9 OF CHAR;
- BEGIN COCO.PutSeq("goto pOt__LoopLabel_");
- Strings.FromLInt(loopno, 16, s); COCO.PutSeq(s); TermStmt
- END Exit;
-
- PROCEDURE CasePfx*;
- BEGIN COCO.PutSeq("switch(")
- END CasePfx;
-
- PROCEDURE CaseSfx*;
- BEGIN COCO.PutSeq(")"); COCO.Separate
- END CaseSfx;
-
- PROCEDURE CaseLabelList*(VAR x,y: COCT.Item);
- VAR first, last: LONGINT; np: INTEGER;
- BEGIN COCO.Undent;
- first := x.intval; last := y.intval + 1;
- REPEAT COCO.PutSeq("case"); COCO.Separate;
- COCQ.Link(x); COCJ.CConstValue(x, x.qoffs, np); COCQ.Unlink(x);
- COCO.PutSeq(":"); COCO.Wrap;
- INC(x.intval)
- UNTIL x.intval = last;
- x.intval := first;
- COCO.Indent
- END CaseLabelList;
-
- PROCEDURE CaseBar*;
- BEGIN COCO.Undent; COCO.PutSeq("break"); TermStmt; COCO.Indent
- END CaseBar;
-
- PROCEDURE CaseElse*;
- BEGIN COCO.Undent;
- COCO.PutSeq("break"); TermStmt;
- COCO.PutSeq("default:"); TermStmt;
- COCO.Indent
- END CaseElse;
-
- PROCEDURE IfPfx*;
- BEGIN COCO.PutSeq("if(")
- END IfPfx;
-
- PROCEDURE IfSfx*;
- BEGIN COCO.PutSeq(")"); COCO.Separate
- END IfSfx;
-
- PROCEDURE Else*;
- BEGIN COCO.Undent; COCO.PutSeq("} else"); COCO.Separate
- END Else;
-
- PROCEDURE CExport*;
- CONST quote = 22X;
- VAR obj, firstvar, firstproc: COCT.Object; im: INTEGER;
- BEGIN
- COCO.PutSeq("#ifndef pOt_"); COCO.PutSeq(COCT.topScope.name); COCO.PutSeq("__INC"); COCO.Wrap;
- COCO.PutSeq("#define pOt_"); COCO.PutSeq(COCT.topScope.name); COCO.PutSeq("__INC"); COCO.Wrap;
- Logo; COCO.Wrap;
- im := 0;
- WHILE im # COCT.nofGmod DO
- IF COCT.GlbMod[im].mode # NotYetExp THEN
- COCO.PutSeq("#include ");
- COCO.PutSeq(quote); COCO.PutSeq(COCT.GlbMod[im].name); COCO.PutSeq(".h"); COCO.PutSeq(quote);
- COCO.Wrap
- END;
- INC(im)
- END; COCO.Wrap;
- obj := COCT.topScope.next; firstvar := NIL;
- WHILE (obj # NIL) & (obj.mode = Mod) DO obj := obj.next END;
- WHILE (obj # NIL) & (obj.mode <= Typ) DO
- IF (obj.mode = Typ) & (obj.typ.ref # 0) THEN COCY.TypeObj(obj); obj := obj.next
- ELSIF (obj.mode = Con) & obj.marked THEN COCY.ConstObj(obj, Decl); obj := obj.next
- ELSIF obj.mode = Var THEN
- IF firstvar = NIL THEN firstvar := obj END;
- REPEAT obj := obj.next UNTIL (obj = NIL) OR (obj.mode # Var)
- ELSE obj := obj.next
- END
- END; COCO.Wrap; firstproc := obj;
- COCD.DeclTypDescs; COCO.Wrap;
- obj := firstvar;
- COCY.StartVOList;
- WHILE (obj # NIL) & (obj.mode <= Typ) DO
- IF (obj.mode = Var) & obj.marked THEN COCY.VarObj(obj, Decl) END;
- obj := obj.next
- END;
- COCY.StopVOList; COCO.Wrap;
- obj := firstproc;
- WHILE obj # NIL DO
- IF (obj.mode IN {XProc, CProc, IProc}) & obj.marked THEN COCY.ProcObj(obj, Decl) END;
- obj := obj.next
- END;
- COCY.BodyObj(COCT.topScope, Decl); COCO.Wrap;
- COCO.PutSeq("#endif"); COCO.Wrap
- END CExport;
-
- PROCEDURE CommitCExport*(VAR TmpFName, FName: ARRAY OF CHAR; VAR newHF: BOOLEAN);
- VAR
- oldFile, newFile: Files.File;
- oldRider, newRider: Files.Rider;
- ch0, ch1: CHAR;
- res: INTEGER;
- BEGIN newFile := Files.Old(TmpFName); oldFile := Files.Old(FName);
- IF oldFile # NIL THEN
- Files.Set(oldRider, oldFile, 0); Files.Set(newRider, newFile, 0);
- REPEAT Files.Read(oldRider, ch0); Files.Read(newRider, ch1)
- UNTIL (ch0 # ch1) OR newRider.eof;
- IF oldRider.eof & newRider.eof THEN newHF := FALSE
- ELSIF ~newHF THEN COCS.Mark(156)
- END;
- Files.Close(oldFile)
- ELSE newHF := TRUE
- END;
- Files.Close(newFile);
- IF newHF THEN Files.Delete(FName, res); Files.Rename(TmpFName, FName, res)
- ELSE Files.Delete(TmpFName, res)
- END;
- IF res > 1 THEN HALT(21H) END
- END CommitCExport;
-
- PROCEDURE InitData*;
- BEGIN Logo; COCO.Wrap;
- COCD.InitStrings; COCO.Wrap
- END InitData;
-
- BEGIN tempsafe := TRUE
- END COCC.
-