2
0

FoxInterpreterSymbols.Mod 37 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635
  1. MODULE FoxInterpreterSymbols; (** AUTHOR ""; PURPOSE ""; *)
  2. IMPORT Strings, Basic := FoxBasic, StringPool, Streams, Commands, PersistentObjects, Modules, Machine, SyntaxTree := FoxSyntaxTree, SYSTEM;
  3. CONST
  4. TAB = 09X;
  5. CONST
  6. sfTypeNone = 0X;
  7. sfTypeCHAR = 01X;
  8. sfTypeCHAR8 = 02X;
  9. sfTypeCHAR16 = 03X;
  10. sfTypeCHAR32 = 04X;
  11. sfTypeRANGE = 05X;
  12. sfTypeSHORTINT = 06X;
  13. sfTypeINTEGER = 07X;
  14. sfTypeLONGINT = 08X;
  15. sfTypeHUGEINT = 09X;
  16. sfTypeWORD = 0AX;
  17. sfTypeLONGWORD = 0BX;
  18. sfTypeSIGNED8 = 0CX;
  19. sfTypeSIGNED16 = 0DX;
  20. sfTypeSIGNED32 = 0EX;
  21. sfTypeSIGNED64 = 0FX;
  22. sfTypeUNSIGNED8 = 10X;
  23. sfTypeUNSIGNED16 = 11X;
  24. sfTypeUNSIGNED32 = 12X;
  25. sfTypeUNSIGNED64 = 13X;
  26. sfTypeREAL = 14X;
  27. sfTypeLONGREAL = 15X;
  28. sfTypeCOMPLEX = 16X;
  29. sfTypeLONGCOMPLEX = 17X;
  30. sfTypeBOOLEAN = 18X;
  31. sfTypeSET = 19X;
  32. sfTypeANY = 1AX;
  33. sfTypeOBJECT = 1BX;
  34. sfTypeBYTE = 1CX;
  35. sfTypeADDRESS = 1DX;
  36. sfTypeSIZE = 1EX;
  37. sfTypePointerToRecord = 20X;
  38. sfTypePointerToArray = 21X;
  39. sfTypeOpenArray = 22X;
  40. sfTypeStaticArray = 23X;
  41. sfTypeRecord = 24X;
  42. TYPE
  43. Item*= PersistentObjects.Object;
  44. Object* = PersistentObjects.Object;
  45. Content* = PersistentObjects.Content;
  46. TYPE
  47. Result*= OBJECT (Item)
  48. PROCEDURE Evaluate*(): Value;
  49. BEGIN
  50. RETURN NIL;
  51. END Evaluate;
  52. PROCEDURE SetV*(v: Value): BOOLEAN;
  53. BEGIN
  54. RETURN FALSE;
  55. END SetV;
  56. PROCEDURE Find*(CONST name: ARRAY OF CHAR): Result;
  57. BEGIN
  58. RETURN NIL;
  59. END Find;
  60. PROCEDURE Address*(): ADDRESS;
  61. BEGIN
  62. RETURN NIL;
  63. END Address;
  64. PROCEDURE Trace*;
  65. BEGIN
  66. END Trace;
  67. END Result;
  68. SymbolResult*=OBJECT(Result)
  69. VAR name: ARRAY 32 OF CHAR;
  70. PROCEDURE InitSymbol(CONST n: ARRAY OF CHAR);
  71. BEGIN
  72. COPY(n, name);
  73. END InitSymbol;
  74. END SymbolResult;
  75. TypeResult*= OBJECT(SymbolResult)
  76. VAR
  77. type-: Modules.TypeDesc;
  78. address: ADDRESS;
  79. PROCEDURE & InitType(CONST name: ARRAY OF CHAR; CONST t: Modules.TypeDesc);
  80. BEGIN
  81. InitSymbol(name);
  82. type := t;
  83. END InitType;
  84. PROCEDURE Address(): ADDRESS;
  85. BEGIN
  86. RETURN type.tag;
  87. END Address;
  88. PROCEDURE Evaluate(): Value;
  89. BEGIN
  90. RETURN NIL;
  91. END Evaluate;
  92. PROCEDURE Constructor*(): ProcedureResult;
  93. BEGIN
  94. RETURN FindConstructor(SELF, type);
  95. END Constructor;
  96. END TypeResult;
  97. ModuleResult*= OBJECT(SymbolResult)
  98. VAR
  99. self: Modules.TypeDesc;
  100. mod: Modules.Module;
  101. PROCEDURE & InitModule(CONST name: ARRAY OF CHAR; m: Modules.Module);
  102. BEGIN
  103. mod := m;
  104. InitSymbol(name);
  105. ASSERT(m # NIL);
  106. self := FindType(m.typeInfo, "@Self");
  107. ASSERT(self # NIL);
  108. END InitModule;
  109. PROCEDURE Find(CONST name: ARRAY OF CHAR): Result;
  110. VAR num: LONGINT;
  111. proc: ProcedureResult;
  112. field: FieldResult;
  113. type: Modules.TypeDesc;
  114. typeResult: TypeResult;
  115. BEGIN
  116. IF FindProc(self.procedures, name,num) THEN
  117. NEW(proc, SELF, name, self.procedures[num]);
  118. proc.address := self.procedures[num].address;
  119. RETURN proc
  120. ELSIF FindField(self.fields, name, num) THEN
  121. NEW(field, name, self.fields[num]);
  122. field.address := self.fields[num].offset;
  123. RETURN field;
  124. ELSE
  125. type := FindType(mod.typeInfo, name);
  126. IF type # NIL THEN
  127. NEW(typeResult, name, type);
  128. END;
  129. RETURN typeResult;
  130. END;
  131. RETURN NIL;
  132. END Find;
  133. END ModuleResult;
  134. Callstack = OBJECT
  135. VAR
  136. data: ARRAY 1024 OF CHAR;
  137. pos: LONGINT;
  138. size: LONGINT;
  139. H: HUGEINT; (* result in register *)
  140. retType: Modules.FieldEntry;
  141. parameters: POINTER TO ARRAY OF Modules.FieldEntry;
  142. pPos: LONGINT;
  143. PROCEDURE & Init;
  144. BEGIN
  145. pos := 1024; size := 0;
  146. END Init;
  147. PROCEDURE Next(s: SIZE): ADDRESS;
  148. BEGIN
  149. DEC(pos, s); INC(size, s);
  150. RETURN ADDRESSOF(data[pos]);
  151. END Next;
  152. PROCEDURE PushH(h: HUGEINT);
  153. VAR p: POINTER {UNSAFE} TO RECORD h: HUGEINT END;
  154. BEGIN
  155. p := Next(SIZEOF(HUGEINT));
  156. p.h := h;
  157. END PushH;
  158. PROCEDURE PushL(i: LONGINT);
  159. VAR p: POINTER {UNSAFE} TO RECORD i: LONGINT END;
  160. BEGIN
  161. p := Next(SIZEOF(LONGINT));
  162. p.i := i;
  163. END PushL;
  164. PROCEDURE PushI(i: INTEGER);
  165. BEGIN
  166. PushL(i);
  167. END PushI;
  168. PROCEDURE PushS(i: SHORTINT);
  169. BEGIN
  170. PushL(i);
  171. END PushS;
  172. PROCEDURE PushB(b: BOOLEAN);
  173. VAR p: POINTER {UNSAFE} TO RECORD b: BOOLEAN END;
  174. BEGIN
  175. p := Next(SIZEOF(LONGINT));
  176. p.b := b;
  177. END PushB;
  178. PROCEDURE PushC(c: CHAR);
  179. BEGIN
  180. PushL(ORD(c));
  181. END PushC;
  182. PROCEDURE PushSet(set: SET);
  183. VAR p: POINTER {UNSAFE} TO RECORD s:SET END;
  184. BEGIN
  185. p := Next(SIZEOF(SET));
  186. p.s := set;
  187. END PushSet;
  188. PROCEDURE PushR(r: REAL);
  189. VAR p: POINTER {UNSAFE} TO RECORD r: REAL END;
  190. BEGIN
  191. p := Next(SIZEOF(REAL));
  192. p.r := r;
  193. END PushR;
  194. PROCEDURE PushX(x: LONGREAL);
  195. VAR p: POINTER {UNSAFE} TO RECORD x: LONGREAL END;
  196. BEGIN
  197. p := Next(SIZEOF(LONGREAL));
  198. p.x := x;
  199. END PushX;
  200. PROCEDURE PushA(a: ADDRESS);
  201. VAR p: POINTER {UNSAFE} TO RECORD a: ADDRESS END;
  202. BEGIN
  203. p := Next(SIZEOF(ADDRESS));
  204. p.a := a;
  205. END PushA;
  206. PROCEDURE PushSz(s: SIZE);
  207. VAR p: POINTER {UNSAFE} TO RECORD s: SIZE END;
  208. BEGIN
  209. p := Next(SIZEOF(SIZE));
  210. p.s := s;
  211. END PushSz;
  212. PROCEDURE Call(adr: ADDRESS);
  213. TYPE
  214. P = PROCEDURE();
  215. VAR
  216. esp: ADDRESS;
  217. p: P;
  218. BEGIN
  219. p := SYSTEM.VAL(P, adr);
  220. esp := Machine.CurrentSP();
  221. Machine.SetSP(esp-size);
  222. IF size > 0 THEN
  223. SYSTEM.MOVE(ADDRESS OF data[pos], esp-size, size);
  224. END;
  225. p();
  226. Machine.SetSP(esp);
  227. END Call;
  228. PROCEDURE CallH(adr: ADDRESS): HUGEINT;
  229. TYPE
  230. P = PROCEDURE(): HUGEINT;
  231. VAR
  232. res: HUGEINT; esp: ADDRESS;
  233. p: P;
  234. BEGIN
  235. p := SYSTEM.VAL(P, adr);
  236. esp := Machine.CurrentSP();
  237. Machine.SetSP(esp-size);
  238. IF size > 0 THEN
  239. SYSTEM.MOVE(ADDRESS OF data[pos], esp-size, size);
  240. END;
  241. res := p();
  242. Machine.SetSP(esp);
  243. RETURN res;
  244. END CallH;
  245. PROCEDURE CallR(adr: ADDRESS): REAL;
  246. TYPE
  247. P = PROCEDURE(): REAL;
  248. VAR
  249. res: REAL; esp: ADDRESS;
  250. p: P;
  251. BEGIN
  252. p := SYSTEM.VAL(P, adr);
  253. esp := Machine.CurrentSP();
  254. Machine.SetSP(esp-size);
  255. IF size > 0 THEN
  256. SYSTEM.MOVE(ADDRESS OF data[pos], esp-size, size);
  257. END;
  258. res := p();
  259. Machine.SetSP(esp);
  260. RETURN res;
  261. END CallR;
  262. PROCEDURE CallX(adr: ADDRESS): LONGREAL;
  263. TYPE
  264. P = PROCEDURE(): LONGREAL;
  265. VAR
  266. res: LONGREAL; esp: ADDRESS;
  267. p: P;
  268. BEGIN
  269. p := SYSTEM.VAL(P, adr);
  270. esp := Machine.CurrentSP();
  271. Machine.SetSP(esp-size);
  272. IF size > 0 THEN
  273. SYSTEM.MOVE(ADDRESS OF data[pos], esp-size, size);
  274. END;
  275. res := p();
  276. Machine.SetSP(esp);
  277. RETURN res;
  278. END CallX;
  279. END Callstack;
  280. ProcedureResult*= OBJECT(SymbolResult)
  281. VAR
  282. proc: Modules.ProcedureEntry;
  283. address: ADDRESS;
  284. stack: Callstack;
  285. index: LONGINT;
  286. caller-: Result;
  287. PROCEDURE ReturnsPointer*(): BOOLEAN;
  288. BEGIN
  289. CASE proc.returnType.class
  290. OF sfTypeANY, sfTypeOBJECT, sfTypePointerToRecord: RETURN TRUE
  291. ELSE RETURN FALSE
  292. END;
  293. END ReturnsPointer;
  294. PROCEDURE Address(): ADDRESS;
  295. BEGIN
  296. RETURN address;
  297. END Address;
  298. PROCEDURE & InitProcedure(c: Result; CONST name: ARRAY OF CHAR; CONST p: Modules.ProcedureEntry);
  299. BEGIN
  300. InitSymbol(name); proc := p;
  301. caller := c;
  302. END InitProcedure;
  303. PROCEDURE Pars*();
  304. BEGIN
  305. index := 0;
  306. NEW(stack); (* can optimize this *)
  307. END Pars;
  308. PROCEDURE PushAddress*(adr: ADDRESS); (* for self pointer *)
  309. BEGIN
  310. stack.PushA(adr);
  311. END PushAddress;
  312. PROCEDURE Push*(o: Result): BOOLEAN;
  313. VAR type: Modules.EntryType;
  314. s: SHORTINT; i: INTEGER; l: LONGINT; h: HUGEINT;
  315. r: REAL; x: LONGREAL;
  316. b: BOOLEAN;
  317. set: SET;
  318. var: BOOLEAN;
  319. v:Value;
  320. a: ADDRESS;
  321. BEGIN
  322. IF (proc.parameters = NIL) OR (index >= LEN(proc.parameters)) THEN RETURN FALSE END;
  323. type := proc.parameters[index].type;
  324. var := 1 IN proc.parameters[index].flags;
  325. INC(index);
  326. IF var THEN
  327. IF type.subclass = 0X THEN
  328. CASE type.class OF
  329. sfTypeCHAR .. sfTypePointerToArray:
  330. (*! check type ! *)
  331. stack.PushA(o.Address());
  332. RETURN TRUE;
  333. ELSE
  334. RETURN FALSE
  335. END;
  336. ELSIF type.subclass = sfTypeOpenArray THEN
  337. CASE type.class OF
  338. sfTypeCHAR, sfTypeCHAR8:
  339. IF o IS StringValue THEN
  340. stack.PushSz(LEN(o(StringValue).value));
  341. stack.PushA(ADDRESSOF(o(StringValue).value[0]));
  342. RETURN TRUE;
  343. END;
  344. END;
  345. END;
  346. ELSE
  347. v := o.Evaluate();
  348. IF v = NIL THEN RETURN FALSE END;
  349. WITH v: Value DO
  350. IF type.subclass = 0X THEN
  351. CASE type.class OF
  352. sfTypeSHORTINT,sfTypeSIGNED8 :
  353. IF v.GetInt(h) THEN
  354. s:= SHORTINT(h); stack.PushS(s);
  355. RETURN TRUE;
  356. END;
  357. | sfTypeINTEGER,sfTypeSIGNED16 :
  358. IF v.GetInt(h) THEN
  359. i:= INTEGER(h); stack.PushI(i);
  360. RETURN TRUE;
  361. END;
  362. | sfTypeLONGINT,sfTypeSIGNED32:
  363. IF v.GetInt(h) THEN
  364. l:= LONGINT(h); stack.PushL(l);
  365. RETURN TRUE;
  366. END;
  367. | sfTypeHUGEINT,sfTypeSIGNED64:
  368. IF v.GetInt(h) THEN
  369. stack.PushH(h);
  370. RETURN TRUE;
  371. END;
  372. |sfTypeREAL:
  373. IF v.GetReal(x) THEN
  374. r := REAL(x);stack.PushR(r);
  375. RETURN TRUE;
  376. END;
  377. |sfTypeLONGREAL:
  378. IF v.GetReal(x) THEN
  379. stack.PushX(x);
  380. RETURN TRUE;
  381. END;
  382. |sfTypeBOOLEAN:
  383. IF v.GetBoolean(b) THEN
  384. stack.PushB(b);
  385. RETURN TRUE
  386. END;
  387. |sfTypeSET:
  388. IF v.GetSet(set) THEN
  389. stack.PushSet(set);
  390. RETURN TRUE
  391. END;
  392. |sfTypePointerToRecord:
  393. IF v.GetAddress(a) THEN
  394. stack.PushA(a);
  395. RETURN TRUE
  396. END;
  397. ELSE TRACE(ORD(type.class)); HALT(100);
  398. END;
  399. ELSIF type.subclass = sfTypeOpenArray THEN
  400. CASE type.class OF
  401. sfTypeCHAR, sfTypeCHAR8:
  402. IF v IS StringValue THEN
  403. stack.PushSz(LEN(v(StringValue).value));
  404. stack.PushA(ADDRESSOF(v(StringValue).value[0]));
  405. RETURN TRUE;
  406. END;
  407. END;
  408. END;
  409. END;
  410. END;
  411. RETURN FALSE;
  412. END Push;
  413. PROCEDURE Check*(): BOOLEAN;
  414. BEGIN
  415. RETURN (proc.parameters = NIL) & (index = 0) OR (index = LEN(proc.parameters));
  416. END Check;
  417. PROCEDURE Evaluate(): Value;
  418. VAR
  419. type: Modules.EntryType;
  420. int: IntegerValue;
  421. real: RealValue;
  422. bool: BooleanValue;
  423. set: SetValue;
  424. any: AnyValue;
  425. BEGIN
  426. type := proc.returnType;
  427. CASE type.class OF
  428. sfTypeSHORTINT,sfTypeSIGNED8 :
  429. NEW(int, SHORTINT(stack.CallH(address)));
  430. RETURN int;
  431. | sfTypeINTEGER,sfTypeSIGNED16 :
  432. NEW(int, INTEGER(stack.CallH(address)));
  433. RETURN int;
  434. | sfTypeLONGINT,sfTypeSIGNED32:
  435. NEW(int, LONGINT(stack.CallH(address)));
  436. RETURN int;
  437. | sfTypeHUGEINT,sfTypeSIGNED64:
  438. NEW(int, stack.CallH(address));
  439. RETURN int;
  440. |sfTypeREAL:
  441. NEW(real, stack.CallR(address));
  442. RETURN real
  443. |sfTypeLONGREAL:
  444. NEW(real, stack.CallX(address));
  445. RETURN real;
  446. |sfTypeBOOLEAN:
  447. NEW(bool, SYSTEM.VAL(BOOLEAN, stack.CallH(address)));
  448. RETURN bool;
  449. |sfTypeSET:
  450. NEW(set, SYSTEM.VAL(SET, stack.CallH(address)));
  451. RETURN set;
  452. | sfTypeANY, sfTypeOBJECT, sfTypePointerToRecord: (* pointers are passed as varpars *)
  453. stack.Call(address);
  454. RETURN NIL;
  455. | 0X:
  456. stack.Call(address);
  457. RETURN NIL;
  458. END;
  459. RETURN NIL;
  460. END Evaluate;
  461. END ProcedureResult;
  462. FieldResult* = OBJECT (SymbolResult)
  463. VAR field: Modules.FieldEntry;
  464. address: ADDRESS;
  465. PROCEDURE & InitField(CONST name: ARRAY OF CHAR; CONST f: Modules.FieldEntry);
  466. BEGIN
  467. InitSymbol(name); field := f;
  468. END InitField;
  469. PROCEDURE Address(): ADDRESS;
  470. BEGIN
  471. RETURN address;
  472. END Address;
  473. PROCEDURE Evaluate(): Value;
  474. VAR
  475. s: SHORTINT;
  476. i: INTEGER;
  477. l: LONGINT;
  478. h: HUGEINT;
  479. int: IntegerValue;
  480. a: ANY;
  481. any: AnyValue;
  482. BEGIN
  483. CASE field.type.class OF
  484. sfTypeSHORTINT,sfTypeSIGNED8 :
  485. SYSTEM.GET(address, s);
  486. NEW(int, s);
  487. RETURN int;
  488. | sfTypeINTEGER,sfTypeSIGNED16 :
  489. SYSTEM.GET(address, i);
  490. NEW(int, i);
  491. RETURN int;
  492. | sfTypeLONGINT,sfTypeSIGNED32:
  493. SYSTEM.GET(address, l);
  494. NEW(int, l);
  495. RETURN int;
  496. | sfTypeHUGEINT,sfTypeSIGNED64:
  497. SYSTEM.GET(address, h);
  498. NEW(int,LONGINT(h));
  499. RETURN int;
  500. | sfTypePointerToRecord, sfTypeANY, sfTypeOBJECT:
  501. SYSTEM.GET(address, a);
  502. NEW(any, a);
  503. RETURN any;
  504. ELSE
  505. HALT(100);
  506. END;
  507. END Evaluate;
  508. PROCEDURE SetV(v: Value): BOOLEAN;
  509. VAR
  510. s: SHORTINT; i: INTEGER; l: LONGINT; h: HUGEINT;
  511. r: REAL; x: LONGREAL;
  512. b: BOOLEAN;
  513. set: SET;
  514. BEGIN
  515. CASE field.type.class OF
  516. sfTypeSHORTINT, sfTypeSIGNED8:
  517. IF v.GetInt(h) THEN
  518. s:= SHORTINT(h); SYSTEM.PUT(address, s);
  519. RETURN TRUE;
  520. END;
  521. |sfTypeINTEGER, sfTypeSIGNED16:
  522. IF v.GetInt(h) THEN
  523. i:= INTEGER(h); SYSTEM.PUT(address, i);
  524. RETURN TRUE;
  525. END;
  526. |sfTypeLONGINT, sfTypeSIGNED32:
  527. IF v.GetInt(h) THEN
  528. l:= LONGINT(h); SYSTEM.PUT(address, l);
  529. RETURN TRUE;
  530. END;
  531. |sfTypeHUGEINT, sfTypeSIGNED64:
  532. IF v.GetInt(h) THEN
  533. SYSTEM.PUT(address, h);
  534. RETURN TRUE
  535. END;
  536. |sfTypeREAL:
  537. IF v.GetReal(x) THEN
  538. r := REAL(x); SYSTEM.PUT(address, r);
  539. RETURN TRUE
  540. END;
  541. |sfTypeLONGREAL:
  542. IF v.GetReal(x) THEN
  543. SYSTEM.PUT(address,x);
  544. RETURN TRUE
  545. END;
  546. |sfTypeBOOLEAN:
  547. IF v.GetBoolean(b) THEN
  548. SYSTEM.PUT(address,b);
  549. RETURN TRUE
  550. END;
  551. |sfTypeSET:
  552. IF v.GetSet(set) THEN
  553. SYSTEM.PUT(address,set);
  554. RETURN TRUE
  555. END;
  556. END;
  557. END SetV;
  558. PROCEDURE Find(CONST name: ARRAY OF CHAR): Result;
  559. VAR type, value: ADDRESS;
  560. VAR typeInfo: Modules.TypeDesc; num: LONGINT;
  561. proc: ProcedureResult; f: FieldResult;
  562. BEGIN
  563. IF (field.type.class = sfTypePointerToRecord)
  564. OR (field.type.class = sfTypeANY)
  565. OR (field.type.class = sfTypeOBJECT)
  566. THEN
  567. SYSTEM.GET(address, value);
  568. SYSTEM.GET(value-SIZEOF(ADDRESS), type); (* type desc *)
  569. RETURN FindInType(SELF, value, type, name);
  570. (*
  571. SYSTEM.GET(type-SIZEOF(ADDRESS), typeInfo); (* type info*)
  572. IF FindProc(typeInfo.procedures, name,num) THEN
  573. NEW(proc, SELF, name, typeInfo.procedures[num]);
  574. proc.address := typeInfo.procedures[num].address;
  575. RETURN proc
  576. ELSIF FindField(typeInfo.fields, name, num) THEN
  577. NEW(f, name, typeInfo.fields[num]);
  578. f.address := value + typeInfo.fields[num].offset;
  579. RETURN f;
  580. ELSE HALT(101);
  581. END;
  582. *)
  583. ELSIF field.type.class = sfTypeRecord THEN
  584. type := field.type.type;
  585. RETURN FindInType(SELF, address, type, name);
  586. (*
  587. SYSTEM.GET(type-SIZEOF(ADDRESS), typeInfo); (* type info*)
  588. IF FindProc(typeInfo.procedures, name,num) THEN
  589. NEW(proc, SELF, name, typeInfo.procedures[num]);
  590. proc.address := typeInfo.procedures[num].address;
  591. RETURN proc
  592. ELSIF FindField(typeInfo.fields, name, num) THEN
  593. NEW(f, name, typeInfo.fields[num]);
  594. f.address := address + typeInfo.fields[num].offset;
  595. RETURN f;
  596. ELSE HALT(101);
  597. END;
  598. *)
  599. ELSE HALT(100);
  600. END;
  601. END Find;
  602. END FieldResult;
  603. (* traverse types and supertypes for first occurence of symbol name *)
  604. PROCEDURE FindInType(scope: Result; address: ADDRESS; type: ADDRESS; CONST name: ARRAY OF CHAR): Result;
  605. VAR tag: ADDRESS; typeInfo: Modules.TypeDesc; i, num: LONGINT;
  606. proc: ProcedureResult; f: FieldResult;
  607. BEGIN
  608. FOR i := 15 TO 0 BY -1 DO
  609. SYSTEM.GET(type-(2+i)*SIZEOF(ADDRESS), tag);
  610. IF tag # NIL THEN
  611. SYSTEM.GET(tag-SIZEOF(ADDRESS), typeInfo);
  612. IF FindProc(typeInfo.procedures, name,num) THEN
  613. NEW(proc, scope, name, typeInfo.procedures[num]);
  614. proc.address := typeInfo.procedures[num].address;
  615. RETURN proc
  616. ELSIF FindField(typeInfo.fields, name, num) THEN
  617. NEW(f, name, typeInfo.fields[num]);
  618. f.address := address + typeInfo.fields[num].offset;
  619. RETURN f;
  620. END;
  621. END;
  622. END;
  623. RETURN NIL;
  624. END FindInType;
  625. PROCEDURE FindConstructor(scope: Result; type: ADDRESS): ProcedureResult;
  626. VAR tag: ADDRESS; typeInfo: Modules.TypeDesc; i, num: LONGINT;
  627. proc: ProcedureResult; f: FieldResult;
  628. BEGIN
  629. FOR i := 15 TO 0 BY -1 DO
  630. SYSTEM.GET(type-(2+i)*SIZEOF(ADDRESS), tag);
  631. IF tag # NIL THEN
  632. SYSTEM.GET(tag-SIZEOF(ADDRESS), typeInfo);
  633. FOR num := 0 TO LEN(typeInfo.procedures)-1 DO
  634. IF SyntaxTree.FlagProcedureConstructor IN typeInfo.procedures[num].flags THEN
  635. NEW(proc, scope, typeInfo.procedures[num].name^, typeInfo.procedures[num]);
  636. proc.address := typeInfo.procedures[num].address;
  637. RETURN proc
  638. END;
  639. END;
  640. END;
  641. END;
  642. RETURN NIL;
  643. END FindConstructor;
  644. TYPE
  645. Value*= OBJECT(Result)
  646. PROCEDURE & InitValue;
  647. BEGIN InitObject
  648. END InitValue;
  649. PROCEDURE Evaluate(): Value;
  650. BEGIN
  651. RETURN SELF;
  652. END Evaluate;
  653. PROCEDURE GetInt*(VAR h: HUGEINT): BOOLEAN;
  654. BEGIN
  655. RETURN FALSE;
  656. END GetInt;
  657. PROCEDURE GetAddress*(VAR a: ADDRESS): BOOLEAN;
  658. BEGIN
  659. RETURN FALSE;
  660. END GetAddress;
  661. PROCEDURE GetReal*(VAR x: LONGREAL): BOOLEAN;
  662. BEGIN
  663. RETURN FALSE;
  664. END GetReal;
  665. PROCEDURE GetBoolean*(VAR x: BOOLEAN): BOOLEAN;
  666. BEGIN
  667. RETURN FALSE;
  668. END GetBoolean;
  669. PROCEDURE GetSet*(VAR x: SET): BOOLEAN;
  670. BEGIN
  671. RETURN FALSE;
  672. END GetSet;
  673. PROCEDURE GetChar*(VAR x: CHAR): BOOLEAN;
  674. BEGIN
  675. RETURN FALSE;
  676. END GetChar;
  677. PROCEDURE GetRange*(VAR x: RANGE): BOOLEAN;
  678. BEGIN
  679. RETURN FALSE;
  680. END GetRange;
  681. PROCEDURE WriteValue*(w: Streams.Writer);
  682. BEGIN
  683. END WriteValue;
  684. PROCEDURE GetString*(VAR w: ARRAY OF CHAR);
  685. VAR stringWriter: Streams.StringWriter;
  686. BEGIN
  687. NEW(stringWriter, 128);
  688. WriteValue(stringWriter); stringWriter.Update;
  689. stringWriter.Get(w);
  690. END GetString;
  691. END Value;
  692. CONST StrValue="value";
  693. TYPE
  694. AnyValue*=OBJECT(Value)
  695. VAR value*:ANY;
  696. PROCEDURE & InitAny*(value: ANY);
  697. BEGIN InitValue; SELF.value := value; type := "AnyValue";
  698. END InitAny;
  699. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  700. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  701. END Enumerate;
  702. PROCEDURE GetAddress(VAR a: ADDRESS): BOOLEAN;
  703. BEGIN
  704. a := value; RETURN TRUE;
  705. END GetAddress;
  706. PROCEDURE WriteValue(w: Streams.Writer);
  707. BEGIN w.Address(value);
  708. END WriteValue;
  709. PROCEDURE Address(): ADDRESS;
  710. BEGIN
  711. RETURN ADDRESSOF(value)
  712. END Address;
  713. PROCEDURE Find(CONST name: ARRAY OF CHAR): Result;
  714. VAR type, v, address: ADDRESS;
  715. VAR typeInfo: Modules.TypeDesc; num: LONGINT;
  716. proc: ProcedureResult; f: FieldResult;
  717. BEGIN
  718. IF value # NIL THEN
  719. address := value;
  720. SYSTEM.GET(address-SIZEOF(ADDRESS), type); (* type desc *)
  721. RETURN FindInType(SELF, address, type, name);
  722. (*
  723. SYSTEM.GET(type-SIZEOF(ADDRESS), typeInfo); (* type info*)
  724. IF FindProc(typeInfo.procedures, name,num) THEN
  725. NEW(proc, SELF, name, typeInfo.procedures[num]);
  726. proc.address := typeInfo.procedures[num].address;
  727. RETURN proc
  728. ELSIF FindField(typeInfo.fields, name, num) THEN
  729. NEW(f, name, typeInfo.fields[num]);
  730. f.address := address + typeInfo.fields[num].offset;
  731. RETURN f;
  732. ELSE HALT(101);
  733. END;
  734. *)
  735. ELSE
  736. RETURN NIL;
  737. END;
  738. END Find;
  739. END AnyValue;
  740. AddressValue*=OBJECT(Value)
  741. VAR value*:ADDRESS;
  742. PROCEDURE & InitAny*(value: ADDRESS);
  743. BEGIN InitValue; SELF.value := value; type := "AnyValue";
  744. END InitAny;
  745. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  746. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  747. END Enumerate;
  748. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  749. VAR int: LONGINT;
  750. BEGIN
  751. IF name = StrValue THEN c.GetInteger(int); value := int;
  752. ELSE Set^(name, index, c);
  753. END;
  754. END Set;
  755. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  756. BEGIN
  757. IF name = StrValue THEN c.SetInteger(value);
  758. ELSE Get^(name, index, c);
  759. END;
  760. END Get;
  761. PROCEDURE GetAddress(VAR a: ADDRESS): BOOLEAN;
  762. BEGIN
  763. a := value; RETURN TRUE;
  764. END GetAddress;
  765. PROCEDURE WriteValue(w: Streams.Writer);
  766. BEGIN w.Address(value);
  767. END WriteValue;
  768. PROCEDURE Address(): ADDRESS;
  769. BEGIN
  770. RETURN ADDRESSOF(value)
  771. END Address;
  772. END AddressValue;
  773. IntegerValue*=OBJECT(Value)
  774. VAR value*: HUGEINT;
  775. PROCEDURE & InitInteger*(value: HUGEINT);
  776. BEGIN InitValue; SELF.value := value; type := "IntegerValue";
  777. END InitInteger;
  778. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  779. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  780. END Enumerate;
  781. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  782. VAR val: LONGINT;
  783. BEGIN
  784. IF name = StrValue THEN c.GetInteger(val); value := val;
  785. ELSE Set^(name, index, c);
  786. END;
  787. END Set;
  788. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  789. BEGIN
  790. IF name = StrValue THEN c.SetInteger(LONGINT(value));
  791. ELSE Get^(name, index, c);
  792. END;
  793. END Get;
  794. PROCEDURE GetInt(VAR v: HUGEINT): BOOLEAN;
  795. BEGIN
  796. v := value; RETURN TRUE;
  797. END GetInt;
  798. PROCEDURE GetReal(VAR x: LONGREAL): BOOLEAN;
  799. BEGIN
  800. x := value; RETURN TRUE;
  801. END GetReal;
  802. PROCEDURE WriteValue(w: Streams.Writer);
  803. BEGIN w.Int(value,0);
  804. END WriteValue;
  805. PROCEDURE Address(): ADDRESS;
  806. BEGIN
  807. RETURN ADDRESSOF(value)
  808. END Address;
  809. END IntegerValue;
  810. RealValue*=OBJECT(Value)
  811. VAR value*: LONGREAL;
  812. PROCEDURE & InitReal*(value: LONGREAL);
  813. BEGIN InitValue; SELF.value := value; type := "RealValue";
  814. END InitReal;
  815. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  816. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  817. END Enumerate;
  818. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  819. BEGIN
  820. IF name = StrValue THEN c.GetFloat(value);
  821. ELSE Set^(name, index, c);
  822. END;
  823. END Set;
  824. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  825. BEGIN
  826. IF name = StrValue THEN c.SetFloat(value);
  827. ELSE Get^(name, index, c);
  828. END;
  829. END Get;
  830. PROCEDURE GetReal(VAR x: LONGREAL): BOOLEAN;
  831. BEGIN
  832. x := value; RETURN TRUE;
  833. END GetReal;
  834. PROCEDURE WriteValue(w: Streams.Writer);
  835. BEGIN w.Float(value,40);
  836. END WriteValue;
  837. PROCEDURE Address(): ADDRESS;
  838. BEGIN
  839. RETURN ADDRESSOF(value)
  840. END Address;
  841. END RealValue;
  842. BooleanValue*=OBJECT(Value)
  843. VAR value*: BOOLEAN;
  844. PROCEDURE & InitBoolean*(value: BOOLEAN);
  845. BEGIN InitValue; SELF.value := value; type := "BooleanValue";
  846. END InitBoolean;
  847. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  848. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  849. END Enumerate;
  850. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  851. BEGIN
  852. IF name = StrValue THEN c.GetBoolean(value);
  853. ELSE Set^(name, index, c);
  854. END;
  855. END Set;
  856. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  857. BEGIN
  858. IF name = StrValue THEN c.SetBoolean(value);
  859. ELSE Get^(name, index, c);
  860. END;
  861. END Get;
  862. PROCEDURE GetBoolean(VAR x: BOOLEAN): BOOLEAN;
  863. BEGIN
  864. x := value; RETURN TRUE;
  865. END GetBoolean;
  866. PROCEDURE WriteValue(w: Streams.Writer);
  867. BEGIN IF value THEN w.String("TRUE") ELSE w.String("FALSE") END
  868. END WriteValue;
  869. PROCEDURE Address(): ADDRESS;
  870. BEGIN
  871. RETURN ADDRESSOF(value)
  872. END Address;
  873. END BooleanValue;
  874. StringValue*=OBJECT(Value)
  875. VAR value*: Strings.String;
  876. PROCEDURE & InitString*(CONST value: ARRAY OF CHAR);
  877. BEGIN InitValue; SELF.value := Strings.NewString(value); type := "StringValue";
  878. END InitString;
  879. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  880. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  881. END Enumerate;
  882. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  883. BEGIN
  884. IF name = StrValue THEN c.GetString(value);
  885. ELSE Set^(name, index, c);
  886. END;
  887. END Set;
  888. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  889. BEGIN
  890. IF name = StrValue THEN c.SetString(value);
  891. ELSE Get^(name, index, c);
  892. END;
  893. END Get;
  894. PROCEDURE WriteValue(w: Streams.Writer);
  895. BEGIN (*w.String('"');*) w.String(value^); (*w.String('"');*)
  896. END WriteValue;
  897. PROCEDURE Address(): ADDRESS;
  898. BEGIN
  899. RETURN value;
  900. END Address;
  901. END StringValue;
  902. SetValue*=OBJECT(Value)
  903. VAR value*: SET;
  904. PROCEDURE & InitSet*(value: SET);
  905. BEGIN InitValue; SELF.value := value; type := "SetValue"
  906. END InitSet;
  907. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  908. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  909. END Enumerate;
  910. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  911. BEGIN
  912. IF name = StrValue THEN c.GetSet(value);
  913. ELSE Set^(name, index, c);
  914. END;
  915. END Set;
  916. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  917. BEGIN
  918. IF name = StrValue THEN c.SetSet(value);
  919. ELSE Get^(name, index, c);
  920. END;
  921. END Get;
  922. PROCEDURE GetSet(VAR x: SET): BOOLEAN;
  923. BEGIN
  924. x:= value; RETURN TRUE;
  925. END GetSet;
  926. PROCEDURE WriteValue(w: Streams.Writer);
  927. BEGIN
  928. w.Set(value)
  929. END WriteValue;
  930. PROCEDURE Address(): ADDRESS;
  931. BEGIN
  932. RETURN ADDRESSOF(value)
  933. END Address;
  934. END SetValue;
  935. RangeValue*=OBJECT(Value)
  936. VAR value*: RANGE;
  937. PROCEDURE & InitRange*(r: RANGE);
  938. BEGIN InitValue; value := r; type := "RangeValue"
  939. END InitRange;
  940. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  941. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  942. END Enumerate;
  943. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  944. BEGIN
  945. IF name = StrValue THEN c.GetRange(value);
  946. ELSE Set^(name, index, c);
  947. END;
  948. END Set;
  949. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  950. BEGIN
  951. IF name = StrValue THEN c.SetRange(value);
  952. ELSE Get^(name, index, c);
  953. END;
  954. END Get;
  955. PROCEDURE GetRange(VAR x: RANGE): BOOLEAN;
  956. BEGIN
  957. x := value; RETURN TRUE;
  958. END GetRange;
  959. PROCEDURE WriteValue(w: Streams.Writer);
  960. BEGIN
  961. 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;
  962. END WriteValue;
  963. PROCEDURE Address(): ADDRESS;
  964. BEGIN
  965. RETURN ADDRESSOF(value)
  966. END Address;
  967. END RangeValue;
  968. CharValue*=OBJECT(Value)
  969. VAR value: CHAR;
  970. PROCEDURE & InitChar*(c: CHAR);
  971. BEGIN InitValue; value := c; type := "CharValue";
  972. END InitChar;
  973. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  974. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  975. END Enumerate;
  976. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  977. BEGIN
  978. IF name = StrValue THEN c.GetChar(value);
  979. ELSE Set^(name, index, c);
  980. END;
  981. END Set;
  982. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  983. BEGIN
  984. IF name = StrValue THEN c.SetChar(value);
  985. ELSE Get^(name, index, c);
  986. END;
  987. END Get;
  988. PROCEDURE GetChar(VAR c: CHAR): BOOLEAN;
  989. BEGIN
  990. c := value; RETURN TRUE;
  991. END GetChar;
  992. PROCEDURE WriteValue(w: Streams.Writer);
  993. BEGIN
  994. w.Hex(ORD(value),2); w.String("X");
  995. END WriteValue;
  996. PROCEDURE Address(): ADDRESS;
  997. BEGIN
  998. RETURN ADDRESSOF(value)
  999. END Address;
  1000. END CharValue;
  1001. EnumValue*=OBJECT(Value)
  1002. VAR value: LONGINT; translation: PersistentObjects.Translation;
  1003. PROCEDURE & InitEnumValue*(trans: PersistentObjects.Translation; v: LONGINT);
  1004. BEGIN InitValue; value := v; translation := trans; type := "EnumValue";
  1005. END InitEnumValue;
  1006. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  1007. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  1008. END Enumerate;
  1009. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  1010. BEGIN
  1011. IF name = StrValue THEN c.GetEnum(translation, value);
  1012. ELSE Set^(name, index, c);
  1013. END;
  1014. END Set;
  1015. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  1016. BEGIN
  1017. IF name = StrValue THEN c.SetEnum(translation, value);
  1018. ELSE Get^(name, index, c);
  1019. END;
  1020. END Get;
  1021. PROCEDURE WriteValue(w: Streams.Writer);
  1022. VAR str: ARRAY 32 OF CHAR;
  1023. BEGIN
  1024. IF translation.Name(value, str) THEN w.String(str) ELSE w.String("unknown") END;
  1025. END WriteValue;
  1026. PROCEDURE Address(): ADDRESS;
  1027. BEGIN
  1028. RETURN ADDRESSOF(value)
  1029. END Address;
  1030. END EnumValue;
  1031. MathArrayValue*=OBJECT(Value)
  1032. VAR values: ARRAY [*] OF Value;
  1033. PROCEDURE &InitMathArrayValue*(len: LONGINT);
  1034. BEGIN
  1035. InitValue;
  1036. NEW(values, len);
  1037. type := "MathArrayValue";
  1038. END InitMathArrayValue;
  1039. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  1040. BEGIN Enumerate^(enum); enum(StrValue,FALSE);
  1041. END Enumerate;
  1042. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  1043. BEGIN
  1044. IF name = StrValue THEN values[index] := ContentGetValue(c)
  1045. ELSE Set^(name, index, c);
  1046. END;
  1047. END Set;
  1048. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  1049. BEGIN
  1050. IF name = StrValue THEN c.SetObject(values[index],"Value");
  1051. ELSE Get^(name, index, c);
  1052. END;
  1053. END Get;
  1054. PROCEDURE SetValue*(at: LONGINT; value: Value);
  1055. BEGIN
  1056. values[at] := value;
  1057. END SetValue;
  1058. PROCEDURE GetValue*(at: LONGINT): Value;
  1059. BEGIN
  1060. RETURN values[at]
  1061. END GetValue;
  1062. PROCEDURE WriteValue*(w: Streams.Writer);
  1063. VAR i: LONGINT; max: LONGINT;
  1064. BEGIN
  1065. w.String("[ ");
  1066. max := LEN(values,0)-1;
  1067. FOR i := 0 TO max DO
  1068. values[i].WriteValue(w);
  1069. IF i < max THEN
  1070. w.String(", ");
  1071. END;
  1072. END;
  1073. w.String("] ");
  1074. END WriteValue;
  1075. END MathArrayValue;
  1076. (* object value represented as ANY wrapped in Value ? *)
  1077. Symbol*= OBJECT
  1078. VAR
  1079. name: StringPool.Index;
  1080. item-: Item;
  1081. PROCEDURE & InitSymbol(name: StringPool.Index; index: LONGINT);
  1082. BEGIN
  1083. SELF.name := name; SELF.item := item;
  1084. END InitSymbol;
  1085. PROCEDURE GetName(VAR name: ARRAY OF CHAR);
  1086. BEGIN
  1087. StringPool.GetString(SELF.name, name);
  1088. END GetName;
  1089. END Symbol;
  1090. Container* = OBJECT (Item)
  1091. VAR
  1092. symbols-: Basic.List;
  1093. lookup-: Basic.HashTableInt;
  1094. (* New scope. Note that it is possible that a scope is registered with an alias *)
  1095. PROCEDURE & InitContainer*;
  1096. BEGIN
  1097. InitObject();
  1098. NEW(lookup, 16); NEW(symbols, 16);
  1099. type := "Container";
  1100. END InitContainer;
  1101. PROCEDURE Enumerate(enum: PersistentObjects.Enumerator);
  1102. VAR i: LONGINT; symbol: Symbol; o: ANY; name: ARRAY 256 OF CHAR;
  1103. BEGIN Enumerate^(enum);
  1104. FOR i := 0 TO symbols.Length()-1 DO
  1105. o := symbols.Get(i);
  1106. symbol := o(Symbol);
  1107. symbol.GetName(name);
  1108. enum(name, FALSE);
  1109. END;
  1110. END Enumerate;
  1111. PROCEDURE Set(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  1112. BEGIN
  1113. IF FALSE THEN
  1114. ELSE Set^(name, index, c);
  1115. END;
  1116. END Set;
  1117. PROCEDURE Get(CONST name: ARRAY OF CHAR; index: LONGINT; c: Content);
  1118. VAR item: Item;
  1119. BEGIN
  1120. item := Find(name);
  1121. IF item # NIL THEN c.SetObject(item,"Item")
  1122. ELSE Get^(name, index, c);
  1123. END;
  1124. END Get;
  1125. PROCEDURE GetItem*(index: LONGINT): Item;
  1126. BEGIN
  1127. RETURN symbols.Get(index)(Symbol).item
  1128. END GetItem;
  1129. (* Enter a symbol with its name *)
  1130. PROCEDURE Enter1*(item: Item; name: StringPool.Index);
  1131. VAR any: ANY; symbol: Symbol;
  1132. BEGIN
  1133. any := lookup.Get(name);
  1134. IF any # NIL THEN
  1135. symbol := any(Symbol)
  1136. ELSE
  1137. NEW(symbol, name, symbols.Length());
  1138. symbols.Add(symbol);
  1139. lookup.Put(symbol.name, symbol);
  1140. END;
  1141. symbol.item := item
  1142. END Enter1;
  1143. (* Enter a symbol with its name *)
  1144. PROCEDURE Enter*(item: Item; CONST name: ARRAY OF CHAR);
  1145. BEGIN
  1146. Enter1(item, StringPool.GetIndex1(name))
  1147. END Enter;
  1148. PROCEDURE Find1*(id: LONGINT): Item;
  1149. VAR any: ANY;
  1150. BEGIN
  1151. any := lookup.Get(id);
  1152. IF any # NIL THEN RETURN any(Symbol).item ELSE RETURN NIL END
  1153. END Find1;
  1154. (* Find a symbol with name *)
  1155. PROCEDURE Find*(CONST name: ARRAY OF CHAR): Item;
  1156. BEGIN
  1157. RETURN Find1(StringPool.GetIndex1(name))
  1158. END Find;
  1159. END Container;
  1160. Scope* = OBJECT
  1161. VAR
  1162. outer-: Scope;
  1163. object-: Object;
  1164. level: LONGINT;
  1165. PROCEDURE & InitScope*(outer: Scope; object: Object);
  1166. BEGIN
  1167. SELF.outer := outer;
  1168. IF outer = NIL THEN level := 0 ELSE level := outer.level + 1 END;
  1169. ASSERT(object # NIL);
  1170. SELF.object := object
  1171. END InitScope;
  1172. PROCEDURE Enter*(object: Object): Scope;
  1173. VAR scope: Scope;
  1174. BEGIN
  1175. NEW(scope, SELF, object);
  1176. RETURN scope
  1177. END Enter;
  1178. PROCEDURE FindObject*(CONST name: ARRAY OF CHAR; index: LONGINT; VAR in: Object): Object;
  1179. VAR object: Object;
  1180. BEGIN
  1181. in := SELF.object;
  1182. object := FindInObject(in, name, index);
  1183. IF (object = NIL) & (outer # NIL) THEN
  1184. object := outer.FindObject(name, index, in)
  1185. END;
  1186. RETURN object
  1187. END FindObject;
  1188. PROCEDURE FindObject1*(name: StringPool.Index; index: LONGINT; VAR in: Object): Object;
  1189. VAR str: ARRAY 256 OF CHAR;
  1190. BEGIN
  1191. StringPool.GetString(name, str);
  1192. RETURN FindObject(str,index, in);
  1193. END FindObject1;
  1194. PROCEDURE Leave*(): Scope;
  1195. BEGIN
  1196. RETURN outer
  1197. END Leave;
  1198. PROCEDURE Dump*(log: Streams.Writer);
  1199. BEGIN
  1200. IF object # NIL THEN object.Dump(log,"scope object") END;
  1201. log.Ln;
  1202. IF outer # NIL THEN outer.Dump(log) END;
  1203. END Dump;
  1204. END Scope;
  1205. PROCEDURE Indent(w: Streams.Writer; level: LONGINT);
  1206. BEGIN
  1207. WHILE level> 0 DO w.Char(TAB); DEC(level) END;
  1208. END Indent;
  1209. PROCEDURE Test*(context: Commands.Context);
  1210. VAR scope, inner: Scope; container: Container; integer: IntegerValue; float: RealValue; string: StringValue;
  1211. BEGIN
  1212. NEW(container);
  1213. container.Enter(integer, "integer");
  1214. container.Enter(float,"float");
  1215. container.Enter(string,"string");
  1216. NEW(scope, NIL, container);
  1217. NEW(container);
  1218. inner := scope.Enter(container);
  1219. scope.Dump(context.out);
  1220. (*scope.Write(context.out);*)
  1221. END Test;
  1222. PROCEDURE ContentGetValue(c: Content): Value;
  1223. VAR o: Object;
  1224. BEGIN
  1225. c.GetObject(o); IF o = NIL THEN RETURN NIL ELSE RETURN o(Value) END;
  1226. END ContentGetValue;
  1227. PROCEDURE NewIntegerValue(value: LONGINT): IntegerValue;
  1228. VAR obj: IntegerValue;
  1229. BEGIN
  1230. NEW(obj, value); RETURN obj
  1231. END NewIntegerValue;
  1232. PROCEDURE NewFloatValue(value: LONGREAL): RealValue;
  1233. VAR obj: RealValue;
  1234. BEGIN
  1235. NEW(obj, value); RETURN obj
  1236. END NewFloatValue;
  1237. PROCEDURE NewBooleanValue(value: BOOLEAN): BooleanValue;
  1238. VAR obj: BooleanValue;
  1239. BEGIN
  1240. NEW(obj, value); RETURN obj
  1241. END NewBooleanValue;
  1242. PROCEDURE NewStringValue(CONST value: ARRAY OF CHAR): StringValue;
  1243. VAR obj: StringValue;
  1244. BEGIN
  1245. NEW(obj, value); RETURN obj
  1246. END NewStringValue;
  1247. PROCEDURE NewNameValue(CONST value: ARRAY OF CHAR): StringValue;
  1248. VAR obj: StringValue;
  1249. BEGIN
  1250. NEW(obj, value); RETURN obj
  1251. END NewNameValue;
  1252. PROCEDURE NewRangeValue(value: RANGE): RangeValue;
  1253. VAR obj: RangeValue;
  1254. BEGIN
  1255. NEW(obj, value); RETURN obj
  1256. END NewRangeValue;
  1257. PROCEDURE NewCharValue(value: CHAR): CharValue;
  1258. VAR obj: CharValue;
  1259. BEGIN
  1260. NEW(obj, value); RETURN obj
  1261. END NewCharValue;
  1262. PROCEDURE NewSetValue(value: SET): SetValue;
  1263. VAR obj: SetValue;
  1264. BEGIN
  1265. NEW(obj, value); RETURN obj
  1266. END NewSetValue;
  1267. PROCEDURE NewEnumValue(translation: PersistentObjects.Translation; value: LONGINT): EnumValue;
  1268. VAR obj: EnumValue;
  1269. BEGIN
  1270. NEW(obj, translation, value);
  1271. END NewEnumValue;
  1272. PROCEDURE FindInObject*(in: Object; CONST name: ARRAY OF CHAR; index: LONGINT): Object;
  1273. VAR content: Content;
  1274. TYPE Class=PersistentObjects.Class;
  1275. BEGIN
  1276. NEW(content);
  1277. in.Get(name, index, content);
  1278. IF content.success THEN
  1279. CASE content.class OF
  1280. |Class.String: RETURN NewStringValue(content.string^);
  1281. |Class.Object: RETURN content.object
  1282. |Class.Name: RETURN NewNameValue(content.name);
  1283. |Class.Boolean: RETURN NewBooleanValue(content.boolean);
  1284. |Class.Integer: RETURN NewIntegerValue(content.integer);
  1285. |Class.Float: RETURN NewFloatValue(content.float);
  1286. |Class.Enum: RETURN NewEnumValue(content.translation,content.integer)
  1287. |Class.Range: RETURN NewRangeValue(content.range)
  1288. |Class.Set: RETURN NewSetValue(content.set)
  1289. |Class.Char: RETURN NewCharValue(content.char)
  1290. END
  1291. END;
  1292. RETURN NIL
  1293. END FindInObject;
  1294. TYPE
  1295. ObjectFilter* = OBJECT
  1296. VAR
  1297. content: Content;
  1298. object: Object;
  1299. found: Container;
  1300. attribute, value: ARRAY 256 OF CHAR;
  1301. PROCEDURE & InitObjectFilter*;
  1302. BEGIN
  1303. NEW(content); NEW(found);
  1304. END InitObjectFilter;
  1305. PROCEDURE AddFiltered(obj: Object);
  1306. BEGIN
  1307. IF obj # NIL THEN
  1308. obj.Get(attribute, -1, content);
  1309. IF content.success & content.Equals(value) THEN
  1310. found.Enter(obj,"any");
  1311. END;
  1312. END;
  1313. END AddFiltered;
  1314. PROCEDURE Enumerate(CONST name: ARRAY OF CHAR; array: BOOLEAN);
  1315. VAR obj: Object; index: LONGINT;
  1316. BEGIN
  1317. object.Get(name,-1, content);
  1318. IF content.success & (content.class = PersistentObjects.Class.Object) THEN
  1319. IF array THEN
  1320. index := 0;
  1321. REPEAT
  1322. object.Get(name, index, content);
  1323. obj := content.object;
  1324. AddFiltered(obj);
  1325. INC(index);
  1326. UNTIL obj = NIL;
  1327. ELSE
  1328. AddFiltered(content.object)
  1329. END;
  1330. END;
  1331. END Enumerate;
  1332. PROCEDURE Filter*(obj: Object; attribute, value: ARRAY OF CHAR): Container;
  1333. BEGIN
  1334. NEW(found);
  1335. object := obj;
  1336. COPY(attribute, SELF.attribute);
  1337. COPY(value, SELF.value);
  1338. obj.Enumerate(Enumerate);
  1339. RETURN found
  1340. END Filter;
  1341. END ObjectFilter;
  1342. PROCEDURE FindType(CONST types: POINTER TO ARRAY OF Modules.TypeDesc; CONST name: ARRAY OF CHAR): Modules.TypeDesc;
  1343. VAR i: LONGINT;
  1344. BEGIN
  1345. IF types = NIL THEN RETURN NIL END;
  1346. FOR i := 0 TO LEN(types)-1 DO
  1347. IF types[i].name = name THEN
  1348. RETURN types[i];
  1349. END;
  1350. END;
  1351. RETURN NIL;
  1352. END FindType;
  1353. PROCEDURE FindField(CONST types: POINTER TO ARRAY OF Modules.FieldEntry; CONST name: ARRAY OF CHAR; VAR num: LONGINT): BOOLEAN;
  1354. BEGIN
  1355. IF types = NIL THEN RETURN FALSE END;
  1356. FOR num := 0 TO LEN(types)-1 DO
  1357. IF types[num].name^ = name THEN
  1358. RETURN TRUE;
  1359. END;
  1360. END;
  1361. RETURN FALSE;
  1362. END FindField;
  1363. PROCEDURE FindProc(CONST types: POINTER TO ARRAY OF Modules.ProcedureEntry; CONST name: ARRAY OF CHAR; VAR num: LONGINT): BOOLEAN;
  1364. BEGIN
  1365. IF types = NIL THEN RETURN FALSE END;
  1366. FOR num := 0 TO LEN(types)-1 DO
  1367. IF types[num].name^ = name THEN
  1368. RETURN TRUE;
  1369. END;
  1370. END;
  1371. RETURN FALSE;
  1372. END FindProc;
  1373. PROCEDURE GetModule*(CONST name: ARRAY OF CHAR): ModuleResult;
  1374. VAR msg: ARRAY 128 OF CHAR; res: LONGINT; mod:ModuleResult; m: Modules.Module;
  1375. BEGIN
  1376. m := Modules.ThisModule(name, res, msg);
  1377. IF m # NIL THEN
  1378. NEW(mod, name, m);
  1379. ELSE
  1380. mod := NIL;
  1381. END;
  1382. RETURN mod;
  1383. END GetModule;
  1384. PROCEDURE FindInObject1*(in: Object; name: StringPool.Index; index: LONGINT): Object;
  1385. VAR str: ARRAY 256 OF CHAR;
  1386. BEGIN
  1387. StringPool.GetString(name, str);
  1388. RETURN FindInObject(in,str,index);
  1389. END FindInObject1;
  1390. END FoxInterpreterSymbols.
  1391. SystemTools.FreeDownTo FoxInterpreterSymbols ~
  1392. FoxInterpreterSymbols.Test ~