| 12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459 |
- COMPILER M2
- (* Step 1 — minimal integer pipeline (m2compiler-V3).
- Subset: program MODULE + CONST (literal) + VAR INTEGER +
- assignment + integer expressions (+ - * DIV MOD, leading sign,
- parens). Fresh QBE backend (QbeGen) to gen_ssa/<Module>.ssa;
- assemble with qbe, link with cc.
- Test convention: a global VAR ExitCode : INTEGER makes generated
- $main return its value as the process exit code, else return 0.
- Semantic errors reuse the V1/V2/Test2 family: 200 duplicate,
- 201 undeclared, 202 module name mismatch, 210 bad assignment,
- 211 bad arithmetic, 221 not a type, 230 not supported yet,
- 231 opaque type outside definition.
- Scalar-phase TYPEs (named, integer subrange, enum) check fully;
- composite forms wait for step 3. Procedure headings (formals,
- result, FORWARD) enter scopes now; bodies parse + check with one
- 230 at END (lowering = step 4).
- Statements: assignment, IF/ELSIF/ELSE, WHILE, REPEAT/UNTIL,
- LOOP/EXIT (230 outside LOOP), FOR/TO/static-sign-BY, full CASE
- (labels, ranges, ELSE; compare-chain), RETURN with 232 checks
- (outside proc / value mismatch / missing value). WITH waits for
- records (step 3). Boolean connectives are eager (or/and/xor);
- relations yield 0/1 via cXXw.
- Clarion-form classes (docs/OOP.txt): CLASS decl + single
- inheritance + CLASS IMPLEMENTATION blocks, methods with ";"
- (per the Table example, not the sketch's ","), VIRTUAL flagged.
- Scopes and member checks now; lowering later (one 230 per
- class/impl block). Classic identifiers: no underscores, so the
- Table example's _names stay lexically out of reach.
- Step 3.1 arrays: "ARRAY [lo..hi, ...] OF T" (folded literal
- bounds, int/char) and open "ARRAY OF T" formals; index suffixes
- with per-level checks (217/218, trap on breach via $abort);
- whole-array ":=" with runtime count check + blit; string
- literals lower as descriptors (1-char stays CHAR, empty works);
- array/string "=" is 213 (no built-in whole comparison).
- Step 3.3 sets: multi-word masks (no header, static words) over
- bases ≤ 256 values; literals are SET OF [0..255] (222 on
- out-of-span); + - * / as or/and/xor-not, IN with span trap,
- =/# word-wise (lenient cross-base); CASE labels reject sets.
- Step 3.4 records: flat blobs; array fields are pointers to static
- descriptors (locked amendment — one layout per type); nested
- records inline; static declaration-order offsets; field chains
- mix with indexes; WITH pushes fields + bases (215/216);
- whole-record deep copy; record/set/class "=" is 213.
- Step 3.6 pointers: vars (l), NIL as a real type (FNil — assignment
- and =/# work, everything else 210-214/222), ^ deref with sfx
- discipline (address flows, load at use; chains compose),
- pointer =/# via ceql/cnel (< > etc. are 213), NEW/DISPOSE as
- builtin statements via extern malloc/free (recursive skeleton
- init; DISPOSE shallow and nils, deviating from Wirth-undefined);
- nil-deref is raw (no check). *)
- IMPORT SymTab, QbeGen;
- CHARACTERS
- eol = CHR(13) .
- lf = CHR(10) .
- letter = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" .
- digit = "0123456789" .
- hexDigit = digit + "ABCDEFabcdef" .
- noQuote1 = ANY - "'" - eol .
- noQuote2 = ANY - '"' - eol .
- IGNORE CHR(9) .. CHR(13)
- COMMENTS FROM "(*" TO "*)" NESTED
- COMMENTS FROM "//" TO lf
- TOKENS
- ident = letter { letter | digit } .
- integer = digit { digit }
- | digit { digit } CONTEXT("..")
- | "0x" hexDigit { hexDigit }
- | "0X" hexDigit { hexDigit } .
- real = digit { digit } "." { digit }
- [ ( "E" | "e" ) [ "+" | "-" ] digit { digit } ] .
- string = "'" { noQuote1 } "'"
- | '"' { noQuote2 } '"' .
- charConst = digit { digit } ( "C" | "c" ) .
- ustring = ( "U" | "u" ) ( "'" { noQuote1 } "'" | '"' { noQuote2 } '"' ) .
- PRODUCTIONS
- M2
- = Unit "." .
- (* Units: program modules compile fully; DEFINITION and
- IMPLEMENTATION modules parse + check now but lower in step 4
- (each ends with one 230); same for nested local modules. *)
- Unit
- = DefUnit
- | ImplUnit
- | ProgModule .
- (* Step 4.3: one session compiles DEFINITION, its IMPLEMENTATION
- and one program (last) into one image. Units share the symbol
- table; imports materialize exported names. *)
- DefUnit (. VAR m1, m2, pn: SymTab.Name; .)
- = "DEFINITION" "MODULE"
- GetIdent<m1> (. IF NOT SymTab.BeginDef(m1) THEN
- SemError(200) END;
- QbeGen.SetModule(m1); .)
- ";"
- { Import }
- { ConstBlock | TypeBlock<TRUE> | VarBlock
- | ProcHeading<pn> ";" (. SymTab.CloseProc;
- QbeGen.AbortFunc; .) }
- "END"
- GetIdent<m2> (. IF NOT SymTab.Equal(m1, m2) THEN
- SemError(202) END;
- SymTab.EndUnit; .) .
- ImplUnit (. VAR m1, m2: SymTab.Name; .)
- = "IMPLEMENTATION" "MODULE"
- GetIdent<m1> (. IF NOT SymTab.BeginImpl(m1) THEN
- SemError(201) END;
- QbeGen.SetModule(m1); .)
- ";"
- { Import }
- DeclSeq
- [ "BEGIN" (. QbeGen.BeginInit(m1); .)
- [ StatSeq ] (. QbeGen.EndInit; .) ]
- "END"
- GetIdent<m2> (. IF NOT SymTab.Equal(m1, m2) THEN
- SemError(202) END;
- SymTab.EndUnit; .) .
- ProgModule (. VAR m1, m2: SymTab.Name; .)
- = "MODULE"
- GetIdent<m1> (. IF NOT SymTab.BeginProg(m1) THEN
- SemError(200) END;
- QbeGen.SetModule(m1); .)
- [ Priority ]
- ";"
- { Import }
- DeclSeq
- [ "BEGIN" (. QbeGen.BeginBody; .)
- [ StatSeq ] ]
- "END"
- GetIdent<m2> (. IF NOT SymTab.Equal(m1, m2) THEN
- SemError(202) END;
- QbeGen.EndModule(m1);
- SymTab.EndUnit; .) .
- DeclSeq
- = { ConstBlock | TypeBlock<FALSE> | VarBlock | ProcDecl ";"
- | NestedModule ";" | ClassItem ";" } .
- (* Local module, Wirth form. Declarations lower like top-level ones
- (same QBE module prefix); a BEGIN body becomes an init function
- that main calls; the EXPORT list is hoisted into the enclosing
- scope at END. *)
- NestedModule (. VAR m1, m2: SymTab.Name;
- expNames: ARRAY [0 .. 63] OF SymTab.Name;
- expCount, k: CARDINAL; .)
- = "MODULE"
- GetIdent<m1> (. IF NOT SymTab.Enter(m1,
- SymTab.KindModule) THEN
- SemError(200) END;
- SymTab.PushScope;
- expCount := 0; .)
- [ Priority ]
- ";"
- { Import }
- [ "EXPORT" [ "QUALIFIED" ]
- GetIdent<expNames[expCount]> (. INC(expCount); .)
- { "," GetIdent<expNames[expCount]>
- (. INC(expCount); .) }
- ";" ]
- DeclSeq
- [ "BEGIN" (. QbeGen.BeginInit(m1); .)
- [ StatSeq ] (. QbeGen.EndInit; .) ]
- "END"
- GetIdent<m2> (. IF NOT SymTab.Equal(m1, m2) THEN
- SemError(202) END;
- k := 0;
- WHILE k < expCount DO
- SymTab.ExportUp(expNames[k]);
- INC(k)
- END;
- SymTab.PopScope; .) .
- Priority
- = "[" integer "]" (. SemError(230); .) .
- (* Imports (4.3): FROM materializes the names (unqualified use);
- plain IMPORT only demands the module exists — qualified `L.x`
- materializes on first use (Design). *)
- (* Unknown modules stay unchecked stubs (legacy, so hand-written
- import lines don't fail); a known module's missing export is
- 201. *)
- Import (. VAR n: SymTab.Name; .)
- = "FROM"
- GetIdent<n>
- "IMPORT"
- ImpList<n> ";"
- | "IMPORT"
- ImpModList ";" .
- ImpList<mod: SymTab.Name> (. VAR n: SymTab.Name; .)
- = ImpName<mod>
- { "," ImpName<mod> } .
- (* Pervasive built-ins imported from SYSTEM (e.g. TSIZE) are
- accepted and ignored: the built-in applies regardless. *)
- ImpName<mod: SymTab.Name> (. VAR n: SymTab.Name; .)
- = GetIdent<n> (. IF SymTab.ModKnown(mod)
- AND NOT SymTab.ImportFrom(mod, n) THEN
- SemError(201) END; .)
- | ( "TSIZE" | "SIZE" | "ADR" | "HIGH" | "LEN"
- | "CHR" | "ORD" | "ORDL" | "VAL" | "ABS" | "CAP"
- | "UCHR" | "CHR8" | "UORD"
- | "INC" | "DEC" ) .
- ImpModList (. VAR n: SymTab.Name; .)
- = GetIdent<n>
- { "," GetIdent<n> } .
- (* Opaque TYPE declarations (definition modules). The targetless
- alias resolves to InvalidType until step 4 completes it. *)
- (* Scalar-phase TYPEs: named types, integer subranges, enumerations.
- Opaque "TYPE T;" needs isDef (definition units); elsewhere 231.
- Composite forms (ARRAY/RECORD/SET/POINTER) arrive with step 3. *)
- TypeBlock<isDef: BOOLEAN>
- = "TYPE" (. SymTab.BeginTypeBlock; .)
- { TypeItem<isDef> ";" | ClassItem ";" }
- (. SymTab.EndTypeBlock; .) .
- TypeItem<isDef: BOOLEAN> (. VAR n: SymTab.Name;
- t, op: SymTab.TypeIndex; .)
- = GetIdent<n> (. op := SymTab.OpaqueBase(n);
- IF op = SymTab.InvalidType THEN
- IF NOT SymTab.Enter(n,
- SymTab.KindType) THEN
- SemError(200) END
- END; .)
- ( "=" Type<t, FALSE> (. IF op # SymTab.InvalidType THEN
- SymTab.SetTarget(op, t)
- ELSE SymTab.SetSymType(n, t)
- END; .)
- | (. IF op # SymTab.InvalidType THEN
- (* stays opaque *)
- ELSIF NOT isDef THEN
- SemError(231)
- ELSE SymTab.SetSymType(n,
- SymTab.NewAlias()) END; .) ) .
- Type<VAR t: SymTab.TypeIndex; allowOpen: BOOLEAN>
- = TypeIdent<t>
- | Subrange<t>
- | Enum<t>
- | ArrayType<t, allowOpen>
- | SetType<t>
- | RecordType<t>
- | PointerType<t>
- | ProcType<t> .
- PointerType<VAR t: SymTab.TypeIndex> (. VAR base: SymTab.TypeIndex; .)
- = "POINTER" "TO" Type<base, FALSE>(. t := SymTab.NewPtr(base); .) .
- (* Procedure types (step 8.5): PROCEDURE (params): result. Values
- are code pointers; params are collected into the descriptor. *)
- ProcType<VAR t: SymTab.TypeIndex> (. VAR res, pt: SymTab.TypeIndex;
- isV: BOOLEAN; .)
- = "PROCEDURE" (. res := SymTab.InvalidType;
- t := SymTab.NewProcType(res); .)
- [ "(" [ ProcTypeSection<t> { ";" ProcTypeSection<t> } ] ")" ]
- [ ":" TypeIdent<res> (. SymTab.SetProcTypeRes(t, res); .) ] .
- ProcTypeSection<t: SymTab.TypeIndex> (. VAR pt: SymTab.TypeIndex;
- isV: BOOLEAN;
- cnt, k: CARDINAL;
- names: ARRAY [0 .. 15] OF SymTab.Name; .)
- = (. isV := FALSE; cnt := 0; .)
- [ "VAR" (. isV := TRUE; .) ]
- GetIdent<names[cnt]> (. INC(cnt); .)
- { "," GetIdent<names[cnt]> (. INC(cnt); .) }
- ( ":" Type<pt, FALSE> (. k := 0;
- WHILE k < cnt DO
- SymTab.ProcTypeAdd(t, isV, pt);
- INC(k)
- END; .)
- | (. (* type-only parameter list:
- each name is a type (GNU
- shorthand used by the
- Coco/R scanner frame) *)
- k := 0;
- WHILE k < cnt DO
- IF SymTab.Lookup(names[k])
- AND ((SymTab.SymKind(names[k]) = SymTab.KindType)
- OR (SymTab.SymKind(names[k]) = SymTab.KindPredef)) THEN
- pt := SymTab.SymType(names[k])
- ELSE SemError(201);
- pt := SymTab.InvalidType
- END;
- SymTab.ProcTypeAdd(t, isV, pt);
- INC(k)
- END; .) ) .
- (* Arrays: "OF" without bounds is an open formal (allowed only
- where allowOpen); "[lo..hi, ...]" nests bounded levels inside
- out. Bounds are folded literals (int/char); anything else 230.
- Bare-type indices ("ARRAY Color OF") wait for enum ordinals. *)
- ArrayType<VAR t: SymTab.TypeIndex; allowOpen: BOOLEAN>
- (. VAR elem: SymTab.TypeIndex;
- ok: BOOLEAN;
- bnds, bndh: ARRAY [0 .. 7] OF INTEGER;
- nb, k: CARDINAL; .)
- = "ARRAY"
- ( "OF" Type<elem, FALSE> (. IF NOT allowOpen THEN
- SemError(230) END;
- t := SymTab.NewOpenArray(elem); .)
- | "[" (. SymTab.BoundBegin; ok := TRUE; .)
- BoundPair<ok>
- { "," BoundPair<ok> }
- "]" (. (* snapshot before the element
- type, which reuses the bound
- buffer for a nested ARRAY *)
- nb := SymTab.BoundCount();
- k := 0;
- WHILE k < nb DO
- bnds[k] := SymTab.BoundLo(k);
- bndh[k] := SymTab.BoundHi(k);
- INC(k)
- END; .)
- "OF" Type<elem, FALSE>
- (. IF ok THEN
- k := nb;
- WHILE k > 0 DO
- DEC(k);
- elem := SymTab.NewArrayB(
- elem, bnds[k], bndh[k])
- END;
- t := elem
- ELSE t := SymTab.InvalidType
- END; .) ) .
- BoundPair<VAR ok: BOOLEAN> (. VAR tlo, thi: SymTab.TypeIndex;
- qlo, qhi: QbeGen.QVal;
- lo, hi: INTEGER;
- cl, cl2: INTEGER; .)
- = Expr<tlo, qlo> ".." Expr<thi, qhi>
- (. IF (tlo = SymTab.InvalidType)
- OR (thi = SymTab.InvalidType) THEN
- ok := FALSE
- ELSE cl := SymTab.ClassOf(tlo);
- cl2 := SymTab.ClassOf(thi);
- IF ((cl # SymTab.ClInt)
- AND (cl # SymTab.ClChar))
- OR ((cl2 # SymTab.ClInt)
- AND (cl2 # SymTab.ClChar)) THEN
- SemError(230); ok := FALSE
- ELSIF NOT SymTab.ConstInt(qlo, lo)
- OR NOT SymTab.ConstInt(qhi, hi)
- OR (lo > hi) THEN
- SemError(230); ok := FALSE
- ELSIF NOT SymTab.BoundAdd(lo, hi) THEN
- SemError(230); ok := FALSE
- END;
- END; .) .
- (* Sets: multi-word masks over bases ≤ 256 values (bool, char,
- bounded subranges; enums wait for ordinals, INTEGER is
- unbounded). Literals are SET OF [0..255]; assignment and
- comparison across suitable bases are lenient (masks over min
- words + zero-check extras), out-of-span literals are 222. *)
- SetType<VAR t: SymTab.TypeIndex> (. VAR base: SymTab.TypeIndex;
- blo, bhi, bspan: INTEGER;
- bcls: INTEGER; .)
- = "SET" "OF" Type<base, FALSE>
- (. IF base = SymTab.InvalidType THEN
- t := SymTab.InvalidType
- ELSE bcls :=
- SymTab.ClassOf(base);
- IF bcls = SymTab.ClBool THEN
- blo := 0; bspan := 2
- ELSIF bcls = SymTab.ClChar THEN
- blo := 0; bspan := 256
- ELSIF SymTab.SubBounds(base,
- blo, bhi) THEN
- bspan := bhi - blo + 1
- ELSE bspan := 0 END;
- IF (bspan <= 0)
- OR (bspan > 256) THEN
- SemError(230);
- t := SymTab.InvalidType
- ELSE t := SymTab.NewSet(base)
- END
- END; .) .
- (* Records: flat blobs; array fields are pointers to static
- descriptors (locked amendment), nested records inline. Field
- offsets static and declaration-ordered. *)
- (* Field list: plain fields and (optionally) one variant part. The
- variant part is a `CASE ... END` item; because it starts with the
- CASE keyword it is unambiguously distinguishable from a field
- (which starts with an identifier). *)
- RecordType<VAR t: SymTab.TypeIndex> (. VAR t2: SymTab.TypeIndex;
- tagOk: BOOLEAN; .)
- = "RECORD" (. t := SymTab.NewRecord(); .)
- [ RecItem<t> { ";" [ RecItem<t> ] } ]
- "END" .
- RecItem<rec: SymTab.TypeIndex> (. VAR tt: SymTab.TypeIndex; .)
- = RecField<rec>
- | CaseField<rec> (. SymTab.MarkVariant(rec); .) .
- (* A variant part: CASE tag : Type OF variants. The layout overlays
- every branch from the tag slot (see SymTab.ComputeOffsets). *)
- CaseField<rec: SymTab.TypeIndex> (. VAR tagT: SymTab.TypeIndex;
- tagN: SymTab.Name; .)
- = "CASE" (. SymTab.ResetFields(rec); .)
- GetIdent<tagN> (. IF NOT SymTab.FieldPending(rec,
- tagN) THEN
- SemError(200) END; .)
- ":" Type<tagT, FALSE> (. IF (tagT # SymTab.InvalidType)
- AND NOT SymTab.IsOrdinal(tagT) THEN
- SemError(224)
- END;
- SymTab.FixPendingF(rec, tagT);
- SymTab.SetVariantTag(rec, tagN); .)
- "OF"
- RecFieldList<rec>
- { "|" (. SymTab.ResetFields(rec); .)
- RecFieldList<rec> }
- "END" .
- RecFieldList<rec: SymTab.TypeIndex> (. VAR lt, lq: SymTab.TypeIndex;
- lv1, lv2: QbeGen.QVal; .)
- = VarLabel<lt, lv1> [ ".." VarLabel<lq, lv2> ] ":"
- RecField<rec> { ";" [ RecField<rec> ] } .
- (* Variant case label: a constant (or a constant range). Values are
- not interpreted (the layout overlays regardless). *)
- VarLabel<VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal>
- (. VAR lname: SymTab.Name; .)
- = ( ident (. LexName(lname);
- QbeGen.CopyOp("0", q);
- t := SymTab.IntType(); .)
- | integer (. LexString(lname);
- QbeGen.CopyOp("0", q);
- t := SymTab.IntType(); .)
- | charConst (. LexString(lname);
- QbeGen.CopyOp("0", q);
- t := SymTab.CharType(); .) ) .
- RecField<rec: SymTab.TypeIndex> (. VAR n: SymTab.Name;
- t2: SymTab.TypeIndex; .)
- = RecIdents<rec> ":" Type<t2, FALSE>(. SymTab.FixPendingF(rec, t2); .) .
- RecIdents<rec: SymTab.TypeIndex> (. VAR n: SymTab.Name; .)
- = GetIdent<n> (. IF NOT SymTab.FieldPending(rec,
- n) THEN
- SemError(200) END; .)
- { "," GetIdent<n> (. IF NOT SymTab.FieldPending(rec,
- n) THEN
- SemError(200) END; .) } .
- TypeIdent<VAR t: SymTab.TypeIndex> (. VAR n, qid: SymTab.Name;
- k: INTEGER;
- dotted: BOOLEAN; .)
- = GetIdent<n> (. dotted := FALSE;
- IF NOT SymTab.Lookup(n) THEN
- k := -1;
- t := SymTab.ForwardType(n);
- IF t = SymTab.InvalidType THEN
- SemError(201)
- END
- ELSE k := SymTab.SymKind(n);
- IF (k = SymTab.KindType)
- OR (k = SymTab.KindPredef) THEN
- t := SymTab.SymType(n)
- ELSE t := SymTab.InvalidType
- END
- END; .)
- [ "." GetIdent<qid> (. dotted := TRUE;
- IF k = SymTab.KindModule THEN
- t := SymTab.QualType(n, qid);
- IF t = SymTab.InvalidType THEN
- SemError(201)
- END
- ELSE SemError(221);
- t := SymTab.InvalidType
- END; .) ]
- (. IF NOT dotted THEN
- IF (k = SymTab.KindModule)
- OR ((k # SymTab.KindType)
- AND (k # SymTab.KindPredef)
- AND (k # SymTab.KindImport)
- AND (k # -1)) THEN
- SemError(221)
- END
- END; .) .
- Subrange<VAR t: SymTab.TypeIndex> (. VAR tlo, thi: SymTab.TypeIndex;
- qlo, qhi: QbeGen.QVal;
- lo, hi: INTEGER; .)
- = "[" Expr<tlo, qlo> ".." Expr<thi, qhi>
- (. IF (tlo = SymTab.InvalidType)
- OR (thi = SymTab.InvalidType) THEN
- t := SymTab.InvalidType
- ELSIF (SymTab.ClassOf(tlo) #
- SymTab.ClInt)
- OR (SymTab.ClassOf(thi) #
- SymTab.ClInt) THEN
- SemError(230);
- t := SymTab.InvalidType
- ELSIF NOT SymTab.ConstInt(qlo, lo)
- OR NOT SymTab.ConstInt(qhi, hi)
- OR (lo > hi) THEN
- SemError(230);
- t := SymTab.InvalidType
- ELSE t := SymTab.NewSubR(lo, hi)
- END; .)
- "]" .
- Enum<VAR t: SymTab.TypeIndex> (. VAR n: SymTab.Name;
- ord: INTEGER;
- qv: QbeGen.QVal; .)
- = "(" (. t := SymTab.NewEnum();
- ord := 0; .)
- GetIdent<n> (. IF NOT SymTab.Enter(n,
- SymTab.KindConst) THEN
- SemError(200) END;
- SymTab.SetSymType(n, t);
- QbeGen.IntStr(ord, qv);
- SymTab.SetSymVal(n, qv);
- INC(ord); .)
- { "," GetIdent<n> (. IF NOT SymTab.Enter(n,
- SymTab.KindConst) THEN
- SemError(200) END;
- SymTab.SetSymType(n, t);
- QbeGen.IntStr(ord, qv);
- SymTab.SetSymVal(n, qv);
- INC(ord); .) }
- ")" .
- (* Clarion-form classes (docs/OOP.txt): declaration + single
- inheritance + IMPLEMENTATION blocks. Scopes and member checks
- now; lowering (vtable, dispatch, THIS) later — one 230 per
- class/impl block. Methods end with ";" per the Table example
- (not "," as in the sketch). No underscores in identifiers. *)
- (* Single CLASS item in both loops: separating declaration from
- IMPLEMENTATION at the loop level needs 2-token lookahead
- (CLASS ident vs CLASS IMPLEMENTATION), which LL(1) cannot do.
- The second token decides after CLASS is consumed. A misplaced
- CLASS IMPLEMENTATION inside TYPE still parses (harmless: the
- whole unit ends 230 until lowering). *)
- ClassItem
- = "CLASS" ( "IMPLEMENTATION" ClassImplRest | ClassRest ) .
- ClassRest (. VAR cn, m2, pn: SymTab.Name;
- ct: SymTab.TypeIndex; .)
- = GetIdent<cn> (. IF NOT SymTab.Enter(cn,
- SymTab.KindType) THEN
- SemError(200) END;
- ct := SymTab.NewClass();
- SymTab.SetSymType(cn, ct);
- SymTab.PushClassScope(ct); .)
- [ Parents<ct> ]
- ";"
- { ClassField<ct> ";" }
- { MethodHeading<pn> ";" (. SymTab.CloseProc;
- QbeGen.AbortFunc; .) }
- "END"
- GetIdent<m2> (. IF NOT SymTab.Equal(cn, m2) THEN
- SemError(202) END;
- SymTab.PopScope;
- SemError(230); .) .
- Parents<ct: SymTab.TypeIndex> (. VAR p: SymTab.Name; .)
- = "(" Parent1<ct>
- { "," GetIdent<p> (. SemError(230); .) }
- ")" .
- Parent1<ct: SymTab.TypeIndex> (. VAR p: SymTab.Name;
- pt: SymTab.TypeIndex; .)
- = GetIdent<p> (. IF NOT SymTab.Lookup(p) THEN
- SemError(201)
- ELSE pt := SymTab.SymType(p);
- IF SymTab.ClassOf(pt) #
- SymTab.ClClass THEN
- SemError(230)
- ELSE SymTab.SetParent(ct, pt)
- END
- END; .) .
- ClassField<ct: SymTab.TypeIndex> (. VAR n, rhs: SymTab.Name;
- t: SymTab.TypeIndex; .)
- = GetIdent<n>
- ( "=" GetIdent<rhs> (. IF NOT SymTab.Enter(n,
- SymTab.KindConst) THEN
- SemError(200) END;
- IF SymTab.Lookup(rhs) THEN
- SymTab.SetSymType(n,
- SymTab.SymType(rhs))
- END; .)
- | (. IF NOT SymTab.FieldPending(ct,
- n) THEN
- SemError(200) END; .)
- { "," GetIdent<n> (. IF NOT SymTab.FieldPending(ct,
- n) THEN
- SemError(200) END; .) }
- ":" Type<t, FALSE> (. SymTab.FixPendingF(ct, t); .) ) .
- MethodHeading<VAR pn: SymTab.Name> (. VAR wantVirt: BOOLEAN; .)
- = (. wantVirt := FALSE; .)
- [ "VIRTUAL" (. wantVirt := TRUE; .) ]
- ProcHeading<pn> (. IF wantVirt THEN
- SymTab.MarkVirtual END; .) .
- ClassImplRest (. VAR cn, m2: SymTab.Name;
- ct: SymTab.TypeIndex; .)
- = GetIdent<cn> (. IF NOT SymTab.Lookup(cn) THEN
- SemError(201);
- ct := SymTab.InvalidType
- ELSE ct := SymTab.SymType(cn);
- IF SymTab.ClassOf(ct) #
- SymTab.ClClass THEN
- SemError(230);
- ct := SymTab.InvalidType
- END
- END;
- IF ct #
- SymTab.InvalidType THEN
- IF NOT SymTab.PushClassMembers(
- ct) THEN
- SemError(230) END
- END; .)
- ";" { MethodImpl<ct> ";" }
- [ "BEGIN"
- [ StatSeq ] ]
- "END"
- GetIdent<m2> (. IF NOT SymTab.Equal(cn, m2) THEN
- SemError(202) END;
- SymTab.PopScope;
- SemError(230); .) .
- MethodImpl<ct: SymTab.TypeIndex> (. VAR pn: SymTab.Name; .)
- = (. QbeGen.SetNoEmit(TRUE); .)
- MethodHeading<pn> ";"
- (. IF (ct #
- SymTab.InvalidType)
- AND NOT SymTab.MethodExists(ct,
- pn) THEN
- SemError(201) END; .)
- ( "FORWARD" (. SymTab.MarkFwd;
- SymTab.CloseProc; .)
- | Block<pn> (. SymTab.CloseProc; .) )
- (. QbeGen.AbortFunc;
- QbeGen.SetNoEmit(FALSE);
- SemError(230); .) .
- ConstBlock
- = "CONST" { ConstDecl ";" } .
- ConstDecl (. VAR n: SymTab.Name;
- t: SymTab.TypeIndex;
- qv: QbeGen.QVal;
- cls: INTEGER; .)
- = GetIdent<n> (. IF NOT SymTab.Enter(n,
- SymTab.KindConst) THEN
- SemError(200) END; .)
- "="
- Expr<t, qv> (. SymTab.SetSymType(n, t);
- cls := SymTab.ClassOf(t);
- IF cls = SymTab.ClStr THEN
- SemError(230)
- ELSIF NOT QbeGen.IsImm(qv) THEN
- SemError(230) END;
- SymTab.SetSymVal(n, qv);
- QbeGen.DeclConst(n, qv, t); .) .
- VarBlock
- = "VAR" { VarDecl ";" } .
- VarDecl (. VAR nm: SymTab.Name;
- t: SymTab.TypeIndex;
- i: CARDINAL;
- cls: INTEGER; .)
- = VarIdents ":"
- Type<t, FALSE> (. cls := SymTab.ClassOf(t);
- IF (t # SymTab.InvalidType)
- AND (cls # SymTab.ClInt)
- AND (cls # SymTab.ClBool)
- AND (cls # SymTab.ClChar)
- AND (cls # SymTab.ClReal)
- AND (cls # SymTab.ClArray)
- AND (cls # SymTab.ClSet)
- AND (cls # SymTab.ClRecord)
- AND (cls # SymTab.ClPtr)
- AND (cls # SymTab.ClLong)
- AND (cls # SymTab.ClProc)
- AND (cls # SymTab.ClUChar)
- AND (cls # SymTab.ClUStr)
- AND (cls # SymTab.ClEnum) THEN
- SemError(230) END;
- IF QbeGen.LocFull() THEN
- SemError(233) END;
- i := 0;
- WHILE i < SymTab.PendCount() DO
- SymTab.PendName(i, nm);
- QbeGen.DeclVar(nm, t);
- INC(i)
- END;
- (* a plain VAR list, not a
- heading: the signature
- result is discarded *)
- IF NOT SymTab.FixPending(t) THEN
- END; .) .
- VarIdents (. VAR n: SymTab.Name; .)
- = GetIdent<n> (. IF NOT SymTab.EnterPending(n,
- SymTab.KindVar) THEN
- SemError(200) END; .)
- { ","
- GetIdent<n> (. IF NOT SymTab.EnterPending(n,
- SymTab.KindVar) THEN
- SemError(200) END; .) } .
- ParIdents<isV: BOOLEAN> (. VAR n: SymTab.Name; .)
- = GetIdent<n> (. IF NOT SymTab.EnterParam(n, isV) THEN
- SemError(200) END; .)
- { "," GetIdent<n> (. IF NOT SymTab.EnterParam(n, isV) THEN
- SemError(200) END; .) } .
- (* Procedure headings enter scopes/params/result and buffer the
- QBE header; bodies lower to functions (4.1, module level only).
- FORWARD marks; the body heading re-enters (signature compare
- deferred). Nested procedures parse + check, lowering = 4.2. *)
- ProcHeading<VAR pn: SymTab.Name> (. VAR t: SymTab.TypeIndex;
- mg: QbeGen.QVal; .)
- = "PROCEDURE"
- GetIdent<pn> (. IF NOT SymTab.EnterProc(pn) THEN
- IF NOT SymTab.ReenterProc(pn) THEN
- IF NOT SymTab.ResumeProc(pn) THEN
- SemError(200) END
- END
- END;
- QbeGen.Mangled(pn,
- SymTab.ProcUid(pn), mg);
- QbeGen.BeginFunc(mg); .)
- [ FormalParams ]
- [ ":" TypeIdent<t> (. IF NOT SymTab.SetProcRes(t) THEN
- SemError(235) END;
- QbeGen.SetFuncRes(t);
- IF (t #
- SymTab.InvalidType)
- AND ((SymTab.ClassOf(t)
- = SymTab.ClArray)
- OR (SymTab.ClassOf(t)
- = SymTab.ClRecord)
- OR (SymTab.ClassOf(t)
- = SymTab.ClSet)
- OR (SymTab.ClassOf(t)
- = SymTab.ClClass)) THEN
- SemError(230) END; .) ] .
- FormalParams
- = "(" [ ParamSection { ";" ParamSection } ] ")" .
- ParamSection (. VAR t: SymTab.TypeIndex;
- nm: SymTab.Name;
- i: CARDINAL;
- isV: BOOLEAN; .)
- = (. isV := FALSE; .)
- [ "VAR" (. isV := TRUE; .) ]
- ParIdents<isV> ":" Type<t, TRUE> (. i := 0;
- WHILE i < SymTab.PendCount() DO
- SymTab.PendName(i, nm);
- (* value open arrays are
- passed as descriptor
- addresses (no copy):
- same representation as
- VAR formals *)
- IF NOT QbeGen.FuncParam(nm,
- isV
- OR SymTab.IsOpenArray(t),
- t) THEN
- SemError(233) END;
- INC(i)
- END;
- IF NOT SymTab.FixPending(t) THEN
- SemError(235) END; .) .
- (* Nested procedures lower like top-level ones (4.2): the
- static link gives them their parent's frame. Methods keep
- parse-now/230-later. *)
- ProcDecl (. VAR pn: SymTab.Name; .)
- = ProcHeading<pn> ";"
- ( "FORWARD" (. SymTab.MarkFwd;
- SymTab.CloseProc;
- QbeGen.AbortFunc; .)
- | "EXTERNAL" (. SymTab.MarkExternal("");
- SymTab.CloseProc;
- QbeGen.AbortFunc; .)
- | (. QbeGen.EndFuncHeader; .)
- Block<pn> (. SymTab.CloseProc;
- QbeGen.EndFunc(
- SymTab.ProcRes(pn)); .) ) .
- Block<pn: SymTab.Name> (. VAR m2: SymTab.Name; .)
- = DeclSeq
- [ "BEGIN"
- [ StatSeq ] ]
- "END"
- GetIdent<m2> (. IF NOT SymTab.Equal(pn, m2) THEN
- SemError(202) END; .) .
- StatSeq
- = Statement { ";" [ Statement ] } .
- (* Trailing/empty statements (`a; ; b`, Coco/R's generated `;;`)
- are accepted: the statement after ';' is optional. *)
- Statement (. VAR lx: QbeGen.QVal; .)
- = AssOrCall
- | IfStat
- | WhileStat
- | RepeatStat
- | LoopStat
- | ForStat
- | CaseStat
- | WithStat
- | ReturnStat
- | HaltStat
- | NewStat
- | DisposeStat
- | IncDecStat
- | "EXIT" (. IF QbeGen.TopLoop(lx) THEN
- QbeGen.Jmp(lx)
- ELSE SemError(230) END; .) .
- (* INC(v [,step]) / DEC(v [,step]) as builtin statements over an
- integer designator. *)
- IncDecStat (. VAR dt, et2: SymTab.TypeIndex;
- dk: INTEGER;
- qd, qv, qn2, qstep:
- QbeGen.QVal;
- qn: SymTab.Name;
- sfx, isInc: BOOLEAN; .)
- = (. isInc := TRUE; .)
- ( "INC" (. isInc := TRUE; .)
- | "DEC" (. isInc := FALSE; .) )
- "(" (. QbeGen.CopyOp("1", qstep); .)
- Design<dt, dk, qd, qn, sfx>
- [ "," Expr<et2, qstep> ]
- ")" (. IF dt = SymTab.InvalidType THEN
- ELSIF (dk # SymTab.KindVar)
- AND (dk # SymTab.KindParam)
- AND (dk # SymTab.KindField) THEN
- SemError(210)
- ELSIF NOT SymTab.IsIntFamily(dt) THEN
- SemError(211)
- ELSE
- IF sfx
- OR (dk = SymTab.KindField) THEN
- QbeGen.ElemLoad(qd, 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)
- ELSE QbeGen.StoreVar(qn,
- qn2, FALSE)
- END
- END; .) .
- (* NEW/DISPOSE as builtin statements (no call syntax until step 4).
- Targets are pointer designators; DISPOSE nils afterwards (safer
- than Wirth-undefined; documented). DISPOSE is shallow. *)
- NewStat (. VAR dt: SymTab.TypeIndex;
- dk: INTEGER;
- qd, qm: QbeGen.QVal;
- qn: SymTab.Name;
- sfx: BOOLEAN;
- bt: SymTab.TypeIndex; .)
- = "NEW" "(" Design<dt, dk, qd, qn, sfx> ")"
- (. IF dt = SymTab.InvalidType THEN
- ELSIF (dk # SymTab.KindVar)
- AND (dk # SymTab.KindParam)
- AND (dk # SymTab.KindField) THEN
- SemError(210)
- ELSIF SymTab.ClassOf(dt) #
- SymTab.ClPtr THEN
- SemError(219)
- 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; .) .
- DisposeStat (. VAR dt: SymTab.TypeIndex;
- dk: INTEGER;
- qd, qv: QbeGen.QVal;
- qn: SymTab.Name;
- sfx: BOOLEAN; .)
- = "DISPOSE" "(" Design<dt, dk, qd, qn, sfx> ")"
- (. IF dt = SymTab.InvalidType THEN
- ELSIF (dk # SymTab.KindVar)
- AND (dk # SymTab.KindParam)
- AND (dk # SymTab.KindField) THEN
- SemError(210)
- ELSIF SymTab.ClassOf(dt) #
- SymTab.ClPtr THEN
- SemError(219)
- 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; .) .
- (* WITH pushes each record's fields (inner wins) plus its base
- address; field designators resolve through both stacks. *)
- WithStat (. VAR nW: CARDINAL; .)
- = "WITH" (. nW := 0; .)
- WithItem<nW> { "," WithItem<nW> }
- "DO" [ StatSeq ] "END"
- (. WHILE nW > 0 DO
- SymTab.PopScope;
- QbeGen.PopWith;
- DEC(nW)
- END; .) .
- WithItem<VAR nW: CARDINAL> (. VAR dt: SymTab.TypeIndex;
- dk: INTEGER;
- qd, qe: QbeGen.QVal;
- qn: SymTab.Name;
- sfx: BOOLEAN; .)
- = Design<dt, dk, qd, qn, sfx>
- (. IF dt = SymTab.InvalidType THEN
- ELSIF (SymTab.ClassOf(dt) #
- SymTab.ClRecord)
- AND (SymTab.ClassOf(dt) #
- SymTab.ClClass) THEN
- SemError(215)
- ELSIF SymTab.PushRecord(dt) THEN
- QbeGen.PushWith(qd);
- INC(nW)
- END; .) .
- (* Assignment or procedure-statement call (4.1, module level).
- Bare `P;` is a syntax error; function-as-statement is 233. *)
- AssOrCall (. VAR dt, et: SymTab.TypeIndex;
- dk: INTEGER;
- qd, qe, qt, ql: QbeGen.QVal;
- qn: SymTab.Name;
- ct2, res0: SymTab.TypeIndex;
- q2, mg0: QbeGen.QVal;
- isR, conv, wconv: BOOLEAN;
- called, sfx: BOOLEAN; .)
- = Design<dt, dk, qd, qn, sfx>
- ( ":="
- Expr<et, qe> (. IF (dt # SymTab.InvalidType)
- AND (dk # SymTab.KindVar)
- AND (dk # SymTab.KindParam)
- AND (dk # SymTab.KindField) THEN
- SemError(210)
- ELSIF NOT SymTab.Assignable(et,
- dt) THEN
- SemError(210)
- ELSIF (dt # SymTab.InvalidType)
- AND (SymTab.ClassOf(dt) =
- SymTab.ClClass) THEN
- SemError(230) 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 ((dk = SymTab.KindVar)
- OR (dk = SymTab.KindParam)
- OR (dk = SymTab.KindField))
- AND (dt # SymTab.InvalidType)
- AND (et # SymTab.InvalidType)
- AND (SymTab.ClassOf(dt) #
- SymTab.ClClass) THEN
- IF sfx
- OR (dk = 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
- ELSIF 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.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; .)
- | ArgList<qn, dt, qd, FALSE, ct2, q2, called>
- | (* bare `P;`: proper parameterless
- procedure call; anything else
- here is 233 (was a bare syntax
- error before 4.2) *)
- (. IF (dk = SymTab.KindProc)
- AND NOT sfx THEN
- res0 := SymTab.ProcRes(qn);
- IF res0 #
- SymTab.InvalidType THEN
- SemError(233)
- ELSIF SymTab.ProcNPar(qn) #
- 0 THEN
- SemError(233)
- ELSE QbeGen.Mangled(qn,
- SymTab.ProcUid(qn), mg0);
- QbeGen.CallBegin(mg0,
- res0,
- SymTab.ProcDepthOf(qn),
- SymTab.IsExternal(qn));
- QbeGen.CallEnd(FALSE, q2)
- END
- ELSE SemError(233)
- END; .) ) .
- (* Actual-parameter list shared by statement and expression calls.
- want selects CallEnd's result handling; t/q carry the call
- value (statement calls discard). Arity/type failures are 233;
- evaluation code still emits so the .ssa stays assembleable. *)
- ArgList<pn: SymTab.Name; pt: SymTab.TypeIndex; callee: QbeGen.QVal;
- want: BOOLEAN;
- VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal;
- VAR called: BOOLEAN> (. VAR i: CARDINAL;
- res: SymTab.TypeIndex;
- mg: QbeGen.QVal;
- ok, ind: BOOLEAN; .)
- = "(" (. called := TRUE;
- ok := TRUE;
- ind := FALSE;
- IF SymTab.SymKind(pn) =
- SymTab.KindProc THEN
- res := SymTab.ProcRes(pn);
- QbeGen.Mangled(pn,
- SymTab.ProcUid(pn), mg);
- QbeGen.CallBegin(mg, res,
- SymTab.ProcDepthOf(pn),
- SymTab.IsExternal(pn))
- ELSIF (pt # SymTab.InvalidType)
- AND (SymTab.ClassOf(pt) = SymTab.ClProc) THEN
- ind := TRUE;
- res :=
- SymTab.ProcTypeRes(pt);
- QbeGen.CallBeginInd(callee,
- res, FALSE)
- ELSE SemError(233);
- ok := FALSE;
- res := SymTab.InvalidType
- END;
- i := 0; .)
- [ ActParam<pn, pt, ind, i> (. INC(i); .)
- { "," ActParam<pn, pt, ind, i> (. INC(i); .) } ]
- ")" (. IF ok THEN
- IF ind THEN
- IF i #
- SymTab.ProcTypeNPar(pt) THEN
- SemError(233); ok := FALSE
- END
- ELSIF i #
- SymTab.ProcNPar(pn) THEN
- SemError(233); ok := FALSE
- END
- END;
- IF NOT ok THEN
- t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- ELSIF want THEN
- IF res =
- SymTab.InvalidType THEN
- SemError(233);
- t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- ELSE t := res;
- QbeGen.CallEnd(TRUE, q)
- END
- ELSE
- IF res #
- SymTab.InvalidType THEN
- SemError(233)
- END;
- t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q);
- QbeGen.CallEnd(FALSE, q)
- END; .) .
- (* One actual: VAR formals take recorded designator addresses
- (233 otherwise); value formals take converted expressions. *)
- ActParam<pn: SymTab.Name; pt: SymTab.TypeIndex; ind: BOOLEAN;
- i: CARDINAL> (. VAR at, ft: SymTab.TypeIndex;
- qe, qa, qt: QbeGen.QVal;
- isV, conv: BOOLEAN; .)
- = Expr<at, qe> (. IF ind THEN
- ft :=
- SymTab.ProcTypeParamType(pt,
- i);
- isV :=
- SymTab.ProcTypeParamIsVar(pt,
- i)
- ELSE
- ft := SymTab.ParamType(pn, i);
- isV := SymTab.ParamIsVar(pn, i)
- END;
- IF (at = SymTab.InvalidType)
- OR (ft =
- SymTab.InvalidType) THEN
- 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 *)
- QbeGen.DeclCharStr(qe,
- qa);
- IF NOT QbeGen.CallArg(qa,
- "l") THEN
- SemError(233)
- END
- ELSIF NOT QbeGen.AddrOfVal(qe,
- qa) THEN
- SemError(233)
- ELSIF NOT SymTab.VarParamOk(at,
- ft) THEN
- SemError(233)
- ELSIF NOT QbeGen.CallArg(qa,
- "l") THEN
- SemError(233)
- 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 *)
- QbeGen.DeclCharStr(qe,
- qa);
- IF NOT QbeGen.CallArg(qa,
- "l") THEN
- SemError(233)
- END
- ELSIF NOT SymTab.Assignable(at,
- ft) THEN
- SemError(233)
- 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
- SemError(233)
- END
- ELSIF NOT QbeGen.CallArg(qe,
- QbeGen.ArgClass(ft)) THEN
- SemError(233)
- END
- END
- END; .) .
- IfStat (. VAR t: SymTab.TypeIndex;
- q, lThen, lElse, lEnd:
- QbeGen.QVal;
- hasElse: BOOLEAN; .)
- = "IF" (. hasElse := FALSE; .)
- Expr<t, q> (. IF NOT SymTab.BoolCheck(t) THEN
- SemError(214) END;
- QbeGen.NewLabel(lThen);
- QbeGen.NewLabel(lElse);
- QbeGen.NewLabel(lEnd);
- QbeGen.Jnz(q, lThen, lElse);
- QbeGen.EmitLabel(lThen); .)
- "THEN" [ StatSeq ] (. QbeGen.Jmp(lEnd); .)
- { "ELSIF" (. QbeGen.EmitLabel(lElse);
- QbeGen.NewLabel(lElse); .)
- Expr<t, q> (. IF NOT SymTab.BoolCheck(t) THEN
- SemError(214) END;
- QbeGen.NewLabel(lThen);
- QbeGen.Jnz(q, lThen, lElse);
- QbeGen.EmitLabel(lThen); .)
- "THEN" [ StatSeq ] (. QbeGen.Jmp(lEnd); .) }
- [ "ELSE" (. QbeGen.EmitLabel(lElse);
- hasElse := TRUE; .)
- [ StatSeq ] ]
- "END" (. IF hasElse THEN
- QbeGen.EmitLabel(lEnd)
- ELSE QbeGen.EmitLabel(lElse);
- QbeGen.EmitLabel(lEnd)
- END; .) .
- WhileStat (. VAR t: SymTab.TypeIndex;
- q, lTop, lBody, lEnd:
- QbeGen.QVal; .)
- = "WHILE" (. QbeGen.NewLabel(lTop);
- QbeGen.NewLabel(lBody);
- QbeGen.NewLabel(lEnd);
- QbeGen.EmitLabel(lTop); .)
- Expr<t, q> (. IF NOT SymTab.BoolCheck(t) THEN
- SemError(214) END;
- QbeGen.Jnz(q, lBody, lEnd);
- QbeGen.EmitLabel(lBody); .)
- "DO" [ StatSeq ] (. QbeGen.Jmp(lTop); .)
- "END" (. QbeGen.EmitLabel(lEnd); .) .
- RepeatStat (. VAR t: SymTab.TypeIndex;
- q, lTop, lEnd: QbeGen.QVal; .)
- = "REPEAT" (. QbeGen.NewLabel(lTop);
- QbeGen.NewLabel(lEnd);
- QbeGen.EmitLabel(lTop); .)
- [ StatSeq ]
- "UNTIL" Expr<t, q> (. IF NOT SymTab.BoolCheck(t) THEN
- SemError(214) END;
- QbeGen.Jnz(q, lEnd, lTop);
- QbeGen.EmitLabel(lEnd); .) .
- LoopStat (. VAR lTop, lEnd: QbeGen.QVal; .)
- = "LOOP" (. QbeGen.NewLabel(lTop);
- QbeGen.NewLabel(lEnd);
- QbeGen.PushLoop(lEnd);
- QbeGen.EmitLabel(lTop); .)
- [ StatSeq ]
- "END" (. QbeGen.Jmp(lTop);
- QbeGen.PopLoop;
- QbeGen.EmitLabel(lEnd); .) .
- (* FOR with static-sign BY (literal, non-zero; 220 otherwise).
- Runtime direction would need a compare-select; the literal
- sign picks cslew/csegew at "DO" time. *)
- ForStat (. VAR lv: SymTab.Name;
- tlo, thi, tby:
- SymTab.TypeIndex;
- qlo, qhi, qby, qt, qk, qb:
- QbeGen.QVal;
- lTop, lBody, lEnd:
- QbeGen.QVal;
- by: INTEGER;
- ok: BOOLEAN; .)
- = "FOR" (. by := 1; .)
- GetIdent<lv> (. ok := SymTab.Lookup(lv);
- IF NOT ok THEN
- SemError(201)
- ELSIF (SymTab.SymKind(lv) #
- SymTab.KindVar)
- AND (SymTab.SymKind(lv) #
- SymTab.KindParam) THEN
- SemError(220); ok := FALSE
- ELSIF NOT SymTab.IsIntFamily(
- SymTab.SymType(lv)) THEN
- SemError(220); ok := FALSE
- END; .)
- ":=" Expr<tlo, qlo> (. IF NOT SymTab.IsIntFamily(tlo) THEN
- SemError(220); ok := FALSE
- END; .)
- "TO" Expr<thi, qhi> (. IF NOT SymTab.IsIntFamily(thi) THEN
- SemError(220); ok := FALSE
- END; .)
- [ "BY" Expr<tby, qby> (. IF (tby #
- SymTab.InvalidType)
- AND NOT SymTab.IsIntFamily(tby) THEN
- SemError(220); ok := FALSE
- END;
- IF NOT SymTab.ConstInt(qby, by) THEN
- SemError(230); by := 1
- ELSIF by = 0 THEN
- SemError(220); by := 1
- END; .) ]
- "DO" (. IF ok THEN
- QbeGen.StoreVar(lv, qlo,
- FALSE) END;
- QbeGen.NewLabel(lTop);
- QbeGen.NewLabel(lBody);
- QbeGen.NewLabel(lEnd);
- QbeGen.EmitLabel(lTop);
- QbeGen.LoadVar(lv, FALSE, qt);
- QbeGen.NewTemp(qk);
- IF by > 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); .)
- [ StatSeq ]
- "END" (. IF ok THEN
- QbeGen.LoadVar(lv, FALSE,
- qt);
- QbeGen.IntStr(by, qb);
- QbeGen.NewTemp(qk);
- QbeGen.Op3("add", qk,
- qt, qb, FALSE);
- QbeGen.StoreVar(lv, qk,
- FALSE) END;
- QbeGen.Jmp(lTop);
- QbeGen.EmitLabel(lEnd); .) .
- CaseStat (. VAR tsel: SymTab.TypeIndex;
- qsel, lEnd: QbeGen.QVal; .)
- = "CASE" Expr<tsel, qsel> (. QbeGen.NewLabel(lEnd); .)
- "OF" CaseAlt<tsel, qsel, lEnd>
- { "|" CaseAlt<tsel, qsel, lEnd> }
- [ "ELSE" [ StatSeq ] ]
- "END" (. QbeGen.EmitLabel(lEnd); .) .
- (* Compare-chain lowering: each alternative ends its match-tests
- with "jmp lAfter", so the no-match fallthrough skips the body:
- "cmp; jnz(lBody,lF); lF: ... ; jmp lAfter; lBody: S; jmp lEnd;
- lAfter:". Falls into the next alternative, ELSE, or END. *)
- CaseAlt<tsel: SymTab.TypeIndex; qsel: QbeGen.QVal;
- lEnd: QbeGen.QVal> (. VAR lBody, lAfter: QbeGen.QVal; .)
- = (. QbeGen.NewLabel(lBody);
- QbeGen.NewLabel(lAfter); .)
- CaseLabel<tsel, qsel, lBody>
- { "," CaseLabel<tsel, qsel, lBody> }
- ":" (. QbeGen.Jmp(lAfter);
- QbeGen.EmitLabel(lBody); .)
- [ StatSeq ] (. QbeGen.Jmp(lEnd);
- QbeGen.EmitLabel(lAfter); .) .
- CaseLabel<tsel: SymTab.TypeIndex; qsel: QbeGen.QVal;
- lBody: QbeGen.QVal> (. VAR t2, t3: SymTab.TypeIndex;
- q2, q3, qc, qd, qe:
- QbeGen.QVal;
- lNext: QbeGen.QVal; .)
- = Expr<t2, q2> (. IF (t2 #
- SymTab.InvalidType)
- AND (tsel #
- SymTab.InvalidType)
- AND ((SymTab.ClassOf(t2) =
- SymTab.ClSet)
- OR (SymTab.ClassOf(tsel) =
- SymTab.ClSet)) THEN
- SemError(230)
- ELSIF (t2 #
- SymTab.InvalidType)
- AND (tsel #
- SymTab.InvalidType)
- AND NOT SymTab.EqCheck(t2,
- tsel) THEN
- SemError(213) END;
- IF NOT QbeGen.IsImm(q2) THEN
- SemError(230);
- QbeGen.CopyOp("0", q2)
- END;
- QbeGen.NewLabel(lNext);
- QbeGen.Cmp(SymTab.OpEq,
- qsel, q2, qc, FALSE);
- QbeGen.Jnz(qc, lBody, lNext);
- QbeGen.EmitLabel(lNext); .)
- [ ".." Expr<t3, q3> (. IF (t3 #
- SymTab.InvalidType)
- AND (tsel #
- SymTab.InvalidType)
- AND NOT SymTab.EqCheck(t3,
- tsel) THEN
- SemError(213) END;
- IF NOT QbeGen.IsImm(q3) THEN
- SemError(230);
- QbeGen.CopyOp("0", q3)
- 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); .) ] .
- ReturnStat (. VAR t: SymTab.TypeIndex;
- q, qt: QbeGen.QVal;
- res: SymTab.TypeIndex;
- hadE, conv: BOOLEAN; .)
- = "RETURN" (. hadE := FALSE; .)
- [ Expr<t, q> (. hadE := TRUE; .) ]
- (. conv := FALSE;
- IF NOT SymTab.InProc() THEN
- SemError(232)
- ELSE res := SymTab.CurRes();
- IF NOT hadE THEN
- IF res #
- SymTab.InvalidType THEN
- SemError(232)
- ELSE QbeGen.EmitRet(q,
- FALSE)
- END
- ELSIF (res =
- SymTab.InvalidType)
- OR (t #
- SymTab.InvalidType)
- AND NOT SymTab.Assignable(t,
- res) THEN
- SemError(232)
- ELSE
- conv := (SymTab.ClassOf(
- res) = 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; .) .
- HaltStat (. VAR t: SymTab.TypeIndex;
- q: QbeGen.QVal; .)
- = "HALT" [ "(" Expr<t, q> ")" ] (. QbeGen.HaltQ; .) .
- (* Designator: scalar loads, array addresses, and index suffixes.
- Each index descends one level (bounds-checked, trap on breach);
- nested levels reload the inner descriptor address. q ends as the
- value (scalars), the descriptor address (plain arrays), or the
- element address (indexed); sfx marks the indexed form. *)
- Design<VAR t: SymTab.TypeIndex; VAR k: INTEGER;
- VAR q: QbeGen.QVal; VAR qn: SymTab.Name; VAR sfx: BOOLEAN>
- (. VAR n, fn, mal: SymTab.Name;
- cls: INTEGER;
- curT, it, eT, bt:
- SymTab.TypeIndex;
- iq, ql, qlo, qhi, qe:
- QbeGen.QVal;
- lo, hi: INTEGER;
- fo: INTEGER;
- isOpen: BOOLEAN;
- qb, cv: QbeGen.QVal; .)
- = GetIdent<n> (. QbeGen.CopyOp(n, qn);
- sfx := FALSE;
- IF NOT SymTab.Lookup(n) THEN
- SemError(201);
- t := SymTab.InvalidType;
- k := -1;
- QbeGen.CopyOp("0", q)
- ELSE
- t := SymTab.SymType(n);
- k := SymTab.SymKind(n);
- IF k = SymTab.KindConst THEN
- IF SymTab.Equal(n,
- "TRUE") THEN
- t := SymTab.BoolType();
- QbeGen.CopyOp("1", q)
- ELSIF SymTab.Equal(n,
- "FALSE") THEN
- t := SymTab.BoolType();
- QbeGen.CopyOp("0", q)
- ELSIF SymTab.Equal(n,
- "NIL") THEN
- QbeGen.CopyOp("0", q)
- ELSE
- cls :=
- SymTab.ClassOf(t);
- IF (t #
- SymTab.InvalidType)
- AND ((cls = SymTab.ClInt)
- OR (cls
- = SymTab.ClChar)
- OR (cls
- = SymTab.ClEnum)
- OR (cls
- = SymTab.ClReal)
- OR (cls
- = SymTab.ClNil)) THEN
- IF cls = SymTab.ClNil THEN
- QbeGen.CopyOp("0", q)
- ELSIF ((cls
- = SymTab.ClInt)
- OR (cls
- = SymTab.ClChar)
- OR (cls
- = SymTab.ClEnum))
- AND SymTab.GetSymVal(n, cv)
- AND QbeGen.IsImm(cv) THEN
- QbeGen.CopyOp(cv, q)
- ELSE
- QbeGen.LoadVar(n,
- cls = SymTab.ClReal,
- q)
- END
- ELSE
- IF t #
- SymTab.InvalidType THEN
- SemError(230)
- END;
- QbeGen.CopyOp("0", q)
- END
- END
- ELSIF (k = SymTab.KindVar)
- OR (k = SymTab.KindParam) THEN
- cls :=
- SymTab.ClassOf(t);
- IF (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(n,
- cls = SymTab.ClReal, q)
- ELSIF (cls = SymTab.ClPtr)
- OR (cls = SymTab.ClProc) THEN
- QbeGen.LoadPtr(n, q)
- ELSIF cls = SymTab.ClLong THEN
- QbeGen.LoadLong(n, q)
- ELSIF (cls
- = SymTab.ClArray)
- OR (cls
- = SymTab.ClSet)
- OR (cls
- = SymTab.ClRecord)
- OR (cls
- = SymTab.ClUStr)
- OR (cls
- = SymTab.ClClass) THEN
- QbeGen.AddrOf(n, q)
- ELSE SemError(230);
- QbeGen.CopyOp("0", q)
- END
- ELSE QbeGen.CopyOp("0", q);
- IF k = SymTab.KindImport THEN
- SemError(230)
- ELSIF k =
- SymTab.KindProc THEN
- (* bare procedure name:
- a following ArgList
- makes it a call;
- otherwise Fact
- reports 230 *)
- ELSE
- IF k = SymTab.KindField THEN
- IF QbeGen.TopWith(qb) THEN
- fo :=
- SymTab.FieldOffset(
- SymTab.FieldOwner(n),
- n);
- QbeGen.FieldAddr(qb,
- fo, q);
- sfx := TRUE
- ELSE SemError(230);
- QbeGen.CopyOp("0", q)
- END
- END
- END
- END
- END; .)
- { "[" Expr<it, iq>
- (. IF t = SymTab.InvalidType THEN
- ELSIF SymTab.ClassOf(t) #
- SymTab.ClArray THEN
- SemError(217);
- t := SymTab.InvalidType
- ELSIF NOT SymTab.IsIntFamily(it)
- AND (SymTab.ClassOf(it) #
- SymTab.ClChar) THEN
- SemError(218);
- t := SymTab.InvalidType
- 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; .)
- { "," Expr<it, iq>
- (. IF t = SymTab.InvalidType THEN
- ELSIF SymTab.ClassOf(t) #
- SymTab.ClArray THEN
- SemError(217);
- t := SymTab.InvalidType
- ELSIF NOT SymTab.IsIntFamily(it)
- AND (SymTab.ClassOf(it) #
- SymTab.ClChar) THEN
- SemError(218);
- t := SymTab.InvalidType
- 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; .) }
- "]"
- | "." GetIdent<fn>
- (. IF k = SymTab.KindModule THEN
- (* qualified L.x: materialize
- the export, then load it *)
- IF NOT SymTab.MaterializeAlias(n,
- fn, mal) THEN
- SemError(201);
- t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- ELSE
- QbeGen.CopyOp(mal, qn);
- t := SymTab.SymType(mal);
- k := SymTab.SymKind(mal);
- sfx := FALSE;
- IF k = SymTab.KindProc THEN
- (* call: ArgList supplies
- the value *)
- QbeGen.CopyOp("0", q)
- ELSIF NOT QbeGen.LoadDesignator(
- mal, t, k, q) THEN
- SemError(230);
- QbeGen.CopyOp("0", q)
- END
- END
- ELSIF t = SymTab.InvalidType THEN
- ELSIF (SymTab.ClassOf(t) #
- SymTab.ClRecord)
- AND (SymTab.ClassOf(t) #
- SymTab.ClClass) THEN
- SemError(215);
- t := SymTab.InvalidType
- ELSIF NOT SymTab.FieldExists(t,
- fn) THEN
- SemError(216);
- t := SymTab.InvalidType
- ELSE
- fo := SymTab.FieldOffset(t,
- fn);
- t := SymTab.FieldType(t, fn);
- QbeGen.FieldAddr(q, fo, qe);
- (* array fields are inline:
- the field address is the
- descriptor, like records *)
- QbeGen.CopyOp(qe, q);
- sfx := TRUE
- END; .)
- | "^"
- (. IF t = SymTab.InvalidType THEN
- ELSIF SymTab.ClassOf(t) #
- SymTab.ClPtr THEN
- SemError(219);
- t := SymTab.InvalidType
- ELSE
- bt := SymTab.PtrBase(t);
- IF bt = SymTab.InvalidType THEN
- ELSE
- IF sfx THEN
- QbeGen.ElemLoad(q, t,
- qb);
- QbeGen.CopyOp(qb, q)
- END;
- t := bt;
- (* q holds the pointee
- address: Fact loads
- scalars/pointers and uses
- the address for
- aggregates; the VAR-actual
- note is q itself. *)
- sfx := TRUE
- END
- END; .) } .
- Expr<VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal>
- (. VAR t2: SymTab.TypeIndex;
- op: INTEGER;
- q2, qt, wl: QbeGen.QVal;
- isR: BOOLEAN; .)
- = SimExpr<t, q>
- [ Rel<op> SimExpr<t2, q2>
- (. IF op = SymTab.OpIn THEN
- IF SymTab.InCheck(t, t2) THEN
- IF (t = SymTab.InvalidType)
- OR (t2 = SymTab.InvalidType) THEN
- t := SymTab.BoolType(); QbeGen.CopyOp("0", q)
- ELSE
- QbeGen.InSet(q, q2, SymTab.SetBaseLo(t2),
- SymTab.SetCount(t2), qt);
- t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
- END
- ELSE SemError(222); t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- END
- ELSIF SymTab.RelCheck(t, t2, op) THEN
- IF (t = SymTab.InvalidType)
- OR (t2 = SymTab.InvalidType) THEN
- t := SymTab.BoolType(); QbeGen.CopyOp("0", q)
- ELSIF (SymTab.ClassOf(t) = SymTab.ClPtr)
- OR (SymTab.ClassOf(t2) = SymTab.ClPtr) THEN
- IF (op # SymTab.OpEq) AND (op # SymTab.OpNeq1)
- AND (op # SymTab.OpNeq2) THEN
- SemError(213); t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- ELSE
- QbeGen.CmpL(op, q, q2, qt);
- t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
- END
- ELSIF (SymTab.ClassOf(t) = SymTab.ClSet)
- OR (SymTab.ClassOf(t2) = SymTab.ClSet) THEN
- QbeGen.CmpSet(op, q, q2,
- SymTab.SetWords(t), SymTab.SetWords(t2), qt);
- t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
- ELSIF SymTab.StrCompat(t, t2) THEN
- QbeGen.StrEq(op, 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, wl); QbeGen.CopyOp(wl, q)
- END;
- IF SymTab.IsIntFamily(t2) THEN
- QbeGen.WidenLong(q2, wl); QbeGen.CopyOp(wl, q2)
- END;
- QbeGen.CmpLong(op, q, q2, qt);
- t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
- ELSE
- isR := SymTab.ClassOf(t) = SymTab.ClReal;
- t := SymTab.BoolType();
- QbeGen.Cmp(op, q, q2, qt, isR);
- QbeGen.CopyOp(qt, q)
- END
- ELSE SemError(213); t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- END; .) ] .
- Rel<VAR op: INTEGER>
- = "=" (. op := SymTab.OpEq; .)
- | "#" (. op := SymTab.OpNeq1; .)
- | "<" (. op := SymTab.OpLt; .)
- | "<=" (. op := SymTab.OpLe; .)
- | ">" (. op := SymTab.OpGt; .)
- | ">=" (. op := SymTab.OpGe; .)
- | "IN" (. op := SymTab.OpIn; .) .
- SimExpr<VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal>
- (. VAR t2, res2, lt, rt:
- SymTab.TypeIndex;
- op: INTEGER;
- q2, qt, wq, qf:
- QbeGen.QVal;
- neg, isR, isL, folded:
- BOOLEAN;
- lw, rw, mw: CARDINAL;
- lTrue, lNext, lDone, qr, qs:
- QbeGen.QVal; .)
- = (. neg := FALSE; .)
- [ "+" | "-" (. neg := TRUE; .) ]
- Term<t, q> (. IF neg 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
- END; .)
- { AddOp<op> (. IF op = SymTab.OpOr THEN
- QbeGen.DelayBegin END; .)
- Term<t2, q2> (. IF op = SymTab.OpOr THEN
- QbeGen.DelayEnd END; .)
- (. IF op = SymTab.OpOr THEN
- (* short-circuit: if q is true the RHS is skipped *)
- IF SymTab.BoolCheck(t) AND SymTab.BoolCheck(t2) THEN
- t := SymTab.BoolType()
- ELSE SemError(212); t := SymTab.InvalidType END;
- IF t # SymTab.InvalidType THEN
- 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)
- ELSE QbeGen.DelayFlush; QbeGen.CopyOp("0", q)
- END
- ELSIF (op = SymTab.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
- (* string concatenation; a CHAR operand becomes a
- 1-character string literal *)
- 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;
- t := SymTab.NewStr();
- QbeGen.CopyOp(qt, q)
- ELSIF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType)
- AND (SymTab.ClassOf(t) = SymTab.ClSet)
- AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN
- lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2);
- mw := lw;
- IF rw > mw THEN mw := rw END;
- IF op = SymTab.OpAdd THEN
- QbeGen.SetBinOp(0, q, q2, lw, rw, qt)
- ELSE
- QbeGen.SetBinOp(2, q, q2, lw, rw, qt)
- END;
- t := SymTab.NewSet(
- SymTab.NewSubR(0,
- VAL(INTEGER, mw) * 32 - 1));
- QbeGen.CopyOp(qt, q)
- ELSE
- IF SymTab.ArithCheck(t, t2, FALSE, res2) THEN
- lt := t; rt := t2; t := res2
- ELSE SemError(211); t := SymTab.InvalidType END;
- IF t # SymTab.InvalidType THEN
- isL := SymTab.IsLongFamily(t);
- isR := SymTab.ClassOf(t) = SymTab.ClReal;
- folded := FALSE;
- IF (NOT isL) AND (NOT isR)
- AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN
- IF op = SymTab.OpAdd THEN
- folded := QbeGen.Fold2(0, q, q2, qf)
- ELSE
- folded := QbeGen.Fold2(1, q, q2, qf)
- END
- END;
- IF folded THEN QbeGen.CopyOp(qf, q)
- ELSE
- IF isL THEN
- IF SymTab.IsIntFamily(lt) THEN
- QbeGen.WidenLong(q, wq); QbeGen.CopyOp(wq, q)
- END;
- IF SymTab.IsIntFamily(rt) THEN
- QbeGen.WidenLong(q2, wq); QbeGen.CopyOp(wq, q2)
- END;
- QbeGen.NewTemp(qt);
- IF op = SymTab.OpAdd THEN
- QbeGen.Op3L("add", qt, q, q2)
- ELSE
- QbeGen.Op3L("sub", qt, q, q2)
- END
- ELSE
- QbeGen.NewTemp(qt);
- IF op = SymTab.OpAdd THEN
- QbeGen.Op3("add", qt, q, q2, isR)
- ELSE
- QbeGen.Op3("sub", qt, q, q2, isR)
- END
- END;
- QbeGen.CopyOp(qt, q)
- END
- ELSE QbeGen.CopyOp("0", q)
- END
- END; .) } .
- AddOp<VAR op: INTEGER>
- = "+" (. op := SymTab.OpAdd; .)
- | "-" (. op := SymTab.OpSub; .)
- | "OR" (. op := SymTab.OpOr; .) .
- Term<VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal>
- (. VAR t2, res2, lt, rt:
- SymTab.TypeIndex;
- op: INTEGER;
- q2, qt, wq, qf:
- QbeGen.QVal;
- isR, isL, folded: BOOLEAN;
- lw, rw, mw: CARDINAL;
- lNext, lFalse, lDone, qr, qs:
- QbeGen.QVal; .)
- = Fact<t, q> { MulOp<op> (. IF op = SymTab.OpAnd THEN
- QbeGen.DelayBegin END; .)
- Fact<t2, q2> (. IF op = SymTab.OpAnd THEN
- QbeGen.DelayEnd END; .)
- (. IF op = SymTab.OpAnd THEN
- (* short-circuit: if q is false the RHS is skipped *)
- IF SymTab.BoolCheck(t) AND SymTab.BoolCheck(t2) THEN
- t := SymTab.BoolType()
- ELSE SemError(212); t := SymTab.InvalidType END;
- IF t # SymTab.InvalidType THEN
- 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)
- ELSE QbeGen.DelayFlush; QbeGen.CopyOp("0", q)
- END
- ELSIF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType)
- AND (SymTab.ClassOf(t) = SymTab.ClSet)
- AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN
- lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2);
- mw := lw;
- IF rw > mw THEN mw := rw END;
- IF op = SymTab.OpTimes THEN
- QbeGen.SetBinOp(1, q, q2, lw, rw, qt)
- ELSE
- QbeGen.SetBinOp(3, q, q2, lw, rw, qt)
- END;
- t := SymTab.NewSet(
- SymTab.NewSubR(0,
- VAL(INTEGER, mw) * 32 - 1));
- QbeGen.CopyOp(qt, q)
- ELSE
- IF SymTab.ArithCheck(t, t2,
- (op = SymTab.OpDiv) OR (op = SymTab.OpMod),
- res2) THEN
- lt := t; rt := t2; t := res2
- ELSE SemError(211); t := SymTab.InvalidType END;
- IF t # SymTab.InvalidType THEN
- isL := SymTab.IsLongFamily(t);
- isR := SymTab.ClassOf(t) = SymTab.ClReal;
- folded := FALSE;
- IF (NOT isL) AND (NOT isR)
- AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN
- IF op = SymTab.OpTimes THEN
- folded := QbeGen.Fold2(2, q, q2, qf)
- ELSIF op = SymTab.OpDiv THEN
- folded := QbeGen.Fold2(3, q, q2, qf)
- ELSIF op = SymTab.OpMod THEN
- folded := QbeGen.Fold2(4, q, q2, qf)
- END
- END;
- IF folded THEN QbeGen.CopyOp(qf, q)
- ELSE
- IF isL THEN
- IF SymTab.IsIntFamily(lt) THEN
- QbeGen.WidenLong(q, wq); QbeGen.CopyOp(wq, q)
- END;
- IF SymTab.IsIntFamily(rt) THEN
- QbeGen.WidenLong(q2, wq); QbeGen.CopyOp(wq, q2)
- END;
- QbeGen.NewTemp(qt);
- IF op = SymTab.OpTimes THEN
- QbeGen.Op3L("mul", qt, q, q2)
- ELSIF (op = SymTab.OpDiv)
- OR (op = SymTab.OpSlash) THEN
- QbeGen.Op3L("div", qt, q, q2)
- ELSE
- QbeGen.Op3L("rem", qt, q, q2)
- END
- ELSE
- QbeGen.NewTemp(qt);
- IF op = SymTab.OpTimes THEN
- QbeGen.Op3("mul", qt, q, q2, isR)
- ELSIF (op = SymTab.OpDiv)
- OR (op = SymTab.OpSlash) THEN
- QbeGen.Op3("div", qt, q, q2, isR)
- ELSE
- QbeGen.Op3("rem", qt, q, q2, isR)
- END
- END;
- QbeGen.CopyOp(qt, q)
- END
- ELSE QbeGen.CopyOp("0", q)
- END
- END; .) } .
- MulOp<VAR op: INTEGER>
- = "*" (. op := SymTab.OpTimes; .)
- | "/" (. op := SymTab.OpSlash; .)
- | "DIV" (. op := SymTab.OpDiv; .)
- | "MOD" (. op := SymTab.OpMod; .)
- | ( "AND" | "&" ) (. op := SymTab.OpAnd; .) .
- Fact<VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal>
- (. VAR s: ARRAY [0 .. 255] OF CHAR;
- et, dt, t2, st, ct2:
- SymTab.TypeIndex;
- dk: INTEGER;
- qd, q2, sq, qa, qm0, qr:
- QbeGen.QVal;
- qn, vn: SymTab.Name;
- vt: SymTab.TypeIndex;
- c1, c2: INTEGER;
- called, isHigh, sfx, isCh,
- isU, uok, isStr: BOOLEAN;
- ucp: INTEGER; .)
- = integer (. LexString(s);
- QbeGen.NormInt(s, q);
- t := SymTab.IntType(); .)
- | charConst (. LexString(s);
- QbeGen.NormLit(s, q, isCh);
- t := SymTab.CharType(); .)
- | real (. LexString(s);
- QbeGen.NormReal(s, q);
- t := SymTab.RealType(); .)
- | string (. LexString(s);
- IF SymTab.StrLen(s) = 3 THEN
- t := SymTab.CharType();
- QbeGen.IntStr(
- QbeGen.CharVal(s), q)
- ELSE t := SymTab.NewStr();
- QbeGen.DeclStr(s, q);
- (* a literal's value IS its
- static descriptor address *)
- QbeGen.NoteAddr(q, q)
- END; .)
- | ustring (. LexString(s);
- QbeGen.DeclUStr(s, q, isU, ucp,
- uok);
- IF NOT uok THEN
- SemError(234);
- t := SymTab.InvalidType
- ELSIF isU THEN
- t := SymTab.UCharType();
- QbeGen.IntStr(ucp, q)
- ELSE
- t := SymTab.NewUStr();
- QbeGen.NoteAddr(q, q)
- END; .)
- | Design<dt, dk, qd, qn, sfx> (. called := FALSE;
- t := dt;
- IF sfx THEN
- IF dt =
- SymTab.InvalidType THEN
- QbeGen.CopyOp("0", q)
- ELSIF (SymTab.ClassOf(dt) =
- SymTab.ClRecord)
- OR (SymTab.ClassOf(dt) =
- SymTab.ClSet)
- OR (SymTab.ClassOf(dt) =
- SymTab.ClArray)
- OR (SymTab.ClassOf(dt) =
- SymTab.ClClass) THEN
- QbeGen.CopyOp(qd, q)
- ELSE QbeGen.ElemLoad(qd, dt,
- q)
- END
- ELSE QbeGen.CopyOp(qd, q)
- END;
- IF (dk = SymTab.KindVar)
- OR (dk = SymTab.KindParam)
- OR (dk =
- SymTab.KindField) THEN
- IF sfx THEN
- QbeGen.NoteAddr(q, qd)
- ELSE
- QbeGen.AddrOf(qn, qa);
- QbeGen.NoteAddr(q, qa)
- END
- ELSIF sfx
- AND (dt #
- SymTab.InvalidType)
- AND ((SymTab.ClassOf(dt) =
- SymTab.ClArray)
- OR (SymTab.ClassOf(dt) =
- SymTab.ClSet)
- OR (SymTab.ClassOf(dt) =
- SymTab.ClRecord)) THEN
- QbeGen.NoteAddr(qd, qd)
- END; .)
- [ TypedSetLit<dt, q> (. t := dt; .) ]
- [ ArgList<qn, dt, qd, TRUE, ct2, q2, called>
- (. t := ct2;
- QbeGen.CopyOp(q2, q); .) ]
- (. IF NOT called
- AND (dk = SymTab.KindProc) THEN
- (* bare zero-arg function
- call (parentheses may be
- omitted); a proper or
- parameterised proc here
- is 230 *)
- IF (SymTab.ProcNPar(qn) = 0)
- AND (SymTab.ProcRes(qn) #
- SymTab.InvalidType) THEN
- QbeGen.Mangled(qn,
- SymTab.ProcUid(qn), qm0);
- QbeGen.CallBegin(qm0,
- SymTab.ProcRes(qn),
- SymTab.ProcDepthOf(qn),
- SymTab.IsExternal(qn));
- QbeGen.CallEnd(TRUE, q);
- t := SymTab.ProcRes(qn)
- ELSE
- (* procedure used as a
- value (assign to a
- procedure variable):
- its code address *)
- t := SymTab.ProcTypeOf(qn);
- QbeGen.Mangled(qn,
- SymTab.ProcUid(qn), qm0);
- QbeGen.ProcAddr(qm0, q)
- END
- END; .)
- | ( "HIGH" (. isHigh := TRUE; .)
- | ( "LEN" | "LENGTH" ) (. isHigh := FALSE; .) )
- "(" ( Design<dt, dk, qd, qn, sfx> (. isStr := FALSE; .)
- | string (. LexString(s);
- isStr := TRUE;
- IF SymTab.StrLen(s) = 3 THEN
- dt := SymTab.CharType();
- QbeGen.IntStr(QbeGen.CharVal(s),
- qd)
- ELSE
- dt := SymTab.NewStr();
- QbeGen.DeclStr(s, qd);
- QbeGen.NoteAddr(qd, qd)
- END;
- dk := -1;
- qn[0] := CHR(0); .) )
- ")"
- (. IF isStr THEN
- (* fold: content length at
- compile time *)
- IF SymTab.StrLen(s) = 3 THEN
- c1 := 1
- ELSE
- c1 :=
- SymTab.StrLen(s) - 2
- END;
- IF isHigh THEN
- DEC(c1)
- END;
- QbeGen.IntStr(c1, qr);
- t := SymTab.IntType();
- QbeGen.CopyOp(qr, q)
- ELSIF dt = SymTab.InvalidType THEN
- t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- ELSIF SymTab.ClassOf(dt) #
- SymTab.ClArray THEN
- SemError(217);
- t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- ELSE
- IF isHigh THEN
- IF SymTab.IsOpenArray(dt) THEN
- QbeGen.OpenHi(qd, qr)
- ELSE
- QbeGen.IntStr(
- SymTab.ArrayHi(dt), qr)
- END
- ELSE
- IF SymTab.IsOpenArray(dt) THEN
- QbeGen.LoadCount(qd, qr)
- ELSE
- QbeGen.IntStr(VAL(
- INTEGER,
- SymTab.ArrayLen(dt)),
- qr)
- END
- END;
- t := SymTab.IntType();
- QbeGen.CopyOp(qr, q)
- END; .)
- | ( "SIZE" | "TSIZE" ) "(" Design<dt, dk, qd, qn, sfx> ")"
- (. IF dt = SymTab.InvalidType THEN
- t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- ELSE
- QbeGen.IntStr(VAL(INTEGER,
- SymTab.ObjectSize(dt)), q);
- t := SymTab.IntType()
- END; .)
- | "ADR" "(" Design<dt, dk, qd, qn, sfx> ")"
- (. IF dt = SymTab.InvalidType THEN
- t := SymTab.InvalidType;
- QbeGen.CopyOp("0", q)
- ELSE
- IF sfx THEN
- QbeGen.CopyOp(qd, q)
- ELSIF (dk = SymTab.KindVar)
- OR (dk = SymTab.KindParam) THEN
- QbeGen.AddrOf(qn, q)
- ELSE SemError(230);
- QbeGen.CopyOp("0", q)
- END;
- t := SymTab.AddrType()
- END; .)
- | "CHR" "(" Expr<et, q> ")"
- (. IF (et # SymTab.InvalidType)
- AND NOT SymTab.IsIntFamily(et) THEN
- SemError(211) END;
- t := SymTab.CharType(); .)
- | ( "ORD" | "ORDL" ) "(" Expr<et, q> ")"
- (. IF et # SymTab.InvalidType THEN
- IF (SymTab.ClassOf(et) #
- SymTab.ClChar)
- AND (SymTab.ClassOf(et) #
- SymTab.ClBool)
- AND (SymTab.ClassOf(et) #
- SymTab.ClEnum)
- AND NOT SymTab.IsIntFamily(et) THEN
- SemError(211) END
- END;
- t := SymTab.IntType(); .)
- | "CAP" "(" Expr<et, q> ")"
- (. QbeGen.CapQ(q, qa);
- QbeGen.CopyOp(qa, q);
- t := SymTab.CharType(); .)
- | "UCHR" "(" Expr<et, q> ")"
- (. (* UCHR: the UCHAR constructor.
- CHAR -> UCHAR (identity);
- INTEGER familly -> UCHAR
- (codepoint value). *)
- IF (et # SymTab.InvalidType)
- AND (SymTab.ClassOf(et) # SymTab.ClChar)
- AND NOT SymTab.IsIntFamily(et) THEN
- SemError(211) END;
- t := SymTab.UCharType(); .)
- | "CHR8" "(" Expr<et, q> ")"
- (. IF (et # SymTab.InvalidType)
- AND (SymTab.ClassOf(et) # SymTab.ClUChar) THEN
- SemError(211) END;
- QbeGen.WidenLong(q, qa);
- QbeGen.CheckRange(qa, "0", "255");
- t := SymTab.CharType(); .)
- | "UORD" "(" Expr<et, q> ")"
- (. (* UORD(u): the codepoint as a
- 32-bit ordinal (INTEGER),
- cf. ORD for CHAR. *)
- IF (et # SymTab.InvalidType)
- AND (SymTab.ClassOf(et) # SymTab.ClUChar) THEN
- SemError(211) END;
- t := SymTab.IntType(); .)
- | "ABS" "(" Expr<et, q> ")"
- (. IF (et # SymTab.InvalidType)
- AND NOT SymTab.IsIntFamily(et)
- AND (SymTab.ClassOf(et) #
- SymTab.ClReal) THEN
- SemError(211)
- ELSE QbeGen.AbsQ(q, qa,
- SymTab.ClassOf(et) =
- SymTab.ClReal);
- QbeGen.CopyOp(qa, q)
- END;
- t := et; .)
- | "VAL" "(" GetIdent<vn> "," Expr<et, q> ")"
- (. IF NOT SymTab.Lookup(vn) THEN
- SemError(201);
- t := SymTab.InvalidType
- ELSE vt := SymTab.SymType(vn);
- IF vt = SymTab.InvalidType THEN
- t := SymTab.InvalidType
- ELSIF et =
- SymTab.InvalidType THEN
- t := vt
- ELSE
- c1 := SymTab.ClassOf(et);
- c2 := SymTab.ClassOf(vt);
- IF ((c1 = SymTab.ClInt)
- OR (c1 =
- SymTab.ClChar)
- OR (c1 =
- SymTab.ClBool)
- OR (c1 =
- SymTab.ClEnum))
- AND ((c2 = SymTab.ClInt)
- OR (c2 =
- SymTab.ClChar)
- OR (c2 =
- SymTab.ClBool)
- OR (c2 =
- SymTab.ClEnum)) THEN
- t := vt
- ELSIF (c1 = SymTab.ClPtr)
- AND (c2 = SymTab.ClPtr) THEN
- t := vt
- ELSIF (c1 = SymTab.ClReal)
- AND (c2 = SymTab.ClReal) THEN
- t := vt
- ELSE SemError(230);
- t := SymTab.InvalidType
- END
- END
- END; .)
- | "(" Expr<et, q> ")" (. t := et; .)
- | SetLit<st, sq> (. t := st;
- QbeGen.CopyOp(sq, q); .)
- | ( "NOT" | "~" ) Fact<t2, q2> (. IF SymTab.BoolCheck(t2) THEN
- t := SymTab.BoolType()
- ELSE SemError(212);
- t := SymTab.InvalidType END;
- IF t # SymTab.InvalidType THEN
- QbeGen.NotQ(q2, q)
- ELSE QbeGen.CopyOp("0", q)
- END; .) .
- (* Set literals are SET OF [0..255] (8 words); elements validated
- 0..255 statically when foldable (222 otherwise), runtime trap
- for computed elements. Ranges always lower via SetRange. *)
- SetLit<VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal>
- = "{" (. t := SymTab.NewSet(
- SymTab.NewSubR(0, 255));
- QbeGen.NewSetTemp(8, q);
- QbeGen.SetZero(q, 8); .)
- [ SetElem<t, q> { "," SetElem<t, q> } ]
- "}" .
- (* Typed set constructor: TypeName{ elems } — e.g. BITSET{0},
- BITSET{}. The declared type (not SET OF [0..255]) sets the
- width and element span. *)
- TypedSetLit<vt: SymTab.TypeIndex; VAR q: QbeGen.QVal>
- (. VAR nw: CARDINAL; .)
- = "{" (. IF SymTab.ClassOf(vt) #
- SymTab.ClSet THEN
- SemError(230); nw := 8
- ELSE nw := SymTab.SetWords(vt);
- IF nw = 0 THEN nw := 8 END
- END;
- QbeGen.NewSetTemp(nw, q);
- QbeGen.SetZero(q, nw); .)
- [ SetElem<vt, q> { "," SetElem<vt, q> } ]
- "}" .
- SetElem<st: SymTab.TypeIndex; sq: QbeGen.QVal> (. VAR et, et2: SymTab.TypeIndex;
- qe, q2: QbeGen.QVal;
- v, v2: INTEGER;
- lo: INTEGER;
- span: CARDINAL;
- cl, cl2: INTEGER;
- hasR: BOOLEAN; .)
- = (. hasR := FALSE; .)
- Expr<et, qe>
- [ ".." Expr<et2, q2> (. hasR := TRUE; .) ]
- (. lo := SymTab.SetBaseLo(st);
- span := SymTab.SetCount(st);
- IF (et = SymTab.InvalidType)
- OR (hasR AND (et2 =
- SymTab.InvalidType)) THEN
- ELSE cl :=
- SymTab.ClassOf(et);
- IF hasR THEN
- cl2 :=
- SymTab.ClassOf(et2)
- ELSE cl2 := SymTab.ClInt
- END;
- IF ((cl # SymTab.ClInt)
- AND (cl # SymTab.ClChar)
- AND (cl # SymTab.ClBool))
- OR (hasR AND
- ((cl2
- # SymTab.ClInt)
- AND (cl2
- # SymTab.ClChar)
- AND (cl2
- # SymTab.ClBool))) THEN
- SemError(222)
- ELSIF hasR
- AND SymTab.ConstInt(qe, v)
- AND SymTab.ConstInt(q2,
- v2)
- AND ((v < lo)
- OR (v2 < lo)
- OR (v >= lo +
- VAL(INTEGER, span))
- OR (v2 >= lo +
- VAL(INTEGER, span))
- OR (v > v2)) THEN
- SemError(222)
- ELSIF hasR THEN
- QbeGen.SetRange(sq, qe, q2,
- lo, span)
- ELSIF SymTab.ConstInt(qe,
- v)
- AND ((v < lo)
- OR (v >= lo +
- VAL(INTEGER,
- span))) THEN
- SemError(222)
- ELSE QbeGen.SetBit(sq, qe,
- lo, span)
- END
- END; .) .
- GetIdent<VAR n: SymTab.Name>
- = ident (. LexName(n); .) .
- END M2.
|