| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868 |
- 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;
- 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: 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)
- 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.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;
- 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
- 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.CheckRange(ql, qlo, qhi);
- eT := SymTab.ArrayElem(t);
- 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;
- 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
- END
- END;
- INC(i)
- END
- 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 LowerCall (n: AST.Node; VAR t: SymTab.TypeIndex;
- VAR q: QbeGen.QVal; want: BOOLEAN);
- VAR nm, pn, cqn: SymTab.Name; i, ai: CARDINAL; at, ft, res: SymTab.TypeIndex;
- qa, qt, qe, mg, qres: QbeGen.QVal; conv, isV, qual, ind, isC, va: BOOLEAN;
- uid, depth, np: CARDINAL; ext: BOOLEAN; ck: INTEGER; pi: INTEGER;
- ct: SymTab.TypeIndex; csfx: BOOLEAN; cl: CHAR;
- seq, next, arg: AST.Node;
- BEGIN
- qual := CalleeAlias(n, nm);
- ind := FALSE; isC := FALSE; va := FALSE; pi := -1; ext := FALSE;
- 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
- IF ext THEN QbeGen.CopyOp(nm, mg) ELSE QbeGen.Mangled(nm, uid, mg) END;
- 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);
- IF ext THEN
- (* External callee: bind to its C link name (the procedure's
- own name); SymTab.ProcLink cannot be consulted after
- EndUnit. *)
- QbeGen.CopyOp(nm, mg)
- ELSE
- QbeGen.Mangled(nm, uid, mg)
- END;
- 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, pn) THEN
- QbeGen.CallBegin(pn, res, 0, TRUE)
- ELSE
- QbeGen.CallBegin(nm, res, 0, FALSE)
- END
- ELSE
- res := SymTab.InvalidType;
- QbeGen.CallBegin(nm, res, 0, FALSE)
- END
- END
- 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 va THEN
- (* permissive C variadic argument *)
- QbeGen.CArgAdd(qe, at, qa, cl)
- ELSIF isV THEN
- IF (SymTab.ClassOf(at) = SymTab.ClChar)
- AND (SymTab.ClassOf(ft) = SymTab.ClArray)
- AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar)
- AND QbeGen.IsImm(qe) THEN
- (* 1-char string literal passed to a VAR ARRAY OF CHAR:
- pass its static descriptor *)
- QbeGen.DeclCharStr(qe, qa);
- IF NOT QbeGen.CallArg(qa, "l") THEN END
- ELSIF SymTab.IsByteBuf(ft)
- AND (SymTab.ClassOf(at) # SymTab.ClArray)
- AND (SymTab.ClassOf(at) # SymTab.ClStr) THEN
- (* gm2 ext: wrap the scalar actual as a stack byte-buffer
- descriptor (count = SIZE(actual), payload = a copy) *)
- QbeGen.OpenScalarDesc(qe, at, ft, qa);
- IF NOT QbeGen.CallArg(qa, "l") THEN END
- ELSIF QbeGen.AddrOfVal(qe, qa) THEN
- IF NOT QbeGen.CallArg(qa, "l") THEN END
- END
- ELSE
- IF (SymTab.ClassOf(at) = SymTab.ClChar)
- AND (SymTab.ClassOf(ft) = SymTab.ClArray)
- AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar)
- AND QbeGen.IsImm(qe) THEN
- (* 1-char string literal passed to ARRAY OF CHAR: pass its
- static descriptor, not the char code *)
- QbeGen.DeclCharStr(qe, qa);
- IF NOT QbeGen.CallArg(qa, "l") THEN END
- ELSIF SymTab.IsByteBuf(ft)
- AND (SymTab.ClassOf(at) # SymTab.ClArray)
- AND (SymTab.ClassOf(at) # SymTab.ClStr) THEN
- (* gm2 ext: wrap the scalar actual as a stack byte-buffer
- descriptor (count = SIZE(actual), payload = a copy) *)
- QbeGen.OpenScalarDesc(qe, at, ft, qa);
- IF NOT QbeGen.CallArg(qa, "l") THEN END
- ELSE
- conv := (SymTab.ClassOf(ft) = SymTab.ClReal)
- 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
- 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 CompositeRes(res) THEN QbeGen.CopyOp(qres, q) END
- ELSE
- t := SymTab.InvalidType; QbeGen.CopyOp("0", q); QbeGen.CallEnd(FALSE, q)
- 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
- IF ext THEN QbeGen.CopyOp(nm, mg) ELSE QbeGen.Mangled(nm, uid, mg) END;
- 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;
- 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.ClassOf(et) = SymTab.ClReal);
- 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); 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);
- QbeGen.IntStr(VAL(INTEGER, SymTab.ObjectSize(dt)), q);
- 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.ClReal THEN
- IF isMax THEN QbeGen.NormReal("3.402823e38", q)
- ELSE QbeGen.NormReal("-3.402823e38", 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), qn);
- IF (qn[0] = "U") OR (qn[0] = "u") THEN
- QbeGen.DeclUStr(qn, 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(qn) = 3 THEN c1 := 1
- ELSE QbeGen.DeclStr(qn, qd); c1 := SymTab.StrLen(qn) - 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.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) THEN
- QbeGen.ConvIR(q, qa); QbeGen.CopyOp(qa, q); t := vt
- ELSIF (c1 = SymTab.ClLong) AND (c2 = SymTab.ClReal) THEN
- QbeGen.ConvLR(q, qa); QbeGen.CopyOp(qa, q); t := vt
- ELSIF (c1 = SymTab.ClReal) 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) AND (c2 = SymTab.ClLong) THEN
- QbeGen.ConvRL(q, qa); QbeGen.CopyOp(qa, q); 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
- (* ADR of a procedure is its code address *)
- LowerProcAddr(qn, q)
- 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;
- 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 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.ClassOf(ft) = SymTab.ClReal) 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;
- BEGIN
- LowerExpr(AST.Child(n, 0), tsel, qsel);
- 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 *)
- 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;
- (* 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;
- 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, qn);
- IF (qn[0] = "U") OR (qn[0] = "u") THEN
- (* U"..." / U'...': one codepoint -> UCHAR, else a ustring *)
- QbeGen.DeclUStr(qn, 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(qn) = 3 THEN
- t := SymTab.CharType(); QbeGen.IntStr(QbeGen.CharVal(qn), q)
- ELSE
- t := AST.Ty(n); IF t = -1 THEN t := SymTab.NewStr() END; QbeGen.DeclStr(qn, 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;
- QbeGen.NewSetTemp(8, q); QbeGen.SetZero(q, 8);
- 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);
- QbeGen.SetRange(q, q2, qt, SymTab.SetBaseLo(t), SymTab.SetCount(t))
- ELSE
- LowerExpr(el, t2, q2);
- QbeGen.SetBit(q, q2, SymTab.SetBaseLo(t), SymTab.SetCount(t))
- 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.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);
- QbeGen.SetRange(q, q2, qt, SymTab.SetBaseLo(t),
- SymTab.SetCount(t))
- ELSE
- LowerExpr(el, t2, q2);
- QbeGen.SetBit(q, q2, SymTab.SetBaseLo(t), SymTab.SetCount(t))
- 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.ClassOf(t) = SymTab.ClReal);
- 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
- QbeGen.InSet(q, q2, SymTab.SetBaseLo(t2), SymTab.SetCount(t2), qt);
- 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
- QbeGen.CmpSet(rop, q, q2, SymTab.SetWords(t), SymTab.SetWords(t2), qt);
- t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
- 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.ClassOf(t) = SymTab.ClReal);
- 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;
- QbeGen.SetBinOp(idx, q, q2, lw, rw, qt);
- t := SymTab.NewSet(SymTab.NewSubR(0, VAL(INTEGER, mw) * 32 - 1));
- 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.ClassOf(lt) = SymTab.ClReal)
- OR (SymTab.ClassOf(rt) = SymTab.ClReal) 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.ClassOf(t) = SymTab.ClReal;
- 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)
- 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: 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.NkAssign THEN
- LowerDesign(AST.Child(seq, 0), dt, cls, qd, qn, sfx);
- LowerExpr(AST.Child(seq, 1), et, qe);
- 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;
- isR := (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClReal);
- 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 (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.CopySet(qd, qe, SymTab.SetWords(dt), SymTab.SetWords(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 (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.CopySet(qd, qe, SymTab.SetWords(dt), SymTab.SetWords(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); QbeGen.StoreVar(qn, qt, TRUE)
- 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;
- (* 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 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
- QbeGen.CopySet(qt, q, SymTab.SetWords(procRes[emitProc]),
- SymTab.SetWords(procRes[emitProc]))
- ELSE QbeGen.CopyRecord(qt, q, procRes[emitProc])
- END;
- QbeGen.EmitRet("0", FALSE)
- ELSE
- conv := (SymTab.ClassOf(SymTab.CurRes()) = SymTab.ClReal)
- AND SymTab.IsIntFamily(t);
- IF conv THEN QbeGen.ConvIR(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 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;
- 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
- QbeGen.BeginInit(nm);
- LowerStmt(AST.Child(c, 2));
- QbeGen.EndInit
- 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
- QbeGen.BeginInit(nm);
- LowerStmt(AST.Child(c, 2));
- QbeGen.EndInit
- 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;
- 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 isProg THEN
- QbeGen.BeginBody;
- EmitCountInits;
- nUserLab := 0;
- LowerStmt(AST.Child(u, 2))
- ELSIF AST.Child(u, 2) # AST.NoNode THEN
- QbeGen.BeginInit(nm);
- EmitCountInits;
- nUserLab := 0;
- LowerStmt(AST.Child(u, 2));
- QbeGen.EndInit
- ELSIF nCountInit > 0 THEN
- QbeGen.BeginInit(nm);
- EmitCountInits;
- QbeGen.EndInit
- END
- END LowerOneUnit;
- 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
- END Lower.
|