{$W-,I+} program P2FP (output, int, {dat,} ols, obj); {N B S P a s c a l C o m p i l e r -- P a s s 2} { *Authors: Brian G. Lucas * Justin C. Walker *Address comments to: * Justin C. Walker * Interactive Systems Corp * 1050 17th Street, N.W. * Suite 580 * Washington, D.C. 20036 * This software has been developed at the National Bureau of Standards. * As a product of the U.S. Government, it is in the public domain, and * should not be sold or otherwise used for profit. } {DEC OS versions maintained by DECUS Pascal SIG: John R. Barr - University of Montana Bill Heidebrecht - TRW DSSG Brian Nelson - University of Toledo RSX / IAS / RSTS revision history: } {Modified to correspond, more or less, to pass2.c. JCW\770303} {Modified to generate RSX-11 object modules JRB\780410} {Error corrections JCW\JBH\780615} {Modified to generate global references to run-time library JRB\780628} {Modified to separate procedures into object modules JRB\780630} {Modified to generate correct code for eoln JBH\780810} {Modified to generate PSECT definition in every procedure JRB\780827} {Modified for extern procedures JRB\780915} {Corrected 'bhi' error in fornode JBH\781110} {Corrected opstk corruption in notnode JRB\781125} {Removed invoke eoln test in buildtree JBH\781209} {Implemented sqr JBH\790111} {Fixed problems in address, iabs & notnode JBH\790111} {Added error msgs 19 (mult str) & 20 (round) JBH\790310} {Fixed subtreematch bug (lex level problem) JBH\790712} {Increased size of reltab and symbol table in pass2; Added err msg 32 in pass2. JBH\791006} {Added true external capability JCW\JRB\791006} {Improved code gen for real consts JBH\791006} {Optimize ifnode for const expression. JBH\791101} {Fix real comparison bug in genfpbinary. JBH\791110} {Add X option for separate compilation. JRB\791201} {Fix getregister and definetemp bugs; combine .ols and .lst files. JBH\791201} {Minmax and Printcode bug fixes. JBH\800315} {P1 and P2 error corrections. JBH\SHK\BDN\801004} {P1 and P2 error corrections. JBH\801023} {P1 and P2 error corrections. JBH\810606} {P1 and P2 error corrections. JBH\811020} const ht=chr(9); nl=chr(10); ff=chr(12); compiler_version = ' Pascal-N '; pass2id = "PASS2"; {Operating system version:} {*************************} const RSX11 = false; RSTS = false; RT11 = true; UNIX = false; type byte = char; {Description of node} {*******************} const maxarg=255; litcode=chr(162); type fvalue = array [0..3] of integer; fvalptr = @fvalue; ptn = @node; {description of tree nodes} node = record code: byte; {indicates node type} size: byte; dsp: record case boolean of false: (disp: integer); true: (xval: fvalptr) end; segnr: byte; nrarg: byte; arg: array[1..maxarg] of ptn end; var tree, {pointer to expression tree} target: ptn; {pointer to subtree target of store} sideeffects: boolean; {true if subtree just traversed has sideeffects} {Description of symbol table} {***************************} const maxsym = 80; maxnamesize = 15; type symbol_types = (localsy, externalsy, ceesy, fortransy); stab = {packed} record sname: array [0..5] of char; stype: symbol_types; slev: char; snum: 0..255; {arg count for use by pdb} sval: integer {unique symbol number for searching} end; var stable: array[0..maxsym] of stab; {s,}lastid: -1..maxsym; {Description of relocation info} {******************************} type reltypes = (absact,absrel,txtact,txtrel,datact,datrel,bssact,bssrel, uxtact,uxtrel); relpair = record segnr: byte; reltype: reltypes end; const {commonly used kinds of relocation} ordinary = relpair(chr(0), absact); global = relpair(chr(0), uxtact); {Description of code buffer} {**************************} const maxcode=2047; {size of code buffer} workspace=54; {size of workspace area in code buffer} maxlexlev=15; {Max lexical nesting level} maxrel=255; {size of relocation table} type codeindex=0..maxcode+workspace; relindex=0..maxrel {associative table for relocation data}; relent = record rs: relpair; cix: codeindex end; var codebuf: array[codeindex] of integer; reltab: array[relindex] of relent; cp: codeindex; {first empty cell beyond instructions} rlp: relindex; {current reloc tab index} checksum: integer; {checksum of text and data} header_bytes: boolean; {header bytes required} dcnt: integer; {sizes of text(words) and data(bytes)} {Description of register resources} {*********************************} type registers=(gr0,gr1,gr2,gr3,gr4,gr5,sfis,stk,gcc,mem,dbl); resources=set of registers; const evenregs=[gr0,gr2]; oddregs=[gr1,gr3]; gregs=evenregs + oddregs; tregs=[gr2,gr3]; assignable=gregs; maxtmpregs=2 {use two regs for temps}; tmpuseregs=[gr3]; var avail, {the set of free registers} tmpreg, {the set of registers in use as temps} usedregs, {the set of regs in use} pushdesire: resources; {the set of registers desired for next push} withtmpreg: integer; {number of temp regs used by definetemp} truecode: integer; {code of the last setting of condition code} {Description of operand status} {*****************************} {pass2 uses an operand stack to keep track of the state of code generation during the tree walk by gencode. This is done to avoid modifying the tree.} const maxopstk=127; {max stack depth} {machine dependent data structure parameters:} bitsize=chr(0); bytesize=chr(7); wordsize=chr(15); longsize=chr(31); floatsize=chr(31); doublesize=chr(63); type {Meaning of addrstates: liter - literal (immediate value) based - offset from base register indexed - offset from specified address indirect- operand is pointer loaded - operand is on stack saved - is in temp area of stack frame stored - has been stored in target temp - anonymous pointer from WITH copy - copy of temp value fistack - loaded on FIS stack } addrstates = (liter,based,indexed,indirect,loaded,saved,stored,temp,copy,fistack); operstates = set of addrstates; operand = record state: operstates; adr: record case boolean of false: (addr: integer); true: (xval: fvalptr) end; rel: relpair; reg: registers; opsize: byte end; var tos: integer; opstk: array[0..maxopstk] of operand; {whatwhere: specifies what to generate and where to leave it. noload - Don't load value on stack loadvalue - Value of expression to be loaded loadaddr - Address of operand to be loaded tryupdate - Check for possible in situ operation } type whatwhere=(noload,loadvalue,loadaddr,tryupdate); {disposition: what to do with current tos. pop - pop it off leave - leave it on push - put a new value on } disposition = (pop,leave,push); {Branch conditions} {*****************} type brtypes=0..18 {encoding for branch types on PDP-11}; brtabform=array[brtypes] of brtypes; brtabcode=array[brtypes] of integer; const unconditional=1; { br code for unconditional branch } brtab=brtabcode( {branch instruction codes} { 0-nop} 160, { 1-br} 256, {signed tests} { 2-beq} 768, { 3-bne} 512, { 4-bgt} 1536, { 5-ble} 1792, { 6-bge} 1024, { 7-blt} 1280, { 8-bpl} -32768, { 9-bmi} -32512, {unsigned tests} {10-beq} 768, {11-bne} 512, {12-bhi} -32256, {13-blos} -32000, {14-bhis,bcc} -31232, {15-blo,bcs} -30976, {misc.} {16-bvc} -31744, {17-bvs} -31488, {18-sob} 32256); brinv=brtabform( {inverse conditions} 1,0,3,2,5,4,7,6,9,8,11,10,13,12,15,14,17,16,18); brrev=brtabform( {reverse conditions} 0,1,2,3,7,6,5,4,8,9,10,11,15,14,13,12,16,17,18); {Branching and state information} type blockstate = record roving: 0..maxlexlev end; branchlist = record last: codeindex; state: blockstate end; const emptychain = branchlist( 0, ( 0 )); var lastbr: codeindex; { points to list of all branches } falsechain, truechain: branchlist; { conditional lists, state info. } curstate: blockstate; {Miscellaneous variables} {***********************} var namesize: integer; {length of current procedure name} name: array [1..maxnamesize] of char; {current procedure name} localsize, {size of local variable area} tempbase, {start of temp storage} paramsize, {size of parameter area} rvsize, {size of returned value, 0 if none} procnr, {unique index of this procedure} calltype, {internal,external,cee,fortran indicator} lexlev: integer; {current lex level} {Files used in pass2} {*******************} const intx=2; {argv index to int code filename} olsx=5; {" object listing filename} objx=4; {" object code filename} datx=3; {" initialized data filename} flgx=1; {" pass2 switches} {switches to control output from pass2: list: generate object listing (.ols); char O sdump: generate stack dump (standard output); char S dproc: generate name/procnumber concordance (.ols); char P xtern: generate symbolic external procedure names; char X ncmdlne: generate initialisation code without command line; char N profile: generate profiling code for each subprogram; char F trace: line trace is in effect in this module indef: indefinite program execution } var list, sdump, dproc, xtern, ncmdlne, profile, trace, indef: boolean; ols_opened, Ok_to_proceed: boolean; runtimcheks: integer; {files used by second pass:} int: file of char; {file of intermediate code} ols: text; {file to put object listings} obj: file of integer; {object module file} {dat: file of char; intermediate home for data and case tables} {*******************************************************} { Additional declarations for RSTS: ********************} {var} { ourjob: integer;} { jobnum_tmpname: array [1..11] of char;} { External procedure declarations for RSTS: ************} {function jobnum: integer; external;} {procedure defext (var ext: array [1..3] of char); external;} {*******************************************************} {*******************************************************} { Additional Declarations for RT-11 } type versionstring = array [1..80] of char; var nbsversion : @versionstring; procedure error(prog, msg : array [1..80] of char); external; function version:@versionstring; external; {*******************************************************} procedure pass2error(n:integer); {assigned error numbers (arbitrary, more or less): # where why 1 buildtree stack-arg mismatch (s < argn) 2 buildtree stack overflow 3 emit0 emitaddr emitbranch codebuf overflow 4 emitaddr reltab overflow 6 newtos opstk overflow 9 buildtree non-immediate litd processed (**TEMP**) 10 refertotemp can't find temp 18 load double load unimplemented 19 store multiple store unimplemented 20 genfpconvert round not yet implemented 30 searchid symtab overflow 31 gencode sadel not yet implemented 32 gencode set inclusion operators (<=, >=) not yet impl. 44 getregister no reg available 45 move insufficient registers available 70 casenode no such caselabel; no code generated 99 moduleident illegal data in intermediate file } begin {pass2error} {$Y-} error(pass2id, ""); {$Y+} writeln(output,'Pass2 error ',n,' in ',name: namesize) end {pass2error}; function getbyte: byte; begin getbyte := int@; get(int) end {getbyte}; function getword: integer; var temp: integer; begin temp := ord(int@)*256; get(int); getword := ord(int@)+temp; get(int) end {getword}; procedure openols; forward; procedure readoptions; var intopt: integer; boolopt: boolean; ch: char; begin {readoptions} ch := getbyte; { options switch A..Z } intopt := getword; { option value } boolopt := intopt > 0; if ch = 'F' then profile := boolopt else if ch = 'I' then indef := boolopt else if ch = 'N' then ncmdlne := boolopt else if ch = 'O' then list := boolopt else if ch = 'P' then dproc := boolopt else if ch = 'R' then runtimcheks := intopt else if ch = 'S' then sdump := boolopt else if ch = 'X' then xtern := boolopt else if ch = chr(2) then {abort p2} begin while not eof(int) do get(int); {$Y-} error(pass2id, "Code generation aborted"); {$Y+} Ok_to_proceed := false end { else ignore option. }; if list or dproc then openols end {readoptions}; procedure ident; {Obtain main or procedure identification and id size} var i: integer; begin {ident} i := ord(getbyte); namesize := 0; while i > 0 do begin if namesize < maxnamesize then namesize := succ(namesize); name[namesize] := getbyte; i := pred(i) end end {ident}; {searchid - search symbol table, return the index of requested symbol; if not found, the symbol is added to the table and the new index is returned. Its value is initialized to zero, and its type is set up according to isuser} function searchid(symno:integer; isuser:boolean): integer; var lchar: char; sym: array[0..5] of char; found: boolean; i: 0..maxsym; procedure itoa(N:integer); {translate N to a string, length 3, and start storing at sym[3]} begin {itoa} sym[5]:=chr((N mod 10)+ord('0')); N:=N div 10; sym[4]:=chr((N mod 10)+ord('0')); N:=N div 10; sym[3]:=chr((N mod 10)+ord('0')) end {itoa}; begin {searchid} if isuser and ((calltype<>0) or xtern) then begin {use first part of actual name:} i := 0; loop if i>namesize-1 then sym[i] := ' ' else sym[i] := name[i+1]; if (sym[i]>='a') and (sym[i]<='z') then sym[i]:=chr(ord(sym[i])-32); if sym[i] = '_' then sym[i] := '$'; exit if i >= 5; i := succ(i); end {loop}; if symno < 0 then begin {make const psect name unique by ending it with a '.'} i := 0; repeat i := i + 1 until (i = 5) or (sym[i] = ' '); sym[i] := '.' end end {use actual name} else begin {build a unique symbol:} if isuser then if symno >= 0 then lchar := 'I' {user proc} else lchar := 'D' {consts} else lchar := '$'; {library proc} sym[0]:=lchar; sym[1]:=lchar; sym[2]:=lchar; itoa(max (0, symno)) {put 3 chars of symno into sym, from sym[3]} end; {look for the symbol} i:=0; found:=false; if i <= lastid then loop with stable[i] do if isuser then found := (sname[0]<>'$') and (sval=symno) else found := (sname[0]='$') and (sval=symno); exit if found or (i >= lastid); i:=i+1 end; {put in table if not there} if not found then begin lastid:=succ(lastid); if lastid<=maxsym then with stable[lastid] do begin sname := sym; slev := chr(lexlev + ord(not isuser)); snum := 0; sval := symno; if isuser then case calltype of 0: stype := localsy; 1: stype := externalsy; 2: stype := ceesy; 3: stype := fortransy end else stype := localsy end else begin pass2error(30); lastid:=pred(lastid) end; i:=lastid end; searchid:=ord(i) end {searchid}; procedure buildtree; {special code values: call, varb, and parm all have the form +____+____+ | | | +____+____+ | | | Lex level referred to "code" } const stacksize=256; ENDCODE=7; var syminx: -1..maxsym; s: 0..stacksize; stack: array[1..stacksize] of ptn; coden,argn: integer; adrn: record case boolean of false: (addrn: integer); true: (xval: fvalptr) end; temp: ptn; sizen,segn,ch: byte; allign: integer; {to round out localsize if odd} procedure read8 (var p: fvalptr); {read 8 bytes of data to be used as a float constant.} begin new(p); p@[0] := getword; p@[1] := getword; p@[2] := getword; p@[3] := getword end {read8}; begin {buildtree} s := 0; repeat coden := ord(getbyte); if coden > 7 then begin {not a pseudo op} if coden = 8 then tree:=nil {null node} else begin segn:=chr(0); adrn.addrn:=0; sizen:=chr(0); {so subtreematch will work} argn:=0; case coden of 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191, {varb} 192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207: {parm} begin segn:=chr(coden mod 16) {segn = lex level}; sizen:=getbyte; adrn.addrn:=getword; {collapse code value} if coden < 192 then coden:=176 else coden:=192 end; 162,163 {lit,rdata}: adrn.addrn := getword; 164 {litd}: begin {Read in a floating lit, and make it 2 words long.} read8(adrn.xval); {collect data for float lit} sizen := chr(2) end; 140,141 {rtemp,dtemp}: begin adrn.addrn:=ord(getbyte); if coden=141 then argn:=2 end; 131,132,133,134,135,168,169,170,171,172,173 {addressing, "vector" ops}: begin sizen:=getbyte; adrn.addrn:=getword; if coden>=134 then argn:=2 else argn:=1 end; 146,147,152 {n-ary}: argn:=ord(getbyte) + 1; 145 {case}: begin argn := ord(getbyte); adrn.addrn := ord(getbyte); end; 138 {invoke}: begin argn:=ord(getbyte); adrn.addrn := getword; {proc nr} if adrn.addrn = 4 {new} then sizen := chr(2) else if adrn.addrn > 100 then sizen := chr(4) {Note: system routines whose index is > 100 are assumed to be real functions.} end; 208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223: {call} begin segn:=chr(coden mod 16) {segn = lex level}; sizen:=getbyte; adrn.addrn := getword; {proc nr} argn := ord(getbyte); coden:=208 {collapse code value} end; 149 {for}: argn:=5; 144 {tertiary}: argn:=3; 10,12,24,25,26,27,28,29,30,31,32,33,34,35,36,44,45,56,57,58,59,60,61,62, 63,64,65,66,67,88,89,90,91,92,93,94,95, 104,105,106,107,108,109,110,111,113,114,115,118,120,121,122,123,124,125, 126,148 {binary}: begin argn:=2; sizen:=chr(2) end; 9,16,17,37,40,41,42,69,72,73,74,75,76,96,112,117,127,159 {unary}: begin argn:=1; sizen:=chr(2) end; 255 {line}: begin argn:=1; adrn.addrn:=getword end end; {case} new(tree,argn); with tree@ do begin code:=chr(coden); size:=chr(ord(sizen)*8-1); dsp.disp:=adrn.addrn; segnr:=segn; nrarg:=chr(argn); if s0 do begin arg[argn] := stack[s]; argn := argn-1; s := s-1 end end end; {not null node} if s>=stacksize then begin pass2error(2); s:=0 end; s := s+1; stack[s] := tree end {not a pseudo op} else case coden of {pseudo ops} 1 {xch}: {swap(stack[s],stack[s-1])} begin temp:=stack[s]; stack[s]:=stack[s-1]; stack[s-1]:=temp end; 2 {del}: if s>0 then s:=s-1 else pass2error(1); 3: {option} readoptions; 4: {word - should not occur}; 5 {ident}: ident; 6: {proc} begin procnr := getword; calltype := ord(getbyte); ident; lexlev := lexlev+1; if (procnr=0) {and (lexlev=1)} then syminx := searchid(-1, true); syminx := searchid(procnr, true) end; 7: {end} begin procnr := getword; rvsize := ord(getbyte); localsize:=getword; allign:=1; if localsize<0 then allign:=-1; if odd(localsize) then localsize:=localsize+allign; tempbase:=localsize; paramsize:=getword; if odd(paramsize) then paramsize:=paramsize+1; dcnt:=getword; {data size (bytes) as of this procedure} end end {pseudo ops} until (coden = ENDCODE) or not Ok_to_proceed; end {buildtree}; {procedure prescan;} {General tree-walk to permit any "1st pass" computations needed prior to code generation. Currently, this includes: 1. Register usage for temp values (FORCODE and DTEMP nodes) Starts with global pointer "tree", pointing to the head of the code tree for the current procedure.} {var i: integer;} { function tracetemp(pn: ptn): integer;} {Count temps used by this subtree. Store and return value as appropriate} { const }{node type, logic:} { FORCODE = 149;} {check arg[5]; return num+1} { DTEMP = 141;} {check arg[2]; return num+1} { LOOPCODE = 147;} {check arg[1]-arg[n]; return max} { EXITCODE = 148;} {check arg[2]; return num} { SEQ = 152;} {check arg[1]-arg[n]; return max} { IFCODE = 144;} {check arg[2],arg[3]; return max} { CASECODE = 145;} {check arg[1]-arg[n]; return max} { LINECODE = 255;}{check arg[1]; return value} { var lsize,i: integer;} { begin }{tracetemp} { lsize:=0;} { if pn <> nil then with pn@ do} { if ord(code)=FORCODE then} { begin lsize:=tracetemp(arg[5])+1; size:=chr(lsize) end} { else if ord(code)=DTEMP then} { begin lsize:=tracetemp(arg[2])+1; size:=chr(lsize) end} { else if ord(code)=CASECODE then } { for i := 2 to ord(nrarg) do} { with arg[i]@ do} { lsize := max(lsize, tracetemp(arg[ord(nrarg)]))} { else if (ord(code)=LOOPCODE) or (ord(code)=SEQ) then} { for i:=1 to nrarg do lsize := max(lsize,tracetemp(arg[i]))} { else if ord(code)=IFCODE then begin} { lsize:=tracetemp(arg[2]);} { lsize:=max(lsize,tracetemp(arg[3]))} { end} { else if ord(code)=EXITCODE then} { lsize:=tracetemp(arg[2])} { else if ord(code)=LINECODE then} { lsize:=tracetemp(arg[1]);} { tracetemp:=lsize} { end; }{tracetemp} {begin }{prescan} { i:=tracetemp(tree) }{discard the temp count for the whole tree} {end; }{prescan} procedure newtos; begin if tosabsact then begin with reltab[rlp] do begin rs:=r; cix:=cp end; if rlp=maxrel then pass2error(4) else rlp:=rlp+1 end; codebuf[cp]:=i; if cp=maxcode then pass2error(3) else cp:=cp+1 end {emitaddr}; procedure emit0(i:integer); begin codebuf[cp]:=i; if cp=maxcode then pass2error(3) else cp:=cp+1 end {emit0}; procedure freeregister(reg: registers); begin avail:=avail + ([reg]*{inter}assignable) end {freeregister}; procedure moveregister(from,too: registers); const mov=4096{mov instr}; var src,dst,lop: integer; begin {moveregister} lop:=mov; if from=stk then src:=22 {(sp)+} else src:=ord(from); if too=stk then dst:=38 {-(sp)} else dst:=ord(too); emit0(lop+src*64+dst) end {moveregister}; procedure saveregister(saveall: boolean; desire: resources); var n,taddr: integer; begin {saveregister} n:=0; {start from bottom of operand stack} while (n<=tos) and (saveall or ((avail *{inter} desire)=[])) do begin with opstk[n] do if (state *{inter} [loaded,based,indexed] <> []) and ([saved,copy,temp] *{inter} state = []) and (reg < stk) then begin moveregister(reg,stk); freeregister(reg); state:=state + [saved] -{sdiff} [copy] end; n:=succ(n) end end {saveregister}; function getregister(desire: resources): registers; var reg: registers; begin {getresister} if desire <> [] then if desire*{inter}assignable <> [] then begin if desire * avail = [] then if gr4 in desire then avail := avail + [gr4] else saveregister(false, desire); if desire * avail = [] then pass2error(44); reg:=any(desire*{inter}avail); avail:=avail-{sdiff}[reg]; usedregs:=usedregs + [reg] end else reg:=any(desire) else reg:=mem; if reg = gr4 then curstate.roving:=0; {may use as scratch} getregister:=reg end {getregister}; procedure restoreregister(thru: integer; desire: resources); var i: integer; lreg: registers; ldesire: resources; begin {restoreregister} i:=tos; {restore from top of operand stack} while i>=thru do begin with opstk[i] do if (saved in state) or (reg = stk) then begin if reg in avail then ldesire := [reg] else ldesire := desire; lreg := getregister(ldesire); moveregister(stk,lreg); reg := lreg; state:=state-[saved] end; i:=pred(i) end end {restoreregister}; procedure swaptos; var temp: operand; begin {swaptos} if ((saved in opstk[tos].state) or (opstk[tos].reg=stk)) and ((saved in opstk[tos-1].state) or (opstk[tos-1].reg=stk)) then restoreregister(tos-1, gregs); temp := opstk[tos]; opstk[tos] := opstk[tos-1]; opstk[tos-1] := temp; end {swaptos}; procedure emitbranch(brtype: brtypes; var list: branchlist); begin {emitbranch} if cp >= maxcode-3 then begin pass2error(3); cp := 0 end; if list.last = 0 then list.state := curstate else begin if list.state.roving <> curstate.roving then list.state.roving := 0; end; codebuf[cp] := brtype; codebuf[cp+1] := lastbr; lastbr := cp; { list of all branches } codebuf[cp+2] := list.last; list.last := cp; { list of branches to this target} cp := cp+3 end {emitbranch}; procedure mergebranchchains(var from, into: branchlist); var nextbr, temp: codeindex; begin {mergebranchchains} if from.last <> 0 then if into.last <> 0 then begin if from.state.roving <> into.state.roving then into.state.roving := 0; nextbr := from.last; while nextbr > 0 do begin temp := codebuf[nextbr+2]; codebuf[nextbr+2] := into.last; into.last := nextbr; nextbr := temp end end else into := from end {mergebranchchains}; procedure fixbranch(fallthru: boolean; var chain: branchlist); var nextbr, temp: codeindex; begin {fixbranch} if chain.last <> 0 then begin nextbr := chain.last; while nextbr > 0 do begin temp := codebuf[nextbr+2]; codebuf[nextbr+2] := cp-nextbr; nextbr := temp end; if fallthru then begin if curstate.roving <> chain.state.roving then curstate.roving := 0; end else curstate := chain.state end end {fixbranch}; procedure label_; begin curstate.roving := 0; end {label_}; { Getenvironment - sets up addressability to lex level 'oflevel', and leaves the stack frame pointer in register 'leaveitin'. Note that this is not called to access globals, since these are addressed relative to the BSS segment} function getenvironment(oflevel: integer; leaveitin: resources): registers; var n: integer; src,dst: registers; begin {getenvironment} {assert leaveitin <= [gr0,gr1,gr2,gr3,gr4,gr5,stk]} if oflevel=lexlev then dst:=gr5 {at current level} else if oflevel=curstate.roving then dst:=gr4 {at curstate.roving level} else begin {must chain to get it} if ofleveldst then begin emit0(4608+ord(src)*64+ord(dst)); {mov @src,dst} n:=n-1 end; if odd(n) then begin emit0(4608+ord(dst)*64+ord(dst)); {mov @dst,dst} n:=n-1 end; while n>0 do begin emit0(5632+ord(dst)*64+ord(dst)); {mov @(dst)+,dst} n:=n-2 end end; if not (dst in leaveitin) then begin src := dst; if (gr4 in leaveitin) or (oflevel = curstate.roving) then dst := gr4 {this is the preferred dst} else dst := getregister(leaveitin); {else any one will do} if src <> dst then moveregister(src, dst) end; if dst=gr4 then curstate.roving:=oflevel; {adjust curstate.roving if gr4 changes} getenvironment:=dst end {getenvironment}; {Address - determine the state of addressing for the top operand on opstk. Set up for accessing.} procedure address(lockr4: boolean; dispose: disposition; var mr: integer; var hasaddr: boolean); var baseregs: resources; rb: registers; begin {address} with opstk[tos] do begin if liter in state then begin mr:=23; hasaddr:=true end {immediate addressing} else begin if loaded in state then begin {register or stack} if dispose=push then begin rb:=getregister(pushdesire); reg:=rb end; if (reg=stk) or (saved in state) then case dispose of leave: mr:=14; {(sp)} push: mr:=38; {-(sp)} pop: mr:=22 {(sp)+} end else {register} mr:=ord(reg); hasaddr:=false end else begin {memory reference} dispose:=pop; {can discard register used for addressing} {if (state * [based,indexed]) <> [] then restoreregister(tos,gregs);} if based in state then rel.reltype:=absact else if (rel.reltype=absact) {or (lexlev=1)} then begin {non-global reference} {For NBS-PASCAL, globals will be in BSS, so they are not checked for here.} baseregs:=gregs + [gr4,gr5]; rel.reltype:=absact; if lockr4 then baseregs:=baseregs -{setdiff} [gr4]; rb:=getenvironment(ord(rel.segnr),baseregs); if indexed in state then begin emit0(24576 + ord(rb)*64 + ord(reg) {add rb,reg}); freeregister(rb) end else reg := rb end else {global reference} {if reltype is actual, make it relative; don't touch if indexed} if not (indexed in state) then if not odd(ord(rel.reltype)) then rel.reltype := succ(rel.reltype); if odd(ord(rel.reltype)) then begin {use relative addressing} if indirect in state then mr:=63 else mr:=55; {[@]addr(pc)} hasaddr:=true end else if indirect in state then begin mr:=56+ord(reg); hasaddr:=true end {@addr(reg)} else if (adr.addr=0) and (rel.reltype=absact) then begin mr:=8+ord(reg); hasaddr:=false end {(reg)} else begin mr:=48+ord(reg); hasaddr:=true end {addr(reg)} end; if (dispose=pop) and (state * [copy, saved] = []) then freeregister(reg) end end {with opstk[tos]} end {address}; procedure load(desire: resources); forward; procedure loadaddress(desire: resources); forward; procedure emit7(fop: integer; dstdis: disposition); var dstmr: integer; dstaddr: boolean; begin {emit7} if (opstk[tos].opsize<=bytesize) and (fop<512) then fop:=fop+512; address(false,dstdis,dstmr,dstaddr); emit0(fop*64+dstmr); if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel) end {emit7}; {code emitter for floating ops of form "op [f]dst"} procedure emitfop1(fop:integer; dstdis: disposition); {fop will be: 0: clrf, 1: tstf, 2: absf, 3: negf} var dstmr: integer; {mode/reg field for instr} dstaddr: boolean; {set up by address - is address needed?} regr: registers; {register for negation operation} begin {emitfop1} address(false,dstdis,dstmr,dstaddr); {compute oprnd address} if fop=2 {absf} then begin emit0( 42700b+dstmr {bic #10000,dst} ); emit0( 100000b ) end else if fop=3 {negf} then begin regr := getregister( gregs ); emit0( 12700b+ord(regr) {mov #100000,regr} ); emit0( 100000b ); emit0( 74000b+ord(regr)*64+dstmr {xor regr,dst} ); freeregister( regr ) end; if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel) end {emitfop1}; procedure emit10(fop: integer; srcdis: disposition); var srcmr,srcword: integer; srcrel: relpair; srcaddr: boolean; begin {emit10} {assert destination must be a register} {restoreregister(tos-1,gregs);} {the destination must be a register} address(false,srcdis,srcmr,srcaddr); if srcaddr then with opstk[tos] do begin srcword := adr.addr; srcrel := rel end; tos:=tos-1; emit0((fop*8+ord(opstk[tos].reg))*64+srcmr); if srcaddr then emitaddr(srcword,srcrel) end {emit10}; procedure emit15(fop: integer; srcdis,dstdis: disposition); var srcmr,dstmr,srcword: integer; srcrel: relpair; srcaddr,dstaddr: boolean; opt: (none,some,all); begin {emit15} if (opstk[tos].opsize<=bytesize) or (opstk[tos-1].opsize<=bytesize) then if (fop <> 6) and (fop <> 14) then fop:=fop+8; {if either is byte then use byte instruction} {must assure that add,sub always enter with words} opt:= none; with opstk[tos] do if (liter in state) and (rel.reltype=absact) then case fop of 1 {mov }: if adr.addr=0 then begin fop:=40 {clr}; opt:=some end; 9 {movb}: if adr.addr=0 then begin fop:=552 {clrb}; opt:=some end; 5,13 {bis,bisb}: if adr.addr=0 then opt:=all; 0 {and }: if adr.addr=0 then begin fop:=40 {clr}; opt:=some end else if adr.addr=-1 then opt:=all; 8 {andb}: if adr.addr=0 then begin fop:=552 {clrb}; opt:=some end else if adr.addr=255 then opt:=all; 4 {bic }: if adr.addr=0 then opt:=all else if adr.addr=-1 then begin fop:=40 {clr}; opt:=some end; 12 {bicb}: if adr.addr=0 then opt:=all else if adr.addr=255 then begin fop:=552 {clrb}; opt:=some end; 6 {add }: if adr.addr=0 then opt:=all else if adr.addr=1 then begin fop:=42 {inc}; opt:=some end else if adr.addr=-1 then begin fop:=43 {dec}; opt:=some end; 14 {sub }: if adr.addr=0 then opt:=all else if adr.addr=1 then begin fop:=43 {dec}; opt:=some end else if adr.addr=-1 then begin fop:=42 {inc}; opt:=some end; 2 {cmp }: if adr.addr=0 then begin fop:=47 {tst}; opt:=some end; 10 {cmpb}: if adr.addr=0 then begin fop:=559 {tstb}; opt:=some end; 7,15: {not used} end; if opt=none then begin {check for buried addressing register and restore it:} if opstk[tos-1].state *{inter} [indexed,based] <> [] then restoreregister(tos-1,gregs); if (fop=2 {cmp}) or (fop=10 {cmpb}) then swaptos {because pdp11 cmp is backwards} else if (fop=0 {and}) or (fop=8 {andb}) then begin {pdp11 lacks and, must simulate with bic} if liter in opstk[tos].state then opstk[tos].adr.addr:=-(opstk[tos].adr.addr+1) else begin load(gregs + [stk,gr4]); emit7(41 {com},leave) end; fop:=fop+4 {change to bic[b]} end; address(false,srcdis,srcmr,srcaddr); if srcaddr then with opstk[tos] do begin srcword:=adr.addr; srcrel:=rel end; tos:=tos-1; address((srcmr mod 8)=4,dstdis,dstmr,dstaddr); emit0((fop*64+srcmr)*64+dstmr); if srcaddr then emitaddr(srcword,srcrel); if dstaddr then with opstk[tos] do emitaddr(adr.addr,rel) end else begin tos:=tos-1; if opt=some then emit7(fop,dstdis) end end {emit15}; procedure adjuststack(i:integer); var expand: boolean; begin {if i<0 then expand stack else shrink stack} if i<>0 then begin if i<0 then begin i:=-i; expand:=true end else expand:=false; if odd(i) then i:=i+1; if i=2 then if expand then emit0(2598 {clr -(sp)}) else emit0(3030 {tst (sp)+}) else begin if expand then emit0(-6714 {sub $i,sp}) else emit0(26054 {add $i,sp}); emit0(i) end end end {adjuststack}; procedure gencall(u:boolean;n:integer); var r: relpair; s: integer; begin {gencall} emit0(2551 {jsr pc,0(pc)}); s := searchid(n,u); {find symbol number} if u then r.reltype:=txtrel else r.reltype:=uxtrel; r.segnr:=chr(n); emitaddr(0,r); codebuf[cp-1] := 0 end {gencall}; procedure emitfop2(fop: integer; srcdis,dstdis: disposition); var srcaddr: boolean; {will an address be needed} srcmr: integer; {mode bytes, address value} begin {emitfop2} if opstk[tos-1].state *{inter} [indexed,based] <> [] then restoreregister(tos-1,gregs); {restore buried addressing register} if odd(fop) {load} then begin if opstk[tos-1].reg=stk then begin if fistack in opstk[tos].state then gencall( false, 214 {Pop FIS to stack} ) else if liter in opstk[tos].state then with opstk[tos].adr do begin if xval@[1]=0 then emit0( 5046b {clr -(SP)} ) else begin emit0( 12746b {mov #,-(SP)} ); emit0( xval@[1] ) end; if xval@[0]=0 then emit0( 5046b {clr -(SP)} ) else begin emit0( 12746b {mov #,-(SP)} ); emit0( xval@[0] ) end end else {variable to stack} if indirect in opstk[tos].state then begin loadaddress( [stk] ); gencall( false, 211 {Push FIS} ); gencall( false, 214 {Pop FIS to stack} ) end else begin opstk[tos].opsize := wordsize; duptos; opstk[tos].adr.addr := opstk[tos].adr.addr + 2; address(false,srcdis,srcmr,srcaddr); emit0( 10046b+srcmr*64 {mov src,-(SP)} ); if srcaddr then with opstk[tos] do emitaddr(adr.addr, rel); tos := pred(tos); address(false,srcdis,srcmr,srcaddr); emit0( 10046b+srcmr*64 {mov src,-(SP)} ); if srcaddr then with opstk[tos] do emitaddr(adr.addr, rel) end end else with opstk[tos] do {loading to fis stack} if reg=stk then begin gencall( false, 213 {Push FIS from stack} ) end else if liter in state then begin reg := getregister( gregs ); gencall( false, 212 {Push addr FIS} ); emit0( 12600b+ord(reg) {mov (SP)+,reg} ); if adr.xval@[0]=0 then emit0( 5020b+ord(reg) {clr (reg)+} ) else begin emit0( 12720b+ord(reg) {mov #,(reg)+} ); emit0( adr.xval@[0] ) end; if adr.xval@[1]=0 then emit0( 5020b+ord(reg) {clr (reg)+} ) else begin emit0( 12720b+ord(reg) {mov #,(reg)+} ); emit0( adr.xval@[1] ) end; freeregister( reg ) end else begin {Variable to FIS stack} loadaddress( [stk] ); gencall( false, 211 {Push FIS} ) end; tos := pred(tos) end else {store} if fistack in opstk[tos].state then begin tos := pred(tos); if opstk[tos].reg=stk then gencall( false, 214 {Pop FIS to stack} ) else begin loadaddress( [stk] ); gencall( false, 210 {Pop FIS} ) end end end {emitfop2}; {load - put operand value on stack} procedure load{(desire: resources)}; {Previously declared as forward} var dstreg: registers; hasaddr: boolean; begin {load} {assert desire <= [gr0,gr1,gr2,gr3,sfis,stk,gcc]} with opstk[tos] do if (loaded in state) and ((opsize<=wordsize) or (reg in desire)) {Must be loaded and the opsize<=wordsize or loaded in the proper register if opsize>wordsize. This will only be the stack.} then begin {loaded, but perhaps in the wrong place} if not (reg in desire) then begin if gcc in desire then begin {convert boolean to gcc} emit7(47 {tst[b]},pop); truecode:=3; reg:=gcc end else if reg=gcc then begin {convert gcc to boolean in desired register} opsize:=wordsize; pushdesire := desire; emit0(brtab[truecode] + 2); emit7(40 {clr},push); freeregister(reg); emit0(brtab[unconditional] + 2); pushlit(1); emit15(1 {mov $1,reg},pop,push) end else begin {move from current register to desired register} if (saved in state) and (desire=[stk]) then begin state := state - [saved]; {already loaded on stack} reg := stk end else begin dstreg:=getregister(desire); moveregister(reg,dstreg); freeregister(reg); reg:=dstreg end end end end else if not((fistack in state) and (reg in desire)) then begin {not loaded, lets do it} newtos; opstk[tos]:=opstk[tos-1]; {opstk[tos-1].}state:=[loaded]; pushdesire:=desire; if {opstk[tos-1].}opsize>wordsize then desire := desire -{setdiff} gregs; dstreg := any(desire); case dstreg of {different loads for different folks} gr0,gr1,gr2,gr3,gr4,gr5:begin if (opsize<=bytesize) and (pushdesire * avail <> []) then begin reg := getregister(pushdesire); emit0(2560 + ord(reg) {clr r?}); emit15(5 {bis[b]}, pop, leave); opsize:=wordsize end else if opsize<=wordsize then emit15(1 {mov[b]},pop,push) else pass2error(18) {double load to register} end; stk:begin if opsize <= bytesize then begin {To avoid high-order garbage from "movb s,-(sp)", clear first:} emit0(2598 {clr -(sp)}); reg:=stk; { force to stack in address } emit15(1 {mov[b]}, pop,leave); opsize:=wordsize {now tos is a word} end else if opsize<=wordsize then emit15(1 {mov[b]},pop,push) else if opsize<=doublesize then begin {doublesize check temporary until pass1 corrected} { assumed to be short floating point } reg := stk; emitfop2( 1 {load}, pop, push ) end else pass2error(18) { multiple load to stack } end; sfis: begin {Put operand on FIS stack} {opstk[tos-1].}state := [fistack]; {opstk[tos-1].}reg := sfis; emitfop2( 1 {load}, pop, push ) end; gcc:begin emit7(47 {tst[b]},pop); tos:=tos-1; truecode:=3 {ne}; reg:=gcc end; mem: end; end end {load}; { Loadaddress - determine addressing state of top operand; prepare to load its address onto stack} procedure loadaddress{(desire: resources)}; {Previously declared as forward} var dobase,dodisp: integer; nxtdis: disposition; rb,rx: registers; { dobase: 0 => nothing; 1 => move; 6 => add} begin {loadaddress} {assert desire <= [gr0,gr1,gr2,gr3,stk]} with opstk[tos] do begin if indirect in state then begin state:=state -{sdiff}[indirect]; opsize:=wordsize; end else begin rb:=reg; rx:=rb; if based in state then begin if copy in state then begin nxtdis:=push; dobase:=1 end else begin nxtdis:=leave; dobase:=0 end; dodisp:=6 end else begin if indexed in state then begin nxtdis:=leave; dobase:=6 end else begin nxtdis:=push; dobase:=1 end; if rel.reltype=absact then begin rb:=getenvironment(ord(rel.segnr),[gr4,gr5]); dodisp:=6 end else begin dodisp:=dobase; dobase:=0 end end; pushdesire:=desire; newtos; with opstk[tos] do begin state:=[loaded]; reg:=rx; opsize:=wordsize end; if dobase<>0 then begin newtos; with opstk[tos] do begin state:=[loaded,copy]; reg:=rb; opsize:=wordsize end; emit15(dobase,pop,nxtdis); nxtdis:=leave end; swaptos; opstk[tos].state:=[liter]; opstk[tos].opsize := wordsize; emit15(dodisp,pop,nxtdis) end; load(desire) end end {loadaddress}; procedure extend(tosize: byte; desire: resources); type table=array[bitsize..pred(wordsize)] of integer; const mask=table(-2,-4,-8,-16,-32,-64,-128,-256,-512,-1024,-2048,-4096, -8192,-16384,-32768); begin {extend} {assert tosize<=wordsize} with opstk[tos] do if opsize 2) {because floating ops don't do mem to mem} then if sideeffects then loadit:=noload else loadit:=tryupdate else loadit:=loadvalue; gencode(node@.arg[2],ldesire,loadit);{get rhs in gregs or sfis, depending} with opstk[tos] do if not (stored in state) then begin if (targetsize<=wordsize) or (fop = 2 {float}) then begin {simple store} if reg=gcc then load(gregs); {load will convert to boolean} if fop <> 2 then extend(targetsize,gregs + [stk]); opsize:=targetsize; if force=noload then dispose:=pop else dispose:=leave; if fop = 0 then {16 bit value} emit15(1 {mov},dispose,pop) else begin {assume float} emitfop2(2 {store},dispose,pop) end end else {multiple store} pass2error(19) end; if force=noload then tos:=tos-1 else opstk[tos]:=opstk[tos+1]; sideeffects:=true; {tell parent node that there are side effects} target:=savetarget end {store}; procedure move; var lop: integer; ra, rb, rc: registers; begin {move} with node@ do begin gencode(arg[1], gregs, loadaddr); rc := opstk[tos].reg; gencode(arg[2], gregs - [rc], loadaddr); rb := opstk[tos].reg; if size <= bytesize then lop := 112020B {movb (rb)+,(rc)+} else lop := 12020B {mov (rb)+,(rc)+}; pushlit(dsp.disp); load(gregs + [gr4] - [rb] - [rc]); {mov #n,ra} restoreregister(tos-2, gregs); {top 3 must be in registers} ra := opstk[tos].reg; rb := opstk[tos-1].reg; rc := opstk[tos-2].reg; emit0(lop + ord(rb)*64 + ord(rc)); {mov/b (rb)+,(rc)+} emit0(77002B + ord(ra)*64); {sob ra,.-2} freeregister(ra); freeregister(rb); freeregister(rc); tos := tos - 3 end {with node@} end {move}; procedure genunary(fop: integer); var update: boolean; begin {genunary} with node@ do if (force=tryupdate) and subtreematch(target,arg[1]) then update:=true else begin gencode(arg[1],desire,loadvalue); update:=false end; emit7(fop,leave); if update then opstk[tos].state:=[stored] end {genunary}; {generate code for unary floating ops} procedure genfpunary(fop: integer); var update: boolean; begin {genfpunary} with node@ do if (force=tryupdate) and subtreematch(target,arg[1]) then update:=true else begin gencode(arg[1],[stk],loadvalue); update:=false end; emitfop1(fop,leave); if update then opstk[tos].state:=[stored] else if not (stk in desire) and (sfis in desire) then load(desire) end {genfpunary}; procedure genfpconvert(fop: integer); {generate code for conversions from/to floating} {fop: 0 => float; 1 => trunc; 2 => round } type opvalue = array [0..2] of integer; opsze = array [0..2] of byte; const stacksize = opvalue ( -4, -2, -2 ); procno = opvalue ( 201, 98, 99 ); parmsize = opsze ( floatsize, wordsize, wordsize ); begin {genfpconvert} saveregister( true, [] ); adjuststack( stacksize[fop] ); {returned value} gencode( node@.arg[1], [stk], loadvalue ); gencall( false,procno[fop] ); opstk[tos].opsize := parmsize[fop] end {genfpconvert}; {generate code for floating binary ops.} procedure genfpbinary(fop: integer); begin {genfpbinary} with node@ do begin gencode( arg[1], [sfis], loadvalue ); gencode( arg[2], [sfis], loadvalue ); gencall( false, fop+215 ); tos := pred(tos); if stk in desire then load( desire ) end end {genfpbinary}; procedure fpcompare( fop:integer ); {generate floating point compare operations} begin {fpcompare} gencode(node@.arg[1], [stk], loadvalue); gencode(node@.arg[2], [stk], loadvalue); tos := tos - 1; gencall( false, 97 {fpcmp}); truecode := fop; with opstk[tos] do begin state := [loaded]; opsize := bitsize; reg := gcc end end {fpcompare}; procedure genbinary(fop: integer; nobyte: boolean); var update: boolean; begin {genbinary} with node@ do begin if (force=tryupdate) and (not nobyte or (opstk[tos].opsize=wordsize)) and subtreematch(target,arg[1]) then update:=true else begin gencode(arg[1],desire*(gregs + [stk]),loadvalue); if nobyte then extend(wordsize,desire*(gregs + [stk])); update:=false end; gencode(arg[2],gregs,noload) end; if nobyte then extend(wordsize,gregs); if loaded in opstk[tos].state then load(gregs+[gr4]); {convert gcc to boolean} emit15(fop,pop,leave); if update then opstk[tos].state:=[stored] end {genbinary}; procedure compare(fop: brtypes); begin {compare} with node@ do begin gencode(arg[1],gregs,noload); if opstk[tos].reg = gcc then load(gregs); gencode(arg[2],gregs,noload); if loaded in opstk[tos].state then load(gregs) end; emit15(2 {cmp},pop,pop); truecode:=fop; with opstk[tos] do begin state:=[loaded]; reg:=gcc end end {compare}; procedure vcompare(fop:integer); {emit code to do "multiple compare", leaving the condition codes set according to the last compare done. Higher level stuff will have to weave together sequences of these as well as convert condition codes to booleans. Does not touch truechain or falsechain} var savecp: codeindex; lop: integer; ra, rb, rc : registers; begin {vcompare} with node@ do begin gencode(arg[1],gregs,loadaddr); {get left arg address into reg} rc := opstk[tos].reg; gencode(arg[2],gregs - [rc],loadaddr); {get right arg address into new reg} rb := opstk[tos].reg; if size <= bytesize then lop:= -23536 {cmpb (r?)+,(r?)+} else lop:= 9232; {cmp (r?)+,(r?)+} pushlit(dsp.disp); load(gregs+[gr4]-[rb]-[rc]); {load length and force to reg} restoreregister(tos-2,gregs); {make sure all 3 are in regs} ra := opstk[tos].reg; rb := opstk[tos-1].reg; rc := opstk[tos-2].reg; savecp:=cp; {mark point for sob return} emit0(lop+ord(rc)*64+ord(rb)); emit0(brtab[3]+1); {bne around sob, ending comparison on first nonequal} emit0(32259 {sob} + ord(ra)*64); {sob r?,.-4} truecode:=fop; freeregister(ra); freeregister(rb); freeregister(rc); tos:=tos-2; {leave something on stack as result} with opstk[tos] do begin state:=[loaded]; { ...which is loaded...} reg:=gcc { ...in the condition codes...} end; end {with node@} end {vcompare}; procedure minmax(fop: integer); { fop function 0 umax 1 umin 2 imax 3 imin } var lcp: codeindex; this,other: ptn; loadit: whatwhere; loperand: operand; begin {minmax} {generate for u, i max/min functions. Optimize for x:=max(x,y)} loadit:=loadvalue; {assuming no optimization} this:=node@.arg[1]; other:=node@.arg[2]; if force=tryupdate then {check subtrees} if subtreematch(target{lhs},this) then loadit:=noload else if subtreematch(target,other) then begin {flip subtree} this:=other; other:=node@.arg[1]; loadit:=noload end; {Now, generate the code:} if loadit<>noload {if not updating} then gencode(this,desire,loadit); {for "1st" arg} gencode(other,gregs,noload); {for "2nd" arg...don't load its value} if loaded in opstk[tos].state then load(gregs); {pop off stack if there} loperand:=opstk[tos]; {save for later use} swaptos; {to counteract the same in emit15} emit15(2{cmp},pop,leave); case fop of {make the branch codes-bxx .+1; will fix up target after store} 0 {umax}: fop := 101400B {blos}; 1 {umin}: fop := 103000B {bhis}; 2 {imax}: fop := 3400B {ble}; 3 {imin}: fop := 2000B {bge} end; emit0(fop); {store the branch and} lcp:=cp; {note its location} newtos; opstk[tos]:=loperand; {restore "other" arg} emit15(1{mov},pop,leave); {and emit the store.} if loadit=noload {only if update} then opstk[tos].state:=[stored]; codebuf[lcp-1]:=codebuf[lcp-1]+cp-lcp; {point the branch to the right target} end {minmax}; procedure mdmconst(fop,n:integer; desire:resources; update:boolean); var i,j: integer; { code generated for values of fop mod div mul n=0 0) error 1) error 2) clr dst n=1 3) clr dst 4) nop 5) nop n=2 6) bic $-n,dst 7) asr dst 8) asl dst n=2^i 9) bic $-n,dst 10) ash $-i,dst 11) ash $i,dst n<>2^i 12) div $n,dst 13) div $n,dst 14) mul $n,dst } begin {mdmconst} if n<>0 then begin i:=0; j:=1; while (i<15) and (j9) then begin {can't update...get operand in reg} update:=false; if fop>=12 then desire:=oddregs {for mul,div,mod} else desire:=gregs; load(desire); extend(wordsize,desire) end else opstk[tos].state := opstk[tos].state-[copy]; {ok to release addr reg} case fop of 0 {mod 0}, 1 {div 0}: {error}; 2 {mul 0}, 3 {mod 1}: emit7(40 {clr},leave); 6,9 {mod 2^i, i>0}: begin pushlit(-n); emit15(4 {bic},pop,leave) end; 7 {div 2}: emit7(50 {asr},leave); 8 {mul 2}: emit7(51 {asl},leave); 10 {div 2^i, i>1}: begin pushlit(-i); emit10(58 {ash},pop) end; 11 {mul 2^i, i>1}: begin pushlit(i); emit10(58 {ash},pop) end; 12 {mod n, n$2^i}, 13 {div n, n$2^i}: begin cvtdouble(false); pushlit(n); emit10(57 {div},pop); cvtsingle(odd(fop)) end; 14 {mul n, n$2^i}: begin pushlit(n); emit10(56 {mul},pop) end end; if update then opstk[tos].state:=[stored]; end {mdmconst}; procedure muldivmod(fop: integer {0=mod, 1=div, 2=mul}); var update:boolean; usereg : resources; swapping : ptn; lcp_before, lcp_after : codeindex; lop : integer; begin {muldivmod} with node@ do begin if (fop = 2 {mul}) and (((force = tryupdate) and subtreematch(target,arg[2])) or (arg[1]@.code = litcode)) then begin swapping := arg[1]; arg[1] := arg[2]; arg[2] := swapping end; if (force = tryupdate) and subtreematch(target,arg[1]) then begin update:=true; duptos; opstk[tos].state:=opstk[tos].state + [copy] end else begin update:=false; gencode(arg[1],gregs,noload) end; if arg[2]@.code=litcode then begin mdmconst(fop, arg[2]@.dsp.disp, desire, update); if stored in opstk[tos].state then begin tos:=tos-1; opstk[tos].state:=opstk[tos].state + [stored] end end else begin lop := 56; {assume mul operation} usereg := gregs - tmpreg; {construct set of possible registers to use} if (fop < 2) and (tmpreg <> []) then usereg := gregs - tregs; {mod, div need a doublet of registers} usereg := usereg * oddregs; lcp_before := cp; gencode(arg[2], gregs, noload); extend(wordsize, gregs); if fop < 2 then begin {mod, div} lop := 57; {operation must be div} if (tmpreg = tregs) and (opstk[tos].reg in gregs) then load(gregs); {force a load - may have insufficient registers later} if usereg - [opstk[tos].reg] = [] then restoreregister(tos-1, gregs); {arguments cannot be in same register} swaptos; {need to access dividend} lcp_after := cp; {need to see if any code generated} if saved in opstk[tos].state then restoreregister(tos, gregs) end; load(usereg); {mul, div need odd registers (pun intended)} extend(wordsize, usereg); if fop < 2 {mul, div} then {div needs double sized register} cvtdouble((lcp_before < lcp_after) and (lcp_after = cp)); swaptos; if [indexed,based] * opstk[tos].state <> [] then restoreregister(tos, gregs); emit10(lop, pop); {mul, div} if fop < 2 then cvtsingle(odd(fop)) end end {with} end {muldivmod}; procedure iabs; var update: boolean; savecp: codeindex; begin {iabs} with node@ do begin if (force=tryupdate) and subtreematch(target,arg[1]) then begin emit7(47{tst},leave); update:=true end else begin gencode(arg[1],desire,loadvalue); update:=false end end; savecp:=cp; cp:=succ(cp); {save space for a branch} emit7(44{neg},leave); {turn around sign} codebuf[savecp]:= -32768{bpl} + (cp-savecp-1); if update then opstk[tos].state:=[stored] {because we have done the op} end {iabs}; procedure iodd; begin {iodd} gencode(node@.arg[1],gregs,noload); with opstk[tos] do if gcc in desire then begin if loaded in state then begin emit7(48 {ror},pop); truecode:=15 {carry set} end else begin pushlit(1); emit15(3 {bit},pop,pop); truecode:=3 {not equal} end; state:=[loaded]; reg:=gcc end else begin load(desire); opsize:=bitsize; {only least significant bit is valid} extend(wordsize,desire) {to handle "odd(val)" as arg} end end {iodd}; procedure square(fop: integer); {emit code for sqr. fop: 0 => integer; 2 => real } var r: integer; begin {square} with node@ do if fop = 0 then begin {sqr integer} gencode(arg[1], oddregs, loadvalue); r := ord(opstk[tos].reg); emit0(70000b + 64*r + r) {mul r,r} end else begin {sqr real} gencode(arg[1], [sfis], loadvalue); gencall( false, 202 {FSQR}) end end {square}; procedure notnode; var tempchain: branchlist; update : boolean; begin {notnode} with node@ do if (force=tryupdate) and subtreematch(target,arg[1]) then update := true else begin gencode(arg[1],desire*(gregs + [stk,gcc]),loadvalue); update := false end; with opstk[tos] do begin if reg=gcc then begin tempchain:=truechain; truechain:=falsechain; falsechain:=tempchain; truecode:=brinv[truecode] end else begin emit7(44 {neg},leave); emit7(42 {inc},leave) end; if update then state := [stored] end end {notnode}; procedure condandor(isand: boolean); var savechain: branchlist; begin {condandor} gencode(node@.arg[1],[gcc],loadvalue); tos:=tos-1; if isand then begin {and} emitbranch(brinv[truecode],falsechain); fixbranch(true,truechain); savechain:=falsechain end else begin {or} emitbranch(truecode,truechain); fixbranch(true,falsechain); savechain:=truechain end; truechain:=emptychain; falsechain:=emptychain; gencode(node@.arg[2],[gcc],loadvalue); if isand then mergebranchchains(savechain,falsechain) else mergebranchchains(savechain,truechain); with opstk[tos] do begin state:=[loaded]; reg:=gcc end; if not (gcc in desire) then load(desire) {will convert gcc to boolean} end {condandor}; procedure sgens; begin {sgens} gencode(node@.arg[1],gregs,noload); if (opstk[tos].opsize < wordsize) then load(gregs); {ash src must be word-aligned} pushlit(1); load(gregs); swaptos; emit10(58 {ash},pop) end {sgens}; procedure sin; type table=array[0..15] of integer; const powerof2=table(1,2,4,8,16,32,64,128,256,512, 1024,2048,4096,8192,16384,-32768); var ltruecode,lop: integer; loadit: whatwhere; begin {sin} gencode(node@.arg[1],gregs,noload); loadit:=loadvalue; with opstk[tos] do if liter in state then if gcc in desire then begin if adr.addr<16 then adr.addr:=powerof2[adr.addr] else adr.addr:=0; loadit:=noload; ltruecode:=3 {not equal} end else adr.addr:=-adr.addr else begin load(gregs); if gcc in desire then lop:=41 {com} else lop:=44 {neg}; emit7(lop,leave); ltruecode:=15 {carry set} end; gencode(node@.arg[2],gregs,loadit); swaptos; if loadit=noload {this means we can use a "bit" instruction} then emit15(3 {bit},pop,pop) else emit10(58 {ash},pop); with opstk[tos] do begin if gcc in desire then begin if loaded in state then freeregister(reg); reg:=gcc; truecode:=ltruecode end else begin opsize:=bitsize; {only low order bit is valid} extend(wordsize, desire) end; state:=[loaded]; end end {sin}; procedure sany; var lop: integer; rega: registers; begin {sany} gencode(node@.arg[1],gregs,loadvalue); with opstk[tos] do begin rega:=reg; if opsize<=bytesize then lop:=-29696 {rorb} else lop:=3072 {ror}; opsize:=wordsize end; pushdesire:=desire; emit7(40 {clr},push); emit0(177 {sec}); emit0(lop+ord(rega) {ror rega}); emit0(-30974 {bcs .+6}); emit7(42 {inc},leave); emit0(508 {br .-10}); freeregister(rega) end {sany}; procedure indexnode(node: ptn{; multiplier: integer}); type doset = set of (chkreg, getinx, mmult, swap, add, {mdisp,} chkcst, merge); dotabtype = array[0..7] of record todo: doset; fstate: operstates end; const dotab = dotabtype( ( [], [] ), { [], const index } ( [getinx,{mdisp}mmult,merge], [indexed] ), { [] } ( [chkcst], [indirect] ), { [indirect], const index } ( [getinx,mmult,swap,add], [based] ), { [indirect] } ( [chkreg], [indexed] ), { [indexed], const index } ( [chkreg,getinx,add,{mdisp}mmult], [indexed] ), { [indexed] } ( [], [based] ), { [based], const index } ( [chkreg,getinx,mmult,add], [based] ) { [based] } ); var variable: ptn; fixed,laddr,offset,n: integer; lrel: relpair; lstate: operstates; ldesire: resources; doit: doset; procedure findcstpart(node: ptn; var varpart: ptn; var cstpart: integer); const litcode = chr(162); addcode = chr(32); subcode = chr(33); var subpart: integer; begin {findcstpart} with node@ do if code = litcode then begin varpart := nil; cstpart := dsp.disp end else if (code = addcode) and (arg[2]@.code = litcode) then begin findcstpart(arg[1], varpart, subpart); cstpart := subpart + arg[2]@.dsp.disp end else if (code = addcode) and (arg[1]@.code = litcode) then begin findcstpart(arg[2], varpart, subpart); cstpart := arg[1]@.dsp.disp + subpart end else if (code = subcode) and (arg[2]@.code = litcode) then begin findcstpart(arg[1], varpart, subpart); cstpart := subpart - arg[2]@.dsp.disp end else begin varpart := node; cstpart := 0 end end {findcstpart}; begin {indexnode} with node@ do if code <> chr(134) then gencode(node, gregs, noload) else begin {multiplier := dsp.disp;} indexnode(arg[1]{, multiplier}); findcstpart(arg[2], variable, fixed); offset := fixed * {multiplier}dsp.disp; with opstk[tos] do begin laddr:=adr.addr; lrel:=rel; lstate:=state; if state = [] then n := 0 else if indirect in state then n := 2 else if indexed in state then n := 4 else n := 6; { must be based } if variable <> nil then n := n + 1; doit := dotab[n].todo; if swap in doit then begin { will convert indirect to based } state := state - [indirect]; laddr := 0 end; if chkreg in doit then begin restoreregisters(tos,gregs); state := state + [loaded]; { so later add will work } if copy in state then doit := doit + [swap] { so we don't destroy register } end end; if getinx in doit then begin gencode(variable,gregs,noload); {compute index value} extend(wordsize, gregs) end; if mmult in doit then mdmconst(2 {mul}, {multiplier}dsp.disp, gregs, false); if swap in doit then begin load(gregs); swaptos end; {if mdisp in doit then mdmconst(2, dsp.disp, gregs, false);} if add in doit then emit15(6 {add}, pop, leave); if merge in doit then begin opstk[tos-1].reg := opstk[tos].reg; tos := tos - 1 end; if (chkcst in doit) and (offset <> 0) then begin { convert indirect to based } loadaddress(gregs); laddr := 0; lstate := [based]; lrel.reltype := absact end; with opstk[tos] do begin if getinx in doit then begin state := dotab[n].fstate; { possibly a new addressing state } if state = [based] then lrel.reltype := absact end else state := lstate; opsize := size; adr.addr := laddr + offset; rel := lrel end end {with node@} end {indexnode}; procedure definetemp; var taddr: integer; usereg: boolean; ltmpreg : resources; begin {definetemp} with node@ do begin {the number of temp regs required by "inner" code will be left in the node's size field, courtesy of prescan} { usereg := ord(size)<=maxtmpregs;} usereg := tmpreg <> tregs; if not usereg then begin {reserve a local spot for it} newtos; with opstk[tos] do begin if lexlev=1 then begin {local are is in bss} taddr:=tempbase + (dsp.disp - withtmpreg)*2; if taddr>localsize then localsize:=taddr; rel.reltype:=bssact; state:=[] end else begin {local area is in stack} taddr:=tempbase + (withtmpreg - dsp.disp)*2; if taddr=0) do with opstk[i] do if (temp in state) and (rel.segnr=lookfor) then found:=true else i:=i-1; newtos; if found then begin opstk[tos]:=opstk[i]; opstk[tos].state:=opstk[tos].state-[temp] + [copy]; end else pass2error(10) end {refertotemp}; procedure ifnode; var endchain,lfalsechain,ltruechain: branchlist; which_stmt: integer; begin {ifnode} with node@ do begin if ord(arg[1]@.code) = 162 {liter} then begin {const Boolean-expression, optimize by generating only the executable statement.} if arg[1]@.dsp.disp = 1 { true } then which_stmt := 2 { then-stmt } else which_stmt := 3; { else-stmt } gencode(arg[which_stmt], desire, force) end {const expression} else begin {var expression} lfalsechain := falsechain; falsechain := emptychain; ltruechain := truechain; truechain := emptychain; endchain := emptychain; saveregister(true, []); gencode(arg[1], [gcc], loadvalue); { Boolean-expression } tos := tos-1; {remove condition code operand} emitbranch(brinv[truecode], falsechain); fixbranch(true, truechain); gencode(arg[2], desire, force); { then-stmt } emitbranch(1, endchain); fixbranch(false, falsechain); gencode(arg[3], desire, force); { else-stmt } fixbranch(true, endchain); falsechain := lfalsechain; truechain := ltruechain end {var expression} end {with node@} end {ifnode}; procedure casenode; var endchain: branchlist; casestate: blockstate; tp: codeindex; i, j: integer; case_lab, lmin, lop, diff: integer; found: boolean; lreg: registers; begin {casenode} with node@ do begin if ord(arg[1]@.code) = 162 {liter} then begin {case-index-expr is const; optimize by generating only the selected stmt:} case_lab := arg[1]@.dsp.disp; found := false; i := 2; { search case-list-elements: } while (i <= ord(nrarg)-2) and not found do with arg[i]@ do begin j := 1; { search case-constant-list: } while (j <= ord(nrarg)-1) and not found do if arg[j]@.dsp.disp = case_lab then begin found := true; gencode(arg[ord(nrarg)], desire, force) end else j := succ(j); i := succ(i) end {while/with}; if not found then if arg[ord(nrarg) - 1] = nil then begin pass2error(70) end else gencode(arg[ord(nrarg) - 1], desire, force) end {const expr} else begin {var expr} saveregister(true, []); {push all tos registers} gencode(arg[1], gregs, loadvalue); extend(wordsize, gregs); lmin := arg[ord(nrarg)]@.dsp.disp; diff := dsp.disp - lmin; { lmax - lmin } lreg := opstk[tos].reg; if lmin <> 0 then begin {subtract min case label from reg:} lop := 162700B; { sub #lmin,r } if lmin = -1 then lop := 5200B { inc r } else if lmin = 1 then lop := 5300B; { dec r } emit0(lop + ord(lreg)); if abs(lmin) <> 1 then emit0(lmin) end; emit0(0 {case}); emit0(lastbr); lastbr := cp-2; emit0(diff+1); { nrtargets } emit0(ord(lreg)); freeregister(lreg); tos := tos-1; tp := cp; endchain.last := 0; endchain.state := curstate; casestate := curstate; for i := 0 to diff do emit0(-1); { initialize jump table } for i := 2 to (ord(nrarg)-2) do begin with arg[i]@ do begin for j := 1 to (ord(nrarg)-1) do { fixup this entry in jump table: } codebuf[arg[j]@.dsp.disp - lmin + tp] := cp-tp+4; curstate := casestate; { restore state as of case jump } saveregister(true, []); {push all tos registers} gencode(arg[ord(nrarg)], desire, force) end; emitbranch(1 {br}, endchain) end; found := false; for i := 0 to diff do { fixup all unused entries in jumptable } if codebuf[tp+i]=-1 then begin found := true; codebuf[tp+i] := cp-tp+4 end; if found then begin curstate := casestate; saveregister(true, []); gencode(arg[ord(nrarg) - 1], desire, force) end; fixbranch(false, endchain) end {var expr} end {with node@} end {casenode}; procedure loopnode; var lfalsechain, ltruechain: branchlist; loophead: codeindex; i: integer; begin {loopnode} lfalsechain := falsechain; falsechain := emptychain; ltruechain := truechain; truechain := emptychain; saveregister(true,[]); label_; loophead := cp; with node@ do for i:=1 to ord(nrarg) do gencode(arg[i],assignable+[stk],noload); falsechain := emptychain; emitbranch(1, falsechain); codebuf[falsechain.last+2] := loophead-cp+3; { fixup backward branch } fixbranch(false,truechain); { fixup all exit branches } falsechain := lfalsechain; truechain := ltruechain end {loopnode}; procedure exitnode; var savechain: branchlist; begin {exitnode} { truechain is used globally to accumulate exits from current loop } { falsechain is used locally to accumulate continues for this exit } falsechain := emptychain; savechain := truechain; truechain := emptychain; with node@ do begin gencode(arg[1],[gcc],loadvalue); tos := tos - 1; { pop off condition code value } if arg[2] <> nil then begin emitbranch(brinv[truecode],falsechain); fixbranch(true,truechain); truechain := emptychain; gencode(arg[2],desire,force); emitbranch(1,truechain) end else emitbranch(truecode,truechain) end; fixbranch(false,falsechain); falsechain := emptychain; mergebranchchains(savechain,truechain) end {exitnode}; procedure fornode; {decision table for setting up for node:} {todo: FLD1 - load expr1 (from value is not constant) FLD2 - load expr 2 (to value is not constant) FDEC - increment is -1 (downto) FADD - FNEG - FSUB - FSWP - FREG - } type todo = (FLD1,FLD2,FDEC,FADD,FNEG,FSUB,FSWP,FREG); whattodo = set of todo; fortabtype = array [0..7] of whattodo; const fortab = fortabtype( [ FSWP,FSUB, FADD, FLD2,FLD1], [ FADD, FLD2 ], [FREG, FNEG,FADD, FLD1], [FREG ], [FREG, FSUB, FADD,FDEC,FLD2,FLD1], [ FNEG,FADD,FDEC,FLD2 ], [FREG, FADD,FDEC, FLD1], [FREG, FDEC ]); var backchain, forwchain: branchlist; dowhat: whattodo; usereg: boolean; targetsize: byte; lop,tcadjust: integer; regs1,regs2,tcregs: resources; looptop: codeindex; tabindex: 0..7; howload: whatwhere; ltmpreg : resources; begin {fornode} with node@ do begin forwchain := emptychain; backchain := emptychain; tcadjust := 0; tabindex := 0; {following assumes arg[4] is LIT with value +-1} if arg[2]@.code = litcode then tabindex:=tabindex+1; if arg[3]@.code = litcode then tabindex:=tabindex+2; if arg[4]@.dsp.disp<0 then tabindex:=tabindex+4; dowhat:=fortab[tabindex]; {find out if we can leave trip count in a temp register} { if (ord(size) <= maxtmpregs) then begin} if tmpreg <> tregs then begin usereg:=true; tcregs:=tregs end else begin usereg:=false; tcregs:=[stk] end; if FREG in dowhat then begin regs1:=tcregs; regs2:=gregs end else begin regs1:=gregs; regs2:=tcregs end; {Now, get loop variable} gencode(arg[1],gregs,noload); targetsize:=opstk[tos].opsize; {Now, get initial value:} if FLD1 in dowhat then howload:=loadvalue else howload:=noload; gencode(arg[2],regs1,howload); emit15(1{mov},leave,pop); if FLD1 in dowhat then begin opstk[tos]:=opstk[tos+1]; extend(wordsize,gregs) end else begin tcadjust:=tcadjust-arg[2]@.dsp.disp; tos:=tos-1 end; {Next, the final value:} if FLD2 in dowhat then howload:=loadvalue else howload:=noload; gencode(arg[3],regs2,howload); if FLD2 in dowhat then extend(wordsize,gregs) else begin tcadjust:=tcadjust+arg[3]@.dsp.disp; tos:=tos-1 end; if FSWP in dowhat then swaptos; if FSUB in dowhat then emit15(14{sub},pop,leave); if FNEG in dowhat then emit7(44{neg},leave); if FDEC in dowhat then tcadjust:=1-tcadjust else tcadjust:=tcadjust+1; {if haven't loaded anything and tcadjust<=0, don't generate code} if (dowhat*[FLD1,FLD2] <> []) or (tcadjust>0) then begin pushlit(tcadjust); if FADD in dowhat then begin emit15(6{add},pop,leave); emitbranch(5{ble},forwchain) end else load(regs1); {trip count next...mark temp} opstk[tos].state:=opstk[tos].state + [temp]; if usereg then begin ltmpreg := tmpreg; tmpreg := tmpreg + [opstk[tos].reg] end; { Store very large temp # (as segnr) so it won't match anything set up by with } opstk[tos].rel.segnr:=chr(255); label_; looptop:=cp; gencode(arg[5],desire,force); gencode(arg[1],gregs,noload); opstk[tos].opsize:=targetsize; if FDEC in dowhat then lop:=43{dec} else lop:=42{inc}; emit7(lop,pop); tos:=tos-1; {if we're using a temp register, emit an sob; else do dec,bgt} if usereg then begin emitbranch(18{sob},backchain); codebuf[lastbr+2] := looptop-cp+3; emit0(ord(opstk[tos].reg)); fixbranch(true,forwchain); freeregister(opstk[tos].reg); tmpreg := ltmpreg end else begin emit7(43{dec},leave); emitbranch( 4{bgt},backchain); codebuf[lastbr+2] := looptop-cp+3; fixbranch(true,forwchain); emit7(47{tst},pop) {delete trip count from stack} end; tos:=tos-1 end { if } end { with node@ do } end {fornode}; procedure sequence; var numarg,i: integer; begin {sequence} numarg:=ord(node@.nrarg); for i:=1 to numarg-1 do gencode(node@.arg[i],assignable + [stk],noload); gencode(node@.arg[numarg],desire,force) end {sequence}; procedure call(isfunc: boolean; isuser: boolean); var i: integer; reg: registers; symindex: integer; cctype: symbol_types; begin {call} with node@ do begin symindex := searchid( dsp.disp, isuser ); cctype := stable[symindex].stype; saveregister(true,[]); {save stack registers} if cctype=fortransy then for i:=2 to 5 do emit0( 10046b+i*64 {mov Ri,-(SP)} ); if isfunc then begin newtos; with opstk[tos] do begin state := [loaded]; opsize := size; reg := stk; if isuser and (cctype <= externalsy) then adjuststack(-(ord(size)+1) div 8); end end; if cctype <= externalsy then {local proc or pascal ext} for i:=1 to ord(node@.nrarg) do begin gencode(arg[i], [stk], loadvalue); tos:=tos-1 end else begin {C or fortran ext} for i:=ord(node@.nrarg) downto 1 do begin gencode(arg[i], [stk], loadvalue); tos := tos -1 end; if cctype = fortransy then begin emit0( 12746b {mov lit,-(SP)} ); emit0( ord(node@.nrarg) ); emit0( 10605b {mov SP,R5} ) end end; if isuser and (cctype<=externalsy) then reg:=getenvironment(ord(segnr), [gr4]); {getenvironment called for effect} if isfunc and (cctype >= ceesy) then opstk[tos].reg := getregister( [gr0] ); gencall(isuser,dsp.disp); if cctype >= ceesy then begin i := stable[symindex].snum; if cctype = fortransy then i := succ(i); adjuststack( 2*i ); if cctype = fortransy then for i:=5 downto 2 do emit0( 12600b+i {mov (SP)+,Ri} ) end end end {call}; begin {gencode} if node<>nil then with node@ do begin case ord(code) of 9 {refer}: begin gencode(arg[1],desire*(gregs + [stk]),noload); if indirect in opstk[tos].state then begin {just turn it off} opstk[tos].state:=opstk[tos].state-[indirect]; opstk[tos].opsize:=wordsize {it's a pointer} end else loadaddress(desire*(gregs + [stk])) end; 10,12 {stol,stof}: store(ord(code)-10); 16,17 {succ,pred}: genunary(ord(code)+26 {inc,dec}); 24,25,26,27,28,29 {uceq-uclt}: compare(ord(code)-14); 30,31 {umax,umin}: minmax(ord(code)-30); 32 {iadd}: genbinary(6 {add},true); 33 {isub}: genbinary(14 {sub},true); 34 {imul}: muldivmod(2); 35 {idiv}: muldivmod(1); 36 {imod}: muldivmod(0); 37 {isqr}: square(0); 40 {ineg}: genunary(44 {neg}); 41 {iabs}: iabs; 42 {iodd}: iodd; 56,57,58,59,60,61 {iceq-iclt}: compare(ord(code)-54); 62,63 {imax,imin}: minmax(ord(code)-60); 64, 65, 66, 67 {fadd, fsub, fmul, fdiv}: genfpbinary(ord(code)-64); 69 {fsqr}: square(2); 72 {fneg}: genfpunary(3); 73 {fabs}: genfpunary(2); 74,75,76 {float - round}: genfpconvert(ord(code)-74); 88,89,90,91,92,93 {fceq - fclt}: fpcompare(ord(code)-86{brtype}); 96 {not}: notnode; 104,105,106,107,108,109 {eqv-nrimp, aka "bceq"-"bclt"}: {With no packed values, booleans are bytes, so can call compare} compare(ord(code)-102); 110 {or}: if gcc in desire then condandor(false) else genbinary(5 {bis},false); 111 {and}: if gcc in desire then condandor(true) else genbinary(0 {and},false); 113 {union}: if size<=wordsize then genbinary(5 {bis}, false); 114 {inter}: if size<=wordsize then genbinary(0 {and}, false); 115 {sdiff}: if size<=wordsize then genbinary(4 {bic}, false); 117 {sgens}: sgens; 118 {sadel}: pass2error( 31 ); 120,121 {sceq,scne}: if size<=wordsize then compare(ord(code)-118); 123,124 {scle,scge}: pass2error(32); 126 {sin}: sin; 127 {sany}: sany; 132 {ofset}: begin gencode(arg[1],gregs,noload); with opstk[tos] do begin if indirect in state then begin loadaddress(gregs); rel.reltype:=absact; {no relocation for offset} adr.addr:=dsp.disp; state:=[based] end else adr.addr:=adr.addr+dsp.disp; opsize:=size end end; 133 {indir}: begin gencode(arg[1],gregs,noload); with opstk[tos] do begin if loaded in state then begin {result of a refer-to-temp} adr.addr:=dsp.disp; rel.reltype:=absact; {offset needs no relocation} state:=(state-[loaded]) + [based] end else if (indirect in state) or (dsp.disp<>0) then begin opsize:=wordsize; load(gregs); adr.addr:=dsp.disp; rel.reltype:=absact; state:=[based] end else state:=state + [indirect]; opsize:=size end end; 134 {index}: indexnode(node{, 1}); 135 {movem}: move; 138 {invok}: if size=chr(255) then call(false,false) else call(true,false); 140 {rtemp}: refertotemp; 141 {dtemp}: definetemp; 144 {if}: ifnode; 145 {case}: casenode; 147 {loop}: loopnode; 148 {exit}: exitnode; 149 {for}: fornode; 152 {seq}: sequence; 168,169,170,171,172,173 {vceq-vclt}: vcompare(ord(code)-158); 208 {call}: if size=chr(255) then call(false,true) else call(true,true); 162 {liter}: pushlit(dsp.disp); 164 {litd}: pushlitd(dsp.disp); 163,176,192 {rdata,varb,parm}: begin newtos; with opstk[tos] do begin state:=[]; opsize:=size; reg:=mem; adr.addr:=dsp.disp; rel.segnr:=segnr; {Resolve relocation type for varbles here so we know what to do back up the tree} if code=chr(176) {is it a variable} then if ord(segnr)=1 {make level 1 varbles reside in BSS segment} then rel.reltype:=bssact else rel.reltype:=absact {no mod for local addresses. Done in p1. Tacky} else if code=chr(192) {parm} then begin rel.reltype:=absact; adr.addr:=adr.addr+6 {stack frame header} end else rel.reltype:=datact {rdata} end end; 255 {line}: begin trace := true; emit0(104404b {TRAP 4}); emit0(dsp.disp); gencode(arg[1], desire, force) end end; {of case} if force=loadvalue then load(desire) else if force=loadaddr then loadaddress(desire); if sdump then dumpstack(ord(code)) end {of node<>nil} end {gencode}; begin {genscan} if lexlev=1 then rlp:=rlp+1; {reserve one entry in reltab} if profile then rlp:=rlp+1; {reserve one entry in reltab} cp:=cp+9; {reserve 9 words in code} avail:=assignable; tmpreg:=[]; {initialize free registers} usedregs:=[]; withtmpreg := 0; {no with-statement temps in registers yet} tos:=-1; curstate.roving:=lexlev-1; gencode(tree,assignable + [stk],noload); codebuf[cp]:=0 {something solid so optimize branches doesn't barf} end {genscan}; procedure finalgeneration; {this procedure completes code generation by generating code for branches and compacting code in the buffer} var maxcp,maxrlp,oldcp: integer; r : relpair; procedure optimizebranches; const {limits on branch targets} soblow=-63; sobhigh=0; brlow=-128; brhigh=127; var temp,adjust,nextbr,target,i: integer; brtype: brtypes; procedure sumadjust(from:integer; back:boolean; var target:integer); var too:integer; begin {sumadjust} too:=nextbr+target; while from>0 do if back then if from>too then begin target:=target+(codebuf[from] div 256); from:=codebuf[from+1] end else from:=0 else if from0 do begin brtype:=codebuf[nextbr]; if (brtype>0) and (brtype<18) then begin {simple branches only} target:=codebuf[nextbr+2] + nextbr; if codebuf[target]=1 {assumes no legal instr has opcode 1!!} then codebuf[nextbr+2]:=codebuf[target+2]+target-nextbr end; nextbr:=codebuf[nextbr+1] end; {optimize branches which merely skip over an unconditional branch} nextbr:=lastbr; while nextbr>0 do begin brtype:=codebuf[nextbr]; if (brtype>0) and (brtype<18) then begin {simple branches only} target:=codebuf[nextbr+2]; if (target=6) and (brtype<>1) and (codebuf[nextbr+3]=1) {assumes no legal instr has opcode 1!!} then begin {conditional skipping over unconditional} codebuf[nextbr]:=brinv[brtype]; {invert branch type} codebuf[nextbr+2]:=codebuf[nextbr+5]+3; {create new target} codebuf[nextbr+5]:=3 {make unconditional into a null} end end; nextbr:=codebuf[nextbr+1] end; {while} {now optimize each branch as to size and type depending on distance to target} nextbr:=0; while lastbr>0 do begin {swap(codebuf[lastbr+1],nextbr,lastbr)} temp:=codebuf[lastbr+1]; codebuf[lastbr+1]:=nextbr; nextbr:=lastbr; lastbr:=temp; {reverse links} adjust:=0; brtype:=codebuf[nextbr]; if brtype=0 then begin {case} i:=0; {%for i:=0 to codebuf[nextbr]-1} while i0 then sumadjust(nextbr,false,target); if brtype=18 then {branch on count} if (target<=sobhigh+1) and (target>=soblow+1) then adjust:=3 {can use sob instruction} else if (target<=brhigh+2) and (target>=brlow+2) then adjust:=2 {can use dec,bne} else adjust:=0 {must use dec,beq,jmp} else {unconditional or simple conditional} if (target<=brhigh+1) and (target>=brlow+1) then if target=3 then adjust:=3 {null branch, will be removed} else adjust:=2 {can use br or bcond} else if brtype=1 then adjust:=1 {can use jmp} else adjust:=0;{must use bnot cond,jmp} {fixup targets of forward branches} if target>0 then codebuf[nextbr+2]:=target-adjust; codebuf[nextbr]:=adjust*256+brtype end {not a case} end; {while} {now we can adjust targets for backward branches} lastbr:=0; while nextbr>0 do begin if ((codebuf[nextbr] mod 256)>0) and (codebuf[nextbr+2]<0) then {not a case and is backward target, adjust it} sumadjust(lastbr,true,codebuf[nextbr+2]); {swap(codebuf[nextbr+1],lastbr,nextbr)} temp:=codebuf[nextbr+1]; codebuf[nextbr+1]:=lastbr; lastbr:=nextbr; nextbr:=temp {reverse links} end {while} end {optimizebranches}; procedure generatebranches; var nextbr,nxtrel,adjust,reg,target,nrtargets,temp: integer; brtype: brtypes; procedure emit5(i:brtypes; offset:integer); begin {emit5} emit0(brtab[i]+(offset mod 256)) end {emit5}; begin {generatebranches} nextbr:=0; {go up list and reverse links} while lastbr<>0 do begin {swap(codebuf[lastbr+1],nextbr,lastbr)} temp:=codebuf[lastbr+1]; codebuf[lastbr+1]:=nextbr; nextbr:=lastbr; lastbr:=temp end; {set up first relocatable word} if rlp0) and (oldcp=nextbr) then begin {must generate code for a branch} temp:=codebuf[oldcp]; adjust:=temp div 256; brtype:=temp mod 256; nextbr:=codebuf[oldcp+1]; if brtype>0 then begin {not a case} target:=codebuf[oldcp+2]; if brtype<18 then begin {simple branch} if adjust>=2 then begin if adjust=2 then emit5(brtype,target-1 {short branch}) end else begin if adjust=0 then begin if brtype=1 then emit0(160{nop}) else emit5(brinv[brtype],2); target:=target-1 end; emit0(119 {jmp target(pc)}); emit0((target-2)*2) end; oldcp:=oldcp+3 end else begin {branch on count} reg:=codebuf[oldcp+3]; if adjust=3 then emit0(32256+(reg*64)-(target-1) {sob reg,target}) else begin emit0(2752+reg {dec reg}); if adjust=2 then emit5(3,target-2 {bne target}) else begin emit5(2{ble},2); emit0(119 {jmp target(pc)}); emit0((target-4)*2) end end; oldcp:=oldcp+4 end {branch on count} end {not a case} else begin {case} nrtargets:=codebuf[oldcp+2]; reg:=codebuf[oldcp+3]; emit0(3264+reg {asl reg}); emit0(25024+reg {add pc,reg}); emit0(27655+(reg*64) {add 4(reg),pc}); emit0(4); oldcp:=oldcp+4; while nrtargets>0 do begin codebuf[cp]:=(codebuf[oldcp]-4)*2; cp:=cp+1; oldcp:=oldcp+1; nrtargets:=nrtargets-1 end end {case} end {code generation for a branch} else begin {not a branch, move up code and adjust reltab} codebuf[cp]:=codebuf[oldcp]; if oldcp=nxtrel then begin {adjust entry in relocation table} reltab[rlp].cix:=cp; rlp:=rlp+1; if rlp0 then {move down return address and purge parameters} if paramsize > 4 then begin emit0(5558{mov (sp)+,[paramsize-2](sp)}); emit0(paramsize-2); adjuststack(paramsize-2) end else begin if paramsize > 2 then emit0(5518{mov (sp)+,(sp)}); emit0(5518{mov (sp)+,(sp)}) end; emit0(135 {rts pc}) end end {finalgeneration}; procedure printcode; const ht=chr(9); nl=chr(10); type itabform=array[0..122] of {packed} record class:integer; mnemonic:array[1..5] of char end; const itab=itabform( ( 0,'halt '),( 0,'wait '),( 0,'rti '),( 0,'bpt '), ( 0,'iot '),( 0,'reset'),( 0,'rtt '),( 0,'.....'), ( 7,'jmp '), ( 6,'rts '),( 1,'spl '),( 2,'ccc '),( 2,'scc '), ( 7,'swab '),( 5,'br '),( 5,'bne '),( 5,'beq '), ( 5,'bge '),( 5,'blt '),( 5,'bgt '),( 5,'ble '), (11,'jsr '), ( 7,'clr '),( 7,'com '),( 7,'inc '),( 7,'dec '), ( 7,'neg '),( 7,'adc '),( 7,'sbc '),( 7,'tst '), ( 7,'ror '),( 7,'rol '),( 7,'asr '),( 7,'asl '), ( 3,'mark '),( 7,'mfpi '),( 7,'mtpi '),( 7,'sxt '), (15,'mov '),(15,'cmp '),(15,'bit '), (15,'bic '),(15,'bis '),(15,'add '), (10,'mul '),(10,'div '),(10,'ash '),(10,'ashc '), (11,'xor '), ( 6,'fadd '),( 6,'fsub '),( 6,'fmul '),( 6,'fdiv '), ( 9,'sob '), ( 5,'bpl '),( 5,'bmi '),( 5,'bhi '),( 5,'blos '), ( 5,'bvc '),( 5,'bvs '),( 5,'bcc '),( 5,'bcs '), ( 4,'emt '),( 4,'trap '), ( 7,'clrb '),( 7,'comb '),( 7,'incb '),( 7,'decb '), ( 7,'negb '),( 7,'adcb '),( 7,'sbcb '),( 7,'tstb '), ( 7,'rorb '),( 7,'rolb '),( 7,'asrb '),( 7,'aslb '), ( 0,'.....'),( 7,'mfpd '),( 7,'mtpd '),( 0,'.....'), (15,'movb '),(15,'cmpb '),(15,'bitb '), (15,'bicb '),(15,'bisb '),(15,'sub '), ( 0,'cfcc '),( 0,'setf '),( 0,'seti '),( 0,'ldub '), ( 0,'ldsc '),( 0,'sta0 '),( 0,'mrs '),( 0,'stq0 '), ( 0,'.....'),( 0,'setd '),( 0,'setl '),( 0,'.....'), ( 0,'.....'),( 0,'.....'),( 0,'.....'),( 0,'.....'), ( 7,'ldfps'),( 7,'stfps'),( 7,'stst '), ( 8,'clrf '),( 8,'tstf '),( 8,'absf '),( 8,'negf '), (13,'mulf '),(13,'modf '),(13,'addf '),(13,'ldf '), (13,'subf '),(13,'cmpf '),(14,'stf '),(13,'divf '), (16,'stexp'),(16,'stcfi'),(14,'stcfd'),(12,'ldexp'), (12,'ldcif'),(13,'ldcfd')); const {indicies to entries in above table} merr=7; mjmp=8; mrts=mjmp+1; mccc=mrts+2; mswab=mrts+4; mbr=mswab+1; mjsr=mbr+7; mclr=mjsr+1; mmov=mclr+16; mmul=mmov+6; mfadd=mmul+5; msob=mfadd+4; mbpl=mmul+10; mclrb=mbpl+10; mmovb=mclrb+16; mcfcc=mmovb+6; mldfps=mcfcc+16; mclrf=mldfps+3; mmulf=mclrf+4; var lcs,lcp,inst,ix,t:integer; lrlp:relindex; ch: char; procedure writeoctal(i:integer); begin write(ols,ord(i<0):1,i div 4096 mod 8:1,i div 512 mod 8:1, i div 64 mod 8:1,i div 8 mod 8:1,i mod 8:1) end {writeoctal}; procedure greg(i:integer); type rtab=array[0..7] of array[1..2] of char; const grtab=rtab('r0','r1','r2','r3','r4','r5','sp','pc'); begin write(ols,grtab[i mod 8]) end {greg}; procedure freg(i:integer); type rtab=array[0..7] of array[1..2] of char; const frtab=rtab('f0','f1','f2','f3','f4','f5','f*','f*'); begin write(ols,frtab[i mod 8]) end {freg}; procedure srcdst(i:integer; isfloat:boolean); procedure breg; begin {breg} write(ols,'('); greg(i); write(ols,')') end {breg}; begin {srcdst} case (i div 8) mod 8 of 0:if isfloat then freg(i) else greg(i); 1:breg; 2,3:begin if odd(i div 8) then write(ols,'@'); if (i mod 8)=7 then begin write(ols,'#'); write(ols,codebuf[lcp]); lcp:=lcp+1 end else begin breg; write(ols,'+') end; end; 4,5:begin if odd(i div 8) then write(ols,'@'); write(ols,'-'); breg end; 6,7:begin if odd(i div 8) then write(ols,'@'); if (i mod 8)=7 then writeoctal((lcp+1)*2+codebuf[lcp]) else begin write(ols,codebuf[lcp]); breg end; lcp:=lcp+1 end end {of case} end {srcdst}; begin {printcode} if procnr >= 0 then begin writeln(ols, ' '); writeln(ols,'; procedure ',name:namesize,'(',procnr:3,')') end; lcp:=0; lrlp:=0; while lcp1) then lcp := lcp + 1 end; 5,6:ix:=((inst div 64+8) mod 16)+mclrb; {clrb-mtpd} 7:ix:=merr {illegal} end; 9,10,11,12,13,14:ix:=((inst div 4096) mod 8)+(mmovb-1); {movb-sub} 15:case (inst div 256) mod 16 of 0:if ((inst div 64) mod 4)=0 then if (inst mod 64)<16 then ix:=(inst mod 64)+mcfcc {cfcc-setl} else ix:=merr {illegal} else ix:=((inst div 64) mod 4)+(mldfps-1); {ldfps-stst} 1:ix:=((inst div 64) mod 4)+mclrf; {clrf-negf} 2,3,4,5,6,7,8,9,10,11,12,13,14,15: ix:=((inst div 256) mod 16)+(mmulf-2) {mulf-ldcfd} end end; {of outer case} write(ols,ht,itab[ix].mnemonic:8); case itab[ix].class of 1:write(ols,inst mod 8); 2:write(ols,inst mod 16); 3:write(ols,inst mod 64); 4:write(ols,inst mod 256); 5:begin t:=inst mod 256; if t>127 then t:=t-256; {byte sign extend} writeoctal((lcp+t)*2) end; 6:greg(inst); 7:srcdst(inst,false); 8:srcdst(inst,true); 9:begin greg(inst div 64); write(ols,','); writeoctal((lcp-(inst mod 64))*2) end; 10:begin srcdst(inst,false); write(ols,','); greg(inst div 64) end; 11:begin greg(inst div 64); write(ols,','); srcdst(inst,false) end; 12:begin srcdst(inst,false); write(ols,','); freg(inst div 64 mod 4) end; 13:begin srcdst(inst,true); write(ols,','); freg(inst div 64 mod 4) end; 14:begin freg(inst div 64 mod 4); write(ols,','); srcdst(inst,true) end; 15:begin srcdst(inst div 64,false); write(ols,','); srcdst(inst,false) end; 16:begin freg(inst div 64 mod 4); write(ols,','); srcdst(inst,false) end end; {of case} writeln(ols); while lcs 0 then begin codebuf[w+0] := rldrec; codebuf[w+1] := lcentry; codebuf[w+2] := dataprefix; codebuf[w+3] := datasuffix; codebuf[w+4] := 0; writerecord( true, w, w+5, 0 ); reset({dat}int, {argv[datx]@}argv[0]@); address := 0; codebuf[w] := txtrec; while dcnt>0 do begin count := 0; codebuf[w+1] := address; while (dcnt>0) and (count < maxtxt) do begin byte1 := {dat}int@; get({dat}int); dcnt := pred(dcnt); if dcnt<=0 then byte2 := chr(0) else begin byte2 := {dat}int@; get({dat}int); dcnt := pred(dcnt) end; codebuf[w+2+count] := ord(byte1) + ord(byte2)*256; address := address+2; count := succ(count) end {while}; writerecord(true,w,w+2+count,0); count := 0 end {while dcnt>0}; end {if dcnt <> 0}; codebuf[w] := endgsdrec; writerecord(true, w, w+1, 0); codebuf[w] := endmodrec; writerecord(true, w, w+1, 0); end {outtrailer}; procedure outprocedure; {write out procedure code and relocation data} const w=maxcode+1; gsdrec=1; txtrec=3; rldrec=4; glbsym=4; glbsymdef=8; psectentry=5; fastmem=1; library=2; overlay=4; kludge=8; readonly=16; relocate=32; global=64; dataref=128; instentry=psectentry*256+relocate+kludge; globentry=psectentry*256+relocate+global+kludge+overlay; dataentry=psectentry*256+relocate+global+kludge+overlay; profentry=psectentry*256+relocate+global+kludge; instdef=glbsym*256+relocate+glbsymdef+global; traentry=3*256; lcentry=7; systprefix = 126423B; {RAD50('$$$'), heap psect} globpref1 = 124744B; {RAD50('$GL'), globals psect} globpref2 = 57043B; {RAD50('OBS'), globals psect} profpref1 = 125522B; {RAD50('$PR'), profiling psect} profpref2 = 057260B; {RAD50('OF '), profiling psect} type reference=record link:@reference; value:integer end; var prefix,suffix,gx,rx, dataprefix, datasuffix, i: integer; globlist:@reference; procedure setcodebuf( var s:array [0..5] of char ); begin {setcodebuf} codebuf[rx+1] := radcvt( s, 0 ); codebuf[rx+2] := radcvt( s, 3 ) end {setcodebuf}; procedure addlist( ptr:@reference; ref:integer ); var nptr:@reference; begin {addlist} loop exit if ref=ptr@.value; exit if ptr@.link=nil then begin new(nptr); ptr@.link := nptr; nptr@.link := nil; nptr@.value := ref; end; ptr := ptr@.link; end; end {addlist}; procedure addglobref( procnr:integer; isuser, setcode:boolean ); var ptr:@reference; ref:integer; begin {addglobref} ptr := globlist; ref := searchid( procnr, isuser ); if setcode then setcodebuf( stable[ref].sname ); if ptr=nil then begin new(globlist); globlist@.link := nil; globlist@.value := ref; end else addlist( ptr, ref ); end {addglobref}; procedure outgblref; const maxrld=w+7+42; instref=glbsym*256+global; var ptr:@reference; begin {outgblref} codebuf[w+0] := gsdrec; rx := w; ptr := globlist; loop exit if ptr=nil; setcodebuf( stable[ptr@.value].sname ); codebuf[rx+3] := instref; codebuf[rx+4] := 0; rx := rx + 4; ptr := ptr@.link; if rx>=maxrld then begin writerecord(true,w,rx+1,0); rx := w; end; end; if rx>w then writerecord(true,w,rx+1,0); end {outgblref}; procedure outtxtandrld(prefix,f: integer); const lcentry=7; maxtxt=42; maxrld=w+7+42; endgsdrec=2; endmodrec=6; type relsiztab = array [0..14] of integer; const relentsize = relsiztab(0,2,3,2,3,4,4,4,2,1,3,0,3,4,4); var relent,txtaddr,lrlp,lcp,rcp,tcp,i,j: integer; type optarray=array [0..15] of integer; const optrec=optarray(gsdrec, profpref1, profpref2, profentry, 0, rldrec, lcentry, profpref1, profpref2, 0, txtrec, 0, 052525b, 0, 0, 0); begin {outtxtandrld} mark; globlist := nil; if trace then addglobref(999, false, false); if profile then begin addglobref(998, false, false); for i := 0 to 15 do codebuf[w + i] := optrec[i]; codebuf[w + 16] := namesize; codebuf[w + 4] := 8 + ((namesize + 2) div 2) * 2; for i := 1 to namesize do begin j := i div 2; if odd(i) then codebuf[w+16+j] := codebuf[w+16+j] + ord(name[i])*256 else codebuf[w+16+j] := ord(name[i]) end; writerecord(true, w, w+5, 0); writerecord(true, w+5, w+10, 0); writerecord(true, w+10, w+17+j, 0) end; {*** create TXT record header and RLD record header} codebuf[w+2] := txtrec; codebuf[w+6] := rldrec; {create and write out initial RLD record to define location counter} codebuf[w+7] := lcentry; codebuf[w+8] := prefix; codebuf[w+9] := suffix; codebuf[w+10] := 0; {begin at relative zero} writerecord(true, w+6, w+11, 0); {write out a text record followed by a RLD record (if required)} {until all text has been processed} lrlp:=0; lcp:=0; if rlp>0 then rcp:=reltab[0].cix else rcp:=f; {first relocated word} while lcpf then tcp := f; rx:=w+7; txtaddr:=lcp*2; while (rcpw+7 then {write out relocation entries} writerecord(true,w+6,rx,0); {bump up text index and continue} lcp:=tcp end; outgblref; {Output global references} release; codebuf[w] := endgsdrec; writerecord(true, w, w+1, 0); codebuf[w] := endmodrec; writerecord(true, w, w+1, 0); end {outtxtandrld}; begin {outprocedure} gx := searchid( procnr, true); prefix := radcvt( stable[gx].sname, 0 ); suffix := radcvt( stable[gx].sname, 3 ); i := searchid( -1, true ); dataprefix := radcvt( stable[i].sname, 0 ); datasuffix := radcvt( stable[i].sname, 3 ); {create GSD record for an object module} outheader( prefix, suffix ); {create GSD record for this procedure} codebuf[w+0]:=gsdrec; {create entry for psect containing instructions} codebuf[w+1]:=prefix; codebuf[w+2]:=suffix; {psect name} codebuf[w+3]:=instentry; {entry type and flags} codebuf[w+4]:=cp*2; {size in bytes} codebuf[w+5]:=prefix; codebuf[w+6]:=suffix; {entry name} codebuf[w+7]:=instdef; codebuf[w+8]:=0; codebuf[w+9]:=dataprefix; codebuf[w+10]:=datasuffix; codebuf[w+11]:=dataentry; codebuf[w+12]:=0; codebuf[w+13]:=globpref1; codebuf[w+14]:=globpref2; codebuf[w+15]:=globentry; codebuf[w+16]:=0; gx := w + 17; {if this is outermost procedure, then generate transfer address entry} if procnr=0 then begin codebuf[gx]:=prefix; codebuf[gx+1]:=suffix; {transfer name} codebuf[gx+2]:=traentry; codebuf[gx+3]:=0; {start at location zero} codebuf[gx+4]:=globpref1; codebuf[gx+5]:=globpref2; codebuf[gx+6]:=globentry; codebuf[gx+7]:=localsize; gx:=gx+8 end; writerecord(true,w,gx,0); {now output the text and relocation entries} outtxtandrld(prefix, cp) end {outprocedure}; procedure olsheading; begin {olsheading} writeln(ols); writeln(ols, compiler_version, nbsversion@) end {olsheading}; procedure openols; begin {openols} if Ok_to_proceed and not ols_opened then begin ols_opened := true; rewrite(ols, argv[olsx]@, "OLS"); olsheading end end {openols}; procedure openp2files; var i : integer; ch : char; begin {openp2files} Ok_to_proceed := true; if argc = 2 then begin reset(int, "I"); rewrite(obj, argv[1]@, "OBJ"); rewrite(ols, "TT:"); dproc := true; ols_opened := true; olsheading; {$Y-} argv[0]@ := "D"; {$Y+} end else if (argc = 5) or (argc = 6) then begin reset(int, argv[intx]@); rewrite(obj, argv[objx]@, "OBJ"); i := 0; repeat ch := argv[datx]@[i]; argv[0]@[i] := ch; i := i + 1 until ch = chr(0) end else begin Ok_to_proceed := false; if argc = 1 then writeln(pass2id, compiler_version, nbsversion@) else {$Y-} error(pass2id, "Bad command") {$Y+} end end {openp2files}; procedure moduleident; { read module name and initial options, if any. } var s: -1..maxsym; ch: byte; begin {moduleident} while (not eof(int)) and (int@ = chr(3)) do begin ch := getbyte; readoptions end; if eof(int) or (int@ <> chr(6)) then begin pass2error(99); Ok_to_proceed := false end end {moduleident}; begin {P2FP} nbsversion := version; {intitialize output flags and then process option flags} list:=false; sdump:=false; dproc:=false; xtern:=false; ncmdlne := false; profile := false; indef := false; ols_opened := false; openp2files; if Ok_to_proceed then begin options; lastid := -1; {No id's entered} {initialize object module output} header_bytes := true; lexlev := 0; procnr := -1; moduleident; {initialize code buffer indicies} while Ok_to_proceed and (procnr <> 0) do begin mark; buildtree; if Ok_to_proceed then begin if sdump then writeln(output, NL, '-------- ', name: namesize); cp:=0; {init code buffer pointer} rlp:=0; {relocation data buffer pointer} lastbr:=0; {branch chain optimization index} trace:=false; {assume no line trace} {Set up symbol table entry for this procedure} { s:=searchid(procnr,true); }{get symbol for user proc} stable[searchid(procnr,true)].snum:= paramsize div 2; {number of parms, for pdb} if (calltype = 0) and (rvsize < 255) then begin { prescan;} genscan; {generate code in code buffer} release; {optimise on heap space} mark; finalgeneration; {finish code generation of branches} {output code, both binary and symbolic forms} if dproc then writeln(ols,procnr:3,' ':2,name:namesize, ' ':18-namesize,dcnt:6,cp:6,lastid:6); if list then printcode; outprocedure; end; {remove unneeded entries from table} while stable[lastid].slev > chr(lexlev) do lastid := pred(lastid); {update counters:} calltype := 0; lexlev := lexlev-1; release end; {Ok_to_proceed} {test for termination conditions} if eof(int) or (int@ = chr(0)) then procnr := 0 end {while not end of module}; if Ok_to_proceed then outtrailer end {Ok_to_proceed} end {P2FP}.