vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 00:32:24 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions
compiler/src/voc/OPC.Mod

1410 lines
46 KiB
Modula-2
Raw Blame History

MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
(* C source code generator version
30.4.2000 jt, synchronized with BlackBox version, in particular
various promotion rules changed (long) => (LONGINT), xxxL avoided
*)
IMPORT OPT, OPM, version;
CONST demoVersion = FALSE;
CONST
(* structure forms *)
Byte = 1; Bool = 2; Char = 3;
SInt = 4; Int = 5; LInt = 6;
Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
Pointer = 13; ProcTyp = 14;
Comp = 15;
(*
Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10;
Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16;
Pointer = 17; ProcTyp = 18;
Comp = 19;
*)
(*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
Pointer = 13; ProcTyp = 14;
Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18;
Comp = (*15*)19;*)
(* composite structure forms *)
Array = 2; DynArr = 3; Record = 4;
(* object history *)
removed = 4;
(* object modes *)
Var = 1; VarPar = 2; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
CProc = 9; Mod = 11; TProc = 13;
(* symbol values and ops *)
eql = 9; neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
(* nodes classes *)
Ninittd = 14;
(* module visibility of objects *)
internal = 0; external = 1;
UndefinedType = 0; (* named type not yet defined *)
ProcessingType = 1; (* pointer type is being processed *)
PredefinedType = 2; (* for all predefined types *)
DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *)
DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *)
HeaderMsg = " voc ";
BasicIncludeFile = "SYSTEM";
Static = "static ";
Export = "export "; (* particularily introduced for VC++ declspec() *)
Extern = "import "; (* particularily introduced for VC++ declspec() *)
Struct = "struct ";
LocalScope = "_s"; (* name of a local intermediate scope (variable name) *)
GlobalScope = "_s"; (* pointer to current scope extension *)
LinkName = "lnk"; (* pointer to previous scope field *)
FlagExt = "__h";
LenExt = "__len";
DynTypExt = "__typ";
TagExt = "__typ";
OpenParen = "(";
CloseParen = ")";
OpenBrace = "{";
CloseBrace = "}";
OpenBracket = "[";
CloseBracket = "]";
Underscore = "_";
Quotes = 22X;
SingleQuote = 27X;
Tab = 9X;
Colon = ": ";
Semicolon = ";";
Comma = ", ";
Becomes = " = ";
Star = "*";
Blank = " ";
Dot = ".";
DupFunc = "__DUP("; (* duplication of dynamic arrays *)
DupArrFunc = "__DUPARR("; (* duplication of fixed size arrays *)
DelFunc = "__DEL("; (* removal of dynamic arrays *)
NilConst = "NIL";
VoidType = "void";
CaseStat = "case ";
VAR
indentLevel: INTEGER;
ptrinit, mainprog, ansi: BOOLEAN;
hashtab: ARRAY 105 OF SHORTINT;
keytab: ARRAY 36, 9 OF CHAR;
GlbPtrs: BOOLEAN;
BodyNameExt: ARRAY 13 OF CHAR;
PROCEDURE Init*;
BEGIN
indentLevel := 0;
ptrinit := OPM.ptrinit IN OPM.opt;
(*mainprog := OPM.mainprog IN OPM.opt;*)
mainprog := OPM.mainProg OR OPM.mainLinkStat;
ansi := OPM.ansi IN OPM.opt;
IF ansi THEN BodyNameExt := "__init(void)" ELSE BodyNameExt := "__init()" END
END Init;
PROCEDURE Indent* (count: INTEGER);
BEGIN INC(indentLevel, count)
END Indent;
PROCEDURE BegStat*;
VAR i: INTEGER;
BEGIN i := indentLevel;
WHILE i > 0 DO OPM.Write(Tab); DEC (i) END
END BegStat;
PROCEDURE EndStat*;
BEGIN OPM.Write(Semicolon); OPM.WriteLn
END EndStat;
PROCEDURE BegBlk*;
BEGIN OPM.Write(OpenBrace); OPM.WriteLn; INC(indentLevel)
END BegBlk;
PROCEDURE EndBlk*;
BEGIN DEC(indentLevel); BegStat; OPM.Write(CloseBrace); OPM.WriteLn
END EndBlk;
PROCEDURE EndBlk0*;
BEGIN DEC(indentLevel); BegStat; OPM.Write(CloseBrace)
END EndBlk0;
PROCEDURE Str1(s: ARRAY OF CHAR; x: LONGINT);
VAR ch: CHAR; i: INTEGER;
BEGIN ch := s[0]; i := 0;
WHILE ch # 0X DO
IF ch = "#" THEN OPM.WriteInt(x)
ELSE OPM.Write(ch);
END ;
INC(i); ch := s[i]
END
END Str1;
PROCEDURE Length(VAR s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] # 0X DO INC(i) END ;
RETURN i
END Length;
PROCEDURE PerfectHash (VAR s: ARRAY OF CHAR): INTEGER;
VAR i, h: INTEGER;
BEGIN i := 0; h := 0;
WHILE (s[i] # 0X) & (i < 5) DO h := 3*h + ORD(s[i]); INC(i) END;
RETURN h MOD 105
END PerfectHash;
PROCEDURE Ident* (obj: OPT.Object);
VAR mode, level, h: INTEGER;
BEGIN
mode := obj^.mode; level := obj^.mnolev;
IF (mode IN {Var, Typ, LProc}) & (level > 0) OR (mode IN {Fld, VarPar}) THEN
OPM.WriteStringVar(obj^.name);
h := PerfectHash(obj^.name);
IF hashtab[h] >= 0 THEN
IF keytab[hashtab[h]] = obj^.name THEN OPM.Write(Underscore) END
END
ELSE
IF (mode # Typ) OR (obj^.linkadr # PredefinedType) THEN
IF mode = TProc THEN Ident(obj^.link^.typ^.strobj)
ELSIF level < 0 THEN (* use unaliased module name *)
OPM.WriteStringVar(OPT.GlbMod[-level].name);
IF OPM.currFile = OPM.HeaderFile THEN OPT.GlbMod[-level].vis := 1 (*include in header file*) END ;
ELSE OPM.WriteStringVar(OPM.modName)
END ;
OPM.Write(Underscore)
ELSIF (obj = OPT.sysptrtyp^.strobj) OR (obj = OPT.bytetyp^.strobj) (*OR (obj = OPT.int8typ^.strobj) OR (obj = OPT.int16typ^.strobj) OR (obj = OPT.int32typ^.strobj) OR (obj = OPT.int64typ^.strobj)*) THEN
OPM.WriteString("SYSTEM_")
END ;
OPM.WriteStringVar(obj^.name)
END
END Ident;
PROCEDURE Stars (typ: OPT.Struct; VAR openClause: BOOLEAN);
VAR pointers: INTEGER;
BEGIN
openClause := FALSE;
IF ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.comp # Record) THEN
IF typ^.comp IN {Array, DynArr} THEN
Stars (typ^.BaseTyp, openClause);
openClause := (typ^.comp = Array)
ELSIF typ^.form = ProcTyp THEN
OPM.Write(OpenParen); OPM.Write(Star)
ELSE
pointers := 0;
WHILE (typ^.strobj = NIL) & (typ^.form = Pointer) DO INC (pointers); typ := typ^.BaseTyp END ;
IF typ^.comp # DynArr THEN Stars (typ, openClause) END ;
IF pointers > 0 THEN
IF openClause THEN OPM.Write(OpenParen); openClause := FALSE END ;
WHILE pointers > 0 DO OPM.Write(Star); DEC (pointers) END
END
END
END
END Stars;
PROCEDURE ^AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN);
PROCEDURE DeclareObj(dcl: OPT.Object; scopeDef: BOOLEAN);
VAR
typ: OPT.Struct;
varPar, openClause: BOOLEAN; form, comp: INTEGER;
BEGIN
typ := dcl^.typ;
varPar := ((dcl^.mode = VarPar) & (typ^.comp # Array)) OR (typ^.comp = DynArr) OR scopeDef;
Stars(typ, openClause);
IF varPar THEN
IF openClause THEN OPM.Write(OpenParen) END ;
OPM.Write(Star)
END ;
IF dcl.name # "" THEN Ident(dcl) END ;
IF varPar & openClause THEN OPM.Write(CloseParen) END ;
openClause := FALSE;
LOOP
form := typ^.form;
comp := typ^.comp;
IF ((typ^.strobj # NIL) & (typ^.strobj^.name # "")) OR (form = NoTyp) OR (comp = Record) THEN EXIT
ELSIF (form = Pointer) & (typ^.BaseTyp^.comp # DynArr) THEN
openClause := TRUE
ELSIF (form = ProcTyp) OR (comp IN {Array, DynArr}) THEN
IF openClause THEN OPM.Write(CloseParen); openClause := FALSE END ;
IF form = ProcTyp THEN
IF ansi THEN OPM.Write(")"); AnsiParamList(typ^.link, FALSE)
ELSE OPM.WriteString(")()")
END ;
EXIT
ELSIF comp = Array THEN
OPM.Write(OpenBracket); OPM.WriteInt(typ^.n); OPM.Write(CloseBracket)
END
ELSE
EXIT
END ;
typ := typ^.BaseTyp
END
END DeclareObj;
PROCEDURE Andent*(typ: OPT.Struct); (* ident of possibly anonymous record type *)
BEGIN
IF (typ^.strobj = NIL) OR (typ^.align >= 10000H) THEN
OPM.WriteStringVar(OPM.modName); Str1("__#", typ^.align DIV 10000H)
ELSE Ident(typ^.strobj)
END
END Andent;
PROCEDURE Undefined(obj: OPT.Object): BOOLEAN;
BEGIN
(* imported anonymous types have obj^.name = ""; used e.g. for repeating inherited fields *)
RETURN (obj^.mnolev >= 0) & (obj^.linkadr # 3+OPM.currFile ) & (obj^.linkadr # PredefinedType) OR (obj^.name = "")
END Undefined;
PROCEDURE ^FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT);
PROCEDURE DeclareBase(dcl: OPT.Object); (* declare the specifier of object dcl*)
VAR typ, prev: OPT.Struct; obj: OPT.Object; nofdims: INTEGER; off, n, dummy: LONGINT;
BEGIN
typ := dcl^.typ; prev := typ;
WHILE ((typ^.strobj = NIL) OR (typ^.comp = DynArr) OR Undefined(typ^.strobj)) & (typ^.comp # Record) & (typ^.form # NoTyp)
& ~((typ^.form = Pointer) & (typ^.BaseTyp^.comp = DynArr)) DO
prev := typ; typ := typ^.BaseTyp
END ;
obj := typ^.strobj;
IF typ^.form = NoTyp THEN (* proper procedure *)
OPM.WriteString(VoidType)
ELSIF (obj # NIL) & ~Undefined(obj) THEN (* named type, already declared *)
Ident(obj)
ELSIF typ^.comp = Record THEN
OPM.WriteString(Struct); Andent(typ);
IF (prev.form # Pointer) & ((obj # NIL) OR (dcl.name = "")) THEN
(* named record type not yet declared OR anonymous record with empty name *)
IF (typ^.BaseTyp # NIL) & (typ^.BaseTyp^.strobj.vis # internal) THEN
OPM.WriteString(" { /* "); Ident(typ^.BaseTyp^.strobj); OPM.WriteString(" */"); OPM.WriteLn; Indent(1)
ELSE OPM.Write(Blank); BegBlk
END ;
FieldList(typ, TRUE, off, n, dummy);
EndBlk0
END
ELSIF (typ^.form = Pointer) & (typ^.BaseTyp^.comp = DynArr) THEN
typ := typ^.BaseTyp^.BaseTyp; nofdims := 1;
WHILE typ^.comp = DynArr DO INC(nofdims); typ := typ^.BaseTyp END ;
OPM.WriteString(Struct); BegBlk;
BegStat; Str1("LONGINT len[#]", nofdims); EndStat;
BegStat; NEW(obj); NEW(obj.typ); (* aux. object for easy declaration *)
obj.typ.form := Comp; obj.typ.comp := Array; obj.typ.n := 1; obj.typ.BaseTyp := typ; obj.mode := Fld; obj.name := "data";
obj.linkadr := UndefinedType; DeclareBase(obj); OPM.Write(Blank); DeclareObj(obj, FALSE);
EndStat; EndBlk0
END
END DeclareBase;
PROCEDURE NofPtrs* (typ: OPT.Struct): LONGINT;
VAR fld: OPT.Object; btyp: OPT.Struct; n: LONGINT;
BEGIN
IF (typ^.form = Pointer) & (typ^.sysflag = 0) THEN RETURN 1
ELSIF (typ^.comp = Record) & (typ^.sysflag MOD 100H = 0) THEN
btyp := typ^.BaseTyp;
IF btyp # NIL THEN n := NofPtrs(btyp) ELSE n := 0 END ;
fld := typ^.link;
WHILE (fld # NIL) & (fld^.mode = Fld) DO
IF fld^.name # OPM.HdPtrName THEN n := n + NofPtrs(fld^.typ)
ELSE INC(n)
END ;
fld := fld^.link
END ;
RETURN n
ELSIF typ^.comp = Array THEN
btyp := typ^.BaseTyp; n := typ^.n;
WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ;
RETURN NofPtrs(btyp) * n
ELSE RETURN 0
END
END NofPtrs;
PROCEDURE PutPtrOffsets (typ: OPT.Struct; adr: LONGINT; VAR cnt: LONGINT);
VAR fld: OPT.Object; btyp: OPT.Struct; n, i: LONGINT;
BEGIN
IF (typ^.form = Pointer) & (typ^.sysflag = 0) THEN
OPM.WriteInt(adr); OPM.WriteString(", "); INC(cnt);
IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END
ELSIF (typ^.comp = Record) & (typ^.sysflag MOD 100H = 0) THEN
btyp := typ^.BaseTyp;
IF btyp # NIL THEN PutPtrOffsets(btyp, adr, cnt) END ;
fld := typ^.link;
WHILE (fld # NIL) & (fld^.mode = Fld) DO
IF fld^.name # OPM.HdPtrName THEN PutPtrOffsets(fld^.typ, adr + fld^.adr, cnt)
ELSE
OPM.WriteInt(adr + fld^.adr); OPM.WriteString(", "); INC(cnt);
IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END
END ;
fld := fld^.link
END
ELSIF typ^.comp = Array THEN
btyp := typ^.BaseTyp; n := typ^.n;
WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ;
IF NofPtrs(btyp) > 0 THEN i := 0;
WHILE i < n DO PutPtrOffsets(btyp, adr + i * btyp^.size, cnt); INC(i) END
END
END
END PutPtrOffsets;
PROCEDURE InitTProcs(typ, obj: OPT.Object);
BEGIN
IF obj # NIL THEN
InitTProcs(typ, obj^.left);
IF obj^.mode = TProc THEN
BegStat;
OPM.WriteString("__INITBP(");
Ident(typ); OPM.WriteString(Comma); Ident(obj);
Str1(", #)", obj^.adr DIV 10000H);
EndStat
END ;
InitTProcs(typ, obj^.right)
END
END InitTProcs;
PROCEDURE PutBase(typ: OPT.Struct);
BEGIN
IF typ # NIL THEN
PutBase(typ^.BaseTyp);
Ident(typ^.strobj); OPM.WriteString(DynTypExt); OPM.WriteString(", ")
END
END PutBase;
PROCEDURE LenList(par: OPT.Object; ansiDefine, showParamName: BOOLEAN);
VAR typ: OPT.Struct; dim: INTEGER;
BEGIN
IF showParamName THEN Ident(par); OPM.WriteString(LenExt) END ;
dim := 1; typ := par^.typ^.BaseTyp;
WHILE typ^.comp = DynArr DO
IF ansiDefine THEN OPM.WriteString(", LONGINT ") ELSE OPM.WriteString(Comma) END ;
IF showParamName THEN Ident(par); OPM.WriteString(LenExt); OPM.WriteInt(dim) END ;
typ := typ^.BaseTyp; INC(dim)
END
END LenList;
PROCEDURE DeclareParams(par: OPT.Object; macro: BOOLEAN);
BEGIN
OPM.Write(OpenParen);
WHILE par # NIL DO
IF macro THEN OPM.WriteStringVar(par.name)
ELSE
IF (par^.mode = Var) & (par^.typ^.form = Real) THEN OPM.Write("_") END ;
Ident(par)
END ;
IF par^.typ^.comp = DynArr THEN
OPM.WriteString(Comma); LenList(par, FALSE, TRUE);
ELSIF (par^.mode = VarPar) & (par^.typ^.comp = Record) THEN
OPM.WriteString(Comma); OPM.WriteStringVar(par.name); OPM.WriteString(TagExt)
END ;
par := par^.link;
IF par # NIL THEN OPM.WriteString(Comma) END
END ;
OPM.Write(CloseParen)
END DeclareParams;
PROCEDURE ^DefineType(str: OPT.Struct);
PROCEDURE ^ProcHeader(proc: OPT.Object; define: BOOLEAN);
PROCEDURE DefineTProcTypes(obj: OPT.Object); (* define all types that are used in a TProc definition *)
VAR par: OPT.Object;
BEGIN
IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ;
IF ansi THEN par := obj^.link;
WHILE par # NIL DO DefineType(par^.typ); par := par^.link END
END
END DefineTProcTypes;
PROCEDURE DeclareTProcs(obj: OPT.Object; VAR empty: BOOLEAN);
BEGIN
IF obj # NIL THEN
DeclareTProcs(obj^.left, empty);
IF obj^.mode = TProc THEN
IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ;
IF OPM.currFile = OPM.HeaderFile THEN
IF obj^.vis = external THEN
DefineTProcTypes(obj);
OPM.WriteString(Extern); empty := FALSE;
ProcHeader(obj, FALSE)
END
ELSE empty := FALSE;
DefineTProcTypes(obj);
IF obj^.vis = internal THEN OPM.WriteString(Static)
ELSE OPM.WriteString(Export)
END ;
ProcHeader(obj, FALSE)
END
END ;
DeclareTProcs(obj^.right, empty)
END
END DeclareTProcs;
PROCEDURE BaseTProc*(obj: OPT.Object): OPT.Object;
VAR typ, base: OPT.Struct; mno: LONGINT;
BEGIN typ := obj^.link^.typ; (* receiver type *)
IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ;
base := typ^.BaseTyp; mno := obj^.adr DIV 10000H;
WHILE (base # NIL) & (mno < base^.n) DO typ := base; base := typ^.BaseTyp END ;
OPT.FindField(obj^.name, typ, obj);
RETURN obj
END BaseTProc;
PROCEDURE DefineTProcMacros(obj: OPT.Object; VAR empty: BOOLEAN);
BEGIN
IF obj # NIL THEN
DefineTProcMacros(obj^.left, empty);
IF (obj^.mode = TProc) & (obj = BaseTProc(obj)) & ((OPM.currFile # OPM.HeaderFile) OR (obj^.vis = external)) THEN
OPM.WriteString("#define __");
Ident(obj);
DeclareParams(obj^.link, TRUE);
OPM.WriteString(" __SEND(");
IF obj^.link^.typ^.form = Pointer THEN
OPM.WriteString("__TYPEOF("); Ident(obj^.link); OPM.Write(")")
ELSE Ident(obj^.link); OPM.WriteString(TagExt)
END ;
Str1(", #, ", obj^.adr DIV 10000H);
IF obj^.typ = OPT.notyp THEN OPM.WriteString(VoidType) ELSE Ident(obj^.typ^.strobj) END ;
OPM.WriteString("(*)");
IF ansi THEN
AnsiParamList(obj^.link, FALSE);
ELSE
OPM.WriteString("()");
END ;
OPM.WriteString(", ");
DeclareParams(obj^.link, TRUE);
OPM.Write(")"); OPM.WriteLn
END ;
DefineTProcMacros(obj^.right, empty)
END
END DefineTProcMacros;
PROCEDURE DefineType(str: OPT.Struct); (* define a type object *)
VAR obj, field, par: OPT.Object; empty: BOOLEAN;
BEGIN
IF (OPM.currFile = OPM.BodyFile) OR (str^.ref < OPM.MaxStruct (*for hidden exports*) ) THEN
obj := str^.strobj;
IF (obj = NIL) OR Undefined(obj) THEN
IF obj # NIL THEN (* check for cycles *)
IF obj^.linkadr = ProcessingType THEN
IF str^.form # Pointer THEN OPM.Mark(244, str^.txtpos); obj^.linkadr := PredefinedType END
ELSE obj^.linkadr := ProcessingType
END
END ;
IF str^.comp = Record THEN
(* the following exports the base type of an exported type even if the former is non-exported *)
IF str^.BaseTyp # NIL THEN DefineType(str^.BaseTyp) END ;
field := str^.link;
WHILE (field # NIL) & (field^.mode = Fld) DO
IF (field^.vis # internal) OR (OPM.currFile = OPM.BodyFile) THEN DefineType(field^.typ) END ;
field := field^.link
END
ELSIF str^.form = Pointer THEN
IF str^.BaseTyp^.comp # Record THEN DefineType(str^.BaseTyp) END
ELSIF str^.comp IN {Array, DynArr} THEN
DefineType(str^.BaseTyp)
ELSIF str^.form = ProcTyp THEN
IF str^.BaseTyp # OPT.notyp THEN DefineType(str^.BaseTyp) END ;
field := str^.link;
WHILE field # NIL DO DefineType(field^.typ); field := field^.link END
END
END ;
IF (obj # NIL) & Undefined(obj) THEN
OPM.WriteString("typedef"); OPM.WriteLn; OPM.Write(Tab); Indent(1);
obj^.linkadr := ProcessingType;
DeclareBase(obj); OPM.Write(Blank);
obj^.typ^.strobj := NIL; (* SG: trick to make DeclareObj declare the type *)
DeclareObj(obj, FALSE);
obj^.typ^.strobj := obj; (* SG: revert trick *)
obj^.linkadr := 3+OPM.currFile;
EndStat; Indent(-1); OPM.WriteLn;
IF obj^.typ^.comp = Record THEN empty := TRUE;
DeclareTProcs(str^.link, empty); DefineTProcMacros(str^.link, empty);
IF ~empty THEN OPM.WriteLn END
END
END
END
END DefineType;
PROCEDURE Prefixed(x: OPT.ConstExt; y: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER;
BEGIN i := 0;
WHILE x[i+1] = y[i] DO INC(i) END ;
RETURN y[i] = 0X
END Prefixed;
PROCEDURE CProcDefs(obj: OPT.Object; vis: INTEGER);
VAR i: INTEGER; ext: OPT.ConstExt;
BEGIN
IF obj # NIL THEN
CProcDefs(obj^.left, vis);
(* bug: obj.history cannot be used to cover unexported and deleted CProcs; use special flag obj.adr = 1 *)
IF (obj^.mode = CProc) & (obj^.vis >= vis) & (obj^.adr = 1) THEN
ext := obj.conval.ext; i := 1;
IF (ext[1] # "#") & ~(Prefixed(ext, "extern ") OR Prefixed(ext, Extern)) THEN
OPM.WriteString("#define "); Ident(obj);
DeclareParams(obj^.link, TRUE);
OPM.Write(Tab);
END ;
FOR i := i TO ORD(obj.conval.ext[0]) DO OPM.Write(obj.conval.ext[i]) END;
OPM.WriteLn
END ;
CProcDefs(obj^.right, vis)
END
END CProcDefs;
PROCEDURE TypeDefs* (obj: OPT.Object; vis(*replaced by test on currFile in DefineType*): INTEGER);
BEGIN
IF obj # NIL THEN
TypeDefs(obj^.left, vis);
(* test typ.txtpos to skip types that have been unexported; obj.history # removed is not enough!*)
IF (obj^.mode = Typ) & (obj^.typ^.txtpos > 0) THEN DefineType(obj^.typ) END ;
TypeDefs(obj^.right, vis)
END
END TypeDefs;
PROCEDURE DefAnonRecs(n: OPT.Node);
VAR o: OPT.Object; typ: OPT.Struct;
BEGIN
WHILE (n # NIL) & (n^.class = Ninittd) DO
typ := n^.typ;
IF (typ^.strobj = NIL) & ((OPM.currFile = OPM.BodyFile) OR (typ.ref < OPM.MaxStruct)) THEN
DefineType(typ); (* declare base and field types, if any *)
NEW(o); o.typ := typ; o.name := ""; DeclareBase(o); EndStat; OPM.WriteLn
(* simply defines a named struct, but not a type;
o.name = "" signals field list expansion for DeclareBase in this very special case *)
END ;
n := n^.link
END
END DefAnonRecs;
PROCEDURE TDescDecl* (typ: OPT.Struct);
VAR nofptrs: LONGINT;
o: OPT.Object;
BEGIN
BegStat; OPM.WriteString("__TDESC(");
Andent(typ);
Str1(", #", typ^.n + 1); Str1(", #) = {__TDFLDS(", NofPtrs(typ));
OPM.Write('"');
IF typ^.strobj # NIL THEN OPM.WriteStringVar(typ^.strobj^.name) END ;
Str1('", #), {', typ^.size);
nofptrs := 0; PutPtrOffsets(typ, 0, nofptrs); Str1("#}}", -(nofptrs + 1) * OPM.LIntSize);
EndStat
END TDescDecl;
PROCEDURE InitTDesc*(typ: OPT.Struct);
BEGIN
BegStat; OPM.WriteString("__INITYP(");
Andent(typ); OPM.WriteString(", ");
IF typ^.BaseTyp # NIL THEN Andent(typ^.BaseTyp) ELSE Andent(typ) END ;
Str1(", #)", typ^.extlev);
EndStat;
IF typ^.strobj # NIL THEN InitTProcs(typ^.strobj, typ^.link) END
END InitTDesc;
PROCEDURE Align*(VAR adr: LONGINT; base: LONGINT);
BEGIN
CASE base OF
| 2: INC(adr, adr MOD 2)
| 4: INC(adr, (-adr) MOD 4)
| 8: INC(adr, (-adr) MOD 8)
|16: INC(adr, (-adr) MOD 16)
ELSE (*1*)
(*OPM.LogWStr("unhandled case at OPC.Align, base = "); OPM.LogWNum(base, 0); OPM.LogWLn;*)
END
END Align;
PROCEDURE Base*(typ: OPT.Struct): LONGINT;
BEGIN
CASE typ^.form OF
| Byte: RETURN 1
| Char: RETURN OPM.CharAlign
| Bool: RETURN OPM.BoolAlign
| SInt: RETURN OPM.SIntAlign
| Int: RETURN OPM.IntAlign
| LInt: RETURN OPM.LIntAlign
(* | Int8: RETURN OPM.Int8Align
| Int16: RETURN OPM.Int16Align
| Int32: RETURN OPM.Int32Align
| Int64: RETURN OPM.Int64Align*)
| Real: RETURN OPM.RealAlign
| LReal: RETURN OPM.LRealAlign
| Set: RETURN OPM.SetAlign
| Pointer: RETURN OPM.PointerAlign
| ProcTyp: RETURN OPM.ProcAlign
| Comp:
IF typ^.comp = Record THEN RETURN typ^.align MOD 10000H
ELSE RETURN Base(typ^.BaseTyp)
END
ELSE OPM.LogWStr("unhandled case in OPC.Base, typ^form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn;
END
END Base;
PROCEDURE FillGap(gap, off, align: LONGINT; VAR n, curAlign: LONGINT);
VAR adr: LONGINT;
BEGIN
adr := off; Align(adr, align);
IF (curAlign < align) & (gap - (adr - off) >= align) THEN (* preserve alignment of the enclosing struct! *)
DEC(gap, (adr - off) + align);
BegStat;
IF align = OPM.IntSize THEN OPM.WriteString("INTEGER")
ELSIF align = OPM.LIntSize THEN OPM.WriteString("LONGINT")
ELSIF align = OPM.LRealSize THEN OPM.WriteString("LONGREAL")
END ;
Str1(" _prvt#", n); INC(n); EndStat;
curAlign := align
END ;
IF gap > 0 THEN BegStat; Str1("char _prvt#", n); INC(n); Str1("[#]", gap); EndStat END
END FillGap;
PROCEDURE FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT);
VAR fld: OPT.Object; base: OPT.Struct; gap, adr, align, fldAlign: LONGINT;
BEGIN
fld := typ.link; align := typ^.align MOD 10000H;
IF typ.BaseTyp # NIL THEN FieldList(typ.BaseTyp, FALSE, off, n, curAlign)
ELSE off := 0; n := 0; curAlign := 1
END ;
WHILE (fld # NIL) & (fld.mode = Fld) DO
IF (OPM.currFile = OPM.HeaderFile) & (fld.vis = internal) OR
(OPM.currFile = OPM.BodyFile) & (fld.vis = internal) & (typ^.mno # 0) THEN
fld := fld.link;
WHILE (fld # NIL) & (fld.mode = Fld) & (fld.vis = internal) DO fld := fld.link END ;
ELSE
(* mimic OPV.TypSize to detect gaps caused by private fields *)
adr := off; fldAlign := Base(fld^.typ); Align(adr, fldAlign);
gap := fld.adr - adr;
IF fldAlign > curAlign THEN curAlign := fldAlign END ;
IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END ;
BegStat; DeclareBase(fld); OPM.Write(Blank); DeclareObj(fld, FALSE);
off := fld.adr + fld.typ.size; base := fld.typ; fld := fld.link;
WHILE (fld # NIL) & (fld.mode = Fld) & (fld.typ = base) & (fld.adr = off)
(* ?? *) & ((OPM.currFile = OPM.BodyFile) OR (fld.vis # internal) OR (fld.typ.strobj = NIL)) DO
OPM.WriteString(", "); DeclareObj(fld, FALSE); off := fld.adr + fld.typ.size; fld := fld.link
END ;
EndStat
END
END ;
IF last THEN
adr := typ.size - typ^.sysflag DIV 100H;
IF adr = 0 THEN gap := 1 (* avoid empty struct *) ELSE gap := adr - off END ;
IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END
END
END FieldList;
PROCEDURE IdentList (obj: OPT.Object; vis: INTEGER);
(* generate var and param lists; vis: 0 all global vars, local var, 1 exported(R) var, 2 par list, 3 scope var *)
VAR base: OPT.Struct; first: BOOLEAN; lastvis: INTEGER;
BEGIN
base := NIL; first := TRUE;
WHILE (obj # NIL) & (obj^.mode # TProc) DO
IF (vis IN {0, 2}) OR ((vis = 1) & (obj^.vis # 0)) OR ((vis = 3) & ~obj^.leaf) THEN
IF (obj^.typ # base) OR (obj^.vis # lastvis) THEN (* new variable base type definition required *)
IF ~first THEN EndStat END ;
first := FALSE;
base := obj^.typ; lastvis := obj^.vis;
BegStat;
IF (vis = 1) & (obj^.vis # internal) THEN OPM.WriteString(Extern)
ELSIF (obj^.mnolev = 0) & (vis = 0) THEN
IF obj^.vis = internal THEN OPM.WriteString(Static)
ELSE OPM.WriteString(Export)
END
END ;
IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.WriteString("double")
ELSE DeclareBase(obj)
END
ELSE OPM.Write(",");
END ;
OPM.Write(Blank);
IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.Write("_") END ;
DeclareObj(obj, vis = 3);
IF obj^.typ^.comp = DynArr THEN (* declare len parameter(s) *)
EndStat; BegStat;
base := OPT.linttyp;
OPM.WriteString("LONGINT "); LenList(obj, FALSE, TRUE)
ELSIF (obj^.mode = VarPar) & (obj^.typ^.comp = Record) THEN
EndStat; BegStat;
OPM.WriteString("LONGINT *"); Ident(obj); OPM.WriteString(TagExt);
base := NIL
ELSIF ptrinit & (vis = 0) & (obj^.mnolev > 0) & (obj^.typ^.form = Pointer) THEN
OPM.WriteString(" = NIL")
END
END ;
obj := obj^.link
END ;
IF ~first THEN EndStat END
END IdentList;
PROCEDURE AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN);
VAR name: ARRAY 32 OF CHAR;
BEGIN
OPM.Write("(");
IF (obj = NIL) OR (obj^.mode = TProc) THEN OPM.WriteString("void")
ELSE
LOOP
DeclareBase(obj);
IF showParamNames THEN
OPM.Write(Blank); DeclareObj(obj, FALSE)
ELSE
COPY(obj^.name, name); obj^.name := ""; DeclareObj(obj, FALSE); COPY(name, obj^.name)
END ;
IF obj^.typ^.comp = DynArr THEN
OPM.WriteString(", LONGINT ");
LenList(obj, TRUE, showParamNames)
ELSIF (obj^.mode = VarPar) & (obj^.typ^.comp = Record) THEN
OPM.WriteString(", LONGINT *");
IF showParamNames THEN Ident(obj); OPM.WriteString(TagExt) END
END ;
IF (obj^.link = NIL) OR (obj^.link.mode = TProc) THEN EXIT END ;
OPM.WriteString(", ");
obj := obj^.link
END
END ;
OPM.Write(")")
END AnsiParamList;
PROCEDURE ProcHeader(proc: OPT.Object; define: BOOLEAN);
BEGIN
IF proc^.typ = OPT.notyp THEN OPM.WriteString(VoidType) ELSE Ident(proc^.typ^.strobj) END ;
OPM.Write(Blank); Ident(proc); OPM.Write(Blank);
IF ansi THEN
AnsiParamList(proc^.link, TRUE);
IF ~define THEN OPM.Write(";") END ;
OPM.WriteLn;
ELSIF define THEN
DeclareParams(proc^.link, FALSE);
OPM.WriteLn;
Indent(1); IdentList(proc^.link, 2(* map REAL to double *)); Indent(-1)
ELSE OPM.WriteString("();"); OPM.WriteLn
END
END ProcHeader;
PROCEDURE ProcPredefs (obj: OPT.Object; vis: SHORTINT); (* forward declaration of procedures *)
BEGIN
IF obj # NIL THEN
ProcPredefs(obj^.left, vis);
IF (obj^.mode IN {LProc, XProc}) & (obj^.vis >= vis) & ((obj^.history # removed) OR (obj^.mode = LProc)) THEN
(* previous XProc may be deleted or become LProc after interface change*)
IF vis = external THEN OPM.WriteString(Extern)
ELSIF obj^.vis = internal THEN OPM.WriteString(Static)
ELSE OPM.WriteString(Export)
END ;
ProcHeader(obj, FALSE);
END ;
ProcPredefs(obj^.right, vis);
END;
END ProcPredefs;
PROCEDURE Include(name: ARRAY OF CHAR);
BEGIN
OPM.WriteString("#include "); OPM.Write(Quotes); OPM.WriteStringVar(name);
OPM.WriteString(".h"); OPM.Write(Quotes); OPM.WriteLn
END Include;
PROCEDURE IncludeImports(obj: OPT.Object; vis: INTEGER);
BEGIN
IF obj # NIL THEN
IncludeImports(obj^.left, vis);
IF (obj^.mode = Mod) & (obj^.mnolev # 0) & (OPT.GlbMod[-obj^.mnolev].vis >= vis) THEN (* @self and SYSTEM have mnolev = 0 *)
Include(OPT.GlbMod[-obj^.mnolev].name) (* use unaliased module name *)
END;
IncludeImports(obj^.right, vis);
END;
END IncludeImports;
PROCEDURE GenDynTypes (n: OPT.Node; vis: INTEGER);
VAR typ: OPT.Struct;
BEGIN
WHILE (n # NIL) & (n^.class = Ninittd) DO
typ := n^.typ;
IF (vis = internal) OR (typ^.ref < OPM.MaxStruct (*type needed in symbol file*)) THEN
BegStat;
IF vis = external THEN OPM.WriteString(Extern)
ELSIF (typ^.strobj # NIL) & (typ^.strobj^.mnolev > 0) THEN OPM.WriteString(Static)
ELSE OPM.WriteString(Export)
END ;
OPM.WriteString("LONGINT *"); Andent(typ); OPM.WriteString(DynTypExt);
EndStat
END ;
n := n^.link
END
END GenDynTypes;
PROCEDURE GenHdr*(n: OPT.Node);
BEGIN
(* includes are delayed until it is known which ones are needed in the header *)
OPM.currFile := OPM.HeaderFile;
DefAnonRecs(n);
TypeDefs(OPT.topScope^.right, 1); OPM.WriteLn;
IdentList(OPT.topScope^.scope, 1); OPM.WriteLn;
GenDynTypes(n, external); OPM.WriteLn;
ProcPredefs(OPT.topScope^.right, 1);
OPM.WriteString(Extern); OPM.WriteString("void *");
OPM.WriteStringVar(OPM.modName); OPM.WriteString(BodyNameExt);
EndStat; OPM.WriteLn;
CProcDefs(OPT.topScope^.right, 1); OPM.WriteLn;
OPM.WriteString("#endif"); OPM.WriteLn
END GenHdr;
PROCEDURE GenHeaderMsg;
VAR i: INTEGER;
BEGIN
OPM.WriteString("/*"); OPM.WriteString(HeaderMsg);
OPM.Write(" "); OPM.WriteString(version.versionLong); OPM.Write (" "); (* noch *)
FOR i := 0 TO OPM.MaxSet (*31*) DO (*noch*)
IF i IN OPM.glbopt THEN
CASE i OF (* c.f. ScanOptions in OPM *)
| OPM.extsf: OPM.Write("e")
| OPM.newsf: OPM.Write("s")
| OPM.mainprog: OPM.Write("m")
| OPM.inxchk: OPM.Write("x")
| OPM.vcpp: OPM.Write("v")
| OPM.ranchk: OPM.Write("r")
| OPM.typchk: OPM.Write("t")
| OPM.assert: OPM.Write("a")
| OPM.ansi: OPM.Write("k")
| OPM.ptrinit: OPM.Write("p")
| OPM.include0: OPM.Write("i")
| OPM.lineno: OPM.Write("l")
| OPM.useparfile: OPM.Write("P")
| OPM.dontasm: OPM.Write("S")
| OPM.dontlink: OPM.Write("c")
| OPM.mainlinkstat: OPM.Write("M")
| OPM.notcoloroutput: OPM.Write("f")
| OPM.forcenewsym: OPM.Write("F")
| OPM.verbose: OPM.Write("v")
ELSE
(* this else is necessary cause
if someone defined a new option in OPM module
and forgot to add it here then
if option is passed this will
generate __CASECHK and cause Halt,
noch *)
OPM.LogWStr ("( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg"); OPM.LogWLn;
END
END
END;
OPM.WriteString(" */"); OPM.WriteLn
END GenHeaderMsg;
PROCEDURE GenHdrIncludes*;
BEGIN
OPM.currFile := OPM.HeaderInclude;
GenHeaderMsg;
OPM.WriteLn;
OPM.WriteString("#ifndef "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn;
OPM.WriteString("#define "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn;
OPM.WriteLn;
Include(BasicIncludeFile);
IncludeImports(OPT.topScope^.right, 1); OPM.WriteLn
END GenHdrIncludes;
PROCEDURE GenBdy*(n: OPT.Node);
BEGIN
OPM.currFile := OPM.BodyFile;
GenHeaderMsg;
Include(BasicIncludeFile);
IncludeImports(OPT.topScope^.right, 0); OPM.WriteLn;
DefAnonRecs(n);
TypeDefs(OPT.topScope^.right, 0); OPM.WriteLn;
IdentList(OPT.topScope^.scope, 0); OPM.WriteLn;
GenDynTypes(n, internal); OPM.WriteLn;
ProcPredefs(OPT.topScope^.right, 0); OPM.WriteLn;
CProcDefs(OPT.topScope^.right, 0); OPM.WriteLn
END GenBdy;
PROCEDURE RegCmds(obj: OPT.Object);
BEGIN
IF obj # NIL THEN
RegCmds(obj^.left);
IF (obj^.mode = XProc) & (obj^.history # removed) THEN
IF (obj^.vis # 0) & (obj^.link = NIL) & (obj^.typ = OPT.notyp) THEN (*command*)
BegStat; OPM.WriteString('__REGCMD("');
OPM.WriteStringVar(obj.name); OPM.WriteString('", '); Ident(obj); OPM.Write(")"); EndStat
END
END ;
RegCmds(obj^.right)
END
END RegCmds;
PROCEDURE InitImports(obj: OPT.Object);
BEGIN
IF obj # NIL THEN
InitImports(obj^.left);
IF (obj^.mode = Mod) & (obj^.mnolev # 0) THEN
BegStat; OPM.WriteString("__IMPORT(");
OPM.WriteStringVar(OPT.GlbMod[-obj^.mnolev].name);
OPM.Write(CloseParen); EndStat
END ;
InitImports(obj^.right)
END
END InitImports;
PROCEDURE GenEnumPtrs* (var: OPT.Object);
VAR typ: OPT.Struct; n: LONGINT;
BEGIN GlbPtrs := FALSE;
WHILE var # NIL DO
typ := var^.typ;
IF NofPtrs(typ) > 0 THEN
IF ~GlbPtrs THEN GlbPtrs := TRUE;
OPM.WriteString(Static);
IF ansi THEN
OPM.WriteString("void EnumPtrs(void (*P)(void*))")
ELSE
OPM.WriteString("void EnumPtrs(P)"); OPM.WriteLn;
OPM.Write(Tab); OPM.WriteString("void (*P)();");
END ;
OPM.WriteLn;
BegBlk
END ;
BegStat;
IF typ^.form = Pointer THEN
OPM.WriteString("P("); Ident(var); OPM.Write(")");
ELSIF typ^.comp = Record THEN
OPM.WriteString("__ENUMR(&"); Ident(var); OPM.WriteString(", ");
Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); OPM.WriteString(", 1, P)")
ELSIF typ^.comp = Array THEN
n := typ^.n; typ := typ^.BaseTyp;
WHILE typ^.comp = Array DO n := n * typ^.n; typ := typ^.BaseTyp END ;
IF typ^.form = Pointer THEN
OPM.WriteString("__ENUMP("); Ident(var); Str1(", #, P)", n)
ELSIF typ^.comp = Record THEN
OPM.WriteString("__ENUMR("); Ident(var); OPM.WriteString(", ");
Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); Str1(", #, P)", n)
END
END ;
EndStat
END ;
var := var^.link
END ;
IF GlbPtrs THEN
EndBlk; OPM.WriteLn
END
END GenEnumPtrs;
PROCEDURE EnterBody*;
BEGIN
OPM.WriteLn; OPM.WriteString(Export);
IF mainprog THEN
IF ansi THEN
OPM.WriteString("main(int argc, char **argv)"); OPM.WriteLn;
ELSE
OPM.WriteString("main(argc, argv)"); OPM.WriteLn;
OPM.Write(Tab); OPM.WriteString("int argc; char **argv;"); OPM.WriteLn
END
ELSE
OPM.WriteString("void *");
OPM.WriteString(OPM.modName); OPM.WriteString(BodyNameExt); OPM.WriteLn;
END ;
BegBlk; BegStat;
IF mainprog THEN OPM.WriteString("__INIT(argc, argv)") ELSE OPM.WriteString("__DEFMOD") END ;
EndStat;
IF mainprog & demoVersion THEN BegStat;
OPM.WriteString('/*don`t do it!*/ printf("DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\n")');
EndStat
END ;
InitImports(OPT.topScope^.right);
BegStat;
IF mainprog THEN OPM.WriteString('__REGMAIN("') ELSE OPM.WriteString('__REGMOD("') END ;
OPM.WriteString(OPM.modName);
IF GlbPtrs THEN OPM.WriteString('", EnumPtrs)') ELSE OPM.WriteString('", 0)') END ;
EndStat;
IF OPM.modName # "SYSTEM" THEN RegCmds(OPT.topScope) END
END EnterBody;
PROCEDURE ExitBody*;
BEGIN
BegStat;
IF mainprog THEN OPM.WriteString("__FINI;") ELSE OPM.WriteString("__ENDMOD;") END ;
OPM.WriteLn; EndBlk
END ExitBody;
PROCEDURE DefineInter* (proc: OPT.Object); (* define intermediate scope record and variable *)
VAR scope: OPT.Object;
BEGIN
scope := proc^.scope;
OPM.WriteString(Static); OPM.WriteString(Struct); OPM.WriteStringVar(scope^.name); OPM.Write(Blank);
BegBlk;
IdentList(proc^.link, 3); (* parameters *)
IdentList(scope^.scope, 3); (* local variables *)
BegStat; (* scope link field declaration *)
OPM.WriteString(Struct); OPM.WriteStringVar (scope^.name);
OPM.Write(Blank); OPM.Write(Star); OPM.WriteString(LinkName); EndStat;
EndBlk0; OPM.Write(Blank);
OPM.Write(Star); OPM.WriteStringVar (scope^.name); OPM.WriteString(GlobalScope); EndStat; OPM.WriteLn;
ProcPredefs (scope^.right, 0);
OPM.WriteLn;
END DefineInter;
PROCEDURE EnterProc* (proc: OPT.Object);
VAR var, scope: OPT.Object; typ: OPT.Struct; dim: INTEGER;
BEGIN
IF proc^.vis # external THEN OPM.WriteString(Static) END ;
ProcHeader(proc, TRUE);
BegBlk;
scope := proc^.scope;
IdentList(scope^.scope, 0);
IF ~scope^.leaf THEN (* declare intermediate procedure scope record variable*)
BegStat; OPM.WriteString(Struct); OPM.WriteStringVar (scope^.name);
OPM.Write(Blank); OPM.WriteString(LocalScope); EndStat
END ;
var := proc^.link;
WHILE var # NIL DO (* declare copy of fixed size value array parameters *)
IF (var^.typ^.comp = Array) & (var^.mode = Var) THEN
BegStat;
IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END ;
OPM.Write(Blank); Ident(var); OPM.WriteString("__copy");
EndStat
END ;
var := var^.link
END ;
IF ~ansi THEN
var := proc^.link;
WHILE var # NIL DO (* "unpromote" value real parameters *)
IF (var^.typ^.form = Real) & (var^.mode = Var) THEN
BegStat;
Ident(var^.typ^.strobj); OPM.Write(Blank); Ident(var); OPM.WriteString(" = _"); Ident(var);
EndStat
END ;
var := var^.link
END
END ;
var := proc^.link;
WHILE var # NIL DO (* copy value array parameters *)
IF (var^.typ^.comp IN {Array, DynArr}) & (var^.mode = Var) & (var^.typ^.sysflag = 0) THEN
BegStat;
IF var^.typ^.comp = Array THEN
OPM.WriteString(DupArrFunc);
Ident(var); OPM.WriteString(Comma);
IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END
ELSE
OPM.WriteString(DupFunc);
Ident(var); OPM.WriteString(Comma); Ident(var); OPM.WriteString(LenExt);
typ := var^.typ^.BaseTyp; dim := 1;
WHILE typ^.comp = DynArr DO
OPM.WriteString(" * "); Ident(var); OPM.WriteString(LenExt); OPM.WriteInt(dim);
typ := typ^.BaseTyp; INC(dim)
END ;
OPM.WriteString(Comma);
IF (typ^.strobj = NIL) THEN OPM.Mark(200, typ^.txtpos)
ELSE Ident(typ^.strobj)
END
END ;
OPM.Write(CloseParen); EndStat
END ;
var := var^.link
END ;
IF ~scope^.leaf THEN
var := proc^.link; (* copy addresses of parameters into local scope record *)
WHILE var # NIL DO
IF ~var^.leaf THEN (* only if used by a nested procedure *)
BegStat;
OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var);
OPM.WriteString(Becomes);
IF var^.typ^.comp IN {Array, DynArr} THEN OPM.WriteString("(void*)")
(* K&R and ANSI differ in the type: array or element type*)
ELSIF var^.mode # VarPar THEN OPM.Write("&")
END ;
Ident(var);
IF var^.typ^.comp = DynArr THEN
typ := var^.typ; dim := 0;
REPEAT (* copy len(s) *)
OPM.WriteString("; ");
OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(LenExt);
IF dim # 0 THEN OPM.WriteInt(dim) END ;
OPM.WriteString(Becomes); Ident(var); OPM.WriteString(LenExt);
IF dim # 0 THEN OPM.WriteInt(dim) END ;
typ := typ^.BaseTyp
UNTIL typ^.comp # DynArr;
ELSIF (var^.mode = VarPar) & (var^.typ^.comp = Record) THEN
OPM.WriteString("; ");
OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(TagExt);
OPM.WriteString(Becomes); Ident(var); OPM.WriteString(TagExt)
END ;
EndStat
END;
var := var^.link;
END;
var := scope^.scope; (* copy addresses of local variables into scope record *)
WHILE var # NIL DO
IF ~var^.leaf THEN (* only if used by a nested procedure *)
BegStat;
OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(Becomes);
IF var^.typ^.comp # Array THEN OPM.Write("&")
ELSE OPM.WriteString("(void*)") (* K&R and ANSI differ in the type: array or element type*)
END ;
Ident(var); EndStat
END ;
var := var^.link
END;
(* now link new scope *)
BegStat; OPM.WriteString(LocalScope); OPM.Write(Dot); OPM.WriteString(LinkName);
OPM.WriteString(Becomes); OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); EndStat;
BegStat; OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); OPM.WriteString(Becomes);
OPM.Write("&"); OPM.WriteString(LocalScope); EndStat
END
END EnterProc;
PROCEDURE ExitProc*(proc: OPT.Object; eoBlock, implicitRet: BOOLEAN);
VAR var: OPT.Object; indent: BOOLEAN;
BEGIN
indent := eoBlock;
IF implicitRet & (proc^.typ # OPT.notyp) THEN
OPM.Write(Tab); OPM.WriteString("__RETCHK;"); OPM.WriteLn
ELSIF ~eoBlock OR implicitRet THEN
IF ~proc^.scope^.leaf THEN
(* link scope pointer of nested proc back to previous scope *)
IF indent THEN BegStat ELSE indent := TRUE END ;
OPM.WriteStringVar(proc^.scope^.name); OPM.WriteString(GlobalScope);
OPM.WriteString(Becomes); OPM.WriteString(LocalScope); OPM.Write(Dot); OPM.WriteString(LinkName);
EndStat
END;
(* delete array value parameters *)
var := proc^.link;
WHILE var # NIL DO
IF (var^.typ^.comp = DynArr) & (var^.mode = Var) & (var^.typ^.sysflag = 0) THEN
IF indent THEN BegStat ELSE indent := TRUE END ;
OPM.WriteString(DelFunc); Ident(var); OPM.Write(CloseParen); EndStat
END ;
var := var^.link
END
END ;
IF eoBlock THEN EndBlk; OPM.WriteLn
ELSIF indent THEN BegStat
END
END ExitProc;
PROCEDURE CompleteIdent*(obj: OPT.Object);
VAR comp, level: INTEGER;
BEGIN
(* obj^.mode IN {Var, VarPar} *)
level := obj^.mnolev;
IF obj^.adr = 1 THEN (* WITH-variable *)
IF obj^.typ^.comp = Record THEN Ident(obj); OPM.WriteString("__")
ELSE (* cast with guard pointer type *)
OPM.WriteString("(("); Ident(obj^.typ^.strobj); OPM.Write(")"); Ident(obj); OPM.Write(")")
END
ELSIF (level # OPM.level) & (level > 0) THEN (* intermediate var *)
comp := obj^.typ^.comp;
IF (obj^.mode # VarPar) & (comp # DynArr) THEN OPM.Write(Star); END;
OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString(GlobalScope);
OPM.WriteString("->"); Ident(obj)
ELSE
Ident(obj)
END
END CompleteIdent;
PROCEDURE TypeOf*(ap: OPT.Object);
VAR i: INTEGER;
BEGIN
ASSERT(ap.typ.comp = Record);
IF ap.mode = VarPar THEN
IF ap.mnolev # OPM.level THEN (*intermediate level var-par record; possible WITH-guarded*)
OPM.WriteStringVar(ap^.scope^.name); OPM.WriteString("_s->"); Ident(ap)
ELSE (*local var-par record*)
Ident(ap)
END ;
OPM.WriteString(TagExt)
ELSIF ap^.typ^.strobj # NIL THEN
Ident(ap^.typ^.strobj); OPM.WriteString(DynTypExt)
ELSE Andent(ap.typ) (*anonymous ap type, p^ *)
END
END TypeOf;
PROCEDURE Cmp*(rel: INTEGER);
BEGIN
CASE rel OF
eql :
OPM.WriteString(" == ");
| neq :
OPM.WriteString(" != ");
| lss :
OPM.WriteString(" < ");
| leq :
OPM.WriteString(" <= ");
| gtr :
OPM.WriteString(" > ");
| geq :
OPM.WriteString(" >= ");
ELSE
OPM.LogWStr("unhandled case in OPC.Cmp, rel = "); OPM.LogWNum(rel, 0); OPM.LogWLn;
END;
END Cmp;
PROCEDURE Case*(caseVal: LONGINT; form: INTEGER);
VAR
ch: CHAR;
BEGIN
OPM.WriteString(CaseStat);
CASE form OF
| Char :
ch := CHR (caseVal);
IF (ch >= " ") & (ch <= "~") THEN
OPM.Write(SingleQuote);
IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\"); OPM.Write(ch);
ELSE OPM.Write(ch);
END;
OPM.Write(SingleQuote);
ELSE
OPM.WriteString("0x"); OPM.WriteHex (caseVal);
END;
| SInt, Int, LInt :
OPM.WriteInt (caseVal);
ELSE
OPM.LogWStr("unhandled case in OPC.Case, form = "); OPM.LogWNum(form, 0); OPM.LogWLn;
END;
OPM.WriteString(Colon);
END Case;
PROCEDURE SetInclude* (exclude: BOOLEAN);
BEGIN
IF exclude THEN OPM.WriteString(" &= ~"); ELSE OPM.WriteString(" |= "); END;
END SetInclude;
PROCEDURE Increment* (decrement: BOOLEAN);
BEGIN
IF decrement THEN OPM.WriteString(" -= "); ELSE OPM.WriteString(" += "); END;
END Increment;
PROCEDURE Halt* (n: LONGINT);
BEGIN
Str1("__HALT(#)", n)
END Halt;
PROCEDURE Len* (obj: OPT.Object; array: OPT.Struct; dim: LONGINT);
BEGIN
IF array^.comp = DynArr THEN
CompleteIdent(obj); OPM.WriteString(LenExt);
IF dim # 0 THEN OPM.WriteInt(dim) END
ELSE (* array *)
WHILE dim > 0 DO array := array^.BaseTyp; DEC(dim) END ;
OPM.WriteInt(array^.n); OPM.PromoteIntConstToLInt()
END
END Len;
PROCEDURE Constant* (con: OPT.Const; form: INTEGER);
VAR i, len: INTEGER; ch: CHAR; s: SET;
hex: LONGINT; skipLeading: BOOLEAN;
BEGIN
CASE form OF
Byte:
OPM.WriteInt(con^.intval)
| Bool:
OPM.WriteInt(con^.intval)
| Char:
ch := CHR(con^.intval);
IF (ch >= " ") & (ch <= "~") THEN
OPM.Write(SingleQuote);
IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\") END ;
OPM.Write(ch);
OPM.Write(SingleQuote)
ELSE
OPM.WriteString("0x"); OPM.WriteHex(con^.intval)
END
| SInt, Int, LInt:
OPM.WriteInt(con^.intval)
(* | Int8, Int16, Int32, Int64:
OPM.WriteInt(con^.intval)*)
| Real:
OPM.WriteReal(con^.realval, "f")
| LReal:
OPM.WriteReal(con^.realval, 0X)
| Set:
OPM.WriteString("0x");
skipLeading := TRUE;
s := con^.setval; i := MAX(SET) + 1;
REPEAT
hex := 0;
REPEAT
DEC(i); hex := 2 * hex;
IF i IN s THEN INC(hex) END
UNTIL i MOD 8 = 0;
IF (hex # 0) OR ~skipLeading THEN
OPM.WriteHex(hex);
skipLeading := FALSE
END
UNTIL i = 0;
IF skipLeading THEN OPM.Write("0") END
| String:
OPM.Write(Quotes);
len := SHORT(con^.intval2) - 1; i := 0;
WHILE i < len DO ch := con^.ext^[i];
IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\") END ;
OPM.Write(ch); INC(i)
END ;
OPM.Write(Quotes)
| NilTyp:
OPM.WriteString(NilConst);
ELSE
OPM.LogWStr("unhandled case in OPC.Constant, form = "); OPM.LogWNum(form, 0); OPM.LogWLn;
END;
END Constant;
PROCEDURE InitKeywords;
VAR n, i: SHORTINT;
PROCEDURE Enter(s: ARRAY OF CHAR);
VAR h: INTEGER;
BEGIN h := PerfectHash(s); hashtab[h] := n; COPY(s, keytab[n]); INC(n)
END Enter;
BEGIN n := 0;
FOR i := 0 TO 104 DO hashtab[i] := -1 END ;
Enter("asm");
Enter("auto");
Enter("break");
Enter("case");
Enter("char");
Enter("const");
Enter("continue");
Enter("default");
Enter("do");
Enter("double");
Enter("else");
Enter("enum");
Enter("extern");
Enter("export"); (* pseudo keyword used by voc *)
Enter("float");
Enter("for");
Enter("fortran");
Enter("goto");
Enter("if");
Enter("import"); (* pseudo keyword used by voc *)
Enter("int");
Enter("long");
Enter("register");
Enter("return");
Enter("short");
Enter("signed");
Enter("sizeof");
Enter("static");
Enter("struct");
Enter("switch");
Enter("typedef");
Enter("union");
Enter("unsigned");
Enter("void");
Enter("volatile");
Enter("while");
(* what about common predefined names from cpp as e.g.
Operating System: ibm, gcos, os, tss and unix
Hardware: interdata, pdp11, u370, u3b,
u3b2, u3b5, u3b15, u3b20d,
vax, ns32000, iAPX286, i386,
sparc , and sun
UNIX system variant:
RES, and RT
The lint(1V) command:
lint
*)
END InitKeywords;
BEGIN InitKeywords
END OPC.
Reference in a new issue View git blame Copy permalink