2
0

FoxInterpreterSymbols.Mod 36 KB

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