FoxInterpreterSymbols.Mod 42 KB

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