(Syntax10.Scn.FntGF(Syntax10b.Scn.Fnt    " M 7F %   e 8 1 R   #  <      5   & K 3  8 ( 4 > ? $ "    !       #       S -  . t*")!O%m$8FoldElemsNew#Syntax10.Scn.Fnt Shortcut for OPM.err 88*Syntax10.Scn.Fnt BEGIN OPM.err(n); END err;8  8#Syntax10.Scn.Fnt,, Shortcut for allocating a new constant. 8|8CSyntax10.Scn.Fnt'Syntax10b.Scn.FntB VAR const:Const; BEGIN NEW(const); RETURN const; END NewConst;8  8#Syntax10.Scn.Fnt** Shortcut for allocating a new object. 88CSyntax10.Scn.Fnt#Syntax10b.Scn.Fnt; VAR obj:Object; BEGIN NEW(obj); RETURN obj; END NewObj;8 8#Syntax10.Scn.Fnt88 Create new structure with given form and composite. 88QSyntax10.Scn.Fnt](CSyntax10b.Scn.Fnt VAR typ:Struct; BEGIN NEW(typ); typ^.form:=form; typ^.comp:=comp; typ^.ref:=maxStruct; (* ref >= maxStruct: not exported yet *) typ^.txtpos:=OPM.errpos; typ^.size:=-1; typ^.BaseTyp:=undftyp; RETURN typ; END NewStr;8 8#Syntax10.Scn.Fnt## Create a node with given class 8m8CSyntax10.Scn.Fnt8Syntax10b.Scn.FntQ VAR node:Node; BEGIN NEW(node); node^.class:=class; RETURN node END NewNode;8 8#Syntax10.Scn.Fnt44 Shortcut for allocating a new string extension. 88CSyntax10.Scn.Fnt%Syntax10b.Scn.Fnt= VAR ext:ConstExt; BEGIN NEW(ext); RETURN ext; END NewExt;8  !8#Syntax10.Scn.Fnt Create a new scope, and link it to owner. owenr may be NIL, if this is a "standalone" scope. Sideeffects: Links current topScope as outer scope into Object.left, and modifies topScope, to point to new scope. 88#Syntax10.Scn.Fnt VAR head:Object; BEGIN head:=NewObj(); head.mode:=Head; head.mnolev:=level; head.link:=owner; IF owner#NIL THEN owner.scope:=head; END; head.left:=topScope; head.right:=NIL; head.scope:=NIL; topScope:=head; END OpenScope;8  8#Syntax10.Scn.FntNN Sideeffect: Modifies topScope to point to outer scope in topScope.left. 88#Syntax10.Scn.Fnt00 BEGIN topScope:=topScope.left; END CloseScope;8 8#Syntax10.Scn.Fnt88 (Re-)iniitalise the module, for a new compilation. 8 8?Syntax10.Scn.Fnt.nsEd BEGIN SYSimported:=FALSE; sfpresent:=TRUE; (* Reset topScope to universe, and create a first scope for the module. Initialize the module table. *) topScope:=universe; OpenScope(0,NIL); SelfName:=name; topScope^.name:=name; GlbMod[0]:=topScope; nofGmod:=1; (* Set the booleans representing the options we need to know. *) newsf:=OPM.newsf IN opt; findpc:=OPM.findpc IN opt; extsf:=newsf OR (OPM.extsf IN opt); END Init;8 c8#Syntax10.Scn.Fnt{{ Set global pointers to NIL, so that the as much allocated storage as possible can be freed by the garbage collector. 88#Syntax10.Scn.Fnt VAR i:INTEGER; BEGIN CloseScope; i:=0; WHILE iobj^.name THEN (* idem *) obj:=obj^.right; ELSE (* found *) IF (obj^.mode=Typ) & (obj^.vis=internal) THEN obj:=NIL; (* why that ?? *) ELSE obj^.used:=TRUE; (* Remeber used objects *) END; EXIT; END; END; res:=obj END FindImport;8 [8#Syntax10.Scn.Fnt Search object named by the last scaned identifier. The current scope as well as all outer scopes plus universe are searched. 858Syntax10.Scn.FntH-Syntax10b.Scn.Fnto0"$& VAR obj,head:Object; BEGIN head:=topScope; LOOP obj:=head^.right; (* This level's scope is anchored in right *) LOOP IF obj=NIL THEN EXIT; END; IF OPS.nameobj^.name THEN obj:=obj^.right; ELSE (* found, obj^.used not set for local objects *) EXIT; END END; IF obj#NIL THEN EXIT; END; (* Terminate because object found *) head:=head^.left; (* Go to next outer scope *) IF head=NIL THEN EXIT; END; (* Terminate because no outer scope *) END; res:=obj END Find;8  2D8#Syntax10.Scn.Fnt Search object with given name in the field list of the given typ. Note: This procedure assumes (and does not check) that typ is a record type. 88QSyntax10.Scn.Fnt  Syntax10b.Scn.FntD  VAR obj:Object; BEGIN WHILE typ#NIL DO obj:=typ.link; WHILE obj#NIL DO IF nameobj.name THEN obj:=obj.right; ELSE (* found *) res:=obj; RETURN; END; END; typ:=typ.BaseTyp; END; res:=NIL; END FindField;8 &8#Syntax10.Scn.Fnt99 Create new object wityh given name in current scope. 8o8CSyntax10.Scn.Fnt&Syntax10b.Scn.Fnt%O VAR ob0,ob1:Object; left:BOOLEAN; mnolev:SHORTINT; BEGIN ob0:=topScope; ob1:=ob0^.right; left:=FALSE; LOOP IF ob1#NIL THEN IF nameob1^.name THEN ob0:=ob1; ob1:=ob0^.right; left:=FALSE; ELSE (*double def*) err(1); ob0:=ob1; ob1:=ob0^.right; END; ELSE (*insert*) ob1:=NewObj(); ob1^.leaf:=TRUE; IF left THEN ob0^.left:=ob1 ELSE ob0^.right:=ob1 END; ob1^.left:=NIL; ob1^.right:=NIL; COPY(name,ob1^.name); mnolev:=topScope^.mnolev; ob1^.mnolev:=mnolev; EXIT; END; END; obj:=ob1; END Insert;8Q8+48J g-/` "k   I?6:%@iHsParcElemsAlloc Courier10.Scn.Fnto4 4(44 4 4 4+4.444/44 4EEF-H7 H H X H H  H$ H HHH H H&MODULE OROPT; (* NW, RC 6.3.89 / 23.1.92 *) (* object model 24.2.94 *) (* I assume, that this module manages the symbol and syntax tree. *) IMPORT OPS:=OROPS,OPM:=OROPM; CONST MaxConstLen*=OPS.MaxStrLen; TYPE Const*=POINTER TO ConstDesc; Object*=POINTER TO ObjDesc; Struct*=POINTER TO StrDesc; Node*=POINTER TO NodeDesc; ConstExt*=POINTER TO OPS.String; ConstDesc*=RECORD ext*:ConstExt; (* string or code for code proc *) intval*:LONGINT; (* constant value or adr, proc par size, text position or least case label *) intval2*:LONGINT; (* string length, proc var size or larger case label *) setval*:SET; (* constant value, procedure body present or "ELSE" present in case *) realval*:LONGREAL; (* real or longreal constant value *) END; ObjDesc*=RECORD left*,right*:Object; (* links to subtrees with objects whose names are less (->left) or greater (->right) than its name *) link*:Object; (* link to next object in the sequence of declaration *) scope*:Object; (* points to Object which contains this object *) name*:OPS.Name; leaf*:BOOLEAN; (* true for procedures who don't call further procedures or unaliased variables *) mode*:SHORTINT; mnolev*:SHORTINT; (* mnolev<0 -> mno=-mnolev *) vis*:SHORTINT; (* internal, external, externalR *) history*:SHORTINT; (* relevant if name#"" *) used*:BOOLEAN; (* Object was referenced. Only set for non-local objects. *) fpdone*:BOOLEAN; fprint*:LONGINT; typ*:Struct; conval*:Const; adr*,linkadr*:LONGINT; x*:INTEGER; (* linkadr and x can be freely used by the backend *) END; StrDesc*=RECORD form*:SHORTINT; (* Encodes the kind of simple type. *) comp*:SHORTINT; (* Differentiates between simple type and the different composite types. *) mno*:SHORTINT; (* Number of module from which type was imported *) extlev*:SHORTINT; (* Number of "superclasses" *) ref*:INTEGER; (* Number of type used in linearizing the symbol tree *) sysflag*:INTEGER; (* Used for exttensions beyond Oberon *) n*:LONGINT; (* Number of array elements/type bound procedures *) size*:LONGINT; (* number of bytes needed to store an instance of this type *) align*:LONGINT; (* align is alignment for records and len offset for dynarrs *) txtpos*:LONGINT; (* declaration position in source *) allocated*,pbused*,pvused*,fpdone,idfpdone:BOOLEAN; idfp,pbfp*,pvfp*:LONGINT; BaseTyp*:Struct; link*:Object; (* List of record fields *) strobj*:Object; (* Points to name of this type *) END; NodeDesc*=RECORD left*,right*,link*:Node; class*,subcl*:SHORTINT; (* define the kind of node *) readonly*:BOOLEAN; typ*:Struct; obj*:Object; conval*:Const; END; CONST maxImps=31; (* must be <= MAX(SHORTINT) *) maxStruct=OPM.MaxStruct; (* must beOPM.MaxHdFld THEN OPM.Mark(225,typ^.txtpos); END; FPrintTProcs(typ^.link); OPM.FPrint(pvfp,pbfp); strobj:=typ^.strobj; IF (strobj=NIL) OR (strobj^.name="") THEN pbfp:=pvfp; END END; typ^.pbfp:=pbfp; typ^.pvfp:=pvfp END END FPrintStr; PROCEDURE FPrintObj*(obj:Object); VAR fprint:LONGINT; f,m:INTEGER; rval:REAL; ext:ConstExt; BEGIN IF ~obj^.fpdone THEN fprint:=0; obj^.fpdone:=TRUE; OPM.FPrint(fprint,obj^.mode); IF obj^.mode=Con THEN f:=obj^.typ^.form; OPM.FPrint(fprint,f); CASE f OF | Bool,Char,SInt,Int,LInt: OPM.FPrint(fprint,obj^.conval^.intval); | Set: OPM.FPrintSet(fprint,obj^.conval^.setval); | Real: rval:=SHORT(obj^.conval^.realval); OPM.FPrintReal(fprint,rval); | LReal: OPM.FPrintLReal(fprint,obj^.conval^.realval); | String: FPrintName(fprint,obj^.conval^.ext^); | NilTyp: ELSE err(127); END ELSIF obj^.mode=Var THEN OPM.FPrint(fprint,obj^.vis); FPrintStr(obj^.typ); OPM.FPrint(fprint,obj^.typ^.pbfp); ELSIF obj^.mode IN {XProc,IProc} THEN FPrintSign(fprint,obj^.typ,obj^.link); ELSIF obj^.mode=CProc THEN FPrintSign(fprint,obj^.typ,obj^.link); ext:=obj^.conval^.ext; m:=ORD(ext^[0]); f:=1; OPM.FPrint(fprint,m); WHILE f <= m DO OPM.FPrint(fprint,ORD(ext^[f])); INC(f); END; ELSIF obj^.mode=Typ THEN FPrintStr(obj^.typ); OPM.FPrint(fprint,obj^.typ^.pbfp); END; obj^.fprint:=fprint; END END FPrintObj; PROCEDURE FPrintErr*(obj:Object; errno:INTEGER); VAR ch:CHAR; i,j:INTEGER; BEGIN IF obj^.mnolev#0 THEN COPY(GlbMod[-obj^.mnolev]^.name,OPM.objname); i:=0; WHILE OPM.objname[i]#0X DO INC(i) END; OPM.objname[i]:="."; j:=0; INC(i); REPEAT ch:=obj^.name[j]; OPM.objname[i]:=ch; INC(j); INC(i) UNTIL ch=0X; ELSE COPY(obj^.name,OPM.objname); END; IF errno=249 THEN IF OPM.noerr THEN err(errno); END; ELSIF errno=253 THEN (* extension *) IF ~symNew & ~symExtended & ~extsf THEN err(errno); END; symExtended:=TRUE ELSE IF ~symNew & ~newsf THEN err(errno); END; symNew:=TRUE; END; END FPrintErr; (*-------------------------- Import --------------------------*) PROCEDURE InsertImport*(obj:Object; VAR root,old:Object); VAR left:BOOLEAN; ob0,ob1:Object; BEGIN IF root=NIL THEN root:=obj; old:=NIL; ELSE ob0:=root; ob1:=ob0^.right; left:=FALSE; IF obj^.nameob0^.name THEN ob1:=ob0^.right; left:=FALSE; ELSE old:=ob0; RETURN; END; LOOP IF ob1#NIL THEN IF obj^.nameob1^.name THEN ob0:=ob1; ob1:=ob1^.right; left:=FALSE; ELSE old:=ob1; EXIT; END; ELSE ob1:=obj; IF left THEN ob0^.left:=ob1; ELSE ob0^.right:=ob1; END; ob1^.left:=NIL; ob1^.right:=NIL; old:=NIL; EXIT; END; END; END; END InsertImport; PROCEDURE InName(VAR name:ARRAY OF CHAR); VAR ch:CHAR; i:INTEGER; BEGIN i:=0; REPEAT OPM.SymRCh(ch); name[i]:=ch; INC(i); UNTIL ch=0X; END InName; PROCEDURE InMod(VAR mno:SHORTINT); (* mno is global *) VAR head:Object; i:SHORTINT; mn:LONGINT; name:OPS.Name; BEGIN mn:=OPM.SymRInt(); IF mn=0 THEN mno:=impCtxt.glbmno[0]; ELSE IF mn=Smname THEN InName(name); IF (name=SelfName) & ~impCtxt.self THEN err(154); END; i:=0; WHILE (i= maxStruct:not exported yet, ref used for err 155 *) typ^.mno:=mno; typ^.allocated:=TRUE; typ^.strobj:=obj; obj^.mode:=Typ; obj^.typ:=typ; obj^.mnolev:=-mno; obj^.vis:=internal; (* name not visible here *) tag:=OPM.SymRInt(); IF tag=Ssys THEN typ^.sysflag:=SHORT(OPM.SymRInt()); tag:=OPM.SymRInt() END; CASE tag OF | Sptr: typ^.form:=Pointer; typ^.size:=OPM.PointerSize; typ^.n:=0; InStruct(typ^.BaseTyp) | Sarr: typ^.form:=Comp; typ^.comp:=Array; InStruct(typ^.BaseTyp); typ^.n:=OPM.SymRInt(); typSize(typ) (* no bounds address !! *) | Sdarr: typ^.form:=Comp; typ^.comp:=DynArr; InStruct(typ^.BaseTyp); IF typ^.BaseTyp^.comp=DynArr THEN typ^.n:=typ^.BaseTyp^.n + 1 ELSE typ^.n:=0 END; typSize(typ) | Srec: typ^.form:=Comp; typ^.comp:=Record; InStruct(typ^.BaseTyp); (*----- Old ----- IF typ^.BaseTyp=notyp THEN typ^.BaseTyp:=NIL; typ^.extlev:=0 ELSE typ^.extlev:=typ^.BaseTyp^.extlev + 1 END; ----- End Old -----*) (*----- New -----*) IF typ.BaseTyp=notyp THEN typ.BaseTyp:=NIL; END; typ.extlev:=0; t:=typ.BaseTyp; WHILE (t#NIL) & (t.form=Comp) & (t.comp=Record) DO INC(typ^.extlev); t:=t.BaseTyp; END; (*----- End New -----*) typ^.size:=OPM.SymRInt(); typ^.align:=OPM.SymRInt(); typ^.n:=OPM.SymRInt(); impCtxt.nextTag:=OPM.SymRInt(); last:=NIL; WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag<=Shdpro) DO fld:=InFld(); fld^.mnolev:=-mno; IF last#NIL THEN last^.link:=fld END; last:=fld; InsertImport(fld,typ^.link,dummy); impCtxt.nextTag:=OPM.SymRInt() END; WHILE impCtxt.nextTag#Send DO fld:=InTProc(mno); InsertImport(fld,typ^.link,dummy); impCtxt.nextTag:=OPM.SymRInt() END | Spro: typ^.form:=ProcTyp; typ^.size:=OPM.ProcSize; InSign(mno,typ^.BaseTyp,typ^.link) END; IF ref=impCtxt.minr THEN WHILE ref= Sxpro THEN obj^.conval:=NewConst(); obj^.conval^.intval:=-1; InSign(mno,obj^.typ,obj^.link); CASE tag OF | Sxpro:obj^.mode:=XProc | Sipro:obj^.mode:=IProc | Scpro:obj^.mode:=CProc; ext:=NewExt(); obj^.conval^.ext:=ext; OPM.SymRCh(ch); s:=ORD(ch); ext^[0]:=ch; (* HP has: s := SHORT(OPM.SymRInt()); ext^[0] := CHR(s); *) i:=1; WHILE i<=s DO OPM.SymRCh(ext^[i]); INC(i) END END ELSIF tag=Salias THEN obj^.mode:=Typ; InStruct(obj^.typ) ELSE obj^.mode:=Var; IF tag=Srvar THEN obj^.vis:=externalR END; InStruct(obj^.typ) END; InName(obj^.name) END; FPrintObj(obj); IF (obj^.mode=Var) & ((obj^.typ^.strobj=NIL) OR (obj^.typ^.strobj^.name="")) THEN (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) OPM.FPrint(impCtxt.reffp,obj^.typ^.ref - maxStruct) END; IF tag#Stype THEN InsertImport(obj,GlbMod[mno].right,old); IF impCtxt.self THEN IF old#NIL THEN (* obj is from old symbol file, old is new declaration *) IF old^.vis=internal THEN old^.history:=removed ELSE FPrintObj(old); (* FPrint(obj) already called *) IF obj^.fprint#old^.fprint THEN old^.history:=pbmodified ELSIF obj^.typ^.pvfp#old^.typ^.pvfp THEN old^.history:=pvmodified ELSE old^.history:=same END END ELSE obj^.history:=removed (* OutObj not called if mnolev<0 *) END (* ELSE old=NIL, or file read twice, consistent, OutObj not called *) END ELSE (* obj already inserted in InStruct *) IF impCtxt.self THEN (* obj^.mnolev=0 *) IF obj^.vis=internal THEN obj^.history:=removed ELSIF obj^.history=inserted THEN obj^.history:=same END (* ELSE OutObj not called for obj with mnolev<0 *) END END; RETURN obj END InObj; PROCEDURE Import*(aliasName:OPS.Name; VAR name:OPS.Name; VAR done:BOOLEAN); VAR obj:Object; mno:SHORTINT; (* done used in Browser *) BEGIN IF name="SYSTEM" THEN OPM.Mark(-300,0); SYSimported:=TRUE; Insert(aliasName,obj); obj^.mode:=Mod; obj^.mnolev:=0; obj^.scope:=syslink; obj^.typ:=notyp ELSE impCtxt.nofr:=FirstRef; impCtxt.minr:=maxStruct; impCtxt.nofm:=0; impCtxt.self:=aliasName="@self"; impCtxt.reffp:=0; OPM.OldSym(name,done); IF done THEN InMod(mno); impCtxt.nextTag:=OPM.SymRInt(); WHILE ~OPM.eofSF() DO obj:=InObj(mno); impCtxt.nextTag:=OPM.SymRInt() END; Insert(aliasName,obj); obj^.mode:=Mod; obj^.scope:=GlbMod[mno].right; GlbMod[mno].link:=obj; obj^.mnolev :=-mno; obj^.typ:=notyp; OPM.CloseOldSym ELSIF impCtxt.self THEN newsf:=TRUE; extsf:=TRUE; sfpresent:=FALSE ELSE err(152) (*sym file not found*) END END END Import; (*-------------------------- Export --------------------------*) PROCEDURE OutName(VAR name:ARRAY OF CHAR); VAR i:INTEGER; ch:CHAR; BEGIN i:=0; REPEAT ch:=name[i]; OPM.SymWCh(ch); INC(i) UNTIL ch=0X END OutName; PROCEDURE OutMod(mno:INTEGER); BEGIN IF expCtxt.locmno[mno]<0 THEN (* new mod *) OPM.SymWInt(Smname); expCtxt.locmno[mno]:=expCtxt.nofm; INC(expCtxt.nofm); OutName(GlbMod[mno].name) ELSE OPM.SymWInt(-expCtxt.locmno[mno]) END END OutMod; PROCEDURE ^OutStr(typ:Struct); PROCEDURE ^OutFlds(fld:Object; adr:LONGINT; visible:BOOLEAN); PROCEDURE OutHdFld(typ:Struct; fld:Object; adr:LONGINT); VAR i,j,n:LONGINT; btyp:Struct; BEGIN IF typ^.comp=Record THEN OutFlds(typ^.link,adr,FALSE) 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 (btyp^.form=Pointer) OR (btyp^.comp=Record) THEN j:=nofhdfld; OutHdFld(btyp,fld,adr); IF j#nofhdfld THEN i:=1; WHILE (i