PCT.Mod 83 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675
  1. (* Paco, Copyright 2000 - 2002, Patrik Reali, ETH Zurich *)
  2. MODULE PCT; (** AUTHOR "prk"; PURPOSE "Parallel Compiler: symbol table"; *)
  3. IMPORT
  4. SYSTEM, KernelLog, StringPool, Strings, PCM, PCS;
  5. CONST
  6. MaxPlugins = 4;
  7. (** Error Codes *)
  8. Ok* = 0;
  9. DuplicateSymbol* = 1;
  10. NotAType* = 53;
  11. IllegalPointerBase* = 57;
  12. RecursiveType* = 58;
  13. IllegalValue* = 63;
  14. IllegalType* = 88; (** open array not allowed here *)
  15. IllegalArrayBase* = 89;
  16. IllegalMixture* = 91; (* fof mixture of enhanced arrays and traditional arrays not allowed: forbidden ARRAY OF ARRAY [*] OF ... *)
  17. ParameterMismatch* = 115;
  18. ReturnMismatch* = 117;
  19. DuplicateOperator* = 139;
  20. ImportCycle* = 154;
  21. MultipleInitializers* = 144;
  22. NotImplemented* = 200;
  23. ObjectOnly* = 249;
  24. InitializerOutsideObject* = 253;
  25. IndexerNotVirtual* = 991;
  26. (** Reserved Names *)
  27. BodyNameStr* = "@Body";
  28. SelfNameStr* = "@Self";
  29. AnonymousStr* = "@NoName";
  30. PtrReturnTypeStr* = "@PtrReturnType"; (* ug *)
  31. AssignIndexer*= "@AssignIndexer";
  32. ReadIndexer*= "@ReadIndexer";
  33. AwaitProcStr = "@AwaitProc"; (* ug *)
  34. HiddenProcStr ="@tmpP"; (* ug *)
  35. (**Search.mode*)
  36. local* = 0;
  37. (**Scope.state*)
  38. structdeclared* = 1; (** all structures declared *)
  39. structshallowallocated *= 2; (* fof *)
  40. structallocated* = 3; (** all structures allocated (size set) *)
  41. procdeclared* = 4; (** all procedures declared *)
  42. hiddenvarsdeclared* = 5; (** all proc. calls returning pointers or delegates as hidden variables declared *) (* ug *)
  43. modeavailable* = 6; (** body mode available (ACTIVE, EXCLUSIVE) *)
  44. complete* = 7; (** code available *)
  45. (** Access Flags *)
  46. HiddenRW* = 0; (** can neither read nor write symbol in same module *) (* ug *)
  47. InternalR* = 1; (** can read symbol in same module *)
  48. InternalW* = 2; (** can write symbol in same module *)
  49. ProtectedR* = 3; (** can read symbol in type extentions *)
  50. ProtectedW* = 4; (** can write symbol in type extentions *)
  51. PublicR* = 5; (** can read everywhere *)
  52. PublicW* = 6; (** can write everywhere *)
  53. Hidden* = {HiddenRW}; (* ug *)
  54. Internal* = {InternalR, InternalW};
  55. Protected* = {ProtectedR, ProtectedW};
  56. Public* = {PublicR, PublicW};
  57. (**Array.mode*)
  58. static* = 1; open* = 2;
  59. (** Record.mode *)
  60. exclusive* = 0; active* = 1; safe* = 2; class* = 16; interface* = 17;
  61. (** Symbol .flags / all *)
  62. used* = 16; (**object is accessed*)
  63. written*=17; (* object has been written to *) (** fof 070731 *)
  64. (** Symbol .flags / Proc only *)
  65. Constructor* = 1;
  66. Inline* = 2; (** inline proc *)
  67. copy* = 3; (** copy of a method defined in a superinterface *)
  68. NonVirtual* = 7; (** Non-virtual method, cannot be overridden *)
  69. Operator* = 10;
  70. Indexer *= 11;
  71. RealtimeProc* = PCM.RealtimeProc; (* = 21 *) (* realtime procedure that is not allowed to allocate memory nor to wait on locks or conditions *)
  72. (** Symbol .flags / Variable only *)
  73. (**PCM.Untraced = 4 -> PCT.Variable only*)
  74. (** Parameter .flags *)
  75. WinAPIParam* = PCM.WinAPIParam; (* = 13 *) (* ejz *)
  76. CParam* = PCM.CParam; (* = 14 *) (* fof for Linux *)
  77. (** Calling Conventions *)
  78. OberonCC* = 1; OberonPassivateCC* = 2; WinAPICC* = 3; (* ejz *) CLangCC* = 4; (* fof for Linux *)
  79. (** Struct flags *)
  80. StaticMethodsOnly* = 5; (** Delegate / restriction, static methods only *)
  81. SystemType* = 6; (** Record / hidden system type descs (pointer to array of pointers/descriptors), allocated by need *)
  82. RealtimeProcType* = PCM.RealtimeProcType; (* = 8 *) (** realtime property of delegates and static procedure types *)
  83. (** Scope.flags *)
  84. Overloading* = 31; (**Modules only: duplicate entries allowed (applies to all scopes in the module)*)
  85. AutodeclareSelf* = 30; (**Methods only: self is automatically allocated when the method is created*)
  86. SuperclassAvailable* = 29; (**Records only: Superclass available before (or by a different thread) the actual one is entered*)
  87. CanSkipAllocation* = 28; (** Records only: the pointer only is used, record allocation can be skipped (no need to wait for StructComplete *)
  88. RealtimeScope* = 27; (** direct or indirect owner of scope is a realtime procedure, i.e. within scope no memory allocation, no locking and no await are allowed *)
  89. VAR
  90. BodyName-, SelfName-, Anonymous-, PtrReturnType- (* ug *) : LONGINT; (** indexes to stringpool *)
  91. (*debug/trace counters*)
  92. AWait, ANoWait: LONGINT;
  93. TYPE
  94. StringIndex* = StringPool.Index;
  95. (** Symbol Table Structures *)
  96. Struct* = POINTER TO RECORD
  97. owner-: Type; (* canonical name of structure, if any *)
  98. size*: PCM.Attribute; (* back-end: size information *)
  99. sym*: PCM.Attribute; (* fingerprinting information *)
  100. flags-: SET;
  101. END;
  102. Symbol* = OBJECT
  103. VAR
  104. name-: StringIndex; (**string-pool index*)
  105. vis-: SET;
  106. type*: Struct;
  107. adr*, sym*: PCM.Attribute; (**allocation and fingerprinting information*)
  108. flags*: SET;
  109. sorted-: Symbol;
  110. inScope-: Scope;
  111. dlink*: Symbol; (* chain for user defined purposes *)
  112. info*: ANY; (** user defined data *)
  113. pos-: LONGINT; (*fof 070731 *)
  114. PROCEDURE Use;
  115. BEGIN INCL(flags, used)
  116. END Use;
  117. (** fof 070731 >> *)
  118. PROCEDURE Write;
  119. BEGIN
  120. INCL(flags,written);
  121. END Write;
  122. (** << fof *)
  123. END Symbol;
  124. Node* = OBJECT
  125. VAR
  126. pos*: LONGINT;
  127. END Node;
  128. Scope* = OBJECT
  129. VAR
  130. state-: SHORTINT;
  131. flags-: SET;
  132. ownerID-: ADDRESS; (** process owning this scope*)
  133. module-: Module; (** module owning this scope *)
  134. sorted-, last-: Symbol; (** objects in the scope; last is the last object inserted *)
  135. firstValue-, lastValue-: Value;
  136. firstVar-, lastVar-: Variable;
  137. firstHiddenVar-, lastHiddenVar-: Variable; (* ug *) (** variables denoting proc. calls that return pointers, not inserted in sorted list of all symbols *)
  138. firstProc-, lastProc-: Proc;
  139. firstType-, lastType-: Type;
  140. parent-: Scope;
  141. code*: PCM.Attribute;
  142. imported-: BOOLEAN; (*cached information*)
  143. valueCount-, varCount-, procCount-, typeCount-: LONGINT; (** variables/procedures in this scope. *)
  144. tmpCount: LONGINT; (* ug *)
  145. PROCEDURE Await*(state: SHORTINT);
  146. BEGIN {EXCLUSIVE}
  147. IF SELF.state >= state THEN INC(ANoWait) ELSE INC(AWait) END;
  148. AWAIT(SELF.state >= state) (** remove EXCLUSIVE, not needed*)
  149. END Await;
  150. PROCEDURE ChangeState(state: SHORTINT);
  151. BEGIN {EXCLUSIVE}
  152. ASSERT((ownerID = 0) OR (ownerID = PCM.GetProcessID()), 500);(* global scope has no process id (=0) since different processes may insert elements here, cf. procedure Init *)
  153. ASSERT(SELF.state < state, 501);
  154. SELF.state := state
  155. END ChangeState;
  156. PROCEDURE CreateSymbol*(name: StringIndex; vis: SET; type: Struct; VAR res: WORD);
  157. VAR o: Symbol;
  158. BEGIN
  159. NEW(o);
  160. InitSymbol(o, name, vis, type);
  161. Insert(SELF, o, res);
  162. END CreateSymbol;
  163. PROCEDURE CreateValue*(name: StringIndex; vis: SET; c: Const; pos: LONGINT; (*fof*) VAR res: WORD);
  164. VAR v: Value;
  165. BEGIN
  166. v := NewValue(name, vis, c); v.pos := pos; (*fof*)
  167. Insert(SELF, v, res);
  168. IF res = Ok THEN
  169. INC(valueCount);
  170. IF lastValue = NIL THEN firstValue := v ELSE lastValue.nextVal := v END;
  171. lastValue := v
  172. END
  173. END CreateValue;
  174. PROCEDURE CreateType*(name: StringIndex; vis: SET; type: Struct; pos: LONGINT; (*fof*) VAR res: WORD);
  175. VAR t: Type;
  176. BEGIN
  177. NEW(t);
  178. InitType(t, name, vis, type); t.pos := pos; (*fof*)
  179. Insert(SELF, t, res);
  180. IF res = Ok THEN
  181. INC(typeCount);
  182. IF lastType = NIL THEN firstType := t ELSE lastType.nextType := t END;
  183. lastType := t
  184. END
  185. END CreateType;
  186. PROCEDURE CreateAlias*(ov: Variable; type: Struct; (* scope: Scope; extern: BOOLEAN; *) VAR res: WORD);
  187. VAR v: Alias;
  188. BEGIN
  189. NEW(v); v.name := ov.name; v.vis := ov.vis; v.type := type;
  190. v.obj := ov; v.level := ov.level;
  191. (* v.extern := extern; *)
  192. (* ov.alias := v; *)
  193. Insert((* scope *) SELF, v, res)
  194. END CreateAlias;
  195. PROCEDURE CreateVar*(name: StringIndex; vis, flags: SET; type: Struct; pos: LONGINT; (*fof*) info: ANY; (* ug *) VAR res: WORD);
  196. BEGIN HALT(99) (*abstract*)
  197. END CreateVar;
  198. PROCEDURE CreateProc*(name: StringIndex; vis, flags: SET; scope: (*Proc*)Scope; return: Struct; pos: LONGINT; (*fof*) VAR res: WORD);
  199. BEGIN HALT(99) (*abstract*)
  200. END CreateProc;
  201. (* ug *)
  202. PROCEDURE CreateHiddenVarName*(VAR name: StringPool.Index);
  203. VAR s1, s: ARRAY 256 OF CHAR;
  204. BEGIN
  205. Strings.IntToStr(tmpCount, s1);
  206. Strings.Concat(HiddenProcStr, s1, s);
  207. StringPool.GetIndex(s, name);
  208. INC(tmpCount)
  209. END CreateHiddenVarName;
  210. (* ug *)
  211. PROCEDURE CreateAwaitProcName*(VAR name: StringPool.Index; count: LONGINT);
  212. VAR s1, s: ARRAY 256 OF CHAR;
  213. BEGIN
  214. Strings.IntToStr(count, s1);
  215. Strings.Concat(AwaitProcStr, s1, s);
  216. StringPool.GetIndex(s, name)
  217. END CreateAwaitProcName;
  218. (* ug *)
  219. PROCEDURE FindHiddenVar*(pos: LONGINT; info: ANY): Variable;
  220. VAR p: Variable; s: Scope;
  221. BEGIN
  222. s := SELF;
  223. WHILE s IS WithScope DO s := s.parent END;
  224. p := s.firstHiddenVar;
  225. WHILE (p # NIL) & ((p.pos # pos) OR (p.info # info)) DO p := p.nextVar END;
  226. RETURN p
  227. END FindHiddenVar;
  228. END Scope;
  229. WithScope* = OBJECT (Scope)
  230. VAR
  231. withGuard*, withSym*: Symbol;
  232. (* ug *)
  233. PROCEDURE CreateVar*(name: StringIndex; vis, flags: SET; type: Struct; pos: LONGINT; (*fof*) info: ANY; VAR res: WORD);
  234. VAR s: Scope;
  235. BEGIN
  236. s := parent;
  237. WHILE s IS WithScope DO s := s.parent END;
  238. s.CreateVar(name, vis, flags, type, pos, info, res)
  239. END CreateVar;
  240. END WithScope;
  241. ProcScope* = OBJECT(Scope)
  242. VAR
  243. ownerS-: Delegate;
  244. ownerO-: Proc;
  245. firstPar-, lastPar-: Parameter;
  246. formalParCount-, (* number of formal parameters *) (* ug *)
  247. parCount-: LONGINT; (* number of total parameters, including PtrReturnType and SELF parameters *)
  248. cc-: LONGINT;
  249. returnParameter-: ReturnParameter; (* fof, for access to the return parameter in procedures*)
  250. PROCEDURE &Init*; (* ejz *)
  251. BEGIN
  252. cc := OberonCC
  253. END Init;
  254. PROCEDURE SetCC*(cc: LONGINT);
  255. BEGIN
  256. SELF.cc := cc
  257. END SetCC;
  258. PROCEDURE CreateVar*(name: StringIndex; vis, flags: SET; type: Struct; pos: LONGINT; (*fof*) info: ANY; (*ug*) VAR res: WORD);
  259. VAR v: LocalVar;
  260. BEGIN
  261. NEW(v); v.pos := pos; (*fof*)
  262. InitSymbol(v, name, vis, type);
  263. v.flags := flags;
  264. v.info := info; (* ug *)
  265. v.level := ownerO.level;
  266. CheckVar(v, {static, open}, {static, open} (* fof *) ,res);
  267. IF (v.type IS Array) & (v.type(Array).mode IN {open}) & ~v.type(Array).isDynSized THEN
  268. res := IllegalType; v.type := UndefType;
  269. END;
  270. IF vis = Hidden THEN (* ug *)
  271. IF lastHiddenVar = NIL THEN firstHiddenVar := v ELSE lastHiddenVar.nextVar := v END;
  272. lastHiddenVar := v; INCL(v.vis,PublicW); (* fof: may be overwritten by any caller (otherwise results in readonly designator in PCB yielding errors) *)
  273. res := Ok
  274. ELSE
  275. Insert(SELF, v, res);
  276. IF res = Ok THEN
  277. INC(varCount);
  278. IF lastVar = NIL THEN firstVar := v ELSE lastVar.nextVar := v END;
  279. lastVar := v
  280. END
  281. END
  282. END CreateVar;
  283. PROCEDURE ReversePars*; (* ejz *)
  284. VAR p, next: Parameter;
  285. BEGIN
  286. p := firstPar; firstPar := NIL; lastPar := p;
  287. WHILE p # NIL DO
  288. next := p.nextPar;
  289. p.nextPar := firstPar; firstPar := p;
  290. p := next
  291. END
  292. END ReversePars;
  293. PROCEDURE CreatePar*(vis: SET; ref: BOOLEAN; name: StringIndex; flags: SET; type: Struct; pos: LONGINT; (*fof 070731 *) VAR res: WORD);
  294. VAR p: Parameter;
  295. (* ug *)
  296. PROCEDURE IsHiddenPar(name: StringIndex): BOOLEAN;
  297. BEGIN
  298. IF (name = PtrReturnType) OR (name = SelfName) THEN
  299. RETURN TRUE
  300. ELSE
  301. RETURN FALSE
  302. END
  303. END IsHiddenPar;
  304. BEGIN
  305. NEW(p); p.pos := pos; (*fof*)
  306. InitSymbol(p, name, vis, type);
  307. CheckVar(p, {static, open}, {static, open} (* fof *),res);
  308. p.flags := flags;
  309. p.ref := ref;
  310. Insert(SELF, p, res);
  311. IF res = Ok THEN
  312. INC(parCount);
  313. IF ~IsHiddenPar(name) THEN INC(formalParCount) END; (* ug *)
  314. IF lastPar = NIL THEN firstPar := p ELSE lastPar.nextPar := p END;
  315. lastPar := p
  316. END
  317. END CreatePar;
  318. (** fof >> *)
  319. PROCEDURE CreateReturnPar*(type: Struct; VAR res: WORD);
  320. (* if return type of the function admits it, create the return parameter *)
  321. VAR v: ReturnParameter; RetName: StringIndex;
  322. BEGIN
  323. IF (type IS EnhArray) OR (type IS Tensor) OR (type IS Pointer) THEN
  324. NEW(v); RetName := (* ownerO.name *) StringPool.GetIndex1("RETURNPARAMETER"); (*! very unclean, for testing purposes *)
  325. InitSymbol(v,RetName,{},type);
  326. Insert(SELF,v,res);
  327. v.ref := TRUE; (* ~(type IS Tensor); *)
  328. returnParameter := v;
  329. END;
  330. END CreateReturnPar;
  331. (** << fof *)
  332. PROCEDURE CreateProc*(name: StringIndex; vis, flags: SET; scope: (*Proc*)Scope; return: Struct; pos: LONGINT; (*fof*) VAR res: WORD);
  333. VAR p: Proc;
  334. BEGIN
  335. p := NewProc(vis, name, flags, scope(ProcScope), return, res);
  336. p.pos := pos; (*fof*)
  337. Insert(SELF, p, res);
  338. IF res = Ok THEN
  339. INC(procCount);
  340. IF lastProc = NIL THEN firstProc := p ELSE lastProc.nextProc := p END;
  341. lastProc := p
  342. END
  343. END CreateProc;
  344. END ProcScope;
  345. RecScope* = OBJECT(Scope)
  346. VAR
  347. owner-: Record;
  348. body-, initproc-: Method;
  349. firstMeth-, lastMeth-: Method;
  350. totalVarCount-, totalProcCount-: LONGINT; (**var/proc count including base type (overwritten method are counted only once)*)
  351. PROCEDURE CreateVar*(name: StringIndex; vis, flags: SET; type: Struct; pos: LONGINT; (*fof*) info : ANY; (*ug*) VAR res: WORD);
  352. VAR f: Field; obj: Symbol;
  353. BEGIN
  354. ASSERT(vis # Hidden);
  355. IF CheckForRecursion(type, owner) THEN
  356. res := RecursiveType;
  357. type := Int32 (*NoType -> trap in TypeSize*)
  358. END;
  359. NEW(f); f.pos := pos; (*fof*) InitSymbol(f, name, vis, type); f.flags := flags; CheckVar(f, {static}, {static, open} (* fof *) ,res);
  360. f.info := info; (* ug *)
  361. IF (SuperclassAvailable IN flags) & (owner.brec # NIL) THEN (*import: already ok*)
  362. obj := Find(SELF, owner.brec.scope, name, structdeclared, FALSE);
  363. IF obj # NIL THEN res := DuplicateSymbol END
  364. END;
  365. Insert(SELF, f, res);
  366. IF res = Ok THEN
  367. INC(varCount);
  368. IF lastVar = NIL THEN firstVar := f ELSE lastVar.nextVar := f END;
  369. lastVar := f
  370. END
  371. END CreateVar;
  372. PROCEDURE CreateProc*(name: StringIndex; vis, flags: SET; scope: (*Proc*)Scope; return: Struct; pos: LONGINT; (*fof*) VAR res: WORD);
  373. VAR m: Method;
  374. BEGIN
  375. m := NewMethod(vis, name, flags, scope(ProcScope), return, owner, pos, res);
  376. m.pos := pos; (* fof *)
  377. Insert(SELF, m, res);
  378. IF res = Ok THEN
  379. INC(procCount);
  380. IF lastMeth = NIL THEN
  381. firstProc := m; firstMeth := m
  382. ELSE
  383. lastMeth.nextProc := m; lastMeth.nextMeth := m
  384. END;
  385. lastProc := m;
  386. lastMeth := m
  387. END
  388. END CreateProc;
  389. PROCEDURE IsProtected* (): BOOLEAN;
  390. VAR scope: RecScope;
  391. BEGIN scope := SELF;
  392. WHILE (scope # NIL) & (scope.owner.mode * {exclusive, active} = {}) DO
  393. IF scope.owner.brec # NIL THEN scope := scope.owner.brec.scope ELSE scope := NIL END;
  394. END;
  395. RETURN scope # NIL;
  396. END IsProtected;
  397. END RecScope;
  398. (** fof >> *)
  399. CustomArrayScope* = OBJECT (RecScope)
  400. END CustomArrayScope;
  401. (** << fof *)
  402. ModScope* = OBJECT(Scope)
  403. VAR
  404. owner-: Module;
  405. records-: Record;
  406. nofRecs-: INTEGER;
  407. PROCEDURE CreateVar*(name: StringIndex; vis, flags: SET; type: Struct; pos: LONGINT; (*fof*) info: ANY; (*ug*) VAR res: WORD);
  408. VAR v: GlobalVar;
  409. BEGIN
  410. NEW(v); v.pos := pos; (*fof*) InitSymbol(v, name, vis, type); v.flags := flags; CheckVar(v, {static}, {static, open} (* fof *) ,res);
  411. v.info := info; (* ug *)
  412. IF vis = Hidden THEN (* ug *)
  413. IF lastHiddenVar = NIL THEN firstHiddenVar := v ELSE lastHiddenVar.nextVar := v END;
  414. lastHiddenVar := v; INCL(v.vis,PublicW); (* fof: may be overwritten by any caller (otherwise results in readonly designator in PCB yielding errors) *)
  415. res := Ok
  416. ELSE
  417. Insert(SELF, v, res);
  418. IF res = Ok THEN
  419. INC(varCount);
  420. IF lastVar = NIL THEN firstVar := v ELSE lastVar.nextVar := v END;
  421. lastVar := v
  422. END
  423. END
  424. END CreateVar;
  425. PROCEDURE CreateProc*(name: StringIndex; vis, flags: SET; scope: (*Proc*)Scope; return: Struct; pos: LONGINT; (*fof*) VAR res: WORD);
  426. VAR p: Proc;
  427. BEGIN
  428. p := NewProc(vis, name, flags, scope(ProcScope), return, res);
  429. p.pos := pos; (* fof *)
  430. Insert(SELF, p, res);
  431. IF res = Ok THEN
  432. INC(procCount);
  433. IF lastProc = NIL THEN firstProc := p ELSE lastProc.nextProc := p END;
  434. lastProc := p
  435. END;
  436. END CreateProc;
  437. PROCEDURE AddModule*(alias: StringIndex; m: Module; pos: LONGINT; (* fof *) VAR res: WORD);
  438. BEGIN
  439. Insert(SELF, NewModule(alias, TRUE, m.flags, m.scope), res);
  440. m.pos := pos; (* fof *)
  441. END AddModule;
  442. END ModScope;
  443. (** ------------ Structures ----------------- *)
  444. Basic* = POINTER TO RECORD (Struct)
  445. END;
  446. Array* = POINTER TO RECORD (Struct)
  447. mode-: SHORTINT; (** array size: static, open *)
  448. base-: Struct; (** element type *)
  449. len-: LONGINT; (** array size (iff mode=static) *)
  450. opendim-: LONGINT;
  451. isDynSized*: BOOLEAN;
  452. END;
  453. (** fof >> *)
  454. EnhArray* = POINTER TO RECORD (Struct)
  455. mode-: SHORTINT; (** array size: static, open *)
  456. base-: Struct; (** element type, if more dimensional array then of type EnhArray *)
  457. len-: LONGINT; (** array size (iff mode=static) *)
  458. inc-: LONGINT; (** increment of this dimension (iff mode = static) *)
  459. dim-: LONGINT; (* number of dimensions *)
  460. opendim-: LONGINT; (** number of open dimensions *)
  461. END;
  462. Tensor* = POINTER TO RECORD (Struct)
  463. (** type is always open *)
  464. base-: Struct; (** no size or geometry information available at compile time *)
  465. END;
  466. (** << fof *)
  467. Record* = POINTER TO RECORD (Struct)
  468. scope-: RecScope; (** record contents *)
  469. brec-: Record; (**base record*)
  470. btyp-: Struct; (** base type, for dynamic records = Pointer to brec*)
  471. ptr-: Pointer; (** dynamic type*)
  472. intf-: POINTER TO Interfaces;
  473. mode*(*-*): SET;
  474. prio*: LONGINT; (**body priority (mode = active)*)
  475. imported-: BOOLEAN;
  476. link-: Record; (** Module.records, embedded list *)
  477. (*td*: PCM.Attribute; (**type descriptor*) in PCBT.RecSize*)
  478. pvused*, pbused*: BOOLEAN; (*what features of the record are used, to decide which fp to use [pvfp/pbfp]*)
  479. END;
  480. (** fof >> *)
  481. CustomArray*= POINTER TO RECORD (Record)
  482. dim-: LONGINT;
  483. etyp: Struct;
  484. END;
  485. (** << fof *)
  486. Pointer* = POINTER TO RECORD (Struct)
  487. base-: Struct;
  488. baseA-: Array;
  489. baseR-: Record;
  490. END;
  491. Interface* = Pointer; (*pointer to record, mode = interface*)
  492. Interfaces* = ARRAY OF Interface;
  493. Delegate* = POINTER TO RECORD (Struct)
  494. return-: Struct; (** return type, or NoType *)
  495. scope-: ProcScope; (** parameter list *)
  496. END;
  497. (** ------------ Symbols ------------------ *)
  498. Const* = POINTER TO RECORD
  499. type-: Struct;
  500. int-: LONGINT;
  501. real-: LONGREAL;
  502. long-: HUGEINT;
  503. set-: SET;
  504. bool-: BOOLEAN;
  505. ptr-: ANY;
  506. str-: POINTER TO PCS.String; (** int = strlen *)
  507. owner-: Value;
  508. END;
  509. (** fof >> *)
  510. ConstArray* = POINTER TO RECORD (Const) (* array of constants, denoted as [[1,2,3],[4,5,6]] *)
  511. data-: POINTER TO ARRAY OF CHAR; (* array data as array of Bytes *)
  512. len-: POINTER TO ARRAY OF LONGINT; (* array geometry. Dimension encoded in LEN(len) *)
  513. END;
  514. (** << fof *)
  515. Value* = OBJECT (Symbol)
  516. VAR
  517. const-: Const;
  518. nextVal-: Value; (** next value in scope (by insertion order) *)
  519. END Value;
  520. Variable* = OBJECT (Symbol)
  521. VAR
  522. level-: SHORTINT; (**LocalVar and Parameter only*)
  523. nextVar-: Variable; (** next variable in scope (by insertion order) *)
  524. END Variable;
  525. GlobalVar* = OBJECT (Variable)
  526. END GlobalVar;
  527. LocalVar* = OBJECT (Variable)
  528. END LocalVar;
  529. (** fof >> *)
  530. ReturnParameter*= OBJECT (Variable) VAR ref-: BOOLEAN; END ReturnParameter;
  531. (** << fof *)
  532. Parameter* = OBJECT (Variable)
  533. VAR
  534. ref-: BOOLEAN;
  535. nextPar-: Parameter; (** next parameter in scope (by insertion order) *)
  536. END Parameter;
  537. Field* = OBJECT(Variable)
  538. END Field;
  539. Alias* = OBJECT (Variable) (**type-casted variable*)
  540. VAR
  541. extern: BOOLEAN;
  542. obj-: Variable
  543. END Alias;
  544. Proc* = OBJECT (Symbol)
  545. VAR
  546. scope-: ProcScope;
  547. nextProc-: Proc;
  548. level-: SHORTINT;
  549. END Proc;
  550. Method* = OBJECT (Proc)
  551. VAR
  552. super-: Method;
  553. boundTo-: Record;
  554. self-: Parameter;
  555. nextMeth-: Method;
  556. END Method;
  557. Type* = OBJECT (Symbol)
  558. VAR
  559. nextType-: Type;
  560. PROCEDURE Use;
  561. BEGIN
  562. Use^;
  563. IF (type.owner # SELF) & (* aliased *)
  564. (*imported*) (* only imported modules are in the use list *)
  565. (PublicR IN type.owner.vis) (* exported *)
  566. THEN type.owner.Use END
  567. END Use;
  568. END Type;
  569. Module* = OBJECT (Symbol)
  570. VAR
  571. context*, label*: StringIndex;
  572. scope-: ModScope;
  573. imported-, sysImported-: BOOLEAN;
  574. imports*: ModuleArray; (** directly and indirectly imported modules, no duplicates allowed, no aliases *)
  575. directImps*: ModuleArray; (** only directly imported modules **)
  576. next: Module;
  577. PROCEDURE AddImport*(m: Module);
  578. VAR i: LONGINT;
  579. BEGIN
  580. ASSERT(m = m.scope.owner);
  581. IF (imports = NIL) OR (imports[LEN(imports)-1] # NIL) THEN ExtendModArray(imports) END;
  582. i := 0;
  583. WHILE imports[i] # NIL DO INC(i) END;
  584. imports[i] := m
  585. END AddImport;
  586. PROCEDURE AddDirectImp*(m: Module);
  587. VAR i: LONGINT;
  588. BEGIN
  589. ASSERT(m = m.scope.owner);
  590. IF (directImps = NIL) OR (directImps[LEN(directImps)-1] # NIL) THEN ExtendModArray(directImps) END;
  591. i := 0;
  592. WHILE directImps[i] # NIL DO INC(i) END;
  593. directImps[i] := m
  594. END AddDirectImp;
  595. PROCEDURE Use;
  596. BEGIN
  597. INCL(flags, used);
  598. IF SELF # scope.owner THEN INCL(scope.owner.flags, used) END
  599. END Use;
  600. END Module;
  601. ModuleArray* = POINTER TO ARRAY OF Module;
  602. ModuleDB* = Module;
  603. (** ImportPlugin: import new module. If self # NIL, do self.AddImport(new) (must be done there to break recursive imports) *)
  604. ImporterPlugin* = PROCEDURE (self: Module; VAR new: Module; name: StringIndex);
  605. VAR
  606. Byte-, Bool-, Char8-, Char16-, Char32-: Struct;
  607. Int8-, Int16-, Int32-, Int64-, Float32-, Float64-: Struct;
  608. Set-, Ptr-, String-, NilType-, NoType-, UndefType-, Address*, SetType*, Size*: Struct;
  609. NumericType-: ARRAY 6 OF Basic; (**Int8 .. Float64*)
  610. CharType-: ARRAY 3 OF Basic; (** Char8 .. Char32 *)
  611. Allocate*: PROCEDURE(context, scope: Scope; hiddenVarsOnly: BOOLEAN); (* ug *)
  612. PreAllocate*, PostAllocate*: PROCEDURE (context, scope: Scope); (* ug *)
  613. Universe-, System-: Module;
  614. True-, False-: Const;
  615. SystemAddress-, SystemSize-: Type;
  616. AddressSize*, SetSize*: LONGINT;
  617. import: ARRAY MaxPlugins OF ImporterPlugin;
  618. nofImportPlugins: LONGINT;
  619. database*: ModuleDB; (**collection of modules, first is sentinel*)
  620. (** ---------------- Helper Functions --------------------- *)
  621. (** ExtendModArray - Double structure size, copy elements into new structure *)
  622. PROCEDURE ExtendModArray*(VAR a: ModuleArray);
  623. VAR b: ModuleArray; i: LONGINT;
  624. BEGIN
  625. IF a = NIL THEN NEW(a, 16)
  626. ELSE
  627. NEW(b, 2*LEN(a));
  628. FOR i := 0 TO LEN(a)-1 DO b[i] := a[i] END;
  629. a := b
  630. END
  631. END ExtendModArray;
  632. (** ---------------- Type Compatibility Functions -------------- *)
  633. PROCEDURE IsCardinalType*(t: Struct): BOOLEAN;
  634. BEGIN RETURN (t = Int8) OR (t = Int16) OR (t = Int32) OR (t = Int64)
  635. END IsCardinalType;
  636. PROCEDURE IsFloatType*(t: Struct): BOOLEAN;
  637. BEGIN RETURN (t = Float32) OR (t = Float64)
  638. END IsFloatType;
  639. PROCEDURE IsCharType*(t: Struct): BOOLEAN;
  640. BEGIN RETURN (t = Char8) OR (t = Char16) OR (t = Char32)
  641. END IsCharType;
  642. PROCEDURE IsPointer*(t: Struct): BOOLEAN;
  643. BEGIN RETURN (t = Ptr) OR (t = NilType) OR (t IS Pointer)
  644. END IsPointer;
  645. (* ug: new procedure *)
  646. (* This procedure was necessary to insert because the parser must know whether a type contains pointers at the state PCT.structdeclared.
  647. The procedure PCV.TypeSize computes the size of a type and as a side effect sets the field containPtrs of the size object. However, this occurs
  648. sometimes too late for the parser, namely at the state change to PCT.structallocated.
  649. It is the programmer's responsability not to call the following procedure before t's scope has reached PCT.structdeclared. *)
  650. PROCEDURE ContainsPointer*(t: Struct): BOOLEAN;
  651. VAR b: BOOLEAN; f: Variable;
  652. BEGIN
  653. IF (t IS Pointer) OR (t = Ptr) THEN (* PTR/ANY, generic object type or open array *)
  654. RETURN TRUE
  655. ELSIF t IS Record THEN
  656. WITH t: Record DO
  657. IF t.brec # NIL THEN
  658. b:= ContainsPointer(t.brec)
  659. END;
  660. f := t.scope.firstVar;
  661. WHILE (f # NIL) & ~b DO
  662. b := ContainsPointer(f.type);
  663. f := f.nextVar
  664. END
  665. END;
  666. RETURN b
  667. ELSIF (t IS Array) & (t(Array).mode = static) THEN
  668. RETURN ContainsPointer(t(Array).base)
  669. ELSIF (t IS Delegate) & ~(StaticMethodsOnly IN t.flags) THEN
  670. RETURN TRUE
  671. ELSE RETURN FALSE
  672. END
  673. END ContainsPointer;
  674. PROCEDURE IsStaticDelegate*(t: Struct): BOOLEAN;
  675. BEGIN RETURN (t IS Delegate) & (StaticMethodsOnly IN t.flags)
  676. END IsStaticDelegate;
  677. PROCEDURE IsDynamicDelegate*(t: Struct): BOOLEAN;
  678. BEGIN RETURN (t IS Delegate) & ~(StaticMethodsOnly IN t.flags)
  679. END IsDynamicDelegate;
  680. PROCEDURE IsRecord*(t: Struct): BOOLEAN;
  681. BEGIN
  682. RETURN (t IS Record);
  683. END IsRecord;
  684. PROCEDURE IsBasic*(t: Struct): BOOLEAN;
  685. BEGIN
  686. RETURN (t IS Basic);
  687. END IsBasic;
  688. PROCEDURE BasicTypeDistance*(from, to: Basic): LONGINT;
  689. VAR i, j: LONGINT;
  690. BEGIN
  691. IF IsCharType(from) THEN
  692. i := 0; j := LEN(CharType);
  693. WHILE (i < LEN(CharType)) & (CharType[i] # from) DO INC(i) END;
  694. REPEAT DEC(j) UNTIL (j < i) OR (CharType[j] = to);
  695. ELSE
  696. i := 0; j := LEN(NumericType);
  697. WHILE (i < LEN(NumericType)) & (NumericType[i] # from) DO INC(i) END;
  698. REPEAT DEC(j) UNTIL (j < i) OR (NumericType[j] = to);
  699. END;
  700. RETURN j - i
  701. END BasicTypeDistance;
  702. PROCEDURE RecordTypeDistance*(from, to: Record): LONGINT;
  703. VAR i: LONGINT;
  704. BEGIN
  705. i := 0;
  706. WHILE (from # NIL) & (from # to) DO from := from.brec; INC(i) END;
  707. IF from = NIL THEN i := -1 END;
  708. RETURN i
  709. END RecordTypeDistance;
  710. PROCEDURE PointerTypeDistance*(from, to: Pointer): LONGINT;
  711. BEGIN
  712. IF ~((to.base IS Record) & (from.base IS Record)) THEN
  713. RETURN -1;
  714. ELSE
  715. RETURN RecordTypeDistance(from.baseR, to.baseR);
  716. END;
  717. END PointerTypeDistance;
  718. PROCEDURE ArrayTypeDistance*(from, to: Array): LONGINT;
  719. VAR i: LONGINT;
  720. BEGIN
  721. i := -1;
  722. IF from = to THEN
  723. i := 0
  724. ELSIF (from.mode = static) & (to.mode IN {open}) THEN
  725. i := TypeDistance(from.base, to.base);
  726. IF i >= 0 THEN INC(i) END
  727. ELSIF (from.mode = open) & (to.mode = open) THEN
  728. i := TypeDistance(from.base, to.base);
  729. END;
  730. RETURN i
  731. END ArrayTypeDistance;
  732. PROCEDURE TypeDistance*(from, to: Struct): LONGINT;
  733. VAR i: LONGINT; ptr: Pointer;
  734. BEGIN
  735. i := -1;
  736. IF from = to THEN
  737. i := 0
  738. ELSIF (to IS Array) & (to(Array).mode = open) & (to(Array).base = Byte) THEN
  739. i := 1
  740. ELSIF (from = String) THEN
  741. IF (to IS Array) & (to(Array).mode = open) & (to(Array).base = Char8) THEN i := 1 END
  742. ELSIF (from = Char8) THEN
  743. IF (to IS Array) & (to(Array).mode = open) & (to(Array).base = Char8) THEN i := 1
  744. ELSIF to = Byte THEN i := 1 END
  745. ELSIF (from = Int8) & (to = Byte) THEN
  746. i := 1
  747. ELSIF (from = NilType) THEN
  748. IF (to = Ptr) OR (to IS Pointer) OR (to IS Delegate) THEN i := 1 END
  749. ELSIF (from = NoType) THEN
  750. IF (to IS Delegate) THEN i := 1 END (*special case: procedure -> proctype, not resolved yet*)
  751. ELSIF (from IS Basic) THEN
  752. IF to IS Basic THEN i := BasicTypeDistance(from(Basic), to(Basic)) END
  753. ELSIF (from IS Array) THEN
  754. IF to IS Array THEN i := ArrayTypeDistance(from(Array), to(Array)) END
  755. ELSIF (from IS Record) THEN
  756. IF to IS Record THEN i := RecordTypeDistance(from(Record), to (Record)) END
  757. ELSIF (from IS Pointer) THEN
  758. ptr := from(Pointer);
  759. IF (to = Ptr) THEN i := 1
  760. ELSIF to IS Pointer THEN i := PointerTypeDistance(ptr, to(Pointer))
  761. (* ELSE i := TypeDistance(ptr.base, to); *)
  762. END
  763. (*no procedure test, procedure must be the same*)
  764. END;
  765. RETURN i
  766. END TypeDistance;
  767. PROCEDURE SignatureDistance*(from, to: Parameter): LONGINT;
  768. VAR i, res: LONGINT;
  769. BEGIN
  770. i := 0;
  771. WHILE (from # NIL) & (to # NIL) DO
  772. res := TypeDistance(from.type, to.type);
  773. IF res = -1 THEN RETURN -1 END;
  774. INC(i, res);
  775. from := from.nextPar; to := to.nextPar
  776. END;
  777. RETURN i
  778. END SignatureDistance;
  779. PROCEDURE SignatureDistance0*(parCount: LONGINT; CONST pars: ARRAY OF Struct; to: Parameter): LONGINT;
  780. VAR i, res, res0: LONGINT;
  781. BEGIN
  782. i := 0;
  783. WHILE (i < parCount) DO
  784. res0 := TypeDistance(pars[i], to.type);
  785. IF res0 = -1 THEN RETURN MAX(LONGINT) END;
  786. INC(res, res0);
  787. to := to.nextPar;
  788. INC(i)
  789. END;
  790. ASSERT((to = NIL) OR (to.name = SelfName));
  791. RETURN res
  792. END SignatureDistance0;
  793. PROCEDURE IsLegalReturnType(t: Struct): BOOLEAN;
  794. BEGIN
  795. RETURN (t = NoType) OR (t IS Basic) OR IsPointer(t)
  796. OR (t IS Record) OR (t IS Array) (* & (t(Array).mode = static) *) OR (t IS Delegate) OR (t IS EnhArray) OR (t IS Tensor) (* fof *)
  797. END IsLegalReturnType;
  798. PROCEDURE ParameterMatch*(Pa, Pb: Parameter; VAR faulty: Symbol): BOOLEAN;
  799. BEGIN
  800. faulty := NIL;
  801. IF Pa = Pb THEN RETURN TRUE END;
  802. WHILE (Pa # NIL) & (Pb # NIL) DO
  803. IF ((Pa.ref # Pb.ref) OR (Pa.flags * {PCM.ReadOnly} # Pb.flags * {PCM.ReadOnly}) OR ~EqualTypes(Pa.type, Pb.type)) & ((Pa.name # SelfName) OR (Pb.name # SelfName)) THEN
  804. faulty := Pa; RETURN FALSE
  805. END;
  806. Pa := Pa.nextPar; Pb := Pb.nextPar;
  807. END;
  808. RETURN
  809. ((Pa = NIL) OR (Pa.name = SelfName)) & ((Pb = NIL) OR (Pb.name = SelfName))
  810. END ParameterMatch;
  811. PROCEDURE EqualTypes*(Ta, Tb: Struct): BOOLEAN;
  812. VAR dummy: Symbol;
  813. BEGIN
  814. (* << Alexey, comparison of enhanced arrays and tensors *)
  815. IF Ta = Tb THEN
  816. RETURN TRUE;
  817. ELSIF Ta IS EnhArray THEN
  818. IF (Tb IS EnhArray) & (Ta(EnhArray).mode = Tb(EnhArray).mode) & (Ta(EnhArray).dim = Tb(EnhArray).dim) THEN
  819. IF Ta(EnhArray).mode = static THEN
  820. IF (Ta(EnhArray).len = Tb(EnhArray).len) & (Ta(EnhArray).inc = Tb(EnhArray).inc) & (EqualTypes(Ta(EnhArray).base,Tb(EnhArray).base)) THEN
  821. RETURN TRUE;
  822. END;
  823. ELSE
  824. IF (Ta(EnhArray).opendim = Tb(EnhArray).opendim) & EqualTypes(Ta(EnhArray).base,Tb(EnhArray).base) THEN
  825. RETURN TRUE;
  826. END;
  827. END;
  828. END;
  829. ELSIF Ta IS Tensor THEN
  830. IF (Tb IS Tensor) & (EqualTypes(Ta(Tensor).base,Tb(Tensor).base)) THEN
  831. RETURN TRUE;
  832. END;
  833. ELSIF Ta IS CustomArray THEN
  834. KernelLog.String('Custom arrays are not yet implemented!'); KernelLog.Ln;
  835. ELSIF (Ta IS Array) & (Tb IS Array) & (Ta(Array).mode = open) & (Tb(Array).mode = open) & EqualTypes(Ta(Array).base, Tb(Array).base) THEN
  836. RETURN TRUE;
  837. ELSIF (Ta IS Delegate) & (Tb IS Delegate) & ParameterMatch(Ta(Delegate).scope.firstPar, Tb(Delegate).scope.firstPar, dummy) & (Ta(Delegate).return = Tb(Delegate).return) THEN
  838. RETURN TRUE;
  839. END;
  840. RETURN FALSE;
  841. (* >> Alexey*)
  842. (* commented by Alexey
  843. RETURN
  844. (* rule 1 *) (Ta = Tb) OR
  845. (* rule 2*) (Ta IS Array) & (Tb IS Array) &
  846. (Ta(Array).mode = open) & (Tb(Array).mode = open) &
  847. EqualTypes(Ta(Array).base, Tb(Array).base) OR
  848. (* rule 3*) (Ta IS Delegate) & (Tb IS Delegate) &
  849. ParameterMatch(Ta(Delegate).scope.firstPar, Tb(Delegate).scope.firstPar, dummy) &
  850. (Ta(Delegate).return = Tb(Delegate).return)
  851. *)
  852. END EqualTypes;
  853. PROCEDURE CheckForRecursion(type, banned: Struct): BOOLEAN;
  854. VAR res: BOOLEAN; brec: Record; f: Variable;
  855. BEGIN
  856. res := FALSE;
  857. IF type = NIL THEN
  858. (*skip*)
  859. ELSIF type = banned THEN
  860. res := TRUE
  861. ELSIF type IS Record THEN
  862. brec := type(Record).brec;
  863. IF brec # NIL THEN
  864. res := CheckForRecursion(brec, banned);
  865. IF ~res & (brec.scope # NIL) THEN
  866. f := brec.scope.firstVar;
  867. WHILE (f # NIL) & ~res DO
  868. res := CheckForRecursion(f.type, banned);
  869. f := f.nextVar;
  870. END
  871. END
  872. END
  873. ELSIF type IS Array THEN
  874. res := CheckForRecursion(type(Array).base, banned)
  875. END;
  876. RETURN res
  877. END CheckForRecursion;
  878. (* CompareSignature - res < 0 ==> s1 < s1; used for sorting overloaded procedures *)
  879. PROCEDURE CompareSignature(s1, s2: Parameter): WORD;
  880. VAR res: WORD;
  881. PROCEDURE GetInfo(t: Struct; VAR m: Module; VAR o: Symbol);
  882. BEGIN
  883. m := NIL;
  884. o := t.owner;
  885. IF (o = NIL) & (t IS Record) & (t(Record).ptr # NIL) THEN o := t(Record).ptr.owner END;
  886. IF (o # NIL) & (o.inScope # NIL) THEN
  887. m := o.inScope.module
  888. END
  889. END GetInfo;
  890. PROCEDURE CompareType(t1, t2: Struct): WORD;
  891. VAR
  892. m1, m2: Module;
  893. o1, o2: Symbol;
  894. res: WORD;
  895. BEGIN
  896. GetInfo(t1, m1,o1);
  897. GetInfo(t2, m2, o2);
  898. IF (t1 IS Array) & (t2 IS Array) THEN
  899. IF (t1(Array).mode = open) & ~(t2(Array).mode = open) THEN
  900. res := 1;
  901. ELSIF ~(t1(Array).mode = open) & (t2(Array).mode = open) THEN
  902. res := -1;
  903. ELSIF (t1(Array).mode = static) & (t2(Array).mode = static) THEN
  904. IF t1(Array).len > t2(Array).len THEN
  905. res := 1;
  906. ELSIF t1(Array).len < t2(Array).len THEN
  907. res := -1;
  908. ELSE
  909. res := CompareType(t1(Array).base, t2(Array).base);
  910. END;
  911. ELSE
  912. res := CompareType(t1(Array).base, t2(Array).base);
  913. END;
  914. ELSIF (t1 IS EnhArray) & (t2 IS EnhArray) THEN
  915. IF (t1(EnhArray).mode = open) & ~(t2(EnhArray).mode = open) THEN
  916. res := 1;
  917. ELSIF ~(t1(EnhArray).mode = open) & (t2(EnhArray).mode = open) THEN
  918. res := -1;
  919. ELSIF (t1(EnhArray).mode = static) & (t2(EnhArray).mode = static) THEN
  920. IF t1(EnhArray).len > t2(EnhArray).len THEN
  921. res := 1;
  922. ELSIF t1(EnhArray).len < t2(EnhArray).len THEN
  923. res := -1;
  924. ELSE
  925. res := CompareType(t1(EnhArray).base, t2(EnhArray).base);
  926. END;
  927. ELSE
  928. res := CompareType(t1(EnhArray).base, t2(EnhArray).base);
  929. END;
  930. ELSIF (t1 IS Pointer) & (t2 IS Pointer) THEN
  931. res := CompareType(t1(Pointer).base, t2(Pointer).base);
  932. ELSIF m1 = m2 THEN
  933. IF o1 = o2 THEN res := 0;
  934. ELSIF o1 = NIL THEN res := -1
  935. ELSIF o2 = NIL THEN res := 1
  936. ELSE res := StringPool.CompareString(o1.name, o2.name)
  937. END
  938. ELSIF m1 = NIL THEN res := -1
  939. ELSIF m2 = NIL THEN res := 1
  940. ELSE res := StringPool.CompareString(m1.name, m2.name)
  941. END;
  942. RETURN res;
  943. END CompareType;
  944. BEGIN
  945. IF s1 = s2 THEN res := 0 (* both are NIL *)
  946. ELSIF s1 = NIL THEN res := -1
  947. ELSIF s2 = NIL THEN res := 1
  948. ELSIF s1.type = s2.type THEN res := CompareSignature(s1.nextPar, s2.nextPar)
  949. ELSE
  950. (*
  951. GetInfo(s1.type, m1, o1);
  952. GetInfo(s2.type, m2, o1);
  953. IF m1 = m2 THEN
  954. IF o1 = o2 THEN res := CompareSignature(s1.nextPar, s2.nextPar)
  955. ELSIF o1 = NIL THEN res := -1
  956. ELSIF o2 = NIL THEN res := 1
  957. ELSE res := StringPool.CompareString(o1.name, o2.name)
  958. END
  959. ELSIF m1 = NIL THEN res := -1
  960. ELSIF m2 = NIL THEN res := 1
  961. ELSE res := StringPool.CompareString(m1.name, m2.name)
  962. END
  963. *)
  964. res := CompareType(s1.type, s2.type);
  965. IF res = 0 THEN res := CompareSignature(s1.nextPar, s2.nextPar); END
  966. END;
  967. RETURN res
  968. END CompareSignature;
  969. (* Returns TRUE if the built-in function GETPROCEDURE can be used with this procedure type *)
  970. PROCEDURE GetProcedureAllowed*(scope : ProcScope; returnType : Struct) : BOOLEAN;
  971. PROCEDURE TypeAllowed(type : Struct) : BOOLEAN;
  972. BEGIN
  973. RETURN (type = NoType) OR (type IS Record) OR ((type IS Pointer) & (type(Pointer).baseR # NIL));
  974. END TypeAllowed;
  975. BEGIN
  976. RETURN
  977. ((scope.formalParCount = 0) & TypeAllowed(returnType)) OR
  978. ((scope.formalParCount = 1) & TypeAllowed(scope.firstPar.type) & TypeAllowed(returnType)) OR
  979. ((scope.formalParCount = 1) & (scope.firstPar.type = Ptr) & (returnType = Ptr)); (* TO BE REMVOED REMOVE ANY->ANY *)
  980. END GetProcedureAllowed;
  981. (** ------------ Scope Related Functions ------------------ *)
  982. PROCEDURE SetOwner*(scope: Scope);
  983. BEGIN scope.ownerID := PCM.GetProcessID()
  984. END SetOwner;
  985. PROCEDURE InitScope*(scope, parent: Scope; flags: SET; imported: BOOLEAN);
  986. BEGIN
  987. ASSERT(scope.parent = NIL, 500);
  988. ASSERT(flags - {Overloading, AutodeclareSelf, SuperclassAvailable, CanSkipAllocation, RealtimeScope} = {}, 501);
  989. scope.parent := parent; scope.imported := imported; scope.flags := flags;
  990. IF (parent # NIL) & (RealtimeScope IN parent.flags) THEN
  991. INCL(scope.flags, RealtimeScope) (* ug: RealtimeScope flag is inherited from parent scope *)
  992. END;
  993. IF ~(scope IS ModScope) THEN scope.module := parent.module END
  994. (*
  995. Note: don't call SetOwner: this can cause a race condition, as usually the
  996. parent creates the scope and the child fills it. The checking of the parent may
  997. happen before the child has taken possession of the scope
  998. *)
  999. END InitScope;
  1000. PROCEDURE Insert(scope: Scope; obj: Symbol; VAR res: WORD);
  1001. VAR p, q: Symbol; d: WORD;
  1002. BEGIN
  1003. ASSERT((scope.ownerID = 0) OR (PCM.GetProcessID() = scope.ownerID), 501); (*fof global scope has no process id (=0) since different processes may insert elements here, cf. procedure Init *)
  1004. (* ASSERT(scope.state < complete, 502); *)
  1005. IF (scope.state >= complete) & (scope IS ModScope) THEN
  1006. res := ImportCycle;
  1007. RETURN;
  1008. END;
  1009. (* ASSERT((scope.state < structdeclared) OR (obj IS Proc), 503); *)
  1010. obj.inScope := scope;
  1011. obj.sorted := NIL;
  1012. scope.last := obj;
  1013. IF (obj.name # Anonymous) THEN
  1014. p := scope.sorted; q := NIL;
  1015. WHILE (p # NIL) & (StringPool.CompareString(p.name, obj.name) < 0) DO q := p; p := p.sorted END;
  1016. IF (p = NIL) OR (p.name # obj.name) THEN
  1017. (* ok *)
  1018. ELSIF (Overloading IN scope.module.scope.flags) OR ((Operator IN obj.flags) & ~(Indexer IN obj.flags) ) THEN
  1019. IF obj IS Proc THEN
  1020. WITH obj: Proc DO
  1021. IF ~(p IS Proc) THEN q := p; p := p.sorted END;
  1022. d := 1;
  1023. WHILE (d > 0) & (p # NIL) & (p.name = obj.name) DO
  1024. d := CompareSignature(p(Proc).scope.firstPar, obj.scope.firstPar);
  1025. IF d > 0 THEN q := p; p := p.sorted END
  1026. END;
  1027. IF d = 0 THEN
  1028. IF Operator IN obj.flags THEN
  1029. res := DuplicateOperator
  1030. ELSE
  1031. res := DuplicateSymbol
  1032. END
  1033. END
  1034. END
  1035. ELSIF ~(p IS Proc) THEN
  1036. res := DuplicateSymbol
  1037. END
  1038. ELSE
  1039. res := DuplicateSymbol
  1040. END;
  1041. IF res = Ok THEN
  1042. obj.sorted := p;
  1043. IF q = NIL THEN scope.sorted := obj ELSE q.sorted := obj END
  1044. END
  1045. END
  1046. END Insert;
  1047. PROCEDURE Lookup(scope: Scope; name: StringIndex): Symbol;
  1048. VAR p: Symbol;
  1049. BEGIN
  1050. (* it is cheaper to traverse the whole list, than to compare the strings *)
  1051. p := scope.sorted;
  1052. WHILE (p # NIL) & (p.name # name) DO p := p.sorted END;
  1053. IF (p = NIL) OR (p.name # name) THEN
  1054. p := NIL
  1055. ELSE
  1056. p.Use;
  1057. END;
  1058. RETURN p
  1059. END Lookup;
  1060. (* ug *)
  1061. PROCEDURE HiddenVarExists*(scope: Scope; info: ANY): BOOLEAN;
  1062. VAR v: Variable;
  1063. BEGIN
  1064. v := scope.firstHiddenVar;
  1065. WHILE (v # NIL) & ((v.vis # Hidden) OR (v.info # info)) DO v := v.nextVar END;
  1066. RETURN v # NIL
  1067. END HiddenVarExists;
  1068. PROCEDURE IsVisible(vis: SET; current, search: Scope; localsearch: BOOLEAN): BOOLEAN;
  1069. VAR res: BOOLEAN; rec, tmp: Record;
  1070. BEGIN
  1071. res := FALSE;
  1072. IF HiddenRW IN vis THEN (* ug *)
  1073. res := FALSE
  1074. ELSIF current = search THEN
  1075. res := TRUE
  1076. ELSIF PublicR IN vis THEN
  1077. res := TRUE
  1078. ELSIF (InternalR IN vis) & (current.module = search.module) THEN
  1079. res := TRUE
  1080. ELSIF (ProtectedR IN vis) THEN
  1081. IF localsearch THEN
  1082. res := TRUE
  1083. ELSE
  1084. WHILE (current # NIL) & ~(current IS RecScope) DO current := current.parent END;
  1085. IF current # NIL THEN
  1086. rec := search(RecScope).owner;
  1087. tmp := current(RecScope).owner;
  1088. WHILE (tmp # NIL) & (tmp # rec) DO tmp := tmp.brec END;
  1089. res := tmp # NIL
  1090. END
  1091. END
  1092. END;
  1093. RETURN res
  1094. END IsVisible;
  1095. (** Find -
  1096. findAny -> if FALSE and duplicatesAllowed, find the first non-procedure
  1097. mark -> mark the object as used
  1098. *)
  1099. PROCEDURE Find*(current, search: Scope; name: StringIndex; mode: SHORTINT; mark: BOOLEAN): Symbol;
  1100. VAR p: Symbol; rec: Record; backtrack: Scope; localsearch, restrict: BOOLEAN;
  1101. BEGIN
  1102. restrict := FALSE;
  1103. IF current = search THEN
  1104. localsearch := TRUE;
  1105. p := Lookup(Universe.scope, name)
  1106. END;
  1107. IF (p = NIL) & (search IS RecScope) THEN
  1108. rec := search(RecScope).owner;
  1109. IF localsearch THEN backtrack := search.parent END (*allow search outside the record hierarchy*)
  1110. END;
  1111. WHILE (p = NIL) & (search # NIL) DO
  1112. IF (mode # local) & (PCM.GetProcessID() # search.ownerID) THEN
  1113. search.Await(mode)
  1114. END;
  1115. p := Lookup(search, name);
  1116. IF (p # NIL) & IsVisible(p.vis, current, search, localsearch) & (~restrict OR (search IS ModScope) OR (p IS Type) OR (p IS Value))THEN
  1117. (*skip*)
  1118. ELSIF rec # NIL THEN
  1119. p := NIL;
  1120. rec := rec.brec;
  1121. IF rec = NIL THEN
  1122. search := backtrack;
  1123. restrict := TRUE;
  1124. ELSE
  1125. search := rec.scope
  1126. END
  1127. ELSE
  1128. p := NIL;
  1129. search := search.parent;
  1130. IF (search # NIL) & (search IS RecScope) THEN
  1131. rec := search(RecScope).owner;
  1132. backtrack := search.parent
  1133. END
  1134. END
  1135. END;
  1136. IF mark & (p # NIL) THEN p.Use END;
  1137. RETURN p
  1138. END Find;
  1139. PROCEDURE FindIndexer*(scope: RecScope; name: StringIndex): Method;
  1140. VAR s: Symbol;
  1141. BEGIN
  1142. IF scope = NIL THEN RETURN NIL END;
  1143. s := Lookup(scope, name);
  1144. IF (s # NIL) & (s IS Method) THEN RETURN s(Method) ELSE
  1145. IF scope.owner.brec # NIL THEN
  1146. RETURN FindIndexer(scope.owner.brec.scope, name)
  1147. ELSE
  1148. RETURN NIL
  1149. END
  1150. END
  1151. END FindIndexer;
  1152. PROCEDURE FindOperator*(current, search: Scope; parents: BOOLEAN; name: StringIndex; CONST pars: ARRAY OF Struct; parCount (*ug*), pos: LONGINT): Proc;
  1153. VAR
  1154. p: Symbol;
  1155. hitProc: Proc;
  1156. hitScope: Scope;
  1157. dist, hit, i: LONGINT;
  1158. hitClash, localDone: BOOLEAN;
  1159. BEGIN
  1160. localDone := FALSE;
  1161. hitClash := FALSE;
  1162. hit := MAX(LONGINT);
  1163. hitProc := NIL;
  1164. i := 0;
  1165. IF (PCM.GetProcessID() # search.ownerID) THEN search.Await(procdeclared) END;
  1166. WHILE ~localDone DO
  1167. p := Lookup(search, name);
  1168. WHILE (p # NIL) & (p.name = name) DO
  1169. IF (p IS Proc) & (p(Proc).scope.formalParCount = parCount) THEN (* ug *)
  1170. IF IsVisible(p.vis, current, search, current = search) THEN
  1171. dist := Distance(pars, p(Proc).scope.firstPar, parCount (* ug *));
  1172. (* dist := SignatureDistance0(parCount, pars, p(Proc).scope.firstPar); *)
  1173. IF dist >= MAX(LONGINT) THEN
  1174. (* operator not applicable *)
  1175. ELSIF dist < hit THEN
  1176. hitProc := p(Proc);
  1177. hitScope := search;
  1178. hit := dist;
  1179. hitClash := FALSE;
  1180. ELSIF (dist = hit) & (hitScope = search) THEN
  1181. (* two operators with equal distance found *)
  1182. hitClash := TRUE;
  1183. (* PCM.Error(139, pos, " (local)"); *)
  1184. END
  1185. END;
  1186. END;
  1187. p := p.sorted;
  1188. END;
  1189. IF search # search.module.scope THEN
  1190. search := search.parent;
  1191. ELSE
  1192. localDone := TRUE;
  1193. END;
  1194. END;
  1195. IF hitClash & (hit = 0) THEN
  1196. PCM.Error(139, pos, " (local)");
  1197. END;
  1198. IF (search(ModScope).owner.imports # NIL) & (hit > 0) & (parents) THEN
  1199. (*
  1200. PrintString(search(ModScope).owner.name); KernelLog.String(" imports:"); KernelLog.Ln;
  1201. FOR i := 0 TO LEN(search(ModScope).owner.imports^) - 1 DO
  1202. IF search(ModScope).owner.imports[i] # NIL THEN
  1203. KernelLog.String(" "); PrintString(search(ModScope).owner.imports[i].name); KernelLog.Ln;
  1204. ELSE
  1205. KernelLog.String(" NIL");
  1206. END;
  1207. END;
  1208. *)
  1209. i := 0;
  1210. WHILE (i < LEN(search(ModScope).owner.imports^)) & (search(ModScope).owner.imports[i] # NIL) DO
  1211. IF (PCM.GetProcessID() # search(ModScope).owner.imports[i].scope.ownerID) THEN search.Await(procdeclared) END;
  1212. p := Lookup(search(ModScope).owner.imports[i].scope, name);
  1213. WHILE (p # NIL) & (p.name = name) DO
  1214. IF (p IS Proc) & (p(Proc).scope.formalParCount = parCount) (* ug *) THEN
  1215. IF IsVisible(p.vis, current, search(ModScope).owner.imports[i].scope, current = search(ModScope).owner.imports[i].scope) THEN
  1216. dist := Distance(pars, p(Proc).scope.firstPar, parCount (* ug *));
  1217. (* dist := SignatureDistance0(parCount, pars, p(Proc).scope.firstPar); *)
  1218. IF dist >= MAX(LONGINT) THEN
  1219. (* operator not applicable *)
  1220. ELSIF dist < hit THEN
  1221. hitProc := p(Proc);
  1222. hit := dist;
  1223. hitClash := FALSE;
  1224. ELSIF (dist = hit) & (hitProc.inScope.module # current.module) THEN
  1225. (* if best operator (hitProc) is not defined in local module, then error: operator not unique *)
  1226. PCM.Error(139, pos, "");
  1227. END
  1228. END;
  1229. END;
  1230. p := p.sorted;
  1231. END;
  1232. INC(i);
  1233. END;
  1234. END;
  1235. IF hitClash THEN
  1236. PCM.Error(139, pos, " (local)");
  1237. END;
  1238. RETURN hitProc;
  1239. END FindOperator;
  1240. PROCEDURE PrintString*(s: StringPool.Index);
  1241. VAR str: PCS.String;
  1242. BEGIN
  1243. StringPool.GetString(s, str);
  1244. KernelLog.String(str);
  1245. END PrintString;
  1246. PROCEDURE Distance(CONST pars: ARRAY OF Struct; param: Parameter; parCount: LONGINT (* ug *)): LONGINT;
  1247. VAR dist, res, i: LONGINT;
  1248. baseA, baseF: Struct;
  1249. BEGIN
  1250. dist := 0;
  1251. FOR i := 0 TO parCount-1 DO (* ug *)
  1252. IF (pars[i] = NilType) OR (param.type = NilType) THEN
  1253. RETURN MAX(LONGINT);
  1254. END;
  1255. res := TypeDistance(pars[i], param.type);
  1256. IF res = -1 THEN
  1257. (* no match *)
  1258. RETURN MAX(LONGINT);
  1259. END;
  1260. IF (param.ref) & (res # 0) & ~(param.type IS Array) THEN
  1261. (* actual and formal types of VAR parameter must be identical *)
  1262. RETURN MAX(LONGINT);
  1263. END;
  1264. IF (param.ref) & (res # 0) & (param.type IS Array) & (pars[i] IS Array)THEN
  1265. (* maybe the only difference is an open array ... go down the array chain *)
  1266. baseA := pars[i](Array).base; (* actual parameter *)
  1267. baseF := param.type(Array).base; (* formal parameter *)
  1268. WHILE (baseA IS Array) & (baseF IS Array) DO
  1269. baseA := baseA(Array).base;
  1270. baseF := baseF(Array).base;
  1271. END;
  1272. IF TypeDistance(baseA, baseF) # 0 THEN
  1273. RETURN MAX(LONGINT);
  1274. END;
  1275. END;
  1276. INC(dist, res);
  1277. param := param.nextPar;
  1278. END;
  1279. RETURN dist;
  1280. END Distance;
  1281. PROCEDURE FindProcedure*(current, search: Scope; name: StringIndex; parCount: LONGINT; CONST pars: ARRAY OF Struct; identicSignature, mark: BOOLEAN): Proc;
  1282. VAR p: Symbol; hitProc: Proc; rec: Record; backtrack: Scope; localsearch: BOOLEAN; totCount, hit, dist: LONGINT;
  1283. BEGIN
  1284. IF identicSignature THEN hit := 1 ELSE hit := MAX(LONGINT) END;
  1285. localsearch := current = search;
  1286. totCount := parCount;
  1287. IF (search IS RecScope) THEN
  1288. INC(totCount); (* include SELF *)
  1289. rec := search(RecScope).owner;
  1290. IF localsearch THEN backtrack := search.parent END (*allow search outside the record hierarchy*)
  1291. END;
  1292. WHILE (hit # 0) & (search # NIL) DO
  1293. IF (PCM.GetProcessID() # search.ownerID) THEN search.Await(procdeclared) END;
  1294. p := Lookup(search, name);
  1295. WHILE (p # NIL) & (p.name = name) DO
  1296. IF IsVisible(p.vis, current, search, localsearch) & (p IS Proc) THEN
  1297. WITH p: Proc DO
  1298. IF (totCount = p.scope.parCount) THEN
  1299. dist := SignatureDistance0(parCount, pars, p.scope.firstPar);
  1300. IF dist < hit THEN
  1301. hitProc := p; hit := dist
  1302. END
  1303. END
  1304. END
  1305. END;
  1306. p := p.sorted
  1307. END;
  1308. IF (hit = 0) THEN
  1309. (*skip*)
  1310. ELSIF rec # NIL THEN
  1311. rec := rec.brec;
  1312. IF rec # NIL THEN search := rec.scope ELSE search := backtrack; totCount := parCount END
  1313. ELSE
  1314. search := search.parent;
  1315. IF (search # NIL) & (search IS RecScope) THEN
  1316. rec := search(RecScope).owner;
  1317. backtrack := search.parent
  1318. END
  1319. END
  1320. END;
  1321. IF mark & (hitProc # NIL) THEN hitProc.Use END;
  1322. RETURN hitProc
  1323. END FindProcedure;
  1324. PROCEDURE FindSameSignature*(search: Scope; name: StringIndex; par: Parameter; identic: BOOLEAN): Proc;
  1325. VAR i: LONGINT; parlist: ARRAY 32 OF Struct;
  1326. BEGIN
  1327. WHILE (par # NIL) & (par.name # SelfName) DO
  1328. parlist[i] := par.type; INC(i);
  1329. par := par.nextPar
  1330. END;
  1331. RETURN FindProcedure(search, search, name, i, parlist, identic, FALSE)
  1332. END FindSameSignature;
  1333. PROCEDURE CheckInterfaceImpl(rec, int: Record; VAR res: WORD);
  1334. VAR m: Proc; o (* , faulty *): Symbol;
  1335. BEGIN
  1336. m := int.scope.firstProc;
  1337. WHILE m # NIL DO
  1338. o := FindSameSignature(rec.scope, m.name, m.scope.firstPar, TRUE);
  1339. IF o = NIL THEN
  1340. res := 290
  1341. (*
  1342. ELSIF ~ParameterMatch(m.scope.firstPar, o(Method).scope.firstPar, faulty) THEN
  1343. res := 115
  1344. *)
  1345. ELSIF m.type # o.type THEN
  1346. res := 117
  1347. END;
  1348. m := m.nextProc
  1349. END
  1350. END CheckInterfaceImpl;
  1351. PROCEDURE StateStructShallowAllocated*(scope: Scope); (* fof *)
  1352. VAR state: LONGINT;
  1353. BEGIN
  1354. state := scope.state;
  1355. IF scope.state < structshallowallocated THEN
  1356. scope.ChangeState(structshallowallocated);
  1357. ELSE
  1358. HALT(100);
  1359. END;
  1360. END StateStructShallowAllocated;
  1361. PROCEDURE ChangeState*(scope: Scope; state: SHORTINT; pos: LONGINT);
  1362. VAR rec, r, int: Record; rscope: RecScope; mth: Method; i: LONGINT; res: WORD;
  1363. BEGIN
  1364. WHILE scope.state < state DO
  1365. CASE scope.state+1 OF
  1366. | structdeclared:
  1367. | structshallowallocated:
  1368. IF scope.imported THEN
  1369. Allocate(NIL, scope, FALSE) (* ug: hiddenVarsOnly = FALSE *)
  1370. ELSE
  1371. Allocate(scope.module.scope, scope, FALSE) (* ug: hiddenVarsOnly = FALSE *)
  1372. END;
  1373. | structallocated: (* automatically increment after structshallowallocated *)
  1374. | procdeclared:
  1375. IF (scope IS RecScope) THEN
  1376. rscope := scope(RecScope); rec := rscope.owner;
  1377. rscope.totalProcCount := rscope.procCount;
  1378. IF (rec.brec # NIL) & ~rec.brec.imported THEN
  1379. rec.brec.scope.Await(procdeclared);
  1380. END;
  1381. IF ~(SuperclassAvailable IN scope.flags) & (rec.brec # NIL) THEN
  1382. INC(rscope.totalProcCount, rec.brec.scope.procCount);
  1383. mth := rscope.firstMeth;
  1384. WHILE mth# NIL DO
  1385. IF ~(NonVirtual IN mth.flags) THEN
  1386. mth.super := FindOverwrittenMethod(rec, mth.name, mth.scope,res); ASSERT(res = Ok)
  1387. END;
  1388. IF mth.super # NIL THEN DEC(rscope.totalProcCount); mth.Use END;
  1389. mth := mth.nextMeth
  1390. END
  1391. END;
  1392. IF (res = 0) & (rscope.initproc = NIL) THEN
  1393. REPEAT rec := rec.brec UNTIL (rec = NIL) OR (rec.scope.initproc # NIL);
  1394. IF rec # NIL THEN rscope.initproc := rec.scope.initproc END;
  1395. END;
  1396. rec := rscope.owner; r := rec;
  1397. IF (res = 0) & ~(interface IN r.mode) THEN
  1398. WHILE (r # NIL) & (res = 0) DO
  1399. FOR i := 0 TO LEN(r.intf)-1 DO
  1400. int := r.intf[i].baseR;
  1401. IF ~int.imported THEN
  1402. int.scope.Await(procdeclared);
  1403. END;
  1404. CheckInterfaceImpl(rec, int, res)
  1405. END;
  1406. r := r.brec;
  1407. END
  1408. END;
  1409. IF res # 0 THEN PCM.Error(res, pos, "") END
  1410. END;
  1411. PostAllocate(NIL, scope)
  1412. | hiddenvarsdeclared:
  1413. IF scope.imported THEN
  1414. Allocate(NIL, scope, TRUE) (* ug: hiddenVarsOnly = TRUE *)
  1415. ELSE
  1416. Allocate(scope.module.scope, scope, TRUE) (* ug: hiddenVarsOnly = TRUE *)
  1417. END;
  1418. | modeavailable:
  1419. | complete:
  1420. END;
  1421. scope.ChangeState(scope.state+1)
  1422. END
  1423. END ChangeState;
  1424. PROCEDURE Import*(self: Module; VAR new: Module; name: StringIndex);
  1425. VAR i: LONGINT;
  1426. BEGIN
  1427. new := NIL;
  1428. IF name = System.name THEN
  1429. new := System;
  1430. IF self # NIL THEN self.sysImported := TRUE END
  1431. ELSIF (self # NIL) & (self.imports # NIL) THEN
  1432. i := 0;
  1433. WHILE (i < LEN(self.imports)) & (self.imports[i] # NIL) & (self.imports[i].name # name) DO
  1434. INC(i)
  1435. END;
  1436. IF (i < LEN(self.imports)) & (self.imports[i] # NIL) THEN
  1437. new := self.imports[i];
  1438. END
  1439. END;
  1440. IF new = NIL THEN
  1441. new := Retrieve(database, name);
  1442. IF (new # NIL) & (self # NIL) THEN self.AddImport(new) END;
  1443. END;
  1444. i := 0;
  1445. WHILE (new = NIL) & (i < nofImportPlugins) DO
  1446. import[i](self, new, name);
  1447. INC(i);
  1448. IF (PCM.CacheImports IN PCM.parserOptions) & (new # NIL) THEN
  1449. Register(database, new);
  1450. END
  1451. END;
  1452. END Import;
  1453. PROCEDURE TraverseScopes*(top: Scope; proc: PROCEDURE(s: Scope));
  1454. VAR s: Scope; lastType: Struct; t: Type; v: Variable; p: Proc;
  1455. PROCEDURE ExtractScope(o: Symbol): Scope;
  1456. VAR type: Struct; s: Scope;
  1457. BEGIN
  1458. type := o.type;
  1459. LOOP
  1460. IF (type.owner # NIL) & (type.owner # o) THEN
  1461. EXIT
  1462. ELSIF type IS Array THEN
  1463. type := type(Array).base
  1464. ELSIF type IS Pointer THEN
  1465. type := type(Pointer).base
  1466. ELSE
  1467. IF (type IS Record) & ~(interface IN type(Record).mode) THEN s := type(Record).scope END;
  1468. EXIT
  1469. END
  1470. END;
  1471. RETURN s
  1472. END ExtractScope;
  1473. BEGIN
  1474. top.Await(complete);
  1475. IF top IS ModScope THEN proc(top) END;
  1476. t := top.firstType;
  1477. WHILE t # NIL DO
  1478. s := ExtractScope(t);
  1479. IF s # NIL THEN TraverseScopes(s, proc); proc(s) END;
  1480. t := t.nextType
  1481. END;
  1482. v := top.firstVar;
  1483. WHILE v # NIL DO
  1484. IF v.type # lastType THEN
  1485. lastType := v.type;
  1486. s := ExtractScope(v);
  1487. IF s # NIL THEN TraverseScopes(s, proc); proc(s) END
  1488. END;
  1489. v := v.nextVar
  1490. END;
  1491. p := top.firstProc;
  1492. WHILE p # NIL DO
  1493. s := p.scope;
  1494. TraverseScopes(s, proc); proc(s);
  1495. p := p.nextProc
  1496. END;
  1497. END TraverseScopes;
  1498. PROCEDURE AddRecord*(scope: Scope; rec: Record);
  1499. VAR mod: ModScope;
  1500. BEGIN {EXCLUSIVE}
  1501. mod := scope.module.scope;
  1502. rec.link := mod.records; mod.records := rec;
  1503. INC(mod.nofRecs);
  1504. END AddRecord;
  1505. PROCEDURE CommitParList(scope: ProcScope; level: SHORTINT);
  1506. VAR p: Parameter;
  1507. BEGIN
  1508. p := scope.firstPar;
  1509. WHILE p # NIL DO
  1510. p.level := level; p := p.nextPar
  1511. END
  1512. END CommitParList;
  1513. (** ------------ Const Creation ------------------- *)
  1514. PROCEDURE GetIntType*(i: LONGINT): Struct;
  1515. VAR type: Struct;
  1516. BEGIN
  1517. IF (MIN(SHORTINT) <= i) & (i <= MAX(SHORTINT)) THEN type := Int8
  1518. ELSIF (MIN(INTEGER) <= i) & (i <= MAX(INTEGER)) THEN type := Int16
  1519. ELSE type := Int32
  1520. END;
  1521. RETURN type
  1522. END GetIntType;
  1523. PROCEDURE GetCharType*(i: LONGINT): Struct;
  1524. VAR type: Struct;
  1525. BEGIN
  1526. IF PCM.LocalUnicodeSupport THEN
  1527. IF (0 > i) OR (i > 0FFFFH) THEN type := Char32
  1528. ELSIF (i > 0FFH) THEN type := Char16
  1529. ELSE type := Char8
  1530. END;
  1531. RETURN type
  1532. ELSE
  1533. RETURN Char8
  1534. END;
  1535. END GetCharType;
  1536. PROCEDURE NewIntConst*(i: LONGINT; type: Struct): Const;
  1537. VAR c: Const;
  1538. BEGIN NEW(c); c.int := i; c.type := type; RETURN c
  1539. END NewIntConst;
  1540. PROCEDURE NewInt64Const*(i: HUGEINT): Const;
  1541. VAR c: Const;
  1542. BEGIN NEW(c); c.long := i; c.type := Int64; RETURN c
  1543. END NewInt64Const;
  1544. PROCEDURE NewBoolConst(b: BOOLEAN): Const;
  1545. VAR c: Const;
  1546. BEGIN NEW(c); c.bool := b; c.type := Bool; RETURN c
  1547. END NewBoolConst;
  1548. PROCEDURE NewSetConst*(s: SET): Const;
  1549. VAR c: Const;
  1550. BEGIN NEW(c); c.set := s; c.type := Set; RETURN c
  1551. END NewSetConst;
  1552. PROCEDURE NewFloatConst*(r: LONGREAL; type: Struct): Const;
  1553. VAR c: Const;
  1554. BEGIN
  1555. ASSERT((type = Float32) OR (type = Float64));
  1556. NEW(c); c.real := r; c.type := type; RETURN c
  1557. END NewFloatConst;
  1558. PROCEDURE NewStringConst*(CONST str: ARRAY OF CHAR): Const;
  1559. VAR c: Const; len: LONGINT;
  1560. BEGIN
  1561. len := 0;
  1562. WHILE str[len] # 0X DO INC(len) END;
  1563. NEW(c); NEW(c.str); c.int := len+1; COPY(str, c.str^); c.type := String; RETURN c
  1564. END NewStringConst;
  1565. PROCEDURE NewPtrConst*(p: ANY; type: Struct): Const;
  1566. VAR c: Const;
  1567. BEGIN NEW(c); c.ptr := p; c.type := type; RETURN c
  1568. END NewPtrConst;
  1569. (** fof >> *)
  1570. PROCEDURE MakeArrayType*(len: ARRAY OF LONGINT; dim: LONGINT; base: Struct; basesize: LONGINT): Struct;
  1571. VAR inc: LONGINT; a: EnhArray; i: LONGINT; res: WORD;
  1572. BEGIN
  1573. inc := basesize;
  1574. FOR i := dim - 1 TO 0 BY -1 DO
  1575. NEW( a );
  1576. InitStaticEnhArray( a, len[i], base, {static}, res ); (* temporary ! *)
  1577. a.inc := inc; inc := inc * len[i];
  1578. base := a;
  1579. END;
  1580. RETURN base
  1581. END MakeArrayType;
  1582. PROCEDURE NewArrayConst*( VAR data: ARRAY OF SYSTEM.BYTE; len: ARRAY OF LONGINT; dim: LONGINT; base: Struct; basesize: LONGINT): Const;
  1583. (* create new array constant with dimension LEN(len) und shape len of base type base with size basesize (defined in PCBT) *)
  1584. VAR c: ConstArray; i, lencheck: LONGINT; a: EnhArray;
  1585. res: WORD; inc: LONGINT;
  1586. BEGIN
  1587. ASSERT( dim <= LEN( len ) ); NEW( c );
  1588. NEW( c.data, LEN( data ) );
  1589. SYSTEM.MOVE( ADDRESSOF( data[0] ), ADDRESSOF( c.data[0] ), LEN( data ) );
  1590. NEW( c.len, dim );
  1591. SYSTEM.MOVE( ADDRESSOF( len[0] ), ADDRESSOF( c.len[0] ), SIZEOF( LONGINT ) * dim );
  1592. lencheck := 1; inc := basesize;
  1593. FOR i := dim - 1 TO 0 BY -1 DO
  1594. NEW( a );
  1595. InitStaticEnhArray( a, len[i], base, {static}, res ); (* temporary ! *)
  1596. a.inc := inc; inc := inc * len[i];
  1597. lencheck := lencheck * len[i]; base := a;
  1598. END;
  1599. ASSERT( lencheck * basesize = LEN( data ) );
  1600. c.type := base; RETURN c;
  1601. END NewArrayConst;
  1602. (** << fof *)
  1603. (** ------------ Structure Creation ------------------- *)
  1604. PROCEDURE CheckArrayBase(a: Array; allowedMode: SET; VAR res: WORD);
  1605. VAR base: Array;
  1606. BEGIN
  1607. ASSERT(a.base # NIL, 500);
  1608. IF CheckForRecursion(a.base, a) THEN
  1609. res := RecursiveType;
  1610. a.base := NoType
  1611. END;
  1612. IF (a.base IS Array) THEN
  1613. base := a.base(Array);
  1614. IF ~(base.mode IN allowedMode) THEN
  1615. res := IllegalArrayBase; a.base := Char8
  1616. ELSE
  1617. a.opendim := base.opendim
  1618. END
  1619. (** fof >> *)
  1620. ELSIF a.base IS EnhArray THEN (* mixture of enharrys and arrays is forbidden *) (*fof*)
  1621. res := IllegalMixture;
  1622. (** << fof *)
  1623. END;
  1624. END CheckArrayBase;
  1625. (** fof >> *)
  1626. PROCEDURE CheckEnhArrayBase( a: EnhArray; allowedMode: SET; VAR res: WORD );
  1627. VAR base: EnhArray;
  1628. BEGIN
  1629. ASSERT( a.base # NIL , 500 );
  1630. IF CheckForRecursion( a.base, a ) THEN
  1631. res := RecursiveType; a.base := NoType
  1632. END;
  1633. IF (a.base IS EnhArray) THEN
  1634. base := a.base( EnhArray );
  1635. IF ~(base.mode IN allowedMode) THEN
  1636. res := IllegalArrayBase; a.base := Char8
  1637. ELSE a.opendim := base.opendim; a.dim := base.dim
  1638. END
  1639. ELSIF a.base IS Array THEN (* mixture of enharrys and arrays is forbidden *)
  1640. res := IllegalMixture;
  1641. ELSE a.opendim := 0; a.dim := 0;
  1642. END;
  1643. END CheckEnhArrayBase;
  1644. PROCEDURE ElementType*( a: Struct ): Struct;
  1645. BEGIN
  1646. IF a IS EnhArray THEN
  1647. WHILE (a IS EnhArray) DO a := a( EnhArray ).base; END;
  1648. ELSIF a IS Tensor THEN a := a( Tensor ).base;
  1649. END;
  1650. RETURN a;
  1651. END ElementType;
  1652. (** << fof *)
  1653. PROCEDURE InitOpenArray*(a: Array; base: Struct; VAR res: WORD);
  1654. BEGIN
  1655. res := Ok;
  1656. a.mode := open; a.base := base;
  1657. CheckArrayBase(a, {static, open}, res);
  1658. INC(a.opendim);
  1659. END InitOpenArray;
  1660. PROCEDURE InitStaticArray*(a: Array; len: LONGINT; base: Struct; VAR res: WORD);
  1661. BEGIN
  1662. res := Ok;
  1663. a.mode := static; a.len := len; a.base := base;
  1664. IF len < 0 THEN res := IllegalValue; a.len := 1 END;
  1665. CheckArrayBase(a, {static}, res);
  1666. END InitStaticArray;
  1667. (** fof >> *)
  1668. PROCEDURE InitTensor*( a: Tensor; base: Struct; VAR res: WORD );
  1669. BEGIN
  1670. res := Ok; a.base := base; (* any checks ? *)
  1671. END InitTensor;
  1672. PROCEDURE InitOpenEnhArray*( a: EnhArray; base: Struct; allow: SET; VAR res: WORD ); (*fof*)
  1673. BEGIN
  1674. res := Ok; a.mode := open; a.base := base; a.len := 0;
  1675. CheckEnhArrayBase( a, allow, res ); INC( a.opendim );
  1676. INC( a.dim );
  1677. (* it is not allowed to mix open and static arrays *)
  1678. END InitOpenEnhArray;
  1679. PROCEDURE InitStaticEnhArray*( a: EnhArray; len: LONGINT; base: Struct; allow: SET; VAR res: WORD ); (*fof*)
  1680. BEGIN
  1681. res := Ok; a.mode := static; a.len := len; a.base := base;
  1682. IF len < 0 THEN res := IllegalValue; a.len := 1 END;
  1683. CheckEnhArrayBase( a, allow, res ); INC( a.dim );
  1684. (* it is not allowed to mix open and static arrays *)
  1685. END InitStaticEnhArray;
  1686. PROCEDURE SetEnhArrayLen*( a: EnhArray; len: LONGINT ); (* len is write protected, programmers must know what they are doing *)
  1687. BEGIN
  1688. a.len := len;
  1689. END SetEnhArrayLen;
  1690. PROCEDURE SetEnhArrayInc*( a: EnhArray; inc: LONGINT ); (* inc is write protected, programmers must know what they are doing *)
  1691. BEGIN
  1692. a.inc := inc;
  1693. END SetEnhArrayInc;
  1694. PROCEDURE BuildOpenArray*( base: Struct; dim: LONGINT ): Struct;
  1695. VAR a: EnhArray; res: WORD;
  1696. BEGIN
  1697. IF dim > 0 THEN
  1698. base := BuildOpenArray( base, dim - 1 ); NEW( a );
  1699. InitOpenEnhArray( a, base, {open}, res ); RETURN a;
  1700. ELSE RETURN base;
  1701. END;
  1702. END BuildOpenArray;
  1703. PROCEDURE BuildTensor*( base: Struct ): Tensor;
  1704. VAR a: Tensor; res: WORD;
  1705. BEGIN
  1706. NEW( a ); InitTensor( a, base, res ); RETURN a;
  1707. END BuildTensor;
  1708. (** << fof *)
  1709. PROCEDURE CopyMethods(scope: RecScope; CONST intf: Interfaces; isImported: BOOLEAN);
  1710. VAR i: LONGINT; res: WORD; rs: RecScope; s: ProcScope; m: Method; par: Parameter;
  1711. f: SET;
  1712. BEGIN
  1713. i := 0;
  1714. WHILE (i < LEN(intf)) & (intf[i] # NIL) DO
  1715. rs := intf[i].baseR.scope;
  1716. IF ~isImported THEN rs.Await(procdeclared) END;
  1717. m := rs.firstMeth;
  1718. WHILE m # NIL DO
  1719. NEW(s); InitScope(s, scope, {AutodeclareSelf}, FALSE); SetOwner(s);
  1720. par := m.scope.firstPar;
  1721. WHILE (par # m.scope.lastPar) DO
  1722. s.CreatePar(par.vis, par.ref, par.name, par.flags, par.type, 0 (*fof *), res); ASSERT(res = 0);
  1723. par := par.nextPar
  1724. END;
  1725. f := m.flags;
  1726. scope.CreateProc(m.name, m.vis, m.flags-{used}+{copy}, s, m.type, 0(*fof*), res);
  1727. IF res = 1 THEN
  1728. KernelLog.String("CopyMethods: Duplicate Interface Method"); KernelLog.Ln;
  1729. res := 0
  1730. END;
  1731. ASSERT(res = 0);
  1732. m := m.nextMeth;
  1733. END;
  1734. INC(i);
  1735. END;
  1736. END CopyMethods;
  1737. PROCEDURE InitRecord*(r: Record; base: Struct; CONST intf: Interfaces; scope: RecScope; isInterface, isImported, isDynamic: BOOLEAN; VAR res: WORD);
  1738. VAR i: LONGINT;
  1739. BEGIN
  1740. res := Ok;
  1741. ASSERT(base # NIL, 500);
  1742. ASSERT(scope # NIL, 501);
  1743. ASSERT((scope.owner = NIL) OR (scope.owner = r), 502);
  1744. (*r.ptr := NIL;*) r.brec := NIL; r.btyp := base; r.scope := scope;
  1745. scope.owner := r; r.imported := isImported;
  1746. IF isInterface THEN
  1747. INCL(r.mode, interface);
  1748. CopyMethods(scope, intf, isImported)
  1749. END;
  1750. IF base IS Pointer THEN
  1751. base := base(Pointer).base;
  1752. IF ~isDynamic THEN res := ObjectOnly END
  1753. END;
  1754. IF base IS Record THEN
  1755. IF isInterface THEN res := 601(*NotImplemented*) END;
  1756. IF CheckForRecursion(base, r) THEN
  1757. res := RecursiveType;
  1758. base := NoType
  1759. END;
  1760. WITH base: Record DO
  1761. RecordSizeUsed(base);
  1762. r.brec := base
  1763. END
  1764. ELSIF (base # NoType) & (SuperclassAvailable IN scope.flags) THEN
  1765. res := NotAType;
  1766. r.btyp := NoType
  1767. END;
  1768. i := 0;
  1769. WHILE (i < LEN(intf)) & (intf[i] # NIL) DO
  1770. IF ~(interface IN intf[i].baseR.mode) THEN res := 602(*NotImplemented*) END;
  1771. INC(i)
  1772. END;
  1773. NEW(r.intf, i);
  1774. WHILE (i > 0) DO DEC(i); r.intf[i] := intf[i] END
  1775. END InitRecord;
  1776. PROCEDURE NewRecord*(base: Struct; scope: RecScope; flags: SET; imported: BOOLEAN; VAR res: WORD): Record;
  1777. VAR r: Record; intf: ARRAY 1 OF Interface;
  1778. BEGIN
  1779. ASSERT(flags - {SystemType} = {}, 500);
  1780. res := Ok;
  1781. NEW(r); InitRecord(r, base, intf, scope, FALSE, imported, FALSE, res);
  1782. r.flags := flags;
  1783. NEW(r.intf, 0);
  1784. RETURN r
  1785. END NewRecord;
  1786. (** fof >> *)
  1787. PROCEDURE InitCustomArray*(r: CustomArray; base: Struct; dim: LONGINT;scope: CustomArrayScope; VAR res: WORD);
  1788. VAR i: LONGINT;intf: ARRAY 1 OF Interface;
  1789. BEGIN
  1790. InitRecord(r,NoType, intf, scope, FALSE, FALSE, FALSE, res);
  1791. r.dim := dim; r.etyp := base;
  1792. END InitCustomArray;
  1793. PROCEDURE NewCustomArray*(base: Struct; dim: LONGINT; scope: CustomArrayScope; VAR res: WORD): Pointer;
  1794. VAR p: Pointer; r: CustomArray;
  1795. BEGIN
  1796. res := Ok;
  1797. ASSERT(base # NIL, 500);
  1798. ASSERT(scope # NIL, 501);
  1799. NEW(p); NEW(r); InitCustomArray(r, base, dim, scope, res);
  1800. r.ptr := p; p.base := r; p.baseR := r;
  1801. RETURN p
  1802. END NewCustomArray;
  1803. (** << fof *)
  1804. PROCEDURE NewClass*(base: Struct; CONST implements: Interfaces; scope: RecScope; imported: BOOLEAN; VAR res: WORD): Pointer;
  1805. VAR p: Pointer; r: Record;
  1806. BEGIN
  1807. res := Ok;
  1808. ASSERT(base # NIL, 500);
  1809. ASSERT(scope # NIL, 501);
  1810. NEW(p); NEW(r); InitRecord(r, base, implements, scope, FALSE, imported, TRUE, res);
  1811. INCL(r.mode, class);
  1812. r.ptr := p; p.base := r; p.baseR := r;
  1813. (*
  1814. IF (r.brec # NIL) & ~(class IN r.brec.mode) THEN PCM.Error(pos, 200, "base class is not a class") END;
  1815. *)
  1816. RETURN p
  1817. END NewClass;
  1818. PROCEDURE NewInterface*(CONST implements: Interfaces; scope: RecScope; imported: BOOLEAN; VAR res: WORD): Pointer;
  1819. VAR p: Pointer; r: Record;
  1820. BEGIN
  1821. res := Ok;
  1822. ASSERT(scope # NIL, 501);
  1823. NEW(p); NEW(r);
  1824. r.ptr := p; p.base := r; p.baseR := r;
  1825. InitRecord(r, NoType, implements, scope, TRUE, imported, TRUE, res);
  1826. RETURN p
  1827. END NewInterface;
  1828. PROCEDURE InitPointer*(ptr: Pointer; base: Struct; VAR res: WORD);
  1829. BEGIN
  1830. res := Ok;
  1831. ASSERT(base # NIL, 500);
  1832. ASSERT(ptr.base = NIL, 501);
  1833. ptr.base := base;
  1834. IF (base IS Record) THEN
  1835. WITH base: Record DO
  1836. ptr.baseR := base;
  1837. IF (base.ptr = NIL) & (base.owner = NIL) & (base.scope = NIL) THEN (*rec not initialized yet!*)
  1838. base.ptr := ptr;
  1839. (*PCM.LogWLn; PCM.LogWStr("PCT.InitPointer: setting record.ptr");*)
  1840. END
  1841. END
  1842. ELSIF base IS Array THEN
  1843. ptr.baseA := base(Array);
  1844. ELSE
  1845. res := IllegalPointerBase;
  1846. ptr.base := UndefType;
  1847. END;
  1848. (*
  1849. ELSIF ~((base = UndefType) OR (base IS Array)) THEN
  1850. res := IllegalPointerBase;
  1851. ptr.base := UndefType
  1852. ELSE
  1853. ptr.baseA := base(Array)
  1854. END;
  1855. *)
  1856. END InitPointer;
  1857. PROCEDURE InitDelegate*(p: Delegate; return: Struct; scope: ProcScope; flags: SET; VAR res: WORD);
  1858. BEGIN
  1859. ASSERT(return # NIL, 500);
  1860. ASSERT(scope # NIL, 501);
  1861. ASSERT(scope.ownerS = NIL, 502);
  1862. ASSERT(scope.ownerO = NIL, 503);
  1863. ASSERT(flags - {StaticMethodsOnly, RealtimeProcType (* ug *), WinAPIParam, CParam(* fof for Linux *)} = {}, 504); (* ejz *)
  1864. p.return := return; p.scope := scope; scope.ownerS := p;
  1865. p.flags := flags;
  1866. IF ~IsLegalReturnType(return) THEN
  1867. res := 603(*NotImplemented*); p.return := NoType
  1868. END;
  1869. ASSERT(p.scope # NIL, 504);
  1870. CommitParList(scope, 0)
  1871. END InitDelegate;
  1872. (** ------------ Symbol Creation ------------------- *)
  1873. PROCEDURE InitSymbol*(o: Symbol; name: StringIndex; vis: SET; type: Struct);
  1874. BEGIN ASSERT(o # NIL); o.name := name; o.type := type; o.vis := vis
  1875. END InitSymbol;
  1876. PROCEDURE InitType*(t: Type; name: StringIndex; vis: SET; type: Struct); (** for PCOM object comparison - don't insert in scope *)
  1877. BEGIN
  1878. InitSymbol(t, name, vis, type);
  1879. IF type.owner = NIL THEN type.owner := t END;
  1880. END InitType;
  1881. PROCEDURE NewValue*(name: StringIndex; vis: SET; c: Const): Value; (** for PCOM object comparison - don't insert in scope *)
  1882. VAR v: Value;
  1883. BEGIN
  1884. NEW(v); InitSymbol(v, name, vis, c.type); v.const := c;
  1885. IF c.owner = NIL THEN c.owner := v END;
  1886. RETURN v
  1887. END NewValue;
  1888. PROCEDURE CheckVar(v: Variable; allowedArray: SET; allowedEnhArray: SET; (* fof *) VAR res: WORD);
  1889. BEGIN
  1890. IF (v.type IS Array) & ~(v.type(Array).mode IN allowedArray) THEN
  1891. res := IllegalType; v.type := UndefType
  1892. (*
  1893. ELSIF (v.vis - Internal # {}) & ((v.type = Char16) OR (v.type = Char32)) THEN
  1894. res := 200; v.vis := Internal
  1895. *)
  1896. (** fof >> *)
  1897. ELSIF (v.type IS EnhArray) & ~(v.type( EnhArray ).mode IN allowedEnhArray) THEN
  1898. res := IllegalType; v.type := UndefType
  1899. (** << fof *)
  1900. END;
  1901. END CheckVar;
  1902. PROCEDURE NewGlobalVar*(vis: SET; name: LONGINT; flags: SET; type: Struct; VAR res: WORD): GlobalVar; (** for PCOM object comparison - don't insert in scope *)
  1903. VAR v: GlobalVar;
  1904. BEGIN
  1905. res := Ok;
  1906. NEW(v); InitSymbol(v, name, vis, type); v.flags := flags; CheckVar(v, {static}, {static} (* fof *) ,res); RETURN v
  1907. END NewGlobalVar;
  1908. PROCEDURE InitProc(p: Proc; vis: SET; name: StringIndex; scope: ProcScope; return: Struct; VAR res: WORD);
  1909. VAR o: Proc;
  1910. BEGIN
  1911. ASSERT(return # NIL, 500);
  1912. ASSERT(scope # NIL, 501);
  1913. ASSERT(scope.ownerS = NIL, 502);
  1914. ASSERT(scope.ownerO = NIL, 503);
  1915. InitSymbol(p, name, vis, return); p.scope := scope; scope.ownerO := p;
  1916. IF ~IsLegalReturnType(return) THEN
  1917. res := 604(*NotImplemented*); p.type := NoType
  1918. (** fof >> *)
  1919. ELSIF ~IsBasic(return) THEN
  1920. p.scope.CreateReturnPar(return,res);
  1921. END;
  1922. (** << fof *)
  1923. p.level := 0;
  1924. IF (scope.parent IS ProcScope) THEN
  1925. o := scope.parent(ProcScope).ownerO;
  1926. p.level := o.level+1
  1927. END;
  1928. CommitParList(scope, p.level);
  1929. IF scope.imported THEN PreAllocate(NIL, scope) ELSE PreAllocate(scope.module.scope, scope) END
  1930. END InitProc;
  1931. PROCEDURE NewProc*(vis: SET; name: StringIndex; flags: SET; scope: ProcScope; return: Struct; VAR res: WORD): Proc; (** for PCOM object comparison - don't insert in scope *)
  1932. VAR p: Proc; i: LONGINT;
  1933. BEGIN
  1934. res := Ok;
  1935. NEW(p); InitProc(p, vis, name, scope, return, res);
  1936. IF flags - {Inline, Operator, RealtimeProc} # {} THEN
  1937. res := 605(*NotImplemented*)
  1938. END;
  1939. IF RealtimeProc IN flags THEN INCL(p.scope.flags, RealtimeScope) END; (* ug: realtime property of procedure is copied to scope *)
  1940. p.flags := flags;
  1941. RETURN p
  1942. END NewProc;
  1943. PROCEDURE FindOverwrittenMethod(owner: Record; name: StringPool.Index; mscope: ProcScope; VAR res: WORD): Method;
  1944. VAR pars: ARRAY 32 OF Struct; i, parCount: LONGINT; obj: Symbol; super: Method; par: Parameter;
  1945. BEGIN
  1946. IF owner.brec # NIL THEN
  1947. IF Overloading IN owner.brec.scope.module.scope.flags THEN
  1948. ASSERT(mscope.lastPar.name = SelfName);
  1949. parCount := mscope.parCount-1;
  1950. i := 0; par := mscope.firstPar;
  1951. WHILE i < parCount DO pars[i] := par.type; INC(i); par := par.nextPar END;
  1952. ASSERT(par = mscope.lastPar);
  1953. obj := FindProcedure(owner.scope, owner.brec.scope, name, parCount, pars, TRUE, FALSE);
  1954. ELSE
  1955. obj := Find(owner.scope, owner.brec.scope, name, procdeclared, FALSE)
  1956. END;
  1957. IF obj # NIL THEN
  1958. IF obj IS Method THEN super := obj(Method) ELSE res := DuplicateSymbol END
  1959. END
  1960. END;
  1961. RETURN super
  1962. END FindOverwrittenMethod;
  1963. PROCEDURE NewMethod(vis: SET; name: StringIndex; flags: SET; scope: ProcScope; return: Struct; boundTo: Record; pos: LONGINT; VAR res: WORD): Method;
  1964. VAR p: Method; faulty: Symbol; initializer: BOOLEAN;
  1965. BEGIN
  1966. res := Ok;
  1967. ASSERT(boundTo # NIL, 500);
  1968. initializer := FALSE;
  1969. IF Constructor IN flags THEN
  1970. initializer := TRUE; EXCL(flags, Constructor); vis := Public
  1971. END;
  1972. NEW(p);
  1973. IF Indexer IN flags THEN
  1974. IF flags -{copy, NonVirtual, Operator, Indexer, Inline} # {} THEN res := 606(*NotImplemented*) END;
  1975. ELSE
  1976. IF flags -{copy, NonVirtual, RealtimeProc} # {} THEN res := 606(*NotImplemented*) END;
  1977. END;
  1978. p.boundTo := boundTo;
  1979. IF (SuperclassAvailable IN boundTo.scope.flags) & ~(NonVirtual IN flags) THEN
  1980. p.super := FindOverwrittenMethod(boundTo, name, scope, res);
  1981. IF (p.super # NIL) & (RealtimeProc IN p.super.flags) THEN (* realtime property of superclass method is inherited *)
  1982. INCL(flags, RealtimeProc)
  1983. END;
  1984. IF (p.super # NIL) THEN (* export if supermethod has been exported *)
  1985. IF (p.super.vis * Public # {}) & (vis*Public = {}) THEN
  1986. vis := vis + p.super.vis;
  1987. (*
  1988. PCM.Warning(Streams.Invalid,pos,"auto-export of overwritten exported method");
  1989. *)
  1990. END;
  1991. END;
  1992. END;
  1993. IF AutodeclareSelf IN scope.flags THEN
  1994. IF (boundTo.ptr # NIL) & ((p.super = NIL) OR ~p.super.self.ref) THEN
  1995. IF name = 0 THEN
  1996. PCM.LogWLn; PCM.LogWStr("PtrSelf "); PCM.LogWStr0(name); PCM.LogWNum(name);
  1997. HALT(MAX(INTEGER))
  1998. END;
  1999. scope.CreatePar(Internal, FALSE, SelfName, {}, boundTo.ptr, 0,(* fof *) res)
  2000. ELSE
  2001. PCM.LogWLn; PCM.LogWStr("RecSelf "); PCM.LogWStr0(name); PCM.LogWNum(name);
  2002. HALT(MAX(INTEGER));
  2003. scope.CreatePar(Internal, TRUE, SelfName, {}, boundTo, 0,(* fof *) res)
  2004. END
  2005. END;
  2006. p.self := scope.last(Parameter);
  2007. ASSERT(p.self.name = SelfName);
  2008. InitProc(p, vis, name, scope, return, res); (*InitProc creates the param-list, thus self must be already allocated*)
  2009. IF RealtimeProc IN flags THEN INCL(p.scope.flags, RealtimeScope) END; (* ug: realtime property of method is copied to scope *)
  2010. p.flags := flags;
  2011. IF p.super # NIL THEN
  2012. p.Use;
  2013. IF (Indexer IN flags) & (Inline IN p.super.flags) THEN
  2014. res := 992
  2015. ELSIF ~ParameterMatch(scope.firstPar, p.super.scope.firstPar, faulty) THEN
  2016. res := ParameterMismatch
  2017. ELSIF ~EqualTypes(return, p.super.type) THEN
  2018. res := ReturnMismatch
  2019. END
  2020. END;
  2021. IF p.name = BodyName THEN
  2022. IF (boundTo.scope.body = NIL) & ((boundTo.ptr # NIL) OR ~(SuperclassAvailable IN boundTo.scope.flags)) THEN
  2023. boundTo.scope.body := p
  2024. ELSE
  2025. res := ObjectOnly
  2026. END
  2027. ELSIF initializer THEN
  2028. IF boundTo.scope.initproc # NIL THEN
  2029. res := MultipleInitializers
  2030. ELSIF (boundTo.ptr = NIL) & (SuperclassAvailable IN boundTo.scope.flags) THEN
  2031. res := InitializerOutsideObject
  2032. ELSE
  2033. boundTo.scope.initproc := p
  2034. END
  2035. END;
  2036. RETURN p
  2037. END NewMethod;
  2038. PROCEDURE NewModule*(name: StringIndex; imported: BOOLEAN; flags: SET; scope: ModScope): Module;
  2039. VAR m: Module;
  2040. BEGIN
  2041. ASSERT(scope # NIL, 500);
  2042. ASSERT(flags - {used} = {}, 501);
  2043. NEW(m);
  2044. m.name := name;
  2045. m.scope := scope; m.imported := imported; scope.module := m;
  2046. m.vis := Internal;
  2047. IF scope.owner = NIL THEN
  2048. scope.owner := m;
  2049. IF imported THEN PreAllocate(NIL, scope) ELSE PreAllocate(scope, scope) END
  2050. ELSE
  2051. m.adr := scope.owner.adr; (*avoid replication of adr!*)
  2052. m.sym := scope.owner.sym
  2053. END;
  2054. m.flags := flags;
  2055. RETURN m
  2056. END NewModule;
  2057. (** ---------------- Special Functions --------------------- *)
  2058. PROCEDURE SetMode*(scope: Scope; mode: LONGINT; VAR res: WORD);
  2059. BEGIN
  2060. res := Ok;
  2061. IF mode = exclusive THEN
  2062. WHILE scope IS ProcScope DO scope := scope.parent END;
  2063. IF scope IS RecScope THEN
  2064. INCL(scope(RecScope).owner.mode, mode)
  2065. END
  2066. ELSIF (mode IN {safe, active}) & (scope IS ProcScope) THEN
  2067. WITH scope: ProcScope DO
  2068. IF scope.ownerO.name = BodyName THEN
  2069. INCL(scope.ownerO(Method).boundTo.mode, mode)
  2070. ELSE
  2071. res := 607(*NotImplemented*)
  2072. END
  2073. END
  2074. ELSE
  2075. res := 608(*NotImplemented*)
  2076. END
  2077. END SetMode;
  2078. PROCEDURE SetProcFlag*(scope: Scope; flag: LONGINT; VAR res: WORD);
  2079. BEGIN
  2080. IF (flag = RealtimeProc) & (scope IS ProcScope) THEN
  2081. WITH scope: ProcScope DO
  2082. IF scope.ownerO.name = BodyName THEN
  2083. INCL(scope.ownerO.flags, flag);
  2084. INCL(scope.flags, RealtimeScope) (* Realtime property is propagated to scope *)
  2085. ELSE
  2086. res := 607 (* NotImplemented *)
  2087. END
  2088. END
  2089. ELSE
  2090. res := 608 (* NotImplemented *)
  2091. END
  2092. END SetProcFlag;
  2093. PROCEDURE IsRealtimeScope*(scope: Scope): BOOLEAN;
  2094. BEGIN
  2095. RETURN RealtimeScope IN scope.flags
  2096. END IsRealtimeScope;
  2097. PROCEDURE RecordSizeUsed*(rec: Record);
  2098. BEGIN rec.pbused := TRUE;
  2099. IF rec.owner # NIL THEN
  2100. rec.owner.Use
  2101. ELSIF (rec.ptr # NIL) & (rec.ptr.owner # NIL) THEN
  2102. rec.ptr.owner.Use
  2103. END
  2104. END RecordSizeUsed;
  2105. (** fof 070731 >> *)
  2106. PROCEDURE Written*(s: Symbol);
  2107. BEGIN
  2108. s.Write();
  2109. END Written;
  2110. PROCEDURE RemoveWarning*(s: Symbol);
  2111. BEGIN
  2112. s.pos := 0;
  2113. END RemoveWarning;
  2114. (** << fof *)
  2115. PROCEDURE GetTypeName*(type: Struct; VAR name: ARRAY OF CHAR);
  2116. BEGIN
  2117. name[0] := 0X;
  2118. IF type.owner # NIL THEN
  2119. StringPool.GetString(type.owner.name, name)
  2120. ELSIF (type IS Record) THEN
  2121. WITH type: Record DO
  2122. IF type.ptr # NIL THEN GetTypeName(type.ptr, name) END
  2123. END
  2124. END;
  2125. END GetTypeName;
  2126. (** GetScopeName - return the name of the scope owner *)
  2127. PROCEDURE GetScopeName*(scope: Scope; VAR name: ARRAY OF CHAR);
  2128. BEGIN
  2129. IF scope IS ProcScope THEN
  2130. StringPool.GetString(scope(ProcScope).ownerO.name, name)
  2131. ELSIF scope IS RecScope THEN
  2132. GetTypeName(scope(RecScope).owner, name)
  2133. ELSIF scope IS ModScope THEN
  2134. StringPool.GetString(scope(ModScope).owner.name, name)
  2135. ELSE
  2136. HALT(99)
  2137. END
  2138. END GetScopeName;
  2139. (** ---------------- Module Database ------------------- *)
  2140. (* Register - add a module to the database *)
  2141. PROCEDURE Register*(root: ModuleDB; m: Module);
  2142. VAR p, q: Module;
  2143. BEGIN
  2144. q := root; p := root.next;
  2145. WHILE (p # NIL) & (StringPool.CompareString(p.name, m.name) < 0) DO q := p; p := p.next END;
  2146. IF (p = NIL) OR (p.name # m.name) THEN
  2147. m.next := p;
  2148. q.next := m
  2149. ELSE
  2150. HALT(99) (*duplicate entry*)
  2151. END
  2152. END Register;
  2153. (* Unregister - remove a module from the database *)
  2154. PROCEDURE Unregister*(root: ModuleDB; name: StringPool.Index);
  2155. VAR p: Module;
  2156. BEGIN {EXCLUSIVE}
  2157. p := root;
  2158. WHILE (p.next # NIL) & (p.next.name # name) DO p := p.next END;
  2159. IF p.next # NIL THEN
  2160. p.next := p.next.next
  2161. END
  2162. END Unregister;
  2163. (* Retrieve - find a module in the database *)
  2164. PROCEDURE Retrieve*(root: ModuleDB; name: StringPool.Index): Module;
  2165. VAR p: Module;
  2166. BEGIN
  2167. p := root.next;
  2168. WHILE (p # NIL) & (StringPool.CompareString(p.name, name) < 0) DO p := p.next END;
  2169. IF (p = NIL) OR (p.name # name) THEN
  2170. RETURN NIL
  2171. ELSE
  2172. RETURN p
  2173. END
  2174. END Retrieve;
  2175. (* Enumerate - Traverse database *)
  2176. PROCEDURE Enumerate*(root: ModuleDB; EnumProc: PROCEDURE {DELEGATE} (m: Module));
  2177. VAR p: Module;
  2178. BEGIN
  2179. p := root.next;
  2180. WHILE (p # NIL) DO EnumProc(p); p := p.next END
  2181. END Enumerate;
  2182. PROCEDURE InitDB*(VAR root: ModuleDB);
  2183. BEGIN NEW(root)
  2184. END InitDB;
  2185. (** ---------------- Plug-in Management ------------------- *)
  2186. PROCEDURE AddImporter*(p: ImporterPlugin);
  2187. VAR i: LONGINT;
  2188. BEGIN
  2189. FOR i := 0 TO nofImportPlugins-1 DO ASSERT(import[i] # p) END;
  2190. import[nofImportPlugins] := p;
  2191. INC(nofImportPlugins)
  2192. END AddImporter;
  2193. PROCEDURE RemoveImporter*(p: ImporterPlugin);
  2194. VAR i: LONGINT;
  2195. BEGIN
  2196. i := 0;
  2197. WHILE (i < nofImportPlugins) & (import[i] # p) DO INC(i) END;
  2198. ASSERT(i < nofImportPlugins);
  2199. DEC(nofImportPlugins);
  2200. IF i # nofImportPlugins THEN import[i] := import[nofImportPlugins] END;
  2201. import[nofImportPlugins] := NIL
  2202. END RemoveImporter;
  2203. (* ---------------- Module Initialisation ------------------- *)
  2204. PROCEDURE DummyAllocate(context, scope: Scope; hiddenVarsOnly: BOOLEAN (* ug *));
  2205. END DummyAllocate;
  2206. (* ug *)
  2207. PROCEDURE DummyPrePostAllocate(context, scope: Scope);
  2208. END DummyPrePostAllocate;
  2209. PROCEDURE NewBasic(m: Module; CONST name: ARRAY OF CHAR): Basic;
  2210. VAR b: Basic; res: WORD;
  2211. BEGIN
  2212. NEW(b);
  2213. m.scope.CreateType(StringPool.GetIndex1(name), Public, b, 0 (* fof *), res); ASSERT(res = Ok);
  2214. RETURN b
  2215. END NewBasic;
  2216. PROCEDURE Init;
  2217. VAR scope: ModScope; idx: StringIndex; res: WORD;
  2218. BEGIN
  2219. InitDB(database);
  2220. BodyName := StringPool.GetIndex1(BodyNameStr);
  2221. SelfName := StringPool.GetIndex1(SelfNameStr);
  2222. Anonymous := StringPool.GetIndex1(AnonymousStr);
  2223. PtrReturnType := StringPool.GetIndex1(PtrReturnTypeStr); (* ug *)
  2224. NEW(scope); InitScope(scope, NIL, {}, TRUE); scope.ownerID := 0; (*fof: global scope modified by PCB.Body => not guaranteed to be the same process ! *)
  2225. idx := StringPool.GetIndex1("Universe");
  2226. Universe := NewModule(idx, TRUE, {}, scope);
  2227. NEW(scope); InitScope(scope, NIL, {}, TRUE); scope.ownerID := 0; (*fof: global scope modified by PCB.Body => not guaranteed to be the same process ! *)
  2228. idx := StringPool.GetIndex1("SYSTEM");
  2229. System := NewModule(idx, TRUE, {}, scope);
  2230. (* don't commit scopes, leave this to PCB who will insert data *)
  2231. Byte := NewBasic(System, "BYTE");
  2232. Bool := NewBasic(Universe, "BOOLEAN");
  2233. CharType[0] := NewBasic(Universe, "CHAR"); Char8 := CharType[0];
  2234. IF PCM.LocalUnicodeSupport THEN
  2235. Universe.scope.CreateType(StringPool.GetIndex1("CHAR8"), Public, Char8, 0(*fof*), res); ASSERT(res = Ok);
  2236. CharType[1] := NewBasic(Universe, "CHAR16"); Char16 := CharType[1];
  2237. CharType[2] := NewBasic(Universe, "CHAR32"); Char32 := CharType[2]
  2238. END;
  2239. NumericType[0] := NewBasic(Universe, "SHORTINT"); Int8 := NumericType[0];
  2240. NumericType[1] := NewBasic(Universe, "INTEGER"); Int16 := NumericType[1];
  2241. NumericType[2] := NewBasic(Universe, "LONGINT"); Int32 := NumericType[2];
  2242. NumericType[3] := NewBasic(Universe, "HUGEINT"); Int64 := NumericType[3];
  2243. NumericType[4] := NewBasic(Universe, "REAL"); Float32 := NumericType[4];
  2244. NumericType[5]:= NewBasic(Universe, "LONGREAL"); Float64 := NumericType[5];
  2245. Set := NewBasic(Universe, "SET");
  2246. Ptr := NewBasic(Universe, "ANY");
  2247. NEW(String);
  2248. NEW(NilType);
  2249. NEW(NoType);
  2250. NEW(UndefType);
  2251. True := NewBoolConst(TRUE);
  2252. False := NewBoolConst(FALSE);
  2253. (* actual size will be patched later *)
  2254. System.scope.CreateType (StringPool.GetIndex1("ADDRESS"), Public, Int32, 0, res); ASSERT(res = Ok);
  2255. SystemAddress := System.scope.lastType;
  2256. (* actual size will be patched later *)
  2257. System.scope.CreateType (StringPool.GetIndex1("SIZE"), Public, Int32, 0, res); ASSERT(res = Ok);
  2258. SystemSize := System.scope.lastType;
  2259. END Init;
  2260. BEGIN
  2261. PreAllocate := DummyPrePostAllocate; (* ug *) Allocate := DummyAllocate; PostAllocate := DummyPrePostAllocate; (* ug *)
  2262. Init
  2263. END PCT.
  2264. (**
  2265. Notes:
  2266. ImportPlugins:
  2267. 1. must call self.AddImport(new); done in the loader to break possible recursive import cycles
  2268. the import procedure first look into the list of already imported modules (self.imports), otherwise
  2269. calls the loaders.
  2270. *)
  2271. (*
  2272. Symbol Table.
  2273. scope states:
  2274. description searching from child
  2275. none
  2276. checking all declarations parsed allowed, to parent if declaration
  2277. declared declarations allocated
  2278. variables allocated, locally declared types sized
  2279. complete procedure parsed + allocated
  2280. Scoping, object visibility rules and invariants
  2281. Oberon: a symbol must be declared before its use. The symbol in the nearest scope
  2282. is used. Exceptions: pointer to.
  2283. Active Oberon: The symbol in the nearest scope is used.
  2284. This compiler: The symbol in the nearest scope is used. Exception: local scope, a
  2285. symbol must be declared before its use or in a parent scope. Exception: pointers.
  2286. Also declaration sequence as in Oberon: first const/type/var, then procs
  2287. Implications:
  2288. * no fixups needed (but for pointers)
  2289. * record structures cannot be recursive.
  2290. * check on declaration
  2291. * allows early continuation in parsing
  2292. Known problems:
  2293. * during declaration parsing, search upper scope only for declarations, not
  2294. procedures (declarations cannot reference a procedure). Delay check for
  2295. shadowing.
  2296. * during procedure parsing, search upper scope for every symbol
  2297. * mutual reference: record inside a procedure needs a symbol in parent scope:
  2298. procedure cannot allocate its own data as long as record (fields) are not
  2299. completly parsed, but this can only happen when procedure declarations are
  2300. allocated. Workaround: state "declared" and "allocated". "declared" allows
  2301. search of symbols.
  2302. * Allocation / TypeSize:
  2303. records can be linked before they are allocated.
  2304. HowTo:
  2305. Find has a "required state" tag.
  2306. POINTER TO -> local
  2307. in declaration in a Record -> declared
  2308. in declaration otherwise -> allocated
  2309. in implementation -> complete
  2310. Allocation/Procedure:
  2311. call -> adr: on procedure allocation
  2312. vars/params: on scope declarations, only by self+children (parsed only after allocated)
  2313. Module:
  2314. const/type: on module allocation
  2315. vars/: on scope declaration
  2316. Record:
  2317. struct/td: on allocation
  2318. fields: on complete (restrict access!) -> by record parser self
  2319. methods: on complete -> by record parser self
  2320. Database:
  2321. 1 Register, duplicate entries
  2322. Special errors:
  2323. 601 InitRecord interface base is a record
  2324. 602 InitRecord interface is no interface
  2325. 603 InitDelegate illegal return type
  2326. 604 InitProc illegal return type
  2327. 605 NewProc unknown flags
  2328. 606 NewMethod unknown flags
  2329. 607 SetMode only body can be safe or active
  2330. 608 SetMode unknown flag
  2331. *)
  2332. (*
  2333. 03.08.03 prk remove trace trap thrown when base type of record or object did not exists
  2334. 28.12.02 prk NonVirtual flag added
  2335. 02.04.02 prk CreateVar/Proc: if insert fails, don't add the the mod scope's non-sorted lists
  2336. 18.03.02 prk CreateVar/Proc/Par: if insert fails, don't add the the scope's non-sorted lists
  2337. 22.02.02 prk unicode support
  2338. 05.02.02 prk PCT.Find cleanup
  2339. 31.01.02 prk Find: procedure local objects must not see the local variables of the procedure
  2340. 22.11.01 prk improved flag handling
  2341. 19.11.01 prk definitions
  2342. 17.11.01 prk more flexible type handling of integer constants
  2343. 16.11.01 prk constant folding of reals done with maximal precision
  2344. 15.11.01 prk ptr field added to Const, NewPtrConst
  2345. 13.11.01 prk lookup with signature improved
  2346. 22.10.01 prk Insert, invariant check simplified
  2347. 20.10.01 prk ParameterMatch, fail if number of parameters differ
  2348. 05.09.01 prk CanSkipAllocation flag for record scopes
  2349. 29.08.01 prk PCT functions: return "res" instead of taking "pos"
  2350. 27.08.01 prk PCT.Insert removed, use Create procedures instead
  2351. 27.08.01 prk scope.unsorted list removed; use var, proc, const and type lists instead
  2352. 17.08.01 prk overloading
  2353. 09.08.01 prk Symbol Table Loader Plugin
  2354. 11.07.01 prk support for fields and methods with same name in scope
  2355. 06.07.01 prk mark object explicitly
  2356. 05.07.01 prk import interface redesigned
  2357. 04.07.01 prk scope flags added, remove imported
  2358. 02.07.01 prk access flags, new design
  2359. 28.06.01 prk add var and proc counters to scope
  2360. 27.06.01 prk StringPool cleaned up
  2361. 27.06.01 prk ProcScope.CreatePar added
  2362. 21.06.01 prk using stringpool index instead of array of char
  2363. 19.06.01 prk module database
  2364. 15.06.01 prk support for duplicate scope entries
  2365. 14.06.01 prk type descs for dynamic arrays of ptrs generated by the compiler
  2366. 13.06.01 prk ProcScope, parameter list added to avoid parameter testing
  2367. 12.06.01 prk Interfaces
  2368. 06.06.01 prk use string pool for object names
  2369. 17.05.01 prk Delegates
  2370. 08.05.01 prk PCT interface cleanup. Use InitX instead of New*, allows type extension
  2371. 26.04.01 prk separation of RECORD and OBJECT in the parser
  2372. 26.04.01 prk RecordUse, mark type as used too (a type can be allocated even if never referenced directly)
  2373. 20.04.01 prk don't accept static arrays with negative length
  2374. 02.04.01 prk interface cleanup
  2375. 29.03.01 prk Java imports
  2376. 22.02.01 prk self reference for methods: use pointer-based self if possible (i.e. if object is dynamic and method
  2377. definitions in super-class is not record-based).
  2378. 22.02.01 prk delegates
  2379. *)