
<<FILE: M2TImpl.mesa>>
<<Modula-2 Symboltable Handler>>
<<Last Edited by: Gutknecht, September 18, 1985 0:29:18 am PDT>>
    <<Satterthwaite December 11, 1985 3:25:14 pm PST>>

DIRECTORY
M2D: TYPE USING [ObjClass, StrForm, ObjPtr, HeaderPtr, ConstPtr, TypPtr, ModulePtr, StrPtr, EnumPtr, RangePtr, PointerPtr, ProcPtr, 
SetPtr, RecordPtr, ProcTypPtr, CDPtr, ParPtr, ImpPtr, ExpPtr, Object, Structure, BDesc, Parameter, ImportItem, ExportItem, 
WordSize, nilval, sysmod, mainmod, undftyp, notyp, cardtyp, inttyp, dbltyp, realtyp, lrltyp, booltyp, chartyp, stringtyp, bitstyp, 
addrtyp, wordtyp, proctyp, InitData],
M2S: TYPE USING [id, Enter, Diff, Mark],
M2T: TYPE;

M2TImpl : CEDAR PROGRAM 
IMPORTS M2D, M2S
EXPORTS M2T = 

BEGIN OPEN M2T;

Scope: PUBLIC M2D.HeaderPtr; -- header of scope located by Find

topScope: M2D.HeaderPtr;
universe: M2D.HeaderPtr;

lastpar: M2D.ParPtr;
lastimp: M2D.ImpPtr;
lastexp: M2D.ExpPtr;


FindField: PUBLIC PROC [id: CARDINAL, rec: M2D.RecordPtr] RETURNS [fld: M2D.ObjPtr] =
{ fld _ rec^.firstFld;
DO
IF fld = NIL THEN EXIT;
IF M2S.Diff [id, fld^.name] = 0 THEN EXIT;
fld _ fld^.next
ENDLOOP };

FindExport: PUBLIC PROC [id: CARDINAL, mod: M2D.ModulePtr] RETURNS [obj: M2D.ObjPtr] =
{ -- find an object in export list of module mod --
IF mod^.key = 0 THEN -- local module --
{ FOR exp: M2D.ExpPtr _ mod^.firstExp, exp^.next DO
IF exp = NIL THEN { obj _ NIL; EXIT };
IF M2S.Diff [id, exp^.name] = 0 THEN { obj _ exp^.item; EXIT };
ENDLOOP }
ELSE { obj _ mod^.firstObj;
DO
IF obj = NIL THEN EXIT;
IF M2S.Diff [id, obj^.name] = 0 THEN EXIT;
obj _ obj^.next
ENDLOOP }};

FindInScope: PROC [id: CARDINAL, hdr: M2D.HeaderPtr] RETURNS [obj: M2D.ObjPtr] =
{ obj _ hdr^.next;
DO
IF obj = NIL THEN EXIT;
IF M2S.Diff [id, obj^.name] = 0 THEN EXIT;
obj _ obj^.next
ENDLOOP;
IF obj = NIL THEN { 
FOR imp: M2D.ImpPtr _ hdr^.firstImp, imp^.next DO
IF imp = NIL THEN EXIT;
IF M2S.Diff [id, imp^.name] = 0 THEN { obj _ imp^.item; EXIT };
ENDLOOP }};

Find: PUBLIC PROC [id: CARDINAL] RETURNS [obj: M2D.ObjPtr] =
{ Scope _ topScope;
DO 
obj _ FindInScope [id, Scope];
IF obj # NIL THEN EXIT;
IF Scope^.kind = Module THEN
{ obj _ FindInScope [id, universe]; EXIT };
Scope _ NARROW [Scope^.base]
ENDLOOP };

NewObj: PUBLIC PROC [id: CARDINAL, class: M2D.ObjClass] RETURNS [obj: M2D.ObjPtr] =
{ obj _ FindInScope [id, topScope];
IF obj # NIL THEN M2S.Mark [100];
SELECT class FROM
Header    =>    obj _ NEW [M2D.Object.Header _ [name: id, ext: Header []]];
Const        =>    obj _ NEW [M2D.Object.Const _ [name: id, ext: Const [[Int [0]]]]];
Typ        =>    obj _ NEW [M2D.Object.Typ _ [name: id, ext: Typ []]];
Var        =>    obj _ NEW [M2D.Object.Var _ [name: id, ext: Var []]];
Field        =>    obj _ NEW [M2D.Object.Field _ [name: id, ext: Field []]];
Proc        =>    { obj _ NEW [M2D.Object.Proc _ [name: id, ext: Proc []]]; NewProc };
Module    =>    obj _ NEW [M2D.Object.Module _ [name: id, ext: Module [firstExp: lastexp]]]; 
ENDCASE;
topScope^.last^.next _ obj; topScope^.last _ obj };

NewStr: PUBLIC PROC [form: M2D.StrForm] RETURNS [str: M2D.StrPtr] =
{ SELECT form FROM
Undef        => str _ NEW [M2D.Structure.Undef];
Bool        => str _ NEW [M2D.Structure.Bool];
Char        => str _ NEW [M2D.Structure.Char];
Int        => str _ NEW [M2D.Structure.Int];
Card        => str _ NEW [M2D.Structure.Card];
Double    => str _ NEW [M2D.Structure.Double];
Real        => str _ NEW [M2D.Structure.Real];
LongReal    => str _ NEW [M2D.Structure.LongReal];
String        => str _ NEW [M2D.Structure.String];
Opaque    => str _ NEW [M2D.Structure.Opaque];
Enum        => str _ NEW [M2D.Structure.Enum];
Range        => str _ NEW [M2D.Structure.Range];
Pointer    => str _ NEW [M2D.Structure.Pointer];
Set         => str _ NEW [M2D.Structure.Set];
Array     => str _ NEW [M2D.Structure.Array];
Record     => str _ NEW [M2D.Structure.Record];
ProcTyp     => { str _ NEW [M2D.Structure.ProcTyp]; NewProc }
ENDCASE };

NewImp: PUBLIC PROC [obj: M2D.ObjPtr] =
{ imp: M2D.ImpPtr _ lastimp;
n: CARDINAL; 
WHILE imp # NIL DO
IF M2S.Diff [imp^.name, obj^.name] = 0 THEN M2S.Mark [100];
imp _ imp^.next
ENDLOOP;
imp _ NEW [M2D.ImportItem _ [ name: obj^.name, item: obj, next: lastimp ]];
lastimp _ imp;
IF (obj^.class = Typ) AND (obj^.typ^.form = Enum) THEN
{ -- import enum constants too --
enum: M2D.EnumPtr = NARROW [obj^.typ];
n _ enum^.NofConst;
WHILE n > 0 DO
n _ n - 1; obj _ obj^.next; NewImp [obj]
ENDLOOP }};

NewProc: PUBLIC PROC  =
{ lastpar _ NIL };

NewPar: PUBLIC PROC [typ: M2D.StrPtr, varpar: BOOLEAN] =
{ par: M2D.ParPtr = NEW [M2D.Parameter _ [typ: typ, varpar: varpar, next: lastpar]];
lastpar _ par };

NewExp: PUBLIC PROC [id: CARDINAL] =
{ exp: M2D.ExpPtr = NEW [M2D.ExportItem _ [name: id, item: NIL, next: lastexp]];
lastexp _ exp };

ParamLink: PUBLIC PROC RETURNS [p: M2D.ParPtr] =
{ q: M2D.ParPtr; -- reverse parameter chain --
p _ NIL;
WHILE lastpar # NIL DO
q _ lastpar; lastpar _ q^.next; q^.next _ p; p _ q
ENDLOOP };

FirstObj: PUBLIC PROC RETURNS [M2D.ObjPtr] =  { RETURN [topScope^.next] };

LastObj: PUBLIC PROC RETURNS [M2D.ObjPtr] =  { RETURN [topScope^.last] };

NewScope: PUBLIC PROC [class: M2D.ObjClass] RETURNS [hdr: M2D.HeaderPtr] =
{ hdr _ NEW [M2D.Object.Header _ [ext: Header [kind: class, base: topScope]]];
IF class = Module THEN hdr^.firstImp _ lastimp;
hdr^.last _ hdr; topScope _ hdr };

LinkScope: PUBLIC PROC =
{ -- link object list of definition module to scope --
obj: M2D.ObjPtr _ M2D.mainmod^.firstObj;
topScope^.next _ obj;
IF obj # NIL THEN
{ WHILE obj^.next # NIL DO obj _ obj^.next ENDLOOP;
topScope^.last _ obj }};

CloseScope: PUBLIC PROC = { topScope _ NARROW [topScope^.base] };

CheckUDP: PUBLIC PROC [obj: M2D.ObjPtr] =
{ -- obj is newly defined type;
<<check for undefined forward references pointing to this new type>>
FOR ob1: M2D.ObjPtr _ topScope^.next, ob1^.next WHILE ob1 # NIL DO
IF (ob1^.class = Typ) AND (ob1^.typ^.form = Pointer) THEN
{ pointer: M2D.PointerPtr _ NARROW [ob1^.typ];
IF (pointer^.BaseTyp = M2D.undftyp) AND (M2S.Diff [pointer^.BaseId, obj^.name] = 0) THEN pointer^.BaseTyp _ obj^.typ };
ENDLOOP };

InitImpExp: PUBLIC PROC = { lastimp _ NIL; lastexp _ NIL };

ValidateExports: PUBLIC PROC [ancestor: M2D.ModulePtr, qual: BOOLEAN] =
{ ob0, ob1, ob2: M2D.ObjPtr; im0, im1: M2D.ImpPtr; id: CARDINAL;
env: M2D.HeaderPtr = NARROW [topScope^.base];
lastimp _ env^.firstImp;
im1 _ topScope^.firstImp; ob1 _ topScope^.next; 
FOR exp: M2D.ExpPtr _ ancestor^.firstExp, exp^.next WHILE exp # NIL DO
id _ exp^.name; ob0 _ ob1;
DO
IF ob0 = NIL THEN EXIT;
IF M2S.Diff [id, ob0^.name] = 0 THEN EXIT;
ob0 _ ob0^.next
ENDLOOP;
IF ob0 = NIL THEN { im0 _ im1;
DO
IF im0 = NIL THEN EXIT;
IF M2S.Diff [id, im0^.name] = 0 THEN { ob0 _ im0^.item; EXIT };
im0 _ im0^.next
ENDLOOP };
IF ob0 # NIL THEN { exp^.item _ ob0;
IF NOT qual THEN
{ ob2 _ FindInScope [ob0^.name, env];
IF ob2 = NIL THEN NewImp [ob0] ELSE M2S.Mark [150] -- collision -- }
ELSE M2S.Mark [80] };
ENDLOOP;
env^.firstImp _ lastimp };

Mark: PUBLIC PROC = { topScope^.name _ M2S.id -- Mark name buffer --};

Release: PUBLIC PROC = { M2S.id _ topScope^.name -- Release name buffer --};

InitTableHandler: PUBLIC PROC = { topScope _ universe; M2D.mainmod _ NIL };

EnterTyp: PROC [name: REF TEXT, form: M2D.StrForm, size: CARDINAL] RETURNS [str: M2D.StrPtr] =
{ obj: M2D.TypPtr = NARROW [NewObj [M2S.Enter [name], Typ]];
str _ NewStr [form]; obj^.typ _ str;
str^.strobj _ obj; str^.size _ size };

EnterProc: PROC [name: REF TEXT, num: CARDINAL, res: M2D.StrPtr] =
{ obj: M2D.ProcPtr = NARROW [NewObj [M2S.Enter [name], Proc]];
cd: M2D.CDPtr = NEW [M2D.BDesc.Code _ [Code[num: num, cod: ]]];
NewProc;
obj^.typ _ res;  obj^.bd _ cd };

{ obj: M2D.ObjPtr;
BBtyp: M2D.StrPtr;

set: M2D.SetPtr _ NIL;
range: M2D.RangePtr _ NIL;
proctyp: M2D.ProcTypPtr _ NIL;
const: M2D.ConstPtr;

M2D.InitData;
InitImpExp; topScope _ NIL; Scope _ NIL; M2D.mainmod _ NIL;
universe _ NewScope [Module];
M2D.undftyp _ NewStr [Undef]; M2D.undftyp^.size _ 1;
M2D.notyp _ NewStr [Undef]; M2D.notyp^.size _ 0;
M2D.stringtyp _ NewStr [String]; M2D.stringtyp^.size _ 0;
BBtyp _ NewStr[Range]; -- Bitset basetype --

<<initialization of module SYSTEM -->>
M2D.wordtyp _ EnterTyp ["WORD ", Undef, 1];
M2D.addrtyp _ EnterTyp ["ADDRESS ", Double, 1];
EnterProc ["TSIZE ", 8, NIL];
EnterProc ["ADR ", 10, M2D.addrtyp];
M2D.sysmod _ NEW [M2D.Object.Module _ [ name: M2S.Enter ["SYSTEM "],
ext: Module [key: 1, firstExp: lastexp, firstObj: topScope^.next]]];

<<initialization of universe -->>
InitImpExp;
topScope^.last _ topScope;
M2D.cardtyp _ EnterTyp ["CARDINAL ", Card, 1];
M2D.inttyp _ EnterTyp ["INTEGER ", Int, 1];
M2D.chartyp _ EnterTyp ["CHAR ", Char, 1];
M2D.booltyp _ EnterTyp ["BOOLEAN ", Bool, 1];
obj _ NewObj [M2S.Enter ["FALSE "], Const]; obj^.typ _ M2D.booltyp;
const _ NARROW [obj]; const^.conval.B _ FALSE;
obj _ NewObj [M2S.Enter ["TRUE "], Const]; obj^.typ _ M2D.booltyp; 
const _ NARROW [obj]; const^.conval.B _ TRUE;
obj _ NewObj [M2S.Enter ["NIL "], Const]; obj^.typ _ M2D.addrtyp; 
const _ NARROW [obj]; const^.conval.C _ M2D.nilval;
M2D.realtyp _ EnterTyp ["REAL ", Real, 2];
M2D.bitstyp _ EnterTyp ["BITSET ", Set, 1];
set _ NARROW [M2D.bitstyp]; set^.BaseTyp _ BBtyp;
BBtyp^.size _ 1;
range _ NARROW [BBtyp]; range^.BaseTyp _ M2D.cardtyp;
range^.min _ 0; range^.max _ M2D.WordSize - 1;
M2D.dbltyp _ EnterTyp ["LONGINT ", Double, 2];
M2D.lrltyp _ EnterTyp ["LONGREAL ", LongReal, 4];
M2D.proctyp _ EnterTyp ["PROC ", ProcTyp, 1];
proctyp _ NARROW [M2D.proctyp];
proctyp^.firstPar _ NIL; proctyp^.resTyp _ M2D.notyp;
EnterProc ["HALT ", 1, M2D.notyp];
EnterProc ["ABS ", 2, M2D.inttyp];
EnterProc ["CAP ", 3, M2D.chartyp];
EnterProc ["FLOAT ", 4, M2D.realtyp];
EnterProc ["ODD ", 5, M2D.booltyp];
EnterProc ["ORD ", 6, M2D.cardtyp];
EnterProc ["TRUNC ", 7, M2D.cardtyp];
EnterProc ["SIZE ", 8, NIL];
EnterProc ["MIN ", 11, M2D.cardtyp];
EnterProc ["MAX ", 12, M2D.cardtyp];
EnterProc ["HIGH ", 13, M2D.cardtyp];
EnterProc ["CHR ", 14, M2D.chartyp];
EnterProc ["LONG ", 15, M2D.dbltyp];
EnterProc ["INC ", 16, M2D.notyp];
EnterProc ["DEC ", 17, M2D.notyp];
EnterProc ["INCL ", 18, M2D.notyp];
EnterProc ["EXCL ", 19, M2D.notyp];
EnterProc ["SHIFT ", 20, M2D.cardtyp];
Mark}

END.
