home *** CD-ROM | disk | FTP | other *** search
- ⓪ IMPLEMENTATION MODULE MM2Comp2;⓪ (*$Z+,J+,R-,F-*)⓪ ⓪ (*$M- !!!! >>> Am Ende $M- und Safety auf FALSE! <<< *)⓪ ⓪ (*$S- Stackcheck erst bei komplexeren Routinen *)⓪ ⓪ (*⓪ IMPORT TOSDebug;⓪ IMPORT TOSIO, InOut;⓪ (*$E+*)⓪ *)⓪ ⓪ (* REPORT⓪#------⓪ ⓪ ~~~ möglichst oft WITH verwenden, damit neuer Comp mehr rausholt⓪ ⓪ ~ebenso, wie loadReg auch storeReg einführen - das könnte oft statt 'moveTo'⓪"benutzt werden⓪ ⓪ Beginn: 23.11.89⓪ ⓪ 26.1.90: Beginn Real-Codierung; Subversion: 'ß/2'⓪ 27.1.90: Fehler behoben, daß z.B. bei MULU die source ein Adr-Reg sein konnte.⓪)WITH wird in diesem Modul codiert⓪)FOR mit konst. lower/upper bound wird optimiert codiert⓪)Procs ohne F-Ergebnis belassen Parms auf A3-Stack⓪ 31.1.90: Reals fertig (bisher nur LONGREAL bei softReal, REAL bei externalFPU⓪*noch nicht getestet)⓪)BY in Array-Constr. nun auch in ConstExpr anwendbar⓪)Stack wird bei Value-Constr. und Parm-Übergabe geprüft ('stackCheck')⓪)genANDI benutzte immer D0, statt das verlangte Reg. -> MOD-Op funktio-⓪+nierte teilw. nicht.⓪)Bei "IMPORT SYSTEM" stürzt Compiler nicht mehr ab.⓪ 11.2.90: Word-Mul mit INTEGER macht richtigen Overflow-Check⓪ 08.5.90: CASE löscht nicht D0, wenn Wert vorher schon in D0 ist⓪ 14.6.90: Version 'ß/5'⓪)'+' als StrCat-Symbol;⓪)"IF TRUE OR f() THEN" löst keinen internen A3-Fehler mehr aus⓪)FLOAT/LFLOAT erlauben Reals als Argument⓪)LENGTH liefert auch bei String-Literals CARDINAL/LONGCARD statt ZZ⓪)CHR liefert nun CHAR statt SS bei Literals⓪)SS-Literale werden in CONST nicht mehr abgeschnitten, wenn mit "&&"⓪+bzw. "+" zusammengesetzt.⓪)SS-Typen nun genau nach ISO (7C ist SS, '1' auch, '' auch)⓪ 30.6.90: CAST erlaubt keine SETs mehr, wenn Größen unterschiedlich;⓪ 03.7.90: Kennung 45 zeigt nun 'regset' an; 'constMul' erweitert Byte auf⓪)Word bei MULU/MULS.⓪ 20.7.90: Gleich/Ungleich auf Sets nun Word- statt Byteweise; kein 'rBranch'⓪)mehr, wenn z.B. IF FALSE THEN WriteString ('bla') vorkommt⓪ 23.7.90: loadRegExt lädt nun mit Sicherheit den Wert in ein 'niceRegs'; bisher⓪)blieben INTEGERs ggf. im geschützten Register.⓪)CAST (CARDINAL, ByteSet) geht nun⓪ 12.9.90: Compiler läuft nun mit beiden Real-Formaten; bei constantFold wird⓪)bei Cross-Compile kurz ins akt. Format gewandelt - geht aber noch nicht⓪)bei ShortReals!⓪)Subranges können nicht mehr an Base-Type-VAR-Parms übergeben werden⓪ 21.9.90: LENGTH (REF-Open-Array) nochmal korrigiert; extractConstPtr arbeitet⓪)nun richtig, Record-Const-Selektionen gehen auch bei constPtr.⓪)Kennung v. Rec-Variante von 16 nach 47 geändert.⓪ 26.9.90: CADR() geht auf TABLE⓪ 18.10.90: Read-Only-Vars werden auch bei INC/DEC geprüft; "FOR c:= d+1 TO f()"⓪*vertauscht Werte nicht mehr auf dem Stack; Reg-Vars auch bei ST-FPU.⓪ 01.11.90: Sets, die nicht bei Null beginnen, verändern bei INCL usw. nicht mehr⓪)den Orignal-Index-Wert, falls er in einer Reg-Var steht.⓪)Busfehler bei großen Aggregaten behoben. Kein SP-Inkonsistent⓪)mehr bei ungeraden Längen großer Daten (>256 Byte)⓪ 11.11.90: Bei Moves auf den Stack wird möglichst ein extra ADDQ #1,A3 vermieden,⓪)indem aus einem MOVE.B ein MOVE.W/L wird ("moveTo"). Direktive ^+⓪)läßt Open Array-/REF/VAR-Parameter immer auf geraden Adr. beginnend⓪)annehmen (hat aber z.Zt. bei Open Arrays keinen Effekt).⓪ 20.11.90: accessArray setzt "mayBeOdd" nun auch bei Zugriffen in Byte-Arrays.⓪)addIdxReg erhält neuen Parm, um "ADD Dn,An" statt "0(An,Dn)" zu gen.⓪)ARRAY OF BYTE/CHAR erlauben nur noch 32768 Elemente.⓪ 08.12.90: Bei A7-Parm-Übergabe nun pauschal alle Value-Args an Open Arrays⓪)verboten, weil 1. u.U. Spilling z.Zt. Fehler macht, 2. das mit⓪)mehreren Parms auf dem A7 sowieso nicht klappen würde, weil z.Zt.⓪)die Pointer/High-Werte sich mit den Value-Kopien auf dem selben⓪)Stack (A7) mischen würden.⓪ 19.12.90: Beim Array-Zugriff mit CARDINALs auf CARDINAL-Subranges wird kein⓪*CHK mehr erzeugt, bei INTEGER-Index auf CARDINAL-Subranges wird⓪*auch die Untergrenze geprüft.⓪ 01.02.91: accessArray meldet nun "] erwartet", wenn zu viele Indices auftauchen;⓪*runtimeLength kommt nun auch mit Arrays klar (der Index in D0 wurde⓪*vom High-Wert zu früh überschrieben); extractConstPtr korrigiert auch⓪*'start', wenn die Const dabei kleiner als 128 Byte wird, so daß nicht⓪*mehr die ersten 2 Byte verloren gehen; richtige Fehlermeldung statt⓪*Internem Fehler, wenn Par-Daten > 32KB; Kein Fehler mehr bei⓪*FOR x:= 1 TO ORD(10) DO END; $W- funktioniert wieder bei REF- an⓪*VAR-Parms; $A+ wirkt nun auf alle "designator".⓪ 27.02.91: Bei TT-FPU wird bei Conversion Real->WholeNumber der Real-Wert, wenn⓪*er im Reg steht, zur richtigen Zeit auf den Stack geladen - wurde⓪*zuvor vor dem Spilling auf den Stack gebracht, was zu Fehlern mit⓪*der Stack-Reihenfolge führen konnte.⓪ 02.03.91: Vergleich von Procs mit Proc-Vars sowie alle Vergl. mit localProcTypes⓪*nun möglich, nur Vergl. von lokalen Prozeduren (beide const.) geht⓪*noch nicht; varComp meldet nicht mehr Inkompatibilität, wenn viele⓪*Importe vorkommen (durch MOVEM.W wurde Item-Ptr ggf. verändert).⓪ 11.03.91: Nicht-Arrays als akt. Parm. von Open Arrays führen nicht mehr zu⓪*internen Fehlern; accessArray kommt auch klar, wenn auf Array-Elem⓪*eines Open Arrays zugegriffen wird; runtimeRealOp: erzeugt keinen⓪*falschen Code mehr, wenn bei Soft-Reals ein REAL-Operand im Register⓪*steht.⓪ 12.03.91: Mehrdim. Open Arrays; Debug-Ausgabe wieder in simpleExpression,⓪*zusätzlich am Ende von BOOLEAN-Ergebnissen; Bool-Expr korrigiert⓪*für Bool-Zuweisungen (kein IF/WHILE/UNTIL).⓪ 26.03.91: "0 - expr" wird nicht mehr zu "expr"; Kein int. Fehler mehr bei⓪*Verw. von Std-Procs in Exprs.⓪ 08.04.91: Bei Word-Division wird Divisor nun bei $R+ extra auf Null geprüft,⓪*damit der Exc-Vektor nicht mehr verbogen werden braucht; Daten >⓪*32KB auf dem A3-Stack werden korrekt runterkopiert; Wenn A7Hidden ist,⓪*wird Ptr auf Proc-Adr bei Proc-Var trotzdem korrekt geholt; SHIFT/⓪*ROTATE erlauben nun variable Weite, wenn das Set ein vollst. Byte/⓪*Word/Long ist.⓪ 01.08.91: Nun auch Spaces hinter "." (Records) erlaubt. Allerdings ist nicht⓪*sicher, ob der FetNoSp-Aufruf beim evtl. Nachladen das 1. Zeichen⓪*verschwinden lassen kann. Daher dort eine Sicherheitsabfrage.⓪*Kein Verif.Error mehr, wenn cutConst bei $D+ vorkommt (z.B. durch⓪*"WriteString (VT52.Seq[VT52.wrapOn])".⓪ 09.08.91: Wenn FOR Reg-Vars benutzt, werden die vorigen Reg-Werte _immer_ LONG⓪*gesichert, da evtl. ein MOVEQ das gesamte Reg zerstört.⓪ 15.09.91: CAST () löscht unbenutzte Upper-Bytes & over-Flag (damit CARDINAL(-1)⓪*DIV 2 $7FFF ergibt); Bei TC-Parm-Übergabe klappen nun mehrere ADDRESS-⓪*Parms und Args für Regs werden ggf. auf Ziel-Typ angepaßt.⓪*Record-Aggregate werden am Ende von Varianten besser aufgefüllt,⓪*letztes Feld einer Variante wird korrekt aufgefüllt.⓪ 26.10.91: "const IN const" geht; Funcresults v. LONGREAL bei $D+ gehen.⓪ 17.11.91: sizedAt6 ignoriert nun Bit 8, dafür wird f. BTST nun genarSized (..-1)⓪*statt genar aufgerufen - damit erzeugt nun genar (EOR.. den korrekten⓪*Wert für die Opsize: '/'-Operator bei SETs geht nun auch bei Sets⓪*mit mehr als 1 Byte.⓪ 20.11.91: String-Consts an ARRAY OF CHAR werden nun immer Null-terminiert und⓪*auch der High-Wert ist entsprechend um eins höher (der Einfachheit⓪*halber).⓪ 04.02.92: 'const': PushExpr (fact) vor checkCall(), sodaß es 1. klappen könnte⓪*und 2. kein bong mehr in funcCall/LookExpr kommt.⓪ 13.02.92: 'constOp': wenn Divisor >= 65536, klappts nun auch mit LONGINTs⓪*(bisher wurde hier immer nur unsigned per SWAP geteilt).⓪ 09.03.92: kein Arithm. Überlauf mehr bei Indizierung mit LONGs auf Arrays mit⓪*Feldgröße > 1 Byte.⓪ 30.05.93: Kein Stack-Check bei REF-Parms mehr.⓪ 13.12.93: Konstant-Argumente werden nur noch bis 8 (bisher 16) Byte direkt⓪*statt über eine Referenz im RAM erzeugt.⓪*Konstanten werdem im DATA-Puffer statt im Code abgelegt.⓪ 24.01.94: MaxLabels von 20 auf 50 erhöht (erlaubte bisher nur 20 OR-Verknüp-⓪*fungen, nun eben 50).⓪ 15.02.94: accessArray und stdFunction verbrauchen nun weniger Stack in⓪*Rekursion.⓪*Neue Label-Behandlung, die weniger Speicher auf dem Stack belegt.⓪*Es sind nun 256 Sprungziele möglich.⓪ 04.04.94: Keine internen Abstürze (Bus-/Addr-Error) bei CONSTs, die aus⓪*zwei CONSTs zusammengesetzt werden, die einzeln < 16, zusammen > 16⓪*Bytes sind (addToConstPar).⓪ 18.08.94: Korrektur bei neuer Label-Verwaltung, erzeugte teils Assert-Error⓪*bei IF-Ausdrücken, wo altes Lbl-Verfahren noch klappte.⓪ *)⓪ ⓪ (*⓪!* Markierungen:⓪!* "!!!" für dringende Korrekturen,⓪!* "~~~" für mögl. Optimierungen und Verbesserungen (z.B. Sicherheits-Checks)⓪!* "&&&" für Erweiterungen, bzw. Lösung von Einschränkungen⓪!*)⓪ ⓪ (*~~~ 'deallocExpr' einführen:⓪!* sorgt z.B. für das Rücksetzen von 'ConstItem.itemNo', wie in⓪!* 'addToConst' geschehen.⓪!*)⓪ ⓪ (*~~~ adapt-Aufrufe durch fitValue mit erledigen! -> nur fitValue wird⓪!* für assignments, usw, aufgerufen⓪!*)⓪ ⓪ (*~~~⓪!* Value Constructors mit Variablen werden erstmal immer auf dem Stack⓪!* angelegt, egal, was danach mit ihnen geschieht.⓪!* Da solche konstruierten Werte aber - bis auf Sets - nicht in Expressions⓪!* vorkommen können, könnte man sie auch gleich in der Ziel-Var anlegen;⓪!* dann spart man sich ggf. das Umkopieren vom Stack auf die Var.⓪!* Damit das geht, müßte schon der Expression-Routine mitgeteilt werden,⓪!* wohin der Wert am Ende geht: Auf den Stack als Parm oder in eine Var.⓪!*⓪!* Wenn man diese Information mit übergibt, könnte daraufhin auch an vielen⓪!* anderen Stellen eine Optimierung vorgenommen werden: Beispielsweise⓪!* bei Expressions mit großen Sets: Statt das Erg. auf den Stack zu laden,⓪!* könnte es gleich in die Ziel-Var. Allerdings muß hier erkannt werden,⓪!* daß die Expr nicht weitergeht -- nee! braucht gar nicht! Denn schließlich⓪!* ist es wohl egal, ob die Weiterrechnung mit den Sets dann auf dem Stack⓪!* oder über die Var geht -- ist ja nur ein anderer Speicherbereich?!⓪!* Oh! es könnte doch schiefgehen: wenn ein Zw-Ergebnis schon in die Var kommt⓪!* und dann mit dem eigentlichen alten Wert der Var noch weitergerechnet⓪!* werden soll.⓪!* Also: Es muß doch erkannt werden, daß die Expr zu ende ist. Das könnte⓪!* man sicher durch das Prüfen des Folgezeichens erreichen: wenn es keins⓪!* der mögl. Operatoren ist, würde die Expr-Routine ja dann auch Schluß machen.⓪!*)⓪ ⓪ (*⓪!* Reg-Var-Handhabung⓪!* ------------------⓪!*⓪!* Pro Modul- oder Procedure-Block wird zuerst 'freeRegs' auf alle⓪!* Regs, bis auf A3 & A7 gesetzt. Bei Procs (Main.ProcDec) werden dann ggf.⓪!* noch A5 & A6 rausgenommen. In 'varRegs' sind übrigens alle theoretischen⓪!* Reg f. Vars definiert ({D3..D7,A3..A7,F3..F7}).⓪!*⓪!* Werden dann Parameter oder Vars deklariert, die vor oder nach ihrem⓪!* Bezeichner die Option "$Reg" haben, werden sie geprüft, ob sie von⓪!* ihrem Typ her als Reg-Var tauglich sind (Symbol.allocReg). Wenn ja, werden⓪!* sie mit Expr.getRegVar alloziert. Ist kein Reg mehr frei, wird die⓪!* Var normal über Memory angesprochen. Ist ein Reg frei, wird das Reg⓪!* belegt und die Reg-Nr bei der Var-Beschreibung eingetragen (Symbol.VarDec⓪!* & Main.SetPar).⓪!*⓪!* Bei Code-Beginn werden dann die Regs für die Vars nochmal freigegeben⓪!* (In ProcDec & ModDec).⓪!* Wird nun auf eine Reg-Var zugegriffen (designator), wird sie, wenn sie⓪!* noch nicht im Reg liegt, dahin geladen, falls ihr Reg unbelegt ist.⓪!* Belegt kann es dann sein, wenn durch FOR oder WITH eine temp. Reg-⓪!* Var benötigt wird: Dann wird, wenn kein Var-Reg mehr frei ist, eine⓪!* Reg-Var wieder ins Memory gelegt und stattdessen nun für die temp.⓪!* Var benutzt. Am Ende von FOR/WITH wird dann das Reg. wieder als unbelegt⓪!* gekennzeichnet, so daß beim nächsten Zugriff auf diese Reg-Var sie wieder⓪!* ins Reg geladen werden kann.⓪!*⓪!* Damit eine Reg-Var, die als Parameter übergeben wurde, beim ersten⓪!* Zugriff und einer Wert-Ermittelung (also nicht Zuweisung darauf) erstmal⓪!* ihr Wert vom Stack geladen wird, während bei einer Zuweisung nicht erst⓪!* ggf. der Wert geladen wird und bei Wert-Ermittelung einer lok. Var⓪!* sogar erkannt werden kann, daß sie noch nicht init. wurde, wird⓪!* bei Deklaration von Vars ein 'dirty'-Flag gesetzt. Das Flag wird erst⓪!* bei einem Schreibzugriff auf die Var gelöscht. Wird auf eine 'dirty'⓪!* Var. lesend zugegriffen, wird ein Fehler ausgelöst.⓪!* >> Leider geht das doch nicht so einfach, daß bei Zuweisung auf eine⓪!* Reg-Var ggf. erst gar nicht der alte Wert geladen wird: denn bei einem⓪!* deref. Pointer muß dann erkannt werden, daß nicht auf den Pointer, sondern⓪!* auf den deref. Wert zugewiesen wird, weshalb natürlich der Pointer-Wert⓪!* geladen werden muß. Das geht aber z.Zt. noch gar nicht. Das ist ein⓪!* ähnliches Problem, wie mit Proc-Vars: Da sie auch nicht von vornherein⓪!* erkannt werden, ruft 'assignment' erstmal designator mit der Information⓪!* auf, es würde eine Zuweisung erfolgen - erst hinterher stellt sich heraus,⓪!* daß ein Proc-Call, bei dem der Wert doch gelesen wird, stattfindet.⓪!*⓪!* Folgendes geht noch nicht:⓪!* Wird eine Var benutzt, wird die jeweils größte Proc-Tiefe, in der⓪!* es benutzt wird, in der Var-Beschreibung vermerkt. Wird dann eine⓪!* Proc aufgerufen, die LOKAL zur eigenen ist (Expr.call), wird geprüft,⓪!* welche der eigenen lok. Variablen z.Zt. in Regs liegen und von der⓪!* aufzurufenden Proc oder einer tieferen Proc benutzt werden. Solche⓪!* Vars werden dann in Memory zurückgespeichert, so daß sie erst beim⓪!* nächsten Zugriff im eigenen Level wieder geladen werden.⓪!* Es muß noch ausgearbeitet werden, wie mit dem 'dirty'-Flag bei lok.⓪!* Procs zu verfahren ist: Es kann sowohl sein, daß in der lok. Proc⓪!* die Var gelesen wird, jedoch korrekt in der umgebenden Proc der Wert⓪!* vor dem lok. Proc-Aufruf init. wird, als es auch möglich ist, daß⓪!* der Wert in der lok. Proc init. wird, und die lok. Proc auch vor dem⓪!* Zugriff in der äußeren Proc aufgerufen wird. In beiden Fällen darf es⓪!* keinen Fehler wg. Zugriff auf uninit. Var geben.⓪!*)⓪ ⓪ (*⓪!* Real-Generierung⓪!* ----------------⓪!*⓪!* Es gibt drei Arten der Code-Erzeugung für Reals:⓪!* a) keine FPU vorhanden -> mit Pseudo-Regs in Runtime arbeiten; Runtime-⓪!* Routinen für Real-Operationen (+, -, *, /, <, >, usw)⓪!* b) externe FPU vorhanden -> Regs der FPU werden verwendet. Es werden⓪!* andere Runtime-Routinen verwendet, die bei monadischen Ops die⓪!* Reg-Nr erhalten, bei duadischen Ops eine Reg-Nr sowie die Adr. der⓪!* andern '<ea>' erhalten.⓪!* c) interne FPU vorhanden -> nix Runtime-Aufrufe⓪!*⓪!* Fall a) verlangt, daß meist alle temp. Regs gesichert werden müssen,⓪!* weil die Routinen sehr aufwendig sind.⓪!*⓪!* Für Fall b) brauchen ggf. nicht so viele Regs gesichert werden, auch⓪!* kann man hier vielleicht den Op-Code für bestimmte Gruppen von Operationen⓪!* mit übergeben, anstatt f. jede Operation eine einzelne Routine zu haben.⓪!* Allerdings muß hier bei duad. Ops auch jew. eine Routine vorgesehen werden⓪!* für den Fall, daß beide Werte schon im Reg stehen, denn dann kann keine⓪!* Adr. sondern es muß eine Reg-Nr übergeben werden.⓪!*⓪!* Das Verfahren von b), für den zu verändernden Ziel-Operanden eine⓪!* Reg-Nr anzugeben, kann auch für a) verwendet werden, um dies einfacher⓪!* handhaben zu können. Allerdings wäre es vom Zeitverhalten günstiger,⓪!* wenn die Adr. des Regs direkt übergeben wird, weil die hier ggf. direkt⓪!* bestimmt werden kann, im Runtime müßte sie aus der Reg-Nr berechnet werden.⓪!*⓪!* Allen Fällen ist eins gemeinsam: bei duadischen Ops wird der rechte⓪!* Wert in ein Reg geladen, deshalb wird dies vor der Fallunterscheidung⓪!* vorgenommen.⓪!*⓪!* Während bei a) die Vergleiche durch verschiedene Runtime-Routinen⓪!* durchgeführt werden, die dann jew. ein T/F-Flag liefern, wird bei⓪!* b) und c) eine CMP-Instr. gen. und dann ein Bcc, wie bei nicht-Real-⓪!* Vergleichen.⓪!*⓪!* Werden die Pseudo-Regs im Runtime benutzt, werden 4-Byte-Reals⓪!* linksbündig, also im Longword mit der kleineren Adr. abgelegt.⓪!*⓪!* Real-Formate⓪!* ------------⓪!* Die Runtime-Routinen, die f. MM2-Reals benutzt werden, sind immer⓪!* benutzbar, also auch für 68881-Betrieb. Das Runtime muß allerdings⓪!* für die entsprechende Benutzung übersetzt sein. Der Vorteil liegt⓪!* nun darin, daß es z.B. zwei Shells gibt: Eine mit MM2-Reals, eine⓪!* mit IEEE-Reals. Übersetzte Module, die zwar Reals benutzen, dazu⓪!* aber ausschließlich die MM2-Real-Routinen des Runtime aufrufen,⓪!* laufen mit beiden Shells. Dies ist besonders beim Compiler von⓪!* Vorteil. So brauchen nicht zwei Compiler f. jedes Format existieren.⓪!* Nachteil ist nur, daß dann eben nicht die schnelleren IEEE-Zugriffe⓪!* geschehen.⓪!* Werden Real-Konstanten abgelegt, ist allerdings das Format sofort⓪!* festgeschrieben. Deshalb dürfen hier im Compiler keine Real-Konstanten⓪!* vorkommen, sondern sie müssen ggf. von integer-Werten umgewandelt werden.⓪!* Das führt zu folgenden Kombinationen:⓪!* - Wird eine Real-Konst. verwendet, ist das Format sofort festgelegt und⓪!* wird im Modulheader festgehalten.⓪!* - Werden Runtime-Aufrufe für die externe FPU getätigt, ist das Format⓪!* ebenfalls festgelegt.⓪!* - Werden keine Real-Konst. benutzt und nur Runtime-Aufrufe der MM2-Reals⓪!* gemacht, bleibt das Real-Format frei. Das heißt: Wird ein Modul mit⓪!* $F- übersetzt, kann es formatfrei bleiben, so wie der Compiler.⓪!*)⓪ ⓪ (*⓪!* Wichtige Hinweise:⓪!* - Zwischenergebnisse dürfen nicht auf den A7-Stack, sondern müssen dann⓪!* immer auf den A3-Stack geladen werden. Würde ein Wert auf den A7 kommen,⓪!* könnte ein vorher auf den A7 gespillter Pointer, z.B. für die Ziel-Adr,⓪!* nicht mehr direkt runtergeladen werden, um dann den Ergebniswert vom⓪!* Stack zu laden.⓪!*)⓪ ⓪ FROM SYSTEM IMPORT⓪"CompilerVersion, ASSEMBLER, ADDRESS, ADR, TSIZE, BYTE, WORD, LONGWORD;⓪ ⓪ FROM MM2Comp IMPORT⓪"SBothTyp, ZZTyp, BothTyp, CardPtr, SCardPtr, IntPtr, SIntPtr,⓪$SSTyp, BytIPtr, UndefTyp, CardRel, IntRel, BSetPtr, RealPtr, SRealPtr,⓪$BoolPtr, StrPtr, CharPtr,⓪"SerVal0, SerVal1, SerLead0, SerLead1, SerCnt1, SerOffset1,⓪"DataPtr, DataEnd, Accu, AccuPtr, AccuSize,⓪"NumConst, StrConst, SymNot, SymAnd, SymOr,⓪"StackReserve, Options, Tiefe, CodeStart, Header, EvalStk, Peephole,⓪"ConFact, CSP, compatRR, compat, PushInt, PullInt, SyntaxErr, GetSbl,⓪"LocalSearch, Global, fpu, RealConstIsUsed, IEEERuntimeCall, FPUType,⓪"TreSpc, TreSrc, StatSeq, BadId, ROScope, StrLen, STRBUF, TextOffset,⓪"AsmMode, WithScope, VarReg, A3Offset, A7Offset, HaltOnError, FetNoSp,⓪"StatLinkOffs, AsComp20;⓪ ⓪ IMPORT SysUtil0, Block;⓪ ⓪ IMPORT GEMScan,⓪"BIOS, SysCtrl, SysTypes, HdlError, ErrBase, MOSGlobals, SysBuffers;⓪ ⓪ FROM Strings IMPORT Assign, Append, String;⓪ FROM StrConv IMPORT StrToReal, CardToStr, LHexToStr;⓪ FROM Convert IMPORT ConvCard;⓪ FROM RealCtrl IMPORT AnyReal, UsedFormat, AnyRealFormat, Conv, SmallREAL,⓪(RealFormat, LargeREAL, SmallLONGREAL, LargeLONGREAL;⓪ FROM SFP004 IMPORT FPUError;⓪ ⓪ ⓪ CONST Safety = FALSE; (* TRUE: alle möglichen asserts kodieren *)⓪&Safety2 = TRUE; (* f. kritische asserts (z.B. Codegen) *)⓪&Test = FALSE; (* dann geht 'showExpr' usw./ InOut importieren! *)⓪ ⓪ (*$? Safety: (*$R+*) *)⓪ ⓪&InternalVersion = 'V#3592';⓪ ⓪&constBufSize = 8; (* Wenn Const größer, wird sie im DATA-Buf abgelegt *)⓪ ⓪&CompileWithNewCompiler = (CompilerVersion > 3);⓪ ⓪ CONST CompileWithOldCompiler = NOT CompileWithNewCompiler;⓪ ⓪ (* nur zur Verifikation, daß richtiger Modus gewählt ist: *)⓪ (*$? CompileWithOldCompiler:⓪"PROCEDURE testProc;⓪"VAR testStr1: ARRAY [0..2] OF CHAR; testStr2: ARRAY [0..5] OF CHAR;⓪"BEGIN testStr2:= testStr1 END testProc;⓪ *)⓪ (*$? CompileWithNewCompiler:⓪"CONST testChar = CHR (0);⓪ *)⓪ ⓪ TYPE⓪"PtrItem = ADDRESS;⓪ ⓪ CONST⓪"anyFloatReg = RegSet {F0..F7};⓪"anyCPUReg = anyDataReg + anyAddrReg;⓪ ⓪ (*$I CompErr.ICL *)⓪ ⓪ MODULE MM2Comp3;⓪ ⓪"(*⓪$FROM InOut (*!!!*) IMPORT WriteCard, WriteString, WritePg, WriteLn, Write, Read;⓪"*)⓪"FROM GEMScan IMPORT ChainDepth, CallingChain, InputScan, InitChain;⓪"FROM SysCtrl IMPORT GetScanAddr, ScanBack;⓪ ⓪ FROM SysTypes IMPORT ScanDesc, ExcDesc;⓪ FROM HdlError IMPORT CatchErrors, GetErrorMsg;⓪ FROM ErrBase IMPORT ErrResp, RtnCond;⓪ ⓪ FROM MOSGlobals IMPORT DivByZero, OutOfRange, Overflow, HALTInstr, MemArea;⓪ FROM SysBuffers IMPORT HdlErrorStack;⓪ ⓪ IMPORT ASSEMBLER, ADR, TSIZE, CompilerVersion, BYTE, WORD, LONGWORD, ADDRESS;⓪ IMPORT String, Append, StrToReal, CardToStr, PtrItem;⓪ ⓪ (* FROM MM2Comp *) IMPORT⓪"ZZTyp, SBothTyp, BothTyp, CardPtr, SCardPtr, IntPtr, SIntPtr,⓪$CardRel, IntRel, BoolPtr, StrPtr, RealPtr, CharPtr,⓪"DataPtr, DataEnd, NumConst, StrConst, SymNot, SymAnd, SymOr,⓪"BadId, Options, Tiefe, CodeStart, Header, EvalStk, Peephole, FetNoSp,⓪"ConFact, CSP, compatRR, compat, LocalSearch, PushInt, SyntaxErr, GetSbl,⓪"TreSpc, TreSrc, StatSeq, TextOffset, StrLen, STRBUF, HaltOnError, AsComp20;⓪ ⓪ (* FROM outer *) IMPORT SuppressCode, InternalVersion, RegType, RelocCount,⓪4Assign;⓪ ⓪ EXPORT⓪"OptimizedCompile, MaxStringConst, StringTerminator, DebugTrapNo, ErrorTrapNo,⓪"DivByZeroTrap, StackOverflowTrap, OverflowTrap, RangeTrap, DisplayTrap,⓪"bong, assert, entryC, entryL,⓪"FoldingConst, varParm, refParm, scalar, refVar, rtnD0, rtnTC, global, typeDesc,⓪"indirVar, extVar, parmA7, imported, exported, userDef, ByteSet, IFS,⓪"Symbol, TextPointer, TreeBase, CurrentSymbol, SyntaxError, CodeSpace,⓪"OpenScope, CloseScope, CodePtr, SetCodePtr, GetTextPtr, SetTextPtr, Entry,⓪"Exit, GetSymbol, TreeSearch, StatementSequence, ConstantFactor, DataSpace,⓪"SearchLocalItem, CallRuntimeProc, AsnComp, ExprComp, VarComp, PutCode, plus,⓪"minus, becomes, lparen, rparen, lbrack, rbrack, lbrace, rbrace, tilde, dot,⓪"arrow, comma, endSym, doSym, toSym, bySym, asterisk, strConc, dblpoint,⓪"ParmRegNo, ParmToReg, SetVarLink, LastVarLink, SetProcLink, PutData,⓪"LastProcLink, VarAddress, IndexType, ParmType, FirstParm, NextParm,⓪"LocalTree, RefType, ElementType, BaseType, SetBaseType, OpenArrayType,⓪"VarParm, NoOfElems, LowBound, HighBound, ItemNo, ItemFlag, SetItemFlag,⓪"ParmFlag, IsRegVar, MakeRegVar, MakeMemVar, IsInReg, IsInMem, UsedReg,⓪"SetReg, UseReg, UseMem, IsDirty, ClearDirt, SetDirt, SetAccessDepth,⓪"NewAccessDepth, AccessDepth, TypeLength, AnyTypeLength, SetTypeLength,⓪"BooleanType, StrConstType, ByteType, CharType, StdProcNo, StdProcParms,⓪"StdParmType, NextStdParm, StdParmRes, HostType, FirstRecField, NextRecField,⓪"SetTableLink, LastTableLink, SetConstLink, LastConstLink, NextTagField, TagFieldList,⓪"SignalOverflow, HasOverflown;⓪ ⓪ ⓪ (*$I COMPERR.ICL *)⓪ ⓪ CONST OptimizedCompile = CompilerVersion > 3;⓪ ⓪ (*$? NOT OptimizedCompile: Arghhh! Das geht nicht! Zuerst 'Ret6L' usw anpassen*)⓪"⓪"MaxStringConst = 256; (* Max. Länge einer String-Konstante *)⓪"StringTerminator = 0C;⓪"⓪"DebugTrapNo = 5; (* könnte durch Var. ersetzt werden~~~ *)⓪"ErrorTrapNo = 6; (* könnte durch Var. ersetzt werden~~~ *)⓪"StackOverflowTrap = $FFF6;⓪"OverflowTrap = $FFF9;⓪"RangeTrap = $FFFA;⓪"DisplayTrap = $FFE7;⓪"DivByZeroTrap= $FFFB;⓪ ⓪ ⓪ VAR FoldingConst: BOOLEAN;⓪"(* Diese Var setzt M2Expr.constantFold temporär auf TRUE *)⓪ ⓪$SignalOverflow: BOOLEAN;⓪$HasOverflown: BOOLEAN;⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ CONST⓪ ⓪"varParm = 0; (* Bei Parameter-Beschreibungen von Prozeduren *)⓪"refParm = 1; (* Bei Parameter-Beschreibungen von Prozeduren *)⓪"⓪"scalar = 0;⓪"refVar = 0; (* Read Only; nur bei gültig, wenn nicht 'typeDesc' *)⓪"rtnD0 = 0; (* Function-Return via D0 statt (A3) *)⓪"rtnTC = 0; (* Function-Return a la TC (nur, wenn Bit 3 gesetzt) *)⓪"global = 1;⓪"typeDesc = 2;⓪"indirVar = 3; (* VAR-Parameter bei lokalen Variablen, *⓪7* auch IMMER gesetzt bei Open Array-Parms! *)⓪"parmA7 = 3; (* Bei Procs: Parameter auf A7 oder in Regs übergeben *)⓪"extVar = 4;⓪"imported = 5;⓪"exported = 6;⓪"userDef = 7;⓪ ⓪ TYPE⓪ ⓪"ByteSet = SET OF [0..7];⓪ ⓪"IFS = SET OF [0..7];⓪ ⓪"Symbol = RECORD⓪-CASE : BOOLEAN OF⓪/TRUE: flags: IFS; typ: BYTE|⓪/FALSE: itemNo: CARDINAL⓪-END;⓪-item: PtrItem;⓪+END;⓪ ⓪"TextPointer = RECORD⓪2ptr: ADDRESS;⓪2ofs: LONGCARD⓪0END;⓪ ⓪ VAR⓪"TreeBase: ADDRESS;⓪"CurrentSymbol: Symbol;⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ (*⓪!* Auswertung der Symbole & Tree-Daten⓪!*)⓪ ⓪ CONST⓪"plus = 2;⓪"minus = 3;⓪"becomes= 6;⓪"lparen = 14;⓪"rparen = 26;⓪"lbrack = 15;⓪"rbrack = 27;⓪"lbrace = 16;⓪"rbrace = 28;⓪"tilde = 12;⓪"dot = 9;⓪"arrow = 17;⓪"comma = 10;⓪"endSym = 35; (* END *)⓪"doSym = 40; (* DO *)⓪"toSym = 43; (* TO *)⓪"bySym = 44; (* BY *)⓪"asterisk = 4;⓪"strConc = plus; (* '+': Verkettungs-Zeichen f. String-Consts *)⓪"dblpoint = 8; (* .. *)⓪ ⓪ ⓪ (*$Z-*) (*$? OptimizedCompile: (*$Z+*) *)⓪ ⓪ VAR globalScan: ScanDesc;⓪$errorMsg: ARRAY [0..31] OF CHAR;⓪ ⓪ PROCEDURE scanPrep (depth: CARDINAL);⓪"BEGIN⓪$IF depth # 0 THEN⓪&GetScanAddr (globalScan);⓪&WHILE depth > 0 DO⓪(DEC (depth);⓪(IF ScanBack (globalScan) THEN END;⓪&END⓪$END;⓪$InitChain (globalScan);⓪"END scanPrep;⓪ ⓪ PROCEDURE scanner;⓪"VAR c: CARDINAL;⓪"BEGIN⓪$c:= 0;⓪$InputScan (errorMsg, c)⓪"END scanner;⓪ ⓪"(*⓪#* Schnittstelle zu externen Routinen⓪#*)⓪ ⓪"VAR regs: ARRAY [0..11] OF LONGWORD;⓪"CONST A1 = 6; A2 = 7; rA4 = 9; A6 = 11;⓪ ⓪"VAR n: CARDINAL;⓪&ok: BOOLEAN;⓪ ⓪ PROCEDURE GetKBShift (): BITSET;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE #-1,-(A7)⓪(MOVE #11,-(A7)⓪(TRAP #13⓪(ADDQ.L #4,A7⓪((*$? NOT OptimizedCompile:⓪(MOVE.W D0,(A3)+⓪(*)⓪$END⓪"END GetKBShift;⓪"(*$L=*)⓪ ⓪ PROCEDURE SyntaxError (n: INTEGER);⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; damit Scanning möglich ist:⓪(LINK A5,#0⓪$END;⓪$scanPrep (2);⓪$ASSEMBLER⓪(UNLK A5⓪$END;⓪$ASSEMBLER⓪&TST HaltOnError⓪&BEQ.W noHalt⓪$END;⓪$errorMsg:= ' Syntax-Fehler! ';⓪$scanner;⓪$IF 2 IN GetKBShift () THEN⓪&(* ignore error *)⓪&ASSEMBLER⓪(BRA ende⓪&END;⓪$END;⓪$ASSEMBLER⓪$noHalt⓪&MOVE.W -(A3),D0⓪&MOVE.L A3,EvalStk⓪&MOVEM.L regs,D1/D4-D7/A0-A6⓪&MOVE D0,D5⓪&JMP SyntaxErr⓪$ende⓪&SUBQ.L #2,A3⓪$END⓪"END SyntaxError;⓪"(*$L=*)⓪ ⓪ PROCEDURE appendScanDesc;⓪"VAR i: INTEGER;⓪"BEGIN⓪$IF BadId[0] # 0C THEN⓪&Append (' >', BadId,ok);⓪$END;⓪$Append (InternalVersion + ":", BadId,ok);⓪$FOR i:= 0 TO 3 DO⓪&WITH CallingChain[i] DO⓪(IF (ChainDepth >= i) & (modName[0] # 0C) THEN⓪*IF i # 0 THEN Append (",", BadId, ok) END;⓪*Append (CardToStr (relAddr, 0), BadId, ok);⓪(END⓪&END⓪$END;⓪"END appendScanDesc;⓪ ⓪ PROCEDURE bong ();⓪"(* diese Routine ist nur für interne verifikationen gedacht, nicht für⓪#* syntax-fehlermeldungen! *)⓪"BEGIN⓪$scanPrep (2);⓪$IF HaltOnError THEN⓪&errorMsg:= ' Interner Fehler! ';⓪&scanner;⓪&IF 2 IN GetKBShift () THEN (* ignore error *) RETURN END;⓪&HaltOnError:= FALSE;⓪$ELSE⓪&appendScanDesc;⓪$END;⓪$SyntaxError (rIntEr)⓪"END bong;⓪ ⓪ PROCEDURE assert (ok: BOOLEAN);⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(TST.W -(A3)⓪(BNE ok0⓪(JMP bong⓪&ok0⓪$END⓪"END assert;⓪"(*$L=*)⓪ ⓪ ⓪ (*$L-*)⓪ PROCEDURE compat4 ();⓪ BEGIN⓪ ASSEMBLER⓪)CMP.L ZZTyp,D0⓪)BEQ compatzz ; ZZ ist zu allen Ordinalen kompat.⓪)CMP.L BothTyp,D0⓪)BEQ compat1⓪)CMP.L SBothTyp,D0⓪)BEQ compat7⓪)CMP.L CardPtr,D0⓪)BEQ compat5⓪)CMPI.B #20,-1(A1,D0.L) ;POINTER?⓪)BEQ compat5 ; ist kompat. mit Adr⓪)BRA compat2⓪ compat7 CMP.L SIntPtr,D2⓪)BEQ compat2⓪)CMP.L SCardPtr,D2⓪)BEQ compat2⓪)CMPI.B #41,-1(A1,D2.L) ;Bitnum?⓪)RTS⓪ compatzz CMP.L SIntPtr,D2⓪)BEQ compat2⓪)CMP.L SCardPtr,D2⓪)BEQ compat2⓪)CMPI.B #41,-1(A1,D2.L) ;Bitnum?⓪)BEQ compat2⓪ compat1 CMP.L CardPtr,D2⓪)BEQ compat2⓪)CMP.L IntPtr,D2⓪)BEQ compat2⓪ compat5 CMPI.B #23,-1(A1,D2.L) ;Address?⓪ compat2⓪ END⓪ END compat4;⓪ ⓪ (*⓪!* Pruefen, ob zwei Typen Assignment-kompatibel sind.⓪!* (D2 = Source, D0 = Destination)⓪!*⓪!* Ergebnis in D1⓪!*)⓪ ⓪ (*$L-*)⓪ PROCEDURE asComp;⓪ BEGIN⓪ ASSEMBLER⓪)CMP.L D0,D2⓪)BEQ.L isCompat ;gleiche Typen ->⓪)CMPI.B #11,-1(A1,D2.L) ;Source Subr ?⓪)BNE AsComp12⓪)MOVE.L -18(A1,D2.L),D2 ;ja: durch Basetype ersetzen⓪ AsComp12 MOVE.W -2(A1,D0.L),D1 ;Dest-Kennung⓪ ⓪)CMPI.B #44,D1 ;local Proc Type?⓪)BEQ NOTAC22 ; dann passen alle Proc-Types/Procs⓪)CMPI.B #19,D1 ;Proc Type?⓪)BNE NOTAC20 ; nein, dann weiter mit scalaren...⓪)⓪)MOVE.W -2(A1,D2.L),D1 ;Source-Kennung⓪)CMPI.B #44,D1 ;local Proc type?⓪)BEQ NOTAC21 ; dann erstmal OK, Check zur Runtime⓪)CMPI.B #6,D1 ;Procedure?⓪)BNE.W noCompat ;nein -> nicht compatibel⓪)BTST #9,D1 ; nur globale Procs erlaubt⓪)BEQ.W noGlobls⓪ !NOTAC21 JMP AsComp20⓪ !NOTAC22 MOVE.L -10(A1,D0.L),D0 ;bei lok.Proctypes ^19er-Kennung laden⓪)JMP AsComp20⓪ ⓪ noGlobls MOVE #rBdPro,D1⓪)RTS⓪ ⓪ !NOTAC20 CMPI.B #11,D1⓪)BEQ isSub⓪)CMPI.B #12,D1 ;Dest Array ... of Char ?⓪)BNE.L asComp1 ;leider nicht: nicht kompatibel⓪)MOVE.L -14(A1,D0.L),D1 ;Elementtyp holen⓪)CMP.L CharPtr,D1 ;sollte CHAR sein⓪)BEQ.L AsComp10 ;behandeln wie String⓪)BRA.L asComp1 ;bleibt nur Int/Card-Kompat.⓪ ⓪ ; Destination ist Subrange⓪ ⓪ isSub MOVE.L -18(A1,D0.L),D0 ;BaseTyp⓪)BRA asComp1 ;kompatibel?⓪)⓪); Assignment-kompatible Typen:⓪); Aufbau: Source-Kennung, Dest-Kennung⓪)⓪ AsTab ; LONGINT:=⓪)DC.B 22, 1⓪)DC.B 30, 1⓪)DC.B 33, 1⓪)DC.B 34, 1⓪)DC.B 35, 1⓪)DC.B 41, 1⓪); LongBoth:=⓪)DC.B 1, 30⓪)DC.B 22, 30⓪)DC.B 33, 30⓪)DC.B 34, 30⓪)DC.B 35, 30⓪)DC.B 41, 30⓪); LONGCARD:=⓪)DC.B 1, 22⓪)DC.B 30, 22⓪)DC.B 33, 22⓪)DC.B 34, 22⓪)DC.B 35, 22⓪)DC.B 41, 22⓪); INTEGER:=⓪)DC.B 34, 33⓪)DC.B 35, 33⓪)DC.B 41, 33⓪); CARDINAL:=⓪)DC.B 33, 34⓪)DC.B 35, 34⓪)DC.B 41, 34⓪); ShortBoth:=⓪)DC.B 33, 35⓪)DC.B 34, 35⓪)DC.B 41, 35⓪); ADDRESS:=⓪)DC.B 33, 23 ; address := shortint⓪)DC.B 34, 23 ; address := shortcard⓪)DC.B 35, 23 ; address := shortboth⓪); BITNUM:=⓪)DC.B 33, 41 ; BITNUM:= shortint⓪)DC.B 34, 41 ; BITNUM:= shortcard⓪)DC.B 35, 41 ; BITNUM:= shortboth⓪); REALs⓪)DC.B 2, 40⓪)DC.B 40, 2⓪)⓪)DC.W 0⓪)⓪ AsTab2 ; Diese Tabelle erlaubt auch LONG-Types auf SHORT-Types⓪); INTEGER:=⓪)DC.B 1, 33⓪)DC.B 30, 33⓪)DC.B 22, 33⓪); CARDINAL:=⓪)DC.B 1, 34⓪)DC.B 30, 34⓪)DC.B 22, 34⓪); ShortBoth:=⓪)DC.B 1, 35⓪)DC.B 30, 35⓪)DC.B 22, 35⓪); BITNUM:=⓪)DC.B 1, 41 ; BITNUM:= shortint⓪)DC.B 30, 41 ; BITNUM:= shortcard⓪)DC.B 22, 41 ; BITNUM:= shortboth⓪)⓪)DC.W 0⓪)⓪); Kompatibilitaet Int/Card pruefen mit Subrange-Check,⓪); Kompatibilitaet LongInt/Int, LongCard/Card⓪ ⓪ !asComp1 CMP.L D0,D2⓪)BEQ.L isCompat ;DIREKT GLEICH⓪)JSR compat4⓪)BEQ.L isCompat⓪)EXG D0,D2⓪)JSR compat4⓪)EXG D0,D2⓪)BEQ.L isCompat⓪)⓪)MOVE.L Options,D1⓪)BTST #11,D1 ;$K+ ?⓪)BEQ noLongs⓪)⓪)LEA AsTab2(PC),A0⓪)BSR checkTab⓪)BEQ isCompat⓪)⓪ noLongs LEA AsTab(PC),A0⓪)BRA checkTab⓪)⓪ search ADDQ.L #1,A0⓪ checkTab MOVE.B (A0)+,D1⓪)BEQ.L noCompat⓪)CMP.B -1(A1,D2.L),D1⓪)BNE search ;Sourcetyp falsch⓪)MOVE.B (A0),D1⓪)CMP.B -1(A1,D0.L),D1⓪)BNE search ;Desttyp falsch⓪)⓪); Types sind kompatibel⓪)⓪ isCompat CLR.W D1⓪)RTS⓪ ⓪ noCompat MOVEQ #-1,D1⓪)RTS⓪ ⓪ ; Destination ist ARRAY OF CHAR⓪ ⓪ AsComp10 CMPI.B #27,-1(A1,D2.L) ;Source String-Const ?⓪*BEQ AsString3⓪*CMPI.B #12,-1(A1,D2.L) ;Source Array ... of Char ?⓪*BNE noCompat ;leider nicht: nicht kompatibel⓪*MOVE.L -14(A1,D2.L),D1 ;Elementtyp holen⓪*CMP.L CharPtr,D1 ;sollte CHAR sein⓪*BNE noCompat ;keine weiteren Moeglichkeiten⓪*MOVE.L -6(A1,D0.L),D1 ;Dest-Länge holen⓪*CMP.L -6(A1,D2.L),D1 ;Source-Länge abziehen⓪*BEQ isCompat⓪*BRA noCompat⓪ AsString3 MOVE.L -6(A1,D0.L),D1 ;Dest-Länge holen⓪*CMP.L -6(A1,D2.L),D1 ;Source-Länge abziehen⓪*BCC isCompat ;bei Stringconst darf Source auch kleiner sein⓪*MOVE #rSCoOv,D1⓪$END⓪"END asComp;⓪ ⓪ (*⓪!* ALS VARPAR KOMPATIBLE TYPEN (KENNUNGEN):⓪!*)⓪ ⓪ (*$L-*)⓪ PROCEDURE VCTAB;⓪ BEGIN⓪ ASSEMBLER⓪)DC.B 35,33 ;SBOTH/SINT⓪)DC.B 35,34 ;SBOTH/SCARD⓪)DC.B 4,1 ;ZZ/INT⓪)DC.B 4,22 ;ZZ/CARD⓪)DC.B 4,23 ;ZZ/ADR⓪)DC.B 30,1 ;BOTH/INT⓪)DC.B 30,22 ;BOTH/CARD⓪)DC.B 30,23 ;BOTH/ADR⓪)DC.B 23,22 ;ADR/CARD⓪)DC.B 22,23 ;CARD/ADR⓪)DC.B 20,23 ;PTR/ADR⓪)DC.B 23,20 ;ADR/PTR⓪)DC.B 0⓪)SYNC⓪ END⓪ END VCTAB;⓪ ⓪ ⓪ (*$L-*)⓪ PROCEDURE varComp;⓪ BEGIN ASSEMBLER⓪ vc7 CMP.L D0,D2⓪*BEQ.L VarComp5⓪*MOVE.B -1(A1,D0.L),D1 ;DEST KNG⓪*BNE VarComp9⓪*MOVE.L -6(A1,D0.L),D0 ; INZW. NACHDEKLARIERTER OPAQUE⓪*BRA vc7⓪ VarComp9 CMPI.B #27,D1 ;DEST String?⓪*BEQ VarComp6⓪*CMPI.B #19,D1 ;PROC.TYPE?⓪*BNE notAC20⓪*; Daß keine Procs (Kennung 6) als Arg. gehen, wird schon vorher durch⓪*; designator-Aufruf bei VAR-Parms geregelt⓪*JMP AsComp20⓪ notAC20⓪ (* Das läßt PIM3 nicht mehr zu:⓪*CMPI.B #11,-1(A1,D2.L) ;SOURCE SUBR?⓪*BNE VarComp4⓪*MOVE.L -18(A1,D2.L),D2⓪*BRA vc7⓪ *)⓪ VarComp4 MOVEM.L D0/D1/D2,-(A7)⓪*MOVE.B -1(A1,D0.L),D0 ;Dest Kennung⓪*MOVE.B -1(A1,D2.L),D2 ;Source Kennung⓪*CMPI.B #21,D0 ;Word ?⓪*BEQ VarComp8⓪*CMPI.B #38,D0 ;Byte ?⓪*BEQ VarComp8⓪*CMPI.B #26,D0 ;Long ?⓪*BEQ VarComp8⓪*LEA VCTAB,A0⓪ VarComp2 MOVE.B (A0)+,D1⓪*BEQ VarComp1b ;ENDMARKE⓪*CMP.B (A0)+,D0⓪*BNE VarComp2⓪*CMP.B D1,D2⓪*BNE VarComp2⓪*MOVEM.L (A7)+,D0/D1/D2⓪*RTS⓪ ⓪ VarComp1b MOVEM.L (A7)+,D0/D1/D2⓪ VarComp1 ANDI #$00,CCR ;CLEAR ZERO FLAG⓪*RTS⓪ VarComp8 MOVEM.L (A7)+,D0/D1/D2⓪*BRA VarComp3 ;Laengenvergleich⓪ ⓪ VarComp6 CMPI.B #27,-1(A1,D2.L) ;Dest ist String - Source auch ?⓪*BNE VarComp5⓪ VarComp3 MOVE.L -6(A1,D2.L),D1 ;Laenge muss uebereinstimmen!⓪*CMP.L -6(A1,D0.L),D1⓪ VarComp5⓪)END⓪ END varComp;⓪ ⓪ ⓪ (*$L+*)⓪ ⓪"⓪"PROCEDURE CodeSpace;⓪$BEGIN⓪&(*$R-*)⓪&IF LONGCARD (regs [A1]) + LONGCARD (TreSpc) - LONGCARD (regs [rA4]) < $400L THEN⓪(SyntaxError (rSpace)⓪&END⓪&(*$R=*)⓪$END CodeSpace;⓪"⓪"PROCEDURE DataSpace;⓪$BEGIN⓪&IF DataPtr > DataEnd THEN⓪(SyntaxError (rDaSpc)⓪&END⓪$END DataSpace;⓪ ⓪"PROCEDURE OpenScope (t: PtrItem);⓪$VAR (*$Reg*)p: POINTER TO PtrItem;⓪$BEGIN⓪&(* MOVE.L t,-(A6) *)⓪&DEC (regs [A6], 4);⓪&p:= ADDRESS (regs [A6]);⓪&p^:= t⓪$END OpenScope;⓪ ⓪"PROCEDURE CloseScope ();⓪$BEGIN⓪&(* ADDQ.L #4,A6 *)⓪&INC (regs [A6], 4)⓪$END CloseScope;⓪ ⓪"PROCEDURE CodePtr (): ADDRESS;⓪$BEGIN⓪&RETURN ADDRESS (regs [rA4])⓪$END CodePtr;⓪ ⓪"PROCEDURE SetCodePtr (p: ADDRESS);⓪$BEGIN⓪&assert ((p # NIL) & NOT ODD (p));⓪®s [rA4]:= LONGWORD (p)⓪$END SetCodePtr;⓪ ⓪"PROCEDURE GetTextPtr (VAR p: TextPointer);⓪$BEGIN⓪&p.ptr:= ADDRESS (regs [A2]);⓪&p.ofs:= TextOffset⓪$END GetTextPtr;⓪ ⓪"PROCEDURE SetTextPtr (p: TextPointer);⓪$VAR l: LONGCARD;⓪$BEGIN⓪&(*⓪'* Vorsicht⓪'* Das Setzen funktioniert nicht im 'singleLine'-Mode, also beim⓪'* Compile im GME, weil dann die Zeile sicher längst nicht mehr⓪'* vorhanden ist.⓪'*)⓪&SyntaxError (rNImpY);⓪&(*⓪&assert (p.ptr # NIL);⓪&IF p.ofs # TextOffset THEN SyntaxError (rTxtLg) END;⓪®s [A2]:= LONGWORD (p.ptr)⓪&*)⓪$END SetTextPtr;⓪ ⓪"PROCEDURE Entry;⓪$(* Einsprung, bei dem D2/D3 nicht mehr relevant sind *)⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L A1,TreeBase⓪(MOVEM.L D1/D4-D7/A0-A6,regs⓪(LEA CurrentSymbol,A0⓪(MOVE D3,Symbol.itemNo(A0)⓪(MOVE.L D2,Symbol.item(A0)⓪(MOVE.L EvalStk,A3⓪&END⓪$END Entry;⓪$(*$L=*)⓪ ⓪"PROCEDURE Exit;⓪$(* Aussprung, bei dem D2/D3 von CurrentSymbol zurückgegeben werden *)⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(LEA CurrentSymbol,A0⓪(MOVE Symbol.itemNo(A0),D3⓪(MOVE.L Symbol.item(A0),D2⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0-A6⓪&END⓪$END Exit;⓪$(*$L=*)⓪"⓪"PROCEDURE GetSymbol0 (VAR s: Symbol);⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0-A6⓪(JSR GetSbl⓪(MOVEM.L D1/D4-D7/A0-A6,regs⓪(MOVE.L EvalStk,A3⓪(MOVE.L -(A3),A0⓪(MOVE D3,Symbol.itemNo(A0)⓪(MOVE.L D2,Symbol.item(A0)⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪&END⓪$END GetSymbol0;⓪$(*$L=*)⓪ ⓪"PROCEDURE GetSymbol ();⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L #CurrentSymbol,(A3)+⓪(JMP GetSymbol0⓪&END⓪$END GetSymbol;⓪$(*$L=*)⓪ ⓪"PROCEDURE TreeSearch (text: ADDRESS);⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.L -(A3),D0⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0/A1/A2/A3/A4-A6⓪(MOVE.L A2,-(A7)⓪(MOVE.L D0,A2⓪(MOVE.B (A2),D2⓪(JSR TreSrc⓪(MOVE.L (A7)+,A2⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(LEA CurrentSymbol,A0⓪(MOVE D3,Symbol.itemNo(A0)⓪(MOVE.L D2,Symbol.item(A0)⓪(MOVE.L EvalStk,A3⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪&END⓪$END TreeSearch;⓪$(*$L=*)⓪ ⓪"PROCEDURE StatementSequence;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0/A1/A2/A3/A4-A6⓪(JSR StatSeq⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(LEA CurrentSymbol,A0⓪(MOVE D3,Symbol.itemNo(A0)⓪(MOVE.L D2,Symbol.item(A0)⓪(MOVE.L EvalStk,A3⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪&END⓪$END StatementSequence;⓪$(*$L=*)⓪ ⓪"PROCEDURE ConstantFactor (): BOOLEAN;⓪$(* IN/OUT: CurrentSymbol! *)⓪$(* RETURN FALSE: Fehler in Faktor?! *)⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0-A6⓪(LEA CurrentSymbol,A0⓪(MOVE Symbol.itemNo(A0),D3⓪(MOVE.L Symbol.item(A0),D2⓪(JSR ConFact⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(SCC D0⓪(MOVE.L EvalStk,A3⓪(LEA CurrentSymbol,A0⓪(MOVE D3,Symbol.itemNo(A0)⓪(MOVE.L D2,Symbol.item(A0)⓪(ANDI #1,D0⓪ (*$? NOT OptimizedCompile:⓪(MOVE D0,(A3)+⓪ *)⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪&END⓪$END ConstantFactor;⓪$(*$L=*)⓪ ⓪"PROCEDURE SearchLocalItem (VAR tree: PtrItem): BOOLEAN;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.L -4(A3),A0⓪(MOVE.L (A0),D2⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0/A1/A2/A3/A4-A6⓪(MOVE.L D2,-(A7)⓪(JSR FetNoSp⓪(MOVE.B D2,D1⓪(MOVE.L (A7)+,D2⓪(CMP.B -(A2),D1⓪(BEQ ok0⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(MOVE.L EvalStk,A3⓪(MOVE #rFetch,(A3)+⓪(JMP SyntaxError⓪#ok0: JSR LocalSearch⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(SCC D0⓪(ANDI #1,D0⓪(MOVE.L EvalStk,A3⓪(MOVE.L -(A3),A0⓪(MOVE.L D2,(A0)⓪((*$? NOT OptimizedCompile:⓪(MOVE D0,(A3)+⓪(*)⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪&END⓪$END SearchLocalItem;⓪$(*$L=*)⓪ ⓪ (*⓪"PROCEDURE ConstantSet (type: PtrItem);⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.L -(A3),D2⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0/A1/A2/A3/A4-A6⓪(JSR ConSet⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(MOVE.L EvalStk,A3⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪&END⓪$END ConstantSet;⓪$(*$L=*)⓪ *)⓪ ⓪"PROCEDURE CallRuntimeProc (n: CARDINAL);⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.W -(A3),D3⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0/A1/A2/A3/A4-A6⓪(JSR CSP⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(MOVE.L EvalStk,A3⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪(ADDQ.L #1,RelocCount⓪&END⓪$END CallRuntimeProc;⓪$(*$L=*)⓪ ⓪"PROCEDURE AsnComp (left, right: PtrItem): INTEGER;⓪$(* RETURN: 0: OK, >0: errorCode, <0: not compat *)⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.L -(A3),D2 ; right⓪(MOVE.L -(A3),D0 ; left⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0/A1/A2/A3/A4-A6⓪(JSR asComp⓪(MOVE D1,D0⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(MOVE.L EvalStk,A3⓪((*$? NOT OptimizedCompile:⓪(MOVE D0,(A3)+⓪(*)⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪&END⓪$END AsnComp;⓪$(*$L=*)⓪ ⓪"PROCEDURE ExprComp (VAR type: PtrItem; left, right: PtrItem): BOOLEAN;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.L -(A3),D2 ; right⓪(MOVE.L -(A3),D0 ; left⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0/A1/A2/A3/A4-A6⓪(JSR compatRR⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(SEQ D0⓪(ANDI #1,D0⓪(MOVE.L EvalStk,A3⓪(MOVE.L -(A3),A0⓪(MOVE.L D2,(A0)⓪((*$? NOT OptimizedCompile:⓪(MOVE D0,(A3)+⓪(*)⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪&END⓪$END ExprComp;⓪$(*$L=*)⓪ ⓪"PROCEDURE VarComp (left, right: PtrItem): BOOLEAN;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVEM.L D3-D7/A4-A6,-(A7)⓪(MOVE.L -(A3),D2 ; right⓪(MOVE.L -(A3),D0 ; left⓪(MOVE.L A3,EvalStk⓪(MOVEM.L regs,D1/D4-D7/A0/A1/A2/A3/A4-A6⓪(JSR varComp⓪(MOVEM.L D1/D4-D7/A0/A1/A2/A3/A4-A6,regs⓪(SEQ D0⓪(ANDI #1,D0⓪(MOVE.L EvalStk,A3⓪((*$? NOT OptimizedCompile:⓪(MOVE D0,(A3)+⓪(*)⓪(MOVEM.L (A7)+,D3-D7/A4-A6⓪&END⓪$END VarComp;⓪$(*$L=*)⓪ ⓪"PROCEDURE PutCode (d: ARRAY OF WORD);⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(LEA regs,A1⓪(MOVE.L rA4*4(A1),A2⓪(MOVE.W -(A3),D0⓪(MOVE.L -(A3),A0⓪(⓪&luup⓪((*⓪(CMPI #$485F,(A0)⓪(BNE ok0⓪(LINK A5,#0⓪(JSR HALT⓪(UNLK A5⓪(BREAK⓪&ok0⓪(*)⓪(MOVE.W (A0)+,(A2)+⓪(DBRA D0,luup⓪(MOVE.L A2,rA4*4(A1)⓪&END⓪$END PutCode;⓪$(*$L=*)⓪ ⓪"PROCEDURE PutData (d: ARRAY OF WORD);⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L DataPtr,A2⓪(MOVE.W -(A3),D0⓪(MOVE.L -(A3),A0⓪&luup⓪(MOVE.W (A0)+,(A2)+⓪(DBRA D0,luup⓪(MOVE.L A2,DataPtr⓪&END⓪$END PutData;⓪$(*$L=*)⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪"(*⓪#* Auswertung der Symbole & Tree-Daten⓪#*)⓪ ⓪ ⓪"PROCEDURE enterL (p: ADDRESS; offset: INTEGER; v: LONGWORD);⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),D1⓪(MOVE.W -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L D1,0(A0,D0.W)⓪&END⓪$END enterL;⓪$(*$L=*)⓪ ⓪"PROCEDURE enterB (p: ADDRESS; offset: INTEGER; v: BYTE);⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(SUBQ.L #1,A3⓪(MOVE.B -(A3),D1⓪(MOVE.W -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.B D1,0(A0,D0.W)⓪&END⓪$END enterB;⓪$(*$L=*)⓪ ⓪"PROCEDURE entryL (p: ADDRESS; offset: INTEGER): LONGINT;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.W -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪((*$? NOT OptimizedCompile:⓪(MOVE.L 0(A0,D0.W),(A3)+⓪(*)⓪((*$? OptimizedCompile:⓪(MOVE.L 0(A0,D0.W),D0⓪(*)⓪&END⓪$END entryL;⓪$(*$L=*)⓪ ⓪"PROCEDURE entryI (p: ADDRESS; offset: INTEGER): INTEGER;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.W -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪((*$? NOT OptimizedCompile:⓪(MOVE.W 0(A0,D0.W),(A3)+⓪(*)⓪((*$? OptimizedCompile:⓪(MOVE.W 0(A0,D0.W),D0⓪(*)⓪&END⓪$END entryI;⓪$(*$L=*)⓪ ⓪"PROCEDURE entryC (p: ADDRESS; offset: INTEGER): CARDINAL;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.W -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪((*$? NOT OptimizedCompile:⓪(MOVE.W 0(A0,D0.W),(A3)+⓪(*)⓪((*$? OptimizedCompile:⓪(MOVE.W 0(A0,D0.W),D0⓪(*)⓪&END⓪$END entryC;⓪$(*$L=*)⓪ ⓪"PROCEDURE entryB (p: ADDRESS; offset: INTEGER): BYTE;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.W -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪((*$? NOT OptimizedCompile:⓪(MOVE.B 0(A0,D0.W),(A3)+⓪(CLR.B (A3)+⓪(*)⓪((*$? OptimizedCompile:⓪(MOVE.B 0(A0,D0.W),D0⓪(*)⓪&END⓪$END entryB;⓪$(*$L=*)⓪ ⓪ ⓪"(*⓪#* Reg-Var-Verwaltung⓪#*)⓪ ⓪"TYPE VarInfo = (dum0, dum1, dum2, dum3, dum4, dirty, inReg, regVar);⓪'VarSet = SET OF VarInfo;⓪"CONST RegSet = VarSet {dum0..dum4};⓪ ⓪"PROCEDURE IsRegVar (item: PtrItem): BOOLEAN;⓪$BEGIN⓪&RETURN regVar IN VarSet (entryB (item, -15))⓪$END IsRegVar;⓪ ⓪"PROCEDURE IsInReg (item: PtrItem): BOOLEAN;⓪$BEGIN⓪&RETURN inReg IN VarSet (entryB (item, -15))⓪$END IsInReg;⓪ ⓪"PROCEDURE IsInMem (item: PtrItem): BOOLEAN;⓪$BEGIN⓪&RETURN NOT IsInReg (item)⓪$END IsInMem;⓪"⓪"PROCEDURE UsedReg (item: PtrItem): CARDINAL;⓪$BEGIN⓪&RETURN ORD (BYTE (VarSet (entryB (item, -15)) * RegSet))⓪$END UsedReg;⓪"⓪"PROCEDURE SetReg (item: PtrItem; reg: CARDINAL);⓪$VAR (*$Reg*)r: VarSet;⓪$BEGIN⓪&r:= VarSet (entryB (item, -15));⓪&enterB (item, -15, r - RegSet + VarSet (SHORT (WORD (reg))))⓪$END SetReg;⓪"⓪"PROCEDURE MakeRegVar (item: PtrItem);⓪$BEGIN⓪&enterB (item, -15, VarSet (entryB (item, -15)) + VarSet {regVar})⓪$END MakeRegVar;⓪ ⓪"PROCEDURE MakeMemVar (item: PtrItem);⓪$BEGIN⓪&enterB (item, -15, VarSet (entryB (item, -15)) - VarSet {regVar})⓪$END MakeMemVar;⓪"⓪"PROCEDURE UseReg (item: PtrItem);⓪$BEGIN⓪&enterB (item, -15, VarSet (entryB (item, -15)) + VarSet {inReg})⓪$END UseReg;⓪"⓪"PROCEDURE UseMem (item: PtrItem);⓪$BEGIN⓪&enterB (item, -15, VarSet (entryB (item, -15)) - VarSet {inReg})⓪$END UseMem;⓪ ⓪"PROCEDURE IsDirty (item: PtrItem): BOOLEAN;⓪$BEGIN⓪&RETURN dirty IN VarSet (entryB (item, -15))⓪$END IsDirty;⓪ ⓪"PROCEDURE ClearDirt (item: PtrItem);⓪$BEGIN⓪&enterB (item, -15, VarSet (entryB (item, -15)) - VarSet {dirty})⓪$END ClearDirt;⓪ ⓪"PROCEDURE SetDirt (item: PtrItem);⓪$BEGIN⓪&enterB (item, -15, VarSet (entryB (item, -15)) + VarSet {dirty})⓪$END SetDirt;⓪ ⓪"PROCEDURE SetAccessDepth (item: PtrItem; n: CARDINAL);⓪$BEGIN⓪&enterB (item, -16, SHORT (WORD (n)))⓪$END SetAccessDepth;⓪ ⓪"PROCEDURE NewAccessDepth (item: PtrItem; n: CARDINAL);⓪$BEGIN⓪&IF n > ORD (entryB (item, -16)) THEN⓪(enterB (item, -16, SHORT (WORD (n)))⓪&END⓪$END NewAccessDepth;⓪ ⓪ (*$L-*)⓪ ⓪"PROCEDURE Ret6L (item: PtrItem): LONGINT;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L -6(A0),D0⓪&END;⓪$END Ret6L;⓪ ⓪"PROCEDURE Ret10L (item: PtrItem): LONGINT;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L -10(A0),D0⓪&END;⓪$END Ret10L;⓪ ⓪"PROCEDURE Ret14L (item: PtrItem): LONGINT;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L -14(A0),D0⓪&END;⓪$END Ret14L;⓪ ⓪"PROCEDURE AccessDepth (item: PtrItem): CARDINAL;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(CLR.W D0⓪(MOVE.B -16(A0),D0⓪&END;⓪$END AccessDepth;⓪ ⓪"PROCEDURE SetTableLink (item: PtrItem; v: LONGWORD);⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L D0,-10(A0)⓪&END;⓪$END SetTableLink;⓪ ⓪"PROCEDURE LastTableLink (item: PtrItem): LONGINT;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret10L/⓪&END;⓪$END LastTableLink;⓪ ⓪"PROCEDURE SetConstLink (item: PtrItem; v: LONGWORD);⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L D0,-14(A0)⓪&END;⓪$END SetConstLink;⓪ ⓪"PROCEDURE LastConstLink (item: PtrItem): ADDRESS;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret14L/⓪&END;⓪$END LastConstLink;⓪ ⓪"PROCEDURE SetVarLink (item: PtrItem; v: LONGWORD);⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L D0,-14(A0)⓪&END;⓪$END SetVarLink;⓪ ⓪"PROCEDURE LastVarLink (item: PtrItem): LONGINT;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret14L/⓪&END;⓪$END LastVarLink;⓪ ⓪"PROCEDURE SetProcLink (item: PtrItem; v: LONGWORD);⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L D0,-18(A0)⓪&END;⓪$END SetProcLink;⓪ ⓪"PROCEDURE LastProcLink (item: PtrItem): LONGINT;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L -18(A0),D0⓪&END;⓪$END LastProcLink;⓪ ⓪"PROCEDURE IndexType (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret10L/⓪&END;⓪$END IndexType;⓪ ⓪"PROCEDURE ParmType (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret10L/⓪&END;⓪$END ParmType;⓪ ⓪"PROCEDURE FirstParm (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret10L/⓪&END;⓪$END FirstParm;⓪ ⓪"PROCEDURE NextParm (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret6L/⓪&END;⓪$END NextParm;⓪ ⓪"PROCEDURE LocalTree (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret14L/⓪&END;⓪$END LocalTree;⓪ ⓪"PROCEDURE RefType (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret10L/⓪&END;⓪$END RefType;⓪ ⓪"PROCEDURE ElementType (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret14L/⓪&END;⓪$END ElementType;⓪ ⓪"PROCEDURE BaseType (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L -18(A0),D0⓪&END;⓪$END BaseType;⓪ ⓪"PROCEDURE SetBaseType (item: PtrItem; t: PtrItem);⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L D0,-18(A0)⓪&END;⓪$END SetBaseType;⓪ ⓪"PROCEDURE OpenArrayType (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret6L/⓪&END;⓪$END OpenArrayType;⓪ ⓪"PROCEDURE VarParm (item: PtrItem): BOOLEAN;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.W -12(A0),D0⓪&END;⓪$END VarParm;⓪ ⓪"PROCEDURE NoOfElems (item: PtrItem): LONGCARD;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret10L/⓪&END;⓪$END NoOfElems;⓪ ⓪"PROCEDURE LowBound (item: PtrItem): LONGINT;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret10L/⓪&END;⓪$END LowBound;⓪ ⓪"PROCEDURE HighBound (item: PtrItem): LONGINT;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret14L/⓪&END;⓪$END HighBound;⓪ ⓪"PROCEDURE SetItemFlag (item: PtrItem; f:IFS);⓪$BEGIN⓪&ASSEMBLER⓪(SUBQ.L #1,A3⓪(MOVE.B -(A3),D0⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.B D0,-2(A0)⓪&END;⓪$END SetItemFlag;⓪ ⓪"PROCEDURE ParmFlag (item: PtrItem): IFS;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.B -12(A0),D0⓪&END;⓪$END ParmFlag;⓪ ⓪"PROCEDURE ParmToReg (item: PtrItem): BOOLEAN;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(TST.B -11(A0)⓪(SMI D0⓪(ANDI #1,D0⓪&END;⓪$END ParmToReg;⓪ ⓪"PROCEDURE ParmRegNo (item: PtrItem): RegType;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.B -11(A0),D0⓪(ANDI #11111%,D0⓪&END;⓪$END ParmRegNo;⓪ ⓪"PROCEDURE VarAddress (item: PtrItem): LONGINT;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret6L/⓪&END;⓪$END VarAddress;⓪ ⓪"PROCEDURE AnyTypeLength (item: PtrItem): LONGCARD;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret6L/⓪&END;⓪$END AnyTypeLength;⓪ ⓪"PROCEDURE StdProcNo (item: PtrItem): CARDINAL;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.W -4(A0),D0⓪&END;⓪$END StdProcNo;⓪ ⓪"PROCEDURE StdProcParms (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L -8(A0),D0⓪&END;⓪$END StdProcParms;⓪ ⓪"PROCEDURE StdParmType (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret6L/⓪&END;⓪$END StdParmType;⓪ ⓪"PROCEDURE NextStdParm (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret14L/⓪&END;⓪$END NextStdParm;⓪ ⓪"PROCEDURE StdParmRes (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret10L/⓪&END;⓪$END StdParmRes;⓪ ⓪"PROCEDURE FirstRecField (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret10L/⓪&END;⓪$END FirstRecField;⓪ ⓪"PROCEDURE NextRecField (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(JMP Ret14L/⓪&END;⓪$END NextRecField;⓪ ⓪"PROCEDURE NextTagField (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L -18(A0),D0⓪&END;⓪$END NextTagField;⓪ ⓪"PROCEDURE TagFieldList (item: PtrItem): PtrItem;⓪$BEGIN⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L -22(A0),D0⓪&END;⓪$END TagFieldList;⓪ ⓪ (*$L+*)⓪ ⓪"PROCEDURE ItemNo (item: PtrItem): CARDINAL;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(; RETURN ORD (entryB (item, -1))⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVEQ #0,D0⓪(MOVE.B -1(A0),D0⓪((*$? NOT OptimizedCompile:⓪(MOVE.W D0,(A3)+⓪(*)⓪&END⓪$END ItemNo;⓪$(*$L=*)⓪ ⓪"PROCEDURE ItemFlag (item: PtrItem): IFS;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(; RETURN IFS (entryB (item, -2))⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪((*$? NOT OptimizedCompile:⓪(MOVE.B -2(A0),(A3)+⓪(CLR.B (A3)+⓪(*)⓪((*$? OptimizedCompile:⓪(MOVE.B -2(A0),D0⓪(*)⓪&END⓪$END ItemFlag;⓪$(*$L=*)⓪ ⓪"PROCEDURE TypeLength (item: PtrItem): LONGCARD;⓪$(*$L-*)⓪$TYPE itemSet = SET OF [0..47];⓪$BEGIN⓪&(*⓪(n:= ORD (entryB (item, -1));⓪(IF (n IN itemSet {1,2,3,5,8,9,11,12,13,14,19..26,⓪:30,33,34,35,38,39,40,41,4,44,45}) THEN⓪*RETURN LONGCARD (entryL (item, -6))⓪(ELSIF n = 6 THEN⓪*RETURN 4⓪(ELSIF n = 32 (* OPEN ARRAY *) THEN⓪*RETURN $10000⓪(ELSIF n = 42 (* OPEN ARRAY *) THEN⓪*RETURN $FFFFFFFE (* muß gerade sein! *)⓪(ELSE⓪*WriteLn; WriteCard (n, 0); WriteLn;⓪*bong;⓪*RETURN 1⓪(END⓪&*)⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVEQ #0,D0⓪(MOVE.B -1(A0),D0⓪(CMPI.B #60,D0⓪(BCC error⓪(LEA itemTab(PC),A1⓪(TST.B 0(A1,D0.W)⓪(BEQ error⓪(BMI special⓪((*$? NOT OptimizedCompile:⓪(MOVE.L -6(A0),(A3)+⓪(*)⓪((*$? OptimizedCompile:⓪(MOVE.L -6(A0),D0⓪(*)⓪(RTS⓪&itemTab⓪(; {1,2,3,4,5,8,9,11,12,13,14,19..26,30,33,34,35,38,39,40,41,44,45}⓪(DC.B 0,1,1,1,1,1,-1,0,1,1,0,1,1,1,1,0,0,0,0,1⓪(DC.B 1,1,1,1,1,1,1,0,0,0,1,0,-1,1,1,1,0,0,1,1⓪(DC.B 1,1,-1,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0⓪&special⓪(CMPI.B #6,D0⓪(BEQ isProc⓪(CMPI.B #32,D0⓪(BEQ isOpn⓪(CMPI.B #42,D0⓪(BNE error⓪(MOVEQ #-2,D0⓪((*$? NOT OptimizedCompile:⓪(MOVE.L D0,(A3)+⓪(*)⓪(RTS⓪&isOpn⓪((*$? NOT OptimizedCompile:⓪(MOVE.L #$10000,(A3)+⓪(*)⓪((*$? OptimizedCompile:⓪(MOVE.L #$10000,D0⓪(*)⓪(RTS⓪&isProc⓪(MOVEQ #4,D0⓪((*$? NOT OptimizedCompile:⓪(MOVE.L D0,(A3)+⓪(*)⓪(RTS⓪&error⓪(MOVE D0,n⓪(LINK A5,#0⓪&END;⓪&BadId:= 'TypeLength of #';⓪&Append (CardToStr (n, 0), BadId, ok);⓪&scanPrep (2);⓪&appendScanDesc;⓪&SyntaxError (rFatlR)⓪$END TypeLength;⓪$(*$L=*)⓪ ⓪"PROCEDURE SetTypeLength (item: PtrItem; l: LONGCARD);⓪$BEGIN⓪&enterL (item, -6, l)⓪$END SetTypeLength;⓪ ⓪"PROCEDURE BooleanType (item: PtrItem): BOOLEAN;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(; RETURN ADDRESS (item) = BoolPtr⓪(MOVE.L -(A3),D0⓪(CMP.L BoolPtr,D0⓪(SEQ D0⓪(ANDI #1,D0⓪((*$? NOT OptimizedCompile:⓪(MOVE D0,(A3)+⓪(*)⓪&END⓪$END BooleanType;⓪$(*$L=*)⓪ ⓪"PROCEDURE StrConstType (item: PtrItem): BOOLEAN;⓪$(*$L-*)⓪$BEGIN⓪&ASSEMBLER⓪(; RETURN ADDRESS (item) = StrPtr⓪(MOVE.L -(A3),D0⓪(CMP.L StrPtr,D0⓪(SEQ D0⓪(ANDI #1,D0⓪((*$? NOT OptimizedCompile:⓪(MOVE D0,(A3)+⓪(*)⓪&END⓪$END StrConstType;⓪$(*$L=*)⓪ ⓪"PROCEDURE ByteType (item: PtrItem): BOOLEAN;⓪$(*⓪%* Liefert FALSE, wenn Datum keinesfalls auf ungeraden Adressen liegt⓪%*)⓪$(*$L-*)⓪$VAR n: CARDINAL;⓪$TYPE itemSet = SET OF [0..47];⓪$BEGIN⓪&(*⓪(n:= ORD (entryB (item, -1));⓪(IF n = 12 (* ARRAY *) THEN⓪*RETURN TypeLength (ElementType (item)) = 1L⓪(ELSE⓪*RETURN ODD (AnyTypeLength (item))⓪(END⓪&*)⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(CMPI.B #12,-1(A0)⓪(BNE noArray⓪(MOVE.L -14(A0),A0⓪(ADDA.L TreeBase,A0⓪(CMPI.L #1,-6(A0)⓪(SEQ D0⓪(BRA rtn⓪&noArray⓪(BTST #0,-6+3(A0)⓪(SNE D0⓪&rtn⓪(ANDI #1,D0⓪((*$? NOT OptimizedCompile:⓪(MOVE D0,(A3)+⓪(*)⓪&END⓪$END ByteType;⓪$(*$L=*)⓪ ⓪"PROCEDURE HostType (item: PtrItem): PtrItem;⓪$(*$L-*)⓪$BEGIN⓪&(*⓪(IF ORD (entryB (item, -1)) = 11 (* SUBRANGE *) THEN⓪*RETURN PtrItem (entryL (item, -18))⓪(ELSE⓪*RETURN item⓪(END⓪&*)⓪&ASSEMBLER⓪((*$? NOT OptimizedCompile:⓪(MOVE.L -4(A3),A0⓪(ADDA.L TreeBase,A0⓪(CMPI.B #11,-1(A0)⓪(BNE noSubrg⓪(MOVE.L -18(A0),-4(A3)⓪(*)⓪((*$? OptimizedCompile:⓪(MOVE.L -(A3),D0⓪(MOVE.L TreeBase,A0⓪(CMPI.B #11,-1(A0,D0.L)⓪(BNE noSubrg⓪(MOVE.L -18(A0,D0.L),D0⓪(*)⓪&noSubrg⓪&END⓪$END HostType;⓪$(*$L=*)⓪ ⓪"PROCEDURE CharType (item: PtrItem): BOOLEAN;⓪$(*$L-*)⓪$VAR n: CARDINAL;⓪$BEGIN⓪&(*⓪(n:= ORD (entryB (item, -1));⓪(RETURN (n = 3 (* CHAR *))⓪,(* geht nicht wg. TypeLength:⓪.OR (n = 27) (* SS-Type *) & (TypeLength (item) = 1L)⓪,*)⓪&*)⓪&ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(CMPI.B #3,-1(A0)⓪(SEQ D0⓪(ANDI #1,D0⓪((*$? NOT OptimizedCompile:⓪(MOVE D0,(A3)+⓪(*)⓪&END⓪$END CharType;⓪$(*$L=*)⓪ ⓪ ⓪ (*$Z-*)⓪ PROCEDURE fatalError (no: INTEGER; msg: ARRAY OF CHAR; causer: ErrResp;⓪6cont: RtnCond; VAR excData: ExcDesc ): BOOLEAN;⓪ (*$Z=*)⓪"VAR ok: BOOLEAN; foldConst: BOOLEAN;⓪"BEGIN⓪$foldConst:= FALSE;⓪$IF ~SignalOverflow & (no = Overflow) THEN⓪&HasOverflown:= TRUE;⓪&RETURN FALSE⓪$ELSIF FoldingConst⓪$AND ( (no = DivByZero) OR⓪*(no = OutOfRange) OR⓪*(no = Overflow) ) THEN⓪&(* normalen Fehler melden während Constant-Folding *)⓪&(* Versuchsweise ignorieren, wenn SuppressCode = TRUE,⓪'* damit "TRUE OR (1/0)" keinen Fehler bringt. *)⓪&IF SuppressCode THEN⓪(RETURN FALSE⓪&END;⓪&foldConst:= TRUE⓪$END;⓪$IF msg[0] = '' THEN⓪&GetErrorMsg (no, BadId)⓪$ELSE⓪&Assign (msg, BadId, ok)⓪$END;⓪$IF foldConst THEN⓪&(* normalen Fehler (kein interner Fehler) melden während Constant-Folding *)⓪&HaltOnError:= FALSE;⓪&SyntaxError (rCExpr)⓪$END;⓪$(* wenn hier Backtrace mögl. sein soll, darf kein HALT ausgelöst werden,⓪%* weil dann >Laufzeitfehler während Deinit< auftritt. Stattdessen⓪%* hier selbst GEMScan aufrufen *)⓪$errorMsg:= ' Interner Fehler! ';⓪$WITH globalScan DO⓪&pc:= excData.regPC;⓪&link:= excData.regA5.ad;⓪&stack:= excData.regUSP⓪$END;⓪$scanPrep (0);⓪$IF HaltOnError THEN⓪&scanner;⓪&IF 2 IN GetKBShift () THEN (* ignore error *) RETURN FALSE END;⓪&HaltOnError:= FALSE;⓪$ELSE⓪&appendScanDesc;⓪$END;⓪$SyntaxError (rFatlR);⓪$RETURN TRUE⓪"END fatalError;⓪ ⓪ VAR wsp: MemArea;⓪ ⓪ PROCEDURE Tracer;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(CMPI.W #$FFFF,ZZTyp⓪(SNE D0⓪$END⓪"END Tracer;⓪"(*$L=*)⓪ ⓪ BEGIN⓪"(*⓪#* Und nun für alle Fälle die Laufzeitfehler abfangen.⓪#*)⓪"wsp.bottom:= ADR (HdlErrorStack);⓪"wsp.length:= SIZE (HdlErrorStack);⓪"ok:= CatchErrors (fatalError, wsp);⓪"⓪"ASSEMBLER⓪(LEA Tracer,A0⓪(; BREAK⓪"END;⓪ END MM2Comp3;⓪ ⓪ ⓪ VAR FP: ARRAY [F0..F7],BOOLEAN,[0..5] OF CHAR;⓪$ASM: ARRAY [0..11] OF CHAR;⓪ ⓪ CONST⓪ ⓪$SizeOfLongReal = 8;⓪$SizeOfShortReal = 4;⓪$⓪$⓪$LADD = 7;⓪$LSUB = 8;⓪$LMUL = 11;⓪$LDIV = 14;⓪$LREQ = 0;⓪$LRNE = 1;⓪$LRLE = 2;⓪$LRGE = 3;⓪$LRLT = 4;⓪$LRGT = 5;⓪$LNEG = 6;⓪$LABS = 91;⓪$⓪$SNEG = 92;⓪$SABS = 93;⓪$SADD = 94;⓪$SSUB = 95;⓪$SMUL = 96;⓪$SDIV = 97;⓪$SRLE = 98;⓪$SRGE = 99;⓪$SRLT = 100;⓪$SRGT = 101;⓪$⓪$RXPD = 24;⓪$RSHT = 25;⓪$⓪$FNUL = 18; (* Float-Operation ohne <ea>, opcode in D0 *)⓪$FOPS = 26; (* Float-Operation mit <ea>.S in D1, opcode in D0 *)⓪$FOPD = 27; (* Float-Operation mit <ea>.D in (A0), opcode in D0 *)⓪$FMVS = 85; (* Float-Move <ea>.S nach (A0), opcode in D0 *)⓪$FMVD = 86; (* Float-Move <ea>.D nach (A0), opcode in D0 *)⓪$⓪$FCPN = 87; (* Float-Operation & Bcc (D2) ohne <ea>, opcode in D0 *)⓪$FCPS = 88; (* Float-Operation & Bcc (D2) mit <ea>.S in D1, opcode in D0 *)⓪$FCPD = 89; (* Float-Operation & Bcc (D2) mit <ea>.D in (A0), opcode in D0 *)⓪$⓪$(* diverse Push/Pop-Operationen für FPU-Reals *)⓪$FP7S = 113;⓪$FP7D = 114;⓪$FP3S = 115;⓪$FP3D = 116;⓪$FG7S = 117;⓪$FG7D = 118;⓪$FG3S = 119;⓪$FG3D = 120;⓪$FP7M = 121;⓪$FG7M = 122;⓪$⓪$SINCL= 22;⓪$SEXCL= 23;⓪$SIRG = 110;⓪$SMEM = 28;⓪$SEQU = 29;⓪$SNEQ = 30;⓪$SLEQ = 31;⓪ ⓪$IMLW = 50;⓪$CMLW = 51;⓪$IMLL = 56;⓪$CMLL = 57;⓪$IDVL = 58;⓪$CDVL = 59;⓪$IMDL = 60;⓪$CMDL = 61;⓪$⓪$PS3B = 62;⓪$PS3W = 63;⓪$PS3L = 64;⓪$PS7B = 65;⓪$PS7W = 66;⓪$PS7L = 67;⓪$⓪$CWOP = 111;⓪$CLOP = 112;⓪$⓪$COPYW= 68;⓪$COPYL= 69;⓪$⓪$CAPI = 70;⓪$LENW = 71;⓪$LENL = 72;⓪ ⓪$LC2S = 102;⓪$LI2S = 103;⓪$LC2D = 104;⓪$LI2D = 105;⓪$S2LC = 106;⓪$S2LI = 107;⓪$D2LC = 108;⓪$D2LI = 109;⓪ ⓪$CMP8 = 43; (* RES1 *)⓪ ⓪$SAND = 73;⓪$SXOR = 74;⓪$SSUM = 75;⓪$SDIF = 76;⓪$(* Es folgen zwei weitere 4er-Blöcke mit den selben Set-Operatoren *)⓪$⓪$ROTA = 123;⓪$SHFT = 124;⓪ ⓪ ⓪ VAR⓪"GlobalA7Hidden, LocalA7Hidden: BOOLEAN;⓪"LocalA7WhenHidden: LONGINT;⓪ ⓪ PROCEDURE coding (): BOOLEAN;⓪"BEGIN⓪$IF InConstExpr THEN SyntaxError (rConXp) ELSE RETURN NOT SuppressCode END⓪"END coding;⓪ ⓪ PROCEDURE activateCodeSuppression (VAR last: BOOLEAN);⓪"BEGIN⓪$last:= SuppressCode;⓪$SuppressCode:= TRUE⓪"END activateCodeSuppression;⓪ ⓪ PROCEDURE restoreCodeSuppression (last: BOOLEAN);⓪"BEGIN⓪$SuppressCode:= last⓪"END restoreCodeSuppression;⓪ ⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ CONST⓪"strConstSize = constBufSize-1;⓪ ⓪ ⓪ TYPE⓪ ⓪ (*$? CompileWithNewCompiler:⓪"LongREAL = LONGREAL;⓪"ShortREAL = REAL;⓪ *)⓪ (*$? CompileWithOldCompiler:⓪"LongREAL = LONGREAL;⓪"ShortREAL = LONGINT;⓪ *)⓪ ⓪"RR = ARRAY [0..1] OF LONGWORD; (* quasi ZZ-Type für Reals *)⓪"SR = ARRAY [0..0] OF LONGWORD;⓪ ⓪ ⓪"convBits = (signChange, expand, shorten, signedConv, realConv,⓪.procShorten, procExpand, subCheck);⓪"convSet = SET OF convBits;⓪ ⓪"ConvDesc = RECORD⓪/boundsCheck: BOOLEAN;⓪/signedBounds: BOOLEAN;⓪/boundSize: CARDINAL;⓪/lowerBound, upperBound: LONGWORD;⓪/sizeFlags: convSet;⓪/sourceSize, destSize: CARDINAL;⓪/destType: PtrItem;⓪-END;⓪"⓪"Directions = (noDir, up, down);⓪ ⓪"Operator = (add, sub, mul, div, rdiv, mod, rem, or, and,⓪.lt, eq, gt, ge, le, ne, cc, pl, vc, in);⓪"OpSet = SET OF Operator;⓪"Relation = [lt..gt];⓪ ⓪"BS = SET OF [0..7];⓪"ShortSet = SET OF [0..31];⓪"LongSet = SET OF [0..(constBufSize * 8 -1)];⓪"FullSet = SET OF [0..MaxCard];⓪"PtrSet = POINTER TO BS;⓪"PtrFullSet = POINTER TO FullSet;⓪ ⓪"PtrStr = POINTER TO CHAR;⓪ ⓪"ItemSet = SET OF [0..63];⓪ ⓪"Label = ADDRESS;⓪"ZZ = RECORD⓪/over: BOOLEAN;⓪/CASE : CARDINAL OF⓪/| 0: b3: INTEGER; b1: BYTE; b: BYTE;⓪/| 1: c2: CARDINAL; c: CARDINAL;⓪/| 2: i2: INTEGER; i: INTEGER;⓪/| 3: v: LONGINT;⓪/| 4: l: LONGCARD⓪/END;⓪-END;⓪ ⓪"LW = LONGWORD;⓪"⓪"ConstValue = RECORD⓪1(*⓪2* Alle Daten sind rechtsbündig (constBufSize Byte)!⓪2*)⓪1CASE : CARDINAL OF⓪30: lw:ARRAY [0..1] OF LW|⓪39: d0:LW;b4,b3,b2:BYTE; ch: CHAR|⓪31: d8:LW;b5,b6,b7:BYTE; b: BYTE|⓪32: d1:LW;w2:WORD; w: WORD|⓪34: d2:LW; l: LONGWORD|⓪35: d4:WORD; zz: ZZ|⓪36: d5:LW; ss: ShortSet|⓪37: ws: LongSet|⓪33: d7:LW; sr: SR|⓪211: rr: RR|⓪210: str: ARRAY [0..strConstSize] OF CHAR;⓪1END⓪/END;⓪ ⓪ ⓪"ExprKind = (unused, jmp, condFlags, constant, constRef, constImm,⓪.register, memory, stack, spilledSP);⓪ ⓪"MemModes = (extL, relConst, pcRel, relRef, immRef, absRef,⓪.(* der Rest sind nur indir. Adr-Arten (wg. 'indir'-Routine): *)⓪.d16An, d8AnXn, ptrOnA3, ptrOnA7);⓪#(*⓪$* 'ptrOnA3/A7': ist eigentlich der Modus 'd16n', das Base-Reg steht⓪$* jedoch temporär auf dem Stack. Wird dort z.B. bei Proc-Aufruf hingeladen.⓪$* Nach Proc-Aufruf muß vor einem 'gen...'-Aufruf der Wert in ein⓪$* Base-Reg zurückgeladen werden, weil es sonst zum Deadlock kommen könnte.⓪$*)⓪ ⓪#(*⓪$* In 'ExprDesc' wird die Adressierung beschrieben, mit der ohne⓪$* Weiteres auf das Datum (typ in 'item') zugegriffen werden kann.⓪$* Also sind alle Zugriffswege bis auf den letzten, der das Datum⓪$* überträgt, schon codiert.⓪$*⓪$* 'register' kommt nur bei Scalaren, SETs (<=32 Elems) und Reals vor,⓪$* jedoch nicht bei strukturierten Typen, denn nur sie werden überhaupt in⓪$* Regs benötigt, um Operationen mit ihnen zu machen. Für die Float-Register⓪$* werden die Regs des 68881 oder entsprechender Runtime-Variablen verwendet.⓪$* Im letzteren Fall wird trotzdem so getan, als stünden sie in den echten⓪$* FFP-Regs - erst die Code-generierenden Routinen erzeugen dann doch⓪$* den Speicher-Zugriff.⓪$* Einziger Fall, wo dies schwieriger ist, sind große Sets. Sie können⓪$* bei Operationen nicht in Registern zwischengespeichert werden, sondern⓪$* müssen auf den A3-Stack. Deshalb muß bei den Set-Operationen eine⓪$* Sonderauswertung für die Stack-Ablage vorgenommen werden. Schade ist⓪$* nur, daß dadurch immer schon eine Kopie auf den Stack kommt, obwohl⓪$* vielleicht danach sofort eine Zuweisung kommt, so daß das gleich hätte⓪$* kombiniert werden können.⓪$* Die restlichen Typen passen immer in ein Register (ggf. die Pseuso-Real-⓪$* Regs) und können somit auch von überall, also auch vom A3-Stack, direkt⓪$* ohne Sonderbehandlung geladen werden. Bei Long-Reals muß lediglich das⓪$* Umladen von einer Var/dem Stack zu den Pseudo-Regs (und umgekehrt)⓪$* sonderbehandelt werden. Dies wird wohl auch bei den Real-Operationen⓪$* direkt berücksichtigt.⓪$*⓪$* Neben den Operationen sind nur noch Zuweisungen größerer Datentypen⓪$* möglich. Für diesen Fall, besonders beim Laden vom A3-Stack, wird⓪$* Sorge getragen in 'moveTo'.⓪$*⓪$* Einfache Variablen bis 32 Bit sind meist mit 'memory' beschrieben.⓪$*⓪$* mode = 'immRef' wird für Adressen von globalen Variablen und Prozeduren⓪$* verwendet. Sie müssen reloziert werden und sind daher immer Long.⓪$* Sie dürfen nicht als Konstante ausgewertet und dann durch⓪$* constantFold bei einer Adreß-Differenz wegoptimiert werden,⓪$* sondern müssen letztendlich unbedingt im Code erscheinen, weil⓪$* sonst Fehler durch optimiertes Linken entstehen könnten.⓪$* Adr. von lokalen Procs sind ja auch quasi Konstanten, weshalb sie⓪$* nicht mit 'relRef' gekennzeichnet werden dürfen. Stattdessen wird⓪$* dann 'relConst' verwendet. Diese Adressierung ist allerdings bei⓪$* der 68000 nicht vorgesehen, weshalb sie bei Zugriff ggf. durch⓪$* einen LEA-Befehl und der 'relRef'-Adressierung zu ersetzen ist.⓪$*⓪$* Adressen von relativen Variablen werden gleich in ein Register geladen,⓪$* während relative Code-Adressen mit mode = 'pcRel' (ohne Relozieren)⓪$* oder 'relRef' (mit Relozieren) gekennzeichnet werden.⓪$*⓪$* Daten können NIEMALS als Wert/Referenz einer Expression auf dem⓪$* A7-Stack stehen! Der dient lediglich zum Retten bei 'spillReg'⓪$* und bei der Parameterübergabe.⓪$*⓪$* Andererseits können Werte aber schon auf dem A3-Stack stehen,⓪$* so daß dies bei Zuweisungen und anderen Operationen beachtet⓪$* werden muß (dazu dient 'bothOnStack')!⓪$*⓪$* Große SET- (und solche mit neg. Lowbound oder Highbound > 31) und⓪$* String-Literals werden immer im DATA-Puffer abgelegt und mit⓪$* kind = 'constRef' gekennzeichnet.⓪$* SET-Literals können aber wieder gekürzt werden, falls sie durch⓪$* constantFold zusammengefaßt werden. Allerdings bleibt letztendlich⓪$* immer eine Konstante im Code zurück. Bei Const-Expression werden⓪$* sie daher wie Prozeduren angelegt, so daß auf sie mehrfach zugegriffen⓪$* werden kann und vom Linker korrekt behandelt/reloziert/entfernt⓪$* werden können.⓪$*&&& offen ist noch, wie genau die einbindung stattfindet: es muß schon⓪$* im Deklarationsteil (CONST) der Code abgelegt werden, und zwar⓪$* je nach Tiefe global oder lokal. bei lokalen muß gesichert sein,⓪$* daß der bereich schon zur proc gehört, so daß er nicht vom linker⓪$* falsch wegoptimiert wird, bei globalen muß überlegt werden, ob bei⓪$* aktiver $M-option die verkettung mitgeführt werden muß, außerdem⓪$* muß wie bei glob. procs die längenliste mit aufgebaut werden.⓪$*⓪$* 'ExprDesc.varItem': Zeigt auf die Item-Beschreibung der Variablen⓪$* oder Konstante.⓪$* Kann z.B. verwendet werden, um Reg-Var zu markieren oder⓪$* ref-Flag zum Schreibschutz zu setzen.⓪$* Ist bei 'kind=constant' 'varItem=NIL', dann bedeutet dies,⓪$* daß die Konst als Konstruktor zusammengesetzt wurde, aber noch⓪$* nicht im Code sondern nur in 'exprConst' vorliegt -> sie muß⓪$* dann noch im Data-Puffer abgelegt werden, falls sie referenziert⓪$* werden soll.⓪$*⓪$* Werden Daten auf die Stacks (A3, A7) geladen, werden entsprechend die⓪$* glob. Vars 'A7Offset' & 'A3Offset' angepaßt. In 'ExprDesc.stackPtr'⓪$* kann dann ggf. der Stack-Offset gesichert werden, so daß, wenn später⓪$* auf die Werte auf dem Stack zugegriffen werden soll (z.B. bei WITH-⓪$* Pointern), aus der Differenz zum aktuellen A3/7Offset ein direkter⓪$* Zugriff erfolgen kann. Das Erhöhen/Erniedrigen von A3/7Offset geschieht⓪$* generell in den Low-Level-Codegen-Routinen (gen...). Allerdings ist⓪$* zu beachten, daß dann teilweise die Werte nicht angepaßt werden, so⓪$* z.B., wenn eine Runtime-Routine den Wert verändert. Auch muß aufge-⓪$* paßt werden, wenn die Werte nach 'stackPtr' gesichert werden: Es darf⓪$* erst definiert vor/nach dem Codegen-Aufruf geschehen und bei A3 muß die⓪$* Typlänge ggf. noch abgezogen werden. Bei Proc-Calls wird ja ggf. schon⓪$* im Voraus der SP (A7) für alle Parms erniedrigt, was ebenso zu beachten⓪$* ist.⓪$*)⓪ ⓪"ExprDesc = RECORD⓪/item: PtrItem; (* Beschreibt TYPE des Datums *)⓪/CASE : CARDINAL OF⓪/0: exprSize: LONGCARD| (* z.Zt. nur bei ItemNo 27 & 43 benutzt *)⓪/1: not: BOOLEAN| (* Nur bei Booleans verwendet *)⓪/2: regset: BOOLEAN; (* Nur SETs: Bit-Ordnung wie in Reg *)⓪2zerobased: BOOLEAN| (* Nur SETs: Kein lowbound-Abzug *)⓪/3: highReg: RegType; (* Open Array: ^ auf High-Wert *)⓪2highOfs: INTEGER; (* Open Array: Offs. High-Wert zum ^ *)⓪/END;⓪/typeChecked: BOOLEAN;⓪/regVar: BOOLEAN; (* TRUE: Expr kann in Reg liegen *)⓪/readOnly: BOOLEAN; (* TRUE: Var ist z.B. REF-Parm *)⓪/varItem: PtrItem; (* ^Var/Const/Proc-Beschreibung *)⓪/constHead: ADDRESS; (* Adr. d. Konst. im DATA-Puffer *)⓪/CASE kind: ExprKind OF⓪/| jmp:⓪/| constImm,⓪1constRef: (* 'varItem' zeigt auf CONST-Eintrag im Tree *⓪<* oder ist NIL, wenn Datum im DATA-Puffer liegt *)⓪;(* wenn varItem#NIL, ist constHead=NIL und umgekehrt! *)⓪;constOfs: LONGCARD; (* Ofs. zu Konst-Beginn *)⓪;constAddr: ADDRESS; (* Adr. im DATA-Puffer *)⓪;(* constHead nicht hier einfügen, weil es auch⓪<* vorkommt, daß constHead zum Relozieren benötigt⓪<* wird, wenn bereits kind<>constRef ist. *)⓪/| constant: (* auch bei SET bis 4 Byte *)⓪;(* & Strings <= constBufSize Zeichen *)⓪;exprConst: ConstValue;⓪/| condFlags:relOp: Operator;⓪;signed: BOOLEAN;⓪;fpuFlags: BOOLEAN;⓪/| register: exprReg: RegType;⓪/| memory: mode: MemModes;⓪;mayBeOdd: BOOLEAN; (* FALSE: MOVE.W bei Byte-Daten *)⓪;baseReg, idxReg: RegType;⓪;idxL: BOOLEAN; (* TRUE: idxReg ist .L *)⓪;CASE : CARDINAL OF⓪;|1: tiefe: CARDINAL; (* für Procs *)⓪;|2: extAddr: ADDRESS (* bei 'extL' *)⓪;|3: disp: LONGINT; (* bei 'd16An', 'd8AnXn' *)⓪;|4: depth: LONGINT; (* bei 'ptrOnA3/A7' *)⓪;|5: absAddr: ADDRESS; (* bei 'pcRel' *)⓪;END;⓪/| stack,⓪1spilledSP:spillReg: RegType; (* nur bei 'spilledSP' *)⓪;spillOfs: LONGINT; (* n.b. spilledSP: A3/A7 *)⓪;stackReg: RegType;⓪;up: BOOLEAN; (* FALSE bei A7, sonst TRUE *)⓪;stackedSize: LONGCARD; (* Platz v. Datum auf Stack *)⓪;restoreAfterUse: LONGCARD; (* Freigeben bei dealloc*)⓪;stackPtr: LONGINT; (* SP-Offset bei Push *)⓪/END;⓪-END;⓪ ⓪"NumberSize = (unspecSize, ord2, ord4, real4, real8);⓪"NumberType = (unspecType, realType, intType, cardType, bothType);⓪ ⓪ ⓪ CONST⓪"maxDepth = 99;⓪ ⓪ TYPE ExprSP = [-1..maxDepth];⓪ ⓪ VAR⓪"exprStack : ARRAY [0..maxDepth] OF RECORD⓪0expr: ExprDesc;⓪0maySpill: BOOLEAN (* FALSE: nicht auf den Stack laden *)⓪.END;⓪"exprSp : ExprSP; (* -1 means empty *)⓪"spillSp : ExprSP; (* everything below that doesn't use a reg *)⓪"spilling : BOOLEAN; (* prevents recursion *)⓪"spillDestReg: RegType; (* dies ist der Ziel-Stack *)⓪"spillDestDir: Directions;(* und das seine Richtung *)⓪"helpExpr2, helpExpr: ExprDesc;⓪ ⓪ ⓪ PROCEDURE Size (REF expr: ExprDesc): LONGCARD;⓪"(*⓪#* Liefert Größe des Datums⓪#*)⓪"(*$L-*)⓪"BEGIN⓪$(*⓪&IF (expr.item = SSTyp) OR (expr.item = UndefTyp) THEN⓪(RETURN expr.exprSize⓪&ELSE⓪(RETURN TypeLength (expr.item)⓪&END⓪$*)⓪$ASSEMBLER⓪(MOVE.L -(A3),A0⓪(MOVE.L ExprDesc.item(A0),D0⓪(CMP.L SSTyp,D0⓪(BEQ ok⓪(CMP.L UndefTyp,D0⓪(BEQ ok⓪(MOVE.L D0,(A3)+⓪ (*$? OptimizedCompile:⓪(JMP TypeLength/⓪%ok MOVE.L ExprDesc.exprSize(A0),D0⓪ *)⓪ (*$? NOT OptimizedCompile:⓪(JMP TypeLength⓪%ok MOVE.L ExprDesc.exprSize(A0),(A3)+⓪ *)⓪$END⓪"END Size;⓪"(*$L=*)⓪ ⓪ ⓪ PROCEDURE XOR (a,b: BOOLEAN): BOOLEAN;⓪"BEGIN⓪$RETURN a AND NOT b OR b AND NOT a⓪"END XOR;⓪ ⓪ (*$? Test:⓪ PROCEDURE showZZ (zz: ZZ);⓪"BEGIN⓪$InOut.WriteLn;⓪$IF zz.over THEN⓪&InOut.WriteCard (zz.l, 0);⓪$ELSE⓪&InOut.WriteInt (zz.v, 0)⓪$END;⓪$InOut.WriteLn;⓪"END showZZ;⓪ ⓪ PROCEDURE writeReg (r: RegType);⓪"BEGIN⓪$IF r >= F0 THEN⓪&InOut.Write ('F')⓪$ELSIF r >= A0 THEN⓪&InOut.Write ('A')⓪$ELSE⓪&InOut.Write ('D')⓪$END;⓪$InOut.WriteCard (r MOD 8, 1);⓪"END writeReg;⓪ ⓪ PROCEDURE showRegs (regs: RegSet; set: BOOLEAN; txt: ARRAY OF CHAR);⓪"VAR r: RegType;⓪"BEGIN⓪$InOut.WriteLn;⓪$InOut.WriteString (txt);⓪$FOR r:= MIN (RegType) TO MAX (RegType) DO⓪&IF XOR (NOT set, r IN regs) THEN⓪(writeReg (r);⓪(InOut.WriteString (' ')⓪&END⓪$END;⓪$InOut.WriteLn;⓪"END showRegs;⓪ ⓪ PROCEDURE showExpr (REF expr: ExprDesc);⓪"VAR ch: CHAR; i: CARDINAL;⓪"BEGIN⓪$InOut.WriteLn;⓪$InOut.WriteString ('A3Offset: ');⓪$InOut.WriteInt (A3Offset, 0);⓪$InOut.WriteString (' // A7Offset: ');⓪$InOut.WriteInt (A7Offset, 0);⓪$InOut.WriteLn;⓪$InOut.WriteString ('itemNo: ');⓪$InOut.WriteCard (ItemNo (expr.item), 2);⓪$InOut.WriteString (', size: ');⓪$InOut.WriteCard (Size (expr), 0);⓪$InOut.WriteString (', varItem: ');⓪$InOut.WriteLHex (expr.varItem, 9);⓪$InOut.WriteString (', constHead: '); InOut.WriteLHex (expr.constHead, 7);⓪$InOut.WriteLn;⓪$⓪$WITH expr DO⓪&InOut.WriteString ('kind: ');⓪&CASE kind OF⓪&| jmp: InOut.WriteString ('jmp.');⓪&| constRef: InOut.WriteString ('constRef.');⓪2InOut.WriteString ('constOfs: '); InOut.WriteCard (constOfs, 0); InOut.WriteLn;⓪2InOut.WriteString ('constAddr: '); InOut.WriteLHex (constAddr, 7); InOut.WriteLn;⓪&| constant: InOut.WriteString ('constant.'); InOut.WriteLn;⓪2InOut.WriteString ('exprConst: ');⓪2IF BooleanType (item) THEN⓪4IF BOOLEAN (exprConst.w) THEN InOut.WriteString ('TRUE'); ELSE InOut.WriteString ('FALSE'); END;⓪2ELSIF item = SSTyp THEN⓪4FOR i:= 0 TO strConstSize DO⓪6InOut.Write (exprConst.str [i])⓪4END⓪2ELSIF exprConst.zz.over THEN⓪4InOut.WriteCard (exprConst.zz.l, 0);⓪2ELSE⓪4InOut.WriteInt (exprConst.zz.v, 0)⓪2END;⓪&| condFlags:InOut.WriteString ('condFlags.');⓪2(* relOp signed *)⓪&| register: InOut.WriteString ('register.'); InOut.WriteLn;⓪2InOut.WriteString ('exprReg: '); writeReg (exprReg);⓪&| memory: InOut.WriteString ('memory.'); InOut.WriteLn;⓪2InOut.WriteString ('mode: ');⓪2CASE mode OF⓪2| relConst, absRef, immRef, relRef:⓪4CASE mode OF⓪4|relConst: InOut.WriteString ('relConst.');⓪4|absRef: InOut.WriteString ('absRef.');⓪4|immRef: InOut.WriteString ('immRef.');⓪4|relRef: InOut.WriteString ('relRef.')⓪4END;⓪4InOut.WriteLn;⓪4InOut.WriteString ('tiefe: '); InOut.WriteCard (tiefe, 0);⓪2|d16An, d8AnXn:⓪4IF mode = d16An THEN⓪6InOut.WriteString ('d16An.')⓪4ELSE⓪6InOut.WriteString ('d8AnXn.')⓪4END;⓪4InOut.WriteLn;⓪4InOut.WriteString ('disp: '); InOut.WriteInt (disp, 0); InOut.WriteLn;⓪4InOut.WriteString ('baseReg: '); writeReg (baseReg);⓪4IF mode = d8AnXn THEN⓪6InOut.WriteLn;⓪6InOut.WriteString ('idxReg: '); writeReg (idxReg); InOut.WriteLn;⓪6InOut.WriteString ('idxL: '); IF idxL THEN InOut.WriteString ('TRUE'); ELSE InOut.WriteString ('FALSE'); END;⓪4END;⓪2|extL:⓪4InOut.WriteString ('extL.')⓪4(* extAddr *)⓪2|ptrOnA3:⓪4InOut.WriteString ('ptrOnA3.')⓪4(* depth *)⓪2|ptrOnA7:⓪4InOut.WriteString ('ptrOnA7.')⓪4(* depth *)⓪2|pcRel:⓪4InOut.WriteString ('pcRel.')⓪4(* absAddr *)⓪2ELSE⓪4InOut.WriteString ('???')⓪2END;⓪2InOut.WriteLn;⓪2InOut.WriteString ('mayBeOdd: '); IF mayBeOdd THEN InOut.WriteString ('TRUE'); ELSE InOut.WriteString ('FALSE'); END;⓪&| stack,⓪(spilledSP:IF kind = stack THEN⓪4InOut.WriteString ('stack.'); InOut.WriteLn;⓪2ELSE⓪4InOut.WriteString ('spilledSP.'); InOut.WriteLn;⓪4InOut.WriteString ('spillReg: '); writeReg (spillReg); InOut.WriteLn;⓪2END;⓪2InOut.WriteString ('stackReg: '); writeReg (stackReg); InOut.WriteLn;⓪2InOut.WriteString ('up: '); IF up THEN InOut.WriteString ('TRUE'); ELSE InOut.WriteString ('FALSE'); END; InOut.WriteLn;⓪2InOut.WriteString ('stackPtr: '); InOut.WriteInt (stackPtr, 0); InOut.WriteLn;⓪2InOut.WriteString ('stackedSize: '); InOut.WriteCard (stackedSize, 0);⓪2(* restoreAfterUse *)⓪&ELSE⓪(InOut.WriteString ('???')⓪&END;⓪$END;⓪$InOut.WriteLn;⓪$IF BooleanType (expr.item) THEN⓪&IF expr.not THEN⓪(InOut.WriteString ('not = TRUE!'); InOut.WriteLn;⓪&END;⓪$ELSIF (ItemNo (expr.item) = 5) OR (ItemNo (expr.item) = 5) THEN⓪&InOut.WriteString ('SET:'); InOut.WriteLn;⓪&IF NOT expr.typeChecked THEN⓪(InOut.WriteString (' not typeChecked!'); InOut.WriteLn;⓪&ELSE⓪(IF expr.regset THEN⓪*InOut.WriteString (' regset'); InOut.WriteLn;⓪(END;⓪(IF expr.zerobased THEN⓪*InOut.WriteString (' zerobased'); InOut.WriteLn;⓪(END⓪&END⓪$END;⓪$⓪$InOut.Read (ch)⓪"END showExpr;⓪ ⓪ PROCEDURE showExprStack;⓪"VAR ch: CHAR; c: ExprSP;⓪"BEGIN⓪$InOut.WriteLn;⓪$InOut.WriteString ('** exprStack Begin **'); InOut.WriteLn;⓪$c:= exprSp;⓪$WHILE c >= 0 DO⓪&showExpr (exprStack[c].expr);⓪&DEC (c)⓪$END;⓪$InOut.WriteString ('** exprStack End **'); InOut.WriteLn;⓪$InOut.Read (ch)⓪"END showExprStack;⓪ *)⓪ ⓪ PROCEDURE Move (s, d: ADDRESS; n: LONGCARD);⓪"BEGIN⓪$(* diese Routine muß in beiden Richtungen mit Überlappungen klarkommen *)⓪$Block.Copy (s, n, d) (* <- die hier tut's *)⓪"END Move;⓪ ⓪ PROCEDURE Clear (d: ADDRESS; n: CARDINAL);⓪"BEGIN⓪$ASSEMBLER⓪(MOVE n(A6),D0⓪(MOVE.L d(A6),A0⓪(BRA c⓪&l CLR.B (A0)+⓪&c DBRA D0,l⓪$END⓪"END Clear;⓪ ⓪ PROCEDURE swapBytes (VAR set: ShortSet; n: CARDINAL);⓪"BEGIN⓪$ASSEMBLER⓪(CMPI.W #1,n(A6)⓪(BEQ ok⓪(MOVE.L set(A6),A0⓪(CMPI.W #2,n(A6)⓪(BEQ wd⓪(MOVE.L (A0),D0⓪(ROR.W #8,D0⓪(SWAP D0⓪(ROR.W #8,D0⓪(MOVE.L D0,(A0)⓪(RTS⓪%wd MOVE.W 2(A0),D0⓪(ROR.W #8,D0⓪(MOVE.W D0,2(A0)⓪%ok⓪$END⓪"END swapBytes;⓪ ⓪ ⓪ PROCEDURE bitInOptions (n: CARDINAL): BOOLEAN;⓪"VAR rangeCheck: BOOLEAN;⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L Options,D0⓪(MOVE.W n(A6),D1⓪(BTST D1,D0⓪(SNE D0⓪(ANDI #1,D0⓪(MOVE D0,rangeCheck(A6)⓪$END;⓪$RETURN rangeCheck⓪"END bitInOptions;⓪ ⓪ PROCEDURE warningsActive (): BOOLEAN;⓪"VAR w: BOOLEAN;⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L Options,D0⓪(BTST #23,D0 ; $W⓪(SNE D0⓪(ANDI #1,D0⓪(MOVE D0,w(A6)⓪$END;⓪$RETURN w⓪"END warningsActive;⓪ ⓪ PROCEDURE suppressOpt (): BOOLEAN;⓪"VAR b: BOOLEAN;⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L Options,D0⓪(BTST #10,D0 ; $J⓪(SEQ D0⓪(ANDI #1,D0⓪(MOVE D0,b(A6)⓪$END;⓪$RETURN b⓪"END suppressOpt;⓪ ⓪ PROCEDURE stackCheckActive (): BOOLEAN;⓪"VAR rangeCheck: BOOLEAN;⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L Options,D0⓪(BTST #19,D0 ; $S⓪(SNE D0⓪(ANDI #1,D0⓪(MOVE D0,rangeCheck(A6)⓪$END;⓪$RETURN rangeCheck⓪"END stackCheckActive;⓪ ⓪ PROCEDURE rangeCheckActive (): BOOLEAN;⓪"VAR rangeCheck: BOOLEAN;⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L Options,D0⓪(BTST #18,D0 ; $R⓪(SNE D0⓪(ANDI #1,D0⓪(MOVE D0,rangeCheck(A6)⓪$END;⓪$RETURN rangeCheck⓪"END rangeCheckActive;⓪ ⓪ PROCEDURE overflowCheckActive (): BOOLEAN;⓪"BEGIN⓪$RETURN rangeCheckActive ()⓪"END overflowCheckActive;⓪ ⓪ PROCEDURE generateDebugCode (): BOOLEAN;⓪"VAR flag: BOOLEAN;⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L Options,D0⓪(BTST #04,D0 ; $D⓪(SNE D0⓪(ANDI #1,D0⓪(MOVE D0,flag(A6)⓪$END;⓪$RETURN flag⓪"END generateDebugCode;⓪ ⓪ PROCEDURE extendedSyntax (): BOOLEAN;⓪"VAR flag: BOOLEAN;⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L Options,D0⓪(BTST #01,D0 ; $A⓪(SNE D0⓪(ANDI #1,D0⓪(MOVE D0,flag(A6)⓪$END;⓪$RETURN flag⓪"END extendedSyntax;⓪ ⓪ ⓪ PROCEDURE makeUndef (VAR expr: ExprDesc);⓪"BEGIN⓪$expr.exprSize:= Size (expr);⓪$expr.item:= UndefTyp⓪"END makeUndef;⓪ ⓪ ⓪ PROCEDURE SetSize (VAR expr: ExprDesc; size: LONGCARD);⓪"(*⓪#* Setzt Größe des Datums, wandelt ggf. nach UndefTyp (ist nötig,⓪#* wenn Aufruf von syncConstant, wenn ein CHAR als Parm übergeben wird).⓪#*)⓪"BEGIN⓪$IF (expr.item # SSTyp) & (expr.item # UndefTyp) THEN⓪&makeUndef (expr)⓪$ELSE⓪&expr.exprSize:= size⓪$END⓪"END SetSize;⓪ ⓪ ⓪ PROCEDURE isOpenArray (type: PtrItem): BOOLEAN;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; RETURN (ItemNo (type) = 32) OR (ItemNo (type) = 42)⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.B -1(A0),D0⓪(CMPI.B #32,D0⓪(BEQ OK⓪(CMPI.B #42,D0⓪%OK SEQ D0⓪(ANDI #1,D0⓪$END⓪"END isOpenArray;⓪"(*$L=*)⓪ ⓪ PROCEDURE isLongOpenArray (type: PtrItem): BOOLEAN;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; RETURN ItemNo (type) = 42⓪(MOVE.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.B -1(A0),D0⓪(CMPI.B #42,D0⓪(SEQ D0⓪(ANDI #1,D0⓪$END⓪"END isLongOpenArray;⓪"(*$L=*)⓪ ⓪ ⓪ PROCEDURE card16ZZ (x: ZZ): BOOLEAN;⓪"(* TRUE, wenn Wert in CARDINAL paßt *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;RETURN NOT x.over & (x.v <= LONG (MAX (CARDINAL))) & (x.v >= 0L)⓪(MOVE.L -(A3),D1 ;x.v⓪(MOVE.W -(A3),D0 ;x.over⓪(BNE false⓪(CMPI.L #$FFFF,D1⓪(SLS D0⓪(ANDI #1,D0⓪(RTS⓪&false:⓪(CLR D0⓪$END⓪"END card16ZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE int16ZZ (x: ZZ): BOOLEAN;⓪"(* TRUE, wenn Wert in INTEGER paßt *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;RETURN NOT x.over & (x.v <= LONG (MaxInt)) & (x.v >= LONG (MinInt))⓪(MOVE.L -(A3),D1 ;x.v⓪(MOVE.W -(A3),D0 ;x.over⓪(BNE false⓪(MOVE.W D1,A0⓪(CMPA.L D1,A0⓪(SEQ D0⓪(ANDI #1,D0⓪(RTS⓪&false:⓪(CLR D0⓪$END⓪"END int16ZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE int8ZZ (x: ZZ): BOOLEAN;⓪"(* TRUE, wenn Wert in Byte paßt *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;RETURN NOT x.over & (x.v <= 127L) & (x.v >= -128L)⓪(MOVE.L -(A3),A0 ;x.v⓪(MOVE.W -(A3),D0 ;x.over⓪(BNE false⓪(ADDA.W #128,A0⓪(CMPA.W #$FF,A0⓪(SLS D0⓪(ANDI #1,D0⓪(RTS⓪&false:⓪(CLR D0⓪$END⓪"END int8ZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE int3ZZ (x: ZZ): BOOLEAN;⓪"(* TRUE, wenn Wert für ADDQ paßt⓪#* Vorsicht! Damit ist auch der Wert +8 zugelassen, Null aber auch! *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;RETURN NOT x.over & (ABS (x.v) <= 8L)⓪(MOVE.L -(A3),A0 ;x.v⓪(MOVE.W -(A3),D0 ;x.over⓪(BNE false⓪(ADDQ.L #8,A0⓪(CMPA.W #16,A0⓪(SLS D0⓪(ANDI #1,D0⓪(RTS⓪&false:⓪(CLR D0⓪$END⓪"END int3ZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE card8ZZ (x: ZZ): BOOLEAN;⓪"(* TRUE, wenn Wert in Byte paßt *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;RETURN NOT x.over & (x.v <= 255L) & (x.v >= 0L)⓪(MOVE.L -(A3),A0 ;x.v⓪(MOVE.W -(A3),D0 ;x.over⓪(BNE false⓪(CMPA.W #$FF,A0⓪(SLS D0⓪(ANDI #1,D0⓪(RTS⓪&false:⓪(CLR D0⓪$END⓪"END card8ZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE nullZZ (x: ZZ): BOOLEAN;⓪"(* TRUE, wenn Wert Null ist *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;RETURN NOT x.over & (x.v = 0L)⓪(MOVE.L -(A3),D1 ;x.v⓪(BNE falsev⓪(MOVE.W -(A3),D0 ;x.over⓪(BNE false⓪(MOVEQ #1,D0⓪(RTS⓪&falsev:⓪(SUBQ.L #2,A3⓪&false:⓪(CLR D0⓪$END⓪"END nullZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE sizeZZ (x: ZZ): CARDINAL;⓪"(*$L-*)⓪"BEGIN⓪$(*⓪&IF x.over THEN⓪(RETURN 4⓪&ELSIF (x.v <= 255L) & (x.v >= -128L) THEN⓪(RETURN 1⓪&ELSIF (x.v <= LONGINT (LONG (MaxCard))) & (x.v >= LONG (MinInt)) THEN⓪(RETURN 2⓪&ELSE⓪(RETURN 4⓪&END⓪$*)⓪$ASSEMBLER⓪(MOVE.L -(A3),A0 ;x.v⓪(MOVE.W -(A3),D0 ;x.over⓪(BNE four⓪(CMPA.W #255,A0⓪(BGT noone⓪(CMPA.W #-128,A0⓪(BGE one⓪&noone:⓪(CMPA.L #65535,A0⓪(BGT four⓪(CMPA.W #-32768,A0⓪(BLT four⓪(MOVEQ #2,D0⓪(RTS⓪&one:⓪(MOVEQ #1,D0⓪(RTS⓪&four:⓪(MOVEQ #4,D0⓪$END⓪"END sizeZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE sizeZZeven (x: ZZ): CARDINAL;⓪"(*⓪#* wie 'sizeZZ', nur wird nie 1 geliefert, sondern dann 2⓪#*)⓪"(*$L-*)⓪"BEGIN⓪$(*⓪&IF x.over THEN⓪(RETURN 4⓪&ELSIF (x.v <= LONGINT (LONG (MaxCard))) & (x.v >= LONG (MinInt)) THEN⓪(RETURN 2⓪&ELSE⓪(RETURN 4⓪&END⓪$*)⓪$ASSEMBLER⓪(MOVE.L -(A3),A0 ;x.v⓪(MOVE.W -(A3),D0 ;x.over⓪(BNE four⓪(CMPA.L #65535,A0⓪(BGT four⓪(CMPA.W #-32768,A0⓪(BLT four⓪(MOVEQ #2,D0⓪(RTS⓪&four:⓪(MOVEQ #4,D0⓪$END⓪"END sizeZZeven;⓪"(*$L=*)⓪"⓪ PROCEDURE toZZ (l: LONGWORD; signed: BOOLEAN): ZZ;⓪"VAR x: ZZ;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; x.v:= LONGINT (l);⓪(; x.over:= NOT signed & (x.v < 0L);⓪(; RETURN x⓪(MOVE.W -(A3),D0 ;signed⓪(BNE notOver⓪(MOVE.L -(A3),D1 ;l⓪(BPL notOver2⓪(MOVE #1,(A3)+ ;x.over⓪(MOVE.L D1,(A3)+ ;x.v⓪(RTS⓪¬Over:⓪(MOVE.L -(A3),D1 ;l⓪¬Over2:⓪(CLR (A3)+ ;x.over⓪(MOVE.L D1,(A3)+ ;x.v⓪$END⓪"END toZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE expandToZZ (itemNo: CARDINAL; VAR x: ZZ);⓪"(* setzt bei nicht-LONGINTs das over-Flag, falls Wert > 2^31 *)⓪"BEGIN⓪$IF itemNo # 4 THEN⓪&x.over:= (itemNo # 1) & (x.v < 0)⓪$END⓪"END expandToZZ;⓪ ⓪ PROCEDURE posZZ (x: ZZ): BOOLEAN;⓪"(* TRUE, wenn Wert positiv *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; RETURN x.over OR (x.v >= 0L)⓪(MOVE.L -(A3),D1⓪(MOVE.W -(A3),D0⓪(BNE over⓪(TST.L D1⓪(SPL D0⓪(ANDI #1,D0⓪&over:⓪$END⓪"END posZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE negZZ (VAR x: ZZ);⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; IF x.over THEN SyntaxError (rAriOv) END;⓪(; x.v:= -x.v;⓪(MOVE.L -(A3),A0⓪(TST.W ZZ.over(A0)⓪(BNE over⓪(NEG.L ZZ.v(A0)⓪(RTS⓪&over:⓪$END;⓪$SyntaxError (rAriOv)⓪"END negZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE intZZ (x: ZZ): LONGINT;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; IF x.over THEN SyntaxError (rAriOv) END;⓪(; RETURN x.v⓪(MOVE.L -(A3),D0 ;x.v⓪(TST.W -(A3) ;x.over⓪(BNE over⓪(RTS⓪&over:⓪$END;⓪$SyntaxError (rAriOv)⓪"END intZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE cardZZ (x: ZZ): LONGCARD;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; IF NOT x.over & (x.v < 0L) THEN SyntaxError (rAriOv) END;⓪(; RETURN x.l⓪(MOVE.L -(A3),D0 ;x.v⓪(BPL ok⓪(TST.W -(A3) ;x.over⓪(BEQ over⓪(RTS⓪&ok:⓪(SUBQ.L #2,A3⓪(RTS⓪&over:⓪$END;⓪$SyntaxError (rAriOv)⓪"END cardZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE shortInt (x: LONGWORD): BOOLEAN;⓪"(* TRUE, wenn Wert in INTEGER paßt *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; RETURN (LONGINT (x) <= LONG (MaxInt)) & (LONGINT (x) >= LONG (MinInt))⓪(MOVE.L -(A3),D0 ;x⓪(MOVE.W D0,A0⓪(CMPA.L D0,A0⓪(SEQ D0⓪(AND #1,D0⓪$END⓪"END shortInt;⓪"(*$L=*)⓪ ⓪ PROCEDURE byteVal (x: LONGWORD): BOOLEAN;⓪"(* TRUE, wenn Wert in BYTE (mit Vorzeichen!) paßt *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(; RETURN (LONGINT (x) <= 127L) & (LONGINT (x) >= -128L)⓪(MOVE.L -(A3),A0 ;x⓪(ADDA.W #128,A0⓪(CMPA.W #255,A0⓪(SLS D0⓪(ANDI #1,D0⓪$END⓪"END byteVal;⓪"(*$L=*)⓪ ⓪ PROCEDURE lowByte (x: LONGINT): CARDINAL;⓪"(* Returns Low-Byte: 0-255 *)⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L -(A3),D0⓪(ANDI #$FF,D0⓪$END⓪"END lowByte;⓪"(*$L=*)⓪ ⓪ PROCEDURE addZZ (VAR l: ZZ; r: ZZ);⓪"VAR overflow: BOOLEAN;⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L l(A6),A0⓪(LEA r(A6),A1⓪(MOVE.W ZZ.over(A1),D1⓪(BNE ok10⓪(TST.L ZZ.v(A1)⓪(BPL ok1⓪&ok10⓪(SUBQ #1,D1⓪&ok1⓪(MOVE.L ZZ.v(A0),D2⓪(MOVE.W ZZ.over(A0),D0⓪(BNE ok20⓪(TST.L D2⓪(BPL ok2⓪&ok20⓪(SUBQ #1,D0⓪&ok2⓪(ADD.L ZZ.v(A1),D2⓪(MOVE.L D2,ZZ.v(A0)⓪(ADDX.W D1,D0⓪(BPL ok3⓪(ADDQ #1,D0 ; wenn Erg neg, muß high-Word $FFFF sein⓪(BNE over⓪(TST.L D2 ; ZZ.v muß natürlich auch neg. sein⓪(BPL over⓪(BRA ok⓪&ok3⓪(TST D0⓪(BNE over ; High-word muß sonst erstmal Null sein⓪(TST.L D2⓪(BPL ok⓪(MOVEQ #1,D0⓪&ok⓪(MOVE.W D0,ZZ.over(A0)⓪(CLR overflow(A6)⓪(BRA ende⓪&over⓪(MOVE #1,overflow(A6)⓪&ende⓪$END;⓪$IF overflow THEN SyntaxError (rAriOv) END⓪"END addZZ;⓪ ⓪ PROCEDURE subZZ (VAR l: ZZ; r: ZZ);⓪"VAR overflow: BOOLEAN;⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L l(A6),A0⓪(LEA r(A6),A1⓪(MOVE.W ZZ.over(A1),D1⓪(BNE ok10⓪(TST.L ZZ.v(A1)⓪(BPL ok1⓪&ok10⓪(SUBQ #1,D1⓪&ok1⓪(MOVE.L ZZ.v(A0),D2⓪(MOVE.W ZZ.over(A0),D0⓪(BNE ok20⓪(TST.L D2⓪(BPL ok2⓪&ok20⓪(SUBQ #1,D0⓪&ok2⓪(SUB.L ZZ.v(A1),D2⓪(MOVE.L D2,ZZ.v(A0)⓪(SUBX.W D1,D0⓪(BPL ok3⓪(ADDQ #1,D0 ; wenn Erg neg, muß high-Word $FFFF sein⓪(BNE over⓪(TST.L D2 ; ZZ.v muß natürlich auch neg. sein⓪(BPL over⓪(BRA ok⓪&ok3⓪(TST D0⓪(BNE over ; High-word muß sonst erstmal Null sein⓪(TST.L D2⓪(BPL ok⓪(MOVEQ #1,D0⓪&ok⓪(MOVE.W D0,ZZ.over(A0)⓪(CLR overflow(A6)⓪(BRA ende⓪&over⓪(MOVE #1,overflow(A6)⓪&ende⓪$END;⓪$IF overflow THEN SyntaxError (rAriOv) END⓪"END subZZ;⓪ ⓪ PROCEDURE cmpZZ (l: ZZ; r: ZZ): Relation;⓪"(* liefert 'eq', 'lt' oder 'gt' *)⓪"VAR rel: Relation;⓪"BEGIN⓪$ASSEMBLER⓪(LEA l(A6),A0⓪(LEA r(A6),A1⓪(MOVE.W ZZ.over(A1),D1⓪(BNE ok10⓪(TST.L ZZ.v(A1)⓪(BPL ok1⓪&ok10⓪(SUBQ #1,D1⓪&ok1⓪(MOVE.L ZZ.v(A0),D2⓪(MOVE.W ZZ.over(A0),D0⓪(BNE ok20⓪(TST.L D2⓪(BPL ok2⓪&ok20⓪(SUBQ #1,D0⓪&ok2⓪(SUB.L ZZ.v(A1),D2⓪(SUBX.W D1,D0⓪(BPL ok3⓪(MOVEQ #lt,D0⓪(BRA ok⓪&ok3⓪(BNE plu⓪(MOVEQ #eq,D0⓪(BRA ok⓪&plu⓪(MOVEQ #gt,D0⓪&ok⓪(MOVE D0,rel(A6)⓪&ende⓪$END;⓪$RETURN rel⓪"END cmpZZ;⓪ ⓪ PROCEDURE inZZ (x, lo, hi: ZZ): BOOLEAN;⓪"(* TRUE, wenn lo <= x <= hi *)⓪"BEGIN⓪$(*$? Safety: assert (ORD (x.over) < 2); *)⓪$(*$? Safety: assert (ORD (lo.over) < 2); *)⓪$(*$? Safety: assert (ORD (hi.over) < 2); *)⓪$RETURN (cmpZZ (x, lo) # lt) & (cmpZZ (hi, x) # lt)⓪"END inZZ;⓪"⓪ PROCEDURE diffZZ (l: ZZ; r: ZZ): LONGCARD;⓪"BEGIN⓪$(*$? Safety: assert (ORD (l.over) < 2); *)⓪$(*$? Safety: assert (ORD (r.over) < 2); *)⓪$subZZ (l, r);⓪$IF NOT posZZ (l) THEN SyntaxError (rAriOv) END;⓪$RETURN l.l⓪"END diffZZ;⓪ ⓪ PROCEDURE mulZZ (VAR l: ZZ; r: ZZ);⓪"BEGIN⓪$(*$? Safety: assert (ORD (l.over) < 2); *)⓪$(*$? Safety: assert (ORD (r.over) < 2); *)⓪$IF nullZZ (l) OR (cmpZZ (r, toZZ (1L, FALSE)) = eq) THEN⓪&(* l bleibt *)⓪$ELSIF nullZZ (r) OR (cmpZZ (l, toZZ (1L, FALSE)) = eq) THEN⓪&l:= r⓪$ELSIF r.over OR l.over THEN⓪&IF SignalOverflow THEN⓪(SyntaxError (rAriOv)⓪&ELSE⓪(HasOverflown:= TRUE⓪&END⓪$ELSE⓪&l.v:= l.v * r.v;⓪$END;⓪"END mulZZ;⓪ ⓪ PROCEDURE divZZ (VAR l: ZZ; r: ZZ);⓪"BEGIN⓪$(*$? Safety: assert (ORD (l.over) < 2); *)⓪$(*$? Safety: assert (ORD (r.over) < 2); *)⓪$IF r.over THEN⓪&IF NOT l.over THEN⓪(l:= toZZ (0L, FALSE)⓪&ELSE⓪(l.l:= l.l DIV r.l;⓪(l.over:= l.v < 0L⓪&END⓪$ELSIF l.over THEN⓪&IF (NOT r.over & (r.l < 0L)) THEN⓪(l.v:= l.l DIV LONGCARD (ABS (r.v)); (* hier ist Range-Error möglich *)⓪(l.over:= FALSE⓪&ELSE⓪(l.l:= l.l DIV r.l;⓪(l.over:= l.v < 0L⓪&END⓪$ELSE⓪&l.v:= l.v DIV r.v⓪$END;⓪"END divZZ;⓪ ⓪ PROCEDURE modZZ (VAR l: ZZ; r: ZZ);⓪"(* Achtung bei neg. Werten!!! Da wird ggf. falsch gerundet?!⓪#* >> auch remZZ und entspr. div-routine erstellen! *)⓪"VAR z: ZZ;⓪"BEGIN⓪$(*$? Safety: assert (ORD (l.over) < 2); *)⓪$(*$? Safety: assert (ORD (r.over) < 2); *)⓪$(* l:= l - l / r * r *)⓪$z:= l;⓪$divZZ (z, r);⓪$mulZZ (z, r);⓪$subZZ (l, z);⓪"END modZZ;⓪ ⓪ PROCEDURE makeMask (lo, hi: CARDINAL): LONGCARD;⓪"VAR res: LONGCARD;⓪"BEGIN⓪$ASSEMBLER⓪(MOVEQ #0,D2⓪(MOVE.W lo(A6),D0⓪(MOVE.W hi(A6),D1⓪&L CMP.W D1,D0⓪(BHI E⓪(BSET D0,D2⓪(ADDQ #1,D0⓪(BRA L⓪&E MOVE.L D2,res(A6)⓪$END;⓪$RETURN res⓪"END makeMask;⓪ ⓪ PROCEDURE makeInvMask (lo, hi: CARDINAL): LONGCARD;⓪"VAR res: LONGCARD;⓪"BEGIN⓪$res:= makeMask (lo, hi);⓪$ASSEMBLER⓪(MOVE.L res(A6),D0⓪(NOT.L D0⓪(MOVE.L D0,res(A6)⓪$END;⓪$RETURN res⓪"END makeInvMask;⓪ ⓪ PROCEDURE longSignedType (type: PtrItem): BOOLEAN;⓪"(*⓪#* TRUE, wenn Type Long oder ShortCard ist;⓪#* FALSE, wenn ShortInt, ShortBoth oder Byte; Error, wenn größer⓪#*)⓪"BEGIN⓪$(*$? Safety: assert (TypeLength (type) <= 4); *)⓪$RETURN (TypeLength (type) = 4) OR (ItemNo (HostType (type)) = 34)⓪"END longSignedType;⓪ ⓪ ⓪ PROCEDURE constSize (VAR expr: ExprDesc): CARDINAL;⓪"(* liefert die Größe der Konstanten in Bytes. *)⓪"VAR (*$Reg*)l: LONGCARD;⓪"BEGIN⓪$(*$? Safety: assert (expr.kind = constant); *)⓪$IF expr.item = ZZTyp THEN⓪&WITH expr.exprConst DO⓪(IF card8ZZ (zz) OR int8ZZ (zz) THEN⓪*RETURN 1⓪(ELSIF card16ZZ (zz) OR int16ZZ (zz) THEN⓪*RETURN 2⓪(ELSE⓪*RETURN 4⓪(END⓪&END⓪$ELSE⓪&RETURN SHORT (Size (expr))⓪$END⓪"END constSize;⓪ ⓪ PROCEDURE exprSize (VAR expr: ExprDesc): LONGCARD;⓪"BEGIN⓪$IF expr.kind = constant THEN⓪&RETURN LONG (constSize (expr))⓪$ELSE⓪&RETURN Size (expr)⓪$END⓪"END exprSize;⓪ ⓪ PROCEDURE signedType (type: PtrItem): BOOLEAN;⓪"VAR (*$Reg*)n: CARDINAL;⓪"BEGIN⓪$n:= ItemNo (HostType (type));⓪$(*$? Safety: assert (n # 4); (* hier hängt's vom Wert ab.. *) *)⓪$RETURN (n=1) OR (n=33) OR (n=39)⓪"END signedType;⓪ ⓪ PROCEDURE signedConst (type: PtrItem; const: ZZ): BOOLEAN;⓪"VAR (*$Reg*)n: CARDINAL;⓪"BEGIN⓪$n:= ItemNo (HostType (type));⓪$IF n = 4 THEN⓪&RETURN NOT posZZ (const)⓪$ELSE⓪&RETURN (n=1) OR (n=33) OR (n=39)⓪$END⓪"END signedConst;⓪ ⓪ PROCEDURE signedExpr (REF expr: ExprDesc): BOOLEAN;⓪"VAR (*$Reg*)n: CARDINAL;⓪"BEGIN⓪$n:= ItemNo (HostType (expr.item));⓪$IF n = 4 THEN⓪&(*$? Safety: assert (expr.kind = constant); *)⓪&RETURN NOT posZZ (expr.exprConst.zz)⓪$ELSE⓪&RETURN (n=1) OR (n=33) OR (n=39)⓪$END⓪"END signedExpr;⓪ ⓪ ⓪ ⓪ (*⓪!* allg. Routinen, z.B. für 'ExprDesc'⓪!*)⓪ ⓪ ⓪ PROCEDURE sizedItem (n: CARDINAL; signed: BOOLEAN): PtrItem;⓪"VAR (*$Reg*)r: PtrItem;⓪"BEGIN⓪$CASE n OF⓪$| 1: IF signed THEN r:= BytIPtr ELSE r:= CharPtr END⓪$| 2: IF signed THEN r:= SIntPtr ELSE r:= SCardPtr END⓪$| 4: IF signed THEN r:= IntPtr ELSE r:= CardPtr END⓪$END;⓪$RETURN r⓪"END sizedItem;⓪ ⓪ ⓪ PROCEDURE isJoker (t: PtrItem): BOOLEAN;⓪"BEGIN⓪$RETURN ItemNo (t) IN ItemSet {21,26,38,39};⓪"END isJoker;⓪ ⓪ PROCEDURE jokerSize (itemNo: CARDINAL): CARDINAL;⓪"BEGIN⓪$IF (itemNo = 38 (* BYTE *)) OR (itemNo = 39 (* signed BYTE *)) THEN⓪&RETURN 1⓪$ELSIF itemNo = 21 (* WORD *) THEN⓪&RETURN 2⓪$ELSIF itemNo = 26 (* LONG *) THEN⓪&RETURN 4⓪$END;⓪$RETURN 0⓪"END jokerSize;⓪ ⓪ ⓪ PROCEDURE roundedUp (l: LONGCARD): LONGCARD;⓪"BEGIN⓪$IF ODD (l) THEN RETURN l+1L ELSE RETURN l END⓪"END roundedUp;⓪ ⓪ PROCEDURE roundUp (VAR l: LONGCARD);⓪"BEGIN⓪$IF ODD (l) THEN INC (l) END⓪"END roundUp;⓪ ⓪ PROCEDURE roundUpCard (VAR l: CARDINAL);⓪"BEGIN⓪$IF ODD (l) THEN INC (l) END⓪"END roundUpCard;⓪"⓪ ⓪ PROCEDURE roundedSize (VAR expr: ExprDesc): LONGCARD;⓪"VAR (*$Reg*)n: LONGCARD;⓪"BEGIN⓪$n:= Size (expr);⓪$IF ODD (n) & (expr.kind = stack) THEN⓪&INC (n)⓪$END;⓪$RETURN n⓪"END roundedSize;⓪ ⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ (* Code erzeugende Routinen *)⓪ ⓪ (*⓪"MODULE codeGen;⓪"⓪"IMPORT⓪$ASSEMBLER, ADDRESS, ADR, TSIZE, BYTE, WORD, LONGWORD,⓪$Operator, ExprDesc, BS, TypeLength, BoolPtr, PtrSet,⓪$PtrFullSet, rOpTyp, SyntaxError, ItemNo,⓪$SuppressCode, toZZ, addZZ, subZZ, divZZ, mulZZ, modZZ, ExprKind,⓪$OpSet, CodePtr, SetCodePtr, assert, bong, shortInt, MemModes,⓪$Label, PutCode, coding, PtrItem, RegType, lowByte, byteVal,⓪$ZZ, rStruc, LastVarLink, SetVarLink, Code, LastProcLink, SetProcLink,⓪$BooleanType, CardPtr, rBranc, rExOvr, Directions,⓪$D0,D1,D2,D7,A0,A2,A3,A4,A5,A6,A7,F0,F2,F7;⓪"⓪"EXPORT⓪$EXTW, EXTL, ADDA, TST, TRAPV, Bcc, SWAP, ADD, ASLI, MULS, MULU, BRA,⓪$CHK, NEGL, LastDataRelocAdr,⓪$genMOVEir, ToHere, genClrReg, genMOVEQ, genMOVEar,⓪$genMOVErr, genADDA, genADDAL, genia, genPEA, gena, genar, genarSized,⓪$gen, genr, genir, genBool, genbcc, genQ, genPush, genPullReg, genMOVErind,⓪$genPushAddress, genLEA, genLEAabs, genLEApcrel, genLEArel, genMOVELIndTo;⓪ *)⓪ ⓪ VAR⓪"LastDataRelocAdr: POINTER TO LONGCARD;⓪ ⓪ CONST⓪ ⓪"ADD = $D000;⓪"ADDA = $D000;⓪"ADDI = $0600;⓪"ADDQ = $5000;⓪"AND_ = $C000;⓪"ANDI = $0200;⓪"ASR = $E020;⓪"ASRI = $E000;⓪"ASLI = $E100;⓪"BRA = $6000;⓪"Bcc = $6000;⓪"BCLR = $0180;⓪"BCLRI = $0880;⓪"BSET = $01C0;⓪"BSETI = $08C0;⓪"BSR = $6100;⓪"BTST = $0100;⓪"BTSTI = $0800;⓪"CHK = $4180;⓪"CLR = $4200;⓪"CLRW = $4240;⓪"CMP = $B000;⓪"CMPAL = $B1C0;⓪"CMPI = $0C00;⓪"DBcc = $50C8;⓪"DIVS = $81C0;⓪"DIVU = $80C0;⓪"EOR = $B100;⓪"EORI = $0A00;⓪"EXG = $C100;⓪"EXTW = $4880;⓪"EXTL = $48C0;⓪"JSR = $4E00;⓪"LEA = $4000; (* $01C0 wird z.B. in 'genar' addiert *)⓪"LSLI = $E108;⓪"LSRI = $E008;⓪"MOVE = $0000;⓪"MOVEML= $48C0;⓪"MULS = $C1C0;⓪"MULU = $C0C0;⓪"NEG = $4400;⓪"NEGL = $4480;⓪"NOP = $4E71;⓪"NOT_ = $4600;⓪"OR_ = $8000;⓪"OR2 = $8100;⓪"PEA = $4840;⓪"ROL = $E138;⓪"ROLI = $E118;⓪"RORI = $E018;⓪"SCC = $50C0;⓪"SUB = $9000;⓪"SUBI = $0400;⓪"SUBQ = $5100;⓪"SWAP = $4840;⓪"TRAP = $4E40;⓪"TRAPV = $4E76;⓪"TST = $4A00;⓪ ⓪"FGET = $0000; (* FMOVE <ea>,FPn *)⓪"FPUT = $2000; (* FMOVE FPn,<ea>, $4000 wird durch 'Fea' addiert *)⓪"FMOVEM= $C000;⓪"FABS = $0018;⓪"FNEG = $001A;⓪"FADD = $0022;⓪"FSUB = $0028;⓪"FMUL = $0023;⓪"FDIV = $0020;⓪"FCMP = $0038;⓪"FBEQ = 000001%;⓪"FBNE = 001110%;⓪"FBLE = 010101%;⓪"FBGE = 010011%;⓪"FBLT = 010100%;⓪"FBGT = 010010%;⓪ ⓪ ⓪ PROCEDURE mapCC (op: Operator; signed, negate: BOOLEAN): CARDINAL;⓪"(*⓪#* Vorsicht: wenn 'op = cc' und 'signed = TRUE', wird VC generiert!⓪#* Das ist also für echte Überlauf-Tests gedacht (z.B. bei Addition, usw)!⓪#* Wenn dagegen eigentlich ein größer/kleiner-Test erfolgen soll,⓪#* muß ein op aus le, ge, lt, gt ausgewählt werden. Dann wird⓪#* bei NOT signed ggf. zwar auch CC erzeugt, bei signed Test dafür⓪#* dann aber GE.⓪#*)⓪"VAR x: CARDINAL;⓪"BEGIN⓪$CASE op OF⓪$| eq: x:= $700⓪$| ne: x:= $600⓪$| cc: IF signed THEN x:= $800 ELSE x:= $400 END⓪$| pl: x:= $A00⓪$| le: IF signed THEN x:= $F00 ELSE x:= $300 END⓪$| ge: IF signed THEN x:= $C00 ELSE x:= $400 END⓪$| lt: IF signed THEN x:= $D00 ELSE x:= $500 END⓪$| gt: IF signed THEN x:= $E00 ELSE x:= $200 END⓪$ELSE⓪&bong⓪$END;⓪$IF negate THEN⓪&ASSEMBLER⓪(MOVE x(A6),D0⓪(BCHG #8,D0⓪(MOVE D0,x(A6)⓪&END⓪$END;⓪$RETURN x⓪"END mapCC;⓪ ⓪ PROCEDURE mapFPUcc (op: Operator; negate: BOOLEAN): CARDINAL;⓪"(*⓪#* Für FPU. Mit Exception, wenn unordered.⓪#*)⓪"VAR m: CARDINAL;⓪"BEGIN⓪$CASE op OF⓪&eq: m:= FBEQ|⓪&ne: m:= FBNE|⓪&le: m:= FBLE|⓪&ge: m:= FBGE|⓪<: m:= FBLT|⓪>: m:= FBGT|⓪$ELSE⓪&bong⓪$END;⓪$IF negate THEN⓪&ASSEMBLER⓪(MOVE m(A6),D0⓪(EORI #$F,D0⓪(MOVE D0,m(A6)⓪&END⓪$END;⓪$RETURN m⓪"END mapFPUcc;⓪ ⓪ PROCEDURE mapAlways (): CARDINAL;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;RETURN 0⓪(CLR D0⓪$END⓪"END mapAlways;⓪"(*$L=*)⓪ ⓪ PROCEDURE mapNever(): CARDINAL;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;RETURN $100⓪(MOVE #$100,D0⓪$END⓪"END mapNever;⓪"(*$L=*)⓪ ⓪ PROCEDURE mapTRUE (negate: BOOLEAN): CARDINAL;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;IF negate THEN x:= $700 ELSE x:= $600 END;⓪(;RETURN x⓪(TST -(A3)⓪(BNE neg⓪(MOVE #$600,D0⓪(RTS⓪#neg: MOVE #$700,D0⓪$END⓪"END mapTRUE;⓪"(*$L=*)⓪ ⓪ PROCEDURE mapFALSE (negate: BOOLEAN): CARDINAL;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(;IF negate THEN x:= $600 ELSE x:= $700 END;⓪(;RETURN x⓪(TST -(A3)⓪(BNE neg⓪(MOVE #$700,D0⓪(RTS⓪#neg: MOVE #$600,D0⓪$END⓪"END mapFALSE;⓪"(*$L=*)⓪ ⓪ ⓪ PROCEDURE Fea (REF expr: ExprDesc; VAR ea: BOOLEAN): CARDINAL;⓪"VAR (*$Reg*)size: CARDINAL;⓪"BEGIN⓪$IEEERuntimeCall;⓪$IF (expr.kind = register) & (expr.exprReg >= F0) THEN⓪&ea:= FALSE;⓪&RETURN (expr.exprReg - F0) * $400⓪$ELSE⓪&ea:= TRUE;⓪&size:= SHORT (Size (expr));⓪&IF size = SizeOfShortReal THEN⓪(RETURN $4400⓪&ELSE⓪((*$? Safety: assert (size = SizeOfLongReal); *)⓪(RETURN $5400⓪&END⓪$END⓪"END Fea;⓪ ⓪ PROCEDURE Freg (reg: RegType): CARDINAL;⓪"BEGIN⓪$(*$? Safety: assert (reg >= F0); *)⓪$IEEERuntimeCall;⓪$RETURN (reg - F0) * $80⓪"END Freg;⓪ ⓪ PROCEDURE getFPUop (VAR source: ExprDesc; destReg: RegType;⓪4op: Operator; isrel: BOOLEAN;⓪4VAR n, m: CARDINAL; VAR ea: BOOLEAN);⓪"BEGIN⓪$IEEERuntimeCall;⓪$IF isrel THEN⓪&n:= FCMP⓪$END;⓪$CASE op OF⓪&add: n:= FADD|⓪&sub: n:= FSUB|⓪&mul: n:= FMUL|⓪&rdiv:n:= FDIV|⓪&eq: m:= FBEQ|⓪&ne: m:= FBNE|⓪&le: m:= FBLE|⓪&ge: m:= FBGE|⓪<: m:= FBLT|⓪>: m:= FBGT|⓪$ELSE⓪&SyntaxError (rOpTyp)⓪$END;⓪$INC (n, Fea (source, ea) + Freg (destReg));⓪"END getFPUop;⓪ ⓪ ⓪ PROCEDURE updateStackOffsets (stackReg: RegType; up: BOOLEAN; size: LONGINT);⓪"BEGIN⓪$(*$? Safety: assert (size # 0L); *)⓪$IF stackReg = A7 THEN⓪&IF ODD (size) THEN INC (size) END;⓪&IF up THEN⓪(INC (A7Offset, size)⓪&ELSE⓪(DEC (A7Offset, size)⓪&END⓪$ELSIF stackReg = A3 THEN⓪&IF up THEN⓪(INC (A3Offset, size)⓪&ELSE⓪(DEC (A3Offset, size)⓪&END⓪$END;⓪"END updateStackOffsets;⓪ ⓪ ⓪ TYPE codeDesc = RECORD⓪2extSize: INTEGER;⓪2CASE : CARDINAL OF⓪42: extWord: WORD|⓪44: extLong: LONGWORD|⓪48: extDouble: RR|⓪2END;⓪2reloc: BOOLEAN⓪0END;⓪ ⓪ PROCEDURE getSrcEA (VAR src: ExprDesc;⓪4size: INTEGER;⓪4VAR opcode: CARDINAL;⓪4VAR code: codeDesc);⓪"VAR (*$Reg*)l: LONGINT;⓪"BEGIN⓪$WITH src DO⓪&WITH code DO⓪(reloc:= FALSE;⓪(extSize:= 0;⓪(CASE kind OF⓪(| constRef:⓪,bong () (* sollte nach 'constImm' gewandelt sein *)⓪(| constImm:⓪,INC (opcode, 111100%); (* immediate mode *)⓪,reloc:= TRUE;⓪(| constant:⓪,INC (opcode, 111100%);⓪,IF size <= 0 THEN size:= SHORT (Size (src)) END;⓪,extSize:= size;⓪,IF size <= 2 THEN⓪.extSize:= 2;⓪.extWord:= exprConst.w⓪,ELSIF size = 4 THEN⓪.extLong:= exprConst.l⓪,ELSIF size = 8 THEN⓪.extDouble:= exprConst.rr⓪,ELSE⓪.bong⓪,END⓪(| register:⓪,(*$? Safety: assert (exprReg < F0); *)⓪,INC (opcode, exprReg)⓪(| memory:⓪,CASE mode OF⓪,| pcRel: INC (opcode, 111010%); (* pc-rel *)⓪6extSize:= 2;⓪6l:= LONGINT (absAddr) - LONGINT (CodePtr ());⓪6IF coding() & (l < LONG (MinInt)) THEN⓪8(* branch too long *)⓪8SyntaxError (rBranc)⓪6END;⓪6extWord:= WORD (SHORT (l));⓪,| relRef: INC (opcode, 111010%); (* pc-rel m. Reloc *)⓪6reloc:= TRUE;⓪,| immRef: INC (opcode, 111100%); (* immediate m. Reloc *)⓪6reloc:= TRUE;⓪,| absRef: INC (opcode, 111001%); (* absolut long m. Reloc *)⓪6reloc:= TRUE;⓪,| extL: IF shortInt (extAddr) THEN⓪8INC (opcode, 111000%); (* absolute word *)⓪8extSize:= 2;⓪8extWord:= WORD (SHORT (LONGINT (extAddr)))⓪6ELSE⓪8INC (opcode, 111001%); (* absolute long *)⓪8extSize:= 4;⓪8extLong:= LONGWORD (extAddr)⓪6END⓪,| d16An: (*$? Safety2: assert (shortInt (disp)); *)⓪6IF disp = 0L THEN⓪8INC (opcode, 010000% + baseReg - A0);⓪6ELSE⓪8INC (opcode, 101000% + baseReg - A0);⓪8extSize:= 2;⓪8extWord:= WORD (SHORT (disp))⓪6END⓪,| d8AnXn: (*$? Safety2: assert (byteVal (disp)); *)⓪6INC (opcode, 110000% + baseReg - A0);⓪6extSize:= 2;⓪6extWord:= WORD (lowByte (disp)⓪K+ (idxReg) * $1000⓪K+ $800 * ORD (idxL))⓪,ELSE⓪.bong (* dann ist's ptrOnA3/A7 -- muß schon vorher⓪4* ausgewertet werden! *)⓪,END⓪(| stack:⓪,IF size = 0 THEN size:= SHORT (Size (src)) END;⓪,(*$? Safety: assert (stackReg IN (tempRegs + RegSet {A3,A7})); *)⓪,updateStackOffsets (stackReg, up, ABS (size));⓪,IF up THEN⓪.INC (opcode, 011000%)⓪,ELSE⓪.INC (opcode, 100000%)⓪,END;⓪,INC (opcode, stackReg-A0);⓪(END⓪&END⓪$END⓪"END getSrcEA;⓪ ⓪ ⓪ PROCEDURE sizedAt6 (opcode: CARDINAL): BOOLEAN;⓪"(* TRUE, wenn bereits Size-Angabe in Bits 6&7 enthalten *)⓪"BEGIN⓪$RETURN (opcode DIV 64 MOD 4) # 0⓪"END sizedAt6;⓪ ⓪ PROCEDURE sizeAt6 (size: CARDINAL): CARDINAL;⓪"BEGIN⓪$IF size = 2 THEN⓪&RETURN 40H⓪$ELSIF size = 4 THEN⓪&RETURN 80H⓪$ELSIF size = 1 THEN⓪&RETURN 00H⓪$END;⓪"END sizeAt6;⓪ ⓪ PROCEDURE getSizeAt6 (size: LONGINT; VAR opcode: CARDINAL);⓪"BEGIN⓪$IF size < 0L THEN⓪&(* nix *)⓪$ELSIF size = 2L THEN⓪&INC (opcode, 40H)⓪$ELSIF size = 4L THEN⓪&INC (opcode, 80H)⓪$ELSIF size # 1L THEN⓪&bong ();⓪$END;⓪"END getSizeAt6;⓪ ⓪ PROCEDURE getAnSize (VAR dest: ExprDesc; VAR opcode: CARDINAL);⓪"(* size f. Instr. wie ADDA, LEA, usw. ermitteln *)⓪"VAR (*$Reg*)size: LONGCARD;⓪"BEGIN⓪$size:= Size (dest);⓪$IF size = 2L THEN⓪&INC (opcode, $C0)⓪$ELSIF size = 4L THEN⓪&INC (opcode, $1C0)⓪$ELSE⓪&bong;⓪$END;⓪"END getAnSize;⓪ ⓪ PROCEDURE AnSized (size: LONGCARD): CARDINAL;⓪"(* size f. Instr. wie ADDA, LEA, usw. ermitteln *)⓪"BEGIN⓪$IF size = 2L THEN⓪&RETURN $C0;⓪$ELSIF size = 4L THEN⓪&RETURN $1C0;⓪$ELSE⓪&bong;⓪$END;⓪"END AnSized;⓪ ⓪ PROCEDURE sizedMOVE (size: LONGCARD): CARDINAL;⓪"VAR (*$Reg*)opcode: CARDINAL;⓪"BEGIN⓪$IF size = 2L THEN opcode:= $3000⓪$ELSIF size = 4L THEN opcode:= $2000⓪$ELSIF size = 1L THEN opcode:= $1000⓪$ELSE bong END;⓪$RETURN opcode⓪"END sizedMOVE;⓪ ⓪ PROCEDURE getSizeForMOVE (VAR dest: ExprDesc; VAR opcode: CARDINAL);⓪"BEGIN⓪$INC (opcode, sizedMOVE (Size (dest)))⓪"END getSizeForMOVE;⓪ ⓪ PROCEDURE getDestReg (reg: RegType; VAR opcode: CARDINAL);⓪"BEGIN⓪$IF reg < A0 THEN⓪&INC (opcode, reg * $200)⓪$ELSE⓪&(*$? Safety: assert (reg < F0); *)⓪&INC (opcode, (reg-A0) * $200 + $40)⓪$END;⓪"END getDestReg;⓪ ⓪ ⓪ PROCEDURE RelocRef (REF expr: ExprDesc);⓪"(* sieht Ref. f. Table/Proc/Var-Relozierung vor *)⓪"⓪"PROCEDURE putw (l: LONGWORD);⓪$BEGIN⓪&(*$? Safety: assert (LONGINT (l) < 0L); *)⓪&IF LONGINT (l) < LONG (MinInt) THEN SyntaxError (rBranc) END;⓪&PutCode (SHORT (LONGINT (l)))⓪$END putw;⓪"⓪"PROCEDURE pokeL (addr: ADDRESS; l: LONGWORD);⓪$VAR pl: POINTER TO LONGWORD;⓪$BEGIN⓪&pl:= addr;⓪&pl^:= l⓪$END pokeL;⓪"⓪"PROCEDURE peekL (addr: ADDRESS): LONGCARD;⓪$VAR pl: POINTER TO LONGCARD;⓪$BEGIN⓪&pl:= addr;⓪&RETURN pl^⓪$END peekL;⓪"⓪"VAR (*$Reg*)l: LONGCARD; (*$Reg*)item: PtrItem; p: ADDRESS;⓪"⓪"BEGIN⓪$IF coding () THEN⓪&p:= CodePtr () - CodeStart;⓪&item:= expr.varItem;⓪&IF item = NIL THEN⓪((* Verweis auf Konstante im DATA-Puffer *)⓪((*$? Safety: assert (expr.constHead # NIL); *)⓪(INC (RelocCount);⓪(l:= peekL (expr.constHead+2);⓪(IF l = 0 THEN LastDataRelocAdr:= expr.constHead+2 END;⓪(PutCode (l);⓪(pokeL (expr.constHead+2, p);⓪&ELSIF ItemNo (item) = 50 THEN⓪(INC (RelocCount);⓪(PutCode (LastConstLink (item));⓪(SetConstLink (item, p)⓪&ELSIF ItemNo (item) = 28 THEN⓪(INC (RelocCount);⓪(PutCode (LastTableLink (item));⓪(SetTableLink (item, p)⓪&ELSIF ItemNo (item) = 17 THEN⓪(INC (RelocCount);⓪(PutCode (LastVarLink (item));⓪(SetVarLink (item, p)⓪&ELSIF ItemNo (item) = 6 THEN⓪(IF global IN ItemFlag (item) THEN⓪*INC (RelocCount);⓪*PutCode (LastProcLink (item));⓪*SetProcLink (item, p)⓪(ELSE⓪*(*$R-*)⓪*IF VarAddress (item) = 0L THEN⓪,l:= LastProcLink (item);⓪,SetProcLink (item, CodePtr ());⓪,IF l = 0L THEN⓪.PutCode (CARDINAL(0))⓪,ELSE⓪.putw (l - CodePtr ());⓪,END⓪*ELSE⓪,putw (LONGCARD (VarAddress (item)) - CodePtr () + CodeStart);⓪*END⓪*(*$R=*)⓪(END⓪&ELSE⓪(bong⓪&END⓪$END;⓪"END RelocRef;⓪ ⓪ PROCEDURE ForwardRef (VAR target: Label);⓪"(* sieht Sprung-Adr. f. "Bcc.W" vor *)⓪"BEGIN⓪$IF coding () THEN⓪&target:= CodePtr ();⓪&PutCode ( CARDINAL(0) );⓪$ELSE⓪&target:= NIL⓪$END⓪"END ForwardRef;⓪ ⓪ PROCEDURE ToHere (target: Label);⓪"(* für BYTE/WORD-Offsets *)⓪"VAR (*$Reg*)ofs: LONGCARD; (*$Reg*)p: POINTER TO CARDINAL; pb: POINTER TO CHAR;⓪"BEGIN⓪$IF target # NIL THEN⓪&ofs:= CodePtr () - target;⓪&IF ODD (ofs) THEN⓪(DEC (ofs);⓪(IF ofs >= $80L THEN⓪*SyntaxError (rStruc)⓪(END;⓪(pb:= target;⓪(pb^:= CHR (SHORT (ofs));⓪&ELSE⓪(IF ofs >= $8000L THEN⓪*SyntaxError (rStruc)⓪(END;⓪(p:= target;⓪(p^:= SHORT (ofs);⓪&END;⓪$END⓪"END ToHere;⓪ ⓪ PROCEDURE encodeTail (VAR dest: ExprDesc; code: codeDesc);⓪"(* 'encode' ohne Ablegen des Op-Codes *)⓪"BEGIN⓪$IF code.reloc THEN⓪&RelocRef (dest)⓪$ELSIF code.extSize = 2 THEN⓪&PutCode (code.extWord)⓪$ELSIF code.extSize = 4 THEN⓪&PutCode (code.extLong)⓪$ELSIF code.extSize = 8 THEN⓪&PutCode (code.extDouble)⓪$END;⓪"END encodeTail;⓪ ⓪ PROCEDURE encode (VAR dest: ExprDesc; opcode: CARDINAL; code: codeDesc);⓪"BEGIN⓪$PutCode (opcode);⓪$encodeTail (dest, code);⓪"END encode;⓪ ⓪ PROCEDURE genClrReg (dest: RegType);⓪"(* Erz. MOVEQ #0,dest-Reg *)⓪"VAR opcode: CARDINAL;⓪"BEGIN⓪$opcode:= $7000;⓪$getDestReg (dest, opcode);⓪$IF coding () THEN⓪&PutCode (opcode)⓪$END⓪"END genClrReg;⓪ ⓪ PROCEDURE genMOVEQ (x: ZZ; dest: RegType);⓪"(* Erz. MOVEQ #x,dest-Reg *)⓪"VAR opcode: CARDINAL;⓪"BEGIN⓪$opcode:= $7000 + ORD (x.b);⓪$getDestReg (dest, opcode);⓪$IF coding () THEN⓪&PutCode (opcode)⓪$END⓪"END genMOVEQ;⓪ ⓪ PROCEDURE genMOVEir (x: ZZ; size: CARDINAL; dest: RegType);⓪"(* Erz. MOVE.size #v,dest-Reg *)⓪"VAR opcode: CARDINAL;⓪"BEGIN⓪$opcode:= $003C + sizedMOVE (size);⓪$getDestReg (dest, opcode);⓪$IF coding () THEN⓪&PutCode (opcode);⓪&IF size > 2 THEN PutCode (x.v) ELSE PutCode (x.i) END⓪$END⓪"END genMOVEir;⓪ ⓪ PROCEDURE genMOVEimmind (source: ADDRESS; dest: RegType; size: CARDINAL; inc: BOOLEAN);⓪"(* Erz. MOVE.x #source,(dest-Reg)+ *)⓪"VAR (*$Reg*)n, (*$Reg*)opcode: CARDINAL;⓪&(*$Reg*)p: POINTER TO BYTE;⓪"BEGIN⓪$updateStackOffsets (dest, inc, size);⓪$opcode:= $003C + sizedMOVE (size);⓪$IF inc THEN INC (opcode, $00C0) ELSE INC (opcode, $0080) END;⓪$INC (opcode, (dest-A0) * $200);⓪$IF coding () THEN⓪&PutCode (opcode);⓪&IF size = 1 THEN⓪(p:= source;⓪(PutCode (ORD (p^))⓪&ELSE⓪(REPEAT⓪*p:= source;⓪*n:= ORD (p^) * 256;⓪*INC (p);⓪*PutCode (n + ORD (p^));⓪*INC (source, 2);⓪*DEC (size, 2)⓪(UNTIL size = 0⓪&END⓪$END⓪"END genMOVEimmind;⓪ ⓪ PROCEDURE genMOVErind (source, dest: RegType; size: CARDINAL; inc: BOOLEAN);⓪"(* Erz. MOVE.x source-Reg,(dest-Reg)+ *)⓪"VAR (*$Reg*)opcode: CARDINAL;⓪"BEGIN⓪$updateStackOffsets (dest, inc, size);⓪$opcode:= sizedMOVE (size);⓪$IF inc THEN INC (opcode, $00C0) ELSE INC (opcode, $0080) END;⓪$INC (opcode, source);⓪$INC (opcode, (dest-A0) * $200);⓪$IF coding () THEN⓪&PutCode (opcode)⓪$END⓪"END genMOVErind;⓪ ⓪ PROCEDURE genMOVEaind (VAR source: ExprDesc; dest: RegType;⓪7size: CARDINAL; inc: BOOLEAN);⓪"(* Erz. MOVE.x source,(dest-Reg)+ *)⓪"VAR opcode: CARDINAL; code: codeDesc;⓪"BEGIN⓪$updateStackOffsets (dest, inc, size);⓪$IF size = 0 THEN size:= SHORT (Size (source)) END;⓪$opcode:= sizedMOVE (size);⓪$IF inc THEN⓪&IF dest = A7 THEN⓪(INC (opcode, $0100) (* ~~~ ggf. PEA verwenden bei aufrufer *)⓪&ELSE⓪(INC (opcode, $00C0)⓪&END⓪$ELSE⓪&INC (opcode, $0080)⓪$END;⓪$INC (opcode, (dest-A0) * $200);⓪$getSrcEA (source, size, opcode, code);⓪$IF coding () THEN⓪&encode (source, opcode, code);⓪$END⓪"END genMOVEaind;⓪ ⓪ PROCEDURE genCLRind (dest: RegType; size: CARDINAL; inc: BOOLEAN);⓪"(* Erz. CLR.x (dest-Reg)+ *)⓪"VAR opcode: CARDINAL;⓪"BEGIN⓪$updateStackOffsets (dest, inc, size);⓪$IF inc THEN⓪&IF dest = A7 THEN⓪(opcode:= CLR + $0020⓪&ELSE⓪(opcode:= CLR + $0018⓪&END⓪$ELSE opcode:= CLR + $0010 END;⓪$getSizeAt6 (size, opcode);⓪$INC (opcode, dest-A0);⓪$IF coding () THEN⓪&PutCode (opcode)⓪$END⓪"END genCLRind;⓪ ⓪ PROCEDURE genMOVEindind (source, dest: RegType; size: CARDINAL; inc: BOOLEAN);⓪"(* Erz. MOVE.x (source-Reg)+,(dest-Reg)+ *)⓪"VAR (*$Reg*)opcode: CARDINAL;⓪"BEGIN⓪$updateStackOffsets (source, inc, size);⓪$updateStackOffsets (dest, inc, size);⓪$opcode:= sizedMOVE (size);⓪$IF inc THEN INC (opcode, $00D8) ELSE INC (opcode, $0090) END;⓪$INC (opcode, source-A0);⓪$INC (opcode, (dest-A0) * $200);⓪$IF coding () THEN⓪&PutCode (opcode)⓪$END⓪"END genMOVEindind;⓪ ⓪ PROCEDURE genMOVEar (VAR source: ExprDesc; dest: RegType);⓪"(* Erz. MOVE.x source,dest-Reg *)⓪"VAR opcode: CARDINAL; code: codeDesc;⓪"BEGIN⓪$opcode:= MOVE;⓪$getDestReg (dest, opcode);⓪$getSizeForMOVE (source, opcode);⓪$getSrcEA (source, 0, opcode, code);⓪$IF coding () THEN⓪&encode (source, opcode, code);⓪$END⓪"END genMOVEar;⓪ ⓪ PROCEDURE genMOVEaa (VAR source, dest: ExprDesc; size: CARDINAL);⓪"(* Erz. MOVE.x source,dest *)⓪"VAR opcode: CARDINAL; VAR code, code2: codeDesc;⓪"BEGIN⓪$IF size = 0 THEN size:= SHORT (Size (source)) END;⓪$(*$? Safety2: assert ( (dest.kind#stack) OR (source.kind#stack)⓪<OR (source.stackReg#dest.stackReg) ); *)⓪$opcode:= 0;⓪$getSrcEA (dest, size, opcode, code2);⓪$ASSEMBLER ; versch. SrcEA nach DestEA⓪&MOVE opcode(A6),D0⓪&MOVE D0,D1⓪&ANDI #7,D0⓪&ANDI #$38,D1⓪&LSL #3,D1⓪&ROR #7,D0⓪&OR D1,D0⓪&MOVE D0,opcode(A6)⓪$END;⓪$INC (opcode, sizedMOVE (size));⓪$getSrcEA (source, size, opcode, code);⓪$IF coding () THEN⓪&encode (source, opcode, code);⓪&encodeTail (dest, code2)⓪$END⓪"END genMOVEaa;⓪ ⓪ PROCEDURE genMOVErr (source, dest: RegType; size: CARDINAL);⓪"(* Erz. MOVE.L source-Reg,dest-Reg *)⓪"VAR n: CARDINAL;⓪"BEGIN⓪$n:= sizedMOVE (size) + source;⓪$getDestReg (dest, n);⓪$IF coding () THEN⓪&PutCode (n)⓪$END⓪"END genMOVErr;⓪ ⓪ PROCEDURE genMOVELIndTo (source, dest: RegType; offset: INTEGER);⓪"(* Erz. MOVE.L [offset](source-Reg),dest-Reg *)⓪"VAR (*$Reg*)n: CARDINAL;⓪"BEGIN⓪$n:= 0010000000010000% + source - A0;⓪$IF dest < A0 THEN⓪&INC (n, dest * $200)⓪$ELSE⓪&INC (n, (dest-A0) * $200 + $40)⓪$END;⓪$IF coding () THEN⓪&IF offset = 0 THEN⓪(PutCode (n)⓪&ELSE⓪(PutCode (n - $10 + $28);⓪(PutCode (offset)⓪&END⓪$END⓪"END genMOVELIndTo;⓪ ⓪ PROCEDURE genADDA (long: BOOLEAN; sourceReg, destReg: RegType);⓪"(* Erz. ADDA.size Xn,An *)⓪"VAR (*$Reg*)n: CARDINAL;⓪"BEGIN⓪$IF coding () THEN⓪&IF long THEN⓪(n:= $D1C0⓪&ELSE⓪(n:= $D0C0⓪&END;⓪&PutCode (n + sourceReg + $200 * (destReg-A0))⓪$END⓪"END genADDA;⓪ ⓪ PROCEDURE genSUBA (long: BOOLEAN; sourceReg, destReg: RegType);⓪"(* Erz. SUBA.size Xn,An *)⓪"VAR (*$Reg*)n: CARDINAL;⓪"BEGIN⓪$IF coding () THEN⓪&IF long THEN⓪(n:= $91C0⓪&ELSE⓪(n:= $90C0⓪&END;⓪&PutCode (n + sourceReg + $200 * (destReg-A0))⓪$END⓪"END genSUBA;⓪ ⓪ PROCEDURE genADDAL (ofs: LONGINT; reg: RegType);⓪"(* Erz. ADDA.L #n,An *)⓪"BEGIN⓪$updateStackOffsets (reg, TRUE, ofs);⓪$IF coding () THEN⓪&PutCode ($D1FC + $200 * (reg-A0));⓪&PutCode (ofs)⓪$END⓪"END genADDAL;⓪ ⓪ PROCEDURE genia (opcode: CARDINAL; data: ARRAY OF WORD; VAR dest: ExprDesc;⓪1size: LONGINT);⓪"(* z.B. ANDI #data,dest *)⓪"(* ist die Type-Größe Byte oder Word und 'data' ein Long, wird nur das⓪#* 2. Word als Konstante abgelegt. *)⓪"VAR code: codeDesc;⓪"BEGIN⓪$(*$? Safety2: assert ((dest.kind # register) OR (dest.exprReg < A0)); *)⓪$IF size = 0L THEN size:= Size (dest) END;⓪$getSizeAt6 (size, opcode);⓪$CASE dest.kind OF⓪$| condFlags, constant: bong⓪$ELSE⓪&getSrcEA (dest, SHORT (size), opcode, code);⓪$END;⓪$IF coding () THEN⓪&PutCode (opcode);⓪&IF ABS(size)<=2L THEN⓪(PutCode (data [HIGH (data)])⓪&ELSE⓪(PutCode (data [0]);⓪(PutCode (data [1])⓪&END;⓪&encodeTail (dest, code)⓪$END⓪"END genia;⓪ ⓪ PROCEDURE genra (opcode: CARDINAL; sourceReg: RegType; VAR dest: ExprDesc);⓪"(* z.B. ADD Dn,dest *)⓪"(* wenn 'dest' ein Reg ist, wird automatisch die andere Adr-Art "<ea>,Dn"⓪#* codiert *)⓪"VAR code: codeDesc; (*$Reg*)size: INTEGER;⓪"BEGIN⓪$(*$? Safety2: assert (sourceReg < A0); *)⓪$IF dest.kind = register THEN⓪&(*$? Safety2: assert (dest.exprReg < A0); *)⓪&INC (opcode, $200 * dest.exprReg + sourceReg);⓪&getSizeAt6 (SHORT (Size (dest)), opcode);⓪&IF coding () THEN⓪(PutCode (opcode)⓪&END⓪$ELSE⓪&INC (opcode, $100 + $200 * sourceReg);⓪&size:= SHORT (Size (dest));⓪&getSizeAt6 (size, opcode);⓪&getSrcEA (dest, size, opcode, code);⓪&IF coding () THEN⓪(encode (dest, opcode, code)⓪&END⓪$END⓪"END genra;⓪ ⓪ PROCEDURE genPEA ( VAR dest: ExprDesc );⓪"VAR code: codeDesc; opcode: CARDINAL;⓪"BEGIN⓪$opcode:= PEA;⓪$updateStackOffsets (A7, FALSE, 4);⓪$getSrcEA (dest, 0, opcode, code);⓪$IF coding () THEN⓪&encode (dest, opcode, code);⓪$END⓪"END genPEA;⓪ ⓪ PROCEDURE gena ( opcode: CARDINAL; VAR dest: ExprDesc; size: INTEGER );⓪"(* generiere Instruktion mit Addressmode, z.B. "TST" *)⓪"VAR code: codeDesc;⓪"BEGIN⓪$(*$? Safety2: assert ((dest.kind # register) OR (dest.exprReg < A0)); *)⓪$IF size = 0 THEN⓪&getSizeAt6 (Size (dest), opcode)⓪$ELSIF size > 0 THEN⓪&getSizeAt6 (size, opcode)⓪$END;⓪$CASE dest.kind OF⓪$| condFlags, constant: bong⓪$ELSE⓪&getSrcEA (dest, size, opcode, code);⓪$END;⓪$IF coding () THEN⓪&encode (dest, opcode, code);⓪$END⓪"END gena;⓪ ⓪ PROCEDURE genarSized ( opcode: CARDINAL; VAR source: ExprDesc; dest: RegType;⓪7size: LONGINT );⓪"(* wenn 'dest' ein Adreß-Reg, wird Size nach ADDA/LEA, usw. bestimmt *)⓪"VAR code: codeDesc;⓪"BEGIN⓪$IF dest < A0 THEN⓪&IF NOT sizedAt6 (opcode) THEN⓪(getSizeAt6 (size, opcode);⓪&END;⓪&getDestReg (dest, opcode);⓪$ELSE⓪&(*$? Safety2: assert ((dest # A3) & (dest # A7)); *) (* wg. updateStackOffset *)⓪&INC (opcode, (dest-A0) * $200 + AnSized (size))⓪$END;⓪$getSrcEA (source, SHORT (size), opcode, code);⓪$IF coding () THEN⓪&encode (source, opcode, code);⓪$END⓪"END genarSized;⓪ ⓪ PROCEDURE genar ( opcode: CARDINAL; VAR source: ExprDesc; dest: RegType );⓪"(* wenn 'dest' ein Adreß-Reg, wird Size nach ADDA/LEA, usw. bestimmt *)⓪"BEGIN⓪$genarSized (opcode, source, dest, Size (source));⓪"END genar;⓪ ⓪ PROCEDURE genEXG (r1, r2: RegType);⓪"VAR (*$Reg*)opcode: CARDINAL; (*$Reg*)r: RegType;⓪"BEGIN⓪$(*$? Safety: assert ((r1 < F0) & (r2 < F0));*)⓪$opcode:= EXG;⓪$IF r1 >= A0 THEN⓪&DEC (r1,A0);⓪&IF r2 >= A0 THEN⓪(INC (opcode, 01001000%);⓪(DEC (r2,A0);⓪&ELSE⓪(INC (opcode, 10001000%);⓪&END⓪$ELSIF r2 >= A0 THEN⓪&INC (opcode, 10001000%);⓪&DEC (r2,A0);⓪&r:= r1; r1:= r2; r2:= r⓪$ELSE⓪&INC (opcode, 01000000%);⓪$END;⓪$IF coding () THEN⓪&PutCode (opcode + r1 + $200 * r2);⓪$END⓪"END genEXG;⓪"⓪ PROCEDURE gen ( opcode: WORD );⓪"BEGIN⓪$IF coding () THEN⓪&PutCode (opcode);⓪$END⓪"END gen;⓪ ⓪ PROCEDURE setByte (at: ADDRESS; b: BYTE);⓪"(* z. B. für Setzen eines Short-BRA-Offsets *)⓪"VAR (*$Reg*)p: POINTER TO BYTE;⓪"BEGIN⓪$IF coding () THEN⓪&p:= at;⓪&p^:= b⓪$END⓪"END setByte;⓪ ⓪ PROCEDURE genr ( opcode: CARDINAL; dest: RegType );⓪"(* f. EXT (Reg. ab Bit 0), Achtung: Keine Size-Bestimmung! *)⓪"BEGIN⓪$(*$? Safety2: assert (dest < A0); *)⓪$gen (opcode + dest);⓪"END genr;⓪ ⓪ PROCEDURE genANDI (size: CARDINAL; data: ARRAY OF WORD; dest: RegType);⓪"VAR opcode: CARDINAL;⓪"BEGIN⓪$(*$? Safety2: assert (dest < A0); *)⓪$opcode:= ANDI + dest;⓪$getSizeAt6 (size, opcode);⓪$IF coding () THEN⓪&PutCode (opcode);⓪&IF size = 4 THEN⓪(PutCode (data [0]);⓪(PutCode (data [1])⓪&ELSE⓪(PutCode (data [HIGH (data)])⓪&END⓪$END⓪"END genANDI;⓪ ⓪ PROCEDURE genir (opcode: CARDINAL; long: BOOLEAN; data: ARRAY OF WORD; dest: RegType);⓪"(* z.B. f. MULU, der ea-code immediate-adressierung wird hier generiert *)⓪"(* dest-Reg muß Dn, nicht An, sein! *)⓪"VAR code: codeDesc;⓪"BEGIN⓪$IF coding () THEN⓪&INC (opcode, $3C + dest * $200);⓪&PutCode (opcode);⓪&IF long THEN⓪(PutCode (data [0]);⓪(PutCode (data [1])⓪&ELSE⓪(PutCode (data [HIGH (data)])⓪&END;⓪$END⓪"END genir;⓪ ⓪ PROCEDURE genBool ( cc: CARDINAL; int_fpu: BOOLEAN; VAR dest: ExprDesc );⓪"(* gen. Scc und anschließendem AND #1 *)⓪"(* geht nicht bei REALs! *)⓪"VAR code: codeDesc; opcode: CARDINAL;⓪"BEGIN⓪$(*$? Safety: assert (BooleanType (dest.item)); *)⓪$(* Scc bzw. FScc erzeugen *)⓪$IF int_fpu THEN⓪&(*$? Safety: assert (fpu () = internalFPU); *)⓪&opcode:= $F240⓪$ELSE⓪&opcode:= SCC + cc;⓪$END;⓪$getSrcEA (dest, 0, opcode, code);⓪$IF coding () THEN⓪&PutCode (opcode);⓪&IF int_fpu THEN PutCode (cc) END;⓪&encodeTail (dest, code)⓪$END;⓪$(* ANDI #1 erzeugen *)⓪$opcode:= ANDI;⓪$getSizeAt6 (2, opcode);⓪$getSrcEA (dest, 2, opcode, code);⓪$IF coding () THEN⓪&PutCode (opcode);⓪&PutCode (CARDINAL(1));⓪&encodeTail (dest, code)⓪$END⓪"END genBool;⓪ ⓪ ⓪ PROCEDURE genbcc ( cc: CARDINAL; int_fpu: BOOLEAN; VAR target: Label );⓪"(* Gen. Bcc.W mit Vorwärts-Ref., Ansprung durch 'ToHere (target)' *)⓪"BEGIN⓪$IF coding () THEN⓪&IF int_fpu THEN⓪(PutCode ($F280 + cc);⓪&ELSE⓪(PutCode (Bcc + cc);⓪&END;⓪&ForwardRef (target);⓪$ELSE⓪&target:= NIL⓪$END⓪"END genbcc;⓪ ⓪ PROCEDURE genbccs ( cc: CARDINAL; VAR target: Label );⓪"(* Gen. Bcc.B mit Vorwärts-Ref., Ansprung durch 'ToHere (target)' *)⓪"BEGIN⓪$IF coding () THEN⓪&PutCode (Bcc + cc);⓪&target:= CodePtr () - 1L;⓪$ELSE⓪&target:= NIL⓪$END⓪"END genbccs;⓪ ⓪ PROCEDURE genDBcc ( cc: CARDINAL; reg: RegType; distance: LONGINT );⓪"(* Gen. DBcc _ohne_ offene Vorwärts-Ref. *)⓪"BEGIN⓪$(*$? Safety: assert ((distance < 0L) & NOT ODD (distance)); *)⓪$IF coding () THEN⓪&IF distance <= -32768L THEN⓪((*~~~ long-bra *) SyntaxError (rBranc)⓪&END;⓪&PutCode (DBcc + cc + reg);⓪&PutCode (SHORT (distance));⓪$END⓪"END genDBcc;⓪ ⓪ PROCEDURE bccBackTo (cc: CARDINAL; target: ADDRESS);⓪"VAR (*$Reg*)diff: LONGINT;⓪"BEGIN⓪$diff:= LONGINT (target) - LONGINT (CodePtr () + 2L);⓪$(*$? Safety: assert ((diff < 0L) & NOT ODD (diff)); *)⓪$IF diff > -128L THEN⓪&gen (Bcc + cc + lowByte (diff))⓪$ELSIF diff > -32768L THEN⓪&gen (Bcc + cc);⓪&gen (SHORT (diff))⓪$ELSIF coding () THEN⓪&(*~~~ long-bra *) SyntaxError (rBranc)⓪$END⓪"END bccBackTo;⓪ ⓪ PROCEDURE dbccBackTo (cc: CARDINAL; reg: RegType; target: ADDRESS);⓪"VAR (*$Reg*)diff: LONGINT;⓪"BEGIN⓪$diff:= LONGINT (target) - LONGINT (CodePtr () + 2L);⓪$(*$? Safety: assert ((diff < 0L) & NOT ODD (diff)); *)⓪$IF diff > -32768L THEN⓪&gen (DBcc + reg + cc);⓪&gen (SHORT (diff))⓪$ELSIF coding () THEN⓪&(*~~~ long-dbra *) SyntaxError (rBranc)⓪$END⓪"END dbccBackTo;⓪ ⓪ ⓪ PROCEDURE genLEA (VAR expr: ExprDesc; dest: RegType);⓪"VAR (*$Reg*)t: PtrItem;⓪"BEGIN⓪$(*$? Safety2: assert (dest >= A0); *)⓪$t:= expr.item; expr.item:= CardPtr;⓪$genar (LEA, expr, dest);⓪$expr.item:= t;⓪"END genLEA;⓪ ⓪ (*⓪ PROCEDURE genLEAabs (VAR x: ADDRESS; dest: RegType);⓪"(* LEA $xxxxxxxx,An *)⓪"BEGIN⓪$(*$? Safety2: assert (dest >= A0);*)⓪$IF coding () THEN⓪&PutCode (LEA + $01C0 + 111001% + $200 * dest);⓪&RelocRef (x)⓪$END⓪"END genLEAabs;⓪ *)⓪ ⓪ PROCEDURE genLEApcrel (x: ADDRESS; dest: RegType);⓪"(* LEA y(PC),An 'y' wird aus 'CodePtr - x' berechnet *)⓪"(* 'x' muß schon eine existente Adr. vorher im Code sein! *)⓪"VAR (*$Reg*)diff: LONGINT;⓪"BEGIN⓪$(*$? Safety2: assert (dest >= A0);*)⓪$IF coding () THEN⓪&(* diff-Prüfung darf nur bei coding() erfolgen, sonst Fehler bei IF FALSE...! *)⓪&diff:= LONGINT (x) - LONGINT (CodePtr () + 2L);⓪&IF diff < LONG (MinInt) THEN⓪(SyntaxError (rBranc) (* branch too long *)⓪((*~~~ hier und auch bei anderen relativen sprüngen dann ggf. mit⓪)* hilfsreg. arbeiten, damit auch procs > 32K werden können! *)⓪&END;⓪&PutCode (LEA + $01C0 + 111010% + $200 * (dest-A0));⓪&PutCode (SHORT (diff))⓪$END⓪"END genLEApcrel;⓪ ⓪ ⓪ PROCEDURE genLEArel (c: INTEGER; source,dest: RegType);⓪"(* LEA c(An),Am *)⓪"BEGIN⓪$(*$? Safety2: assert ((dest >= A0) & (source >= A0)); *)⓪$updateStackOffsets (dest, TRUE, c);⓪$IF coding () THEN⓪&PutCode (LEA + $01C0 + source + 100000% + $200 * (dest-A0));⓪&PutCode (c)⓪$END⓪"END genLEArel;⓪ ⓪ ⓪ PROCEDURE genQr (ofs: INTEGER; size: CARDINAL; reg: RegType);⓪"(* gen. ADDQ/SUBQ je nach 'ofs' *)⓪"VAR opcode: CARDINAL;⓪"BEGIN⓪$updateStackOffsets (reg, TRUE, ofs);⓪$IF ofs < 0 THEN⓪&ofs:= -ofs;⓪&opcode:= SUBQ⓪$ELSE⓪&opcode:= ADDQ⓪$END;⓪$(*$? Safety: assert ( (ofs>=1) & (ofs<=8) & (size > 0) );*)⓪$getSizeAt6 (size, opcode);⓪$IF coding () THEN⓪&PutCode (opcode + CARDINAL (ofs) MOD 8 * $200 + reg)⓪$END;⓪"END genQr;⓪ ⓪ PROCEDURE genQ (ofs: INTEGER; VAR expr: ExprDesc);⓪"(* gen. ADDQ/SUBQ je nach 'ofs' *)⓪"VAR (*$Reg*)opcode: CARDINAL;⓪"BEGIN⓪$IF expr.kind = register THEN⓪&genQr (ofs, SHORT (Size (expr)), expr.exprReg)⓪$ELSE⓪&IF ofs < 0 THEN⓪(ofs:= -ofs;⓪(opcode:= SUBQ⓪&ELSE⓪(opcode:= ADDQ⓪&END;⓪&(*$? Safety: assert ( (ofs>=1) & (ofs<=8) );*)⓪&gena (opcode + CARDINAL (ofs) MOD 8 * $200, expr, 0)⓪$END⓪"END genQ;⓪ ⓪ PROCEDURE syncStack (size: LONGCARD; destReg: RegType; dir: Directions);⓪"BEGIN⓪$IF ODD (size) & (destReg # A7) THEN⓪&IF dir = up THEN⓪(genQr (1, 4, destReg)⓪&ELSIF dir = down THEN⓪(genQr (-1, 4, destReg)⓪&END⓪$END⓪"END syncStack;⓪ ⓪ ⓪ PROCEDURE genPushReg (source: RegType; long: BOOLEAN; destReg: RegType);⓪"(* packt Reg auf A3- oder A7-Stack *)⓪"VAR (*$Reg*)size, (*$Reg*)opcode: CARDINAL;⓪"BEGIN⓪$IF long THEN size:= 4 ELSE size:= 2 END;⓪$CASE destReg OF⓪$| A3: (* "(A3)+" *)⓪*IF long THEN opcode:= 0010011011000000% ELSE opcode:= 0011011011000000% END;⓪$| A7: (* "-(A7)" *)⓪*IF long & (source >= A0) THEN⓪,opcode:= PEA + 010000%;⓪,DEC (source, A0);⓪*ELSE⓪,IF long THEN opcode:= 0010111100000000% ELSE opcode:= 0011111100000000% END;⓪*END⓪$ELSE⓪&bong⓪$END;⓪$updateStackOffsets (destReg, (destReg = A3), size);⓪$IF coding () THEN⓪&PutCode (opcode + source)⓪$END⓪"END genPushReg;⓪ ⓪ PROCEDURE genPush (VAR source: ExprDesc; size: CARDINAL;⓪3destReg: RegType; dir: Directions);⓪"(* packt Datum auf A3- oder A7-Stack *)⓪"(* ACHTUNG: vorher prüfen, ob es sich schon dort befindet! *)⓪"(* wenn size = 0, wird sie aus 'source' ermittelt *)⓪"VAR code: codeDesc; opcode: CARDINAL;⓪"BEGIN⓪$IF size = 0 THEN size:= SHORT (Size (source)) END;⓪$IF dir = noDir THEN⓪&(* "(An)" *)⓪&opcode:= 0000000010000000%⓪$ELSE⓪&IF dir = up THEN⓪((* "(An)+" *)⓪(opcode:= 0000000011000000%;⓪(updateStackOffsets (destReg, TRUE, size);⓪&ELSE⓪((* "-(An)" *)⓪(IF (source.kind = register) & (source.exprReg >= A0) & (destReg = A7) THEN⓪*(*$? Safety2: assert (size # 1); *)⓪*genPushReg (source.exprReg, size = 4, A7);⓪*RETURN⓪(END;⓪(opcode:= 0000000100000000%;⓪(updateStackOffsets (destReg, FALSE, size);⓪&END⓪$END;⓪$INC (opcode, (destReg-A0) * $200);⓪$INC (opcode, sizedMOVE (size));⓪$getSrcEA (source, size, opcode, code);⓪$IF coding () THEN⓪&encode (source, opcode, code);⓪$END⓪"END genPush;⓪ ⓪ PROCEDURE genPushConst (const: LONGCARD; size: CARDINAL;⓪8destReg: RegType; dir: Directions);⓪"(* packt Konst. auf A3- oder A7-Stack *)⓪"VAR code: codeDesc; (*$Reg*)opcode: CARDINAL;⓪"BEGIN⓪$CASE dir OF⓪$| up: (* "(An)+" *) opcode:= 0000000011111100%;⓪,updateStackOffsets (destReg, TRUE, size);⓪$| down: (* "-(An)" *) opcode:= 0000000100111100%;⓪,updateStackOffsets (destReg, FALSE, size);⓪$| noDir:(* "(An)" *) opcode:= 0000000010111100%⓪$END;⓪$INC (opcode, (destReg-A0) * $200);⓪$INC (opcode, sizedMOVE (size));⓪$IF coding () THEN⓪&PutCode (opcode);⓪&IF size < 4 THEN⓪((*$R-*)⓪(PutCode (SHORT (const));⓪((*$R=*)⓪&ELSE⓪(PutCode (const)⓪&END⓪$END⓪"END genPushConst;⓪ ⓪ PROCEDURE genPopReg (reg: RegType; long: BOOLEAN; stack: RegType);⓪"(* lädt Reg vom A3- oder A7-Stack *)⓪"VAR (*$Reg*)size, opcode: CARDINAL;⓪"BEGIN⓪$CASE stack OF⓪$| A3: (* "-(A3)" *) opcode:= 0011000000100011%⓪$| A7: (* "(A7)+" *) opcode:= 0011000000011111%⓪$END;⓪$IF long THEN size:= 4 ELSE size:= 2 END;⓪$updateStackOffsets (stack, (stack = A7), size);⓪$IF long THEN DEC (opcode, $1000) END;⓪$getDestReg (reg, opcode);⓪$IF coding () THEN⓪&PutCode (opcode)⓪$END⓪"END genPopReg;⓪ ⓪ PROCEDURE genPullReg (VAR source: ExprDesc; long: BOOLEAN; to: RegType);⓪"(* lädt Reg vom A3- oder A7-Stack *)⓪"VAR (*$Reg*)reg, (*$Reg*)size, opcode: CARDINAL;⓪"BEGIN⓪$IF source.kind = memory THEN⓪&CASE source.mode OF⓪&| ptrOnA3: reg:= A3⓪&| ptrOnA7: reg:= A7⓪&END;⓪$ELSE⓪&(*$? Safety2: assert (source.kind = spilledSP);*)⓪®:= source.spillReg;⓪$END;⓪$IF reg = A3 THEN⓪&(* "-(A3)" *) opcode:= 0011000000100011%⓪$ELSE⓪&(*$? Safety2: assert (reg = A7); *)⓪&(* "(A7)+" *) opcode:= 0011000000011111%⓪$END;⓪$IF long THEN size:= 4 ELSE size:= 2 END;⓪$updateStackOffsets (reg, (reg = A7), size);⓪$IF long THEN DEC (opcode, $1000) END;⓪$getDestReg (to, opcode);⓪$IF coding () THEN⓪&PutCode (opcode)⓪$END⓪"END genPullReg;⓪ ⓪ PROCEDURE genPushAddress (VAR source: ExprDesc; destReg: RegType);⓪"(*⓪#* kann in dieser Form nur von spillReg() verwendet werden!⓪#*)⓪"VAR code: codeDesc;⓪"BEGIN⓪$(*$? Safety2: assert (source.kind = memory);*)⓪$IF destReg = A3 THEN⓪&genLEA (source, source.baseReg);⓪&genPushReg (source.baseReg, TRUE, destReg)⓪$ELSIF destReg = A7 THEN⓪&genPEA (source)⓪$ELSE⓪&bong⓪$END⓪"END genPushAddress;⓪ ⓪ PROCEDURE addConstToAddrReg (c: LONGINT; reg: RegType);⓪"BEGIN⓪$(*$? Safety2: assert (reg IN (RegSet {A0..A7}));*)⓪$IF ABS (c) <= 8L THEN⓪&genQr (SHORT (c), 4, reg)⓪$ELSIF ABS (c) <= 32767L THEN⓪&genLEArel (SHORT (c), reg, reg)⓪$ELSE⓪&genADDAL (c, reg)⓪$END⓪"END addConstToAddrReg;⓪ ⓪ FORWARD initConstExpr (VAR expr: ExprDesc; size: CARDINAL; const: ZZ);⓪ ⓪ PROCEDURE incReg (reg: RegType; i: ZZ; size: CARDINAL);⓪"(*⓪#* erhöht oder erniedrigt ein Register um einen konstanten Wert⓪#*)⓪"VAR const: ExprDesc; (*$Reg*)opcode: CARDINAL;⓪"BEGIN⓪$IF NOT nullZZ (i) THEN⓪&IF int3ZZ (i) THEN⓪(genQr (i.i, size, reg)⓪&ELSE⓪(IF reg >= A0 THEN⓪*addConstToAddrReg (i.v, reg)⓪(ELSE⓪*IF posZZ (i) THEN⓪,opcode:= ADD⓪*ELSE⓪,opcode:= SUB;⓪,negZZ (i)⓪*END;⓪*initConstExpr (const, size, i);⓪*genar (opcode, const, reg)⓪(END⓪&END⓪$END⓪"END incReg;⓪ ⓪ ⓪ PROCEDURE dropNewConstant (addr: ADDRESS; size: LONGCARD; VAR oldexpr: ExprDesc);⓪"(*⓪#* Legt Daten von 'addr' als eigene Konstante im DATA-Puffer an.⓪#* 'size' darf auch Null sein (3.6.94).⓪#*)⓪"VAR pc: POINTER TO CHAR; (*$Reg*)origSize: LONGCARD;⓪&expr: ExprDesc;⓪"BEGIN⓪$(*⓪%* Const ab 'addr' wird im DATA-Puffer abgelegt - ggf. kann sie von⓪%* constantFold wieder weggekürzt werden.⓪%*)⓪$expr:= oldexpr; (* kopie anlegen, weil ggf. 'addr' auf selbe expr zeigt *)⓪$origSize:= size;⓪$WITH expr DO⓪&varItem:= NIL; (* nun keine Tree-Referenz mehr *)⓪&IF ItemNo (item) = 27 THEN⓪((* String 0-terminieren *)⓪(pc:= addr + size - 1L;⓪(IF pc^ # 0C THEN INC (size) END⓪&END;⓪&IF ODD (size) THEN INC (size) END;⓪&IF size >= LONG (MaxInt) THEN (* das wäre nicht mehr besonders sinnvoll... *)⓪(SyntaxError (rConLg)⓪&END;⓪&kind:= constRef;⓪&constOfs:= 0;⓪&constAddr:= NIL;⓪&constHead:= NIL;⓪&IF NOT SuppressCode THEN⓪(constHead:= DataPtr;⓪(PutData (VAL (CARDINAL, size));⓪(PutData (LONGCARD (0));⓪(constAddr:= DataPtr;⓪(Move (addr, constAddr, SHORT (size));⓪(Clear (constAddr + origSize, SHORT (size - origSize));⓪(INC (DataPtr, size);⓪&ELSE⓪((*$? Safety: assert (NOT InConstExpr)*)⓪&END;⓪$END;⓪$oldexpr:= expr;⓪$DataSpace;⓪"END dropNewConstant;⓪ (*$D-*)⓪ ⓪ PROCEDURE constantAtEnd (VAR expr: ExprDesc): BOOLEAN;⓪"(*⓪#* Liefert TRUE, wenn Const am Ende vom Data-Puffer abgelegt ist.⓪#*)⓪"VAR pc: POINTER TO CARDINAL;⓪"BEGIN⓪$(*$? Safety: assert (expr.kind = constRef);*)⓪$pc:= expr.constHead;⓪$RETURN (pc # NIL) AND (DataPtr = expr.constAddr + LONG(pc^));⓪"END constantAtEnd;⓪ ⓪ (* nicht benötigt⓪$PROCEDURE constantFollows (REF second, first: ExprDesc): BOOLEAN;⓪&(*⓪'* Liefert TRUE, wenn 'second' genau hiner 'first' liegt⓪'*)⓪&VAR pc: POINTER TO CARDINAL;⓪&BEGIN⓪((*$? Safety: assert (first.kind = constRef);*)⓪((*$? Safety: assert (first.constHead # NIL);*)⓪((*$? Safety: assert (second.kind = constRef);*)⓪((*$? Safety: assert (second.constHead # NIL);*)⓪(pc:= first.constHead;⓪(RETURN (second.constHead = first.constAddr + LONG(pc^));⓪&END constantFollows;⓪ *)⓪ ⓪ PROCEDURE extendConstant (newSize: LONGCARD; VAR expr: ExprDesc);⓪"(*⓪#* erweitert Konstante im Puffer (muß mit dropNewConstant erzeugt sein).⓪#*)⓪"VAR pc: POINTER TO CARDINAL; (*$Reg*)origSize: LONGCARD;⓪"BEGIN⓪$(*$? Safety: assert (newSize > 0L);*)⓪$origSize:= newSize;⓪$WITH expr DO⓪&(*$? Safety: assert (kind = constRef);*)⓪&IF ODD (newSize) THEN INC (newSize) END;⓪&IF newSize >= LONG (MaxInt) THEN (* das wäre nicht mehr besonders sinnvoll... *)⓪(SyntaxError (rConLg)⓪&END;⓪&IF NOT SuppressCode THEN⓪((*$? Safety: assert (constHead # NIL); *)⓪((*$? Safety: pc:= constHead; assert (DataPtr = constAddr + LONG(pc^)); *)⓪(DataPtr:= constAddr + newSize;⓪(pc:= constHead;⓪(pc^:= SHORT(newSize);⓪&ELSE⓪((*$? Safety: assert (NOT InConstExpr)*)⓪&END;⓪$END;⓪$DataSpace;⓪"END extendConstant;⓪ ⓪ PROCEDURE addNewConstant (addr: ADDRESS; dataSize, addSize: LONGCARD;⓪7VAR expr: ExprDesc);⓪"(*⓪#* Fügt weitere Werte an die mit 'dropNewConstant' im DATA-Puffer abgelegte⓪#* Konstante an.⓪#* Es wird kein Null-Zeichen mehr bei String-Consts angefügt! Das ist⓪#* nur nötig, falls man CADR auf eine String-Const anwendet und das ist⓪#* bei einer zusammengesetzten Const sowieso nicht mehr sinnvoll.⓪#* Achtung: Es kann vorkommen (in addToConstPar), daß die Konstante⓪#* innerhalb des neu zu belegenden Speichers liegt, also nur ein Stück⓪#* zurückverschoben wird. Somit sicherstellen, daß vor dem Move() der⓪#* vermeintlich freie Speicher hinter 'DataPtr' nicht verändert wird!⓪#*)⓪"VAR (*$Reg*)oldSize, (*$Reg*)newSize: LONGCARD; pc: POINTER TO CARDINAL;⓪"BEGIN⓪$WITH expr DO⓪&(*$? Safety: assert (kind = constRef);⓪3assert ((addSize > 0) & (dataSize > 0));*)⓪&oldSize:= Size (expr);⓪&newSize:= oldSize + addSize;⓪&IF ODD (newSize) THEN INC (newSize) END;⓪&IF newSize >= LONG (MaxInt) THEN⓪((* das wäre nicht mehr besonders sinnvoll... *)⓪(SyntaxError (rConLg)⓪&END;⓪&IF NOT SuppressCode THEN⓪((*$? Safety: assert (constHead # NIL); *)⓪((*$? Safety: pc:= constHead; assert (DataPtr = constAddr + LONG(pc^)); *)⓪(Move (addr, constAddr + oldSize, SHORT (dataSize));⓪(Clear (constAddr + oldSize + dataSize, SHORT (addSize-dataSize));⓪(DataPtr:= constAddr + newSize;⓪(pc:= constHead;⓪(pc^:= SHORT(newSize);⓪&ELSE⓪((*$? Safety: assert (NOT InConstExpr) *)⓪&END;⓪$END;⓪$DataSpace⓪"END addNewConstant;⓪ ⓪ PROCEDURE cutConst (VAR expr: ExprDesc);⓪"(*⓪#* Im DATA-Puffer erzeugte Konstante wieder verwerfen⓪#*)⓪"VAR pc: POINTER TO CARDINAL;⓪"BEGIN⓪$WITH expr DO⓪&(*$? Safety: assert (kind = constRef);*)⓪&IF constHead # NIL THEN⓪(pc:= constHead;⓪(IF DataPtr = constAddr + LONG(pc^) THEN⓪*DataPtr:= constHead;⓪(ELSE⓪*(* Konst bleibt unbenutzt im Puffer, wird später beim DATA-Segment-⓪+* Erzeugen ignoriert *)⓪(END;⓪(constAddr:= NIL;⓪(constHead:= NIL;⓪&END⓪$END⓪"END cutConst;⓪ (*$D-*)⓪ ⓪ PROCEDURE reduceConstant (VAR expr: ExprDesc);⓪"(* verkürzt Konst im Puffer auf die wirklich benötigte Länge *)⓪"VAR pc: POINTER TO CARDINAL; newSize: LONGCARD;⓪"BEGIN⓪$WITH expr DO⓪&IF NOT SuppressCode THEN⓪(newSize:= Size (expr);⓪(IF ODD (newSize) THEN INC (newSize) END;⓪((*$? Safety: assert (kind = constRef);*)⓪((*$? Safety: assert (constHead # NIL);*)⓪((*$? Safety: pc:= constHead; assert (DataPtr = constAddr + LONG(pc^)); *)⓪(IF constOfs > 0 THEN⓪+Move (constAddr + constOfs, constAddr, newSize);⓪+constOfs:= 0⓪(END;⓪(DataPtr:= constAddr + newSize;⓪(pc:= constHead;⓪(pc^:= SHORT(newSize);⓪&END;⓪$END⓪"END reduceConstant;⓪ (*$D-*)⓪ ⓪ PROCEDURE dropConstantFromTree (VAR expr: ExprDesc);⓪"(*⓪#* Legt eine Konstante aus dem Tree in den DATA-Puffer.⓪#* Achtung: Dabei geht die Referenz auf die evtl. benamte Konstante⓪#* verloren, so daß dann eine Kopie der Konstante im Puffer erzeugt wird!⓪#* Sollte daher nur aufgerufen werden, wenn dabei eine neue zusammengesetzte⓪#* Konstante erzeugt wird oder sie gleich danach wieder mit "cutConst"⓪#* entfernt wird!⓪#*)⓪"VAR os: INTEGER; pd: POINTER TO LONGINT; n: INTEGER; vi: PtrItem; ofs: LONGCARD;⓪"BEGIN⓪$WITH expr DO⓪&IF NOT SuppressCode THEN⓪((*$? Safety: assert (kind = constRef);*)⓪((*$? Safety: assert (constHead = NIL);*)⓪((*$? Safety: assert (varItem # NIL);*)⓪(n:= entryC (varItem, -16);⓪(vi:= varItem; (* varItem wird gleich auf NIL gesetzt *)⓪(ofs:= constOfs;⓪(dropNewConstant (ADR(Accu)(*dummy*), n, expr); (* erstmal vollen Platz reservieren *)⓪(constOfs:= ofs;⓪(os:= -20;⓪(pd:= constAddr; (* Zieladr. *)⓪(REPEAT⓪*pd^:= entryL (vi, os);⓪*INC (pd, 4);⓪*DEC (os, 4);⓪*DEC (n, 4);⓪(UNTIL n <= 0;⓪(IF constOfs > 0 THEN⓪*(* nur ein Teil der Konst wird benötigt -> kürzen *)⓪*reduceConstant (expr)⓪(END⓪&END⓪$END⓪"END dropConstantFromTree;⓪ (*$D-*)⓪ ⓪ ⓪ PROCEDURE genTrap (trapCode: CARDINAL);⓪"BEGIN⓪$gen (TRAP + ErrorTrapNo);⓪$gen (trapCode)⓪"END genTrap;⓪ ⓪ ⓪ PROCEDURE pushInt (l: LONGWORD);⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L l(A6),D0⓪(JSR PushInt⓪$END⓪"END pushInt;⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ (*⓪"Label-Verwaltung.⓪"⓪"Als "Label" wird hier nicht das Sprungziel sondern der Sprung-Zeiger⓪"verstanden. "Labels" ist somit eine Liste von Byte- und Word-Adressen,⓪"wo Zeiger auf das bei Aufruf von "Solve" stehende Ziel (CodePtr)⓪"einzutragen sind. So kommt jedes "Label" auch nur einmal vor, während⓪"alle "Labels" auf ein gemeinsames Ziel zeigen werden.⓪ ⓪"15.02.94.⓪"Neue Label-Behandlung, die weniger Speicher auf dem Stack belegt: Statt⓪"alle Labels jeweils lokal in einem großen Array zu speichern, wird nun⓪"ein gemeinsamer Label-Pool verwaltet, der jeweils einen Eintrag und einen⓪"Index auf den Vorgänger (ist nicht unbedingt stetig auf-/absteigend!)⓪"enthält. In "Labels" wird dann nur noch der Index auf den Anfang der⓪"Liste vermerkt.⓪"LabelPoolIdx ist ein Hilfszeiger, der, solange er nicht am Ende des Pools⓪"angekommen ist, immer das nächste Feld vergibt. Am Ende wird dann geprüft⓪"(langsamer), ob noch freie Felder im Array vorhanden sind, die wg. "Solve"-⓪"Aufrufen zwischenzeitlich frei wurden.⓪ *)⓪ ⓪ CONST⓪"LabelPoolSize = 256;⓪ ⓪ TYPE⓪"Labels = RECORD⓪-(* dies später über Compiler-interne-Jmp-List lösen *)⓪-root, tail: [0..LabelPoolSize]; (* Index in Pool *)⓪+END;⓪ ⓪ VAR⓪"LabelPool: ARRAY [1..LabelPoolSize] OF RECORD⓪$used: BOOLEAN;⓪$addr: Label;⓪$next: [0..LabelPoolSize]⓪"END;⓪"LabelPoolIdx, LabelsInPool: [0..LabelPoolSize];⓪ ⓪ PROCEDURE InitLabels (VAR list: Labels);⓪"BEGIN⓪$list.root:= 0⓪"END InitLabels;⓪ ⓪ PROCEDURE PopLabel (VAR list: Labels);⓪"BEGIN⓪$(*$? Safety: assert (list.root # 0);*)⓪$WITH LabelPool[list.root] DO⓪&used:= FALSE;⓪&DEC (LabelsInPool);⓪&list.root:= next⓪$END⓪"END PopLabel;⓪ ⓪ PROCEDURE MarkRef (target: Label; VAR list: Labels);⓪"VAR idx, i: INTEGER;⓪"BEGIN⓪$IF LabelsInPool = LabelPoolSize THEN SyntaxError (rLblOv); RETURN END;⓪$IF LabelsInPool = 0 THEN⓪&LabelPoolIdx:= 0 (* bei leerem Pool auch Hilfszeiger rücksetzen *)⓪$END;⓪$IF LabelPoolIdx < LabelPoolSize THEN⓪&INC (LabelPoolIdx);⓪&idx:= LabelPoolIdx⓪$ELSE⓪&(* nach leeren Feldern in Pool suchen *)⓪&LOOP FOR i:= 1 TO LabelPoolSize DO⓪(IF NOT LabelPool [i].used THEN⓪*idx:= i;⓪*EXIT⓪(END⓪&END END;⓪&SyntaxError (rLblOv); RETURN⓪$END;⓪$INC (LabelsInPool);⓪$WITH LabelPool [idx] DO⓪&addr:= target;⓪&next:= list.root;⓪&used:= TRUE;⓪&IF next = 0 THEN⓪(list.tail:= idx⓪&END;⓪$END;⓪$list.root:= idx;⓪"END MarkRef;⓪ ⓪ PROCEDURE AddLabelsTo (VAR from: Labels; VAR to: Labels);⓪"BEGIN⓪$(* TT 18.8.94: das geht nicht - baut Mist bei "IF (a OR b) OR (c OR d) THEN..."⓪&IF from.root # 0 THEN⓪(IF to.root = 0 THEN⓪*to:= from;⓪(ELSE⓪*(* 'from' an Schwanz von 'to' anhängen *)⓪*LabelPool [to.tail].next:= from.root;⓪(END;⓪(from.root:= 0⓪&END⓪$*)⓪$WHILE from.root # 0 DO⓪&WITH LabelPool [from.root] DO⓪(MarkRef (addr, to);⓪(used:= FALSE;⓪(DEC (LabelsInPool);⓪(from.root:= next⓪&END⓪$END⓪"END AddLabelsTo;⓪ ⓪ PROCEDURE Solve (VAR list: Labels);⓪"BEGIN⓪$WHILE list.root # 0 DO⓪&WITH LabelPool [list.root] DO⓪(ToHere (addr);⓪(used:= FALSE;⓪(DEC (LabelsInPool);⓪(list.root:= next⓪&END⓪$END⓪"END Solve;⓪ ⓪ PROCEDURE PushLabels (VAR list: Labels; VAR no: CARDINAL);⓪"BEGIN⓪$no:= 0;⓪$WHILE list.root # 0 DO⓪&WITH LabelPool [list.root] DO⓪(IF addr # NIL THEN⓪*pushInt (addr);⓪*INC (no)⓪(END;⓪(used:= FALSE;⓪((*$?Safety2: assert (LabelsInPool # 0);*)⓪(DEC (LabelsInPool);⓪(list.root:= next⓪&END⓪$END⓪"END PushLabels;⓪ ⓪ PROCEDURE unSolved (VAR list: Labels): BOOLEAN;⓪"BEGIN⓪$RETURN list.root # 0⓪"END unSolved;⓪ ⓪ (*alt:⓪ ⓪"CONST⓪$MaxLabels = 50;⓪$⓪"TYPE⓪$Labels = RECORD⓪/(* dies später über Compiler-interne-Jmp-List lösen *)⓪/n: CARDINAL;⓪/t: ARRAY [1..MaxLabels] OF Label (* ~~~ die ist z.Zt. begrenzt! *)⓪-END;⓪"⓪"VAR⓪$dummyLbl1, dummyLbl2: Labels;⓪"⓪"PROCEDURE InitLabels (VAR list: Labels);⓪$BEGIN⓪&list.n:= 0⓪$END InitLabels;⓪"⓪"PROCEDURE PopLabel (VAR list: Labels);⓪$BEGIN⓪&(*$? Safety: assert (list.n > 0);*)⓪&DEC (list.n)⓪$END PopLabel;⓪"⓪"PROCEDURE MarkRef (target: Label; VAR list: Labels);⓪$BEGIN⓪&IF list.n = MaxLabels THEN SyntaxError (rLblOv) END;⓪&INC (list.n);⓪&list.t [list.n]:= target⓪$END MarkRef;⓪"⓪"PROCEDURE AddLabelsTo (VAR from: Labels; VAR to: Labels);⓪$BEGIN⓪&WHILE from.n > 0 DO⓪(MarkRef (from.t [from.n], to);⓪(DEC (from.n)⓪&END⓪$END AddLabelsTo;⓪"⓪"PROCEDURE Solve (VAR list: Labels);⓪$BEGIN⓪&WHILE list.n > 0 DO⓪(ToHere (list.t [list.n]);⓪(DEC (list.n)⓪&END⓪$END Solve;⓪"⓪"PROCEDURE PushLabels (VAR list: Labels; VAR no: CARDINAL);⓪$BEGIN⓪&no:= 0;⓪&WHILE list.n > 0 DO⓪(IF list.t [list.n] # NIL THEN⓪*pushInt (list.t [list.n]);⓪*INC (no)⓪(END;⓪(DEC (list.n)⓪&END⓪$END PushLabels;⓪"⓪"PROCEDURE unSolved (VAR list: Labels): BOOLEAN;⓪$BEGIN⓪&RETURN list.n > 0⓪$END unSolved;⓪ *)⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ ⓪ (*$S+ ab hier Stackcheck *)⓪ ⓪ ⓪ (* --- Routinen zum Setzen/Auswerten von 'ExprDesc'-Variablen --- *)⓪ ⓪ ⓪ FORWARD deallocRegs ( VAR expr: ExprDesc );⓪ FORWARD loadReg ( VAR expr: ExprDesc; niceRegs: RegSet );⓪ FORWARD allocReg ( desiredRegs: RegSet ) : RegType;⓪ FORWARD makeIndir (VAR expr: ExprDesc; ofs: LONGINT; odd: BOOLEAN);⓪ FORWARD loadAddress ( VAR expr: ExprDesc );⓪ FORWARD loadAddressTo ( VAR expr: ExprDesc; niceRegs: RegSet );⓪ FORWARD loadAllocedReg ( VAR expr: ExprDesc; r: RegType );⓪ ⓪ PROCEDURE changeToStackTo (VAR dest: ExprDesc; niceRegs: RegSet);⓪"(*⓪#* Formt dest in (An)+ um⓪#*)⓪"VAR t: PtrItem;⓪"BEGIN⓪$IF (dest.kind # stack) OR NOT (dest.stackReg IN niceRegs) THEN⓪&t:= dest.item;⓪&loadAddressTo (dest, niceRegs);⓪&WITH dest DO⓪(item:= t; (* wurde von loadAdress auf CardPtr gesetzt *)⓪(kind:= stack;⓪(stackReg:= exprReg;⓪(up:= TRUE;⓪(restoreAfterUse:= 0;⓪(stackedSize:= 0⓪&END⓪$END⓪"END changeToStackTo;⓪ ⓪ PROCEDURE changeToStack (VAR dest: ExprDesc);⓪"(*⓪#* Formt dest in (An)+ um⓪#*)⓪"BEGIN⓪$changeToStackTo (dest, addrRegs + RegSet {A3,A7})⓪"END changeToStack;⓪ ⓪ PROCEDURE changeToIndir (VAR dest: ExprDesc; r: RegType);⓪"(*⓪#* Formt alles in (An) um.⓪#*)⓪"BEGIN⓪$WITH dest DO⓪&kind:= memory;⓪&mode:= d16An;⓪&baseReg:= r;⓪&mayBeOdd:= FALSE;⓪&disp:= 0;⓪$END⓪"END changeToIndir;⓪ ⓪ PROCEDURE changeStackToIndir (VAR dest: ExprDesc);⓪"(*⓪#* Formt (An)+ oder -(An) in (An) um.⓪#* Vorsicht: Bei -(An) wird keine Stack-Korrektur (SUB) vorgenommen⓪#*)⓪"BEGIN⓪$WITH dest DO⓪&(*$? Safety2: assert ((kind = stack) & (restoreAfterUse = 0L));*)⓪&changeToIndir (dest, stackReg);⓪$END⓪"END changeStackToIndir;⓪ ⓪ PROCEDURE changeConstantToConstRef (VAR expr: ExprDesc; destSize: LONGCARD);⓪"(*⓪#* Sorgt dafür, daß Konstante auf Wert in DATA-Segment zugreifen wird.⓪#* Nicht mit dropConstantFromTree zu verwechseln, wo die Konstante für⓪#* einen Compile-Time-Zugriff in den DATA-Puffer gelegt wird.⓪#*)⓪"VAR fl: IFS;⓪"BEGIN⓪$WITH expr DO⓪&(*$? Safety: assert (kind = constant); *)⓪&IF varItem # NIL THEN⓪(kind:= constRef;⓪(constOfs:= 0;⓪(constHead:= NIL⓪&ELSE⓪(dropNewConstant (ADR (exprConst.b)+1L-Size (expr), destSize, expr);⓪&END⓪$END⓪"END changeConstantToConstRef;⓪ ⓪ PROCEDURE oddAccess (VAR fact: ExprDesc): BOOLEAN;⓪"BEGIN⓪$(*$? Safety2: assert (fact.kind = memory);*)⓪$RETURN fact.mayBeOdd⓪"END oddAccess;⓪ ⓪ PROCEDURE loadIndir (VAR fact: ExprDesc; ofs: LONGINT; odd: BOOLEAN);⓪"(* Lädt den Pointer in 'fact' und macht indir. Zugriff draus;⓪#* verändert den Typ aber nicht.⓪#* z.B. f. VAR-Parameter-Vars und WITH-Zugriff über (A6).⓪#*)⓪"VAR t: PtrItem;⓪"BEGIN⓪$WITH fact DO⓪&(* kurzzeitig LONG-Type aus Datum machen *)⓪&t:= item; item:= CardPtr;⓪&odd:= oddAccess (fact) OR odd;⓪&loadReg (fact, addrRegs);⓪&item:= t;⓪&makeIndir (fact, ofs, odd)⓪$END;⓪"END loadIndir;⓪ ⓪ PROCEDURE makeInd0An (VAR expr: ExprDesc);⓪"(* macht aus einer beliebigen Adressierung eine mit 0(An) *)⓪"VAR t: PtrItem;⓪"BEGIN⓪$t:= expr.item;⓪$loadAddress (expr);⓪$makeIndir (expr, 0, FALSE);⓪$expr.item:= t⓪"END makeInd0An;⓪ ⓪ PROCEDURE initOpenArrayAccess (VAR expr: ExprDesc; needHigh: BOOLEAN);⓪"(* IN: 'expr' mit Open-Array - Variable⓪#* 'needHigh': TRUE -> auf HIGH-Werte soll zugegriffen werden.⓪#* OUT: 'expr' enthält Pointer auf Open Array,⓪#* 'expr.highReg/highOfs' werden intialisiert, mit initHighExpr kann⓪#* eine Expr zum Zugriff darauf erzeugt werden.⓪#* Achtung: 'deallocReg (expr.highReg)' nicht vergessen!⓪#* Achtung: wenn 'needHigh' = FALSE, kann auch nicht mehr auf weitere⓪#* High-Werte (mehrdim. OpArr) zugegriffen werden!⓪#*)⓪"VAR t: PtrItem; r, r2: RegType;⓪"BEGIN⓪$WITH expr DO⓪&(*$? Safety: assert (isOpenArray (item));*)⓪&IF highReg = 0 THEN⓪(t:= item;⓪(IF needHigh THEN⓪*changeToStack (expr); (* "(An)+" *)⓪*r2:= stackReg;⓪*item:= sizedItem (4, FALSE);⓪*r:= allocReg (addrRegs);⓪*loadAllocedReg (expr, r); (* "MOVE.L (An)+,Ap" *)⓪,(* loadReg nicht möglich, weil dann expr-Reg freigegeben würde *)⓪*makeIndir (expr, 0, FALSE); (* expr: (Ap) *)⓪*highReg:= r2; (* high: (An) *)⓪*highOfs:= 0⓪(ELSE⓪*loadIndir (expr, 0, FALSE); (* "MOVE.L x(A6),An" *)⓪(END;⓪(item:= t⓪&ELSE⓪((* 'expr' enthält bereits den benötigten Pointer auf das Array *)⓪&END⓪$END⓪"END initOpenArrayAccess;⓪ ⓪ PROCEDURE initExpr (VAR desc: ExprDesc; item: PtrItem; kind: ExprKind);⓪"VAR i: CARDINAL;⓪"BEGIN⓪$SysUtil0.ClearVar (desc);⓪$desc.item:= item;⓪$desc.kind:= kind;⓪"END initExpr;⓪ ⓪ PROCEDURE initStackExpr (VAR expr: ExprDesc; type: PtrItem; reg: RegType);⓪"BEGIN⓪$initExpr (expr, type, stack);⓪$WITH expr DO⓪&stackReg:= reg;⓪&up:= (stackReg # A7);⓪&restoreAfterUse:= 0;⓪&stackedSize:= 0;⓪&stackPtr:= 0⓪$END⓪"END initStackExpr;⓪ ⓪ PROCEDURE initMemExpr (VAR desc: ExprDesc; item: PtrItem; mod: MemModes;⓪7odd: BOOLEAN);⓪"BEGIN⓪$initExpr (desc, item, memory);⓪$WITH desc DO⓪&idxL:= FALSE;⓪&mayBeOdd:= odd;⓪&mode:= mod;⓪$END;⓪"END initMemExpr;⓪ ⓪ PROCEDURE initHighExpr (REF from: ExprDesc; VAR high: ExprDesc);⓪"VAR t: PtrItem;⓪"BEGIN⓪$WITH from DO⓪&IF isLongOpenArray (item) THEN t:= CardPtr ELSE t:= SCardPtr END;⓪&initMemExpr (high, t, d16An, FALSE);⓪&high.baseReg:= highReg;⓪&high.disp:= highOfs;⓪&makeInd0An (high);⓪&changeToStack (high)⓪$END⓪"END initHighExpr;⓪ ⓪ PROCEDURE adjustHighPtr (REF from: ExprDesc; VAR high: ExprDesc);⓪"(* wenn 'high' bereits benutzt wurde, kann hiermit der Offset⓪#* ggf. korrigiert werden *)⓪"VAR stacked: INTEGER;⓪"BEGIN⓪$WITH high DO⓪&stacked:= SHORT(stackedSize);⓪&changeStackToIndir (high);⓪&IF isLongOpenArray (from.item) THEN item:= CardPtr ELSE item:= SCardPtr END;⓪&disp:= from.highOfs-stacked;⓪&makeInd0An (high);⓪&changeToStack (high);⓪&stackedSize:= from.highOfs⓪$END;⓪"END adjustHighPtr;⓪ ⓪ PROCEDURE initPseudoRegExpr (VAR expr: ExprDesc; item: PtrItem;⓪=r: RegType; upper: BOOLEAN);⓪"VAR lastSymbol: Symbol; ok: BOOLEAN;⓪"(*⓪#* 'upper': TRUE -> 2. LONGWORD ansprechen⓪#* Achtung: Bei Shortreals steht Wert immer im 1. LONGWORD, d.h. dann muß⓪#* 'upper' FALSE sein!⓪#* Damit diese Routine von 'pushRealReg' benutzbar ist, darf hier kein⓪#* Register alloziert werden!⓪#*)⓪"BEGIN⓪$(*$? Safety: assert ((r >= F0) & (fpu () = softReal));*)⓪$lastSymbol:= CurrentSymbol;⓪$TreeSearch (ADR (FP[r,upper]));⓪$IF ORD (CurrentSymbol.typ) # 17 (* VAR *) THEN⓪&Assign (FP[r,upper],BadId,ok); SyntaxError (rNoRun)⓪$END;⓪$initMemExpr (expr, item, absRef, FALSE);⓪$expr.varItem:= CurrentSymbol.item;⓪$CurrentSymbol:= lastSymbol;⓪"END initPseudoRegExpr;⓪ ⓪ ⓪ PROCEDURE initRegExpr (VAR expr: ExprDesc; size: CARDINAL; reg: RegType);⓪"BEGIN⓪$initExpr (expr, sizedItem (size, FALSE), register);⓪$expr.exprReg:= reg⓪"END initRegExpr;⓪ ⓪ ⓪ PROCEDURE makeIndir (VAR expr: ExprDesc; ofs: LONGINT; odd: BOOLEAN);⓪"(* IN: expr Adr. des Datums in Reg⓪#* OUT: expr adressiert Datum mit Offset als "ofs(An)"⓪#* oder "ADDA ofs,An; (An)"⓪#*)⓪"VAR t: PtrItem;⓪"BEGIN⓪$WITH expr DO⓪&IF kind = register THEN⓪((*$? Safety2: assert (exprReg > D7); *)⓪(IF (ofs > LONG (MaxInt))⓪(OR (ofs < LONG (MinInt)) THEN⓪*t:= expr.item;⓪*expr.item:= CardPtr; (* f. Long-MOVE *)⓪*loadReg (expr, addrRegs); (* falls Reg = A6 *)⓪*expr.item:= t;⓪*genADDAL (ofs, exprReg);⓪*ofs:= 0;⓪(END;⓪(baseReg:= exprReg;⓪(kind:= memory;⓪(mode:= d16An;⓪(mayBeOdd:= odd;⓪(disp:= ofs;⓪&ELSE⓪((*$? Safety:⓪*assert ((ofs = 0L) & ~odd);⓪*assert (kind = memory);⓪(*)⓪(IF mode = immRef THEN (* globale Proc *)⓪*mode:= absRef⓪(ELSIF mode = relConst THEN (* lokale Proc *)⓪*mode:= relRef⓪(ELSE⓪*bong⓪(END⓪&END⓪$END⓪"END makeIndir;⓪ ⓪ PROCEDURE makeIndirIdx (VAR expr: ExprDesc; index: RegType; long: BOOLEAN;⓪8odd: BOOLEAN);⓪"(*⓪#* Vorsicht: long=FALSE nur übergeben, wenn index in INTEGER paßt,⓪#* aber nicht, wenn index zwar 2 Byte groß ist, aber > MaxInt⓪#* werden kann!⓪#*)⓪"BEGIN⓪$WITH expr DO⓪&(*$? Safety: assert (kind = register);*)⓪&kind:= memory;⓪&mayBeOdd:= odd;⓪&baseReg:= exprReg;⓪&idxReg:= index;⓪&idxL:= long;⓪&mode:= d8AnXn;⓪&disp:= 0⓪$END;⓪"END makeIndirIdx;⓪ ⓪ PROCEDURE initConstExpr (VAR expr: ExprDesc; size: CARDINAL; const: ZZ);⓪"BEGIN⓪$initExpr (expr, sizedItem (size, FALSE), constant);⓪$expr.exprConst.zz:= const⓪"END initConstExpr;⓪ ⓪ (*$D-*)⓪ PROCEDURE getLink (tiefe: CARDINAL): RegType;⓪"VAR baseReg: RegType; count: ExprDesc;⓪"BEGIN⓪$IF tiefe = 0 THEN⓪&(*$? Safety: assert (VarReg # 0); *)⓪&baseReg:= VarReg;⓪$ELSE⓪&baseReg:= allocReg (addrRegs);⓪&genMOVELIndTo (VarReg, baseReg, StatLinkOffs);⓪&IF tiefe > 4 THEN⓪((*!!! Der StatLinkOffs muß pro Scope einzeln gemerkt und hier⓪)* berücksichtigt werden, weil es sonst schieffgeht, wenn eine⓪)* lokale Proc keine Parms hat oder die Parms auf dem A3 erwartet!⓪)*)⓪(initConstExpr (count, 2, toZZ (LONG(tiefe)-1L, FALSE));⓪(loadReg (count, dataRegs);⓪(genMOVELIndTo (baseReg, baseReg, StatLinkOffs);⓪(genDBcc (mapNever (), count.exprReg, -4);⓪(deallocRegs (count);⓪&ELSE⓪(WHILE tiefe > 1 DO⓪*genMOVELIndTo (baseReg, baseReg, StatLinkOffs);⓪*DEC (tiefe)⓪(END⓪&END⓪$END;⓪$RETURN baseReg⓪"END getLink;⓪ (*$D-*)⓪ ⓪ PROCEDURE indir (VAR fact: ExprDesc): BOOLEAN;⓪"BEGIN⓪$WITH fact DO⓪&RETURN (kind = memory) & (mode >= d16An)⓪$END⓪"END indir;⓪ ⓪ ⓪ MODULE stackedRegs;⓪ ⓪"IMPORT SyntaxError, rBlkOv, RegType, A7, assert, tempRegs, A7Offset,⓪)Safety, genPushReg, genPopReg, toZZ, incReg;⓪"⓪"EXPORT pushNonTemp, popNonTemp, releaseNonTemp;⓪"⓪"CONST max = 40;⓪"⓪"VAR discardFromA7Stk: ARRAY [1..max] OF RECORD⓪:reg: RegType;⓪:long: BOOLEAN;⓪:ofs: LONGINT⓪8END;⓪&discardFromA7SP: CARDINAL;⓪ ⓪"PROCEDURE pushNonTemp (regToPush: RegType; longReg: BOOLEAN);⓪$(* ist nur für nicht-temporäre Regs gedacht! *)⓪$BEGIN⓪&(*$? Safety: assert (NOT (regToPush IN tempRegs));*)⓪&IF discardFromA7SP = max THEN SyntaxError (rBlkOv) END;⓪&INC (discardFromA7SP);⓪&WITH discardFromA7Stk [discardFromA7SP] DO⓪(reg:= regToPush;⓪(long:= longReg;⓪(genPushReg (reg, long, A7);⓪(ofs:= A7Offset;⓪&END;⓪$END pushNonTemp;⓪ ⓪"PROCEDURE popNonTemp (regToPop: RegType);⓪$BEGIN⓪&(*$? Safety: assert (discardFromA7SP # 0);*)⓪&WITH discardFromA7Stk [discardFromA7SP] DO⓪((*$? Safety:⓪*assert (ofs = A7Offset);⓪*assert (reg = regToPop);⓪(*)⓪(genPopReg (reg, long, A7);⓪&END;⓪&DEC (discardFromA7SP);⓪$END popNonTemp;⓪ ⓪"PROCEDURE releaseNonTemp (to: LONGINT);⓪$VAR a7: LONGINT; n: CARDINAL;⓪$BEGIN⓪&a7:= A7Offset;⓪&n:= discardFromA7SP;⓪&WHILE A7Offset # to DO⓪(IF n # 0 THEN⓪*WITH discardFromA7Stk [n] DO⓪,incReg (A7, toZZ (ofs - A7Offset, TRUE), 4);⓪,genPopReg (reg, long, A7)⓪*END;⓪*DEC (n);⓪(ELSE⓪*incReg (A7, toZZ (to - A7Offset, TRUE), 4)⓪(END⓪&END;⓪&A7Offset:= a7⓪$END releaseNonTemp;⓪"⓪"END stackedRegs;⓪ ⓪ (* --- Code erzeugende Routinen --- *)⓪ ⓪ ⓪ FORWARD spillReg (desiredRegs: RegSet);⓪ FORWARD spillRegByMove (desiredRegs: RegSet): BOOLEAN;⓪ ⓪ PROCEDURE getReg (from: RegSet): RegType;⓪"VAR r: RegType;⓪"BEGIN⓪$from:= from * freeRegs;⓪$FOR r:= MIN (RegType) TO MAX (RegType) DO⓪&IF r IN from THEN⓪(EXCL (freeRegs,r);⓪(RETURN r⓪&END⓪$END;⓪$bong⓪"END getReg;⓪ ⓪ PROCEDURE getHiReg (from: RegSet): RegType;⓪"VAR r: RegType;⓪"BEGIN⓪$from:= from * freeRegs;⓪$FOR r:= MAX (RegType) TO MIN (RegType) BY -1 DO⓪&IF r IN from THEN⓪(EXCL (freeRegs,r);⓪(RETURN r⓪&END⓪$END;⓪$bong⓪"END getHiReg;⓪ ⓪ PROCEDURE getThisReg (r: RegType): BOOLEAN;⓪"BEGIN⓪$IF r IN freeRegs THEN⓪&EXCL (freeRegs, r);⓪&RETURN TRUE⓪$ELSE⓪&RETURN FALSE⓪$END⓪"END getThisReg;⓪ ⓪ PROCEDURE allocReg ( desiredRegs: RegSet ) : RegType;⓪"BEGIN⓪$IF desiredRegs - varRegs # RegSet {} THEN⓪&desiredRegs:= desiredRegs * tempRegs;⓪&(* wenn nicht ausschließlich Regs f. Reg-Vars gewünscht werden, bedeutet⓪'* das, daß eigentlich ausschließlich temp. gewünscht sein, die andern⓪'* wurden nur z.B. bei loadReg zugelassen, falls der Wert schon in einer⓪'* Reg-Var steht *)⓪&IF desiredRegs * freeRegs = RegSet {} THEN⓪(IF NOT spillRegByMove (desiredRegs) THEN⓪*REPEAT⓪,spillReg (desiredRegs)⓪*UNTIL desiredRegs * freeRegs # RegSet {};⓪(END⓪&END;⓪&RETURN getReg (desiredRegs)⓪$ELSE⓪&RETURN getHiReg (desiredRegs * varRegs)⓪$END;⓪"END allocReg;⓪ ⓪ PROCEDURE allocRegVar (desired: VarType; VAR r: RegType): BOOLEAN;⓪"VAR (*$Reg*)regs: RegSet;⓪"BEGIN⓪$IF desired = dataVar THEN⓪®s:= RegSet {D0..D7}⓪$ELSIF desired = ptrVar THEN⓪®s:= RegSet {A0..A7}⓪$ELSE⓪®s:= RegSet {F0..F7}⓪$END;⓪$regs:= regs * freeVarRegs * varRegs;⓪$IF regs * freeRegs # RegSet {} THEN⓪&r:= getHiReg (regs);⓪&RETURN TRUE⓪$ELSE⓪&RETURN FALSE⓪$END⓪"END allocRegVar;⓪ ⓪ PROCEDURE allocAddrRegIfAllowed ( desiredRegs: RegSet ) : RegType;⓪"(*⓪#* wie 'allocReg', nur wird, wenn gewünscht, ein Adreßreg. alloziert,⓪#* sofern eins frei ist⓪#*)⓪"BEGIN⓪$IF (desiredRegs * addrRegs # RegSet {})⓪$& (freeRegs * addrRegs # RegSet {}) THEN⓪&RETURN allocReg (addrRegs)⓪$ELSE⓪&RETURN allocReg (desiredRegs)⓪$END;⓪"END allocAddrRegIfAllowed;⓪ ⓪ PROCEDURE deallocReg ( reg: RegType );⓪"BEGIN⓪$IF reg IN tempRegs THEN⓪&(*$? Safety: assert (~(reg IN freeRegs));*)⓪&INCL (freeRegs, reg);⓪$END⓪"END deallocReg;⓪ ⓪ PROCEDURE deallocRegVar ( reg: RegType );⓪"BEGIN⓪$(*$? Safety: assert (reg IN varRegs);⓪1assert (~(reg IN freeRegs));*)⓪$INCL (freeRegs, reg);⓪"END deallocRegVar;⓪ ⓪ PROCEDURE deallocRegs ( VAR expr: ExprDesc );⓪"(* deallocate the registers that were used by expr *)⓪"BEGIN⓪$WITH expr DO⓪&CASE kind OF⓪&| register: deallocReg (exprReg);⓪&| memory: CASE mode OF⓪2| d16An: deallocReg (baseReg);⓪2| d8AnXn: deallocReg (baseReg); deallocReg (idxReg);⓪2ELSE⓪2END⓪&| stack: deallocReg (stackReg);⓪&ELSE⓪&END;⓪$END;⓪"END deallocRegs;⓪ ⓪ PROCEDURE deallocHighReg ( VAR expr: ExprDesc );⓪"BEGIN⓪$IF expr.highReg >= A0 THEN deallocReg (expr.highReg) END⓪"END deallocHighReg;⓪ ⓪ ⓪ PROCEDURE exclRegs (REF expr: ExprDesc; VAR regs: RegSet);⓪"(* IN: expr, regs; OUT: regs *)⓪"(* fügt Register aus 'regs' aus, die von 'expr' benutzt werden *)⓪"BEGIN⓪$WITH expr DO⓪&CASE kind OF⓪&| register: EXCL (regs, exprReg);⓪&| stack: EXCL (regs, stackReg);⓪&| memory:⓪2CASE mode OF⓪2| d16An: EXCL (regs, baseReg);⓪2| d8AnXn: EXCL (regs, baseReg); EXCL (regs, idxReg);⓪2ELSE⓪2END⓪&ELSE⓪&END;⓪$END;⓪"END exclRegs;⓪ ⓪ PROCEDURE exprUsesRegs (VAR expr: ExprDesc; regs: RegSet): BOOLEAN;⓪"(* TRUE, wenn die Expr eines der 'regs' belegt *)⓪"BEGIN⓪$WITH expr DO⓪&CASE kind OF⓪&| register: RETURN exprReg IN regs;⓪&| memory: CASE mode OF⓪2| d16An: RETURN baseReg IN regs;⓪2| d8AnXn: RETURN (baseReg IN regs) OR (idxReg IN regs);⓪2ELSE⓪2END⓪&| stack: RETURN stackReg IN regs;⓪&ELSE⓪&END;⓪$END;⓪$RETURN FALSE⓪"END exprUsesRegs;⓪ ⓪ PROCEDURE usesTempRegs ( VAR expr: ExprDesc ): BOOLEAN;⓪"(* return TRUE if temp. Regs are allocated by expr *)⓪"BEGIN⓪$RETURN exprUsesRegs (expr, tempRegs)⓪"END usesTempRegs;⓪ ⓪ ⓪ PROCEDURE cancelExpr (VAR expr: ExprDesc);⓪"(*⓪#* muß aufgerufen werden, wenn eine Expr verworfen wird.⓪#* denn hier wird dann ggf. der Stack von dem noch drauf befindlichen⓪#* Datum gesäubert.⓪#* 'restoreStack' und 'deallocRegs' müssen zusätzlich noch aufgerufen werden!⓪#*)⓪"BEGIN⓪$WITH expr DO⓪&IF kind = stack THEN⓪(IF stackReg = A3 THEN⓪*incReg (A3, toZZ (-LONGINT (stackedSize), TRUE), 4)⓪(ELSE⓪*(*$? Safety: assert (stackReg = A7);*)⓪*incReg (A7, toZZ (stackedSize, FALSE), 4)⓪(END;⓪(stackedSize:= 0⓪&ELSE⓪((*$? Safety:⓪*assert ((kind # memory) OR ((mode # ptrOnA3) & (mode # ptrOnA7)))⓪(*)⓪&END⓪$END⓪"END cancelExpr;⓪ ⓪ ⓪ PROCEDURE clearExpr (VAR expr: ExprDesc);⓪"(* Ergebnis löschen. *)⓪"VAR r: RegType;⓪"BEGIN⓪$cancelExpr (expr);⓪$deallocRegs (expr);⓪$expr.kind:= constant;⓪$expr.exprConst.zz:= toZZ (0L, FALSE)⓪"END clearExpr;⓪ ⓪ PROCEDURE restoreStack (VAR expr: ExprDesc);⓪"BEGIN⓪$WITH expr DO⓪&IF (kind = stack) & (restoreAfterUse # 0L) THEN⓪(bong; (*&&& sollte wohl z.Zt. nicht auftreten *)⓪((*⓪*(*$? Safety: assert (stackReg = A3);*)⓪*incReg (A3, toZZ (-LONGINT (restoreAfterUse), TRUE), 4);⓪*restoreAfterUse:= 0⓪(*)⓪&END⓪$END⓪"END restoreStack;⓪ ⓪ PROCEDURE noDataAccess (VAR expr: ExprDesc);⓪"(*⓪#* Lädt expr in ein Datenreg, falls es in einem Adreß-Reg liegt.⓪#* Dies ist z.B. bei den MUL-Instr. nötig, weil diese kein Adr-Reg⓪#* als source erlauben, jedoch ggf. durch vorigen Expand oder Spill⓪#* der Wert in ein Adr-Reg kam.⓪#*)⓪"BEGIN⓪$IF (expr.kind = register) & (expr.exprReg >= A0) THEN⓪&loadReg (expr, dataRegs)⓪$END⓪"END noDataAccess;⓪ ⓪ ⓪ PROCEDURE reloadPtr (VAR expr: ExprDesc);⓪"(* reloads baseReg, if mode = ptrOnA3/A7 *)⓪"VAR r: RegType;⓪"BEGIN⓪$WITH expr DO⓪&IF (kind = memory) & ( (mode = ptrOnA3) OR (mode = ptrOnA7) ) THEN⓪(r:= allocReg (addrRegs);⓪((* verifizieren, daß richtiger Wert vom Stack geholt wird: *)⓪((*$? Safety: assert ((mode # ptrOnA7) OR (depth = A7Offset));*)⓪(genPullReg (expr, TRUE, r);⓪((*$? Safety: assert ((mode # ptrOnA3) OR (depth = A3Offset));*)⓪(mode:= d16An;⓪(disp:= 0;⓪(baseReg:= r⓪&ELSIF kind = spilledSP THEN⓪(stackReg:= allocReg (addrRegs);⓪((*$? Safety: IF spillReg = A7 THEN assert (spillOfs = A7Offset) END;*)⓪(genPullReg (expr, TRUE, stackReg);⓪((*$? Safety: IF spillReg = A3 THEN assert (spillOfs = A3Offset) END;*)⓪(kind:= stack⓪&END;⓪$END;⓪"END reloadPtr;⓪ ⓪ PROCEDURE swapExpr (VAR left, right: ExprDesc);⓪"VAR temp: ExprDesc;⓪"BEGIN⓪$temp:= left;⓪$left:= right;⓪$right:= temp⓪"END swapExpr;⓪ ⓪ PROCEDURE PushExpr ( expr: ExprDesc );⓪"BEGIN⓪$IF exprSp < maxDepth THEN⓪&INC (exprSp);⓪&exprStack[exprSp].expr:= expr;⓪&exprStack[exprSp].maySpill:= TRUE;⓪$ELSE⓪&SyntaxError (rExOvr)⓪$END;⓪"END PushExpr;⓪ ⓪ PROCEDURE PushExprNoSpill ( expr: ExprDesc );⓪"BEGIN⓪$PushExpr (expr);⓪$exprStack[exprSp].maySpill:= FALSE⓪"END PushExprNoSpill;⓪ ⓪ PROCEDURE LookExpr ( VAR expr: ExprDesc );⓪"BEGIN⓪$IF exprSp >= 0 THEN⓪&expr:= exprStack[exprSp].expr;⓪$ELSE⓪&bong⓪$END;⓪"END LookExpr;⓪ ⓪ PROCEDURE PopExpr ( VAR expr: ExprDesc );⓪"BEGIN⓪$LookExpr (expr);⓪$DEC (exprSp);⓪$IF spillSp > exprSp THEN spillSp:= exprSp END;⓪"END PopExpr;⓪ ⓪ ⓪ FORWARD pushRealReg (VAR expr: ExprDesc; to: RegType);⓪ ⓪ PROCEDURE pushReg (VAR expr: ExprDesc; sp: RegType);⓪"(*⓪#* lädt ein Reg auf den Stack⓪#*⓪#* ACHTUNG: dabei darf nicht rekursiv ein neues Spilling ausgelöst⓪#* werden!⓪#*)⓪"VAR dir: Directions;⓪"BEGIN⓪$(*$? Safety: assert ((sp = A7) OR (sp = A3));*)⓪$IF sp = A7 THEN dir:= down ELSE dir:= up END;⓪$WITH expr DO⓪&deallocReg (exprReg);⓪&IF sp = A3 THEN stackPtr:= A3Offset END;⓪&IF exprReg >= F0 THEN⓪(pushRealReg (expr, sp)⓪&ELSE⓪(genPush (expr, 0, sp, dir)⓪&END;⓪&kind:= stack;⓪&stackReg:= sp;⓪&up:= (sp = A7);⓪&restoreAfterUse:= 0;⓪&stackedSize:= roundedSize (expr);⓪&IF sp = A7 THEN stackPtr:= A7Offset END;⓪$END⓪"END pushReg;⓪ ⓪ (*$E-*)⓪ ⓪ PROCEDURE spillRegByMove (desiredRegs: RegSet): BOOLEAN;⓪"(*⓪#* Anwendung vor spillReg-Aufruf: Wenn TRUE, konnte ein Reg freigemacht⓪#* werden, indem das vorige in ein anderes Reg umgeladen wurde.⓪#*)⓪"⓪"VAR (*$Reg*)unused: RegSet; (*$Reg*)mySpillSp: ExprSP;⓪ ⓪"BEGIN⓪$desiredRegs:= desiredRegs - RegSet {F0..F7};⓪$mySpillSp:= spillSp;⓪$WHILE mySpillSp < exprSp DO⓪&INC (mySpillSp);⓪&WITH exprStack[mySpillSp].expr DO⓪(CASE kind OF⓪(| register: IF exprReg IN desiredRegs THEN⓪7unused:= (freeRegs - desiredRegs) * (dataRegs+addrRegs);⓪7IF exprStack[mySpillSp].maySpill THEN⓪9IF exprReg IN dataRegs THEN⓪;unused:= unused * addrRegs⓪9ELSE⓪;unused:= unused * dataRegs⓪9END;⓪7END;⓪7IF (unused # RegSet {}) & (TypeLength (item) # 1L) THEN⓪9(* das neu belegte Register ist also keins,⓪:* was genötigt wird:⓪:* Es wird in ein anderes, freies Reg umgeladen *)⓪9loadAllocedReg (exprStack[mySpillSp].expr, getReg (unused));⓪9RETURN TRUE⓪7END⓪5END;⓪ ⓪(| memory: IF (mode = d16An) OR (mode = d8AnXn) THEN⓪7IF NOT (baseReg IN desiredRegs)⓪7AND (mode = d8AnXn) & (idxReg IN desiredRegs) THEN⓪9(* wenn ein Datenreg aber kein AddrReg benötigt⓪:* wird, braucht nur der Index aufaddiert werden *)⓪9IF baseReg IN tempRegs THEN⓪;genADDA (idxL, idxReg, baseReg);⓪;deallocReg (idxReg);⓪;mode:= d16An;⓪;RETURN TRUE⓪9END⓪7END;⓪5END⓪(ELSE⓪(END;⓪&END;⓪$END;⓪$RETURN FALSE⓪"END spillRegByMove;⓪ ⓪ PROCEDURE spillReg (desiredRegs: RegSet);⓪"(*⓪#* Wenn nur ein Reg freigemacht werden soll, wird ggf. das Reg durch einen⓪#* MOVE zu einem freien Reg freigemacht.⓪#*)⓪"⓪"PROCEDURE outOfRegs;⓪$BEGIN⓪&BadId:= 'out of registers';⓪&SyntaxError (rFatlR)⓪$END outOfRegs;⓪$⓪"VAR (*$Reg*)unused: RegSet; (*$Reg*)r: RegType;⓪ ⓪"BEGIN⓪$IF spilling THEN bong END;⓪$spilling:= TRUE;⓪$IF spillSp >= exprSp THEN⓪&outOfRegs;⓪$ELSE⓪&INC (spillSp);⓪&WITH exprStack[spillSp] DO⓪(WITH expr DO⓪*CASE kind OF⓪*| register: IF exprReg IN tempRegs THEN⓪9IF NOT maySpill THEN outOfRegs END;⓪9pushReg (expr, spillDestReg);⓪7END;⓪"⓪*| memory: IF (mode = d16An) OR (mode = d8AnXn) THEN⓪9IF (baseReg IN tempRegs)⓪9OR (mode = d8AnXn) & (idxReg IN tempRegs) THEN⓪;IF spillDestReg = A3 THEN⓪=depth:= A3Offset;⓪;END;⓪;IF NOT maySpill THEN outOfRegs END;⓪;genPushAddress (expr, spillDestReg);⓪;deallocRegs (expr);⓪;IF spillDestReg = A7 THEN⓪=depth:= A7Offset;⓪=mode:= ptrOnA7⓪;ELSE⓪=mode:= ptrOnA3⓪;END⓪9END;⓪7END⓪*⓪*| stack: IF stackReg IN tempRegs THEN⓪9IF spillDestReg = A3 THEN spillOfs:= A3Offset END;⓪9IF NOT maySpill THEN outOfRegs END;⓪9genPushReg (stackReg, TRUE, spillDestReg);⓪9deallocReg (stackReg);⓪9IF spillDestReg = A7 THEN spillOfs:= A7Offset END;⓪9kind:= spilledSP;⓪9spillReg:= spillDestReg;⓪7END⓪*ELSE⓪*END;⓪(END;⓪&END;⓪$END;⓪$spilling:= FALSE⓪"END spillReg;⓪ ⓪ PROCEDURE spillRegs (desiredRegs: RegSet);⓪"(* sichert die benötigten Regs *)⓪"VAR ok: BOOLEAN;⓪"BEGIN⓪$IF desiredRegs * freeRegs # desiredRegs THEN⓪&LOOP⓪(IF NOT spillRegByMove (desiredRegs) THEN EXIT END;⓪(IF desiredRegs * freeRegs = desiredRegs THEN RETURN END⓪&END;⓪&REPEAT⓪(spillReg (desiredRegs)⓪&UNTIL desiredRegs * freeRegs = desiredRegs⓪$END⓪"END spillRegs;⓪ ⓪ PROCEDURE spillAllRegs ();⓪"(* sichert alle temporären Regs *)⓪"BEGIN⓪$(*&&& auch reg-vars in ihre⓪%* memory-zelle retten. dafür sorgen, daß beim nächsten⓪%* benutzen der wert wieder ins reg geladen wird und dort bleibt *)⓪$spillRegs (tempRegs);⓪"END spillAllRegs;⓪ ⓪ PROCEDURE spillAllRegsExcept (VAR expr: ExprDesc);⓪"(* sichert alle temporären Regs außer denen von 'expr' *)⓪"VAR regs: RegSet;⓪"BEGIN⓪$regs:= tempRegs;⓪$exclRegs (expr, regs);⓪$spillRegs (regs);⓪"END spillAllRegsExcept;⓪ ⓪ PROCEDURE loadAddressTo ( VAR expr: ExprDesc; niceRegs: RegSet );⓪"(*⓪#* Lädt Referenz der Expr. in ein Adreß-Reg. und setzt Länge auf 4.⓪#* Ist die Expr eine Konstante, wird die Konstante dazu im Code abgelegt.⓪#* Wird z.B. f. ADR()-Funktion benutzt.⓪#*)⓪"VAR r: RegType; ptr: ADDRESS; gl: BOOLEAN; ofs: LONGINT;⓪"BEGIN⓪$ofs:= 0;⓪$WITH expr DO⓪&IF kind = constant THEN⓪(changeConstantToConstRef (expr, Size (expr));⓪&END;⓪&IF (kind = constRef) THEN⓪((* LEA <const-adr>,An und INC(An,<constOfs) generieren *)⓪(ofs:= constOfs;⓪(kind:= memory;⓪(mode:= absRef;⓪(tiefe:= 0;⓪(mayBeOdd:= FALSE;⓪((* Achtung: hier muß 'constHead' noch erhalten bleiben! *)⓪&ELSIF kind = stack THEN⓪((*$? Safety: assert ((stackReg # A3) OR (up) OR (stackedSize = 0L));*)⓪(changeStackToIndir (expr)⓪&END;⓪&assert ((kind = memory) & (mode # immRef));⓪&IF ((mode = d16An) OR (mode = d8AnXn)) & ~shortInt (disp) THEN⓪((* Sonderbehandlung: Obwohl bei d16An 'disp' nur 16 Bit groß⓪)* sein darf, werten wir hier ggf. auch größere Offsets aus,⓪)* da dies u.U. bei Zuweisung großer Daten vom Stack in⓪)* 'loadSizedAddress' vorkommt. Für evtl. Adr-Arten der 68020⓪)* ist das eh' sinvoll. *)⓪((* statt LEA disp(baseReg),r: LEA 0(baseReg),r + ADDA #ofs,r *)⓪(ofs:= disp;⓪(disp:= 0;⓪&END;⓪&IF (mode = d16An) & (baseReg IN niceRegs) & (ABS (disp) <= 8L) THEN⓪((* statt LEA x(An),An wird ADDQ/SUBQ #x,An erzeugt,⓪)* bei LEA 0(An),An wird sogar gar nix gen. *)⓪(incReg (baseReg, toZZ (disp, TRUE), 4);⓪(exprReg:= baseReg;⓪&ELSIF (mode = d8AnXn) & (baseReg IN niceRegs) & (disp = 0L) THEN⓪((* statt LEA 0(An,Xm),An wird ADD Xm,An gen. *)⓪(genADDA (idxL, idxReg, baseReg);⓪(deallocReg (idxReg);⓪(exprReg:= baseReg;⓪&ELSE⓪(deallocRegs (expr);⓪(r:= allocReg (niceRegs);⓪(genLEA (expr, r);⓪(exprReg:= r;⓪&END;⓪&kind:= register;⓪&IF ofs # 0 THEN⓪(incReg (exprReg, toZZ (ofs, TRUE), 4)⓪&END;⓪&item:= CardPtr;⓪$END;⓪"END loadAddressTo;⓪ ⓪ PROCEDURE loadAddress ( VAR expr: ExprDesc );⓪"(*⓪#* Lädt Referenz der Expr. in ein Adreß-Reg. und setzt Länge auf 4.⓪#* Ist die Expr eine Konstante, wird die Konstante dazu im Code abgelegt.⓪#* Wird z.B. f.ADR()-Funktion benutzt.⓪#*)⓪"BEGIN⓪$loadAddressTo (expr, addrRegs)⓪"END loadAddress;⓪ ⓪ PROCEDURE loadSizedAddress (VAR expr, oldExpr: ExprDesc; size: LONGINT);⓪"(* nur lokal für die beiden folg. Routinen! *)⓪"(* Test: FEHLER19.M *)⓪"BEGIN⓪$oldExpr:= expr;⓪$WITH expr DO⓪&IF (kind = stack) & NOT (stackReg IN tempRegs) THEN⓪((*$? Safety: assert (stackReg IN RegSet {A3,A7});*)⓪(IF ODD (size) THEN INC (size) END;⓪(oldExpr.stackedSize:= size;⓪(stackedSize:= size;⓪(IF up THEN⓪*(* LEA (A3),An *)⓪*changeStackToIndir (expr);⓪*loadAddress (expr);⓪(ELSE⓪*(* LEA -stackSize(A3),An *)⓪*changeStackToIndir (expr);⓪*disp:= -size;⓪*loadAddress (expr);⓪(END⓪&ELSE⓪(loadAddress (expr)⓪&END⓪$END⓪"END loadSizedAddress;⓪ ⓪ PROCEDURE updateStack (VAR expr: ExprDesc);⓪"VAR n: LONGINT;⓪"BEGIN⓪$WITH expr DO⓪&IF (kind = stack) & NOT (stackReg IN tempRegs) THEN⓪(n:= stackedSize;⓪(IF NOT up THEN n:= -n END;⓪(incReg (stackReg, toZZ (n, TRUE), 4);⓪&END⓪$END⓪"END updateStack;⓪ ⓪ PROCEDURE loadDestAddress (VAR expr: ExprDesc; size: LONGINT);⓪"(*⓪#* wie 'loadExprAddress', jedoch mit manueller size-Angabe für Destinations⓪#* Für Destinations darf der Stack sofort korrigiert werden (dazu updateStacks⓪#* aufrufen), weil der Wert ja immer auf den Stack kommt, so daß er auch⓪#* sofort geschützt werden sollte.⓪#*)⓪"VAR oldExpr: ExprDesc;⓪"BEGIN⓪$loadSizedAddress (expr, oldExpr, size);⓪$updateStack (oldExpr)⓪"END loadDestAddress;⓪ ⓪ PROCEDURE loadExprAddress (VAR expr, oldExpr: ExprDesc);⓪"(*⓪#* wie 'loadAddress', geht auch, wenn Datum auf Stack steht.⓪#* nicht für Ziel-designator anzuwenden (dafür gibt's loadDestAddress)!⓪#* Achtung: Da der Stack nicht gleich hier korrigiert werden darf,⓪#* muß dies nach dem Zugriff mit 'updateStack (oldExpr)' geschehen!⓪#*)⓪"BEGIN⓪$loadSizedAddress (expr, oldExpr, LONGINT (expr.stackedSize));⓪"END loadExprAddress;⓪ ⓪ PROCEDURE loadSourceAddress ( VAR expr: ExprDesc );⓪"(*⓪#* wie 'loadAddress', nur kann für source-werte bei MOVE noch optimiert werden⓪#*)⓪"BEGIN⓪$WITH expr DO⓪&IF ((kind = constant) OR (kind = constRef)) & (constOfs = 0) THEN⓪((* wenn absolute Adr, kann statt LEA adr,An besser #adr gen. werden *)⓪(IF kind = constant THEN⓪*changeConstantToConstRef (expr, Size (expr));⓪(END;⓪((*$? Safety: assert (kind = constRef); *)⓪(kind:= constImm;⓪(item:= CardPtr;⓪(RETURN⓪&ELSIF kind = memory THEN⓪(IF mode = absRef THEN⓪*(* wenn absolute Adr, kann statt LEA adr,An besser #adr gen. werden *)⓪*mode:= immRef;⓪*item:= CardPtr;⓪*RETURN⓪(ELSIF mode = extL THEN⓪*(* wenn externe Adr, kann statt LEA adr,An besser #adr gen. werden *)⓪*exprConst.l:= LONGWORD (extAddr);⓪*kind:= constant;⓪*item:= CardPtr;⓪*RETURN⓪(END⓪&END⓪$END;⓪$loadAddress (expr)⓪"END loadSourceAddress;⓪ ⓪ PROCEDURE moveAddress (VAR expr, dest: ExprDesc);⓪"(*⓪#* wie loadSourceAddress, nur wird der Wert gleich woanders abgelegt;⓪#* üblicherweise wird dies benutzt, um Variablen-Refs auf den Stack⓪#* zu packen.⓪#*)⓪"VAR t: PtrItem;⓪"BEGIN⓪$(*~~~ hier ggf. stattdessen PEA gen. *)⓪$WITH expr DO⓪&t:= item;⓪&IF (kind # memory)⓪&OR (mode # d16An)⓪&OR (disp # 0L) THEN⓪(loadSourceAddress (expr)⓪&ELSE⓪(kind:= register;⓪(exprReg:= baseReg⓪&END;⓪&item:= sizedItem (4, FALSE);⓪&genMOVEaa (expr, dest, 0);⓪&item:= t⓪$END;⓪"END moveAddress;⓪ ⓪ PROCEDURE inDataReg (VAR expr: ExprDesc): BOOLEAN;⓪"BEGIN⓪$RETURN (expr.kind = register) & (expr.exprReg < A0)⓪"END inDataReg;⓪ ⓪ (* unbenutzt⓪ PROCEDURE moveReg ( source, dest: RegType; size: CARDINAL );⓪"BEGIN⓪$(*$? Safety: assert (~(source IN tempRegs) & ~(dest IN tempRegs));*)⓪$genMOVErr (source, dest, size)⓪"END moveReg;⓪ *)⓪ ⓪ (* unbenutzt⓪ PROCEDURE moveTempReg ( source, dest: RegType; size: CARDINAL );⓪"BEGIN⓪$(*$? Safety: assert ((source IN tempRegs) & ~(dest IN tempRegs));*)⓪$deallocReg (source);⓪$genMOVErr (source, dest, size)⓪"END moveTempReg;⓪ *)⓪ ⓪ (* unbenutzt⓪ PROCEDURE moveToTempReg ( source: RegType;⓪:VAR dest: RegType; niceRegs: RegSet; size: CARDINAL );⓪"(* move register to one of niceRegs *)⓪"BEGIN⓪$(*$? Safety: assert (~(source IN tempRegs));*)⓪$dest:= allocReg (niceRegs);⓪$genMOVErr (source, dest, size)⓪"END moveToTempReg;⓪ *)⓪ ⓪ PROCEDURE constToReg (v: ZZ; size: CARDINAL; r: RegType);⓪"BEGIN⓪$IF int8ZZ (v) & (r IN anyDataReg) THEN⓪&genMOVEQ (v, r)⓪$ELSE⓪&genMOVEir (v, size, r)⓪$END;⓪"END constToReg;⓪ ⓪ PROCEDURE prepareStackForLoad (VAR expr: ExprDesc);⓪"BEGIN⓪$IF expr.kind = stack THEN⓪&WITH expr DO⓪(IF (stackReg = A3) & ~up THEN⓪*incReg (stackReg,⓪2toZZ (LONGINT (Size (expr)) - LONGINT (stackedSize), FALSE),⓪24);⓪*stackedSize:= Size (expr)⓪(END;⓪&END;⓪$END;⓪"END prepareStackForLoad;⓪ ⓪ FORWARD copy (VAR source, dest: ExprDesc; size: LONGCARD; byByte: BOOLEAN);⓪ FORWARD loadRealReg (VAR expr: ExprDesc; niceRegs: RegSet);⓪ ⓪ PROCEDURE loadAllocedReg ( VAR expr: ExprDesc; r: RegType );⓪"(* load the expr. into the register *)⓪"VAR op: CARDINAL;⓪"BEGIN⓪$IF (r >= F0) THEN⓪&SyntaxError (rRegVa)⓪$ELSE⓪&(*$? Safety: assert ((r < A0) OR (Size (expr) # 1L)); *)⓪&WITH expr DO⓪(CASE kind OF⓪(| constRef: (*$?Safety2: assert (constOfs = 0); *)⓪4kind:= memory;⓪4mode:= absRef;⓪4genMOVEar (expr, r);⓪ ⓪(| constant: constToReg (exprConst.zz, SHORT (Size (expr)), r);⓪(⓪(| condFlags:IF fpuFlags THEN⓪6op:= mapFPUcc (relOp, not);⓪4ELSE⓪6op:= mapCC (relOp, signed, not);⓪4END;⓪4not:= FALSE; (* ~~~ ist das korrekt? oder nicht verändern? *)⓪4kind:= register;⓪4exprReg:= r;⓪4genBool (op, fpuFlags, expr);⓪ ⓪(| register: IF (exprReg >= F0) & (item = SRealPtr) THEN⓪6deallocReg (exprReg);⓪6initPseudoRegExpr (expr, item, exprReg, FALSE);⓪6genMOVEar (expr, r);⓪4ELSE⓪6genMOVEar (expr, r);⓪6deallocReg (exprReg)⓪4END;⓪(⓪(| memory,⓪*stack: IF (kind = memory) & (mode = relConst) THEN⓪6(*⓪7* wir wollen die Adr. einer lok. Proc laden⓪7* dann erzeugen wir stattdessen einen LEA⓪7*)⓪6(*$? Safety: assert (r >= A0);*)⓪6mode:= relRef;⓪6genLEA (expr, r);⓪4ELSE⓪6IF (kind = stack) THEN⓪8(*$? Safety: assert ( (stackReg # A3) OR up OR⓪N(Size (expr) = stackedSize) );*)⓪6END;⓪6genMOVEar (expr, r)⓪4END;⓪(END;⓪&END⓪$END;⓪$expr.kind:= register;⓪$expr.exprReg:= r;⓪"END loadAllocedReg;⓪ ⓪ PROCEDURE loadRegVar ( VAR expr: ExprDesc; r: RegType );⓪"BEGIN⓪$(*$? Safety: assert (NOT (r IN freeRegs) & (r IN varRegs));*)⓪$WITH expr DO⓪&CASE kind OF⓪&| register: IF exprReg # r THEN⓪4loadAllocedReg (expr, r)⓪2END;⓪&| stack,⓪(memory: IF r < F0 THEN⓪4deallocRegs (expr);⓪2END;⓪2(*$? Safety:⓪4IF (kind = memory) & (mode = relConst) THEN⓪6assert (r IN addrRegs);⓪4END;⓪2*)⓪2prepareStackForLoad (expr);⓪2loadAllocedReg (expr, r)⓪&ELSE⓪2loadAllocedReg (expr, r)⓪&END;⓪$END;⓪"END loadRegVar;⓪ ⓪ PROCEDURE loadReg ( VAR expr: ExprDesc; niceRegs: RegSet );⓪"(* load the expr. into one of the registers in niceRegs *)⓪"VAR r: RegType;⓪"BEGIN⓪$IF niceRegs <= RegSet{F0..F7} THEN⓪&loadRealReg (expr, niceRegs)⓪$ELSE⓪&WITH expr DO⓪(CASE kind OF⓪(| register: IF ~ ( exprReg IN niceRegs ) THEN⓪6r:= allocReg (niceRegs);⓪6loadAllocedReg (expr, r)⓪4END;⓪(| stack,⓪*memory: deallocRegs (expr);⓪4IF (kind = memory) & (mode = relConst) THEN⓪6niceRegs:= addrRegs * niceRegs;⓪6(*$? Safety: assert (niceRegs # RegSet {});*)⓪4END;⓪4prepareStackForLoad (expr);⓪4r:= allocReg (niceRegs);⓪4loadAllocedReg (expr, r)⓪(ELSE⓪4r:= allocReg (niceRegs);⓪4loadAllocedReg (expr, r)⓪(END;⓪&END;⓪$END;⓪"END loadReg;⓪ ⓪ PROCEDURE swapRegs (VAR left, right: ExprDesc);⓪"(* tauscht Regs aus *)⓪"VAR r: RegType;⓪"BEGIN⓪$(*$? Safety: assert ((left.kind = register) & (right.kind = register));*)⓪$genEXG (right.exprReg, left.exprReg);⓪$r:= right.exprReg;⓪$right.exprReg:= left.exprReg;⓪$left.exprReg:= r⓪"END swapRegs;⓪ ⓪ PROCEDURE loadRegByEXG ( VAR expr: ExprDesc; destReg: RegType);⓪"(* 'expr' soll nach 'destReg' geladen werden. 'destReg' ist aber belegt.⓪#* Hier wird nun nach der Expr gesucht, die das Reg belegt und dann deren⓪#* Reg in ein anderes Reg gelegt. Diese Routine geht davon aus, daß die⓪#* anderen Exprs genau 'kind=register' sind, wenn sie das Reg belegen.⓪#* Wird in dieser Form für die Reg-Parm-Übergabe gebraucht. *)⓪"VAR (*$Reg*) mySpillSp: ExprSP;⓪"BEGIN⓪$IF destReg >= F0 THEN⓪&SyntaxError (rNImpY)⓪$ELSE⓪&loadReg (expr, addrRegs+dataRegs);⓪&mySpillSp:= spillSp;⓪&WHILE mySpillSp < exprSp DO⓪(INC (mySpillSp);⓪(IF (exprStack[mySpillSp].expr.kind = register)⓪(& (exprStack[mySpillSp].expr.exprReg = destReg) THEN⓪*swapRegs (expr, exprStack[mySpillSp].expr);⓪*RETURN⓪(END;⓪&END;⓪&bong()⓪$END;⓪"END loadRegByEXG;⓪ ⓪ ⓪ PROCEDURE extendRegToLong (VAR expr: ExprDesc);⓪"VAR s: CARDINAL; t: PtrItem; r: RegType;⓪"BEGIN⓪$(*$? Safety: assert (expr.kind = register);*)⓪$s:= SHORT (Size (expr));⓪$IF s < 4 THEN⓪&(*$? Safety: assert (s = 2);*)⓪&IF signedExpr (expr) THEN⓪(genr (EXTL, expr.exprReg);⓪(t:= IntPtr⓪&ELSE⓪(genr (SWAP, expr.exprReg);⓪(genr (CLRW, expr.exprReg);⓪(genr (SWAP, expr.exprReg);⓪(t:= SCardPtr⓪&END;⓪&expr.item:= t⓪$END⓪"END extendRegToLong;⓪ ⓪ PROCEDURE loadRegExt (VAR expr: ExprDesc; niceRegs: RegSet;⓪6resultSize: CARDINAL; setType: BOOLEAN);⓪"(* load expr into Reg and extend to 'resultSize' *)⓪"VAR s: CARDINAL; r: RegType; unsignedExpand, signed: BOOLEAN;⓪"BEGIN⓪$(*$? Safety: assert (NOT (niceRegs <= RegSet {F0..F7})); *)⓪$s:= SHORT (Size (expr));⓪$IF s = resultSize THEN⓪&loadReg (expr, niceRegs)⓪$ELSE⓪&(*$? Safety: assert (s < resultSize);*)⓪&IF (expr.kind = constant) & int8ZZ (expr.exprConst.zz) THEN⓪(r:= allocReg (niceRegs);⓪(loadAllocedReg (expr, r);⓪(IF r IN anyDataReg THEN⓪*(* MOVEQ wurde erz., so daß kein weiteres Extend nötig ist *)⓪*RETURN⓪(END⓪&END;⓪&⓪&signed:= signedExpr (expr);⓪&⓪&unsignedExpand:= FALSE;⓪&IF expr.kind = register THEN⓪(IF signed THEN⓪*r:= expr.exprReg;⓪*IF NOT (r IN niceRegs) THEN⓪,r:= allocReg (niceRegs);⓪,loadAllocedReg (expr, r)⓪*END;⓪(ELSE⓪*IF (expr.exprReg IN niceRegs) & (niceRegs * freeRegs = RegSet {}) THEN⓪,(* Reg muß im gleichen Reg expandiert werden m. ANDI *)⓪,unsignedExpand:= TRUE⓪*ELSE⓪,r:= allocReg (niceRegs * dataRegs);⓪,genClrReg (r); (* MOVEQ #0,Dr *)⓪,loadAllocedReg (expr, r)⓪*END;⓪(END;⓪&ELSE⓪(IF signed & ( (expr.kind = memory) OR (expr.kind = stack) ) THEN⓪*deallocRegs (expr)⓪(END;⓪(IF NOT signed⓪(& exprUsesRegs (expr, niceRegs)⓪(& (niceRegs * freeRegs = RegSet {}) THEN⓪*(* Reg muß nach dem Load expandiert werden m. ANDI *)⓪*unsignedExpand:= TRUE;⓪(ELSIF signed & (s = 2) THEN⓪*r:= allocAddrRegIfAllowed (niceRegs)⓪(ELSE⓪*r:= allocReg (niceRegs * dataRegs)⓪(END;⓪(IF NOT signed THEN⓪*IF (expr.kind = memory) OR (expr.kind = stack) THEN⓪,deallocRegs (expr)⓪*END;⓪*IF unsignedExpand THEN⓪,r:= allocReg (niceRegs * dataRegs)⓪*ELSE⓪,genClrReg (r); (* MOVEQ #0,Dr *)⓪*END;⓪(END;⓪(prepareStackForLoad (expr);⓪(loadAllocedReg (expr, r);⓪&END;⓪&⓪&(*$? Safety: assert (expr.exprReg IN niceRegs); *)⓪&⓪&IF signed & (r < A0) THEN⓪(IF s = 1 THEN genr (EXTW, expr.exprReg); END;⓪(IF resultSize = 4 THEN genr (EXTL, expr.exprReg); END⓪&ELSIF unsignedExpand THEN⓪((* ANDI auf Data-Reg *)⓪(IF resultSize = 2 THEN⓪*genANDI (2, $00FF, expr.exprReg);⓪(ELSIF s = 1 THEN⓪*genANDI (4, $000000FFL, expr.exprReg)⓪(ELSE⓪*genANDI (4, $0000FFFFL, expr.exprReg)⓪(END⓪&END;⓪&⓪&IF setType THEN⓪(expr.item:= sizedItem (resultSize, signed)⓪&END⓪$END⓪"END loadRegExt;⓪ ⓪ PROCEDURE copyRegExt (REF source: ExprDesc; VAR second: ExprDesc;⓪6niceRegs: RegSet; destSize: CARDINAL);⓪"(*⓪#* kopiert <ea> aus 'source' in ein neues Reg und liefert dessen⓪#* Beschreibung in 'second'.⓪#* Optional kann eine Größe (destSize > 0) für das zweite Reg.⓪#* bestimmt werden, so daß dann ein expand gemacht wird.⓪#* Wenn 'niceRegs' auch Adreßreg. erlaubt und ein signed expand nötig ist,⓪#* wird, falls eins der Adr-Regs frei ist, der Wert dorthinein kopiert.⓪#*)⓪"VAR sourceSize: CARDINAL; signed: BOOLEAN; regs: RegSet; reg: RegType;⓪"BEGIN⓪$second:= source;⓪$sourceSize:= SHORT (Size (source));⓪$IF sourceSize < destSize THEN⓪&(* expand *)⓪&signed:= signedExpr (source);⓪&IF signed THEN⓪(IF sourceSize = 2 THEN⓪*reg:= allocAddrRegIfAllowed (niceRegs)⓪(ELSE⓪*reg:= allocReg (niceRegs * dataRegs)⓪(END;⓪(regs:= freeRegs;⓪(loadAllocedReg (second, reg);⓪(IF reg < A0 THEN⓪*IF sourceSize = 1 THEN genr (EXTW, reg); END;⓪*IF destSize = 4 THEN genr (EXTL, reg); END⓪(END;⓪&ELSE⓪(reg:= allocReg (dataRegs * niceRegs);⓪(genClrReg (reg); (* MOVEQ #0,Dr *)⓪(regs:= freeRegs;⓪(loadAllocedReg (second, reg);⓪&END;⓪&second.item:= sizedItem (destSize, signed)⓪$ELSE⓪®:= allocReg (niceRegs);⓪®s:= freeRegs;⓪&loadAllocedReg (second, reg);⓪$END;⓪$freeRegs:= regs⓪"END copyRegExt;⓪ ⓪ PROCEDURE copyRef ( VAR expr, ref: ExprDesc );⓪"(*⓪#* Legt eine Kopie von 'expr' an, so daß nun beide auf keinen Fall das⓪#* selbe Adr-Reg benutzen und damit nicht der eine den Ptr des andern⓪#* ändern kann.⓪#* Die Routine legt z.Zt. einfach immer zwei Adr-Regs an, auch wenn dies⓪#* nicht nötig wäre, z.B. bei absolut-Zugriffen.⓪#* Beide Exprs zeigen danach mit (An) auf den Wert.⓪#*)⓪"VAR t: PtrItem; odd: BOOLEAN;⓪"BEGIN⓪$(*$? Safety: assert (expr.kind # stack); (* wer räumt sonst den Stack ab? *) *)⓪$t:= expr.item;⓪$odd:= (expr.kind = memory) & expr.mayBeOdd;⓪$loadAddressTo (expr, addrRegs);⓪$copyRegExt (expr, ref, addrRegs, 0);⓪$makeIndir (expr, 0, odd);⓪$makeIndir (ref, 0, odd);⓪$expr.item:= t;⓪$ref.item:= t⓪"END copyRef;⓪ ⓪ PROCEDURE newRegWithConstant (VAR expr: ExprDesc; size: CARDINAL; const: ZZ);⓪"(* lädt die Konst in ein neues Datenregister; 'item' ist NIL! *)⓪"VAR r: RegType;⓪"BEGIN⓪$r:= allocReg (dataRegs);⓪$constToReg (const, size, r);⓪$initExpr (expr, NIL, register);⓪$expr.exprReg:= r⓪"END newRegWithConstant;⓪ ⓪ PROCEDURE moveA6toTempReg (VAR baseReg: RegType);⓪"VAR r: RegType;⓪"BEGIN⓪$IF NOT (baseReg IN tempRegs) (* Vorsicht, wenn sich varRegs & tempRegs⓪B* überlappen&&& Dann müssen auch Var-Regs⓪B* geschützt werden! *)⓪$THEN⓪&r:= allocReg (addrRegs);⓪&genMOVErr (baseReg, r, 4);⓪&deallocReg (baseReg);⓪&baseReg:= r⓪$END;⓪"END moveA6toTempReg;⓪ ⓪ PROCEDURE addIdxReg (VAR expr, index: ExprDesc; long, nullDisp: BOOLEAN);⓪"(* IN: expr zum Zugriff auf Datum mit indir. Zugriff (d16 o. d8)⓪#* 'nullDisp': TRUE, wenn voraussichtlich 'disp' Null bleibt.⓪#* OUT: expr plus index-Reg⓪#*⓪#* Vorsicht: long=FALSE nur übergeben, wenn index in INTEGER paßt,⓪#* aber nicht, wenn index zwar 2 Byte groß ist, aber > MaxInt⓪#* werden kann!⓪#*)⓪"BEGIN⓪$(*⓪%* 1) (An) -> ADD index,An / wenn index in Reg: 0(An,index)⓪%* 2) disp(An) -> disp(An,index), falls ABS (disp) < 128 & disp # 0⓪%* 3) disp(An,Xn) -> ADD index,An⓪%*)⓪$WITH expr DO⓪&(*$? Safety: assert ((kind = memory) & (Size (index) > 1L));*)⓪&IF (mode = d16An) & byteVal (disp)⓪&AND (NOT nullDisp OR (disp # 0) OR (index.kind = register)) THEN⓪(loadReg (index, anyCPUReg);⓪(restoreStack (index);⓪(mode:= d8AnXn;⓪(idxReg:= index.exprReg;⓪(idxL:= long⓪&ELSE⓪(moveA6toTempReg (baseReg);⓪(genar (ADDA, index, baseReg);⓪(restoreStack (index);⓪(deallocRegs (index)⓪&END⓪$END⓪"END addIdxReg;⓪ ⓪ PROCEDURE addDisp (VAR expr: ExprDesc; ofs: LONGINT);⓪"(* IN: expr zum Zugriff auf Datum mit indir. Zugriff (d16 o. d8)⓪#* OUT: expr mit neuem offset ('ofs' wird addiert)⓪#*)⓪"BEGIN⓪$WITH expr DO⓪&(*$? Safety:⓪(assert ((expr.kind = memory) & ( (mode=d8AnXn) OR (mode=d16An) ));⓪&*)⓪&INC (ofs, disp);⓪&IF mode = d8AnXn THEN⓪(IF (ofs > LONG (127)) OR (ofs < LONG (-128)) THEN⓪*moveA6toTempReg (baseReg);⓪*genADDA (idxL, idxReg, baseReg);⓪*deallocReg (idxReg);⓪*mode:= d16An⓪(END⓪&END;⓪&IF mode = d16An THEN⓪(IF (ofs > LONG (MaxInt))⓪(OR (ofs < LONG (MinInt)) THEN⓪*moveA6toTempReg (baseReg);⓪*genADDAL (ofs, baseReg);⓪*ofs:= 0⓪(END;⓪&END;⓪&disp:= ofs⓪$END⓪"END addDisp;⓪ ⓪ PROCEDURE addOffset (VAR fact: ExprDesc; ofs: LONGINT);⓪"(* Achtung: fact.item muß hiernach wieder neu gesetzt werden, weil⓪#* wg. 'loadAddress' dieser immer auf CardPtr gesetzt wird! *)⓪"VAR odd: BOOLEAN;⓪"BEGIN⓪$odd:= oddAccess (fact) OR ODD (ofs); (* ~~~ immer? *)⓪$IF indir (fact) THEN⓪&addDisp (fact, ofs);⓪&fact.mayBeOdd:= odd⓪$ELSIF ofs # 0L THEN⓪&loadAddress (fact);⓪&makeIndir (fact, ofs, odd);⓪$END⓪"END addOffset;⓪ ⓪ ⓪ PROCEDURE loadCCR ( VAR expr: ExprDesc );⓪"(* check the BOOLEAN *)⓪"BEGIN⓪$WITH expr DO⓪&(*$? Safety: assert (BooleanType (item));*)⓪&CASE kind OF⓪&| condFlags: (* OK *)⓪&| constant: bong⓪&| register,⓪(memory,⓪(stack: gena (TST, expr, 0);⓪3deallocRegs (expr);⓪3kind:= condFlags;⓪3fpuFlags:= FALSE;⓪3signed:= FALSE;⓪3relOp:= ne⓪&END;⓪$END;⓪"END loadCCR;⓪ ⓪ PROCEDURE tstAndJmp (true: BOOLEAN; VAR fact: ExprDesc; VAR targets: Labels;⓪5VAR oldExpr: ExprDesc; VAR backPtr: ADDRESS);⓪"VAR lbl: Label; negate: BOOLEAN; n: CARDINAL;⓪"BEGIN⓪$(*$? Safety: assert (fact.kind # jmp);*)⓪$loadCCR (fact);⓪$backPtr:= CodePtr ();⓪$oldExpr:= fact;⓪$negate:= fact.not;⓪$IF NOT true THEN negate:= NOT negate END;⓪$(*$? Safety: assert (fact.kind = condFlags);*)⓪$IF fact.fpuFlags THEN⓪&n:= mapFPUcc (fact.relOp, negate);⓪$ELSE⓪&n:= mapCC (fact.relOp, fact.signed, negate);⓪$END;⓪$genbcc (n, fact.fpuFlags, lbl);⓪$fact.kind:= jmp;⓪$MarkRef (lbl, targets);⓪"END tstAndJmp;⓪ ⓪ PROCEDURE moveAndJmp (true: BOOLEAN; VAR fact: ExprDesc; VAR targets: Labels;⓪6VAR oldExpr: ExprDesc; VAR backPtr: ADDRESS);⓪"VAR lbl: Label; negate: BOOLEAN;⓪"BEGIN⓪$(*$? Safety: assert (fact.kind # jmp);*)⓪$loadReg (fact, RegSet{D0});⓪$backPtr:= CodePtr ();⓪$oldExpr:= fact;⓪$negate:= fact.not;⓪$IF NOT true THEN negate:= NOT negate END;⓪$genbcc (mapCC (ne, FALSE, negate), FALSE, lbl);⓪$MarkRef (lbl, targets);⓪"END moveAndJmp;⓪ ⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ (* diverse Hilfsroutinen *)⓪ ⓪ PROCEDURE getConversionDesc (source, dest: PtrItem; VAR d: ConvDesc);⓪"(*⓪#* Liefert für 'safe conversion' sowie expand/shorten die erforderlichen⓪#* Codierungs-Infos sowie den Ergebnistypen (=dest). Wird von 'fitValue'⓪#* dann angepaßt.⓪#*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L d(A6),A2⓪(MOVE.L dest(A6),D0 ;dest⓪(MOVE.L source(A6),D2 ;source⓪(MOVE.L TreeBase,A1⓪(⓪(CLR.W ConvDesc.boundsCheck(A2)⓪(CLR.B ConvDesc.sizeFlags(A2)⓪(CLR ConvDesc.signedBounds(A2)⓪(CMPI.B #6,-1(A1,D2.L) ; Procedure?⓪(BNE takeLen⓪(MOVE.W #4,ConvDesc.sourceSize(A2)⓪(BRA wasProc⓪ takeLen MOVE.W -4(A1,D2.L),ConvDesc.sourceSize(A2)⓪ wasProc MOVE.W -4(A1,D0.L),ConvDesc.destSize(A2)⓪(MOVE.L D0,ConvDesc.destType(A2)⓪(⓪(CMP.L D0,D2⓪(BEQ.W isComp ;gleiche Typen -> kein Code nötig⓪(⓪(CMPI.B #11,-1(A1,D2.L) ;Source Subr ?⓪(BNE Comp12⓪(MOVE.L -18(A1,D2.L),D2 ;ja: durch Basetype ersetzen⓪ Comp12⓪(; BOOLEANs, BITNUM und Enums bei Source werden als CARDINAL geprüft:⓪(CMPI.B #24,-1(A1,D2.L) ;BOOLEAN?⓪(BEQ isBool2⓪(CMPI.B #41,-1(A1,D2.L) ;BITNUM?⓪(BEQ isBool2⓪(CMPI.B #9,-1(A1,D2.L) ;Enum?⓪(BNE noEnum⓪ isBool2 MOVE.L SCardPtr,D2⓪ noEnum⓪(MOVE.W -2(A1,D0.L),D1 ;Dest-Kennung⓪(⓪(CMPI.B #11,D1⓪(BEQ isSubr⓪(CMPI.B #24,D1 ;BOOLEAN? dann CARDINAL [0..1]⓪(BEQ isBool⓪(CMPI.B #41,D1 ;BITNUM? dann CARDINAL [0..31]⓪(BEQ isBin⓪(CMPI.B #9,D1 ;Enum? dann CARDINAL [0..MAX(enum)]⓪(BEQ isEnum⓪(⓪(BSR.W asComp1⓪(TST.B ConvDesc.sizeFlags(A2)⓪(BPL.W ende⓪(; Dest ist CHAR und muß als CARDINAL [0..255] gechecked werden⓪(CLR.L ConvDesc.lowerBound(A2)⓪(MOVE.L #255,ConvDesc.upperBound(A2)⓪(MOVE #1,ConvDesc.boundsCheck(A2)⓪(MOVE #1,ConvDesc.boundSize(A2)⓪(BRA.W ende⓪(⓪ isEnum ; Dest ist Enum⓪(MOVE.L -10(A1,D0.L),ConvDesc.upperBound(A2)⓪ contDst CLR.L ConvDesc.lowerBound(A2)⓪(MOVE.L SCardPtr,D0 ;BaseType⓪(BRA hdlSubr⓪(⓪(; Dest ist BOOLEAN⓪ isBool MOVE.L #1,ConvDesc.upperBound(A2)⓪(BRA contDst⓪(⓪(; Dest ist BITNUM⓪ isBin MOVE.L #31,ConvDesc.upperBound(A2)⓪(BRA contDst⓪(⓪ isSubr ; Dest ist Subrange⓪(MOVE.L -10(A1,D0.L),ConvDesc.lowerBound(A2)⓪(MOVE.L -14(A1,D0.L),ConvDesc.upperBound(A2)⓪(MOVE.L -18(A1,D0.L),D0 ;BaseType⓪(⓪ hdlSubr BSR asComp1⓪(MOVE #1,ConvDesc.boundsCheck(A2)⓪(CMPI.W #2,-4(A1,D0.L) ;Laenge des BaseType:⓪(BEQ Comp3 ; Word ->⓪(BCS Comp40 ; Byte ->⓪(MOVE #4,ConvDesc.boundSize(A2)⓪(CMP.L IntPtr,D0 ;*** Long: signed?⓪(BNE isComp⓪(ADDQ #1,ConvDesc.signedBounds(A2)⓪(BRA isComp⓪ Comp40 MOVE #1,ConvDesc.boundSize(A2)⓪(CMP.L BytIPtr,D0 ;*** Byte signed?⓪(BNE isComp⓪(ADDQ #1,ConvDesc.signedBounds(A2)⓪(BRA isComp⓪ Comp3 MOVE #2,ConvDesc.boundSize(A2)⓪(CMP.L SIntPtr,D0 ;*** Word RangeCheck⓪(BNE isComp⓪(ADDQ #1,ConvDesc.signedBounds(A2)⓪ isComp BRA.W ende⓪ ⓪ asComp1 LEA AsTab(PC),A0⓪(BRA search2⓪ search ADDQ.L #2,A0⓪ search2 MOVE.B (A0)+,D1⓪(BEQ.L rtn⓪(CMP.B -1(A1,D2.L),D1⓪(BNE search ;Sourcetyp falsch⓪(MOVE.B (A0),D1⓪(CMP.B -1(A1,D0.L),D1⓪(BNE search ;Desttyp falsch⓪(⓪(MOVE.B 1(A0),D1 ;gefunden: Code fuer Typanpassung holen⓪(MOVE.B D1,ConvDesc.sizeFlags(A2)⓪ rtn RTS⓪(⓪(; Assignment-kompatible Typen. Types, die hier nicht aufgeführt⓪(; sind, werden direkt ohne weitere Prüfung zugewiesen!⓪(; Aufbau: Source-Kennung, Dest-Kennung, Check-Code⓪(; Check-Codes:⓪(; Bit 0: Int<->Card, 1: expand, 2: short, 3: signed, 4: real,⓪(; 5: Proc-Short, 6: Proc-Expand,⓪(; 7: Subrange-Test f. dest durchführen!⓪(⓪ AsTab ; selbe Größe, aber Vorzeichenwechsel⓪(DC.B 4, 22, 1001%⓪(DC.B 4, 1, 1001%⓪(DC.B 1, 22, 1001%⓪(DC.B 22, 1, 0001%⓪(DC.B 33, 34, 1001%⓪(DC.B 34, 33, 0001%⓪(⓪(; expand⓪(DC.B 3, 1, 0010%⓪(DC.B 33, 1, 0010%⓪(DC.B 34, 1, 0010%⓪(DC.B 35, 1, 0010%⓪(⓪(DC.B 3, 4, 0010%⓪(DC.B 33, 4, 0010%⓪(DC.B 34, 4, 0010%⓪(DC.B 35, 4, 0010%⓪(⓪(DC.B 3, 22, 0010%⓪(DC.B 33, 22, 1011%⓪(DC.B 34, 22, 0010%⓪(DC.B 35, 22, 0010%⓪(⓪(DC.B 3, 30, 0010%⓪(DC.B 33, 30, 0010%⓪(DC.B 34, 30, 0010%⓪(DC.B 35, 30, 0010%⓪(⓪(DC.B 33, 23, 0010% ; 23: ADDRESS⓪(DC.B 34, 23, 0010%⓪(DC.B 35, 23, 0010%⓪(⓪(DC.B 3, 33, 0010%⓪(DC.B 3, 34, 0010%⓪(DC.B 3, 35, 0010%⓪(⓪(DC.B 6, 44, 01000000% ; Procedure -> Localproc-Type⓪(DC.B 19, 44, 01000000% ; Proc-Type -> Localproc-Type⓪(⓪(⓪(; short⓪(DC.B 1, 33, 1100% ; LI -> I⓪(DC.B 22, 33, 0101% ; LC -> I⓪(DC.B 4, 33, 0100% ; ZZ -> I⓪(DC.B 30, 33, 0100% ; LB -> I⓪(DC.B 1, 34, 0100% ; LI -> C⓪(DC.B 22, 34, 0100% ; LC -> C⓪(DC.B 4, 34, 0100% ; ZZ -> C⓪(DC.B 30, 34, 0100% ; LB -> C⓪(DC.B 1, 35, 0100% ; LI -> B⓪(DC.B 22, 35, 0100% ; LC -> B⓪(DC.B 4, 35, 0100% ; ZZ -> B⓪(DC.B 30, 35, 0100% ; LB -> B⓪(DC.B 1, 3, 0100% ; LI -> CHAR⓪(DC.B 22, 3, 0100% ; LC -> CHAR⓪(DC.B 30, 3, 0100% ; LB -> CHAR⓪(DC.B 4, 3, 0100% ; ZZ -> CHAR⓪(DC.B 33, 3, 10000100% ; I -> CHAR⓪(DC.B 34, 3, 10000100% ; C -> CHAR⓪(DC.B 35, 3, 10000100% ; SB -> CHAR⓪(DC.B 4, 38, 00000100% ; ZZ -> BYTE⓪(DC.B 33, 38, 00001100% ; I -> BYTE⓪(DC.B 34, 38, 00000100% ; C -> BYTE⓪(DC.B 35, 38, 00000100% ; SB -> BYTE⓪(DC.B 44, 19, 00100000% ; Localproc-Type -> Proc-Type⓪(⓪(;reals⓪(DC.B 40, 2, 10010% ; expand⓪(DC.B 2, 40, 10100% ; shorten⓪(⓪(DC.B 0⓪(SYNC⓪&ende⓪$END;⓪"END getConversionDesc;⓪ ⓪ PROCEDURE alwaysFitting (type: PtrItem): ConvDesc;⓪"(*⓪#* liefert 'range' so, daß 'valueFitting' immer TRUE liefert.⓪#*)⓪"VAR range: ConvDesc;⓪"BEGIN⓪$range.boundsCheck:= FALSE;⓪$range.sizeFlags:= convSet {};⓪$range.destType:= type;⓪$range.sourceSize:= 0;⓪$range.destSize:= 0;⓪$RETURN range⓪"END alwaysFitting;⓪ ⓪ ⓪ PROCEDURE GetRparen;⓪"BEGIN⓪$IF CurrentSymbol.itemNo # rparen THEN⓪&SyntaxError (rParXp)⓪$END;⓪$GetSymbol⓪"END GetRparen;⓪ ⓪ PROCEDURE ChkComma;⓪"BEGIN⓪$IF CurrentSymbol.itemNo # comma THEN⓪&SyntaxError (rComXp)⓪$END;⓪"END ChkComma;⓪ ⓪ PROCEDURE GetComma;⓪"BEGIN⓪$GetSymbol;⓪$ChkComma;⓪"END GetComma;⓪ ⓪ PROCEDURE GetLparen;⓪"BEGIN⓪$GetSymbol;⓪$IF CurrentSymbol.itemNo # lparen THEN⓪&SyntaxError (rLPaXp)⓪$END;⓪"END GetLparen;⓪ ⓪ PROCEDURE GetRbrack;⓪"BEGIN⓪$IF CurrentSymbol.itemNo # rbrack THEN⓪&SyntaxError (rBrkXp)⓪$END;⓪$GetSymbol⓪"END GetRbrack;⓪ ⓪ PROCEDURE ChkRbrace;⓪"BEGIN⓪$IF CurrentSymbol.itemNo # rbrace THEN⓪&SyntaxError (rBrcXp)⓪$END;⓪"END ChkRbrace;⓪ ⓪ PROCEDURE isNumber (item: PtrItem; VAR size: NumberSize;⓪CVAR type: NumberType): BOOLEAN;⓪"BEGIN⓪$item:= HostType (item);⓪$IF (item = SCardPtr) THEN⓪&size:= ord2;⓪&type:= cardType⓪$ELSIF (item = SIntPtr) THEN⓪&size:= ord2;⓪&type:= intType⓪$ELSIF (item = BothTyp) OR (item = ZZTyp) THEN⓪&size:= ord4;⓪&type:= bothType⓪$ELSIF (item = SBothTyp) THEN⓪&size:= ord2;⓪&type:= bothType⓪$ELSIF (item = CardPtr) THEN⓪&size:= ord4;⓪&type:= cardType⓪$ELSIF (item = IntPtr) THEN⓪&size:= ord4;⓪&type:= intType⓪$ELSIF (item = SRealPtr) THEN⓪&size:= real4;⓪&type:= realType⓪$ELSIF (item = RealPtr) THEN⓪&size:= real8;⓪&type:= realType⓪$ELSE⓪&size:= unspecSize;⓪&type:= unspecType;⓪&RETURN FALSE⓪$END;⓪$RETURN TRUE⓪"END isNumber;⓪ ⓪ PROCEDURE isWholeNumber (t: PtrItem): BOOLEAN;⓪"BEGIN⓪$RETURN ItemNo (HostType (t)) IN ItemSet {1, 30, 33, 34, 35, 4, 22}⓪"END isWholeNumber;⓪ ⓪ PROCEDURE isOrdinal (t: PtrItem): BOOLEAN;⓪"(* TRUE, wenn 'whole number' oder CHAR, Enum, BOOLEAN *)⓪"BEGIN⓪$RETURN (ItemNo (HostType (t)) IN ItemSet {1, 30, 33, 34, 35, 4, 22, 3, 9, 24})⓪$OR CharType (HostType (t))⓪"END isOrdinal;⓪ ⓪ PROCEDURE isReal (type: PtrItem): BOOLEAN;⓪"VAR n: CARDINAL;⓪"BEGIN⓪$n:= ItemNo (type);⓪$RETURN (n = 2 (* REAL *)) OR (n = 40 (* LONGREAL *))⓪"END isReal;⓪ ⓪ PROCEDURE isPointer (type: PtrItem): BOOLEAN;⓪"(* alle für Adreß-Register in Frage kommenden Types⓪#* - VORSICHT: nicht anwenden auf Proc-Type m. StaticLink sowie OpenArray *)⓪"VAR n: CARDINAL;⓪"BEGIN⓪$n:= ItemNo (type);⓪$RETURN (n = 20 (* POINTER *))⓪(OR (n = 23 (* ADDRESS *))⓪(OR (n = 19 (* PROCEDURE *))⓪(OR (n = 8 (* Opaque (eigen) *))⓪(OR (n = 25 (* Opaque (extern) *))⓪"END isPointer;⓪ ⓪ PROCEDURE isChar (t: PtrItem): BOOLEAN;⓪"(* liefert TRUE, wenn 't' ein CHAR-Type (Var oder Const) ist *)⓪"BEGIN⓪$RETURN CharType (t)⓪"END isChar;⓪ ⓪ PROCEDURE isSS (VAR expr: ExprDesc): BOOLEAN;⓪"(* liefert TRUE, wenn 't' ein String-Literal ist *)⓪"BEGIN⓪$RETURN (expr.item = SSTyp)⓪"END isSS;⓪ ⓪ PROCEDURE isStringVar (t: PtrItem): BOOLEAN;⓪"(* liefert TRUE, wenn 't' = ARRAY [0..x] OF CHAR ist *)⓪"BEGIN⓪$RETURN (ItemNo (t) = 12)⓪)& (ItemNo (ElementType (t)) = 3)⓪)(* >> nicht mehr nötig: & (LowBound (IndexType (t)) = 0L) *)⓪"END isStringVar;⓪ ⓪ PROCEDURE isProc (t: PtrItem): BOOLEAN;⓪"BEGIN⓪$RETURN (ItemNo (t) = 6) OR (ItemNo (t) = 44) OR (ItemNo (t) = 19)⓪"END isProc;⓪ ⓪ PROCEDURE MaxReal (longReal: BOOLEAN): RR;⓪"BEGIN⓪$(* Die Routinen liefern die Werte im benötigten Ziel-Format *)⓪$IF fpu () = softReal THEN⓪&IF longReal THEN RETURN RR (LargeLONGREAL (MM2Real))⓪2ELSE RETURN RR (LargeREAL (MM2Real)) END⓪$ELSE⓪&IF longReal THEN RETURN RR (LargeLONGREAL (IEEEReal))⓪2ELSE RETURN RR (LargeREAL (IEEEReal)) END⓪$END;⓪$RealConstIsUsed;⓪"END MaxReal;⓪ ⓪ PROCEDURE MinReal (longReal: BOOLEAN): RR;⓪"BEGIN⓪$(* Die Routinen liefern die Werte im benötigten Ziel-Format *)⓪$IF fpu () = softReal THEN⓪&IF longReal THEN RETURN RR (SmallLONGREAL (MM2Real))⓪2ELSE RETURN RR (SmallREAL (MM2Real)) END⓪$ELSE⓪&IF longReal THEN RETURN RR (SmallLONGREAL (IEEEReal))⓪2ELSE RETURN RR (SmallREAL (IEEEReal)) END⓪$END;⓪$RealConstIsUsed⓪"END MinReal;⓪ ⓪ PROCEDURE getBounds (item: PtrItem; VAR lowBound, highBound: ZZ);⓪"(*⓪#* es können alle Scalare übergeben werden, also auch BYTE, WORD, ADDRESS,⓪#* LONGWORD, usw.⓪#* Nur Reals gehen nicht!⓪#*)⓪"VAR n: CARDINAL; signed: BOOLEAN;⓪"BEGIN⓪$lowBound:= toZZ (0L, FALSE);⓪$n:= ItemNo (item);⓪$IF n = 11 THEN (* Subrange *)⓪&signed:= signedType (item);⓪&lowBound:= toZZ (LowBound (item), signed);⓪&highBound:= toZZ (HighBound (item), signed)⓪$ELSIF n = 9 THEN (* Enum *)⓪&highBound:= toZZ (NoOfElems (item) - 1L, FALSE);⓪$ELSIF n = 3 THEN (* CHAR *)⓪&highBound:= toZZ (255L, FALSE)⓪$ELSIF (n = 39) THEN (* signed BYTE *)⓪&lowBound:= toZZ (-128L, TRUE);⓪&highBound:= toZZ (127L, FALSE)⓪$ELSIF (n = 38) THEN (* BYTE *)⓪&lowBound:= toZZ (-128L, TRUE);⓪&highBound:= toZZ (255L, FALSE)⓪$ELSIF (n = 41) THEN (* BITNUM *)⓪&highBound:= toZZ (31L, FALSE)⓪$ELSIF n = 24 THEN (* BOOLEAN *)⓪&highBound:= toZZ (1L, FALSE)⓪$ELSIF n = 34 THEN (* CARDINAL *)⓪&highBound:= toZZ (LONG (MaxCard), FALSE)⓪$ELSIF (n = 21) THEN (* WORD *)⓪&lowBound:= toZZ (LONG (MinInt), TRUE);⓪&highBound:= toZZ (LONG (MaxCard), FALSE)⓪$ELSIF n = 22 THEN (* LONGCARD *)⓪&highBound:= toZZ (MaxLCard, FALSE)⓪$ELSIF n = 33 THEN (* INTEGER *)⓪&lowBound:= toZZ (LONG (MinInt), TRUE);⓪&highBound:= toZZ (LONG (MaxInt), TRUE)⓪$ELSIF n = 35 THEN (* SBothTyp *)⓪&highBound:= toZZ (LONG (MaxInt), TRUE)⓪$ELSIF n = 1 THEN (* LONGINT *)⓪&lowBound:= toZZ (MinLInt, TRUE);⓪&highBound:= toZZ (MaxLInt, FALSE)⓪$ELSIF n = 30 THEN (* LongBoth *)⓪&highBound:= toZZ (MaxLInt, FALSE)⓪$ELSIF n IN ItemSet {8,20,23,25,26,4} THEN⓪&lowBound:= toZZ (MinLInt, TRUE); (* Opq, Pointer, Longword, ZZ *)⓪&highBound:= toZZ (MaxLCard, FALSE)⓪$ELSE⓪&SyntaxError (rSclXp) (* dieser type ist nicht scalar *)⓪$END;⓪"END getBounds;⓪ ⓪ PROCEDURE getElems (lowBound, highBound: ZZ; VAR elems: LONGCARD);⓪"BEGIN⓪$elems:= diffZZ (highBound, lowBound) + 1L⓪"END getElems;⓪ ⓪ ⓪ (*$? CompileWithOldCompiler:⓪ PROCEDURE LTOS (lr: LongREAL): ShortREAL;⓪"CONST fpstat = $fffa40; (* Response word of MC68881 read *)⓪(fpstatlo= $fffa41;⓪(fpctrl = $fffa42; (* Control word of MC68881 write *)⓪(fpcmd = $fffa4a; (* Command word of MC68881 write *)⓪(fpcond = $fffa4e; (* Condition word of MC68881 write *)⓪(fpop = $fffa50; (* Operand long of MC68881 read/write *)⓪"VAR res: ShortREAL;⓪"BEGIN⓪$IF fpu () # softReal THEN⓪&ASSEMBLER⓪(LEA lr(A6),A0⓪ externl MOVE.W #$5400,fpcmd ; FMOVE.D (A0),FP0⓪ !DoDl1 TST.B fpstatlo⓪(BEQ DoDl1⓪(MOVE.L (A0)+,fpop⓪(MOVE.L (A0),fpop⓪(MOVE.W #$6400,fpcmd ; FMOVE.S FP0,D1⓪ !DoDl3 MOVE.B fpstatlo,D0⓪(BEQ DoDl3⓪(CMPI.B #4,D0⓪(BNE DoDErr⓪ !GoBack MOVE.L fpop,D0⓪(CMPI.B #2,fpstatlo⓪(BEQ NoErr⓪ !DoDErr CLR.L D0⓪(JSR FPUError⓪ NoErr MOVE.L D0,res(A6)⓪&END⓪$ELSE⓪&ASSEMBLER⓪(LEA lr(A6),A0⓪(MOVE.L (A0)+,D1⓪(MOVE.L (A0),D0⓪(TST.W D1 ; test exponent⓪(BEQ.S null ; branch if zero⓪(SWAP D1 ; get exponent into low word⓪(MOVE.W D1,D2 ; prepare exponent calculation⓪(ASR #3,D2⓪(ADD #$40,D2 ; add bias⓪(BMI null ; still neg.: underflow⓪(CMP #$80,D2 ; compare with maximum ffp exponent⓪(BCC overfl ; branch if exponent too high⓪(BTST #0,D1 ; test sign bit⓪(BNE isneg⓪(ADDI.B #$80,D2⓪"isneg SWAP D0 ; get mantissa bit 16..24⓪(MOVE D0,D1 ; now complete mantissa⓪(TST.B D1 ; must we round up ?⓪(BPL noround ; skip rounding up⓪(ADD.L #$100,D1 ; round it up⓪(BCC noround ; were there all ones ?⓪(BSET #31,D1 ; division by two⓪(ADDQ.B #1,D2 ; correct exponent⓪(BVS overfl ; exponent overflow⓪ noround MOVE.B D2,D1 ; place sign & exponent⓪(MOVE.L D1,D0⓪(BRA rok⓪ overfl TRAP #6⓪(DC.W -7-$4000 ;overflow⓪ null MOVEQ #0,D0 ; get a true zero⓪ rok MOVE.L D0,res(A6)⓪&END;⓪$END;⓪$RETURN res⓪"END LTOS;⓪ *)⓪ ⓪ PROCEDURE LRNEG (VAR lr: RR);⓪"BEGIN⓪$IF fpu () = softReal THEN⓪&ASSEMBLER⓪(MOVE.L lr(A6),A0⓪(TST.W (A0)⓪(BEQ ZERO⓪(BCHG #0,1(A0)⓪'ZERO:⓪&END⓪$ELSE⓪&ASSEMBLER⓪(MOVE.L lr(A6),A0⓪(BCHG #7,(A0)⓪&END⓪$END⓪"END LRNEG;⓪ ⓪ PROCEDURE SRNEG (VAR sr: SR);⓪"BEGIN⓪$IF fpu () = softReal THEN⓪&ASSEMBLER⓪(MOVE.L sr(A6),A0⓪(TST.L (A0)⓪(BEQ zero⓪(EORI.B #$80,3(A0)⓪'zero⓪&END⓪$ELSE⓪&ASSEMBLER⓪(MOVE.L sr(A6),A0⓪(BCHG #7,(A0)⓪&END⓪$END⓪"END SRNEG;⓪ ⓪ PROCEDURE LRABS (VAR lr: RR);⓪"BEGIN⓪$IF fpu () = softReal THEN⓪&ASSEMBLER⓪(MOVE.L lr(A6),A0⓪(TST.W (A0)⓪(BEQ ZERO⓪(BCLR #0,1(A0)⓪'ZERO:⓪&END⓪$ELSE⓪&ASSEMBLER⓪(MOVE.L lr(A6),A0⓪(BCLR #7,(A0)⓪&END⓪$END⓪"END LRABS;⓪ ⓪ PROCEDURE SRABS (VAR sr: SR);⓪"BEGIN⓪$IF fpu () = softReal THEN⓪&ASSEMBLER⓪(MOVE.L sr(A6),A0⓪(TST.L (A0)⓪(BEQ zero⓪(ORI.B #$80,3(A0)⓪'zero⓪&END⓪$ELSE⓪&ASSEMBLER⓪(MOVE.L sr(A6),A0⓪(BCLR #7,(A0)⓪&END⓪$END⓪"END SRABS;⓪ ⓪ PROCEDURE DestFormat (): AnyRealFormat;⓪"BEGIN⓪$RETURN VAL (AnyRealFormat, ORD (fpu () # softReal))⓪"END DestFormat;⓪ ⓪ PROCEDURE verifyIdenticalFormats;⓪"BEGIN⓪$IF DestFormat () # UsedFormat THEN⓪&(*!!! hier fehlt eine Funktion, um ohne FPU LR nach SR im IEEE-Format⓪'* zu konvertieren.⓪'* Um die Sache nicht noch komplizierter machen, ist z.Zt. auch das⓪'* SHORTen von MM2Real-Consts unter einer FPU nicht möglich. Dem⓪'* wäre abzuhelfen, indem einfach die entspr. Routine aus dem Runtime⓪'* hier verwendet würde. *)⓪&BadId:= 'LONG/SHORT(IEEE-const): need FPU';⓪&SyntaxError (rTmpRs);⓪$END;⓪"END verifyIdenticalFormats;⓪ ⓪ PROCEDURE srToSys (r: SR): REAL;⓪"BEGIN⓪$verifyIdenticalFormats;⓪$(* wenn keine Konvertierung nötig, ist alles OK⓪&RETURN Conv (AnyReal {LONGREAL (r), DestFormat ()}, UsedFormat);⓪$*)⓪$RETURN REAL (r)⓪"END srToSys;⓪ ⓪ PROCEDURE srToDest (r: REAL): SR;⓪"BEGIN⓪$verifyIdenticalFormats;⓪$(* wenn keine Konvertierung nötig, ist alles OK⓪&RETURN RR (Conv (AnyReal {r, UsedFormat}, DestFormat ()));⓪$*)⓪$RETURN SR (r)⓪"END srToDest;⓪ ⓪ PROCEDURE lrToSys (r: RR): LONGREAL;⓪"VAR ar: AnyReal;⓪"BEGIN⓪$ar.value:= LONGREAL (r);⓪$ar.format:= DestFormat ();⓪$RETURN Conv (ar, UsedFormat);⓪"END lrToSys;⓪ ⓪ PROCEDURE lrToDest (r: LONGREAL): RR;⓪"VAR ar: AnyReal;⓪"BEGIN⓪$ar.value:= r;⓪$ar.format:= UsedFormat;⓪$RETURN RR (Conv (ar, DestFormat ()));⓪"END lrToDest;⓪ ⓪ PROCEDURE shortenReal (VAR expr: ExprDesc; errNo: INTEGER);⓪"BEGIN⓪$(*$? Safety: assert ((expr.item = RealPtr) & (expr.kind = constant));*)⓪$expr.item:= SRealPtr;⓪$IF ABS (lrToSys (expr.exprConst.rr)) > lrToSys (MaxReal (FALSE)) THEN⓪&SyntaxError (errNo)⓪$END;⓪$(*$? CompileWithOldCompiler:⓪&expr.exprConst.sr:= LTOS (expr.exprConst.rr);⓪$*)⓪$(*$? CompileWithNewCompiler:⓪&verifyIdenticalFormats;⓪&expr.exprConst.sr:= SR (SHORT (LONGREAL (expr.exprConst.rr)));⓪$*)⓪$expr.exprConst.zz.over:= FALSE⓪"END shortenReal;⓪ ⓪ PROCEDURE expandReal (VAR expr: ExprDesc);⓪"BEGIN⓪$(*$? Safety: assert ((expr.item = SRealPtr) & (expr.kind = constant));*)⓪$expr.item:= RealPtr;⓪$verifyIdenticalFormats;⓪$expr.exprConst.rr:= RR (LONG (REAL (expr.exprConst.sr)));⓪"END expandReal;⓪ ⓪ PROCEDURE adaptZZ (VAR this: ExprDesc; to: PtrItem; boundCheck: BOOLEAN);⓪"(* Paßt auch Real-Konstanten an! *)⓪"VAR lo, hi: ZZ;⓪"BEGIN⓪$WITH this DO⓪&IF kind = constant THEN⓪(IF (item = ZZTyp) & (isWholeNumber (to) OR (ItemNo (to) = 38)) THEN⓪*item:= to;⓪*IF boundCheck THEN⓪,getBounds (to, lo, hi);⓪,IF NOT inZZ (exprConst.zz, lo, hi) THEN⓪.SyntaxError (rConOp)⓪,END⓪*END⓪(ELSIF (item = RealPtr) & (to = SRealPtr) THEN⓪*shortenReal (this, rConOp);⓪(END⓪&END⓪$END⓪"END adaptZZ;⓪ ⓪ PROCEDURE cutZZ (VAR x: ZZ; size: CARDINAL);⓪"(*$D-*)⓪"(* löscht unbenutzte Upper-Bytes in ZZ-Feld *)⓪"BEGIN⓪$WITH x DO⓪&over:= FALSE;⓪&IF size <= 2 THEN⓪(c2:= 0;⓪(IF size = 1 THEN⓪*b1:= BYTE (0)⓪(END⓪&END⓪$END⓪"(*$D-*)⓪"END cutZZ;⓪ ⓪ PROCEDURE reduceZZ (VAR expr: ExprDesc);⓪"(*⓪#* Wandelt Type, so daß keinesfalls mehr ZZ-Type eingestellt ist⓪#*)⓪"VAR int: BOOLEAN; lo, hi: ZZ;⓪"BEGIN⓪$IF (expr.item = ZZTyp) THEN⓪&(*$? Safety: assert (expr.kind = constant);*)⓪&int:= int16ZZ (expr.exprConst.zz);⓪&IF card16ZZ (expr.exprConst.zz) THEN⓪(IF int THEN⓪*expr.item:= SBothTyp⓪(ELSE⓪*expr.item:= SCardPtr⓪(END⓪&ELSIF int THEN⓪(expr.item:= SIntPtr⓪&ELSE⓪(getBounds (BothTyp, lo, hi);⓪(IF inZZ (expr.exprConst.zz, lo, hi) THEN⓪*expr.item:= BothTyp⓪(ELSIF posZZ (expr.exprConst.zz) THEN⓪*expr.item:= CardPtr⓪(ELSE⓪*expr.item:= IntPtr⓪(END⓪&END⓪$END⓪"END reduceZZ;⓪ ⓪ PROCEDURE makeZZ (t: PtrItem): PtrItem;⓪"BEGIN⓪$IF ItemNo (t) IN ItemSet {1, 22, 30, 33, 34, 35} THEN⓪&RETURN ZZTyp⓪$ELSE⓪&RETURN t⓪$END⓪"END makeZZ;⓪ ⓪ PROCEDURE getNumTypeForRange (lo, hi: ZZ; VAR t: PtrItem);⓪"(*⓪#* Liefert CARDINAL/INTEGER/SBothTyp/LONGCARD/LONGINT/BothTyp,⓪#* je nachdem, was am günstigsten f. [lo..hi] paßt.⓪#* Meldet SyntaxError, wenn Werte zu groß⓪#*)⓪"BEGIN⓪$IF card16ZZ (lo) & card16ZZ (hi) THEN⓪&IF int16ZZ (lo) & int16ZZ (hi) THEN⓪(t:= SBothTyp⓪&ELSE⓪(t:= SCardPtr⓪&END⓪$ELSIF int16ZZ (lo) & int16ZZ (hi) THEN⓪&t:= SIntPtr⓪$ELSIF posZZ (lo) THEN⓪&IF NOT hi.over THEN⓪(t:= BothTyp⓪&ELSE⓪(t:= CardPtr⓪&END⓪$ELSE⓪&IF cmpZZ (hi, toZZ (MaxLInt, FALSE)) = gt THEN⓪(SyntaxError (rBouRg)⓪&END;⓪&t:= IntPtr⓪$END;⓪"END getNumTypeForRange;⓪ ⓪ PROCEDURE adaptSSToChar (VAR expr: ExprDesc);⓪"BEGIN⓪$IF (expr.item = SSTyp) THEN⓪&IF Size (expr) <= 1L THEN expr.item:= CharPtr END⓪$END⓪"END adaptSSToChar;⓪ ⓪ FORWARD extractConst (VAR fact: ExprDesc; ofs, size: LONGCARD);⓪ ⓪ PROCEDURE adaptStringToSS (VAR expr: ExprDesc);⓪"(*⓪#* Diese Funktion wandelt Konstanten vom Typ ARRAY [..] OF CHAR nach SS.⓪#* Das kommt v.A. bei Value Constructors vor. "LENGTH" macht z.B. Gebrauch⓪#* hiervon. Allerdings darf dies nicht ohne Weiteres bei Zuweisungen⓪#* verwendet werden, da ja nicht unbedingt ein CHAR-Array als Null-termin.⓪#* String angesehen werden darf, man könnte ja sich gerade mit Value-Constr.⓪#* ein CHAR-Array mit 0-Zeichen mittendrin basteln wollen. Dies geht nur⓪#* mit einer zusätzlichen Direktive, die die Annahme erlaubt, daß ein⓪#* CHAR-Array ein String sei.⓪#* ~~~ Allerdings könnte man hierfür auch statt der Direktive den SS-Typ⓪#* bei Value-Constr. beibehalten, dann geht's automatisch.⓪#*)⓪"VAR ptr: POINTER TO ARRAY [0..32767] OF CHAR;⓪&l2, len: CARDINAL;⓪"BEGIN⓪$WITH expr DO⓪&IF (kind = constant) OR (kind = constRef) THEN⓪(IF isStringVar (item) THEN⓪*(* nun die Länge des Strings bestimmen und String verschieben *)⓪*l2:= SHORT (Size (expr));⓪*IF kind = constant THEN⓪,ptr:= ADR (exprConst.b) + 1 - LONG (l2)⓪*ELSE⓪,(*$? Safety: assert (constHead # NIL); *)⓪,ptr:= constAddr + constOfs;⓪*END;⓪*len:= LENGTH (ptr^);⓪*IF len > l2 THEN⓪,len:= l2;⓪*ELSE⓪,l2:= len⓪*END;⓪*IF len = 0 THEN len:= 1 END;⓪*extractConst (expr, 0, len);⓪*item:= SSTyp;⓪*exprSize:= l2⓪(END⓪&END⓪$END⓪"END adaptStringToSS;⓪ ⓪ PROCEDURE SetSSLength (VAR expr: ExprDesc);⓪"BEGIN⓪$IF (ItemNo (expr.item) = 27) THEN⓪&(*$? Safety: assert (expr.item = SSTyp);*)⓪&SetTypeLength (expr.item, Size (expr))⓪$END⓪"END SetSSLength;⓪ ⓪ PROCEDURE ResetSSLength (VAR expr: ExprDesc);⓪"BEGIN⓪$IF (expr.item = SSTyp) THEN⓪&SetTypeLength (expr.item, 0)⓪$END⓪"END ResetSSLength;⓪ ⓪ ⓪ PROCEDURE compatTT (left, right: PtrItem): BOOLEAN;⓪"VAR resType: PtrItem;⓪"BEGIN⓪$RETURN ExprComp (resType, left, right)⓪"END compatTT;⓪ ⓪ PROCEDURE checkCompat (VAR left, right: ExprDesc; VAR resType: PtrItem;⓪8errNo: INTEGER);⓪"(*⓪#* ZZ-Types werden angepaßt, wenn Subrange, wird daraus Basetype gemacht.⓪#*)⓪"VAR no: CARDINAL;⓪"BEGIN⓪$adaptSSToChar (left);⓪$adaptSSToChar (right);⓪$adaptZZ (left, HostType (right.item), TRUE);⓪$adaptZZ (right, HostType (left.item), TRUE);⓪$SetSSLength (left);⓪$SetSSLength (right);⓪$IF NOT ExprComp (resType, left.item, right.item) THEN SyntaxError (errNo) END;⓪$ResetSSLength (left);⓪$ResetSSLength (right);⓪$no:= ItemNo (resType);⓪$IF (no # 6) & (no # 19) & (no # 44) THEN⓪&right.item:= resType;⓪&left.item:= resType;⓪$END⓪"END checkCompat;⓪ ⓪ PROCEDURE varCompat (source, dest: PtrItem): BOOLEAN;⓪"BEGIN⓪$RETURN VarComp (dest, source)⓪"END varCompat;⓪ ⓪ FORWARD fitValue (VAR source: ExprDesc; conv: ConvDesc);⓪ ⓪ PROCEDURE checkVarCompat (VAR source: ExprDesc; dest: PtrItem; errNo: INTEGER);⓪"VAR range: ConvDesc;⓪"BEGIN⓪$IF NOT varCompat (source.item, dest) THEN SyntaxError (errNo) END;⓪$IF ItemNo (source.item) = 44 THEN⓪&(* 8 Byte-Proc-Parm wird an VAR-Parm übergeben.⓪'* -> Da es ein Parm ist, ist die Var auf jeden Fall schon init.,⓪'* so daß nun einfach ein NIL-Check auf das upper Long gemacht wird: *)⓪&getConversionDesc (source.item, dest, range);⓪&fitValue (source, range);⓪$END⓪"END checkVarCompat;⓪ ⓪ PROCEDURE asnCompat (VAR source: ExprDesc; dest: PtrItem;⓪5VAR range: ConvDesc): BOOLEAN;⓪"(*⓪#* Für range-Checks werden in 'range' die notwendigen Informationen⓪#* geliefert⓪#*)⓪"VAR (*$Reg*)n: INTEGER;⓪"BEGIN⓪$SetSSLength (source);⓪$n:= AsnComp (dest, source.item);⓪$IF n # 0 THEN⓪&adaptSSToChar (source);⓪&adaptZZ (source, dest, TRUE);⓪&n:= AsnComp (dest, source.item);⓪&IF n > 0 THEN SyntaxError (n) END⓪$END;⓪$ResetSSLength (source);⓪$IF n = 0 THEN getConversionDesc (source.item, dest, range) END;⓪$RETURN n = 0⓪"END asnCompat;⓪ ⓪ PROCEDURE checkAsnCompat (VAR source: ExprDesc; dest: PtrItem;⓪:VAR range: ConvDesc; errNo: INTEGER);⓪"BEGIN⓪$IF NOT asnCompat (source, dest, range) THEN⓪&SyntaxError (errNo)⓪$END;⓪"END checkAsnCompat;⓪ ⓪ PROCEDURE checkValCompat (VAR source: ExprDesc; dest: PtrItem;⓪:VAR range: ConvDesc; errNo: INTEGER);⓪"(* Value an Parameter - Joker auch zulassen *)⓪"BEGIN⓪$IF NOT asnCompat (source, dest, range) THEN⓪&IF isJoker (dest) THEN⓪(IF source.item = ZZTyp THEN⓪*(*$? Safety: assert (source.kind = constant);*)⓪*IF (LONG (sizeZZ (source.exprConst.zz)) > TypeLength (dest)) THEN⓪,SyntaxError (rConRg) (* const zu groß f. zuweisung *)⓪*END;⓪*range:= alwaysFitting (dest);⓪*source.item:= dest⓪(ELSE⓪*IF Size (source) > TypeLength (dest) THEN⓪,SyntaxError (rParTy) (* nicht zuweisungskompat *)⓪*END;⓪*getConversionDesc (source.item,⓪,sizedItem (SHORT (TypeLength (dest)), signedType (source.item)), range)⓪(END;⓪&ELSE⓪(SyntaxError (errNo)⓪&END⓪$END⓪"END checkValCompat;⓪ ⓪ ⓪ PROCEDURE swapOp (VAR op: Operator);⓪"(* wird aufgerufen, wenn rechter/linker Op vertauscht werden *)⓪"(* nicht geeignet, um den Vergleich zu invertieren (NOT)! *)⓪"BEGIN⓪$CASE op OF⓪$| le: op:= ge⓪$| ge: op:= le⓪$| gt: op:= lt⓪$| lt: op:= gt⓪$| eq, ne: (* ok *)⓪$END⓪"END swapOp;⓪ ⓪ PROCEDURE prepareFPUop (VAR source, dest: ExprDesc; VAR op: Operator;⓪8VAR isrel: BOOLEAN);⓪"BEGIN⓪$isrel:= op IN OpSet {eq, ne, le, ge, lt, gt};⓪$(*⓪%* wenn source schon im Reg steht, dann ggf. operanden tauschen⓪%*)⓪$IF (source.kind = register)⓪$& (op IN OpSet {mul, add, eq, ne, le, ge, lt, gt}) THEN⓪&swapExpr (source, dest);⓪&IF isrel THEN swapOp (op) END⓪$END⓪"END prepareFPUop;⓪ ⓪ ⓪ PROCEDURE checkStack (size: LONGCARD);⓪"VAR r: RegType; a7: ExprDesc;⓪"BEGIN⓪$IF stackCheckActive () & (size > StackReserve DIV 4L) THEN⓪&INC (size, StackReserve);⓪&r:= allocAddrRegIfAllowed (dataRegs + addrRegs);⓪&IF (r >= A0) & (size <= 32767) THEN⓪(genLEArel (SHORT (size), A3, r)⓪&ELSE⓪(genMOVErr (A3, r, 4);⓪(incReg (r, toZZ (size, FALSE), 4);⓪&END;⓪&initRegExpr (a7, 4, A7);⓪&genar (CMP, a7, r);⓪&gen (Bcc + mapCC (cc, FALSE, TRUE) + 4);⓪&genTrap (StackOverflowTrap);⓪&deallocReg (r)⓪$END⓪"END checkStack;⓪ ⓪ PROCEDURE checkOverflow (type: PtrItem);⓪"BEGIN⓪$IF overflowCheckActive () THEN⓪&IF signedType (type) THEN⓪(gen (TRAPV);⓪&ELSE (* 68020: einfach TRAPCS *)⓪(gen (Bcc + mapCC (cc, FALSE, FALSE) + 4);⓪(genTrap (OverflowTrap);⓪&END⓪$END⓪"END checkOverflow;⓪ ⓪ PROCEDURE checkMulOverflow (VAR expr: ExprDesc);⓪"(* erzeugt bei unsigned:⓪#* SWAP Dn⓪#* TST.W Dn⓪#* BEQ ok⓪#* TRAP #6⓪#* DC overflow⓪#* ok SWAP Dn⓪#*⓪#* bei signed:⓪#* MOVE.W Dn,An⓪#* CMPA.L Dn,An⓪#* BEQ ok⓪#* TRAP #6⓪#* DC overflow⓪#* ok⓪#*)⓪"VAR help: ExprDesc; t: PtrItem;⓪"BEGIN⓪$IF overflowCheckActive () THEN⓪&IF signedType (expr.item) THEN⓪(copyRegExt (expr, help, dataRegs + addrRegs, 4);⓪(t:= expr.item; expr.item:= CardPtr; (* um CMP.L zu erzeugen *)⓪(genar (CMP, expr, help.exprReg);⓪(expr.item:= t;⓪(deallocRegs (help);⓪(gen (Bcc + mapCC (eq, FALSE, FALSE) + 4);⓪(genTrap (OverflowTrap)⓪&ELSE⓪(genr (SWAP, expr.exprReg);⓪(gena (TST, expr, 2);⓪(gen (Bcc + mapCC (eq, FALSE, FALSE) + 4);⓪(genTrap (OverflowTrap);⓪(genr (SWAP, expr.exprReg);⓪&END;⓪$END⓪"END checkMulOverflow;⓪ ⓪ ⓪ (*⓪ PROCEDURE pwr2 (n: INTEGER): LONGINT;⓪"VAR res: LONGINT;⓪"BEGIN⓪$ASSEMBLER⓪(; prüfe, ob Konst. eine 2-Potenz ist⓪(MOVEQ #1,D1⓪(MOVE n(A6),D0⓪(BEQ ende⓪(BMI neg⓪(ASL D0,D1⓪&ende⓪(MOVE.L D1,res(A6)⓪$END;⓪$RETURN res⓪"END pwr2;⓪ *)⓪ ⓪ PROCEDURE log2 (x: ZZ; VAR n: CARDINAL): BOOLEAN;⓪"VAR res: CARDINAL;⓪"BEGIN⓪$ASSEMBLER⓪(; prüfe, ob Konst. eine 2-Potenz ist⓪(MOVE.L x.v(A6),D1⓪(TST.W x.over(A6)⓪(BEQ nov⓪(TST.L D1⓪(BNE false⓪(MOVEQ #32,D0 ; dieser Wert ist gar nicht möglich (max. 2^32-1) :-)⓪(BRA ende⓪&nov⓪(TST.L D1⓪(BEQ false⓪(BPL p⓪(NEG.L D1⓪&p MOVEQ #-1,D0⓪&l ADDQ #1,D0⓪(LSR.L #1,D1⓪(BCC l⓪(TST.L D1⓪(BEQ ende⓪&false⓪(MOVEQ #33,D0⓪&ende⓪(MOVE D0,res(A6)⓪$END;⓪$n:= res;⓪$RETURN n <= 31⓪"END log2;⓪ ⓪ ⓪ ⓪ (*$D-*)⓪ ⓪ MODULE WithDisplays;⓪ ⓪"IMPORT⓪$Safety, BadId, SyntaxError, rTmpRs,⓪$ExprKind, deallocRegs, genPushReg, pushReg, genPopReg, assert, D0, A7, F0,⓪$loadAddressTo, exprStack, ptrVar, PtrItem, ExprDesc, exprSp, ExprSP,⓪$RegType, A7Offset, allocRegVar, PopExpr, PushExpr, RegSet, freeRegs,⓪$deallocReg, pushNonTemp, popNonTemp, freeVarRegs, getThisReg,⓪$bong, deallocRegVar, varRegs;⓪ ⓪"EXPORT⓪$reloadDisplays, spillDisplays, closeDisplay, openDisplay,⓪$procDepth, getDisplay, loadDisplay, freeDisplay;⓪ ⓪"CONST WithDisplays = 20;⓪ ⓪"TYPE DisplayDesc = RECORD expr: ExprSP; oldReg: RegType END;⓪ ⓪"VAR displayStack: ARRAY [1..WithDisplays] OF DisplayDesc;⓪&spillSP, displaySP: [0..WithDisplays];⓪'(*⓪(* spillSP zeigt auf Grenze, oberhalb der alle Displays auf dem⓪(* A7-Stack stehen, darunter stehen sie in einem Reg⓪(*)⓪ ⓪ ⓪"PROCEDURE spill;⓪$BEGIN⓪&INC (spillSP);⓪&IF spillSP > displaySP THEN⓪(BadId:= 'Register-Variable (für POINTER) freimachen!';⓪(SyntaxError (rTmpRs)⓪((*!!! das spilling kann nur Reg-Vars für WITH freimachen -- wenn jedoch⓪)* alle addr-regs in expliziten reg-vars abgelegt sind, bekommen⓪)* wir kein Reg frei. -> spilling auf alle Exprs ausweiten. dann⓪)* dies auch anwenden, wenn eine lokale proc aufgerufen wird, die⓪)* auf welche von äußeren reg-vars zugreift⓪)*)⓪&END;⓪&WITH exprStack [displayStack [spillSP].expr].expr DO⓪(IF kind = register THEN⓪*(* wir haben einen WITH-Pointer im Reg gefunden -> auf A7 laden *)⓪*(*$? Safety:⓪,assert (exprReg IN varRegs);⓪,assert (displayStack [spillSP].oldReg = F0);⓪**)⓪*displayStack [spillSP].oldReg:= exprReg;⓪*deallocRegVar (exprReg);⓪*pushNonTemp (exprReg, TRUE);⓪*kind:= stack;⓪*stackReg:= A7;⓪*up:= TRUE;⓪*restoreAfterUse:= 0;⓪*stackedSize:= 4;⓪*stackPtr:= A7Offset;⓪(END;⓪((*$? Safety: assert (kind = stack)*)⓪&END⓪$END spill;⓪ ⓪"PROCEDURE getDisplayReg (VAR r: RegType);⓪$VAR saved: RegSet;⓪$BEGIN⓪&(*⓪'* Wir brauchen ein Addr-Reg.⓪'* Dazu wird jede gerade freie Reg verwendet, also auch eins, das⓪'* für eine Var reserviert ist, aber z.Zt. nicht benutzt wird.⓪'*)⓪&saved:= freeVarRegs;⓪&freeVarRegs:= RegSet {D0..A7};⓪&IF allocRegVar (ptrVar, r) THEN⓪((*$? Safety: assert (displayStack [spillSP].expr = -1);*)⓪((* Reg war vorher nicht belegt -> auf A7 retten *)⓪(pushNonTemp (r, TRUE)⓪&ELSE⓪(REPEAT⓪*spill;⓪(UNTIL allocRegVar (ptrVar, r)⓪&END;⓪&freeVarRegs:= saved⓪$END getDisplayReg;⓪ ⓪"PROCEDURE reloadDisplay (VAR d: DisplayDesc);⓪$BEGIN⓪&IF NOT getThisReg (d.oldReg) THEN⓪(bong⓪&END;⓪&(*$? Safety: assert (d.oldReg # F0); *)⓪&WITH exprStack [d.expr].expr DO⓪((*$? Safety: assert ((kind = stack) & (stackPtr = A7Offset));*)⓪(popNonTemp (d.oldReg);⓪(kind:= register;⓪(exprReg:= d.oldReg;⓪(d.oldReg:= F0;⓪&END⓪$END reloadDisplay;⓪ ⓪"PROCEDURE spillDisplays (VAR marker: CARDINAL);⓪$BEGIN⓪&marker:= spillSP;⓪&WHILE spillSP # displaySP DO spill END;⓪$END spillDisplays;⓪ ⓪"PROCEDURE reloadDisplays (marker: CARDINAL);⓪$BEGIN⓪&WHILE (spillSP # marker) DO⓪(reloadDisplay (displayStack [spillSP]);⓪(DEC (spillSP)⓪&END⓪$END reloadDisplays;⓪ ⓪"PROCEDURE loadDisplay (VAR expr: ExprDesc);⓪$VAR r: RegType; regs: RegSet;⓪$BEGIN⓪&getDisplayReg (r);⓪&INCL (freeRegs, r);⓪®s:= RegSet {};⓪&INCL (regs, r);⓪&loadAddressTo (expr, regs);⓪&EXCL (freeRegs, r);⓪&(*$? Safety: assert (expr.kind = register);*)⓪&PushExpr (expr);⓪&INC (displaySP);⓪&displayStack [displaySP].expr:= exprSp;⓪&displayStack [displaySP].oldReg:= F0 (* um ggf. Fehler auszulösen *)⓪$END loadDisplay;⓪ ⓪"PROCEDURE freeDisplay;⓪$VAR expr: ExprDesc;⓪$BEGIN⓪&(*$? Safety: assert (displayStack [displaySP].expr = exprSp);*)⓪&DEC (displaySP);⓪&IF spillSP > displaySP THEN DEC (spillSP) END;⓪&PopExpr (expr);⓪&(*$? Safety: assert (expr.kind = register);*)⓪&deallocRegVar (expr.exprReg);⓪&(*!!! Diese Annahme, daß 'expr' ein Reg ist, kann nicht mehr gemacht⓪'* werden, sobald auch bei voller Belegung aller Addr-Reg-Vars⓪'* WITH noch mögl. ist: Dann kann es entweder sein, daß auch der⓪'* innerste With-Ptr auf dem Stack steht, so daß das deallocRegVar⓪'* nicht getan werden darf, oder eine RegVar wurde ins memory⓪'* gelegt, so daß dann dies wieder zurcükgeladen werden darf. Dann⓪'* dürfte dazu wahrscheinlich hier erstmal die Freigabe erfolgen.⓪'*)⓪&IF displayStack [spillSP].expr = -1 THEN⓪((* -> kein gespillter WITH-Ptr mehr -> Reg. normal wiederherstellen *)⓪(popNonTemp (expr.exprReg);⓪&ELSE⓪((* da haben wir ja noch einen, der auf dem Stack liegt⓪)* -> runter mit ihm *)⓪(reloadDisplay (displayStack [spillSP]);⓪(DEC (spillSP);⓪&END⓪$END freeDisplay;⓪ ⓪"PROCEDURE procDepth (tiefe: CARDINAL): CARDINAL;⓪$(*⓪%* Bestimmt die A6-Tiefe, denn in WITH-Scopes ist Tiefe⓪%* zu groß ist, weil WITH-Pointer nicht mehr als neues⓪%* A6-Scope angelegt werden⓪%*)⓪$VAR n: CARDINAL;⓪$BEGIN⓪&n:= displaySP;⓪&WHILE tiefe > 0 DO⓪(IF displayStack [n].expr = -1 THEN⓪*RETURN tiefe⓪(END;⓪(DEC (tiefe);⓪(DEC (n)⓪&END;⓪&RETURN 0⓪$END procDepth;⓪ ⓪"PROCEDURE getDisplay (tiefe: CARDINAL; VAR expr: ExprDesc);⓪$BEGIN⓪&expr:= exprStack [displayStack [displaySP - tiefe].expr].expr⓪$END getDisplay;⓪ ⓪"PROCEDURE openDisplay;⓪$BEGIN⓪&INC (displaySP);⓪&INC (spillSP);⓪&(*$? Safety: assert (spillSP = displaySP);*)⓪&displayStack [displaySP].expr:= -1;⓪$END openDisplay;⓪ ⓪"PROCEDURE closeDisplay;⓪$BEGIN⓪&(*$? Safety: assert (displayStack [displaySP].expr = -1);*)⓪&DEC (displaySP);⓪&DEC (spillSP);⓪&(*$? Safety: assert (spillSP = displaySP);*)⓪$END closeDisplay;⓪ ⓪"BEGIN⓪$spillSP:= 0;⓪$displaySP:= 0;⓪$openDisplay;⓪"END WithDisplays;⓪ ⓪ (*$D-*)⓪ ⓪ ⓪ MODULE RuntimeCalls;⓪ ⓪ (*⓪!* in diesem Modul sind alle Funktionen zusammengefaßt, die Runtime-⓪!* Aufrufe vorbereiten und dazu Werte in bestimte Register laden.⓪!*⓪!* Regeln:⓪!*⓪!* Werden mehrere ExprDesc in Regs geladen, muß beachtet werden, daß⓪!* es zu keinem Deadlock kommt. Z.B. kann es dann passieren, wenn nachein-⓪!* ander ein Adr-Reg nach A0 und ein Data-Reg nach D0 geladen werden sollen;⓪!* ist dann z.B. das A0 von der 2. Expr durch (A0) oder ähnliches belegt,⓪!* geht's schief.⓪!* Deshalb müssen mehrere Regs immer in 2 Schritten beladen werden:⓪!* Zuerst werden alle Exprs lediglich in beliebige (anyReg, anyDataReg, usw)⓪!* Regs geladen, erst danach jedes zu seinem Ziel-Reg - ggf. ist dazu⓪!* dann 'loadRegs' zu benutzen.⓪!*)⓪ ⓪"IMPORT coding, CallRuntimeProc, deallocRegs, loadReg, RegSet, RegType,⓪)D0, D1, D2, A0, A1, A2, A3, A7, ExprDesc, ZZ, exclRegs, spillRegs,⓪)Safety, allocReg, deallocReg, constToReg, swapExpr, ExprKind, anyReg,⓪)anyCPUReg, tempRegs, assert, loadAddress, COPYW, COPYL, swapRegs,⓪)swapOp, Operator, sizedItem, Size, LENW, LENL, CAPI, loadRegExt,⓪)PtrItem, PS3B, PS3W, PS3L, LADD, LSUB, LMUL, LDIV, SIRG, CMP8,⓪)dataRegs, incReg, freeRegs, SMEM, SXOR, SINCL, SEXCL, toZZ,⓪)initPseudoRegExpr, F0, F2, F7, floatRegs, bong, fpu, FPUType,⓪)FADD, FSUB, FDIV, FMUL, FNEG, LNEG, RSHT, RXPD, FNUL, FGET, FPUT,⓪)FOPS, FOPD, FMVS, FMVD, rNImpY, SizeOfLongReal, Freg, Fea,⓪)TypeLength, SizeOfShortReal, SyntaxError, isReal, OpSet,⓪)BoolPtr, FCMP, FBEQ, FBNE, FBLE, FBGE, FBGT, FBLT, getFPUop,⓪)FCPN, FCPS, FCPD, LREQ, LRNE, LRLE, LRGE, LRLT, LRGT, FABS,⓪)changeStackToIndir, loadDestAddress, updateStack, loadExprAddress,⓪)anyDataReg, loadAddressTo, pushReg, A7Offset, genar, CMP,⓪)initStackExpr, genMOVErr, RealPtr, SRealPtr, CardPtr, IntPtr,⓪)rOpTyp, MemModes, roundUp, posZZ, cmpZZ, negZZ, getBounds, RefType,⓪)LC2S, LI2S, LC2D, LI2D, S2LC, S2LI, D2LC, D2LI, prepareFPUop,⓪)SADD, SSUB, SMUL, SDIV, SRLE, SRGE, SRLT, SRGT, LABS, SABS, SNEG,⓪)int8ZZ, FP7S, FP7D, FP3S, FP3D, FG7S, FG7D, FG3S, FG3D,⓪)spillRegByMove, genPushReg, genPopReg, PushExpr, PopExpr,⓪)makeInd0An, initRegExpr, SCardPtr, ItemNo, genMOVEar, changeToStack,⓪)IEEERuntimeCall, isStringVar, updateStackOffsets, reloadPtr,⓪)Test, (*$? Test: showExpr, showExprStack, showRegs, *)⓪)exprUsesRegs, FP7M, FG7M, loadRealReg, changeToStackTo, addrRegs;⓪ ⓪"EXPORT runtimeConstMul, runtimeVarMul, runtimeConstCopy, runtimeCap,⓪)runtimeCopyOnStack, runtimeElemSet, runtimeSetOp, runtimeLength,⓪)runtimeMoveRealRegToVar, runtimeRealOp, runtimeRealMono,⓪)runtimePushRealReg, runtimeCopyOpenArray, runtimeRangeSet,⓪)runtimeCmp8Byte, runtimeMoveRealRegs, runtimeLoadRealToReg,⓪)runtimeShiftRotate;⓪ ⓪ ⓪"PROCEDURE callRuntime (n: CARDINAL);⓪$BEGIN⓪&IF coding () THEN CallRuntimeProc (n) END⓪$END callRuntime;⓪ ⓪"PROCEDURE loadRegs (VAR x1: ExprDesc; r1: RegType;⓪6VAR x2: ExprDesc; r2: RegType);⓪$(*⓪%* Diese Funktion ist aufzurufen, nachdem beide exprs in Regs⓪%* geladen wurden (z.B. loadReg (expr, anyReg)).⓪%* Hier wird dann dafür gesorgt, daß die richtigen Regs belegt werden.⓪%*)⓪$VAR b1, b2: BOOLEAN; regs: RegSet;⓪$BEGIN⓪®s:= RegSet {};⓪&(*$? Safety: assert ((x1.kind = register) & (x2.kind = register)); *)⓪&b1:= (x1.exprReg = r2);⓪&b2:= (x2.exprReg = r1);⓪&IF b1 THEN⓪(IF b2 THEN⓪*(* wenn beide Ops schon in den Regs stehen, aber verkehrt herum,⓪+* dann beide mit EXG-Instr. tauschen *)⓪*swapRegs (x1, x2)⓪(ELSE⓪*(* x1 steht im falschen Reg *)⓪*INCL (regs, r1);⓪*loadReg (x1, regs)⓪(END⓪&ELSIF b2 THEN⓪((* x2 steht im falschen Reg *)⓪(INCL (regs, r2);⓪(loadReg (x2, regs)⓪&END;⓪&IF x1.exprReg # r1 THEN⓪(regs:= RegSet {};⓪(INCL (regs, r1);⓪(loadReg (x1, regs)⓪&END;⓪&IF x2.exprReg # r2 THEN⓪(regs:= RegSet {};⓪(INCL (regs, r2);⓪(loadReg (x2, regs)⓪&END;⓪$END loadRegs;⓪"⓪"PROCEDURE prepareUno (REF expr: ExprDesc; usedRegs: RegSet);⓪$BEGIN⓪&exclRegs (expr, usedRegs);⓪&spillRegs (usedRegs)⓪$END prepareUno;⓪"⓪"PROCEDURE prepareDuo (REF exp1, exp2: ExprDesc; usedRegs: RegSet);⓪$BEGIN⓪&exclRegs (exp1, usedRegs);⓪&exclRegs (exp2, usedRegs);⓪&spillRegs (usedRegs)⓪$END prepareDuo;⓪"⓪"PROCEDURE runtimeShiftRotate (opcode: CARDINAL; VAR set, count: ExprDesc;⓪@lo, hi: ZZ);⓪$BEGIN⓪&prepareDuo (set, count, RegSet {D0,D1,D2});⓪&loadReg (set, anyCPUReg);⓪&loadReg (count, anyCPUReg);⓪&loadRegs (set, D0, count, D1);⓪&constToReg (hi, 2, D2);⓪&callRuntime (opcode)⓪$END runtimeShiftRotate;⓪$⓪"PROCEDURE runtimeMoveRealRegs (opcode: CARDINAL; pop: BOOLEAN);⓪$(* FMOVEM f. ST-FPU gen. *)⓪$BEGIN⓪&IEEERuntimeCall;⓪&(*$? Safety: assert ((D0 IN freeRegs) & (A1 IN freeRegs) & (A2 IN freeRegs)); *)⓪&(*>>> hier wird davon ausgegangen, daß die Register D0/A1/A2 frei sind!⓪'* wenn Parm-Übergabe über temp. Regs geht, ist das nicht mehr der Fall.*)⓪&constToReg (toZZ (LONG (opcode), FALSE), 2, D0);⓪&IF pop THEN⓪(callRuntime (FG7M)⓪&ELSE⓪(callRuntime (FP7M)⓪&END⓪$END runtimeMoveRealRegs;⓪"⓪"PROCEDURE runtimeLoadRealToReg (VAR expr: ExprDesc; niceRegs: RegSet);⓪$⓪$VAR old: ExprDesc; long, ea: BOOLEAN; n: CARDINAL; t: PtrItem;⓪(r: RegType; regs: RegSet;⓪ ⓪$PROCEDURE loadnr;⓪&BEGIN⓪(constToReg (toZZ (LONG (n + Freg (r)), FALSE), 2, D0);⓪&END loadnr;⓪$⓪$BEGIN⓪&(*$? Safety: assert (fpu () = externalFPU);*)⓪&n:= FGET + Fea (expr, ea);⓪&IEEERuntimeCall;⓪&IF ea THEN⓪(long:= Size (expr) > LONG (SizeOfShortReal);⓪(IF long THEN⓪*regs:= RegSet {A0,D0,A2};⓪(ELSE⓪*regs:= RegSet {D0,D1,A2};⓪(END;⓪&ELSE⓪(regs:= RegSet {D0,A2};⓪&END;⓪&prepareUno (expr, regs);⓪&r:= allocReg (niceRegs);⓪&IF ea THEN⓪(t:= expr.item;⓪(IF long THEN⓪*loadExprAddress (expr, old);⓪*loadReg (expr, RegSet {A0});⓪*loadnr;⓪*callRuntime (FOPD);⓪*updateStack (old)⓪(ELSE⓪*loadReg (expr, RegSet{D1});⓪*loadnr;⓪*callRuntime (FOPS)⓪(END;⓪(deallocReg (expr.exprReg);⓪(expr.item:= t;⓪&ELSE⓪((*$? Safety: assert (expr.kind = register); *)⓪((*$? Safety: assert (expr.exprReg # r); *)⓪(deallocRegs (expr);⓪(loadnr;⓪(callRuntime (FNUL)⓪&END;⓪&expr.kind:= register;⓪&expr.exprReg:= r;⓪$END runtimeLoadRealToReg;⓪"⓪"PROCEDURE runtimePushRealReg (VAR source: ExprDesc; sp: RegType);⓪$(*⓪%* Reg in 'expr' auf Stack retten,⓪%* ohne irgend ein Register zu spillen (höchstens Umladen in ein anderes).⓪%*)⓪$⓪$VAR r: RegType;⓪$⓪$PROCEDURE save (reg: RegType; long: BOOLEAN; VAR regSaved: BOOLEAN);⓪&VAR regs: RegSet;⓪&BEGIN⓪(regSaved:= FALSE;⓪(IF NOT (reg IN freeRegs) THEN⓪*regs:= RegSet{reg};⓪*IF NOT spillRegByMove (regs) THEN⓪,(* D2 ist belegt - wir retten es auf den anderen Stack und holen es⓪-* danach zurück *)⓪,genPushReg (reg, long, r);⓪,regSaved:= TRUE⓪*ELSE⓪,EXCL (freeRegs, reg); (* wg. nächstem 'spillRegByMove' belegen *)⓪*END⓪(END;⓪&END save;⓪$⓪$VAR a2s, d2s, ea: BOOLEAN; n: CARDINAL; v: ZZ; oldFree: RegSet;⓪$BEGIN⓪&(*$? Safety:⓪(assert (fpu () = externalFPU);⓪(assert ((sp=A3) OR (sp=A7));⓪(assert (source.kind = register);⓪&*)⓪&IEEERuntimeCall;⓪&n:= FPUT + Freg (source.exprReg) + $4400;⓪&IF source.item = RealPtr THEN INC (n, $1000) END;⓪&v:= toZZ (LONG (n), FALSE);⓪&⓪&oldFree:= freeRegs;⓪&IF sp = A7 THEN r:= A3 ELSE r:= A7 END;⓪&save (D2, FALSE, d2s);⓪&save (A2, TRUE, a2s);⓪&⓪&constToReg (v, 2, D2);⓪&callRuntime (FP7S + ORD (source.item = RealPtr) + 2*ORD(sp=A3));⓪&updateStackOffsets (sp, sp=A3, Size (source));⓪&⓪&IF a2s THEN⓪((* A2 zurückladen *)⓪(genPopReg (A2, TRUE, r)⓪&END;⓪&IF d2s THEN⓪((* D2 zurückladen *)⓪(genPopReg (D2, FALSE, r)⓪&END;⓪&freeRegs:= oldFree⓪$END runtimePushRealReg;⓪ ⓪"PROCEDURE runtimeMoveRealRegToVar (VAR source: ExprDesc; dest: ExprDesc);⓪$VAR ea: BOOLEAN; regs: RegSet; t: PtrItem; n: CARDINAL;⓪$BEGIN⓪&(*$? Safety:⓪(assert (fpu () = externalFPU);⓪(assert ((dest.kind # register) & (source.kind = register));⓪&*)⓪&prepareUno (dest, RegSet {A0,D0,A2}); (* source ist immer float-Reg *)⓪&t:= dest.item;⓪®s:= freeRegs;⓪&n:= FPUT + Fea (dest, ea) + Freg (source.exprReg); (* danach ändert sich dest.imte! *)⓪&loadDestAddress (dest, Size (dest));⓪&loadReg (dest, RegSet {A0});⓪&constToReg (toZZ (LONG (n), FALSE), 2, D0);⓪&freeRegs:= regs;⓪&IEEERuntimeCall;⓪&IF TypeLength (t) = LONG (SizeOfShortReal) THEN⓪(callRuntime (FMVS)⓪&ELSE⓪(callRuntime (FMVD)⓪&END;⓪$END runtimeMoveRealRegToVar;⓪"⓪"PROCEDURE runtimeRealMono (VAR expr: ExprDesc; op: CARDINAL);⓪$(*⓪%* 'op':⓪%* 2: -()⓪%* 3: ABS()⓪%* LC2S..D2LI: FLOAT/TRUNC⓪%*)⓪$VAR n: CARDINAL;⓪(r: RegType;⓪(regs: RegSet;⓪(destType, t: PtrItem;⓪(dlong, slong, ea: BOOLEAN;⓪(old, pseudoReg: ExprDesc;⓪$⓪$PROCEDURE loadnr;⓪&BEGIN⓪(constToReg (toZZ (LONG (n + Freg (r)), FALSE), 2, D0)⓪&END loadnr;⓪$⓪$BEGIN⓪&slong:= expr.item = RealPtr;⓪&destType:= expr.item;⓪&IF (fpu () = softReal) OR (op >= LC2S) (* Bei FLOAT/TRUNC immer *) THEN⓪(⓪(IF fpu () = softReal THEN⓪*IF slong & (op # 0) THEN (* -> bei sr:= lr kommt kein extra Reg-Load *)⓪,loadRealReg (expr, floatRegs);⓪*END;⓪(END;⓪(⓪(regs:= RegSet {};⓪(IF op = 0 THEN⓪*(* SHORT () *)⓪*(*$? Safety: assert (slong);*)⓪*destType:= SRealPtr;⓪*regs:= RegSet {A0,D0..D2,F2};⓪*n:= RSHT⓪(ELSIF op = 1 THEN⓪*(* LONG () *)⓪*(*$? Safety: assert (NOT slong);*)⓪*destType:= RealPtr;⓪*regs:= RegSet {A0,D0,D1,F2};⓪*n:= RXPD⓪(ELSIF op = 2 THEN⓪*(* Negate *)⓪*IF slong THEN n:= LNEG ELSE n:= SNEG END⓪(ELSIF op = 3 THEN⓪*(* ABS () *)⓪*IF slong THEN n:= LABS ELSE n:= SABS END⓪(ELSIF (op >= LC2S) & (op <= D2LI) THEN⓪*(* LC2S, LI2S, LC2D, LI2D, S2LC, S2LI, D2LC, D2LI *)⓪*regs:= RegSet {D0..D1,F2};⓪*IF op = D2LC THEN INCL (regs, D2) END;⓪*n:= op;⓪*IF op >= S2LC THEN⓪,IF (op - S2LC) MOD 2 = 0 THEN⓪.destType:= CardPtr⓪,ELSE⓪.destType:= IntPtr⓪,END⓪*ELSE⓪,IF op <= LI2S THEN⓪.destType:= SRealPtr⓪,ELSE⓪.destType:= RealPtr⓪,END⓪*END⓪(ELSE⓪*bong ()⓪(END;⓪(⓪(dlong:= destType = RealPtr;⓪(⓪(IF slong OR dlong THEN⓪*INCL (regs, A0)⓪(END;⓪(IF NOT slong OR NOT dlong THEN⓪*INCL (regs, D0)⓪(END;⓪(prepareUno (expr, regs);⓪(⓪(IF (fpu () # softReal) & (expr.kind = register) THEN⓪*(* wenn Wert in echtem FP-Reg steht, muß er zum Zugriff⓪+* ins RAM (auf den Stack) geladen werden, weil die Routinen unten⓪+* (z.B. loadReg, loadRegExt) kein Reg-Transfer von Fn nach Dn⓪+* können. *)⓪*pushReg (expr, A7);⓪(END;⓪(⓪((* Eingabewert nach D0/(A0) laden *)⓪(IF slong THEN⓪*IF expr.kind # register THEN⓪,loadExprAddress (expr, old);⓪,loadReg (expr, RegSet {A0});⓪*ELSE⓪,initPseudoRegExpr (pseudoReg, expr.item, expr.exprReg, FALSE);⓪,loadExprAddress (pseudoReg, old); (* expr-Adr: A0 *)⓪,loadReg (pseudoReg, RegSet {A0});⓪,deallocReg (A0)⓪,(* FPn bleibt alloziert *)⓪*END;⓪(ELSE⓪*IF expr.item = SRealPtr THEN⓪,loadReg (expr, RegSet {D0})⓪*ELSE⓪,loadRegExt (expr, RegSet {D0}, 4, TRUE)⓪*END;⓪(END;⓪(⓪((* Rückgabewert vorbereiten *)⓪(IF dlong THEN⓪*IF slong THEN⓪,(* A0 ist bereits besetzt *)⓪*ELSE⓪,(* Auf dem Stack Platz f. LONGREAL reserv.⓪-* und A0 darauf zeigen lassen *)⓪,deallocRegs (expr);⓪,initStackExpr (expr, RealPtr, A3);⓪,expr.up:= FALSE;⓪,expr.stackedSize:= SizeOfLongReal;⓪,genMOVErr (A3, A0, 4);⓪,incReg (A3, toZZ (LONG(SizeOfLongReal), TRUE), 4);⓪*END⓪(ELSE⓪*IF slong THEN⓪,(* D0 für Erg. vorbereiten *)⓪,deallocRegs (expr); (* A0 freigeben *)⓪,expr.kind:= register;⓪,expr.exprReg:= allocReg (RegSet {D0})⓪*ELSE⓪,(* Erg. kommt wieder nach D0 *)⓪*END⓪(END;⓪(⓪(expr.item:= destType;⓪(⓪(callRuntime (n);⓪(⓪(IF slong THEN⓪*updateStack (old)⓪(END;⓪(⓪&ELSE⓪&⓪((*$? Safety: assert (fpu () = externalFPU); *)⓪(IF op = 2 THEN⓪*n:= FNEG;⓪(ELSE⓪*(*$? Safety: assert (op = 3); *)⓪*n:= FABS;⓪(END;⓪(INC (n, Fea (expr, ea));⓪(IF ea THEN⓪*IF slong THEN⓪,regs:= RegSet {A0,D0,A2};⓪*ELSE⓪,regs:= RegSet {D0,D1,A2};⓪*END;⓪*r:= allocReg (floatRegs);⓪(ELSE⓪*regs:= RegSet {D0,A2};⓪*r:= expr.exprReg;⓪(END;⓪(prepareUno (expr, regs);⓪(IEEERuntimeCall;⓪(IF ea THEN⓪*t:= expr.item;⓪*IF slong THEN⓪,loadExprAddress (expr, old);⓪,loadReg (expr, RegSet {A0});⓪,loadnr;⓪,callRuntime (FOPD);⓪,updateStack (old)⓪*ELSE⓪,loadReg (expr, RegSet{D1});⓪,loadnr;⓪,callRuntime (FOPS)⓪*END;⓪*deallocReg (expr.exprReg);⓪*expr.item:= t;⓪*expr.exprReg:= r;⓪(ELSE⓪*loadnr;⓪*callRuntime (FNUL)⓪(END⓪&END;⓪$END runtimeRealMono;⓪ ⓪"PROCEDURE runtimeRealOp (op: Operator; VAR source, dest: ExprDesc);⓪$(*⓪%* für Compares, DIV & SUB gilt: 'source' ist der rechte Wert⓪%* 'source' ist generell eine beliebige Adr, 'dest' ist ein Register⓪%*)⓪$VAR m, n: CARDINAL;⓪(regs: RegSet;⓪(isrel, long, ea: BOOLEAN;⓪(old, pseudoReg: ExprDesc;⓪$⓪$PROCEDURE loadnm;⓪&BEGIN⓪(constToReg (toZZ (LONG (n), FALSE), 2, D0);⓪(IF isrel THEN⓪*constToReg (toZZ (LONG (m), FALSE), 2, D2)⓪(END⓪&END loadnm;⓪$⓪$BEGIN⓪&(* 'dest' kommt in ein Register, 'source' kann alles sein.⓪'* Overflow-Checks werden in den Routinen erkannt *)⓪&⓪&prepareFPUop (source, dest, op, isrel);⓪&long:= dest.item = RealPtr;⓪&⓪&IF fpu () = softReal THEN⓪&⓪(IF long THEN⓪*loadRealReg (dest, floatRegs);⓪*prepareDuo (dest, source, RegSet {A0..A2,D0..D2});⓪*⓪*CASE op OF⓪,add: n:= LADD|⓪,sub: n:= LSUB|⓪,mul: n:= LMUL|⓪,rdiv:n:= LDIV|⓪,eq: n:= LREQ|⓪,ne: n:= LRNE|⓪,le: n:= LRLE|⓪,ge: n:= LRGE|⓪,lt: n:= LRLT|⓪,gt: n:= LRGT|⓪*ELSE⓪,SyntaxError (rOpTyp)⓪*END;⓪*⓪*IF source.kind = register THEN⓪,deallocReg (source.exprReg);⓪,initPseudoRegExpr (source, source.item, source.exprReg, FALSE);⓪*END;⓪*⓪*loadExprAddress (source, old); (* source-Adr: A0 (rechter Wert) *)⓪*loadReg (source, RegSet {A0});⓪*⓪*initPseudoRegExpr (pseudoReg, dest.item, dest.exprReg, FALSE);⓪*loadAddressTo (pseudoReg, RegSet {A1}); (* dest-Adr: A1 (linker Wert) *)⓪*⓪(ELSE⓪*IF op IN OpSet {mul, rdiv} THEN⓪,regs:= RegSet {A0,D0..D2};⓪*ELSIF op IN OpSet {eq, ne} THEN⓪,⓪,(* direkten CMP.L gen. *)⓪,loadReg (dest, dataRegs);⓪,genar (CMP, source, dest.exprReg);⓪,deallocRegs (source);⓪,WITH dest DO⓪.deallocReg (exprReg);⓪.item:= BoolPtr;⓪.kind:= condFlags;⓪.fpuFlags:= FALSE;⓪.relOp:= op;⓪.signed:= FALSE;⓪.not:= FALSE⓪,END;⓪,RETURN⓪ ⓪*ELSE⓪,regs:= RegSet {D0..D2}⓪*END;⓪*prepareDuo (source, dest, regs);⓪*loadReg (source, anyCPUReg);⓪*loadReg (dest, anyCPUReg);⓪*loadRegs (source, D0, dest, D1);⓪*⓪*CASE op OF⓪,add: n:= SADD|⓪,sub: n:= SSUB|⓪,mul: n:= SMUL|⓪,rdiv:n:= SDIV|⓪,le: n:= SRLE|⓪,ge: n:= SRGE|⓪,lt: n:= SRLT|⓪,gt: n:= SRGT|⓪*ELSE⓪,SyntaxError (rOpTyp)⓪*END;⓪*⓪(END;⓪(⓪(callRuntime (n);⓪(⓪(IF long THEN⓪*deallocRegs (pseudoReg);⓪*updateStack (old)⓪(END;⓪(deallocRegs (source);⓪(⓪(IF isrel THEN⓪*WITH dest DO⓪,deallocReg (exprReg);⓪,item:= BoolPtr;⓪,kind:= register;⓪,exprReg:= allocReg (RegSet {D0});⓪,not:= FALSE⓪*END;⓪(END;⓪(⓪&ELSE⓪((*$? Safety: assert (fpu () = externalFPU);*)⓪(⓪((*⓪)* Achtung: hier wird 'runtimeLoadRealToReg' aufgerufen, wobei⓪)* bestimmte An/Dn-Regs benötigt werden!⓪)* Das heißt, daß diese Regs frei sein müssen, also nicht⓪)* von 'source' belegt sein dürfen.⓪)* Das wird hier sichergestellt, indem 'source' erst nochmal⓪)* auf den expr-Stack geladen wird, damit ggf. ein Spilling⓪)* möglich ist.⓪)*)⓪(PushExpr (source);⓪(loadRealReg (dest, floatRegs);⓪(PopExpr (source);⓪(reloadPtr (source);⓪(⓪((* Opcode nach D0 *)⓪(getFPUop (source, dest.exprReg, op, isrel, n, m, ea);⓪(regs:= RegSet {D0,A2};⓪(IEEERuntimeCall;⓪(IF ea THEN⓪*IF long THEN⓪,regs:= RegSet {A0,D0,A2}⓪*ELSE⓪,regs:= RegSet {D0,D1,A2}⓪*END;⓪(END;⓪(IF isrel THEN⓪*INCL (regs, D2)⓪(END;⓪(prepareDuo (source, dest, regs);⓪(IF ea THEN⓪*IF long THEN⓪,loadExprAddress (source, old);⓪,loadReg (source, RegSet {A0});⓪,loadnm;⓪,IF isrel THEN⓪.callRuntime (FCPD)⓪,ELSE⓪.callRuntime (FOPD)⓪,END;⓪,updateStack (old)⓪*ELSE⓪,loadReg (source, RegSet {D1});⓪,loadnm;⓪,IF isrel THEN⓪.callRuntime (FCPS)⓪,ELSE⓪.callRuntime (FOPS)⓪,END⓪*END;⓪(ELSE⓪*loadnm;⓪*IF isrel THEN⓪,callRuntime (FCPN)⓪*ELSE⓪,callRuntime (FNUL)⓪*END⓪(END;⓪(⓪(deallocRegs (source);⓪(⓪(IF isrel THEN⓪*WITH dest DO⓪,deallocReg (exprReg);⓪,item:= BoolPtr;⓪,kind:= condFlags;⓪,fpuFlags:= FALSE;⓪,relOp:= ne;⓪,signed:= FALSE;⓪,not:= FALSE⓪*END;⓪(END;⓪(⓪&END;⓪$END runtimeRealOp;⓪ ⓪"PROCEDURE runtimeCopyOpenArray (VAR expr: ExprDesc; n: CARDINAL);⓪$VAR usedRegs: RegSet;⓪$BEGIN⓪&usedRegs:= RegSet {A0,A1,A2,D1,D2};⓪&exclRegs (expr, usedRegs);⓪&spillRegs (usedRegs);⓪&loadAddressTo (expr, RegSet {A0});⓪&callRuntime (n);⓪$END runtimeCopyOpenArray;⓪"⓪"PROCEDURE runtimeCopyOnStack (VAR expr, addr, count: ExprDesc;⓪@instrSize: CARDINAL; toA7: BOOLEAN);⓪$VAR n: CARDINAL; usedRegs: RegSet;⓪$BEGIN⓪&CASE instrSize OF⓪(1: n:= PS3B|⓪(2: n:= PS3W|⓪(4: n:= PS3L⓪&END;⓪&IF toA7 THEN⓪(INC (n, 3)⓪&ELSE⓪(SyntaxError (rNImpY) (* A3-Routinen berücksichtigen A0 noch nicht *)⓪&END;⓪&usedRegs:= RegSet {A0,A1,A2,D1,D2};⓪&(*⓪'* Wenn Aufruf von "moveOpenArray", dann enthält eins der temp. Regs⓪'* den alten A7. Es kann nun vorkommen (bei mehrdim. Open Arrays by⓪'* Value), daß 'count' in D0, während das gerettete A7 in A2 liegt.⓪'* Nun käme ein sofortiger spillRegs-Aufruf damit nicht klar, weil⓪'* A2 nach D0 gemoved werden sollte, was aber nicht geht, da es⓪'* noch von 'count' benutzt wird. Daher wird's hier nun ggf. erst⓪'* umgeladen:⓪'*)⓪&IF exprUsesRegs (count, RegSet{D0}) THEN loadReg (count, RegSet {D1}) END;⓪&IF exprUsesRegs (addr, RegSet{D0}) THEN makeInd0An (addr) END;⓪&exclRegs (expr, usedRegs);⓪&exclRegs (addr, usedRegs);⓪&exclRegs (count, usedRegs);⓪&spillRegs (usedRegs);⓪&loadReg (count, anyDataReg);⓪&loadAddress (expr);⓪&loadAddress (addr);⓪&loadRegs (expr, A0, addr, A1);⓪&loadReg (count, RegSet {D1});⓪&callRuntime (n);⓪$END runtimeCopyOnStack;⓪ ⓪"PROCEDURE runtimeElemSet (VAR elem, set: ExprDesc;⓪<op: Operator; lo: ZZ);⓪$VAR size: LONGCARD; regs: RegSet; n: CARDINAL; old: ExprDesc; t: PtrItem;⓪$BEGIN⓪&(*$? Safety: assert (set.typeChecked); *)⓪&(*$? Safety: assert (NOT set.regset);*)⓪®s:= RegSet {A0,D0,D1};⓪&IF op = in THEN INCL (regs, D2) END;⓪&prepareDuo (elem, set, regs);⓪&loadRegExt (elem, dataRegs, 2, TRUE);⓪&size:= Size (set); (* Size geht durch loadAddress verloren! *)⓪&t:= set.item;⓪&loadExprAddress (set, old);⓪&loadReg (set, RegSet {A0});⓪&loadReg (elem, RegSet {D0});⓪&IF NOT set.zerobased THEN⓪(negZZ (lo);⓪(incReg (D0, lo, 2);⓪&END;⓪&IF op = in THEN⓪(constToReg (toZZ (size, FALSE), 2, D1);⓪(n:= SMEM⓪&ELSIF op = add THEN⓪(n:= SINCL⓪&ELSE⓪(n:= SEXCL⓪&END;⓪&callRuntime (n);⓪&set.item:= t;⓪&updateStack (old)⓪$END runtimeElemSet;⓪"⓪"PROCEDURE runtimeRangeSet (VAR elem1, elem2, set: ExprDesc; lo: ZZ);⓪$(* Bits 'elem1' bis 'elem2' in 'set' setzen; 'set' muß bereits (A0) sein *)⓪$VAR size: LONGCARD; regs: RegSet; n: CARDINAL;⓪$BEGIN⓪&(*$? Safety: assert (set.typeChecked);*)⓪&(*$? Safety: assert (NOT set.regset);*)⓪®s:= RegSet {A0,A1,A2,D0,D1,D2};⓪&exclRegs (elem1, regs);⓪&exclRegs (elem2, regs);⓪&exclRegs (set, regs);⓪&spillRegs (regs);⓪&loadRegExt (elem1, anyCPUReg, 2, TRUE);⓪&loadRegExt (elem2, anyCPUReg, 2, TRUE);⓪&loadRegs (elem1, D0, elem2, D1);⓪&(*$? Safety:⓪(assert ((set.kind = memory) & (set.mode = d16An) & (set.baseReg = A0));⓪&*)⓪&IF NOT set.zerobased THEN⓪(negZZ (lo); incReg (D0, lo, 2); incReg (D1, lo, 2);⓪&END;⓪&constToReg (toZZ (Size (set), FALSE), 2, D2);⓪&callRuntime (SIRG);⓪$END runtimeRangeSet;⓪"⓪"PROCEDURE runtimeCmp8Byte (VAR l, r: ExprDesc);⓪$PROCEDURE load (VAR x: ExprDesc);⓪&BEGIN⓪(IF (x.kind = stack) & (x.stackReg = A3) THEN⓪*(* SUBQ.L #8,A3 *)⓪*incReg (A3, toZZ (-8, FALSE), 4);⓪*x.stackedSize:= 0⓪(END;⓪(loadAddress (x)⓪&END load;⓪$BEGIN⓪&prepareDuo (l, r, RegSet {A0,A1});⓪&load (r); (* 'r' zuerst, falls beide auf Stack liegen! *)⓪&load (l);⓪&loadRegs (r, A0, l, A1);⓪&callRuntime (CMP8);⓪$END runtimeCmp8Byte;⓪"⓪"PROCEDURE runtimeSetOp (VAR l, r: ExprDesc;⓪:op: Operator; const, opcode: CARDINAL);⓪$VAR regs: RegSet;⓪$BEGIN⓪&(*$? Safety: assert (NOT l.regset);*)⓪&IF op = eq THEN⓪(regs:= RegSet {A0,A1,D0}⓪&ELSE⓪(regs:= RegSet {A0,A1,D0,D1}⓪&END;⓪&IF opcode = SXOR THEN INCL (regs, D2) END;⓪&prepareDuo (l, r, regs);⓪&loadAddress (l);⓪&loadAddress (r);⓪&loadRegs (l, A0, r, A1);⓪&constToReg (toZZ (LONG (const - 1), FALSE), 2, D0);⓪&callRuntime (opcode);⓪&deallocRegs (r);⓪$END runtimeSetOp;⓪"⓪"PROCEDURE runtimeLength (VAR expr: ExprDesc);⓪$VAR exprsize: LONGCARD; size, opcode: CARDINAL; old: ExprDesc;⓪$BEGIN⓪&prepareUno (expr, RegSet {D0,D1,A0});⓪&exprsize:= Size (expr);⓪&IF (exprsize <= 65536L) THEN⓪(opcode:= LENW;⓪(size:= 2⓪&ELSE⓪(opcode:= LENL;⓪(size:= 4⓪&END;⓪&IF isStringVar (expr.item) THEN⓪(loadExprAddress (expr, old);⓪(loadReg (expr, RegSet {A0});⓪(constToReg (toZZ (exprsize-1, FALSE), size, D0);⓪(callRuntime (opcode);⓪(updateStack (old);⓪&ELSE⓪((*$? Safety: assert ((ItemNo (expr.item) = 32) OR (ItemNo (expr.item) = 42)); *)⓪((*/// bei mehrdim. Open Arrays hier sicherstellen, daß nur⓪)* eine Dim. besteht! *)⓪(changeToStackTo (expr, addrRegs-RegSet{A0});⓪(expr.item:= CardPtr;⓪(genMOVEar (expr, A0);⓪(expr.item:= sizedItem (size, FALSE);⓪(genMOVEar (expr, D0);⓪(callRuntime (opcode);⓪&END;⓪&deallocRegs (expr);⓪&initRegExpr (expr, size, allocReg (RegSet {D0}));⓪$END runtimeLength;⓪$⓪"PROCEDURE runtimeCap (VAR expr: ExprDesc);⓪$VAR t: PtrItem;⓪$BEGIN⓪&prepareUno (expr, RegSet {D0,A2});⓪&t:= expr.item;⓪&loadRegExt (expr, RegSet {D0}, 2, TRUE);⓪&callRuntime (CAPI);⓪&expr.item:= t⓪$END runtimeCap;⓪$⓪"PROCEDURE runtimeConstMul (VAR expr: ExprDesc; factor: ZZ;⓪=size, opcode: CARDINAL);⓪$BEGIN⓪&prepareUno (expr, RegSet {D0..D2});⓪&loadReg (expr, RegSet {D0});⓪&constToReg (factor, size, D1);⓪&callRuntime (opcode);⓪$END runtimeConstMul;⓪ ⓪"PROCEDURE runtimeVarMul (VAR left, right: ExprDesc;⓪;mul: BOOLEAN; opcode: CARDINAL);⓪$(*⓪%* Ergebnis in 'left', 'right' wird freigegeben⓪%*)⓪$BEGIN⓪&prepareDuo (left, right, RegSet {D0..D2});⓪&IF mul⓪&AND (⓪+(left.kind = register) & (left.exprReg = D1)⓪(OR (right.kind = register) & (right.exprReg = D0) )⓪&THEN⓪(swapExpr (left, right)⓪&END;⓪&loadReg (right, anyCPUReg); (*restoreStack (right);*)⓪&loadReg (left, anyCPUReg);⓪&loadRegs (left, D0, right, D1);⓪&callRuntime (opcode);⓪&deallocRegs (right);⓪$END runtimeVarMul;⓪ ⓪"PROCEDURE runtimeConstCopy (VAR source, dest: ExprDesc;⓪>long: BOOLEAN; count: LONGCARD);⓪$VAR regs: RegSet; size, opcode: CARDINAL; save: RegSet;⓪(old2, old, workSource, workDest: ExprDesc;⓪$BEGIN⓪&IF long THEN regs:= RegSet {A0..A2,D0..D2} ELSE regs:= RegSet {A0,A1,D0,D1} END;⓪&prepareDuo (source, dest, regs);⓪&workSource:= source;⓪&workDest:= dest;⓪&save:= freeRegs;⓪&loadDestAddress (workDest, count); (* dest -> A0 *)⓪&loadExprAddress (workSource, old); (* source -> A1 *)⓪&loadRegs (workSource, A1, workDest, A0);⓪&IF long THEN⓪(opcode:= COPYL;⓪(size:= 4⓪&ELSE⓪(opcode:= COPYW;⓪(size:= 2⓪&END;⓪&constToReg (toZZ (count, FALSE), size, D0);⓪&callRuntime (opcode);⓪&updateStack (old);⓪&freeRegs:= save;⓪&(* wenn auf Stack kopiert wurde, ggf. SP hochsetzen *)⓪&WITH dest DO⓪(IF kind = stack THEN⓪*INC (stackedSize, count);⓪*IF stackReg IN tempRegs THEN⓪,(*⓪-* Reg (A0) wurde schon von Runtime-Routine hochgesetzt.⓪-* Nun kann 'dest' einfach A0 zugewiesen bekommen.⓪-* Allerdings kann es sein, daß A0 vorher von 'source' belegt war.⓪-* Diese hat nun eigentlich A1 als Pointer, allerdings wurde⓪-* dies durch das Arbeiten über 'workSource' nicht in 'source'⓪-* ggf. durch 'loadRegs' angepaßt. Zum Glück wird 'source' aber⓪-* nicht mehr benötigt, so daß sie jetzt hier freigegeben wird⓪-* und dann A0 f. 'dest' verwendet werden kann.⓪-*)⓪,deallocRegs (source); source.kind:= jmp (* dummy *);⓪,deallocReg (stackReg);⓪,stackReg:= allocReg (RegSet {A0})⓪*ELSE⓪,(* Reg ist A3 oder so -> wurde schon von 'loadXXXAddress' hochgesetzt*)⓪,(* nur syncStacks darf nicht nochmal ADDQ #1,A3 machen: *)⓪,IF ODD (stackedSize) THEN INC (stackedSize) END⓪*END;⓪(END⓪&END;⓪$END runtimeConstCopy;⓪ ⓪"END (* MODULE *) RuntimeCalls;⓪ ⓪ ⓪ PROCEDURE makePostInc (VAR sp: ExprDesc; size: LONGCARD);⓪"(*⓪#* Wird aufgerufen, um den A7-Stackpointer in einen Hilfs-Pointer⓪#* umzuladen, damit mit (An)+ gearbeitet werden kann.⓪#* Der Wert 'size' gibt die Parameterlänge an und muß gerade sein!⓪#*)⓪"VAR descSP: ExprDesc;⓪"BEGIN⓪$(*$? Safety: assert (sp.kind = stack);*)⓪$WITH sp DO⓪&IF NOT up THEN⓪(roundUp (size);⓪((*$? Safety: assert (stackReg IN (tempRegs + RegSet {A3,A7}));*)⓪(incReg (stackReg, toZZ (-LONGINT (size), FALSE), 4);⓪(initRegExpr (descSP, 4, stackReg);⓪(loadReg (descSP, addrRegs);⓪(stackReg:= descSP.exprReg;⓪(up:= TRUE;⓪(restoreAfterUse:= 0;⓪(stackedSize:= 0⓪&END⓪$END⓪"END makePostInc;⓪ ⓪ ⓪ (*⓪!* BEGIN of RealGen⓪!*)⓪ ⓪ (*⓪!* Dies Modul ist für alle Real-Operationen zuständig.⓪!*⓪!* Hierin wird entschieden, auf welche Art die Reals angesprochen werden:⓪!* a) über die Runtime-Funktionen mit simulierten FP-Regs,⓪!* b) über Runtime, speziell ausgelegt für den externen 881, mit Benutzung⓪!* seiner Regs,⓪!* c) direkt über den 881-Prozessor einer PAK oder des Atari TT.⓪!*)⓪ ⓪ PROCEDURE genStoreIntFPUReg (r: RegType; VAR dest: ExprDesc);⓪"VAR n: CARDINAL; VAR code: codeDesc;⓪"BEGIN⓪$n:= $F200;⓪$getSrcEA (dest, 0, n, code);⓪$IF coding () THEN⓪&PutCode (n);⓪&n:= FPUT + Freg (r) + $4400;⓪&IF dest.item = RealPtr THEN INC (n, $1000) END;⓪&PutCode (n);⓪&encodeTail (dest, code);⓪$END;⓪"END genStoreIntFPUReg;⓪ ⓪ PROCEDURE genLoadIntFPUReg (VAR expr: ExprDesc;⓪<opcode: CARDINAL; r: RegType);⓪"VAR ea: BOOLEAN; n1, n2: CARDINAL; VAR code: codeDesc;⓪"BEGIN⓪$n1:= $F200;⓪$n2:= opcode + Fea (expr, ea) + Freg (r);⓪$IF ea THEN getSrcEA (expr, 0, n1, code); END;⓪$IF coding () THEN⓪&PutCode (n1);⓪&PutCode (n2);⓪&IF ea THEN encodeTail (expr, code); END⓪$END;⓪"END genLoadIntFPUReg;⓪ ⓪ PROCEDURE moveRealRegs (pop: BOOLEAN; list: CARDINAL);⓪"(* FMOVEM gen. *)⓪"VAR op2, opcode: CARDINAL; st: ExprDesc; code: codeDesc;⓪"BEGIN⓪$op2:= FMOVEM + $2000 * ORD (~pop) + $1000 * ORD (pop) + list;⓪$IF fpu () = externalFPU THEN⓪&runtimeMoveRealRegs (op2, pop)⓪$ELSE⓪&(*$? Safety: assert (fpu () = internalFPU); (*sinnlos bei softReals*)*)⓪&IEEERuntimeCall;⓪&initStackExpr (st, CardPtr, A7);⓪&st.up:= pop;⓪&opcode:= $F200;⓪&getSrcEA (st, -1, opcode, code);⓪&IF coding () THEN⓪(PutCode (opcode);⓪(PutCode (op2);⓪&END;⓪$END;⓪"END moveRealRegs;⓪ ⓪ PROCEDURE loadInternalFPU (VAR expr: ExprDesc;⓪>opcode: CARDINAL; niceRegs: RegSet);⓪"VAR r: RegType;⓪"BEGIN⓪$r:= allocReg (niceRegs);⓪$genLoadIntFPUReg (expr, opcode, r);⓪$deallocRegs (expr);⓪$expr.kind:= register;⓪$expr.exprReg:= r;⓪"END loadInternalFPU;⓪ ⓪ PROCEDURE loadRealReg (VAR expr: ExprDesc; niceRegs: RegSet);⓪"VAR size: CARDINAL;⓪&r: RegType;⓪&pseudoReg: ExprDesc;⓪"BEGIN⓪$WITH expr DO⓪&IF (kind # register) OR ~(exprReg IN niceRegs) THEN⓪(IF (fpu () = softReal) THEN⓪*size:= SHORT (Size (expr));⓪*IF (kind = stack) & (size > 4) THEN makePostInc (expr, size) END;⓪*IF kind = register THEN⓪,deallocReg (exprReg);⓪,initPseudoRegExpr (expr, item, exprReg, FALSE);⓪*END;⓪*changeToStack (expr);⓪*r:= allocReg (niceRegs);⓪*(*$? Safety: assert (r >= F0); *)⓪*initPseudoRegExpr (pseudoReg, item, r, FALSE);⓪*IF size > 4 THEN⓪,changeToStack (pseudoReg)⓪*END;⓪*copy (expr, pseudoReg, size, FALSE);⓪*deallocRegs (pseudoReg);⓪*deallocRegs (expr);⓪*expr.kind:= register;⓪*expr.exprReg:= r;⓪(ELSIF fpu () = internalFPU THEN⓪*loadInternalFPU (expr, FGET, niceRegs)⓪(ELSE⓪*runtimeLoadRealToReg (expr, niceRegs)⓪(END;⓪&END⓪$END⓪"END loadRealReg;⓪ ⓪ PROCEDURE pushRealReg (VAR expr: ExprDesc; to: RegType);⓪"(*⓪#* lädt 'expr' auf den Stack. 'expr' muß im Reg stehen!⓪#* Es muß darauf geachtet werden, daß keinesfalls ein spilling⓪#* ausgelöst wird, weil es sonst zu Konflikten kommen kann⓪#* (Rekursion in 'spillReg')!⓪#*)⓪"VAR pseudoReg, stack: ExprDesc;⓪"BEGIN⓪$(*$? Safety: assert (expr.kind = register);*)⓪$IF (fpu () = softReal) THEN⓪&initStackExpr (stack, expr.item, to);⓪&IF expr.item = RealPtr THEN⓪(initPseudoRegExpr (pseudoReg, CardPtr, expr.exprReg, to = A7);⓪(genMOVEaa (pseudoReg, stack, 4);⓪(initPseudoRegExpr (pseudoReg, CardPtr, expr.exprReg, to # A7);⓪(genMOVEaa (pseudoReg, stack, 4);⓪&ELSE⓪(initPseudoRegExpr (pseudoReg, expr.item, expr.exprReg, FALSE);⓪(genMOVEaa (pseudoReg, stack, 4);⓪&END;⓪$ELSIF fpu () = internalFPU THEN⓪&initStackExpr (stack, expr.item, to);⓪&genStoreIntFPUReg (expr.exprReg, stack);⓪$ELSE⓪&runtimePushRealReg (expr, to);⓪$END;⓪"END pushRealReg;⓪ ⓪ PROCEDURE assignRealReg (VAR source, dest: ExprDesc);⓪"(*⓪#* Entweder ist 'dest' ein Reg (Reg-Var) und 'source' ist beliebig⓪#* oder 'source' ist im Register und 'dest' ist Var oder RegVar.⓪#* Beides nur mit FPU (ST oder TT)!⓪#*)⓪"BEGIN⓪$(*$? Safety: assert (fpu() # softReal); *)⓪$IF dest.kind = register THEN⓪&(*$? Safety: assert (dest.exprReg IN varRegs); *)⓪&INCL (freeRegs, dest.exprReg);⓪&loadRealReg (source, RegSet {dest.exprReg});⓪&(*$? Safety: assert (NOT (dest.exprReg IN freeRegs)); *)⓪$ELSE⓪&(*$? Safety: assert (source.kind = register); *)⓪&IF fpu () = internalFPU THEN⓪(genStoreIntFPUReg(source.exprReg, dest);⓪&ELSE⓪(runtimeMoveRealRegToVar (source, dest);⓪&END⓪$END⓪"END assignRealReg;⓪ ⓪ PROCEDURE negateReal (VAR expr: ExprDesc);⓪"BEGIN⓪$IF fpu () = internalFPU THEN⓪&(* FNEG FPn *)⓪&loadInternalFPU (expr, FNEG, floatRegs)⓪$ELSE⓪&runtimeRealMono (expr, 2)⓪$END⓪"END negateReal;⓪ ⓪ PROCEDURE absReal (VAR expr: ExprDesc);⓪"BEGIN⓪$IF fpu () = internalFPU THEN⓪&(* FABS FPn *)⓪&loadInternalFPU (expr, FABS, floatRegs)⓪$ELSE⓪&runtimeRealMono (expr, 3)⓪$END⓪"END absReal;⓪ ⓪ PROCEDURE convertReal (VAR expr: ExprDesc; n: CARDINAL);⓪$(*⓪%* 'n':⓪%* 0: SHORT()⓪%* 1: LONG()⓪%* LC2S..D2LI: FLOAT/TRUNC⓪%*)⓪"BEGIN⓪$IF (fpu () # softReal) & (n <= 1) THEN⓪&(* das reicht schon f. Expand/Short *)⓪&loadRealReg (expr, floatRegs);⓪&IF n = 0 THEN⓪(expr.item:= SRealPtr⓪&ELSE⓪(expr.item:= RealPtr⓪&END⓪$ELSE⓪&(* ruft immer die allgemeinen Runtime-Funktionen auf: *)⓪&runtimeRealMono (expr, n)⓪$END⓪"END convertReal;⓪ ⓪ PROCEDURE realOp (op: Operator; VAR this, from: ExprDesc);⓪"(*⓪#* für DIV & SUB gilt: 'this' ist der rechte Wert.⓪#* 'from' kommt in ein Register, 'this' kann alles sein.⓪#*)⓪"VAR isrel: BOOLEAN; n2,n1,m: CARDINAL; ea: BOOLEAN; code: codeDesc;⓪"BEGIN⓪$IF fpu () = internalFPU THEN⓪&prepareFPUop (this, from, op, isrel);⓪&loadRealReg (from, floatRegs);⓪&getFPUop (this, from.exprReg, op, isrel, n2, m, ea);⓪&n1:= $F200;⓪&IF ea THEN getSrcEA (this, 0, n1, code); END;⓪&IF coding () THEN⓪(PutCode (n1);⓪(PutCode (n2);⓪(IF ea THEN encodeTail (this, code); END⓪&END;⓪&deallocRegs (this);⓪&IF isrel THEN⓪(WITH from DO⓪*deallocReg (exprReg);⓪*item:= BoolPtr;⓪*kind:= condFlags;⓪*fpuFlags:= TRUE;⓪*relOp:= op;⓪*signed:= TRUE; (* irrelevant bei FPU *)⓪*not:= FALSE⓪(END;⓪&END;⓪$ELSE⓪&runtimeRealOp (op, this, from);⓪&(*wird schon in runtime-Routine gemacht: deallocRegs (this); *)⓪$END;⓪$PushExpr (from)⓪"END realOp;⓪ ⓪ (*⓪!* END of RealGen⓪!*)⓪ ⓪ ⓪ PROCEDURE constMul (VAR op: ExprDesc; resultType: PtrItem; factor: ZZ;⓪4checkOver: BOOLEAN);⓪"(*⓪#* Beim Aufruf müssen alle ExprDesc außer 'op' auf dem Stack stehen, da⓪#* sonst der Spill-Mechanismus nicht funktionieren kann!⓪#*⓪#* wenn der Factor Eins ist, der result-Type aber größer als der von 'op',⓪#* wird zumindest Code zum Expandieren erzeugt.⓪#*)⓪"⓪"VAR opSize, resultSize, opcode: CARDINAL; signed: BOOLEAN;⓪ ⓪"PROCEDURE overCheck;⓪$BEGIN⓪&(*~~~ die kodierung gen. zwar einen Overflow-Check, sinngemäß ist es⓪'* bei der Anwendung f. array-index und f. high-wert-calcs ein⓪'* range-check!⓪'* param 'checkOver' sollte bestimmbar machen, von welchem Flag⓪'* es abh. ist, den overflow zu prüfen: von der overflow- oder von⓪'* der range-check-option.⓪'*)⓪&IF checkOver THEN checkOverflow (resultType) END⓪$END overCheck;⓪ ⓪"PROCEDURE extend;⓪$BEGIN⓪&IF resultSize > opSize THEN⓪(loadRegExt (op, dataRegs, resultSize, TRUE);⓪&END;⓪$END extend;⓪ ⓪"PROCEDURE singleAdd;⓪$BEGIN⓪&genar (ADD, op, op.exprReg);⓪&overCheck⓪$END singleAdd;⓪ ⓪"BEGIN⓪$signed:= signedType (resultType);⓪$opSize:= SHORT (Size (op));⓪$resultSize:= SHORT (TypeLength (resultType));⓪$IF nullZZ (factor) THEN⓪&(* es darf keine Null-Konst. erzeugt werden, weil dadurch evtl.⓪'* folgende Proc-Aufrufe wegoptimiert würden. *)⓪&clearExpr (op);⓪$ELSE⓪&IF factor.over THEN⓪((* ~~~ overflow, wenn ABS ('op') > 1 *)⓪((* wir melden erstmal immer einen Fehler: *)⓪(SyntaxError (rAriOv)⓪&ELSIF factor.v = 1L THEN⓪((* extend, aber ggf. in selbem Reg, auch bei Reg-Vars *)⓪(IF resultSize > opSize THEN⓪*loadRegExt (op, anyDataReg, resultSize, TRUE);⓪(END;⓪&ELSIF factor.v = 2L THEN⓪(extend;⓪(loadReg (op, dataRegs);⓪(singleAdd⓪&ELSIF factor.v = 4L THEN⓪(extend;⓪(loadReg (op, dataRegs);⓪(IF checkOver & NOT signed THEN⓪*(* bei Rangecheck kann mit mehrfach-Shift kein Overflow bei⓪+* unsigned Typen erkannt werden *)⓪*singleAdd; singleAdd⓪(ELSE⓪*gena (ASLI + $200 * 2, op, 0);⓪*overCheck⓪(END⓪&ELSIF factor.v = 8L THEN⓪(extend;⓪(loadReg (op, dataRegs);⓪(IF checkOver & NOT signed THEN⓪*(* s.o. *)⓪*singleAdd; singleAdd; singleAdd⓪(ELSE⓪*gena (ASLI + $200 * 3, op, 0);⓪*overCheck⓪(END⓪&ELSE⓪((*~~~ ggf. auch bei anderen 2-Potenz-Faktoren mit ASL arbeiten?!⓪)* dann z.b. f. 2^16 SWAP verwenden! *)⓪(IF opSize <= 2 THEN⓪*loadRegExt (op, dataRegs, 2, FALSE);⓪*IF signed THEN opcode:= MULS ELSE opcode:= MULU END;⓪*genir (opcode, FALSE, factor.v, op.exprReg);⓪*IF resultSize = 4 THEN⓪,IF signed THEN op.item:= IntPtr ELSE op.item:= CardPtr END;⓪*ELSIF checkOver THEN⓪,checkMulOverflow (op)⓪*END⓪(ELSE⓪*IF signed & int16ZZ (factor) & posZZ (factor)⓪*OR NOT signed & card16ZZ (factor) THEN⓪,(* Long * Word *)⓪,IF signed THEN opcode:= IMLW ELSE opcode:= CMLW END;⓪,runtimeConstMul (op, factor, 2, opcode);⓪,overCheck;⓪*ELSE⓪,(* Long * Long *)⓪,IF signed THEN opcode:= IMLL ELSE opcode:= CMLL END;⓪,runtimeConstMul (op, factor, 4, opcode);⓪,overCheck;⓪*END⓪(END⓪&END⓪$END;⓪$op.item:= resultType;⓪"END constMul;⓪ ⓪ ⓪ ⓪ PROCEDURE constAdd (VAR op: ExprDesc; resultType: PtrItem; const: ZZ;⓪4checkOver: BOOLEAN);⓪ ⓪"VAR opSize, resultSize: CARDINAL;⓪ ⓪"BEGIN⓪$resultSize:= SHORT (TypeLength (resultType));⓪$opSize:= SHORT (Size (op));⓪$IF resultSize > opSize THEN⓪&loadRegExt (op, dataRegs, resultSize, TRUE);⓪$END;⓪$IF NOT nullZZ (const) THEN⓪&loadReg (op, dataRegs);⓪&incReg (op.exprReg, const, resultSize);⓪&IF checkOver THEN checkOverflow (resultType) END⓪$END;⓪$op.item:= resultType;⓪"END constAdd;⓪"⓪ ⓪ PROCEDURE bothOnStack (left, right: ExprDesc): BOOLEAN;⓪"BEGIN⓪$RETURN (left.kind = stack) AND (right.kind = stack)⓪+AND (left.up = right.up)⓪"END bothOnStack;⓪ ⓪ ⓪ PROCEDURE mustCopyByByte (VAR expr: ExprDesc): BOOLEAN;⓪"(*⓪#* Liefert TRUE, wenn Datum byteweise kopiert werden sollte, da es sonst⓪#* u.U. zu Adreß-Fehler kommen kann.⓪#* Liefert nicht TRUE, wenn Datum ein Byte groß ist, weil dann der⓪#* vergesehene MOVE verwendet werden kann.⓪#*)⓪#⓪"BEGIN⓪$RETURN (Size (expr) # 1L)⓪'AND (expr.kind = memory) & expr.mayBeOdd & ByteType (expr.item)⓪"END mustCopyByByte;⓪ ⓪ ⓪ (* ************************************************************************* *)⓪ ⓪ (*⓪!* Intelligente, Code erzeugende Routinen⓪!*)⓪ ⓪ PROCEDURE clrSingle (VAR dest: ExprDesc; n: CARDINAL);⓪"(*⓪#* 'stackedSize' wird nur hochgezählt, wenn 'n' nicht Null ist!⓪#*)⓪"BEGIN⓪$gena (CLR, dest, n);⓪$IF dest.kind = stack THEN⓪&IF dest.stackReg = A7 THEN roundUpCard (n) END;⓪&INC (dest.stackedSize, n)⓪$END;⓪"END clrSingle;⓪ ⓪ PROCEDURE moveSingle (VAR source, dest: ExprDesc; n: CARDINAL);⓪"(*⓪#* 'stackedSize' wird nur hochgezählt, wenn 'n' nicht Null ist!⓪#*)⓪"BEGIN⓪$IF (source.kind = constant) AND (source.exprConst.zz.l = 0L) THEN⓪&IF n = 0 THEN⓪((* hiermit wird verhindert, daß stackedSize verändert wird, *⓪)* aber trotzdem die Size von 'source' verwendet wird *)⓪(gena (CLR, dest, SHORT (Size (source)))⓪&ELSE⓪(clrSingle (dest, n)⓪&END⓪$ELSE⓪&genMOVEaa (source, dest, n);⓪&IF source.kind = stack THEN⓪(IF source.stackReg = A7 THEN roundUpCard (n) END;⓪(INC (source.stackedSize, n)⓪&END;⓪&IF dest.kind = stack THEN⓪(IF dest.stackReg = A7 THEN roundUpCard (n) END;⓪(INC (dest.stackedSize, n)⓪&END⓪$END⓪"END moveSingle;⓪ ⓪ ⓪ PROCEDURE copy (VAR source, dest: ExprDesc; size: LONGCARD; byByte: BOOLEAN);⓪ ⓪"VAR null: ExprDesc;⓪&ptrConst: ADDRESS;⓪&first, nulled: BOOLEAN;⓪&constSave: ConstValue;⓪ ⓪"TYPE copyProc = PROCEDURE (CARDINAL);⓪"⓪"PROCEDURE zero (siz: CARDINAL): BOOLEAN;⓪$CONST null = BYTE (0);⓪$VAR n: CARDINAL; p: POINTER TO BYTE;⓪$BEGIN⓪&p:= ptrConst;⓪&REPEAT⓪(IF p^ # null THEN RETURN FALSE END;⓪(DEC (siz);⓪(INC (p)⓪&UNTIL siz = 0;⓪&RETURN TRUE⓪$END zero;⓪ ⓪"PROCEDURE constCopy (n: CARDINAL);⓪$BEGIN⓪&(*$? Safety:⓪(assert (first OR (dest.kind = stack) & (dest.stackReg # A7) & (dest.up));⓪&*)⓪&first:= FALSE;⓪&IF (n = 4) AND NOT zero (4)⓪&AND ( zero (2) OR zero (2) )⓪&AND (dest.kind = stack) & (dest.stackReg # A7) THEN⓪(constCopy (2);⓪(constCopy (2)⓪&ELSE⓪(DEC (size, n);⓪(IF zero (n) THEN⓪*IF nulled THEN⓪,moveSingle (null, dest, n)⓪*ELSE⓪,IF size <= 2L THEN⓪.(* CLR (An)+ *)⓪.clrSingle (dest, n)⓪,ELSE⓪.(* MOVEQ #0,Dn *)⓪.(* MOVE D0,(An)+ *)⓪.initConstExpr (null, n, toZZ (0L, FALSE));⓪.loadReg (null, dataRegs);⓪.nulled:= TRUE;⓪.moveSingle (null, dest, n)⓪,END⓪*END⓪(ELSE⓪*Move (ptrConst, ADR (source.exprConst.b) + 1L - LONG (n), n);⓪*moveSingle (source, dest, n);⓪(END;⓪(INC (ptrConst, n)⓪&END⓪$END constCopy;⓪ ⓪"PROCEDURE memCopy (n: CARDINAL);⓪$BEGIN⓪&(*$? Safety: assert (first OR (dest.kind = stack) &⓪<((source.kind # stack) OR (dest.up = source.up)));*)⓪&first:= FALSE;⓪&DEC (size, n);⓪&moveSingle (source, dest, n)⓪$END memCopy;⓪ ⓪"PROCEDURE doit (n: CARDINAL);⓪$BEGIN⓪&IF source.kind = constant THEN⓪(constCopy (n)⓪&ELSE⓪(memCopy (n)⓪&END;⓪$END doit;⓪ ⓪"BEGIN⓪$(*$? Safety:⓪&assert ( NOT byByte OR NOT ((dest.kind=stack) & (dest.stackReg=A7)) );⓪$*)⓪$IF (dest.kind = register) & (source.kind = constant) THEN⓪&(*$? Safety: assert ((dest.exprReg IN varRegs) & NOT (dest.exprReg IN freeRegs));*)⓪&constToReg (source.exprConst.zz, SHORT (size), dest.exprReg);⓪$ELSE⓪&(*⓪'* Sonderfall, wenn single Instr. und source.kind = constant:⓪'* dann kann, wenn ein Byte an ein Long zugewiesen wird, ein⓪'* MOVEQ #const,Dn gen. werden!⓪'*)⓪&IF (size = 4L) & NOT byByte⓪&& (source.kind = constant) & int8ZZ (source.exprConst.zz)⓪&& NOT nullZZ (source.exprConst.zz) THEN⓪(loadReg (source, anyDataReg)⓪&END;⓪&⓪&nulled:= FALSE;⓪&constSave:= source.exprConst;⓪&ptrConst:= ADR (constSave.b) + 1L - size;⓪&first:= TRUE;⓪&IF NOT byByte THEN⓪(WHILE SHORT (size) >= 4 DO⓪*doit (4)⓪(END;⓪(IF SHORT (size) >= 2 THEN⓪*doit (2)⓪(END⓪&END;⓪&WHILE SHORT (size) # 0 DO⓪(doit (1)⓪&END;⓪&IF nulled THEN deallocRegs (null) END;⓪$END⓪"END copy;⓪ ⓪ ⓪ PROCEDURE moveLocalProcOnA3 (VAR source: ExprDesc);⓪"(* Lädt eine Prozedur oder eine Proc-Var (Typ 19) auf den A3-Stack *)⓪"VAR help: ExprDesc;⓪"BEGIN⓪$initStackExpr (help, CardPtr, A3);⓪$(*⓪&IF (source.kind # stack) OR (source.stackReg # A3) THEN⓪((*was war denn hier???*)⓪&END;⓪$*)⓪$IF ItemNo (source.item) = 6 THEN⓪&IF global IN ItemFlag (source.item) THEN⓪(genMOVEaa (source, help, 4);⓪(deallocRegs (source);⓪(gena (CLR, help, 4);⓪&ELSE⓪(makeIndir (source, 0, FALSE);⓪(loadAddress (source);⓪(genMOVEaa (source, help, 4);⓪(deallocRegs (source);⓪((* bei lokalen procs Display laden *)⓪(IF source.tiefe = 0 THEN⓪*(* MOVE.L A6,(A3)+ *)⓪*initRegExpr (source, 4, getLink (0));⓪(ELSE⓪*(* MOVE.L (Ar),(A3)+ *)⓪*initRegExpr (source, 4, getLink (source.tiefe-1));⓪*makeIndir (source, 0, FALSE)⓪(END;⓪(genMOVEaa (source, help, 4);⓪(deallocRegs (source)⓪&END⓪$ELSE⓪&(*$? Safety: assert (ItemNo (source.item) = 19);*)⓪&genMOVEaa (source, help, 4);⓪&deallocRegs (source);⓪&gena (CLR, help, 4);⓪$END;⓪$source:= help;⓪$source.up:= FALSE;⓪$source.stackedSize:= 8;⓪"END moveLocalProcOnA3;⓪ ⓪ ⓪ PROCEDURE fitValue (VAR source: ExprDesc; (*kein VAR! *) conv: ConvDesc);⓪"(*⓪#* Macht Expand und Range-Check für alle ordinalen und Real-Types⓪#*⓪#* Der Type von expr wird auch mit angepaßt!⓪#*⓪#* Erzeugt Range-Check-Code, falls $R-Option aktiv ist.⓪#* Muß nach 'asnCompatible' und vor dem Assignment⓪#* aufgerufen werden.⓪#*⓪#* ~~~ in sonderfällen könnte dies schon außen optimiert werden:⓪#* denn diese routine muß zum check den wert ins reg laden,⓪#* bei zuweisung eines card auf einen int bräuchte aber nur⓪#* erst hinterher ein BMI-check gemacht werden.⓪#* lösung: zumindest sollte diese routine auch den status 'condRegs'⓪#* auswerten können und bei den einfachen fällen auch darauf verzichten,⓪#* den wert ins reg zu laden. dann würde dies von assign erkannt werden⓪#* müssen, und dann nach dem assign der kind=condRegs sein und dann⓪#* der check hier gemacht werden.⓪#*)⓪"⓪"PROCEDURE prepareBoundCheck (lo, hi: LONGWORD; signed: BOOLEAN; size: CARDINAL);⓪$(* bereitet Subrange-Check vor. Wenn bereits einer vorgesehen ist,⓪%* wird der Bereich entspr. verkleinert *)⓪$VAR z1: ZZ;⓪$BEGIN⓪&WITH conv DO⓪(IF boundsCheck THEN⓪*z1:= toZZ (lowerBound, signedBounds);⓪*IF cmpZZ (z1, toZZ (lo, signed)) = lt THEN lowerBound:= lo END;⓪*z1:= toZZ (upperBound, signedBounds);⓪*IF cmpZZ (z1, toZZ (hi, signed)) = gt THEN upperBound:= hi END;⓪(ELSE⓪*boundsCheck:= TRUE;⓪*lowerBound:= lo;⓪*upperBound:= hi⓪(END;⓪(signedBounds:= signed;⓪(IF cmpZZ (toZZ (lowerBound, signedBounds),⓪2toZZ (upperBound, signedBounds)) = gt THEN⓪*(* ranges überschneiden sich nicht mehr -> Fehler melden *)⓪*SyntaxError (rSubrg)⓪(END;⓪(boundSize:= size⓪&END⓪$END prepareBoundCheck;⓪ ⓪"VAR loExpr, hiExpr, help: ExprDesc;⓪&savedType: PtrItem;⓪&elems: LONGCARD;⓪&lo, hi: ZZ;⓪ ⓪"BEGIN (* fitValue *)⓪$WITH conv DO⓪&IF realConv IN sizeFlags THEN⓪(IF source.kind = constant THEN⓪*IF shorten IN sizeFlags THEN⓪,shortenReal (source, rReaRg)⓪*ELSIF expand IN sizeFlags THEN⓪,expandReal (source)⓪*END⓪(ELSE⓪*IF shorten IN sizeFlags THEN⓪,convertReal (source, 0)⓪*ELSIF expand IN sizeFlags THEN⓪,convertReal (source, 1)⓪*END⓪(END⓪((*~~~ die runtime-aufrufe bei der VAL-auswertung können hierdurch⓪)* ersetzt werden⓪)*)⓪"⓪&ELSIF sizeFlags # convSet {} THEN⓪&⓪(IF source.kind = constant THEN⓪*⓪*getBounds (destType, lo, hi);⓪*IF NOT inZZ (source.exprConst.zz, lo, hi) THEN SyntaxError (rConRg) END;⓪(⓪(ELSE⓪(⓪*(*$? Safety2: assert ((sourceSize) = SHORT (Size (source)));*)⓪*⓪*(*⓪+* Range-Check bei Zuweisung von verschiedenen Basistypes⓪+* ------------------------------------------------------⓪+*⓪+* shorten⓪+* -------⓪+*⓪+* LONGINT -> INTEGER:⓪+* MOVE.L source,Dx⓪+* ; signed -> MOVEA⓪+* MOVE.W Dx,Ay⓪+* CMP.L Dx,Ay⓪+* BEQ ok⓪+* TRAP⓪+* ok MOVE Dx,dest⓪+*⓪+* LONGCARD -> INTEGER (wie LONGCARD/LONGINT->CARDINAL, plus BMI):⓪+* MOVE.L source,Dx⓪+* ; NOT signed⓪+* MOVEQ #0,Dy⓪+* MOVE.W Dx,Dy⓪+* BMI er ; <- signChange⓪+* CMP.L Dx,Dy⓪+* BEQ ok⓪+* er TRAP⓪+* ok MOVE Dx,dest⓪+*⓪+* LONGCARD / LONGINT -> CARDINAL⓪+* MOVE.L source,Dx⓪+* ; NOT signed⓪+* MOVEQ #0,Dy⓪+* MOVE.W Dx,Dy⓪+* CMP.L Dx,Dy⓪+* BEQ ok⓪+* er TRAP⓪+* ok MOVE Dx,dest⓪+*⓪+* LONGCARD / LONGINT -> BOOLEAN / Enum:⓪+* wie LONGCARD / LONGINT -> CARDINAL, zusätzlich Subrange-Check⓪+*⓪+* LONGCARD / LONGINT -> CHAR (wie LC/LI->CARDINAL, nur andere Size):⓪+* MOVE.L source,Dx⓪+* ; NOT signed⓪+* MOVEQ #0,Dy⓪+* MOVE.B Dx,Dy ; <- Size: destSize⓪+* CMP.L Dx,Dy⓪+* BEQ ok⓪+* er TRAP⓪+* ok MOVE Dx,dest⓪+*⓪+* Enum / CARDINAL / INTEGER -> CHAR⓪+* MOVE.W source,Dx⓪+* MOVE.B Dx,dest⓪+* zusätzlich Subrange-Test [0..255]⓪+*⓪+* BOOLEAN -> CHAR⓪+* MOVE.W source,Dx⓪+* MOVE.B Dx,dest⓪+* kein Test nötig⓪+*⓪+* Localproc-Type (44) -> Proc-Type (19)⓪+* LEA source,A0⓪+* TST.L 4(A0)⓪+* BEQ ok⓪+* TRAP⓪+* ok⓪+*⓪+* expand⓪+* ------⓪+*⓪+* CHAR -> CARDINAL / INTEGER⓪+* MOVEQ #0,Dx⓪+* MOVE.B source,Dx⓪+* MOVE.W Dx,dest⓪+*⓪+* CHAR / CARDINAL / BOOLEAN / Enum -> LONGCARD / LONGINT⓪+* MOVEQ #0,Dx⓪+* MOVE source,Dx ; size: 'sourceSize'⓪+* MOVE.L Dx,dest⓪+*⓪+* INTEGER -> LONGINT⓪+* MOVE.W source,Dx⓪+* EXT.L Dx⓪+* MOVE.L Dx,dest⓪+*⓪+* INTEGER -> LONGCARD⓪+* MOVE.W source,Dx⓪+* EXT.L Dx⓪+* BPL ok⓪+* TRAP⓪+* ok MOVE.L Dx,dest⓪+*⓪+* Procedure (6) / Proc-Type (19) -> Localproc-Type (44)⓪+* MOVE.L source,(A3)+⓪+* CLR.L (A3)+⓪+*⓪+*⓪+* keine Size-Änderung⓪+* -------------------⓪+*⓪+* BOOLEAN / Enum (<32768 Elemente) -> INTEGER:⓪+* immer OK⓪+*⓪+* CARDINAL / INTEGER -> Enum / BOOLEAN⓪+* nur Subrange-Check⓪+*⓪+* CARDINAL / Enum (>=32768 Elemente) -> INTEGER,⓪+* INTEGER -> CARDINAL:⓪+* Range-Check [0..$7FFF]⓪+*⓪+* LONGCARD -> LONGINT,⓪+* LONGINT -> LONGCARD:⓪+* MOVE.L source,D0⓪+* BPL ok⓪+* TRAP⓪+* ok MOVE.L Dx,dest⓪+*⓪+*)⓪ ⓪*(* wenn Size = 1, dann muß es ein CHAR o. BYTE sein: *)⓪*(*$? Safety2:⓪*assert ((destSize # 1)⓪2OR (ItemNo (destType) = 38)⓪2OR (ItemNo (destType) = 3));⓪*assert ((sourceSize # 1)⓪2OR (ItemNo (source.item) = 38)⓪2OR (ItemNo (source.item) = 3));⓪**)⓪*IF shorten IN sizeFlags THEN⓪,⓪,(* beim Kürzen muß source > 1 Byte, dest < 4 Byte sein: *)⓪,(*$? Safety2:⓪,assert (((sourceSize) = 4) OR (sourceSize = 2));⓪,assert (((destSize) = 2) OR (destSize = 1));⓪,*)⓪,loadReg (source, anyDataReg);⓪,IF rangeCheckActive () & NOT (subCheck IN sizeFlags) THEN⓪.savedType:= source.item;⓪.source.item:= sizedItem (destSize, signedConv IN sizeFlags);⓪.copyRegExt (source, help, dataRegs + addrRegs, sourceSize);⓪.IF signChange IN sizeFlags THEN⓪0(*$? Safety: assert (NOT (signedConv IN sizeFlags));*)⓪0gen (Bcc + mapCC(pl, FALSE, TRUE) + 4)⓪.END;⓪.source.item:= savedType;⓪.genar (CMP, source, help.exprReg);⓪.deallocRegs (help);⓪.gen (Bcc + mapCC (eq, FALSE, FALSE) + 4);⓪.genTrap (RangeTrap)⓪,END⓪*⓪*ELSIF expand IN sizeFlags THEN⓪,⓪,(* beim Erweitern muß source < 4 Byte, dest > 1 Byte sein: *)⓪,(*$? Safety2:⓪,assert ((sourceSize = 1) OR (sourceSize = 2));⓪,assert ((destSize = 2) OR (destSize = 4));⓪,*)⓪,IF rangeCheckActive ()⓪,& (signedConv IN sizeFlags)⓪,& (signChange IN sizeFlags) THEN⓪.(* INTEGER -> LONGCARD *)⓪.loadRegExt (source, anyDataReg, 4, TRUE);⓪.gen (Bcc + mapCC (pl, FALSE, FALSE) + 4);⓪.genTrap (RangeTrap)⓪,ELSE⓪.loadRegExt (source, anyCPUReg, 4, TRUE)⓪.(* hier wird Wert ggf. auch in ein Adreß-Reg. geladen *)⓪,END⓪,⓪*ELSIF procShorten IN sizeFlags THEN⓪,⓪,(*$? Safety2:⓪,assert (ItemNo (source.item) = 44);⓪,assert (ItemNo (destType) = 19);⓪,assert (source.kind # stack);⓪,*)⓪,loadAddress (source);⓪,makeIndir (source, 4, FALSE);⓪,gena (TST, source, 4);⓪,source.disp:= 0;⓪,gen (Bcc + mapCC (eq, FALSE, FALSE) + 4);⓪,genTrap (DisplayTrap)⓪,⓪*ELSIF procExpand IN sizeFlags THEN⓪,⓪,(*$? Safety2: assert (ItemNo (destType) = 44);*)⓪,moveLocalProcOnA3 (source);⓪,⓪*ELSE⓪,⓪,(* sonst müssen Größen identisch sein *)⓪,(*$? Safety2: assert ((sourceSize) = (sourceSize));*)⓪,⓪,IF rangeCheckActive () THEN⓪.IF signChange IN sizeFlags THEN⓪0IF sourceSize = 4 THEN⓪2loadReg (source, anyDataReg);⓪2gen (Bcc + mapCC (pl, FALSE, FALSE) + 4);⓪2genTrap (RangeTrap)⓪0ELSE⓪2(*$? Safety2: assert (sourceSize = 2);*)⓪2prepareBoundCheck (0L, $7FFFL, FALSE, sourceSize)⓪0END⓪.END⓪,END⓪,⓪*END; (* IF shorten.. OR expand.. ELSE *)⓪&⓪(END⓪"⓪&ELSIF (source.kind # constant) & (source.kind # constRef) THEN⓪ ⓪((* prüfen, ob beide Types wirklich gleich groß sind.⓪)* Falls nicht, haben wir bei 'getConversionDesc' einen der Types⓪)* (z.B. BothTyp, SBothTyp) vergessen.⓪)*)⓪((*$? Safety2: assert (Size (source) = TypeLength (destType));*)⓪"⓪&END; (* ELSIF sizeFlags # convSet {} ELSE *)⓪&⓪&IF NOT isSS (source) THEN⓪(source.item:= destType;⓪(IF sizeFlags # convSet {} THEN⓪*sourceSize:= destSize;⓪(END;⓪&END;⓪&⓪&IF boundsCheck THEN⓪&⓪(IF source.kind = constant THEN⓪,⓪*getBounds (destType, lo, hi);⓪*IF NOT inZZ (source.exprConst.zz, lo, hi) THEN SyntaxError (rConRg) END;⓪(⓪(ELSE⓪*IF rangeCheckActive () THEN⓪,⓪,initConstExpr (loExpr, boundSize,⓪;toZZ (lowerBound, signedBounds));⓪,initConstExpr (hiExpr, boundSize,⓪;toZZ (upperBound, signedBounds));⓪,⓪,IF (boundSize = 2)⓪,& (LONGCARD (lowerBound) = 0L)⓪,& (LONGCARD (upperBound) <= $7FFFL) THEN⓪.loadReg (source, anyDataReg);⓪.genir (CHK, FALSE, upperBound, source.exprReg);⓪,ELSIF (boundSize = 4)⓪,& (LONGCARD (lowerBound) # 0L)⓪,& ( (LONGCARD (lowerBound) <= $7FFFL)⓪/OR (LONGCARD (upperBound) <= $7FFFL) ) THEN⓪.(* Wert wird in ein Adreß-Reg geladen und kann dann mit CMPA.W⓪/* verglichen werden *)⓪.loadReg (source, addrRegs);⓪.IF LONGCARD (lowerBound) <= $7FFFL THEN loExpr.item:= SIntPtr END;⓪.IF LONGCARD (upperBound) <= $7FFFL THEN hiExpr.item:= SIntPtr END;⓪.genar (CMP, loExpr, source.exprReg);⓪.gen (Bcc + mapCC (lt, signedBounds, FALSE) + 4 + SHORT (Size (hiExpr)));⓪.genar (CMP, hiExpr, source.exprReg);⓪.gen (Bcc + mapCC (le, signedBounds, FALSE) + 4);⓪.genTrap (RangeTrap)⓪,ELSE⓪.loadReg (source, anyDataReg);⓪.IF signedBounds & (LONGCARD (lowerBound) = 0L) THEN⓪0gen (Bcc + mapCC (pl, FALSE, FALSE) + 4);⓪0genTrap (RangeTrap)⓪.ELSE⓪0IF LONGCARD (lowerBound) # 0L THEN⓪2genar (CMP, loExpr, source.exprReg);⓪2gen (Bcc + mapCC (lt, signedBounds, FALSE) + 6);⓪0END;⓪0genar (CMP, hiExpr, source.exprReg);⓪0gen (Bcc + mapCC (le, signedBounds, FALSE) + 4);⓪0genTrap (RangeTrap)⓪.END⓪,END⓪(⓪*END (* IF rangeCheckActive () *)⓪*⓪(END (* IF source.kind = constant *)⓪(⓪&END (* IF boundsCheck *)⓪$END (* WITH conv *)⓪"END fitValue;⓪ ⓪ PROCEDURE valueFitting (REF range: ConvDesc): BOOLEAN;⓪"(*⓪#* Liefert TRUE, wenn kein Range-Check oder Expand durchgeführt werden muß.⓪#*)⓪"BEGIN⓪$WITH range DO⓪&RETURN NOT ( rangeCheckActive ()⓪3& (boundsCheck OR (sizeFlags # convSet {})) )⓪3& (sourceSize = destSize)⓪$END;⓪"END valueFitting;⓪ ⓪ ⓪ PROCEDURE syncStacks (VAR expr, dest: ExprDesc; pre: BOOLEAN);⓪"(*⓪#* korrigiert bei Datentransfer ggf. die Stacks⓪#* 'pre': TRUE, wenn Aufruf vor dem Transfer, sonst danach⓪#*)⓪"PROCEDURE syncStack (VAR sp: ExprDesc);⓪$BEGIN⓪&WITH sp DO⓪((*$? Safety: assert (stackReg IN (tempRegs + RegSet {A3,A7}));*)⓪(IF pre & NOT up THEN⓪*IF stackReg # A7 THEN⓪,incReg (stackReg, toZZ (-1L, FALSE), 4);⓪,INC (stackedSize)⓪*END;⓪(ELSIF NOT pre & up THEN⓪*IF stackReg # A7 THEN⓪,incReg (stackReg, toZZ (+1L, FALSE), 4);⓪,INC (stackedSize)⓪*END;⓪(END;⓪&END⓪$END syncStack;⓪"BEGIN⓪$IF (dest.kind = stack) & ODD (dest.stackedSize) THEN⓪&IF (expr.kind = stack) THEN syncStack (expr) END;⓪&syncStack (dest)⓪$END;⓪$(*$? Safety: assert (pre OR NOT ODD (A3Offset) & NOT ODD (A7Offset))*)⓪"END syncStacks;⓪ ⓪ PROCEDURE adaptStack (VAR expr: ExprDesc; sourceSize: LONGCARD);⓪"(*⓪#* Paßt A3 f. Laden eines Datum vom Stack an⓪#*)⓪"BEGIN⓪$WITH expr DO⓪&IF (kind = stack) & (stackReg = A3) THEN⓪((*$? Safety: assert (stackedSize # 0L);*)⓪(incReg (stackReg,⓪0toZZ (LONGINT (sourceSize) - LONGINT (stackedSize), FALSE), 4);⓪(stackedSize:= sourceSize⓪&END⓪$END⓪"END adaptStack;⓪"⓪ ⓪ PROCEDURE fillStack (VAR dest: ExprDesc; destSize: LONGCARD);⓪"(*⓪#* füllt Stack bei String-Consts auf 'destSize' auf⓪#*)⓪"BEGIN⓪$(*$? Safety: assert (dest.stackReg IN (tempRegs + RegSet {A3,A7}));*)⓪$incReg (dest.stackReg, toZZ (LONGINT (destSize) - LONGINT (dest.stackedSize), FALSE), 4);⓪$dest.stackedSize:= destSize⓪"END fillStack;⓪ ⓪ ⓪ (* ************************************************************************* *)⓪ ⓪ (*⓪!* Vorbereitende Hilfs-Routinen, die Code-unabhängig sind⓪!*)⓪ ⓪ PROCEDURE shiftLeft (VAR expr: ExprDesc; n: CARDINAL);⓪"VAR c: CARDINAL;⓪"BEGIN⓪$IF n > 0 THEN⓪&WITH expr.exprConst DO⓪(FOR c:= n TO strConstSize DO⓪*str [c-n]:= str [c]⓪(END;⓪(FOR c:= strConstSize - n + 1 TO strConstSize DO⓪*str [c]:= StringTerminator⓪(END⓪&END;⓪&SetSize (expr, Size (expr) + LONG (n));⓪$END⓪"END shiftLeft;⓪ ⓪ PROCEDURE shiftRight (VAR expr: ExprDesc; n: CARDINAL);⓪"VAR c: CARDINAL;⓪"BEGIN⓪$WITH expr.exprConst DO⓪&FOR c:= strConstSize TO n BY -1 DO⓪(str [c]:= str [c-n]⓪&END;⓪&FOR c:= 0 TO n-1 DO⓪(str [c]:= 0C⓪&END⓪$END;⓪$SetSize (expr, Size (expr) - LONG (n));⓪"END shiftRight;⓪ ⓪ PROCEDURE terminateStringConst (VAR expr: ExprDesc; destType: PtrItem);⓪"(*⓪#* Fügt bei String-Consts ggf. eine Null an, wenn die dest-Länge⓪#* es erfordert.⓪#*)⓪"VAR destSize, exprSize: LONGCARD;⓪"BEGIN⓪$(*$? Safety:⓪$assert (expr.item = SSTyp);⓪$*)⓪$exprSize:= Size (expr);⓪$destSize:= TypeLength (destType);⓪$IF exprSize < destSize THEN⓪&IF expr.kind = constant THEN (* noch kein Ende-Zeichen dran *)⓪(IF (exprSize = 0)⓪(OR (expr.exprConst.str[strConstSize] # StringTerminator) THEN⓪*shiftLeft (expr, 1) (* String aufschieben *)⓪(END⓪&ELSE⓪((*$? Safety: assert ((expr.kind = constRef));*)⓪((* bei Strings im Data ist schon eine Null dran *)⓪(SetSize (expr, Size (expr) + 1L);⓪&END⓪$END;⓪"END terminateStringConst;⓪ ⓪ PROCEDURE adaptStringConst (VAR expr: ExprDesc; destType: PtrItem);⓪"(*⓪#* Füllt String-Consts auf Länge des String-Typs 'destType' auf.⓪#* Ist 'destType' kleiner, wird String auch korrekt gekürzt.⓪#* Wird nur für Typ-Casts von Strings benutzt.⓪#*)⓪"VAR destSize, exprSize: LONGCARD;⓪"BEGIN⓪$(*$? Safety: assert (isSS (expr) & isStringVar (destType));*)⓪$exprSize:= Size (expr);⓪$destSize:= TypeLength (destType);⓪$IF exprSize # destSize THEN⓪&IF exprSize <= LONG (constBufSize) THEN⓪((*$? Safety: assert (expr.kind = constant);*)⓪(IF destSize > LONG (constBufSize) THEN⓪*(* Const muß abgelegt werden.⓪-Sie wird nur in ihrer upsprünglichen Länge abgelegt, was⓪-aber u.U. zu Speicherverletzungen führen kann, weil trotzdem⓪-die Anzahl von "destSize" Bytes bei einer Zuweisung kopiert⓪-werden wird! Aber das vernachlässigen wir einfach, bis jemand⓪-sich darüber beschwert.⓪**)⓪*changeConstantToConstRef (expr, exprSize);⓪(ELSIF destSize > exprSize THEN⓪*shiftLeft (expr, SHORT (destSize-exprSize)) (* String verlängern *)⓪(ELSE⓪*shiftRight (expr, SHORT (exprSize-destSize)) (* String verkürzen *)⓪(END;⓪&ELSE⓪((*$? Safety: assert (expr.kind = constRef);*)⓪((*⓪)* String müßte bereits 0-terminiert sein, daher keine weitere⓪)* Aktion nötig⓪)*)⓪&END⓪$END;⓪$expr.item:= destType⓪"END adaptStringConst;⓪ ⓪ ⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ ⓪ FORWARD VarExpression ();⓪ FORWARD ConstExpression;⓪ ⓪ FORWARD call (VAR leftOnA3: LONGCARD; pushAddr: BOOLEAN; pushBase: LONGINT);⓪ FORWARD hdlSetConstructor (type: PtrItem);⓪ FORWARD hdlArrayConstructor (type: PtrItem);⓪ FORWARD hdlRecordConstructor (type: PtrItem);⓪ ⓪ PROCEDURE hdlConstructor (t: PtrItem);⓪"BEGIN⓪$IF (ItemNo (t) = 45) OR (ItemNo (t) = 5) (* SET *) THEN⓪&hdlSetConstructor (t)⓪$ELSIF ItemNo (t) = 12 (* ARRAY *) THEN⓪&hdlArrayConstructor (t)⓪$ELSIF ItemNo (t) = 13 (* RECORD *) THEN⓪&hdlRecordConstructor (t);⓪$ELSE⓪&SyntaxError (rValCs)⓪$END;⓪"END hdlConstructor;⓪ ⓪ PROCEDURE deref (VAR fact: ExprDesc);⓪"(*⓪#* lädt Pointer und ändert 'expr' in seinen Basetype⓪#*)⓪"VAR no: CARDINAL;⓪"BEGIN⓪$no:= ItemNo (fact.item);⓪$IF (no = 20 (* POINTER *) )⓪$OR (no = 23 (* ADDRESS *) ) THEN⓪&(* Wert des Pointers laden: MOVE.L (Ax),Ax *)⓪&loadReg (fact, anyAddrReg);⓪&makeIndir (fact, 0, TRUE);⓪&fact.item:= RefType (fact.item);⓪&IF ItemNo (fact.item) = 0 (* zeigt auf Relay *) THEN⓪(SyntaxError (rBdPtr)⓪&END;⓪&fact.readOnly:= FALSE⓪$ELSE⓪&SyntaxError (rPtrXp)⓪$END⓪"END deref;⓪ ⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ ⓪ ⓪ PROCEDURE extractConst (VAR fact: ExprDesc; ofs, size: LONGCARD);⓪"(*⓪#* verkleinert 'fact'. Dazu ist 'ofs' der Offset ab Const-Beginn, 'size'⓪#* die neue Länge.⓪#*)⓪"VAR endptr: ADDRESS;⓪&help: ConstValue;⓪"BEGIN⓪$WITH fact DO⓪&IF kind = constant THEN⓪(endptr:= ADR (exprConst.b) + 1;⓪(Move (endptr - Size (fact) + ORD (ofs), endptr - size, size);⓪&ELSE⓪((*$? Safety: assert (kind = constRef); *)⓪(INC (constOfs, ofs);⓪(IF (size <= constBufSize) THEN⓪*(* wir können Const aus Code 'exprConst' ablegen *)⓪*IF constHead = NIL THEN dropConstantFromTree (fact) END;⓪*Move (constAddr + constOfs, ADR(help.b)+1-size, size);⓪*cutConst (fact);⓪*exprConst:= help;⓪*kind:= constant⓪(ELSE⓪*(* abgelegte Const im DATA-Puffer direkt kürzen *)⓪*IF (constOfs > 0) & (varItem = NIL) & constantAtEnd (fact) THEN⓪,reduceConstant (fact);⓪*END⓪(END;⓪&END;⓪$END⓪"END extractConst;⓪ ⓪ ⓪ PROCEDURE checkBounds (VAR index: ExprDesc; VAR arrayLow, arrayHigh, base: ZZ);⓪"(*⓪#* Dyn. Range-check f. Array-Bounds⓪#*⓪#* Findet zuerst heraus, ob Index-Range in den Feldbereich paßt, so daß⓪#* kein Range-Check nötig wird. Dazu werden dann die Array-Bounds⓪#* korrigiert, so daß auch die Index-Breitenbestimmung außerhalb⓪#* sich ggf. auf einen Shortint beschränken kann, obwohl das Feld⓪#* selbst einen Long-Range hat.⓪#*⓪#* In 'base' wird der Offset geliefert, der beim Elementzugriff vom⓪#* index noch subtrahiert werden muß.⓪#*⓪#* ~~~ kann diese Routine mit 'fitValue' kombiniert werden, sobald⓪#* 'fitValue' die Checks rein nach den Bounds beurteilt (und nicht⓪#* getrennt nach range-check und sign-change)?⓪#*)⓪"VAR alreadyInReg, lowFits, highFits, chkInstr: BOOLEAN;⓪&indexLow, indexHigh: ZZ;⓪"BEGIN⓪$base:= arrayLow;⓪$⓪$(* Prüfen, ob Index bedingungslos in Feldbereich paßt *)⓪$getBounds (index.item, indexLow, indexHigh);⓪$lowFits:= cmpZZ (indexLow, arrayLow) # lt;⓪$highFits:= cmpZZ (indexHigh, arrayHigh) # gt;⓪$IF lowFits THEN arrayLow:= indexLow END;⓪$IF highFits THEN arrayHigh:= indexHigh END;⓪$IF cmpZZ (arrayLow, arrayHigh) = gt THEN⓪&(* ranges überschneiden sich nicht mehr -> Fehler melden *)⓪&SyntaxError (rSubrg)⓪$END;⓪$⓪$IF rangeCheckActive () THEN⓪&(* [..arrayHigh]⓪(- index[0..61000] -> array[0..60000] : [..60000] CMP #60000⓪(- index[0..31000] -> array[0..30000] : [..30000] CHK #30000⓪(- index[0..61000] -> array[0..30000] : [..30000] CHK #30000⓪(- index[0..31000] -> array[0..60000] : [..31000] keine Prüfung⓪&*)⓪&chkInstr:= (Size (index) = 2L) & int16ZZ (arrayHigh) & (arrayHigh.l >= 0);⓪((* >>> Size(index) muß 2 sein, weil CHK nur diese Größe kann,⓪)* der zu testende High-Bound muß innerhalb 0..$7FFF liegen. *)⓪&⓪&(*⓪'* Low-Check durchführen:⓪'* Wert gleichzeitig auf Null bringen, damit die Elemente⓪'* am Ende mit Null-Baseoffset adressiert werden können.⓪'*⓪'* index[-10..] -> array[0..] : [0..], kein CHK, keine Base-Korrektur⓪'*)⓪&IF NOT lowFits THEN⓪(alreadyInReg:= (index.kind = register) & (index.exprReg IN dataRegs);⓪(loadReg (index, dataRegs);⓪(IF nullZZ (arrayLow) THEN⓪*IF alreadyInReg THEN⓪,(* TST index, um Flags zu setzen *)⓪,gena (TST, index, 0)⓪*END;⓪*(* Reg nur auf negativ testen: BLE error *)⓪(ELSE⓪*subZZ (arrayHigh, arrayLow);⓪*negZZ (arrayLow); (* arrayLow darf nicht > 2^31 sein - naja *)⓪*incReg (index.exprReg, arrayLow, SHORT (Size (index)));⓪*(* ADD wurde erzeugt -> BCC/GE error *)⓪*(* SUB wurde erzeugt -> BCS/LT error *)⓪*base:= toZZ (0L, FALSE);⓪*arrayLow:= toZZ (0L, FALSE)⓪(END;⓪(IF chkInstr OR highFits THEN⓪*(* wir müssen hier schon Trap erzeugen *)⓪*gen (Bcc + mapCC (ge, signedExpr (index), FALSE) + 4);⓪*genTrap (RangeTrap)⓪(ELSE⓪*(* sprung auf Trap von arrayHigh-check *)⓪*gen (Bcc + mapCC (lt, signedExpr (index), FALSE) + 4 + sizeZZeven (arrayHigh))⓪(END;⓪&END;⓪&⓪&(*⓪'* Nun High-Check durchführen:⓪'* CHK geht nur bei high<=MaxInt⓪'* beim obigen SUB muß sonst ggf. mit BCC der unterlauf⓪'* geprüft werden!⓪'*⓪'* Es wird immer vorzeichenlos verglichen. Das geht, weil der Wert⓪'* immer bull-based vorliegt.⓪'*)⓪&IF NOT highFits THEN⓪(loadReg (index, anyDataReg);⓪(IF chkInstr THEN⓪*genir (CHK, FALSE, arrayHigh.c, index.exprReg);⓪(ELSE⓪*genia (CMPI, arrayHigh.l, index, 0);⓪*gen (Bcc + mapCC (le, FALSE, FALSE) + 4);⓪*genTrap (RangeTrap)⓪(END⓪&END⓪$⓪$END (* IF rangeCheckActive *)⓪"END checkBounds;⓪ ⓪ FORWARD varMul (op: Operator; left, right: ExprDesc;⓪2chkOver: BOOLEAN; resultType: PtrItem);⓪ ⓪ PROCEDURE accessArray (VAR fact: ExprDesc; no: CARDINAL; forHIGH: BOOLEAN);⓪ ⓪"PROCEDURE myMulZZ (VAR x: ZZ; elemSize: LONGCARD; VAR over: BOOLEAN);⓪$VAR pos: BOOLEAN;⓪$BEGIN⓪&SignalOverflow:= FALSE;⓪&HasOverflown:= FALSE;⓪&pos:= posZZ (x);⓪&mulZZ (x, toZZ (elemSize, FALSE));⓪&over:= HasOverflown;⓪&IF HasOverflown THEN⓪(IF pos THEN⓪*x:= toZZ (MaxLCard, FALSE)⓪(ELSE⓪*x:= toZZ (MinLInt, TRUE)⓪(END;⓪&END;⓪&SignalOverflow:= TRUE;⓪$END myMulZZ;⓪ ⓪"VAR⓪$firstOpenArray, highPtrUsed: BOOLEAN;⓪ ⓪"PROCEDURE accessSubRoutine (): BOOLEAN;⓪"⓪$(*⓪%* Dieser Teil wird als Subroutine verwendet, um den Stackbedarf⓪%* bei der VarExpression-Rekursion klein zu halten⓪%*)⓪%⓪$VAR⓪&highPtr, high, index, size: ExprDesc;⓪&idxBaseType, highType, type: PtrItem;⓪&ofs: LONGINT;⓪&elemSize: LONGCARD;⓪&base, min, max, lowBound, highBound: ZZ;⓪&minOver, maxOver: BOOLEAN;⓪&sizeIsConst, odd, longIdx: BOOLEAN;⓪&idxIsNull, needHigh, open, longOpen: BOOLEAN;⓪&range: ConvDesc;⓪&endptr: ADDRESS;⓪&highLen, n: CARDINAL;⓪®: RegType;⓪ ⓪$BEGIN⓪&PopExpr (index);⓪&IF highPtrUsed THEN PopExpr (highPtr); reloadPtr (highPtr) END;⓪&PopExpr (fact);⓪&⓪&open:= (no # 12);⓪&highLen:= 0;⓪&IF open THEN⓪(longOpen:= (no = 42);⓪(IF longOpen THEN⓪*highLen:= 4;⓪*highType:= CardPtr⓪(ELSE⓪*highLen:= 2;⓪*highType:= SCardPtr⓪(END⓪&ELSIF forHIGH THEN⓪(SyntaxError (rBdHig)⓪&ELSIF isSS (fact) THEN⓪(highType:= CardPtr⓪&ELSE⓪(highType:= IndexType (fact.item)⓪&END;⓪&checkAsnCompat (index, highType, range, rBdIdx);⓪&⓪&sizeIsConst:= TRUE;⓪&IF open THEN⓪(reloadPtr (fact);⓪(type:= OpenArrayType (fact.item);⓪(sizeIsConst:= NOT isOpenArray (type);⓪(⓪(needHigh:= ~sizeIsConst OR forHIGH⓪/(* wenn weitere Dims folgen, High-Zugriff für Elementgrößenbe-⓪0* stimmung anfordern *)⓪*OR rangeCheckActive () AND⓪-( (index.kind#constant) OR ~nullZZ(index.exprConst.zz) );⓪/(* wenn Index = 0, brauchen wird den High-Wert nicht prüfen *)⓪(IF firstOpenArray THEN⓪*initOpenArrayAccess (fact, needHigh);⓪*firstOpenArray:= FALSE;⓪(END;⓪(IF needHigh THEN⓪*IF NOT highPtrUsed THEN⓪,initHighExpr (fact, highPtr);⓪,highPtrUsed:= TRUE;⓪*END;⓪(END;⓪(⓪(lowBound:= toZZ (0L, FALSE);⓪(IF longOpen THEN⓪*highBound:= toZZ ($FFFFFFFFL, FALSE);⓪(ELSE⓪*IF TypeLength (type) = 1 THEN⓪,highBound:= toZZ ($7FFFL, FALSE)⓪*ELSE⓪,highBound:= toZZ ($FFFFL, FALSE)⓪*END⓪(END;⓪&ELSIF isSS (fact) THEN⓪(lowBound:= toZZ (0L, FALSE);⓪(highBound:= toZZ (Size (fact)-1L, FALSE);⓪(type:= CharPtr;⓪&ELSE⓪(getBounds (IndexType (fact.item), lowBound, highBound);⓪(type:= ElementType (fact.item)⓪&END;⓪&elemSize:= TypeLength (type);⓪&⓪&minOver:= FALSE;⓪&maxOver:= FALSE;⓪&⓪&(*⓪'* offset:= (index - lowBound) * elemSize⓪'*)⓪ ⓪&(* ----------------------------------- *⓪'* Range-Check für 'index' durchführen *⓪'* ----------------------------------- *)⓪&idxIsNull:= FALSE;⓪&IF index.kind = constant THEN⓪(idxIsNull:= nullZZ (index.exprConst.zz);⓪(IF open THEN⓪*IF ~idxIsNull THEN⓪,IF rangeCheckActive () THEN⓪.reloadPtr (fact);⓪.⓪.(* wenn das "Ah"-Reg noch in Benutzung ist, muß es nun wieder⓪/* auf den korrekten Wert gebracht werden, falls es wg. mehrdim.⓪/* Open Arrays für die dyn. Elementgrößenbestimmung (s.u.)⓪/* schon fortgeschritten ist. *)⓪.adjustHighPtr (fact, highPtr);⓪.⓪.(* Konstante mit High-Wert vergleichen *)⓪.genia (CMPI, index.exprConst.zz.l, highPtr,0);(* CMPI #idx,(An)+ *)⓪.IF sizeIsConst THEN⓪0highPtrUsed:= FALSE;⓪0deallocRegs (highPtr);⓪.ELSE⓪0INC (highPtr.stackedSize, highLen);⓪.END;⓪.(* wenn HIGH-Wert >= Idx, dann OK *)⓪.gen (Bcc + mapCC (ge, FALSE, FALSE) + 4);⓪.genTrap (RangeTrap);⓪,END⓪*END;⓪(ELSE⓪*IF NOT inZZ (index.exprConst.zz, lowBound, highBound) THEN⓪,SyntaxError (rIdxRg)⓪*END;⓪(END;⓪(negZZ (lowBound);⓪(addZZ (index.exprConst.zz, lowBound);⓪(base:= toZZ (0, FALSE)⓪&ELSE (* IF index.kind = constant *)⓪((*⓪)* 'lowBound' und 'highBound' beschreiben die⓪)* Grenzen des Feldbereichs.⓪)*⓪)* 'base' dagegen enthält den Offset, der vom 'index'⓪)* abgezogen werden muß, wenn auf das Element zugegriffen⓪)* wird.⓪)*)⓪((* offset:= (index - lowBound) * elemSize *)⓪((* oder: offset:= index * elemSize - lowBound * elemSize *)⓪(checkBounds (index, lowBound, highBound, base);⓪+(* korrigiert ggf. die Bounds und setzt 'base' *)⓪(IF open THEN⓪*IF rangeCheckActive () THEN⓪,reloadPtr (fact);⓪,(* Index mit High-Wert vergleichen *)⓪,⓪,(* wenn das "Ah"-Reg noch in Benutzung ist, muß es nun wieder⓪-* auf den korrekten Wert gebracht werden, falls es wg. mehrdim.⓪-* Open Arrays für die dyn. Elementgrößenbestimmung (s.u.)⓪-* schon fortgeschritten ist. *)⓪,adjustHighPtr (fact, highPtr);⓪,⓪,loadRegExt (index, anyCPUReg, highLen, TRUE);⓪,genar (CMP, highPtr, index.exprReg); (* CMP (Ah)+,Di *)⓪,IF sizeIsConst THEN⓪.highPtrUsed:= FALSE;⓪.deallocRegs (highPtr);⓪,ELSE⓪.INC (highPtr.stackedSize, highLen);⓪,END;⓪,(* wenn Idx <= HIGH-Wert, dann OK *)⓪,gen (Bcc + mapCC (le, FALSE, FALSE) + 4);⓪,genTrap (RangeTrap);⓪*END;⓪(END;⓪&END; (* IF index.kind = constant *)⓪&⓪&IF sizeIsConst & (index.kind = constant) THEN⓪&⓪(mulZZ (index.exprConst.zz, toZZ (elemSize, FALSE));⓪(ofs:= intZZ (index.exprConst.zz);⓪ ⓪(endptr:= ADR (fact.exprConst.b) + 1L;⓪(reloadPtr (fact);⓪(IF (fact.kind = constant) OR (fact.kind = constRef) THEN⓪*(*$? Safety: assert (ofs >= 0L);*)⓪*extractConst (fact, ofs, elemSize);⓪(ELSE⓪*IF ofs # 0L THEN⓪,addOffset (fact, ofs);⓪,(* fact.item wird gleich sowieso neu gesetzt *)⓪*END⓪(END;⓪&⓪&ELSE (* IF sizeIsConst & (index.kind = constant) *)⓪(⓪((*⓪)* es muß bestimmt werden, welchen Type der Index⓪)* nach der Skalierung hat. Dazu wird der mögliche⓪)* Bereich des Index mit der Elementgröße multipliziert⓪)* und daraus dann der neue Typ bestimmt.⓪)*⓪)* Wenn der Feldbereich ein long-Range ist, die index-⓪)* Var aber nur Shortint, wurde bereits von 'checkBounds'⓪)* der Feldbereich entsprechend verkleinert, so daß⓪)* dann auch die Word-Var als Index ausreicht.⓪)*)⓪(IF sizeIsConst THEN⓪*min:= lowBound;⓪*max:= highBound;⓪*myMulZZ (min, elemSize, minOver);⓪*myMulZZ (max, elemSize, maxOver);⓪*getNumTypeForRange (min, max, idxBaseType);⓪*longIdx:= longSignedType (idxBaseType);⓪(ELSE⓪*idxBaseType:= CardPtr; (* HIGH-Werte sind immer positiv *)⓪*longIdx:= TRUE⓪(END;⓪(⓪(INC (fact.highOfs, highLen);⓪(PushExpr (fact);⓪(PushExpr (index);⓪(⓪(IF sizeIsConst OR idxIsNull THEN⓪*initExpr (size, idxBaseType, constant);⓪*IF idxIsNull THEN elemSize:= 0 END;⓪*size.exprConst.zz:= toZZ (elemSize, FALSE)⓪(ELSE⓪*(* falls mehrere offene Dimensionen noch kommen, müssen die⓪+* High-Werte (plus 1) miteinander multipliziert werden, um⓪+* die Elementgröße zu errechnen *)⓪*fact.item:= type;⓪*REPEAT⓪,adjustHighPtr (fact, highPtr);⓪,n:= SHORT (Size (highPtr));⓪,(*$? Safety: assert (highPtr.kind = stack); *)⓪,copyRegExt (highPtr, high, dataRegs, 4);⓪,INC (highPtr.stackedSize, n);⓪,incReg (high.exprReg, toZZ (1,FALSE), 4);⓪,IF type = fact.item THEN (* wir sind noch beim 1. High-Wert. *)⓪.size:= high⓪,ELSE⓪.varMul (mul, size, high, FALSE, CardPtr); (* ist immer Long-Mul *)⓪.PopExpr (size)⓪,END;⓪,INC (fact.highOfs, n); (* "fact" ist auf ExprStack *)⓪,fact.item:= OpenArrayType (fact.item);⓪*UNTIL NOT isOpenArray (fact.item);⓪*elemSize:= TypeLength (fact.item)⓪(END;⓪(⓪(IF highPtrUsed & sizeIsConst THEN⓪*(* den High-Ptr brauchen wir nun nicht mehr *)⓪*highPtrUsed:= FALSE;⓪*deallocRegs (highPtr);⓪(END;⓪(⓪(PopExpr (index);⓪(reloadPtr (index);⓪(⓪((* nun den Index mit der Elementgröße multipl. *)⓪(IF longIdx THEN n:= 4 ELSE n:= 2 END;⓪(IF index.kind = constant THEN⓪*mulZZ (index.exprConst.zz, toZZ (elemSize, FALSE));⓪(ELSE⓪*constMul (index, idxBaseType, toZZ (elemSize, FALSE),⓪6minOver OR maxOver);⓪(END;⓪(IF sizeIsConst THEN (* ... dann ist 'index' nicht 'constant' *)⓪*mulZZ (base, toZZ (elemSize, FALSE));⓪(ELSE⓪*(*$? Safety: assert (nullZZ (base)); *)⓪*(* falls 'base' doch nicht immer Null ist:⓪0(* hier sofort die 'base' vom Index abziehen *)⓪0IF ~nullZZ (base) OR (SHORT (Size (index)) < n) THEN⓪2negZZ (base);⓪2loadRegExt (index, anyCPUReg, n, TRUE);⓪2incReg (index.exprReg, base, n);⓪0END;⓪0base:= toZZ (0, FALSE);⓪**)⓪*IF index.kind = constant THEN⓪,constMul (size, CardPtr, index.exprConst.zz,⓪8minOver OR maxOver(*nötig?*));⓪,index:= size;⓪*ELSE⓪,IF SHORT (Size (index)) < n THEN⓪.loadRegExt (index, anyCPUReg, n, TRUE);⓪,END;⓪,varMul (mul, index, size, FALSE, CardPtr);⓪,PopExpr (index)⓪*END⓪(END;⓪(⓪(PopExpr (fact);⓪(reloadPtr (fact);⓪(⓪(IF (fact.kind = constant) OR (fact.kind = constRef) THEN⓪*(* Damit sind auch Indizierungen von Const. möglich *)⓪*makeInd0An (fact);⓪(END;⓪(⓪(odd:= oddAccess (fact) OR ODD (elemSize);⓪*(* 'elemSize' ist hier die Größe des Typs hinter den offenen Dims,⓪+* sie bestimmt auch beim mehrdim. Open Arrays, ob das Ganze ungerade⓪+* sein kann. *)⓪(⓪(IF ~idxIsNull THEN⓪*IF indir (fact) THEN⓪,IF SHORT (Size (index)) < n THEN⓪.loadRegExt (index, anyCPUReg, n, TRUE)⓪,END;⓪,addIdxReg (fact, index, longIdx, nullZZ (base));⓪,fact.mayBeOdd:= odd⓪*ELSE⓪,loadAddress (fact);⓪,IF (index.kind # register)⓪,& ( (Size (index) = 4L) OR (Size (index) = 2L) & ~longIdx ) THEN⓪.(* wenn fact = "0(An)", dann "ADD index,An" *)⓪.genar (ADDA, index, fact.exprReg);⓪.restoreStack (index);⓪.deallocRegs (index);⓪.makeIndir (fact, 0, odd)⓪,ELSE⓪.loadRegExt (index, anyCPUReg, n, TRUE);⓪.makeIndirIdx (fact, index.exprReg, longIdx, odd)⓪,END⓪*END;⓪*addDisp (fact, -intZZ (base))⓪(END;⓪(⓪&END; (* IF sizeIsConst & (index.kind = constant) *)⓪&⓪&fact.item:= type;⓪&⓪&IF CurrentSymbol.itemNo # comma THEN⓪(IF highPtrUsed THEN⓪*DEC (fact.highOfs, INTEGER(SHORT (highPtr.stackedSize)));⓪*(* Das muß der Aufrufer v. accessArray erledigen: deallocRegs (highPtr) *)⓪(END;⓪(RETURN FALSE (* Ende der Indizierung *)⓪&END;⓪&⓪&no:= ItemNo (fact.item);⓪&IF NOT ( (no = 12) (* ARRAY *)⓪/OR (no = 42) (* OPEN LONGARRAY *)⓪/OR (no = 32) (* OPEN ARRAY *) ) THEN⓪(SyntaxError (rBrkXp)⓪&END;⓪&⓪&PushExpr (fact);⓪&IF highPtrUsed THEN PushExpr (highPtr) END;⓪&⓪&RETURN TRUE (* weiter geht's mit nächstem Index *)⓪$END accessSubRoutine;⓪ ⓪"BEGIN (* accessArray *)⓪$highPtrUsed:= FALSE;⓪$firstOpenArray:= TRUE;⓪$PushExpr (fact);⓪$REPEAT⓪&GetSymbol;⓪&VarExpression ();⓪$UNTIL NOT accessSubRoutine ();⓪$GetRbrack;⓪"END accessArray;⓪ ⓪ (*$D-*)⓪ ⓪ PROCEDURE desigAccess (VAR fact: ExprDesc; forHIGH: BOOLEAN);⓪ ⓪"VAR (*$Reg*)no: CARDINAL; type: PtrItem; (*$Reg*)ofs: LONGINT;⓪&endptr: ADDRESS; (*$Reg*)elemSize: LONGCARD;⓪ ⓪"BEGIN⓪$LOOP⓪&no:= ItemNo (fact.item);⓪&IF CurrentSymbol.itemNo = lbrack THEN⓪(IF (no = 12) (* ARRAY *)⓪(OR (no = 42) (* OPEN LONGARRAY *)⓪(OR (no = 32) (* OPEN ARRAY *) THEN⓪*accessArray (fact, no, forHIGH)⓪(ELSE⓪*SyntaxError (rArrXp)⓪(END;⓪&ELSIF CurrentSymbol.itemNo = dot THEN⓪(IF forHIGH THEN SyntaxError (rBdHig) END;⓪(IF no = 13 (* RECORD *) THEN⓪*WITH fact DO⓪,type:= LocalTree (item);⓪,IF NOT SearchLocalItem (type) THEN SyntaxError (rIdUn) END;⓪,ofs:= TypeLength (type);⓪,IF (kind = constant) OR (kind = constRef) THEN⓪.type:= RefType (type);⓪.elemSize:= TypeLength (type);⓪.extractConst (fact, ofs, elemSize);⓪.item:= type⓪,ELSE⓪.addOffset (fact, ofs);⓪.item:= RefType (type);⓪,END;⓪*END;⓪(ELSE⓪*SyntaxError (rRecXp)⓪(END;⓪(GetSymbol⓪&ELSIF CurrentSymbol.itemNo = arrow THEN⓪(IF forHIGH THEN SyntaxError (rBdHig) END;⓪(deref (fact);⓪(GetSymbol⓪&ELSE⓪(EXIT⓪&END;⓪&fact.regVar:= FALSE;⓪$END; (* LOOP *)⓪"END desigAccess;⓪ ⓪ PROCEDURE checkSet (VAR fact: ExprDesc);⓪"VAR n: CARDINAL; lo, hi: ZZ;⓪"BEGIN⓪$n:= ItemNo (fact.item);⓪$IF (n = 5) OR (n = 45) THEN⓪&fact.regset:= (n = 45) OR (TypeLength (fact.item) = 1L);⓪&getBounds (RefType (fact.item), lo, hi);⓪&fact.zerobased:= posZZ (lo) & (cmpZZ (hi, toZZ (31L, FALSE)) # gt);⓪&fact.typeChecked:= TRUE⓪$END;⓪"END checkSet;⓪ ⓪ TYPE DesigAccesses = (readDesig, (* willBeRead *)⓪6setDesig, (* willBeWritten *)⓪6modifyDesig,(* willBeWritten, willBeRead *)⓪6varDesig, (* might be read/written *)⓪6typeDesig); (* no read/write *)⓪ ⓪ PROCEDURE initIndir (VAR fact: ExprDesc; ofs: LONGINT; odd: BOOLEAN);⓪"BEGIN⓪$initExpr (fact, RefType (CurrentSymbol.item), register);⓪$fact.exprReg:= getLink (procDepth (Tiefe));⓪$makeIndir (fact, ofs, odd OR ODD (ofs))⓪"END initIndir;⓪ ⓪ PROCEDURE designator (access: DesigAccesses; loadRegToMemory: BOOLEAN;⓪6errNo: INTEGER);⓪ ⓪"(*⓪#* 'willBeRead': TRUE -> Wert der Var wird benötigt (sonst wird ggf.⓪#* bei Reg-Vars der Wert aus dem Memory erst gar nicht geladen, z.B.⓪#* bei Zuweisung darauf)⓪#* 'willBeWritten': TRUE -> Wert wird beschrieben -> damit wird dann⓪#* automatisch die Var. in den Initialisiert-Status versetzt.⓪#*⓪#* wenn 'loadRegToMemory' = TRUE, wird, wenn Var eine Reg-Var⓪#* ist, ein Zugriff auf die Memory-Zelle vorbereitet und die Var⓪#* darin abgelegt.⓪#*)⓪ ⓪"VAR willBeRead, willBeWritten: BOOLEAN;⓪ ⓪ (*$D-*)⓪ ⓪"PROCEDURE getVar (VAR fact: ExprDesc);⓪$VAR item: PtrItem; fl: IFS; reg: RegType; loadValue, accessReg: BOOLEAN;⓪$BEGIN⓪&item:= CurrentSymbol.item;⓪&fl:= CurrentSymbol.flags;⓪&⓪&NewAccessDepth (item, Global + 1);⓪&⓪&accessReg:= FALSE;⓪&loadValue:= FALSE;⓪&⓪&IF extVar IN fl THEN⓪(⓪((*$? Safety: assert (IsInMem (item));*)⓪(initMemExpr (fact, RefType (item), extL, FALSE);⓪(fact.extAddr:= LONGCARD (VarAddress (item));⓪(IF ODD (LONGCARD (fact.extAddr)) THEN fact.mayBeOdd:= TRUE END⓪(⓪&ELSE⓪(⓪(IF procDepth (Tiefe) # 0 THEN⓪*IF IsRegVar (item) THEN⓪,(* Reg-Vars nicht in lok. Procs benutzbar *)⓪,SyntaxError (rLocVa)⓪*END;⓪*(*$? Safety: assert (IsInMem (item));*)⓪*loadRegToMemory:= TRUE⓪(END;⓪(⓪(IF willBeRead & IsDirty (item) THEN⓪*(* Var. ist noch nicht initialisiert! *)⓪*SyntaxError (rNoIni)⓪(END;⓪(⓪(IF NOT loadRegToMemory & IsRegVar (item) THEN⓪*reg:= UsedReg (item);⓪*IF IsInReg (item) THEN⓪,(*$? Safety: assert (NOT (reg IN freeRegs));*)⓪,accessReg:= TRUE⓪*ELSE⓪,(*⓪-* Var liegt noch im Memory - wenn ihr Reg unbelegt ist, dann⓪-* benutzen; wenn kein Assignment, dann erst Wert aus Memory laden.⓪-*)⓪,IF reg IN freeRegs THEN⓪.(* Reg am Ende auf jeden Fall benutzen -> gleich reservieren *)⓪.EXCL (freeRegs, reg);⓪.UseReg (item); (* Reg benutzen *)⓪.IF willBeRead THEN⓪0(* ist schon oben erfolgt:⓪4IF IsDirty (item) THEN⓪6(* Var. ist noch nicht initialisiert! *)⓪6SyntaxError (rNoIni)⓪4ELSE⓪0*)⓪2(* zuerst auf Mem zugreifen, dann erst ins Reg laden *)⓪2loadValue:= TRUE⓪0(* END *)⓪.ELSE⓪0(*~~~ das lassen wir erstmal, denn dann klappt's⓪1* mit deref. Pointern nicht, z.B. bei "p^:= ..."⓪1* wird hier vermutet, daß eine Zuweisung auf 'p'⓪1* erfolgt und dann wird 'p' gar nicht mehr ggf. geladen.⓪2(* Assign -> gleich Reg benutzen *)⓪2accessReg:= TRUE⓪1* stattdessen:⓪1*)⓪0IF IsDirty (item) THEN⓪2(* Var. ist noch nicht initialisiert! *)⓪2accessReg:= TRUE⓪0ELSE⓪2(* zuerst auf Mem zugreifen, dann erst ins Reg laden *)⓪2loadValue:= TRUE⓪0END⓪.END⓪,END⓪*END⓪(END;⓪(⓪(IF willBeWritten THEN⓪*ClearDirt (item)⓪(END;⓪(⓪(IF accessReg THEN⓪*initExpr (fact, RefType (item), register);⓪*EXCL (freeRegs, reg);⓪*UseReg (item);⓪*fact.exprReg:= reg;⓪(ELSE⓪*IF global IN fl THEN⓪,initMemExpr (fact, RefType (item), absRef, ODD (VarAddress (item))⓪O(*$? OldByteOrder: OR TRUE *) );⓪*ELSE⓪,(* local *)⓪,initIndir (fact, VarAddress (item), FALSE)⓪*END⓪(END;⓪(⓪(IF NOT (global IN fl) & (indirVar IN fl) THEN⓪*(*$? Safety: assert (IsInMem (item));*)⓪,(*~~~ könnte man auch zulassen mit ein⓪2wenig aufwand, dann aber 'willBeRead' berücksichtigen*)⓪*IF isOpenArray (fact.item) THEN⓪,IF NOT bitInOptions (30) (* ^ *) THEN⓪.fact.mayBeOdd:= TRUE⓪,END⓪*ELSE⓪,loadIndir (fact, 0, NOT bitInOptions (30) (* ^ *))⓪*END;⓪(END;⓪(⓪&END;⓪&⓪&fact.varItem:= item;⓪&fact.readOnly:= refVar IN fl;⓪&fact.regVar:= IsRegVar (item);⓪&⓪&(*⓪'* Reg-Var, falls sie noch im Mem liegt, in ihr Register laden,⓪'* falls nicht Assignment darauf erfolgen soll.⓪'*)⓪&IF loadValue THEN⓪(loadRegVar (fact, reg)⓪&END;⓪$END getVar;⓪ ⓪ (*$D-*)⓪ ⓪"PROCEDURE getRecElem (VAR fact: ExprDesc);⓪$(* bei WITH-Scope *)⓪$VAR withPtr: ExprDesc; varItem: PtrItem; ofs: LONGINT;⓪$BEGIN⓪&varItem:= CurrentSymbol.item;⓪&getDisplay (Tiefe, withPtr); (* hole WITH-Expr *)⓪&ofs:= TypeLength (CurrentSymbol.item);⓪&(* Record-Elems können nicht in einem Reg stehen! Schon, weil gar⓪'* kein Platz für die nötigen Informationen dazu reserviert ist. *)⓪&IF withPtr.kind # register THEN⓪((*$? Safety: assert (withPtr.kind = stack);*)⓪(IF GlobalA7Hidden THEN⓪*(*!!! das sollte mal gelöst werden.⓪+* z.b, indem der gerettete A7 auf dem Stack in ein temp. Reg⓪+* geladen wird (steht in 'stacks.help') *)⓪*BadId:= 'keinen WITH-Zugriff durchführen!';⓪*SyntaxError (rTmpRs)⓪(END;⓪(initExpr (fact, RefType (CurrentSymbol.item), register);⓪(fact.exprReg := A7;⓪((*$? Safety: assert (withPtr.stackPtr # 0L);*)⓪(makeIndir (fact, withPtr.stackPtr - A7Offset, FALSE);⓪(loadIndir (fact, ofs, ODD (ofs));⓪(fact.readOnly:= withPtr.readOnly;⓪&ELSE⓪(fact:= withPtr;⓪(makeIndir (fact, ofs, ODD (ofs));⓪(fact.item:= RefType (CurrentSymbol.item)⓪&END;⓪&fact.varItem:= 20L; (* damit ggf. Buserror ausgelöst wird *)⓪$END getRecElem;⓪ ⓪"VAR fact: ExprDesc; newtype: PtrItem;⓪ ⓪"TYPE DAS = SET OF DesigAccesses;⓪ ⓪"BEGIN (* designator *)⓪$willBeRead:= access IN DAS {readDesig, modifyDesig};⓪$willBeWritten:= access IN DAS {setDesig, modifyDesig, varDesig};⓪$IF extendedSyntax ()⓪$AND ( (ORD (CurrentSymbol.typ) = 36) &⓪+(StdProcNo (CurrentSymbol.item) = 104 (* CAST *) )⓪)OR (typeDesc IN CurrentSymbol.flags) ) THEN⓪&IF (typeDesc IN CurrentSymbol.flags) THEN⓪((* Type-Transfer *)⓪(newtype:= CurrentSymbol.item;⓪(GetLparen;⓪&ELSE⓪((* CAST *)⓪(GetLparen;⓪(GetSymbol;⓪(IF NOT (typeDesc IN CurrentSymbol.flags) THEN SyntaxError (rTyDXp) END;⓪(newtype:= CurrentSymbol.item;⓪(GetComma;⓪&END;⓪&GetSymbol;⓪&designator (access, loadRegToMemory, errNo); (* Rekursion! *)⓪&PopExpr (fact);⓪&IF Size (fact) # TypeLength (newtype) THEN SyntaxError (rConv) END;⓪&fact.item:= newtype;⓪&checkSet (fact);⓪&GetRparen;⓪$ELSE⓪&IF NOT (userDef IN CurrentSymbol.flags) THEN⓪(SyntaxError (errNo)⓪&ELSIF ORD (CurrentSymbol.typ) = 17 THEN⓪(getVar (fact)⓪&ELSIF ORD (CurrentSymbol.typ) = 14 (* Record-Elem *) THEN⓪(getRecElem (fact)⓪&ELSE⓪(SyntaxError (errNo)⓪&END;⓪&GetSymbol;⓪$END;⓪$desigAccess (fact, FALSE);⓪$checkSet (fact);⓪$IF willBeWritten THEN⓪&(* Abfrage muß *nach* dem desigAccess-Aufruf stehen: *)⓪&IF (access # varDesig) OR warningsActive () THEN⓪(IF fact.readOnly THEN SyntaxError (rRdOnl) END;⓪&END⓪$END;⓪$PushExpr (fact)⓪"END designator;⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ ⓪ PROCEDURE initProcExpr (VAR expr: ExprDesc; item: PtrItem; tiefe: CARDINAL);⓪"BEGIN⓪$IF global IN ItemFlag (item) THEN⓪&initMemExpr (expr, item, immRef, FALSE);⓪$ELSE⓪&initMemExpr (expr, item, relConst, FALSE);⓪&(*⓪'* 'immRef' muß verwendet werden, weil proc in Expr als Konst.⓪'* angesprochen werden muß. Bei einem Aufruf sorgt 'call' dann ggf.⓪'* für eine Wandlung nach 'absRef'.⓪'* Eigentlich müßte passend dazu auch eine Art Konstante f. relative⓪'* Procs eingetragen werden, damit bei einer Bestimmung der Adr.⓪'* der Proc dann ihre Adr. mit "LEA ofs(PC)" geladen wird. Leider⓪'* klappt das aber nicht, weil ja 'loadReg' dazu verwendet wird und⓪'* dort ein 'MOVE.L' erzeugt würde, und es dafür keine Konst-<ea>⓪'* f. rel-pc gibt.⓪'* Deshalb wird mit der virtuellen Adressierung 'relConst' gearbeitet,⓪'* die dann im Falle des Ladens der Konstante übersetzt werden muß⓪'* nach 'pcRel' mit LEA. Dies kommt z.Zt. aber gar nicht vor.⓪'*)⓪$END;⓪$expr.varItem:= item;⓪$expr.tiefe:= tiefe⓪"END initProcExpr;⓪ ⓪ ⓪ TYPE RegState = RECORD⓪2regs: RegSet;⓪0END;⓪ ⓪ PROCEDURE SaveRegState (VAR save: RegState);⓪"BEGIN⓪$WITH save DO⓪®s:= freeRegs;⓪$END⓪"END SaveRegState;⓪ ⓪ PROCEDURE RestoreRegState (VAR save: RegState);⓪"BEGIN⓪$WITH save DO⓪&freeRegs:= regs;⓪$END⓪"END RestoreRegState;⓪ ⓪ MODULE fold;⓪ ⓪ (*⓪!* dieses lokale Modul dient ausschließlich dazu, die Funktion⓪!* 'constantFold' bereitzustellen.⓪!*)⓪ ⓪"IMPORT Operator, ExprDesc, BS, initExpr, TypeLength, BoolPtr, PtrSet,⓪)WORD, PtrFullSet, rOpTyp, SyntaxError, inZZ, ItemNo, PushExpr,⓪)SuppressCode, toZZ, addZZ, subZZ, divZZ, mulZZ, modZZ, ExprKind,⓪)cutConst, Size, dropConstantFromTree, OpSet, CodePtr, SetCodePtr,⓪)getBounds, RefType, ZZ, nullZZ, posZZ, cmpZZ, lrToSys, srToDest,⓪)ItemSet, srToSys, lrToDest, Safety, FoldingConst, expandToZZ,⓪)reduceConstant, ADDRESS, ADR, CompileWithOldCompiler, assert;⓪ ⓪ ⓪"EXPORT constantFold;⓪ ⓪ ⓪"TYPE SetOp = PROCEDURE (VAR BS, BS, BS);⓪ ⓪"VAR true: BOOLEAN;⓪&dest: ExprDesc;⓪ ⓪"PROCEDURE setAnd (VAR d: BS; l, r: BS);⓪$BEGIN⓪&d:= l * r;⓪$END setAnd;⓪ ⓪"PROCEDURE setOr (VAR d: BS; l, r: BS);⓪$BEGIN⓪&d:= l + r;⓪$END setOr;⓪ ⓪"PROCEDURE setXOr (VAR d: BS; l, r: BS);⓪$BEGIN⓪&d:= l / r;⓪$END setXOr;⓪ ⓪"PROCEDURE setDiff (VAR d: BS; l, r: BS);⓪$BEGIN⓪&d:= l - r;⓪$END setDiff;⓪ ⓪"PROCEDURE setEq (VAR d: BS; l, r: BS);⓪$BEGIN⓪&true:= true AND (l = r)⓪$END setEq;⓪ ⓪"PROCEDURE setLe (VAR d: BS; l, r: BS);⓪$BEGIN⓪&true:= true AND (l <= r)⓪$END setLe;⓪ ⓪"PROCEDURE setGe (VAR d: BS; l, r: BS);⓪$BEGIN⓪&true:= true AND (l >= r)⓪$END setGe;⓪ ⓪"PROCEDURE constantFold (op: Operator; VAR left, right: ExprDesc);⓪ ⓪$PROCEDURE bigOp (op: SetOp);⓪&VAR i: CARDINAL; destSet, leftSet, rightSet: PtrSet;⓪&BEGIN⓪(destSet:= dest.constAddr + dest.constOfs;⓪(leftSet:= left.constAddr + left.constOfs;⓪(rightSet:= right.constAddr + right.constOfs;⓪(IF NOT SuppressCode THEN⓪*FOR i:= 0 TO SHORT (TypeLength (left.item)) - 1 DO⓪,op (destSet^, leftSet^, rightSet^);⓪,INC (destSet);⓪,INC (leftSet);⓪,INC (rightSet)⓪*END⓪(END⓪&END bigOp;⓪ ⓪$PROCEDURE makeBool (true: BOOLEAN);⓪&BEGIN⓪(initExpr (dest, BoolPtr, constant);⓪(dest.exprConst.w:= WORD (true)⓪&END makeBool;⓪ ⓪$PROCEDURE inSet (setaddr: ADDRESS);⓪&VAR rightSet: PtrSet; n: CARDINAL; lo, hi: ZZ;⓪&BEGIN⓪(getBounds (RefType (right.item), lo, hi);⓪(IF NOT SuppressCode & inZZ (left.exprConst.zz, lo, hi) THEN⓪*(*$? Safety: assert (right.typeChecked);*)⓪*IF NOT right.zerobased THEN⓪,subZZ (left.exprConst.zz, lo);⓪*END;⓪*n:= left.exprConst.zz.c DIV 8;⓪*IF right.regset THEN⓪,n:= SHORT (Size (right)) - 1 - n⓪*END;⓪*rightSet:= setaddr + LONG (n);⓪*makeBool (left.exprConst.zz.c MOD 8 IN rightSet^)⓪(ELSE⓪*makeBool (FALSE)⓪(END⓪&END inSet;⓪ ⓪$VAR r1, r2: LONGREAL; s1, s2: REAL; itemNo: CARDINAL;⓪(rightIsLast: BOOLEAN;⓪ ⓪$BEGIN (* constantFold *)⓪&FoldingConst:= TRUE;⓪&itemNo:= ItemNo (right.item);⓪&CASE itemNo OF⓪&| 5, 45: (* SET *)⓪*IF right.kind = constRef THEN⓪,(* zuerst einmal beide Konstanten in DATA-Puffer *⓪-* legen, weil Reihenfolge im Tree anders ist. *)⓪,IF op # in THEN⓪.(*$? Safety: assert (left.kind = constRef); *)⓪.IF left.constHead = NIL THEN dropConstantFromTree (left) END;⓪,END;⓪,IF right.constHead = NIL THEN dropConstantFromTree (right) END;⓪,(* Es kann nun sein, daß 'right' vor 'left' im Speicher liegt.⓪-* Das passiert, wenn 'right' eine anonyme Konst und 'left' eine⓪-* aus dem Tree ist. Aus diesem Grund muß immer der im DATA-Puffer⓪-* zuerst kommende Wert als 'dest' verwendet werden. *)⓪,rightIsLast:= right.constHead > left.constHead;⓪,IF rightIsLast THEN dest:= left; ELSE dest:= right; END;⓪,CASE op OF⓪,| mul: bigOp (setAnd);⓪,| rdiv:bigOp (setXOr);⓪,| add: bigOp (setOr);⓪,| sub: bigOp (setDiff);⓪,| eq,⓪.ne: true:= TRUE;⓪3bigOp (setEq);⓪3IF op = ne THEN true:= NOT true END;⓪3makeBool (true);⓪,| le: true:= TRUE;⓪3bigOp (setLe);⓪3makeBool (true);⓪,| ge: true:= TRUE;⓪3bigOp (setGe);⓪3makeBool (true);⓪,| in: inSet (right.constAddr + right.constOfs)⓪,ELSE⓪.SyntaxError (rOpTyp)⓪,END;⓪,IF rightIsLast THEN⓪.cutConst (left);⓪.IF op # in THEN cutConst (right) END⓪,ELSE⓪.cutConst (right);⓪.IF op # in THEN cutConst (left) END⓪,END;⓪,IF dest.constOfs # 0 THEN reduceConstant (dest); END;⓪*ELSE (* IF right.kind = constRef... *)⓪,(*$? Safety: assert (left.kind = constant); *)⓪,dest:= left;⓪,CASE op OF⓪,| add: dest.exprConst.ws:= left.exprConst.ws + right.exprConst.ws⓪,| sub: dest.exprConst.ws:= left.exprConst.ws - right.exprConst.ws⓪,| mul: dest.exprConst.ws:= left.exprConst.ws * right.exprConst.ws⓪,| rdiv: dest.exprConst.ws:= left.exprConst.ws / right.exprConst.ws⓪,| in: inSet (ADR (right.exprConst.b)+1L - Size(right));⓪,| eq: makeBool (left.exprConst.ws = right.exprConst.ws)⓪,| ne: makeBool (left.exprConst.ws # right.exprConst.ws)⓪,| ge: makeBool (left.exprConst.ws >= right.exprConst.ws)⓪,| le: makeBool (left.exprConst.ws <= right.exprConst.ws)⓪,ELSE⓪.SyntaxError (rOpTyp)⓪,END⓪*END;⓪*PushExpr (dest)⓪&| 2: (* RR/LONGREAL *)⓪*dest:= left;⓪*r1:= lrToSys (left.exprConst.rr);⓪*r2:= lrToSys (right.exprConst.rr);⓪*CASE op OF⓪*| add: r1:= r1 + r2⓪*| sub: r1:= r1 - r2⓪*| mul: r1:= r1 * r2⓪*| rdiv: r1:= r1 / r2⓪*| eq: makeBool (r1 = r2)⓪*| ne: makeBool (r1 # r2)⓪*| ge: makeBool (r1 >= r2)⓪*| le: makeBool (r1 <= r2)⓪*| gt: makeBool (r1 > r2)⓪*| lt: makeBool (r1 < r2)⓪*ELSE⓪,SyntaxError (rOpTyp)⓪*END;⓪*IF op < eq THEN⓪,dest.exprConst.rr:= lrToDest (r1);⓪*END;⓪*PushExpr (dest)⓪&| 40: (* REAL *)⓪*dest:= left;⓪*s1:= srToSys (left.exprConst.sr);⓪*s2:= srToSys (right.exprConst.sr);⓪*CASE op OF⓪*| add: s1:= s1 + s2⓪*| sub: s1:= s1 - s2⓪*| mul: s1:= s1 * s2⓪*| rdiv: s1:= s1 / s2⓪*| eq: makeBool (s1 = s2)⓪*| ne: makeBool (s1 # s2)⓪*| ge: makeBool (s1 >= s2)⓪*| le: makeBool (s1 <= s2)⓪*| gt: makeBool (s1 > s2)⓪*| lt: makeBool (s1 < s2)⓪*ELSE⓪,SyntaxError (rOpTyp)⓪*END;⓪*IF op < eq THEN⓪,dest.exprConst.sr:= srToDest (s1);⓪*END;⓪*PushExpr (dest)⓪&| 1,22,30,4, (* 32 Bit INTEGER/CARDINAL/BOTH/ZZ *)⓪(23, 20, (* ADDRESS, Pointer *)⓪(33, 34, 35, (* 16 Bit INTEGER/CARDINAL *)⓪(3, 24, 9: (* CHAR, BOOLEAN, Enum *)⓪*(*!!! müssten hier nicht alle skalaren erlaubt sein und dann⓪+* nur, wie bei relops mit vars, bestimmte typen nur auf '#' & '='⓪+* zulassen?!⓪+* >>> folgende Abfrage ist sicher noch nicht vollständig!⓪+* besser: Tabelle verwenden, damit auch ADDRESS+ADDRESS,⓪+* aber nicht ADDRESS=ADDRESS und nicht ADDRESS+LONGCARD⓪+* verboten werden! *)⓪*IF (itemNo IN ItemSet {3,24,9}) & (op IN OpSet {add,sub,mul,div,mod})⓪*OR (itemNo = 20) & NOT (op IN OpSet {eq, ne}) THEN⓪,SyntaxError (rOpTyp)⓪*END;⓪*(* Werte zu ZZ-Typen erweitern, damit 'over'-Flag stimmt *)⓪*expandToZZ (itemNo, left.exprConst.zz);⓪*expandToZZ (itemNo, right.exprConst.zz);⓪*CASE op OF⓪*| add: addZZ (left.exprConst.zz, right.exprConst.zz)⓪*| sub: subZZ (left.exprConst.zz, right.exprConst.zz)⓪*| mul: mulZZ (left.exprConst.zz, right.exprConst.zz)⓪*| div: divZZ (left.exprConst.zz, right.exprConst.zz)⓪*| mod: modZZ (left.exprConst.zz, right.exprConst.zz)⓪*| eq, ne, ge, le, gt, lt:⓪,subZZ (left.exprConst.zz, right.exprConst.zz);⓪,WITH left.exprConst DO⓪.CASE op OF⓪.| eq: makeBool (nullZZ (zz))⓪.| ne: makeBool (NOT nullZZ (zz))⓪.| ge: makeBool (posZZ (zz))⓪.| lt: makeBool (NOT posZZ (zz))⓪.| le: makeBool (nullZZ (zz) OR NOT posZZ (zz))⓪.| gt: makeBool (NOT nullZZ (zz) & posZZ (zz))⓪.END⓪,END;⓪,left:= dest⓪*ELSE⓪,SyntaxError (rOpTyp)⓪*END;⓪*PushExpr (left)⓪&ELSE⓪*SyntaxError (rOpTyp)⓪&END;⓪&FoldingConst:= FALSE;⓪$END constantFold;⓪ ⓪"END fold;⓪ ⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ PROCEDURE checkDivisor (VAR expr: ExprDesc);⓪"BEGIN⓪$IF expr.kind = constant THEN⓪&IF nullZZ (expr.exprConst.zz) THEN SyntaxError (rDvNul) END⓪$ELSE⓪&IF rangeCheckActive () THEN⓪(IF (expr.kind = register) & (expr.exprReg IN anyDataReg) THEN⓪*(* TST expr, um Flags zu setzen *)⓪*gena (TST, expr, 0)⓪(ELSE⓪*loadReg (expr, anyDataReg);⓪(END;⓪(gen (Bcc + mapCC (ne, FALSE, FALSE) + 4);⓪(genTrap (DivByZeroTrap)⓪&END⓪$END⓪"END checkDivisor;⓪"⓪ PROCEDURE varMul (op: Operator; left, right: ExprDesc;⓪2chkOver: BOOLEAN; resultType: PtrItem);⓪ ⓪"PROCEDURE opWTo (op: Operator; VAR left, right: ExprDesc);⓪$VAR opcode: CARDINAL; signed: BOOLEAN;⓪$BEGIN⓪&signed:= signedType (resultType);⓪&IF op = mul THEN⓪(IF inDataReg (right) THEN swapExpr (right, left) END;⓪(IF signed THEN opcode:= MULS ELSE opcode:= MULU END;⓪(loadReg (left, dataRegs)⓪&ELSE⓪(IF signed THEN opcode:= DIVS ELSE opcode:= DIVU END;⓪(checkDivisor (right);⓪(loadRegExt (left, dataRegs, 4, FALSE)⓪&END;⓪&noDataAccess (right);⓪&genar (opcode, right, left.exprReg);⓪&restoreStack (right);⓪&IF (op = mul) & chkOver THEN checkMulOverflow (left) END;⓪&IF op = mod THEN genr (SWAP, left.exprReg) END;⓪&deallocRegs (right);⓪&left.item:= resultType;⓪&PushExpr (left)⓪$END opWTo;⓪"⓪"PROCEDURE opLTo (op: Operator; VAR left, right: ExprDesc);⓪$VAR pn: CARDINAL; r2: RegType; signed: BOOLEAN; regs: RegSet;⓪$BEGIN⓪&signed:= signedType (resultType);⓪&IF op = mul THEN⓪(IF signed THEN pn:= IMLL ELSE pn:= CMLL END⓪&ELSIF op = div THEN⓪(IF signed THEN pn:= IDVL ELSE pn:= CDVL END⓪&ELSIF op = mod THEN⓪(IF signed THEN pn:= IMDL ELSE pn:= CMDL END⓪&ELSE⓪(SyntaxError (rOpTyp)⓪&END;⓪&runtimeVarMul (left, right, op = mul, pn);⓪&IF (op = mul) & chkOver THEN checkOverflow (resultType) END;⓪&left.item:= resultType;⓪&PushExpr (left)⓪$END opLTo;⓪ ⓪"BEGIN⓪$(*$? Safety: assert (Size (left) = Size (right));*)⓪$IF isReal (resultType) THEN⓪&realOp (op, right, left)⓪$ELSIF (TypeLength (resultType) = 2L) THEN⓪&(*$? Safety: assert ((Size (left) = 2L));*)⓪&opWTo (op, left, right)⓪$ELSE⓪&(*$? Safety: assert (Size (right) = 4L);*)⓪&opLTo (op, left, right)⓪$END⓪"END varMul;⓪ ⓪ ⓪ PROCEDURE funcCall;⓪"VAR leftOnA3: LONGCARD; type: PtrItem; fact: ExprDesc;⓪&rtnRegNo: RegType; cdecl, rtnReg: BOOLEAN;⓪"BEGIN⓪$IF InConstExpr THEN SyntaxError (rConXp) END;⓪$LookExpr (fact);⓪$type:= fact.item;⓪$IF NOT isProc (type) THEN SyntaxError (rNoPrc) END;⓪$IF ItemNo (type) = 44 THEN⓪&(* bei Aufruf einer Proc m. Frame-Ptr muß der Ptr auf die Parm-Kette⓪'* erst geholt werden *)⓪&type:= RefType (type)⓪$END;⓪$cdecl:= parmA7 IN ItemFlag (type);⓪$rtnReg:= rtnD0 IN ItemFlag (type);⓪$type:= ElementType (type);⓪$IF type = NIL (* Proc, keine Funktion *) THEN SyntaxError (rNotFn) END;⓪$IF ItemNo (type) = 0 (* zeigt auf Relay *) THEN SyntaxError (rBdRtn) END;⓪$rtnRegNo:= D0;⓪$IF cdecl THEN⓪&IF (TypeLength (type) > 4)⓪&OR (ItemNo (type) IN ItemSet {12,13} (* RECORD, ARRAY *)) THEN⓪((* Return-Wert ist zu groß für Register. Deshalb wird nun auf dem⓪)* A7-Stack der Platz dafür reserviert und 'call' übermittelt, daß⓪)* nach Laden aller Parms ein Ptr auf diese Stack-Adr. noch auf den⓪)* A7 muß. *)⓪(initStackExpr (fact, type, A7);⓪(WITH fact DO⓪*up:= TRUE;⓪*stackedSize:= roundedUp (TypeLength (type));⓪*incReg (A7, toZZ (-INT(stackedSize), TRUE), 4);⓪(END;⓪(rtnReg:= FALSE⓪&ELSE⓪((* Rückgabe erfolgt in Register *)⓪(IF rtnReg THEN⓪*(* TC-Rückgabe: Pointer/Proc-Types/Opaques nach A0 *)⓪*IF ItemNo (type) IN ItemSet {19,20,23,8,25} THEN⓪,rtnRegNo:= A0⓪*END⓪(END;⓪(rtnReg:= TRUE⓪&END⓪$END;⓪$call (leftOnA3, cdecl & ~rtnReg, A7Offset);⓪$IF rtnReg THEN⓪&(*$? Safety: assert ((leftOnA3 = 0L) & (TypeLength (type) <= 4L));*)⓪&initExpr (fact, type, register);⓪&fact.exprReg:= allocReg (RegSet {rtnRegNo})⓪$ELSIF NOT cdecl THEN⓪&initStackExpr (fact, type, A3);⓪&fact.up:= FALSE;⓪&fact.stackedSize:= roundedUp (TypeLength (type));⓪&fact.restoreAfterUse:= leftOnA3;⓪&INC (A3Offset, fact.stackedSize);⓪$END;⓪$checkSet (fact);⓪$PushExpr (fact);⓪"END funcCall;⓪ ⓪ PROCEDURE shiftOrRotate (rotate, shiftUp: BOOLEAN;⓪9VAR expr, dest: ExprDesc);⓪"VAR opcode: CARDINAL;⓪"BEGIN⓪$IF rotate THEN⓪&IF shiftUp THEN opcode:= ROLI ELSE opcode:= RORI END⓪$ELSE⓪&IF shiftUp THEN opcode:= LSLI ELSE opcode:= LSRI END⓪$END;⓪$(*$? Safety: assert (expr.kind = constant);*)⓪$IF expr.exprConst.zz.c > 8 THEN⓪&(* Shift-Weite > 8, dann Weite ins Reg laden *)⓪&loadReg (expr, dataRegs);⓪&getDestReg (expr.exprReg, opcode);⓪&INC (opcode, $20) (* LSR # -> LSR Dn *)⓪$ELSE⓪&(* Shiftweite setzen *)⓪&INC (opcode, $200 * (expr.exprConst.zz.c MOD 8));⓪$END;⓪$getSizeAt6 (Size (dest), opcode);⓪$genr (opcode, dest.exprReg);⓪"END shiftOrRotate;⓪ ⓪ (* ----------------------------------------------------------------------- *)⓪ ⓪ FORWARD loadOnA3 (VAR expr: ExprDesc; range: ConvDesc);⓪ FORWARD hdlCall (mode: CARDINAL; type: PtrItem);⓪ ⓪ PROCEDURE hdlSetConstructor (type: PtrItem);⓪"(*⓪#* SET-Erzeugung.⓪#*⓪#* Ist das Set > 16 Byte, wird Platz im Code reserviert und dieser⓪#* gelöscht, sonst wird's im ExprDesc angelegt. Sodann werden alle⓪#* Const-Elemente im Set gesetzt.⓪#* Kommen Vars vor, wird bei der ersten Var. das Set auf den A3 bzw.⓪#* in ein Reg geladen und bei A3 wird ein Hilfs-Ptr zum Zugriff⓪#* vorbereitet. Dann werden die Vars wie bei INCL die Bits im Reg/Speicher⓪#* setzen.⓪#*)⓪"VAR base: PtrItem;⓪&lbl: Label;⓪&size: CARDINAL;⓪&elem1, elem2, set: ExprDesc;⓪&setAddr: ADDRESS;⓪&dropped, const: BOOLEAN;⓪&n: CARDINAL;⓪&lo, hi: ZZ;⓪&r2, r: RegType;⓪&⓪"PROCEDURE loadSet;⓪$VAR r: RegType;⓪$BEGIN⓪&IF (size = 1) OR set.regset THEN⓪(loadReg (set, dataRegs)⓪&ELSE⓪(r:= allocReg (RegSet{A0}); (* 'A0' ist f. 'runtimeRangeSet' nötig *)⓪(genMOVErr (A3, r, 4);⓪(loadOnA3 (set, alwaysFitting (type)); (* gen. ggf. CLR-Loop *)⓪(initMemExpr (set, set.item, d16An, FALSE);⓪(checkSet (set);⓪(set.baseReg:= r;⓪((* 'set' zeigt nun mit (An) in den Speicher *)⓪&END;⓪$END loadSet;⓪"⓪"PROCEDURE get (VAR elem: ExprDesc);⓪$VAR range: ConvDesc;⓪$BEGIN⓪&VarExpression ();⓪&PopExpr (elem);⓪&IF elem.kind # constant THEN⓪(IF const THEN⓪*loadSet;⓪*const:= FALSE⓪(END;⓪&END;⓪&checkAsnCompat (elem, base, range, rBdTyp);⓪&fitValue (elem, range);⓪$END get;⓪"⓪"PROCEDURE setConst (c: CARDINAL);⓪$VAR n: CARDINAL;⓪(pbs: POINTER TO SET OF [0..7];⓪$BEGIN⓪&n:= c DIV 8;⓪&IF set.regset THEN n:= size - 1 - n END;⓪&pbs:= setAddr + LONG (n);⓪&INCL (pbs^, c MOD 8)⓪$END setConst;⓪"⓪"BEGIN⓪$base:= RefType (type);⓪$size:= SHORT (TypeLength (type));⓪$⓪$initExpr (set, type, constant);⓪$IF size > constBufSize THEN⓪&(* Konst. wird im Data-Puffer angelegt. *)⓪&dropNewConstant (ADR(Accu)(*dummy-Adr*), size, set); (* Platz reservieren *)⓪&setAddr:= set.constAddr;⓪&Clear (setAddr, size);⓪&dropped:= TRUE⓪$ELSE⓪&setAddr:= ADR (set.exprConst.b)+1L - LONG (size);⓪&dropped:= FALSE⓪$END;⓪$checkSet (set);⓪$⓪$const:= TRUE;⓪$GetSymbol;⓪$IF CurrentSymbol.itemNo # rbrace THEN⓪&LOOP⓪(get (elem1);⓪(getBounds (base, lo, hi);⓪(⓪(IF CurrentSymbol.itemNo = dblpoint THEN⓪*⓪*GetSymbol;⓪*get (elem2);⓪*⓪*IF set.kind # register THEN⓪,IF (elem1.kind = constant) & (elem2.kind = constant)⓪,& (const OR dropped) THEN⓪.IF NOT set.zerobased THEN⓪0subZZ (elem1.exprConst.zz, lo);⓪0subZZ (elem2.exprConst.zz, lo)⓪.END;⓪.FOR n:= elem1.exprConst.zz.c TO elem2.exprConst.zz.c DO⓪0setConst (n)⓪.END;⓪,ELSE⓪.(* wir haben ein großes Set - Bits durch Runtime setzen *)⓪.runtimeRangeSet (elem1, elem2, set, lo);⓪,END;⓪,deallocRegs (elem2);⓪,deallocRegs (elem1);⓪*ELSE⓪,loadReg (elem2, anyDataReg);⓪,loadReg (elem1, anyDataReg);⓪,(* prüfen, ob lo <= hi: sonst keine Bits setzen *)⓪,genar (CMP, elem1, elem2.exprReg);⓪,genbccs (mapCC (cc, FALSE, TRUE), lbl);⓪,IF NOT set.zerobased THEN⓪.negZZ (lo);⓪.loadReg (elem2, dataRegs);⓪.loadReg (elem1, dataRegs);⓪.incReg (elem2.exprReg, lo, 2);⓪.incReg (elem1.exprReg, lo, 2)⓪,END;⓪,PushExpr (set);⓪,r2:= allocReg (dataRegs);⓪,genMOVErr (elem2.exprReg, r2, 2);⓪,incReg (r2, toZZ (1L, FALSE), 2);⓪,genar (SUB, elem1, elem2.exprReg);⓪,deallocRegs (elem1);⓪,IF size = 1 THEN⓪.hi:= toZZ ($80L,FALSE)⓪,ELSIF size = 2 THEN⓪.hi:= toZZ ($8000L,FALSE)⓪,ELSE⓪.hi:= toZZ ($80000000,FALSE)⓪,END;⓪,r:= allocReg (dataRegs);⓪,genMOVEir (hi, size, r);⓪,gen (ASR + $200*elem2.exprReg + sizeAt6 (size) + r);⓪,gen (ROL + $200*r2 + sizeAt6 (size) + r);⓪,deallocReg (r2);⓪,PopExpr (set);⓪,deallocRegs (elem2);⓪,loadReg (set, anyDataReg);⓪,genra (OR_, r, set); (* OR r,set.exprReg *)⓪,deallocReg (r);⓪,ToHere (lbl)⓪*END⓪*⓪(ELSE (* IF CurrentSymbol.itemNo = dblpoint ... *)⓪*⓪*IF set.kind = register THEN⓪,IF elem1.kind = constant THEN⓪.(* wenn Set ins Reg geladen wurde, dann muß nun jedes Elem⓪/* einzeln mit BSET # gesetzt werden *)⓪.IF NOT set.zerobased THEN subZZ (elem1.exprConst.zz, lo) END;⓪.genia (BSETI, elem1.exprConst.zz.c, set, -1);⓪,ELSE⓪.loadReg (elem1, anyDataReg);⓪.IF NOT set.zerobased THEN⓪0negZZ (lo);⓪0loadReg (elem1, dataRegs);⓪0incReg (elem1.exprReg, lo, 2)⓪.END;⓪.genar (BSET, set, elem1.exprReg);⓪,END⓪*ELSIF const THEN⓪,IF NOT set.zerobased THEN subZZ (elem1.exprConst.zz, lo) END;⓪,setConst (elem1.exprConst.zz.c);⓪*ELSE⓪,runtimeElemSet (elem1, set, add, lo);⓪,(*$? Safety: assert (set.kind = register);*)⓪,changeToIndir (set, set.exprReg);⓪*END;⓪*deallocRegs (elem1);⓪*⓪(END;⓪(⓪(IF CurrentSymbol.itemNo = rbrace THEN EXIT END;⓪(IF CurrentSymbol.itemNo # comma THEN SyntaxError (rBrcXp) END;⓪(GetSymbol;⓪&END;⓪$END;⓪$⓪$IF NOT const AND (set.kind # register) THEN⓪&(* wir hatten (A0)-Adressierung. Nun wieder als (A3)-Stack definiern*)⓪&(*$? Safety: assert (set.kind = memory);*)⓪&deallocRegs (set);⓪&changeToStack (set);⓪&WITH set DO⓪(stackReg:= A3;⓪(up:= FALSE;⓪(stackedSize:= size⓪&END⓪$END;⓪$PushExpr (set)⓪"END hdlSetConstructor;⓪ ⓪ PROCEDURE handleDebug (VAR expr: ExprDesc);⓪"⓪"VAR⓪$dest, help: ExprDesc;⓪$l, oldOffs: LONGINT;⓪$resultType: PtrItem;⓪"⓪"PROCEDURE pushExpr (ref: BOOLEAN);⓪$VAR keep: BOOLEAN;⓪(savedState: RegState;⓪$BEGIN⓪&keep:= FALSE;⓪&WITH expr DO⓪(IF (kind = stack) & (stackReg = A3) THEN⓪*(* 'loadOnA3' kopiert nicht, wenn Datum schon auf Stack steht *)⓪*help:= expr;⓪*WITH help DO⓪,l:= stackedSize;⓪,changeToIndir (help, stackReg);⓪,disp:= -l⓪*END;⓪*IF item = RealPtr THEN⓪,(* Wenn Datum größer als 4 Byte (LONGREAL), dann kann allerdings⓪-* auch nicht mit loadOnA3 gearbeitet werden, ohne ein Zusatz-Reg⓪-* zu verwenden. Daher wird in diesem Fall eine Sonderbehandlung⓪-* gemacht: 2 mal MOVE.L -8(A3),(A3)+ *)⓪,expr.up:= TRUE;⓪,genMOVEaa (help, expr, 4); (* MOVE.L -8(A3),(A3)+ *)⓪,genMOVEaa (help, expr, 4); (* MOVE.L -8(A3),(A3)+ *)⓪,expr.up:= FALSE;⓪,RETURN⓪*END;⓪(ELSIF (kind # constant)⓪(AND ( (kind # memory) OR (mode # immRef) )⓪(AND (kind # register) THEN⓪*copyRef (expr, help);⓪(ELSE⓪*help:= expr;⓪*reduceZZ (help);⓪*keep:= TRUE; (* Register nicht freigeben! *)⓪(END;⓪&END;⓪&SaveRegState (savedState);⓪&IF ref THEN loadAddress (help) END;⓪&loadOnA3 (help, alwaysFitting (help.item));⓪&IF keep THEN RestoreRegState (savedState) END;⓪$END pushExpr;⓪ ⓪"BEGIN⓪$(*⓪%* Debug-Information ablegen.⓪%* Das wird nu so kodiert:⓪%* Expr als Value-Parm auf A3-Stack⓪%* (bei Strings wird lediglich Pointer und High-Wert übergeben)⓪%* TRAP #5⓪%* DC.W Item-No (nur Scalare, Reals & Strings)⓪%*)⓪$WITH expr DO⓪&IF (scalar IN ItemFlag (item))⓪&OR isReal (item)⓪&OR isStringVar (item)⓪&OR (ItemNo (item) = 32) & (ItemNo (OpenArrayType (item)) = 3) THEN⓪(oldOffs:= A3Offset;⓪(IF isStringVar (item)⓪(OR (ItemNo (item) = 32) & (ItemNo (OpenArrayType (item)) = 3) THEN⓪*resultType:= HostType (item);⓪*IF ItemNo (item) = 32 THEN (* ARRAY OF CHAR *)⓪,initStackExpr (dest, NIL, A3);⓪,copyRef (expr, help);⓪,changeToStack (help);⓪,copy (help, dest, 6, FALSE);⓪,deallocRegs (help)⓪*ELSE (* String-Var *)⓪,pushExpr (TRUE);⓪,initConstExpr (help, 2, toZZ (TypeLength (resultType)-1L, FALSE));⓪,loadOnA3 (help, alwaysFitting (help.item));⓪*END;⓪*gen (TRAP + DebugTrapNo);⓪*gen (CARDINAL(27));⓪(ELSE⓪*pushExpr (FALSE);⓪*gen (TRAP + DebugTrapNo);⓪*gen (ItemNo (HostType (help.item)));⓪(END;⓪(A3Offset:= oldOffs;⓪&END;⓪$END;⓪"END handleDebug;⓪ ⓪ PROCEDURE expression (condJmp: BOOLEAN;⓪6VAR false, true, falseNot, trueNot: Labels);⓪"(*⓪#* Beim Aufruf müssen alle sonstigen ExprDesc auf dem Stack stehen, da⓪#* sonst der Spill-Mechanismus nicht funktionieren kann!⓪#*)⓪ ⓪"(*⓪#* condJmp: TRUE -> Gen. Bcc.W zu false/true-Targets, welche dann vom⓪#* Aufrufer deklariert werden, trueNot wird nicht benutzt.⓪#* false/true/trueNot werden auch bei BOOLEAN-Expressions verwendet,⓪#* wenn condJmp FALSE ist. Dann steht 'true' für das Label, an dem der Wert⓪#* TRUE oder FALSE korrekt im Register steht, falls 'trueNot' Referenzen⓪#* enthält, steht dort der invertierte Wert im Register, es muß also⓪#* noch ein NOT (EORI #1,Dn) generiert werden. Der Wert 'not' der Expr⓪#* zeigt an, ob die noch ungelöste Expr auch invertiert werden muß.⓪#*)⓪ ⓪ ⓪"PROCEDURE setOp (op: Operator; VAR left, right: ExprDesc; type: PtrItem);⓪$VAR opcode: CARDINAL; size: CARDINAL;⓪(leftOnA3, rightOnA3, destOnA3: BOOLEAN;⓪$BEGIN⓪&size:= SHORT (TypeLength (type));⓪&(*$? Safety: assert (left.typeChecked);*)⓪&IF left.regset THEN⓪(prepareStackForLoad (right);⓪(IF bothOnStack (left, right) THEN⓪*loadReg (right, dataRegs);⓪*restoreStack (right);⓪(END;⓪(reloadPtr (left);⓪(prepareStackForLoad (left);⓪(⓪(CASE op OF⓪(| le,⓪*sub: loadReg (right, dataRegs);⓪/restoreStack (right);⓪/gena (NOT_, right, 0);⓪/noDataAccess (left);⓪/opcode:= AND_⓪(| ge: loadReg (left, dataRegs);⓪/restoreStack (left);⓪/gena (NOT_, left, 0);⓪/swapExpr (left, right);⓪/noDataAccess (left);⓪/opcode:= AND_⓪(| eq,⓪*ne: opcode:= CMP⓪(| add: noDataAccess (left);⓪/opcode:= OR_⓪(| mul: noDataAccess (left);⓪/opcode:= AND_⓪(| rdiv:(*~~~ EORI bei const möglich *)⓪/loadReg (left, dataRegs);⓪/opcode:= EOR⓪(ELSE⓪*SyntaxError (rOpTyp)⓪(END;⓪(loadReg (right, dataRegs);⓪(restoreStack (right);⓪(genar (opcode, left, right.exprReg);⓪(IF opcode = EOR THEN⓪*(*⓪+* Die Ops müssen vertauscht werden, weil das Ziel bei EOR⓪+* in den Bits 0..5, das Source-Reg in 9..11 liegt!⓪+*)⓪*swapExpr (left, right);⓪(END;⓪(restoreStack (left);⓪(deallocRegs (left);⓪(⓪(IF op IN OpSet {eq, ne, le, ge} THEN⓪*deallocRegs (right);⓪*WITH right DO⓪,item:= BoolPtr;⓪,kind:= condFlags;⓪,fpuFlags:= FALSE;⓪,relOp:= eq;⓪,signed:= FALSE;⓪,not:= (op = ne)⓪*END⓪(ELSE⓪*right.item:= type⓪(END;⓪(PushExpr (right)⓪ ⓪&ELSE⓪ ⓪(CASE op OF⓪(| add: opcode:= SSUM;⓪(| sub: opcode:= SDIF;⓪(| mul: opcode:= SAND;⓪(| rdiv:opcode:= SXOR;⓪(| le, ge, eq, ne: (* nix *)⓪(ELSE⓪*SyntaxError (rOpTyp)⓪(END;⓪((*⓪)* Die Daten in 'left' und 'right' können auf dem A3-Stack stehen.⓪)*⓪)* Bei den nicht-rel-Operationen muß auch das Ergebnis dorthin.⓪)* Daher sind dann verschiedene Fälle zu berücksichtigen:⓪)* - beide Daten stehen nicht auf dem Eval-Stack;⓪)* - das rechte Datum steht auf A3, das linke aber nicht;⓪)* - das linke Datum steht auf A3. Wenn auch das rechte dort steht,⓪)* wird es einfach abgeräumt.⓪)* Für diese drei Fälle existieren verschiedene Runtime-Funktionen⓪)* (bei '+', '-', '*' und '/').⓪)*⓪)* Bei den Relations-Ops wird der A3-Stack immer abgeräumt, es muß nur⓪)* darauf geachtet werden, daß, wenn beide Werte auf dem A3 stehen,⓪)* der Stack in der richtigen Reihenfolge abgeräumt wird.⓪)*)⓪(⓪(leftOnA3:= (left.kind = stack);⓪(rightOnA3:= (right.kind = stack);⓪((*$? Safety:⓪(IF leftOnA3 THEN assert (left.stackReg = A3) END;⓪(IF rightOnA3 THEN assert (right.stackReg = A3) END;⓪(*)⓪(reloadPtr (left);⓪(⓪(IF op IN OpSet {add, sub, mul, rdiv} THEN⓪*IF rightOnA3 THEN⓪,IF leftOnA3 THEN⓪.incReg (A3, toZZ (LONG (-INTEGER (size)), TRUE), 4);⓪.changeStackToIndir (right)⓪,ELSE⓪.INC (opcode, 4);⓪.changeStackToIndir (right);⓪.right.disp:= -INTEGER(size)⓪,END⓪*END;⓪*IF leftOnA3 THEN⓪,INC (opcode, 8);⓪,changeStackToIndir (left);⓪,left.disp:= -INTEGER(size)⓪*ELSIF NOT rightOnA3 THEN⓪,(* A3 korrigieren, denn die Routinen kopieren das Erg. aufn Stack *)⓪,updateStackOffsets (A3, TRUE, size)⓪*END;⓪*runtimeSetOp (left, right, mul, size DIV 2, opcode);⓪*deallocRegs (left);⓪*initStackExpr (left, type, A3);⓪*checkSet (left);⓪*left.up:= FALSE;⓪*left.stackedSize:= size;⓪(ELSE⓪*IF leftOnA3 OR rightOnA3 THEN⓪,incReg (A3,⓪4toZZ (LONG (-INTEGER (⓪:size * (ORD (leftOnA3) + ORD (rightOnA3)) )), TRUE),⓪44);⓪,IF leftOnA3 THEN⓪.changeStackToIndir (left);⓪,END;⓪,IF rightOnA3 THEN⓪.IF leftOnA3 THEN⓪0changeStackToIndir (right);⓪0right.disp:= size⓪.ELSE⓪0changeStackToIndir (right);⓪.END⓪,END⓪*END;⓪*IF op IN OpSet {eq, ne} THEN⓪,runtimeSetOp (left, right, eq, size DIV 2, SEQU)⓪*ELSE⓪,IF op = ge THEN swapExpr (left, right) END;⓪,runtimeSetOp (left, right, le, size DIV 2, SLEQ)⓪*END;⓪*deallocRegs (left);⓪*WITH left DO⓪,item:= BoolPtr;⓪,kind:= condFlags;⓪,fpuFlags:= FALSE;⓪,relOp:= eq;⓪,signed:= FALSE;⓪,not:= (op = ne)⓪*END⓪(END;⓪(PushExpr (left)⓪ ⓪&END;⓪$END setOp;⓪ ⓪ ⓪ ⓪"PROCEDURE factor ();⓪ ⓪$⓪$PROCEDURE cast (VAR source: ExprDesc; destType: PtrItem);⓪&(*⓪'* Wenn 'source' ein Signed Type ist⓪'* und ein expand nötig ist, wird das Vorzeichen mit erweitert!⓪'* String-Consts werden korrekt auf die Dest-Länge erweitert,⓪'* ggf. sogar verkürzt.⓪'* Ansonsten können nur unstrukturierte (skalare) Typen oder⓪'* solche mit identischer Länge gecastet werden.⓪'*)⓪&VAR sourceSize, destSize, sourceType: LONGCARD;⓪&BEGIN⓪((*$D-*)⓪(reduceZZ (source);⓪(sourceSize:= Size (source);⓪(destSize:= TypeLength (destType);⓪(sourceType:= HostType (source.item);⓪(IF (sourceSize <= 4L)⓪(AND (destSize <= 4L)⓪(AND ( (ItemNo (sourceType) IN⓪2ItemSet {1,3,8,9,21,22,24,25,26,30,33,34,35,4,38,39,41})⓪-OR (ItemNo (destType) IN⓪2ItemSet {1,3,8,9,21,22,24,25,26,30,33,34,35,4,38,39,41}) ) THEN⓪*(* dies sind alles Zahltypen, so daß die Werte immer⓪+* rechtsbündig sind. Entsprechend wird auch gecastet *)⓪*IF source.kind = constant THEN⓪,(* unbenutze Upper-Bytes des ZZ-Feldes auf Null setzen *)⓪,cutZZ (source.exprConst.zz, SHORT (destSize));⓪*ELSIF sourceSize # destSize THEN⓪,IF sourceSize < destSize THEN⓪.loadRegExt (source, anyCPUReg, SHORT (destSize), FALSE)⓪,ELSE⓪.loadReg (source, anyDataReg)⓪,END⓪*END⓪(ELSIF sourceSize # destSize THEN⓪*IF isSS (source) & isStringVar (destType) THEN⓪,terminateStringConst (source, destType);⓪,adaptStringConst (source, destType);⓪*ELSIF (ItemNo (sourceType) = 44) & (ItemNo (destType) = 19) THEN⓪,(* nix weiter tun. es wird einfach das untere longword genommen *)⓪*ELSE⓪,SyntaxError (rCast)⓪*END⓪(END;⓪((*$D-*)⓪(source.item:= destType⓪&END cast;⓪ ⓪$PROCEDURE stdFunction;⓪&⓪&VAR expr: ExprDesc;⓪*nsize: NumberSize; ntype: NumberType;⓪*range: ConvDesc;⓪*type: PtrItem;⓪*itemNo, n: CARDINAL;⓪*mask, elems: LONGCARD;⓪*lo, hi: ZZ;⓪*last: BOOLEAN;⓪*pc: POINTER TO CHAR;⓪ ⓪&PROCEDURE safeConversion (VAR expr: ExprDesc; destType: PtrItem);⓪(⓪(TYPE kinds = (wholeNumber, realNumber, noNumber);⓪(⓪(PROCEDURE getKind (t: PtrItem;⓪:VAR ns: NumberSize; VAR nt: NumberType; VAR k: kinds);⓪*BEGIN⓪,IF isNumber (t, ns, nt) THEN⓪.IF nt = realType THEN⓪0k:= realNumber⓪.ELSE⓪0k:= wholeNumber⓪.END⓪,ELSE⓪.k:= noNumber⓪,END⓪*END getKind;⓪*⓪(VAR sourceType: PtrItem;⓪,source, dest: kinds;⓪,const: BOOLEAN;⓪,dNumSize, sNumSize: NumberSize;⓪,dNumType, sNumType: NumberType;⓪ ⓪(PROCEDURE convertScalar;⓪*VAR range: ConvDesc;⓪*BEGIN⓪,getConversionDesc (sourceType, destType, range);⓪,fitValue (expr, range)⓪*END convertScalar;⓪ ⓪(PROCEDURE getSourceType;⓪*BEGIN⓪,sourceType:= HostType (expr.item);⓪,getKind (sourceType, sNumSize, sNumType, source);⓪*END getSourceType;⓪ ⓪(BEGIN⓪*adaptSSToChar (expr);⓪*reduceZZ (expr);⓪*IF expr.item # destType THEN⓪,const:= expr.kind = constant;⓪,getSourceType;⓪,getKind (destType, dNumSize, dNumType, dest);⓪,IF source = realNumber THEN⓪.IF dest = noNumber THEN SyntaxError (rNoCnv) END;⓪.IF dest = wholeNumber THEN⓪0(* Real nach LONGCARD/LONGINT konvertieren.⓪1* Dann weiter wie bei Conv. from LONGCARD/LONGINT *)⓪0(*$? CompileWithNewCompiler:⓪0IF const THEN⓪2WITH expr.exprConst DO⓪4IF sNumSize = real4 THEN⓪6IF dNumType = cardType THEN⓪8l:= LONGWORD (VAL (LONGCARD, srToSys (sr)))⓪6ELSE⓪8l:= LONGWORD (VAL (LONGINT, srToSys (sr)))⓪6END;⓪4ELSE⓪6IF dNumType = cardType THEN⓪8l:= LONGWORD (VAL (LONGCARD, lrToSys (rr)))⓪6ELSE⓪8l:= LONGWORD (VAL (LONGINT, lrToSys (rr)))⓪6END;⓪4END;⓪4zz.over:= FALSE⓪2END;⓪2IF dNumType = cardType THEN⓪4expr.item:= CardPtr;⓪2ELSE⓪4expr.item:= IntPtr;⓪2END;⓪0ELSE⓪0*)⓪2convertReal (expr, S2LC + ORD (dNumType = intType)⓪J+ 2 * ORD (sNumSize = real8));⓪0(*$? CompileWithNewCompiler:⓪0END;⓪0*)⓪0getSourceType;⓪0convertScalar⓪.ELSE⓪0(* Runtime: REAL -> LONGREAL oder umgekehrt *)⓪0IF const THEN⓪2IF dNumSize = real4 THEN⓪4(* SHORT () *)⓪4shortenReal (expr, rReaRg);⓪2ELSE⓪4(* LONG () *)⓪4expandReal (expr);⓪2END⓪0ELSE⓪2convertReal (expr, ORD (sNumSize = real4))⓪0END;⓪.END⓪,ELSIF (source = wholeNumber) THEN⓪.IF (dest = realNumber) THEN⓪0(*$? CompileWithNewCompiler:⓪0IF const THEN⓪2RealConstIsUsed;⓪2WITH expr.exprConst DO⓪4IF dNumSize = real4 THEN⓪6IF sNumType = intType THEN⓪8sr:= srToDest (VAL (REAL, LONGINT (l)))⓪6ELSE⓪8sr:= srToDest (VAL (REAL, LONGCARD (l)))⓪6END;⓪6zz.over:= FALSE⓪4ELSE⓪6IF sNumType = intType THEN⓪8rr:= lrToDest (VAL (LONGREAL, LONGINT (l)))⓪6ELSE⓪8rr:= lrToDest (VAL (LONGREAL, LONGCARD (l)))⓪6END⓪4END⓪2END⓪0ELSE⓪0*)⓪2convertReal (expr, LC2S + 2 * ORD (dNumSize = real8)⓪J+ ORD (sNumType = intType) )⓪0(*$? CompileWithNewCompiler:⓪0END⓪0*)⓪.ELSE⓪0convertScalar⓪.END⓪,ELSE⓪.(* enums, char, boolean *)⓪.IF dest # wholeNumber THEN SyntaxError (rNoCnv) END;⓪.convertScalar⓪,END;⓪,expr.item:= destType⓪*END⓪(END safeConversion;⓪(⓪&PROCEDURE getVarExpr;⓪(BEGIN⓪*GetSymbol;⓪*VarExpression ();⓪*PopExpr (expr);⓪*itemNo:= ItemNo (expr.item)⓪(END getVarExpr;⓪(⓪&PROCEDURE getDesig (access: DesigAccesses);⓪(BEGIN⓪*GetSymbol;⓪*designator (access, FALSE, rVarXp);⓪*PopExpr (expr)⓪(END getDesig;⓪(⓪&PROCEDURE getType;⓪(BEGIN⓪*GetSymbol;⓪*IF NOT (typeDesc IN CurrentSymbol.flags) THEN SyntaxError (rTyDXp) END;⓪*type:= CurrentSymbol.item;⓪(END getType;⓪(⓪&PROCEDURE doShiftRotate;⓪((* Subroutine zur Stack-Ersparnis *)⓪(⓪(VAR⓪*help, help2, dest: ExprDesc;⓪*shifts, bits: CARDINAL;⓪*mask: LONGCARD;⓪*lo2, hi2: ZZ;⓪*mustMask, shiftUp: BOOLEAN;⓪(⓪(BEGIN⓪*LookExpr (dest);⓪*IF (ItemNo (dest.item) # 45)⓪*OR (ItemNo (HostType (RefType (dest.item))) # 41) THEN⓪,SyntaxError (rBinXp)⓪*END;⓪*(*$? Safety: assert (dest.regset & dest.zerobased);*)⓪*ChkComma;⓪*getVarExpr;⓪*IF NOT isWholeNumber (expr.item) THEN SyntaxError (rWhNXp) END;⓪*PopExpr (dest);⓪*reloadPtr (dest);⓪*getBounds (RefType (dest.item), lo, hi);⓪*bits:= SHORT (diffZZ (hi, lo)) + 1;⓪*mustMask:= NOT nullZZ (lo)⓪5OR (cmpZZ (hi, toZZ (Size(dest)*8L-1L, FALSE)) # eq);⓪*IF expr.kind = constant THEN⓪,shiftUp:= posZZ (expr.exprConst.zz);⓪,IF NOT shiftUp THEN negZZ (expr.exprConst.zz) END;⓪,IF n = 108 (* ROTATE *) THEN⓪.(* beim Rotieren nur Faktor MOD Setbreite nehmen *)⓪.modZZ (expr.exprConst.zz, toZZ (LONG (bits), FALSE))⓪,END;⓪,IF NOT nullZZ (expr.exprConst.zz) THEN⓪.IF cmpZZ (expr.exprConst.zz,⓪8toZZ (LONG (bits), FALSE)) = lt THEN⓪0(* Wir schieben/rot. den Wert weniger als die Setbreite *)⓪0shifts:= expr.exprConst.zz.c;⓪0(*⓪1* MOVE set,D0⓪1* MOVE D0,D2 ; help2⓪1* MOVE #expr,D1⓪1* LSL/R D1,D0⓪1*)⓪0prepareStackForLoad (dest);⓪0loadReg (dest, anyDataReg);⓪0IF mustMask THEN copyRegExt (dest, help2, dataRegs, 0) END;⓪0shiftOrRotate (n=108, shiftUp, expr, dest);⓪0IF mustMask THEN⓪2(* unbenutzte Bits wiederherstellen *)⓪2lo2:= lo; hi2:= hi;⓪2IF shiftUp THEN INC (lo.c, shifts) ELSE DEC (hi.c, shifts) END;⓪2mask:= makeMask (lo.c, hi.c);⓪2IF n = 107 (* SHIFT *) THEN⓪4(*⓪5* ANDI #mask,D0⓪5*)⓪4genANDI (SHORT (Size (dest)), mask, dest.exprReg);⓪2ELSE⓪4(*⓪5* MOVE D0,D2⓪5* ANDI #mask,D0⓪5* MOVE #bits,D1⓪5* ROR/L D1,D2⓪5* ANDI #mask,D2⓪5* OR D2,D0⓪5*)⓪4PushExpr (help2);⓪4deallocRegs (expr);⓪4copyRegExt (dest, help, dataRegs, 0);⓪4genANDI (SHORT (Size (dest)), mask, dest.exprReg);⓪4initConstExpr (expr, 2, toZZ (LONG (bits), FALSE));⓪4shiftOrRotate (TRUE, NOT shiftUp, expr, help);⓪4IF shiftUp THEN⓪6hi:= lo; lo:= lo2; DEC (hi.c)⓪4ELSE⓪6lo:= hi; INC (lo.c); hi:= hi2⓪4END;⓪4genANDI (SHORT (Size (dest)), makeMask (lo.c, hi.c), help.exprReg);⓪4genar (OR_, help, dest.exprReg);⓪4deallocRegs (help);⓪4PopExpr (help2);⓪2END;⓪2(* und nun die restlichen Bits wiederherstellen:⓪3* ANDI #inverseMask(lo,hi),D2⓪3* OR D2,D0⓪3*)⓪2loadReg (help2, dataRegs);⓪2genANDI (SHORT (Size (dest)), makeInvMask (lo2.c, hi2.c), help2.exprReg);⓪2genar (OR_, help2, dest.exprReg);⓪2deallocRegs (help2);⓪0END;⓪.ELSE⓪0(* Wir schieben mehr als die Bitbreite -> Erg. ist 0 *)⓪0clearExpr (dest)⓪.END;⓪,END⓪*ELSE⓪,IF mustMask THEN⓪.SyntaxError (rNImpY) (*!!! fehlt noch *)⓪,END;⓪,safeConversion (expr, SIntPtr);⓪,IF n = 108 (* ROTATE *) THEN n:= ROTA ELSE n:= SHFT END;⓪,runtimeShiftRotate (n, dest, expr, lo, hi);⓪*END;⓪*deallocRegs (expr);⓪*expr:= dest⓪(END doShiftRotate;⓪&⓪&PROCEDURE doHigh;⓪(VAR⓪*help: ExprDesc;⓪*regs: RegSet;⓪(BEGIN⓪*(*⓪+* Jetzt wird ordentlich herumgesaut:⓪+* Es wird davon ausgegangen, daß das Open Array ein Parm/Var⓪+* ist und der Descriptor entweder x(A6) oder bei lok.⓪+* Scopes x(A0) adressiert wird. Dann wird der Array-Access⓪+* ggf. durchgeführt, um an den High-Offset zu kommen bei⓪+* mehrdim. Open Arrays (z.B: HIGH (a[0])). Dabei wird die⓪+* Codeerzeugung unterdrückt. Wenn kein Array-Index vorkam,⓪+* bleibt in 'help' der Zugriff auf den Array-Desc. erhalten,⓪+* bei einem Index dagegen beschreibt 'help' den Ptr auf das⓪+* Array. Der Ptr auf die High-Werte steht dann in help.highReg.⓪+* So kann 'deallocRegs(help)' nicht einfach so aufgerufen wer-⓪+* den, weil evtl. dann der High-Ptr (in A0) freigegeben wird.⓪+* Deshalb wird 'freeRegs' gesichert und hinterher wieder⓪+* zurückgesetzt.⓪+*)⓪*initIndir (expr, VarAddress (CurrentSymbol.item), FALSE);⓪*expr.varItem:= CurrentSymbol.item;⓪*GetSymbol;⓪*help:= expr; regs:= freeRegs;⓪*activateCodeSuppression (last);⓪*desigAccess (help, TRUE);⓪*restoreCodeSuppression (last);⓪*freeRegs:= regs;⓪*addDisp (expr, help.highOfs+4);⓪*itemNo:= ItemNo (help.item);⓪*IF itemNo = 32 THEN⓪,expr.item:= SCardPtr⓪*ELSIF itemNo = 42 THEN⓪,expr.item:= CardPtr⓪*ELSE⓪,SyntaxError (rBdHig)⓪*END⓪(END doHigh;⓪&⓪&BEGIN (* stdFunction *)⓪(n:= StdProcNo (CurrentSymbol.item);⓪(type:= CurrentSymbol.item;⓪(GetLparen;⓪(IF n < 100 THEN⓪*CASE n OF⓪ ⓪*| 1: (* ABS *)⓪/getVarExpr;⓪/expr.item:= HostType (expr.item);⓪/IF NOT isNumber (expr.item, nsize, ntype) OR (ntype = cardType) THEN⓪1SyntaxError (rIoRXp)⓪/END;⓪/IF expr.kind = constant THEN⓪1WITH expr.exprConst DO⓪3IF ntype = realType THEN⓪5IF nsize = real4 THEN SRABS (sr) ELSE LRABS (rr) END⓪3ELSE⓪5IF NOT posZZ (zz) THEN negZZ (zz) END⓪3END⓪1END⓪/ELSE⓪1IF ntype = realType THEN⓪3absReal (expr);⓪1ELSE⓪3IF (expr.kind = register) & (expr.exprReg IN dataRegs) THEN⓪5gena (TST, expr, 0);⓪3ELSE⓪5loadReg (expr, dataRegs);⓪3END;⓪3gen (Bcc + mapCC (pl, FALSE, FALSE) + 2);⓪3gena (NEG, expr, 0);⓪3(*⓪4* eigentlich ist nach Wirth & ISO der Result-Typ⓪4* gleich dem Argument-Typ. Allerdings war bei MM2⓪4* bisher das Res CARDINAL/LONGCARD. Damit beiden⓪4* gerecht wird, machen wir nun BothTyp draus:⓪4*)⓪3IF nsize = ord2 THEN⓪5expr.item:= SBothTyp⓪3ELSE⓪5expr.item:= BothTyp⓪3END⓪1END⓪/END⓪*⓪*| 2: (* ORD *)⓪/(*⓪0* nach ISO gehen nur Ordinale, wir erlauben aber auch⓪0* LONGWORD, WORD & BYTE!!⓪0*)⓪/getVarExpr;⓪/adaptSSToChar (expr);⓪/expr.item:= HostType (expr.item);⓪/IF exprSize (expr) > 2 THEN⓪1type:= CardPtr⓪/ELSE⓪1type:= SCardPtr⓪/END;⓪/IF isOrdinal (expr.item) THEN⓪1safeConversion (expr, type)⓪/ELSIF isJoker (expr.item) THEN⓪1cast (expr, type)⓪/ELSE⓪1SyntaxError (rSclXp)⓪/END⓪*⓪*| 3: (* HIGH *)⓪/GetSymbol;⓪/IF NOT (userDef IN CurrentSymbol.flags)⓪/OR (ORD (CurrentSymbol.typ) # 17) THEN⓪1SyntaxError (rBdHig)⓪/END;⓪/doHigh;⓪*⓪*| 4, (* LONG *)⓪,5: (* SHORT *)⓪/getVarExpr;⓪/IF expr.item = ZZTyp THEN⓪1(*$? Safety: assert (expr.kind = constant);*)⓪1IF n = 4 (* LONG *) THEN⓪3IF expr.exprConst.zz.l < 0L THEN⓪5expr.item:= IntPtr⓪3ELSIF expr.exprConst.zz.over THEN⓪5expr.item:= CardPtr⓪3ELSE⓪5expr.item:= BothTyp⓪3END⓪1END (* sonst bleibt's beim Alten *)⓪/ELSE⓪1type:= StdProcParms (type);⓪1expr.item:= HostType (expr.item);⓪1WHILE StdParmType (type) # expr.item DO⓪3type:= NextStdParm (type);⓪3IF type = NIL THEN SyntaxError (rParTy) END⓪1END;⓪1type:= StdParmRes (type);⓪1IF isJoker (expr.item) THEN⓪3cast (expr, type)⓪1ELSE⓪3(* hier kann 'type' auch BYTE sein! *)⓪3safeConversion (expr, type)⓪1END⓪/END⓪*⓪*| 6: (* ODD *)⓪/getVarExpr;⓪/IF NOT (scalar IN ItemFlag (expr.item)) THEN SyntaxError (rSclXp) END;⓪/IF expr.kind = constant THEN⓪1expr.exprConst.zz.over:= FALSE;⓪1expr.exprConst.w:= WORD (ODD (CARDINAL (expr.exprConst.w)));⓪1expr.exprConst.w2:= WORD (0);⓪1expr.not:= FALSE⓪/ELSE⓪1(*⓪2* Für die Odd-Bestimmung wird einfach der Wert in ein⓪2* Reg. geladen und dann mit "ANDI #1,Dn" ein Boolean⓪2* daraus gemacht⓪2*)⓪1loadReg (expr, dataRegs);⓪1genANDI (2, CARDINAL (1), expr.exprReg);⓪1IF condJmp THEN⓪3deallocRegs (expr);⓪3WITH expr DO⓪5kind:= condFlags;⓪5fpuFlags:= FALSE;⓪5relOp:= ne;⓪5signed:= FALSE;⓪5not:= FALSE⓪3END⓪1END⓪/END;⓪/expr.item:= BoolPtr⓪/⓪*| 7, (* MIN *)⓪,8: (* MAX *)⓪/getType;⓪/IF isOrdinal (type) THEN⓪1getBounds (type, lo, hi);⓪1IF isNumber (type, nsize, ntype) THEN⓪3type:= ZZTyp (* aus MAX (CARDINAL/INTEGER) wird ZZ; *⓪A* Chars/Enums bleiben dagegen bei ihren Typ *)⓪1END;⓪1initExpr (expr, HostType (type), constant);⓪1IF n = 7 (* MIN *) THEN⓪3expr.exprConst.zz:= lo⓪1ELSE⓪3expr.exprConst.zz:= hi⓪1END;⓪/ELSIF isReal (type) THEN⓪1initExpr (expr, RealPtr, constant);⓪1IF n = 7 (* MIN *) THEN⓪3expr.exprConst.rr:= MinReal (ItemNo (type) = 2)⓪1ELSE⓪3expr.exprConst.rr:= MaxReal (ItemNo (type) = 2)⓪1END;⓪/ELSE⓪1SyntaxError (rOoRXp)⓪/END;⓪/GetSymbol;⓪/⓪*| 9: (* VAL *)⓪/getType;⓪/IF NOT isOrdinal (type) & NOT isReal (type) THEN⓪1SyntaxError (rOoRXp)⓪/END;⓪/GetComma;⓪/getVarExpr;⓪/adaptSSToChar (expr);⓪/IF NOT isOrdinal (expr.item) & NOT isReal (expr.item) THEN⓪1SyntaxError (rOoRXp)⓪/END;⓪/safeConversion (expr, type)⓪/⓪*|10: (* LENGTH *)⓪/getVarExpr;⓪/IF (expr.kind = constRef) OR (expr.kind = constant) THEN⓪1IF expr.kind = constRef THEN⓪3IF expr.constHead = NIL THEN dropConstantFromTree (expr) END;⓪1END;⓪1adaptStringToSS (expr);⓪1IF NOT isSS (expr) THEN SyntaxError (rStCXp) END;⓪1elems:= Size (expr);⓪1(*$? Safety: assert (elems > 0L);*)⓪1IF expr.kind = constRef THEN⓪3(* sonst kann man nicht explizit ein 0C an's Ende hängen⓪5pc:= expr.constAddr + elems - 1L;⓪5IF pc^ = 0C THEN DEC (elems) END;⓪3*)⓪3cutConst (expr)⓪1ELSE⓪3(*$? Safety: assert (expr.kind = constant);*)⓪3(* sonst kann man nicht explizit ein 0C an's Ende hängen⓪5IF expr.exprConst.str[strConstSize] = 0C THEN DEC (elems) END⓪3*)⓪1END;⓪1IF elems <= 65535L THEN n:= 2 ELSE n:= 4 END;⓪1initConstExpr (expr, n, toZZ (elems, FALSE));⓪1(* hier CARDINAL/LONGCARD liefern - nicht ZZ (nach ISO)! *)⓪/ELSIF isStringVar (expr.item)⓪/OR ((ItemNo (expr.item) = 32) OR (ItemNo (expr.item) = 42))⓪2& (ItemNo (OpenArrayType (expr.item)) = 3) THEN⓪1deallocHighReg (expr);⓪1runtimeLength (expr)⓪/ELSE⓪1SyntaxError (rStrXp)⓪/END;⓪/⓪*|11: (* SIZE *)⓪/GetSymbol;⓪/IF typeDesc IN CurrentSymbol.flags THEN⓪1initConstExpr (expr, 4, toZZ (TypeLength (CurrentSymbol.item), FALSE));⓪1GetSymbol⓪/ELSE⓪1activateCodeSuppression (last);⓪1designator (typeDesig, FALSE, rVoCXp);⓪1restoreCodeSuppression (last);⓪1PopExpr (expr);⓪1IF isOpenArray (expr.item) THEN SyntaxError (rSizVr) END;⓪1restoreStack (expr);⓪1deallocRegs (expr);⓪1initConstExpr (expr, 4, toZZ (TypeLength (expr.item), FALSE));⓪/END;⓪/expr.item:= ZZTyp;⓪/⓪*|12: (* INT *)⓪/(*⓪0* nach ISO gehen nur Ordinale & Reals, wir erlauben aber auch⓪0* LONGWORD, WORD & BYTE.⓪0* Besonderheit bei BYTE: Der Wert wird mit Vorzeichen expandiert⓪0*)⓪/getVarExpr;⓪/expr.item:= HostType (expr.item);⓪/adaptSSToChar (expr);⓪/reduceZZ (expr);⓪/IF Size (expr) > 2L THEN⓪1type:= IntPtr⓪/ELSE⓪1type:= SIntPtr (* ist teilw. kritisch, z.B. bei INT(shortcard) *)⓪/END;⓪/IF isReal (expr.item) OR isOrdinal (expr.item) THEN⓪1safeConversion (expr, type)⓪/ELSIF isJoker (expr.item) THEN⓪1IF jokerSize (ItemNo (expr.item)) = 1 THEN⓪3(* bei INT (byte) wird mit Vorzeichen expandiert! *)⓪3expr.item:= BytIPtr⓪1END;⓪1cast (expr, type)⓪/ELSE⓪1SyntaxError (rSclXp)⓪/END⓪/⓪*|13: (* CAP *)⓪/getVarExpr;⓪/adaptSSToChar (expr);⓪/IF NOT isChar (HostType (expr.item)) THEN SyntaxError (rChrXp) END;⓪/IF expr.kind = constant THEN⓪1expr.exprConst.ch:= CAP (expr.exprConst.ch)⓪/ELSE⓪1runtimeCap (expr)⓪/END⓪/⓪*|14: (* CHR *)⓪/getVarExpr;⓪/IF NOT isWholeNumber (expr.item) THEN⓪1SyntaxError (rWhNXp)⓪/END;⓪/type:= CharPtr;⓪/getConversionDesc (expr.item, type, range);⓪/fitValue (expr, range);⓪/expr.item:= type;⓪/⓪*|15, 16: (* FLOAT, LFLOAT *)⓪/getVarExpr;⓪/IF NOT isNumber (expr.item, nsize, ntype)⓪/& NOT isReal (expr.item) THEN SyntaxError (rNumXp) END;⓪/IF n = 15 THEN type:= SRealPtr ELSE type:= RealPtr END;⓪/safeConversion (expr, type);⓪/⓪*|17: (* TRUNC *)⓪/getVarExpr;⓪/IF NOT isReal (expr.item) THEN SyntaxError (rReaXp) END;⓪/safeConversion (expr, CardPtr);⓪*⓪*|18: ASSEMBLER⓪8DC.W SerLead1⓪0Serial2 DC.W SerVal1 ;SerienNr ^^^⓪/END;⓪*⓪*ELSE⓪,SyntaxError (rNotFn)⓪*END;⓪(ELSE⓪*ASSEMBLER⓪0PEA labelAdr(PC)⓪*END;⓪*CASE n OF⓪ ⓪*|102: (* 101: ADR *)⓪0ASSEMBLER⓪2; Achtung: die '102' ist nur ein Pseudo-Label, das nicht⓪2; vorkommt! In Wahrheit wird diese Routine durch den⓪2; ELSE-Zweig des CASE (s.u.) angesprungen!⓪1labelAdr:⓪0END;⓪0⓪0getDesig (varDesig);⓪0IF warningsActive () THEN⓪2IF expr.readOnly THEN SyntaxError (rRefRs) END;⓪2IF expr.regVar THEN SyntaxError (rRegVa) END;⓪0END;⓪0IF isOpenArray (expr.item) THEN⓪2deallocHighReg (expr);⓪2loadIndir (expr, 0, FALSE)⓪0END;⓪0loadSourceAddress (expr);⓪0expr.item:= StdParmRes (StdProcParms (type)); (* ADDRESS *)⓪0⓪0ASSEMBLER⓪:BRA.W SerOk⓪:DC.W SerLead0⓪2Serial1 DC.W SerVal0 ;SerienNr ^^^⓪0END;⓪ ⓪*|103: (* TSIZE *)⓪0getType;⓪0initConstExpr (expr, 4, toZZ (TypeLength (type), FALSE));⓪0expr.item:= ZZTyp;⓪0GetSymbol;⓪0(* mehrere Args zulassen bei Records (werden nicht geprüft): *)⓪0WHILE (CurrentSymbol.itemNo = comma)⓪0& (ItemNo (type) = 13 (* RECORD *) ) DO⓪2(*&&& Werte auswerten *)⓪2GetSymbol;⓪2ConstExpression;⓪2PopExpr (helpExpr);⓪0END;⓪*⓪*|104: (* CAST *)⓪0getType;⓪0GetComma;⓪0getVarExpr;⓪0cast (expr, type);⓪0IF extendedSyntax () & ~AsmMode THEN⓪2desigAccess (expr, FALSE);⓪2deallocHighReg (expr); (* 15.2.94, hier stand irrtümlich 'help' *)⓪0END;⓪0⓪*|105: (* CADR *)⓪*⓪0GetSymbol;⓪0IF (userDef IN CurrentSymbol.flags)⓪0AND (ORD (CurrentSymbol.typ) = 28) THEN⓪2(* TABLE *)⓪2initMemExpr (expr, 0(*dummy*), absRef, FALSE);⓪2expr.varItem:= CurrentSymbol.item;⓪2expr.readOnly:= TRUE;⓪2GetSymbol;⓪0ELSE⓪2VarExpression ();⓪2PopExpr (expr);⓪2WITH expr DO⓪4IF isOpenArray (item) THEN⓪6deallocHighReg (expr);⓪6loadIndir (expr, 0, FALSE)⓪4END;⓪4IF (kind # memory)⓪4& (kind # constant)⓪4& (kind # constRef)⓪4OR (kind = memory) & (mode = immRef) THEN⓪6SyntaxError (rVoCXp)⓪4END⓪2END;⓪2reduceZZ (expr);⓪0END;⓪0loadSourceAddress (expr);⓪0expr.item:= StdParmRes (StdProcParms (type)); (* ADDRESS *)⓪0(* oder noch besser: auf POINTER TO expr.item --⓪1* dann würde auch korrekter Check möglich sein, ob⓪1* durch 'reduceZZ' ein 2- oder 4-Byte wert abgelegt wurde *)⓪*⓪*|106: (* DEREF *)⓪0getVarExpr;⓪0deref (expr)⓪*⓪*|107, 108: (* SHIFT, ROTATE *)⓪0GetSymbol;⓪0VarExpression ();⓪0doShiftRotate;⓪ ⓪*|126, 127: (* CALLSYS, CALLEXT *)⓪0hdlCall (n-126, type);⓪0initExpr (expr, StdParmRes (StdProcParms (type)), register);⓪0expr.exprReg:= allocReg (RegSet {D0})⓪ ⓪*(*&&& ADDADR, SUBADR, DIFADR *)⓪*⓪*ELSE⓪,IF n >= 120 THEN⓪.SyntaxError (rNotFn)⓪,END;⓪,ASSEMBLER⓪0; Hiermit wird System-Funktion 101 (ADR) angesprungen:⓪0RTS⓪,END;⓪*END;⓪*ASSEMBLER⓪0; Seriennummer Serial1 gegen Serial2 prüfen ^^^⓪0MOVE.L (A7)+,A0⓪0CLR.L D0⓪0MOVE.W Serial1-labelAdr(A0),D0⓪0MOVEQ #SerCnt1,D1⓪(lp LSR.L #1,D0⓪0BCC l1⓪0BTST #6,D0⓪0BNE l2⓪(l3 BSET #17,D0⓪(l2 DBF D1,lp⓪0ADDI.W #SerOffset1,D0⓪0CMP.W Serial2-labelAdr(A0),D0⓪0BEQ SerOk⓪0LEA SCardPtr,A0⓪0MOVE.L 8(A0),-4(A0) ; BothTyp -> SIntPtr⓪0BRA SerOk⓪(l1 BTST #6,D0⓪0BEQ l2⓪0BRA l3⓪(SerOk⓪*END⓪(END;⓪(checkSet (expr);⓪(PushExpr (expr);⓪(GetRparen⓪&END stdFunction;⓪ ⓪ ⓪$PROCEDURE checkCall;⓪&BEGIN⓪(IF (CurrentSymbol.itemNo) = lparen THEN⓪*funcCall⓪(END⓪&END checkCall;⓪ ⓪$PROCEDURE userFunction;⓪&VAR fact: ExprDesc;⓪&BEGIN⓪(initProcExpr (fact, CurrentSymbol.item, procDepth (Tiefe));⓪(PushExpr (fact);⓪(GetSymbol;⓪&END userFunction;⓪ ⓪ ⓪$PROCEDURE const (namedID: BOOLEAN);⓪&⓪&VAR StringBuffer: ARRAY [0..MaxStringConst] OF CHAR;⓪*StringLength: [0..MaxStringConst];⓪*itemIsUserConst: BOOLEAN;⓪*currentItem: PtrItem;⓪*fact: ExprDesc;⓪ ⓪&PROCEDURE hdlString;⓪(VAR type: PtrItem;⓪(BEGIN⓪*WITH fact DO⓪,(* String-Kennung erzeugen - muß unbedingt vor drop...-Aufruf! *)⓪,IF StringLength <= strConstSize THEN⓪.initExpr (fact, SSTyp, constant);⓪.IF itemIsUserConst THEN⓪0fact.varItem:= currentItem; (* Verweis auf CONST im Tree *)⓪.END;⓪.(* String in Expr merken *)⓪.(* String wird als Konst. abgelegt *)⓪.IF StringLength = 0 THEN⓪0exprConst.ch:= 0C⓪.ELSE⓪0Move (ADR (StringBuffer),⓪2ADR (exprConst.b)-LONG(StringLength-1)(* rechtsbündig *),⓪2StringLength)⓪.END;⓪,ELSE⓪.(* String kommt ins DATA-Segment *)⓪.initExpr (fact, SSTyp, constRef);⓪.IF itemIsUserConst THEN⓪0fact.varItem:= currentItem; (* Verweis auf CONST im Tree *)⓪.ELSE⓪0(* String sofort in DATA-Puffer ablegen *)⓪0dropNewConstant (ADR (StringBuffer), StringLength, fact);⓪.END⓪,END;⓪,SetSize (fact, StringLength);⓪*END;⓪(END hdlString;⓪&⓪&PROCEDURE appendToBuffer (item: PtrItem);⓪(VAR n: [0..MaxStringConst]; p: POINTER TO CHAR;⓪(BEGIN⓪*IF StringLength + StrLen >= MaxStringConst THEN⓪,SyntaxError (rSCoLg)⓪*END;⓪*n:= 0;⓪*p:= AccuPtr;⓪*WHILE n < StrLen DO⓪,INC (n);⓪,StringBuffer [StringLength]:= p^;⓪,INC (StringLength); INC (p);⓪*END⓪(END appendToBuffer;⓪ ⓪&PROCEDURE loadConst (type: PtrItem);⓪((* lädt Konstante aus Accu auf ExprStack *)⓪((* kann laden: alles, außer String-Consts *)⓪(VAR nsize: NumberSize; ntype: NumberType;⓪,lo, hi: ZZ; n: CARDINAL;⓪(BEGIN⓪*initExpr (fact, type, constant);⓪*WITH fact DO⓪,IF itemIsUserConst THEN⓪.varItem:= currentItem; (* Verweis auf CONST im Tree *)⓪,END;⓪,n:= SHORT (TypeLength (item));⓪,IF (n < 4) & (scalar IN ItemFlag (item)) THEN⓪.Move (ADR (Accu), ADR (exprConst.l), 4)⓪,ELSIF n <= constBufSize THEN⓪.Move (AccuPtr, ADR (exprConst.b)+1L-LONG(n), n)⓪,ELSE⓪.(* Konst kommt ins DATA-Segment *)⓪.(* Wenn Const > AccuSize, wurde sie von ConstantFactor() in den⓪/* Code abgelegt, und zwar mit einem Sicherheits-Offset von $100⓪/* Bytes. *)⓪.IF itemIsUserConst THEN⓪0kind:= constRef;⓪0constOfs:= 0;⓪0constHead:= NIL;⓪.ELSE⓪0(* Konst sofort in DATA-Puffer ablegen *)⓪0dropNewConstant (AccuPtr, n, fact);⓪.END⓪,END;⓪,IF isNumber (item, nsize, ntype) THEN⓪.IF (nsize = ord4) & (item # ZZTyp) THEN⓪0exprConst.zz.over:= (ntype = cardType) & (exprConst.zz.v < 0L);⓪.ELSIF nsize = ord2 THEN⓪0IF ntype = intType THEN exprConst.w2:= WORD (-1) END;⓪0exprConst.zz.over:= FALSE;⓪0IF ntype = bothType THEN item:= ZZTyp END;⓪.(*⓪.ELSIF ntype = realType THEN⓪.*)⓪.END⓪,END;⓪*END;⓪(END loadConst;⓪ ⓪&BEGIN (* const *)⓪(IF CurrentSymbol.itemNo = lbrace (* '{' -> BITSET *) THEN⓪*(* keinen Fehler melden, damit PIM3-konform⓪,SyntaxError (rBitse)⓪**)⓪*hdlSetConstructor (BSetPtr);⓪*GetSymbol⓪(ELSE⓪*currentItem:= CurrentSymbol.item;⓪*itemIsUserConst:= (userDef IN CurrentSymbol.flags) &⓪<(ItemNo (currentItem) = 50);⓪*IF NOT ConstantFactor () THEN SyntaxError (rFactr) END;⓪*IF StrConstType (CurrentSymbol.item) THEN⓪,StringLength:= 0;⓪,LOOP⓪.appendToBuffer (CurrentSymbol.item);⓪.GetSymbol;⓪.IF (CurrentSymbol.itemNo) # strConc THEN EXIT END;⓪.itemIsUserConst:= FALSE;⓪.GetSymbol;⓪.IF NOT ConstantFactor ()⓪.OR NOT StrConstType (CurrentSymbol.item) THEN⓪0SyntaxError (rStCXp)⓪.END⓪,END;⓪,hdlString⓪*ELSE⓪,(* numerische oder strukt. Konst. *)⓪,loadConst (CurrentSymbol.item); (* Wert steht in Accu *)⓪,GetSymbol⓪*END;⓪*IF namedID & ~AsmMode THEN⓪,(* benamte Consts wie Designators auswerten *)⓪,desigAccess (fact, FALSE);⓪,PushExpr (fact);⓪,checkCall;⓪,PopExpr (fact)⓪*END;⓪*checkSet (fact);⓪*PushExpr (fact)⓪(END⓪&END const;⓪ ⓪$PROCEDURE getFactExpr;⓪&PROCEDURE handleJmp;⓪(VAR tempTrue, tempFalse, dummyLbl1, dummyLbl2: Labels;⓪(BEGIN⓪*GetSymbol;⓪*expression (TRUE, tempFalse, tempTrue, dummyLbl1, dummyLbl2);⓪*(*$? Safety: assert (~unSolved (dummyLbl1)); *)⓪*(*$? Safety: assert (~unSolved (dummyLbl2)); *)⓪*AddLabelsTo (tempFalse, false);⓪*AddLabelsTo (tempTrue, true);⓪(END handleJmp;⓪&BEGIN⓪((* Unterscheidung ist nötig, weil sonst "(x IN s) = b" nicht ginge: *)⓪(IF condJmp THEN⓪*handleJmp⓪(ELSE⓪*GetSymbol;⓪*VarExpression ()⓪(END⓪&END getFactExpr;⓪ ⓪$PROCEDURE hdlType;⓪&VAR t: PtrItem; expr: ExprDesc;⓪&BEGIN⓪(t:= CurrentSymbol.item;⓪(GetSymbol;⓪(IF CurrentSymbol.itemNo = lparen THEN⓪*(* Type Transfer *)⓪*GetSymbol;⓪*VarExpression ();⓪*GetRparen;⓪*PopExpr (expr);⓪*IF isSS (expr) & isStringVar (t) THEN⓪,(*⓪-* Es können auch String-Consts mit dem Typ-Bezeichner gecastet⓪-* werden, allerdings nur, wenn die Const auch ganz reinpaßt⓪-*)⓪,IF Size (expr) > TypeLength (t) THEN SyntaxError (rSCoOv) END;⓪,terminateStringConst (expr, t);⓪,adaptStringConst (expr, t);⓪*ELSE⓪,IF (expr.kind = constant) & isWholeNumber (expr.item) THEN⓪.IF (LONG (sizeZZ (expr.exprConst.zz)) > TypeLength (t)) THEN⓪0SyntaxError (rConRg)⓪.END;⓪.expr.item:= t⓪,ELSE⓪.IF Size (expr) # TypeLength (t) THEN SyntaxError (rConv) END;⓪,END;⓪*END;⓪*expr.item:= t;⓪*IF extendedSyntax () & ~AsmMode THEN desigAccess (expr, FALSE); END;⓪*checkSet (expr);⓪*PushExpr (expr);⓪*IF extendedSyntax () & ~AsmMode THEN checkCall END⓪(ELSIF CurrentSymbol.itemNo = lbrace THEN⓪*(* Type/Value Constructor *)⓪*hdlConstructor (t);⓪*GetSymbol⓪(ELSE⓪*SyntaxError (rFactr)⓪(END⓪&END hdlType;⓪ ⓪$PROCEDURE swapLabels;⓪&VAR tempFalse: Labels;⓪&BEGIN⓪(tempFalse:= false;⓪(false:= true;⓪(true:= tempFalse;⓪&END swapLabels;⓪ ⓪$PROCEDURE hdlNot;⓪&VAR fact: ExprDesc;⓪&BEGIN⓪(GetSymbol;⓪(swapLabels;⓪(factor ();⓪(swapLabels;⓪(PopExpr (fact);⓪(IF NOT BooleanType (fact.item) THEN SyntaxError (rBolXp) END;⓪((* folgende Conditions bzw. Const-Wert invertieren *)⓪(IF fact.kind = constant THEN⓪*(*$? Safety: assert (ORD (fact.exprConst.w) < 2); *)⓪*fact.exprConst.w:= WORD (NOT BOOLEAN (fact.exprConst.w))⓪(ELSE⓪*fact.not:= NOT fact.not⓪(END;⓪(PushExpr (fact);⓪&END hdlNot;⓪ ⓪$BEGIN (* factor *)⓪&IF (CurrentSymbol.itemNo) = 0 THEN⓪(SyntaxError (rIdUn)⓪&ELSIF typeDesc IN (CurrentSymbol.flags) THEN⓪(hdlType⓪&ELSIF userDef IN CurrentSymbol.flags THEN⓪(IF (ORD (CurrentSymbol.typ) = 17)⓪(OR (ORD (CurrentSymbol.typ) = 14) THEN⓪*designator (readDesig, FALSE, -1043 (* darf nicht vorkommen *));⓪*checkCall⓪(ELSIF ORD (CurrentSymbol.typ) = 36 THEN⓪*stdFunction;⓪*IF extendedSyntax () & ~AsmMode THEN checkCall END⓪(ELSIF ORD (CurrentSymbol.typ) = 6 THEN⓪*userFunction;⓪*checkCall⓪(ELSE⓪*const (TRUE)⓪(END;⓪&ELSE⓪(IF CurrentSymbol.itemNo = lparen THEN⓪*(* In Klammer müssen neue Labels vergeben werden *)⓪*getFactExpr;⓪*GetRparen;⓪(ELSIF (CurrentSymbol.itemNo = tilde)⓪(OR (CurrentSymbol.itemNo = SymNot) THEN⓪*hdlNot⓪(ELSE⓪*const (FALSE)⓪(END⓪&END;⓪$END factor;⓪ ⓪ ⓪"PROCEDURE term ();⓪ ⓪$VAR resultType: PtrItem;⓪(size: CARDINAL;⓪ ⓪$PROCEDURE constOp (op: Operator; VAR expr, const: ExprDesc);⓪ ⓪&VAR n, opcode: CARDINAL; signed: BOOLEAN;⓪*p: POINTER TO BYTE;⓪ ⓪&BEGIN⓪(IF isReal (resultType) THEN⓪*realOp (op, const, expr)⓪(ELSIF op = mul THEN⓪*constMul (expr, resultType, const.exprConst.zz, TRUE);⓪*PushExpr (expr)⓪(ELSE⓪*(* Achtung: Wenn bei DIV/MOD die Word-optimierten Routinen⓪+* "CDVW,IDVW,CMDW,IMDW" benutzt werden, muß 'checkDivisor' vorher⓪+* aufgerufen werden, da die Routinen keine Null-Prüfung machen. *)⓪*IF nullZZ (const.exprConst.zz) THEN⓪,SyntaxError (rDvNul)⓪*END;⓪*signed:= signedExpr (expr);⓪*IF posZZ (const.exprConst.zz) & log2 (const.exprConst.zz, n) THEN⓪,IF op = div THEN⓪.IF n # 0 (* DIV durch 1? *) THEN⓪0IF n >= (size * 8) THEN⓪2(* Ergebnis ist Null *)⓪2clearExpr (expr)⓪0ELSE⓪2loadReg (expr, dataRegs);⓪2IF n >= 16 THEN⓪4(* CLR.W und SWAP bzw. SWAP und EXT.L *)⓪4IF ~signed THEN genr (CLRW, expr.exprReg) END;⓪4genr (SWAP, expr.exprReg);⓪4IF signed THEN genr (EXTL, expr.exprReg) END;⓪4DEC (n, 16);⓪4size:= 2⓪2END;⓪2IF n > 0 THEN⓪4IF signed THEN opcode:= ASRI ELSE opcode:= LSRI END;⓪4getSizeAt6 (size, opcode);⓪4IF n > 8 THEN⓪6(* LSR #8,expr *)⓪6genr (opcode, expr.exprReg);⓪6DEC (n, 8)⓪4END;⓪4(* LSR #n,expr *)⓪4genr (opcode + $200 * (n MOD 8), expr.exprReg)⓪2END⓪0END⓪.END⓪,ELSIF op = mod THEN⓪.IF n < (size * 8) THEN⓪0IF n = 0 THEN⓪2(* Ergebnis ist Null *)⓪2clearExpr (expr)⓪0ELSIF signed THEN⓪2(* hier müßten neg. Werten erst in pos. gewandelt, nach dem⓪3* ANDI wieder negiert werden. Das ist zu umständlich, daher⓪3* wird einfacherhalber der DIV-Befehl benutzt *)⓪2varMul (op, expr, const, TRUE, resultType);⓪2RETURN⓪0ELSE⓪2loadReg (expr, dataRegs);⓪2genANDI (size, const.exprConst.zz.v-1L, expr.exprReg);⓪0END⓪.END⓪,ELSE⓪.SyntaxError (rOpTyp)⓪,END;⓪,PushExpr (expr)⓪*ELSE⓪,varMul (op, expr, const, TRUE, resultType);⓪*END;⓪(END⓪&END constOp;⓪ ⓪$PROCEDURE mulop (n: CARDINAL; VAR op: Operator): BOOLEAN;⓪&VAR expr: ExprDesc;⓪&BEGIN⓪(IF n = asterisk THEN⓪*op:= mul⓪(ELSIF (n = 5) (* / *) THEN⓪*op:= rdiv;⓪(ELSIF (n = 50) (* DIV *) THEN⓪*op:= div;⓪(ELSIF (n = 52) (* MOD *) THEN⓪*op:= mod⓪(ELSIF (n = SymAnd) OR (n = 19) (* & *) THEN⓪*op:= and⓪(ELSE⓪*RETURN FALSE⓪(END;⓪(RETURN TRUE⓪&END mulop;⓪ ⓪$VAR⓪&op: Operator;⓪&lconst, rconst: BOOLEAN;⓪&localTrue, localFalse: Labels;⓪ ⓪$PROCEDURE handleAnd;⓪&VAR⓪(last, left, right: ExprDesc;⓪(bccPtr: ADDRESS;⓪(lastRegs: RegSet;⓪(f1, ignore: BOOLEAN;⓪(nice: RegSet;⓪&BEGIN⓪(PopExpr (left);⓪(⓪(IF NOT BooleanType (left.item) THEN SyntaxError (rOpTyp) END;⓪(⓪((*⓪)* nun müssen wir alle andern Regs spillen, da im Fall,⓪)* daß in der Bool-Expr sonstwo ein spill auftauchen würde,⓪)* durch die Label-Springerei an Stellen gesprungen werden⓪)* könnte, an denen ein Reg noch auf dem Stack steht, obwohl⓪)* es durch die optimierten Sprünge gar nicht auf den Stack kam.⓪)* Beispiel: ptrToBool:= NOT bool AND boolFunc();⓪)* hier würde das Addr-Reg f. das Ergebnis beim F-Aufruf⓪)* auf den Stack kommen, aber erst bei der Zuweisung und somit⓪)* hinter dem false-Label von 'NOT bool' erst zurückgeladen⓪)* werden. Wenn nun aber bool=TRUE, würde zum Label gesprungen,⓪)* ohne daß überhaupt das Reg gespilled worden wäre.⓪)*)⓪(spillAllRegsExcept (left);⓪(⓪((* Sprung, wenn FALSE... *)⓪(ignore:= FALSE;⓪(bccPtr:= NIL;⓪(last:= left;⓪(IF left.kind = constant THEN⓪*IF BOOLEAN (left.exprConst.w) = FALSE THEN⓪,(* rechten Teil ignorieren *)⓪,ignore:= TRUE⓪*END⓪(ELSE⓪*IF condJmp THEN⓪,tstAndJmp (FALSE, left, localFalse, last, bccPtr);⓪*ELSIF NOT left.not THEN⓪,moveAndJmp (FALSE, left, localFalse, last, bccPtr);⓪*ELSE⓪,moveAndJmp (FALSE, left, localTrue, last, bccPtr);⓪*END;⓪*IF unSolved (true) THEN Solve (true); bccPtr:= NIL END;⓪*IF unSolved (trueNot) THEN Solve (trueNot); bccPtr:= NIL END⓪(END;⓪(restoreStack (left);⓪(lastRegs:= freeRegs;⓪(deallocRegs (left);⓪(⓪((* Nun die rechte Seite... *)⓪(GetSymbol;⓪(f1:= SuppressCode;⓪(SuppressCode:= SuppressCode OR ignore; (* ggf. keinen Code erzeugen *)⓪((* die linke Seite darf nicht mehr auf den Expr-Stack weil⓪)* sie bereits dealloziert ist. *)⓪(factor ();⓪(SuppressCode:= f1;⓪(PopExpr (right);⓪(IF NOT BooleanType (right.item) THEN SyntaxError (rOpTyp) END;⓪ ⓪(IF right.kind = constant THEN⓪*IF BOOLEAN (right.exprConst.w) = FALSE THEN⓪,(* 'right' bleibt, 'left' wird ignoriert *)⓪*ELSE⓪,(* wenn rechts TRUE, ignorieren; links übernehmen *)⓪,freeRegs:= lastRegs;⓪,right:= last⓪*END;⓪*IF bccPtr # NIL THEN⓪,(* Bcc rückgängig machen, da rechts kein Code erz. wurde: *)⓪,IF condJmp OR NOT left.not THEN⓪.PopLabel (localFalse)⓪,ELSE⓪.PopLabel (localTrue)⓪,END;⓪,SetCodePtr (bccPtr)⓪*END⓪(ELSE⓪*IF left.kind = constant THEN⓪,IF ignore THEN⓪.(* dann noch kein Code erzeugt -> kind bleibt erhalten *)⓪.deallocRegs (right);⓪.WITH right DO⓪0IF kind = stack THEN⓪2updateStackOffsets (stackReg, up, stackedSize)⓪0END⓪.END;⓪.right:= left;⓪,END⓪*ELSIF NOT condJmp THEN⓪,nice:= RegSet{};⓪,INCL (nice, left.exprReg);⓪,loadReg (right, nice)⓪*END⓪(END;⓪(PushExpr (right);⓪&END handleAnd;⓪$⓪$PROCEDURE handleOp;⓪&VAR⓪(left, right: ExprDesc; real: BOOLEAN;⓪&BEGIN⓪(PopExpr (right);⓪(PopExpr (left);⓪(⓪(checkCompat (left, right, resultType, rBdTyp);⓪(⓪(lconst:= left.kind = constant;⓪(rconst:= right.kind = constant;⓪(IF lconst & rconst OR (left.kind = constRef) & (right.kind = constRef) THEN⓪*constantFold (op, left, right);⓪(ELSE⓪*CASE ItemNo (resultType) OF⓪*| 5, 45: (* SET *)⓪.setOp (op, left, right, resultType)⓪*| 40, 2, (* REAL *)⓪,1,22,30,4, (* 32 Bit INTEGER/CARDINAL/BOTH/ZZ *)⓪,23, (* ADDRESS *)⓪,33, 34, 35: (* 16 Bit INTEGER/CARDINAL *)⓪.prepareStackForLoad (right);⓪.IF bothOnStack (left, right) THEN⓪0IF (ItemNo (left.item) = 2) OR (ItemNo (left.item) = 40) THEN⓪2loadRealReg (right,floatRegs);⓪0ELSE⓪2loadReg (right,dataRegs);⓪0END;⓪0restoreStack (right);⓪.END;⓪.reloadPtr (left);⓪.prepareStackForLoad (left);⓪.size:= SHORT (TypeLength (resultType));⓪.IF (op = mul) & lconst THEN⓪0constOp (op, right, left);⓪.ELSIF rconst THEN⓪0constOp (op, left, right);⓪.ELSE⓪0varMul (op, left, right, TRUE, resultType)⓪.END⓪*ELSE⓪.SyntaxError (rOpTyp)⓪*END⓪(END⓪&END handleOp;⓪&⓪&⓪$BEGIN (* term *)⓪&InitLabels (localFalse);⓪&InitLabels (localTrue);⓪&factor ();⓪&WHILE mulop (CurrentSymbol.itemNo, op) DO⓪(IF (op = and) THEN⓪*(* --- BOOLEAN / AND --- *)⓪*handleAnd;⓪(ELSE⓪*GetSymbol;⓪*factor ();⓪*handleOp;⓪(END⓪&END;⓪&AddLabelsTo (localFalse, false);⓪&AddLabelsTo (localTrue, falseNot)⓪$END term;⓪ ⓪ ⓪"PROCEDURE simpleExpression ();⓪ ⓪$VAR resultType: PtrItem;⓪(localFalse, localTrue: Labels;⓪(notReal, lconst, rconst: BOOLEAN;⓪(op: Operator;⓪ ⓪$PROCEDURE addSub (opcode: CARDINAL; VAR ea, const: ExprDesc);⓪&(* Bei SUB ist 'ea' left, 'const' right *)⓪&VAR x: ZZ; isConst: BOOLEAN;⓪&BEGIN⓪(isConst:= (const.kind = constant) & notReal;⓪(x:= const.exprConst.zz;⓪(IF isConst & int3ZZ (x) THEN⓪*loadReg (ea, dataRegs);⓪*IF op = sub THEN negZZ (x) END;⓪*genQ (SHORT (x.v), ea);⓪(ELSE⓪*IF (op = add) & isConst & int8ZZ (x) THEN swapExpr (const, ea) END;⓪*IF notReal THEN⓪,loadReg (ea, dataRegs);⓪,genar (opcode, const, ea.exprReg)⓪*ELSE⓪,ea.item:= resultType;⓪,realOp (op, const, ea); (* macht ggf. selbst Overflow-Check *)⓪,RETURN⓪*END⓪(END;⓪(checkOverflow (resultType);⓪(deallocRegs (const);⓪(ea.item:= resultType;⓪(PushExpr (ea);⓪&END addSub;⓪ ⓪$PROCEDURE opTo (VAR left, right: ExprDesc);⓪&(*⓪'* bei SUB muß 'right' als <ea>, left in Reg genommen werden.⓪'*)⓪&VAR opcode: CARDINAL;⓪&BEGIN⓪(IF op = add THEN⓪*opcode:= ADD;⓪(ELSE⓪*opcode:= SUB⓪(END;⓪(IF (op = add) & (lconst OR (inDataReg (right))) THEN⓪*addSub (opcode, right, left)⓪(ELSE⓪*addSub (opcode, left, right)⓪(END⓪&END opTo;⓪ ⓪$PROCEDURE negate (VAR expr: ExprDesc; nsize: NumberSize; ntype: NumberType);⓪&BEGIN⓪(IF ntype = realType THEN⓪*(* Real negieren *)⓪*IF expr.kind = constant THEN⓪,WITH expr.exprConst DO⓪.IF nsize = real4 THEN SRNEG (sr) ELSE LRNEG (rr) END⓪,END;⓪*ELSE⓪,negateReal (expr)⓪*END⓪(ELSIF (ntype = intType) OR (ntype = bothType) THEN⓪*IF expr.kind = constant THEN⓪,negZZ (expr.exprConst.zz)⓪*ELSE⓪,loadReg (expr, dataRegs);⓪,restoreStack (expr);⓪,gena (NEG, expr, 0);⓪,checkOverflow (expr.item)⓪*END⓪(ELSE⓪*SyntaxError (rNegTp)⓪(END⓪&END negate;⓪ ⓪$PROCEDURE addop (n: CARDINAL; VAR op: Operator): BOOLEAN;⓪&BEGIN⓪(IF n = plus THEN⓪*op:= add⓪(ELSIF n = minus THEN⓪*op:= sub⓪(ELSIF n = SymOr THEN⓪*op:= or⓪(ELSE⓪*RETURN FALSE⓪(END;⓪(RETURN TRUE⓪&END addop;⓪$⓪ ⓪$PROCEDURE handleNeg (neg: BOOLEAN);⓪&VAR⓪(left: ExprDesc;⓪(size: NumberSize;⓪(ntyp: NumberType;⓪&BEGIN⓪(LookExpr (left);⓪(IF NOT isNumber (left.item, size, ntyp) THEN⓪*SyntaxError (rOpTyp)⓪(END;⓪(IF neg THEN⓪*PopExpr (left);⓪*reloadPtr (left);⓪*negate (left, size, ntyp);⓪*PushExpr (left)⓪(END⓪&END handleNeg;⓪$⓪$PROCEDURE handleOr;⓪&VAR⓪(last, left, right: ExprDesc;⓪(bccPtr: ADDRESS;⓪(nice: RegSet;⓪(f1, ignore: BOOLEAN;⓪(lastRegs: RegSet;⓪&BEGIN⓪((* --- BOOLEAN / OR --- *)⓪(PopExpr (left);⓪(IF NOT BooleanType (left.item) THEN SyntaxError (rOpTyp) END;⓪(⓪(spillAllRegsExcept (left);⓪(⓪((* Sprung, wenn TRUE... *)⓪(ignore:= FALSE;⓪(bccPtr:= NIL;⓪(last:= left;⓪(IF left.kind = constant THEN⓪*IF BOOLEAN (left.exprConst.w) = TRUE THEN⓪,(* rechten Teil ignorieren *)⓪,ignore:= TRUE⓪*END⓪(ELSE⓪*IF condJmp THEN⓪,tstAndJmp (TRUE, left, localTrue, last, bccPtr);⓪*ELSIF NOT left.not THEN⓪,moveAndJmp (TRUE, left, localTrue, last, bccPtr);⓪*ELSE⓪,moveAndJmp (TRUE, left, localFalse, last, bccPtr);⓪*END;⓪*IF unSolved (false) THEN Solve (false); bccPtr:= NIL END;⓪*IF unSolved (falseNot) THEN Solve (falseNot); bccPtr:= NIL END⓪(END;⓪(restoreStack (left);⓪(lastRegs:= freeRegs;⓪(deallocRegs (left);⓪(⓪((* Nun die rechte Seite... *)⓪(GetSymbol;⓪(f1:= SuppressCode;⓪(SuppressCode:= SuppressCode OR ignore; (* ggf. keinen Code erzeugen *)⓪(term ();⓪(SuppressCode:= f1;⓪(PopExpr (right);⓪(IF NOT BooleanType (right.item) THEN SyntaxError (rOpTyp) END;⓪ ⓪(IF right.kind = constant THEN⓪*IF BOOLEAN (right.exprConst.w) = TRUE THEN⓪,(* 'right' bleibt, 'left' wird ignoriert *)⓪*ELSE⓪,(* wenn rechts FALSE, ignorieren; links übernehmen *)⓪,freeRegs:= lastRegs;⓪,right:= last⓪*END;⓪*IF bccPtr # NIL THEN⓪,(* Bcc rückgängig machen, da rechts kein Code erz. wurde: *)⓪,IF condJmp OR NOT left.not THEN⓪.PopLabel (localTrue)⓪,ELSE⓪.PopLabel (localFalse)⓪,END;⓪,SetCodePtr (bccPtr)⓪*END⓪(ELSE⓪*IF left.kind = constant THEN⓪,IF ignore THEN⓪.(* dann noch kein Code erzeugt -> kind bleibt erhalten *)⓪.deallocRegs (right);⓪.WITH right DO⓪0IF kind = stack THEN⓪2updateStackOffsets (stackReg, up, stackedSize)⓪0END⓪.END;⓪.right:= left;⓪,END⓪*ELSIF NOT condJmp THEN⓪,nice:= RegSet{};⓪,INCL (nice, left.exprReg);⓪,loadReg (right, nice)⓪*END⓪(END;⓪(PushExpr (right);⓪&END handleOr;⓪$⓪$PROCEDURE handleOp;⓪&⓪&VAR⓪(left, right: ExprDesc;⓪&BEGIN⓪(PopExpr (right);⓪(PopExpr (left);⓪(⓪(checkCompat (left, right, resultType, rBdTyp);⓪(⓪(lconst:= left.kind = constant;⓪(rconst:= right.kind = constant;⓪(IF lconst & rconst OR (left.kind = constRef) & (right.kind = constRef) THEN⓪*constantFold (op, left, right);⓪(ELSE⓪*CASE ItemNo (resultType) OF⓪*| 5, 45: (* SET *)⓪.setOp (op, left, right, resultType)⓪*| 40, 2, (* REAL *)⓪,1,22,30,4, (* 32 Bit INTEGER/CARDINAL/BOTH/ZZ *)⓪,23, (* ADDRESS *)⓪,33, 34, 35: (* 16 Bit INTEGER/CARDINAL *)⓪.prepareStackForLoad (right);⓪.IF bothOnStack (left, right) THEN⓪0IF isReal (resultType) THEN⓪2loadRealReg (right,floatRegs);⓪0ELSE⓪2loadReg (right,dataRegs);⓪0END;⓪0restoreStack (right);⓪.END;⓪.reloadPtr (left);⓪.prepareStackForLoad (left);⓪.notReal:= NOT isReal (resultType);⓪.IF rconst & notReal & nullZZ (right.exprConst.zz) THEN⓪0left.item:= resultType;⓪0PushExpr (left)⓪.ELSIF lconst & notReal & (op#sub) & nullZZ (left.exprConst.zz) THEN⓪0right.item:= resultType;⓪0PushExpr (right)⓪.ELSE⓪0opTo (left, right)⓪.END⓪*ELSE⓪.SyntaxError (rOpTyp)⓪*END⓪(END⓪&END handleOp;⓪$⓪$PROCEDURE hdlDebug;⓪&VAR expr: ExprDesc;⓪&BEGIN⓪(PopExpr (expr);⓪(handleDebug (expr);⓪(PushExpr (expr);⓪&END hdlDebug;⓪$⓪$VAR number, negSign: BOOLEAN;⓪&⓪$BEGIN (* simpleExpression *)⓪&InitLabels (localTrue);⓪&InitLabels (localFalse);⓪&⓪&(* Vorzeichen testen: *)⓪&number:= FALSE;⓪&IF (CurrentSymbol.itemNo = plus)⓪&OR (CurrentSymbol.itemNo = minus) THEN⓪(negSign:= (CurrentSymbol.itemNo = minus);⓪(number:= TRUE;⓪(GetSymbol⓪&END;⓪ ⓪&term ();⓪&⓪&IF number THEN⓪(handleNeg (negSign)⓪&END;⓪ ⓪&WHILE addop (CurrentSymbol.itemNo, op) DO⓪(IF (op = or) THEN⓪*handleOr⓪(ELSE⓪*GetSymbol;⓪*term ();⓪*handleOp⓪(END⓪&END;⓪&⓪&IF NOT InConstExpr & generateDebugCode () THEN⓪(hdlDebug;⓪&END;⓪&⓪&AddLabelsTo (localTrue, true);⓪&AddLabelsTo (localFalse, trueNot)⓪$END simpleExpression;⓪ ⓪ ⓪"(* ----------------------------------------------------------------------- *)⓪ ⓪ ⓪"VAR lconst, rconst: BOOLEAN;⓪ ⓪"PROCEDURE inSet (VAR expr, set: ExprDesc);⓪$⓪$PROCEDURE makeFalse;⓪&BEGIN⓪(clearExpr (set); (* damit ggf. Daten vom A3-Stack geräumt werden *)⓪(initExpr (set, BoolPtr, constant);⓪(set.exprConst.w:= WORD (FALSE);⓪(PushExpr (set)⓪&END makeFalse;⓪ ⓪$VAR lo, hi: ZZ; n: CARDINAL; relOp: Operator;⓪(old, max: ExprDesc; size: CARDINAL; codePtr: ADDRESS;⓪ ⓪$BEGIN⓪&relOp:= ne;⓪&getBounds (RefType (set.item), lo, hi);⓪ ⓪&size:= SHORT (Size (set));⓪&(*$? Safety: assert (set.typeChecked);*)⓪&IF set.regset⓪&AND ( (set.kind = register)⓪+OR NOT lconst⓪+OR NOT inZZ (expr.exprConst.zz,⓪8toZZ (LONG (size * 8 - 8), FALSE),⓪8toZZ (LONG (size * 8 - 1), FALSE) ) ) THEN⓪(prepareStackForLoad (set);⓪(IF bothOnStack (expr, set) THEN⓪*loadReg (set, dataRegs);⓪*restoreStack (set);⓪(END;⓪(reloadPtr (expr);⓪(prepareStackForLoad (expr);⓪ ⓪(IF lconst THEN⓪*(* BTST #x,set *)⓪*IF inZZ (expr.exprConst.zz, lo, hi) THEN⓪,IF NOT set.zerobased THEN⓪.subZZ (expr.exprConst.zz, lo);⓪,END;⓪,loadReg (set, dataRegs);⓪,restoreStack (set);⓪,genr (BTSTI, set.exprReg);⓪,gen (expr.exprConst.zz.c)⓪*ELSE⓪,(* wenn expr außerhalb des Set, ist Erg. immer FALSE *)⓪,makeFalse;⓪,RETURN⓪*END⓪(ELSE⓪*(* BTST expr-Reg,set *)⓪,(*⓪-* Wenn expr > MAX (set), muß FALSE geliefert werden.⓪-* Das geht so:⓪-* MOVE expr,Dx⓪-* MOVE #hi,Dy ;hier kein CMPI, weil dann Abfrage invertiert⓪-* CMP Dx,Dy ;und dadurch 'SHI' nicht mehr anwendbar wäre⓪-* BCS false ; > C=1⓪-* MOVE set,Ds⓪-* BTST Dx,Ds⓪-* false⓪-* SHI bool ; Z=0 & C=0⓪-*)⓪*loadReg (expr, anyDataReg);⓪*IF NOT set.zerobased THEN⓪,negZZ (lo);⓪,loadReg (expr, dataRegs);⓪,incReg (expr.exprReg, lo, 2);⓪*END;⓪*initConstExpr (max, 2, hi);⓪*loadReg (max, addrRegs + dataRegs);⓪*genar (CMP, expr, max.exprReg);⓪*deallocRegs (max);⓪*gen (Bcc + mapCC (cc, FALSE, TRUE));⓪*codePtr:= CodePtr ();⓪*restoreStack (set);⓪*loadReg (set, anyDataReg);⓪*genarSized (BTST, set, expr.exprReg, -1);⓪*setByte (codePtr - 1L,⓪3SHORT (WORD (SHORT (LONGCARD (CodePtr () - codePtr)))));⓪*relOp:= gt⓪(END⓪ ⓪&ELSE⓪ ⓪(IF lconst THEN⓪*IF inZZ (expr.exprConst.zz, lo, hi) THEN⓪,prepareStackForLoad (set);⓪,IF NOT set.zerobased THEN⓪.subZZ (expr.exprConst.zz, lo);⓪,END;⓪,n:= expr.exprConst.zz.c DIV 8;⓪,IF set.regset THEN⓪.n:= SHORT (Size (set)) - 1 - n⓪,END;⓪,IF n > 0 THEN⓪.(*$? Safety: assert (NOT set.regset);*)⓪.loadExprAddress (set, old);⓪.makeIndir (set, n, FALSE)⓪,ELSIF (set.kind = stack) & (set.stackedSize > 1L) THEN⓪.(*$? Safety: assert ((set.stackReg = A3) & ~set.up);*)⓪.incReg (A3, toZZ (- LONGINT (set.stackedSize), TRUE), 4);⓪.changeStackToIndir (set)⓪,END;⓪,genia (BTSTI, expr.exprConst.zz.c, set, -1);⓪,IF n > 0 THEN⓪.updateStack (old)⓪,END⓪*ELSE⓪,(* wenn expr außerhalb des Set, ist Erg. immer FALSE *)⓪,makeFalse;⓪,RETURN⓪*END⓪(ELSE⓪*reloadPtr (expr);⓪*runtimeElemSet (expr, set, in, lo);⓪(END;⓪ ⓪&END;⓪&deallocRegs (set);⓪&restoreStack (expr);⓪&deallocRegs (expr);⓪&WITH set DO⓪(item:= BoolPtr;⓪(kind:= condFlags;⓪(fpuFlags:= FALSE;⓪(signed:= FALSE;⓪(not:= FALSE;⓪&END;⓪&set.relOp:= relOp;⓪&PushExpr (set)⓪$END inSet;⓪ ⓪"PROCEDURE finish (VAR right, left: ExprDesc; op: Operator; sign: BOOLEAN);⓪$BEGIN⓪&deallocRegs (right);⓪&restoreStack (left);⓪&deallocRegs (left);⓪&WITH right DO⓪(item:= BoolPtr;⓪(kind:= condFlags;⓪(fpuFlags:= FALSE;⓪(relOp:= op;⓪(not:= FALSE;⓪(signed:= sign;⓪&END;⓪&PushExpr (right)⓪$END finish;⓪ ⓪"PROCEDURE cmp (op: Operator; signed: BOOLEAN; VAR left, right: ExprDesc);⓪$BEGIN⓪&IF rconst OR lconst THEN⓪(IF rconst THEN (* damit wird 'right' immer zur Ergebnis-Expr *)⓪*swapExpr (left, right);⓪*rconst:= FALSE; lconst:= TRUE;⓪*swapOp (op)⓪(END;⓪(IF rconst & nullZZ (right.exprConst.zz)⓪(OR lconst & nullZZ (left.exprConst.zz) THEN⓪*IF signed THEN⓪,swapOp (op)⓪*ELSE⓪,IF (op = gt) OR (op = le) THEN⓪.(* ist bei unsigned immer konstant *)⓪.cancelExpr (right);⓪.restoreStack (right);⓪.deallocRegs (right);⓪.cancelExpr (left);⓪.restoreStack (left);⓪.deallocRegs (left);⓪.WITH right DO⓪0item:= BoolPtr;⓪0kind:= constant;⓪0exprConst.zz.over:= FALSE;⓪0exprConst.zz.l:= 0;⓪0exprConst.w:= WORD (op = le);⓪0not:= FALSE;⓪.END;⓪.PushExpr (right);⓪.RETURN⓪,ELSIF op = lt THEN op:= ne⓪,ELSIF op = ge THEN op:= eq END⓪*END;⓪*IF (right.kind = register) & (right.exprReg >= A0) THEN⓪,loadReg (right, dataRegs)⓪*ELSE⓪,gena (TST, right, 0)⓪*END;⓪(ELSE⓪*swapOp (op);⓪*genia (CMPI, left.exprConst.zz.v, right, 0);⓪(END;⓪(restoreStack (right);⓪&ELSE⓪(swapOp (op);⓪(loadReg (right, dataRegs);⓪(restoreStack (right);⓪(genar (CMP, left, right.exprReg)⓪&END;⓪&finish (right, left, op, signed);⓪$END cmp;⓪ ⓪"PROCEDURE relop (n: CARDINAL; VAR op: Operator): BOOLEAN;⓪$BEGIN⓪&CASE n OF⓪&| 18: op:= eq;⓪&| 47, 20: op:= ne⓪&| 21: op:= le;⓪&| 22: op:= ge;⓪&| 23: op:= lt;⓪&| 24: op:= gt;⓪&ELSE⓪(RETURN FALSE⓪&END;⓪&RETURN TRUE⓪$END relop;⓪"⓪"VAR op: Operator;⓪"⓪"PROCEDURE handleOp;⓪$VAR⓪&left, right: ExprDesc;⓪&resultType: PtrItem;⓪&itemno: CARDINAL;⓪$BEGIN⓪&PopExpr (right);⓪&PopExpr (left);⓪ ⓪&checkCompat (left, right, resultType, rBdTyp);⓪&⓪&lconst:= left.kind = constant;⓪&rconst:= right.kind = constant;⓪&IF lconst & rconst OR (left.kind = constRef) & (right.kind = constRef) THEN⓪(constantFold (op, left, right);⓪&ELSE⓪(itemno:= ItemNo (resultType);⓪(IF itemno IN ItemSet {19,44,6,38,39,21,26,8,25,41,33,1,3,9,24,34,22,23,20,35,30} THEN⓪*IF itemno IN ItemSet {19,44,6,38,39,21,26,8,25} THEN⓪,IF (op # eq) & (op # ne) THEN⓪.SyntaxError (rOpqOp)⓪,END;⓪,IF itemno = 44 THEN⓪.(* 8 Byte-Vergleich durchführen *)⓪.IF ItemNo (right.item) # 44 THEN moveLocalProcOnA3 (right) END;⓪.IF ItemNo (left.item) # 44 THEN moveLocalProcOnA3 (left) END;⓪.runtimeCmp8Byte (left, right);⓪.finish (right, left, op, FALSE);⓪.RETURN⓪,END⓪*END;⓪*prepareStackForLoad (right);⓪*IF bothOnStack (left, right) THEN⓪,loadReg (right, dataRegs);⓪,restoreStack (right);⓪*END;⓪*reloadPtr (left);⓪*prepareStackForLoad (left);⓪*cmp (op, itemno IN ItemSet {33,1} (* signed types *), left, right);⓪(ELSIF (itemno = 5) OR (itemno = 45) THEN⓪*(* SET *)⓪*setOp (op, left, right, resultType)⓪(ELSIF (itemno = 2) OR (itemno = 40) THEN⓪*(* REAL, LONGREAL *)⓪*prepareStackForLoad (right);⓪*IF bothOnStack (left, right) THEN⓪,loadRealReg (right, floatRegs);⓪,restoreStack (right);⓪*END;⓪*reloadPtr (left);⓪*prepareStackForLoad (left);⓪*realOp (op, right, left);⓪(ELSE⓪*SyntaxError (rOpTyp)⓪(END⓪&END⓪$END handleOp;⓪ ⓪"PROCEDURE handleIn;⓪$VAR⓪&left, right: ExprDesc;⓪&range: ConvDesc;⓪$BEGIN⓪&PopExpr (right);⓪&PopExpr (left);⓪&⓪&IF (ItemNo (right.item) # 5) & (ItemNo (right.item) # 45) THEN SyntaxError (rOpTyp) END;⓪&checkAsnCompat (left, RefType (right.item), range, rBdTyp);⓪&⓪&lconst:= left.kind = constant;⓪&rconst:= (right.kind = constRef) OR (right.kind = constant);⓪&IF lconst & rconst THEN⓪(constantFold (in, left, right);⓪&ELSE⓪(inSet (left, right)⓪&END⓪$END handleIn;⓪ ⓪"PROCEDURE checkCondFlags;⓪$VAR expr: ExprDesc;⓪$BEGIN⓪&LookExpr (expr);⓪&IF expr.kind = condFlags THEN⓪(PopExpr (expr);⓪(loadReg (expr, dataRegs);⓪(PushExpr (expr);⓪&END;⓪$END checkCondFlags;⓪ ⓪"BEGIN (* expression *)⓪$InitLabels (false);⓪$InitLabels (true);⓪$InitLabels (falseNot);⓪$InitLabels (trueNot);⓪$simpleExpression ();⓪$IF relop (CurrentSymbol.itemNo, op) THEN⓪&GetSymbol;⓪&checkCondFlags;⓪&simpleExpression ();⓪&handleOp;⓪$ELSIF CurrentSymbol.itemNo = 53 (* IN *) THEN⓪&GetSymbol;⓪&simpleExpression ();⓪&handleIn;⓪$END;⓪"END expression;⓪ ⓪ ⓪ PROCEDURE hdlBool (VAR expr: ExprDesc;⓪3VAR false, true, falseNot, trueNot: Labels; debug: BOOLEAN);⓪"VAR target: Label;⓪"BEGIN⓪$AddLabelsTo (false, true);⓪$AddLabelsTo (falseNot, trueNot);⓪$IF expr.kind = constant THEN⓪&Solve (true);⓪&Solve (trueNot);⓪$ELSE⓪&IF expr.kind = condFlags THEN⓪(loadReg (expr, dataRegs)⓪&END;⓪&IF unSolved (trueNot) THEN⓪(loadReg (expr, dataRegs);⓪(IF expr.not = FALSE THEN (* BRA des letzten Wertes hinter EORI erzeugen *)⓪*genbcc (mapAlways (), FALSE, target);⓪*MarkRef (target, true)⓪(END;⓪(Solve (trueNot);⓪(expr.not:= TRUE;⓪&END;⓪&IF expr.not THEN⓪(loadReg (expr, dataRegs);⓪(genia (EORI, CARDINAL (1), expr, 0);⓪(expr.not:= FALSE;⓪&END;⓪&IF unSolved (true) THEN⓪(loadReg (expr, dataRegs);⓪(Solve (true);⓪&END;⓪$END;⓪$IF debug THEN⓪&handleDebug (expr)⓪$END⓪"END hdlBool;⓪ ⓪ ⓪ PROCEDURE VarExpression ();⓪"VAR false, true, trueNot, falseNot: Labels;⓪"PROCEDURE doBool;⓪$VAR expr: ExprDesc;⓪$BEGIN⓪&PopExpr (expr);⓪&hdlBool (expr, false, true, falseNot, trueNot,⓪/NOT InConstExpr & generateDebugCode ());⓪&PushExpr (expr)⓪$END doBool;⓪"BEGIN⓪$expression (FALSE, false, true, falseNot, trueNot);⓪$IF BooleanType (exprStack[exprSp].expr.item) THEN⓪&doBool;⓪$ELSE⓪&(*$? Safety: assert (NOT (unSolved (true) OR unSolved (false)))*)⓪$END;⓪"END VarExpression;⓪ ⓪ ⓪ PROCEDURE ConstExpression;⓪"VAR false, true, trueNot, falseNot: Labels; old: BOOLEAN;⓪"PROCEDURE get;⓪$VAR expr: ExprDesc; size: LONGCARD;⓪$BEGIN⓪&PopExpr (expr);⓪&IF (expr.kind # constant) AND (expr.kind # constRef) THEN⓪(SyntaxError (rConXp)⓪&END;⓪&IF BooleanType (expr.item) THEN⓪(hdlBool (expr, false, true, falseNot, trueNot, FALSE)⓪&ELSE⓪((*$? Safety: assert (NOT (unSolved (true) OR unSolved (false)))*)⓪&END;⓪&PushExpr (expr);⓪$END get;⓪"BEGIN⓪$old:= InConstExpr;⓪$InConstExpr:= TRUE;⓪$expression (FALSE, false, true, falseNot, trueNot);⓪$get;⓪$InConstExpr:= old⓪"END ConstExpression;⓪ ⓪ ⓪ PROCEDURE BoolExpression (VAR false: Labels);⓪"VAR true, trueNot, falseNot: Labels; debug: BOOLEAN;⓪"PROCEDURE get;⓪$VAR help, expr: ExprDesc; ptr: ADDRESS; target: Label;⓪$BEGIN⓪&PopExpr (expr);⓪&IF NOT BooleanType (expr.item) THEN SyntaxError (rBolXp) END;⓪&(*⓪'* Anwendung durch IF, WHILE, UNTIL.⓪'* In allen Fällen wird im TRUE-Fall immer direkt hinter diese⓪'* Expr. gesprungen, im FALSE-Fall werden die offenen Labels auf⓪'* den Integer-Stack gebracht, so daß die IF/WHILE/UNTIL-Anweisung⓪'* diese am Ende auflösen kann (mit 'ToHere', gibt's auch in SYMBOL)⓪'*)⓪&IF debug THEN⓪(hdlBool (expr, false, true, falseNot, trueNot, TRUE);⓪&END;⓪&IF expr.kind = constant THEN⓪(IF BOOLEAN (expr.exprConst.w) = TRUE THEN⓪*(*⓪+* Alle Labels hierher, keine false-Labels übriglassen⓪+*)⓪*Solve (true);⓪*Solve (false);⓪(ELSE⓪*(*⓪+* Alle Sprünge zum false-Label, dann Code-Erzeugung unterdrücken⓪+* Da aber nicht sicher ist, daß nicht vielleicht doch Code erz.⓪+* wird, wird zur Sicherheit vorher noch ein BRA zum false-Lbl erzeugt⓪+* ~~~ die mögl. Code-Erzeugung könnte durch Vergleich der CodePtr⓪+* erkannt werden.⓪+*)⓪*genbcc (mapAlways (), FALSE, target);⓪*MarkRef (target, false);⓪*AddLabelsTo (true, false);⓪*SuppressCode:= TRUE⓪(END⓪&ELSE⓪(tstAndJmp (FALSE, expr, false, help, ptr);⓪(Solve (true);⓪&END;⓪$END get;⓪"BEGIN⓪$GetSymbol;⓪$debug:= NOT InConstExpr & generateDebugCode ();⓪$expression (~debug, false, true, trueNot, falseNot);⓪$get⓪"END BoolExpression;⓪ ⓪ ⓪ (* ************************************************************************* *)⓪ (* ************************************************************************* *)⓪ ⓪ PROCEDURE fitExpression (VAR expr, dest: ExprDesc; REF range: ConvDesc);⓪"BEGIN⓪$IF isSS (expr) & isStringVar (dest.item) THEN⓪&terminateStringConst (expr, dest.item)⓪$END;⓪$PushExpr (dest);⓪$fitValue (expr, range); (* Expand & Range-Check *)⓪$PopExpr (dest);⓪"END fitExpression;⓪ ⓪ PROCEDURE moveTo (VAR expr, dest: ExprDesc;⓪2sync, fillUp, destOpenArr, oddDest: BOOLEAN;⓪2REF range: ConvDesc);⓪"(*⓪#* sync: TRUE -> Stack immer gerade halten⓪#* fillUp: TRUE -> Stack immer bis zur Dest-Länge auffüllen⓪#* destOpenArr: TRUE -> Strings brauchen nicht Null-terminiert werden⓪#* oddDest: TRUE -> 'dest' beginnt mit Sicherheit auf ungerader Adr.⓪#*⓪#* Wenn sync=TRUE und kein Byte-Copy oder oddDest, kann der MOVE auf gerade⓪#* Werte aufgerundet werden, weil ein MOVE.B von der CPU eh einen Word-⓪#* Zugriff macht.⓪#*)⓪ ⓪"VAR l, sourceSize, destSize: LONGCARD; p: ADDRESS; mustCopy, byByte: BOOLEAN;⓪ ⓪"PROCEDURE callCopy (long: BOOLEAN);⓪$BEGIN⓪&runtimeConstCopy (expr, dest, long, sourceSize);⓪$END callCopy;⓪ ⓪"PROCEDURE copyLoop (VAR source, dest: ExprDesc; size: LONGCARD);⓪$⓪$VAR elemSize: CARDINAL; n: LONGCARD; count: ExprDesc; a3, a7: LONGINT;⓪$⓪$BEGIN⓪&(* Schleife erzeugen *)⓪&IF byByte THEN⓪(elemSize:= 1; n:= size⓪&ELSE⓪(elemSize:= 4; n:= size DIV 4L⓪&END;⓪&(* Kopierschleife direkt erzeugen *)⓪&IF source.kind = constant THEN⓪(changeConstantToConstRef (source, size);⓪(changeToStack (source)⓪&END;⓪&initConstExpr (count, 2, toZZ (n-1L, FALSE));⓪&loadReg (count, dataRegs);⓪&a3:= A3Offset; a7:= A7Offset;⓪&moveSingle (source, dest, elemSize);⓪&INC (dest.stackedSize, LONG (elemSize) * (n-1L));⓪&INC (A7Offset, (A7Offset-a7) * LONGINT (n-1L));⓪&INC (A3Offset, (A3Offset-a3) * LONGINT (n-1L));⓪&genDBcc (mapNever (), count.exprReg, -4);⓪&deallocRegs (count);⓪&DEC (size, n * LONG (elemSize));⓪&IF size > 0L THEN⓪(copy (source, dest, size, byByte)⓪&END⓪$END copyLoop;⓪"⓪"PROCEDURE prepareCopy;⓪$(*⓪%* Bereitet Pointer für Aufruf von 'copy' und 'copyLoop' vor:⓪%* Ptr werden ggf. für PostInc gesetzt.⓪%* Nicht aufzurufen, wenn 'runtimeConstCopy' benutzt wird, weil⓪%* im Runtime ggf. nochmal A3 benutzt wird, was aber hier schon⓪%* durch die PostInc-Vorbereitung nicht mehr erlaubt wäre.⓪%*)⓪$BEGIN⓪&(* prüfen, ob PostInc gemacht werden muß *)⓪&IF dest.kind = stack THEN⓪(IF expr.kind = stack THEN⓪*IF NOT dest.up THEN⓪,(* gen. MOVE -(A7),-(A3) *)⓪*ELSE⓪,(*$? Safety: assert (sourceSize = destSize);*)⓪,makePostInc (expr, expr.stackedSize (*das war mal: sourceSize*))⓪.(* wenn mit 'stackedSize' nun irgendwo schiefgeht, dafür sorgen,⓪/* daß stackedSize richtig gesetzt ist, denn 'sourceSize' darf⓪/* nicht verw. werden, weil sonst in 'hdlArrayConstructor' nicht⓪/* ein doppeltes Entfernen vom A3-Stack bei Var-Replikatoren⓪/* verhindert werden kann (dort wird manuell A3 korrigiert und⓪/* dann stackedSize auf 0 gesetzt, damit es hier nicht nochmal⓪/* passiert *)⓪*END⓪(ELSE⓪*makePostInc (dest, destSize) (* dest: (An)+ *)⓪(END⓪&ELSE⓪(changeToStack (dest); (* dest: (An)+ *)⓪(IF expr.kind = stack THEN⓪*(*$? Safety: assert (sourceSize = destSize);*)⓪*makePostInc (expr, expr.stackedSize (*das war mal: sourceSize*))⓪,(* Bei Problemen: siehe oben, anderer makePostInc-Aufruf *)⓪(END;⓪&END;⓪&IF expr.kind # constant THEN⓪(IF (expr.kind = register) & (expr.exprReg >= F0) THEN⓪*(*$? Safety: assert (isReal (expr.item) & (fpu () = softReal));*)⓪*deallocReg (expr.exprReg);⓪*initPseudoRegExpr (expr, expr.item, expr.exprReg, FALSE);⓪(END;⓪(changeToStack (expr); (* expr: (An)+, falls nicht -(An) *)⓪&END;⓪$END prepareCopy;⓪"⓪"PROCEDURE prepareStacks;⓪$BEGIN⓪&IF sync THEN⓪(syncStacks (expr, dest, TRUE)⓪&ELSE⓪(adaptStack (expr, sourceSize)⓪&END;⓪$END prepareStacks;⓪"⓪"BEGIN⓪$IF NOT destOpenArr THEN⓪&fitExpression (expr, dest, range);⓪$END;⓪$reloadPtr (dest);⓪$⓪$sourceSize:= Size (expr);⓪$IF destOpenArr THEN⓪&destSize:= roundedUp (sourceSize)⓪$ELSE⓪&IF (dest.kind = stack) & sync THEN⓪(destSize:= roundedSize (dest)⓪&ELSE⓪(destSize:= Size (dest)⓪&END⓪$END;⓪$⓪$(* Ob byteweise kopiert werden muß, muß schon hier ermittelt werden,⓪%* weil durch die folg. Funktionen ggf. die Informationen darüber⓪%* verloren gehen können. *)⓪$byByte:= oddDest OR mustCopyByByte (expr) OR mustCopyByByte (dest);⓪%(*~~~ hier könnte optimiert werden: dies kommt vor, wenn daten f. value constr. auf den stack kommen.⓪+wenn dabei ein datum ungerader länge war, steht SP nun auf ungerader Adr. Wenn nun eine Konst.⓪+aufgeladen wird, bräuchte nur das 1. Byte byteweise kopiert werden, der Rest geht dann doch wortweise. *)⓪ ⓪$IF sync & ODD (sourceSize) & (sourceSize < destSize)⓪$& (expr.kind # register) THEN⓪&(* Falls expr eine ungerade Größe hat, wird sie um eins vergrößert, damit⓪'* - aus einem MOVE.W und einem MOVE.B ein MOVE.L wird (nicht nur bei⓪'* Stack-Pushs sondern auch bei Zuw. auf Var);⓪'* - bei Stack-Pushs kein extra Sync mehr erzeugt werden braucht.⓪'* Darf nur bei Konstanten und bei Laden aus Memory, jedoch nicht bei⓪'* Move von Reg nach Memory/Stack. *)⓪&IF (sourceSize = 3) & NOT byByte⓪&OR (dest.kind = stack)⓪)AND ( (sourceSize = 1) & NOT ((expr.kind = memory) & expr.mayBeOdd)⓪/OR (sourceSize > 1) & NOT byByte ) THEN⓪(IF expr.kind = constant THEN⓪*shiftLeft (expr, 1);⓪(END;⓪(INC (sourceSize);⓪(IF destSize < sourceSize THEN destSize:= sourceSize END⓪&END⓪$END;⓪ ⓪$mustCopy:= TRUE;⓪$IF (expr.kind = dest.kind) THEN⓪&CASE expr.kind OF⓪&| register: mustCopy:= expr.exprReg # dest.exprReg⓪&| stack: mustCopy:= (expr.stackReg # dest.stackReg) OR⓪=(expr.up = dest.up);⓪&ELSE⓪&END;⓪$END;⓪ ⓪$IF mustCopy THEN⓪"⓪&(*⓪'* ist Zuweisung mit einer einzigen Instr. durchführbar?⓪'*)⓪&IF (sourceSize = 1L)⓪&OR NOT byByte AND (sourceSize # 3L) AND (sourceSize <= 4L)⓪&OR (expr.kind = register) & (expr.exprReg >= F0) & (fpu () # softReal)⓪&OR (dest.kind = register) & (dest.exprReg >= F0) & (fpu () # softReal)⓪&THEN⓪(⓪(IF sync THEN⓪*syncStacks (expr, dest, TRUE)⓪(ELSE⓪*(*$? Safety: assert ( (expr.kind # stack) OR (expr.stackReg # A7)⓪?AND (dest.kind # stack) OR (dest.stackReg # A7) );*)⓪*adaptStack (expr, sourceSize)⓪(END;⓪(IF (expr.kind = register) & (expr.exprReg >= F0)⓪(OR (dest.kind = register) & (dest.exprReg >= F0) THEN⓪*(*$? Safety: assert (isReal (expr.item));*)⓪*assignRealReg (expr, dest);⓪(ELSE⓪*copy (expr, dest, sourceSize, FALSE); (* MOVE.x expr,dest *)⓪(END;⓪(IF fillUp & ~destOpenArr & isSS (expr) THEN⓪*(*~~~ nur, wenn auf A3? *)⓪*fillStack (dest, destSize);⓪(ELSIF sync THEN⓪*syncStacks (expr, dest, FALSE)⓪(END;⓪(⓪&ELSE⓪(⓪(IF byByte & (dest.kind = stack) THEN⓪*(* wenn mehrere Bytes mit "-(A7)" kopiert werden müssen, *⓪+* muß der SP dazu in ein Hilfsreg. geladen werden *)⓪*makePostInc (dest, destSize);⓪(END;⓪ ⓪(IF expr.kind = constRef THEN⓪*(*~~~ null-const erkennen! -> constante cutten und clr-loop gen.! *)⓪(END;⓪(⓪(IF NOT byByte & (sourceSize <= 16L) OR byByte & (sourceSize <= 4L) THEN⓪*(* Direkt kopieren, wenn <= 16 Byte, aber nicht bei Byte-Daten *⓪+* Somit entstehen bis zu 4 MOVE.L *)⓪*prepareCopy;⓪*prepareStacks;⓪*copy (expr, dest, sourceSize, byByte)⓪(ELSE⓪*IF sourceSize >= 256L THEN⓪,(* ab 256 Byte kann ggf. MOVEM-Routine aus Block-Modul verw. werden *)⓪,(* Runtime: Copy (4MB), prüfen, ob Byte/Long-Moves *)⓪,IF sync THEN syncStacks (expr, dest, TRUE) END; (* nicht prepareStacks, weil 'adaptStack' nicht darf *)⓪,callCopy (TRUE);⓪*ELSE⓪,IF byByte & (sourceSize >= 20L) (*~~~ besten Wert ausprobieren *) THEN⓪.(* bei großen Byte-Mengen soll Runtime-Routine prüfen, ob sie *⓪/* doch wortweise kopieren kann *)⓪.(* Runtime: Copy (64KB), prüfen, ob Byte/Long-Moves *)⓪.IF sync THEN syncStacks (expr, dest, TRUE) END; (* nicht prepareStacks, weil 'adaptStack' nicht darf *)⓪.callCopy (FALSE);⓪,ELSE⓪.prepareCopy;⓪.prepareStacks;⓪.copyLoop (expr, dest, sourceSize);⓪,END⓪*END⓪(END;⓪(IF fillUp & ~destOpenArr & isSS (expr) THEN⓪*(*~~~ nur, wenn auf A3? *)⓪*fillStack (dest, destSize);⓪(ELSIF sync THEN⓪*syncStacks (expr, dest, FALSE)⓪(END⓪&⓪&END; (* ... ELSE ... *)⓪&⓪$END; (* IF mustCopy *)⓪"⓪"END moveTo;⓪ ⓪ ⓪ PROCEDURE moveToVar (VAR expr, var: ExprDesc; range: ConvDesc);⓪"(*⓪#* kopiert Datum nach 'var'. Bei String-Konstanten wird entsprechend⓪#* nur der benötigte Teil kopiert.⓪#*)⓪"BEGIN⓪$moveTo (expr, var, FALSE, FALSE, FALSE, FALSE, range);⓪$deallocRegs (expr);⓪"END moveToVar;⓪ ⓪ ⓪ PROCEDURE addToVar (expr: ExprDesc; VAR st: ExprDesc;⓪4odd, more: BOOLEAN; VAR range: ConvDesc);⓪"(*⓪#* Kopiert Datum als Teil einer Variablen ('st' muß Stack sein!).⓪#* Wird von value constructors benutzt⓪#*)⓪"BEGIN⓪$(*$? Safety: assert ((st.kind = stack) & (st.up));*)⓪$moveTo (expr, st, FALSE, more, FALSE, odd, range);⓪$deallocRegs (expr);⓪"END addToVar;⓪ ⓪ ⓪ PROCEDURE makeStackIndir (VAR expr: ExprDesc; ofs: LONGINT);⓪"(*⓪#* macht aus Stack-Adressierung eine indirecte Adressierung mit Offset⓪#*)⓪"BEGIN⓪$WITH expr DO⓪&(*$? Safety: assert ((kind = stack) & (restoreAfterUse = 0L));*)⓪&kind:= memory;⓪&baseReg:= stackReg;⓪&mayBeOdd:= FALSE;⓪&mode:= d16An;⓪&disp:= ofs;⓪$END⓪"END makeStackIndir;⓪ ⓪ ⓪ PROCEDURE loadOnA7 (VAR expr: ExprDesc; range: ConvDesc; VAR size: LONGCARD);⓪"(*⓪#* Kopiert Datum auf den A7-Stack. 'expr' zeigt hinterher auf das Datum⓪#* Wird von 'forStatement' benutzt⓪#*)⓪"VAR st: ExprDesc;⓪"BEGIN⓪$initStackExpr (st, expr.item, A7);⓪$moveTo (expr, st, TRUE, TRUE, FALSE, FALSE, range);⓪$deallocRegs (expr);⓪$size:= st.stackedSize;⓪$makeStackIndir (st, 0);⓪$expr:= st⓪"END loadOnA7;⓪ ⓪ PROCEDURE loadOnA3 (VAR expr: ExprDesc; range: ConvDesc);⓪"(*⓪#* Kopiert Datum auf den A3-Stack. Der Stack wird immer aufgefüllt.⓪#* Wird z.B. von RETURN und Übergaben an alte Routinen im Compiler⓪#* (z.B. CASE) benutzt.⓪#* 'expr' zeigt hinterher auf den A3-Stack⓪#*)⓪"VAR st: ExprDesc; t: PtrItem;⓪"BEGIN⓪$t:= expr.item;⓪$initStackExpr (st, range.destType, A3);⓪$moveTo (expr, st, TRUE, TRUE, FALSE, FALSE, range);⓪$deallocRegs (expr);⓪$expr:= st;⓪$WITH expr DO⓪&(*$? Safety: assert ((kind = stack) & (stackReg = A3));*)⓪&item:= t;⓪&up:= FALSE⓪$END;⓪"END loadOnA3;⓪ ⓪ ⓪ PROCEDURE moveOpenArray (VAR expr, parm, data: ExprDesc; mustCopy: BOOLEAN);⓪"(*⓪#* expr: Das Argument⓪#* parm: Stack f. Parameter⓪#* data: Stack f. Zwischenablage⓪#*)⓪"VAR count, help, highPtr: ExprDesc;⓪&exprBase, parBase, exprType, parType: PtrItem;⓪&opcode, n, instrs, instrSize: CARDINAL;⓪&size: LONGCARD;⓪&identical: BOOLEAN;⓪&odd, addedOne: BOOLEAN;⓪ ⓪ (*⓪"PROCEDURE pushPtr (r: RegType);⓪$(* trägt Pointer auf Datum nach, wenn value als Kopie übergeben wird *)⓪$VAR src, ptr: ExprDesc;⓪$BEGIN⓪&initRegExpr (ptr, 4, parm.stackReg);⓪&makeIndir (ptr, -LONGINT (parm.stackedSize), FALSE);⓪&initRegExpr (src, 4, r);⓪&genMOVEaa (src, ptr, 4);⓪$END pushPtr;⓪ *)⓪ ⓪"PROCEDURE makePtr (VAR ptr: ExprDesc);⓪$BEGIN⓪&initRegExpr (ptr, 4, parm.stackReg);⓪&makeIndir (ptr, -LONGINT (parm.stackedSize), FALSE);⓪$END makePtr;⓪ ⓪"PROCEDURE loadAndPushHigh (VAR highPtr, high: ExprDesc; mustExtend: BOOLEAN;⓪6VAR destHighSize: CARDINAL);⓪$(* hier wird high-wert ggf. auf den dest-high-wert expandiert *)⓪$(* folg. Vars von außeren werden benutzt/verändert:⓪%* parType, parBase, exprType, exprBase, identical, parm *)⓪$VAR destHighType: PtrItem;⓪(help: ExprDesc;⓪(exprSize, fact: LONGCARD;⓪(n: CARDINAL;⓪$BEGIN⓪&(*⓪'* Drei Möglichkeiten:⓪'* 1. beide sind ein ARRAY/LONGARRAY OF ARRAY ...⓪'* 2. beide sind ein ARRAY/LONGARRAY OF T⓪'* 3. Der Par ist ein ARRAY/LONGARRAY OF BYTE/WORD/LONGWORD⓪'* Bei Fall 1. und 2. wird lediglich der High-Wert auf den Stack geladen,⓪'* bei 3. wird er ggf. noch mit der Jokergröße skaliert⓪'*)⓪&exprBase:= OpenArrayType (exprType);⓪&parBase:= OpenArrayType (parType);⓪&IF isOpenArray (exprBase) THEN mustExtend:= TRUE END;⓪&IF identical & ~mustCopy THEN mustExtend:= FALSE END;⓪&IF isLongOpenArray (parType) THEN⓪(destHighType:= CardPtr;⓪(destHighSize:= 4⓪&ELSE⓪(IF mustExtend THEN⓪*destHighType:= CardPtr;⓪(ELSIF TypeLength (parBase) = 1 THEN⓪*destHighType:= SIntPtr⓪(ELSE⓪*destHighType:= SCardPtr⓪(END;⓪(destHighSize:= 2;⓪(IF Size (highPtr) > 2L THEN SyntaxError (rLgAOv) END⓪&END;⓪&IF isLongOpenArray (exprType) THEN highPtr.item:= CardPtr ELSE highPtr.item:= SCardPtr END;⓪&IF mustExtend THEN n:= 4 ELSE n:= destHighSize END;⓪&IF identical & ~mustCopy THEN⓪(moveSingle (highPtr, parm, destHighSize); (* MOVE (Ap)+,(A3)+ *)⓪&ELSE⓪(copyRegExt (highPtr, high, dataRegs, n); (* MOVE (Ap)+,Dh *)⓪&END;⓪&IF NOT varCompat (exprBase, parBase)⓪&AND NOT (isOpenArray (exprBase) & isOpenArray (parBase)) THEN⓪((* wenn 'expr' noch mehr Dims hat, diese alle miteinander multipl. *)⓪(WHILE isOpenArray (exprBase) DO⓪*(* in diesem Fall ist 'mustExtend' immer TRUE *)⓪*incReg (high.exprReg, toZZ (1,FALSE), 4);⓪*IF isLongOpenArray (exprType) THEN highPtr.item:= CardPtr ELSE highPtr.item:= SCardPtr END;⓪*copyRegExt (highPtr, help, dataRegs, 4);⓪*incReg (help.exprReg, toZZ (1,FALSE), 4);⓪*varMul (mul, help, high, FALSE, CardPtr);⓪*PopExpr (high);⓪*incReg (high.exprReg, toZZ (-1,TRUE), 4);⓪*exprBase:= OpenArrayType (exprBase);⓪(END;⓪((* Typen sind nicht gleich groß - ggf. HIGH umrechnen: *)⓪(exprSize:= TypeLength (exprBase); (* Größe der Elems vom Source-Array *)⓪(n:= jokerSize (ItemNo (parBase));⓪(IF n = 0 THEN (* kein Joker *) SyntaxError (rParTy) END;⓪(IF exprSize MOD LONG (n) # 0L THEN SyntaxError (rOddAr) END;⓪(fact:= exprSize DIV LONG (n);⓪&ELSE⓪(fact:= 1⓪&END;⓪&IF ~identical OR mustCopy THEN⓪((* hier wird auch ggf. Expand gemacht: *)⓪(constMul (high, destHighType, toZZ (fact, FALSE), FALSE);⓪(constAdd (high, destHighType, toZZ (fact-1, FALSE), FALSE);⓪(moveSingle (high, parm, destHighSize); (* MOVE.x Dh,(A3)+ *)⓪(IF ~mustCopy THEN deallocRegs (high) END⓪&END;⓪$END loadAndPushHigh;⓪ ⓪"VAR parSize, rn, dims: CARDINAL;⓪&fact, exprSize: LONGCARD;⓪&⓪"BEGIN (* moveOpenArray *)⓪$(*⓪%* Zuerst wird herausgefunden, ob Expr und Parameter kompatibel sind⓪%* und ob die HIGH-Werte identisch sind, weil dann eine optimierte⓪%* Zuweisung erfolgen kann.⓪%*⓪%* LONGARRAY und ARRAY sind kompatibel in beiden Richtungen, ggf. wird⓪%* ein Range-Error bei Laufzeit erkannt (bisher ist nur eine Richtung⓪%* möglich).⓪%* ARRAY OF BYTE/CHAR erlauben nur 32768 Elemente!⓪%*⓪%* Allgemeine Syntax bei Weitergabe von Open-Arrays:⓪%* Expr: {ARRAY Range OF} TX⓪%* Parm: {ARRAY OF | LONGARRAY OF} TP⓪%* Expr und Parm müssen die gleiche Anzahl Dimensionen haben, es sei⓪%* denn, TP ist ein Joker-Type - dann dürfen bei Expr noch weitere⓪%* Dim. folgen.⓪%* Das wird geprüft, indem für jede Open-Array-Dim. beim Parm⓪%* auch eine bei Expr verlangt wird.⓪%*⓪%* Ist TP kein Joker-Type, müssen TX & TP identisch sein und keine⓪%* HIGH-Umrechnung ist nötig. Bei Jokern wird der letzte HIGH-Wert⓪%* bei der Übergabe noch mit dem Faktor TSIZE(TX)/TSIZE(TP) erhöht.⓪%*)⓪$⓪$(*$? Safety: assert (expr.kind = memory);*) (* ist ja schließlich eine Var, oder? *)⓪$odd:= expr.mayBeOdd; (* 'assert' wird hierfür benötigt *)⓪$identical:= TRUE; (* -> HIGH-Werte sind identisch *)⓪$dims:= 0;⓪$parType:= data.item;⓪$(*$? Safety: assert (isOpenArray (parType));*)⓪$exprType:= expr.item;⓪$REPEAT⓪&INC (dims);⓪&parBase:= OpenArrayType (parType);⓪&exprBase:= OpenArrayType (exprType);⓪&IF NOT isOpenArray (exprType) THEN SyntaxError (rArDXp) END;⓪&IF isLongOpenArray (parType) # isLongOpenArray (exprType) THEN⓪(identical:= FALSE;⓪&END;⓪&exprSize:= TypeLength (exprBase); (* Größe der Elems vom Source-Array *)⓪&IF NOT varCompat (exprBase, parBase) THEN⓪((* Typen sind nicht gleich groß - ggf. HIGH umrechnen: *)⓪(n:= jokerSize (ItemNo (parBase));⓪(IF n = 0 THEN (* kein Joker *) SyntaxError (rParTy) END;⓪(IF exprSize MOD LONG (n) # 0L THEN SyntaxError (rOddAr) END;⓪(fact:= exprSize DIV LONG (n);⓪(IF fact # 1L THEN⓪*identical:= FALSE;⓪(END⓪&ELSE⓪(fact:= 1⓪&END;⓪&⓪&parType:= parBase;⓪&exprType:= exprBase;⓪$UNTIL NOT isOpenArray (parType);⓪$⓪$IF identical & (dims = 1) & (exprSize = 1L) THEN⓪$⓪&(*⓪'* Es ist ein eindim. Byte-Array mit identischen HIGH-Größen zu übergeben⓪'*)⓪&IF isLongOpenArray (expr.item) THEN n:= 8 ELSE n:= 6 END;⓪&IF mustCopy THEN⓪((* Das Kopieren wird von einer Runtime-Routine erledigt, die⓪)* lediglich die Adr. v. 'expr' erhält *)⓪(IF isLongOpenArray (expr.item) THEN⓪*rn:= CLOP⓪(ELSE⓪*rn:= CWOP⓪(END;⓪(IF parm.stackReg # A3 THEN⓪*SyntaxError (rNImpY)⓪*(* &&& Runtime-Routinen f. Datum->A3 fehlen⓪+* außerdem: dann muß beachtet werden, daß ggf. 'parm' ein⓪+* temp. hilfsreg verwendet und die Copy-Routine ggf. ein⓪+* spilling auslöst (z.B., wenn ein REF-Parm an einen value-oparr-⓪+* parm übergeben wird). wenn aber das hilfsreg zuerst gespillt⓪+* wird und dann die daten auf den stack geladen werden, dann⓪+* klappt das rückladen nicht mehr so einfach.⓪+* Hierzu muß auch erstmal "PushExpr (parm)" vor dem evtl. Spilling⓪+* erfolgen!⓪+*)⓪*(* DEC (A7Offset, n); *)⓪(ELSE⓪*INC (A3Offset, n);⓪(END;⓪(runtimeCopyOpenArray (expr, rn); (* kopiert Daten nach -(A7) *)⓪&ELSE⓪((* Ptr und HIGH-Wert werden wie bei einer Zuwsg. auf den Stack kopiert*)⓪(changeToStack (expr);⓪(copy (expr, parm, n, FALSE);⓪&END;⓪&deallocRegs (expr);⓪&⓪$ELSE⓪$⓪&initOpenArrayAccess (expr, TRUE);⓪&initHighExpr (expr, highPtr);⓪&⓪&IF parm.stackReg = A7 THEN⓪(SyntaxError (rNImpY) (*@@ Pushs rückwärts: HIGH zuerst!*)⓪&END;⓪&⓪&(*/// quick-and-dirty werden erstmal der pointer und der high-wert auf⓪'* den A3-stack geschmissen!! natürlich müssen die werte auch wahl-⓪'* weise auf den A7-stack kommen oder bei zuw. an opArr-Var sogar⓪'* noch ganz anders ausgewertet werden! *)⓪&IF NOT mustCopy THEN⓪((* natürlich kann der Pointer nur jetzt schon übergeben werden,⓪)* wenn nicht erst eine Kopie angelegt werden muß -- für diesen⓪)* Fall wird hier erstmal nur Platz für den Pointer geschaffen,⓪)* der dann erst später init. wird. *)⓪(moveAddress (expr, parm); (* MOVE.L An,(A3)+ *)⓪&ELSE⓪(incReg (parm.stackReg, toZZ (4L, FALSE), 4);⓪&END;⓪&INC (parm.stackedSize, 4);⓪&⓪&PushExpr (expr);⓪&⓪&parType:= data.item;⓪&exprType:= expr.item;⓪&⓪&loadAndPushHigh (highPtr, count, FALSE, n);⓪&⓪&addedOne:= FALSE;⓪&WHILE isOpenArray (parBase) DO⓪(parType:= parBase;⓪(exprType:= exprBase;⓪(IF mustCopy & NOT addedOne THEN⓪*constAdd (count, CardPtr, toZZ (1L, FALSE), FALSE);⓪*addedOne:= TRUE;⓪(END;⓪(loadAndPushHigh (highPtr, help, TRUE, n);⓪(IF mustCopy THEN⓪*constAdd (help, CardPtr, toZZ (1L, FALSE), FALSE);⓪*PushExpr (highPtr);⓪*varMul (mul, help, count, FALSE, CardPtr);⓪*PopExpr (count);⓪*PopExpr (highPtr);⓪*reloadPtr (highPtr);⓪(END⓪&END;⓪&⓪&deallocRegs (highPtr); (* Damit wird der Ptr auf die High-Werte freigegeben *)⓪&⓪&PopExpr (expr);⓪&reloadPtr (expr);⓪&⓪&size:= TypeLength (parBase);⓪&IF (size MOD 4L = 0L) THEN (* damit sind Byte-Types autom. ausgeschlossen *)⓪(instrSize:= 4;⓪(size:= size DIV 4L⓪&ELSIF (size MOD 2L = 0L) THEN (* damit sind Byte-Types autom. ausgeschlossen *)⓪(instrSize:= 2;⓪(size:= size DIV 2L⓪&ELSE⓪(instrSize:= 1;⓪&END;⓪&⓪&IF mustCopy THEN⓪&⓪(IF FALSE (*~~~ erstmal immer Runtime benutzen, weil kürzer;⓪2* am Ende sollte dies über option gesteuert werden können *)⓪(& NOT addedOne & (Size (count) = 2L) & (size = 1L) THEN⓪*(* Sonderfall: ARRAY OF BYTE/CHAR -> Kopierschleife gen. *)⓪(⓪((*~~~⓪*(*⓪+* Ist die Source kein Var/Ref-Parameter, liegt das Datum auf dem⓪+* Stack und kann daher immer word-weise kopiert werden. dazu wird⓪+* einfach die anzahl durch 2 geteilt. das gleich wird auch bei andern⓪+* Daten gemacht, nur werden dann immer zwei MOVE-Instr. auf einmal⓪+* erzeugt. Dies erspart die Gen. eines Sync und außerdem kann immer⓪+* ein SUB.W gemacht werden, ohne daß bei Werten > 32K falsch gerechnet⓪+* würde!⓪+*)⓪*opcode:= LSRI;⓪*getSizeAt6 (2, opcode);⓪*genr (opcode + $200 * 1, count.exprReg); (* "LSR.W #1,Dcount" *)⓪*⓪*IF data.stackReg = A7 THEN⓪,(* A7-Stack muß vor dem Kopieren runtergesetzt werden *)⓪,FOR n:= 1 TO 2 * instrSize DO⓪.(* wir ziehen count instrSize-mal von A7 ab *)⓪.genSUBA (FALSE, count.exprReg, A7); (* "SUBA.W Dcount,A7" *)⓪,END;⓪,incReg (A7, toZZ (LONG (-2 * INTEGER(instrSize)), TRUE), 4);⓪,(* ~~~ an dieser stelle ggf. stack-overflow prüfen. *)⓪,initRegExpr (help, 4, A7);⓪,loadReg (help, addrRegs);⓪,makeIndir (help, 0, FALSE);⓪,changeToStack (help)⓪*ELSE⓪,help:= data;⓪*END;⓪*⓪*(*⓪+* Nun kann der Pointer nachinit. werden.⓪+* Dazu wird folg. gen: "MOVE.L A3/A7,-x(Aparm)"⓪+*)⓪*pushPtr (data.stackReg);⓪*⓪*IF NOT odd & (instrSize = 1) OR (instrSize = 2) THEN⓪,instrSize:= instrSize * 2; (* aus MOVE.B mach MOVE.W, .W -> .L *)⓪,instrs:= 1;⓪*ELSE⓪,instrs:= 2 (* sonst kodiere den Befehl doppelt *)⓪*END;⓪*⓪*changeToStack (expr);⓪*FOR n:= 1 TO instrs DO⓪,genMOVEaa (expr, help, instrSize);⓪*END;⓪*genDBcc (mapNever (), count.exprReg, -2 -(2 * INTEGER(instrs)));⓪*⓪*IF data.stackReg = A7 THEN⓪,deallocRegs (help)⓪*END;⓪(⓪(*)⓪(⓪(ELSE⓪(⓪*(*⓪+* Bei größeren Basistypen oder mehreren Dims: Runtime aufrufen⓪+* Dabei gibt es folg. Variable:⓪+* - je nach instrSize wird @PUnB, @PUnW oder @PUnL aufgerufen,⓪+* das 'n' steht für '3' oder '7', je nach Destination-Stack.⓪+* - In A1 wird Ptr auf Source übergeben⓪+* - In D1.L wird Elementanzahl, jeweils f. Byte/Word/Long, übergeben⓪+* - In A0 wird Pointer auf Ptr f. erzeugte Kopie übergeben⓪+* - A2 kann von der Routine benutzt werden⓪+*)⓪*IF size # 1L THEN⓪,constMul (count, CardPtr, toZZ (size, FALSE), FALSE);⓪,IF NOT addedOne THEN⓪.constAdd (count, CardPtr, toZZ (size, TRUE), FALSE);⓪,END⓪*ELSIF NOT addedOne THEN⓪,constAdd (count, CardPtr, toZZ (1, TRUE), FALSE);⓪*END;⓪*makePtr (help); (* -x(A3): Adr von Ptr der Array-Kopie *)⓪*runtimeCopyOnStack (help, expr, count, instrSize, data.stackReg = A7);⓪*deallocRegs (help);⓪(END;⓪(deallocRegs (count)⓪&END;⓪&deallocRegs (expr);⓪$⓪$END; (* IF identical & (dims = 1) ELSE *)⓪$⓪"END moveOpenArray;⓪ (*$D-*)⓪ ⓪ ⓪ CONST MaxDynOpArrays = 10;⓪ ⓪ TYPE StackDesc = RECORD⓪3parm, data: ExprDesc;⓪3forParms: BOOLEAN; (* FALSE: value constructors *)⓪3odd: BOOLEAN; (* TRUE: letzter Push ließ SP ungerade *)⓪3openArray: BOOLEAN;⓪3parmIsA3: BOOLEAN;⓪3parmUsed: LONGCARD;⓪3dataUsed: LONGCARD;⓪3dataUsedDyn: BOOLEAN;⓪3stackOffset: LONGINT;⓪3firstParm: BOOLEAN;⓪3dataSP: RegType; (* A3 oder A7 *)⓪1END;⓪ ⓪ PROCEDURE moveToStack ((*kein VAR!*) expr: ExprDesc; VAR stacks: StackDesc;⓪7REF range: ConvDesc; ref, reg: BOOLEAN);⓪"(*⓪#* Die Expr wird als Parameter auf den Parm-Stack gebracht. Wenn es ein⓪#* Open Array Parameter ist, wird der Wert auf den Hilfsstack und seine⓪#* Ref. auf den Parm-Stack gebracht.⓪#* Wenn 'ref' TRUE, wird nicht der Wert, sondern dessen Referenz⓪#* auf den Stack gelegt, bei Konstanten werden diese dann ggf. im⓪#* Code abgelegt.⓪#* Bei String-Konstanten wird nur dann, wenn der Wert (ref = FALSE)⓪#* auf den Parameter-Stack soll, der Stack passend aufgefüllt -- bei⓪#* Ablage auf den Hilfs-Stack wird nur soviel draufgelegt, wie nötig.⓪#*⓪#* 'expr' wird auf jeden Fall freigegeben (mit 'deallocRegs')!⓪#*)⓪ ⓪"VAR ofs: LONGINT;⓪&noCheck, mustCopy: BOOLEAN;⓪&r: RegType;⓪&help: ExprDesc;⓪®s: RegSet;⓪&⓪"BEGIN⓪$mustCopy:= NOT ref; (* -> Datum muß kopiert werden. *)⓪$noCheck:= FALSE;⓪$⓪$IF stacks.dataUsedDyn THEN⓪&(* gesicherten SP ins Reg laden, falls er durch spill auf den Stack kam *)⓪&PopExpr (help);⓪&loadReg (help, dataRegs);⓪&PushExpr (help)⓪$END;⓪$⓪$IF ref & (expr.kind = register) THEN⓪&(*⓪'* Wenn eine REF-Übergabe verlangt ist, der Wert aber in einem⓪'* Reg steht, muß er trotzdem auf den Stack gelegt werden⓪'*)⓪&mustCopy:= TRUE;⓪$ELSIF (expr.kind = stack) THEN⓪&IF expr.stackReg = A3 THEN⓪(expr.up:= FALSE; (* damit der Wert ggf. mit "-(A3)" geholt wird *)⓪((* Datum liegt auf A3-Stack *)⓪(IF stacks.parmIsA3 THEN⓪*IF stacks.openArray OR ref THEN⓪,(* Ref soll auf A3-Stack *)⓪,(*&&& das geht noch nicht -- erklärung siehe unten bei "§§1"⓪-*mustCopy:= NOT stacks.firstParm (* umkopieren, wenn schon Parms auf A3 *)⓪-* stattdessen&&&: *) mustCopy:= TRUE; noCheck:= TRUE;⓪*ELSE⓪,(* Datum soll auf A3-Stack *)⓪,IF valueFitting (range) THEN⓪.stacks.odd:= FALSE;⓪.mustCopy:= FALSE (* wenn's paßt, ist kein move mehr nötig *)⓪,END⓪*END⓪(ELSE⓪*IF stacks.openArray OR ref THEN⓪,(* Ref soll auf A7-Stack -> kein move nötig *)⓪,mustCopy:= FALSE⓪*END⓪(END⓪&ELSE⓪((*$? Safety: assert (expr.stackReg = A7); *)⓪(expr.up:= TRUE; (* damit der Wert ggf. mit "(A7)+" geholt wird *)⓪((* Datum liegt auf A7-Stack *)⓪(IF stacks.parmIsA3 THEN⓪*IF stacks.openArray OR ref THEN⓪,(* Ref soll auf A3-Stack -> kein move nötig *)⓪,mustCopy:= FALSE⓪*END⓪(ELSE⓪*IF stacks.parm.stackReg = A7 THEN⓪,(* wenn mit Hilfsreg kopiert wird, muß immer kopiert werden,⓪-* das Datum darf nicht so auf dem A7 verbleiben! *)⓪,IF stacks.openArray OR ref THEN⓪.(* Ref soll auf A7-Stack *)⓪.(*&&& das geht noch nicht -- erklärung siehe unten bei "§§1"⓪/*mustCopy:= NOT stacks.firstParm (* umkopieren, wenn schon Parms auf A3 *)⓪/* stattdessen&&&: *) mustCopy:= TRUE; noCheck:= TRUE;⓪,ELSE⓪.(* Datum soll auf A7-Stack *)⓪.IF valueFitting (range) THEN⓪0stacks.odd:= FALSE;⓪0mustCopy:= FALSE (* wenn's paßt, ist kein move mehr nötig *)⓪.END⓪,END⓪*END⓪(END⓪&END⓪$END;⓪$⓪$IF isOpenArray (expr.item) THEN⓪&(*$? Safety2: assert (NOT reg); *)⓪&(*⓪'* Source ist ein Open Array. Wird normalerweise an einen Open-Array-⓪'* Parameter übergeben.⓪'* Dies kann aber auch vorkommen, wenn eine Open-Array-Var auf eine⓪'* andere oder ein Open Array-Parameter an eine solche Var zugewiesen⓪'* wird.⓪'*)⓪&IF mustCopy & NOT stacks.dataUsedDyn THEN⓪((* bei ersten Open-Array wird der alte SP nach D0 gerettet *)⓪((* "MOVE.L A7/A3,An" *)⓪(IF stacks.parmIsA3 THEN⓪*GlobalA7Hidden:= TRUE; (* nun kein A7-relativer Zugriff mehr möglich. *)⓪*LocalA7Hidden:= TRUE; (* nun kein A7-relativer Zugriff mehr möglich. *)⓪*LocalA7WhenHidden:= A7Offset;⓪*stacks.stackOffset:= A7Offset;⓪*r:= A7⓪(ELSE⓪*stacks.stackOffset:= A3Offset;⓪*r:= A3⓪(END;⓪(initRegExpr (help, 4, r);⓪(loadReg (help, dataRegs+addrRegs);⓪(stacks.dataUsedDyn:= TRUE;⓪(PushExprNoSpill (help)⓪&ELSIF stacks.dataUsedDyn THEN⓪(PopExpr (help);⓪(PushExprNoSpill (help)⓪&END;⓪&moveOpenArray (expr, stacks.parm, stacks.data, mustCopy);⓪&IF stacks.parmIsA3 THEN⓪(stacks.parm.stackedSize:= 0⓪&END;⓪&IF stacks.dataUsedDyn THEN⓪(PopExpr (help);⓪(PushExpr (help)⓪&END;⓪&⓪$ELSE⓪&⓪&IF mustCopy THEN⓪((* Value-Argument -> erstmal den Wert auf den Stack bringen *)⓪(IF stacks.openArray OR ref THEN⓪*(* Bei REF/VAR/Open Array Parameter muß das Datum auf den Hilfs-Stack *)⓪*IF stacks.openArray THEN⓪,(* Für 'ref' wird schon in 'call' der Stack geprüft.⓪-* >> TT 30.05.93: Nicht mehr - aber der Fall, daß 'mustCopy=TRUE'⓪-* und 'noCheck' = FALSE ist, kommt hier bei REF-Parms eh nicht⓪-* vor. Trotzdem wird sicherheitshalber der Stack-Check auch bei⓪-* REF-Parms gemacht, falls noCheck=FALSE.⓪-* Allerdings wird der Check nur gemacht, wenn Wert wirklich⓪-* auf Stack kopiert wird und nicht nur einfach von A3 nach A7⓪-* verschoben wird: *)⓪*END;⓪*IF NOT noCheck THEN checkStack (Size (expr)) END;⓪*PushExpr (stacks.parm);⓪*moveTo (expr, stacks.data, stacks.forParms, FALSE, TRUE, FALSE, range);⓪*deallocRegs (expr);⓪*PopExpr (stacks.parm);⓪*reloadPtr (stacks.parm);⓪*expr:= stacks.data;⓪*expr.stackReg:= stacks.dataSP⓪(ELSE⓪*(* Bei Value Parameter muß das Datum auf den Parameter-Stack *)⓪*WITH stacks DO⓪,IF reg THEN⓪.fitExpression (expr, parm, range);⓪.IF usesTempRegs (expr) THEN⓪0IF isReal (expr.item) THEN⓪2regs:= floatRegs⓪0ELSIF isPointer (expr.item) THEN⓪2regs:= addrRegs⓪0ELSE⓪2regs:= dataRegs⓪0END;⓪0loadReg (expr, regs)⓪.END;⓪,ELSE⓪.moveTo (expr, parm, forParms, TRUE, FALSE, odd, range);⓪.odd:= NOT forParms AND XOR (odd, ODD (parm.stackedSize));⓪,END;⓪,IF parmIsA3 THEN⓪.(* diese Daten werden vom Aufgerufenen abgeräumt *)⓪.parm.stackedSize:= 0⓪,END;⓪*END;⓪(END;⓪&ELSE⓪((* evtl. Datum auf Stack wird nicht vom Aufgerufenen abgeräumt *)⓪(IF (expr.kind = stack) THEN⓪*IF NOT reg & (stacks.openArray OR ref) THEN⓪,IF stacks.parmIsA3 THEN⓪.stacks.parm.stackedSize:= expr.stackedSize⓪,ELSE⓪.stacks.data.stackedSize:= expr.stackedSize⓪,END⓪*ELSIF expr.stackReg = A7 THEN⓪,stacks.parm.stackedSize:= expr.stackedSize⓪*END⓪(END;⓪&END;⓪ ⓪&IF ref OR stacks.openArray THEN⓪((* Referenz von Datum auf Parameter-Stack bringen *)⓪(IF expr.kind = stack THEN⓪*IF expr.stackReg = A3 THEN⓪,(* Datum auf A3 -> "PEA -size(A3)" *)⓪,ofs:= -LONGINT (expr.stackedSize)⓪*ELSE⓪,(* Datum auf A7 -> "MOVE.L A7,(A3)+" *)⓪,ofs:= 0⓪*END;⓪*makeStackIndir (expr, ofs);⓪(END;⓪(IF reg THEN⓪*loadAddress (expr)⓪(ELSE⓪*moveAddress (expr, stacks.parm);⓪*IF NOT stacks.parmIsA3 THEN⓪,INC (stacks.parm.stackedSize, 4);⓪*END;⓪(END;⓪&END;⓪&⓪&IF reg THEN⓪(PushExpr (expr) (* Reg-Parms werden erst später richtig geladen *)⓪&ELSE⓪(deallocRegs (expr)⓪&END⓪$⓪$END;⓪"END moveToStack;⓪ ⓪ ⓪ ⓪ PROCEDURE initStacks (VAR stacks: StackDesc; forCall: BOOLEAN;⓪6parmSP: RegType; length: LONGCARD; upwd: BOOLEAN);⓪"(*⓪#* Legt bei Beginn von Parameter-Liste die beiden Stacks f. Parameter⓪#* und Ref-Daten (z.B. f. Open Arrays) an.⓪#* 'forCall': TRUE > Daten f. Parm-Übergabe; FALSE > Daten f. value constr.⓪#* 'parmSP': Stack-Register, auf den die Parameter kommen.⓪#* 'length' muß, falls parmSP=A7 und mehr als ein Parameter folgen,⓪#* die Anzahl der auf dem Stack benötigten Bytes enthalten, damit gleich⓪#* der Stack entspr. vorbereitet werden kann.⓪#* 'upwd': TRUE, wenn unbedingt (An)+ verwendet werden soll⓪#*)⓪"BEGIN⓪$IF parmSP = A3 THEN⓪&stacks.dataSP:= A7;⓪$ELSE⓪&(*$? Safety: assert (parmSP = A7);*)⓪&stacks.dataSP:= A3⓪$END;⓪$WITH stacks DO⓪&forParms:= forCall;⓪&odd:= FALSE;⓪&parmIsA3:= (parmSP = A3);⓪&parmUsed:= 0;⓪&dataUsed:= 0;⓪&dataUsedDyn:= FALSE;⓪&firstParm:= TRUE;⓪&initStackExpr (parm, NIL, parmSP);⓪&initStackExpr (data, NIL, dataSP);⓪&IF upwd THEN⓪(makePostInc (parm, length)⓪&END⓪$END⓪"END initStacks;⓪ ⓪ PROCEDURE setParType (VAR stacks: StackDesc; type: PtrItem);⓪"(*⓪#* Wird aufgerufen, um Parameter-Type mitzuteilen⓪#*)⓪"BEGIN⓪$IF type # NIL THEN⓪&stacks.openArray:= isOpenArray (type);⓪&IF stacks.openArray THEN⓪(WITH stacks.parm DO⓪*item:= CardPtr;⓪*stackedSize:= 0⓪(END;⓪(initStackExpr (stacks.data, type, stacks.dataSP);⓪&ELSE⓪(WITH stacks.parm DO⓪*item:= type;⓪*stackedSize:= 0⓪(END;⓪(initStackExpr (stacks.data, type, stacks.dataSP);⓪&END⓪$END⓪"END setParType;⓪ ⓪ PROCEDURE pushStacks (VAR stacks: StackDesc);⓪"(*⓪#* legt SP-Beschreibungen mit 'PushExpr' ab, damit ggf. Spilling geht⓪#*)⓪"BEGIN⓪$PushExpr (stacks.parm);⓪$PushExpr (stacks.data);⓪"END pushStacks;⓪ ⓪ PROCEDURE popStacks (VAR stacks: StackDesc);⓪"BEGIN⓪$PopExpr (stacks.data);⓪$PopExpr (stacks.parm);⓪"END popStacks;⓪ ⓪ PROCEDURE reloadStackPtrs (VAR stacks: StackDesc);⓪"BEGIN⓪$reloadPtr (stacks.data);⓪$reloadPtr (stacks.parm);⓪"END reloadStackPtrs;⓪ ⓪ ⓪ PROCEDURE updateStacks (VAR stacks: StackDesc);⓪"BEGIN⓪$WITH stacks DO⓪&INC (parmUsed, parm.stackedSize);⓪&IF NOT stacks.dataUsedDyn THEN INC (dataUsed, data.stackedSize) END;⓪&deallocRegs (data);⓪&firstParm:= FALSE⓪$END⓪"END updateStacks;⓪ ⓪ PROCEDURE saveStacks (VAR stacks: StackDesc; VAR regWithHiddenA7: RegType);⓪"(*⓪#* wird direkt vor Call aufgerufen.⓪#*)⓪"VAR r: RegType; help: ExprDesc;⓪"BEGIN⓪$WITH stacks DO⓪&IF dataUsedDyn THEN⓪(PopExpr (help);⓪((*$? Safety: assert (help.kind = register);*)⓪(genPushReg (help.exprReg, TRUE, dataSP);⓪(regWithHiddenA7:= help.exprReg;⓪(deallocRegs (help);⓪&END⓪$END⓪"END saveStacks;⓪ ⓪ PROCEDURE deallocStacks (validStacks: BOOLEAN;⓪9VAR stacks: StackDesc; parmLen: LONGINT;⓪9popFromA3: LONGCARD;⓪9popFromA7: LONGCARD;⓪9VAR leftOnA3: LONGCARD);⓪"(*⓪#* Räumt nach Proc-Call mit den Stacks wieder auf.⓪#* In 'popFromA3/7' können zusätzliche Bytes zum Abräumen angegeben werden.⓪#* In 'leftOnA3' wird der Wert zurückgegeben, der dort vom Aufrufer⓪#* abgeräumt werden muß. Dies kann nicht hier erledigt werden, weil⓪#* u.U. call() eine Funktionsproz. aufrief, die noch einen Wert auf⓪#* dem A3-Stack hinterlassen hat. Dann darf der A3-Stack erst nach⓪#* dem Runterladen des Funktionsergebnisses korrigiert werden.⓪#* 'parmLen' gibt an, wieviel Bytes auf den Parm-Stack geladen sein⓪#* müßten, bzw, wieviel Byte die aufgerufene Routine abgeräumt hat.⓪#*)⓪"VAR r: RegType; help: ExprDesc;⓪"BEGIN⓪$leftOnA3:= 0;⓪$IF validStacks THEN⓪&WITH stacks DO⓪(IF NOT forParms THEN⓪*bong () (*wird z.Zt. nicht benutzt -- ggf. sonst A3/7Offset korrig. *)⓪(ELSE⓪*IF dataUsedDyn THEN⓪,(*$? Safety: assert (data.kind = stack);*)⓪,data.stackReg:= dataSP;⓪,data.up:= parmIsA3;⓪,data.item:= sizedItem (4, FALSE);⓪,genMOVEar (data, dataSP);⓪,IF parmIsA3 THEN⓪.A7Offset:= stackOffset⓪,ELSE⓪.A3Offset:= stackOffset⓪,END⓪*END;⓪*IF dataUsed # 0L THEN⓪,IF parmIsA3 THEN⓪.INC (popFromA7, dataUsed);⓪,ELSE⓪.(*⓪/* hier kann A3 ruhig abgeräumt werden, denn der A3 wird nur⓪/* dann als Data-Stack verwendet, wenn die Parms auf den A7⓪/* kommen -- und dann kann ein evtl. Funktionsergebnis nicht⓪/* auf dem A3-Stack übergeben werden.⓪/*)⓪.INC (popFromA3, dataUsed);⓪,END⓪*END;⓪*IF parmUsed # 0L THEN⓪,IF parmIsA3 THEN⓪.HALT;⓪.(*&&& §§1⓪/*⓪/* könnte man auch so lösen, daß, wenn Daten noch auf A3⓪/* als Ergebnis geblieben sind, diese runtergeschoben werden.⓪/* das ist im Durchschnitt auch nicht schlimmer, als den 1. Parm⓪/* sonst gleich auf A7 umzukopieren.⓪/*⓪/* damit das klappt, muß vorige 'firstParm'-Abfrage⓪/* reaktiviert werden. Außerdem muß dann erstmal⓪/* das konzept bezlg. den datentransfers umgestellt⓪/* werden. problem: bei jedem transfer eines datums vom⓪/* stack irgendwohin muß 'restoreStack' ggf. durchgeführt⓪/* werden. so z.b. bei loadReg, gen (ADD,..), usw.⓪/* deshalb dürfen im expr/designator-teil keine gen-aufrufe⓪/* mehr gemacht werden -- 'deallocRegs' sollte auch nur⓪/* von diesen aufgerufenen routinen, die das dann tun⓪/* (so, wie jetzt z.b. loadReg), gemacht werden. stattdessen⓪/* gibt es zusätzlich 'deallocExpr', welches von den äußeren⓪/* routinen benutzt wird, wenn sie davon ausgehen, daß nun⓪/* eine datenzusammenfassung passiert ist. ebenso kann dann⓪/* dort auch 'clearExpr' aufgerufen werden, wobei dafür⓪/* gesorgt wird, daß ggf. der stack von den daten befreit⓪/* wird.⓪/*)⓪.leftOnA3:= parmUsed⓪,ELSE⓪.INC (popFromA7, parmUsed);⓪,END⓪*END⓪(END;⓪(IF parmIsA3 THEN DEC (A3Offset, parmLen) END;⓪&END; (* WITH stacks *)⓪$END;⓪$incReg (A7, toZZ (popFromA7, FALSE), 4);⓪$incReg (A3, toZZ (-INT (popFromA3), TRUE), 4);⓪"END deallocStacks;⓪ ⓪ ⓪ (* ************************************************************************* *)⓪ (* ************************************************************************* *)⓪ (* ************************************************************************* *)⓪ ⓪ VAR SavedTempRegs: RegSet;⓪ ⓪ PROCEDURE assignment ();⓪ ⓪"VAR dest, expr: ExprDesc; range: ConvDesc; lastA3, lastA7: LONGINT;⓪ ⓪"PROCEDURE procCall;⓪$VAR leftOnA3: LONGCARD; item: PtrItem;⓪$BEGIN⓪&item:= expr.item;⓪&IF ItemNo (item) = 44 THEN⓪((* bei Aufruf einer Proc m. Frame-Ptr muß der Ptr auf die Parm-Kette⓪)* erst geholt werden *)⓪(item:= RefType (item);⓪&END;⓪&IF ElementType (item) # NIL (* Funktion *) THEN⓪(SyntaxError (rNoFun)⓪&END;⓪&call (leftOnA3, FALSE, 0);⓪&IF leftOnA3 > 0L THEN⓪(incReg (A3, toZZ (-LONGINT (leftOnA3), TRUE), 4)⓪&END⓪$END procCall;⓪ ⓪"VAR ok: BOOLEAN;⓪ ⓪"BEGIN (* assignment *)⓪$lastA3:= A3Offset;⓪$lastA7:= A7Offset;⓪$⓪$IF (userDef IN CurrentSymbol.flags) & (ORD (CurrentSymbol.typ) = 6) THEN⓪&initProcExpr (expr, CurrentSymbol.item, procDepth (Tiefe));⓪&PushExpr (expr);⓪&GetSymbol ();⓪&procCall⓪$ELSE⓪&designator (setDesig, FALSE, rVarXp);⓪&IF CurrentSymbol.itemNo # becomes THEN⓪(LookExpr (expr);⓪(assert (NOT IsRegVar (expr.varItem));⓪*(* >> proc-Vars dürfen nicht als Reg-Vars dekl. werden, weil⓪+* durch obigen designator-Aufruf dann der Wert ggf. nicht⓪+* aus dem Memory geladen würde, wenn er als Parm übergeben⓪+* wurde. *)⓪(IF (ItemNo (expr.item) = 19) OR (ItemNo (expr.item) = 44) THEN⓪*procCall;⓪(ELSE⓪*SyntaxError (rAsgXp)⓪(END⓪&ELSE⓪(LookExpr (dest);⓪((* ~~~ die Abfrage wird schon in 'designator' gemacht. Einziges⓪/Problem dabei: auch bei Proc-Var-Aufrufen wird schon von⓪/vornherein eine Zuweisung angenommen und so kommt eine⓪/Fehlermeldung, wenn eine Prov-Var als REF-Parm dekl. wurde.⓪*IF dest.readOnly THEN SyntaxError (rRdOnl) END;⓪(*)⓪(GetSymbol;⓪(VarExpression ();⓪(PopExpr (expr);⓪(PopExpr (dest);⓪(⓪(checkAsnCompat (expr, dest.item, range, rParTy);⓪(⓪((*$? Safety: assert (NOT bothOnStack (dest, expr));*)⓪*(* kann eigentlich nicht vorkommen, weil linke Seite beim Assignment⓪+* nur als Pointer existieren kann und dieser höchstens auf den⓪+* A7 gespilled worden sein kann. *)⓪ ⓪(moveToVar (expr, dest, range);⓪(⓪(deallocRegs (dest);⓪&END;⓪$END;⓪$⓪$(*$? Safety: assert (NOT FoldingConst);*)⓪$IF (lastA3 # A3Offset) OR (lastA7 # A7Offset) THEN⓪&IF lastA3 # A3Offset THEN BadId:= 'A3(assign/call)' ELSE BadId:= 'A7(assign/call)' END;⓪&SyntaxError (rIntSP);⓪&A3Offset:= lastA3;⓪&A7Offset:= lastA7;⓪$END;⓪$IF freeRegs * tempRegs # SavedTempRegs THEN⓪&BadId:= 'assign';⓪&(*$? Safety:⓪(Append (LHexToStr (LONGCARD(freeRegs*tempRegs),7), BadId, ok);⓪(Append (LHexToStr (LONGCARD(SavedTempRegs),7), BadId, ok);⓪&*)⓪&SyntaxError (rIntRg);⓪&freeRegs:= freeRegs - tempRegs + SavedTempRegs⓪$END;⓪"END assignment;⓪ ⓪ ⓪ PROCEDURE pushHigh (parType, exprType: PtrItem;⓪4VAR expr, dest: ExprDesc; countUsed, genCode: BOOLEAN);⓪ ⓪"VAR fact, maxHigh, elemSize, exprSize, elems: LONGCARD;⓪&size, n: CARDINAL;⓪&lo, hi: ZZ;⓪&high: ExprDesc;⓪&oldType, destHighType, parBase, exprBase: PtrItem;⓪"⓪"BEGIN⓪$oldType:= expr.item;⓪$REPEAT⓪&parBase:= OpenArrayType (parType);⓪&IF isOpenArray (exprType) THEN⓪(⓪(RETURN; (* dies wird z.Zt. in 'moveOpenArray' erled.*)⓪ ⓪&ELSE⓪(⓪(IF isOpenArray (parBase) THEN⓪*(* es kommt eine weitere open array-dimension *)⓪*IF ItemNo (exprType) # 12 (* ARRAY *) THEN⓪,SyntaxError (rArDXp)⓪*END;⓪*elemSize:= Size (expr); (*!!! unsicher/nur provisiorisch *)⓪*getBounds (IndexType (exprType), lo, hi);⓪*getElems (lo, hi, elems);⓪*exprBase:= ElementType (exprType) (* wird unten benötigt *)⓪(ELSE⓪*(*$? Safety: assert (exprType = expr.item);*)⓪*adaptSSToChar (expr);⓪*exprSize:= Size (expr);⓪*elemSize:= TypeLength (parBase);⓪*elems:= exprSize DIV elemSize;⓪*n:= ItemNo (parBase);⓪*size:= jokerSize (n);⓪*IF size > 0 THEN⓪,(* Basistype ist BYTE/WORD/LONGWORD *)⓪,IF exprSize MOD LONG (size) # 0L THEN SyntaxError (rOddAr) END⓪*ELSIF (n = 3 (* CHAR *)) AND (ItemNo (exprType) = 27) THEN⓪,(* String-Const zu ARRAY OF CHAR immer kompatibel *)⓪*ELSE⓪,(* ~~~ hier fehlt ggf. ZZ-Anpassung!⓪-* -- das kann nur eintreten, wenn z.B. ein ZZ-Wert an ein⓪-* Array of LONGCARD übergeben wird. Dieser Fall sollte⓪-* daher schon bei der asncompat-prüfung in der call-routine⓪-* berücksichtigt werden, so daß dann gleich der passende⓪-* wert auf den stack kommt *)⓪,IF NOT compatTT (parBase, exprType)⓪,AND ( (ItemNo (exprType) # 12) OR⓪2NOT compatTT (parBase, ElementType (exprType)) ) THEN⓪.SyntaxError (rParTy)⓪,END⓪*END⓪(END;⓪(⓪((* 'elems' als HIGH-Wert ablegen *)⓪(DEC (elems);⓪(IF isLongOpenArray (parType) THEN⓪*initConstExpr (high, 4, toZZ (elems, FALSE))⓪(ELSE⓪*IF elemSize = 1 THEN⓪,maxHigh:= $7FFF; (* nur 32KB bei Byte-Arrays zulassen(wg. Optim.) *)⓪*ELSE⓪,maxHigh:= $FFFF⓪*END;⓪*IF elems > maxHigh THEN⓪,SyntaxError (rOpAOv)⓪*END;⓪*initConstExpr (high, 2, toZZ (elems, FALSE))⓪(END;⓪(⓪&END;⓪&⓪&IF genCode THEN⓪(moveSingle (high, dest, 0);⓪(IF countUsed THEN⓪*INC (dest.stackedSize, Size (high));⓪(END;⓪&END;⓪&deallocRegs (high);⓪ ⓪&parType:= parBase;⓪&exprType:= exprBase;⓪&expr.item:= exprType; (* >> damit ggf. 'Size(expr)' (s.o.) funktioniert *)⓪$UNTIL NOT isOpenArray (parBase); (* weitere OPEN ARRAY-Dimens. bearbeiten*)⓪$expr.item:= oldType;⓪"END pushHigh;⓪ ⓪ ⓪ TYPE ParExprDesc = RECORD⓪6expr: ExprDesc;⓪6exprType: PtrItem;⓪6range: ConvDesc;⓪6parType: PtrItem;⓪6byRef, openArray: BOOLEAN⓪4END;⓪ ⓪ ⓪ PROCEDURE initConstPar (VAR parExpr: ParExprDesc);⓪"BEGIN⓪$WITH parExpr DO⓪&initExpr (expr, UndefTyp, constant);⓪&parType:= NIL;⓪&byRef:= FALSE;⓪&openArray:= FALSE;⓪$END⓪"END initConstPar;⓪ ⓪ PROCEDURE getSinglePar ( parType: PtrItem; varPar, refPar, isPar: BOOLEAN;⓪9VAR parExpr: ParExprDesc );⓪"BEGIN⓪$parExpr.parType:= parType;⓪$WITH parExpr DO⓪&byRef:= refPar OR varPar;⓪&openArray:= isOpenArray (parType);⓪ ⓪&(*&&& geht das nun automatisch?⓪(IF openArray THEN⓪*(* nur bei einfachem Datum mit -(A7) arbeiten *)⓪*changeSP (parmSP, parmStackLength)⓪(END;⓪&*)⓪"⓪&IF varPar THEN⓪((* wozu das? in design. wird sowie 'rVarXp' gemeldet -> viel besser?!⓪*IF NOT (userDef IN CurrentSymbol.flags) THEN SyntaxError (rIdXp) END;⓪(*)⓪(designator (varDesig, TRUE, rVarXp)⓪&ELSE⓪(VarExpression ()⓪&END;⓪&PopExpr (expr);⓪&⓪&IF varPar THEN⓪(IF warningsActive () THEN⓪*IF expr.regVar THEN SyntaxError (rRegVa) END;⓪(ELSE⓪*(* !!! erstmal immer Fehler melden, weil sonst dafür gesorgt⓪+* werden muß, daß das ins RAM abgelegte Reg noch vor dem⓪+* nächsten Statement wieder ins Reg muß!⓪,IF expr.regVar & IsInReg (expr.varItem) THEN⓪.(* Reg in Mem ablegen *)⓪.UseMem (expr.varItem);⓪.changeToStack (expr);⓪.changeStackToIndir (expr);⓪.initExpr (reg, expr.item, register);⓪.reg.exprReg:= UsedReg (expr.varItem);⓪.genMOVEaa (reg, expr, 0)⓪,END⓪+* stattdessen also: *)⓪*IF expr.regVar THEN SyntaxError (rRegVa) END;⓪(END⓪&END;⓪&⓪&IF openArray THEN⓪(range:= alwaysFitting (parType);⓪(IF NOT isOpenArray (expr.item) THEN⓪*reduceZZ (expr)⓪(END⓪((* Diese Fälle werden erst beim HIGH-Push ('pushHigh') geprüft *)⓪&ELSE⓪(IF isOpenArray (expr.item) THEN⓪*SyntaxError (rOp2Op) (* Open Array nicht auf norm. Parm zuweisbar *)⓪(ELSIF varPar THEN⓪*checkVarCompat (expr, parType, rVPaTy);⓪*range:= alwaysFitting (parType);⓪(ELSIF isPar THEN⓪*checkValCompat (expr, parType, range, rParTy)⓪(ELSE⓪*checkAsnCompat (expr, parType, range, rParTy)⓪(END⓪&END;⓪$END;⓪"END getSinglePar;⓪ ⓪ ⓪ PROCEDURE pushPar ( VAR stack: StackDesc;⓪4VAR parExpr: ParExprDesc; regPar: BOOLEAN );⓪ ⓪"VAR origExprSize: LONGCARD;⓪"⓪"BEGIN⓪$WITH parExpr DO⓪&IF expr.item = SSTyp THEN⓪(IF parType = CharPtr THEN⓪*adaptSSToChar (expr);⓪(ELSE (* IF NOT openArray OR (Size (expr) = 0) THEN *)⓪*(* String-Consts an Open-Array-Parms immer Null-terminiert übergeben⓪+* (incl. erhöhtem High-Wert). *)⓪*terminateStringConst (expr, parType);⓪(END⓪&END;⓪&⓪&(*$? Safety: assert (Size (expr) > 0L);*)⓪&⓪&exprType:= expr.item;⓪&⓪&IF openArray THEN⓪((* Zuerst einmal Compat-Prüfung usw. machen. Würde zuerst der⓪)* Stack-Push gemacht, könnten irgendwelche nicht zutreffenden⓪)* Annahmen zu internen Fehlern führen *)⓪((*$? Safety: assert (~regPar); *)⓪((* 'expr' wird hier übergeben, damit der Zugriff auf dessen⓪)* HIGH-Werte ggf. bekannt ist. *)⓪(pushHigh (parType, exprType, expr, stack.parm, FALSE, FALSE)⓪)(*~~~ wird zweimal nacheinander aufgerufen - hier wg. Compat-Check,⓪** weiter unten für echten High-Push. Verbraucht sicher viel Zeit *)⓪&END;⓪&⓪&(*⓪'* Nun erfolgt das Laden des Parameters auf den Stack.⓪'* 'expr', das den Zugriff auf das Datum beschreibt, muß erhalten⓪'* bleiben, damit ggf. bei einer HIGH-Übergabe das Zugriff auf⓪'* den HIGH-Wert des Datums möglich ist, falls es ein Open-Array⓪'* Parameter ist.⓪'*)⓪&origExprSize:= AnyTypeLength (exprType); (* Size f. pushHigh retten... *)⓪&IF byRef & (expr.kind = constant) THEN⓪(changeConstantToConstRef (expr, Size (expr));⓪&END;⓪&moveToStack (expr, stack, range, byRef, regPar);⓪&SetTypeLength (exprType, origExprSize); (* ... und wiederherstellen *)⓪&⓪&IF openArray THEN⓪((* 'expr' wird hier übergeben, damit der Zugriff auf dessen⓪)* HIGH-Werte ggf. bekannt ist. *)⓪(pushHigh (parType, exprType, expr, stack.parm, NOT stack.parmIsA3, TRUE)⓪&END;⓪$⓪$END;⓪$updateStacks (stack);⓪"END pushPar;⓪ ⓪ ⓪ PROCEDURE canAddToConstPar (VAR source: ParExprDesc): BOOLEAN;⓪"(*⓪#* Liefert TRUE, wenn 'source' ein Const ist, die erstmal in 'dest'⓪#* gemerkt bzw. mit vorigen Consts zusammengefaßt werden kann.⓪#* Bei REF-Parms geht dies nicht, weil ja nicht der Wert der Const⓪#* sondern ihr Pointer auf den Stack muß. Die hiesige Zusammenfassung⓪#* jedoch versucht ja gerade, mehrere Consts zusammen auf einmal auf⓪#* den Stack zu laden.⓪#*)⓪"VAR parSize, dataSize, size: LONGCARD; c: CARDINAL;⓪"BEGIN⓪$IF NOT (source.byRef OR source.openArray) THEN⓪&IF (source.expr.kind = constant) OR (source.expr.kind = constRef) THEN⓪((*⓪)* String-Consts müssen ggf. Null-terminiert und aufgefüllt werden.⓪)* Wenn sie viel kleiner sind als ihre Ziel-Var, wird normalerweise⓪)* die Const nicht mehr mit abgelegt, da dann die normale Parameter-⓪)* Zuweisung besser vorgeht, indem sie nur die nötigen Bytes kopiert⓪)* und dann den SP auf die Ziel-Länge hochsetzt.⓪)* Für den Fall, daß es ein Value Constructor ist, der in einer⓪)* Const-Expr vorkommt, darf das aber nicht gemacht werden, sondern⓪)* die String-Const muß in ihrer vollen Ziel-Länge abgelegt werden.⓪)*)⓪(IF isSS (source.expr) & isStringVar (source.parType) THEN⓪*terminateStringConst (source.expr, source.parType);⓪*IF NOT InConstExpr⓪*AND (TypeLength (source.parType) - Size (source.expr) > 3L) THEN⓪,RETURN FALSE⓪*END⓪(END;⓪(RETURN TRUE⓪&END⓪$END;⓪$RETURN FALSE⓪"END canAddToConstPar;⓪ ⓪ ⓪ (*$D-*)⓪ PROCEDURE addToConstPar (VAR source, dest: ParExprDesc;⓪9parSize: LONGCARD; roundUp: BOOLEAN);⓪"VAR dataSize: LONGINT; size: LONGCARD; c: INTEGER; x: ADDRESS;⓪"BEGIN⓪$(*$? Safety: assert (dest.expr.item = UndefTyp);*)⓪$makeUndef (source.expr);⓪ ⓪$(* Größe der Const merken und ggf. auf gerade Länge bringen: *)⓪$dataSize:= Size (source.expr);⓪$IF roundUp THEN⓪&IF ODD (parSize) THEN⓪(INC (parSize)⓪&END;⓪&IF ODD (dataSize) THEN⓪(IF source.expr.kind = constant THEN shiftLeft (source.expr, 1) END;⓪(INC (dataSize)⓪&END;⓪$END;⓪$⓪$(* Bei constants die Bytes oberhalb der Expr-Länge löschen: *)⓪$IF source.expr.kind = constant THEN⓪&FOR c:= 0 TO strConstSize - SHORT (dataSize) DO⓪(source.expr.exprConst.str [c]:= 0C⓪&END;⓪$END;⓪$⓪$(* zum Debuggen:⓪&x:= ADR (source.expr.exprConst); x:= ADR (dest.expr.exprConst);⓪$*)⓪$(* neue Größe der zusammengefaßten Const berechnen *)⓪$size:= (Size (dest.expr)) + (parSize);⓪$⓪$(*⓪%* Zuerst 'dest' gültig machen:⓪%* Wenn schon eine Const bestand, dann diese ggf. ablegen, ansonsten⓪%* source zu dest machen⓪%*)⓪$IF (dest.expr.kind = constant) & (size > LONG (constBufSize)) THEN⓪&(* !TT 4.4.94: Diese Version funktionierte nicht, wenn man zwei⓪'* Konstanten mit kind=constant zusammenfügte, die dann > constBufsize⓪'* wurden:⓪*IF dest.parType # NIL THEN⓪,(* schon vorige Const erzeugt;⓪-* Konst. auf jeden Fall in den Data-Puffer ablegen.⓪-* source wird später angefügt *)⓪,dropNewConstant (ADR (dest.expr.exprConst.b)+1L-Size (dest.expr),⓪:Size (dest.expr), dest.expr);⓪*ELSE⓪,(* noch keine vorige Const abgelegt *)⓪,IF source.expr.kind # constRef THEN⓪.(* Konst. auf jeden Fall in den Data-Puffer ablegen *)⓪.dropNewConstant (ADR (source.expr.exprConst.b)+1-ORD(dataSize),⓪<dataSize, source.expr);⓪,END;⓪,(* source wird zu 'dest' übernommen. *)⓪,dest.expr:= source.expr;⓪,(* expandConstant (dest.expr, parSize) Rest der Const löschen *)⓪*END⓪&*)⓪&(* 4.4.94 neue Version, Testprg: CONSTREC.M: *)⓪&dest.parType:= UndefTyp;⓪&dropNewConstant (ADR (dest.expr.exprConst.b)+1L-Size (dest.expr),⓪:Size (dest.expr), dest.expr);⓪$END;⓪$⓪$(*⓪%* Nun, wenn Const schon vorher bestand, source anfügen⓪%*)⓪$IF dest.parType # NIL THEN⓪&IF source.expr.kind = constRef THEN⓪((* neue Const im Code an alte im Code anfügen *)⓪((*$? Safety: assert (dest.expr.kind = constRef);*)⓪((*$? Safety: assert (dest.expr.constOfs = 0); *)⓪((*⓪)* Die hinzuzufügende Konst. muß ggf. erstmal im DATA-Puffer abgelegt⓪)* werden. Danach wird sie gleich wieder freigegeben, damit die ggf.⓪)* davor liegende Konst. aufgefüllt werden kann. Falls die 'source'-⓪)* Konst schon vor der 'dest'-Konst im Puffer abgelegt ist (weil sie⓪)* eine anonyme ist und schon beim Expr-Holen abgelegt wurde, während⓪)* die 'dest'-Konst erst jetzt gerade bei 'dropConstantFromTree' in⓪)* den Puffer gelangte), verbleibt sie ungenutzt im Puffer und wird⓪)* später nicht in das DATA-Segment übernommen.⓪)*)⓪(IF source.expr.constHead = NIL THEN dropConstantFromTree (source.expr) END;⓪(x:= source.expr.constAddr;⓪(cutConst (source.expr); (* löscht 'constAddr' *)⓪((*$? Safety: assert (constantAtEnd (dest.expr)); *)⓪(addNewConstant (x, dataSize, parSize, dest.expr);⓪&ELSIF dest.expr.kind = constRef THEN⓪((*$? Safety: assert (dest.expr.constOfs = 0); *)⓪((*$? Safety: assert (constantAtEnd (dest.expr)); *)⓪(addNewConstant (ADR (source.expr.exprConst.b)+1-ORD(dataSize),⓪6dataSize, parSize, dest.expr);⓪&ELSE⓪(dest.expr.varItem:= NIL; (* auf Konst im Tree darf nicht mehr ref. werden *)⓪(shiftLeft (dest.expr, SHORT (parSize));⓪(FOR c:= strConstSize - SHORT (dataSize) + 1 TO strConstSize DO⓪*dest.expr.exprConst.str [c-SHORT(INT(parSize)-dataSize)]⓪,:= source.expr.exprConst.str [c]⓪(END;⓪&END⓪$ELSIF source.expr.kind = constant THEN⓪&shiftLeft (source.expr, SHORT (INT(parSize)-dataSize));⓪&dest.expr:= source.expr⓪$END;⓪$⓪$WITH dest DO⓪&exprType:= UndefTyp;⓪&parType:= UndefTyp;⓪&range:= alwaysFitting (exprType);⓪&expr.exprSize:= size⓪$END;⓪$⓪$deallocRegs (source.expr); (* ...nur zur Sauberkeit *)⓪"END addToConstPar;⓪ (*$D-*)⓪ ⓪ PROCEDURE saveProcAddr (VAR proc: ExprDesc);⓪"(*⓪#* Falls Adr. der Proc über eine Adr. mit einem temp. Reg erreicht⓪#* wird, wird hier dafür gesorgt, daß ein einzelner, direkter Zeiger⓪#* darauf erzeugt wird, damit beim Spilling nur ein einfacher⓪#* Ptr auf dem Stack steht.⓪#*)⓪"BEGIN⓪$IF usesTempRegs (proc) & (proc.kind = memory) THEN⓪&(*⓪)(* vorzugsweise in ein Addr-Reg laden: *)⓪)IF addrRegs * tempRegs * freeRegs # RegSet {} THEN⓪+loadReg (proc, anyAddrReg)⓪)ELSE⓪+loadReg (proc, anyCPUReg)⓪)END⓪&*)⓪&makeInd0An (proc);⓪$END⓪"END saveProcAddr;⓪ ⓪ PROCEDURE callProcAddr (VAR proc: ExprDesc; hiddenA7: RegType; VAR popA7: BOOLEAN);⓪ ⓪"VAR link: ExprDesc;⓪®s: RegSet;⓪&r: RegType;⓪&A7ofs, d: LONGINT;⓪"⓪"PROCEDURE moveHiddenA7;⓪$(* SP-Kopie ggf. in Addr-Reg laden *)⓪$BEGIN⓪&IF hiddenA7 < A0 THEN⓪(genMOVErr (hiddenA7, A0, 4);⓪(hiddenA7:= A0⓪&END⓪$END moveHiddenA7;⓪"⓪"BEGIN⓪$popA7:= FALSE;⓪$IF LocalA7Hidden THEN⓪&A7ofs:= LocalA7WhenHidden⓪$ELSE⓪&hiddenA7:= A7;⓪&A7ofs:= A7Offset⓪$END;⓪$WITH proc DO⓪&IF (kind = memory) & (mode = ptrOnA7) & (LocalA7Hidden OR (depth # A7ofs)) THEN⓪(popA7:= TRUE;⓪(r:= allocReg (addrRegs);⓪(d:= depth - A7ofs;⓪((* Folg. Access geht nur bis max. 32KB Daten auf dem A7-Stack: *)⓪(IF d >= MAX (SHORTINT) THEN⓪*(* zwar wird vorher schon ein entspr. Test gemacht, aber bis⓪+* hierher können sich noch mehr Daten auf dem Stack angesammelt⓪+* haben (z.B. bei Funktionsprozeduren m. Open Array-Parms?) *)⓪*SyntaxError (rParOv)⓪(END;⓪(moveHiddenA7;⓪(genMOVELIndTo (hiddenA7, r, SHORT (d));⓪(disp:= 0;⓪(kind:= memory;⓪(mode:= d16An;⓪(baseReg:= r⓪&ELSIF (kind = stack) & (LocalA7Hidden OR (stackPtr # A7ofs)) THEN⓪((*$? Safety: assert (stackReg = A7);*)⓪(popA7:= TRUE;⓪(disp:= stackPtr - A7ofs;⓪(kind:= memory;⓪(mode:= d16An;⓪(moveHiddenA7;⓪(baseReg:= hiddenA7⓪&ELSE⓪(reloadPtr (proc);⓪&END;⓪&IF ItemNo (item) = 44 (* Proc-Type mit Frame-Ptr *) THEN⓪((*$? Safety: assert (kind = memory);*)⓪(changeToStack (proc);⓪(proc.item:= CardPtr;⓪(link:= proc;⓪(regs:= addrRegs;⓪(EXCL (regs, proc.stackReg); (* damit A0 nicht zerstört wird *)⓪(loadReg (proc, regs); (* MOVE.L (A0)+,A1 *)⓪(genMOVEar (link, D2); (* MOVE.L (A0)+,D2 *)⓪&ELSIF ItemNo (item) # 6 (* PROCEDURE *) THEN⓪((* Wert der Proc-Var in ein AddrReg laden, unten wird's dann nach (An)⓪)* gewandelt.⓪)* Wenn der Wert allerdings gespilled wurde, ihn mit A7-Offset laden⓪)* und den SP nach dem Call abräumen. *)⓪((*$? Safety: assert (kind # spilledSP);*)⓪(loadReg (proc, anyAddrReg);⓪&END⓪$END;⓪$makeIndir (proc, 0, FALSE);⓪$gena (JSR, proc, 4);⓪$deallocRegs (proc);⓪"END callProcAddr;⓪ ⓪ ⓪ PROCEDURE call (VAR leftOnA3: LONGCARD;⓪0pushAddr: BOOLEAN; pushBase: LONGINT);⓪ ⓪"VAR⓪$popFromA3, popFromA7: LONGCARD;⓪$nextParItem, parType, parItem: PtrItem;⓪$regPar, refPar, varPar: BOOLEAN;⓪ ⓪"PROCEDURE getParmLength (par: PtrItem; VAR pl, sl: LONGCARD; VAR single: BOOLEAN);⓪$(*⓪%* bestimmt die Anzahl Bytes, die auf den Parm-Stack ('pl'), sowie⓪%* überhaupt auf den Stack, jedoch ohne Open Arrays ('sl') kommen werden.⓪%* 'single' ist TRUE, wenn nur ein einziges einfaches Arg. kommt.⓪%*)⓪$⓪$PROCEDURE incpl (n: LONGCARD);⓪&BEGIN⓪(IF pl # 0 THEN single:= FALSE END;⓪(INC (pl, n)⓪&END incpl;⓪&⓪$VAR t: PtrItem; reg, ref: BOOLEAN;⓪$⓪$BEGIN⓪&single:= TRUE;⓪&pl:= 0;⓪&sl:= 0;⓪&WHILE par # NIL DO⓪(reg:= ParmToReg (par);⓪(ref:= (refParm IN ParmFlag (par)) OR (varParm IN ParmFlag (par));⓪(t:= ParmType (par);⓪(IF isOpenArray (t) THEN⓪*(*$? Safety: assert (NOT reg); *)⓪*single:= FALSE; (* weil sonst HIGH bei -(A7) zuerst kommen müßte,⓪;* was moveOpenArray aber noch nicht kann *)⓪*incpl (4); (* für Adresse des Arrays *)⓪*REPEAT⓪,IF isLongOpenArray (t) THEN⓪.incpl (4);⓪,ELSE⓪.incpl (2)⓪,END;⓪,t:= OpenArrayType (t)⓪*UNTIL ~isOpenArray (t);⓪(ELSIF ref THEN⓪*IF ~reg THEN incpl (4) END;⓪*(* TT 30.05.93:⓪.wozu sollte bei REF-Parm der Wert für den Stack-Check erhöht⓪.werden? Normalerweise wird auch wirklich beim REf-Parm nix⓪.auf den Stack kopiert. Und wenn doch, dann doch wohl nur⓪.bei generischen Ausdrücken, also dann, wenn keine Variable⓪.sondern z.B. ein Value Constr. als Par. übergeben wird. Und⓪.da prüft doch der Value Constr. selbst schon den Stack.⓪,IF refParm IN ParmFlag (par) THEN⓪.INC (sl, TypeLength (t));⓪.IF ODD (sl) THEN INC (sl) END;⓪,END⓪**)⓪(ELSE⓪*IF ~reg THEN⓪,incpl (TypeLength (t));⓪,INC (sl, TypeLength (t));⓪,IF ODD (pl) THEN INC (pl); INC (sl) END;⓪*END;⓪(END;⓪(par:= NextParm (par)⓪&END;⓪$END getParmLength;⓪"(*$D-*)⓪"⓪"TYPE CodeSaveDesc = RECORD⓪8stack0: StackDesc;⓪8cutPtr: ADDRESS;⓪8relocNo: LONGCARD;⓪8spillSpSv: INTEGER;⓪8a3, a7: LONGINT;⓪6END;⓪"⓪"VAR stacks: StackDesc;⓪&stackLen, parmLen: LONGCARD;⓪&singlePar, constPar: ParExprDesc;⓪&single, oldHiddenL, oldHiddenG, popA7, hadParms: BOOLEAN;⓪&oldHideVal: LONGINT;⓪&save: CodeSaveDesc;⓪&procItem: PtrItem;⓪&r: RegType;⓪®sToFree: RegSet;⓪&parCnt, noOfParms: CARDINAL;⓪®WithHiddenA7, oldSpillDestReg: RegType;⓪&oldSpillDestDir: Directions;⓪&⓪"PROCEDURE saveCode ();⓪$BEGIN⓪&WITH save DO⓪(stack0:= stacks;⓪(cutPtr:= CodePtr();⓪(relocNo:= RelocCount;⓪(spillSpSv:= spillSp;⓪(a3:= A3Offset;⓪(a7:= A7Offset⓪&END;⓪$END saveCode;⓪"⓪"PROCEDURE restoreCode (): BOOLEAN;⓪$BEGIN⓪&WITH save DO⓪(IF (cutPtr = NIL) (* 1.11.90: zur Sicherheit eingebaut - bin mir nicht sicher *)⓪(OR (spillSpSv # spillSp)⓪(OR (relocNo # RelocCount) THEN⓪*cutPtr:= NIL;⓪*RETURN FALSE⓪(END;⓪(stacks:= stack0;⓪(SetCodePtr(cutPtr);⓪(cutPtr:= NIL;⓪(A3Offset:= a3;⓪(A7Offset:= a7;⓪&END;⓪&RETURN TRUE⓪$END restoreCode;⓪ ⓪"PROCEDURE presetProc;⓪$VAR proc: ExprDesc;⓪$BEGIN⓪&PopExpr (proc);⓪&(*$? Safety: assert ((ItemNo (proc.item) = 6) OR (ItemNo (proc.item) = 44) OR⓪;(ItemNo (proc.item) = 19));*)⓪&saveProcAddr (proc);⓪&PushExpr (proc);⓪&procItem:= proc.item;⓪&IF ItemNo (procItem) = 44 THEN⓪((* bei Aufruf einer Proc m. Frame-Ptr muß der Ptr auf die Parm-Kette⓪)* erst geholt werden *)⓪(procItem:= RefType (procItem);⓪&END⓪$END presetProc;⓪ ⓪"PROCEDURE handleCall;⓪$(* Prozeduraufruf *)⓪$VAR proc, link: ExprDesc;⓪$BEGIN⓪&PopExpr (proc);⓪&IF (ItemNo (proc.item) = 6) & NOT (global IN ItemFlag (proc.item)) THEN⓪((*⓪)* lokale Proc aufrufen: Static Link laden nach D2 bzw. -(A7)⓪)*⓪)* Auf den A7 kommt der Static Link nur, wenn die Proc Parms⓪)* auf A7 erwartet und auch wirklich Parms vorhanden sind!⓪)*)⓪(WITH proc DO⓪*IF (kind = memory) & (mode = ptrOnA7) & LocalA7Hidden⓪*OR (kind = stack) & LocalA7Hidden THEN⓪,IF regWithHiddenA7 = D2 THEN⓪.(* falls wir den HiddenA7 noch brauchen und der in D2 liegt,⓪/* den Wert in ein anderes Reg kopieren: *)⓪.genMOVErr (D2, A0, 4);⓪.regWithHiddenA7:= A0⓪,END⓪*END⓪(END;⓪((* doch zuerst eventuelle Reg-Vars im Memory ablegen *)⓪((*&&&alle reg-vars, die von lok.proc benutzt werden, ablegen*)⓪(IF proc.tiefe = 0 THEN⓪*(* MOVE.L A6,D2 *)⓪*initRegExpr (link, 4, getLink (0));⓪(ELSE⓪*(* MOVE.L (Ar),D2 *)⓪*initRegExpr (link, 4, getLink (proc.tiefe-1));⓪*makeIndir (link, 0, FALSE)⓪(END;⓪(IF (noOfParms # 0) AND (parmA7 IN ItemFlag (proc.item)) THEN⓪*pushReg (link, A7);⓪*INC (stacks.parmUsed, 4)⓪(ELSE⓪*loadReg (link, RegSet {D2})⓪(END;⓪(deallocRegs (link)⓪&END;⓪&callProcAddr (proc, regWithHiddenA7, popA7)⓪$END handleCall;⓪ ⓪"PROCEDURE NthParm (n: CARDINAL): PtrItem;⓪$(* Liefert den <n>ten Parameter. Fängt mit 1 an. *)⓪$VAR par: PtrItem;⓪$BEGIN⓪&par:= FirstParm (procItem);⓪&WHILE n > 1 DO par:= NextParm (par); DEC (n) END;⓪&RETURN par⓪$END NthParm;⓪ ⓪"VAR ok: BOOLEAN;⓪ ⓪"BEGIN (* call *)⓪$(*⓪%* Bei einer Proc-Var kann es passieren, daß ihr Wert in einem temp.⓪%* Reg steht. Wir lassen nun zu, daß das Reg dann ggf. gespilled wird.⓪%* Wird am Ende dann die Adr. für den Aufruf benötigt, wird geprüft,⓪%* ob der auf dem Stack steht. In diesem Fall wird dann über den⓪%* A7-Offset auf den Wert zugegriffen und nach dem Call verworfen.⓪%* Damit der Wert beim ggf. spilling 'kind=register' hat, wird er⓪%* hier schon in ein Reg geladen, sofern es nötig ist (nur nötig, wenn⓪%* temp. Vars belegt werden, die gespilled werden könnten).⓪%* Vorsicht: Wenn die Parm-Übergabe auf den Stack geht, auf den ggf.⓪%* auch die Proc-Adr gespilled wird, muß dies ganz am Anfang vor allen⓪%* Parameter-Loads geschehen! Einfacherhalber wird deshalb erstmal⓪%* der Wert immer gespilled durch den gleich folgenden 'spillAllRegs'.⓪%* Soll dies erst beim ggf. Parm-Load geschehen, kann hier stattdessen⓪%* 'spillAllRegsExcept (proc)' eingesetzt werden.⓪%*)⓪$popFromA3:= 0;⓪$popFromA7:= 0;⓪$parmLen:= 0;⓪$oldHiddenG:= GlobalA7Hidden;⓪$oldHiddenL:= LocalA7Hidden;⓪$oldHideVal:= LocalA7WhenHidden;⓪$LocalA7Hidden:= FALSE;⓪$presetProc;⓪$spillAllRegs (); (* Alle temporaries von früher aus dem Weg *)⓪$⓪$noOfParms:= 0;⓪$parItem:= FirstParm (procItem);⓪$⓪$IF CurrentSymbol.itemNo = lparen THEN⓪&(*$D-*)⓪&IF parItem # NIL THEN⓪(getParmLength (parItem, parmLen, stackLen, single);⓪(checkStack (stackLen);⓪(⓪((* Spilling je nach Parm-Stack auf den anderen Stack legen *)⓪(oldSpillDestReg:= spillDestReg;⓪(oldSpillDestDir:= spillDestDir;⓪(spillDestReg:= A7;⓪(spillDestDir:= down;⓪(IF parmA7 IN ItemFlag (procItem) THEN⓪*initStacks (stacks, TRUE, A7, parmLen, NOT single);⓪*IF stacks.parm.stackReg = A7 THEN⓪,spillDestReg:= A3;⓪,spillDestDir:= up;⓪*END⓪(ELSE⓪*initStacks (stacks, TRUE, A3, 0, FALSE);⓪(END;⓪(⓪(initConstPar (constPar);⓪(save.cutPtr:= NIL;⓪(REPEAT⓪*IF parItem = NIL THEN SyntaxError (rParXp) (* ')' erwartet *) END;⓪*⓪*INC (noOfParms);⓪*parType:= ParmType (parItem);⓪*nextParItem:= NextParm (parItem);⓪*refPar:= refParm IN ParmFlag (parItem);⓪*varPar:= varParm IN ParmFlag (parItem);⓪*regPar:= ParmToReg (parItem);⓪*⓪*IF ItemNo (parType) = 0 (* zeigt auf Relay *) THEN⓪,SyntaxError (rBdPar)⓪*END;⓪*⓪*pushStacks (stacks); (*&&& spilling testen, wenn Daten auf A7 kommen, auch bei Open Arrays *)⓪*GetSymbol ();⓪*getSinglePar (parType, varPar, refPar, TRUE, singlePar);⓪*popStacks (stacks);⓪*⓪*(*⓪+* Wenn Par ins Reg soll, wird keine Const zusammengefaßt!⓪+* Außerdem muß dafür gesorgt werden, daß der Wert keinesfalls⓪+* mehr als ein Reg. belegt (loadReg-Aufruf in movetoStack).⓪+* Am Ende werden nochmal alle Parms rückwärts durchgegangen,⓪+* um die Parms in die richtigen Regs zu laden.⓪+* Dabei muß beachtet werden, daß ggf. ein EXG generiert werden muß.⓪+*)⓪*IF ~regPar & canAddToConstPar (singlePar) & restoreCode () THEN⓪,fitValue (singlePar.expr, singlePar.range);⓪,addToConstPar (singlePar, constPar, TypeLength (parType), TRUE);⓪,saveCode;⓪,reloadStackPtrs (stacks);⓪,setParType (stacks, constPar.parType);⓪,pushPar (stacks, constPar, FALSE);⓪*ELSE⓪,reloadStackPtrs (stacks);⓪,setParType (stacks, singlePar.parType);⓪,pushPar (stacks, singlePar, regPar);⓪,save.cutPtr:= NIL;⓪,initConstPar (constPar);⓪*END;⓪*⓪*parItem:= nextParItem;⓪(UNTIL CurrentSymbol.itemNo # comma;⓪(IF parItem # NIL THEN SyntaxError (rParNr) (* zu wenig Parms *) END;⓪(⓪((* falls A7 in Hilfsreg (meist A0) geladen war, muß dies noch⓪)* vor dem evtl. Laden der Reg-Parms wieder freigegeben werden: *)⓪(deallocRegs (stacks.parm);⓪(⓪((* Nun die Reg-Parms nachladen, und zwar rückwärts, da evtl. gespillt *)⓪((*$? Safety: assert (NOT spilling); *)⓪(regsToFree:= RegSet {};⓪(spilling:= TRUE; (* zur Absicherung, daß nicht wieder gespillt wird *)⓪(FOR parCnt:= noOfParms TO 1 BY -1 DO⓪*parItem:= NthParm (parCnt);⓪*IF ParmToReg (parItem) THEN⓪,WITH singlePar DO⓪.PopExpr (expr);⓪.r:= ParmRegNo (parItem);⓪.IF (expr.kind # register) OR (expr.exprReg # r) THEN⓪0IF r IN freeRegs THEN⓪2loadReg (expr, RegSet {r})⓪0ELSE⓪2(* Reg ist von einem andern Parm belegt. Mit EXG tauschen. *)⓪2loadRegByEXG (expr, r)⓪0END;⓪.END;⓪.INCL (regsToFree, r);⓪,END⓪*END⓪(END;⓪(spilling:= FALSE;⓪(freeRegs:= freeRegs + regsToFree;⓪(⓪(spillDestReg:= oldSpillDestReg;⓪(spillDestDir:= oldSpillDestDir;⓪&ELSE⓪(GetSymbol⓪&END;⓪&(*$D-*)⓪&GetRparen⓪$ELSE⓪&IF parItem # NIL THEN SyntaxError (rParNr) (* zu wenig Parms *) END;⓪$END;⓪$⓪$IF noOfParms # 0 THEN⓪&saveStacks (stacks, regWithHiddenA7)⓪'(* VORSICHT: Falls A7Hidden=TRUE, erhalten wir in 'regWithHiddenA7'⓪(* das Register mit dem Wert des alten A7. Wir brauchen⓪(* diesen Wert dann u.U. noch in 'callProcAddr' und dürfen⓪(* ihn deshalb bis dahin nicht zerstören! (Kann bisher nur⓪(* in handleCall bei Laden des StatLink nach D2 passieren) *)⓪$END;⓪$⓪$IF freeRegs * tempRegs # SavedTempRegs THEN⓪&BadId:= 'call';⓪&(*$? Safety:⓪(Append (LHexToStr (LONGCARD(freeRegs*tempRegs),7), BadId, ok);⓪(Append (LHexToStr (LONGCARD(SavedTempRegs),7), BadId, ok);⓪&*)⓪&SyntaxError (rIntRg);⓪&freeRegs:= freeRegs - tempRegs + SavedTempRegs⓪$END;⓪$⓪$IF pushAddr THEN⓪&(* PEA x(SP) für Übergabe des Return-Wert-Pointers erzeugen *)⓪&WITH singlePar DO⓪(initMemExpr (expr, NIL, d16An, FALSE);⓪(IF ~LocalA7Hidden THEN⓪*expr.baseReg:= A7;⓪*expr.disp:= pushBase - A7Offset;⓪(ELSE⓪*(* Falls Orig-A7 wg. dyn. Arrays auf dem Stack steht, nun⓪+* (A3) nach An laden und dann disp(An) auf Stack pushen. *)⓪*expr.baseReg:= stacks.dataSP (* muß A3 sein, wenn Parms auf A7 *);⓪*loadReg (expr, addrRegs);⓪*makeIndir (expr, pushBase - LocalA7WhenHidden, FALSE)⓪(END;⓪(genPushAddress (expr, A7);⓪(INC (popFromA7, 4);⓪(deallocRegs (expr)⓪&END⓪$END;⓪$⓪$handleCall; (* Proc-Aufruf mit Static-Link-Übergabe *)⓪$IF popA7 THEN INC (popFromA7, 4) END;⓪$⓪$deallocStacks (noOfParms#0, stacks, parmLen, popFromA3, popFromA7, leftOnA3);⓪$GlobalA7Hidden:= oldHiddenG;⓪$LocalA7Hidden:= oldHiddenL;⓪$LocalA7WhenHidden:= oldHideVal⓪"END call;⓪ ⓪ ⓪ PROCEDURE hdlCall (mode: CARDINAL; type: PtrItem);⓪"(*⓪#* ruft TRAP oder externe Funktion mit Parms auf A7.⓪#* mode = 0: SYSTEM.CALLSYS (trapNo, parms...)⓪#* mode = 1: SYSTEM.CALLEXT (addr, parms...)⓪#* Regeln für Parameter:⓪#* - Int-Consts werden, wenn kein 'L' dran, als 16 Bit-Wert übergeben.⓪#* - Byte-Daten als Words geladen (das Byte-Datum findet sich sodann⓪#* auf einer ungeraden Stack-Adresse), das High-Byte wird dabei nicht⓪#* unbedingt richtig expandiert/gelöscht, sondern kann jeden Müll⓪#* enthalten!⓪#* - Alle anderen Daten müssen 1, 2, oder 4 Byte groß sein.⓪#* Für Strings, usw, muß also CADR/ADR() verwendet werden.⓪#* String-Consts dürfen nicht automatisch wie mit CADR ausgewertet werden,⓪#* weil dann zw. Strings der Länge Eins und Char-Consts keine Unter-⓪#* scheidung möglich wäre.⓪#*)⓪"⓪"VAR sp, expr: ExprDesc;⓪&range: ConvDesc;⓪&n, parNo: CARDINAL;⓪&popA7: BOOLEAN;⓪&⓪"BEGIN⓪$GetSymbol;⓪$IF mode = 0 THEN⓪&ConstExpression ()⓪$ELSE⓪&VarExpression ();⓪$END;⓪$PopExpr (expr);⓪$type:= StdParmType (StdProcParms (type));⓪$checkAsnCompat (expr, type, range, rBdTyp);⓪$fitValue (expr, range);⓪$IF mode = 1 THEN saveProcAddr (expr); END;⓪$PushExpr (expr);⓪$spillAllRegs (); (* Alle temporaries von früher aus dem Weg *)⓪$(* &&& An dieser Stelle müßte das Spilling auf A3 statt A7 gelenkt⓪%* werden, damit es zu keinen Konflikten kommt. *)⓪$parNo:= 0;⓪$WHILE CurrentSymbol.itemNo = comma DO⓪&GetSymbol ();⓪&VarExpression ();⓪&LookExpr (expr);⓪&reduceZZ (expr);⓪&n:= SHORT (Size (expr));⓪&IF (n = 3) OR (n > 4)⓪&OR (ItemNo (expr.item) = 12) (* ARRAYs sind nicht erlaubt *)⓪&OR isSS (expr) & (n > 1) (* Strings sind nicht erlaubt *) THEN⓪(SyntaxError (rScAdX)⓪&END;⓪&INC (parNo);⓪$END;⓪$initStackExpr (sp, 0L, A7);⓪$WHILE parNo # 0 DO⓪&PopExpr (expr);⓪&IF (expr.kind = stack) & (expr.stackReg = A7)⓪&OR (expr.kind = memory) & (expr.mode = ptrOnA7) THEN⓪((* expr wurde gespilled - das darf nicht *)⓪(SyntaxError (rNoRgs)⓪&END;⓪&reduceZZ (expr);⓪&n:= SHORT (Size (expr));⓪&IF n = 1 THEN⓪(IF expr.kind # constant THEN⓪*loadReg (expr, anyReg)⓪(END;⓪(n:= 2⓪&END;⓪&(* wenn CADR() verwendet wurde, wird LEA adr(PC),An; PEA (An) erzeugt.⓪'* Besser wäre, gleich PEA adr(PC) zu gen. ~~~ *)⓪&moveSingle (expr, sp, n);⓪&deallocRegs (expr);⓪&DEC (parNo)⓪$END;⓪$PopExpr (expr);⓪$IF mode = 0 THEN⓪&(* TRAP generieren *)⓪&gen (TRAP + expr.exprConst.zz.c);⓪$ELSE⓪&(* JSR gen. *)⓪&callProcAddr (expr, 0, popA7);⓪&(*~~~ unschön: Es wird bei einer Konstant-Adr. kein JSR $adr sondern⓪'* LEA adr,A0 JSR (A0) erzeugt, weil callProcAddr keine absolut-⓪'* Adr. kennt, sondern nur Vars und zu relozierende Adr. *)⓪&IF popA7 THEN INC (sp.stackedSize, 4) END⓪$END;⓪$(* Stack bereinigen *)⓪$incReg (A7, toZZ (sp.stackedSize, FALSE), 4);⓪"END hdlCall;⓪ ⓪ ⓪ PROCEDURE hdlLoad;⓪"(*⓪#* LOAD (expr, regNo);⓪#*)⓪"VAR expr, reg: ExprDesc; free, regs: RegSet;⓪"BEGIN⓪$GetLparen;⓪$GetSymbol;⓪$free:= freeRegs;⓪$VarExpression ();⓪$PopExpr (expr);⓪$adaptSSToChar (expr);⓪$reduceZZ (expr);⓪$IF Size (expr) > 4L THEN SyntaxError (rVarSz) END;⓪$ChkComma;⓪$GetSymbol ();⓪$ConstExpression ();⓪$PopExpr (reg);⓪$IF NOT isWholeNumber (reg.item)⓪$OR NOT inZZ (reg.exprConst.zz, toZZ (0L, FALSE), toZZ (15L, FALSE)) THEN⓪&SyntaxError (rConRg)⓪$END;⓪$regs:= RegSet {};⓪$INCL (regs, reg.exprConst.zz.c);⓪$INCL (freeRegs, reg.exprConst.zz.c);⓪$loadRegExt (expr, regs, 4, FALSE);⓪$freeRegs:= free;⓪$GetRparen⓪"END hdlLoad;⓪ ⓪ PROCEDURE hdlStore;⓪"(*⓪#* STORE (regNo, var);⓪#*)⓪"VAR var, reg: ExprDesc; regNo: RegType; wasFree: BOOLEAN;⓪"BEGIN⓪$GetLparen;⓪$GetSymbol ();⓪$ConstExpression ();⓪$PopExpr (reg);⓪$IF NOT isWholeNumber (reg.item)⓪$OR NOT inZZ (reg.exprConst.zz, toZZ (0L, FALSE), toZZ (15L, FALSE)) THEN⓪&SyntaxError (rConRg)⓪$END;⓪$regNo:= reg.exprConst.zz.c;⓪$wasFree:= regNo IN freeRegs;⓪$EXCL (freeRegs, regNo);⓪$ChkComma;⓪$GetSymbol;⓪$designator (setDesig, FALSE, rVarXp);⓪$PopExpr (var);⓪$IF (Size (var) = 1L) & (regNo >= 8)⓪$OR (Size (var) > 4L) THEN SyntaxError (rVarSz) END;⓪$initExpr (reg, var.item, register);⓪$reg.exprReg:= regNo;⓪$genMOVEaa (reg, var, 0);⓪$deallocRegs (var);⓪$IF wasFree THEN INCL (freeRegs, regNo) END;⓪$GetRparen⓪"END hdlStore;⓪ ⓪ ⓪ PROCEDURE getSingle (VAR singlePar: ParExprDesc; parType: PtrItem;⓪5VAR stillConst: BOOLEAN);⓪"VAR c: BOOLEAN;⓪"BEGIN⓪$GetSymbol;⓪$IF CurrentSymbol.itemNo = lbrace THEN⓪&(*⓪'* anonyme Dimension auswerten⓪'*)⓪&hdlConstructor (parType);⓪&singlePar.parType:= parType;⓪&singlePar.exprType:= parType;⓪&singlePar.byRef:= FALSE;⓪&singlePar.openArray:= FALSE;⓪&PopExpr (singlePar.expr);⓪&singlePar.range:= alwaysFitting (parType);⓪&GetSymbol;⓪$ELSE⓪&getSinglePar (parType, FALSE, FALSE, FALSE, singlePar);⓪$END;⓪$c:= (singlePar.expr.kind = constRef) OR (singlePar.expr.kind = constant);⓪$IF NOT c THEN⓪&IF InConstExpr THEN SyntaxError (rConXp) END;⓪&stillConst:= FALSE⓪$END⓪"END getSingle;⓪ ⓪ (*⓪!* ~~~⓪!* Optimierungen für Konstruktoren:⓪!* Wird ein Wert mit Variablen zusammengesetzt, erzeugt der Compiler (4.3)⓪!* z.Zt. recht ineffizienten Code:⓪!* 1. Sind die meisten Wert konstant, wird ab der 1. nicht-Konstante alles⓪!* dynamisch und einzeln zusammengepackt. besser wäre, wenn die größeren⓪!* kostanten Häppchen ggf. auch wieder als Paket im DATA-Segment abegelegt⓪!* würde. Bisher passiert dies nur beim ersten konstanten Teil bis zur⓪!* ersten Variablen. Noch besser wäre es, in Fällen, bei denen die meisten⓪!* Werte konstant sind, alle diese Werte in ein großes DATA-Element (das⓪!* dann gleich den gesamten Konstruktor-Wert darstellt) zu packen.⓪!* Dann braucht nur noch Code erzeugt werden, der die wenigen variablen Werte⓪!* in die Lücken des Wertes im DATA-Segment einfügt.⓪!* 2. Wie schon woanders hier beschrieben, könnten die Werte gleich in die⓪!* Ziel-Var geschrieben werden, anstatt sie erstmal auf dem A3-Stack aufzu-⓪!* bereiten und hinterher umzukopieren.⓪!*)⓪ PROCEDURE hdlArrayConstructor (arrayType: PtrItem);⓪ ⓪"VAR lo, hi: ZZ;⓪&parSize, saveBytes, stackedBytes, elems: LONGCARD;⓪&parType: PtrItem;⓪&oldA3, a3, a7: LONGINT;⓪&long, saved, isConst: BOOLEAN;⓪&singlePar, constPar: ParExprDesc;⓪&sourcePtr, destPtr, loopAddr, startPtr, cutPtr: ADDRESS;⓪&constSave: ConstValue;⓪&count, prev, dest: ExprDesc;⓪&l, l2, relocNo: LONGCARD;⓪&spillSpSv: INTEGER;⓪&symbol: Symbol;⓪®: RegSet;⓪ ⓪"PROCEDURE saveCode;⓪$BEGIN⓪&a3:= A3Offset;⓪&a7:= A7Offset;⓪&prev:= dest;⓪&cutPtr:= CodePtr();⓪&saveBytes:= stackedBytes;⓪&spillSpSv:= spillSp;⓪&relocNo:= RelocCount;⓪&LastDataRelocAdr:= NIL;⓪&saved:= TRUE;⓪$END saveCode;⓪ ⓪"PROCEDURE restoreCode (): BOOLEAN;⓪$(*⓪%* Diese Routine stellt den gesicherten Zustand wieder her:⓪%* Der Code-Ptr wird zurückgesetzt und 'dest.stackedSize' auch.⓪%* Dies funktioniert nur solange, wie wirklich nur einfache Kopier-⓪%* schleifen abgelegt wurden. Es kann aber z.B. bei der unteren⓪%* Anwendung auch vorkommen, daß zw. zwei Konstanten ein Reg gespilled⓪%* wird. Dann darf 'restoreCode' nicht benutzt werden, weil diese⓪%* Routine nicht fähig wäre, das erfolgte Spilling wieder rückgängig⓪%* zu machen. Theoretisch wäre das zwar möglich, dann sollte dafür⓪%* aber ein allg. Routine erstellt werden, die dann alle Veränderungen⓪%* auch für andere Peephole-Anwendungen rückgängig machen kann.⓪%* Auch sollten dann Reloziereinträge wieder entfernt werden können.⓪%*)⓪$BEGIN⓪&IF saved THEN⓪(IF (spillSpSv # spillSp) THEN⓪*isConst:= FALSE;⓪*RETURN FALSE⓪(END;⓪(IF (relocNo # RelocCount) THEN⓪*IF (relocNo+1 = RelocCount) & (LastDataRelocAdr # NIL) THEN⓪,(* Relozierverweis auf DATA-Element rückgängig machen *)⓪,LastDataRelocAdr^:= 0⓪*ELSE⓪,isConst:= FALSE;⓪,RETURN FALSE⓪*END⓪(END;⓪(saved:= FALSE;⓪(dest:= prev;⓪(SetCodePtr (cutPtr);⓪(stackedBytes:= saveBytes;⓪(A3Offset:= a3;⓪(A7Offset:= a7;⓪&END;⓪&RETURN TRUE⓪$END restoreCode;⓪ ⓪"PROCEDURE pushSingle (odd, mustCopyIfSourceOnA3: BOOLEAN);⓪&⓪$PROCEDURE doit (): BOOLEAN;⓪&VAR l: LONGINT;⓪&BEGIN⓪(IF singlePar.expr.kind = stack THEN⓪*(*$? Safety: assert (singlePar.expr.stackReg = A3);*)⓪*IF dest.stackReg = A3 THEN⓪,IF mustCopyIfSourceOnA3 THEN⓪.(* Wert auf Stack muß dupliziert werden. Dazu muß der Source-SP⓪/* in ein Hilfs-Reg geladen werden, weil er sonst abgeräumt würde *)⓪.l:= singlePar.expr.stackedSize;⓪.changeStackToIndir (singlePar.expr);⓪.addDisp (singlePar.expr, -l);⓪.changeToStack (singlePar.expr); (* >> LEA -x(A3),An *)⓪,ELSE⓪.RETURN FALSE⓪,END⓪*END⓪(END;⓪(RETURN TRUE⓪&END doit;⓪ ⓪$BEGIN⓪&IF InConstExpr THEN SyntaxError (rConXp) END;⓪&isConst:= FALSE; (* muß VOR doit() stehen, da sonst ggf. nicht gelöscht wird! *)⓪&saved:= FALSE;⓪&reloadPtr (dest);⓪&IF doit () THEN⓪(addToVar (singlePar.expr, dest, odd, TRUE, singlePar.range)⓪&END;⓪&initConstPar (constPar);⓪$END pushSingle;⓪ ⓪"BEGIN⓪$getBounds (IndexType (arrayType), lo, hi);⓪$getElems (lo, hi, elems);⓪$parType:= ElementType (arrayType);⓪$parSize:= TypeLength (parType);⓪ ⓪$(*⓪%* Das Kopieren des Array geht folgendermaßen:⓪%* Die Daten werden, falls es keine ConstExpr ist, auf den A3-Stack⓪%* gelegt. Damit es keine Probleme mit ungeraden Elementlängen gibt,⓪%* wird in diesem Fall der A3 gleich erhöht und dann mit einem⓪%* Hilfsregister gearbeitet. Wird A3 direkt verwendet, muß noch der⓪%* Sonderfall, daß durch einen Funktionsaufruf das Ergebnis schon auf dem⓪%* Stack steht, berücksichtigt werden (geschieht in 'pushSingle').⓪%*)⓪$IF NOT InConstExpr & (ODD (parSize)) THEN⓪&startPtr:= CodePtr (); (* Adr. merken f. evtl. Zurückschieben (s.u.) *)⓪&oldA3:= A3Offset;⓪&(* Laden von A3 in ein temp. Reg, dann Erhöhen von A3 *)⓪&checkStack (TypeLength (arrayType));⓪&initRegExpr (dest, 4, A3);⓪&loadReg (dest, addrRegs);⓪&dest.item:= parType;⓪&incReg (A3, toZZ (roundedUp (elems * parSize), FALSE), 4);⓪&makeIndir (dest, 0, FALSE);⓪&changeToStack (dest);⓪$ELSE⓪&startPtr:= NIL;⓪&IF NOT InConstExpr THEN checkStack (TypeLength (arrayType)) END;⓪&initStackExpr (dest, parType, A3);⓪$END;⓪$⓪$initConstPar (constPar);⓪$isConst:= TRUE;⓪$saved:= FALSE;⓪$stackedBytes:= 0;⓪$LOOP⓪&DEC (elems);⓪&PushExpr (dest);⓪&getSingle (singlePar, parType, isConst);⓪&PopExpr (dest);⓪&IF CurrentSymbol.itemNo = bySym THEN⓪((*⓪)* BY-Behandlung:⓪)*⓪)* Wenn ein Wert, der nicht von einem Funktionsaufruf stammt, so klein⓪)* ist, daß er in ein Reg paßt, wird er erst in eines geladen und dann eine⓪)* Zuweisungsschleife mit diesem Reg kodiert.⓪)*⓪)* Bei sonstigen Werten wird der Wert einmal zugewiesen und da herum⓪)* die Schleife gebildet.⓪)*)⓪(GetSymbol;⓪(ConstExpression;⓪(PopExpr (count);⓪(IF (count.kind # constant) OR (count.item # ZZTyp) THEN⓪*SyntaxError (rByNum)⓪(END;⓪(IF NOT inZZ (count.exprConst.zz, toZZ (1L, FALSE), toZZ (elems+1L, FALSE)) THEN⓪*SyntaxError (rByCnt)⓪(END;⓪(l:= count.exprConst.zz.l;⓪(DEC (elems, l-1L);⓪(IF InConstExpr THEN⓪*⓪*(*⓪+* In CONST-Anweisungen wird Wert in jedem Fall statisch kopiert.⓪+*)⓪*⓪*fitValue (singlePar.expr, singlePar.range);⓪*singlePar.range:= alwaysFitting (parType);⓪*⓪*LOOP⓪,IF l = 0L THEN EXIT END;⓪,⓪,IF (constPar.expr.kind = constRef) THEN⓪.⓪.IF singlePar.expr.kind # constRef THEN⓪0constSave:= singlePar.expr.exprConst;⓪0(*⓪0~~~ hier dürfte man sich entscheiden, ob nun die konst⓪2zusammengesetzt werden wird, denn dann sollte sie auf jeden⓪2fall in den DATA-Puffer gelegt werden.⓪2falls aber die konsts einzeln eh' schon im tree vorliegen,⓪2wäre es bei größeren daten platzsparender, stattdessen die⓪2consts nicht zusammenzufügen sondern bei laufzeit zusammen⓪2zu kopieren.⓪2allerdings nicht, wenn es an einen ref-parm gehen soll. dann⓪2wäre evtl. eine gesamtablage im DATA effizienter, wenn es⓪2eine große konst bleibt. d.h, wenn der konstruktor auch vars⓪2enthält, wird auch eine übergabe an einen ref-parm keinen⓪2vorteil haben, wenn man teile davon im data ablegt.⓪2-- Weitere mögliche optimierung: auch bei Konstruktoren mit⓪5Vars/Exprs könnte man alles im DATA-Segment statt auf⓪5dem Stack anlegen. Vorteil: Die Konst-Teile bleiben immer⓪5unverändert im DATA-Segment und nur die variablen Teile⓪5müssen zugewiesen werden. -> Spart Laufzeit und Code zum⓪5Zusammenkopieren. Außerdem fällt das Stack-Gewurschtel⓪5weg.⓪0>>> Achtung: die Überlegung scheint hier am falschen platz⓪2zu sein, denn hier ist nur die sonderbeh. f. BY⓪0*)⓪0dropNewConstant (ADR (constSave.b)+1L-parSize, parSize, singlePar.expr);⓪.END;⓪.makeUndef (singlePar.expr);⓪.WITH singlePar.expr DO⓪0(*$? Safety: assert ((constOfs = 0) & (constHead # NIL)); *)⓪0exprSize:= l * parSize;⓪0extendConstant (exprSize, singlePar.expr);⓪0sourcePtr:= constAddr;⓪.END;⓪.destPtr:= sourcePtr;⓪.WHILE l > 1 DO⓪0INC (destPtr, parSize);⓪0Move (sourcePtr, destPtr, parSize);⓪0DEC (l)⓪.END;⓪,⓪,ELSE⓪.⓪.(*$? Safety: assert (singlePar.expr.kind = constant);*)⓪,⓪,END;⓪,⓪,DEC (l);⓪,IF restoreCode () THEN⓪.(*$? Safety: assert (isConst); *)⓪.addToConstPar (singlePar, constPar, Size (singlePar.expr), FALSE);⓪.saveCode;⓪,ELSE⓪.bong ()⓪,END;⓪,⓪*END;⓪*⓪(ELSE⓪*⓪*(*⓪+* Bei BY im Programmcode wird immer eine Kopierschleife generiert⓪+*)⓪*⓪*(*$? Safety: assert ((dest.kind = stack) OR (dest.kind = spilledSP));*)⓪*l2:= l; (* retten, 'l' ggf. geändert wird *)⓪*IF singlePar.expr.kind = stack THEN⓪,(*$? Safety: assert (singlePar.expr.stackReg = A3);*)⓪,IF (dest.stackReg = A3) AND (parSize # 4L) AND (parSize > 2L) THEN⓪.(* Wert befindet sich bereits auf dem A3-Stack, deshalb 1mal⓪/* weniger kopieren *)⓪.subZZ (count.exprConst.zz, toZZ (1L, FALSE));⓪.DEC (l)⓪,ELSE⓪.incReg (A3, toZZ (-LONGINT (singlePar.expr.stackedSize), TRUE), 4);⓪.changeStackToIndir (singlePar.expr);⓪,END⓪*END;⓪*IF NOT nullZZ (count.exprConst.zz) THEN⓪,reduceZZ (count);⓪,long:= Size (count) > 2L;⓪,IF NOT long THEN⓪.subZZ (count.exprConst.zz, toZZ (1L, FALSE))⓪,END;⓪,IF isSS (singlePar.expr) & isStringVar (parType) THEN⓪.terminateStringConst (singlePar.expr, parType)⓪,END;⓪,IF (parSize = 4L) OR (parSize <= 2L) THEN⓪.fitValue (singlePar.expr, singlePar.range); (* Expand & Range-Check *)⓪.loadReg (singlePar.expr, dataRegs);⓪.singlePar.range:= alwaysFitting (parType)⓪,END;⓪,loadReg (count, dataRegs);⓪,reloadPtr (dest);⓪,(*⓪-* Schleifenbeginn⓪-*)⓪,IF long THEN⓪.gen (BRA + 2);⓪.genr (SWAP, count.exprReg);⓪,END;⓪,loopAddr:= CodePtr ();⓪,reg:= RegSet {}; INCL (reg, count.exprReg);⓪,PushExpr (count);⓪,pushSingle (ODD (parSize), TRUE);⓪,PopExpr (count);⓪,reloadPtr (count);⓪,loadReg (count, reg);⓪,dbccBackTo (mapNever (), count.exprReg, loopAddr);⓪,IF long THEN⓪.genr (SWAP, count.exprReg);⓪.dbccBackTo (mapNever (), count.exprReg, loopAddr-2L);⓪,END;⓪,(*⓪-* Schleifenende⓪-*)⓪,deallocRegs (count)⓪*END;⓪*dest.stackedSize:= parSize * l2;⓪*IF dest.stackReg = A3 THEN⓪,updateStackOffsets (A3, TRUE, parSize * (l-1L))⓪*END⓪*⓪(END (* IF InConstExpr ELSE *)⓪&ELSIF isConst & canAddToConstPar (singlePar) & restoreCode () THEN⓪(fitValue (singlePar.expr, singlePar.range);⓪(addToConstPar (singlePar, constPar, TypeLength (parType), FALSE);⓪(saveCode;⓪(IF NOT InConstExpr THEN⓪*reloadPtr (dest);⓪*addToVar (constPar.expr, dest, ODD (stackedBytes), TRUE, constPar.range);⓪(END;⓪&ELSE⓪(pushSingle (ODD (stackedBytes), FALSE)⓪&END;⓪&IF dest.kind = stack THEN⓪(INC (stackedBytes, dest.stackedSize);⓪(dest.stackedSize:= 0;⓪&END;⓪&IF elems = 0L THEN EXIT END;⓪&IF CurrentSymbol.itemNo # comma THEN SyntaxError (rComXp) END;⓪$END(*LOOP*);⓪$deallocRegs (dest); (* Hilfs-Zeiger freigeben *)⓪$IF isConst & restoreCode () THEN⓪&dest:= constPar.expr;⓪&dest.item:= arrayType;⓪&IF startPtr # NIL THEN⓪((* Es war eine Konstante -> Hilfsreg-Benutzung wieder entfernen; *⓪)* Dies ist v.A. wichtig, weil sonst A3 fälschlicherweise erhöht wäre *)⓪(A3Offset:= oldA3;⓪((* noch kein weiterer Code erzeugt -> einfach CodePtr rücksetzen *)⓪(SetCodePtr (startPtr)⓪&END;⓪$ELSE⓪&initStackExpr (dest, arrayType, A3);⓪&dest.up:= FALSE;⓪&dest.stackedSize:= roundedSize (dest);⓪$END;⓪ ⓪$ChkRbrace;⓪$PushExpr (dest)⓪"END hdlArrayConstructor;⓪ ⓪ ⓪ PROCEDURE hdlRecordConstructor (recordType: PtrItem);⓪"⓪"VAR a3, a7: LONGINT;⓪&long, saved, isConst: BOOLEAN;⓪&singlePar, constPar: ParExprDesc;⓪&sourcePtr, destPtr, cutPtr: ADDRESS;⓪&constSave: ConstValue;⓪&prev, dest: ExprDesc;⓪&loadedBytes, relocNo: LONGCARD;⓪&spillSpSv: INTEGER;⓪&symbol: Symbol;⓪®: RegSet;⓪ ⓪"PROCEDURE saveCode;⓪$BEGIN⓪&a3:= A3Offset;⓪&a7:= A7Offset;⓪&prev:= dest;⓪&cutPtr:= CodePtr();⓪&spillSpSv:= spillSp;⓪&relocNo:= RelocCount;⓪&LastDataRelocAdr:= NIL;⓪&saved:= TRUE;⓪$END saveCode;⓪ ⓪"PROCEDURE restoreCode (): BOOLEAN;⓪$(*⓪%* Diese Routine stellt den gesicherten Zustand wieder her:⓪%* Der Code-Ptr wird zurückgesetzt und 'dest.stackedSize' auch.⓪%* Dies funktioniert nur solange, wie wirklich nur einfache Kopier-⓪%* schleifen abgelegt wurden. Es kann aber z.B. bei der unteren⓪%* Anwendung auch vorkommen, daß zw. zwei Konstanten ein Reg gespilled⓪%* wird. Dann darf 'restoreCode' nicht benutzt werden, weil diese⓪%* Routine nicht fähig wäre, das erfolgte Spilling wieder rückgängig⓪%* zu machen. Theoretisch wäre das zwar möglich, dann sollte dafür⓪%* aber ein allg. Routine erstellt werden, die dann alle Veränderungen⓪%* auch für andere Peephole-Anwendungen rückgängig machen kann.⓪%* Auch sollten dann Reloziereinträge wieder entfernt werden können.⓪%*)⓪$BEGIN⓪&IF saved THEN⓪(IF (spillSpSv # spillSp) THEN⓪*isConst:= FALSE;⓪*RETURN FALSE⓪(END;⓪(IF (relocNo # RelocCount) THEN⓪*IF (relocNo+1 = RelocCount) & (LastDataRelocAdr # NIL) THEN⓪,(* Relozierverweis auf DATA-Element rückgängig machen *)⓪,LastDataRelocAdr^:= 0⓪*ELSE⓪,isConst:= FALSE;⓪,RETURN FALSE⓪*END⓪(END;⓪(saved:= FALSE;⓪(dest:= prev;⓪(SetCodePtr (cutPtr);⓪(A3Offset:= a3;⓪(A7Offset:= a7;⓪&END;⓪&RETURN TRUE⓪$END restoreCode;⓪ ⓪"PROCEDURE pushSingle;⓪$BEGIN⓪&IF InConstExpr THEN SyntaxError (rConXp) END;⓪&isConst:= FALSE; (* muß VOR stack-Abfrage stehen! *)⓪&saved:= FALSE;⓪&reloadPtr (dest);⓪&IF singlePar.expr.kind = stack THEN⓪((*$? Safety: assert (singlePar.expr.stackReg = A3);*)⓪(IF dest.stackReg = A3 THEN⓪*RETURN⓪(END;⓪&END;⓪&addToVar (singlePar.expr, dest, FALSE, TRUE, singlePar.range);⓪&initConstPar (constPar);⓪$END pushSingle;⓪ ⓪"PROCEDURE addConst (VAR par, constPar: ParExprDesc; VAR dest: ExprDesc);⓪$BEGIN⓪&fitValue (par.expr, par.range);⓪&addToConstPar (par, constPar, TypeLength (par.parType), FALSE);⓪&saveCode;⓪&IF NOT InConstExpr THEN⓪(reloadPtr (dest);⓪(addToVar (constPar.expr, dest, FALSE, TRUE, constPar.range)⓪&END;⓪$END addConst;⓪ ⓪"PROCEDURE fillUp (VAR constPar: ParExprDesc; VAR dest: ExprDesc; len: LONGCARD);⓪$VAR constOne: ParExprDesc;⓪$BEGIN⓪&WHILE len > 0 DO⓪(WITH constOne DO⓪*parType:= CharPtr;⓪*initExpr (expr, parType, constant);⓪*expr.exprConst.ch:= 0C;⓪*byRef:= FALSE; openArray:= FALSE;⓪*range:= alwaysFitting (parType);⓪*dest.item:= parType;⓪(END;⓪(IF isConst & canAddToConstPar (constOne) & restoreCode () THEN⓪*addConst (constOne, constPar, dest);⓪*INC (loadedBytes);⓪*DEC (len)⓪(ELSE⓪*(*$? Safety: assert ((dest.kind=stack) & (dest.stackReg=A3)); *)⓪*incReg (A3, toZZ (len,FALSE), 4);⓪*INC (loadedBytes, len);⓪*len:= 0⓪(END;⓪(dest.stackedSize:= 0;⓪&END;⓪$END fillUp;⓪ ⓪"PROCEDURE sync (field: PtrItem);⓪$BEGIN⓪&(*$? Safety: assert (ItemNo (field) = 14); *)⓪&(* prüfen, ob ggf. ein Füllbyte eingefügt werden muß *)⓪&IF INT (TypeLength (field)) < INT (loadedBytes) THEN⓪((* das kann nur ein mit "[x]" rückversetzter Offset sein - geht nicht! *)⓪(SyntaxError (rReOfs)⓪&END;⓪&fillUp (constPar, dest, TypeLength (field) - loadedBytes)⓪$END sync;⓪ ⓪"PROCEDURE addField (field: PtrItem);⓪$BEGIN⓪&(*$? Safety: assert (ItemNo (field) = 14); *)⓪&dest.item:= singlePar.parType;⓪&IF isConst & canAddToConstPar (singlePar) & restoreCode () THEN⓪(addConst (singlePar, constPar, dest);⓪&ELSE⓪(pushSingle⓪&END;⓪&INC (loadedBytes, TypeLength (singlePar.parType));⓪&dest.stackedSize:= 0;⓪$END addField;⓪ ⓪"PROCEDURE fieldListSeq (recField: PtrItem);⓪$VAR parType, tagField: PtrItem;⓪(value: LONGINT;⓪$BEGIN⓪&LOOP⓪(parType:= RefType (recField);⓪(IF ItemNo (recField) = 47 THEN⓪*(*⓪+* Variante auswerten.⓪+* Dazu wird eine ConstExpr geholt, dann auf AsnCompat geprüft.⓪+* Dann wird in den Tags nach dem Wert gesucht.⓪+* Wenn ein Var-Feld existiert, wird der Wert zugewiesen.⓪+*)⓪*GetSymbol;⓪*PushExpr (dest);⓪*ConstExpression ();⓪*singlePar.parType:= parType;⓪*WITH singlePar DO⓪,PopExpr (expr);⓪,PopExpr (dest);⓪,byRef:= FALSE; openArray:= FALSE;⓪,checkAsnCompat (expr, parType, range, rParTy);⓪,fitValue (expr, range);⓪,(* zuerst legen wir den Wert ab, falls nötig *)⓪,IF BaseType (recField) # 0 THEN⓪.sync (BaseType (recField));⓪.addField (BaseType (recField))⓪,END;⓪,(* Nun suchen wir nach dem Wert in den Tags *)⓪,value:= expr.exprConst.zz.v;⓪,tagField:= TagFieldList (recField);⓪,LOOP⓪.IF tagField = 0 THEN⓪0(* Wert exist. nicht in Tag-Feldern *)⓪0SyntaxError (rNoTag)⓪.END;⓪.IF (value >= LowBound (tagField)) & (value <= HighBound (tagField)) THEN⓪0(* gefunden *)⓪0fieldListSeq (NextParm (tagField));⓪0EXIT⓪.END;⓪.tagField:= NextTagField (tagField);⓪,END;⓪*END⓪(ELSE⓪*(* normales Record-Feld auswerten *)⓪*PushExpr (dest);⓪*sync (recField);⓪*getSingle (singlePar, parType, isConst);⓪*PopExpr (dest);⓪*addField (recField);⓪(END;⓪(⓪(recField:= NextRecField (recField);⓪(IF recField = 0 THEN⓪*EXIT⓪(END;⓪(⓪(IF CurrentSymbol.itemNo # comma THEN SyntaxError (rComXp) END;⓪&END (* LOOP *)⓪$END fieldListSeq;⓪ ⓪"BEGIN (* hdlRecordConstructor *)⓪$(*⓪%* Das Kopieren des Records geht folgendermaßen:⓪%* Die Daten werden, falls es keine ConstExpr ist, auf den A3-Stack⓪%* gelegt.⓪%* Wird A3 verwendet, muß noch der Sonderfall, daß durch einen⓪%* Funktionsaufruf das Ergebnis schon auf dem Stack steht,⓪%* berücksichtigt werden (geschieht in 'pushSingle').⓪%*)⓪$IF NOT InConstExpr THEN checkStack (TypeLength (recordType)) END;⓪$initStackExpr (dest, NIL, A3);⓪$initConstPar (constPar);⓪$isConst:= TRUE;⓪$saved:= FALSE;⓪$loadedBytes:= 0;⓪$⓪$fieldListSeq (FirstRecField (recordType));⓪$fillUp (constPar, dest, TypeLength (recordType) - loadedBytes);⓪$⓪$deallocRegs (dest); (* Hilfs-Zeiger freigeben *)⓪$IF isConst & restoreCode () THEN⓪&dest:= constPar.expr;⓪&dest.item:= recordType;⓪$ELSE⓪&initStackExpr (dest, recordType, A3);⓪&dest.up:= FALSE;⓪&dest.stackedSize:= roundedSize (dest);⓪$END;⓪$ChkRbrace;⓪$PushExpr (dest)⓪"END hdlRecordConstructor;⓪ ⓪ ⓪ (* Testausgaben:⓪ PROCEDURE errorBdTyp (l, r: PtrItem);⓪"VAR ok: BOOLEAN;⓪"BEGIN⓪$ConvCard (ItemNo (l), 0, BadId);⓪$Append ('/', BadId, ok);⓪$Append (CardToStr (ItemNo (r), 0), BadId, ok);⓪$SyntaxError (rBdTyp)⓪"END errorBdTyp;⓪ *)⓪ ⓪ PROCEDURE adjustRangeType (t: PtrItem; upperType: PtrItem);⓪"VAR min, max, lo, hi: ZZ; elems: LONGCARD; baseType: PtrItem;⓪"BEGIN⓪$baseType:= BaseType (t);⓪$lo:= toZZ (LowBound (t), signedType (baseType));⓪$hi:= toZZ (HighBound (t), signedType (upperType));⓪$IF TypeLength (t) = 0L THEN⓪&baseType:= makeZZ (baseType)⓪$ELSE⓪&(*$? Safety: assert (t # ZZTyp)*) (* wenn doch, dann Abfrage unten ändern! *)⓪$END;⓪$IF NOT compatTT (baseType, makeZZ (upperType)) THEN⓪&SyntaxError (rBdTyp)⓪&(* errorBdTyp (baseType, makeZZ (upperType)) *)⓪$END;⓪$IF cmpZZ (lo, hi) = gt THEN⓪&SyntaxError (rLowHi)⓪$END;⓪$IF baseType # ZZTyp THEN⓪&(* Subrange hat schon festen Typ - prüfen, ob alles paßt *)⓪&getBounds (BaseType (t), min, max);⓪&IF (cmpZZ (lo, min) = lt) OR (cmpZZ (hi, max) = gt) THEN⓪(SyntaxError (rBouRg)⓪&END;⓪$ELSE⓪&(* wir müssen einen neuen Typen und Größe bestimmen *)⓪&getNumTypeForRange (lo, hi, baseType);⓪&IF baseType = SBothTyp THEN⓪(baseType:= SCardPtr⓪&ELSIF baseType = BothTyp THEN⓪(baseType:= CardPtr⓪&END;⓪&SetBaseType (t, baseType);⓪$END;⓪$SetTypeLength (t, TypeLength (baseType))⓪"END adjustRangeType;⓪ ⓪ ⓪ PROCEDURE hdlInclExcl (incl: BOOLEAN);⓪"VAR dest, elem, set: ExprDesc; range: ConvDesc;⓪&lo, hi: ZZ; n: CARDINAL;⓪"BEGIN⓪$(* A0: Ptr auf Set; D0.W: Element; D1 frei; Range-Check hier machen! *)⓪$GetLparen;⓪$GetSymbol;⓪$designator (modifyDesig, FALSE, rVarXp);⓪$PopExpr (set);⓪$IF (ItemNo (set.item) # 5) & (ItemNo (set.item) # 45) THEN SyntaxError (rOpTyp) END;⓪$ChkComma;⓪$GetSymbol ();⓪$VarExpression ();⓪$PopExpr (elem);⓪$checkAsnCompat (elem, RefType (set.item), range, rBdTyp);⓪$fitValue (elem, range);⓪$getBounds (RefType (set.item), lo, hi);⓪$(*$? Safety: assert (set.typeChecked);*)⓪$IF elem.kind = constant THEN⓪&IF NOT set.zerobased THEN subZZ (elem.exprConst.zz, lo) END;⓪&n:= elem.exprConst.zz.c DIV 8;⓪&IF set.regset THEN⓪(n:= SHORT (Size (set)) - 1 - n⓪&END;⓪&IF (n > 0) & (set.kind # register) THEN⓪(loadAddress (set);⓪(makeIndir (set, n, FALSE)⓪&END;⓪&IF incl THEN n:= BSETI ELSE n:= BCLRI END;⓪&genia (n, elem.exprConst.zz.c, set, -1);⓪$ELSIF set.regset THEN⓪&(*⓪'* Hier wird sichergestellt, daß in 'dest' nur eine einfache⓪'* Adressierung mit über d16(An) erfolgt, also keinesfalls mit⓪'* d8(An,Dn), weil sonst evtl. Dn doppelt (als set-Var im Reg und⓪'* bei moveSingle am Ende) benutzt wird.⓪'*)⓪&makeInd0An (set);⓪&dest:= set;⓪&loadReg (set, anyDataReg);⓪&loadReg (elem, anyDataReg);⓪&IF NOT set.zerobased THEN⓪(negZZ (lo);⓪(loadReg (elem, dataRegs);⓪(incReg (elem.exprReg, lo, 2)⓪&END;⓪&IF incl THEN n:= BSET ELSE n:= BCLR END;⓪&genar (n, set, elem.exprReg);⓪&moveSingle (set, dest, 0);⓪$ELSE⓪&IF incl THEN⓪(runtimeElemSet (elem, set, add, lo)⓪&ELSE⓪(runtimeElemSet (elem, set, sub, lo)⓪&END;⓪$END;⓪$deallocRegs (elem);⓪$deallocRegs (set);⓪$GetRparen;⓪"END hdlInclExcl;⓪ ⓪ ⓪ PROCEDURE forStatement;⓪ ⓪"VAR count, help, var, first, last: ExprDesc;⓪&firstRange, lastRange: ConvDesc;⓪&op: Operator;⓪&loops, by, lo, hi: ZZ;⓪&loopStart, loopEnd: Label;⓪&flags: IFS;⓪®s: RegSet;⓪&lastSuppress, wasReg, usedReg, regVar,⓪&firstOnA7, constInReg, constLoop: BOOLEAN;⓪&constReg, regNo, varReg, varPtr: RegType;⓪&t: PtrItem;⓪&n: CARDINAL;⓪&stackUsed: LONGCARD;⓪&⓪"BEGIN⓪$(*⓪%* FOR var := first TO last DO ...⓪%*⓪%* Regeln:⓪%* - first ist asn-compat zu var⓪%* - last ist identisch mit HostType (var)⓪%* - erst first & last ausrechnen, dann verleichen;⓪%* nur, wenn first <= last, dann Schleife:⓪%* - first auf var zuweisen⓪%* - statement-sequence⓪%* - INC (first)⓪%*⓪%* Der Code sieht dann so aus (Optimierung auf Kürze):⓪%*⓪%* >> Wenn 'first' auf dem A7 steht ('last' natürlich nicht):⓪%* MOVE first,Dx⓪%* MOVE last,-(A7)⓪%* >> sonst:⓪%* MOVE last,-(A7)⓪%* MOVE first,Dx⓪%*⓪%* ; hier ggf. Range-Check f. var:= first⓪%* loop: CMP (A7),Dx⓪%* BHI ende⓪%* MOVE Dx,var⓪%* ...⓪%* MOVE var,Dx⓪%* ADDI #by,Dx⓪%* BCC loop⓪%* ende: ADDQ #Size(last),A7⓪%*⓪%* Beim konstanten Schleifen wird folg. codiert:⓪%* MOVE #hi-lo,-(A7)⓪%* MOVE #first,var⓪%* loop: ...⓪%* ADDI #by,var⓪%* SUBQ #1,(A7)⓪%* BCC loop⓪%* ADDQ #Size(count),A7⓪%*⓪%*⓪%*)⓪$GetSymbol;⓪$⓪$IF NOT (userDef IN CurrentSymbol.flags)⓪$OR (ORD (CurrentSymbol.typ) # 17)⓪$OR ( IFS {exported, imported, extVar, indirVar}⓪(* CurrentSymbol.flags # IFS {})⓪$OR (procDepth (Tiefe) # 0)⓪$OR (global IN CurrentSymbol.flags) & (Global # 0) THEN⓪&SyntaxError (rForVr)⓪$END;⓪$var.varItem:= CurrentSymbol.item;⓪$IF NOT isOrdinal (RefType (var.varItem)) THEN SyntaxError (rScLop) END;⓪$IF refVar IN CurrentSymbol.flags THEN SyntaxError (rRdOnl) END;⓪$IF (AccessDepth (var.varItem) > Global+1) AND NOT suppressOpt () THEN⓪&(* auf Var wurde schon in lok. Proz. zugegriffen - darf nicht bei⓪'* Schleifenvar in Reg! *)⓪&SyntaxError (rForAc)⓪$END;⓪$⓪$(*⓪%* Nun wird die Laufvar. einfach als temp. Reg-Var definiert.⓪%* Das wird aber nur getan, wenn noch ein Reg frei ist, das noch⓪%* nicht für eine Reg-Var vorgemerkt ist. Denn würde ein Reg benutzt,⓪%* das z.Zt. zwar frei ist, dann aber in der Schleife doch benutzt⓪%* werden soll, kann es ineffektiv werden, wenn das dann nicht geht;⓪%* wenn das belegte Reg gar von einer Var. f. eine FOR-Schleife reserv.⓪%* ist, kann es noch aufwendiger werden.⓪%*)⓪$wasReg:= IsRegVar (var.varItem);⓪$regVar:= wasReg OR NOT suppressOpt () & allocRegVar (dataVar, regNo);⓪$IF regVar THEN⓪&initExpr (var, RefType (var.varItem), register);⓪&var.varItem:= CurrentSymbol.item;⓪&IF wasReg THEN⓪(regNo:= UsedReg (var.varItem);⓪((*$? Safety: assert (NOT (regNo IN freeVarRegs));*)⓪(var.exprReg:= regNo;⓪(usedReg:= IsInReg (var.varItem);⓪(IF usedReg THEN⓪*(*$? Safety: assert (NOT (regNo IN freeRegs))*)⓪(ELSE⓪*(*$? Safety: assert (regNo IN freeRegs);*)⓪*EXCL (freeRegs, regNo)⓪(END⓪&ELSE⓪((* wenn Reg vorher unbenutzt war, dann nun auf A7 retten *)⓪((*$? Safety: assert (regNo IN freeVarRegs);*)⓪(pushNonTemp (regNo, TRUE); (* immer LONG retten, da evtl. ein MOVEQ.L gen. wird! *)⓪(usedReg:= FALSE;⓪(var.exprReg:= regNo;⓪&END;⓪&PushExpr (var);⓪&GetSymbol;⓪$ELSE⓪&(* wenn kein Reg frei, dann als normale Var ansprechen *)⓪&designator (setDesig, FALSE, rForVr);⓪&LookExpr (var);⓪$END;⓪$⓪$IF CurrentSymbol.itemNo # becomes THEN SyntaxError (rAsgXp) END;⓪$⓪$GetSymbol ();⓪$VarExpression ();⓪$LookExpr (first);⓪$checkAsnCompat (first, var.item, firstRange, rParTy);⓪$⓪$IF CurrentSymbol.itemNo # toSym THEN SyntaxError (rToXp) END;⓪$⓪$GetSymbol ();⓪$VarExpression ();⓪$PopExpr (last);⓪$adaptZZ (last, var.item, TRUE);⓪$adaptSSToChar (last);⓪$IF NOT compatTT (var.item, last.item) THEN SyntaxError (rForTo) END;⓪$getConversionDesc (last.item, var.item, lastRange);⓪$lastRange.lowerBound:= LONGWORD (0L);⓪$⓪$IF CurrentSymbol.itemNo = bySym THEN⓪&GetSymbol;⓪&ConstExpression ();⓪&PopExpr (help);⓪&by:= help.exprConst.zz;⓪&IF NOT isWholeNumber (help.item) OR nullZZ (by) THEN⓪(SyntaxError (rIntSt)⓪&END;⓪$ELSE⓪&by:= toZZ (1L, FALSE)⓪$END;⓪$⓪$IF CurrentSymbol.itemNo # doSym THEN SyntaxError (rDoXp) END;⓪$⓪$stackUsed:= 0;⓪$IF last.kind = constant THEN⓪&fitValue (last, lastRange); (* prüfe, ob Wert innerhalb 'var' liegt *)⓪&lastRange:= alwaysFitting (var.item);⓪$END;⓪$⓪$PopExpr (first);⓪$reloadPtr (first);⓪$firstOnA7:= (first.kind = stack) & (first.stackReg = A7);⓪$⓪$PopExpr (var);⓪$(* kann eh nicht vorkommen: reloadPtr (var); *)⓪$⓪$(*$? Safety: assert ((last.kind#stack) OR (last.stackReg=A3)); (* siehe oben, Codebsp. *) *)⓪$IF (last.kind # constant) & NOT firstOnA7 THEN⓪&loadOnA7 (last, alwaysFitting (var.item), stackUsed)⓪$END;⓪$⓪$IF regVar THEN⓪&IF NOT usedReg THEN⓪(IF NOT wasReg THEN⓪*MakeRegVar (var.varItem);⓪*SetReg (var.varItem, regNo)⓪(END;⓪(UseReg (var.varItem)⓪&END⓪$ELSE⓪&(*⓪'* Hier muß 'var' in ein einziges Reg geladen werden, falls der⓪'* mode d8AnXn ist⓪'*)⓪&(*$? Safety: assert (var.kind = memory);*)⓪&IF (var.mode # absRef)⓪&AND NOT ((var.mode = d16An) & NOT (var.baseReg IN tempRegs)) THEN⓪(makeInd0An (var);⓪&END;⓪&IF var.mode # absRef THEN⓪(varPtr:= var.baseReg;⓪((*$? Safety: assert (var.mode = d16An);*)⓪((*$? Safety: assert ((varPtr = A0) OR (varPtr = VarReg))*)⓪&END;⓪$END;⓪$⓪$fitValue (first, firstRange);⓪$⓪$constLoop:= ~suppressOpt () & (first.kind = constant) & (last.kind = constant);⓪$⓪$IF constLoop THEN⓪$⓪&(* Access-Level löschen, um zu erkennen, ob Zugriff darauf erfolgt *)⓪&SetAccessDepth (var.varItem, 0);⓪$⓪&loops:= last.exprConst.zz;⓪&subZZ (loops, first.exprConst.zz);⓪&divZZ (loops, by);⓪&⓪&lastSuppress:= SuppressCode;⓪&IF NOT posZZ (loops) THEN⓪(SuppressCode:= TRUE⓪&END;⓪&⓪&initConstExpr (count, sizeZZeven (loops), loops);⓪&constInReg:= allocRegVar (dataVar, constReg);⓪&IF constInReg THEN⓪((*$? Safety: assert (constReg IN freeVarRegs);*)⓪((* da Reg vorher unbenutzt war, nun auf A7 retten *)⓪(pushNonTemp (constReg, TRUE); (* immer LONG retten, da evtl. ein MOVEQ.L gen. wird! *)⓪(INCL (freeRegs, constReg);⓪(regs:= RegSet {};⓪(INCL (regs, constReg);⓪(loadReg (count, regs);⓪&ELSE⓪(loadOnA7 (count, alwaysFitting (count.item), stackUsed);⓪&END;⓪&loopEnd:= NIL;⓪ ⓪$ELSE⓪$⓪&IF regVar & NOT usedReg THEN⓪(regs:= RegSet {};⓪(INCL (regs, regNo);⓪(INCL (freeRegs, regNo)⓪&ELSE⓪(regs:= anyDataReg⓪&END;⓪&loadReg (first, regs);⓪&IF (last.kind # constant) & firstOnA7 THEN⓪(loadOnA7 (last, alwaysFitting (var.item), stackUsed)⓪&END;⓪&(*$? Safety: assert (NOT regVar OR NOT (regNo IN freeRegs));*)⓪&⓪&loopStart:= CodePtr ();⓪&IF last.kind = constant THEN⓪(genia (CMPI, last.exprConst.zz.v, first, 0);⓪&ELSE⓪(genar (CMP, last, first.exprReg)⓪&END;⓪&IF posZZ (by) THEN op:= gt ELSE op:= lt END;⓪&genbcc (mapCC (op, signedExpr (var), FALSE), FALSE, loopEnd);⓪$⓪$END;⓪$⓪$(* MOVE Dx,var *)⓪$IF NOT constLoop THEN⓪&varReg:= first.exprReg;⓪$END;⓪$help:= var;⓪$moveToVar (first, help, lastRange);⓪$ClearDirt (var.varItem);⓪$⓪$IF constLoop THEN⓪&loopStart:= CodePtr ();⓪$END;⓪$⓪$help:= var;⓪$PushExpr (var);⓪$(*⓪%* spillAllRegs ();⓪%*⓪%* nun muß var-Desc entw. auf dem Stack stehen,⓪%* global sein, in einer Reg-Var stehen oder mit d16(A6) adr. sein.⓪%*⓪%* >>> spilling bräuchte eigentlich gar nicht unbedingt getan werden,⓪%* denn es kann sein, daß in den folg. statements das reg nicht⓪%* gespilled werden braucht. Allerdings müssen die 3 unteren⓪%* Vars f. RETURN und EXIT richtig gesetzt sein, und deshalb⓪%* müßten dann diese Vars in 'spillReg' und 'reloadPtr' korrigiert⓪%* werden.⓪%*)⓪$⓪$flags:= ItemFlag (var.varItem);⓪$SetItemFlag (var.varItem, flags + IFS {refVar}); (* 'var' schützen *)⓪$⓪$StatementSequence;⓪$⓪$SetItemFlag (var.varItem, flags);⓪$⓪$IF CurrentSymbol.itemNo # endSym THEN SyntaxError (rBdSym) END;⓪$GetSymbol;⓪$⓪$PopExpr (var);⓪$reloadPtr (var);⓪$IF regVar THEN⓪&IF NOT usedReg THEN⓪(UseMem (var.varItem);⓪(deallocRegVar (regNo);⓪&END;⓪&IF NOT wasReg THEN⓪(MakeMemVar (var.varItem);⓪&END;⓪$ELSE⓪&(*$? Safety:⓪(assert (var.kind = memory);⓪(assert ((var.mode = absRef) OR (var.mode = d16An));⓪(assert ((var.mode # d16An) OR (varPtr = var.baseReg));⓪&*)⓪$END;⓪$⓪$IF constLoop THEN⓪&⓪&IF AccessDepth (var.varItem) # 0 THEN⓪((* Auf Laufvar. wurde zugegriffen *)⓪((* DEC (var, by) *)⓪(IF int3ZZ (by) THEN⓪*genQ (by.i, var)⓪(ELSE⓪*genia (ADDI, by.l, var, 0)⓪(END;⓪&END;⓪&⓪&IF (count.kind = register) & (Size (count) = 2L) THEN⓪((* DBRA Dn,loopStart *)⓪(genDBcc (mapNever (), count.exprReg,⓪1LONGINT (loopStart) - LONGINT (CodePtr () + 2L));⓪&ELSE⓪((* SUBQ #1,(A7) *)⓪(genQ (-1, count);⓪((* BCC loopStart *)⓪(bccBackTo (mapCC (cc, FALSE, FALSE), loopStart);⓪&END;⓪&⓪&IF constInReg THEN deallocRegVar (constReg) END;⓪&⓪$ELSE⓪$⓪&(* MOVE var,Dx *)⓪®s:= RegSet {};⓪&INCL (regs, varReg);⓪&loadReg (help, regs);⓪&deallocRegs (help);⓪&⓪&(* ADD #by,Dx *)⓪&incReg (first.exprReg, by, SHORT (Size (help)));⓪&(* BCC loopStart *)⓪&bccBackTo (mapCC (cc, signedType (help.item), FALSE), loopStart);⓪$⓪$END;⓪$⓪$(* END of FOR *)⓪$(* ADDQ #2/4,A7 *)⓪$ToHere (loopEnd);⓪$incReg (A7, toZZ (stackUsed, FALSE), 4);⓪$⓪$IF constLoop THEN⓪&IF constInReg THEN⓪(popNonTemp (constReg);⓪&END;⓪&SuppressCode:= lastSuppress;⓪$ELSIF suppressOpt () & NOT wasReg THEN⓪&(* letzten Schleifenwert in die Var zurückladen *)⓪&(*$? Safety: assert (first.kind = register);*)⓪&genMOVEaa (first, var, 0);⓪$END;⓪$⓪$IF regVar & NOT wasReg THEN⓪&popNonTemp (regNo);⓪$END;⓪$⓪$SetDirt (var.varItem);⓪$⓪"END forStatement;⓪ ⓪ ⓪ PROCEDURE hdlIncDec (doInc: BOOLEAN);⓪"VAR var, arg: ExprDesc;⓪&vtype: PtrItem;⓪&opcode: CARDINAL;⓪&doCheck: BOOLEAN;⓪&range: ConvDesc;⓪&lo, lo2, hi, hi2: ZZ;⓪"BEGIN⓪$GetLparen;⓪$GetSymbol;⓪$designator (modifyDesig, FALSE, rVarXp);⓪$PopExpr (var);⓪$IF NOT (scalar IN ItemFlag (var.item)) & (ItemNo (var.item) # 20 (* POINTER *)) THEN⓪&SyntaxError (rSclXp)⓪$END;⓪ ⓪$IF CurrentSymbol.itemNo = comma THEN⓪&PushExpr (var);⓪&GetSymbol ();⓪&VarExpression ();⓪&PopExpr (arg);⓪&PopExpr (var);⓪&reloadPtr (var);⓪&IF NOT isWholeNumber (arg.item) THEN⓪(SyntaxError (rWhNXp)⓪&END;⓪$ELSE⓪&initExpr (arg, var.item, constant);⓪&arg.exprConst.zz.c:= 1⓪$END;⓪ ⓪$vtype:= sizedItem (SHORT (Size (var)), signedType (var.item));⓪$getConversionDesc (arg.item, vtype, range);⓪$fitValue (arg, range);⓪ ⓪$doCheck:= TRUE;⓪$IF arg.kind = constant THEN⓪&IF int3ZZ (arg.exprConst.zz) THEN⓪(IF NOT nullZZ (arg.exprConst.zz) THEN⓪*IF NOT doInc THEN negZZ (arg.exprConst.zz) END;⓪*genQ (arg.exprConst.zz.i, var)⓪(ELSE⓪*doCheck:= FALSE⓪(END⓪&ELSIF (var.kind = register) & (var.exprReg >= A0) THEN⓪(addConstToAddrReg (arg.exprConst.zz.v, var.exprReg)⓪&ELSE⓪(IF doInc THEN opcode:= ADDI ELSE opcode:= SUBI END;⓪(genia (opcode, arg.exprConst.l, var, 0)⓪&END⓪$ELSE⓪&IF signedType (var.item) # signedType (arg.item) THEN⓪(SyntaxError (rBdTyp)⓪&END;⓪&loadReg (arg, anyDataReg);⓪&IF doInc THEN opcode:= ADD ELSE opcode:= SUB END;⓪&genra (opcode, arg.exprReg, var)⓪$END;⓪$deallocRegs (arg);⓪$IF doCheck THEN⓪&getBounds (var.item, lo, hi);⓪&var.item:= sizedItem (SHORT (Size (var)), signedType (var.item));⓪&getBounds (var.item, lo2, hi2);⓪&IF (cmpZZ (lo, lo2) # eq) OR (cmpZZ (hi, hi2) # eq) THEN⓪(checkBounds (var, lo, hi, lo2);⓪&ELSE⓪(checkOverflow (var.item)⓪&END;⓪$END;⓪$deallocRegs (var);⓪$GetRparen⓪"END hdlIncDec;⓪ ⓪ PROCEDURE withStatement;⓪"VAR oldA2ofs: INTEGER;⓪&lastWith: BOOLEAN;⓪&withPtr: ExprDesc;⓪"BEGIN⓪$GetSymbol;⓪$designator (readDesig, FALSE, rReDXp);⓪$PopExpr (withPtr);⓪$IF ItemNo (withPtr.item) # 13 THEN SyntaxError (rReDXp) END;⓪$IF withPtr.regVar THEN SyntaxError (rRegVa) END;⓪$IF CurrentSymbol.itemNo # doSym THEN SyntaxError (rDoXp) END;⓪$⓪$lastWith:= WithScope;⓪$WithScope:= TRUE;⓪$OpenScope (LocalTree (withPtr.item));⓪$INC (ROScope, 4);⓪$loadDisplay (withPtr);⓪$⓪$StatementSequence;⓪$⓪$freeDisplay;⓪$CloseScope ();⓪$DEC (ROScope, 4);⓪$WithScope:= lastWith;⓪$⓪$IF CurrentSymbol.itemNo # endSym THEN SyntaxError (rBdSym) END;⓪$GetSymbol;⓪$⓪"END withStatement;⓪ ⓪ ⓪ VAR lastA3, lastA7: LONGINT;⓪ ⓪ PROCEDURE codeBegin;⓪"BEGIN⓪$exprSp:= -1;⓪$spillSp:= -1;⓪$spilling:= FALSE;⓪$spillDestReg:= A7;⓪$spillDestDir:= down;⓪$RelocCount:= 0;⓪$SuppressCode:= FALSE;⓪$lastA3:= A3Offset;⓪$lastA7:= A7Offset;⓪$SavedTempRegs:= freeRegs * tempRegs;⓪$openDisplay; (* für WITH *)⓪"END codeBegin;⓪ ⓪ PROCEDURE codeEnd;⓪"BEGIN⓪$closeDisplay; (* für WITH *)⓪$(*$? Safety:⓪$assert (exprSp = -1);⓪$assert (spillSp = -1);⓪$assert (NOT SuppressCode);⓪$*)⓪$IF (lastA3 # A3Offset) OR (lastA7 # A7Offset) THEN⓪&IF lastA3 # A3Offset THEN BadId:= 'A3/codeend' ELSE BadId:= 'A7/codeend' END;⓪&SyntaxError (rIntSP);⓪&A3Offset:= lastA3;⓪&A7Offset:= lastA7;⓪$END;⓪"END codeEnd;⓪ ⓪ PROCEDURE moveRegs (regs: RegSet; pop: BOOLEAN);⓪"⓪"VAR ncpu, nfpu: CARDINAL; r2, r1, r: RegType; lastA7: LONGINT;⓪&list: RECORD dummy: BYTE; fpu: BYTE; cpu: CARDINAL; END;⓪"⓪"PROCEDURE moveFPU;⓪$BEGIN⓪&IF nfpu # 0 THEN moveRealRegs (pop, ORD(list.fpu)); END;⓪$END moveFPU;⓪"⓪"PROCEDURE moveCPU;⓪$VAR st: ExprDesc;⓪$BEGIN⓪&IF ncpu = 1 THEN⓪(IF pop THEN⓪*genPopReg (r1, TRUE, A7)⓪(ELSE⓪*genPushReg (r1, TRUE, A7)⓪(END⓪&ELSIF ncpu # 0 THEN⓪((* MOVEM gen. *)⓪(initStackExpr (st, CardPtr, A7);⓪(st.up:= pop;⓪(gena (MOVEML + $400 * ORD (pop), st, -1);⓪(gen (list.cpu)⓪&END;⓪$END moveCPU;⓪"⓪"BEGIN⓪$lastA7:= A7Offset;⓪$(*⓪%* CPU-Regs und FPU-Regs sichern⓪%*)⓪$ncpu:= 0;⓪$nfpu:= 0;⓪$list.cpu:= 0;⓪$list.fpu:= BYTE(0);⓪$FOR r:= D0 TO F7 DO⓪&IF (r IN (varRegs - RegSet {A3,A7})) (* wenn's ein Var-Reg ist *)⓪&& NOT (r IN regs) (* und es belegt wurde *) THEN⓪(r2:= r;⓪(IF r < F0 THEN r1:= r END;⓪(ASSEMBLER⓪*; r: 0..23⓪*; F:23-16, D/A:15-0⓪*MOVE.W r2(A6),D0 ;Vorsicht! 'r' liegt u.U. im Register!⓪*TST pop(A6)⓪*BNE norev⓪*SUBI #15,D0⓪*BHI freg⓪*NEG D0⓪*BRA norev⓪(freg⓪*SUBQ #8,D0⓪*NEG D0⓪*ADDI #16,D0⓪(norev⓪*MOVE.L list(A6),D1⓪*BSET D0,D1⓪*MOVE.L D1,list(A6)⓪(END;⓪(IF r < F0 THEN INC (ncpu) ELSE INC (nfpu) END⓪&END;⓪$END;⓪$IF pop THEN⓪&moveFPU;⓪&moveCPU;⓪$ELSE⓪&moveCPU;⓪&moveFPU⓪$END;⓪$A7Offset:= lastA7⓪"END moveRegs;⓪ ⓪ ⓪ (*$D-*)⓪ ⓪ VAR helpCh: CHAR;⓪$helpRange: ConvDesc;⓪$false: Labels;⓪$helpTarget: Label;⓪$helpType: PtrItem;⓪$size: LONGCARD;⓪$helpAddr3, helpAddr2, helpAddr: ADDRESS;⓪$lastOffset: LONGINT;⓪$expandToLongOfs, no, no2: CARDINAL;⓪$helpReg: RegType;⓪$regList: RegSet;⓪$mustReduceZZ: BOOLEAN;⓪ ⓪ PROCEDURE expr;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$lastOffset:= A3Offset;⓪$(*$? Safety: assert (NOT ODD (A3Offset));*)⓪$GetSymbol ();⓪$VarExpression ();⓪$PopExpr (helpExpr);⓪$reduceZZ (helpExpr);⓪$adaptSSToChar (helpExpr);⓪$loadOnA3 (helpExpr, alwaysFitting (helpExpr.item));⓪$(*$? Safety: assert (NOT ODD (A3Offset));*)⓪$A3Offset:= lastOffset;⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪(LEA helpExpr,A0⓪(MOVE.L helpExpr.item(A0),D0⓪(JSR PushInt⓪$END⓪"END expr;⓪"(*$L=*)⓪ ⓪ PROCEDURE caseExpr;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$GetSymbol ();⓪$VarExpression ();⓪$PopExpr (helpExpr);⓪$IF NOT (scalar IN ItemFlag (helpExpr.item)) THEN SyntaxError (rScCas) END;⓪$reduceZZ (helpExpr);⓪$adaptSSToChar (helpExpr);⓪$no2:= SHORT (Size (helpExpr));⓪$IF no2 < 2 THEN no2:= 2 END;⓪$loadRegExt (helpExpr, RegSet {D0}, no2, FALSE);⓪$deallocReg (D0);⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪(LEA helpExpr,A0⓪(MOVE.L helpExpr.item(A0),D0⓪(JSR PushInt⓪$END⓪"END caseExpr;⓪"(*$L=*)⓪ ⓪ PROCEDURE pushExpr;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.W D0,no⓪(JSR PullInt⓪(MOVE.L D0,helpAddr⓪(JSR Entry⓪$END;⓪$(*$? Safety:⓪&assert (NOT ODD (A3Offset));⓪$*)⓪$lastOffset:= A3Offset;⓪$GetSymbol ();⓪$VarExpression ();⓪$PopExpr (helpExpr);⓪$checkAsnCompat (helpExpr, helpAddr, helpRange, rParTy);⓪$IF no = 0 THEN⓪&loadOnA3 (helpExpr, helpRange);⓪$ELSE⓪&fitValue (helpExpr, helpRange);⓪&loadReg (helpExpr, RegSet {D0});⓪&deallocReg (D0)⓪$END;⓪$(*$? Safety: assert (NOT ODD (A3Offset));*)⓪$A3Offset:= lastOffset;⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END pushExpr;⓪"(*$L=*)⓪ ⓪ PROCEDURE pushAdr;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$lastOffset:= A3Offset;⓪$designator (varDesig, FALSE, rVarXp);⓪$PopExpr (helpExpr);⓪$IF helpExpr.regVar THEN SyntaxError (rRegVa) END;⓪$helpAddr:= helpExpr.item;⓪$loadSourceAddress (helpExpr);⓪$loadOnA3 (helpExpr, alwaysFitting (helpExpr.item));⓪$A3Offset:= lastOffset;⓪$ASSEMBLER⓪(JSR Exit⓪(MOVE.L helpAddr,D0⓪(JSR PushInt⓪(MOVEQ #0,D7⓪$END⓪"END pushAdr;⓪"(*$L=*)⓪ ⓪ PROCEDURE doConstExpr;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$ConstExpression;⓪$PopExpr (helpExpr);⓪$IF mustReduceZZ THEN⓪&reduceZZ (helpExpr)⓪$END;⓪$(*⓪%* nun muß die Konstante zurück in den Accu⓪%*)⓪$size:= Size (helpExpr);⓪$helpAddr2:= ADR (Accu);⓪$expandToLongOfs:= 0;⓪$IF isSS (helpExpr) THEN⓪&helpAddr2:= ADR (STRBUF);⓪&helpExpr.item:= StrPtr;⓪&StrLen:= SHORT (size);⓪&IF StrLen > SIZE (STRBUF) THEN SyntaxError (rSCoLg) END;⓪$ELSE⓪&IF (size < 4L) & (scalar IN ItemFlag (helpExpr.item)) THEN⓪(expandToLongOfs:= SHORT (4-size);⓪(size:= 4⓪&ELSIF size > LONG(AccuSize) THEN⓪(helpAddr2:= NIL (* Datum nicht kopieren, sondern Ptr drauf liefern *)⓪&END⓪$END;⓪$IF helpExpr.kind = constRef THEN⓪&IF helpExpr.constHead = NIL THEN dropConstantFromTree (helpExpr) END;⓪&helpAddr3:= helpExpr.constAddr + helpExpr.constOfs - LONG(expandToLongOfs);⓪&cutConst (helpExpr);⓪$ELSE⓪&helpAddr3:= ADR (helpExpr.exprConst.b)-size+1L⓪$END;⓪$IF helpAddr2 # NIL THEN⓪&AccuPtr:= helpAddr2;⓪&Move (helpAddr3, helpAddr2, SHORT (size));⓪$ELSE⓪&AccuPtr:= helpAddr3⓪$END;⓪$ASSEMBLER⓪(JSR Exit⓪(LEA helpExpr,A0⓪(MOVE.L helpExpr.item(A0),D0⓪(JSR PushInt⓪$END⓪"END doConstExpr;⓪"(*$L=*)⓪ ⓪ PROCEDURE constExpr;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE mustReduceZZ,-(A7)⓪(MOVE #1,mustReduceZZ⓪(JSR doConstExpr⓪(MOVE (A7)+,mustReduceZZ⓪$END⓪"END constExpr;⓪"(*$L=*)⓪ ⓪ PROCEDURE constExprZZ;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE mustReduceZZ,-(A7)⓪(CLR mustReduceZZ⓪(JSR doConstExpr⓪(MOVE (A7)+,mustReduceZZ⓪$END⓪"END constExprZZ;⓪"(*$L=*)⓪ ⓪ PROCEDURE boolExpr;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$BoolExpression (false);⓪$PushLabels (false, no);⓪$(*$?Safety2: assert (LabelsInPool = 0); *)⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪(MOVE.W no,D0⓪$END⓪"END boolExpr;⓪"(*$L=*)⓪ ⓪ PROCEDURE assign;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪(MOVE.L A3,-(A7)⓪$END;⓪$InConstExpr:= FALSE;⓪$assignment;⓪$ASSEMBLER⓪(MOVE.L (A7)+,A0⓪(CMPA.L A0,A3⓪(BEQ ok⓪$END;⓪$BadId:= 'A3 corrupted';⓪$SyntaxError (rFatlR);⓪$ASSEMBLER⓪&ok⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END assign;⓪"(*$L=*)⓪ ⓪ PROCEDURE adjustSubrange;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L D0,helpAddr⓪(JSR Entry⓪$END;⓪$adjustRangeType (CurrentSymbol.item, helpAddr);⓪$ASSEMBLER⓪(JSR Exit⓪$END⓪"END adjustSubrange;⓪"(*$L=*)⓪ ⓪ PROCEDURE aCallSys;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$helpType:= CurrentSymbol.item;⓪$GetLparen;⓪$hdlCall (0, helpType);⓪$GetRparen;⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aCallSys;⓪"(*$L=*)⓪ ⓪ PROCEDURE aCallExt;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$helpType:= CurrentSymbol.item;⓪$GetLparen;⓪$hdlCall (1, helpType);⓪$GetRparen;⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aCallExt;⓪"(*$L=*)⓪ ⓪ PROCEDURE aLoad;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$hdlLoad;⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aLoad;⓪"(*$L=*)⓪ ⓪ PROCEDURE aStore;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$hdlStore;⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aStore;⓪"(*$L=*)⓪ ⓪ PROCEDURE aExcl;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$hdlInclExcl (FALSE);⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aExcl;⓪"(*$L=*)⓪ ⓪ PROCEDURE aIncl;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$hdlInclExcl (TRUE);⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aIncl;⓪"(*$L=*)⓪ ⓪ PROCEDURE aInc;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$hdlIncDec (TRUE);⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aInc;⓪"(*$L=*)⓪ ⓪ PROCEDURE aDec;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$hdlIncDec (FALSE);⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aDec;⓪"(*$L=*)⓪ ⓪ PROCEDURE aWith;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$withStatement;⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aWith;⓪"(*$L=*)⓪ ⓪ PROCEDURE aFor;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$forStatement;⓪$ASSEMBLER⓪(JSR Exit⓪(MOVEQ #0,D7⓪$END⓪"END aFor;⓪"(*$L=*)⓪ ⓪ PROCEDURE aBegin;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$codeBegin;⓪$ASSEMBLER⓪(JSR Exit⓪$END⓪"END aBegin;⓪"(*$L=*)⓪ ⓪ PROCEDURE aEnd;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$codeEnd;⓪$ASSEMBLER⓪(JSR Exit⓪$END⓪"END aEnd;⓪"(*$L=*)⓪ ⓪ PROCEDURE saveVarRegs;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$moveRegs (freeVarRegs, FALSE);⓪$ASSEMBLER⓪(JSR Exit⓪$END⓪"END saveVarRegs;⓪"(*$L=*)⓪ ⓪ PROCEDURE restoreVarRegs;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$moveRegs (freeVarRegs, TRUE);⓪$ASSEMBLER⓪(JSR Exit⓪$END⓪"END restoreVarRegs;⓪"(*$L=*)⓪ ⓪ PROCEDURE initBlock;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(JSR Entry⓪$END;⓪$freeRegs:= RegSet {D0..A2,A4..A6,F0..F7};⓪$freeVarRegs:= freeRegs;⓪$ASSEMBLER⓪(JSR Exit⓪$END⓪"END initBlock;⓪"(*$L=*)⓪ ⓪ PROCEDURE exclFromFreeRegs;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE D0,no⓪(JSR Entry⓪$END;⓪$EXCL (freeRegs, no);⓪$ASSEMBLER⓪(JSR Exit⓪$END⓪"END exclFromFreeRegs;⓪"(*$L=*)⓪ ⓪ PROCEDURE inclInFreeRegs;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE D0,no⓪(JSR Entry⓪$END;⓪$INCL (freeRegs, no);⓪$ASSEMBLER⓪(JSR Exit⓪$END⓪"END inclInFreeRegs;⓪"(*$L=*)⓪ ⓪ PROCEDURE getRegVar;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE D0,no⓪(JSR Entry⓪$END;⓪$helpReg:= 0;⓪$IF (VarType (no) # floatVar)⓪$OR (VarType (no) = floatVar) & (fpu () # softReal) THEN⓪&IF allocRegVar (VarType (no), helpReg) THEN⓪(ASSEMBLER⓪*MOVE helpReg,D0⓪*ORI #$80,D0 ; Flag: "ist Reg-Var"⓪*MOVE D0,helpReg⓪(END⓪&END⓪$END;⓪$ASSEMBLER⓪&JSR Exit⓪&MOVE helpReg,D0⓪$END⓪"END getRegVar;⓪"(*$L=*)⓪ ⓪ PROCEDURE discardA7;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L D0,lastOffset⓪(JSR Entry⓪$END;⓪$releaseNonTemp (lastOffset);⓪$ASSEMBLER⓪(JSR Exit⓪$END⓪"END discardA7;⓪"(*$L=*)⓪ ⓪ BEGIN⓪"FP[F0+0,FALSE]:= '@FP0L';⓪"FP[F0+1,FALSE]:= '@FP1L';⓪"FP[F0+2,FALSE]:= '@FP2L';⓪"FP[F0+3,FALSE]:= '@FP3L';⓪"FP[F0+4,FALSE]:= '@FP4L';⓪"FP[F0+5,FALSE]:= '@FP5L';⓪"FP[F0+6,FALSE]:= '@FP6L';⓪"FP[F0+7,FALSE]:= '@FP7L';⓪"FP[F0+0,TRUE]:= '@FP0H';⓪"FP[F0+1,TRUE]:= '@FP1H';⓪"FP[F0+2,TRUE]:= '@FP2H';⓪"FP[F0+3,TRUE]:= '@FP3H';⓪"FP[F0+4,TRUE]:= '@FP4H';⓪"FP[F0+5,TRUE]:= '@FP5H';⓪"FP[F0+6,TRUE]:= '@FP6H';⓪"FP[F0+7,TRUE]:= '@FP7H';⓪"ASM:= 'ASSEMBLER';⓪"LocalA7Hidden:= FALSE;⓪"GlobalA7Hidden:= FALSE;⓪"SignalOverflow:= TRUE;⓪"assert (TSIZE (ConstValue) = LONG (strConstSize + 1));⓪ END MM2Comp2.⓪ ə
- (* $0006758B$0002210A$0002210A$0007237E$FFE9DEE5$FFECE853$0004F58A$FFEBC3F7$00055242$FFE9DEE5$FFEEDF64$000000C8$FFEEDF64$000778E2$FFEEDF64$00076595$FFEEDF64$0006CE38$0004682D$00054B04$00048452$0004D3C2$00055828$FFEEDF64$FFEEDF64$FFEEDF64$FFE9DEE5$FFEEDF64$FFEDA5DC$0003CB5E$FFECC0C3$0005BC6C$0005F2AD$FFEEDF64$0003545B$0005166F$0005BC65$FFEEDF64$0003F64A$FFEEDF64$00022723$0006CE0BÇ$000000B0........T.......T.......T.......T.......T.......T.......T.......T.......T.......$000221B5$000217EF$00021D9A$00021F05$00002019$0000214F$000020CC$0000214C$000020C7$000000B0$000000C8$00021EE0$00021A7D$FFE4ED30$00021ED8$00021DDB¼Çé*)
-
