| 12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317 |
- IMPLEMENTATION MODULE Lower;
- (* Scalar/boolean/control-flow walk (L0-L2): see Lower.def and
- docs/plan-lower.md. The mutually recursive walkers are declared in
- Lower.def (gm2's link pass rejects FORWARD, V3 has no whole-module
- pass, so a definition-visible declaration breaks the cycle). *)
- IMPORT AST, SymTab, QbeGen;
- (* ---------------- self-contained symbol tables (zero SymTab surface) ----
- Flat arrays only, no ARRAY OF RECORD: a record's array field loses its
- length word in static array data, and V3 miscompiles that when the
- field is passed as an open array (docs/wip/nested-array-field-bug.mod).
- Names live in flat CHAR arrays indexed manually at slot * 64. *)
- CONST
- MaxSym = 8192; (* whole-session: >4096 vars/consts/params *)
- MaxName = 63;
- MaxProc = 2048; (* whole-session: the compiler declares >1200 procs *)
- MaxImp = 512; (* per-unit imports *)
- MaxPar = 32;
- HashSize = 16384; (* power of two > MaxSym, MaxProc: open addressing *)
- MaxCFold = 256; (* named compile-time set constants per session *)
- MaxCFoldW = 16; (* mask words (512 bits); wider sets are a 230 *)
- VAR
- symName : ARRAY [0 .. MaxSym * 64 - 1] OF CHAR;
- symKind : ARRAY [0 .. MaxSym - 1] OF INTEGER;
- symTy : ARRAY [0 .. MaxSym - 1] OF SymTab.TypeIndex;
- symVal : ARRAY [0 .. MaxSym * 64 - 1] OF CHAR; (* const value, flat *)
- nSyms : CARDINAL;
- procName : ARRAY [0 .. MaxProc * 64 - 1] OF CHAR;
- procUid : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
- procRes : ARRAY [0 .. MaxProc - 1] OF SymTab.TypeIndex;
- procDep : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
- procExt : ARRAY [0 .. MaxProc - 1] OF BOOLEAN;
- procVa : ARRAY [0 .. MaxProc - 1] OF BOOLEAN; (* C varargs *)
- procNpar : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
- parTy : ARRAY [0 .. MaxProc * MaxPar - 1] OF SymTab.TypeIndex;
- parVar : ARRAY [0 .. MaxProc * MaxPar - 1] OF BOOLEAN;
- parName : ARRAY [0 .. MaxProc * MaxPar * 64 - 1] OF CHAR;
- nProcs : CARDINAL;
- (* Open-addressing indexes into symName/procName: entry = index+1,
- 0 = empty. A whole-session linear scan is too slow (thousands of
- lookups over thousands of entries), so FindSym/FindProc hash. *)
- symHash : ARRAY [0 .. HashSize - 1] OF INTEGER;
- procHash : ARRAY [0 .. HashSize - 1] OF INTEGER;
- (* Per-unit imports (FROM M IMPORT P): the exact proc entry for a
- name, so an unqualified call resolves to the imported proc even
- when another module declares the same name. Reset each unit. *)
- impProc : ARRAY [0 .. MaxImp - 1] OF INTEGER;
- impName : ARRAY [0 .. MaxImp * 64 - 1] OF CHAR;
- nImps : CARDINAL;
- (* Record-array globals too large to expand inline: their template is
- emitted with their data and their elements are initialised by a
- run-time loop (QbeGen.InitRecArray) in the unit's init. Per unit. *)
- nCountInit : CARDINAL;
- countArr : ARRAY [0 .. 63] OF SymTab.Name;
- countTyp : ARRAY [0 .. 63] OF SymTab.TypeIndex;
- (* GOTO/labels: user label name -> QbeGen label, per procedure. *)
- nUserLab : CARDINAL;
- lastView : BOOLEAN; (* last LowerDesign result is a multi-array view *)
- legacyOpen1D : BOOLEAN; (* bootstrap: keep the legacy 1-D open ABI *)
- separateMode : BOOLEAN; (* M2 -c: per-object emission, empty inits *)
- defUnitMode : BOOLEAN; (* lowering the target interface for data *)
- userLabNm : ARRAY [0 .. 255 * 64 - 1] OF CHAR;
- userLabQ : ARRAY [0 .. 255] OF QbeGen.QVal;
- (* Scoping: each symbol records the procedure that owns it (-1 =
- module level); FindSym searches the emitted procedure's chain
- innermost-first so common names (s, i, k) do not collide across
- procedures. *)
- symOwner : ARRAY [0 .. MaxSym - 1] OF INTEGER;
- procParent : ARRAY [0 .. MaxProc - 1] OF INTEGER;
- procSymBase : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
- procSymTop : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
- scopeStack : ARRAY [0 .. MaxProc - 1] OF INTEGER;
- scopeTop : CARDINAL;
- curScopeProc : INTEGER; (* owner while parsing: enclosing proc *)
- emitProc : INTEGER; (* owner while emitting: current proc *)
- qualUid : CARDINAL; (* uid of the last M.P alias resolved *)
- qualIsVar : BOOLEAN; (* last M.P alias is a proc-typed variable *)
- withRec : ARRAY [0 .. 15] OF SymTab.TypeIndex;
- withTop : CARDINAL;
- curMethCls : SymTab.TypeIndex; (* class bound by the last obj.Method *)
- curImplCls : SymTab.TypeIndex; (* class whose implementation is open *)
- curUnitName : SymTab.Name; (* unit being re-emitted (LowerSession) *)
- (* Compile-time set constants (SET CONSTs): masks the grammar computes
- and Lower re-emits as pooled static data. Name-keyed, latest wins,
- exactly like symVal. *)
- cfoldN : CARDINAL;
- cfoldName : ARRAY [0 .. MaxCFold * 64 - 1] OF CHAR;
- cfoldW : ARRAY [0 .. MaxCFold - 1] OF CARDINAL;
- cfoldLo : ARRAY [0 .. MaxCFold - 1] OF INTEGER;
- cfoldMask : ARRAY [0 .. MaxCFold * MaxCFoldW - 1] OF CARDINAL;
- PROCEDURE CopyN (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR);
- VAR i: CARDINAL;
- BEGIN
- i := 0;
- WHILE (i < MaxName) AND (src[i] # CHR(0)) DO dst[i] := src[i]; INC(i) END;
- dst[i] := CHR(0)
- END CopyN;
- PROCEDURE CopySpan (VAR src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR;
- srcOff, dstOff: CARDINAL);
- (* src is a VAR open array on purpose: gm2 copies a value open-array
- formal to a stack VLA of its full length, which overflows the stack
- for the multi-megabyte tables below. *)
- VAR i: CARDINAL;
- BEGIN
- i := 0;
- WHILE (i < MaxName) AND (src[srcOff + i] # CHR(0)) DO
- dst[dstOff + i] := src[srcOff + i]; INC(i)
- END;
- dst[dstOff + i] := CHR(0)
- END CopySpan;
- PROCEDURE HashStr (name: ARRAY OF CHAR): CARDINAL;
- VAR h: CARDINAL; i: CARDINAL;
- BEGIN
- h := 5381; i := 0;
- WHILE (i <= HIGH(name)) AND (name[i] # CHR(0)) DO
- h := (h * 33 + VAL(CARDINAL, ORD(name[i]))) MOD HashSize; INC(i)
- END;
- RETURN h
- END HashStr;
- PROCEDURE SpanEq (VAR arr: ARRAY OF CHAR; off: CARDINAL;
- name: ARRAY OF CHAR): BOOLEAN;
- VAR j: CARDINAL;
- BEGIN
- j := 0;
- WHILE (j < MaxName) AND (name[j] # CHR(0)) DO
- IF arr[off + j] # name[j] THEN RETURN FALSE END;
- INC(j)
- END;
- RETURN arr[off + j] = name[j]
- END SpanEq;
- PROCEDURE HashPut (VAR htab: ARRAY OF INTEGER; VAR names: ARRAY OF CHAR;
- name: ARRAY OF CHAR; idx: CARDINAL);
- (* Insert idx, replacing an existing entry with the same name so the
- latest declaration wins (the linear scan used to search backward). *)
- VAR h: CARDINAL;
- BEGIN
- h := HashStr(name);
- LOOP
- IF htab[h] = 0 THEN htab[h] := VAL(INTEGER, idx) + 1; RETURN END;
- IF SpanEq(names, VAL(CARDINAL, htab[h] - 1) * 64, name) THEN
- htab[h] := VAL(INTEGER, idx) + 1; RETURN
- END;
- h := (h + 1) MOD HashSize
- END
- END HashPut;
- PROCEDURE HashGet (VAR htab: ARRAY OF INTEGER; VAR names: ARRAY OF CHAR;
- name: ARRAY OF CHAR): INTEGER;
- VAR h: CARDINAL;
- BEGIN
- h := HashStr(name);
- LOOP
- IF htab[h] = 0 THEN RETURN -1 END;
- IF SpanEq(names, VAL(CARDINAL, htab[h] - 1) * 64, name) THEN
- RETURN htab[h] - 1
- END;
- h := (h + 1) MOD HashSize
- END
- END HashGet;
- PROCEDURE Reset;
- VAR i: CARDINAL;
- BEGIN
- nSyms := 0; nProcs := 0;
- scopeTop := 0; curScopeProc := -1; emitProc := -1;
- i := 0;
- WHILE i < HashSize DO symHash[i] := 0; procHash[i] := 0; INC(i) END
- END Reset;
- PROCEDURE NoteVar (name: ARRAY OF CHAR; kind: INTEGER; t: SymTab.TypeIndex);
- BEGIN
- IF nSyms >= MaxSym THEN RETURN END;
- CopySpan(name, symName, 0, nSyms * 64);
- symKind[nSyms] := kind; symTy[nSyms] := t;
- symOwner[nSyms] := curScopeProc;
- HashPut(symHash, symName, name, nSyms);
- INC(nSyms)
- END NoteVar;
- PROCEDURE NoteConstVal (val: ARRAY OF CHAR);
- (* Records the evaluated value of the CONST just entered by NoteVar.
- Const values are per-unit and cross-module names collide (every
- module has EOL), so they live here, not in SymTab. *)
- BEGIN
- IF nSyms > 0 THEN CopySpan(val, symVal, 0, (nSyms - 1) * 64) END
- END NoteConstVal;
- PROCEDURE ScopeEnter;
- (* Called at a procedure heading, before NoteProc. Pushes the enclosing
- procedure as the parent scope. *)
- BEGIN
- IF scopeTop <= HIGH(scopeStack) THEN
- scopeStack[scopeTop] := curScopeProc;
- INC(scopeTop)
- END
- END ScopeEnter;
- PROCEDURE ScopeLeave;
- BEGIN
- IF curScopeProc >= 0 THEN procSymTop[curScopeProc] := nSyms END;
- IF scopeTop > 0 THEN
- DEC(scopeTop);
- curScopeProc := scopeStack[scopeTop]
- END
- END ScopeLeave;
- PROCEDURE ReenterScopeProc (ty: INTEGER);
- (* Restores a previously noted proc entry as current for the re-parse
- pass (its registration ran once in the skip pass): pushes the
- current owner and resumes ty, so the Block-end ScopeLeave pops back
- and nested NoteProc/NoteVar attach under the right parent. *)
- BEGIN
- IF (ty < 0) OR (ty >= VAL(INTEGER, nProcs)) THEN RETURN END;
- IF scopeTop <= HIGH(scopeStack) THEN
- scopeStack[scopeTop] := curScopeProc;
- INC(scopeTop)
- END;
- curScopeProc := ty
- END ReenterScopeProc;
- PROCEDURE CurScopeProc (): INTEGER;
- (* The proc entry NoteProc most recently made current (ty stamped on the
- NkProcDecl); captured by the parser's span table for the re-parse. *)
- BEGIN
- RETURN curScopeProc
- END CurScopeProc;
- PROCEDURE NoteProc (name: ARRAY OF CHAR; uid: CARDINAL;
- res: SymTab.TypeIndex; depth: CARDINAL; ext: BOOLEAN);
- BEGIN
- IF nProcs >= MaxProc THEN RETURN END;
- CopySpan(name, procName, 0, nProcs * 64);
- procUid[nProcs] := uid; procRes[nProcs] := res;
- procDep[nProcs] := depth; procExt[nProcs] := ext;
- procNpar[nProcs] := 0;
- procParent[nProcs] := curScopeProc;
- procSymBase[nProcs] := nSyms;
- curScopeProc := VAL(INTEGER, nProcs);
- HashPut(procHash, procName, name, nProcs);
- INC(nProcs)
- END NoteProc;
- PROCEDURE AliasProc (name: ARRAY OF CHAR; uid: CARDINAL;
- res: SymTab.TypeIndex; depth: CARDINAL; ext: BOOLEAN);
- (* A generic procedure formal bound to an actual procedure: add a
- proc-table entry so calls through the formal resolve to the actual,
- without disturbing the scope stack (unlike NoteProc). *)
- BEGIN
- IF nProcs >= MaxProc THEN RETURN END;
- CopySpan(name, procName, 0, nProcs * 64);
- procUid[nProcs] := uid; procRes[nProcs] := res;
- procDep[nProcs] := depth; procExt[nProcs] := ext;
- procNpar[nProcs] := 0;
- procParent[nProcs] := -1;
- procSymBase[nProcs] := nSyms;
- HashPut(procHash, procName, name, nProcs);
- INC(nProcs)
- END AliasProc;
- PROCEDURE MarkProcExternal;
- (* The grammar calls this from the EXTERNAL branch, after NoteProc, so
- the walk records that the callee takes no static link. *)
- BEGIN
- IF nProcs > 0 THEN procExt[nProcs - 1] := TRUE END
- END MarkProcExternal;
- PROCEDURE NoteCProc (name: ARRAY OF CHAR);
- (* FROM libc IMPORT P: note its signature (real prototypes for the
- known C functions, permissive no-result varargs otherwise). NoteProc
- sets curScopeProc; restore it so the next import is not seen as
- nested. *)
- VAR save: INTEGER; i: CARDINAL;
- BEGIN
- save := curScopeProc;
- curScopeProc := -1;
- NoteProc(name, 0, SymTab.ProcRes(name), 0, TRUE);
- curScopeProc := save;
- IF nProcs > 0 THEN
- procExt[nProcs - 1] := TRUE;
- procVa[nProcs - 1] := SymTab.Varargs(name);
- procParent[nProcs - 1] := -1;
- i := 0;
- WHILE i < SymTab.ProcNPar(name) DO
- NoteParam("", SymTab.ParamType(name, i),
- SymTab.ParamIsVar(name, i));
- INC(i)
- END
- END
- END NoteCProc;
- PROCEDURE NoteProcNode (n: AST.Node);
- (* Records the proc-table index in the NkProcDecl's ty field, so
- LowerDecls can find the exact entry. FindProc(name) would return the
- last duplicate (e.g. the two nested `Sep`s), giving the wrong uid and
- the wrong scope for its locals. *)
- BEGIN
- IF nProcs > 0 THEN AST.SetTy(n, VAL(INTEGER, nProcs - 1)) END
- END NoteProcNode;
- PROCEDURE ProcInfoIdx (pi: INTEGER; VAR uid: CARDINAL;
- VAR res: SymTab.TypeIndex; VAR depth: CARDINAL;
- VAR ext: BOOLEAN; VAR npar: CARDINAL): BOOLEAN;
- BEGIN
- IF (pi < 0) OR (pi >= VAL(INTEGER, nProcs)) THEN RETURN FALSE END;
- uid := procUid[pi]; res := procRes[pi]; depth := procDep[pi];
- ext := procExt[pi]; npar := procNpar[pi];
- IF npar > MaxPar THEN npar := MaxPar END;
- RETURN TRUE
- END ProcInfoIdx;
- PROCEDURE ParamInfoIdx (pi: INTEGER; i: CARDINAL;
- VAR t: SymTab.TypeIndex; VAR isVar: BOOLEAN;
- VAR pn: ARRAY OF CHAR): BOOLEAN;
- BEGIN
- IF (pi < 0) OR (pi >= MaxProc)
- OR (i >= procNpar[pi]) OR (procNpar[pi] > MaxPar) THEN
- RETURN FALSE
- END;
- t := parTy[VAL(CARDINAL, pi) * MaxPar + i];
- isVar := parVar[VAL(CARDINAL, pi) * MaxPar + i];
- CopySpan(parName, pn, VAL(CARDINAL, pi) * MaxPar * 64 + i * 64, 0);
- RETURN TRUE
- END ParamInfoIdx;
- PROCEDURE SetProcRes (t: SymTab.TypeIndex);
- BEGIN
- IF nProcs > 0 THEN procRes[nProcs - 1] := t END
- END SetProcRes;
- PROCEDURE NoteParam (name: ARRAY OF CHAR; t: SymTab.TypeIndex; isVar: BOOLEAN);
- VAR j: CARDINAL;
- BEGIN
- IF nProcs = 0 THEN RETURN END;
- j := procNpar[nProcs - 1];
- IF j >= MaxPar THEN RETURN END;
- CopySpan(name, parName, 0, (nProcs - 1) * MaxPar * 64 + j * 64);
- parTy[(nProcs - 1) * MaxPar + j] := t;
- parVar[(nProcs - 1) * MaxPar + j] := isVar;
- procNpar[nProcs - 1] := j + 1
- END NoteParam;
- PROCEDURE NameEq (i: CARDINAL; name: ARRAY OF CHAR): BOOLEAN;
- VAR j: CARDINAL;
- BEGIN
- j := 0;
- WHILE (j < MaxName) AND (name[j] # CHR(0)) DO
- IF symName[i * 64 + j] # name[j] THEN RETURN FALSE END;
- INC(j)
- END;
- RETURN symName[i * 64 + j] = name[j]
- END NameEq;
- PROCEDURE FindSym (name: ARRAY OF CHAR; VAR kind: INTEGER;
- VAR t: SymTab.TypeIndex): BOOLEAN;
- (* Locals/params of the emitted procedure (and its enclosing procedures)
- shadow module-level symbols, so walk the scope chain innermost-first
- and only then fall back to the hash for a module-level symbol. *)
- VAR i: INTEGER; owner: INTEGER;
- BEGIN
- owner := emitProc;
- WHILE owner >= 0 DO
- (* procSymTop is unset for headings that never ScopeLeave (class
- method declarations); fall back to the whole table then. *)
- IF procSymTop[owner] > 0 THEN
- i := VAL(INTEGER, procSymTop[owner]) - 1
- ELSE i := VAL(INTEGER, nSyms) - 1
- END;
- WHILE i >= VAL(INTEGER, procSymBase[owner]) DO
- IF (symOwner[i] = owner) AND NameEq(VAL(CARDINAL, i), name) THEN
- kind := symKind[i]; t := symTy[i]; RETURN TRUE
- END;
- DEC(i)
- END;
- owner := procParent[owner]
- END;
- i := HashGet(symHash, symName, name);
- IF (i >= 0) AND (symOwner[i] = -1) THEN
- kind := symKind[i]; t := symTy[i]; RETURN TRUE
- END;
- RETURN FALSE
- END FindSym;
- PROCEDURE GetConstVal (name: ARRAY OF CHAR; VAR v: ARRAY OF CHAR): BOOLEAN;
- VAR i: INTEGER;
- BEGIN
- i := HashGet(symHash, symName, name);
- IF (i >= 0) AND (symKind[i] = SymTab.KindConst) THEN
- CopySpan(symVal, v, VAL(CARDINAL, i) * 64, 0);
- IF v[0] # CHR(0) THEN RETURN TRUE END
- END;
- (* a literal propagated with its enum type lives only in SymTab *)
- v[0] := CHR(0);
- RETURN SymTab.GetSymVal(name, v)
- END GetConstVal;
- PROCEDURE SetConstVal (name: ARRAY OF CHAR; val: ARRAY OF CHAR);
- (* Refresh a CONST's recorded value after Lower re-emits its aggregate
- constructor (the grammar's value was suppressed under NoEmit). *)
- VAR i: INTEGER;
- BEGIN
- i := HashGet(symHash, symName, name);
- IF i >= 0 THEN CopySpan(val, symVal, 0, VAL(CARDINAL, i) * 64) END
- END SetConstVal;
- PROCEDURE ProcNameEq (i: CARDINAL; name: ARRAY OF CHAR): BOOLEAN;
- VAR j: CARDINAL;
- BEGIN
- j := 0;
- WHILE (j < MaxName) AND (name[j] # CHR(0)) DO
- IF procName[i * 64 + j] # name[j] THEN RETURN FALSE END;
- INC(j)
- END;
- RETURN procName[i * 64 + j] = name[j]
- END ProcNameEq;
- PROCEDURE ProcVisible (i: INTEGER): BOOLEAN;
- (* TRUE when proc i is nested directly in the emitted procedure or one
- of its enclosing procedures (or is module-level). *)
- VAR owner: INTEGER;
- BEGIN
- owner := emitProc;
- WHILE owner >= 0 DO
- IF procParent[i] = owner THEN RETURN TRUE END;
- owner := procParent[owner]
- END;
- RETURN procParent[i] = -1
- END ProcVisible;
- PROCEDURE ImpNameEq (i: CARDINAL; name: ARRAY OF CHAR): BOOLEAN;
- BEGIN
- RETURN SpanEq(impName, i * 64, name)
- END ImpNameEq;
- PROCEDURE FindProc (name: ARRAY OF CHAR): INTEGER;
- (* Scope-aware: a nested procedure (e.g. one of two `Sep`s) must resolve
- to the one in the emitted procedure's chain, not the last duplicate.
- The current unit's imports win over any same-named proc. *)
- VAR i: INTEGER; owner: INTEGER;
- BEGIN
- i := 0;
- WHILE i < VAL(INTEGER, nImps) DO
- IF ImpNameEq(VAL(CARDINAL, i), name) THEN RETURN impProc[i] END;
- INC(i)
- END;
- i := HashGet(procHash, procName, name);
- IF (i >= 0) AND ProcVisible(i) THEN RETURN i END;
- owner := emitProc;
- WHILE owner >= 0 DO
- i := VAL(INTEGER, nProcs) - 1;
- WHILE i > 0 DO
- DEC(i);
- IF (procParent[i] = owner) AND ProcNameEq(VAL(CARDINAL, i), name) THEN
- RETURN i
- END
- END;
- owner := procParent[owner]
- END;
- i := VAL(INTEGER, nProcs) - 1;
- WHILE i > 0 DO
- DEC(i);
- IF (procParent[i] = -1) AND ProcNameEq(VAL(CARDINAL, i), name) THEN
- RETURN i
- END
- END;
- RETURN -1
- END FindProc;
- PROCEDURE FindProcByUid (uid: CARDINAL): INTEGER;
- (* Exact proc entry for a module-qualified call (M.P): the base name may
- be duplicated across modules, but the uid is unique. *)
- VAR i: INTEGER;
- BEGIN
- i := VAL(INTEGER, nProcs);
- WHILE i > 0 DO
- DEC(i);
- IF procUid[i] = uid THEN RETURN i END
- END;
- RETURN -1
- END FindProcByUid;
- PROCEDURE NoteImportedProc (name: ARRAY OF CHAR);
- (* FROM M IMPORT P (a procedure): remember the exact proc entry so an
- unqualified call resolves to the imported proc, not a same-named
- proc declared in another module. Reset at each unit. *)
- VAR pi: INTEGER;
- BEGIN
- IF SymTab.SymKind(name) # SymTab.KindProc THEN RETURN END;
- pi := FindProcByUid(SymTab.ProcUid(name));
- IF pi < 0 THEN RETURN END;
- IF nImps >= MaxImp THEN RETURN END;
- impProc[nImps] := pi;
- CopySpan(name, impName, 0, nImps * 64);
- INC(nImps)
- END NoteImportedProc;
- PROCEDURE Resolve (nm: ARRAY OF CHAR; VAR k: INTEGER;
- VAR t: SymTab.TypeIndex): BOOLEAN;
- VAR kind: INTEGER; ti: SymTab.TypeIndex;
- BEGIN
- IF FindSym(nm, kind, ti) THEN k := kind; t := ti; RETURN TRUE END;
- IF SymTab.Lookup(nm) THEN k := SymTab.SymKind(nm); t := SymTab.SymType(nm);
- RETURN TRUE
- END;
- (* A bare procedure used as a value: it lives in the proc table.
- Sibling method names must fall through so LowerDesign can bind
- THIS, so exclude methods of the open class implementation. *)
- IF FindProc(nm) >= 0 THEN
- IF (curImplCls = SymTab.InvalidType)
- OR NOT SymTab.MethodExists(curImplCls, nm) THEN
- k := SymTab.KindProc; t := SymTab.InvalidType; RETURN TRUE
- END
- END;
- RETURN FALSE
- END Resolve;
- PROCEDURE ProcInfo (nm: ARRAY OF CHAR; VAR uid: CARDINAL;
- VAR res: SymTab.TypeIndex; VAR depth: CARDINAL;
- VAR ext: BOOLEAN; VAR npar: CARDINAL): BOOLEAN;
- VAR i: INTEGER;
- BEGIN
- i := FindProc(nm);
- IF (i < 0) OR (i >= MaxProc) THEN RETURN FALSE END;
- uid := procUid[i]; res := procRes[i]; depth := procDep[i];
- ext := procExt[i]; npar := procNpar[i];
- IF npar > MaxPar THEN npar := MaxPar END;
- RETURN TRUE
- END ProcInfo;
- PROCEDURE ParamInfo (nm: ARRAY OF CHAR; i: CARDINAL;
- VAR t: SymTab.TypeIndex; VAR isVar: BOOLEAN;
- VAR pn: ARRAY OF CHAR): BOOLEAN;
- VAR k: INTEGER;
- BEGIN
- k := FindProc(nm);
- IF (k < 0) OR (k >= MaxProc) THEN RETURN FALSE END;
- IF (i >= procNpar[k]) OR (procNpar[k] > MaxPar) THEN RETURN FALSE END;
- t := parTy[VAL(CARDINAL, k) * MaxPar + i];
- isVar := parVar[VAL(CARDINAL, k) * MaxPar + i];
- CopySpan(parName, pn, VAL(CARDINAL, k) * MaxPar * 64 + i * 64, 0);
- RETURN TRUE
- END ParamInfo;
- PROCEDURE WithField (nm: ARRAY OF CHAR; VAR k: INTEGER;
- VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal): BOOLEAN;
- (* Resolves a bare ident as a field of an open WITH record (innermost
- first), leaving the field address in q and k=KindField. *)
- VAR wt: CARDINAL; fo: INTEGER; qb: QbeGen.QVal;
- BEGIN
- wt := withTop;
- WHILE wt > 0 DO
- DEC(wt);
- IF SymTab.FieldExists(withRec[wt], nm) THEN
- t := SymTab.FieldType(withRec[wt], nm);
- fo := SymTab.FieldOffset(withRec[wt], nm);
- k := SymTab.KindField;
- IF QbeGen.TopWith(qb) THEN QbeGen.FieldAddr(qb, fo, q)
- ELSE QbeGen.CopyOp("0", q)
- END;
- RETURN TRUE
- END
- END;
- RETURN FALSE
- END WithField;
- PROCEDURE Name (n: AST.Node; VAR s: ARRAY OF CHAR);
- BEGIN
- IF n = AST.NoNode THEN s[0] := CHR(0)
- ELSE AST.Txt(AST.Child(n, 0), s)
- END
- END Name;
- (* ---------------- compile-time set constants ----------------
- A SET CONST's value must be static data. Set literals are emitted as
- runtime temporaries, so the grammar computes the bit mask here (where
- the element expressions are already validated) and Lower re-emits it
- as a pooled descriptor (`QbeGen.PoolSet`). Only masks up to MaxCFoldW
- words (512 bits) are folded; a wider SET CONST stays a clear 230. *)
- PROCEDURE Pow2 (b: INTEGER): CARDINAL;
- VAR p: CARDINAL; k: INTEGER;
- BEGIN
- p := 1; k := 0;
- WHILE k < b DO p := p * 2; INC(k) END;
- RETURN p
- END Pow2;
- PROCEDURE MaskZero (VAR mask: ARRAY OF CARDINAL; words: CARDINAL);
- VAR i: CARDINAL;
- BEGIN
- i := 0;
- WHILE (i < words) AND (i <= HIGH(mask)) DO mask[i] := 0; INC(i) END
- END MaskZero;
- PROCEDURE MaskSetBit (VAR mask: ARRAY OF CARDINAL; bit: INTEGER);
- VAR w, b: INTEGER; p: CARDINAL; idx: CARDINAL;
- BEGIN
- IF (bit < 0) OR (bit >= VAL(INTEGER, MaxCFoldW) * 32) THEN RETURN END;
- w := bit DIV 32; b := bit MOD 32;
- IF w > VAL(INTEGER, HIGH(mask)) THEN RETURN END;
- idx := VAL(CARDINAL, w); p := Pow2(b);
- IF (mask[idx] DIV p) MOD 2 = 0 THEN mask[idx] := mask[idx] + p END
- END MaskSetBit;
- PROCEDURE MaskGetBit (VAR mask: ARRAY OF CARDINAL; bit: INTEGER): INTEGER;
- VAR w, b: INTEGER; p: CARDINAL;
- BEGIN
- IF (bit < 0) OR (bit >= VAL(INTEGER, MaxCFoldW) * 32) THEN RETURN 0 END;
- w := bit DIV 32; b := bit MOD 32;
- IF w > VAL(INTEGER, HIGH(mask)) THEN RETURN 0 END;
- p := Pow2(b);
- IF (mask[VAL(CARDINAL, w)] DIV p) MOD 2 = 1 THEN RETURN 1 END;
- RETURN 0
- END MaskGetBit;
- PROCEDURE EvalOrdConst (n: AST.Node; VAR v: INTEGER): BOOLEAN;
- (* The integer value of a compile-time ordinal expression, matching the
- grammar's folding (literals, named CONSTs, unary +/-, + - * DIV MOD). *)
- VAR k: INTEGER; s, cv: QbeGen.QVal; nm, qnm, al: SymTab.Name;
- a, b: INTEGER; isCh: BOOLEAN;
- BEGIN
- IF n = AST.NoNode THEN RETURN FALSE END;
- k := AST.Kind(n);
- IF k = AST.NkIntLit THEN
- Name(n, s); QbeGen.NormInt(s, cv); RETURN SymTab.ConstInt(cv, v)
- ELSIF k = AST.NkCharLit THEN
- Name(n, s);
- IF (s[0] = "'") OR (s[0] = '"') THEN
- v := QbeGen.CharVal(s); RETURN TRUE
- END;
- QbeGen.NormLit(s, cv, isCh); RETURN SymTab.ConstInt(cv, v)
- ELSIF k = AST.NkStrLit THEN
- (* a 1-character string literal "c" is a CHAR constant *)
- Name(n, s);
- IF SymTab.StrLen(s) = 3 THEN v := QbeGen.CharVal(s); RETURN TRUE END;
- RETURN FALSE
- ELSIF k = AST.NkDesignator THEN
- IF (AST.NChild(n) = 1) AND (AST.Kind(AST.Child(n, 0)) = AST.NkIdent) THEN
- Name(AST.Child(n, 0), nm);
- IF SymTab.Equal(nm, "TRUE") THEN v := 1; RETURN TRUE END;
- IF SymTab.Equal(nm, "FALSE") THEN v := 0; RETURN TRUE END;
- IF SymTab.Lookup(nm) AND (SymTab.SymKind(nm) = SymTab.KindConst)
- AND SymTab.GetSymVal(nm, cv) AND QbeGen.IsImm(cv) THEN
- RETURN SymTab.ConstInt(cv, v)
- END;
- RETURN FALSE
- ELSIF (AST.NChild(n) = 2) AND (AST.Kind(AST.Child(n, 0)) = AST.NkIdent)
- AND (AST.Kind(AST.Child(n, 1)) = AST.NkSelector)
- AND (AST.Op(AST.Child(n, 1)) = AST.SelField) THEN
- (* M.lit: a module-qualified constant (enum literal / CONST) *)
- Name(AST.Child(n, 0), nm);
- Name(AST.Child(AST.Child(n, 1), 0), qnm);
- IF SymTab.MaterializeAlias(nm, qnm, al)
- AND SymTab.GetSymVal(al, cv) AND QbeGen.IsImm(cv) THEN
- RETURN SymTab.ConstInt(cv, v)
- END;
- RETURN FALSE
- END;
- RETURN FALSE
- ELSIF k = AST.NkUnary THEN
- IF AST.Op(n) = AST.OpSub THEN
- IF EvalOrdConst(AST.Child(n, 0), v) THEN v := -v; RETURN TRUE END
- ELSIF AST.Op(n) = AST.OpAdd THEN
- RETURN EvalOrdConst(AST.Child(n, 0), v)
- END;
- RETURN FALSE
- ELSIF k = AST.NkBinExpr THEN
- IF EvalOrdConst(AST.Child(n, 0), a)
- AND EvalOrdConst(AST.Child(n, 1), b) THEN
- IF AST.Op(n) = AST.OpAdd THEN v := a + b
- ELSIF AST.Op(n) = AST.OpSub THEN v := a - b
- ELSIF AST.Op(n) = AST.OpMul THEN v := a * b
- ELSIF AST.Op(n) = AST.OpDiv THEN
- IF b = 0 THEN RETURN FALSE END; v := a DIV b
- ELSIF AST.Op(n) = AST.OpMod THEN
- IF b = 0 THEN RETURN FALSE END; v := a MOD b
- ELSE RETURN FALSE
- END;
- RETURN TRUE
- END;
- RETURN FALSE
- END;
- RETURN FALSE
- END EvalOrdConst;
- PROCEDURE EvalSetElem (el: AST.Node; VAR mask: ARRAY OF CARDINAL;
- lo: INTEGER; span: CARDINAL): BOOLEAN;
- VAR a, b: INTEGER;
- BEGIN
- IF AST.Kind(el) = AST.NkSubrange THEN
- IF NOT EvalOrdConst(AST.Child(el, 0), a)
- OR NOT EvalOrdConst(AST.Child(el, 1), b) THEN RETURN FALSE END;
- IF (a < lo) OR (b < lo) OR (a > b)
- OR (b >= lo + VAL(INTEGER, span)) THEN RETURN FALSE END;
- WHILE a <= b DO MaskSetBit(mask, a - lo); INC(a) END;
- RETURN TRUE
- END;
- IF NOT EvalOrdConst(el, a) THEN RETURN FALSE END;
- IF (a < lo) OR (a >= lo + VAL(INTEGER, span)) THEN RETURN FALSE END;
- MaskSetBit(mask, a - lo);
- RETURN TRUE
- END EvalSetElem;
- PROCEDURE NoteSetMask (name: ARRAY OF CHAR; mask: ARRAY OF CARDINAL;
- words: CARDINAL; lo: INTEGER);
- VAR i: CARDINAL;
- BEGIN
- IF cfoldN >= MaxCFold THEN RETURN END;
- CopySpan(name, cfoldName, 0, cfoldN * 64);
- cfoldW[cfoldN] := words; cfoldLo[cfoldN] := lo;
- i := 0;
- WHILE i < MaxCFoldW DO
- IF (i < words) AND (i <= HIGH(mask)) THEN
- cfoldMask[cfoldN * MaxCFoldW + i] := mask[i]
- ELSE cfoldMask[cfoldN * MaxCFoldW + i] := 0
- END;
- INC(i)
- END;
- INC(cfoldN)
- END NoteSetMask;
- PROCEDURE LookupSetMask (name: ARRAY OF CHAR; VAR mask: ARRAY OF CARDINAL;
- VAR words: CARDINAL; VAR lo: INTEGER): BOOLEAN;
- VAR i: INTEGER; k: CARDINAL;
- BEGIN
- i := VAL(INTEGER, cfoldN) - 1;
- WHILE i >= 0 DO
- IF SpanEq(cfoldName, VAL(CARDINAL, i) * 64, name) THEN
- words := cfoldW[i]; lo := cfoldLo[i];
- k := 0;
- WHILE (k < words) AND (k <= HIGH(mask)) DO
- mask[k] := cfoldMask[VAL(CARDINAL, i) * MaxCFoldW + k]; INC(k)
- END;
- RETURN TRUE
- END;
- DEC(i)
- END;
- RETURN FALSE
- END LookupSetMask;
- PROCEDURE EvalSetConst (n: AST.Node; VAR mask: ARRAY OF CARDINAL;
- VAR words: CARDINAL; VAR lo: INTEGER): BOOLEAN;
- VAR k, i, a, b, r: INTEGER;
- t: SymTab.TypeIndex;
- span: CARDINAL;
- seq, el, next: AST.Node;
- m1, m2: ARRAY [0 .. MaxCFoldW - 1] OF CARDINAL;
- w1, w2: CARDINAL;
- l1, l2: INTEGER;
- op: INTEGER;
- nm: SymTab.Name;
- BEGIN
- IF n = AST.NoNode THEN RETURN FALSE END;
- k := AST.Kind(n);
- IF (k = AST.NkSetLit) OR (k = AST.NkBraceLit) THEN
- t := AST.Ty(n);
- IF (k = AST.NkBraceLit) AND (SymTab.ClassOf(t) # SymTab.ClSet) THEN
- RETURN FALSE
- END;
- IF t = SymTab.InvalidType THEN
- lo := 0; words := 8; span := 256
- ELSE
- lo := SymTab.SetBaseLo(t); words := SymTab.SetWords(t);
- span := SymTab.SetCount(t);
- IF words = 0 THEN words := 8; span := 256; lo := 0 END
- END;
- IF words > MaxCFoldW THEN RETURN FALSE END;
- MaskZero(mask, words);
- IF k = AST.NkSetLit THEN
- i := 0;
- WHILE i < VAL(INTEGER, AST.NChild(n)) DO
- el := AST.Child(n, VAL(CARDINAL, i));
- IF NOT EvalSetElem(el, mask, lo, span) THEN RETURN FALSE END;
- INC(i)
- END
- ELSE
- seq := n;
- WHILE seq # AST.NoNode DO
- i := 0;
- WHILE i < VAL(INTEGER, AST.NChild(seq)) DO
- el := AST.Child(seq, VAL(CARDINAL, i));
- IF AST.Kind(el) # AST.NkBlock THEN
- IF NOT EvalSetElem(el, mask, lo, span) THEN RETURN FALSE END
- END;
- INC(i)
- END;
- next := AST.NoNode;
- IF AST.NChild(seq) > 0 THEN
- next := AST.Child(seq, AST.NChild(seq) - 1);
- IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
- END;
- seq := next
- END
- END;
- RETURN TRUE
- ELSIF k = AST.NkDesignator THEN
- IF (AST.NChild(n) # 1) OR (AST.Kind(AST.Child(n, 0)) # AST.NkIdent) THEN
- RETURN FALSE END;
- Name(AST.Child(n, 0), nm);
- RETURN LookupSetMask(nm, mask, words, lo)
- ELSIF k = AST.NkBinExpr THEN
- op := AST.Op(n);
- IF (op # AST.OpAdd) AND (op # AST.OpSub)
- AND (op # AST.OpMul) AND (op # AST.OpDiv) THEN
- RETURN FALSE END;
- IF NOT EvalSetConst(AST.Child(n, 0), m1, w1, l1)
- OR NOT EvalSetConst(AST.Child(n, 1), m2, w2, l2) THEN
- RETURN FALSE END;
- IF l1 # l2 THEN RETURN FALSE END;
- lo := l1;
- words := w1; IF w2 > words THEN words := w2 END;
- IF words > MaxCFoldW THEN RETURN FALSE END;
- MaskZero(mask, words);
- i := 0;
- WHILE i < VAL(INTEGER, words) * 32 DO
- a := MaskGetBit(m1, i); b := MaskGetBit(m2, i);
- IF op = AST.OpAdd THEN r := a; IF b = 1 THEN r := 1 END
- ELSIF op = AST.OpMul THEN
- IF (a = 1) AND (b = 1) THEN r := 1 ELSE r := 0 END
- ELSIF op = AST.OpSub THEN r := a; IF b = 1 THEN r := 0 END
- ELSE r := (a + b) MOD 2
- END;
- IF r # 0 THEN MaskSetBit(mask, i) END;
- INC(i)
- END;
- RETURN TRUE
- END;
- RETURN FALSE
- END EvalSetConst;
- PROCEDURE SetConstMaskOf (n: AST.Node; VAR mask: ARRAY OF CARDINAL;
- VAR words: CARDINAL; VAR lo: INTEGER): BOOLEAN;
- BEGIN
- words := 0; lo := 0;
- RETURN EvalSetConst(n, mask, words, lo)
- END SetConstMaskOf;
- PROCEDURE ParamName (proc: ARRAY OF CHAR; i: CARDINAL;
- VAR s: ARRAY OF CHAR);
- VAR t: SymTab.TypeIndex; isV: BOOLEAN;
- BEGIN
- IF NOT ParamInfo(proc, i, t, isV, s) THEN s[0] := CHR(0) END
- END ParamName;
- PROCEDURE IsArith (op: INTEGER): BOOLEAN;
- BEGIN
- RETURN (op = AST.OpAdd) OR (op = AST.OpSub) OR (op = AST.OpMul)
- OR (op = AST.OpDiv) OR (op = AST.OpMod)
- END IsArith;
- PROCEDURE IsRel (op: INTEGER): BOOLEAN;
- BEGIN
- RETURN ((op >= AST.OpEq) AND (op <= AST.OpGe)) OR (op = AST.OpIn)
- END IsRel;
- PROCEDURE RelSym (a: INTEGER; VAR s: INTEGER): BOOLEAN;
- BEGIN
- IF a = AST.OpEq THEN s := SymTab.OpEq
- ELSIF a = AST.OpNe THEN s := SymTab.OpNeq1
- ELSIF a = AST.OpLt THEN s := SymTab.OpLt
- ELSIF a = AST.OpLe THEN s := SymTab.OpLe
- ELSIF a = AST.OpGt THEN s := SymTab.OpGt
- ELSIF a = AST.OpGe THEN s := SymTab.OpGe
- ELSE RETURN FALSE
- END;
- RETURN TRUE
- END RelSym;
- PROCEDURE IsScalarClass (cls: INTEGER): BOOLEAN;
- BEGIN
- RETURN (cls = SymTab.ClInt) OR (cls = SymTab.ClBool)
- OR (cls = SymTab.ClChar) OR (cls = SymTab.ClUChar)
- OR (cls = SymTab.ClEnum)
- END IsScalarClass;
- PROCEDURE IsSimpleScalar (n: AST.Node): BOOLEAN;
- VAR nm: SymTab.Name; k: INTEGER; t: SymTab.TypeIndex;
- BEGIN
- IF (AST.Kind(n) # AST.NkDesignator) OR (AST.NChild(n) # 1) THEN
- RETURN FALSE END;
- IF AST.Kind(AST.Child(n, 0)) # AST.NkIdent THEN RETURN FALSE END;
- Name(AST.Child(n, 0), nm);
- IF NOT Resolve(nm, k, t) THEN RETURN FALSE END;
- IF (k # SymTab.KindVar) AND (k # SymTab.KindParam)
- AND (k # SymTab.KindConst) THEN
- RETURN FALSE END;
- IF SymTab.Equal(nm, "TRUE") OR SymTab.Equal(nm, "FALSE") THEN
- RETURN TRUE END;
- RETURN IsScalarClass(SymTab.ClassOf(t))
- END IsSimpleScalar;
- PROCEDURE CalleeName (call: AST.Node; VAR nm: SymTab.Name);
- (* The callee of NkCall: child 0 is a designator (or bare ident). *)
- VAR d: AST.Node;
- BEGIN
- nm[0] := CHR(0);
- d := AST.Child(call, 0);
- IF d = AST.NoNode THEN RETURN END;
- IF AST.Kind(d) = AST.NkDesignator THEN d := AST.Child(d, 0) END;
- IF (d # AST.NoNode) AND (AST.Kind(d) = AST.NkIdent) THEN Name(d, nm) END
- END CalleeName;
- PROCEDURE CallResultType (call: AST.Node; VAR t: SymTab.TypeIndex): BOOLEAN;
- (* The result type of a call used as a designator base (F().M()). *)
- VAR nm: SymTab.Name; uid, depth, np: CARDINAL; res: SymTab.TypeIndex;
- ext: BOOLEAN; pi: INTEGER;
- BEGIN
- t := SymTab.InvalidType;
- CalleeName(call, nm);
- pi := FindProc(nm);
- IF pi >= 0 THEN
- IF ProcInfoIdx(pi, uid, res, depth, ext, np) THEN t := res; RETURN TRUE END;
- RETURN FALSE
- END;
- IF SymTab.Lookup(nm) AND (SymTab.SymKind(nm) = SymTab.KindProc) THEN
- t := SymTab.ProcRes(nm); RETURN TRUE
- END;
- RETURN FALSE
- END CallResultType;
- PROCEDURE IsMethodCall (n: AST.Node): BOOLEAN;
- (* n is a call whose callee resolves to a class method: `obj.Method`,
- `p^.Method`, or a bare sibling name inside an implementation. *)
- VAR d, sel: AST.Node; nm, fn: SymTab.Name; k: INTEGER; t: SymTab.TypeIndex;
- i: CARDINAL;
- BEGIN
- IF (AST.Kind(n) # AST.NkCall) OR (AST.NChild(n) < 1) THEN RETURN FALSE END;
- d := AST.Child(n, 0);
- IF AST.Kind(d) # AST.NkDesignator THEN RETURN FALSE END;
- IF AST.NChild(d) = 1 THEN
- (* bare name: a sibling method inside a class implementation? *)
- Name(AST.Child(d, 0), nm);
- RETURN (curImplCls # SymTab.InvalidType)
- AND SymTab.MethodExists(curImplCls, nm)
- END;
- IF AST.Kind(AST.Child(d, 0)) = AST.NkCall THEN
- (* F().M(): the base is a call; take its result type *)
- IF NOT CallResultType(AST.Child(d, 0), t) THEN RETURN FALSE END
- ELSE
- Name(AST.Child(d, 0), nm);
- IF NOT Resolve(nm, k, t) THEN RETURN FALSE END
- END;
- i := 1;
- WHILE i < AST.NChild(d) DO
- sel := AST.Child(d, i);
- IF AST.Op(sel) = AST.SelField THEN
- Name(AST.Child(sel, 0), fn);
- IF (t # SymTab.InvalidType) AND (SymTab.ClassOf(t) = SymTab.ClClass)
- AND SymTab.MethodExists(t, fn) THEN
- RETURN i = AST.NChild(d) - 1
- END;
- IF (t = SymTab.InvalidType) OR NOT SymTab.FieldExists(t, fn) THEN
- RETURN FALSE
- END;
- t := SymTab.FieldType(t, fn)
- ELSIF AST.Op(sel) = AST.SelIndex THEN
- IF (t = SymTab.InvalidType) OR (SymTab.ClassOf(t) # SymTab.ClArray) THEN
- RETURN FALSE
- END;
- t := SymTab.ArrayElem(t)
- ELSIF AST.Op(sel) = AST.SelDeref THEN
- IF (t = SymTab.InvalidType) OR (SymTab.ClassOf(t) # SymTab.ClPtr) THEN
- RETURN FALSE
- END;
- t := SymTab.PtrBase(t)
- ELSE RETURN FALSE
- END;
- INC(i)
- END;
- RETURN FALSE
- END IsMethodCall;
- PROCEDURE CalleeAlias (call: AST.Node; VAR mal: SymTab.Name): BOOLEAN;
- (* Callee is `M.P` (module-qualified): materialize the export alias. *)
- VAR d, sel: AST.Node; nm, fn, al: SymTab.Name; k: INTEGER;
- t: SymTab.TypeIndex;
- BEGIN
- d := AST.Child(call, 0);
- IF (AST.Kind(d) # AST.NkDesignator) OR (AST.NChild(d) # 2) THEN
- RETURN FALSE
- END;
- sel := AST.Child(d, 1);
- IF AST.Op(sel) # AST.SelField THEN RETURN FALSE END;
- Name(AST.Child(d, 0), nm);
- IF NOT Resolve(nm, k, t) THEN RETURN FALSE END;
- IF k # SymTab.KindModule THEN RETURN FALSE END;
- Name(AST.Child(sel, 0), fn);
- IF NOT SymTab.MaterializeAlias(nm, fn, al) THEN RETURN FALSE END;
- (* Lower's proc table is keyed by the base name (the mangled symbol
- is <base>_<uid>), so return fn, not the materialized alias. The
- uid comes from the alias, which is module-exact. *)
- qualIsVar := SymTab.SymKind(al) # SymTab.KindProc;
- qualUid := SymTab.ProcUid(al);
- CopyN(fn, mal);
- RETURN TRUE
- END CalleeAlias;
- PROCEDURE FinalLoad (t: SymTab.TypeIndex; sfx: BOOLEAN; VAR q: QbeGen.QVal);
- (* Fact's final load after a designator/result suffix: scalars/pointers
- are loaded from their address; aggregates keep the address. *)
- VAR cls: INTEGER; q2: QbeGen.QVal;
- BEGIN
- IF NOT sfx THEN RETURN END;
- IF t = SymTab.InvalidType THEN QbeGen.CopyOp("0", q); RETURN END;
- cls := SymTab.ClassOf(t);
- IF (cls # SymTab.ClRecord) AND (cls # SymTab.ClSet)
- AND (cls # SymTab.ClArray) AND (cls # SymTab.ClClass) THEN
- QbeGen.ElemLoad(q, t, q2); QbeGen.CopyOp(q2, q)
- END
- END FinalLoad;
- PROCEDURE LowerDesign (n: AST.Node; VAR t: SymTab.TypeIndex; VAR k: INTEGER;
- VAR q: QbeGen.QVal; VAR qn: SymTab.Name;
- VAR sfx: BOOLEAN);
- (* Base ident then selectors (mirrors the grammar's Design). Leaves the
- address in q with sfx=TRUE for selectors; base vars/consts load. *)
- VAR nm, fn, mal: SymTab.Name; cv: QbeGen.QVal; cls, op: INTEGER;
- i: CARDINAL; sel: AST.Node; eT, it: SymTab.TypeIndex;
- iq, ql, qlo, qhi, qe: QbeGen.QVal;
- lo, hi, fo: INTEGER; isOpen, viewMode: BOOLEAN;
- BEGIN
- IF AST.Kind(AST.Child(n, 0)) = AST.NkCall THEN
- (* a call result used as a designator base: P()^, P()^.field,
- A()[i]. The call yields a value (a pointer/record address);
- sfx=FALSE so a following ^ does not reload it. *)
- LowerExpr(AST.Child(n, 0), t, q);
- k := -1; qn[0] := CHR(0); sfx := FALSE
- ELSE
- Name(AST.Child(n, 0), nm);
- QbeGen.CopyOp(nm, qn);
- sfx := FALSE;
- IF NOT Resolve(nm, k, t) THEN
- IF WithField(nm, k, t, q) THEN
- sfx := TRUE
- ELSIF (curImplCls # SymTab.InvalidType)
- AND SymTab.MethodExists(curImplCls, nm) THEN
- (* bare sibling method name inside a class implementation *)
- QbeGen.ThisBase(q);
- QbeGen.ArmRecv(q);
- curMethCls := curImplCls; k := SymTab.KindProc;
- t := SymTab.InvalidType; sfx := FALSE
- ELSE
- t := SymTab.InvalidType; k := -1; QbeGen.CopyOp("0", q); RETURN
- END
- END;
- IF k = SymTab.KindConst THEN
- IF SymTab.Equal(nm, "TRUE") THEN
- t := SymTab.BoolType(); QbeGen.CopyOp("1", q)
- ELSIF SymTab.Equal(nm, "FALSE") THEN
- t := SymTab.BoolType(); QbeGen.CopyOp("0", q)
- ELSIF SymTab.Equal(nm, "NIL") THEN
- QbeGen.CopyOp("0", q)
- ELSE
- cls := SymTab.ClassOf(t);
- IF (cls = SymTab.ClArray) OR (cls = SymTab.ClRecord)
- OR (cls = SymTab.ClClass) OR (cls = SymTab.ClStr)
- OR (cls = SymTab.ClUStr) OR (cls = SymTab.ClSet) THEN
- (* aggregate/string const: its value IS the descriptor address *)
- IF GetConstVal(nm, cv) THEN QbeGen.CopyOp(cv, q)
- ELSE QbeGen.CopyOp("0", q)
- END
- ELSIF (cls = SymTab.ClInt) OR (cls = SymTab.ClChar)
- OR (cls = SymTab.ClEnum) OR (cls = SymTab.ClLong)
- OR (cls = SymTab.ClBool)
- OR (cls = SymTab.ClByte) OR (cls = SymTab.ClSByte) THEN
- IF GetConstVal(nm, cv) AND QbeGen.IsImm(cv) THEN
- QbeGen.CopyOp(cv, q)
- ELSE QbeGen.CopyOp("0", q)
- END
- ELSIF cls = SymTab.ClReal THEN
- (* a real CONST lives in its data symbol; load it *)
- QbeGen.LoadVar(nm, TRUE, q)
- ELSIF cls = SymTab.ClSReal THEN
- QbeGen.LoadShortReal(nm, q)
- ELSIF cls = SymTab.ClCBool THEN
- QbeGen.LoadShortVar(nm, FALSE, 1, q)
- ELSE QbeGen.CopyOp("0", q)
- END
- END
- ELSIF (k = SymTab.KindVar) OR (k = SymTab.KindParam) THEN
- cls := SymTab.ClassOf(t);
- IF AST.Op(n) = 1 THEN
- (* a forward module-level reference: the grammar's FwdAddrOper
- leaves an address (sfx=TRUE), not a loaded value *)
- QbeGen.AddrOf(nm, q); sfx := TRUE
- ELSIF SymTab.IsSmallInt(t) THEN
- QbeGen.LoadShortVar(nm, SymTab.IsSignedSmallInt(t),
- SymTab.SmallIntBytes(t), q)
- ELSIF (cls = SymTab.ClInt) OR (cls = SymTab.ClBool)
- OR (cls = SymTab.ClChar) OR (cls = SymTab.ClUChar)
- OR (cls = SymTab.ClEnum) OR (cls = SymTab.ClReal) THEN
- QbeGen.LoadVar(nm, cls = SymTab.ClReal, q)
- ELSIF cls = SymTab.ClSReal THEN
- QbeGen.LoadShortReal(nm, q)
- ELSIF (cls = SymTab.ClPtr) OR (cls = SymTab.ClProc) THEN
- QbeGen.LoadPtr(nm, q)
- ELSIF cls = SymTab.ClLong THEN
- QbeGen.LoadLong(nm, q)
- ELSE QbeGen.AddrOf(nm, q)
- END
- ELSIF k = SymTab.KindField THEN
- (* q already holds the field address (WithField) *)
- ELSE QbeGen.CopyOp("0", q)
- END;
- END;
- IF (k = SymTab.KindField) AND SymTab.IsMultiArray(t) THEN
- QbeGen.MakeFieldView(q, t, qe);
- QbeGen.CopyOp(qe, q)
- END;
- viewMode := SymTab.IsMultiArray(t);
- i := 1;
- WHILE i < AST.NChild(n) DO
- sel := AST.Child(n, i);
- op := AST.Op(sel);
- IF op = AST.SelField THEN
- Name(AST.Child(sel, 0), fn);
- IF k = SymTab.KindModule THEN
- (* qualified L.x: materialize the export, then load it *)
- IF SymTab.MaterializeAlias(nm, fn, mal) THEN
- QbeGen.CopyOp(mal, qn);
- t := SymTab.SymType(mal); k := SymTab.SymKind(mal); sfx := FALSE;
- IF k = SymTab.KindProc THEN QbeGen.CopyOp("0", q)
- ELSIF NOT QbeGen.LoadDesignator(mal, t, k, q) THEN
- t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- END
- ELSE t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- END
- ELSIF t = SymTab.InvalidType THEN
- ELSIF (SymTab.ClassOf(t) = SymTab.ClClass)
- AND SymTab.MethodExists(t, fn) THEN
- (* obj.Method: bind the receiver; the call supplies the value *)
- QbeGen.ArmRecv(q);
- QbeGen.CopyOp(fn, qn);
- curMethCls := t; k := SymTab.KindProc; t := SymTab.InvalidType
- ELSIF NOT SymTab.FieldExists(t, fn) THEN t := SymTab.InvalidType
- ELSE
- fo := SymTab.FieldOffset(t, fn);
- t := SymTab.FieldType(t, fn);
- QbeGen.FieldAddr(q, fo, qe);
- QbeGen.CopyOp(qe, q);
- sfx := TRUE;
- IF SymTab.IsMultiArray(t) THEN
- QbeGen.MakeFieldView(q, t, qe);
- QbeGen.CopyOp(qe, q);
- viewMode := TRUE
- ELSE
- viewMode := FALSE
- END
- END
- ELSIF op = AST.SelIndex THEN
- LowerExpr(AST.Child(sel, 0), it, iq);
- IF t = SymTab.InvalidType THEN
- ELSE
- QbeGen.WidenIndex(iq, ql);
- isOpen := SymTab.IsOpenArray(t);
- IF isOpen THEN
- QbeGen.CopyOp("0", qlo);
- IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN
- QbeGen.OpenHiChar(q, qhi)
- ELSE QbeGen.OpenHi(q, qhi)
- END
- ELSE
- lo := SymTab.ArrayLo(t); hi := SymTab.ArrayHi(t);
- IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN
- hi := hi + 1
- END;
- QbeGen.IntStr(lo, qlo); QbeGen.IntStr(hi, qhi)
- END;
- QbeGen.CheckIndex(ql, qlo, qhi);
- eT := SymTab.ArrayElem(t);
- IF viewMode OR ((NOT legacyOpen1D) AND isOpen
- AND (SymTab.ArrayDepth(t) = 1)) THEN
- QbeGen.ViewIndex(q, ql, qlo,
- SymTab.ClassOf(eT) = SymTab.ClArray, qe);
- QbeGen.CopyOp(qe, q)
- ELSE
- QbeGen.ElemAddr(q, ql, qlo, t, qe);
- IF SymTab.ClassOf(eT) = SymTab.ClArray THEN
- QbeGen.ElemLoad(qe, eT, q)
- ELSE QbeGen.CopyOp(qe, q)
- END
- END;
- t := eT; sfx := TRUE
- END
- ELSIF op = AST.SelDeref THEN
- IF t = SymTab.InvalidType THEN
- ELSIF SymTab.ClassOf(t) # SymTab.ClPtr THEN t := SymTab.InvalidType
- ELSE
- IF sfx THEN QbeGen.ElemLoad(q, t, qe); QbeGen.CopyOp(qe, q) END;
- t := SymTab.PtrBase(t); sfx := TRUE;
- viewMode := SymTab.IsMultiArray(t)
- END
- END;
- INC(i)
- END;
- lastView := (t # SymTab.InvalidType)
- AND (SymTab.ClassOf(t) = SymTab.ClArray)
- AND (viewMode OR ((NOT legacyOpen1D)
- AND SymTab.IsOpenArray(t)))
- END LowerDesign;
- PROCEDURE CompositeRes (t: SymTab.TypeIndex): BOOLEAN;
- (* TRUE for a composite (by-value) function result: record/array/set.
- Such results use a hidden destination pointer (sret). *)
- VAR cls: INTEGER;
- BEGIN
- IF t = SymTab.InvalidType THEN RETURN FALSE END;
- cls := SymTab.ClassOf(t);
- RETURN (cls = SymTab.ClRecord) OR (cls = SymTab.ClArray)
- OR (cls = SymTab.ClSet) OR (cls = SymTab.ClClass)
- END CompositeRes;
- PROCEDURE UserLabel (name: ARRAY OF CHAR; VAR q: QbeGen.QVal);
- (* The QbeGen label for a user label/goto name (per procedure). *)
- VAR i: CARDINAL;
- BEGIN
- i := 0;
- WHILE i < nUserLab DO
- IF SpanEq(userLabNm, i * 64, name) THEN q := userLabQ[i]; RETURN END;
- INC(i)
- END;
- QbeGen.NewLabel(q);
- IF nUserLab <= HIGH(userLabQ) THEN
- CopySpan(name, userLabNm, 0, nUserLab * 64);
- userLabQ[nUserLab] := q;
- INC(nUserLab)
- END
- END UserLabel;
- PROCEDURE CheckSub (t: SymTab.TypeIndex; q: ARRAY OF CHAR);
- (* ISO range check: trap when a value is assigned to a subrange outside
- its bounds. Only 32-bit-or-smaller ordinal bases; LONGINT subranges
- are left unchecked for now. *)
- VAR lo, hi, c: INTEGER; ql, qlo, qhi: QbeGen.QVal;
- BEGIN
- IF (t # SymTab.InvalidType) AND SymTab.SubBounds(t, lo, hi) THEN
- c := SymTab.ClassOf(t);
- IF (c # SymTab.ClLong) AND (c # SymTab.ClInvalid) THEN
- QbeGen.WidenIndex(q, ql);
- QbeGen.IntStr(lo, qlo);
- QbeGen.IntStr(hi, qhi);
- QbeGen.CheckRange(ql, qlo, qhi)
- END
- END
- END CheckSub;
- PROCEDURE AppendArg (val: ARRAY OF CHAR; ft: SymTab.TypeIndex;
- isCABI: BOOLEAN; VAR tmp: QbeGen.QVal);
- (* Append one actual to the pending call. At a C-ABI boundary a CHAR
- array is passed as a pointer to its payload (descriptor + 8), which
- is NUL-terminated by the V3 array layout. Descriptor-ABI external
- calls (the runtime shim) and internal calls keep the normal
- descriptor/view argument. *)
- VAR cl: CHAR;
- BEGIN
- IF SymTab.IsShortReal(ft) THEN
- QbeGen.ConvSR(val, tmp);
- cl := "s"
- ELSIF isCABI THEN
- QbeGen.CArg(val, ft, tmp, cl)
- ELSE
- QbeGen.CopyOp(val, tmp);
- cl := QbeGen.ArgClass(ft)
- END;
- IF NOT QbeGen.CallArg(tmp, cl) THEN END
- END AppendArg;
- PROCEDURE AppendArgL (val: ARRAY OF CHAR; ft: SymTab.TypeIndex;
- isCABI: BOOLEAN; VAR tmp: QbeGen.QVal);
- (* Append an address actual (VAR formal or view payload). The class is
- always `l`; C ABI char arrays are shifted to their payload first. *)
- VAR cl: CHAR;
- BEGIN
- IF isCABI THEN
- QbeGen.CArg(val, ft, tmp, cl)
- ELSE
- QbeGen.CopyOp(val, tmp);
- cl := "l"
- END;
- IF NOT QbeGen.CallArg(tmp, cl) THEN END
- END AppendArgL;
- PROCEDURE LowerCall (n: AST.Node; VAR t: SymTab.TypeIndex;
- VAR q: QbeGen.QVal; want: BOOLEAN);
- VAR nm, pn, cqn, cm: SymTab.Name;
- ln: SymTab.LinkName;
- i, ai: CARDINAL; at, ft, res: SymTab.TypeIndex;
- qa, qt, qe, mg, qres, qb, qn: QbeGen.QVal;
- conv, isV, qual, ind, isC, va, cabi: BOOLEAN;
- uid, depth, np, md: CARDINAL; ext: BOOLEAN; ck: INTEGER; pi: INTEGER;
- ct: SymTab.TypeIndex; csfx: BOOLEAN; cl: CHAR;
- seq, next, arg: AST.Node;
- vaD, vaB, vaN: ARRAY [0 .. 63] OF QbeGen.QVal;
- freeDesc: ARRAY [0 .. 127] OF QbeGen.QVal;
- nVa, nFree, kva, kfree: CARDINAL; isOpen1, isExtern: BOOLEAN;
- BEGIN
- qual := CalleeAlias(n, nm);
- ind := FALSE; isC := FALSE; va := FALSE; pi := -1; ext := FALSE;
- cabi := FALSE;
- nVa := 0; nFree := 0; kfree := 0;
- IF qual AND qualIsVar THEN
- (* M.Error where Error is a procedure-typed variable: indirect. *)
- LowerDesign(AST.Child(n, 0), ct, ck, qa, cqn, csfx);
- IF (ct # SymTab.InvalidType)
- AND (SymTab.ClassOf(ct) = SymTab.ClProc) THEN
- ind := TRUE;
- res := SymTab.ProcTypeRes(ct);
- np := SymTab.ProcTypeNPar(ct);
- QbeGen.CallBeginInd(qa, res, FALSE)
- ELSE
- res := SymTab.InvalidType;
- QbeGen.CallBegin(nm, res, 0, FALSE)
- END
- ELSIF qual THEN
- (* M.P: the base name may be duplicated across modules, so select
- the exact proc entry by the alias's uid. *)
- pi := FindProcByUid(qualUid);
- IF ProcInfoIdx(pi, uid, res, depth, ext, np) THEN
- QbeGen.Mangled(nm, uid, mg);
- QbeGen.CallBegin(mg, res, depth, ext)
- ELSE
- res := SymTab.InvalidType;
- QbeGen.CallBegin(nm, res, 0, FALSE)
- END
- ELSE
- CalleeName(n, nm);
- IF FindSym(nm, ck, ct)
- AND ((ck = SymTab.KindVar) OR (ck = SymTab.KindParam))
- AND (SymTab.ClassOf(ct) = SymTab.ClProc) THEN
- (* indirect call through a procedure-typed variable *)
- ind := TRUE;
- LowerDesign(AST.Child(n, 0), ct, ck, qa, cqn, csfx);
- res := SymTab.ProcTypeRes(ct);
- np := SymTab.ProcTypeNPar(ct);
- QbeGen.CallBeginInd(qa, res, FALSE)
- ELSIF ProcInfo(nm, uid, res, depth, ext, np) THEN
- pi := FindProc(nm);
- (* Mangled resolves an explicit external link name by uid, then
- falls back to the module-qualified internal symbol. *)
- QbeGen.Mangled(nm, uid, mg);
- QbeGen.CallBegin(mg, res, depth, ext)
- ELSE
- (* not in Lower's table: a predef C proc (SYSTEM.TRANSFER,
- NEWPROCESS, ...) lives in SymTab with a C link name *)
- IF SymTab.Lookup(nm) AND (SymTab.SymKind(nm) = SymTab.KindProc) THEN
- isC := TRUE;
- res := SymTab.ProcRes(nm);
- np := SymTab.ProcNPar(nm);
- IF SymTab.ProcLink(nm, ln) THEN
- QbeGen.CallBegin(ln, res, 0, TRUE)
- ELSE
- QbeGen.CallBegin(nm, res, 0, FALSE)
- END
- ELSE
- res := SymTab.InvalidType;
- QbeGen.CallBegin(nm, res, 0, FALSE)
- END
- END
- END;
- (* A FOR "C" module exposes a C ABI. Plain EXTERNAL procedures from
- ordinary modules (the runtime shim) keep the descriptor ABI. *)
- IF isC THEN
- cabi := TRUE
- ELSIF qual AND SymTab.ProcModuleByUid(qualUid, cm, md) THEN
- cabi := SymTab.ModForeign(cm)
- ELSIF SymTab.SymMod(nm, cm) THEN
- cabi := SymTab.ModForeign(cm)
- END;
- IF CompositeRes(res) THEN
- (* composite result: pass a hidden destination pointer first *)
- QbeGen.AllocLocal(res, qres);
- IF NOT QbeGen.CallArg(qres, "l") THEN END
- END;
- va := (pi >= 0) AND (pi < VAL(INTEGER, nProcs)) AND procVa[pi];
- (* actuals are a chunked sequence (AstCallNode): follow the NkBlock
- continuations so a call with >MaxChild-1 arguments is complete *)
- ai := 0;
- seq := n;
- WHILE seq # AST.NoNode DO
- i := 0;
- IF seq = n THEN i := 1 END; (* skip the callee in the head *)
- WHILE i < AST.NChild(seq) DO
- arg := AST.Child(seq, i);
- IF AST.Kind(arg) # AST.NkBlock THEN
- LowerExpr(arg, at, qe);
- IF ind THEN
- ft := SymTab.ProcTypeParamType(ct, ai);
- isV := SymTab.ProcTypeParamIsVar(ct, ai)
- ELSIF va THEN
- ft := at; isV := FALSE
- ELSIF isC THEN
- ft := SymTab.ParamType(nm, ai);
- isV := SymTab.ParamIsVar(nm, ai)
- ELSE
- IF NOT ParamInfoIdx(pi, ai, ft, isV, pn) THEN END
- END;
- IF (NOT va) AND SymTab.IsEmptyStr(at)
- AND (ft # SymTab.InvalidType)
- AND (SymTab.ClassOf(ft) = SymTab.ClChar) THEN
- (* ISO: empty string actual for a CHAR formal is 0 *)
- QbeGen.CopyOp("0", qe); at := SymTab.CharType()
- END;
- IF (NOT va) AND (NOT isV) THEN CheckSub(ft, qe) END;
- isOpen1 := (NOT legacyOpen1D)
- AND (ft # SymTab.InvalidType)
- AND (SymTab.ClassOf(ft) = SymTab.ClArray)
- AND (SymTab.ArrayDepth(ft) = 1)
- AND SymTab.IsOpenArray(ft);
- isExtern := ext OR isC;
- IF va THEN
- (* C varargs: float is promoted to double; strings still
- become char pointers. *)
- IF SymTab.IsShortReal(at) THEN
- IF NOT QbeGen.CallArg(qe, "d") THEN END
- ELSE
- QbeGen.CArgAdd(qe, at, qa, cl)
- END
- ELSIF isV THEN
- IF isOpen1 AND NOT isExtern THEN
- IF lastView OR (SymTab.ClassOf(at) = SymTab.ClArray)
- OR (SymTab.ClassOf(at) = SymTab.ClStr)
- OR (SymTab.ClassOf(at) = SymTab.ClUStr) THEN
- QbeGen.MakeOpen1DView(qe, at, ft, lastView, qt);
- IF NOT QbeGen.CallArg(qt, "l") THEN END
- ELSIF (SymTab.ClassOf(at) = SymTab.ClChar)
- AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar)
- AND QbeGen.IsImm(qe) THEN
- QbeGen.DeclCharStr(qe, qa);
- QbeGen.MakeOpen1DView(qa, at, ft, FALSE, qt);
- IF NOT QbeGen.CallArg(qt, "l") THEN END
- ELSIF SymTab.IsByteBuf(ft)
- AND (SymTab.ClassOf(at) # SymTab.ClArray)
- AND (SymTab.ClassOf(at) # SymTab.ClStr) THEN
- QbeGen.OpenScalarDesc(qe, at, ft, qa);
- QbeGen.MakeOpen1DView(qa, at, ft, FALSE, qt);
- IF NOT QbeGen.CallArg(qt, "l") THEN END
- ELSIF QbeGen.AddrOfVal(qe, qa) THEN
- IF NOT QbeGen.CallArg(qa, "l") THEN END
- END
- ELSIF isOpen1 AND isExtern AND lastView THEN
- QbeGen.ViewToOpen1D(qe, ft, qt, qb, qn);
- AppendArgL(qt, ft, cabi, qa);
- IF nVa <= HIGH(vaD) THEN
- QbeGen.CopyOp(qt, vaD[nVa]);
- QbeGen.CopyOp(qb, vaB[nVa]);
- QbeGen.CopyOp(qn, vaN[nVa]);
- INC(nVa)
- END;
- IF nFree <= HIGH(freeDesc) THEN
- QbeGen.CopyOp(qt, freeDesc[nFree]); INC(nFree)
- END
- ELSIF lastView AND (SymTab.ClassOf(ft) = SymTab.ClArray)
- AND (SymTab.ArrayDepth(ft) = 1) THEN
- QbeGen.ViewToOpen1D(qe, ft, qt, qb, qn);
- AppendArgL(qt, ft, cabi, qa);
- IF nVa <= HIGH(vaD) THEN
- QbeGen.CopyOp(qt, vaD[nVa]);
- QbeGen.CopyOp(qb, vaB[nVa]);
- QbeGen.CopyOp(qn, vaN[nVa]);
- INC(nVa)
- END;
- IF nFree <= HIGH(freeDesc) THEN
- QbeGen.CopyOp(qt, freeDesc[nFree]); INC(nFree)
- END
- ELSIF (SymTab.ClassOf(at) = SymTab.ClChar)
- AND (SymTab.ClassOf(ft) = SymTab.ClArray)
- AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar)
- AND QbeGen.IsImm(qe) THEN
- QbeGen.DeclCharStr(qe, qa);
- AppendArgL(qa, ft, cabi, qt)
- ELSIF SymTab.IsByteBuf(ft)
- AND (SymTab.ClassOf(at) # SymTab.ClArray)
- AND (SymTab.ClassOf(at) # SymTab.ClStr) THEN
- QbeGen.OpenScalarDesc(qe, at, ft, qa);
- IF NOT QbeGen.CallArg(qa, "l") THEN END
- ELSIF QbeGen.AddrOfVal(qe, qa) THEN
- AppendArgL(qa, ft, cabi, qt)
- END
- ELSE
- IF isOpen1 AND NOT isExtern THEN
- IF lastView OR (SymTab.ClassOf(at) = SymTab.ClArray)
- OR (SymTab.ClassOf(at) = SymTab.ClStr)
- OR (SymTab.ClassOf(at) = SymTab.ClUStr) THEN
- QbeGen.MakeOpen1DView(qe, at, ft, lastView, qt);
- IF NOT QbeGen.CallArg(qt, "l") THEN END
- ELSIF (SymTab.ClassOf(at) = SymTab.ClChar)
- AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar)
- AND QbeGen.IsImm(qe) THEN
- QbeGen.DeclCharStr(qe, qa);
- QbeGen.MakeOpen1DView(qa, at, ft, FALSE, qt);
- IF NOT QbeGen.CallArg(qt, "l") THEN END
- ELSIF SymTab.IsByteBuf(ft)
- AND (SymTab.ClassOf(at) # SymTab.ClArray)
- AND (SymTab.ClassOf(at) # SymTab.ClStr) THEN
- QbeGen.OpenScalarDesc(qe, at, ft, qa);
- QbeGen.MakeOpen1DView(qa, at, ft, FALSE, qt);
- IF NOT QbeGen.CallArg(qt, "l") THEN END
- ELSE
- IF NOT QbeGen.CallArg(qe, QbeGen.ArgClass(ft)) THEN END
- END
- ELSIF isOpen1 AND isExtern AND lastView THEN
- QbeGen.ViewToOpen1D(qe, ft, qt, qb, qn);
- QbeGen.CopyOp(qt, qe);
- IF nFree <= HIGH(freeDesc) THEN
- QbeGen.CopyOp(qt, freeDesc[nFree]); INC(nFree)
- END;
- AppendArg(qe, ft, cabi, qa)
- ELSIF lastView AND (SymTab.ClassOf(ft) = SymTab.ClArray)
- AND (SymTab.ArrayDepth(ft) = 1) THEN
- QbeGen.ViewToOpen1D(qe, ft, qt, qb, qn);
- QbeGen.CopyOp(qt, qe);
- IF nFree <= HIGH(freeDesc) THEN
- QbeGen.CopyOp(qt, freeDesc[nFree]); INC(nFree)
- END;
- AppendArg(qe, ft, cabi, qa)
- ELSIF (SymTab.ClassOf(at) = SymTab.ClChar)
- AND (SymTab.ClassOf(ft) = SymTab.ClArray)
- AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar)
- AND QbeGen.IsImm(qe) THEN
- QbeGen.DeclCharStr(qe, qa);
- AppendArg(qa, ft, cabi, qt)
- ELSIF SymTab.IsByteBuf(ft)
- AND (SymTab.ClassOf(at) # SymTab.ClArray)
- AND (SymTab.ClassOf(at) # SymTab.ClStr) THEN
- QbeGen.OpenScalarDesc(qe, at, ft, qa);
- IF NOT QbeGen.CallArg(qa, "l") THEN END
- ELSIF cabi
- AND (SymTab.ClassOf(ft) = SymTab.ClArray)
- AND SymTab.IsCharArray(ft) THEN
- AppendArg(qe, ft, cabi, qa)
- ELSE
- IF (SymTab.ClassOf(ft) = SymTab.ClSet)
- AND (SymTab.ClassOf(at) = SymTab.ClSet)
- AND (SymTab.IsPackedSet(ft) # SymTab.IsPackedSet(at)) THEN
- QbeGen.NewSetTemp(SymTab.SetWords(ft), qt);
- QbeGen.CopySetVal(qt, ft, qe, at);
- QbeGen.CopyOp(qt, qe)
- END;
- conv := SymTab.IsRealType(ft) AND SymTab.IsIntFamily(at);
- IF conv THEN
- QbeGen.ConvIR(qe, qt);
- AppendArg(qt, ft, cabi, qa)
- ELSE
- AppendArg(qe, ft, cabi, qa)
- END
- END
- END;
- INC(ai)
- END;
- INC(i)
- END;
- next := AST.NoNode;
- IF AST.NChild(seq) > 0 THEN
- next := AST.Child(seq, AST.NChild(seq) - 1);
- IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
- END;
- seq := next
- END;
- IF want THEN
- t := res; QbeGen.CallEnd(TRUE, q);
- IF SymTab.IsShortReal(res) THEN
- QbeGen.ConvRS(q, qt); QbeGen.CopyOp(qt, q)
- ELSIF SymTab.IsCBool(res) THEN
- QbeGen.MaskCBool(q, qt); QbeGen.CopyOp(qt, q)
- END;
- IF CompositeRes(res) THEN QbeGen.CopyOp(qres, q) END
- ELSE
- t := SymTab.InvalidType; QbeGen.CopyOp("0", q); QbeGen.CallEnd(FALSE, q)
- END;
- kva := 0;
- WHILE kva < nVa DO
- QbeGen.ViewCopyBack(vaD[kva], vaB[kva], vaN[kva]);
- INC(kva)
- END;
- kfree := 0;
- WHILE kfree < nFree DO
- QbeGen.ViewFree(freeDesc[kfree]);
- INC(kfree)
- END
- END LowerCall;
- PROCEDURE IsBuiltin (nm: ARRAY OF CHAR): BOOLEAN;
- BEGIN
- RETURN SymTab.Equal(nm, "ABS") OR SymTab.Equal(nm, "ODD")
- OR SymTab.Equal(nm, "CAP")
- OR SymTab.Equal(nm, "CHR") OR SymTab.Equal(nm, "ORD")
- OR SymTab.Equal(nm, "UCHR") OR SymTab.Equal(nm, "CHR8")
- OR SymTab.Equal(nm, "UORD")
- OR SymTab.Equal(nm, "SIZE") OR SymTab.Equal(nm, "TSIZE")
- OR SymTab.Equal(nm, "LEN") OR SymTab.Equal(nm, "HIGH")
- OR SymTab.Equal(nm, "VAL")
- OR SymTab.Equal(nm, "MIN") OR SymTab.Equal(nm, "MAX")
- OR SymTab.Equal(nm, "SHIFT") OR SymTab.Equal(nm, "ROTATE")
- OR SymTab.Equal(nm, "ADR")
- OR SymTab.Equal(nm, "INC") OR SymTab.Equal(nm, "DEC")
- OR SymTab.Equal(nm, "INCL") OR SymTab.Equal(nm, "EXCL")
- OR SymTab.Equal(nm, "NEW") OR SymTab.Equal(nm, "DISPOSE")
- END IsBuiltin;
- PROCEDURE LowerProcAddr (nm: ARRAY OF CHAR; VAR q: QbeGen.QVal);
- (* Code address of a procedure used as a value (assign to a procedure
- variable): $<base>_<uid>, or the plain C link for external procs.
- Declared before LowerBuiltinExpr, which uses it for ADR. *)
- VAR uid, depth, np: CARDINAL; res: SymTab.TypeIndex; ext: BOOLEAN;
- mg: QbeGen.QVal;
- base: SymTab.Name; ok: BOOLEAN;
- BEGIN
- ok := ProcInfo(nm, uid, res, depth, ext, np);
- IF NOT ok THEN
- (* a qualified/imported procedure appears under its base symbol
- name in the proc table *)
- IF SymTab.SymBase(nm, base) THEN
- ok := ProcInfo(base, uid, res, depth, ext, np)
- END
- END;
- IF ok THEN
- QbeGen.Mangled(nm, uid, mg);
- QbeGen.ProcAddr(mg, q)
- ELSE QbeGen.CopyOp("0", q)
- END
- END LowerProcAddr;
- PROCEDURE LowerBuiltinExpr (n: AST.Node; nm: SymTab.Name;
- VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal);
- (* Value builtins (Fact). *)
- VAR et, et2, dt, vt: SymTab.TypeIndex; qa, qt, q2, qd, qr: QbeGen.QVal;
- k, lo, hi, c1, c2, ucp: INTEGER; qn, vn: SymTab.Name; sfx: BOOLEAN;
- isMax, isU, uok: BOOLEAN;
- lit: ARRAY [0 .. 255] OF CHAR;
- BEGIN
- IF SymTab.Equal(nm, "ODD") THEN
- LowerExpr(AST.Child(n, 1), et, q);
- QbeGen.NewTemp(qt);
- QbeGen.Op3("and", qt, q, "1", FALSE); (* x & 1 *)
- QbeGen.NewTemp(qa);
- QbeGen.Cmp(SymTab.OpNeq1, qt, "0", qa, FALSE); (* <> 0 *)
- QbeGen.CopyOp(qa, q); t := SymTab.BoolType()
- ELSIF SymTab.Equal(nm, "ABS") THEN
- LowerExpr(AST.Child(n, 1), et, q);
- QbeGen.AbsQ(q, qa, SymTab.IsRealType(et));
- QbeGen.CopyOp(qa, q); t := et
- ELSIF SymTab.Equal(nm, "CAP") THEN
- LowerExpr(AST.Child(n, 1), et, q);
- QbeGen.CapQ(q, qa); QbeGen.CopyOp(qa, q); t := SymTab.CharType()
- ELSIF SymTab.Equal(nm, "CHR") THEN
- LowerExpr(AST.Child(n, 1), et, q); t := SymTab.CharType()
- ELSIF SymTab.Equal(nm, "ORD") THEN
- LowerExpr(AST.Child(n, 1), et, q);
- IF SymTab.IsPackedSet(et) THEN
- QbeGen.LoadPacked(q, et, qa); QbeGen.CopyOp(qa, q)
- END;
- t := SymTab.IntType()
- ELSIF SymTab.Equal(nm, "UCHR") THEN
- LowerExpr(AST.Child(n, 1), et, q); t := SymTab.UCharType()
- ELSIF SymTab.Equal(nm, "CHR8") THEN
- LowerExpr(AST.Child(n, 1), et, q);
- QbeGen.WidenLong(q, qa); QbeGen.CheckRange(qa, "0", "255");
- t := SymTab.CharType()
- ELSIF SymTab.Equal(nm, "UORD") THEN
- LowerExpr(AST.Child(n, 1), et, q); t := SymTab.IntType()
- ELSIF SymTab.Equal(nm, "SIZE") OR SymTab.Equal(nm, "TSIZE") THEN
- LowerDesign(AST.Child(n, 1), dt, k, qd, qn, sfx);
- IF (dt # SymTab.InvalidType)
- AND (SymTab.ClassOf(dt) = SymTab.ClArray) THEN
- IF lastView THEN
- QbeGen.ViewSize(qd, q)
- ELSIF SymTab.IsOpenArray(dt) THEN
- QbeGen.OpenSize(qd, dt, q)
- ELSIF SymTab.IsMultiArray(dt) THEN
- QbeGen.IntStr(VAL(INTEGER, SymTab.ArrayPayloadSize(dt)), q)
- ELSE
- QbeGen.IntStr(VAL(INTEGER,
- SymTab.ArrayLen(dt) * SymTab.ArrayLeafBytes(dt)), q)
- END
- ELSE
- QbeGen.IntStr(VAL(INTEGER, SymTab.ObjectSize(dt)), q)
- END;
- t := SymTab.IntType()
- ELSIF SymTab.Equal(nm, "MIN") OR SymTab.Equal(nm, "MAX") THEN
- isMax := SymTab.Equal(nm, "MAX");
- LowerDesign(AST.Child(n, 1), dt, k, qd, qn, sfx);
- IF SymTab.ClassOf(dt) = SymTab.ClSReal THEN
- IF isMax THEN QbeGen.NormReal("3.402823e38", q)
- ELSE QbeGen.NormReal("-3.402823e38", q) END;
- t := SymTab.ShortRealType()
- ELSIF SymTab.ClassOf(dt) = SymTab.ClReal THEN
- IF isMax THEN QbeGen.NormReal("1.7976931348623157e308", q)
- ELSE QbeGen.NormReal("-1.7976931348623157e308", q) END;
- t := SymTab.RealType()
- ELSIF SymTab.ClassOf(dt) = SymTab.ClLong THEN
- IF isMax THEN QbeGen.CopyOp("9223372036854775807", q)
- ELSE QbeGen.CopyOp("-9223372036854775808", q) END;
- t := SymTab.LongType()
- ELSIF SymTab.TypeBounds(dt, lo, hi) THEN
- IF isMax THEN QbeGen.IntStr(hi, q) ELSE QbeGen.IntStr(lo, q) END;
- t := SymTab.IntType()
- ELSE t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- END
- ELSIF SymTab.Equal(nm, "LEN") OR SymTab.Equal(nm, "HIGH") THEN
- IF AST.Kind(AST.Child(n, 1)) = AST.NkStrLit THEN
- (* LEN("literal"): the content length of the literal; a real
- string literal is still declared, as the grammar does *)
- Name(AST.Child(n, 1), lit);
- IF (lit[0] = "U") OR (lit[0] = "u") THEN
- QbeGen.DeclUStr(lit, qd, isU, ucp, uok);
- IF NOT uok THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- ELSIF isU THEN
- IF SymTab.Equal(nm, "HIGH") THEN QbeGen.CopyOp("0", q)
- ELSE QbeGen.CopyOp("1", q)
- END;
- t := SymTab.IntType()
- ELSE
- QbeGen.UStrLen(qd, qr);
- IF SymTab.Equal(nm, "HIGH") THEN QbeGen.DecQ(qr) END;
- QbeGen.CopyOp(qr, q); t := SymTab.IntType()
- END
- ELSE
- IF SymTab.StrLen(lit) = 3 THEN c1 := 1
- ELSE QbeGen.DeclStr(lit, qd); c1 := SymTab.StrLen(lit) - 2
- END;
- IF SymTab.Equal(nm, "HIGH") THEN DEC(c1) END;
- QbeGen.IntStr(c1, q); t := SymTab.IntType()
- END
- ELSE
- LowerDesign(AST.Child(n, 1), dt, k, qd, qn, sfx);
- IF dt = SymTab.InvalidType THEN
- t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- ELSIF SymTab.ClassOf(dt) = SymTab.ClStr THEN
- (* HIGH/LEN of a string CONST: the pooled literal knows its
- length *)
- IF QbeGen.StrLitLen(qd, c1) THEN
- IF SymTab.Equal(nm, "HIGH") THEN DEC(c1) END;
- QbeGen.IntStr(c1, q); t := SymTab.IntType()
- ELSE t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- END
- ELSIF SymTab.ClassOf(dt) = SymTab.ClArray THEN
- IF SymTab.Equal(nm, "HIGH") THEN
- IF SymTab.IsOpenArray(dt) THEN QbeGen.OpenHi(qd, q)
- ELSE QbeGen.IntStr(SymTab.ArrayHi(dt), q) END
- ELSE
- IF SymTab.IsOpenArray(dt) THEN QbeGen.LoadCount(qd, q)
- ELSE QbeGen.IntStr(VAL(INTEGER, SymTab.ArrayLen(dt)), q) END
- END;
- t := SymTab.IntType()
- ELSE
- t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- END
- END;
- ELSIF SymTab.Equal(nm, "VAL") THEN
- Name(AST.Child(n, 1), vn);
- IF NOT SymTab.Lookup(vn) THEN
- t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- ELSE
- vt := SymTab.SymType(vn);
- LowerExpr(AST.Child(n, 2), et, q);
- c1 := SymTab.ClassOf(et); c2 := SymTab.ClassOf(vt);
- IF ((c1 = SymTab.ClInt) OR (c1 = SymTab.ClByte)
- OR (c1 = SymTab.ClSByte) OR (c1 = SymTab.ClWord16)
- OR (c1 = SymTab.ClSWord16))
- AND (c2 = SymTab.ClLong) THEN
- QbeGen.WidenLong(q, qa); QbeGen.CopyOp(qa, q); t := vt
- ELSIF (c1 = SymTab.ClLong) AND ((c2 = SymTab.ClInt)
- OR (c2 = SymTab.ClByte) OR (c2 = SymTab.ClSByte)
- OR (c2 = SymTab.ClWord16) OR (c2 = SymTab.ClSWord16)) THEN
- QbeGen.NarrowLong(q, qa); QbeGen.CopyOp(qa, q); t := vt
- ELSIF ((c1 = SymTab.ClInt) OR (c1 = SymTab.ClByte)
- OR (c1 = SymTab.ClSByte) OR (c1 = SymTab.ClWord16)
- OR (c1 = SymTab.ClSWord16))
- AND ((c2 = SymTab.ClReal) OR (c2 = SymTab.ClSReal)) THEN
- QbeGen.ConvIR(q, qa); QbeGen.CopyOp(qa, q); t := vt
- ELSIF (c1 = SymTab.ClLong)
- AND ((c2 = SymTab.ClReal) OR (c2 = SymTab.ClSReal)) THEN
- QbeGen.ConvLR(q, qa); QbeGen.CopyOp(qa, q); t := vt
- ELSIF ((c1 = SymTab.ClReal) OR (c1 = SymTab.ClSReal))
- AND ((c2 = SymTab.ClInt)
- OR (c2 = SymTab.ClByte) OR (c2 = SymTab.ClSByte)
- OR (c2 = SymTab.ClWord16) OR (c2 = SymTab.ClSWord16)) THEN
- QbeGen.ConvRI(q, qa); QbeGen.CopyOp(qa, q); t := vt
- ELSIF ((c1 = SymTab.ClReal) OR (c1 = SymTab.ClSReal))
- AND (c2 = SymTab.ClLong) THEN
- QbeGen.ConvRL(q, qa); QbeGen.CopyOp(qa, q); t := vt
- ELSIF ((c1 = SymTab.ClReal) OR (c1 = SymTab.ClSReal))
- AND ((c2 = SymTab.ClReal) OR (c2 = SymTab.ClSReal)) THEN
- t := vt
- ELSIF ((c1 = SymTab.ClInt) OR (c1 = SymTab.ClByte)
- OR (c1 = SymTab.ClSByte) OR (c1 = SymTab.ClWord16)
- OR (c1 = SymTab.ClSWord16) OR (c1 = SymTab.ClLong))
- AND (c2 = SymTab.ClPtr) THEN
- IF (c1 # SymTab.ClLong) AND NOT QbeGen.IsImm(q) THEN
- QbeGen.WidenLong(q, qa); QbeGen.CopyOp(qa, q)
- END;
- t := vt
- ELSIF (c1 = SymTab.ClSet) AND (c2 = SymTab.ClInt) THEN
- (* a set as its (first) machine word *)
- QbeGen.LoadW(q, qa); QbeGen.CopyOp(qa, q); t := vt
- ELSIF (c1 = SymTab.ClInt) AND (c2 = SymTab.ClSet) THEN
- (* a word as a set value: zero-filled one-word temp *)
- c2 := SymTab.SetWords(vt);
- IF c2 = 0 THEN c2 := 1 END;
- QbeGen.NewSetTemp(VAL(CARDINAL, c2), qa);
- QbeGen.SetZero(qa, VAL(CARDINAL, c2));
- QbeGen.StoreW(qa, q); QbeGen.CopyOp(qa, q); t := vt
- ELSE t := vt (* same representation: no-op *)
- END
- END
- ELSIF SymTab.Equal(nm, "SHIFT") OR SymTab.Equal(nm, "ROTATE") THEN
- LowerExpr(AST.Child(n, 1), et, q);
- LowerExpr(AST.Child(n, 2), et2, q2);
- QbeGen.SetShift(q, q2, SymTab.SetWords(et), SymTab.SetCount(et),
- SymTab.Equal(nm, "ROTATE"), qt);
- t := et; QbeGen.CopyOp(qt, q)
- ELSIF SymTab.Equal(nm, "ADR") THEN
- LowerDesign(AST.Child(n, 1), dt, k, qd, qn, sfx);
- IF k = SymTab.KindProc THEN
- LowerProcAddr(qn, q)
- ELSIF lastView THEN
- QbeGen.ViewBase(qd, q)
- ELSIF (dt # SymTab.InvalidType)
- AND (SymTab.ClassOf(dt) = SymTab.ClArray)
- AND SymTab.IsOpenArray(dt) AND (NOT sfx) THEN
- IF legacyOpen1D THEN QbeGen.DescData(qd, q)
- ELSE QbeGen.ViewBase(qd, q)
- END
- ELSIF sfx THEN QbeGen.CopyOp(qd, q)
- ELSIF (k = SymTab.KindVar) OR (k = SymTab.KindParam) THEN
- QbeGen.AddrOf(qn, q)
- ELSE QbeGen.CopyOp("0", q)
- END;
- t := SymTab.AddrType()
- ELSE t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- END
- END LowerBuiltinExpr;
- PROCEDURE LowerBuiltinStmt (n: AST.Node; nm: SymTab.Name);
- (* Statement builtins (AssOrCall): INC/DEC, INCL/EXCL, NEW/DISPOSE. *)
- VAR dt, at, et2, bt: SymTab.TypeIndex; dk: INTEGER;
- qd, qv, qe, qn2, qstep, qm: QbeGen.QVal;
- qn: SymTab.Name; sfx, isInc: BOOLEAN;
- BEGIN
- IF SymTab.Equal(nm, "INC") OR SymTab.Equal(nm, "DEC") THEN
- isInc := SymTab.Equal(nm, "INC");
- QbeGen.CopyOp("1", qstep);
- LowerDesign(AST.Child(n, 1), dt, dk, qd, qn, sfx);
- IF AST.NChild(n) > 2 THEN LowerExpr(AST.Child(n, 2), et2, qstep) END;
- IF dt = SymTab.InvalidType THEN
- ELSE
- IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemLoad(qd, dt, qv)
- ELSIF SymTab.IsSmallInt(dt) THEN
- QbeGen.LoadShortVar(qn, SymTab.IsSignedSmallInt(dt),
- SymTab.SmallIntBytes(dt), qv)
- ELSE QbeGen.LoadVar(qn, FALSE, qv)
- END;
- QbeGen.NewTemp(qn2);
- IF isInc THEN QbeGen.Op3("add", qn2, qv, qstep, FALSE)
- ELSE QbeGen.Op3("sub", qn2, qv, qstep, FALSE)
- END;
- CheckSub(dt, qn2);
- IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, qn2, dt)
- ELSIF SymTab.IsSmallInt(dt) THEN
- QbeGen.StoreShortVar(qn, SymTab.SmallIntBytes(dt), qn2)
- ELSE QbeGen.StoreVar(qn, qn2, FALSE)
- END
- END
- ELSIF SymTab.Equal(nm, "INCL") OR SymTab.Equal(nm, "EXCL") THEN
- isInc := SymTab.Equal(nm, "INCL");
- LowerDesign(AST.Child(n, 1), at, dk, qd, qn, sfx);
- LowerExpr(AST.Child(n, 2), et2, qe);
- IF at = SymTab.InvalidType THEN
- ELSIF SymTab.ClassOf(at) # SymTab.ClSet THEN
- ELSE
- IF SymTab.IsBigSet(at) THEN
- IF isInc THEN QbeGen.BigSetBit(qd, qe, SymTab.BigSetSigned(at))
- ELSE QbeGen.BigSetClearBit(qd, qe, SymTab.BigSetSigned(at))
- END
- ELSIF SymTab.IsPackedSet(at) THEN
- IF isInc THEN QbeGen.PackedSetBit(qd, at, qe,
- SymTab.SetBaseLo(at),
- SymTab.SetCount(at))
- ELSE QbeGen.PackedSetClearBit(qd, at, qe,
- SymTab.SetBaseLo(at),
- SymTab.SetCount(at))
- END
- ELSIF isInc THEN QbeGen.SetBit(qd, qe, SymTab.SetBaseLo(at), SymTab.SetCount(at))
- ELSE QbeGen.SetClearBit(qd, qe, SymTab.SetBaseLo(at), SymTab.SetCount(at))
- END
- END
- ELSIF SymTab.Equal(nm, "NEW") THEN
- LowerDesign(AST.Child(n, 1), dt, dk, qd, qn, sfx);
- IF dt = SymTab.InvalidType THEN
- ELSIF SymTab.ClassOf(dt) # SymTab.ClPtr THEN
- ELSE
- bt := SymTab.PtrBase(dt);
- IF bt # SymTab.InvalidType THEN
- QbeGen.NewHeap(bt, qm); QbeGen.InitHeap(qm, bt);
- IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, qm, dt)
- ELSE QbeGen.StorePtr(qn, qm)
- END
- END
- END
- ELSIF SymTab.Equal(nm, "DISPOSE") THEN
- LowerDesign(AST.Child(n, 1), dt, dk, qd, qn, sfx);
- IF dt = SymTab.InvalidType THEN
- ELSIF SymTab.ClassOf(dt) # SymTab.ClPtr THEN
- ELSE
- IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemLoad(qd, dt, qv)
- ELSE QbeGen.LoadPtr(qn, qv)
- END;
- QbeGen.FreeHeap(qv);
- IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, "0", dt)
- ELSE QbeGen.StorePtr(qn, "0")
- END
- END
- END
- END LowerBuiltinStmt;
- PROCEDURE LowerMethod (m: AST.Node; ct: SymTab.TypeIndex);
- (* A class method: hidden THIS receiver, then declared formals; the body
- runs with THIS pushed as the WITH base (bare field names resolve). *)
- VAR nm, txt: SymTab.Name; mg, thisQ: QbeGen.QVal;
- uid, depth, np: CARDINAL; res, pt: SymTab.TypeIndex;
- pv, ext: BOOLEAN; j: CARDINAL; saveCls: SymTab.TypeIndex;
- savedProc: INTEGER;
- BEGIN
- IF (AST.Op(m) # 0) AND (AST.Op(m) # 3) THEN RETURN END;
- Name(AST.Child(m, 0), nm);
- IF NOT ProcInfo(nm, uid, res, depth, ext, np) THEN RETURN END;
- QbeGen.Mangled(nm, SymTab.ClassMethodUid(ct, nm), mg);
- QbeGen.BeginFunc(mg);
- IF NOT QbeGen.FuncParam("THIS", TRUE, ct) THEN END;
- IF CompositeRes(res) THEN
- IF NOT QbeGen.FuncParam("__res", TRUE, res) THEN END
- END;
- j := 0;
- WHILE j < np DO
- IF NOT ParamInfo(nm, j, pt, pv, txt) THEN END;
- IF NOT QbeGen.FuncParam(txt, pv OR SymTab.IsOpenArray(pt), pt) THEN END;
- INC(j)
- END;
- QbeGen.SetFuncRes(res);
- QbeGen.EndFuncHeader;
- QbeGen.ThisBase(thisQ);
- saveCls := curImplCls;
- curImplCls := ct;
- QbeGen.PushWith(thisQ);
- IF withTop <= HIGH(withRec) THEN withRec[withTop] := ct; INC(withTop) END;
- savedProc := emitProc;
- emitProc := FindProc(nm);
- LowerDecls(AST.Child(m, 2));
- nUserLab := 0;
- LowerStmt(AST.Child(m, 1));
- emitProc := savedProc;
- IF withTop > 0 THEN DEC(withTop) END;
- curImplCls := saveCls;
- QbeGen.PopWith;
- QbeGen.EndFunc(res)
- END LowerMethod;
- PROCEDURE LowerMethods (seq: AST.Node; ct: SymTab.TypeIndex);
- VAR i: CARDINAL; m: AST.Node;
- BEGIN
- IF seq = AST.NoNode THEN RETURN END;
- i := 0;
- WHILE i < AST.NChild(seq) DO
- m := AST.Child(seq, i);
- IF i = AST.MaxChild - 1 THEN LowerMethods(m, ct)
- ELSIF AST.Kind(m) = AST.NkFieldDecl THEN LowerMethods(m, ct)
- ELSIF AST.Kind(m) = AST.NkProcDecl THEN LowerMethod(m, ct)
- END;
- INC(i)
- END
- END LowerMethods;
- PROCEDURE LowerMethodHeadings (seq: AST.Node; ct: SymTab.TypeIndex);
- (* Class-declaration method headings: emit+discard a function header per
- method so the backend temp counters advance exactly as the legacy
- parse did (the implementation's temps then line up). *)
- VAR i, j: CARDINAL; m: AST.Node; nm, txt: SymTab.Name;
- mg: QbeGen.QVal; uid, depth, np: CARDINAL; res, pt: SymTab.TypeIndex;
- pv, ext: BOOLEAN;
- BEGIN
- IF seq = AST.NoNode THEN RETURN END;
- i := 0;
- WHILE i < AST.NChild(seq) DO
- m := AST.Child(seq, i);
- IF i = AST.MaxChild - 1 THEN LowerMethodHeadings(m, ct)
- ELSIF AST.Kind(m) = AST.NkFieldDecl THEN LowerMethodHeadings(m, ct)
- ELSIF AST.Kind(m) = AST.NkProcDecl THEN
- Name(AST.Child(m, 0), nm);
- IF ProcInfo(nm, uid, res, depth, ext, np) THEN
- QbeGen.Mangled(nm, SymTab.ClassMethodUid(ct, nm), mg);
- QbeGen.BeginFunc(mg);
- j := 0;
- WHILE j < np DO
- IF NOT ParamInfo(nm, j, pt, pv, txt) THEN END;
- IF NOT QbeGen.FuncParam(txt, pv OR SymTab.IsOpenArray(pt), pt) THEN END;
- INC(j)
- END;
- QbeGen.SetFuncRes(res);
- QbeGen.AbortFunc
- END
- END;
- INC(i)
- END
- END LowerMethodHeadings;
- PROCEDURE LowerMethodCall (n: AST.Node; VAR t: SymTab.TypeIndex;
- VAR q: QbeGen.QVal; want: BOOLEAN);
- VAR d: AST.Node; ct, res, ft, at: SymTab.TypeIndex;
- cq, mg, qa, qt, qe, qres: QbeGen.QVal; fn, pn: SymTab.Name;
- k, vs: INTEGER; i: CARDINAL; sfx, isV, conv: BOOLEAN;
- BEGIN
- d := AST.Child(n, 0);
- curMethCls := SymTab.InvalidType;
- LowerDesign(d, ct, k, cq, pn, sfx);
- ct := curMethCls;
- IF ct = SymTab.InvalidType THEN
- t := SymTab.InvalidType; QbeGen.CopyOp("0", q); RETURN
- END;
- IF AST.NChild(d) = 1 THEN
- Name(AST.Child(d, 0), fn)
- ELSE
- Name(AST.Child(AST.Child(d, AST.NChild(d) - 1), 0), fn)
- END;
- res := SymTab.ClassMethodRes(ct, fn);
- vs := SymTab.VirtSlot(ct, fn);
- IF vs >= 0 THEN QbeGen.VirtCallBegin(cq, vs, res)
- ELSE
- QbeGen.Mangled(fn, SymTab.ClassMethodUid(ct, fn), mg);
- QbeGen.CallBegin(mg, res, 0, FALSE)
- END;
- IF CompositeRes(res) THEN
- QbeGen.AllocLocal(res, qres);
- IF NOT QbeGen.CallArg(qres, "l") THEN END
- END;
- i := 1;
- WHILE i < AST.NChild(n) DO
- LowerExpr(AST.Child(n, i), at, qe);
- ft := SymTab.ClassMethodParamType(ct, fn, i - 1);
- isV := SymTab.ClassMethodParamIsVar(ct, fn, i - 1);
- IF isV THEN
- IF QbeGen.AddrOfVal(qe, qa) THEN
- IF NOT QbeGen.CallArg(qa, "l") THEN END
- END
- ELSE
- conv := SymTab.IsRealType(ft) AND SymTab.IsIntFamily(at);
- IF conv THEN
- QbeGen.ConvIR(qe, qt);
- IF NOT QbeGen.CallArg(qt, "d") THEN END
- ELSE
- IF NOT QbeGen.CallArg(qe, QbeGen.ArgClass(ft)) THEN END
- END
- END;
- INC(i)
- END;
- IF want THEN t := res; QbeGen.CallEnd(TRUE, q);
- IF CompositeRes(res) THEN QbeGen.CopyOp(qres, q) END
- ELSE t := SymTab.InvalidType; QbeGen.CopyOp("0", q); QbeGen.CallEnd(FALSE, q)
- END
- END LowerMethodCall;
- PROCEDURE LowerCase (n: AST.Node);
- (* CASE as a compare-chain (mirrors CaseStat/CaseAlt/CaseLabel). The
- arm list is chunked (AstAppend) so a CASE with more than MaxChild
- alternatives is not truncated. *)
- VAR i, j: CARDINAL; arm, lab, seq, next: AST.Node;
- tsel, t2, t3: SymTab.TypeIndex;
- qsel, q2, q3, qc, qd, qe, lEnd, lBody, lAfter, lNext: QbeGen.QVal;
- hasElse: BOOLEAN;
- BEGIN
- LowerExpr(AST.Child(n, 0), tsel, qsel);
- hasElse := FALSE;
- QbeGen.NewLabel(lEnd);
- (* pass 1: alternatives (ELSE arms come after) *)
- seq := AST.Child(n, 1);
- WHILE seq # AST.NoNode DO
- i := 0;
- WHILE i < AST.NChild(seq) DO
- arm := AST.Child(seq, i);
- IF AST.Kind(arm) = AST.NkBlock THEN
- (* continuation chunk *)
- ELSIF AST.Op(arm) = 1 THEN
- (* ELSE arm: emitted in pass 2 *)
- hasElse := TRUE
- ELSE
- QbeGen.NewLabel(lBody); QbeGen.NewLabel(lAfter);
- j := 0;
- WHILE j + 1 < AST.NChild(arm) DO
- lab := AST.Child(arm, j);
- IF AST.Kind(lab) = AST.NkSubrange THEN
- LowerExpr(AST.Child(lab, 0), t2, q2);
- IF SymTab.IsEmptyStr(t2)
- AND (SymTab.ClassOf(tsel) = SymTab.ClChar) THEN
- QbeGen.CopyOp("0", q2); t2 := SymTab.CharType()
- END;
- QbeGen.NewLabel(lNext);
- QbeGen.Cmp(SymTab.OpEq, qsel, q2, qc, FALSE);
- QbeGen.Jnz(qc, lBody, lNext);
- QbeGen.EmitLabel(lNext);
- LowerExpr(AST.Child(lab, 1), t3, q3);
- IF SymTab.IsEmptyStr(t3)
- AND (SymTab.ClassOf(tsel) = SymTab.ClChar) THEN
- QbeGen.CopyOp("0", q3); t3 := SymTab.CharType()
- END;
- QbeGen.Cmp(SymTab.OpGe, qsel, q2, qc, FALSE);
- QbeGen.Cmp(SymTab.OpLe, qsel, q3, qd, FALSE);
- QbeGen.NewTemp(qe);
- QbeGen.Op3("and", qe, qc, qd, FALSE);
- QbeGen.NewLabel(lNext);
- QbeGen.Jnz(qe, lBody, lNext);
- QbeGen.EmitLabel(lNext)
- ELSE
- LowerExpr(lab, t2, q2);
- IF SymTab.IsEmptyStr(t2)
- AND (SymTab.ClassOf(tsel) = SymTab.ClChar) THEN
- QbeGen.CopyOp("0", q2); t2 := SymTab.CharType()
- END;
- QbeGen.NewLabel(lNext);
- IF (SymTab.ClassOf(tsel) = SymTab.ClSet)
- AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN
- QbeGen.CmpSet(SymTab.OpEq, qsel, q2,
- SymTab.SetWords(tsel), SymTab.SetWords(t2), qc)
- ELSE
- QbeGen.Cmp(SymTab.OpEq, qsel, q2, qc, FALSE)
- END;
- QbeGen.Jnz(qc, lBody, lNext);
- QbeGen.EmitLabel(lNext)
- END;
- INC(j)
- END;
- QbeGen.Jmp(lAfter);
- QbeGen.EmitLabel(lBody);
- LowerStmt(AST.Child(arm, AST.NChild(arm) - 1));
- QbeGen.Jmp(lEnd);
- QbeGen.EmitLabel(lAfter)
- END;
- INC(i)
- END;
- next := AST.NoNode;
- IF AST.NChild(seq) > 0 THEN
- next := AST.Child(seq, AST.NChild(seq) - 1);
- IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
- END;
- seq := next
- END;
- IF NOT hasElse THEN
- QbeGen.TrapCode(2) (* caseSelectException *)
- END;
- (* pass 2: ELSE arms *)
- seq := AST.Child(n, 1);
- WHILE seq # AST.NoNode DO
- i := 0;
- WHILE i < AST.NChild(seq) DO
- arm := AST.Child(seq, i);
- IF (AST.Kind(arm) # AST.NkBlock) AND (AST.Op(arm) = 1) THEN
- LowerStmt(AST.Child(arm, 0))
- END;
- INC(i)
- END;
- next := AST.NoNode;
- IF AST.NChild(seq) > 0 THEN
- next := AST.Child(seq, AST.NChild(seq) - 1);
- IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
- END;
- seq := next
- END;
- QbeGen.EmitLabel(lEnd)
- END LowerCase;
- PROCEDURE LowerWith (n: AST.Node);
- (* WITH: push each record's base address, lower the body, pop only the
- levels this WITH pushed (a nested WITH must restore the outer one). *)
- VAR i, base: CARDINAL; dt: SymTab.TypeIndex; dk: INTEGER;
- qd: QbeGen.QVal; qn: SymTab.Name; sfx: BOOLEAN;
- BEGIN
- base := withTop;
- i := 0;
- WHILE i + 1 < AST.NChild(n) DO
- LowerDesign(AST.Child(n, i), dt, dk, qd, qn, sfx);
- QbeGen.PushWith(qd);
- IF withTop <= HIGH(withRec) THEN
- withRec[withTop] := dt; INC(withTop)
- END;
- INC(i)
- END;
- LowerStmt(AST.Child(n, AST.NChild(n) - 1));
- WHILE withTop > base DO DEC(withTop); QbeGen.PopWith END
- END LowerWith;
- PROCEDURE LowerExprFull (n: AST.Node; VAR t: SymTab.TypeIndex;
- VAR q: QbeGen.QVal; VAR k: INTEGER;
- VAR qn: SymTab.Name; VAR sfx: BOOLEAN;
- asAddr: BOOLEAN);
- VAR t2: SymTab.TypeIndex; q2, qt, qf, qs, qr, qaddr, qa, qb: QbeGen.QVal;
- lNext, lFalse, lTrue, lDone: QbeGen.QVal;
- kind, op, rop, ucp: INTEGER;
- folded, isR, isCh, isU, uok: BOOLEAN;
- i: CARDINAL; el, seq, next: AST.Node;
- lw, rw, mw: CARDINAL; idx: INTEGER; fok, isL: BOOLEAN;
- lt, rt: SymTab.TypeIndex; qw: QbeGen.QVal;
- lit: ARRAY [0 .. 255] OF CHAR;
- BEGIN
- IF AST.Kind(n) = AST.NkDesignator THEN
- LowerDesign(n, t, k, q, qn, sfx);
- IF k = SymTab.KindProc THEN
- (* bare procedure used as a value: its code address *)
- LowerProcAddr(qn, q);
- RETURN
- END;
- (* Record value->address for VAR actuals, mirroring the grammar's
- Design. AddrOfVal cannot rely on the grammar's notes: its ring
- (256) wraps long before a whole-session emit finishes. *)
- IF sfx THEN QbeGen.CopyOp(q, qaddr) ELSE QbeGen.AddrOf(qn, qaddr) END;
- IF NOT asAddr THEN FinalLoad(t, sfx, q) END;
- IF (k = SymTab.KindVar) OR (k = SymTab.KindParam)
- OR (k = SymTab.KindField) THEN
- QbeGen.NoteAddr(q, qaddr)
- ELSIF sfx AND (t # SymTab.InvalidType)
- AND ((SymTab.ClassOf(t) = SymTab.ClArray)
- OR (SymTab.ClassOf(t) = SymTab.ClSet)
- OR (SymTab.ClassOf(t) = SymTab.ClRecord)) THEN
- QbeGen.NoteAddr(q, qaddr)
- END;
- RETURN
- END;
- k := -1; qn[0] := CHR(0); sfx := FALSE;
- IF AST.Kind(n) = AST.NkIntLit THEN
- Name(n, qn); QbeGen.NormInt(qn, q); t := SymTab.IntType()
- ELSIF AST.Kind(n) = AST.NkCharLit THEN
- Name(n, qn); QbeGen.NormLit(qn, q, isCh); t := SymTab.CharType()
- ELSIF AST.Kind(n) = AST.NkRealLit THEN
- Name(n, qn); QbeGen.NormReal(qn, q); t := SymTab.RealType()
- ELSIF AST.Kind(n) = AST.NkStrLit THEN
- Name(n, lit);
- IF (lit[0] = "U") OR (lit[0] = "u") THEN
- (* U"..." / U'...': one codepoint -> UCHAR, else a ustring *)
- QbeGen.DeclUStr(lit, q, isU, ucp, uok);
- IF NOT uok THEN
- t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- ELSIF isU THEN
- t := SymTab.UCharType(); QbeGen.IntStr(ucp, q)
- ELSE
- t := AST.Ty(n); IF t = -1 THEN t := SymTab.NewUStr() END; QbeGen.NoteAddr(q, q)
- END
- ELSIF SymTab.StrLen(lit) = 3 THEN
- t := SymTab.CharType(); QbeGen.IntStr(QbeGen.CharVal(lit), q)
- ELSE
- t := AST.Ty(n); IF t = -1 THEN t := SymTab.NewStr() END;
- QbeGen.DeclStr(lit, q); QbeGen.NoteAddr(q, q)
- END
- ELSIF AST.Kind(n) = AST.NkSetLit THEN
- t := AST.Ty(n); IF t = -1 THEN t := SymTab.NewSet(SymTab.NewSubR(0, 255)) END;
- IF SymTab.IsBigSet(t) THEN
- QbeGen.NewSetTemp(2, q); QbeGen.SetZero(q, 2)
- ELSE
- QbeGen.NewSetTemp(8, q); QbeGen.SetZero(q, 8)
- END;
- i := 0;
- WHILE i < AST.NChild(n) DO
- el := AST.Child(n, i);
- IF AST.Kind(el) = AST.NkSubrange THEN
- LowerExpr(AST.Child(el, 0), t2, q2);
- LowerExpr(AST.Child(el, 1), t2, qt);
- IF SymTab.IsBigSet(t) THEN
- QbeGen.BigSetRange(q, q2, qt, SymTab.BigSetSigned(t))
- ELSE
- QbeGen.SetRange(q, q2, qt, SymTab.SetBaseLo(t), SymTab.SetCount(t))
- END
- ELSE
- LowerExpr(el, t2, q2);
- IF SymTab.IsBigSet(t) THEN
- QbeGen.BigSetBit(q, q2, SymTab.BigSetSigned(t))
- ELSE
- QbeGen.SetBit(q, q2, SymTab.SetBaseLo(t), SymTab.SetCount(t))
- END
- END;
- INC(i)
- END
- ELSIF AST.Kind(n) = AST.NkBraceLit THEN
- (* T{...} typed brace literal: a set here (the type was recorded by
- the grammar in the node's ty field). Array/record/class
- constructors are not lowered here yet. *)
- t := AST.Ty(n);
- IF (t # SymTab.InvalidType) AND (SymTab.ClassOf(t) = SymTab.ClSet) THEN
- IF SymTab.IsBigSet(t) THEN
- QbeGen.NewSetTemp(2, q); QbeGen.SetZero(q, 2)
- ELSIF SymTab.SetWords(t) = 0 THEN
- QbeGen.NewSetTemp(8, q); QbeGen.SetZero(q, 8)
- ELSE
- QbeGen.NewSetTemp(SymTab.SetWords(t), q);
- QbeGen.SetZero(q, SymTab.SetWords(t))
- END;
- seq := n;
- WHILE seq # AST.NoNode DO
- i := 0;
- WHILE i < AST.NChild(seq) DO
- el := AST.Child(seq, i);
- IF AST.Kind(el) # AST.NkBlock THEN
- IF AST.Kind(el) = AST.NkSubrange THEN
- LowerExpr(AST.Child(el, 0), t2, q2);
- LowerExpr(AST.Child(el, 1), t2, qt);
- IF SymTab.IsBigSet(t) THEN
- QbeGen.BigSetRange(q, q2, qt, SymTab.BigSetSigned(t))
- ELSE
- QbeGen.SetRange(q, q2, qt, SymTab.SetBaseLo(t),
- SymTab.SetCount(t))
- END
- ELSE
- LowerExpr(el, t2, q2);
- IF SymTab.IsBigSet(t) THEN
- QbeGen.BigSetBit(q, q2, SymTab.BigSetSigned(t))
- ELSE
- QbeGen.SetBit(q, q2, SymTab.SetBaseLo(t), SymTab.SetCount(t))
- END
- END
- END;
- INC(i)
- END;
- next := AST.NoNode;
- IF AST.NChild(seq) > 0 THEN
- next := AST.Child(seq, AST.NChild(seq) - 1);
- IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
- END;
- seq := next
- END
- ELSIF (t # SymTab.InvalidType)
- AND ((SymTab.ClassOf(t) = SymTab.ClArray)
- OR (SymTab.ClassOf(t) = SymTab.ClRecord)
- OR (SymTab.ClassOf(t) = SymTab.ClClass)) THEN
- (* T{...} aggregate constructor *)
- QbeGen.CtorBegin(t);
- seq := n;
- WHILE seq # AST.NoNode DO
- i := 0;
- WHILE i < AST.NChild(seq) DO
- el := AST.Child(seq, i);
- IF AST.Kind(el) # AST.NkBlock THEN
- LowerExpr(el, t2, q2);
- QbeGen.CtorElem(q2)
- END;
- INC(i)
- END;
- next := AST.NoNode;
- IF AST.NChild(seq) > 0 THEN
- next := AST.Child(seq, AST.NChild(seq) - 1);
- IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
- END;
- seq := next
- END;
- QbeGen.CtorEnd(q)
- ELSE
- t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
- END
- ELSIF AST.Kind(n) = AST.NkDesignator THEN
- LowerDesign(n, t, k, q, qn, sfx)
- ELSIF AST.Kind(n) = AST.NkCall THEN
- IF IsMethodCall(n) THEN LowerMethodCall(n, t, q, TRUE)
- ELSE
- CalleeName(n, qn);
- IF IsBuiltin(qn) THEN LowerBuiltinExpr(n, qn, t, q)
- ELSE LowerCall(n, t, q, TRUE)
- END
- END
- ELSIF AST.Kind(n) = AST.NkUnary THEN
- LowerExpr(AST.Child(n, 0), t, q);
- IF AST.Op(n) = AST.OpSub THEN
- IF QbeGen.IsImm(q) THEN QbeGen.NegFold(q, q)
- ELSE QbeGen.NewTemp(qt);
- QbeGen.NegQ(q, qt, SymTab.IsRealType(t));
- QbeGen.CopyOp(qt, q)
- END
- ELSE
- QbeGen.NotQ(q, qt); QbeGen.CopyOp(qt, q); t := SymTab.BoolType()
- END
- ELSIF AST.Kind(n) = AST.NkBinExpr THEN
- op := AST.Op(n);
- IF IsRel(op) THEN
- LowerExpr(AST.Child(n, 0), t, q);
- LowerExpr(AST.Child(n, 1), t2, q2);
- (* ISO: an empty string compared with CHAR is the terminator;
- against a CHAR array it stays a string (StrEq below). *)
- IF (t # SymTab.InvalidType) AND SymTab.IsEmptyStr(t)
- AND (t2 # SymTab.InvalidType)
- AND (SymTab.ClassOf(t2) = SymTab.ClChar) THEN
- QbeGen.CopyOp("0", q); t := SymTab.CharType()
- ELSIF (t2 # SymTab.InvalidType) AND SymTab.IsEmptyStr(t2)
- AND (t # SymTab.InvalidType)
- AND (SymTab.ClassOf(t) = SymTab.ClChar) THEN
- QbeGen.CopyOp("0", q2); t2 := SymTab.CharType()
- END;
- rop := SymTab.OpEq; folded := RelSym(op, rop);
- IF op = AST.OpIn THEN
- IF SymTab.IsBigSet(t2) THEN
- QbeGen.BigInSet(q, q2, SymTab.BigSetSigned(t2), qt)
- ELSIF SymTab.IsPackedSet(t2) THEN
- QbeGen.PackedInSet(q, q2, SymTab.SetBaseLo(t2),
- SymTab.SetCount(t2), t2, qt)
- ELSE QbeGen.InSet(q, q2, SymTab.SetBaseLo(t2),
- SymTab.SetCount(t2), qt)
- END;
- t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
- ELSIF (SymTab.ClassOf(t) = SymTab.ClPtr)
- OR (SymTab.ClassOf(t2) = SymTab.ClPtr) THEN
- QbeGen.CmpL(rop, q, q2, qt);
- t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
- ELSIF (SymTab.ClassOf(t) = SymTab.ClSet)
- OR (SymTab.ClassOf(t2) = SymTab.ClSet) THEN
- IF SymTab.IsBigSet(t) OR SymTab.IsBigSet(t2) THEN
- QbeGen.BigSetEqual(q, q2, qt);
- IF (rop = SymTab.OpNeq1) OR (rop = SymTab.OpNeq2) THEN
- QbeGen.NotQ(qt, q)
- ELSE QbeGen.CopyOp(qt, q)
- END
- ELSIF SymTab.IsPackedSet(t) OR SymTab.IsPackedSet(t2) THEN
- QbeGen.PackedCmpSet(rop, q, t, q2, t2, qt);
- QbeGen.CopyOp(qt, q)
- ELSE QbeGen.CmpSet(rop, q, q2, SymTab.SetWords(t),
- SymTab.SetWords(t2), qt);
- QbeGen.CopyOp(qt, q)
- END;
- t := SymTab.BoolType()
- ELSIF SymTab.StrCompat(t, t2) THEN
- QbeGen.StrEq(rop, q, q2, qt);
- t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
- ELSIF SymTab.IsLongFamily(t) OR SymTab.IsLongFamily(t2) THEN
- IF SymTab.IsIntFamily(t) THEN QbeGen.WidenLong(q, qf); QbeGen.CopyOp(qf, q) END;
- IF SymTab.IsIntFamily(t2) THEN QbeGen.WidenLong(q2, qf); QbeGen.CopyOp(qf, q2) END;
- QbeGen.CmpLong(rop, q, q2, qt);
- t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
- ELSE
- isR := (t # SymTab.InvalidType) AND SymTab.IsRealType(t);
- t := SymTab.BoolType();
- QbeGen.Cmp(rop, q, q2, qt, isR);
- QbeGen.CopyOp(qt, q)
- END
- ELSIF op = AST.OpAnd THEN
- LowerExpr(AST.Child(n, 0), t, q);
- QbeGen.DelayBegin;
- LowerExpr(AST.Child(n, 1), t2, q2);
- QbeGen.DelayEnd;
- QbeGen.Slot4(qs);
- QbeGen.NewLabel(lNext); QbeGen.NewLabel(lFalse); QbeGen.NewLabel(lDone);
- QbeGen.Jnz(q, lNext, lFalse);
- QbeGen.EmitLabel(lNext);
- QbeGen.DelayFlush;
- QbeGen.StoreW(qs, q2);
- QbeGen.Jmp(lDone);
- QbeGen.EmitLabel(lFalse);
- QbeGen.StoreW(qs, "0");
- QbeGen.Jmp(lDone);
- QbeGen.EmitLabel(lDone);
- QbeGen.LoadW(qs, qr);
- QbeGen.CopyOp(qr, q);
- t := SymTab.BoolType()
- ELSIF op = AST.OpOr THEN
- LowerExpr(AST.Child(n, 0), t, q);
- QbeGen.DelayBegin;
- LowerExpr(AST.Child(n, 1), t2, q2);
- QbeGen.DelayEnd;
- QbeGen.Slot4(qs);
- QbeGen.NewLabel(lTrue); QbeGen.NewLabel(lNext); QbeGen.NewLabel(lDone);
- QbeGen.Jnz(q, lTrue, lNext);
- QbeGen.EmitLabel(lTrue);
- QbeGen.StoreW(qs, "1");
- QbeGen.Jmp(lDone);
- QbeGen.EmitLabel(lNext);
- QbeGen.DelayFlush;
- QbeGen.StoreW(qs, q2);
- QbeGen.Jmp(lDone);
- QbeGen.EmitLabel(lDone);
- QbeGen.LoadW(qs, qr);
- QbeGen.CopyOp(qr, q);
- t := SymTab.BoolType()
- ELSE
- LowerExpr(AST.Child(n, 0), t, q);
- LowerExpr(AST.Child(n, 1), t2, q2);
- IF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType)
- AND (SymTab.ClassOf(t) = SymTab.ClSet)
- AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN
- (* set union/diff (Add/Sub) or intersection/symdiff (Mul/Div) *)
- lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2);
- mw := lw; IF rw > mw THEN mw := rw END;
- IF op = AST.OpAdd THEN idx := 0
- ELSIF op = AST.OpSub THEN idx := 2
- ELSIF op = AST.OpMul THEN idx := 1
- ELSE idx := 3
- END;
- IF SymTab.IsBigSet(t) OR SymTab.IsBigSet(t2) THEN
- QbeGen.NewSetTemp(2, qt);
- QbeGen.SetZero(qt, 2);
- QbeGen.BigSetBin(idx, qt, q, q2);
- IF SymTab.IsBigSet(t) THEN
- t := SymTab.NewBigSet(SymTab.SetBase(t))
- ELSE t := SymTab.NewBigSet(SymTab.SetBase(t2))
- END
- ELSIF SymTab.IsPackedSet(t) OR SymTab.IsPackedSet(t2) THEN
- QbeGen.PackedSetBinOp(idx, q, t, q2, t2, qt);
- t := SymTab.NewSet(SymTab.NewSubR(0, 31))
- ELSE
- QbeGen.SetBinOp(idx, q, q2, lw, rw, qt);
- t := SymTab.NewSet(SymTab.NewSubR(0,
- VAL(INTEGER, mw) * 32 - 1))
- END;
- QbeGen.CopyOp(qt, q)
- ELSIF (op = AST.OpAdd)
- AND (SymTab.StrCompat(t, t2)
- OR (SymTab.IsStrType(t) AND (SymTab.ClassOf(t2) = SymTab.ClChar))
- OR ((SymTab.ClassOf(t) = SymTab.ClChar) AND SymTab.IsStrType(t2))) THEN
- QbeGen.StrFold(q, q2, SymTab.ClassOf(t), SymTab.ClassOf(t2), qt, fok);
- IF NOT fok THEN
- IF SymTab.StrCompat(t, t2) THEN QbeGen.StrCat(q, q2, qt)
- ELSIF SymTab.IsStrType(t) THEN
- QbeGen.DeclCharStr(q2, qs); QbeGen.StrCat(q, qs, qt)
- ELSE
- QbeGen.DeclCharStr(q, qs); QbeGen.StrCat(qs, q2, qt)
- END
- END;
- t := SymTab.NewStr(); QbeGen.CopyOp(qt, q)
- ELSIF (op = AST.OpAdd)
- AND (SymTab.UStrCompat(t, t2)
- OR ((SymTab.ClassOf(t) = SymTab.ClUChar)
- AND (SymTab.ClassOf(t2) = SymTab.ClUStr))
- OR ((SymTab.ClassOf(t) = SymTab.ClUStr)
- AND (SymTab.ClassOf(t2) = SymTab.ClUChar))
- OR ((SymTab.ClassOf(t) = SymTab.ClUChar)
- AND (SymTab.ClassOf(t2) = SymTab.ClUChar))) THEN
- (* UString concatenation: a UCHAR operand becomes a
- 1-codepoint UString; the result is a descriptor *)
- IF SymTab.ClassOf(t) = SymTab.ClUStr THEN QbeGen.CopyOp(q, qa)
- ELSE QbeGen.UStrFrom(q, qa)
- END;
- IF SymTab.ClassOf(t2) = SymTab.ClUStr THEN QbeGen.UStrCat(qa, q2, qt)
- ELSE QbeGen.UStrFrom(q2, qb); QbeGen.UStrCat(qa, qb, qt)
- END;
- t := SymTab.NewUStr(); QbeGen.CopyOp(qt, q)
- ELSE
- lt := t; rt := t2;
- IF SymTab.IsRealType(lt) OR SymTab.IsRealType(rt) THEN
- t := SymTab.RealType()
- ELSIF SymTab.IsLongFamily(lt) OR SymTab.IsLongFamily(rt) THEN
- t := SymTab.LongType()
- ELSE t := SymTab.IntType()
- END;
- isL := SymTab.IsLongFamily(t);
- isR := SymTab.IsRealType(t);
- kind := 0;
- IF op = AST.OpSub THEN kind := 1
- ELSIF op = AST.OpMul THEN kind := 2
- ELSIF op = AST.OpDiv THEN kind := 3
- ELSIF op = AST.OpMod THEN kind := 4
- END;
- folded := FALSE;
- IF (NOT isL) AND (NOT isR) AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN
- folded := QbeGen.Fold2(kind, q, q2, qf)
- END;
- IF folded THEN QbeGen.CopyOp(qf, q)
- ELSE
- IF isL THEN
- IF SymTab.IsIntFamily(lt) THEN
- QbeGen.WidenLong(q, qw); QbeGen.CopyOp(qw, q)
- END;
- IF SymTab.IsIntFamily(rt) THEN
- QbeGen.WidenLong(q2, qw); QbeGen.CopyOp(qw, q2)
- END;
- QbeGen.NewTemp(qt);
- IF op = AST.OpAdd THEN QbeGen.Op3L("add", qt, q, q2)
- ELSIF op = AST.OpSub THEN QbeGen.Op3L("sub", qt, q, q2)
- ELSIF op = AST.OpMul THEN QbeGen.Op3L("mul", qt, q, q2)
- ELSE QbeGen.Op3L("div", qt, q, q2)
- END
- ELSE
- QbeGen.NewTemp(qt);
- IF op = AST.OpAdd THEN QbeGen.Op3("add", qt, q, q2, isR)
- ELSIF op = AST.OpSub THEN QbeGen.Op3("sub", qt, q, q2, isR)
- ELSIF op = AST.OpMul THEN QbeGen.Op3("mul", qt, q, q2, isR)
- ELSIF op = AST.OpDiv THEN QbeGen.Op3("div", qt, q, q2, isR)
- ELSE QbeGen.Op3("rem", qt, q, q2, isR)
- END
- END;
- QbeGen.CopyOp(qt, q)
- END
- END
- END
- END
- END LowerExprFull;
- PROCEDURE LowerExpr (n: AST.Node; VAR t: SymTab.TypeIndex;
- VAR q: QbeGen.QVal);
- VAR k: INTEGER; qn: SymTab.Name; sfx: BOOLEAN;
- BEGIN
- LowerExprFull(n, t, q, k, qn, sfx, FALSE);
- IF AST.Kind(n) # AST.NkDesignator THEN lastView := FALSE END
- END LowerExpr;
- PROCEDURE LowerStmt (seq: AST.Node);
- VAR i: CARDINAL; c, els, by: AST.Node; k: INTEGER;
- t, t2, t3, dt, et: SymTab.TypeIndex;
- q, q2, qt, qf, qd, qe: QbeGen.QVal;
- qlo, qhi, qk, qb, ql, qby: QbeGen.QVal; step: INTEGER;
- lTop, lBody, lEnd, lThen, lElse, lNext, lFalse, lDone, lx: QbeGen.QVal;
- qn, lv: SymTab.Name;
- kind, op, rop, cls: INTEGER;
- sfx, folded, isR, conv, wconv, hasElse, dView, sView: BOOLEAN;
- BEGIN
- IF seq = AST.NoNode THEN RETURN END;
- k := AST.Kind(seq);
- IF k = AST.NkBlock THEN
- i := 0;
- WHILE i < AST.NChild(seq) DO
- LowerStmt(AST.Child(seq, i)); INC(i)
- END
- ELSIF k = AST.NkExcept THEN
- QbeGen.ExcBegin;
- LowerStmt(AST.Child(seq, 0));
- QbeGen.ExcBodyDone;
- QbeGen.ExcHandlerBegin;
- LowerStmt(AST.Child(seq, 1));
- QbeGen.ExcEnd
- ELSIF k = AST.NkRetry THEN
- QbeGen.ExcRetry
- ELSIF k = AST.NkFinally THEN
- (* Module callers split the parts; be safe if one reaches here. *)
- LowerStmt(AST.Child(seq, 0))
- ELSIF k = AST.NkAssign THEN
- LowerDesign(AST.Child(seq, 0), dt, cls, qd, qn, sfx);
- dView := lastView;
- LowerExpr(AST.Child(seq, 1), et, qe);
- sView := lastView;
- IF (dt # SymTab.InvalidType) AND (et # SymTab.InvalidType)
- AND SymTab.IsEmptyStr(et)
- AND (SymTab.ClassOf(dt) = SymTab.ClChar) THEN
- (* ISO: the empty string assigned to CHAR is the terminator *)
- QbeGen.CopyOp("0", qe); et := SymTab.CharType()
- END;
- CheckSub(dt, qe);
- isR := (dt # SymTab.InvalidType) AND SymTab.IsRealType(dt);
- conv := isR AND SymTab.IsIntFamily(et);
- wconv := (dt # SymTab.InvalidType) AND SymTab.IsLongFamily(dt)
- AND SymTab.IsIntFamily(et);
- IF sfx OR (cls = SymTab.KindField) THEN
- IF SymTab.ClassOf(dt) = SymTab.ClArray THEN
- IF dView OR sView THEN
- QbeGen.CopyArrayEx(qd, qe, dt, dView, sView)
- ELSIF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) = SymTab.ClUStr)
- AND SymTab.IsUCharArray(dt) THEN QbeGen.UAssign(qd, qe)
- ELSIF SymTab.StrCompat(dt, et) THEN QbeGen.StrAssign(qd, qe)
- ELSE QbeGen.CopyArray(qd, qe, dt)
- END
- ELSIF SymTab.ClassOf(dt) = SymTab.ClSet THEN
- QbeGen.CopySetVal(qd, dt, qe, et)
- ELSIF SymTab.ClassOf(dt) = SymTab.ClRecord THEN
- QbeGen.CopyRecord(qd, qe, dt)
- ELSIF SymTab.IsLongFamily(dt) THEN
- IF wconv THEN QbeGen.WidenLong(qe, ql); QbeGen.ElemStore(qd, ql, dt)
- ELSE QbeGen.ElemStore(qd, qe, dt)
- END
- ELSIF conv THEN QbeGen.ConvIR(qe, qt); QbeGen.ElemStore(qd, qt, dt)
- ELSE QbeGen.ElemStore(qd, qe, dt)
- END
- ELSE
- IF SymTab.ClassOf(dt) = SymTab.ClArray THEN
- IF dView OR sView THEN
- QbeGen.CopyArrayEx(qd, qe, dt, dView, sView)
- ELSIF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) = SymTab.ClUStr)
- AND SymTab.IsUCharArray(dt) THEN QbeGen.UAssign(qd, qe)
- ELSIF SymTab.StrCompat(dt, et) THEN QbeGen.StrAssign(qd, qe)
- ELSE QbeGen.CopyArray(qd, qe, dt)
- END
- ELSIF SymTab.ClassOf(dt) = SymTab.ClSet THEN
- QbeGen.CopySetVal(qd, dt, qe, et)
- ELSIF SymTab.ClassOf(dt) = SymTab.ClRecord THEN
- QbeGen.CopyRecord(qd, qe, dt)
- ELSIF SymTab.IsSmallInt(dt) THEN
- QbeGen.StoreShortVar(qn, SymTab.SmallIntBytes(dt), qe)
- ELSIF (SymTab.ClassOf(dt) = SymTab.ClPtr)
- OR (SymTab.ClassOf(dt) = SymTab.ClProc) THEN
- QbeGen.StorePtr(qn, qe)
- ELSIF SymTab.IsLongFamily(dt) THEN
- IF wconv THEN QbeGen.WidenLong(qe, ql); QbeGen.StoreLong(qn, ql)
- ELSE QbeGen.StoreLong(qn, qe)
- END
- ELSIF conv THEN
- QbeGen.ConvIR(qe, qt);
- IF SymTab.IsShortReal(dt) THEN
- QbeGen.StoreShortReal(qn, qt)
- ELSE QbeGen.StoreVar(qn, qt, TRUE)
- END
- ELSIF SymTab.IsShortReal(dt) THEN
- QbeGen.StoreShortReal(qn, qe)
- ELSE QbeGen.StoreVar(qn, qe, isR)
- END
- END
- ELSIF k = AST.NkIf THEN
- LowerExpr(AST.Child(seq, 0), t, q);
- QbeGen.NewLabel(lThen); QbeGen.NewLabel(lElse); QbeGen.NewLabel(lEnd);
- QbeGen.Jnz(q, lThen, lElse); QbeGen.EmitLabel(lThen);
- LowerStmt(AST.Child(seq, 1));
- QbeGen.Jmp(lEnd);
- els := AST.Child(seq, 2); hasElse := FALSE;
- WHILE (els # AST.NoNode) AND (AST.Kind(els) = AST.NkIf) DO
- QbeGen.EmitLabel(lElse); QbeGen.NewLabel(lElse);
- LowerExpr(AST.Child(els, 0), t, q);
- QbeGen.NewLabel(lThen); QbeGen.Jnz(q, lThen, lElse);
- QbeGen.EmitLabel(lThen);
- LowerStmt(AST.Child(els, 1));
- QbeGen.Jmp(lEnd);
- els := AST.Child(els, 2)
- END;
- IF els # AST.NoNode THEN
- QbeGen.EmitLabel(lElse); hasElse := TRUE; LowerStmt(els)
- END;
- IF hasElse THEN QbeGen.EmitLabel(lEnd)
- ELSE QbeGen.EmitLabel(lElse); QbeGen.EmitLabel(lEnd)
- END
- ELSIF k = AST.NkWhile THEN
- QbeGen.NewLabel(lTop); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lEnd);
- QbeGen.EmitLabel(lTop);
- LowerExpr(AST.Child(seq, 0), t, q);
- QbeGen.Jnz(q, lBody, lEnd); QbeGen.EmitLabel(lBody);
- LowerStmt(AST.Child(seq, 1));
- QbeGen.Jmp(lTop); QbeGen.EmitLabel(lEnd)
- ELSIF k = AST.NkRepeat THEN
- QbeGen.NewLabel(lTop); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop);
- LowerStmt(AST.Child(seq, 0));
- LowerExpr(AST.Child(seq, 1), t, q);
- QbeGen.Jnz(q, lEnd, lTop); QbeGen.EmitLabel(lEnd)
- ELSIF k = AST.NkLoop THEN
- QbeGen.NewLabel(lTop); QbeGen.NewLabel(lEnd);
- QbeGen.PushLoop(lEnd); QbeGen.EmitLabel(lTop);
- LowerStmt(AST.Child(seq, 0));
- QbeGen.Jmp(lTop); QbeGen.PopLoop; QbeGen.EmitLabel(lEnd)
- ELSIF k = AST.NkExit THEN
- IF QbeGen.TopLoop(lx) THEN QbeGen.Jmp(lx) END
- ELSIF k = AST.NkFor THEN
- Name(AST.Child(seq, 0), lv);
- LowerExpr(AST.Child(seq, 1), t, qlo);
- LowerExpr(AST.Child(seq, 2), t2, qhi);
- IF SymTab.IsEmptyStr(t) THEN
- QbeGen.CopyOp("0", qlo); t := SymTab.CharType()
- END;
- IF SymTab.IsEmptyStr(t2) THEN
- QbeGen.CopyOp("0", qhi); t2 := SymTab.CharType()
- END;
- CheckSub(SymTab.SymType(lv), qlo);
- CheckSub(SymTab.SymType(lv), qhi);
- (* optional BY step: a constant, default +1; its sign also
- selects the termination comparison *)
- step := 1;
- IF AST.Child(seq, 3) # AST.NoNode THEN
- LowerExpr(AST.Child(seq, 3), t3, qby);
- IF NOT SymTab.ConstInt(qby, step) THEN step := 1
- ELSIF step = 0 THEN step := 1
- END
- END;
- IF SymTab.IsSmallInt(SymTab.SymType(lv)) THEN
- QbeGen.StoreShortVar(lv,
- SymTab.SmallIntBytes(SymTab.SymType(lv)), qlo)
- ELSE QbeGen.StoreVar(lv, qlo, FALSE)
- END;
- QbeGen.NewLabel(lTop); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lEnd);
- QbeGen.EmitLabel(lTop);
- IF SymTab.IsSmallInt(SymTab.SymType(lv)) THEN
- QbeGen.LoadShortVar(lv,
- SymTab.IsSignedSmallInt(SymTab.SymType(lv)),
- SymTab.SmallIntBytes(SymTab.SymType(lv)), qt)
- ELSE QbeGen.LoadVar(lv, FALSE, qt)
- END;
- QbeGen.NewTemp(qk);
- IF step > 0 THEN QbeGen.Op3("cslew", qk, qt, qhi, FALSE)
- ELSE QbeGen.Op3("csgew", qk, qt, qhi, FALSE)
- END;
- QbeGen.Jnz(qk, lBody, lEnd);
- QbeGen.EmitLabel(lBody);
- LowerStmt(AST.Child(seq, 4));
- IF SymTab.IsSmallInt(SymTab.SymType(lv)) THEN
- QbeGen.LoadShortVar(lv,
- SymTab.IsSignedSmallInt(SymTab.SymType(lv)),
- SymTab.SmallIntBytes(SymTab.SymType(lv)), qt)
- ELSE QbeGen.LoadVar(lv, FALSE, qt)
- END;
- QbeGen.IntStr(step, qb);
- QbeGen.NewTemp(qk);
- QbeGen.Op3("add", qk, qt, qb, FALSE);
- IF SymTab.IsSmallInt(SymTab.SymType(lv)) THEN
- QbeGen.StoreShortVar(lv,
- SymTab.SmallIntBytes(SymTab.SymType(lv)), qk)
- ELSE QbeGen.StoreVar(lv, qk, FALSE)
- END;
- QbeGen.Jmp(lTop); QbeGen.EmitLabel(lEnd)
- ELSIF k = AST.NkHalt THEN
- IF AST.Child(seq, 0) # AST.NoNode THEN
- LowerExpr(AST.Child(seq, 0), t, q) END;
- QbeGen.HaltQ
- ELSIF k = AST.NkGoto THEN
- Name(AST.Child(seq, 0), qn);
- UserLabel(qn, q);
- QbeGen.Jmp(q)
- ELSIF k = AST.NkLabel THEN
- Name(AST.Child(seq, 0), qn);
- UserLabel(qn, q);
- QbeGen.EmitLabel(q)
- ELSIF k = AST.NkReturn THEN
- IF AST.Child(seq, 0) = AST.NoNode THEN
- QbeGen.EmitRet(q, FALSE)
- ELSE
- LowerExpr(AST.Child(seq, 0), t, q);
- IF (emitProc >= 0) AND (emitProc < VAL(INTEGER, nProcs)) THEN
- CheckSub(procRes[emitProc], q)
- END;
- IF SymTab.IsEmptyStr(t)
- AND (emitProc >= 0) AND (emitProc < VAL(INTEGER, nProcs))
- AND (SymTab.ClassOf(procRes[emitProc]) = SymTab.ClChar) THEN
- QbeGen.CopyOp("0", q); t := SymTab.CharType()
- END;
- IF (emitProc >= 0) AND (emitProc < VAL(INTEGER, nProcs))
- AND CompositeRes(procRes[emitProc]) THEN
- (* composite result: copy into the hidden destination *)
- QbeGen.AddrOf("__res", qt);
- IF SymTab.ClassOf(procRes[emitProc]) = SymTab.ClArray THEN
- QbeGen.CopyArray(qt, q, procRes[emitProc])
- ELSIF SymTab.ClassOf(procRes[emitProc]) = SymTab.ClSet THEN
- IF SymTab.IsBigSet(procRes[emitProc]) THEN
- QbeGen.BigSetCopy(qt, q)
- ELSE
- QbeGen.CopySet(qt, q, SymTab.SetWords(procRes[emitProc]),
- SymTab.SetWords(procRes[emitProc]))
- END
- ELSE QbeGen.CopyRecord(qt, q, procRes[emitProc])
- END;
- QbeGen.EmitRet("0", FALSE)
- ELSE
- IF (emitProc >= 0) AND (emitProc < VAL(INTEGER, nProcs)) THEN
- t2 := procRes[emitProc]
- ELSE t2 := SymTab.CurRes()
- END;
- conv := SymTab.IsRealType(t2) AND SymTab.IsIntFamily(t);
- IF conv THEN
- QbeGen.ConvIR(q, qt);
- IF SymTab.IsShortReal(t2) THEN
- QbeGen.ConvSR(qt, q); QbeGen.EmitRet(q, TRUE)
- ELSE QbeGen.EmitRet(qt, TRUE) END
- ELSIF SymTab.IsShortReal(t2) THEN
- QbeGen.ConvSR(q, qt); QbeGen.EmitRet(qt, TRUE)
- ELSE QbeGen.EmitRet(q, TRUE)
- END
- END
- END
- ELSIF k = AST.NkCase THEN LowerCase(seq)
- ELSIF k = AST.NkWith THEN LowerWith(seq)
- ELSIF k = AST.NkCall THEN
- IF IsMethodCall(seq) THEN LowerMethodCall(seq, t, q, FALSE)
- ELSE
- CalleeName(seq, qn);
- IF IsBuiltin(qn) THEN LowerBuiltinStmt(seq, qn)
- ELSE LowerCall(seq, t, q, FALSE)
- END
- END
- END
- END LowerStmt;
- PROCEDURE ReenterGlobals (seq: AST.Node);
- (* Re-registers a nested module's non-exported globals in the enclosing
- (still-open) module scope, so QbeGen.GlobalRef can resolve their
- "<outer>_<name>" symbols after the nested scope has been popped. *)
- VAR i, j: CARDINAL; c: AST.Node; nm: SymTab.Name; chunk, vn: AST.Node;
- BEGIN
- IF seq = AST.NoNode THEN RETURN END;
- i := 0;
- WHILE i < AST.NChild(seq) DO
- c := AST.Child(seq, i);
- IF i = AST.MaxChild - 1 THEN ReenterGlobals(c)
- ELSIF AST.Kind(c) = AST.NkDeclSeq THEN ReenterGlobals(c)
- ELSIF AST.Kind(c) = AST.NkVarDecl THEN
- chunk := c;
- WHILE chunk # AST.NoNode DO
- j := 0;
- WHILE j < AST.NChild(chunk) DO
- vn := AST.Child(chunk, j);
- IF AST.Kind(vn) = AST.NkIdent THEN
- Name(vn, nm);
- IF SymTab.ReenterModGlobal(nm, SymTab.KindVar, curUnitName) THEN
- SymTab.SetSymType(nm, AST.Ty(c))
- END
- END;
- INC(j)
- END;
- IF AST.NChild(chunk) > 0 THEN
- vn := AST.Child(chunk, AST.NChild(chunk) - 1);
- IF AST.Kind(vn) = AST.NkBlock THEN chunk := vn
- ELSE chunk := AST.NoNode END
- ELSE chunk := AST.NoNode END
- END
- ELSIF (AST.Kind(c) = AST.NkTypeDecl)
- OR (AST.Kind(c) = AST.NkClassDecl) THEN
- (* a nested module's TYPE/CLASS: re-register it so ObjectSize and
- GlobalRef can resolve it after the nested scope is popped *)
- IF AST.NChild(c) >= 1 THEN
- Name(AST.Child(c, 0), nm);
- IF SymTab.ReenterModGlobal(nm, SymTab.KindType, curUnitName) THEN
- SymTab.SetSymType(nm, AST.Ty(c))
- END
- END
- END;
- INC(i)
- END
- END ReenterGlobals;
- PROCEDURE ReenterImports (seq: AST.Node);
- (* A nested module's FROM-imports live in its (now popped) scope. Copy
- them into the enclosing scope so lowering the nested module's
- declarations and body can still resolve the imported names. *)
- VAR i, j: CARDINAL;
- c, cn: AST.Node;
- mod, nm: SymTab.Name;
- BEGIN
- IF seq = AST.NoNode THEN RETURN END;
- i := 0;
- WHILE i < AST.NChild(seq) DO
- c := AST.Child(seq, i);
- IF i = AST.MaxChild - 1 THEN ReenterImports(c)
- ELSIF AST.Kind(c) = AST.NkDeclSeq THEN ReenterImports(c)
- ELSIF (AST.Kind(c) = AST.NkImport) AND (AST.NChild(c) >= 1) THEN
- Name(AST.Child(c, 0), mod);
- IF SymTab.Equal(mod, "libc") THEN
- j := 1;
- WHILE j < AST.NChild(c) DO
- cn := AST.Child(c, j);
- IF AST.Kind(cn) = AST.NkIdent THEN
- Name(cn, nm);
- IF SymTab.DeclareCProc(nm) THEN NoteCProc(nm) END
- END;
- INC(j)
- END
- ELSIF SymTab.ModKnown(mod)
- AND NOT SymTab.Equal(mod, "SYSTEM") THEN
- j := 1;
- WHILE j < AST.NChild(c) DO
- cn := AST.Child(c, j);
- IF AST.Kind(cn) = AST.NkIdent THEN
- Name(cn, nm);
- (* plain IMPORT lists modules; only FROM adds names *)
- IF SymTab.SymKind(nm) # SymTab.KindModule THEN
- IF NOT SymTab.ImportFrom(mod, nm) THEN END
- END
- END;
- INC(j)
- END
- END
- END;
- INC(i)
- END
- END ReenterImports;
- PROCEDURE EmitVarNames (c: AST.Node);
- (* Emit DeclVar for each name of an NkVarDecl; the names are a chunked
- sequence (AstAppend), so follow NkBlock continuations. *)
- VAR j: CARDINAL; chunk, vn: AST.Node; nm: SymTab.Name;
- BEGIN
- chunk := c;
- WHILE chunk # AST.NoNode DO
- j := 0;
- WHILE j < AST.NChild(chunk) DO
- vn := AST.Child(chunk, j);
- IF AST.Kind(vn) = AST.NkIdent THEN
- Name(vn, nm);
- QbeGen.DeclVar(nm, AST.Ty(c));
- IF (NOT QbeGen.InFunction())
- AND (SymTab.ClassOf(AST.Ty(c)) = SymTab.ClArray)
- AND QbeGen.RecArrayNeedsInit(SymTab.ArrayLen(AST.Ty(c)),
- AST.Ty(c))
- AND (nCountInit <= HIGH(countArr)) THEN
- QbeGen.DeclRecTemplate(nm, SymTab.ArrayElem(AST.Ty(c)));
- countArr[nCountInit] := nm;
- countTyp[nCountInit] := AST.Ty(c);
- INC(nCountInit)
- END
- END;
- INC(j)
- END;
- IF AST.NChild(chunk) > 0 THEN
- vn := AST.Child(chunk, AST.NChild(chunk) - 1);
- IF AST.Kind(vn) = AST.NkBlock THEN chunk := vn
- ELSE chunk := AST.NoNode END
- ELSE chunk := AST.NoNode END
- END
- END EmitVarNames;
- PROCEDURE EmitCountInits;
- (* Initialise the length words of record-array globals that were emitted
- compactly (recorded by EmitVarNames). *)
- VAR k: CARDINAL;
- BEGIN
- k := 0;
- WHILE k < nCountInit DO
- QbeGen.InitRecArray(countArr[k], countTyp[k]);
- INC(k)
- END
- END EmitCountInits;
- PROCEDURE SplitModuleBody (body: AST.Node; VAR init, fin: AST.Node);
- (* A module body is NkFinally(initial, final) when FINALLY is present;
- otherwise it is just the initial body. *)
- BEGIN
- IF (body # AST.NoNode) AND (AST.Kind(body) = AST.NkFinally) THEN
- init := AST.Child(body, 0);
- fin := AST.Child(body, 1)
- ELSE
- init := body;
- fin := AST.NoNode
- END
- END SplitModuleBody;
- PROCEDURE LowerFini (nm: SymTab.Name; fin: AST.Node);
- (* Emit <module>_fini as a separate function, called by main in reverse
- initialization order. *)
- BEGIN
- IF fin # AST.NoNode THEN
- QbeGen.BeginFini(nm);
- nUserLab := 0;
- LowerStmt(fin);
- QbeGen.EndFini
- END
- END LowerFini;
- PROCEDURE LowerDecls (seq: AST.Node);
- VAR i, j: CARDINAL; c: AST.Node; nm, txt, gn: SymTab.Name; qv: QbeGen.QVal;
- mg: QbeGen.QVal; uid, depth, np: CARDINAL; res, pt: SymTab.TypeIndex;
- ext, pv: BOOLEAN; kk: INTEGER; ct: SymTab.TypeIndex; savedProc: INTEGER;
- chunk, vn: AST.Node; pi: INTEGER;
- initBody, finBody: AST.Node;
- mk: ARRAY [0 .. MaxCFoldW - 1] OF CARDINAL; mw: CARDINAL; mlo: INTEGER;
- BEGIN
- IF seq = AST.NoNode THEN RETURN END;
- i := 0;
- WHILE i < AST.NChild(seq) DO
- c := AST.Child(seq, i);
- IF i = AST.MaxChild - 1 THEN LowerDecls(c)
- ELSIF AST.Kind(c) = AST.NkDeclSeq THEN LowerDecls(c)
- ELSIF AST.Kind(c) = AST.NkClassDecl THEN
- Name(AST.Child(c, 0), nm);
- IF Resolve(nm, kk, ct) THEN
- IF SymTab.ClassOf(ct) = SymTab.ClClass THEN
- IF AST.Op(c) = 1 THEN
- LowerMethods(AST.Child(c, 3), ct);
- IF AST.Child(c, 2) # AST.NoNode THEN
- SplitModuleBody(AST.Child(c, 2), initBody, finBody);
- QbeGen.BeginInit(nm);
- nUserLab := 0;
- LowerStmt(initBody);
- QbeGen.EndInit;
- LowerFini(nm, finBody)
- END
- ELSE
- LowerMethodHeadings(AST.Child(c, 3), ct)
- END
- END
- END
- ELSIF AST.Kind(c) = AST.NkUnit THEN
- Name(AST.Child(c, 0), nm);
- ReenterImports(AST.Child(c, 3));
- ReenterGlobals(AST.Child(c, 1));
- LowerDecls(AST.Child(c, 1));
- IF AST.Child(c, 2) # AST.NoNode THEN
- SplitModuleBody(AST.Child(c, 2), initBody, finBody);
- QbeGen.BeginInit(nm);
- nUserLab := 0;
- LowerStmt(initBody);
- QbeGen.EndInit;
- LowerFini(nm, finBody)
- END
- ELSIF AST.Kind(c) = AST.NkVarDecl THEN
- (* op=1 marks a forward-typed global: emit it after the rest,
- as the grammar's FlushPend does *)
- IF AST.Op(c) # 1 THEN EmitVarNames(c) END
- ELSIF AST.Kind(c) = AST.NkConstDecl THEN
- Name(AST.Child(c, 0), nm);
- kk := SymTab.ClassOf(AST.Ty(c));
- IF kk = SymTab.ClSet THEN
- (* SET CONST: static data from the mask the grammar computed.
- A module-level const is emitted under its global name
- (<unit>_<name>) so a client's qualified reference binds. *)
- IF LookupSetMask(nm, mk, mw, mlo) THEN
- IF SymTab.GlobalRef(nm, gn) THEN
- QbeGen.PoolSetNamed(gn, mk, mw, qv)
- ELSE QbeGen.PoolSet(mk, mw, qv)
- END;
- SetConstVal(nm, qv)
- ELSE SetConstVal(nm, "0")
- END
- ELSIF (kk = SymTab.ClArray) OR (kk = SymTab.ClRecord)
- OR (kk = SymTab.ClClass) OR (kk = SymTab.ClStr)
- OR (kk = SymTab.ClUStr) THEN
- (* aggregate/string CONST: re-emit the constructor/string so
- its static data is produced (the grammar's CtorEnd/DeclStr
- are suppressed under NoEmit), then refresh the value *)
- LowerExpr(AST.Child(c, 1), ct, qv);
- SetConstVal(nm, qv)
- ELSIF GetConstVal(nm, qv) AND QbeGen.IsImm(qv) THEN
- (* scalar: use the evaluated value recorded by NoteConstVal *)
- QbeGen.DeclConst(nm, qv, AST.Ty(c))
- END
- ELSIF AST.Kind(c) = AST.NkProcDecl THEN
- Name(AST.Child(c, 0), nm);
- pi := AST.Ty(c); (* proc-table index recorded by NoteProcNode *)
- IF (pi < 0) OR (pi >= VAL(INTEGER, nProcs)) THEN pi := FindProc(nm) END;
- IF ProcInfoIdx(pi, uid, res, depth, ext, np) THEN
- QbeGen.Mangled(nm, uid, mg);
- QbeGen.BeginFunc(mg);
- IF CompositeRes(res) THEN
- IF NOT QbeGen.FuncParam("__res", TRUE, res) THEN END
- END;
- j := 0;
- WHILE j < np DO
- IF ParamInfoIdx(pi, j, pt, pv, txt) THEN
- IF NOT QbeGen.FuncParam(txt, pv OR SymTab.IsOpenArray(pt), pt) THEN END
- END;
- INC(j)
- END;
- QbeGen.SetFuncRes(res);
- IF AST.Child(c, 1) = AST.NoNode THEN
- (* declaration-only (definition module): replay the heading *)
- QbeGen.AbortFunc
- ELSE
- QbeGen.EndFuncHeader;
- savedProc := emitProc;
- emitProc := pi;
- LowerDecls(AST.Child(c, 2));
- nUserLab := 0;
- LowerStmt(AST.Child(c, 1));
- emitProc := savedProc;
- QbeGen.EndFunc(res)
- END
- END
- END;
- INC(i)
- END
- END LowerDecls;
- PROCEDURE MaterializeGlobals (unitName: ARRAY OF CHAR; decls: AST.Node);
- (* Make a unit's module-level VAR/CONST visible in the (global) scope
- Lower runs in at session end, so GlobalRef resolves "<unit>_<name>". *)
- VAR i, j: CARDINAL; c: AST.Node; nm: SymTab.Name; chunk, vn: AST.Node;
- BEGIN
- IF decls = AST.NoNode THEN RETURN END;
- i := 0;
- WHILE i < AST.NChild(decls) DO
- c := AST.Child(decls, i);
- IF i = AST.MaxChild - 1 THEN MaterializeGlobals(unitName, c)
- ELSIF AST.Kind(c) = AST.NkDeclSeq THEN MaterializeGlobals(unitName, c)
- ELSIF (AST.Kind(c) = AST.NkVarDecl) OR (AST.Kind(c) = AST.NkConstDecl) THEN
- chunk := c;
- WHILE chunk # AST.NoNode DO
- j := 0;
- WHILE j < AST.NChild(chunk) DO
- vn := AST.Child(chunk, j);
- IF AST.Kind(vn) = AST.NkIdent THEN
- Name(vn, nm);
- IF NOT SymTab.MaterializeReplace(unitName, nm) THEN END
- END;
- INC(j)
- END;
- IF AST.NChild(chunk) > 0 THEN
- vn := AST.Child(chunk, AST.NChild(chunk) - 1);
- IF AST.Kind(vn) = AST.NkBlock THEN chunk := vn
- ELSE chunk := AST.NoNode END
- ELSE chunk := AST.NoNode END
- END
- ELSIF (AST.Kind(c) = AST.NkTypeDecl) OR (AST.Kind(c) = AST.NkClassDecl) THEN
- IF AST.NChild(c) >= 1 THEN
- Name(AST.Child(c, 0), nm);
- IF NOT SymTab.MaterializeReplace(unitName, nm) THEN END
- END
- END;
- INC(i)
- END
- END MaterializeGlobals;
- PROCEDURE LowerDeferredVars (seq: AST.Node);
- (* Emit the forward-typed globals (NkVarDecl op=1) after the rest of the
- unit's declarations, matching the grammar's FlushPend ordering. *)
- VAR i: CARDINAL; c: AST.Node;
- BEGIN
- IF seq = AST.NoNode THEN RETURN END;
- i := 0;
- WHILE i < AST.NChild(seq) DO
- c := AST.Child(seq, i);
- IF i = AST.MaxChild - 1 THEN LowerDeferredVars(c)
- ELSIF AST.Kind(c) = AST.NkDeclSeq THEN LowerDeferredVars(c)
- ELSIF (AST.Kind(c) = AST.NkVarDecl) AND (AST.Op(c) = 1) THEN
- EmitVarNames(c)
- END;
- INC(i)
- END
- END LowerDeferredVars;
- PROCEDURE LowerOneUnit (u: AST.Node; isProg: BOOLEAN);
- VAR nm: SymTab.Name; initBody, finBody: AST.Node;
- BEGIN
- nCountInit := 0;
- Name(AST.Child(u, 0), nm);
- CopySpan(nm, curUnitName, 0, 0);
- QbeGen.SetModule(nm);
- MaterializeGlobals(nm, AST.Child(u, 1));
- LowerDecls(AST.Child(u, 1));
- LowerDeferredVars(AST.Child(u, 1));
- IF AST.Child(u, 2) # AST.NoNode THEN
- SplitModuleBody(AST.Child(u, 2), initBody, finBody)
- ELSE
- initBody := AST.NoNode; finBody := AST.NoNode
- END;
- IF isProg THEN
- (* Program body as its own init function: main calls it, then the
- finalizers, then returns ExitCode. This also makes a module
- RETURN leave only the init function, not main. *)
- QbeGen.BeginInit(nm);
- EmitCountInits;
- nUserLab := 0;
- LowerStmt(initBody);
- QbeGen.EndInit;
- LowerFini(nm, finBody);
- QbeGen.BeginBody
- ELSIF AST.Child(u, 2) # AST.NoNode THEN
- QbeGen.BeginInit(nm);
- EmitCountInits;
- nUserLab := 0;
- LowerStmt(initBody);
- QbeGen.EndInit;
- LowerFini(nm, finBody)
- ELSIF nCountInit > 0 THEN
- QbeGen.BeginInit(nm);
- EmitCountInits;
- QbeGen.EndInit
- ELSIF separateMode AND NOT defUnitMode THEN
- (* Every object exports <module>_init, even when the module has
- no BEGIN body, so a program can call all imported inits.
- A definition lowered only to materialise its globals must not
- define a second init. *)
- QbeGen.BeginInit(nm);
- QbeGen.EndInit
- END
- END LowerOneUnit;
- PROCEDURE SetLegacyOpen1D;
- BEGIN
- legacyOpen1D := TRUE
- END SetLegacyOpen1D;
- PROCEDURE SetSeparate (b: BOOLEAN);
- BEGIN
- separateMode := b
- END SetSeparate;
- PROCEDURE SetDefUnit (b: BOOLEAN);
- BEGIN
- defUnitMode := b
- END SetDefUnit;
- PROCEDURE BeginSession (progName: ARRAY OF CHAR);
- (* Per-unit Lower emission. The grammar still runs its inline emit while
- parsing, but under NoEmit it only mutates QbeGen's counters (nothing
- reaches the buffer). For each unit: BeginUnit snapshots the state
- *before* parsing; after parsing, LowerUnitNow restores that snapshot
- and lets Lower re-emit the unit from the same counter values the
- legacy inline path would have used, so the image stays byte-identical.
- EndSession writes the accumulated session image. *)
- BEGIN
- withTop := 0;
- curImplCls := SymTab.InvalidType;
- scopeTop := 0; curScopeProc := -1; emitProc := -1;
- QbeGen.OpenModule(progName);
- QbeGen.SetNoEmit(TRUE)
- END BeginSession;
- PROCEDURE BeginUnit;
- (* Snapshot the pre-parse state so Lower can discard the grammar's
- suppressed inline mutations for this unit. *)
- BEGIN
- nImps := 0;
- QbeGen.SaveSession
- END BeginUnit;
- PROCEDURE LowerUnitNow (unit: AST.Node; isProg: BOOLEAN);
- VAR nm: SymTab.Name; scoped: BOOLEAN;
- BEGIN
- IF unit = AST.NoNode THEN RETURN END;
- QbeGen.RestoreSession;
- QbeGen.SetNoEmit(FALSE);
- (* Lower the unit in its own module scope, so type lookups resolve
- locally and nothing needs to be copied into globScope. *)
- Name(AST.Child(unit, 0), nm);
- scoped := SymTab.EnterLowerScope(nm);
- LowerOneUnit(unit, isProg);
- IF scoped THEN SymTab.LeaveLowerScope END;
- QbeGen.SetNoEmit(TRUE)
- END LowerUnitNow;
- PROCEDURE EndSession;
- VAR scoped: BOOLEAN;
- BEGIN
- QbeGen.SetNoEmit(FALSE);
- (* EndModule probes the program module's ExitCode symbol. *)
- scoped := SymTab.EnterLowerScope(curUnitName);
- QbeGen.EndModule(curUnitName);
- IF scoped THEN SymTab.LeaveLowerScope END
- END EndSession;
- BEGIN
- scopeTop := 0; curScopeProc := -1; emitProc := -1;
- separateMode := FALSE; defUnitMode := FALSE
- END Lower.
|