123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635 |
- MODULE FoxInterpreterSymbols; (** AUTHOR ""; PURPOSE ""; *)
- IMPORT Strings, Basic := FoxBasic, StringPool, Streams, Commands, PersistentObjects, Modules, Machine, SyntaxTree := FoxSyntaxTree, SYSTEM;
- CONST
- TAB = 09X;
- CONST
- sfTypeNone = 0X;
- sfTypeCHAR = 01X;
- sfTypeCHAR8 = 02X;
- sfTypeCHAR16 = 03X;
- sfTypeCHAR32 = 04X;
- sfTypeRANGE = 05X;
- sfTypeSHORTINT = 06X;
- sfTypeINTEGER = 07X;
- sfTypeLONGINT = 08X;
- sfTypeHUGEINT = 09X;
- sfTypeWORD = 0AX;
- sfTypeLONGWORD = 0BX;
- sfTypeSIGNED8 = 0CX;
- sfTypeSIGNED16 = 0DX;
- sfTypeSIGNED32 = 0EX;
- sfTypeSIGNED64 = 0FX;
- sfTypeUNSIGNED8 = 10X;
- sfTypeUNSIGNED16 = 11X;
- sfTypeUNSIGNED32 = 12X;
- sfTypeUNSIGNED64 = 13X;
- sfTypeREAL = 14X;
- sfTypeLONGREAL = 15X;
- sfTypeCOMPLEX = 16X;
- sfTypeLONGCOMPLEX = 17X;
- sfTypeBOOLEAN = 18X;
- sfTypeSET = 19X;
- sfTypeANY = 1AX;
- sfTypeOBJECT = 1BX;
- sfTypeBYTE = 1CX;
- sfTypeADDRESS = 1DX;
- sfTypeSIZE = 1EX;
- sfTypePointerToRecord = 20X;
- sfTypePointerToArray = 21X;
- sfTypeOpenArray = 22X;
- sfTypeStaticArray = 23X;
- sfTypeRecord = 24X;
- TYPE
- Item*= PersistentObjects.Object;
- Object* = PersistentObjects.Object;
- Content* = PersistentObjects.Content;
- TYPE
- Result*= OBJECT (Item)
- PROCEDURE Evaluate*(): Value;
- BEGIN
- RETURN NIL;
- END Evaluate;
- PROCEDURE SetV*(v: Value): BOOLEAN;
- BEGIN
- RETURN FALSE;
- END SetV;
-
- PROCEDURE Find*(CONST name: ARRAY OF CHAR): Result;
- BEGIN
- RETURN NIL;
- END Find;
- PROCEDURE Address*(): ADDRESS;
- BEGIN
- RETURN NIL;
- END Address;
-
- PROCEDURE Trace*;
- BEGIN
-
- END Trace;
-
- END Result;
-
-
- SymbolResult*=OBJECT(Result)
- VAR name: ARRAY 32 OF CHAR;
-
- PROCEDURE InitSymbol(CONST n: ARRAY OF CHAR);
- BEGIN
- COPY(n, name);
- END InitSymbol;
-
- END SymbolResult;
- TypeResult*= OBJECT(SymbolResult)
- VAR
- type-: Modules.TypeDesc;
- address: ADDRESS;
-
- PROCEDURE & InitType(CONST name: ARRAY OF CHAR; CONST t: Modules.TypeDesc);
- BEGIN
- InitSymbol(name);
- type := t;
- END InitType;
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN type.tag;
- END Address;
-
- PROCEDURE Evaluate(): Value;
- BEGIN
- RETURN NIL;
- END Evaluate;
-
- PROCEDURE Constructor*(): ProcedureResult;
- BEGIN
- RETURN FindConstructor(SELF, type);
- END Constructor;
- END TypeResult;
- ModuleResult*= OBJECT(SymbolResult)
- VAR
- self: Modules.TypeDesc;
- mod: Modules.Module;
-
- PROCEDURE & InitModule(CONST name: ARRAY OF CHAR; m: Modules.Module);
- BEGIN
- mod := m;
- InitSymbol(name);
- ASSERT(m # NIL);
- self := FindType(m.typeInfo, "@Self");
- ASSERT(self # NIL);
- END InitModule;
-
- PROCEDURE Find(CONST name: ARRAY OF CHAR): Result;
- VAR num: LONGINT;
- proc: ProcedureResult;
- field: FieldResult;
- type: Modules.TypeDesc;
- typeResult: TypeResult;
- BEGIN
- IF FindProc(self.procedures, name,num) THEN
- NEW(proc, SELF, name, self.procedures[num]);
- proc.address := self.procedures[num].address;
- RETURN proc
- ELSIF FindField(self.fields, name, num) THEN
- NEW(field, name, self.fields[num]);
- field.address := self.fields[num].offset;
- RETURN field;
- ELSE
- type := FindType(mod.typeInfo, name);
- IF type # NIL THEN
- NEW(typeResult, name, type);
- END;
- RETURN typeResult;
- END;
- RETURN NIL;
- END Find;
- END ModuleResult;
-
- Callstack = OBJECT
- VAR
- data: ARRAY 1024 OF CHAR;
- pos: LONGINT;
- size: LONGINT;
- H: HUGEINT; (* result in register *)
-
- retType: Modules.FieldEntry;
- parameters: POINTER TO ARRAY OF Modules.FieldEntry;
- pPos: LONGINT;
-
- PROCEDURE & Init;
- BEGIN
- pos := 1024; size := 0;
- END Init;
-
- PROCEDURE Next(s: SIZE): ADDRESS;
- BEGIN
- DEC(pos, s); INC(size, s);
- RETURN ADDRESSOF(data[pos]);
- END Next;
-
- PROCEDURE PushH(h: HUGEINT);
- VAR p: POINTER {UNSAFE} TO RECORD h: HUGEINT END;
- BEGIN
- p := Next(SIZEOF(HUGEINT));
- p.h := h;
- END PushH;
- PROCEDURE PushL(i: LONGINT);
- VAR p: POINTER {UNSAFE} TO RECORD i: LONGINT END;
- BEGIN
- p := Next(SIZEOF(LONGINT));
- p.i := i;
- END PushL;
- PROCEDURE PushI(i: INTEGER);
- BEGIN
- PushL(i);
- END PushI;
- PROCEDURE PushS(i: SHORTINT);
- BEGIN
- PushL(i);
- END PushS;
-
- PROCEDURE PushB(b: BOOLEAN);
- VAR p: POINTER {UNSAFE} TO RECORD b: BOOLEAN END;
- BEGIN
- p := Next(SIZEOF(LONGINT));
- p.b := b;
- END PushB;
-
- PROCEDURE PushC(c: CHAR);
- BEGIN
- PushL(ORD(c));
- END PushC;
-
- PROCEDURE PushSet(set: SET);
- VAR p: POINTER {UNSAFE} TO RECORD s:SET END;
- BEGIN
- p := Next(SIZEOF(SET));
- p.s := set;
- END PushSet;
- PROCEDURE PushR(r: REAL);
- VAR p: POINTER {UNSAFE} TO RECORD r: REAL END;
- BEGIN
- p := Next(SIZEOF(REAL));
- p.r := r;
- END PushR;
-
- PROCEDURE PushX(x: LONGREAL);
- VAR p: POINTER {UNSAFE} TO RECORD x: LONGREAL END;
- BEGIN
- p := Next(SIZEOF(LONGREAL));
- p.x := x;
- END PushX;
-
- PROCEDURE PushA(a: ADDRESS);
- VAR p: POINTER {UNSAFE} TO RECORD a: ADDRESS END;
- BEGIN
- p := Next(SIZEOF(ADDRESS));
- p.a := a;
- END PushA;
- PROCEDURE PushSz(s: SIZE);
- VAR p: POINTER {UNSAFE} TO RECORD s: SIZE END;
- BEGIN
- p := Next(SIZEOF(SIZE));
- p.s := s;
- END PushSz;
-
- PROCEDURE Call(adr: ADDRESS);
- TYPE
- P = PROCEDURE();
- VAR
- esp: ADDRESS;
- p: P;
- BEGIN
- p := SYSTEM.VAL(P, adr);
- esp := Machine.CurrentSP();
- Machine.SetSP(esp-size);
- IF size > 0 THEN
- SYSTEM.MOVE(ADDRESS OF data[pos], esp-size, size);
- END;
- p();
- Machine.SetSP(esp);
- END Call;
- PROCEDURE CallH(adr: ADDRESS): HUGEINT;
- TYPE
- P = PROCEDURE(): HUGEINT;
- VAR
- res: HUGEINT; esp: ADDRESS;
- p: P;
- BEGIN
- p := SYSTEM.VAL(P, adr);
- esp := Machine.CurrentSP();
- Machine.SetSP(esp-size);
- IF size > 0 THEN
- SYSTEM.MOVE(ADDRESS OF data[pos], esp-size, size);
- END;
- res := p();
- Machine.SetSP(esp);
- RETURN res;
- END CallH;
- PROCEDURE CallR(adr: ADDRESS): REAL;
- TYPE
- P = PROCEDURE(): REAL;
- VAR
- res: REAL; esp: ADDRESS;
- p: P;
- BEGIN
- p := SYSTEM.VAL(P, adr);
- esp := Machine.CurrentSP();
- Machine.SetSP(esp-size);
- IF size > 0 THEN
- SYSTEM.MOVE(ADDRESS OF data[pos], esp-size, size);
- END;
- res := p();
- Machine.SetSP(esp);
- RETURN res;
- END CallR;
- PROCEDURE CallX(adr: ADDRESS): LONGREAL;
- TYPE
- P = PROCEDURE(): LONGREAL;
- VAR
- res: LONGREAL; esp: ADDRESS;
- p: P;
- BEGIN
- p := SYSTEM.VAL(P, adr);
- esp := Machine.CurrentSP();
- Machine.SetSP(esp-size);
- IF size > 0 THEN
- SYSTEM.MOVE(ADDRESS OF data[pos], esp-size, size);
- END;
- res := p();
- Machine.SetSP(esp);
- RETURN res;
- END CallX;
- END Callstack;
- ProcedureResult*= OBJECT(SymbolResult)
- VAR
- proc: Modules.ProcedureEntry;
- address: ADDRESS;
- stack: Callstack;
- index: LONGINT;
- caller-: Result;
-
- PROCEDURE ReturnsPointer*(): BOOLEAN;
- BEGIN
- CASE proc.returnType.class
- OF sfTypeANY, sfTypeOBJECT, sfTypePointerToRecord: RETURN TRUE
- ELSE RETURN FALSE
- END;
- END ReturnsPointer;
-
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN address;
- END Address;
-
-
- PROCEDURE & InitProcedure(c: Result; CONST name: ARRAY OF CHAR; CONST p: Modules.ProcedureEntry);
- BEGIN
- InitSymbol(name); proc := p;
- caller := c;
- END InitProcedure;
-
- PROCEDURE Pars*();
- BEGIN
- index := 0;
- NEW(stack); (* can optimize this *)
- END Pars;
-
- PROCEDURE PushAddress*(adr: ADDRESS); (* for self pointer *)
- BEGIN
- stack.PushA(adr);
- END PushAddress;
-
- PROCEDURE Push*(o: Result): BOOLEAN;
- VAR type: Modules.EntryType;
- s: SHORTINT; i: INTEGER; l: LONGINT; h: HUGEINT;
- r: REAL; x: LONGREAL;
- b: BOOLEAN;
- set: SET;
- var: BOOLEAN;
- v:Value;
- a: ADDRESS;
- BEGIN
- IF (proc.parameters = NIL) OR (index >= LEN(proc.parameters)) THEN RETURN FALSE END;
- type := proc.parameters[index].type;
- var := 1 IN proc.parameters[index].flags;
- INC(index);
- IF var THEN
- IF type.subclass = 0X THEN
- CASE type.class OF
- sfTypeCHAR .. sfTypePointerToArray:
- (*! check type ! *)
- stack.PushA(o.Address());
- RETURN TRUE;
- ELSE
- RETURN FALSE
- END;
- ELSIF type.subclass = sfTypeOpenArray THEN
- CASE type.class OF
- sfTypeCHAR, sfTypeCHAR8:
- IF o IS StringValue THEN
- stack.PushSz(LEN(o(StringValue).value));
- stack.PushA(ADDRESSOF(o(StringValue).value[0]));
- RETURN TRUE;
- END;
- END;
- END;
- ELSE
- v := o.Evaluate();
- IF v = NIL THEN RETURN FALSE END;
- WITH v: Value DO
- IF type.subclass = 0X THEN
- CASE type.class OF
- sfTypeSHORTINT,sfTypeSIGNED8 :
- IF v.GetInt(h) THEN
- s:= SHORTINT(h); stack.PushS(s);
- RETURN TRUE;
- END;
- | sfTypeINTEGER,sfTypeSIGNED16 :
- IF v.GetInt(h) THEN
- i:= INTEGER(h); stack.PushI(i);
- RETURN TRUE;
- END;
- | sfTypeLONGINT,sfTypeSIGNED32:
- IF v.GetInt(h) THEN
- l:= LONGINT(h); stack.PushL(l);
- RETURN TRUE;
- END;
- | sfTypeHUGEINT,sfTypeSIGNED64:
- IF v.GetInt(h) THEN
- stack.PushH(h);
- RETURN TRUE;
- END;
- |sfTypeREAL:
- IF v.GetReal(x) THEN
- r := REAL(x);stack.PushR(r);
- RETURN TRUE;
- END;
- |sfTypeLONGREAL:
- IF v.GetReal(x) THEN
- stack.PushX(x);
- RETURN TRUE;
- END;
- |sfTypeBOOLEAN:
- IF v.GetBoolean(b) THEN
- stack.PushB(b);
- RETURN TRUE
- END;
- |sfTypeSET:
- IF v.GetSet(set) THEN
- stack.PushSet(set);
- RETURN TRUE
- END;
- |sfTypePointerToRecord:
- IF v.GetAddress(a) THEN
- stack.PushA(a);
- RETURN TRUE
- END;
- ELSE TRACE(ORD(type.class)); HALT(100);
- END;
- ELSIF type.subclass = sfTypeOpenArray THEN
- CASE type.class OF
- sfTypeCHAR, sfTypeCHAR8:
- IF v IS StringValue THEN
- stack.PushSz(LEN(v(StringValue).value));
- stack.PushA(ADDRESSOF(v(StringValue).value[0]));
- RETURN TRUE;
- END;
- END;
- END;
- END;
- END;
- RETURN FALSE;
- END Push;
-
- PROCEDURE Check*(): BOOLEAN;
- BEGIN
- RETURN (proc.parameters = NIL) & (index = 0) OR (index = LEN(proc.parameters));
- END Check;
- PROCEDURE Evaluate(): Value;
- VAR
- type: Modules.EntryType;
- int: IntegerValue;
- real: RealValue;
- bool: BooleanValue;
- set: SetValue;
- any: AnyValue;
- BEGIN
- type := proc.returnType;
- CASE type.class OF
- sfTypeSHORTINT,sfTypeSIGNED8 :
- NEW(int, SHORTINT(stack.CallH(address)));
- RETURN int;
- | sfTypeINTEGER,sfTypeSIGNED16 :
- NEW(int, INTEGER(stack.CallH(address)));
- RETURN int;
- | sfTypeLONGINT,sfTypeSIGNED32:
- NEW(int, LONGINT(stack.CallH(address)));
- RETURN int;
- | sfTypeHUGEINT,sfTypeSIGNED64:
- NEW(int, stack.CallH(address));
- RETURN int;
- |sfTypeREAL:
- NEW(real, stack.CallR(address));
- RETURN real
- |sfTypeLONGREAL:
- NEW(real, stack.CallX(address));
- RETURN real;
- |sfTypeBOOLEAN:
- NEW(bool, SYSTEM.VAL(BOOLEAN, stack.CallH(address)));
- RETURN bool;
- |sfTypeSET:
- NEW(set, SYSTEM.VAL(SET, stack.CallH(address)));
- RETURN set;
- | sfTypeANY, sfTypeOBJECT, sfTypePointerToRecord: (* pointers are passed as varpars *)
- stack.Call(address);
- RETURN NIL;
- | 0X:
- stack.Call(address);
- RETURN NIL;
- END;
- RETURN NIL;
- END Evaluate;
- END ProcedureResult;
- FieldResult* = OBJECT (SymbolResult)
- VAR field: Modules.FieldEntry;
- address: ADDRESS;
-
- PROCEDURE & InitField(CONST name: ARRAY OF CHAR; CONST f: Modules.FieldEntry);
- BEGIN
- InitSymbol(name); field := f;
- END InitField;
-
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN address;
- END Address;
- PROCEDURE Evaluate(): Value;
- VAR
- s: SHORTINT;
- i: INTEGER;
- l: LONGINT;
- h: HUGEINT;
-
- int: IntegerValue;
- a: ANY;
- any: AnyValue;
- BEGIN
- CASE field.type.class OF
- sfTypeSHORTINT,sfTypeSIGNED8 :
- SYSTEM.GET(address, s);
- NEW(int, s);
- RETURN int;
- | sfTypeINTEGER,sfTypeSIGNED16 :
- SYSTEM.GET(address, i);
- NEW(int, i);
- RETURN int;
- | sfTypeLONGINT,sfTypeSIGNED32:
- SYSTEM.GET(address, l);
- NEW(int, l);
- RETURN int;
- | sfTypeHUGEINT,sfTypeSIGNED64:
- SYSTEM.GET(address, h);
- NEW(int,LONGINT(h));
- RETURN int;
- | sfTypePointerToRecord, sfTypeANY, sfTypeOBJECT:
- SYSTEM.GET(address, a);
- NEW(any, a);
- RETURN any;
- ELSE
- HALT(100);
- END;
- END Evaluate;
-
- PROCEDURE SetV(v: Value): BOOLEAN;
- VAR
- s: SHORTINT; i: INTEGER; l: LONGINT; h: HUGEINT;
- r: REAL; x: LONGREAL;
- b: BOOLEAN;
- set: SET;
- BEGIN
- CASE field.type.class OF
- sfTypeSHORTINT, sfTypeSIGNED8:
- IF v.GetInt(h) THEN
- s:= SHORTINT(h); SYSTEM.PUT(address, s);
- RETURN TRUE;
- END;
- |sfTypeINTEGER, sfTypeSIGNED16:
- IF v.GetInt(h) THEN
- i:= INTEGER(h); SYSTEM.PUT(address, i);
- RETURN TRUE;
- END;
- |sfTypeLONGINT, sfTypeSIGNED32:
- IF v.GetInt(h) THEN
- l:= LONGINT(h); SYSTEM.PUT(address, l);
- RETURN TRUE;
- END;
- |sfTypeHUGEINT, sfTypeSIGNED64:
- IF v.GetInt(h) THEN
- SYSTEM.PUT(address, h);
- RETURN TRUE
- END;
- |sfTypeREAL:
- IF v.GetReal(x) THEN
- r := REAL(x); SYSTEM.PUT(address, r);
- RETURN TRUE
- END;
- |sfTypeLONGREAL:
- IF v.GetReal(x) THEN
- SYSTEM.PUT(address,x);
- RETURN TRUE
- END;
- |sfTypeBOOLEAN:
- IF v.GetBoolean(b) THEN
- SYSTEM.PUT(address,b);
- RETURN TRUE
- END;
- |sfTypeSET:
- IF v.GetSet(set) THEN
- SYSTEM.PUT(address,set);
- RETURN TRUE
- END;
- END;
- END SetV;
- PROCEDURE Find(CONST name: ARRAY OF CHAR): Result;
- VAR type, value: ADDRESS;
- VAR typeInfo: Modules.TypeDesc; num: LONGINT;
- proc: ProcedureResult; f: FieldResult;
- BEGIN
- IF (field.type.class = sfTypePointerToRecord)
- OR (field.type.class = sfTypeANY)
- OR (field.type.class = sfTypeOBJECT)
- THEN
- SYSTEM.GET(address, value);
- SYSTEM.GET(value-SIZEOF(ADDRESS), type); (* type desc *)
- RETURN FindInType(SELF, value, type, name);
- (*
- SYSTEM.GET(type-SIZEOF(ADDRESS), typeInfo); (* type info*)
- IF FindProc(typeInfo.procedures, name,num) THEN
- NEW(proc, SELF, name, typeInfo.procedures[num]);
- proc.address := typeInfo.procedures[num].address;
- RETURN proc
- ELSIF FindField(typeInfo.fields, name, num) THEN
- NEW(f, name, typeInfo.fields[num]);
- f.address := value + typeInfo.fields[num].offset;
- RETURN f;
- ELSE HALT(101);
- END;
- *)
- ELSIF field.type.class = sfTypeRecord THEN
- type := field.type.type;
- RETURN FindInType(SELF, address, type, name);
- (*
- SYSTEM.GET(type-SIZEOF(ADDRESS), typeInfo); (* type info*)
- IF FindProc(typeInfo.procedures, name,num) THEN
- NEW(proc, SELF, name, typeInfo.procedures[num]);
- proc.address := typeInfo.procedures[num].address;
- RETURN proc
- ELSIF FindField(typeInfo.fields, name, num) THEN
- NEW(f, name, typeInfo.fields[num]);
- f.address := address + typeInfo.fields[num].offset;
- RETURN f;
- ELSE HALT(101);
- END;
- *)
- ELSE HALT(100);
- END;
- END Find;
-
- END FieldResult;
- (* traverse types and supertypes for first occurence of symbol name *)
- PROCEDURE FindInType(scope: Result; address: ADDRESS; type: ADDRESS; CONST name: ARRAY OF CHAR): Result;
- VAR tag: ADDRESS; typeInfo: Modules.TypeDesc; i, num: LONGINT;
- proc: ProcedureResult; f: FieldResult;
- BEGIN
- FOR i := 15 TO 0 BY -1 DO
- SYSTEM.GET(type-(2+i)*SIZEOF(ADDRESS), tag);
- IF tag # NIL THEN
- SYSTEM.GET(tag-SIZEOF(ADDRESS), typeInfo);
- IF FindProc(typeInfo.procedures, name,num) THEN
- NEW(proc, scope, name, typeInfo.procedures[num]);
- proc.address := typeInfo.procedures[num].address;
- RETURN proc
- ELSIF FindField(typeInfo.fields, name, num) THEN
- NEW(f, name, typeInfo.fields[num]);
- f.address := address + typeInfo.fields[num].offset;
- RETURN f;
- END;
- END;
- END;
- RETURN NIL;
- END FindInType;
-
- PROCEDURE FindConstructor(scope: Result; type: ADDRESS): ProcedureResult;
- VAR tag: ADDRESS; typeInfo: Modules.TypeDesc; i, num: LONGINT;
- proc: ProcedureResult; f: FieldResult;
- BEGIN
- FOR i := 15 TO 0 BY -1 DO
- SYSTEM.GET(type-(2+i)*SIZEOF(ADDRESS), tag);
- IF tag # NIL THEN
- SYSTEM.GET(tag-SIZEOF(ADDRESS), typeInfo);
- FOR num := 0 TO LEN(typeInfo.procedures)-1 DO
- IF SyntaxTree.FlagProcedureConstructor IN typeInfo.procedures[num].flags THEN
- NEW(proc, scope, typeInfo.procedures[num].name^, typeInfo.procedures[num]);
- proc.address := typeInfo.procedures[num].address;
- RETURN proc
- END;
- END;
- END;
- END;
- RETURN NIL;
- END FindConstructor;
-
- TYPE
- Value*= OBJECT(Result)
- PROCEDURE & InitValue;
- BEGIN InitObject
- END InitValue;
- PROCEDURE Evaluate(): Value;
- BEGIN
- RETURN SELF;
- END Evaluate;
-
- PROCEDURE GetInt*(VAR h: HUGEINT): BOOLEAN;
- BEGIN
- RETURN FALSE;
- END GetInt;
- PROCEDURE GetAddress*(VAR a: ADDRESS): BOOLEAN;
- BEGIN
- RETURN FALSE;
- END GetAddress;
-
- PROCEDURE GetReal*(VAR x: LONGREAL): BOOLEAN;
- BEGIN
- RETURN FALSE;
- END GetReal;
- PROCEDURE GetBoolean*(VAR x: BOOLEAN): BOOLEAN;
- BEGIN
- RETURN FALSE;
- END GetBoolean;
- PROCEDURE GetSet*(VAR x: SET): BOOLEAN;
- BEGIN
- RETURN FALSE;
- END GetSet;
- PROCEDURE GetChar*(VAR x: CHAR): BOOLEAN;
- BEGIN
- RETURN FALSE;
- END GetChar;
- PROCEDURE GetRange*(VAR x: RANGE): BOOLEAN;
- BEGIN
- RETURN FALSE;
- END GetRange;
- PROCEDURE WriteValue*(w: Streams.Writer);
- BEGIN
- END WriteValue;
- PROCEDURE GetString*(VAR w: ARRAY OF CHAR);
- VAR stringWriter: Streams.StringWriter;
- BEGIN
- NEW(stringWriter, 128);
- WriteValue(stringWriter); stringWriter.Update;
- stringWriter.Get(w);
- END GetString;
- END Value;
- CONST StrValue="value";
- TYPE
- AnyValue*=OBJECT(Value)
- VAR value*:ANY;
- PROCEDURE & InitAny*(value: ANY);
- BEGIN InitValue; SELF.value := value; type := "AnyValue";
- END InitAny;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE GetAddress(VAR a: ADDRESS): BOOLEAN;
- BEGIN
- a := value; RETURN TRUE;
- END GetAddress;
- PROCEDURE WriteValue(w: Streams.Writer);
- BEGIN w.Address(value);
- END WriteValue;
-
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN ADDRESSOF(value)
- END Address;
-
- PROCEDURE Find(CONST name: ARRAY OF CHAR): Result;
- VAR type, v, address: ADDRESS;
- VAR typeInfo: Modules.TypeDesc; num: LONGINT;
- proc: ProcedureResult; f: FieldResult;
- BEGIN
- IF value # NIL THEN
- address := value;
- SYSTEM.GET(address-SIZEOF(ADDRESS), type); (* type desc *)
- RETURN FindInType(SELF, address, type, name);
- (*
- SYSTEM.GET(type-SIZEOF(ADDRESS), typeInfo); (* type info*)
- IF FindProc(typeInfo.procedures, name,num) THEN
- NEW(proc, SELF, name, typeInfo.procedures[num]);
- proc.address := typeInfo.procedures[num].address;
- RETURN proc
- ELSIF FindField(typeInfo.fields, name, num) THEN
- NEW(f, name, typeInfo.fields[num]);
- f.address := address + typeInfo.fields[num].offset;
- RETURN f;
- ELSE HALT(101);
- END;
- *)
- ELSE
- RETURN NIL;
- END;
- END Find;
- END AnyValue;
- AddressValue*=OBJECT(Value)
- VAR value*:ADDRESS;
- PROCEDURE & InitAny*(value: ADDRESS);
- BEGIN InitValue; SELF.value := value; type := "AnyValue";
- END InitAny;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- VAR int: LONGINT;
- BEGIN
- IF name = StrValue THEN c.GetInteger(int); value := int;
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetInteger(value);
- ELSE Get^(name, index, c);
- END;
- END Get;
- PROCEDURE GetAddress(VAR a: ADDRESS): BOOLEAN;
- BEGIN
- a := value; RETURN TRUE;
- END GetAddress;
- PROCEDURE WriteValue(w: Streams.Writer);
- BEGIN w.Address(value);
- END WriteValue;
-
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN ADDRESSOF(value)
- END Address;
-
- END AddressValue;
- IntegerValue*=OBJECT(Value)
- VAR value*: HUGEINT;
- PROCEDURE & InitInteger*(value: HUGEINT);
- BEGIN InitValue; SELF.value := value; type := "IntegerValue";
- END InitInteger;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- VAR val: LONGINT;
- BEGIN
- IF name = StrValue THEN c.GetInteger(val); value := val;
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetInteger(LONGINT(value));
- ELSE Get^(name, index, c);
- END;
- END Get;
-
- PROCEDURE GetInt(VAR v: HUGEINT): BOOLEAN;
- BEGIN
- v := value; RETURN TRUE;
- END GetInt;
- PROCEDURE GetReal(VAR x: LONGREAL): BOOLEAN;
- BEGIN
- x := value; RETURN TRUE;
- END GetReal;
- PROCEDURE WriteValue(w: Streams.Writer);
- BEGIN w.Int(value,0);
- END WriteValue;
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN ADDRESSOF(value)
- END Address;
- END IntegerValue;
- RealValue*=OBJECT(Value)
- VAR value*: LONGREAL;
- PROCEDURE & InitReal*(value: LONGREAL);
- BEGIN InitValue; SELF.value := value; type := "RealValue";
- END InitReal;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.GetFloat(value);
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetFloat(value);
- ELSE Get^(name, index, c);
- END;
- END Get;
-
- PROCEDURE GetReal(VAR x: LONGREAL): BOOLEAN;
- BEGIN
- x := value; RETURN TRUE;
- END GetReal;
-
- PROCEDURE WriteValue(w: Streams.Writer);
- BEGIN w.Float(value,40);
- END WriteValue;
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN ADDRESSOF(value)
- END Address;
- END RealValue;
- BooleanValue*=OBJECT(Value)
- VAR value*: BOOLEAN;
- PROCEDURE & InitBoolean*(value: BOOLEAN);
- BEGIN InitValue; SELF.value := value; type := "BooleanValue";
- END InitBoolean;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.GetBoolean(value);
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetBoolean(value);
- ELSE Get^(name, index, c);
- END;
- END Get;
- PROCEDURE GetBoolean(VAR x: BOOLEAN): BOOLEAN;
- BEGIN
- x := value; RETURN TRUE;
- END GetBoolean;
- PROCEDURE WriteValue(w: Streams.Writer);
- BEGIN IF value THEN w.String("TRUE") ELSE w.String("FALSE") END
- END WriteValue;
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN ADDRESSOF(value)
- END Address;
- END BooleanValue;
- StringValue*=OBJECT(Value)
- VAR value*: Strings.String;
- PROCEDURE & InitString*(CONST value: ARRAY OF CHAR);
- BEGIN InitValue; SELF.value := Strings.NewString(value); type := "StringValue";
- END InitString;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.GetString(value);
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetString(value);
- ELSE Get^(name, index, c);
- END;
- END Get;
- PROCEDURE WriteValue(w: Streams.Writer);
- BEGIN (*w.String('"');*) w.String(value^); (*w.String('"');*)
- END WriteValue;
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN value;
- END Address;
- END StringValue;
- SetValue*=OBJECT(Value)
- VAR value*: SET;
- PROCEDURE & InitSet*(value: SET);
- BEGIN InitValue; SELF.value := value; type := "SetValue"
- END InitSet;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.GetSet(value);
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetSet(value);
- ELSE Get^(name, index, c);
- END;
- END Get;
-
- PROCEDURE GetSet(VAR x: SET): BOOLEAN;
- BEGIN
- x:= value; RETURN TRUE;
- END GetSet;
- PROCEDURE WriteValue(w: Streams.Writer);
- BEGIN
- w.Set(value)
- END WriteValue;
-
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN ADDRESSOF(value)
- END Address;
- END SetValue;
- RangeValue*=OBJECT(Value)
- VAR value*: RANGE;
- PROCEDURE & InitRange*(r: RANGE);
- BEGIN InitValue; value := r; type := "RangeValue"
- END InitRange;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.GetRange(value);
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetRange(value);
- ELSE Get^(name, index, c);
- END;
- END Get;
- PROCEDURE GetRange(VAR x: RANGE): BOOLEAN;
- BEGIN
- x := value; RETURN TRUE;
- END GetRange;
- PROCEDURE WriteValue(w: Streams.Writer);
- BEGIN
- w.Int(FIRST(value),0); w.String(" .. "); w.Int(LAST(value),0); IF STEP(value) # 1 THEN w.String(" BY "); w.Int(STEP(value),0) END;
- END WriteValue;
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN ADDRESSOF(value)
- END Address;
- END RangeValue;
- CharValue*=OBJECT(Value)
- VAR value: CHAR;
- PROCEDURE & InitChar*(c: CHAR);
- BEGIN InitValue; value := c; type := "CharValue";
- END InitChar;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.GetChar(value);
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetChar(value);
- ELSE Get^(name, index, c);
- END;
- END Get;
-
- PROCEDURE GetChar(VAR c: CHAR): BOOLEAN;
- BEGIN
- c := value; RETURN TRUE;
- END GetChar;
- PROCEDURE WriteValue(w: Streams.Writer);
- BEGIN
- w.Hex(ORD(value),2); w.String("X");
- END WriteValue;
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN ADDRESSOF(value)
- END Address;
- END CharValue;
- EnumValue*=OBJECT(Value)
- VAR value: LONGINT; translation: PersistentObjects.Translation;
- PROCEDURE & InitEnumValue*(trans: PersistentObjects.Translation; v: LONGINT);
- BEGIN InitValue; value := v; translation := trans; type := "EnumValue";
- END InitEnumValue;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.GetEnum(translation, value);
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetEnum(translation, value);
- ELSE Get^(name, index, c);
- END;
- END Get;
- PROCEDURE WriteValue(w: Streams.Writer);
- VAR str: ARRAY 32 OF CHAR;
- BEGIN
- IF translation.Name(value, str) THEN w.String(str) ELSE w.String("unknown") END;
- END WriteValue;
- PROCEDURE Address(): ADDRESS;
- BEGIN
- RETURN ADDRESSOF(value)
- END Address;
- END EnumValue;
- MathArrayValue*=OBJECT(Value)
- VAR values: ARRAY [*] OF Value;
- PROCEDURE &InitMathArrayValue*(len: LONGINT);
- BEGIN
- InitValue;
- NEW(values, len);
- type := "MathArrayValue";
- END InitMathArrayValue;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- BEGIN Enumerate^(enum); enum(StrValue,FALSE);
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN values[index] := ContentGetValue(c)
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF name = StrValue THEN c.SetObject(values[index],"Value");
- ELSE Get^(name, index, c);
- END;
- END Get;
- PROCEDURE SetValue*(at: LONGINT; value: Value);
- BEGIN
- values[at] := value;
- END SetValue;
- PROCEDURE GetValue*(at: LONGINT): Value;
- BEGIN
- RETURN values[at]
- END GetValue;
- PROCEDURE WriteValue*(w: Streams.Writer);
- VAR i: LONGINT; max: LONGINT;
- BEGIN
- w.String("[ ");
- max := LEN(values,0)-1;
- FOR i := 0 TO max DO
- values[i].WriteValue(w);
- IF i < max THEN
- w.String(", ");
- END;
- END;
- w.String("] ");
- END WriteValue;
- END MathArrayValue;
- (* object value represented as ANY wrapped in Value ? *)
- Symbol*= OBJECT
- VAR
- name: StringPool.Index;
- item-: Item;
- PROCEDURE & InitSymbol(name: StringPool.Index; index: LONGINT);
- BEGIN
- SELF.name := name; SELF.item := item;
- END InitSymbol;
- PROCEDURE GetName(VAR name: ARRAY OF CHAR);
- BEGIN
- StringPool.GetString(SELF.name, name);
- END GetName;
- END Symbol;
- Container* = OBJECT (Item)
- VAR
- symbols-: Basic.List;
- lookup-: Basic.HashTableInt;
- (* New scope. Note that it is possible that a scope is registered with an alias *)
- PROCEDURE & InitContainer*;
- BEGIN
- InitObject();
- NEW(lookup, 16); NEW(symbols, 16);
- type := "Container";
- END InitContainer;
- PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
- VAR i: LONGINT; symbol: Symbol; o: ANY; name: ARRAY 256 OF CHAR;
- BEGIN Enumerate^(enum);
- FOR i := 0 TO symbols.Length()-1 DO
- o := symbols.Get(i);
- symbol := o(Symbol);
- symbol.GetName(name);
- enum(name, FALSE);
- END;
- END Enumerate;
- PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- BEGIN
- IF FALSE THEN
- ELSE Set^(name, index, c);
- END;
- END Set;
- PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
- VAR item: Item;
- BEGIN
- item := Find(name);
- IF item # NIL THEN c.SetObject(item,"Item")
- ELSE Get^(name, index, c);
- END;
- END Get;
- PROCEDURE GetItem*(index: LONGINT): Item;
- BEGIN
- RETURN symbols.Get(index)(Symbol).item
- END GetItem;
- (* Enter a symbol with its name *)
- PROCEDURE Enter1*(item: Item; name: StringPool.Index);
- VAR any: ANY; symbol: Symbol;
- BEGIN
- any := lookup.Get(name);
- IF any # NIL THEN
- symbol := any(Symbol)
- ELSE
- NEW(symbol, name, symbols.Length());
- symbols.Add(symbol);
- lookup.Put(symbol.name, symbol);
- END;
- symbol.item := item
- END Enter1;
- (* Enter a symbol with its name *)
- PROCEDURE Enter*(item: Item; CONST name: ARRAY OF CHAR);
- BEGIN
- Enter1(item, StringPool.GetIndex1(name))
- END Enter;
- PROCEDURE Find1*(id: LONGINT): Item;
- VAR any: ANY;
- BEGIN
- any := lookup.Get(id);
- IF any # NIL THEN RETURN any(Symbol).item ELSE RETURN NIL END
- END Find1;
- (* Find a symbol with name *)
- PROCEDURE Find*(CONST name: ARRAY OF CHAR): Item;
- BEGIN
- RETURN Find1(StringPool.GetIndex1(name))
- END Find;
- END Container;
- Scope* = OBJECT
- VAR
- outer-: Scope;
- object-: Object;
- level: LONGINT;
- PROCEDURE & InitScope*(outer: Scope; object: Object);
- BEGIN
- SELF.outer := outer;
- IF outer = NIL THEN level := 0 ELSE level := outer.level + 1 END;
- ASSERT(object # NIL);
- SELF.object := object
- END InitScope;
- PROCEDURE Enter*(object: Object): Scope;
- VAR scope: Scope;
- BEGIN
- NEW(scope, SELF, object);
- RETURN scope
- END Enter;
- PROCEDURE FindObject*(CONST name: ARRAY OF CHAR; index: LONGINT; VAR in: Object): Object;
- VAR object: Object;
- BEGIN
- in := SELF.object;
- object := FindInObject(in, name, index);
- IF (object = NIL) & (outer # NIL) THEN
- object := outer.FindObject(name, index, in)
- END;
- RETURN object
- END FindObject;
- PROCEDURE FindObject1*(name: StringPool.Index; index: LONGINT; VAR in: Object): Object;
- VAR str: ARRAY 256 OF CHAR;
- BEGIN
- StringPool.GetString(name, str);
- RETURN FindObject(str,index, in);
- END FindObject1;
- PROCEDURE Leave*(): Scope;
- BEGIN
- RETURN outer
- END Leave;
- PROCEDURE Dump*(log: Streams.Writer);
- BEGIN
- IF object # NIL THEN object.Dump(log,"scope object") END;
- log.Ln;
- IF outer # NIL THEN outer.Dump(log) END;
- END Dump;
- END Scope;
- PROCEDURE Indent(w: Streams.Writer; level: LONGINT);
- BEGIN
- WHILE level> 0 DO w.Char(TAB); DEC(level) END;
- END Indent;
- PROCEDURE Test*(context: Commands.Context);
- VAR scope, inner: Scope; container: Container; integer: IntegerValue; float: RealValue; string: StringValue;
- BEGIN
- NEW(container);
- container.Enter(integer, "integer");
- container.Enter(float,"float");
- container.Enter(string,"string");
- NEW(scope, NIL, container);
- NEW(container);
- inner := scope.Enter(container);
- scope.Dump(context.out);
- (*scope.Write(context.out);*)
- END Test;
- PROCEDURE ContentGetValue(c: Content): Value;
- VAR o: Object;
- BEGIN
- c.GetObject(o); IF o = NIL THEN RETURN NIL ELSE RETURN o(Value) END;
- END ContentGetValue;
- PROCEDURE NewIntegerValue(value: LONGINT): IntegerValue;
- VAR obj: IntegerValue;
- BEGIN
- NEW(obj, value); RETURN obj
- END NewIntegerValue;
- PROCEDURE NewFloatValue(value: LONGREAL): RealValue;
- VAR obj: RealValue;
- BEGIN
- NEW(obj, value); RETURN obj
- END NewFloatValue;
- PROCEDURE NewBooleanValue(value: BOOLEAN): BooleanValue;
- VAR obj: BooleanValue;
- BEGIN
- NEW(obj, value); RETURN obj
- END NewBooleanValue;
- PROCEDURE NewStringValue(CONST value: ARRAY OF CHAR): StringValue;
- VAR obj: StringValue;
- BEGIN
- NEW(obj, value); RETURN obj
- END NewStringValue;
- PROCEDURE NewNameValue(CONST value: ARRAY OF CHAR): StringValue;
- VAR obj: StringValue;
- BEGIN
- NEW(obj, value); RETURN obj
- END NewNameValue;
- PROCEDURE NewRangeValue(value: RANGE): RangeValue;
- VAR obj: RangeValue;
- BEGIN
- NEW(obj, value); RETURN obj
- END NewRangeValue;
- PROCEDURE NewCharValue(value: CHAR): CharValue;
- VAR obj: CharValue;
- BEGIN
- NEW(obj, value); RETURN obj
- END NewCharValue;
- PROCEDURE NewSetValue(value: SET): SetValue;
- VAR obj: SetValue;
- BEGIN
- NEW(obj, value); RETURN obj
- END NewSetValue;
- PROCEDURE NewEnumValue(translation: PersistentObjects.Translation; value: LONGINT): EnumValue;
- VAR obj: EnumValue;
- BEGIN
- NEW(obj, translation, value);
- END NewEnumValue;
- PROCEDURE FindInObject*(in: Object; CONST name: ARRAY OF CHAR; index: LONGINT): Object;
- VAR content: Content;
- TYPE Class=PersistentObjects.Class;
- BEGIN
- NEW(content);
- in.Get(name, index, content);
- IF content.success THEN
- CASE content.class OF
- |Class.String: RETURN NewStringValue(content.string^);
- |Class.Object: RETURN content.object
- |Class.Name: RETURN NewNameValue(content.name);
- |Class.Boolean: RETURN NewBooleanValue(content.boolean);
- |Class.Integer: RETURN NewIntegerValue(content.integer);
- |Class.Float: RETURN NewFloatValue(content.float);
- |Class.Enum: RETURN NewEnumValue(content.translation,content.integer)
- |Class.Range: RETURN NewRangeValue(content.range)
- |Class.Set: RETURN NewSetValue(content.set)
- |Class.Char: RETURN NewCharValue(content.char)
- END
- END;
- RETURN NIL
- END FindInObject;
- TYPE
- ObjectFilter* = OBJECT
- VAR
- content: Content;
- object: Object;
- found: Container;
- attribute, value: ARRAY 256 OF CHAR;
- PROCEDURE & InitObjectFilter*;
- BEGIN
- NEW(content); NEW(found);
- END InitObjectFilter;
- PROCEDURE AddFiltered(obj: Object);
- BEGIN
- IF obj # NIL THEN
- obj.Get(attribute, -1, content);
- IF content.success & content.Equals(value) THEN
- found.Enter(obj,"any");
- END;
- END;
- END AddFiltered;
- PROCEDURE Enumerate(CONST name: ARRAY OF CHAR; array: BOOLEAN);
- VAR obj: Object; index: LONGINT;
- BEGIN
- object.Get(name,-1, content);
- IF content.success & (content.class = PersistentObjects.Class.Object) THEN
- IF array THEN
- index := 0;
- REPEAT
- object.Get(name, index, content);
- obj := content.object;
- AddFiltered(obj);
- INC(index);
- UNTIL obj = NIL;
- ELSE
- AddFiltered(content.object)
- END;
- END;
- END Enumerate;
- PROCEDURE Filter*(obj: Object; attribute, value: ARRAY OF CHAR): Container;
- BEGIN
- NEW(found);
- object := obj;
- COPY(attribute, SELF.attribute);
- COPY(value, SELF.value);
- obj.Enumerate(Enumerate);
- RETURN found
- END Filter;
- END ObjectFilter;
-
- PROCEDURE FindType(CONST types: POINTER TO ARRAY OF Modules.TypeDesc; CONST name: ARRAY OF CHAR): Modules.TypeDesc;
- VAR i: LONGINT;
- BEGIN
- IF types = NIL THEN RETURN NIL END;
- FOR i := 0 TO LEN(types)-1 DO
- IF types[i].name = name THEN
- RETURN types[i];
- END;
- END;
- RETURN NIL;
- END FindType;
-
- PROCEDURE FindField(CONST types: POINTER TO ARRAY OF Modules.FieldEntry; CONST name: ARRAY OF CHAR; VAR num: LONGINT): BOOLEAN;
- BEGIN
- IF types = NIL THEN RETURN FALSE END;
- FOR num := 0 TO LEN(types)-1 DO
- IF types[num].name^ = name THEN
- RETURN TRUE;
- END;
- END;
- RETURN FALSE;
- END FindField;
- PROCEDURE FindProc(CONST types: POINTER TO ARRAY OF Modules.ProcedureEntry; CONST name: ARRAY OF CHAR; VAR num: LONGINT): BOOLEAN;
- BEGIN
- IF types = NIL THEN RETURN FALSE END;
- FOR num := 0 TO LEN(types)-1 DO
- IF types[num].name^ = name THEN
- RETURN TRUE;
- END;
- END;
- RETURN FALSE;
- END FindProc;
-
- PROCEDURE GetModule*(CONST name: ARRAY OF CHAR): ModuleResult;
- VAR msg: ARRAY 128 OF CHAR; res: LONGINT; mod:ModuleResult; m: Modules.Module;
- BEGIN
- m := Modules.ThisModule(name, res, msg);
- IF m # NIL THEN
- NEW(mod, name, m);
- ELSE
- mod := NIL;
- END;
- RETURN mod;
- END GetModule;
- PROCEDURE FindInObject1*(in: Object; name: StringPool.Index; index: LONGINT): Object;
- VAR str: ARRAY 256 OF CHAR;
- BEGIN
- StringPool.GetString(name, str);
- RETURN FindInObject(in,str,index);
- END FindInObject1;
- END FoxInterpreterSymbols.
- SystemTools.FreeDownTo FoxInterpreterSymbols ~
- FoxInterpreterSymbols.Test ~
|