FoxInterpreterSymbols.Mod 36 KB

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