IMD 1.17: 14/03/2012 8:45:51 COMP1: B3466A 3.5" DS      €COMP1  M”$SIDEVDRT____ ”$6V€ ˙˙ASSMDEFT__éK ”$€5ASSEMBLET_éK]”$€\BLOCKT____éKkž”$8€ŮBODYDEFT__éK ”$B€aBODYHEADT_éK U”$I€TtBODYT_____éK`”$T€˙BUILDTREETéKf”$Y€\CCONSTST__éK„(”%&€'CHEADINGT_éKŹ”%0€˙COUNTT____éK°”%5€–CURT______éKą”%9€sCOMPLIBC__ę2Ŕ”%D€CONVERTC__ę2Đ”%I€DECLDEFT__éKâ”&€[DEVT______éKä”&€‡DEVRT_____éKó”&€zDISPCOUNTTéK”&"€›DUMPTREET_éKH”&)€GKDEBGDEFT__éKK”&3€„DEVDRT____éKL”&8€EXPRESSNT_éK[”'€ÁľFLOATT____éK+”'3€*kFLOATDEFT_éKH”'8€nFORWINITT_éKJ”'B€Ź {file assmdef} import codegen,genutils,globals,sysglobals; export $IF MC68020$ var divsl_reg : regrange; $END$ procedure emit2(opcode: opcodetype; var source,dest: attrtype); procedure emit1(opcode: opcodetype; var dest:FORWUTILSTéKL”'G€jGENCODET__éKMI”(€HtGENEXPDEFTéK–”(#€,GENEXPRT__éKœn”(9€m0GENMOVET__éK š”(I€™ GENUTILT__éK¤”)€JGENUTLDEFTéK§”)€lGENDEFT___éKś”)€ N attrtype); procedure emit0(opcode: opcodetype); GENMOVDEFTéKÄ”)€“GLOBALST__éKČG”)%€FFIDSEARCHT_éK ”02€ –INITT_____éKU”0@€TČINITCOUNTTéKp”0E€mINITDEFT__éKq”0P€ľIODEFT____éKr”0U€áLINKCOMPNTéKw”1Y€‚ {file ASSEMBLE} implement (*assemble*) type opsizetype = array[bytte..long] of 0..2; numopcodetype = array[opcodetype] of 0..15; ctodtype = array['0'..'9'] of 0..9; $IF MC68020$ subopcodetype = fmove..flognp1; LINKCOMPYTéKx”2€ˆMAINBODYT_éKy ”2$€ żMAKE_COMPTéK†”2)€iMC68881T__éK‹&”25€%§ASSEMBLET_]”$65€\BODYT_____Ü”$6@€˙BUILDTREETâ”$6E€\DEBGDEFT__ ”$6P€„ numsubopcodetype = array[subopcodetype] of 0..127; imm_or_reg = (imm,inreg); $END$ const immediateops = [addi,andi,cmpi,moveI,subi]; opsize = opsizetype[0,1,2]; numopcode = numopcodetype [13,13,0,5,{add} 12,0,{a     indexed addrmode } reg: regrange; case boolean of true: (islong: boolean; $IF not MC68020$ dummy: 0..7; disp: byt) $END$ $IF MC68020$ scale: 0..3; case bigdisplacement: boolean of false: (disp: byt); n for MOVEM *) var elem: 0..15; rt: regtype; rn: regrange; begin with extension[getextension],attr do begin wext := 0; {initialize mask to all zeroes } size := 2; for rt := A to D do for rn := 0 to maxreg do if regs[rt,rn] the true: (basesuppress: boolean; indexsuppress: boolean; disp_size: 0..3; index_indirect: 0..15; case integer of 0: (w_disp: shortint); 1: (l_disp: integer))); false: (Doffset: imm_or_reg; D_n begin elem := 8*ord(rt=A)+rn; if predecr then mask[elem] := true else mask[15-elem] := true; end; end; end; (*maskext*) procedure makeEA(var attr: attrtype); (* make effective address field of instruction refndd} 14,14,{ASd} 16 of 6,{BRA,Bcc} 4 of 0,{bit} 4,{CHK} 4,{CLR} 3 of 11,{cmp} 0,{CMPI} 8,{DIVS} $IF MC68020$ 4,{DIVSL} 4,{EXTB} 14,{BFEXTS} 14,{BFEXTU} 14,{BFINS} 0,{CHK2} $END$ 5 of 4,{EXT..LINK} 14,14,{LSd} 1,2{move & movea place holoffset: 0..31; Dwidth: imm_or_reg; D_width: 0..31) $END$ ); 5:(mask: packed array[0..15] of boolean); { for MOVEM } $IF MC68020$ 6: (sourcetype : 0..7; case boolean of true: (sourceFreg : 0..7; ders - opcode determined by size}, 4 of 4{MOVEtoCCR,MOVEfromSR,moveI(dummy, see movea),MOVEM},7{MOVEQ}, 12,{MULS} 4,4,{NEG,NOT} 8,{OR} 4,4,{PEA,RTS} 16 of 5{Scc}, 9,9,0,5{sub}, 5 of 4{SWAP..UNLK} $IF MC68020$ {68881 instructions} ,17 of 15 $E destFreg : 0..7; fop : 0..127); false:(fivebits : 0..31; fp0, fp1, fp2, fp3, fp4, fp5, fp6, fp7 : boolean)); 7: (w_ext: shortint; l_ext: integer); $END$ ND$ ]; $IF MC68020$ numsubopcode = numsubopcodetype [0{fmove},4{fsqrt},24{fabs},29{fcos},14{fsin},20{flogn},10{fatan}, 16{fetox},34{fadd},56{fcmp},32{fdiv},26{fneg},35{fmul},40{fsub}, 6{flognp1}]; $END$ ctod = ctodtype[0,1,2 end; function getextension: integer; begin if extension[1].size = 0 then getextension := 1 else getextension := 2; end; procedure extendint(i: integer; storage: stortype); (* create extension of appropriate size f,3,4,5,6,7,8,9]; var immediateop: boolean; instruction: packed record case integer of 1: (instropcode: 0..15; (* 12..15 *) case integer of 1: (cond: 0..15; displ: byt); 2: (reg1: 0..7; opmoor integer data *) var variantrec: packed record case integer of 0: (l: integer); 1: (wdummy: shortint; case integer of 0: (w: shortint); 1: (bdummy: byt; b: byt) ); end; begin variantrec.l := i; witde: 0..7; eamode: 0..7; eareg: 0..7); 3: (dummy: 0..7; bit8: boolean; size: 0..3) $IF MC68020$; 4: (Coprocid : 0..7; zeros : 0..7; morezeros: 0..63) $END$ );h extension[getextension] do case storage of bytte: begin size := 2; bext := variantrec.b end; wrd: begin size := 2; wext := variantrec.w end; long: begin size := 4; lext := variantrec.l end; $IF MC68020$ multi: if (i<= 32767) and (i>= -327 2: (instrout: shortint); end; extension: array[1..2] of packed record size: shortint; case integer of 1:(trash: byt; bext: byt); 2:(wext: shortint); 3:(lext: integer); 4:(regclass: 0..1; { 68) then begin size := 2; wext := variantrec.w; end else begin size := 4; lext := variantrec.l; end; $END$ end; (*case*) end; (* extendint *) procedure maskext(var attr: attrtype; predecr: boolean); (* emit mask extensio     lect attr *) var diff, refloc, {location of reference} targetloc {location being referenced} : integer; nametemp: alpha; bite,block: integer; reftemp: reflistptr; extension1temp: shortint; $IF MC68020$ displacement_fudge: shortint; {fond; inAreg: begin eamode := 1; eareg := regnum end; postincr: begin eamode := 3; eareg := regnum end; topofstack: begin eamode := 3; eareg := SP end; predecr: begin eamode := 4; eareg := regnum end; locinreg: begin extensir use with indexing addrmode} $END$ procedure svaltostring(valp: csp; var name: string); var k: integer; begin with valp^ do if cclass = paofch then begin name[0] := chr(slgth); for k := 1 to slgth do name[k] := sval[k]; on1temp := extension[1].size; eareg := regnum; if indexed then begin eamode := 6; extendindex(offset) end else if (offset = 0) and (gloptr = NIL) then eamode := 2 else begin $IF MC68020$ displacement_fudge := 0;  end else escape(-8); end; procedure extendindex(offset: integer); begin with attr,extension[getextension] do begin $IF not MC68020$ size := 2; dummy := 0; if offset >= 0 then disp := offset else disp := 256+offset; isl if (offset > 32767) or (offset < -32768) then begin eamode := 6; extendindex(offset); end else $END$ begin eamode := 5; extendint(offset,wrd) end; end; if gloptr <> NIL then {global variable, put out ref } begin ong := indexstorage = long; reg := indexreg; regclass := 0 {D}; $END$ $IF MC68020$ if (offset > 127) or (offset < -128) or ((addrmode = locinreg) and (gloptr <> NIL)) then begin displacement_fudge := 2; bigdisplacement := t refloc := codephile.bytecount+extension1temp+2 $IF MC68020$ + displacement_fudge $END$; if gloptr = currentglobal then begin outputref('',refloc,glob16); end else outputref(gloptr^,refloc,abs16); end; end; shortabs: rue; basesuppress := false; index_indirect := 0; { no indirect } if (offset > 32767) or (offset < -32768) then begin size := 6; disp_size := 3; l_disp := offset; if indexed then indexsuppress := false  begin eamode := 7; eareg := 0; if absaddr.intval then extendint(absaddr.ival+offset,wrd) else with absaddr.valp^ do begin svaltostring(absaddr.valp,nametemp); refloc := codephile.bytecount+extension[1].size+2; outputref(namete else indexsuppress := true; end else begin size := 4; indexsuppress := false; disp_size := 2; w_disp := offset; end; end else begin bigdisplacement := false; size := 2; mp,refloc,abs16); extendint(offset,wrd) end; end; longabs: begin eamode := 7; eareg := 1; if absaddr.intval then extendint(absaddr.ival+offset,long) else with absaddr.valp^ do begin svaltostring(absaddr.valp,nam if offset >= 0 then disp := offset else disp := 256+offset; end; regclass := 0 {D}; if indexed then begin scale := indexscale; islong := indexstorage = long; reg := indexreg; end else begin scale := 0etemp); refloc := codephile.bytecount+extension[1].size+2; outputref(nametemp,refloc,abs32); extendint(offset,long); end; end; prel: begin eamode := 7; if indexed then begin eareg := 3; extendindex(absaddr.ival+offset) end ; islong := false; reg := 0; end; $END$ end; end; begin (*makeEA*) with attr,instruction do case addrmode of inFreg: escape(-8); { Should be handled elsewhere } inDreg: begin eamode := 0; eareg := regnum e else begin eareg := 2; if absaddr.intval then extendint(absaddr.ival+offset,wrd) else with absaddr.valp^ do begin svaltostring(absaddr.valp,nametemp); refloc := codephile.bytecount+extension[1].size+2; if ((offse      ((offset-refloc) <= 32767) then begin outputref(namep^,refloc,rel16); extendint(offset-refloc,wrd); end else begin outputref(namep^,refloc,rel16v); extendint(offset,wrd); end; end; end;C68020$ if opcode = extb then opmode := 7 else $END$ if opcode = swap then opmode := 1 else opmode := 2+ord(dest.storage)-ord(wrd); eamode := 0; eareg := dest.regnum; end; jmp,jsr: begin reg1 := 7;  labelledconst: begin new(reftemp); reftemp^.next := constvalp^.conlbl; constvalp^.conlbl := reftemp; eamode := 7; eareg := 2; reftemp^.pc := codephile.bytecount+extension[1].size+2; extendint(offset,wrd); end; enum opmode := 2+ord(opcode = jmp); makeEA(dest); end; link: { treated as 1-address instr since displ always 0 } $IF MC68020$ if dest.storage = long then begin reg1 := 4; opmode := 0; eamode := 1; eareg := dest.regnt-refloc) >= -32768) and ((offset-refloc) <= 32767) then begin outputref(nametemp,refloc,rel16); extendint(offset-refloc,wrd); end else begin outputref(nametemp,refloc,rel16v); extendint(offset,wrd); const: begin new(reftemp); reftemp^.next := enumstp^.enumlbl; enumstp^.enumlbl := reftemp; eamode := 7; eareg := 2; reftemp^.pc := codephile.bytecount+extension[1].size+2; extendint(offset,wrd); end; end; (*case*)  end; end; end; end; immediate: begin eamode := 7; eareg := 4; extendint(smallval,storage) end; namedconst: with constptr^ do begin eamode := 7; refloc := codephile.bytecount+extension[1].size+2;  end; (*makeEA*) procedure emit0(*opcode: opcodetype*); (* emit zero-address instruction *) begin with instruction do begin instropcode := numopcode[opcode]; immediateop := opcode in immediateops; case opcode of rts: begin reg if isdumped then begin targetloc := offset+location; diff := targetloc-refloc; if (diff >= -32768) and (diff <= 32767) and not immediateop then begin eareg := 2; {pcrel} extendint(diff,wrd); end else if (callmode = abscall) or immedi1 := 7; opmode := 1; eamode := 6; eareg := 5 end; trapv: begin reg1 := 7; opmode := 1; eamode := 6; eareg := 6 end; end; (*case*) outputcodeword(instrout); end; end; (*emit0*) procedure emit1(*opcode: opcodetype; var dest: attrtype*); ateop then begin eareg := 1; {long absolute} outputref('',refloc,abs32); extendint(targetloc,long); end else begin if ((offset-refloc) >= -32768) and ((offset-refloc) <= 32767) then begin eareg := 2; { pc rel (* emit one-address instruction *) begin extension[1].size := 0; with instruction do begin instropcode := numopcode[opcode]; immediateop := opcode in immediateops; case opcode of bra..ble: begin cond := ord(opcode)-ord(bra); ative } outputref(namep^,refloc,rel16); extendint(offset-refloc,wrd); end else begin eareg := 1; {long absolute} outputref('',refloc,abs32); extendint(targetloc,long); end; end; end else {no with dest do if storage = bytte then if offset < 0 then displ := 256+offset else displ := offset else begin displ := 0; extendint(offset,wrd) end; end; clr,neg,nott,tst: begin if opcode = clr then reg1 := 1 else t isdumped} if (callmode = abscall) or immediateop then begin eareg := 1; {long absolute} outputref(namep^,refloc,abs32); extendint(offset,long); end else begin eareg := 2; { pc relative } if ((offset-refloc) >= -32768) and if opcode = tst then reg1 := 5 else if opcode = neg then reg1 := 2 else {nott} reg1 := 3; opmode := ord(dest.storage) - ord(bytte); makeEA(dest); end; $IF MC68020$ extb, $END$ ext,swap: begin reg1 := 4; $IF M     um; extendint(0,long); end else $END$ begin reg1 := 7; opmode := 1; eamode := 2; eareg := dest.regnum; extendint(0,wrd); end; movetoCCR,movefromSR: begin reg1 := 2*ord(opcode = movetoCCR);  >= -8) and (smallval <> 0) then (*quick*) if smallval > 0 then opcode := opq else begin smallval := -smallval; opcode := altopq end else if dest.addrmode = inAreg then opcode := opa else if (addrmode = immediate) and (dest.addrmode <> opmode := 3; makeEA(dest); end; pea: begin reg1 := 4; opmode := 1; makeEA(dest); end; st..sle: begin size := 3; cond := ord(opcode) - ord(st); makeEA(dest); end; trap: begin reg1 := 7; op inDreg) then opcode := opi else andoraddsub; end; (*addorsub*) begin (*emit2*) extension[1].size := 0; extension[2].size := 0; flip := false; if (source.addrmode = immediate) and (opcode <> moveq) $IF MC68020$ andmode := 1; eamode := dest.smallval div 8; eareg := dest.smallval mod 8; end; unlk: begin reg1 := 7; opmode := 1; eamode := 3; eareg := dest.regnum; end; $IF MC68020$ fblt: begin coprocid := 1; zeros :=  (dest.addrmode <> inFreg) $END$ then source.storage := dest.storage else if (source.addrmode = shortabs) and (dest.storage = long) and (opcode in [moveI,addi,andi,cmpi,subi]) then begin flip := true; source.addrmode := longabs end; with i2; morezeros := 20; extendint(dest.offset,wrd); end; $END$ end; (*case*) outputcodeword(instrout); with extension[1] do if size = 2 then outputcodeword(wext) else if size = 4 then outputcodelong(lext) $IF MC68020$ else ifnstruction do begin 1: instropcode := numopcode[opcode]; immediateop := opcode in immediateops; case opcode of add: begin addorsub; if opcode <> add then goto 1; end; adda,suba: with dest do begin reg1 := regnum;  size = 6 then begin outputcodeword(w_ext); outputcodelong(l_ext); end $END$; end; {with instruction} end; (*emit1*) procedure emit2(*opcode: opcodetype; var source,dest: attrtype*); (* emit two-address instruction  opmode := 3+4*ord(storage = long); makeEA(source); end; addi,subi,andi,cmpi: begin if opcode = andi then reg1 := 1 else if opcode = cmpi then reg1 := 6 else if opcode = addi then reg1 := 3 else (*subi*) reg1 :*) label 1; var k: 1..2; smode,sreg: 0..7; flip: boolean; procedure andoraddsub; (* process vanilla and, or, add or sub instruction *) begin with dest,instruction do begin opmode := ord(storage)-ord(bytte); if addrmode <> inDreg= 2; opmode := ord(dest.storage)-ord(bytte); if (source.addrmode = shortabs) and (dest.storage = long) then source.addrmode := longabs; makeEA(source); { produce extension, ignore fields in instr } makeEA(dest); end;  then begin opmode := opmode+4; reg1 := source.regnum; makeEA(dest); end else begin reg1 := regnum; makeEA(source) end; end; end; (*andoraddsub*) procedure addorsub; var opa,opi,opq,altopq: opcodetype; begin if opcode = addq,subq: begin reg1 := source.smallval mod 8; opmode := ord(dest.storage) - ord(bytte) + 4*(ord(opcode = subq)); makeEA(dest); end; andd,orr: andoraddsub; asl,asr,lsl,lsr: begin bit8 := (opcode = asl) or (opcode = lsl add then begin opa := adda; opi := addi; opq := addq; altopq := subq end else (* op = sub *) begin opa := suba; opi := subi; opq := subq; altopq := addq end; with source,instruction do if (addrmode = immediate) and (smallval <= 8) and (smallval); eamode := ord(opcode > asr); with dest do begin eareg := regnum; size := ord(storage) - ord(bytte); end; with source do if addrmode = immediate then reg1 := smallval mod 8 else begin reg1 := regnum; ea     torage = long} else reg1 := 2; opmode := 3; with extension[getextension] do begin size := 2; if dest.addrmode = inDreg then regclass := 0 {dest.addrmode = inAreg} else regclass := 1; reg := dest.regnum;  begin opcode := moveq; goto 1 end; instropcode := 2*ord(dest.storage <> bytte)+ord(dest.storage<> long); makeEA(source); smode := eamode; sreg := eareg; makeEA(dest); opmode := eamode; reg1 := eareg; eamode := smodislong := true; scale := 0; bigdisplacement := false; disp := 0; end; makeEA(source); end; $END$ chk,lea,divs,muls: begin reg1 := dest.regnum; if opcode = chk then begin $IF MC68020$ e; eareg := sreg; if opcode = moveI then { MOVE.L #, ... } eareg := 4; { change abs or named const to immediate } end; movem: begin instropcode := 4; opmode := 2+ord(dest.storage = long); ifmode := eamode+4 end; end; bchg,bclr,bset,btst: begin if source.addrmode = inDreg then begin reg1 := source.regnum; bit8 := true end else begin reg1 := 4; bit8 := false; extendint(source.smallval,wrd);  if dest.storage = long then opmode := 4 else $END$ opmode := 6; end $IF MC68020$ else if ((opcode = muls) or (opcode = divs)) and (dest.storage = long) then begin instropcode := 4; reg1 := 6; end; case opcode of btst: size := 0; bchg: size := 1; bclr: size := 2; bset: size := 3; end; makeEA(dest); end; $IF MC68020$ bfexts, bfextu: begin if opcode = bfexts then reg1 := with extension[getextension] do begin size := 2; regclass := 0; reg := dest.regnum; islong := true; scale := 0; bigdisplacement := false; if opcode = muls then begin opmode := 0; disp := 0; end else {opmode = divs} 5 else {opcode = bfextu} reg1 := 4; opmode := 7; with extension[getextension] do begin size := 2; regclass := 0; reg := dest.regnum; if source.bitoffset.variable = -1 then begin Doffset := imm;  begin opmode := 1; disp := reg; end; end; end $END$ else opmode := 7; makeEA(source); end; $IF MC68020$ divsl: begin reg1 := 6; with extension[getextension] do begin size :=  D_offset := source.bitoffset.static; end else begin Doffset := inreg; D_offset := source.bitoffset.variable; end; Dwidth := imm; D_width := source.bitsize; end; makeEA(source); end; bfins: begin 2; regclass := 0; reg := dest.regnum; islong := true; scale := 0; bigdisplacement := false; opmode := 1; disp := divsl_reg; end; makeEA(source); end; $END$ cmp,cmpa: with dest do reg1 := 7; opmode := 7; with extension[getextension] do begin size := 2; regclass := 0; reg := source.regnum; if dest.bitoffset.variable = -1 then begin Doffset := imm; D_offset := dest.bitoffset.static; begin reg1 := regnum; if addrmode = inAreg then opmode := 3 + 4*ord(storage = long) else opmode := ord(storage)-ord(bytte); makeEA(source); end; cmpm: with dest do begin eareg := source.regnum; eamode := 1 end else begin Doffset := inreg; D_offset := dest.bitoffset.variable; end; Dwidth := imm; D_width := dest.bitsize; end; makeEA(dest); end; chk2: begin if dest.storage = wrd then reg1 := 1 { s; opmode := 4+ord(storage)-ord(bytte); reg1 := regnum; end; move,movea,moveI: begin if dest.addrmode = inDreg then with source do if addrmode = immediate then if (smallval >= -128) and (smallval <= 127) then       dest.addrmode = multiple then begin reg1 := 6; maskext(dest,source.addrmode = predecr); makeEA(source); end else begin reg1 := 4; maskext(source,dest.addrmode = predecr); makeEA(dest); end;  sourceFreg := 4; long: sourceFreg := 0; multi: sourceFreg := 5; end; {case} end; end; $END$ end; (*case*) outputcodeword(instrout); for k := 1 to 2 do with extension[k] do if size = 2 then outputcodeword(wext)  end; moveq: begin reg1 := dest.regnum; bit8 := false; with source do if smallval >= 0 then displ := smallval else displ := 256+smallval; end; sub: begin addorsub; if opcode <> sub then goto 1; end; else if size = 4 then outputcodelong(lext) $IF MC68020$ else if size = 6 then begin outputcodeword(w_ext); outputcodelong(l_ext); end $END$; end; {with instruction} if flip then source.addrmode := shortabs; $IF MC68020$ fmovem: begin coprocid := 1; zeros := 0; with extension[getextension] do begin size := 2; fivebits := 16; if source.addrmode = fmultiple then begin sourcetype := 7; fp0 := source.fregs end; (*emit2*) [0]; fp1 := source.fregs[1]; fp2 := source.fregs[2]; fp3 := source.fregs[3]; fp4 := source.fregs[4]; fp5 := source.fregs[5]; fp6 := source.fregs[6]; fp7 := source.fregs[7]; makeEA(dest); end else begin sourcetype := 6; fp0 := {file BLOCK} procedure checkmodulefwptr(end_of_module: boolean); {Check pointer element types on the module's forward pointer list (from export section).} var tempid: alpha; lcp, nextfwdptr,tempmodulefwptr: ctp; begin  dest.fregs[0]; fp1 := dest.fregs[1]; fp2 := dest.fregs[2]; fp3 := dest.fregs[3]; fp4 := dest.fregs[4]; fp5 := dest.fregs[5]; fp6 := dest.fregs[6]; fp7 := dest.fregs[7]; makeEA(source); end; end; end; fmove..flognp1: w tempid := id; prterr := false; {save - restore} tempmodulefwptr := display[top].fmodule^.modinfo^.modulefwptr; while tempmodulefwptr <> NIL do begin if tempmodulefwptr^.idtype^.eltype = cant_deref then begin id := tempmodulefwptr^.nith extension[getextension] do begin size := 2; coprocid := 1; zeros := 0; fop := numsubopcode[opcode]; if (source.addrmode = inFreg) and (dest.addrmode = inFreg) then begin morezeros := 0; sourceFreg := souramep^; searchid([types],lcp); if lcp=NIL then begin if end_of_module then errorwithinfo(117,'Undefined type ' + tempmodulefwptr^.namep^);; end else tempmodulefwptr^.idtype^.eltype := lcp^.idtype; end else if end_of_module then ce.regnum; destFreg := dest.regnum; sourcetype := 0; end else if source.addrmode = inFreg then begin makeEA(dest); sourcetype := 3; destFreg := source.regnum; case dest.storage of bytte: sourceFreg := 6; wrd: sourceFreg : tempmodulefwptr^.idtype^.eltype := cant_deref; tempmodulefwptr := tempmodulefwptr^.next; end; id := tempid; prterr := true; end; {checkmodulefwptr} procedure checkfwptr(not_in_export: boolean); {Fix up pointer element types on = 4; long: sourceFreg := 0; multi: sourceFreg := 5; end; {case} end else {dest.addrmode = inFreg} begin makeEA(source); sourcetype := 2; destFreg := dest.regnum; case source.storage of bytte: sourceFreg := 6; wrd: forward pointer list. N.B: all pointers are forward till end of ctv declarations ala ISO.} var tempid: alpha; lcp, nextfwptr: ctp; begin tempid := id; prterr := false; {save - restore} while fwptr <> NIL do beg     BOL ELSE ERROR(14) END (* LABELDECLARATION *) ; PROCEDURE CONSTDECLARATION (fsys: setofsys; allowstructconst, externalmodule: boolean); VAR LCP: CTP; LSP: STP; LVALU: VALU; structconstnode: structnodeptr; S); WITH LCP^ DO BEGIN newident(namep,ID); IDTYPE := NIL; KLASS := TYPES; info := sysinfo; disdef.id := namep; END; INSYMBOL; IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16); ENTERID(LCP); TYP(FSYS + [SEMICOLON],LSP); LCP^.IDTYP BEGIN INSYMBOL; IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END; WHILE SY = IDENT DO BEGIN NEW(LCP,KONST); WITH LCP^ DO BEGIN newident(namep,ID); gnamep := namep; IDTYPE := NIL; NEXT := NIL; KLASS := KONST; info := sysE := LSP; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END END ELSE ERROR(14) END; (*while sy=ident*) disdef.level := -1; {restore} END (*TYPEDECLARATION*) in id := fwptr^.namep^; searchid([types],lcp); if lcp=NIL then if not_in_export then begin errorwithinfo(117,'Undefined type ' + fwptr^.namep^); fwptr := fwptr^.next; end else begin fwptr^.idtype^.eltype := cant_deref; neinfo END; INSYMBOL; IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16); CONSTANT(FSYS + [SEMICOLON],LSP,LVALU); if lsp <> NIL then begin if stdpasc then if not modcal and (lsp = anyptrptr) then error(606); if lxtfwptr := fwptr^.next; fwptr^.next := display[top].fmodule^.modinfo^.modulefwptr; display[top].fmodule^.modinfo^.modulefwptr := fwptr; fwptr := nextfwptr; end else begin fwptr^.idtype^.eltype := lcp^.idtype; fwptr := fwptr^.next; endsp^.form in [arrays,records,power] then with lvalu.valp^ do begin if stdpasc then if cclass <> paofch then error(606); if cclass = strctconst then begin isdumped := false; if not allowstructconst then error(6; end; id := tempid; prterr := true; end; {checkfwptr} PROCEDURE LABELDECLARATION (fsys: setofsys); VAR LLP: LABELP; TEST,REDEF: BOOLEAN; BEGIN INSYMBOL; REPEAT IF SY <> INTCONST THEN ERROR(15) else begin WITH D88); if importexportext then begin { Can't dump const now } new(structconstnode); with structconstnode^ do begin sp := lsp; val := lvalu; next := structconstlist; structconstlist := structconstnode; end; end elISPLAY[TOP] DO BEGIN LLP := FLABEL; REDEF := FALSE; WHILE (LLP <> NIL) AND NOT REDEF DO IF LLP^.LABVAL <> VAL.IVAL THEN LLP := LLP^.NEXTLAB ELSE BEGIN REDEF := TRUE; ERROR(166) END; IF NOT REDEF THEN BEGIN NEW(LLP); if vse begin if not hasbeenoutput then begin if not externalmodule then dumpstconst(lsp,lvalu); hasbeenoutput := true; end; if not saveconst then begin release(kstruc); kstruc := NIL end; end; end; end; end; al.ival > 9999 then error(163); WITH LLP^ DO BEGIN LABVAL := VAL.IVAL; NEXTLAB := FLABEL; defined := false; isrefed := false; nonlocalref := false; staticlevel := level; isnlrefed := false; END; FLABEL := ENTERID(LCP); LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END END ELSE ERROR(14) END; (*WHILE*) END (*CONSTDECLA LLP END; END; {with} INSYMBOL end; IF NOT (SY IN FSYS + [COMMA, SEMICOLON]) THEN BEGIN ERROR(6); SKIP(FSYS+[COMMA,SEMICOLON]) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = SEMICOLON THEN INSYMRATION*) ; PROCEDURE TYPEDECLARATION (fsys: setofsys); VAR LCP: CTP; LSP: STP; BEGIN INSYMBOL; IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END; disdef.level := top; WHILE SY = IDENT DO BEGIN NEW(LCP,TYPE     ; PROCEDURE VARDECLARATION (fsys: setofsys); VAR LCP,NXT,IDLIST,previousid: CTP; LSP: STP; lvalu: valu; TEST: BOOLEAN; BEGIN INSYMBOL; REPEAT NXT := NIL; REPEAT IF SY = IDENT THEN BEGIN NEW(LCP,VARS); WITH LCP^ DO BEGIN IDTYPE := LSP; if vtype = localvar then $PARTIAL_EVAL ON$ if top = 1 {main program} then begin if sawkeyboard and (namep^ = 'KEYBOARD') then if lsp <> textptr then error(184) else begin if idlist = nxt th DO BEGIN newident(namep,ID); NEXT := NXT; KLASS := VARS; IDTYPE := NIL; vtype := localvar; VLEV := LEVEL; info := sysinfo; if level = 1 then globalptr := curglobalname else globalptr := NIL; $PARTIAL_EVAL ON$ en idlist := next else previousid^.next := next; nxt := previousid; if not ucsd then enterid(keyboardptr); end else if sawlisting and (namep^ = 'LISTING') then if lsp <> textptr then error(184) else begin if idlis if ((sawkeyboard and (namep^ = 'KEYBOARD')) or (sawlisting and (namep^ = 'LISTING'))) and (top = 1) {main program} then else ENTERID(LCP); $IF not partialevaling$ $PARTIAL_EVAL OFF$ $END$ END; NXT := LCP; t = nxt then idlist := next else previousid^.next := next; nxt := previousid; if not ucsd then enterid(listingptr); end else begin vaddr := allocate(LC,lsp,false,1); previousid := nxt; end; end else INSYMBOL; if sy = lbrack then (* var x[absolute address]: ... *) begin if not (modcal or sysprog) then error(612); insymbol; constant(fsys+[rbrack,comma,colon],lsp,lvalu); if lsp = char_ptr then stretchpaofch VADDR := allocate(LC,lsp,false,1); $IF not partialevaling$ $PARTIAL_EVAL OFF$ $END$ IF NEXT = NIL THEN begin IF LSP <> NIL THEN IF (idlist <> NIL) and (mustinitialize in lsp^.info) THEN BEGIN (*PUT IDLIST INTO LOCar(lsp,lvalu,1); if (lsp <> intptr) and not paofchar(lsp) then error(50); lcp^.vtype := longvar; lcp^.absaddr := lvalu; if lsp <> intptr then begin (*symbolic address*) if sy = comma then begin insymbol; constant(fsyAL FILE LIST*) nxt^.NEXT := DISPLAY[TOP].FFILE; DISPLAY[TOP].FFILE := IDLIST; END; nxt := NIL; end else NXT := NEXT; END; if $IF MC68020$ (level = 1) and $END$ (lc < LClimit) then error(683); IF SY = SEMICOLON THEN s+[rbrack,comma,colon],lsp,lvalu); if lsp <> char_ptr then error(50) else case chr(lvalu.ival) of 'L','l': ; 'S','s': lcp^.vtype := shortvar; 'R','r': lcp^.vtype := relvar; otherwise error(50); end; BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END END ELSE ERROR(14) UNTIL (SY <> IDENT) AND NOT (SY IN TYPEDELS); END (*VARDECLARATION*) ; PROCEDURE PROCDECLARATION (fsys: setofsys);  end; (*sy=comma*) end; (*symbolic address*) if sy = rbrack then insymbol else error(12); end (*sy=lbrack*) END ELSE ERROR(2); IF NOT (SY IN FSYS + [COMMA,COLON] + TYPEDELS) THEN BEGIN ERROR(6); SKIP(FSYS+[COMMA,COLON,SEMICOLON]+TYPVAR FSY: SYMBOLS; OLDLEV,plsave: LEVRANGE; LCP: CTP; FORW,ipssave: BOOLEAN; OLDTOP: DISPRANGE; LLC: ADDRRANGE; MARKP: ^INTEGER; infosave: infobits; procedure procheader; label 1; var LCP1: CTP; LSP: STP; dummy, plc, llc: addrrange; lstateEDELS) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); IDLIST := NXT; previousid := NIL; TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP); WHILE NXT <> NIL DO WITH NXT^: modstateptr; lmarkstacksize: addrrange; waslparent: boolean; BEGIN IF SY = IDENT THEN BEGIN with display[top] do {Look for 'forward' declaration} if occur = MODULEscope then begin lstate := fmodule; repeat s     = IDENT *) ELSE BEGIN ERROR(2); LCP := UPRCPTR END; IF TOP < DISPLIMIT THEN BEGIN TOP := TOP + 1; with DISPLAY[TOP] do begin if FORW then begin (* skip conformant array dope vector parm(s) *) LCP1 := LCP^plc, lsp, true, parmalign); end; INSYMBOL; END ELSE BEGIN ERROR(2); SKIP(FSYS + [SEMICOLON]) END END ELSE IF NOT FORW THEN ERROR(123) END; (* procheader *) BEGIN (*PROCDECLARATION*) FSY := SY; aliasptr := NIL; aliasok := true;.next; (* and get to first explicit parm, which *) while LCP1 <> nil do (* will then also be top of sym tbl tree *) begin if LCP1^.namep <> NIL then goto 1; LCP1 := LCP1^.next; end; 1: FNAME := LCP1; end else  INSYMBOL; LLC := LC; LC := LCAFTERMARKSTACK; DP := TRUE; oldDP := true; infosave := sysinfo; sysinfo := []; OLDLEV := LEVEL; OLDTOP := TOP; IF LEVEL < MAXPLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(663); procheader; with lcp^ do earchsection(lstate^.defineids,lcp); lstate := lstate^.contmodule; until (lstate=NIL) or (lcp<>NIL); if lcp = NIL then searchsection(fname,lcp) end else searchsection(fname,lcp); FORW := FALSE; {default} IF LCP <> NIL THEN BEGIFNAME := NIL; FLABEL := NIL; FFILE := NIL; FMODULE := NIL; OCCUR := BLOCKscope; available_module := NIL; end; END ELSE ERROR(662); if oldlev = 1 then lmarkstacksize := level1markstacksize else lmarkstacksize := markstacksize; waN (* name already declared, check for FORWARD *) IF LCP^.FORWDECL THEN IF LCP^.KLASS = prox THEN FORW := ((FSY = PROCSY) and not lcp^.ismodulebody) ELSE IF LCP^.KLASS = FUNC THEN FORW := (FSY = FUNCSY); IF NOT FORW THEN if ((fsslparent := sy = lparent; llc := lc; lc := lcaftermarkstack; IF FSY <> funcsy THEN PARAMETERLIST(fsys,[SEMICOLON],LCP1,plc,forw,lmarkstacksize) ELSE PARAMETERLIST(fsys,[SEMICOLON,COLON],LCP1,plc,forw,lmarkstacksize); IF NOT FORWy = procsy) and (lcp^.klass = prox)) or ((fsy = funcsy) and (lcp^.klass = func)) then ERROR(160) END; IF NOT FORW THEN BEGIN IF FSY = PROCSY THEN begin NEW(LCP,prox,DECLARED); lcp^.klass := prox; lcp^.ismodulebody := false; e THEN begin LCP^.NEXT := LCP1; LCP^.paramlc := plc end else if waslparent then { paramlist was respecified } begin if stdpasc then error(606); if (plc <> lcp^.paramlc) or (llc <> lc) then error(171) else if not compparmlind else (* function *) begin NEW(LCP,FUNC,DECLARED); with lcp^ do begin klass := func; pfaddr := 0; assignedto := false; end; end; WITH LCP^ DO BEGIN newident(namep,ID); IDTYPE := NIL; paramlc := 0; PFDECKINDsts(lcp^.next,lcp1,true,true) then error(171); end; if forw then lc := llc; if fsy = funcsy then IF SY = COLON THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP1); if lcp1 <> NIL then begin LSP := L := DECLARED; forwdecl := false; extdecl := false; isexported := indefinesection; isdumped := false; isrefed := false; inscope := false; next := NIL; PFLEV := OLDLEV; info := infosave; END; ENTERID(LCP); END ELSE (* forward; mustCP1^.IDTYPE; if lsp = strgptr then error(733) else if lsp <> NIL then begin if cantassign in lsp^.info then error(751); if forw and (lsp <> lcp^.idtype) then error(171); end; LCP^.IDTYPE := LSP; IF LSP <> N update LC for copied value parms *) BEGIN LCP1 := LCP^.NEXT; WHILE LCP1 <> NIL DO BEGIN WITH LCP1^ DO if vtype=cvalparm then dummy := allocate(LC, idtype, false, 1); LCP1 := LCP1^.NEXT; END; END; insymbol; END (* SY IL THEN IF lsp^.form >= prok then begin lsp := anyptrptr; if stdpasc then error(606); end; {***** Machine dependent addr of function result area *****} plc := lcaftermarkstack+lmarkstacksize+LCP^.paramlc; LCP^.pfaddr := allocate(      begin alias := aliasptr <> NIL; if alias and forw then error(620); if alias then othername := aliasptr else othername := curglobalname; end; if not indefinesection then IF SY = SEMICOLON THEN INSYMBOL ELSE ERROp: ctp; inimplmntsection: boolean); { search files to satisfy an 'import' item } var libfile1: file of direntry; libentry: direntry; libfile2: file; tempwidth,templine: integer; tempdisplay: displayframe; templist: listsR(14); aliasok := false; IF indefinesection then begin if forw then error(667) else lcp^.forwdecl := true; end else if (sy=forwardsy) or ((sy=ident) and (id='FORWARD')) then begin IF FORW THEN ERROR(667) witch; tempfwptr: ctp; found,readerror,savedisplay,tempstdpasc, tempcode,tempmodcal,errorinimport,tempucsd: boolean; { Added for FSDdt04001. } prev_temp : boolean; p,i,libsize,blkno: shortint; buf: record case integer of 1: ELSE begin LCP^.FORWDECL := TRUE; lcp^.forwid := uniquenumber; end; insymbol; end else if (sy=externlsy) OR ((sy=ident) and (id='EXTERNAL')) then with lcp^ do (* EXTERNAL declaration *) begin if forwdecl then begin (modulentry: module_directory); 2: (pad: packed array[1..512] of byt); end; begin lcp := NIL; if strlen(id) <= fnlength then with buf do begin found := false; p := 0; repeat p := p + 1; close(libfile1); reset(libf forwdecl:=false; if pflev<>1 then error(666) else if not isexported then error(668); end; extdecl:=true; pflev := 1; if level <> 2 then warning(linenumber+1,'External declarations will be treated as global'); if not isexported then if noile1,searchlistptr^[p],'SHARED'); if IORESULT <> 0 then begin { don't give error for *syslib } if p <> searchfilestop then errorwithinfo(611,'Can''t open ' + searchlistptr^[p]); end else { read in library header } begin read(lt alias then othername := NIL; insymbol; end ELSE {not declared FORWARD, process procedure body} BEGIN MARK(MARKP); with lcp^ do begin FORWDECL := FALSE; INSCOPE := true; end; BLOCK(FSYS,SEMICOLON,LCP); if(lcp^.klass = func) ibfile1,libentry); if ioresult <> 0 then errorwithinfo(611,'Can''t access ' + searchlistptr^[p]) else begin readerror := false; libsize := libentry.dnumfiles; i := 1; while (i <= libsize) and not found anand not lcp^.assignedto then error(181); LCP^.INSCOPE := FALSE; RELEASE(MARKP); END; LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; sysinfo := infosave; DP := TRUE; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); IF NOT (SY d not readerror do begin read(libfile1,libentry); if ioresult <> 0 then begin readerror := true; errorwithinfo(611,'Can''t read ' + searchlistptr^[p]); end else if libentry.dtid = id then found := true; IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END; END (*PROCDECLARATION*); PROCEDURE FINDFORW (FCP: CTP); {Report missing forward procedures in tree rooted at fcp} BEGIN IF FCP <> NIL THEN WITH FCP^ DO BEGIN IF KLASS IN [prox,FUN i := i + 1; end; end; end; until (p = searchfilestop) or found; close(libfile1); if found then begin blkno := libentry.dfirstblk; reset(libfile2,searchlistptr^[p],'SHARED'); if blockread(libfile2,modulentry,1,blkno)C] THEN IF PFDECKIND = DECLARED THEN IF FORWDECL and not ismodulebody THEN errorwithinfo(117,'Missing procedure ' + namep^); FINDFORW(RLINK); FINDFORW(LLINK) END END (*FINDFORW*); procedure searchfiles(fsys: setofsys; var lc <> 1 then begin found := false; errorwithinfo(611,'Can''t open ' + searchlistptr^[p]); end else if srcindex >= maxinfiles then begin found := false; error(610); end else if modulentry.source_size = 0 then errorwithinfo(613,'Mod     p - 1; end; insymbol; moduledeclaration(fsys,true,false, display[top].available_module,false); if savedisplay then begin top := top + 1; display[top] := tempdisplay; end; { These are restored in checkend } (** lmodstate^ := lstate^; with lmodstate^ do begin modinfo^.needscall := false; nextmodule := display[top].available_module; end; display[top].available_module := lmodstate; lstate := lstate^.nextmodule**********************************) (* list := gtemplist; *) (* linenumber := gtemplinenumber; *) (* width := gtempwidth; *) (************************************) gtemplist := templist; fwptr := tempfwptr; ; end; lstate1 := gstate; { save gstate } if checkdefineconflicts(lcp1) then errorinimport := true; gstate := lstate1; { restore gstate } end; end; if lcp1 = NIL then begin searchfiles(fsys,lcp1,inimplmntsection)ule '+id+' in '+ searchlistptr^[p]+' does not have interface text') else if modulentry .system_id <> (ord(crevno[1])-ord('0')) then errorwithinfo(611,'Module '+ searchlistptr^[p] + ': Improper revision number') else begin with sourceinfoptgtemplinenumber := templine; gtempwidth := tempwidth; { FSDdt04001 : } temp_put := prev_temp; putcode := tempcode; modcal := tempmodcal; ucsd := tempucsd; stdpasc := tempstdpasc; { Removed for FSDdt04001 : } { if importexportext r^[srcindex] do begin oldsymcursor := symcursor; oldlinestart := linestart; oldfilepos := filepos; oldsymblk := symblk; oldrelinum := relinum; oldftype := ftype; end; srcindex := srcindex + 1; sourceinfoptr^[srthen outputsymbol; } lcp := modulectp; gstate := gcurstate; end; end; close(libfile2); end; { with buf } end; { searchfiles } procedure importsection(fsys: setofsys; var wheretolinkstate: modstateptr; inimplmntsection: bocindex].filename := searchlistptr^[p]; filepos := (pagesize * (blkno + modulentry.source_block)) DIV 2; close(source); reset(source,searchlistptr^[p],'SHARED'); with fibp(addr(source))^ do begin am := amtable^[untypedfile]; olean); label 1; var lcp,lcp1: ctp; lstate,lstate1,lmodstate: modstateptr; savedisplay,lmoreids, insymboldone,errorinimport: boolean; begin if sy <> ident then begin error(2); skip(fsys + [ident,exportsy,implmtsy,endsy]) end; fpos := filepos; end; relinum := 0; ftype := specil; symblk := 0; { not really used } getnextpage; templist := gtemplist; gtemplist := list; list := listnone; templine := gtemplinenumber; gtemplinenumber := linenumber; telmoreids := sy = ident; while lmoreids do begin insymboldone := false; prterr := false; savedisplay := display[top].occur = modulescope; if savedisplay then top := top - 1; (* search outside this module *) searchid([typmpwidth := gtempwidth; gtempwidth := width; width := 120; { FSDdt04001 : } prev_temp := temp_put; temp_put := putcode; tempcode := putcode; putcode := false; tempmodcal := modcal; modcal := true; tempucsd := ucsd; ucsd := tes,konst,vars,prox,func],lcp1); errorinimport := false; prterr := true; if savedisplay then top := top + 1; if lcp1 <> NIL then if (lcp1^.klass = prox) and lcp1^.ismodulebody then lcp1 := NIL; { find it another way } if rue; tempstdpasc := stdpasc; stdpasc := false; tempfwptr := fwptr; fwptr := NIL; savedisplay := not inimplmntsection and (display[top].occur = modulescope); if savedisplay then begin tempdisplay := display[top]; top := tolcp1 = NIL then begin searchavailablemodules(lcp1); if lcp1 <> NIL then 1: if (lcp1^.klass = prox) and lcp1^.ismodulebody then begin lstate := gstate^.defmodule; while lstate <> NIL do begin new(lmodstate);      ; if (lcp1 <> NIL) and ((level <> 1) or (top > display_ok_to_import)) then error(717); if lcp1 <> NIL then begin insymboldone := true; goto 1; end; end else if lcp1^.idtype=strgptr then error(104); if lcp1 = NIL then err begin if (klass = prox) or (klass = func) then isdumped := false else if (klass = konst) and not values.intval then with values.valp^ do if cclass = strctconst then isdumped := false; if llink <> NIL then checkbintree(llink)or(104) else if not errorinimport then begin if (lcp1^.klass = prox) and lcp1^.ismodulebody then if gstate=NIL then error(687) else begin {Import module} lstate := gstate^.modinfo^.laststate; {Find newest; if rlink <> NIL then checkbintree(rlink); end; end; procedure moduledeclaration(fsys: setofsys; mustbeabstract,forwardmodule: boolean; var wheretolinkstate: modstateptr; modulelist: boolean); var curmodinfo: modinfoptr; l instance} while lstate <> NIL do {Copy all instances into my USE list} begin new(lstate1); lstate1^ := lstate^; with lstate1^ do begin contmodule := NIL; nextmodule := wheretolinkstate; end; wheretolstate,lstate1,curmodstate: modstateptr; modinit1,modinit2: ctp; lsp: stp; newmodule,oldindefine: boolean; labsaddr: valu; oldtop: disprange; oldinfo: infobits; oldlc: addrrange; oldglobalname: alphaptr; oldstructconstlist: strucinkstate := lstate1; lstate := lstate^.contmodule; end; end else begin {Import identfier} if not modcal then error(612); new(lcp); lcp^ := lcp1^; enterid(lcp); (* add object to this module *) if (tnodeptr; procedure exportsection (fsys: setofsys); begin indefinesection := true; if not (sy in [constsy,typesy,varsy,procsy,funcsy, modulesy,endsy,implmtsy]) then begin error(710); skip(fsys) end; while sy in [constsy,typesylcp^.klass = types) and (lcp^.idtype <> NIL) then with lcp^.idtype^ do if (form = scalar) and (scalkind = declared) then begin (* add konsts *) lcp1 := fconst; while lcp1 <> NIL do begin new(lcp); lcp^ := lcp1^; e,varsy, procsy,funcsy,modulesy] do begin case sy of constsy: constdeclaration(fsys,not forwardmodule, not forwardmodule and mustbeabstract); typesy: typedeclaration(fsys); varsy: vardeclaration(fsys); modulesy: begin nterid(lcp); lcp1 := lcp1^.next end; end; { do not put an id out in interface text } if importexportext and putcode then begin moduleinit(curglobalname); importexportext := false; idinimport := true; end; end; end; {lcp1< if not modcal then error(612); moduledeclaration(fsys,true,true,curmodstate^.defmodule,false); end; procsy,funcsy: procdeclaration(fsys); end; {case} if not (sy in [constsy,typesy,varsy,procsy,funcsy, modulesy,endsy,implmtsy]) then >NIL} if not insymboldone then insymbol; lmoreids := sy=comma; if sy in [comma,semicolon] then insymbol else error(14); if lmoreids and (sy <> ident) then begin error(2); if sy = semicolon then begin insymbol; lmoreids begin error(710); skip(fsys) end; end; indefinesection := false; end; (* exportsection *) procedure undump(p: modstateptr); { after module codegen set the isdumped field to false for defined proxs, funcs, and structured consts }:= false; end; end; end; (*while moreids*) if not (sy in (fsys + [exportsy,implmtsy,endsy])) then begin error(6); skip(fsys + [exportsy,implmtsy,endsy]) end end; (* importsection *) procedure checkbintree(id: ctp); begin with id^ do  var modstatetemp: modstateptr; begin while p <> NIL do with p^ do begin if defineids <> NIL then checkbintree(defineids); modstatetemp := p^.defmodule; while modstatetemp <> NIL do begin undump(modstatetemp); modsta     ON(fsys,true,false); end; TYPESY: begin error(653); TYPEDECLARATION(fsys); end; VARSY: begin error(653); VARDECLARATION(fsys); end; procsy,funcsy: begin checkfwptr(true); checkmodulefwptr(false); procdeclaration(fsys+lay[top].available_module; while msp <> NIL do with msp^ do begin while (modinfo^.laststate <> NIL) and (integer(modinfo^.laststate) >= integer(heapsv)) do modinfo^.laststate:= modinfo^.laststate^.contmodule; msp := nextmodule[endsy]); end; forwardsy,externlsy,modulesy: begin checkfwptr(true); error(653); if sy = modulesy then moduledeclaration(fsys,false,false, display[top].available_module,false) else begin insymbol; moduledeclarat; end; release(heapsv); old_display_ok_to_import := display_ok_to_import; end; (* implmtsection *) procedure findmodule (fstate: modstateptr); {Search fstate chain for module with name = id} label 1; begin while fstate <> Ntetemp := modstatetemp^.nextmodule; end; p := p^.contmodule; end; end; {undump} procedure implmtsection; var heapsv: ^integer; lstate,msp: modstateptr; oldlev: levrange; oldlc: addrrange; old_display_ok_to_import: disprange; begin ion(fsys,true,false, display[top].available_module,false); end; end; importsy: begin error(653); insymbol; importsection(fsys,display[top].fmodule^.modinfo^.impmodule,true); end; end; {case} checkfwptr(true); checkmod old_display_ok_to_import := display_ok_to_import; display_ok_to_import := top + 1; mark(heapsv); if sy = labelsy then begin error(6); labeldeclaration(fsys) end; while sy in [constsy,typesy,varsy,modulesy, importsy,forwardsy,exteulefwptr(true); IF SY <> endsy THEN BEGIN ERROR(13); if sy = beginsy then insymbol else SKIP(fsys+[endsy]); END; (* Mark module body not forward *) with modinit1^ do begin forwdecl := false; inscope := true ernlsy] do case sy of CONSTSY: CONSTDECLARATION(fsys+[endsy],true,false); TYPESY: TYPEDECLARATION(fsys+[endsy]); VARSY: VARDECLARATION(fsys+[endsy]); forwardsy,externlsy,modulesy: begin if not modcal then error(612); checkfwptr(true); nd; if newmodule then with modinit2^ do begin forwdecl := false; inscope := true end; (* Find missing forward procedures *) findforw(display[top].fname); lstate := curmodstate; while lstate <> NIL do begin findforw(lstate^.defi checkmodulefwptr(false); case sy of modulesy: moduledeclaration(fsys,false,false, display[top].available_module,false); forwardsy: begin; insymbol; moduledeclaration(fsys,true,true, display[top].availneids); lstate := lstate^.contmodule end; (* handle initialization body *) oldlev := level; if level < maxplevel then level:=level+1 else error(663); oldlc := lc; lc := lcaftermarkstack; dp := false; olddp := false; linelevel := 0; able_module,false); end; externlsy: begin insymbol; moduledeclaration(fsys,true,false, display[top].available_module,false); end; end; end; importsy: begin if not modcal then error(612); insymbodisplay[top].flabel := NIL; { avoid additional errors } inbody := true; repeat body(fsys + [casesy],modinit1); if (sy <> semicolon) and (sy <> period) then begin error(14); skip(fsys + [semicolon,period]) end until sy in blockbegsl; importsection(fsys,display[top].fmodule^.modinfo^.impmodule,true); end; end; {case} while sy in [constsy,typesy,varsy,procsy,importsy, funcsy,externlsy,forwardsy,modulesy] do case sy of CONSTSY: begin error(653); CONSTDECLARATIys+[semicolon,period]; modinit1^.inscope := false; if newmodule then modinit2^.inscope := false; level := oldlev; lc := oldlc; if top = 2 then begin modulewrapup(true); undump(curmodstate); end; msp := disp     IL do if fstate^.modinfo^.modinitbody^.namep^ = id then begin gstate := fstate; goto 1 end else fstate := fstate^.nextmodule; gstate := NIL; {Report failure} 1:end; begin (* moduledeclaration *) if stdpasc then error(606edscall := true; isimplemented := false; impmodule := NIL; usemodule := NIL; useids := NIL; curindefine := false; modulefwptr := NIL; end; end else begin {Found new instance of old module} curmodin); oldlc := LC; oldtop := top; oldinfo := sysinfo; oldindefine := indefinesection; indefinesection := false; oldstructconstlist := structconstlist; structconstlist := NIL; sysinfo := []; LC := initmodLC; aliasptr := NIL; if sy = modulesy fo := gstate^.modinfo; modinit1 := curmodinfo^.modinitbody; with curmodinfo^ do begin if isimplemented then error(719); (* Restore state *) display[top].ffile := svffile; LC := svLC; DP := true; oldDP := true; then insymbol else error(715); if sy <> ident then begin error(2); id := '**undefmodule**' end else if strlen(id) > fnlength then error(689); (* Look for previous occurence of same module *) with display[top] do if occur = BLOCKscope th end; end; if level = 1 then begin oldglobalname := curglobalname; curglobalname := modinit1^.namep; end; if newmodule then modinit1^.othername := curglobalname; with curmodstate^ do {Init new module state} beginen findmodule(available_module) else {occur = MODULEscope} begin findmodule(available_module); lstate := fmodule; while (gstate = NIL) and (lstate <> NIL) do begin findmodule(lstate^.defmodule); lstate := lstate^.contmo modinfo := curmodinfo; defineids := NIL; nextmodule := NIL; defmodule := NIL; contmodule := curmodinfo^.laststate; end; with curmodinfo^, display[top] do begin laststate := curmodstate; fmodule := curmodstate; if sy = idedule; end; end; newmodule := (gstate = NIL); {Did I find one?} if top < displimit then {and new scope} begin top := top + 1; with display[top] do begin fname := NIL; ffile := NIL; flabel := NIL; fnt then insymbol; if sy = semicolon then insymbol else error(14); if (top = 2) and not mustbeabstract then begin modulewrapup(false); moduleinit(curglobalname); idinimport := false; end; if sy = importsy then module := NIL; occur := MODULEscope; available_module := NIL; end end else error(662); new(curmodstate); {Always create new instance} if newmodule then begin {Create new module} ne begin if (top = 2) and newmodule and not mustbeabstract then begin importexportext := true; importexportstart(curglobalname); symbolstart := symcursor - 6; outputsymbol; end; insymbol; fname := useids; importsection(fsys,cuw(curmodinfo); new(modinit1,prox,declared); with modinit1^ do begin newident(namep,id); idtype := NIL; next := NIL; info := []; klass := prox; pfdeckind := declared; isexported := true; alias := false; paramlc :=rmodinfo^.usemodule,false); useids := fname; end; fname := NIL; curindefine := true; (****************************************** * Module name is added at 1 level of the * * display greater than is expected for * * p 0; extdecl := false; inscope := false; forwdecl := true; isdumped := false; isrefed := false; ismodulebody := true; pflev := level; end; with curmodinfo^ do begin modinitbody := modinit1; laststate := NIL; neurposes of the import search mechanism * ******************************************) if newmodule then begin enterid(modinit1); top := top - 1; new(modinit2,prox,declared); modinit2^ := modinit1^; enterid(modinit     ymbol else error(13); end; (* Save state in modinforec & restore previous state *) svffile := ffile; svLC := LC; LC := oldlc; structconstlist := oldstructconstlist; end; {with curmodinfo^, display[top]} top := oldtop; sysi funcsy) do begin checkfwptr(true); procdeclaration(fsys); end; if sy in [constsy,typesy,varsy] then error(606); end; while sy in [constsy,typesy,varsy,importsy, forwardsy,externlsy,modulesy] do case sy onfo := oldinfo; indefinesection := oldindefine; if level = 1 then begin curglobalname := oldglobalname; if not mustbeabstract and (top = 1) then moduleinit(curglobalname); end; dp := true; if not forwardmodule then curmodif CONSTSY: CONSTDECLARATION(fsys,true,false); TYPESY: TYPEDECLARATION(fsys); VARSY: VARDECLARATION(fsys); forwardsy,externlsy,modulesy: begin checkfwptr(true); if level = 1 then {undump global id's} checkbintree(display[top2); { For syntactic reasons } top := top + 1; end; if sy = exportsy then begin if (top = 2) and not importexportext and newmodule and not mustbeabstract and not idinimport then begin importexportext := true; importexportsnfo^.isimplemented := true; curmodstate^.nextmodule := wheretolinkstate; {Add instance to list} wheretolinkstate := curmodstate; lstate1 := curmodstate; while lstate1 <> NIL do begin lstate := lstate1^.defmodule; while lstate <> tart(curglobalname); symbolstart := symcursor - 6; outputsymbol; end; insymbol; exportsection(fsys+[implmtsy,endsy]); end else if newmodule then error(714); curindefine := false; curmodstate^.defineids := fname; fname :NIL do with lstate^, modinfo^ do begin if not mustbeabstract then begin { make sure defined modules were implemented } if not isimplemented then begin errorwithinfo(706, (modinitbody^.namep^ + ': needs concrete instanc= NIL; if importexportext and not mustbeabstract and (top = 2) then begin importexportwrapup; importexportext := false; end; if not mustbeabstract and (top = 2) then while structconstlist <> NIL do with structce')); isimplemented := true; end; end else if not forwardmodule then isimplemented := true; lstate := nextmodule; end; lstate1 := lstate1^.contmodule; end; if modulelist then if sy = semicolon then begin insymboonstlist^ do begin if not val.valp^.hasbeenoutput then begin dumpstconst(sp,val); val.valp^.hasbeenoutput := true; end; structconstlist := next; end; checkfwptr(false); checkmodulefwptr(false); if sy = implmtl; if not (sy in [modulesy,forwardsy,externlsy]) then error(715); end else begin if sy <> period then error(14); end else { not modulelist } if sy = semicolon then insymbol else error(14); gcurstate := curmodstate; modulectp sy then {Concrete module} begin if mustbeabstract then error(720); insymbol; implmtsection; if (top <> 2) and (level = 1) then begin {Define symbol for this module's globals} if odd(oldlc) then oldlc := oldlc - 1; outpu:= curmodinfo^.modinitbody; end; (* moduledeclaration *) PROCEDURE BLOCK (*FSYS: SETOFSYS; FSY: SYMBOLS; FPROCP: CTP*); var lstate1,lstate2: modstateptr; BEGIN (*BLOCK*) if sy = labelsy then labeldeclaration(fsys); if level = 1 then mtextdef(curglobalname^,oldlc,oldglobalname^); {Add globals to enclosing module's globals} oldlc := oldlc + LC; end; end else begin {Abstract module} if not mustbeabstract then error(711); if sy = endsy then insoduleinit(curglobalname); if stdpasc then begin if sy = constsy then CONSTDECLARATION(fsys,true,false); if sy = typesy then TYPEDECLARATION(fsys); if sy = varsy then VARDECLARATION(fsys); while (sy = procsy) or (sy =     ].fname); case sy of modulesy: moduledeclaration(fsys,false,false, display[top].available_module,false); forwardsy: begin insymbol; moduledeclaration(fsys,true,true, display[top].available_module,false); end; gin symbol } BODY(FSYS + [CASESY],fprocp); IF SY <> FSY THEN BEGIN ERROR(6); SKIP(FSYS + [FSY]) END UNTIL (SY = FSY) OR (SY IN BLOCKBEGSYS); if level = 1 then modulewrapup(true); END (*BLOCK*) ;  externlsy: begin insymbol; moduledeclaration(fsys,true,false, display[top].available_module,false); end; end; end; importsy: begin if (level <> 1) and not modcal then error(612) else if stdpasc then error(606); i {file BODYDEFINE} import globals,compinit,compio,compdebug,symtable, sysglobals,codegen; export procedure bodyanalyzerinit; procedure body (fsys: setofsys; fprocp: ctp); procedure expression(fsys: setofsys); procedure setdeno(fsys: setofsysnsymbol; importsection(fsys,display[top].fmodule,false); end; end; {case} while sy in [constsy,typesy,varsy,procsy, funcsy,importsy,forwardsy,externlsy,modulesy] do case sy of CONSTSY: begin error(653); CONSTDECLARAT; settype: stp); function widenconst(var fsp: stp; var fvalu: valu; target: stp): boolean; ION(fsys,true,false); end; TYPESY: begin error(653); TYPEDECLARATION(fsys); end; VARSY: begin error(653); VARDECLARATION(fsys); end; procsy,funcsy: begin checkfwptr(true); proc {file BODYHEAD} implement type fileclass = (untyped,directfile,textphile,any); var donteval,varparm: boolean; procedure identproc(fsys: setofsys); forward; function newexpr: exptr; var lexp: exptr; begin new(lexp); with lexp^ do declaration(fsys); end; importsy: begin error(653); insymbol; importsection(fsys,display[top].fmodule,false); end; forwardsy,externlsy,modulesy: begin checkfwptr(true); error(653); if sy = modulesy then moduledeclaration(fsys,false begin ekind := xpr; etyptr := nil; attr := nil; num_ops := 1; { Most common case is 1 so make that the default } $IF FULLDUMP$ echain := nil; if inbody then begin lastexp^.echain := lexp; lastexp := lexp; enum :=,false, display[top].available_module,false) else begin insymbol; moduledeclaration(fsys,true,false, display[top].available_module,false); end; end; end; {case} checkfwptr(true); IF SY <> BEGINSY THEN BEGIN ERROR(17);  ectr; ectr := ectr+1; end; { used by tree dumper } $END$ end; newexpr := lexp end (*newexpr*); function newexplist: elistptr; { Get an expression-list node of the short form } var lp: elistptr; begin new(lp,false); with lp^ dSKIP(FSYS) END; DP := FALSE; oldDP := false; linelevel := 0; FINDFORW(DISPLAY[TOP].FNAME); lstate1 := display[top].available_module; while lstate1 <> NIL do begin if not lstate1^.modinfo^.isimplemented then begin errorwithinfo(7o begin expptr := nil; nextptr := nil end; newexplist := lp end (*newexplist*); function arithtype(fsp: stp): boolean; { Returns true if type is integer, real or longreal } begin if fsp = intptr then arithtype := true else if fsp = shortin06, lstate1^.modinfo^.modinitbody^.namep^ + ': needs concrete instance'); lstate1^.modinfo^.isimplemented := true; end; lstate1 := lstate1^.nextmodule; end; inbody := true; REPEAT if sy = beginsy then insymbol; { eat up the betptr then arithtype := true else if fsp = realptr then arithtype := true else arithtype := false; end; {arithtype} function widenconst(var fsp: stp; var fvalu: valu; target: stp): boolean; var lval: integer; begin widenconst := false; if (     ^.maxleng then begin paofcharcomp:=true; if not strgtype(etyptr) then begin stretchpaofchar(etyptr,litval,dlgth); etyptr^.aisstrng:=true; etyptr^.unpacksize:=dlgth+1; litval.valp^.cclass := strng; end; end; end bias := k DIV (oldsethigh + 1); rel_elem := k MOD (oldsethigh + 1); s := pval; for j := 1 to bias do s := s^.nxt; if rel_elem in s^.val then $end$ $if not bigsets$ if k in pval then $end$ begin error(; end else if isPAC(desttyptr^.inxtype) then begin dlgth := desttyptr^.inxtype^.max; if etyptr = char_ptr then begin stretchpaofchar(etyptr,litval,dlgth); paofcharcomp := true; end else if paofchar(etyptr) then if litval.valp182); k := plgth end else k := k+1; $if bigsets$ end; (* while k < lmin... *) $end$ end; end; (*power*) end; (*checkconst*) procedure checkint; begin with curexp^ do if (etyptr<>nil) and (etyptr<>intarget=realptr) and (fsp=intptr) then with fvalu do begin lval := ival; fsp := realptr; intval := false; new(valp,true,reel); with valp^ do begin cclass := reel; rval := lval end; widenconst := true; end; en^.cclass = paofch then begin if litval.valp^.slgth < dlgth then stretchpaofchar(etyptr,litval,dlgth); paofcharcomp := litval.valp^.slgth = dlgth; end; end; {isPAC} end; {paofcharcomp} function strgvalue(expr: exptr): booled; {widenconst} function trytowiden(var fexp: exptr; newtype: stp): boolean; (* attempt arithmetic widening coercion on fexp *) var lsp: stp; lexp: exptr; begin trytowiden := false; lsp := fexp^.etyptr; if (lsp = intptr) or (lsp = shortintptr) tan; {determine whether an expression can be considered a string} begin strgvalue := false; with expr^ do if strgtype(etyptr) then strgvalue := true else if eclass = litnode then if etyptr = char_ptr then strgvalue := true else if hen if newtype=realptr then if fexp^.eclass = litnode then trytowiden := widenconst (fexp^.etyptr,fexp^.litval,realptr) else begin (* insert floatnode between fexp and fexp^ *) lexp := newexpr; with lexp^ do begin eclpaofchar(etyptr) then strgvalue := litval.valp^.cclass = paofch; end; procedure checkconst(dest: stp; source: exptr); {check constant to be assigned to object of type 'stp'; assumes compatible types} var lmin,lmax: integer; $if not bigsets$ k:ass := floatnode; ekind := xpr; etyptr := newtype; opnd := fexp; end; fexp := lexp; trytowiden := true; end; end; (*trytowiden*) function shortintandint(fsp1,fsp2: stp): boolean; begin shortintandint := ((fsp1 = intptr) or (fsp1 = shortintpt shortint; $end$ $if bigsets$ k : integer; s : setrecptr; (* current set record item *) j : shortint; (* simple counter *) bias, rel_elem: shortint; (* ordinal bias and relative elem *) $endr)) and ((fsp2 = intptr) or (fsp2 = shortintptr)); end; function paofcharcomp(source: exptr; desttyptr: stp): boolean; { assignment compatibility for packed arrays of characters;} var dlgth: integer; begin paofcharcomp := false; with sourc$ begin if (source^.eclass = litnode) and (dest <> NIL) then with source^ do if (dest <> intptr) and (dest^.form <= subrange) then begin getbounds(dest,lmin,lmax); if (litval.ival < lmin) or (litval.ival > lmax) then error(303); end e^ do if paofchar(desttyptr) and (eclass = litnode) then if desttyptr^.aisstrng then begin if (etyptr = char_ptr) or paofchar(etyptr) then begin if etyptr=char_ptr then dlgth:=1 else dlgth:= litval.valp^.slgth; if dlgth <= desttyptr else if (dest^.form = power) and (dest^.elset <> NIL) then begin getbounds(dest^.elset,lmin,lmax); with litval.valp^ do if plgth-1 > lmax then error(182) else begin k := 0; while (k < lmin) and (k < plgth) do $if bigsets$ begin      tptr) and (etyptr<>shortintptr) then error(125); end; function integerparm(fsys: setofsys): elistptr; var lexp: elistptr; begin lexp := newexplist; expression(fsys+[comma,rparent]); checkint; lexp^.expptr := curexp; integerparm := lexp;  newwords(valp,(sizeof(constrec,true,strng) -(strglgth-strlen(s))+1) div 2); with valp^ do begin cclass := strng; slgth := strlen(s); moveleft(s[1],sval,strlen(s)); end; end; end; makestrparm := lexp; end; functio end; function charparm(fsys: setofsys): elistptr; var lexp: elistptr; begin lexp := newexplist; expression(fsys+[comma,rparent]); with curexp^ do if (etyptr<>nil) and (etyptr<>char_ptr) then error(125); lexp^.expptr := curexp; charparm := n stringparm(fsys: setofsys): elistptr; var lexp: elistptr; begin lexp := newexplist; expression(fsys+[comma,rparent]); with curexp^ do if (etyptr<>nil) then if not strgvalue(curexp) then begin error(125); etyptr := NIL; end lexp; end; function anyparm(fsys: setofsys; isvar: boolean): elistptr; var lexp: elistptr; begin lexp := newexplist; expression(fsys+[comma,rparent]); with curexp^ do if ekind = vrbl then begin if etyptr<>nil then if eclass = se else if not strgtype(etyptr) then begin if etyptr=char_ptr then stretchpaofchar(etyptr,litval,1) else stretchpaofchar(etyptr,litval,litval.valp^.slgth); with etyptr^ do begin aisstrng := true; maxleng := etyptr^.unpacksize; ulnnode then begin if fieldptr^.fispackd then error(125) end else if eclass = unqualfldnode then begin if fieldref^.fispackd then error(125) end else if eclass = subscrnode then if arayp^.etyptr<>nil then with arayp^.etyptr^ do if aisnpacksize := unpacksize+1; end; litval.valp^.cclass := strng; end; lexp^.expptr := curexp; stringparm := lexp; end; function fileparm(fsys: setofsys; fclass: fileclass): elistptr; var lexp: elistptr; begin lexp := newexplist; expressionpackd then if not (aelbitsize in [8,16]) then error(125); end else if ekind = xpr then error(125) else {ekind = cnst} if isvar then error(125) else if eclass = litnode then begin with litval do if intval then error(125) (fsys+[comma,rparent]); with curexp^ do if (etyptr<>nil) then if etyptr^.form <> files then error(125) else case fclass of untyped: if etyptr^.filtype <> nil then error(125); directfile: if (etyptr = textptr) or (etyptr^.filtype = nelse if valp^.cclass < pset then error(125); end; lexp^.expptr := curexp; anyparm := lexp; end; function makeintparm(i: integer): elistptr; var lexp: elistptr; begin lexp := newexplist; lexp^.expptr := newexpr; with lexp^.expptr^ do begin eclail) then error(125); textphile: if etyptr <> textptr then error(184); any: ; end; lexp^.expptr := curexp; fileparm := lexp; end; function makefileexp(fileptr: ctp): exptr; var fileexp: exptr; begin fileexp := newexpr; with fileexp^ do begss := litnode; ekind := cnst; etyptr := intptr; with litval do begin intval := true; ival := i end; end; makeintparm := lexp; end; function makestrparm(s: string255): elistptr; var lexp: elistptr; begin lexp := newexplist; lexp^.expptr := newexpin ekind := vrbl; eclass := idnode; etyptr := textptr; symptr := fileptr; end; makefileexp := fileexp; end; procedure actparmlist (fsys: setofsys; var actualptr: elistptr; formalptr: ctp); var lexp: elistptr; procedure actualroutine(formr; with lexp^.expptr^ do begin eclass := litnode; ekind := cnst; new(etyptr,arrays,true,true); etyptr^ := strgptr^; with etyptr^ do begin maxleng := strlen(s); unpacksize := maxleng+1; end; with litval do begin intval := false; alptr: ctp); begin donteval := true; {change state of expression analyzer} expression(fsys+[comma,rparent]); donteval := false; with curexp^ do if etyptr <> nil then if not (etyptr^.form in [prok,funk]) then error(127) else if not       array^.aeltype = fexptype^.aeltype) then begin conformable := false; goto 1; end; end; if cnfarray^.aispackd or fexptype^.aispackd then conformable := (cnfarray^.aispackd = fexptype^.aispackd) and not fexptype^.aisstrng else conformab firstparmtype := curexp^.etyptr; end; end else if curexp^.etyptr <> firstparmtype then error(127); end; end; goto 1; end else if (vtype=refparm) or (vtype=strparm) then error(127) else if (vtype = anyvarparm) le := cnfarray^.strucwaspackd = fexptype^.strucwaspackd; end; 1: end; {conformable} begin if (formalptr^.idtype <> nil) and (curexp^.etyptr <> nil) then begin if comptypes(curexp^.etyptr,formalptr^.idtype) then begin if (curexp^then {ok} else (*check for possible coercions*) if arithtype(curexp^.etyptr) and arithtype(idtype) then begin if not trytowiden(curexp,idtype) then error(127) end else if not paofcharcomp(curexp,idtype) then error(127); if compparmlists(formalptr^.proktype^.params,etyptr^.params,false,false) then error(127) else if formalptr^.vtype = funcparm then begin if etyptr^.form <> funk then error(127) else if symptr^.idtype <> formalptr^.idtype then error(127) end el.eclass = litnode) and (formalptr^.vtype <> refparm) and (formalptr^.vtype <> strparm) then checkconst(formalptr^.idtype,curexp) end else with formalptr^ do if vtype = dopeparm then begin { Conformant array parameters } { se {formal is procedure parm} if etyptr^.form <> prok then error(127); end; {actualroutine} procedure checkparm(var formalptr: ctp); label 1; var doneptr: ctp; firstparmtype: stp; parm1err: boolean; function conformcoerce a single char literal to a packed array of char } if (curexp^.etyptr = char_ptr) and (curexp^.eclass = litnode) then stretchpaofchar(curexp^.etyptr,curexp^.litval,1); doneptr := formalptr^.firstparm; formalptr := formalptr^.nexable(cnfarray,fexptype: stp): boolean; label 1; var cnfmin,cnfmax,fexpmin,fexpmax : integer; begin conformable := true; if (cnfarray <> NIL) and (fexptype <> NIL) then begin if (fexptype^.form <> arrays) and (fexptype^.fort; firstparmtype := curexp^.etyptr; parm1err := false; if not conformable(formalptr^.idtype,curexp^.etyptr) then begin error(127); parm1err := true; end else if formalptr^.vtype = refparm then begin if curexp^.ekindm <> cnfarrays) then begin conformable := false; goto 1; end; if (cnfarray^.inxtype <> NIL) and (fexptype^.inxtype <> NIL) then begin if not comptypes(cnfarray^.inxtype,fexptype^.inxtype) then begin conformable := false; goto 1; end else  <> vrbl then error(127); end else {formalptr^.vtype = cvalparm} begin if curexp^.etyptr^.form = cnfarrays then error(127); end; while (formalptr <> NIL) and (formalptr <> doneptr) and (sy = comma) do be begin getbounds(cnfarray^.inxtype,cnfmin,cnfmax); getbounds(fexptype^.inxtype,fexpmin,fexpmax); if (fexpmin < cnfmin) or (fexpmax > cnfmax) then begin conformable := false; goto 1; end; end; end; if (cnfarray^.aeltype <>gin lexp^.expptr := curexp; lexp^.nextptr := newexplist; lexp := lexp^.nextptr; insymbol; expression(fsys + [comma,rparent]); formalptr := formalptr^.next; if formalptr^.vtype = refparm then if curexp^.eki NIL) and (fexptype^.aeltype <> NIL) then begin if cnfarray^.aeltype^.form = cnfarrays then begin if not conformable(cnfarray^.aeltype,fexptype^.aeltype) then begin conformable := false; goto 1; end; end else if not (cnfnd <> vrbl then error(127); if (curexp^.etyptr <> NIL) then begin if parm1err then begin if not conformable({original formalptr^}idtype, curexp^.etyptr) then error(127) else begin parm1err := false;       (formalptr^.vtype = refparm) or (formalptr^.vtype = strparm) or (formalptr^.vtype = anyvarparm) then with curexp^ do begin if ekind <> vrbl then error(154) else if (formalptr^.idtype <> curexp^.etyptr) and (formalptr^.idtype <> any begin lexp^.nextptr := newexplist; lexp := lexp^.nextptr end; until sy <> comma; if formalptr <> nil then error(126) end (*actparmlist*); procedure getvariantsize (fsys: setofsys; fsp: stp; var fsize: addrrange); {Subroutine for NEW,DISPOSE,SIZEptrptr) and (etyptr <> anyptrptr) and (formalptr^.idtype <> anyfileptr) and (formalptr^.idtype <> strgptr) and (formalptr^.vtype <> anyvarparm) then error(154) else if (eclass = selnnode) or (eclass = unqualfldnode) thenOF: scan list of variant names} {FSP is ptr to TAGFLD structure (if any); FSIZE is updated to actual size} label 1; var lsp: stp; lvalu: valu; btemp: boolean; begin while sy = comma do begin insymbol; btemp := inbody; inbody := false; begin if fieldptr^.fispackd or (fieldptr^.strucwaspackd and (not allow_packed)) then if not (allow_packed and (formalptr^.vtype = anyvarparm)) then error(154); end else if eclass = subscrnode then with arayp^ do  {don't save expression node for constant } constant(fsys+[comma,rparent],lsp,lvalu); inbody := btemp; if fsp = nil then error(158) else begin if fsp^.tagfieldp <> nil then {validate type of selector} if not comptypes(fsp if etyptr <> nil then if (etyptr^.aispackd and not paofchar(etyptr)) or (etyptr^.strucwaspackd and (not allow_packed)) then if not (allow_packed and (formalptr^.vtype = anyvarparm)) then error(154); if etyptr^.form = subrange then ^.tagfieldp^.idtype,lsp) then error(111); lsp := fsp^.fstvar; {look for variant} while lsp <> nil do {LSP is ptr to VARIANT struct} with lsp^ do if (lvalu.ival >= varval.lo) and (lvalu.ival <= varval.hi) th etyptr := etyptr^.rangetype; end; {with curexp^} if (formalptr^.vtype = anyvarparm) and (curexp^.ekind <> vrbl) then error(154); end; {types <> nil} 1: end; {checkparm} begin (*actparmlist*) lexp := newexplist; actualptr := lexp;en begin fsize := unpacksize; fsp := subvar; goto 1 end else lsp := nxtvar; fsize := fsp^.unpacksize; fsp := nil; {no variant for this case} end; 1:end; end; {getvariantsize} procedure selector (fsys: setofsys); var oldvarpar repeat insymbol; if formalptr = nil then begin expression(fsys+[comma,rparent]); error(126); end else begin if formalptr^.klass = routineparm then actualroutine(formalptr) else begin {formal not routine}m: boolean; procedure subscription (fsys: setofsys); var larray,lsub: exptr; lsp: stp; lmin,lmax: integer; begin repeat larray := curexp; insymbol; expression(fsys+[comma,rbrack]); lsp := larray^.etyptr; lsub := newe with formalptr^ do if (vtype = refparm) or (vtype = strparm) or (vtype = anyvarparm) then varparm := true; expression(fsys+[comma,rparent]); { Check for FOR loop index variable } if varparm and (curexp^.eclass = idnode) then if xpr; with lsub^ do begin eclass := subscrnode; ekind := larray^.ekind; arayp := larray; indxp := curexp; if lsp <> nil then if (lsp^.form <> arrays) and (lsp^.form <> cnfarrays) then begin error(138); etyptr := nil end else (*check*) cantassign in curexp^.symptr^.info then error(702); varparm := false; checkparm(formalptr); end; {formal not routine} formalptr := formalptr^.next; end; lexp^.expptr := curexp; if sy = comma then (* extend parameter list *)  begin etyptr := lsp^.aeltype; if not comptypes(lsp^.inxtype,indxp^.etyptr) then error(139); if indxp^.eclass = litnode then begin if strgtype(lsp) then begin lmax := lsp^.maxleng; lmin := ord(not ucsd); end       else error(141) end; insymbol; curexp := lderf; end (*dereference*); begin (*selector*) oldvarparm := varparm; varparm := false; if not (sy in selectsys + fsys) then begin error(59); skip(selectsys+fsys) end; while sy in seleld (fcp: ctp); (* create tree for unqualified field reference within WITH stmt scope *) begin curexp := newexpr; with curexp^ do begin eclass := unqualfldnode; ekind := vrbl; etyptr := fcp^.idtype; fieldref := fcp; withsctsys do begin if sy = lbrack then subscription(fsys) else if sy = period then selection(fsys) else dereference(fsys); if not (sy in fsys+selectsys) then begin error(59); skip(fsys+selectsys) end end; varparm := oldvarparm; tptr := display[disx].wnodeptr; {link back to WITH stmt node} end; insymbol; end (*unqualfield*);  else getbounds(lsp^.inxtype,lmin,lmax); if (indxp^.litval.ival < lmin) or (indxp^.litval.ival > lmax) then error(302); end; end; {check} end; (*with lsub^*) curexp := lsub; until sy <> comma; if sy = rbrack then  end (*selector*); procedure literals; (* parse literal in an expression *) begin curexp := newexpr; with curexp^ do begin ekind := cnst; eclass := litnode; litval := val; case sy of intconst: etyptr := intptr; realinsymbol else error(12); end; (*subscription*) procedure selection (fsys: setofsys); var lcp: ctp; lsp: stp; lseln: exptr; begin insymbol; if sy <> ident then begin error(2); skip(fsys+selectsys) end else begin lsp := curexconst: etyptr := realptr; stringconst: if lgth = 1 then etyptr := char_ptr else etyptr := makepaofchartype(lgth); end (*case*) end (*with curexp^*); insymbol; end (*literals*); procedure constid (fcp: ctp); (* create tree for p^.etyptr; if lsp <> nil then if lsp^.form <> records then error(140) else begin searchsection(lsp^.fstfld,lcp); lseln := newexpr; with lseln^ do begin eclass := selnnode; ekind := curexp^.ekind; recptr := curexp; fieldptr := lcpconstant identifier *) begin curexp := newexpr; with curexp^ do begin eclass := litnode; ekind := cnst; etyptr := fcp^.idtype; litval := fcp^.values; with litval do if not intval then case valp^.cclass of reel: ; if lcp = nil then begin etyptr := nil; error(152) end else etyptr := lcp^.idtype; end; curexp := lseln end; (*form is record*) insymbol; end; (*sy = ident*) end; (*selection*) procedure dereference (fsys: setofsys)begin new(valp,true,reel); with valp^,fcp^.values do begin cclass := valp^.cclass; rval := valp^.rval end; end; paofch: {copy to allow later coercion to string} with fcp^.values.valp^ do begin newwords(valp,(sizeof(const; var lderf: exptr; lsp: stp; begin lderf := newexpr; with lderf^ do begin eclass := derfnode; ekind := vrbl; opnd := curexp; (* type check *) lsp := curexp^.etyptr; if lsp <> nil then if lsp^.form = pointer trec,true,strng) - (strglgth-slgth)+1) div 2); valp^.cclass := paofch; valp^.slgth := slgth; moveleft(sval[1],valp^.sval[1],slgth); end; otherwise {don't copy} end;{case} end; insymbol; end (* constid *); procedure varhen begin if (lsp=anyptrptr) or (lsp^.eltype=cant_deref) then error(701); etyptr := lsp^.eltype; end else if lsp^.form = files then begin etyptr := lsp^.filtype; eclass := bufnode; if etyptr = NIL then error(6); end iable (fcp: ctp); (* create tree for variable *) begin curexp := newexpr; with curexp^ do begin eclass := idnode; ekind := vrbl; etyptr := fcp^.idtype; symptr := fcp; end; insymbol; end (*variable*); procedure unqualfie       {file BODY} procedure body (*fsys: setofsys; fprocp: ctp*); var llp: labelp; curbody,lastmt: stptr; lmark: ^integer; i: integer; s: string[10]; function max(i,j: shortint): shortint; begin if i > j then max := i elsOP, ADDOP,RELOP,SETSY,PACKEDSY,ARRAYSY, RECORDSY,FILESY,modulesy,importsy, exportsy,implmtsy,othrwisesy,rangesy, dollarsy,OTHERSY, {***** MODCAL SYMBOLS *****} FORWARDSY,externlsy,trysy,recoversy, anyvarsy); vare max := j; end; BEGIN {body} mark(lmark); WRITELN(OUTPUT); IF FPROCP <> NIL THEN writeln(output,fprocp^.namep^, ' ':max(17-strlen(fprocp^.namep^),0), '[',memavail:1,']'); WRITE(OUTPUT,'<',linenumber:5,'>'); STARTDOTS := S keyword: array[1..50] of keywordnode; middle,i,last: shortint; outfile: text; function split(lo,hi: shortint): shortint; var middle: shortint; begin if hi > lo then begin middle := (hi + lo) div 2; keyworCREENDOTS; syntxerr := false; $IF FULLDUMP$ sctr := 1; ectr := 1; new(firstexp); firstexp^.echain := nil; lastexp := firstexp; $END$ body_try_level := 0; { JWH 9/26/91 } parsing_try_level := 0; { JWH 9/26/91 } stmtlist(curbody,lastmt,fsyd[middle].left := split(lo,middle-1); keyword[middle].right := split(middle+1,hi); split := middle; end else if hi = lo then begin split := lo; keyword[lo].left := 0; keyword[lo].right := 0; end else s+[semicolon,endsy]); lastmt^.next := newstmt(endofbodyst,not fprocp^.ismodulebody); IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13); LLP := DISPLAY[TOP].FLABEL; (* CHECK UNDEFINED LABELS *) WHILE LLP <> NIL DO WITH LLP^ DO BEGIN IF NOTsplit := 0; end; begin rewrite(outfile,'symtree.text'); last := 1; with keyword[last] do begin name := 'AND'; pos := ord(mulop); kind := 2; end; last := last + 1; with keyword[last] do begin name := 'ANYVAR';  DEFINED THEN begin setstrlen(s,0); strwrite(s,1,i,labval:1); ERRORwithinfo(168,'Label: '+s); end; defined := false; isrefed := false; { for later use in codegen } LLP := NEXTLAB; END; if putcode and (totalerrors = 0) then genb pos := ord(anyvarsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'ARRAY'; pos := ord(arraysy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'BEGIN'; pos :ody(curbody,fprocp); if tables and not syntxerr then dumptree(curbody,fprocp); release(lmark); inbody := false; END (*body*); procedure bodyanalyzerinit; begin {bodyanalyzer initialization body} donteval := false; varparm := false; end; = ord(beginsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'CASE'; pos := ord(casesy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'CONST'; pos := ord(consprogram makesymtree; type shortint = -32768..32767; keywordnode = record name: string[20]; left,right: shortint; pos,kind: shortint; end; SYMBOL = (IDENT,COMMA,COLON,SEMICOLON,LPARENT, RPARENT,DOSY,TOSY,DOWNTOSY,Etsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'DIV'; pos := ord(mulop); kind := 3; end; last := last + 1; with keyword[last] do begin name := 'DO'; pos := ord(dosy); kind := NDSY, UNTILSY,OFSY,THENSY,ELSESY,BECOMES, LBRACK,RBRACK,ARROW,PERIOD,BEGINSY, IFSY,CASESY,REPEATSY,WHILESY,FORSY, WITHSY,GOTOSY,LABELSY,CONSTSY,TYPESY, VARSY,PROCSY,FUNCSY,PROGSY,INTCONST, REALCONST,STRINGCONST,NOTSY,MUL0; end; last := last + 1; with keyword[last] do begin name := 'DOWNTO'; pos := ord(downtosy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'ELSE'; pos := ord(elsesy); kind := 0; e       begin name := 'LABEL'; pos := ord(labelsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'MOD'; pos := ord(mulop); kind := 4; end; last := last + 1; with keyword[last] do begin d; last := last + 1; with keyword[last] do begin name := 'TYPE'; pos := ord(typesy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'UNTIL'; pos := ord(untilsy); kind := 0; end; last  name := 'MODULE'; pos := ord(modulesy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'NOT'; pos := ord(notsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := ':= last + 1; with keyword[last] do begin name := 'VAR'; pos := ord(varsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'WHILE'; pos := ord(whilesy); kind := 0; end; last := last + 1;nd; last := last + 1; with keyword[last] do begin name := 'END'; pos := ord(endsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'EXPORT'; pos := ord(exportsy); kind := 0; end; lastOF'; pos := ord(ofsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'OR'; pos := ord(addop); kind := 7; end; last := last + 1; with keyword[last] do begin name := 'OTHERWISE'; pos := last + 1; with keyword[last] do begin name := 'EXTERNAL'; pos := ord(externlsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'FILE'; pos := ord(filesy); kind := 0; end; last := l := ord(othrwisesy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'PACKED'; pos := ord(packedsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'PROCEDURE'; poast + 1; with keyword[last] do begin name := 'FOR'; pos := ord(forsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'FORWARD'; pos := ord(forwardsy); kind := 0; end; last := last + 1;s := ord(procsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'PROGRAM'; pos := ord(progsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'RECORD'; pos := or with keyword[last] do begin name := 'FUNCTION'; pos := ord(funcsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'GOTO'; pos := ord(gotosy); kind := 0; end; last := last + 1; with d(recordsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'RECOVER'; pos := ord(recoversy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'REPEAT'; pos := ord(keyword[last] do begin name := 'IF'; pos := ord(ifsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'IMPLEMENT'; pos := ord(implmtsy); kind := 0; end; last := last + 1; with keyword[lrepeatsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'SET'; pos := ord(setsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'THEN'; pos := ord(thensy); ast] do begin name := 'IMPORT'; pos := ord(importsy); kind := 14; end; last := last + 1; with keyword[last] do begin name := 'IN'; pos := ord(relop); kind := 14; end; last := last + 1; with keyword[last] do  kind := 0; end; last := last + 1; with keyword[last] do begin name := 'TO'; pos := ord(tosy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'TRY'; pos := ord(trysy); kind := 0; en       with keyword[last] do begin name := 'WITH'; pos := ord(withsy); kind := 0; end; middle := split(1,last); writeln(outfile,'N0 EQU 0'); for i := 1 to last do begin writeln(outfile); write(outfile,'S',i:1);  local/global vars *) BITSPERADDR = 8; (* # of bits in an address unit (byte) *) WORDSIZE = 4; (* # of address units (bytes) in a word *) BITSPERWORD = 32; (* # of bits per word *) WORDALIGN = 2;  if i < 10 then write(outfile,' '); writeln(outfile,' DC.B ', strlen(keyword[i].name):1, ',''',keyword[i].name,''''); if i = middle then write(outfile,'SYMTREE') else write(outfile,'N',i:1); if i < 10 then writ (* Alignment requirement for a word *) INTSIZE = WORDSIZE; (* Sizes of predefined types, in bytes *) SHORTINTSIZE = 2; REALSIZE = 8; CHARSIZE = 1; (* Unpacked char size *) BITSPERCHAR = 8; (* # e(outfile,' '); writeln(outfile,' DC.L ','S',i:1,',', 'N',keyword[i].left:1,',', 'N',keyword[i].right:1); writeln(outfile,' DC.B ', keyword[i].pos:1,',',keyword[i].kind:1); end; writeln(outfile); writeln(outfiof bits in a packed char *) BOOLSIZE = 1; (* Unpacked boolean size *) SCALARSIZE = 2; (* Unpacked enumerated type *) PTRSIZE = WORDSIZE; (* Size of a pointer, in bytes *) proksize = 8; (* Sizele,' DEF SYMTREE'); writeln(outfile,' END'); close(outfile,'lock'); end.  of a procedure var, in bytes *) INTALIGN = WORDALIGN; (* Alignment requirements *) REALALIGN = WORDALIGN; CHARALIGN = 1; (* Unpacked char alignment *) BOOLALIGN = 1; (* Unpacked boolean alignment *)  {file CONSTS} import sysglobals; export const crevid = daterec[year:91,day:28,month:10]; { crevno = '3.25'; } compilername = 'Pascal'; {title} copyright1 = 'Copyright Hewlett-Packard Company, 1982 SCALARALIGN = WORDALIGN; (* Unpacked enumerated type *) PTRALIGN = WORDALIGN; prokalign = WORDALIGN; parmalign = WORDALIGN; (* minimum alignment for a parameter *) bigsets = true; (* support expanded set capacity ? *, 1991.'; copyright2 = 'All rights reserved.'; FULLDUMP = false; (* conditional compilation for tree dump *) allowmodcal = FALSE; (* conditional compilation for $MODCAL$ *) MC68020 = TRUE; (* conditional compi) $if bigsets$ setlow = 0; (* Bounds on ordinal value of set members *) sethigh = 261999; (* allow 262000 elements *) setdefaulthigh = 8175; (* Default bound for set constructors lation for 68020/68881 *) $IF allowmodcal$ crevno = '3.25M'; $END$ $IF not allowmodcal$ crevno = '3.25'; $END$ IDLENGTH = 80; (* # of significant chars in names. *) MAXCURSOR = 1023; (* Source page size-1 (set containing variable element(s) *) oldsethigh = 255; (* max ordinal set val before extending *) setelemsize = 2; (* Allocate unpacked sets in word units *) setlensize = 2; (* Use word to actual  by workstation) *) maxinfiles = 10; (* Allow 5 levels of INCLUDE *) DISPLIMIT = 20; (* Symbol table levels *) MAXPLEVEL = 15; (* Procedure nesting depth *) LClimit = -32768; (* Maximum size forset size *) setelembits = 16; setalign = wordalign; (* Alignment of unpacked set *) setsize = ( (sethigh + setelembits) div setelembits) * setelemsize + setlensize;        if modownLC = false *) nilvalue = 0; (* representation of NIL *) linesperpage = 60; (* default # of lines on a listing page *) maxerrors = 10; (* maximum number of errors on a line *) optnsize = 13teger; pval : setrecptr ); $end$ $if not bigsets$ PSET: (plgth: shortint; PVAL: SET OF setlow..sethigh); $end$ ; (* option name size *) refiledefault = 30; (* default size for ref file *) defiledefault = 10; (* default size for def file *) maxreg = 7; (* 68000 register numbering *) searchdefault = 10;  STRNG, paofch: (SLGTH: 0..STRGLGTH; SVAL: paoc); bigpaoc: (paoclgth: integer; paocval: bigpac);  (* Max set size , in bytes *) setdefaultsize = ( (setdefaulthigh+setelembits) div setelembits ) * setelemsize + setlensize; (* Default set size,  overlaydefault = 9; TYPE ADDRRANGE = integer; alpha = string[idlength]; (* names *) alphaptr = ^alpha; (* constants *) byt = 0..255; reflistptr = ^localref; localref = record  in bytes, for constructors with variable element(s) *) $end$ $if not bigsets$ setlow = 0; (* Bounds on ordinal value of set members *) sethigh = 255; setele pc: addrrange; next: reflistptr; end; scstref = ^scstruct; stp = ^structure; ctp = ^identifier; CSTCLASS = (REEL,PSET,paofch,STRNG,bigpaoc,strctconst $IF MC68020$ ,chkmsize = 2; (* Allocate unpacked sets in word units *) setlensize = 2; (* Use word to actual set size *) setelembits = 16; setalign = wordalign; (* Alignment of unpacked set *) setsize = 34; (* Max 2_bounds $END$); CSP = ^ CONSTREC; paoc = packed array[1..strglgth] of char; bigpac = packed array[1..1] of char; stortype = (bytte,wrd,long,multi); $if bigsets$ setrecptr = ^setrec; setrec = record nxtsize of a set, in bytes *) $end$ NILFILESIZE = 150+fidleng;(* Size of a file info block *) FILESIZE = 150+fblksize; (* Size of FIB with mass storage buffer *) STRINGSIZE = 81; (* size of the default string, in bytes *) STR : setrecptr; val : set of 0..oldsethigh end; $end$ CONSTREC = RECORD CCLASS: CSTCLASS; case {pooled:} boolean of false: (case cstclass oGLGTH = 255; (* max length of a string *) bigintlen = 10; (* max number of digits in 32-bit integer *) LCAFTERMARKSTACK = 0; (* Addr of first local variable *) markstacksize = 12; (* Size of inner proc stack f strctconst: (kstruc: scstref; isdumped,hasbeenoutput: boolean; namep: alphaptr; location: addrrange)); marker, in bytes *) level1markstacksize = 8; (* Size of outer proc stack marker*) INITLC = 0; (* starting LC in main prog *) initmodlc = 0; (* starting LC in outer modules - ignored  true: (next: csp; (*chain of pooled constants*) conlbl: reflistptr; (* refs to this const *) case cstclass of $if bigsets$ PSET: ( plgth : in       REEL:(RVAL: real) $IF MC68020$; chk2_bounds: (lower,upper: integer; size: stortype) $END$ ); END; VALU = Rrage: stortype; end; case addrmode: addrtype of predecr,postincr, topofstack,loconstack, inAreg,inDreg,inFreg: (); (* use regnum *) ECORD CASE intval: BOOLEAN OF TRUE: (IVAL: INTEGER); FALSE: (VALP: CSP) END; vcref = ^valucel; valucel = record vcnxt: vcref; vcval: valu;  locinreg : (gloptr: alphaptr); (* uses regnum, offset *) shortabs, longabs, prel : (absaddr: valu); (* address + offset *) immediate: (smallval: inte case boolean of true: (vid: ctp); end; scstruct = record scstp: stp; scvcp: vcref; end; (* machine-dependeger); namedconst: (constptr: csp; callmode: callmodetype); labelledconst: (constvalp: csp); enumconst: (enumstp: stp); multiple: (regs: multiregs); $IFnt attributes*) callmodetype = (abscall,relcall); regrange = 0..maxreg; regtype = (A,D,F); addrtype = (inAreg,inDreg,inFreg,multiple,predecr, postincr,locinreg,topofstack,loconstack, labelledconst,namedcon MC68020$ fmultiple: (fregs: packed array[regrange] of boolean); $END$ end; st,enumconst, shortabs,longabs,prel,immediate $IF MC68020$ ,fmultiple $END$ ); accesstype = (direct,indirect); multiregs = packed array[regtype,regrange] of boolean; attrptr = ^attrtype;  (************************************************) (* *) (* HEWLETT-PACKARD *) (* *) (* MODULAR PASCAL-TO-68000 COMPILER *)  attrtype = record next: attrptr; offset: addrrange; {used by absolute,longconst,locinreg} regnum: regrange;{used by inreg,locinreg} access: accesstype; storage(* *) (* - Declaration analyzer from UCSD I.4, *) (* extensively modified by Jeff Eastman and *) (* Tom Lane. *) (* - Executable statement analyzer and tree *) (: stortype; indexed: boolean; indexreg: regrange; indexstorage: stortype; $IF MC68020$ indexscale: 0..3; $END$ packd: boo* - generator by Don Cameron and Tom Lane. *) (* - Code generation for MC68000 by Don Cameron,*) (* Brad Ritter and Sam Sands. *) (* *) (* *) (*lean; signbit: boolean; bitsize: shortint; bitoffset: record static: integer; variable: -1..maxreg; sto Desktop Computer Division *) (* Fort Collins, CO. *) (* *) (* Copyright (c) 1983, Hewlett-Packard Co. *) (************************************************)        {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} forward module codegen; {Code generation for the target machine} $INCLUDE 'GENDEF'$ end; forward module genutils; $INCLUDE 'GENUTLDEF'$ end; forward module genmove; $INCLUDE 'GEmodule compinit; {compiler initialization plus general purpose utilities} $INCLUDE 'INITDEF'$ $INCLUDE 'INIT'$ $INCLUDE 'UTILITIES'$ end; {compinit} $LINENUM 26000${- - - - - - - - - - - - - - - - - - - - - - - - - -} import globals,compinit,coNMOVDEF'$ end; forward module float_hdw; $INCLUDE 'FLOATDEF'$ end; $LINENUM 5000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module assemble; $INCLUDE 'ASSMDEF'$ $INCLUDE 'ASSEMBLE'$ end; {assemble} $LINENUM 6000${- - - - - - -mpio,symtable, declanalyzer,codegen,genutils; begin {Modcal_Cross_Compiler} $INCLUDE 'MAINBODY'$ end. program count; var f: file of integer; i: integer; begin open(f,'COUNTFILE'); read(f,i); i := i + 1; seek(f,1); write(f,i); close(f,'save'); end.  - - - - - - - - - - - - - - - - - - -} module genutils; {utilities for code generation} $INCLUDE 'GENUTIL'$ end; {genutils} $LINENUM 9000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module genexprmod; {code generation for expressions{Schema file: CUR- compile entire compiler} $SEARCH 'CONVERT'$ $CODE OFF$ $UCSD,MODCAL$ program Compiler (input,output); $INCLUDE 'CHEADING'$ {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} module globals; $INCLUDE 'CCONSTS'$ $INCL} $INCLUDE 'GENEXPDEF'$ $INCLUDE 'GENEXPR'$ end; {genexprmod} $LINENUM 12000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module float_hdw; {code generation for floatpoint hardware} $IF MC68020$ $INCLUDE 'MC68881'$ $END$ $IF not UDE 'GLOBALS'$ const { Conditional compilation constants } ovflchecking = false; $OVFLCHECK OFF$ rangechecking = false; $RANGE OFF$ partialevaling = false; $PARTIAL_EVAL OFF$ implement end; {- - - - - - - - - - - - - - - - -MC68020$ $INCLUDE 'FLOAT'$ $END$ end; {float_hdw} $LINENUM 13000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module genmove; {expression utilities, packing} $INCLUDE 'GENMOVE'$ end; {genmove} $LINENUM 15000${- - - - - - -  - - - - - - - - - - - - - -} $INCLUDE 'FORWINIT'$ {abstract module COMPINIT} $INCLUDE 'FORWUTILS'$ $LINENUM 1000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compio; {source input, listing output, lexical analysis} $I- - - - - - - - - - - - - - - - - - - - -} module codegen; {module codegen: implement section} $INCLUDE 'GENCODE'$ end; {codegen} $LINENUM 18000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module bodyanalyzer; {Syntax analysisNCLUDE 'IODEF'$ $INCLUDE 'SCANNER'$ end; {compio} $LINENUM 3000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compdebug; {compiler debugging utilities - all empty routines in production copies} $INCLUDE 'DEBGDEF'$ $INCLUDE 'DU for executable statements; tree building} $INCLUDE 'BODYDEF'$ $INCLUDE 'BODYHEAD'$ $INCLUDE 'EXPRESSN'$ $INCLUDE 'STATEMENT'$ $INCLUDE 'BODY'$ end; {bodyanalyzer} $LINENUM 21000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} modulMPTREE'$ end; {compdebug} $LINENUM 4000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module symtable; {symbol table entry/lookup, structure manipulation} $INCLUDE 'SYMDEF'$ $INCLUDE 'SYMTABLE'$ $INCLUDE 'STRUCTS'$ end; {symtable} e declanalyzer; {Syntax analysis for declarations; symbol table building} $INCLUDE 'DECLDEF'$ $INCLUDE 'PARAMLIST'$ $INCLUDE 'TYP'$ $INCLUDE 'BLOCK'$ end; {declanalyzer} $LINENUM 24000${- - - - - - - - - - - - - - - - - - - - - - - - - - -}      COMPLIBŠNJUIDSEARCHŠD@HŔ/Hz~Nš4ÚJgNşÓBpdmüD@HŔ/HzdNš4ÚJgDJ­~g NşÓNš˙˙Ý B-mľB­~J-mˇgHmj Hz4Nš˙ň?>B-mˇB­j>B-mś+mm~,pQ°-m´fů`HmmŔHz Nš˙ň?>N^NulockNORMALNVHmj Hmm6/<˙˙˙ţNš˙ň7žAíj !mř+HřHmmŔHmpV/<˙˙˙ýNš˙ň7žAímŔ!mř+HřNš˙ô˛ţ IMPLEMENT 1IMPORT/IN.J(LABEL@MODTFn&MODULEf€.NOT|%OFŽXŇ OR ź' OTHERWISE˛2PACKEDʤę* PROCEDUREŕPROGRAMNš˙ň€LNš˙ňppNš˙˙ćNš˙ňbęNš˙ň,xNš˙˙ÄXNš˙˙Ć\mţq\p鈁mq\-˙q\pT㈁-q\-˙đq]p-q]Hmq^Nš˙ňxÂBmmźBmmž/-¤B§B§Nš˙ňP^/-¤Nš˙ôŔ/-¤B§/<Nš˙ňP^/-¤/Hz?<'?<˙˙Nš˙ňWUGmľVĎ˙üf&ŒB—NŃBGUGmľVĎ˙üe*,fŔ&Œ.źNŃ>UGmľVĎ˙übâ*,f˘&Œ.ź˙˙˙˙NŃ(E TJg´*,fň`ćĐ mČfÍČ͈ˆ4Č&͈ ˆ ĐqĐUĐUĐeˆNˆ’ˆĐqˆĐˆĐ qĐUĐeˆ2ˆĐqˆĐˆĐ qĐUĐeĐJ%ˆČˆˆˆ ˆ ЁĐqĐUQHzŘHoHTa˜LßBŹRJ„f i Ui SNuAND€&ANYVAR’„Ž:ARRAY¨Â+BEGINźCASEКCONSTäüDIVř&DO ę$DOWNTO8ELSE2 ENDFÖ´ĐUĐUĐUĐeČÜÍÉŽuŃ)ˆ ĐĄĐEЁРĄĐqˆˆĐĄĐeČBuČ uČÍĐůČÍČ uˆXQČuĐqĐUĐqĐUĐqЁČuČ@͈Śˆˆ$ČÍČÍČ͈>ˆČÍČÍČÍČÍĐ %Č ÍČÍČÍČÍČÍĐůČ ÍČÍP$ˆˆČ uˆČ͈ ˆĐmČ ͈(ˆĐmˆˆ Č,ÍPˆˆIDSEARCHRSYMTREER2 TREESEARCHRüˆĐeČ*͈ŒĐqĐUĐqČ͈ЁĐqĐeˆ ĐqĐUĐqĐUĐqĐeˆ ĐqĐUĐqĐUĐqĐeˆˆŇĐqˆĐĐeČ0ÍȀ͈ ĐqČ͈ЁĐqĐeˆ<ĐqЁĐqˆ:ˆĐĐP„PPPP PP PPPP PP PPPPPP PPPPPPPP PP PPPPPP PPPPPPPPPP PPPPPP PPPP PPPPPPPPPPPPPPPPPP PP PPPP PP PPPP PP ,@ę˙ű˙ű"R˙ű"j˙÷ŚH˙ű\ž$˙úZ´"€˙ű"˜˙÷ŚH˙űá˜*Š"š˙űeˆČ͈ČÍČ,͈ ĐqČ͈ЁĐqĐeˆZĐqЁĐeˆČ͈Č͈PĐeˆ Đ EČ*͈ĐqČ͈ЁĐqĐe‰Č͈Č͈<Č͈ČÍČuĐ šČuĐqČuĐqČtuĐ šČuĐqĐEĐeČuĐqĐeČuĐqĐeČuĐqĐeČuĐqĐeČuĐqĐeČuĐqĐeČ˙ű&n@ë(˙ř/–˙ř˙ű"¤˙ű"ź˙÷ŚH˙ű\ž$˙úZ´@ý—ű@ě˙ű"ţ˙ű"Ö˙ű#Ž@í˙ű˙÷˙ű"ř˙ű#˙÷ŚH˙ű\ž$˙ů÷F*˙˙˙ţ@î |—ű˙ú)œ˙ű#.˙ű#N˙ű#6˙ř*˙ű\ž)˙űŠ˙ř‚ž˙ű˙ű#n˙ű#V˙ř"´˙űá˜$˙řźđ˙ř´˙űÝ˙ű#v˙÷ŚH˙űmî     MODULE CONVERT_TEXT; import sysglobals, misc, asm; export const pagesize = 1024; type pagebuftype = packed array[0..pagesize-1] of char; procedure any_to_UCSD(var T: text; anyvar pagebuffer: pagebuftype); procedure UCSD_to_any(anyvar pagebuffer: pagebČ Č Č ĐĐP)Ђ)Đr5ĐEĐ.QČH Č Đ<]Č Đ<]Č ЎmČ Đ}Č Č Č Č Ađ˙-H˙z/. <x/.˙zNšp n˙z-@˙ü n˙p héK f>p-n˙ü˙l°Ž˙ln.-@˙t n˙z .˙tr ˛0f n˙z .˙tź˙  .˙tR€hĚ n˙zź˙ /Nş˙, .˙üŃŽ˙ř`/. <xHn˙~Nš/Nş˙ n˙puftype; var T: text); END; (ţćCčţćt[´1VÁÂg/Nşôb n h<˙Hhţćp(ţćR@HŔCî˙ü"€HQ?/////<a?<˙˙Nš˙ŔfŇ n h(ţĺ€/?<Nš˙˙׀`0.˙ůčˆ€r˛€f n h<˙HhţćHzNš˙Ŕ`\J. gT n hp(ţćCčţćr(˛1VŔr(ţćCčţćt[´1VÁÂg héK fBpr.˙~-A˙l°Ž˙ln.-@˙t .˙tAî˙~r ˛0f .˙tAî˙~ź˙  .˙tR€hĚHn˙ n .˙řHpp.˙~/Nšp.˙~ŃŽ˙řU/. Nš_˙y/Nşţ|J.˙yg$ n .˙řź˙ RŽ˙ř/. Nš/NşţR`ţŠOî˙l .˙ř €˙n-@˙ř n .˙řB0 .˙řR€hŢN^ _PONĐNV˙ö/-˙ö/Hzd+O˙öBŽ˙řPROGRAM˝†   CONVERT_TEXTHhˆ˝†N^ _\ONĐ()NA/<B'B§ n/(Nşűö?. /.Nş˙†N^ _\ONĐNA?. /.Nş˙l n h<˙HhţćHzNš˙ŔN^ _\ONĐ+NA n h<˙HhţćHzNš˙Ŕ?. /.Nş˙N^ _\ONĐ-NA˙đ n h h"h˙ž (˙ÔHqNVJ­˙ęgp°­˙ęfB­˙ęNI˙˙˙ŕN^.ŸNuNV˙l-n ˙pBŽ˙řB.˙y Žˆ˙řlnJ.˙yg” n .˙řAđ˙-H˙z/. <x/.˙zNšp n˙z-@˙ü n˙p héK f>p-n˙ü˙l°Ž˙ln.-@˙t n˙z .˙tr ˛0f n˙z .˙tź˙  .˙tR€hĚ n˙zź˙ /Nş˙, .˙üŃŽ˙ř`/. <xHn˙~Nš/Nş˙ n˙p"n"iHiţŕ/<Nš˙˙Úž n h(ţŕVŔDJf¸(ţŕ∀fę/<. B§/Nşű n h<˙HhţćHz>Nš˙Ŕ n hCčţä-I˙ôCčţŕ-I˙đJ. f*?<"n˙ô)€?/.Nşý´ n/(Nş÷Ú n˙đVŔDr?čˆ€?/.Nşý‚ n˙đVŔDJg "n"i<˙HiţćHz héK fBpr.˙~-A˙l°Ž˙ln.-@˙t .˙tAî˙~r ˛0f .˙tAî˙~ź˙  .˙tR€hĚHn˙ n .˙řHpp.˙~/Nšp.˙~ŃŽ˙řU/. Nš_˙y/Nşţ|J.˙yg$ n .˙řź˙ RŽ˙ř/. Nš/NşţR`ţŠOî˙l .˙ř €˙n-@˙ř n .˙řB0 .˙řR€hŢN^ _PONĐNV˙ö/-˙ö/Hzd+O˙öBŽ˙řĘNš˙Ŕ` n h<˙HhţćHz°Nš˙Ŕ`ź n h<˙HhţćHzhNš˙Ŕ/<. B§ n/(NşůţJ. g n h<˙HhţćHz0Nš˙Ŕ`z n h<˙Hhţćp(ţćR@HŔCî˙ü"€HQ?/////Hzú?<?<˙˙Nš˙Ŕi¨?///// n h(ţĺ€/?<Nš˙˙׀<,?<˙˙Nš˙ŔfŇ n h n .˙řp˙÷p°.˙÷fRŽ˙ř Ž˙řf$/..˙÷?<˙˙NšJ­˙ęgNC``^ n .˙řp˙÷p °.˙÷d$/.< p.˙÷r A?NšJ­˙ęgNCRŽ˙ř Ž˙řf`ś n .˙řp˙÷-n˙ř˙üp °.˙÷VŔJ.˙÷VÁÂg*RŽ˙ü Ž˙üf B.˙÷` n .˙üp˙÷`Ä/. n .˙řHp _HP?<(ţŕVŔDr?(ţŕčˆ€?/.Nşü6 n h(ţŕVŔDJg<˙HhţćHzdNš˙Ŕ` n h<˙HhţćHzJNš˙Ŕ n h(ţŕ∀S€ă€2;Nű:<˙HhţćHz2Nš˙Ŕ`: n h<˙HhţćHzNš˙Ŕ` n h<˙HhţćHzţNš˙Ŕ`Ž?< n/(NşČ Č S .˙üŽ˙ř?NšJ­˙ęgNCJ.˙÷f`*/.NšJ­˙ęgNC .˙üR€-@˙ř Ž˙řfţś+o˙öŢü Nú,_+_˙öpö°m˙ţgNJN^ _PONĐNu˙HhţćHzRNš˙Ŕ.˙ů€/HzNš˙˙ŘLJg n h<˙HhţćHzţNš˙Ŕ.˙ů€ă€2;Nűff`˘ n hp(ţćCčţćr(˛1VŔr˝†ˇĘM˙Čň¤˙Čň¤˙˙CF˙˙=Đ˙Ă;&˙Ď´ź˙˙˙˙=Đ˙Ă;”˙˙ĆwŞ˙˙CF˙˙˛vˆŚ CONVERT_TEXT˙vZRCF˙˙CF˙Ď˙˙>\˙ĚÚÄ˙˙Ď´ź˙˙CF˙˙>l˙ĚáÖ ˙˙>‚˙ĚćŠ˙ĚćŠCONVERT_TEXT__BASERCONVERT_TEXT_ANY_TO_UCSDúR,CONVERT_TEXT_1_1RśCONVERT_TEXT_UCSD_TO_ANY/RęCONVERT_TEXT_CONVERT_TEXTRt CONVERT_TEXT’Nš˙˙׀?/////Hz0?<?<˙˙Nš˙Ŕi¨?///// n h(ţă€/?<Nš˙˙׀?/////Z$˙˙>–˙Ěę´˙˙>–˙Đ4˙Ďǜ˙˙>ž˙Ď9J0€’8˙˙˙Đ3T˙˙@˙Ď@(˙˙@Y˙̞ś˙ϝ\˙˙?ö˙ϛd?ţ˙Ŕ]¤˙˙>ţ˙ƅĐ˙̞ś˙ĎĆ´˙˙@˙ĎĆV_BASE/@ŕ*0˙Á>Œ˙Ŕ˙˙˙˙?˜˙Á? ˙Á?˙Á?T˙Ə,˙Ǝü˙ĎlO?˙>?T˙ĆHzę?<?<˙˙Nš˙Ŕi¨?///// n h0(ţŕěˆ€/?<Nš˙˙׀?/////Hzž?<?<˙˙Nš˙Ŕi¨?///// n h0(ţâěˆ€/?<Nš˙˙׀Hzd?<?<˙˙Nš˙Ŕi¨ n h(ţŕVŔDf<˙HhţćHz6Nš˙Ŕ` n h<˙HhţćHzNš˙Ŕ n h<˙Hhţćp(ţćCî˙ü"€HQ     Č Č SYSGLOBALSCONVERT_TEXT_1_1 FS_FREADSTR ASM_MOVELEFTFS_FEOLN FS_FREADLN FS_FWRITECHAR FS_FWRITEPAOC FS_FWRITELN f>p-n˙ü˙l°Ž˙ln.-@˙t n˙z .˙tr ˛0f n˙z .˙tź˙  .˙tR€hĚ n˙zź˙ /Nş˙, .˙üŃŽ˙ř`/. <xHn˙~Nš/Nş˙ n˙p $INCLUDE 'DUMPTREE'$ end; {compdebug} $LINENUM 4000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module symtable; {symbol table entry/lookup, structure manipulation} $INCLUDE 'SYMDEF'$ $INCLUDE 'SYMTABLE'$ $INCLUDE 'STRUCTS'$ end héK fBpr.˙~-A˙l°Ž˙ln.-@˙t .˙tAî˙~r ˛0f .˙tAî˙~ź˙  .˙tR€hĚHn˙ n .˙řHpp.˙~/Nšp.˙~ŃŽ˙řU/. Nš_˙y/Nşţ|J.˙yg$ n .˙řź˙ RŽ˙ř/. Nš/NşţR`ţŠOî˙l .˙ř €˙n-@˙ř n .˙řB0 .˙řR€hŢN^ _PONĐNV˙ö/-˙ö/Hzd+O˙öBŽ˙ř; {symtable} {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} forward module codegen; {Code generation for the target machine} $INCLUDE 'GENDEF'$ end; forward module genutils; $INCLUDE 'GENUTLDEF'$ end; forward module genmove;  {file DECLDEFINE} import globals,compinit,compio,symtable,convert_text, bodyanalyzer,genutils,sysglobals,loader; export procedure block (fsys: setofsys; fsy: symbols; fprocp: ctp); procedure moduledeclaration(fsys: setofsys; mustbeabstract, $INCLUDE 'GENMOVDEF'$ end; forward module float_hdw; $INCLUDE 'FLOATDEF'$ end; $LINENUM 5000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module assemble; $INCLUDE 'ASSMDEF'$ $INCLUDE 'ASSEMBLE'$ end; {assemble} $LINENUM 6000${forwardmodule: boolean; var wheretolinkstate: modstateptr; modulelist: boolean); - - - - - - - - - - - - - - - - - - - - - - - - - -} module genutils; {utilities for code generation} $INCLUDE 'GENUTIL'$ end; {genutils} $LINENUM 9000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module genexprmod; {code generation fo{Schema file: DEV- compile entire compiler} $REF 100$ $SEARCH 'CONVERT'$ $IOCHECK OFF$ $UCSD,MODCAL$ program Compiler (input,output); $INCLUDE 'CHEADING'$ {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} module globals; $INCLUDE 'CCONr expressions} $INCLUDE 'GENEXPDEF'$ $INCLUDE 'GENEXPR'$ end; {genexprmod} $LINENUM 12000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module float_hdw; {code generation for float card} $IF MC68020$ $INCLUDE 'MC68881'$ $ENSTS'$ $INCLUDE 'GLOBALS'$ const { Conditional compilation constants } ovflchecking = false; $OVFLCHECK OFF$ rangechecking = false; $RANGE OFF$ partialevaling = false; $PARTIAL_EVAL OFF$ implement end; {- - - - - - - - - - D$ $IF not MC68020$ $INCLUDE 'FLOAT'$ $END$ end; {float_hdw} $LINENUM 13000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module genmove; {expression utilities, packing} $INCLUDE 'GENMOVE'$ end; {genmove} $LINENUM 1- - - - - - - - - - - - - - - - - - - - -} $INCLUDE 'FORWINIT'$ {abstract module COMPINIT} $INCLUDE 'FORWUTILS'$ $LINENUM 1000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compio; {source input, listing output, lexical a5000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module codegen; {module codegen: implement section} $INCLUDE 'GENCODE'$ end; {codegen} $LINENUM 18000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module bodyanalyzernalysis} $INCLUDE 'IODEF'$ $INCLUDE 'SCANNER'$ end; {compio} $LINENUM 3000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compdebug; {compiler debugging utilities - all empty routines in production copies} $INCLUDE 'DEBGDEF'$ ; {Syntax analysis for executable statements; tree building} $INCLUDE 'BODYDEF'$ $INCLUDE 'BODYHEAD'$ $INCLUDE 'EXPRESSN'$ $INCLUDE 'STATEMENT'$ $INCLUDE 'BODY'$ end; {bodyanalyzer} $LINENUM 21000${- - - - - - - - - - - - - - - - - - - - -      NCLUDE 'IODEF'$ $INCLUDE 'SCANNER'$ end; {compio} $LINENUM 3000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compdebug; {compiler debugging utilities - all empty routines in production copies} $INCLUDE 'DEBGDEF'$ $INCLUDE 'DUnalysis for executable statements; tree building} $INCLUDE 'BODYDEF'$ $INCLUDE 'BODYHEAD'$ $INCLUDE 'EXPRESSN'$ $INCLUDE 'STATEMENT'$ $INCLUDE 'BODY'$ end; {bodyanalyzer} $LINENUM 21000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} MPTREE'$ end; {compdebug} $LINENUM 4000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module symtable; {symbol table entry/lookup, structure manipulation} $INCLUDE 'SYMDEF'$ $INCLUDE 'SYMTABLE'$ $INCLUDE 'STRUCTS'$ end; {symtable}  module declanalyzer; {Syntax analysis for declarations; symbol table building} $INCLUDE 'DECLDEF'$ $INCLUDE 'PARAMLIST'$ $INCLUDE 'TYP'$ $INCLUDE 'BLOCK'$ end; {declanalyzer} $LINENUM 24000${- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} module declanalyzer; {Syntax analysis for declarations; symbol table building} $INCLUDE 'DECLDEF'$ $INCLUDE 'PARAMLIST'$ $INCLUDE 'TYP'$ $INCLUDE 'BLOCK'$ end; {declanalyzer} $LINENUM 24000${- - - - - - - - - - - - - - - - - - - {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} forward module codegen; {Code generation for the target machine} $INCLUDE 'GENDEF'$ end; forward module genutils; $INCLUDE 'GENUTLDEF'$ end; forward module genmove; $INCLUDE 'GE - - - - - - - -} module compinit; {compiler initialization plus general purpose utilities} $INCLUDE 'INITDEF'$ $INCLUDE 'INIT'$ $INCLUDE 'UTILITIES'$ end; {compinit} $LINENUM 26000${- - - - - - - - - - - - - - - - - - - - - - - - - -} importNMOVDEF'$ end; forward module float_hdw; $INCLUDE 'FLOATDEF'$ end; $LINENUM 5000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module assemble; $INCLUDE 'ASSMDEF'$ $INCLUDE 'ASSEMBLE'$ end; {assemble} $LINENUM 6000${- - - - - - - globals,compinit,compio,symtable, declanalyzer,codegen,genutils; begin {Modcal_Cross_Compiler} $INCLUDE 'MAINBODY'$ end.  - - - - - - - - - - - - - - - - - - -} module genutils; {utilities for code generation} $INCLUDE 'GENUTIL'$ end; {genutils} $LINENUM 9000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module genexprmod; {code generation for expressions{Schema file: DEVR- compile entire compiler} $SEARCH 'CONVERT'$ $IOCHECK OFF$ $UCSD,MODCAL$ program Compiler (input,output); $INCLUDE 'CHEADING'$ {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} module globals; $INCLUDE 'CCONSTS'$ $} $INCLUDE 'GENEXPDEF'$ $INCLUDE 'GENEXPR'$ end; {genexprmod} $LINENUM 12000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module float_hdw; {code generation for float card} $IF MC68020$ $INCLUDE 'MC68881'$ $END$ $IF INCLUDE 'GLOBALS'$ const { Conditional compilation constants } ovflchecking = true; $OVFLCHECK ON$ rangechecking = true; $RANGE ON$ partialevaling = false; $PARTIAL_EVAL OFF$ implement end; {- - - - - - - - - - - - - - - - -not MC68020$ $INCLUDE 'FLOAT'$ $END$ end; {float_hdw} $LINENUM 13000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module genmove; {expression utilities, packing} $INCLUDE 'GENMOVE'$ end; {genmove} $LINENUM 15000${- - - - - - - - - - - - - - - - - -} $INCLUDE 'FORWINIT'$ {abstract module COMPINIT} $INCLUDE 'FORWUTILS'$ $LINENUM 1000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compio; {source input, listing output, lexical analysis} $I - - - - - - - - - - - - - - - - - - - - - - - -} module codegen; {module codegen: implement section} $INCLUDE 'GENCODE'$ end; {codegen} $LINENUM 18000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module bodyanalyzer; {Syntax a     - -} module compinit; {compiler initialization plus general purpose utilities} $INCLUDE 'INITDEF'$ $INCLUDE 'INIT'$ $INCLUDE 'UTILITIES'$ end; {compinit} $LINENUM 26000${- - - - - - - - - - - - - - - - - - - - - - - - - -} import globals,comp i mod 70 = 0 then begin incrlinecount; writeln(lp); write(lp,'':9); end; $RANGE OFF$ write(lp,paocval[i]:1); $IF rangechecking$ $RANGE ON$ $END$ end; end; strctconst: begin incrlinecount; init,compio,symtable, declanalyzer,codegen,genutils; begin {Modcal_Cross_Compiler} $INCLUDE 'MAINBODY'$ end.  write(lp,'structured constant: '); if kstruc = nil then writeln(lp,'value not saved') else with kstruc^ do begin writeln(lp); incrlinecount; if scstp^.form = arrays then writeln(lp,'array') else if scstp^.formprogram dispcount(output); var f: file of integer; i: integer; begin reset(f,'COUNTFILE'); read(f,i); writeln('Count = ',i:1); close(f,'normal'); end.  = records then writeln(lp,'record'); p := scvcp; while p <> nil do begin incrlinecount; dumpvalu(p^.vcval); writeln(lp); p := p^.vcnxt; end; end; end; end; {case} end; {dumpvalu} {file DUMPTREE} implement procedure dumpvalu (val: valu); var i: shortint; p: vcref; $if bigsets$ s : setrecptr; (* current set record item *) j : integer; (* simple local counter *) bias, rel_elem: shortint;  $IF FULLDUMP$ procedure dumpinfobits (inf: infobits); var ch: char; begin ch := '['; if predeclared in inf then begin write(lp,ch,'PDEC'); ch:=',' end; if mustinitialize in inf then begin write(lp,ch,'INIT'); ch:=',' end; if cantassign (* ordinal bias and relative element value for list *) $end$ begin with val do if intval then write(lp,ival:1) else with valp^ do case cclass of reel: write(lp,rval); pset: begin write(lp,'set:'); $i in inf then begin write(lp,ch,'NOASSGN'); ch:=',' end; if nonstandard in inf then begin write(lp,ch,'NONSTD'); ch:=',' end; if sysprogreq in inf then begin write(lp,ch,'SYSPROG'); ch:=',' end; if modcalreq in inf then begin write(lp,f bigsets$ for j := 0 to plgth-1 do begin if (j mod 32) = 0 then $end$ $if not bigsets$ for i := 0 to plgth-1 do begin if (i mod 32) = 0 then $end$ begin incrlinecount; writeln(lp); write(lp,'':2); end; ch,'MODCAL'); ch:=',' end; if ucsdreq in inf then begin write(lp,ch,'UCSD'); ch:=',' end; if ch='[' then write(lp,ch); write(lp,']'); end; $END$ procedure writename (leadb: shortint; var str: string); {Write string, normalized length, at leas $if bigsets$ bias := j DIV (oldsethigh + 1); rel_elem := j MOD (oldsethigh + 1); s := pval; for i := 1 to bias do s := s^.nxt; if rel_elem in s^.val then $end$ $if not bigsets$ if i in pval then $end$ t 1 trailing blank} begin write(lp,' ':leadb,str,' ':17-strlen(str)); end; procedure dumpsymbol (fcp: ctp; indent: shortint); forward; procedure dumpstruct (fsp: stp; indent: shortint); { Dump a structure node } begin incrlinecount; write(l write(lp,'1') else write(lp,'0'); end; end; paofch: write(lp,'paofchar:',sval:slgth); strng: write(lp,'string:',sval:slgth); bigpaoc: begin write(lp,'paofchar:'); for i := 1 to paoclgth do begin ifp,' ':indent); if fsp = nil then writeln(lp,'NIL type') else with fsp^ do begin if fsp = intptr then write(lp,'integer') else if fsp = realptr then write(lp,'real') else if fsp = boolptr then write(lp,'boolean') else if fsp = char_p      begin write(lp,'var lev=',vlev:2,' addr=',vaddr:6); case vtype of shortvar: write(lp,' short'); longvar: write(lp,' long'); relvar: write(lp,' relative'); localvar: if globalptr = NIL then write(lp,' local') else write(lp,' g dumpstruct(idtype,indent+2); dumpsymbol(rlink,indent); end; {with} end; {dumpsymbol} procedure dumptree (*curbody: stptr; fprocp: ctp*); (* Prints statement/expression trees *) var lstate: modstateptr; $IF FULLDUMP$ { SUPPRESS EXPR/lobalbase = ',globalptr^); valparm: write(lp,' valparm'); refparm: write(lp,' refparm'); { Added following line 8/12/89 JWH } boundparm : write(lp,' boundparm'); cvalparm: write(lp,' copyparm; addr=',vptraddr:1); procparm: begin write(lp,' proSTMT DUMP } procedure dumpelist (fexp: elistptr; setdeno: boolean); (* on entry fexp points to the head of a (possibly empty) list of 'explist' records. setdeno indicates the variant of the records. on exit the 'enum's associated wittr then write(lp,'char') else case form of scalar: write(lp,'scalar'); subrange: begin write(lp,'subrange min='); write(lp,min:1); write(lp,' max='); write(lp,max:1); end; prok: write(lp,'prok parmlc=',parmlc:1); funk: wricparm'); dumpstruct(proktype,indent); end; funcparm: begin write(lp,' funcparm'); dumpstruct(proktype,indent); write(lp,' result type:'); dumpstruct(idtype,indent); end; strparm: begin write(lp,' var string',' maxlete(lp,'funk parmlc=',parmlc:1); pointer: write(lp,'pointer'); power: write(lp,'set ',setmin:1,'..',setmax:1); files: write(lp,'file'); arrays: begin write(lp,'array '); if aispackd then write(lp,'elbitsize=',aelbitsize:1) else write(lp,'elsizngth offset:',vaddr+4:6); end; anyvarparm: write(lp,' anyvarparm'); end; end; field: begin write(lp,'field offset=',fldaddr:1); if fispackd then write(lp,' bitoffset=',fldfbit:1); end; prox,func: begin if klass = pe=',aelsize:1); end; records: write(lp,'record'); otherwise write(lp,'unexpected form=',ord(form)) end; {case form} write(lp,' unpacksize=',unpacksize:1); if sizeoflo then write(lp,' (OFLO)'); write(lp,' align=',align:1); if ispackablerox then if ismodulebody then write(lp,'module ') else write(lp,'proc ') else write(lp,'func '); case pfdeckind of special: write(lp,'special ',ord(spkey):1,' '); standard: write(lp,'standard ',ord(spkey):1,' '); declared: then begin write(lp,' bitsize=',bitsize:1); if signbit then write(lp,' signed'); end; $IF FULLDUMP$ write(lp,' '); dumpinfobits(info); $END$ writeln(lp); case form of records: dumpsymbol(fstfld,inden begin write(lp,'lev=',pflev:1); if klass=func then write(lp,' result=',pfaddr:1); if forwdecl then write(lp,' forw'); if extdecl then write(lp,' ext'); if (klass <> prox) or not ismodulebody and isdumped then t+2); prok: dumpsymbol(params,indent+2); otherwise end; {2nd case form} end {with fsp^} end; {dumpstruct} procedure dumpsymbol (*fcp: ctp; indent: shortint*); { Dump symbol table tree rooted at FCP } begin if fcp <> nil th begin incrlinecount; writeln(lp); incrlinecount; writeln(lp,' entry: ', currentglobal^,'__BASE + ', location:1); incrlinecount; writeln(lp,' exit: ', currentglobal^,'__BASE + en with fcp^ do begin dumpsymbol(llink,indent); incrlinecount; writename(indent,namep^); case klass of types: write(lp,'type'); konst: begin write(lp,'konst '); dumpvalu(values); end; routineparm, vars:', exit_location:1); end; end; otherwise end; {pfdeckind} end; otherwise end; {case klass} $IF FULLDUMP$ write(lp,' '); dumpinfobits(info); $END$ writeln(lp); if klass = types then     h the list have been printed to file lp. NO end-of-line mark has been written to the file *) begin while fexp<>nil do with fexp^ do begin if not setdeno then if expptr = nil then write(lp,' NIL') else write(lp,' ',expptr^.enum:1) eart.valp <> nil then begin incrlinecount; write(lp,', cst part: '); dumpvalu(setcstpart); writeln(lp); end else writeln(lp,', no cst part'); if setvarpart<>nil then begin incrlinecount; writlse write(lp,' ',lowptr^.enum:1,':',hiptr^.enum:1); fexp := nextptr; end; end (*dumpelist*); procedure dumpexprs; (* prints expression records to file lp. The expressions are printed as encountered on the linear list headed by firste(lp,'var part:':43); dumpelist(setvarpart,true); writeln(lp) end; end; otherwise begin incrlinecount; writeln(lp,'???'); end; end (*case eclass*) end(*dumpoperands*); procedure printclass (cls:exp^.echain and linked by echain fields. *) var lexp: exptr; procedure dumpoperands; begin with lexp^ do case eclass of eqnode..andnode,concatnode: begin incrlinecount; writeln(lp,' operands: ', exprs); begin case cls of eqnode: write(lp,'eqnode':12); nenode: write(lp,'nenode':12); ltnode: write(lp,'ltnode':12); lenode: write(lp,'lenode':12); gtnode: write(lp,'gtnode':12); genode opnd1^.enum:1,',',opnd2^.enum:1); end; negnode..truncnode: write(lp,' operand: ',opnd^.enum:1); idnode: writename(2,symptr^.namep^); subscrnode, substrnode: begin write(lp,' arayp: ',arayp^.enum:1, : write(lp,'genode':12); innode: write(lp,'innode':12); subsetnode: write(lp,'subsetnode':12); supersetnode: write(lp,'supersetnd':12); concatnode: write(lp,'concatnode':12); addnode: write(lp,'addnode':12);  ', index: ',indxp^.enum:1); if eclass = substrnode then begin write(lp,', lengthp = '); if lengthp = nil then write(lp,'NIL') else write(lp,lengthp^.enum:1); end; end; selnnode: begin write(lp,' rec: ',recptr^.en subnode: write(lp,'subnode':12); ornode: write(lp,'ornode':12); unionnode: write(lp,'unionnode':12); diffnode: write(lp,'diffnode':12); mulnode: write(lp,'mulnode':12); divnode: write(lp,'divnode':12um:1,', field:'); writename(1,fieldptr^.namep^); end; unqualfldnode: begin write(lp,' withst: ',withstptr^.snum:1, ', field:'); writename(1,fieldref^.namep^); end; litnode: begin incrlinecount; ); modnode: write(lp,'modnode':12); andnode: write(lp,'andnode':12); intersectnode: write(lp,'intersectnd':12); selnnode: write(lp,'selnnode':12); negnode: write(lp,'negnode':12); floatnode: write(lp,'floa write(lp,' '); dumpvalu(litval); writeln(lp) end; fcallnode: begin incrlinecount; writename(2,fptr^.namep^); if actualp = nil then writeln(lp,' no parms') else begin write(lp,' parms:'); dumpelistnode':12); strlennode: write(lp,'strlennode':12); notnode: write(lp,'notnode':12); unqualfldnode: write(lp,'unqualfldnd':12); derfnode: write(lp,'derfnode':12); absnode: write(lp,'absnode':12); chrnode: wrt(actualp,false); writeln(lp) end end; setdenonode: begin with etyptr^ do begin write(lp,' unpacksize=',unpacksize:1); if ispackable then write(lp,' bitsize=',bitsize:1); end; if setcstpite(lp,'chrnode':12); oddnode: write(lp,'oddnode':12); ordnode: write(lp,'ordnode':12); roundnode: write(lp,'roundnode':12); sqrnode: write(lp,'sqrnode':12); truncnode: write(lp,'truncnode':12); fcallnode:       dumpoperands; end; (*with lexp^*) lexp := lexp^.echain; writeln(lp); until lexp = nil end (*lexp <> nil*) end (*dumpexprs*); procedure dumpstmts (curstmt:stptr); var lexp: elistptr; procedure namebody (name: alpha; bodythen writeln(lp,' no parms') else begin write(lp,' parms:'); dumpelist(actualp,false); writeln(lp) end end; casest: dumpcasest(curstmt); compndst: begin write(lp,'compndst':10); dumpbody(' cbody:: stptr); begin write(lp,name); if body=nil then write(lp,'nil') else write(lp,body^.snum:1); end (*namebody*); procedure dumpbody (name: alpha; body: stptr); begin incrlinecount; namebody(name,body); writeln(lp);  ',cbody) end; forst: begin incrlinecount; write(lp,'forst':10); writeln(lp,' ctrl: ',ctrl^.enum:1,', init: ',init^.enum:1, ', incr ',incr:1,', limit: ',limit^.enum:1); write(lp,' ':40); dumpbody('fbody: ', write(lp,'fcallnode':12); setdenonode: write(lp,'setdenonode':12); subscrnode: write(lp,'subscrnode':12); substrnode: write(lp,'substrnode':12); idnode: write(lp,'idnode':12); litnode: write(lp,'litnode':12);  dumpstmts(body) end (*dumpbody*); procedure dumpcasest (curstmt: stptr); var lclabp: clabptr; lstmt,nextsave: stptr; begin with curstmt^ do begin incrlinecount; writeln(lp,'casest':10,' nrlabs: ',nrlabs:1,', nrstmts: ',n otherwise write(lp,' eclass is garbage: ',ord(cls):1) end; end; begin (*dumpexprs*) lexp := firstexp^.echain; incrlinecount; if lexp = nil then writeln(lp,' no expressions') else begin writeln(lp,'ENUM'rstmts:1, ', selecter: ',selecter^.enum:1); write(lp,' ':40); namebody('firstmt: ',firstmt); namebody(', otherwyse: ',otherwyse); incrlinecount; writeln(lp); incrlinecount; writeln(lp,' ':40,'case list elements:'); lclabp := min:5,'EKIND':6,'TYPE':9,'ECLASS':12); repeat with lexp^ do begin incrlinecount; write(lp,enum:5); case ekind of cnst: write(lp,'cnst':6); vrbl: write(lp,'vrbl':6); xpr: write(lp,'xpr':6) end; lab; while lclabp <> nil do with lclabp^ do begin incrlinecount; writeln(lp,' ':40,lowval:1,'..',hival:1,': ',cstmt^.snum:1); lclabp := clabp end; lstmt := firstmt; while lstmt<>nil do with lstmt^ do be if etyptr = boolptr then write(lp,'bool':9) else if etyptr = char_ptr then write(lp,'char':9) else if etyptr = intptr then write(lp,'int':9) else if etyptr = shortintptr then write(lp,'shortint':9) else if etyptr = realptr then gin nextsave := next; next := nil; dumpstmts(lstmt); next := nextsave; lstmt := nextsave end; dumpstmts(otherwyse) end (* with curstmt^ *) end (*dumpcasest*); begin (*dumpstmts*) while curstmt<>nil write(lp,'real':9) else if etyptr = nil then write(lp,'NIL':9) else case etyptr^.form of scalar: write(lp,'scalar':9); subrange: write(lp,'subrange':9); prok: write(lp,'prok':9); funk: write(lp,'funk':9); pointedo with curstmt^ do begin write(lp,snum:5); if next<>nil then write(lp,next^.snum:7) else write(lp,'NIL':7); if labp<>nil then write(lp,labp^.labval:7) else write(lp,' ':7); write(lp,lineno:7); write(lp,' '); case sclass of becomest: br: write(lp,'pointer':9); power: write(lp,'power':9); arrays: write(lp,'arrays':9); records: write(lp,'records':9); files: write(lp,'files':9); otherwise write(lp,' form=',ord(etyptr^.form):3) end; printclass(eclass); egin incrlinecount;writeln(lp,'becomest':10,' lhs: ',lhs^.enum:1, ', rhs: ',rhs^.enum:1); end; pcallst: begin incrlinecount; write(lp,'pcallst':10); writename(2,psymptr^.namep^); if actualp = nil      fbody) end; gotost: begin incrlinecount; writeln(lp,'gotost':10, ' target: ',target^.labval:1); end; ifst: begin incrlinecount; write(lp,'ifst':10,' ifcond: ',ifcond^.enum:1); namebinecount; writeln(lp); end; dumpsymbol(fname,0); incrlinecount; writeln(lp) end; $IF FULLDUMP$ incrlinecount; writeln(lp,' SNUM NEXT LABEL LINENO SCLASS'); dumpstmts(curbody); incrlinecount; writeln(lp); duody(', tru: ',tru); namebody(', fals: ',fals); writeln(lp); dumpstmts(tru); dumpstmts(fals) end; repst: begin write(lp,'repeatst':10,' rcond: ',rcond^.enum:1); dumpbody(', rbody: ',rbody) end; whilest: begin write(lp,mpexprs; $END$ incrlinecount; writeln(lp,fprocp^.namep^,' dump complete'); incrlinecount; writeln(lp); if ioresult <> ord(inoerror) then begin listabort := true; list := listnone; listopen := false; warning'whilest':10,' rcond: ',rcond^.enum:1); dumpbody(', rbody: ',rbody) end; tryst: begin incrlinecount; write(lp,'tryst':10); namebody(' tbody: ',tbody); namebody(', recov: ',recov); writeln(lp); dumpstmts(tbo(linenumber,'Listing aborted'); end; end; end (*dumptree*); dy); dumpstmts(recov); end; withst: begin write(lp,'withst':10,' record: ',refexpr^.enum:1); dumpbody(', wbody: ',wbody) end; emptyst: begin incrlinecount; writeln(lp,'emptyst':10); end; endofbodys {file DEBGDEFINE} import globals,compio,sysglobals; {$Z600} export procedure dumptree (curbody: stptr; fprocp: ctp); t: begin incrlinecount; writeln(lp,' endofbodyst'); end; otherwise begin incrlinecount; writeln(lp,' sclass is garbage: ',ord(sclass):1) end; end (*case*); curstmt := next end (*with curstmt^*) end (*du{Schema file: DEVDR- compile entire compiler} $SEARCH 'CONVERT'$ $IOCHECK OFF$ $UCSD,MODCAL,DEBUG$ program Compiler (input,output); $INCLUDE 'CHEADING'$ {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} module globals; $INCLUDE 'CCONSTmpstmts*); $END$ begin (*dumptree*) if (initlistmode = listfull) and listopen then begin incrlinecount; writeln(lp); incrlinecount; writeln(lp,'Dump of ',fprocp^.namep^); with display[top] do begin if occur = MODULEsS'$ $INCLUDE 'GLOBALS'$ const { Conditional compilation constants } ovflchecking = true; $OVFLCHECK ON$ rangechecking = true; $RANGE ON$ partialevaling = false; $PARTIAL_EVAL OFF$ implement end; {- - - - - - - - - - - - - cope then begin incrlinecount; writeln(lp,'Imported:'); lstate := fmodule^.modinfo^.usemodule; begin dumpsymbol(fmodule^.modinfo^.useids,0); while lstate <> nil do begin dumpsymbol(lstate^.defineids,0); lstate := lstate^.nextmod- - - - - - - - - - - - - - - - - -} $INCLUDE 'FORWINIT'$ {abstract module COMPINIT} $INCLUDE 'FORWUTILS'$ $LINENUM 1000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compio; {source input, listing output, lexical analysiule; end; end; incrlinecount; writeln(lp); incrlinecount; writeln(lp,'Exported:'); lstate := fmodule; while lstate <> nil do begin dumpsymbol(lstate^.defineids,0); lstate := lstate^.contmodule; end; incrlinecount; writeln(lp); incrls} $INCLUDE 'IODEF'$ $INCLUDE 'SCANNER'$ end; {compio} $LINENUM 3000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compdebug; {compiler debugging utilities - all empty routines in production copies} $INCLUDE 'DEBGDEF'$ $INCL     - - - - - - - - - - - - - - - - - - - - - - - - - - - -} module codegen; {module codegen: implement section} $INCLUDE 'GENCODE'$ end; {codegen} $LINENUM 18000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module bodyanalyzer; {Se if op = neop then actualp := makeintparm(1) {scanwhile} else begin actualp := makeintparm(0); error(125); end; insymbol; end else begin actualp := makeintparm(0); error(125); end; ex2 := charparm(fsys); if sy=comma then insymbol else eyntax analysis for executable statements; tree building} $INCLUDE 'BODYDEF'$ $INCLUDE 'BODYHEAD'$ $INCLUDE 'EXPRESSN'$ $INCLUDE 'STATEMENT'$ $INCLUDE 'BODY'$ end; {bodyanalyzer} $LINENUM 21000${- - - - - - - - - - - - - - - - - - - - - - - - rror(20); ex3 := anyparm(fsys,false); actualp^.nextptr := ex3; {link parameters in same order as scanwhile} ex3^.nextptr := ex2; ex2^.nextptr := ex1; end; end; procedure addr; { Process addr (variable [,offset]): anyptr } UDE 'DUMPTREE'$ end; {compdebug} $LINENUM 4000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module symtable; {symbol table entry/lookup, structure manipulation} $INCLUDE 'SYMDEF'$ $INCLUDE 'SYMTABLE'$ $INCLUDE 'STRUCTS'$ end; {sym- - -} module declanalyzer; {Syntax analysis for declarations; symbol table building} $INCLUDE 'DECLDEF'$ $INCLUDE 'PARAMLIST'$ $INCLUDE 'TYP'$ $INCLUDE 'BLOCK'$ end; {declanalyzer} $LINENUM 24000${- - - - - - - - - - - - - - - - - - - - - -table} {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} forward module codegen; {Code generation for the target machine} $INCLUDE 'GENDEF'$ end; forward module genutils; $INCLUDE 'GENUTLDEF'$ end; forward module genmove; $INCL - - - - -} module compinit; {compiler initialization plus general purpose utilities} $INCLUDE 'INITDEF'$ $INCLUDE 'INIT'$ $INCLUDE 'UTILITIES'$ end; {compinit} $LINENUM 26000${- - - - - - - - - - - - - - - - - - - - - - - - - -} import globaUDE 'GENMOVDEF'$ end; forward module float_hdw; $INCLUDE 'FLOATDEF'$ end; $LINENUM 5000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module assemble; $INCLUDE 'ASSMDEF'$ $INCLUDE 'ASSEMBLE'$ end; {assemble} $LINENUM 6000${- - - ls,compinit,compio,symtable, declanalyzer,codegen,genutils; begin {Modcal_Cross_Compiler} $INCLUDE 'MAINBODY'$ end. - - - - - - - - - - - - - - - - - - - - - - -} module genutils; {utilities for code generation} $INCLUDE 'GENUTIL'$ end; {genutils} $LINENUM 9000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module genexprmod; {code generation for expr {file EXPRESSION} procedure funcref (fcp: ctp; fsys: setofsys); (* create tree for function reference *) var lexp: exptr; parmptr: ctp; tp: elistptr; realval: real; procedure splfuncref; (* reference to special function *) essions} $INCLUDE 'GENEXPDEF'$ $INCLUDE 'GENEXPR'$ end; {genexprmod} $LINENUM 12000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module float_hdw; {code generation for float card} $IF MC68020$ $INCLUDE 'MC68881'$ $END$  var lexp: exptr; lval,lmin,lmax: integer; sexp: elistptr; s: string[255]; waslparent,folded: boolean; procedure wsscan; { Process scan (bytecount, testchar, source): integer } var ex1,ex2,ex3: elistptr; begin wit $IF not MC68020$ $INCLUDE 'FLOAT'$ $END$ end; {float_hdw} $LINENUM 13000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module genmove; {expression utilities, packing} $INCLUDE 'GENMOVE'$ end; {genmove} $LINENUM 15000${h lexp^ do begin eclass := fcallnode; ekind := xpr; etyptr := intptr; fptr := fcp; ex1 := integerparm(fsys); if sy=comma then insymbol else error(20); if sy=relop then begin if op = eqop then actualp := makeintparm(0) {scanuntil} els      { & absaddr (variable [,offset]): anyabsptr } begin with lexp^ do begin eclass := fcallnode; ekind := xpr; fptr := fcp; etyptr := anyptrptr; actualp := anyparm(fsys,false); with actualp^.expptr^ do if (ekind = cnst) and (etyptr <> nerror(125) else if lcp2^.strucwaspackd then error(125); end; if lsp <> nil then {remember size; set LSP = TAGFIELD struct} with lsp^ do begin lsize := unpacksize; if sizeoflo then error(672); if form = records then lil) then if etyptr^.form = prok then error(125) else warning(linenumber+1, '''ADDR'' of a constant may not be supported on other implementations'); if sy <> comma then actualp^.nextptr := nil else begin insymbol; actualp^.nextptr := insp := recvar else lsp := nil; end; end else error(2); getvariantsize(fsys, lsp, lsize); {look for variants} with lexp^ do {return an integer constant expression} begin eclass := litnode; ekind := cnst; etyptr tegerparm(fsys); end; end; end (*addr*); procedure blockio; { Process blockread/write(file, buffer, nblocks [, blocknum]): integer } var lxlp: elistptr; begin with lexp^ do begin eclass := fcallnode; ekind := xpr;:= intptr; litval.intval := true; litval.ival := lsize; end; end; {sizefunc} begin (*splfuncref*) with fcp^ do begin insymbol; if sy = lparent then begin insymbol; waslparent := true end else begin waslparent := f etyptr := intptr; fptr := fcp; lxlp := fileparm(fsys,untyped); actualp := lxlp; if sy = comma then insymbol else error(20); lxlp^.nextptr := anyparm(fsys,fcp^.spkey=spblockread); lxlp:=lxlp^.nextptr; if sy = comma then insymbol else error(20); alse; if (spkey <> speof) and (spkey <> speoln) then error(9); end; if spkey in [spabs..spsucc] then expression(fsys+[rparent]); lexp := newexpr; case spkey of spabs,spsqr: begin with curexp^ do if etyptr <> nil then  lxlp^.nextptr := integerparm(fsys); lxlp := lxlp^.nextptr; if sy <> comma then lxlp^.nextptr := makeintparm(-1) else begin insymbol; lxlp^.nextptr := integerparm(fsys); end; end; end (*blockio*); procedure sizefunc; {SIZEOF fun if not arithtype(etyptr) then error(125); with lexp^ do begin etyptr := curexp^.etyptr; folded := false; if curexp^.eclass = litnode then if spkey = spabs then begin eclass := litnode; ekind := cnst; folded := true; with lction} var lcp,lcp2: ctp; lsp: stp; lsize: addrrange; begin lsp := nil; lsize := 0; if sy=ident then begin {get type of type name or identifier} searchid([types,konst,vars,field],lcp); if lcp^.klass = types thenitval do if etyptr = intptr then try $ovflcheck on$ intval := true; ival := abs(curexp^.litval.ival); $if not ovflchecking$ $ovflcheck off$ $end$ recover begin if escapecode = -4 th {type name} begin lsp := lcp^.idtype; if lsp=strgptr then error(125); insymbol; end else {variable name} begin identproc(fsys+[comma,rparent]); lsp := curexp^.etyptr; lcp2 := NIL; en error(301); end else if etyptr = realptr then begin if not inbody then error(50); intval := false; new(valp,true,reel); valp^.cclass := reel; valp^.rval := abs(curexp^.litval.valp^.rval); end  if curexp^.eclass = selnnode then lcp2 := curexp^.fieldptr else if curexp^.eclass = unqualfldnode then lcp2 := curexp^.fieldref; if (lcp2 <> NIL) and (not allow_packed) then if lcp2^.klass = field then if lcp2^.fispackd then else {error} begin intval := true; ival := 0; etyptr := nil; end; end else {sqrnode} if curexp^.litval.intval and ((not MC68020) or (float = flt_off)) then try $ovflcheck on$ lval := sqr(curexp^     etyptr <> nil then if not (etyptr^.form in [scalar,subrange,pointer]) then error(125); with lexp^ do begin etyptr := intptr; if curexp^.eclass <> litnode then begin eclass := ordnode; ekind := xpr; opnd := curexp; pr; etyptr := intptr; opnd := curexp; end; end; sppred,spsucc: begin with curexp^ do begin lmin := minint; lmax := maxint; if etyptr <> nil then with etyptr^ do if form > subrange then error(125) else if form = subr end else begin eclass := litnode; ekind := cnst; litval := curexp^.litval; end; end; end; spstrlen,splength: with lexp^ do begin etyptr := intptr; folded := false; if curexp^.etyptr <> nil then iange then getbounds(rangetype,lmin,lmax) else getbounds(etyptr,lmin,lmax); folded := false; if eclass = litnode then with litval do if intval then try $ovflcheck on$ if spkey = spsucc then lval := ival+1 else .litval.ival); $if not ovflchecking$ $ovflcheck off$ $end$ folded := true; eclass := litnode; ekind := cnst; with litval do begin intval := true; ival := lval end; recover if escapecode = -4 then f not strgvalue(curexp) then error(125) else if curexp^.eclass=litnode then if curexp^.etyptr=char_ptr then begin litval.ival := 1; folded := true; end else with curexp^.litval.valp^ do if cclass = paofch then begin error(301) else escape(escapecode); if not folded then begin ekind := xpr; opnd := curexp; if spkey = spsqr then eclass := sqrnode else eclass := absnode; end; end; end; spchr: begin with curexp^ do litval.ival := slgth; folded := true; end; if not folded then begin eclass := strlennode; ekind := xpr; opnd := curexp; end else begin eclass := litnode; ekind := cnst; litval.intval := tru if (etyptr <> nil) and (etyptr <> intptr) and (etyptr <> shortintptr) then error(125); with lexp^ do begin eclass := chrnode; ekind := xpr; etyptr := char_ptr; opnd := curexp; if curexp^.eclass = litnode then with e; end; end; spstrmax: with lexp^ do begin etyptr := intptr; eclass := strmaxnode; ekind := xpr; opnd := curexp; if curexp^.etyptr <> nil then if not strgtype(curexp^.etyptr) then error(125) else if curexcurexp^.litval do if not intval then error(125) else if (ival<0) or (ival>255) then error(125) else begin eclass := litnode; ekind := cnst; litval := curexp^.litval; end; end; {with lexp^} end; spodd: begin with curep^.ekind<>vrbl then error(125) else if curexp^.etyptr<>strgptr then begin eclass := litnode; ekind := cnst; with litval do begin intval := true; ival := curexp^.etyptr^.maxleng; end; end; end; spconcat: with lexp^, fcpxp^ do if (etyptr<>nil) and (etyptr<>intptr) and (etyptr <> shortintptr) then error(125); with lexp^ do begin etyptr := boolptr; if curexp^.eclass = litnode then begin ekind := cnst; eclass := litnode; with litval do ^ do begin eclass := fcallnode; fptr := fcp; ekind := xpr; etyptr := idtype; sexp := stringparm(fsys); actualp := sexp; while sy = comma do begin insymbol; sexp^.nextptr := stringparm(fsys); sexp := sexp^.nextptr;  begin intval := true; ival := ord(odd(curexp^.litval.ival)) end; end else {operand not constant} begin eclass := oddnode; ekind := xpr; opnd := curexp end; end; {with lexp^} end; spord: begin with curexp^ do if  end; end; spround,sptrunc: begin with curexp^ do if etyptr<>nil then if etyptr<>realptr then error(125); with lexp^ do begin if spkey = sptrunc then eclass := truncnode else eclass := roundnode; ekind := x     lval := ival-1; $if not ovflchecking$ $ovflcheck off$ $end$ folded := true; recover if escapecode = -4 then error(301) else escape(escapecode) ; end; {with curexp^} with lexp^ do begin etyptr :y) else actualp := fileparm(fsys,textphile) else begin actualp := newexplist; if inputptr <> NIL then actualp^.expptr := makefileexp(inputptr) else begin error(185); actualp^.expptr := NIL; end; end;= curexp^.etyptr; if folded then begin eclass := litnode; ekind := cnst; with litval do begin intval := true; ival := lval; if (lvallmax) then error(303); end; end else begin ekind := xpr;  end; otherwise error(651) end; (*case spkey*) end; (*with fcp^*) curexp := lexp; if waslparent then if sy = rparent then insymbol else error(4); end (*splfuncref*); begin (*funcref*) if not inbody and stdpasc then error if spkey = spsucc then eclass := succnode else eclass := prednode; opnd := curexp; end; {not folded} end; {with lexp^} end; spaddr: addr; spsizeof: sizefunc; spscan: wsscan; spblockread, spblockwrite: blockio; spmaxpos,(606); with fcp^ do if (klass = func) and (pfdeckind = special) then splfuncref else begin (* standard or declared func *) insymbol; lexp := newexpr; with lexp^ do begin eclass := fcallnode; ekind := xpr; etyptr := idtypspposition,splinepos: with lexp^ do begin eclass := fcallnode; ekind := xpr; etyptr := intptr; fptr := fcp; if spkey = splinepos then begin error(651); if waslparent then actualp := fileparm(fsys,textphile); end e; actualp := nil; fptr := fcp; if klass = func then parmptr := next else parmptr := proktype^.params; if sy = lparent then begin actparmlist(fsys,actualp,parmptr); if sy = rparent then insymbol else error(4); if (klass = func) and (pf else actualp := fileparm(fsys,directfile); end; sphex,spoctal,spbinary: with lexp^ do begin eclass := fcallnode; ekind := xpr; etyptr := intptr; fptr := fcp; actualp := stringparm(fsys); folded := false; with actualdeckind = standard) then if (spkey = spstrpos) then if switch_strpos then with lexp^ do begin { switch parameters } actualp^.nextptr^.nextptr := actualp; actualp := actualp^.nextptr; actualp^.nextptr^.nextptr := NIL; end p^.expptr^ do if (eclass=litnode) and not litval.intval then with litval.valp^ do if cclass=strng then begin setstrlen(s,slgth); moveleft(sval[1],s[1],slgth); folded := true; end; if folded then try ca else if strpos_warn then warning(linenumber+1, 'STRPOS does not conform to HP standard, see $SWITCH_STRPOS$') else if (spkey in [spsin,spcos,spsqrt,spln,spexp,sparctan]) then with actualp^ do if (expptr^.eclass = litnode) and se spkey of sphex: lval := hex(s); spoctal: lval := octal(s); spbinary: lval := binary(s); end; eclass := litnode; ekind := cnst; litval.intval := true; litval.ival := lval; recover if inbody then {not called by const ((not MC68020) or (float = flt_off)) then begin try with expptr^.litval.valp^ do case spkey of spsin: realval := sin(rval); spcos: realval := cos(rval); spsqrt: realval := sqrt(rval); spln: realval := ant so give the error here} error(50); end; speoln,speof: with lexp^ do begin eclass := fcallnode; ekind := xpr; etyptr := boolptr; fptr := fcp; if waslparent then if spkey = speof then actualp := fileparm(fsys,anln(rval); spexp: realval := exp(rval); sparctan: realval := arctan(rval); end; {case} recover if (escapecode = -6) or (escapecode = -7) or ((escapecode <= -15) and (escapecode >= -17)) then begin error(     shortint; (* bias relative element value *) max_bias : shortint; (* max ordinal bias *) high_bias : shortint; (* range high bias *) cur_bias : shortint; (* current ordinal bias *) rnd else {set type is known} begin if not comptypes(lsp,settype^.elset) then error(137); end; if sy = rangesy then begin insymbol; expression(fsys+[comma,rbrack]); if not comptypes(lsp,curexp^.etyptr) then error(137); end; if (leel_high : shortint; (* current bias's high relative ord *) $end$ $if not bigsets$ constpart: set of SETLOW..SETHIGH; $end$ lmin,lmax,i: integer; begin insymbol; unknowntype := (settype=nil); if unknowntype then begin xp^.eclass=litnode) and (curexp^.eclass=litnode) and not unknowntype then begin {constant element} if not lexp^.litval.intval or not curexp^.litval.intval or (lexp^.litval.ival < settype^.setmin) or (curexp^.litval.ival > settype^.setma50); realval := 0.0; end else escape(escapecode); eclass := litnode; ekind := cnst; litval.intval := false; litval.valp := opnd^.litval.valp; litval.valp^.rval := realval; litval.valp^.cclass := reel;  new(settype,power); with settype^ do (*create new set type*) begin form := power; elset := nil; ispackable := false; sizeoflo := false; $if bigsets$ unpacksize := SETDEFAULTSIZE; align := SETALIGN; setmin := SETLOW; setmax  end; end else if parmptr <> nil then error(126) end; (* with lexp^ *) curexp := lexp; if curexp^.eclass = fcallnode then tp := curexp^.actualp else tp := NIL; curexp^.num_ops := 0; while tp <> NIL do begin if tp^.e:= SETDEFAULTHIGH; $end$ $if not bigsets$ unpacksize := SETSIZE; align := SETALIGN; setmin := SETLOW; setmax := SETHIGH; $end$ info := sysinfo; end; end; setexp := newexpr; with setexp^ do begin eclass := setdenonode; ekxpptr^.num_ops > curexp^.num_ops then curexp^.num_ops := tp^.expptr^.num_ops; tp := tp^.nextptr; end; if klass = routineparm then begin {make func id the first param} tp := newexplist; tp^.nextptr := curexp^.actualp; curexp^.actualp := tp; ind := xpr; etyptr := settype; setcstpart.intval := false; setcstpart.valp := nil; setvarpart := nil; end; $if bigsets$ constpart := NIL; endptr := NIL; max_bias := -1; cur_bias := -1; $end$ $if not bigsets$ constpart := []; $end$ htp^.expptr := newexpr; with tp^.expptr^ do begin ekind := vrbl; eclass := idnode; etyptr := proktype; symptr := curexp^.fptr; end; end; {routineparm} end; (* standard or declared func *) end (*funcref*); procedure setdeno (*fsys: setofsascstpart:=false; hasvarpart:=false; if sy <> rbrack then repeat expression(fsys+[comma,rbrack,rangesy]); lexp := curexp; lsp := curexp^.etyptr; if lsp<>nil then if unknowntype then begin if lsp^.form <> scalar then error(136) eys; settype: stp*); label 1; var unknowntype,hascstpart,hasvarpart,ldone: boolean; setexp,lexp: exptr; lxlp: elistptr; lsp: stp; $if bigsets$ constpart: setrecptr; (* head of set record list *) endptr : setrecptr; lse begin settype^.elset := lsp; unknowntype := false; if (lsp<>intptr) and (lsp<>shortintptr) then begin getbounds(lsp,lmin,lmax); if lmax > SETHIGH then error(658) else with settype^ do begin setmax := lma (* tail of set record list *) s : setrecptr; (* current set record *) j : shortint; (* simple counter *) bias : shortint; (* set list ordinal bias index *) rel_elem : x; (*** if lmax+1 < bitsperword then begin ispackable := true; signbit := false; bitsize := lmax+1 end; ***) unpacksize := setlensize + SETELEMSIZE * ((lmax + setelembits) div setelembits) end end end e     x) then error(182) else if lexp^.litval.ival > curexp^.litval.ival then error(50) else $if bigsets$ begin high_bias := curexp^.litval.ival div (oldsethigh+1); i := lexp^.litval.ival; repeat bias := i div (oldsethigh+1); <> NIL then begin s := constpart; bias := 0; while ( s^.nxt <> NIL ) do begin s := s^.nxt; bias := bias + 1; end; i := (bias+1) * (oldsethigh+1) - 1; if ( i > settype^.setmax ) then i := settype^.setmax; rel_e rel_elem := i mod (oldsethigh+1); if ( bias > max_bias ) then (* need new chunk(s) for set *) begin repeat max_bias := max_bias + 1; new( s ); with s^ do begin nxt := NIL; val := []; end; lem := i MOD (oldsethigh + 1); for j := rel_elem downto 0 do if j in s^.val then begin plgth := ( j + ( bias * (oldsethigh + 1) ) + 1 ); goto 1; end; end; (* if constpart <> NIL *) $end$ $if not bigsets$  if ( endptr <> NIL ) then begin (* add to end/list *) endptr^.nxt := s; endptr := s; end else begin (* begin new list *) endptr := s; constpart := s; end; until ma for i:=settype^.setmax downto settype^.setmin do if i in constpart then begin plgth:=i+1; goto 1 end; $end$ 1: pval := constpart; end; curexp := setexp end (*setdeno*); procedure makedummyexpr(fcp: ctp); begin curexp := newexpr; wx_bias = bias; end else (* fits in current chunk list *) begin s := constpart; for j := 0 to (bias - 1) do s := s^.nxt; end; cur_bias := bias; if bias = high_bias then rel_high := curexp^.litval.ival mod (oith curexp^ do begin eclass := idnode; etyptr := NIL; ekind := vrbl; symptr := fcp; end; end; procedure constructor (fsys: setofsys; fsp: stp); (* Parse a set constructor of the given type *) var lsp: stp; lvalu: valu; begildsethigh+1) else rel_high := oldsethigh; for j := rel_elem to rel_high do s^.val := s^.val + [ j ]; i := i + rel_high - rel_elem + 1; until ( i >= curexp^.litval.ival); end; $end$ $if not bigsets$ for i := lexp^.litval.ivaln if stdpasc then error(606); if fsp = nil then begin skip(fsys+[rbrack]); if sy=rbrack then insymbol; end else if fsp^.form = power then setdeno(fsys,fsp) else begin error(655); skip(fsys+[rbrack]);  to curexp^.litval.ival do constpart := constpart + [i]; $end$ hascstpart := true; end else begin {variable element} if hasvarpart then begin new(lxlp^.nextptr,true); lxlp := lxlp^.nextptr end else begin new(setexp^.setvarp if sy=rbrack then insymbol; makedummyexpr(uvarptr); end; end; {constructor} procedure funcresult (fcp: ctp); (* create a tree for assignment to function name *) begin curexp := newexpr; with curexp^ do begin eclass := idnode; eart); lxlp := setexp^.setvarpart end; with lxlp^ do begin nextptr := nil; lowptr := lexp; hiptr := curexp end; hasvarpart := true; end; ldone := sy <> comma; if not ldone then insymbol; until ldone; if sy = rbrack then insymbol elsekind := vrbl; etyptr := fcp^.idtype; symptr := fcp; with fcp^ do if klass = routineparm then error(103) else if pfdeckind <> declared then error(150) else if not inscope then error(177); end; if fcp^.pfdeckind = declared the error(12); if hasvarpart then setexp^.ekind := xpr else setexp^.ekind := cnst; new(setexp^.setcstpart.valp,true,pset); with setexp^.setcstpart.valp^ do begin cclass := pset; plgth:=0; { now find highest "on" bit } $if bigsets$ if constpart n fcp^.assignedto := true; insymbol; end (*funcresult*); procedure cast(fsys: setofsys; fsp: stp); procedure casttypecheck(fsp1,fsp2: stp); var lform1,lform2: structform; begin if (fsp1<>nil) and (fsp2<>nil) then begin l     roc(*fsys: setofsys*); (* parse identifier in an expression *) var lcp: ctp; procedure makeroutineconst(fcp: ctp); var proctyp: stp; begin with fcp^ do if pfdeckind <> declared then error(652) else if klass = prox then identproc*) procedure expression (*fsys: setofsys*); var lexp: exptr; procedure simpleexpression (fsys: setofsys); var lsigned,lpositive,sywaslit: boolean; lexp: exptr; procedure term (fsys: setofsys); var lexp: exptr; lop: operator;  if ismodulebody then error(704); new(proctyp,prok); with proctyp^ do begin ispackable := false; sizeoflo := false; unpacksize := PROKSIZE; align := PROKALIGN; info := sysinfo; params := fcp^.next; if fcp^.klass = prox procedure factor (fsys: setofsys); var oldvarparm: boolean; procedure notoperation (fsys: setofsys); var lnot: exptr; begin insymbol; factor(fsys); with curexp^ do begin if (etyptr <> nil) and (etyptr <> boolptr) then error(135);form1 := fsp1^.form; lform2 := fsp2^.form; if (lform1 in [scalar,subrange,reals,pointer]) and (lform2 in [scalar,subrange,reals,pointer]) then { For FSDdt03843 : } begin if fsp1^.unpacksize <> fsp2^.unpacksize then begin if ((lform1 = po then form := prok else form := funk; end; curexp := newexpr; with curexp^ do begin ekind := cnst; eclass := idnode; etyptr := proctyp; symptr := fcp; end; insymbol; end; {makeroutineconst} begin {identproc} if inter) and (lform2 = scalar) and (fsp1^.unpacksize = 4) and (fsp2^.unpacksize = 2) and (curexp^.ekind = XPR)) then begin { DO NOTHING } end else error(134) end end else if lform1 <> lform2 then error(134) end; sy <> ident then error(2) else begin searchid([types,konst,vars,field,func,prox,routineparm],lcp); case lcp^.klass of types: begin insymbol; if sy = lbrack then constructor(fsys,lcp^.idtype) else if sy = lparent then beg end; {casttypecheck} begin {cast} if not modcal then error(612); if fsp = strgptr then error(732); insymbol; expression(fsys+[rparent]); if sy = rparent then insymbol else error(4); casttypecheck(fsp,curexp^.etyptr); curexp^.etyptr := fin cast(fsys,lcp^.idtype); selector(fsys) end else begin error(6); skip(fsys); makedummyexpr(lcp); end; end; konst: begin constid(lcp); selector(fsys) end; vars: begin variable(lcp); selector(fsys) end; sp; end; {cast} procedure assignableid (fsys: setofsys; fcp: ctp); (* handle lhs of assignment statement *) begin case fcp^.klass of types: begin insymbol; if sy = lparent then begin cast(fsys,fcp^.idtype); selector(fsys);  field: begin unqualfield(lcp); selector(fsys) end; routineparm: if donteval or (lcp^.vtype = procparm) then begin curexp := newexpr; with curexp^ do begin ekind := vrbl; eclass := idnode; etyptr := lcp^.proktype; symptr  end else begin if modcal then error(9) else error(103); skip(fsys); makedummyexpr(fcp); end; end; vars: begin variable(fcp); selector(fsys); { Check for FOR loop variable } if cantassign:= lcp; end; insymbol; end else begin if lcp^.vtype <> funcparm then error(103); funcref(lcp,fsys); selector(fsys); end; func: if donteval then makeroutineconst(lcp) else begin f in fcp^.info then error(702); end; field: begin unqualfield(fcp); selector(fsys) end; routineparm, func: begin funcresult(fcp); if sy=arrow then error(6); selector(fsys); end; end; end (*assignableid*); procedure identpuncref(lcp,fsys); selector(fsys) end; prox: makeroutineconst(lcp); end; {case} with curexp^ do if etyptr <> nil then if (etyptr^.form = subrange) and not varparm then etyptr := etyptr^.rangetype; end; (*sy = ident*) end; (*      if (ekind = xpr) and (eclass in [eqnode,nenode,ltnode,lenode,gtnode,genode]) then case eclass of eqnode: eclass := nenode; nenode: eclass := eqnode; ltnode: eclass := genode; lenode: eclass := gtnode; gtnode: eclass := lenode; exptemp: exptr; fold_ok: boolean; realval: real; procedure powerof2(fexp: exptr; var res: integer); var i: integer; begin res := 0; with fexp^.litval do if intval then for i := 1 to 14 do if ival = power_table[i] then re; genode: eclass := ltnode; end else begin lnot := newexpr; with lnot^ do begin etyptr := boolptr; if curexp^.eclass <> litnode then begin ekind := xpr; eclass := notnode; opnd := curexp; num_ops := opnd^.num_s := i; end; begin {muloptypecheck} with curexp^ do begin fold_ok := true; num_ops := opnd1^.num_ops + opnd2^.num_ops; lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr; if (lltype = nil) or (lrtype = nil) then etyptr := nil else ops; end else {fold} begin if not inbody then error(50); ekind := cnst; eclass := litnode; with litval do begin intval := true; ival := abs(curexp^.litval.ival-1); end; end; end; {with lnot^} curexp := l begin if [arrays,records,files,pointer,prok] * [lltype^.form,lrtype^.form] <> [] then error(134) else case lop of mul: begin if lltype^.form = power then begin eclass := intersectnode; if comptypes(lltype,lrnot; end; end; {with curexp^} end (*notoperation*); begin (*factor*) if not (sy in facbegsys) then begin error(58); skip(fsys+facbegsys); if not (sy in facbegsys) then curexp := newexpr; end; while sy in fatype) then begin if lltype^.setmax > lrtype^.setmax then etyptr := lrtype {Result type = smaller} end else error(129); end else if arithtype(lltype) and arithtype(lrtype) then begin if lltype<>lcbegsys do begin oldvarparm := varparm; if sy<>ident then varparm := false; case sy of intconst, realconst, stringconst: begin oldvarparm := varparm; varparm := false; literals; varparm := oldvarparm; end;rtype then begin if not shortintandint(lltype,lrtype) then if not trytowiden(opnd1,lrtype) then if not trytowiden(opnd2,lltype) then error(999); {should never get here!} etyptr := opnd1^.etyptr; end en ident: identproc(fsys); lbrack: begin oldvarparm := varparm; varparm := false; setdeno(fsys,nil); varparm := oldvarparm; end; notsy: notoperation(fsys); lparent: begin insymbol; expression(fsys+[rparent]); id else begin error(134); fold_ok := false; end; if eclass = mulnode then if (opnd1^.eclass = litnode) and (opnd2^.eclass <> litnode) then begin powerof2(opnd1,res); if res <> 0 then begin eclass :f (curexp <> NIL) and (curexp^.ekind = vrbl) then curexp^.ekind := xpr; if not inbody and (curexp^.etyptr=realptr) then error(750); if sy = rparent then insymbol else error(4) end; end; (*case*) if not (sy in fsys) then = shftnode; exptemp := opnd1; opnd1 := opnd2; opnd2 := exptemp; opnd2^.litval.ival := res end; end else if (opnd1^.eclass <> litnode) and (opnd2^.eclass = litnode) then begin powerof2(opnd2,res); if res <> 0 then b begin error(6); skip(fsys+facbegsys) end end; (*while*) end (*factor*); procedure muloptypecheck; (* type checker, constant folder for '*','/','div','mod','and' *) var lltype,lrtype: stp; llval,lrval,lval: integer; res: integeregin eclass := shftnode; opnd2^.litval.ival := res end; end; end; idiv,imod: begin if (lltype <> intptr) and (lltype <> shortintptr) or (lrtype <> intptr) and (lrtype <> shortintptr) then begin error(134); etyptr := intptr     lval mod lrval; end; {case} $if not ovflchecking$ $ovflcheck off$ $end$ recover if escapecode = -4 then error(301) else escape(escapecode); eclass := litnode; ekind := cnst; num_ops := 1; { result ofval = ord(true)) then { true and xxx : fold out and operation } curexp := opnd2; end; otherwise {do nothing} ; end { case } else if fold_ok and (opnd2^.eclass = litnode) then case eclass of mulnode: if (op folding 2 operands } with litval do begin intval := true; ival := lval end; end {constant folding integer} else if inbody and (etyptr = realptr) and ((not MC68020) or (float = flt_off)) then begin try if eclass = mulnode thend2^.litval.intval) then begin if (opnd2^.litval.ival = 0) then { xxx * 0 : fold out mul operation } curexp := opnd2 else if (opnd2^.litval.ival = 1) then { xxx * 1 : fold out mul operation } curexp := opnd end; if opnd2^.eclass = litnode then if opnd2^.litval.ival = 0 then error(300) else if (eclass = divnode) and (opnd1^.eclass <> litnode) then begin powerof2(opnd2,res); if res <> 0 then begin ecn realval := opnd1^.litval.valp^.rval * opnd2^.litval.valp^.rval else { eclass = divnode } realval := opnd1^.litval.valp^.rval / opnd2^.litval.valp^.rval; recover if (escapecode = -6) or (escapecode = -7) orlass := shftnode; opnd2^.litval.ival := -res; end; end else if eclass = modnode then if opnd2^.litval.ival < 0 then begin error(125); opnd2^.litval.ival := 1; end; end; rdiv: begin etyptr := realptr; if (escapecode = -5) then begin realval := 0.0; error(301); end else escape(escapecode); eclass := litnode; ekind := cnst; num_ops := 1; { result of folding 2 operands } with litval do begin valp := opnd1^.li lltype<>etyptr then if not trytowiden(opnd1,etyptr) then begin error(134); fold_ok := false; end; if lrtype<>etyptr then if not trytowiden(opnd2,etyptr) then begin error(134); fold_oktval.valp; valp^.rval := realval; valp^.cclass := reel; intval := false; end; end; end else if fold_ok and (opnd1^.eclass = litnode) then case eclass of mulnode: if (opnd1^.litval.intval) then begin if := false; end; end; andop: if (lltype <> boolptr) or (lrtype <> boolptr) then begin error(134); etyptr := boolptr end end; (*case lop*) if fold_ok and (opnd1^.eclass = litnode) and (opnd2^.eclass = litnode) then  (opnd1^.litval.ival = 0) then { 0 * xxx : fold out mul operation } curexp := opnd1 else if (opnd1^.litval.ival = 1) then { 1 * xxx : fold out mul operation } curexp := opnd2; end else if (opnd1^.litval.valp^ begin if opnd1^.litval.intval and opnd2^.litval.intval then begin llval := opnd1^.litval.ival; lrval := opnd2^.litval.ival; if eclass = andnode then begin if not inbody then error(50); lval := ord( (llval=1) and (lrval=1) ); .cclass = reel) and (opnd1^.litval.valp^.rval = 0.0) then { 0.0 * xxx : fold out mul operation } curexp := opnd1 else if (opnd1^.litval.valp^.cclass = reel) and (opnd1^.litval.valp^.rval = 1.0) then { 1.0 * xxx : fold  end else try $ovflcheck on$ case eclass of mulnode: lval := llval*lrval; divnode: if lrval = 0 then error(300) else lval := llval div lrval; modnode: if lrval = 0 then error(300) else lval := lout mul operation } curexp := opnd2; andnode: if (opnd1^.litval.intval) then begin if (opnd1^.litval.ival = ord(false)) then { false and xxx : fold out and operation } curexp := opnd1 else if (opnd1^.litval.i     1; end else if (opnd2^.litval.valp^.cclass = reel) and (opnd2^.litval.valp^.rval = 0.0) then { xxx * 0.0 : fold out mul operation } curexp := opnd2 else if (opnd2^.litval.valp^.cclass = reel) and (opnd2^.litval.valp^ with fexp^ do if eclass = litnode then begin if etyptr = char_ptr then stretch := true else if litval.valp^.cclass = paofch then stretch := true else { struct const } stretch := false; if stretch then .rval = 1.0) then { xxx * 1.0 : fold out mul operation } curexp := opnd1; divnode: if (opnd2^.litval.intval) then begin if (opnd2^.litval.ival = 1) then { xxx DIV 1 : fold out DIV operation } curexp := opnd begin if etyptr=char_ptr then lgth := 1 else lgth := litval.valp^.slgth; stretchpaofchar(etyptr,litval,lgth); etyptr^.aisstrng := true; etyptr^.unpacksize := lgth+1; litval.valp^.cclass := strng; end; 1; end else if (opnd2^.litval.valp^.cclass = reel) and (opnd2^.litval.valp^.rval = 1.0) then { xxx / 1.0 : fold out division operation } curexp := opnd1; andnode: if (opnd2^.litval.intval) then begin if (opnd2^. end; end; begin {addoptypecheck} with curexp^ do begin num_ops := opnd1^.num_ops + opnd2^.num_ops; fold_ok := true; lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr; if (lltype = nil) or (lrtype = nil) then etyptr := nil else begin litval.ival = ord(false)) then { xxx and false : fold out and operation } curexp := opnd2 else if (opnd2^.litval.ival = ord(true)) then { xxx and true : fold out and operation } curexp := opnd1; end; otherwise  if [records,files,pointer,prok] * [lltype^.form,lrtype^.form] <> [] then error(134) else case eclass of addnode,subnode: if lltype^.form = power then begin if comptypes(lltype,lrtype) then begin if eclass = add {do nothing} ; end; { case } end; (*types <> nil*) end (*with curexp^*) end (*muloptypecheck*); begin (*term*) factor(fsys+[mulop]); if (sy = mulop) and not inbody and stdpasc then error(606); while sy = mulop do begin lenode then begin eclass := unionnode; if lltype^.setmax < lrtype^.setmax then etyptr := lrtype; {Result type = larger} end else eclass := diffnode; {Result type = left side} end else error(129); xp := newexpr; lop := op; with lexp^ do begin case op of mul: eclass := mulnode; rdiv,idiv: eclass := divnode; imod: eclass := modnode; andop: eclass := andnode end; etyptr := curexp^.etyptr;  end else if arithtype(lltype) and arithtype(lrtype) then begin if lltype<>lrtype then begin if not shortintandint(lltype,lrtype) then if not trytowiden(opnd1,lrtype) then if not trytowiden(opnd2,lltype) then error(99 ekind := xpr; opnd1 := curexp; insymbol; factor(fsys+[mulop]); opnd2 := curexp; curexp := lexp; muloptypecheck end (* with lexp^ *) end (* sy=mulop *) end (*term*); procedure addoptypecheck; (* typ9); {should never get here!} etyptr := opnd1^.etyptr; end end else if (eclass = addnode) and strgvalue(opnd1) and strgvalue(opnd2) then begin if stdpasc then error(606); eclass := concatnode; new(etyptre checker for binary plus and minus, and 'or' *) var lltype,lrtype: stp; llval,lrval,lval: integer; fold_ok: boolean; realval: real; optemp : exptr; procedure trytomakestr(fexp: exptr); var stretch: boolean; lgth: shortint; begin ); etyptr^ := strgptr^; trytomakestr(opnd1); trytomakestr(opnd2); end else begin error(134); fold_ok := false; end; ornode: if (lltype <> boolptr) or (lrtype <> boolptr) then begin error(134); etyptr := boolpt     nd; end else if fold_ok and (opnd1^.eclass = litnode) then case eclass of addnode: if (opnd1^.litval.intval) then begin if (opnd1^.litval.ival = 0) then { 0 + xxx : fold out the add operation } curexp := opnd2; ode: if (opnd2^.litval.intval) and (opnd2^.litval.ival = ord(true)) then { xxx or true : fold out the or operation } curexp := opnd2 else if (opnd2^.litval.intval) and (opnd2^.litval.ival = ord(false)) then { xxx or false : fold o end else if (opnd1^.litval.valp^.cclass = reel) and (opnd1^.litval.valp^.rval = 0) then { 0.0 + xxx : fold out the add operation } curexp := opnd2; subnode: if (opnd1^.litval.intval) then begin if (opnd1^.litval.ival=0) then ut the or operation } curexp := opnd1; otherwise {do nothing} ; end; { case } end; (*types <> nil*) end; (*with curexp^*) end (*addoptypecheck*); begin (*simpleexpression*) lsigned := false; if sy = addop then r end end; (*case eclass*) if fold_ok and (opnd1^.eclass = litnode) and (opnd2^.eclass = litnode) then begin if opnd1^.litval.intval and opnd2^.litval.intval then begin llval := opnd1^.litval.ival; lrval := opnd2^.litval.ival begin { 0 - xxx : turn subtract into a negate node } optemp := opnd2; eclass := negnode; opnd := optemp; num_ops := optemp^.num_ops; end; end else if (opnd1^.litval.valp^.cclass = reel) and (opnd1^.litval.valp^.; if eclass = ornode then begin if not inbody then error(50); lval := ord((llval=1) or (lrval=1)); end else {addnode,subnode} try $ovflcheck on$ if eclass = addnode then lval := llval+lrval else lval := llval-lrvalrval = 0) then begin { 0.0 - xxx : turn subtract into a negate node } optemp := opnd2; eclass := negnode; opnd := optemp; num_ops := optemp^.num_ops; end; ornode: if (opnd1^.litval.intval) and (opnd1^.litval.ival = ord; $if not ovflchecking$ $ovflcheck off$ $end$ recover if escapecode = -4 then error(301) else escape(escapecode); eclass := litnode; ekind := cnst; num_ops := 1; { result of folding 2 operands } with litva(true)) then { true or xxx : fold out the or operation } curexp := opnd1 else if (opnd1^.litval.intval) and (opnd1^.litval.ival = ord(false)) then { false or xxx : fold out the or operation } curexp := opnd2; otherwise {do nl do begin intval := true; ival := lval end; end else if inbody and (etyptr = realptr) and ((not MC68020) or (float = flt_off)) then begin try if eclass = addnode then realval := opnd1^.litval.valp^.rval + opothing} ; end else if fold_ok and (opnd2^.eclass = litnode) then case eclass of addnode: if (opnd2^.litval.intval) then begin if (opnd2^.litval.ival = 0) then { xxx + 0 : fold out the add operation } curexp := opndnd2^.litval.valp^.rval else { ecalss = subnode } realval := opnd1^.litval.valp^.rval - opnd2^.litval.valp^.rval; recover if (escapecode = -6) or (escapecode = -7) then begin error(301); realval := 0.0; end else 1; end else if (opnd2^.litval.valp^.cclass = reel) and (opnd2^.litval.valp^.rval = 0) then { xxx + 0.0 : fold out the add operation } curexp := opnd1; subnode: if (opnd2^.litval.intval) then begin if (opnd2^.litval.ival=0)escape(escapecode); eclass := litnode; ekind := cnst; num_ops := 1; { result of folding 2 operands } with litval do begin intval := false; new(valp,true,reel); valp^.rval := realval; valp^.cclass := reel; end; e then { xxx - 0 : fold out the subtract operation } curexp := opnd1; end else if (opnd2^.litval.valp^.cclass = reel) and (opnd2^.litval.valp^.rval = 0) then { xxx - 0.0 : fold out the subtract node } curexp := opnd1; orn     if op in [plus,minus] then begin lsigned := true; lpositive := (op=plus); uminus := not lpositive; insymbol; uminus := false; sywaslit := (sy = intconst) or (sy = realconst); end; term(fsys+[addop]); if lsigned then with curexp^ do packed array of char literals can be padded with blanks. } begin $PARTIAL_EVAL ON$ with opnd2^.etyptr^ do if (opnd1^.etyptr = char_ptr) and (opnd1^.eclass = litnode) and paofchar(opnd2^.etyptr) and (not {opnd2^.etyptr^.}aisstrng) a if etyptr <> nil then if not arithtype(etyptr) then error(105) else if not (lpositive or sywaslit) then if (eclass = litnode) and (etyptr = intptr) then if litval.ival = minint then error(661) else litval.ival := -litval.ival nd isPAC({opnd2^.etyptr^.}inxtype) and ({opnd2^.etyptr^.}inxtype^.max = 0) then {Change char literal to a packed array of char literal of length 1} stretchpaofchar(opnd1^.etyptr,opnd1^.litval,1); $IF not partialevaling$ $PARTIAL_EVAL  else if (eclass = litnode) and (etyptr = realptr) then litval.valp^.rval:= -litval.valp^.rval else begin lexp := newexpr; with lexp^ do begin etyptr := curexp^.etyptr; eclass := negnode; ekind := xpr; opnd := curexp; OFF$ $END$ end; begin with curexp^ do begin num_ops := opnd1^.num_ops + opnd2^.num_ops; lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr; if (lltype <> nil) and (lrtype <> nil) then if eclass = innode then b end; curexp := lexp end; if (sy = addop) and not inbody and stdpasc then error(606); while sy = addop do begin lexp := newexpr; with lexp^ do begin case op of plus: eclass := addnode; minus: eclass := subnode; oroegin if lrtype^.form <> power then error(130) else if not comptypes(lltype,lrtype^.elset) then error(129); if opnd1^.eclass = litnode then if not opnd1^.litval.intval or (opnd1^.litval.ivalsethigh) then p: eclass := ornode end; etyptr := curexp^.etyptr; ekind := xpr; opnd1 := curexp; insymbol; term(fsys+[addop]); opnd2 := curexp; curexp := lexp; addoptypecheck end (* with lexp^ *) end (* sy=addop *) end (*simpleexpreserror(182) else if opnd2^.eclass = litnode then begin ekind := cnst; eclass := litnode; $if bigsets$ bias := opnd1^.litval.ival DIV (oldsethigh + 1); rel_elem := opnd1^.litval.ival MOD (oldsethigh + 1); s := opnd2^.litvalsion*); procedure reltypecheck; (* checks operands of the relational node ref'd by curexp *) var lltype,lrtype: stp; llval,lrval: integer; lclass: exprs; l_realval,r_realval: real; is_in : boolean; .valp^.pval; is_in := false; if s <> NIL then begin j := 0; while ( (s^.nxt <> NIL) and (j < bias) ) do begin s := s^.nxt; j := j + 1; end; if j = bias then is_in := rel_elem in s^.val; end; $end$ $(* is element in set ? *) $if bigsets$ j : shortint; (* simple local counter *) s : setrecptr; (* current set record item *) bias, rel_elem: shortint; (* ordinal bias and relative eleif not bigsets$ is_in := opnd1^.litval.ival in opnd2^.litval.valp^.pval; $end$ llval := ord( is_in ); with litval do begin intval := true; ival := llval end; end; end else begin (* relational op *) if lltype <> lrtment value in list *) $end$ procedure check_for_special_situation(opnd1,opnd2 : exptr); { Bug fix for the specific situation of a character literal begin compared with an empty packed array of char literal. ('A' = '') This is allowed becauseype then {check for arithmetic widening} if arithtype(lltype) and arithtype(lrtype) then begin if not shortintandint(lltype,lrtype) then if not trytowiden(opnd1,lrtype) then if not trytowiden(opnd2,lltype) then error(999     ); eqnode: ival := ord(llval = lrval); nenode: ival := ord(llval <> lrval); end; end; end else if inbody and (etyptr = realptr) then begin l_realval := opnd1^.litval.valp^.rval; r_realval := opnd2^.litval.valp^.rval; add_64_base = float_card_base + hex('4000'); sub_64_base = float_card_base + hex('4020'); mul_64_base = float_card_base + hex('4040'); {tst.w base+(source*4)+dest} div_64_base = float_card_base + hex('4060'); neg_64_base = float_card_b with litval do begin intval := true; case eclass of ltnode: ival := ord(l_realval < r_realval); lenode: ival := ord(l_realval <= r_realval); gtnode: ival := ord(l_realval > r_realval); genode: ival := ord(l_realval ase + hex('4080'); abs_64_base = float_card_base + hex('40a0'); { Memory / Chip operations base addresses are for F0. Addresses for other register operands decrease. } { Chip to memory -- base-(regnum*4) } read_32_base = float_card_); {should never get here!} lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr; end; if comptypes(lltype,lrtype) then begin case lltype^.form of pointer: if not (eclass in [eqnode,nenode]) then error(131); prok:>= r_realval); eqnode: ival := ord(l_realval = r_realval); nenode: ival := ord(l_realval <> r_realval); end; { case } end; { with litval } eclass := litnode; ekind := cnst; num_ops := 1; { result of folding 2 operands } end;  if eclass in [eqnode,nenode] then begin if (opnd1^.ekind = cnst) and (opnd2^.ekind = cnst) then begin lclass := eclass; eclass := litnode; ekind := cnst; litval.intval := true; if opnd1^.symptr = opnd2^.symptr then litv end {compatible types} else begin check_for_special_situation(opnd1,opnd2); check_for_special_situation(opnd2,opnd1); if not paofcharcomp(opnd1,opnd2^.etyptr) then if not paofcharcomp(opnd2,opnd1^.etyptr) then error(129);al.ival := ord(lclass = eqnode) else litval.ival := ord(lclass = nenode); end; end else error(131); power: case eclass of lenode: eclass := subsetnode; genode: eclass := supersetnode; ltnode,gtnode: err end; end (*relational op*) end (*with curexp^*) end (*reltypecheck*); begin (*expression*) simpleexpression(fsys+[relop]); if sy = relop then begin if not inbody and stdpasc then error(606); lexp := newexpr; or(132); otherwise end; arrays: if not paofchar(lltype) then error(133); records,files: error(133); cnfarrays: error(133); otherwise end; (*case*) if (opnd1^.eclass = litnode) and (opnd2^.eclass = l with lexp^ do begin case op of ltop: eclass := ltnode; leop: eclass := lenode; geop: eclass := genode; gtop: eclass := gtnode; neop: eclass := nenode; eqop: eclass := eqnode; inop: eclass := innode end; ekind := xpr; etyptritnode) then if opnd1^.litval.intval and opnd2^.litval.intval then begin if not inbody then error(50); llval := opnd1^.litval.ival; lrval := opnd2^.litval.ival; lclass := eclass; eclass := litnode; ekind := cnst; num_ops := 1; { result o := boolptr; opnd1 := curexp; insymbol; simpleexpression(fsys); opnd2 := curexp end; curexp := lexp; reltypecheck end (* sy = relop *) end (*expression*); f folding 2 operands } with litval do begin intval := true; case lclass of ltnode: ival := ord(llval < lrval); lenode: ival := ord(llval <= lrval); gtnode: ival := ord(llval > lrval); genode: ival := ord(llval >= lrval { file FLOAT } import sysglobals, codegen, assemble, genutils, genexprmod; implement const float_card_base = hex('5c0000'); { 64 and 32 bit operations base address is for F0 op F0. The addresses increase for other operands. }      base + hex('456c'); { Memory to chip -- base-(regnum*4) } write_32_base = float_card_base + hex('44fc'); { Memory to chip -- base-(regnum*2) } float64_base = float_card_base + hex('452c'); var maxFregused: shortint; Dreg: array callstdproc('ASM_FLPT_ERROR'); end; procedure wait; var op1,op2: attrtype; bogus_read1,bogus_read2: regrange; rt: regtype; rn: regrange; begin with op1 do begin addrmode := longabs; gloptr :=[regrange] of regrange; rmask: attrtype; error_status_reg: regrange; procedure NIL_attributes(fexp: exptr); { Called as part of the $FLOAT TEST$ option } var ptr: elistptr; begin with fexp^ do begin attr := NIL NIL; offset := 0; absaddr.intval := true; absaddr.ival := float_card_base + 22; end; bogus_read1 := getreg(D); bogus_read2 := getreg(D); error_status_reg := getreg(D); with op2 do begin addrmode := multi; case eclass of eqnode, nenode, ltnode, lenode, gtnode, genode, innode, subsetnode, supersetnode, unionnode, diffnode, intersectnode, concatnode, addnode, subnode, mulnode, divnode, modnode, shftnode, ornode, andnode: begin NIL_attributes(ople; storage := long; for rt := A to D do for rn := 0 to maxreg do regs[rt,rn] := false; regs[D,bogus_read1] := true; regs[D,bogus_read2] := true; regs[D,error_status_reg] := true; end; emit2(movem,op1,op2); pnd1); NIL_attributes(opnd2); end; negnode, notnode, floatnode, derfnode, succnode, bufnode, absnode, chrnode, oddnode, ordnode, prednode, strlennode, strmaxnode, roundnode, sqrnode, truncnode: NIL_attributes(opnd); subscrnode: begin NILfreeit(D,bogus_read1); freeit(D,bogus_read2); freeit(D,error_status_reg); end; procedure wait_test_error; begin wait; test_error; end; procedure no_wait_test_error; var op1, op2: attrtype; begin with op1 _attributes(arayp); NIL_attributes(indxp); end; substrnode: begin NIL_attributes(arayp); NIL_attributes(indxp); NIL_attributes(lengthp); end; selnnode: NIL_attributes(recptr); fcallnode: begin ptr := actualp; while ptr <do begin addrmode := immediate; smallval := 3; end; with op2 do begin addrmode := longabs; gloptr := NIL; offset := 0; absaddr.intval := true; absaddr.ival := float_card_base + 33; stora> NIL do begin NIL_attributes(ptr^.expptr); ptr := ptr^.nextptr; end; end; setdenonode: begin ptr := setvarpart; while ptr <> NIL do begin NIL_attributes(ptr^.lowptr); NIL_attributes(ptr^.hiptr); ptr := ge := bytte; end; emit2(btst,op1,op2); with op1 do begin offset := 6; storage := bytte; end; emit1(beq,op1); callstdproc('ASM_FLPT_ERROR'); end; function getregpair: regrange; var first_reg,secptr^.nextptr; end; end; otherwise { Terminal node } end; { case } end; { with } end; { NIL_attributes } procedure test_error; var op1,op2: attrtype; begin with op1 do begin addrmode := immediate; ond_reg : shortint; begin first_reg := getreg(F); second_reg := getreg(F); getregpair := first_reg; end; procedure loadrealvalue(fexp: exptr); { Load 64 bit real into 2 floating point registers } var op : attrtype;  smallval := 3; end; with op2 do begin addrmode := inDreg; regnum := error_status_reg; end; emit2(btst,op1,op2); with op1 do begin offset := 6; storage := bytte; end; emit1(beq,op1);  begin makeaddressable(fexp); if fexp^.attr^.addrmode <> inFreg then begin with op do begin regnum := getregpair; addrmode := longabs; offset := 0; storage := long; gloptr := NIL; absaddr.intval := true; absaddr.ival := write_32      emit1(pea,op2); freeregs(fexp^.attr); end; procedure moverealvalue(fexp: exptr; var at: attrtype); { Addrmode is inFreg. Move 64 bit real from the floating point registers to the address in at. } var op: attrtype; begsed do reg[D,Dreg[i]].allocstate := free; end; end; procedure realop(fexp: exptr); var op1,op2: attrtype; begin with fexp^, attr^ do case eclass of negnode,absnode,sqrnode: { 64 bit } begin loadrealvalue(opndin makeaddressable(fexp); with op do begin addrmode := longabs; offset := 0; gloptr := NIL; absaddr.intval := true; absaddr.ival := read_32_base - fexp^.attr^.regnum*4 - 4; end; at.storage := long; ); with op1 do begin addrmode := longabs; storage := wrd; offset := 0; gloptr := NIL; absaddr.intval := true; case eclass of negnode: absaddr.ival := neg_64_base + opnd^.attr^.regnum * 5; absnode: absaddr_base - regnum*4 - 4; end; with fexp^ do begin freeregs(attr); emit2(move,attr^,op); op.absaddr.ival := op.absaddr.ival + 4; attr^.offset := attr^.offset + 4; checkoffset(fexp); emit2(move,attr^,op); attr^.storage := multi; attr^.addrmode :emit2(move,op,at); op.absaddr.ival := op.absaddr.ival + 4; at.offset := at.offset + 4; emit2(move,op,at); at.offset := at.offset - 4; at.storage := multi; freeregs(fexp^.attr); end; procedure saverealregs; var rt: r= inFreg; attr^.regnum := op.regnum; end; { with fexp^ } end; end; procedure pushrealvalue(fexp: exptr); { Addrmode is inFreg. Move the 64 bit real number onto the stack. } var op: attrtype; begin makeaddressableegtype; rn: regrange; i: shortint; op: attrtype; begin maxFregused := maxreg; while (maxFregused > 0) and (reg[F,maxFregused].allocstate <> allocated) do maxFregused := maxFregused - 1; if maxFregused > 0 then w(fexp); with op do begin addrmode := longabs; offset := 0; gloptr := NIL; absaddr.intval := true; absaddr.ival := read_32_base - fexp^.attr^.regnum*4; end; SPminus.storage := long; emit2(move,op,SPminusith rmask do begin addrmode := multiple; storage := long; for rt := A to D do for rn := 0 to maxreg do regs[rt,rn] := false; for i := 0 to maxFregused do begin Dreg[i] := getreg(D); regs[D,Dreg[i]] := true; end; with op do be); op.absaddr.ival := op.absaddr.ival - 4; emit2(move,op,SPminus); freeregs(fexp^.attr); fexp^.attr^.addrmode := topofstack; end; procedure pushrealaddress(fexp: exptr); { Addrmode is inFreg. Move to a temporary. Push the agin addrmode := longabs; storage := long; offset := 0; gloptr := NIL; absaddr.intval := true; absaddr.ival := read_32_base - 4*maxFregused; end; emit2(movem,op,rmask); { Load Fregs into D registers } op.storage := bytte; op.absadddress of the temporary.} var op1,op2: attrtype; begin makeaddressable(fexp); getlocstorage(8,op2); op2.storage := long; with op1 do begin addrmode := longabs; offset := 0; gloptr := NIL; absaddrdr.ival := float_card_base + 33; emit1(clr,op); { reset float card state after movem } end; end; procedure reloadrealregs; var op: attrtype; i: shortint; begin if maxFregused > 0 then begin with.intval := true; absaddr.ival := read_32_base - (fexp^.attr^.regnum+1)*4; end; emit2(move,op1,op2); op1.absaddr.ival := op1.absaddr.ival + 4; op2.offset := op2.offset + 4; emit2(move,op1,op2); op2.offset := op2.offset - 4;  op do begin addrmode := longabs; storage := long; offset := 0; gloptr := NIL; absaddr.intval := true; absaddr.ival := write_32_base - 4*maxFregused; end; emit2(movem,rmask,op); { reload Fregs from D registers } for i := 0 to maxFregu     .ival := abs_64_base + opnd^.attr^.regnum * 5; sqrnode: absaddr.ival := mul_64_base + opnd^.attr^.regnum * 5; end; { case } end; emit1(tst,op1); if eclass = sqrnode then wait_test_error else wait; addrmode := inFreg; regnum  { file REALDEF } import globals; export procedure NIL_attributes(fexp: exptr); procedure loadrealvalue(fexp: exptr); procedure pushrealvalue(fexp: exptr); procedure pushrealaddress(fexp: exptr); procedure moverealvalue(fexp: exptr; := opnd^.attr^.regnum; storage := multi; signbit := true; end; floatnode: { int to 64 bit } begin makeaddressable(opnd); with op1 do begin addrmode := longabs; storage := long; offset := 0; gloptr := NIL; abvar at: attrtype); procedure saverealregs; procedure reloadrealregs; procedure realop(fexp: exptr); saddr.intval := true; end; extend(opnd,long); regnum := getregpair; storage := multi; op1.absaddr.ival := float64_base - regnum*2; emit2(move,opnd^.attr^,op1); signbit := true; addrmode := inFreg; freeregs(opnd^.attr); wait; {file FORWDECLS} forward module compinit; import globals,sysglobals; export procedure constant (fsys: setofsys; var fsp: stp; var fvalu: valu); function compvalus (v1,v2: valu): shortint; procedure countbits (v: integer; var nbits: sho end; subnode, addnode, mulnode, divnode: { 64 bit } begin { Evaluate a complicated operand first } if opnd1^.num_ops >= opnd2^.num_ops then begin loadrealvalue(opnd1); loadrealvalue(opnd2); end else begin loadrealvalue(opnd2); lortint; var needsignbit: boolean); function allocate (var flc: addrrange; fsp: stp; incrlc: boolean; minalign: shortint) : addrrange; end; {compinit} adrealvalue(opnd1); end; with op1 do begin addrmode := longabs; offset := 0; gloptr := NIL; absaddr.intval := true; storage := wrd; case eclass of subnode: absaddr.ival := sub_64_base + opnd2^.attr^.regnum*4 forward module genutils; export function min(a,b:integer): integer; procedure outputsymbol; end;  + opnd1^.attr^.regnum; addnode: absaddr.ival := add_64_base + opnd2^.attr^.regnum*4 + opnd1^.attr^.regnum; mulnode: absaddr.ival := mul_64_base + opnd2^.attr^.regnum*4 + opnd1^.attr^.regnum; divnode: { file GENCODE } import genexprmod,assemble,genutils,genmove,fs,ci,float_hdw; implement procedure bigmove (var source,dest: attrtype; wdstomove: integer; A1isfree: boolean; bytetomove: boolean); (* source - will be A0+ or A1+ or disp(Areg absaddr.ival := div_64_base + opnd2^.attr^.regnum*4 + opnd1^.attr^.regnum; end; { case } end; { with op1} emit1(tst,op1); addrmode := inFreg; regnum := opnd1^.attr^.regnum; signbit := true; storage := opnd1^.attr^.sto) dest - will be A0+ or A1+ or disp(Areg) for disp(Areg), Areg is (A0, A1 or A6) disp may not be zero wdstomove- is a word count not a byte count A1isfree - reflects the mode of addressing the dest *) var curmove: shortint; rage; freeregs(opnd2^.attr); wait_test_error; end; end; { case eclass } end; { realop }  multiple,op: attrtype; begin if source.addrmode <> locinreg then begin source.offset := 0; source.gloptr := NIL; source.indexed := false; end; if dest.addrmode <> locinreg then begin dest.offset := 0;     = 0; indexed := false; gloptr := NIL; end; storage := wrd; end; multiple.storage := wrd; emit2(movem,source,multiple); emit2(movem,multiple,dest); dest.offset := dest.offset + wdstomove * 2; source.offsetlval := smallval + 1; end; emit2(move,op,SPminus); callstdproc('ASM_MOVEL'); { if bytetomove then reloadregs; } { <==== JWH 11/17/88 } source.offset := source.offset + op.smallval; dest.offset := dest.offset + op.smallval;  := source.offset + wdstomove * 2; wdstomove := 0; end; 6,8,10,12..24: begin {move multiple long words} if not A1isfree and (wdstomove > 22) then curmove := 11{long words} else curmove := wdstomove DIV 2;  end; end; { bigmove } procedure genbody (curbody: stptr; fprocp: ctp); type initlocvartype = (isnew,isdispose); procedure initlocvar (varid: ctp; heapaddr: exptr; disp: addrrange; fsp: stp; initype: initlocvartype); { in dest.gloptr := NIL; dest.indexed := false; end; if wdstomove < 28 then while wdstomove > 0 do case wdstomove of 1: begin with source do if addrmode <> locinreg then begin addrmode := locinreg; offset := wdstomove := wdstomove - curmove*2; if wdstomove = 0 then begin with source do if addrmode <> locinreg then begin addrmode := locinreg; offset := 0; indexed := false; gloptr := NIL; end; with dest do 0; indexed := false; gloptr := NIL; end; with dest do if addrmode <> locinreg then begin offset := 0; indexed := false; addrmode := locinreg; gloptr := NIL; end; dest.storage := wrd; emit2(move,source,dest); if addrmode <> locinreg then begin addrmode := locinreg; offset := 0; indexed := false; gloptr := NIL; end; end; dest.storage := long; multiple.storage := long; getmultattr(curmove,A1isfree,multiple); emi wdstomove := 0; dest.offset := dest.offset + 2; source.offset := source.offset + 2; end; 2..4: begin if wdstomove = 2 then begin with source do if addrmode <> locinreg then begin addrmode := loct2(movem,source,multiple); emit2(movem,multiple,dest); dest.offset := dest.offset + curmove*4; source.offset := source.offset + curmove*4; end; otherwise {move multiple 11 or 12 long words} begin curmove := 11 + oinreg; offset := 0; indexed := false; gloptr := NIL; end; with dest do if addrmode <> locinreg then begin offset := 0; addrmode := locinreg; indexed := false; gloptr := NIL; end; end; dest.storage := lrd(A1isfree); wdstomove := wdstomove - curmove * 2; getmultattr(curmove,A1isfree,multiple); multiple.storage := long; emit2(movem,source,multiple); dest.storage := long; emit2(movem,multiple,dest); dest.offset := dong; emit2(move,source,dest); wdstomove := wdstomove-2; dest.offset := dest.offset + 4; source.offset := source.offset + 4; end; 5,7,9,11: begin {move multiple words} getmultattr(wdstomove,A1isfree,multiple); est.offset + curmove*4; source.offset := source.offset + curmove*4; end; end {case} else { BIG bigmove } begin { if bytetomove then saveregs; } { <===== jwh 11/17/88 } forgetbaseregs; source.addrmode := locinreg with source do if addrmode <> locinreg then begin addrmode := locinreg; offset := 0; indexed := false; gloptr := NIL; end; with dest do begin if addrmode <> locinreg then begin addrmode := locinreg; offset :; dest.addrmode := locinreg; emit1(pea,source); emit1(pea,dest); SPminus.storage := long; with op do begin addrmode := immediate; smallval := wdstomove * 2; if bytetomove then { <======= jwh 11/17/88 } smal     itialize local variables. Base points to id for variable. Disp is offset from varid's location. Fsp points to structure of current var or one of its fields or elements. } var lmin,lmax: integer; lsize,lcnt: integer; lcp: ctp; initype = isnew then begin if filtype = NIL then begin emit1(clr,SPminus); {CLR.L -(SP) assumes nilvalue = 0} with op2 do begin addrmode := immediate; smallval := -1; end; emit2(move,op2,SPminus); { MOVE.L #-1,-(SP) } op1,op2,op3 : attrtype; patchloc: addrrange; procedure varaddress(opcd: opcodetype; disp: addrrange); var op1 : attrtype; begin if varid <> NIL then with varid^, op1 do begin if vtype < localvar then begin  end else begin varaddress(pea,disp+filesize); if (filtype^.unpacksize=1) then with op2 do begin addrmode := immediate; if fsp = textptr then smallval := -3 else smallval := -2; emit2(move,op2,SP gloptr := NIL; case vtype of shortvar: addrmode := shortabs; longvar: addrmode := longabs; relvar: addrmode := prel; end; absaddr := varid^.absaddr; offset := disp; end else begin addrmode := lociminus); end else with op2 do begin addrmode := immediate; smallval := filtype^.unpacksize; emit2(move,op2,SPminus); end; end; callstdproc('FS_FINITB'); end else { initype = isdispose nreg; offset := disp + vaddr; indexed := false; if vlev = 1 then begin regnum := SB; gloptr := currentglobal; end else begin regnum := localbase; gloptr := NIL; end; end; storage := long} begin SPminus.storage := wrd; emit1(clr,SPminus); callstdproc('FS_FCLOSE'); end; if varid <> NIL then if varid^.vtype = localvar then with varid^ do begin with op3 do begin addrmode := locinreg; ; emit1(opcd,op1); freeregs(addr(op1)); end else { varid = NIL: heap variable } begin if disp = 0 then pushaddress(heapaddr) else if disp > 32767 then begin pushaddress(heapaddr); with op1 do begin addroffset := disp + vaddr; indexed := false; if vlev = 1 then begin regnum := SB; gloptr := currentglobal; end else begin regnum := localbase; gloptr := NIL; end; end; { with op3 } getregattr(A,op1); mode := immediate; smallval := disp; end; SPind.storage := long; emit2(addi,op1,SPind); end else begin loadaddress(heapaddr,false); with heapaddr^.attr^ do begin addrmode := locinreg; offset := disp; emit2(lea,op3,op1); with op1 do begin addrmode := locinreg; offset := 4; indexed := false; gloptr := nil; end; SBind.offset := FIBptrdisp; SBind.storage := long; SBind.gloptr := sy indexed := false; emit1(pea,heapaddr^.attr^); offset := 0; end; end; freeregs(heapaddr^.attr); end; end; begin { initlocvar } if fsp <> NIL then with fsp^ do if mustinitialize in info then case form of fisglobalptr; emit2(move,SBind,op1); op1.addrmode := inAreg; emit2(move,op1,SBind); freeit(A,op1.regnum); SBind.gloptr := NIL; end; { with varid^ } if modulebody then fixbyte(patchloc-1,codephile.bytecount-patchloles: begin if modulebody then begin varaddress(tst,disp+4); patchloc := codephile.bytecount + 2; op1.offset := 0; op1.storage := bytte; emit1(bne,op1); end; SPminus.storage := long; varaddress(pea,disp); if c); end; arrays: if inxtype <> NIL then begin getbounds(inxtype,lmin,lmax); if aeltype <> NIL then begin lsize := aeltype^.unpacksize; if odd(lsize) then lsize := lsize + 1; if (varid = NIL) and (lmax-l     nreg; regnum := getbasereg(cnf^.cnf_index^.hiboundid^.vlev); offset := cnf^.cnf_index^.hiboundid^.vaddr; indexed := false; gloptr := NIL; end; if op1.storage = bytte then begin op1.storage := long; emit1(clr,op1); op1.storage := bytte; end;ndid^.vaddr + 2; emit2(move,cnfsize_attr,op2); op2.storage := long; emit1(ext,op2); end else begin op2 := cnfsize_attr; op2.storage := long; op2.offset := cnf^.cnf_index^.hiboundid^.vaddr + 4; end; $IF MC68020$ emit2(muls,op emit2(move,hibound_attr,op1); getbounds(cnf^.inxtype,hi,lo); try big_range := hi - lo >= 32767; recover if escapecode = -4 {overflow} then big_range := true else escape(escapecode); lobound_attr := hibound_attr; 2,op1); with op do begin addrmode := inDreg; regnum := op1.regnum; storage := long; signbit := true; end; $END$ $IF not MC68020$ SPminus.storage := long; emit2(move,op1,SPminus); freeit(D,op1.regnum); emit2(momin > 0) then begin getlocstorage(ptrsize,op1); moveaddress(heapaddr,op1); op1.access := indirect; op2 := op1; end else if heapaddr <> NIL then op2 := heapaddr^.attr^; for lcnt:=0 to lmax-lmin do begi lobound_attr.offset := cnf^.cnf_index^.loboundid^.vaddr; if (op1.storage = long) or big_range then begin if op1.storage = wrd then begin op1.storage := long; emit1(ext,op1); with op2 do begin addrmode := inDreg; regnumn if heapaddr <> NIL then begin op1 := op2; heapaddr^.attr := addr(op1); end; initlocvar(varid,heapaddr, disp+lcnt*lsize,aeltype,initype); end; end; end; records: begin lcp  := getreg(D); storage := wrd; end; emit2(move,lobound_attr,op2); op2.storage := long; emit1(ext,op2); freeit(D,op2.regnum); end else begin op2 := lobound_attr; op2.offset := cnf^.cnf_index^.loboundid^.vaddr; op2.stora:= fstfld; if (varid = NIL) and (lcp^.next <> NIL) then begin getlocstorage(ptrsize,op1); moveaddress(heapaddr,op1); op1.access := indirect; op2 := op1; end else if heapaddr <> NIL then op2 := heapaddr^.attr^; while lcge := long; end; end else {wrd result} begin if op1.storage = bytte then begin op1.storage := wrd; with op2 do begin addrmode := inDreg; regnum := getreg(D); storage := long; end; lobound_attr.offset := cnf^p <> NIL do with lcp^ do begin if heapaddr <> NIL then begin op1 := op2; heapaddr^.attr := addr(op1); end; initlocvar(varid,heapaddr, disp+fldaddr,idtype,initype); lcp := lcp^.next; end; end; .cnf_index^.loboundid^.vaddr; emit1(clr,op2); op2.storage := bytte; emit2(move,lobound_attr,op2); op2.storage := wrd; freeit(D,op2.regnum); end else { op1.storage := wrd } begin op2 := lobound_attr; op2.offset := cnf^.cnf_index^otherwise escape(-8); end; {case} end; {initlocvar} procedure getcnfsize(cnf: stp; var op: attrtype); var lobound_attr, hibound_attr, cnfsize_attr, op1,op2: attrtype; hi,lo: integer; big_range: boolean; .loboundid^.vaddr; op2.storage := wrd; end; end; emit2(sub,op2,op1); op2.addrmode := immediate; op2.smallval := 1; emit2(addq,op2,op1); {hi - lo + 1} {multiply by size} cnfsize_attr := lobound_att begin with op1 do begin addrmode := inDreg; regnum := getreg(D); case cnf^.inxtype^.unpacksize of 1: storage := bytte; 2: storage := wrd; 4: storage := long; end; with hibound_attr do begin addrmode := locir; if op1.storage = long then {call routine} begin if cnf^.inxtype^.unpacksize = 2 then begin with op2 do begin addrmode := inDreg; regnum := getreg(D); storage := wrd; end; cnfsize_attr.offset := cnf^.cnf_index^.hibou     ve,op2,SPminus); if op2.addrmode = inDreg then freeit(D,op2.regnum); freeregs(addr(hibound_attr)); saveregs; forgetbaseregs; callstdproc('ASM_MPY'); reloadregs; with op do begin addrmode := topofstack; storage := long;or ((eclass in [ornode,andnode]) and not shortcircuit) then if eclass = subnode then treematch := branchmatch(lhs,opnd1) else if branchmatch(lhs,opnd1) then treematch := true else if branchmatch(lhs,opnd2) then begin tree signbit := true; end; $END$ end { multiply routine } else begin { in line multiply } if cnf^.inxtype^.unpacksize = 1 then begin with op2 do begin addrmode := inDreg; regnum := getreg(D); storage := wrd; match := true; temp := opnd1; opnd1 := opnd2; opnd2 := temp; end else treematch := false else treematch := false; end; {with rhs^} end; {treematch} procedure movemulti(source,dest: exptr; numbytes: intege end; cnfsize_attr.offset := cnf^.cnf_index^.hiboundid^.vaddr + 2; emit1(clr,op2); op2.storage := bytte; emit2(move,cnfsize_attr,op2); op2.storage := wrd; end else begin op2 := cnfsize_attr; op2.storage := wrd; op2.offsetr); var numregs : 0..13; {D0-D7,A0-A4} rt : regtype; rn : regrange; numwords,curmove: integer; oddnum : boolean; op,multiregs : attrtype; begin numwords := numbytes div 2; makeaddressable(source); makeaddressable(dest);  := cnf^.cnf_index^.hiboundid^.vaddr + 2; end; emit2(muls,op2,op1); if op2.addrmode = inDreg then freeit(D,op2.regnum); op := op1; op.storage := long; freeregs(addr(hibound_attr)); end; {Packed array ?} if cnf^.aispackd then begin  { If either source or dest has an index register the offset field in the 68010 addressing modes would be restricted to 8 bits. We can't be sure that the final word or byte moves would have an offset that would fit in 8 bits so we get rid of index{ turn bit count into a whole byte count } if op.addrmode <> inDreg then with op1 do begin addrmode := inDreg; regnum := getreg(D); storage := long; emit2(move,op,op1); freeregs(addr(op)); op := op1; end; with oing. } if (source^.attr^.addrmode in [locinreg, prel]) and source^.attr^.indexed then loadaddress(source,false); if (dest^.attr^.addrmode in [locinreg, prel]) and dest^.attr^.indexed then loadaddress(dest,false); if (numwords = 1)p1 do begin addrmode := immediate; smallval := 7; emit2(add,op1,op); smallval := 3; emit2(lsr,op1,op); end; end; end; end; procedure gencode(curstmt: stptr); var oldlc: addrrange; attrlistptr: attrptr;  or (numwords = 2) then begin if numwords = 1 then dest^.attr^.storage := wrd else dest^.attr^.storage := long; emit2(move,source^.attr^,dest^.attr^); if odd(numbytes) then begin with source^.attr^ do offset := offset+numbytes-1; with dest^ opnd: attrtype; i: shortint; p: reflistptr; procedure releaseattr; {release attribute records for the current statement} var p: attrptr; begin if attrlistptr <> NIL then begin p := attrlistptr; while p^.next.attr^ do offset := offset+numbytes-1; end; end else if numwords > 0 then begin numregs := 0; { build MOVEM format with list of available registers } for rt := A to D do for rn := 0 to maxreg do if (reg[rt,rn].allocstate = free) and ( <> NIL do p := p^.next; p^.next := freeattr; freeattr := attrlistptr; end; end; function treematch(lhs,rhs: exptr): boolean; var temp: exptr; begin {treematch} with rhs^ do begin if (eclass in [addnode,subnode]) numregs < numwords) then begin numregs := numregs + 1; if (rt = A) then forgetbasereg(rn); multiregs.regs[rt,rn] := true; end else multiregs.regs[rt,rn] := false; if numwords <= numregs then begin { enou     ffset := offset+2; end; {if oddnum} end {long word move multiple} else begin { not enough available regs, use D0-D7 and A2-A4 } clear(false); { set up source and dest pointers subject to : 1) addressing mode must use offset attributeeregs(source^.attr); freeregs(dest^.attr); end; {movemulti} procedure cnfassign(lhs,rhs: exptr); var op: attrtype; begin pushaddress(rhs); pushaddress(lhs); getcnfsize(lhs^.etyptr,op); if op.addrmode = inDreg 2) A0 and A1 are reserved for source/dest pointers } with source^.attr^ do { form source address, if necessary } if (addrmode = locinreg) and (regnum in [2..4]) or (addrmode <> locinreg) or indexed then begin { address via A0 or A1  then begin SPminus.storage := long; emit2(move,op,SPminus); freeit(D,op.regnum); end; forgetbaseregs; callstdproc('ASM_MOVEL'); end; procedure genassign (lhs,rhs : exptr); var lmin,lmax: valu; r: regrange; begin gh regs available for word move multiple } with multiregs do begin addrmode := multiple; storage := wrd; end; emit2(movem,source^.attr^,multiregs); dest^.attr^.storage := wrd; emit2(movem,multiregs,dest^.attr^); if odd(numbytes) then } with op do begin addrmode := inAreg; if (dest^.attr^.addrmode=locinreg) and (dest^.attr^.regnum = 0) then regnum := 1 else regnum := 0; end; emit2(lea,source^.attr^,op); with source^.attr^ do begin addrmode := lo begin with source^.attr^ do offset := offset+numbytes-1; with dest^.attr^ do offset := offset+numbytes-1; end; end {word move multiple} else if numwords <= 2 * numregs + 1 then begin { enough regs available for long word move multcinreg; offset := 0; indexed := false; regnum := op.regnum; gloptr := NIL; end; end; with dest^.attr^ do { form dest address, if necessary } if (addrmode = locinreg) and (regnum in [2..4]) or (addrmode <> locinreg) or indexed then iple } oddnum := false; if odd(numwords) then begin oddnum := true; numwords := numwords - 1 end; if numwords <> 2 * numregs then { remove extra regs } begin numregs := 0; for rt := A to D do for rn := 0 t begin { address via A0 or A1 } with op do begin addrmode := inAreg; if (source^.attr^.addrmode=locinreg) and (source^.attr^.regnum = 1) then regnum := 0 else regnum := 1; end; emit2(lea,dest^.attr^,op); with dest^.o maxreg do if (reg[rt,rn].allocstate = free) and ((numregs*2) < numwords) then begin numregs := numregs + 1; if (rt = A) then forgetbasereg(rn); multiregs.regs[rt,rn] := true; end else multiregs.regs[rt,rn] := false; attr^ do begin addrmode := locinreg; offset := 0; indexed := false; regnum := op.regnum; gloptr := NIL; end; end; { emit appropriate move sequence } with source^.attr^ do if (regnum = 0) or (regnum = 1) then with reg[A,regend; with multiregs do begin addrmode := multiple; storage := long; end; emit2(movem,source^.attr^,multiregs); dest^.attr^.storage := long; emit2(movem,multiregs,dest^.attr^); with source^.attr^ do offset := offset + 2*numwords; num] do begin allocstate := allocated; usage := other; end; with dest^.attr^ do if (regnum = 0) or (regnum = 1) then with reg[A,regnum] do begin allocstate := allocated; usage := other; end; bigmove(source^.attr^,dest^.att with dest^.attr^ do offset := offset + 2*numwords; if oddnum then { move "odd" word } begin dest^.attr^.storage := wrd; emit2(move,source^.attr^,dest^.attr^); with source^.attr^ do offset := offset+2; with dest^.attr^ do or^, numwords,false,odd(numbytes)); end; {else begin} end; { if numwords > 0 } if ((odd(numbytes)) and (numbytes <= 55)) then { <=== JWH 11/17/88 } begin dest^.attr^.storage := bytte; emit2(move,source^.attr^,dest^.attr^); end; fre      if RANGECHECK then emitcheck(rhs,lhs^.etyptr,true); if lhs^.attr^.packd then if rhs^.attr^.packd then packtopack (lhs,rhs) else pack(lhs,rhs) else with rhs^.attr^ do begin if packd then makeaddressable(rhs); makeaddressable(lhs);addnode,subnode]) then begin if opnd2^.attr^.smallval <> 0 then begin case eclass of addnode: emit2(add,opnd2^.attr^,lhs^.attr^); subnode: emit2(sub,opnd2^.attr^,lhs^.attr^); end; {case} ovflck; end; end else {e if storage = multi then storage := lhs^.attr^.storage else if (storage <> lhs^.attr^.storage) then extend(rhs,lhs^.attr^.storage); if (addrmode = immediate) and (smallval = 0) then emit1(clr,lhs^.attr^) else begin if not rangecheck then maclass in [ornode,andnode]} case eclass of ornode: if opnd2^.attr^.smallval = 1 then emit2(move,opnd2^.attr^,lhs^.attr^); andnode: if opnd2^.attr^.smallval = 0 then emit1(clr,lhs^.attr^); end; {case} end else {opnd2^.eskboolexpr(rhs); movevalue(rhs,lhs^.attr^); end; freeregs(lhs^.attr); end; {with rhs^.attr^} end; {genassign} procedure substrassign(source,dest: exptr); var destisstring: boolean; begin pushsubstr(dest); if strgclass <> litnode} begin loadvalue(opnd2); case eclass of addnode: emit2(add,opnd2^.attr^,lhs^.attr^); subnode: emit2(sub,opnd2^.attr^,lhs^.attr^); ornode: emit2(orr,opnd2^.attr^,lhs^.attr^); andnode: emit2(andd,opnd2^.attr^,lhtype(dest^.arayp^.etyptr) then destisstring := true else destisstring := false; if source^.eclass = substrnode then begin pushsubstr(source); clear(false); if destisstring then if strgtype(source^.arayp^.etyptr) then callstdproc('As^.attr^); end; {case} if eclass in [addnode,subnode] then ovflck; end; freeregs(opnd2^.attr); freeregs(lhs^.attr); done := true; end; end; end; {with} end; {specialassign} $if bigsets$ procedure pushlongwSM_SSUBTOSSUB') else callstdproc('ASM_PSUBTOSSUB') else if strgtype(source^.arayp^.etyptr) then callstdproc('ASM_SSUBTOPSUB') else callstdproc('ASM_PSUBTOPSUB'); end else escape(-8); end; procedure specialassign(lhs,rhs: exord(i: integer); var op: attrtype; begin with op do begin addrmode := immediate; smallval := i; SPminus.storage := long; emit2(move,op,SPminus); end; end; $end$ procedure pushword(i: shortint); var op: attrtype; ptr; var done: boolean); begin genexpr(lhs); with lhs^,attr^ do begin if packd then done := false else if etyptr^.form = reals then done := false else if (rhs^.eclass in [addnode,subnode]) and ((storage = bytte) or (not signbit)) th begin with op do begin addrmode := immediate; smallval := i; SPminus.storage := wrd; emit2(move,op,SPminus); end; end; procedure genbecomes (curstmt : stptr); var done: boolean; offsetexpr: exptr; op: attrtype; begien done := false else if RANGECHECK and ((etyptr^.form = subrange) or ((etyptr^.form=scalar) and (etyptr<>intptr))) then done := false else with rhs^ do begin makeaddressable(lhs); makeaddressable(opnd2); if opnd2^.eclass = litnode then n {genbecomes} with curstmt^ do begin done := false; if treematch(lhs,rhs) then specialassign(lhs,rhs,done); if not done and (rhs^.eclass = fcallnode) then if (rhs^.fptr^.pfdeckind <> standard) and (rhs^.fptr^.spkey = spaddr) then { hfixliteral(opnd2,lhs^.attr^.storage,lhs^.attr^.signbit); if opnd2^.attr^.storage > lhs^.attr^.storage then done := false else begin extend(opnd2,lhs^.attr^.storage); if (opnd2^.eclass = litnode) then begin if (eclass in [andle p := addr(...) } begin makeaddressable(lhs); with rhs^.actualp^,expptr^ do if (eclass = derfnode) and not rangecheck then if branchmatch(lhs,opnd) then { := addr(^... } if nextptr = NIL then done := true else wi     xpr(rhs); end else begin genexpr(rhs); genexpr(lhs); end; if (lhs^.etyptr^.form = prok) and (rhs^.ekind = cnst) then begin makeaddressable(lhs); lhs^.attr^.storage := long; if isoverlay(rhs^.symptr,getaddress) tI limit,cntrl } { calculate pc relative jump to lab } getbrattr(lab,true,op); if signbit then if incr = 1 then emit1(blt,op) { Bcc lab } else emit1(bgt,op) else {unsigned test} if incr = 1 then emit1(bcs,op) hen { OVERLAY MODULE } emit2(move,SPplus,lhs^.attr^) else moveaddress(rhs,lhs^.attr^); with lhs^.attr^ do begin offset := offset+4; with rhs^.symptr^ do if pflev > 1 then movestatic(pflev,lhs^.attr^) else emit1(clr,lhs^.attr else emit1(bhi,op); end; { with ctrl^.attr^ } end; { with curstmt^ } end; { genspecial for } procedure genfor (curstmt : stptr); var op,opp: attrtype; min,max: integer; lab1,limitoffset : addrrange; lab2ref : localref; r : reth nextptr^,expptr^ do begin done := false; makeaddressable(expptr); if eclass = litnode then begin fixliteral(expptr,long,true); with litval do if intval and (ival = 0) then {do nothing} else emit2(add,exppt^); offset := offset-4; freeregs(lhs^.attr); end; end else if paofchar(lhs^.etyptr) then movemulti(rhs,lhs,lhs^.etyptr^.unpacksize) else if rhs^.attr^.addrmode = inFreg then begin makeaddressable(lhs); movr^.attr^,lhs^.attr^); end else { offset not literal } begin extend(expptr,long); loadvalue(expptr); emit2(add,attr^,lhs^.attr^); freeit(D,attr^.regnum); end; done := true; end; if not erealvalue(rhs,lhs^.attr^); freeregs(lhs^.attr); end else if lhs^.etyptr^.form = cnfarrays then cnfassign(lhs,rhs) else if lhs^.attr^.storage = multi then movemulti(rhs,lhs, min(lhs^.etyptr^.unpacksize, rhs^.etyptdone then { above branchmatch failed on } begin done := true; genaddr(rhs,lhs) end; freeregs(lhs^.attr); end; { addr } if not done then if lhs^.etyptr^.form = power then begin { set up external routine for unequal sizer^.unpacksize) ) else genassign(lhs,rhs); end; { not power } end {with} end; {genbecomes} procedure genspecialfor(curstmt: stptr; var done: boolean); var lab: addrrange; op: attrtype; begin done := true;  sets } if RANGECHECK then $if bigsets$ begin pushlongword(lhs^.etyptr^.setmax); pushlongword(lhs^.etyptr^.setmin); end; $end$ $if not bigsets$ begin pushword(lhs^.etyptr^.setmax); pushword(lhs^.etyptr^.setmin); end;  with curstmt^ do begin genexpr(init); genexpr(limit); if ((incr=1) and (init^.litval.ival>limit^.litval.ival)) or ((incr=-1) and (init^.litval.ival 32768) or (init^.attr^.storage = long)) then emit1(tst,ig to see if genspecialfor generated code } if not done then with ctrl^.attr^ do begin makeaddressable(init); if init^.eclass = litnode then fixliteral(init,storage,signbit); loadvalue(init); makeaddressable(limit); if limitnit^.attr^); savestorage := init^.attr^.storage; emitcheck(init,ctrl^.etyptr,true); init^.attr^.storage := savestorage; if (min = 0) and (limit^.attr^.storage = long) and (limit^.attr^.addrmode = inDreg) then emit1(tst,limit^.attr^); em^.eclass = litnode then fixliteral(limit,storage,signbit); if init^.attr^.storage < storage then extend(init,storage); if (not init^.attr^.signbit) and (init^.attr^.storage = wrd) then extend(init,long); if limit^.attr^.storage < iniitcheck(limit,ctrl^.etyptr,true); limit^.attr^.storage := savestorage; end; lab1 := codephile.bytecount; if limit^.eclass = litnode then emit2(cmpi,limit^.attr^,init^.attr^) else emit2(cmp,op,init^.attr^); { CMt^.attr^.storage then extend(limit,init^.attr^.storage); if (not limit^.attr^.signbit) and (limit^.attr^.storage = wrd) then extend(limit,long); if init^.attr^.storage < limit^.attr^.storage then extend(init,limit^.attr^.storP temp,initregnum } { branch corresponding to increment } getbrattr(lab2ref.pc,false,op); if limit^.attr^.signbit then if incr = 1 then emit1(bgt,op) { Bcc lab2 } else emit1(blt,op) else if incr = 1 then emage); if limit^.eclass <> litnode then begin op.storage := limit^.attr^.storage; case op.storage of bytte: getlocstorage(1,op); wrd: getlocstorage(2,op); long: getlocstorage(4,op); end; emit2(move,limit^.attr^it1(bhi,op) else emit1(bcs,op); trangecheck := RANGECHECK; RANGECHECK := false; genassign(ctrl,init); RANGECHECK := trangecheck; clear(false); gencode(fbody); { emit FOR body } {insure that init^.attr^.regnum is,op); if limit^.attr^.addrmode <> inDreg then with limit^.attr^ do begin addrmode := locinreg; indexed := false; packd := false; access := direct; offset := op.offset; regnum := op.regnum; gloptr := op.gloptr; e the next register to be used} repeat r := getreg(D); until r = init^.attr^.regnum; freeit(D,r); if storage < limit^.attr^.storage then extend(ctrl,limit^.attr^.storage); loadvalue(ctrl); with op do begin addrmond; end; lab2ref.next := NIL; if RANGECHECK then if needscheck(init,ctrl^.etyptr,true) or needscheck(limit,ctrl^.etyptr,true) then begin if limit^.eclass = litnode then emit2(cmpi,limit^.attr^,init^.attr^) else emde := immediate; smallval := 1; end; if incr = 1 then emit2(addq,op,ctrl^.attr^) else emit2(subq,op,ctrl^.attr^); getbrattr(lab1,true,op); if not signbit then emit1(bcc,op) { Bcc lab } else emit1(bvc,op); { lab2 } it2(cmp,op,init^.attr^); { CMP temp,initregnum } { branch corresponding to increment } new(lab2ref.next); lab2ref.next^.next := nil; getbrattr(lab2ref.next^.pc,false,opp); if limit^.attr^.signbit then if incr = 1 then emit1(bgtfixreflist(addr(lab2ref)); end; { with ctrl^.attr^ } end; { with curstmt^ } clear(false); end; { genfor } procedure genproc(psymptr: ctp; actualp: elistptr); var lexp,source,dest,length,letter: exptr; checkstp: stp; packunpack     oktype^.params,actualp,false) else if pfdeckind = declared then begin pushparms(next,actualp); if pflev > 1 then begin SPminus.storage := long; movestatic(pflev,SPminus); end; if not isoverlay(psymptr,gencall) then begin getprokc extend(expptr,long); pushvalue(expptr); end; callIOproc('FS_FSEEK'); clear(false); end; sppage: begin pushaddress(actualp^.expptr); callIOproc('FS_FPAGE'); clear(false); end; spclose: with actualp^ do begin onst(psymptr,op1); emit1(jsr,op1); end; clear(false); end else case spkey of spsetstrlen: begin dest := actualp^.expptr; source := actualp^.nextptr^.expptr; makeaddressable(source); genexpr(dest); if rangecheck then  pushaddress(expptr); pushstring(nextptr^.expptr); callIOproc('FS_FCLOSEIT'); clear(false); end; spgotoxy: with actualp^ do begin pushaddress(expptr); extend(nextptr^.expptr,long); pushvalue(nextptr^.expptr); count : integer; datatype,pname: string[9]; testptr,parmptr: elistptr; packing,extending,formatting,checking, isenumtype,isstrgtype,ispaoc,mustinit, newesccode,iseolproc,iswrite: boolean; op1,op2: attrtype; filestorage: stor begin destmax := dest^.etyptr^.maxleng; checking := true; if dest^.etyptr=strgptr then begin {var string} with dest^.attr^ do begin access := direct; storage := bytte; signbit := false; offset := offset+4; end; type; destmax,lobound,hibound: integer; sizeofpaoc: shortint; procedure pushwidth(parmptr: elistptr); begin with parmptr^ do if expptr=NIL then pushword(-1) else begin if rangecheck and ((expptr^.eclass <> litnode) or if source^.eclass = litnode then fixliteral(source,bytte,true); if source^.attr^.storage>bytte then extend(dest,source^.attr^.storage); loadvalue(source); if (source^.attr^.storage=bytte) and (source^.attr^.signbit) then beg not expptr^.litval.intval) then emitcheck(expptr,char_ptr,true); extend(expptr,wrd); pushvalue(expptr); end; end; procedure pushstring(fexp: exptr); begin if strgtype(fexp^.etyptr) then pushaddress(fexp) else begin in with op1 do begin offset := 6; storage := bytte end; emit1(blt,op1); end; emit2(cmp,dest^.attr^,source^.attr^); dest^.attr := NIL; end else if source^.attr^.addrmode <> immediate then begin {not var string}  { 255 is an arbitrary number so that an excessive amount of temp space is not used } sizeofpaoc := min(255,fexp^.etyptr^.unpacksize); getlocstorage(sizeofpaoc+1,op1); with op2 do begin addrmode := immediate; smallval := sizeofpaoc with op1 do begin addrmode := immediate; smallval := destmax; end; with source^, attr^ do if addrmode = topofstack then begin SPind.storage := storage; emit2(cmpi,op1,SPind); end else emit2(cmpi,op1,attr^); ; end; op1.storage := bytte; emit2(move,op2,op1); emit1(pea,op1); pushaddress(fexp); op1.offset := op1.offset + 1; emit1(pea,op1); SPminus.storage := long; emit2(move,op2,Spminus); clear(false);  end else checking := false; if checking then begin with op1 do begin offset := 2; storage := bytte end; emit1(bls,op1); op1.smallval := 7; emit1(trap,op1); end; end; {rangecheck} makeaddressablcallstdproc('ASM_MOVEL'); op1.offset := op1.offset - 1; emit1(pea,op1); emit1(pea,op1); callstdproc('ASM_STRRTRIM'); end; end; begin {genproc} with psymptr^ do if klass = routineparm then callvar(psymptr^.pre(dest); dest^.attr^.storage := bytte; extend(source,bytte); emit2(move,source^.attr^,dest^.attr^); freeregs(source^.attr); freeregs(dest^.attr); end; spseek: begin pushaddress(actualp^.expptr); with actualp^.nextptr^ do begin      extend(nextptr^.nextptr^.expptr,long); pushvalue(nextptr^.nextptr^.expptr); callstdproc('FS_FGOTOXY'); clear(false); end; spunitwait,spunitclear,spget, spput,spnewwords, spdelete,spstrdelete,spstrappend, spinsert,spstrinsert: b begin pushaddress(expptr); pushvalue(nextptr^.expptr); callstdproc('HPM_DISPOSE'); clear(false); end else begin emit1(clr,expptr^.attr^); freeregs(expptr^.attr); end; if mustinitegin pushparms(next,actualp); if (spkey>=spstrdelete) and (spkey<=spstrappend) or (spkey = spdelete) or (spkey = spinsert) then case spkey of spdelete, spstrdelete: callstdproc('ASM_DELETE'); spinsert,  then begin op1.access := indirect; expptr^.attr := addr(op1); initlocvar(NIL,expptr,0,expptr^.etyptr^.eltype,isdispose); clear(false); end; end; spmark: begin makeaddressable(actualp^.expptr); if he spstrinsert: callstdproc('ASM_INSERT'); spstrappend: callstdproc('ASM_SAPPEND'); end else if (spkey=spget) or (spkey=spput) then callIOproc('FS_F' + psymptr^.namep^) else case spkey of spunitwait, apdispose then begin pushaddress(actualp^.expptr); callstdproc('HPM_MARK'); clear(false); end else begin SBind.offset := heapptrdisp; SBind.gloptr := sysglobalptr; emit2(move,SBind,actualp^.expptr^.attr^);  spunitclear: callstdproc('UIO_' + psymptr^.namep^); spnewwords: callstdproc('ASM_NEWWORDS'); end; clear(false); end; spnew: with actualp^ do begin pushaddress(expptr); mustinit := mustinitialize in expptr^.et SBind.gloptr := NIL; end; end; sprelease: begin makeaddressable(actualp^.expptr); if heapdispose then begin pushvalue(actualp^.expptr); callstdproc('HPM_RELEASE'); clear(false); end else begin SBinyptr^.eltype^.info; if mustinit then begin getlocstorage(ptrsize,op1); op1.storage := long; emit2(move,SPind,op1); end; pushvalue(nextptr^.expptr); if heapdispose then callstdproc('HPM_NEW') elsd.offset := heapptrdisp; SBind.storage := long; SBind.gloptr := sysglobalptr; emit2(move,actualp^.expptr^.attr^,SBind); SBind.gloptr := NIL; end; end; spwrite,spwriteln,spwritedir,spstrwrite, spprompt,spread,spreadln,spreaddire callstdproc('ASM_NEWBYTES'); clear(false); if mustinit then begin op2 := op1; op1.access := indirect; expptr^.attr := addr(op1); loadaddress(expptr,false); expptr^.attr^.access := indirect; , spstrread,spoverprint: begin source := actualp^.expptr; iseolproc := (spkey = spreadln) or (spkey = spwriteln) or (spkey = spoverprint); iswrite := spkey in [spwritedir,spwriteln,spwrite, spstrwrite,spprompt,spove moveaddress(expptr,op2); op2.access := indirect; expptr^.attr := addr(op2); initlocvar(NIL,expptr,0,expptr^.etyptr^.eltype,isnew); clear(false); end; end; spdispose: with actualp^ do begin makeaddressrprint]; if iswrite then pname := 'WRITE' else pname := 'READ'; formatting := (source^.etyptr = textptr) or (spkey = spstrread) or (spkey = spstrwrite); if not formatting then begin datatype := ''; filestorage := getstoraable(expptr); mustinit := mustinitialize in expptr^.etyptr^.eltype^.info; if mustinit then begin getlocstorage(ptrsize,op1); op1.storage := long; emit2(move,expptr^.attr^,op1); end; if heapdispose then geinfo(source^.etyptr^.filtype); end; if spkey = spstrwrite then pushvarstring(source) else pushaddress(source); parmptr := actualp^.nextptr; if (spkey = spreaddir) or (spkey = spwritedir) then begin {first seek desired re      end; end else {READ, etc} if parmptr^.nextptr <> NIL then if spkey <> spstrread then emit2(move,SPind,SPminus) else begin op2 := SPind; op2.offset := 4; emit2(move,op2,SPminus); emit2(move,op2,SPminus);  end;{binary write} end {ISWRITE} else {READ,readln,readdir,strread} begin genexpr(expptr); packing := attr^.packd; if formatting then extending := getstorageinfo(etyptr) <> attr^.storage else extending := (filestora end; isenumtype := enumtype(etyptr); isstrgtype := strgtype(etyptr); ispaoc := paofchar(etyptr) and not isstrgtype; if ISWRITE then begin packing := false; extending := false; makeaddressable(expptr); {allocate attr ge <> attr^.storage) or isstrgtype; if packing or extending then begin saveregs; new(lexp); lexp^ := expptr^; getattrec(lexp); if extending and not formatting then begin getlocstorage(source^.etyptr^. filtypcord} SPminus.storage := long; emit2(move,SPind,SPminus); extend(parmptr^.expptr,long); pushvalue(parmptr^.expptr); callIOproc('FS_FSEEK'); clear(false); parmptr := parmptr^.nextptr; end else if (spkey = spstrwritrecord} if formatting then begin if ((etyptr=intptr) or (etyptr=shortintptr)) and ((attr^.storage=bytte) or not(attr^.signbit)) then if attr^.storage <> long then extend(expptr,succ(attr^.storage)); if (ete) or (spkey = spstrread) then with parmptr^ do begin if not branchmatch (expptr,nextptr^.expptr) then begin extend(expptr,long); loadaddress(nextptr^.expptr,false); movevalue(expptr,nextptr^.expptr^.attr^); end; yptr=intptr) or (etyptr=shortintptr) then pushvalue(expptr) else if isenumtype then begin extend(expptr,wrd); pushvalue(expptr); end else if (etyptr=char_ptr) or (etyptr=boolptr) then begin e pushaddress(nextptr^.expptr); parmptr := nextptr^.nextptr; end; while parmptr<>NIL do {process params} with parmptr^,expptr^ do begin checking := false; if not ISWRITE then begin checkstp := etyptr; if etyptxtend(expptr,bytte); if etyptr=boolptr then maskboolexpr(expptr); pushvalue(expptr); end else if etyptr=realptr then pushaddress(expptr) else begin {strg,paoc} pushaddress(expptr); if not isstrgtyper^.form = subrange then etyptr := etyptr^.rangetype; end; SPminus.storage := long; if iseolproc then emit2(move,SPind,SPminus) else if ISWRITE then begin {last value?} if not formatting then testptr := parmptr^.nextptr  then pushword(etyptr^.unpacksize); end; {process width specification} parmptr := parmptr^.nextptr; pushwidth(parmptr); if etyptr = realptr then begin parmptr := parmptr^.nextptr; pushwidth(parmptr); enelse begin testptr := parmptr^.nextptr^.nextptr; if etyptr = realptr then testptr := testptr^.nextptr; end; if testptr <> NIL then if (spkey <> spstrwrite) and (spkey <> spstrread) then emit2(move,SPind,SPminus) elsd; end {formatting} else begin {binary write} if rangecheck then emitcheck(expptr,source^.etyptr^.filtype,true); extend(expptr,filestorage); if not (attr^.addrmode in memorymodes) then begin new(lexp); lexp^ e begin {copy var string} op2 := SPind; op2.offset := 8; SPminus.storage := wrd; emit2(move,op2,SPminus); SPminus.storage := long; op2.offset := 6; emit2(move,op2,SPminus); emit2(move,op2,SPminus); := expptr^; getattrec(lexp); getlocstorage(source^.etyptr^.filtype^.unpacksize, lexp^.attr^); lexp^.attr^.storage := filestorage; movevalue(expptr,lexp^.attr^); pushaddress(lexp); end else pushaddress(expptr);       e^.unpacksize,lexp^.attr^); lexp^.attr^.storage := filestorage; lexp^.eclass := idnode; lexp^.symptr := NIL; end else begin getlocstorage(etyptr^.unpacksize, lexp^.attr^); lexp^.attr^.storage := getstoraf isstrgtype then stringassign(lexp,expptr) else begin extend(lexp,attr^.storage); movevalue(lexp,attr^); freeregs(attr); end; end; end else if checking then begin reloadregs; emitcheck(expptr,checgeinfo(etyptr); end; pushaddress(lexp); end else if formatting and isstrgtype then pushvarstring(expptr) else begin if RANGECHECK then if needscheck(expptr,checkstp,true) then begin checking := true; kstp,true); end; clear(false); parmptr := parmptr^.nextptr; end; {while parmptr<>NIL...} if iseolproc then begin if spkey=spreadln then pname := 'READLN' else if spkey=spwriteln then pname := 'WRITELN' else pn loadaddress(expptr,false); saveregs; SPminus.storage := long; attr^.addrmode := inAreg; emit2(move,attr^,SPminus); attr^.addrmode := locinreg; end else pushaddress(expptr) else pushaddress(expptame := 'OVERPRINT'; callIOproc('FS_F' + pname); clear(false); end; end; spcall: callvar(actualp^.expptr^.etyptr^.params, actualp,false); spescape: with actualp^,expptr^ do begin newesccode := true; if eclass = fcallnr); if formatting then if ispaoc then pushword(etyptr^.unpacksize); end; end; {READ etc.} if isenumtype and formatting then with op1 do begin addrmode := enumconst; offset := 0; enumstp := etyptr; poolenum(eode then if fptr^.pfdeckind <> declared then if fptr^.spkey = spesccode then newesccode := false; if newesccode then { not 'escape(escapecode)' } begin if rangecheck then emitcheck(expptr,shortintptr,true); extend(exptyptr); emit1(pea,op1); end; if formatting then if etyptr = char_ptr then datatype := 'CHAR' else if etyptr = boolptr then datatype := 'BOOL' else if etyptr = realptr then datatype := 'REAL' else if isenumtype then datatype := 'ENUM'ptr,wrd); makeaddressable(expptr); SBind.storage := wrd; SBind.offset := escapecodedisp; SBind.gloptr := sysglobalptr; emit2(move,attr^,SBind); SBind.gloptr := NIL; end; op1.smallval := 10; emit1(t else if isstrgtype then datatype := 'STR' else if ispaoc then datatype := 'PAOC' else { int, shortint } if ISWRITE then if attr^.storage = wrd then datatype := 'WORD' else datatype := 'INT' else { reading } if etyptrap,op1); end; sphalt: begin SBind.storage := wrd; SBind.offset := escapecodedisp; SBind.gloptr := sysglobalptr; if actualp <> NIL then with actualp^, expptr^ do begin if rangecheck then emitcheck(expptr,shortintptr = shortintptr then datatype := 'WORD' else datatype := 'INT'; if (spkey = spstrwrite) or (spkey = spstrread) then datatype := 'STR' + datatype; if (etyptr = realptr) and formatting then callIOproc('MFS_F' + pname + datar,true); extend(expptr,wrd); makeaddressable(expptr); emit2(move,attr^,SBind); end else emit1(clr,SBind); op1.smallval := 10; emit1(trap,op1); SBind.gloptr := NIL; end; spfillchar: begin with actualp^ type) else callIOproc('FS_F' + pname + datatype); if packing or extending then begin reloadregs; if rangecheck then emitcheck(lexp,checkstp,true); if packing then pack(expptr,lexp) else begin makeaddressable(expptr); ido begin dest := expptr; length := nextptr^.expptr; letter := nextptr^.nextptr^.expptr; end; loadaddress(dest,false); { dest addr } loadvalue(letter); { char } loadvalue(length); op1.storage := bytte; op1.offset := 6;      alue(actualp^.expptr); {unit number} actualp:=actualp^.nextptr; pushaddress(actualp^.expptr); {buffer} actualp:=actualp^.nextptr; extend(actualp^.expptr,long); pushvalue(actualp^.expptr); {length,-(SP) } op1.smallval := packunpackcount; SPminus.storage := long; emit2(move,op1,SPminus); {move.l count,-(SP) } if spkey = sppack then callstdproc('ASM_PACK') else callstdproc('ASM_UNPACK'); clear(false); en} actualp:=actualp^.nextptr; extend(actualp^.expptr,long); pushvalue(actualp^.expptr); {blocknumber} actualp:=actualp^.nextptr; extend(actualp^.expptr,long); pushvalue(actualp^.expptr); {async} if spd; otherwise escape(-8); end; {case} end; {genproc} procedure gencase(curstmt:stptr); label 1; const bigcase = 256; bigcasestr = '256'; warnthresh = 100; warnfactor = 2; var otherref1,otherref2: localref; lnomatch,lout,ljmptab:  emit1(ble,op1); { BLE.S *+8 } with dest^.attr^ do begin addrmode := postincr; storage := bytte; end; emit2(move,letter^.attr^,dest^.attr^); { MOVE.B letter, } with op1 do begin addrmode := immediate; smkey = spunitread then callstdproc('UIO_UNITREAD') else callstdproc('UIO_UNITWRITE'); clear(false); end; sppack,spunpack: with actualp^ do begin op1.addrmode := immediate; getbounds(nextptr^.expptr^.etyptr^.inxtype,lobound,allval := 1; end; emit2(subq,op1,length^.attr^); { SUBQ #1,length } op1.offset := -6; op1.storage := bytte; emit1(bgt,op1); { BGT.S *-4 } clear(false); { register contents will be invalid } end; {fillchar}hibound); packunpackcount := hibound - lobound + 1; {Z array bounds} if RANGECHECK and (expptr^.indxp^.eclass <> litnode) then { Check array subscript < lower bound and array subscript + count > upper bound } begin getbound spmoveleft, spmoveright: begin with actualp^ do begin source := expptr; dest := nextptr^.expptr; length := nextptr^.nextptr^.expptr; end; pushaddress(source); pushaddress(dest); extend(length,long); pushvalue(s(expptr^.arayp^.etyptr^.inxtype,lobound,hibound); new(checkstp); with checkstp^ do begin form := subrange; min := lobound; max := hibound - packunpackcount + 1; end; emitcheck(expptr^.indxp,checkstp,false); end; length); clear(false); { register contents will be invalid } if spkey = spmoveright then callstdproc('ASM_MOVER') else callstdproc('ASM_MOVEL'); end; { moveleft, moveright } sprewrite,spreset,spopen,spappend: begin pushaddress(if spkey = spunpack then { push boolean, signed or unsigned } begin if nextptr^.expptr^.etyptr^.aeltype^.signbit then op1.smallval := 1 else op1.smallval := 0; SPminus.storage := bytte; emit2(move,op1,SPminus); {moveactualp^.expptr); {file} parmptr := actualp^.nextptr; with op1 do begin addrmode := immediate; smallval := ord(spkey)-ord(spreset); end; SPminus.storage := wrd; emit2(move,op1,SPminus); if parmptr = NIL then call.b 1/0, -(SP) } end; op1.smallval := expptr^.arayp^.etyptr^.aelsize; checking := RANGECHECK; RANGECHECK := false; { already range checked subscript } pushaddress(expptr); {address of A[i] } RANGECHECK := checkinIOproc('FS_FHPRESET') else begin pushstring(parmptr^.expptr); pushstring(parmptr^.nextptr^.expptr); callIOproc('FS_FHPOPEN'); end; clear(false); end; spunitread,spunitwrite: begin extend(actualp^.expptr,long); pushvg; pushaddress(nextptr^.expptr); {address of Z } SPminus.storage := wrd; emit2(move,op1,SPminus); {move.w unpacksize,-(SP) } op1.smallval := nextptr^.expptr^.etyptr^.aelbitsize; emit2(move,op1,SPminus); {move.w fieldwidth!      addrrange; exitcaserefs,otherlist,p: reflistptr; stmt,nextstmt: stptr; curclabp: clabptr; i: integer; minval,maxval,maxrefs, tablesize,nomatchrefs: integer; holes,unsignedselecte begin addrmode := immediate; smallval := minval; emit2(sub,op1,selecter^.attr^); end; { check minval<=selecter<=maxval } with op1 do begin addrmode := immediate; smallval := maxval-minval; end; if (otherwyse = NIL) then checkcase(ser: boolean; op1,op2: attrtype; procedure assigncasentry ( var list: reflistptr ); { assign the current case table entry to the "list" } var p: reflistptr; begin new(p); with p^ do begin pc := codephillecter^.attr,op1.smallval) else begin unsignedselecter := not selecter^.attr^.signbit; otherref1.next := NIL; getbrattr(otherref1.pc,false,op2); if unsignedselecter then emit1(bcs,op2) { BLT otherwise } else emit1(blt,op2); e.bytecount; next := list; list := p; end; end; procedure checkcase(at: attrptr; i: integer); { Check the case selecter in "at" to make sure it is less than or equal to "i" } var op: attrtype; p : reflistptr; begin  emit2(cmp,op1,selecter^.attr^); { CMP #max,select } otherref2.next := NIL; getbrattr(otherref2.pc,false,op2); if unsignedselecter then emit1(bhi,op2) { BGT otherwise } else emit1(bgt,op2); end; $IF not MC68020 if RANGECHECK then begin new(p); p^.next := NIL; getbrattr(p^.pc,false,op); emit1(blt,op); with op do begin addrmode := immediate; smallval := i; end; emit2(cmpi,op,at^); with op do begin offset := 2; storage := bytte end; emit1(ble,op)$ with op1 do begin addrmode := immediate; smallval := 1; end; emit2(asl,op1,selecter^.attr^); { ASL #1,select } $END$ with op1 do begin addrmode := prel; offset := 6; indexed := true; indexreg := selecter^.attr^.regnum; in; op.smallval := 6; fixreflist(p); emit1(trap,op); { TRAP #6 } end; { else } end; begin { gencase } with curstmt^ do begin makeaddressable(selecter); maskboolexpr(selecter); with selecter^.attr^ do dexstorage := wrd; $IF MC68020$ indexscale := 1; $END$ end; getregattr(D,op2); op2.storage := wrd; emit2(move,op1,op2); freeit(D,selecter^.attr^.regnum); with op1 do begin offset := 2; indexreg := op2.regnum; $IF MC68020$ begin if storage = bytte then extend(selecter,wrd) else if not signbit and (otherwyse = NIL) and (minval <> 0) then extend(selecter,long); loadvalue(selecter); end; otherlist := NIL; exitcaserefs := NIL; holes := false; if miindexscale := 0; $END$ end; emit1(jmp,op1); { emit indexed jump into table } freeit(D,op1.indexreg); { initialize the list of table refs for each case stmt } stmt := firstmt; while stmt <> NIL do with stmt^ do begin tablelistnlab <> NIL then begin minval := minlab^.lowval; maxval := maxlab^.hival; $RANGE ON$ try tablesize := maxval-minval+1; if tablesize > bigcase then warning(linenum,'case table contains more than ' + bigcasestr + ' entries');  := NIL; stmt := next; refcount := 0 end; { emit jump table } ljmptab := codephile.bytecount; curclabp := minlab; i := minval; nomatchrefs := 0; while curclabp <> NIL do begin with curclabp^ do begin while i <= hival do with cst recover if escapecode = -4 { integer overflow } then begin error(679); goto 1; end else escape(escapecode); $IF not rangechecking$ $RANGE OFF$ $END$ if minval <> 0 then {normalize} with op1 do mt^ do begin assigncasentry(tablelist); outputcodeword(codephile.bytecount - ljmptab); refcount := refcount+1; i := i+1; end; curclabp := clabp; end; if curclabp <> NIL then with curclabp^ do while i < lowval do begin!     lse); if (warnfactor*maxrefs>tablesize) and (tablesize >= warnthresh) then warning(linenum, 'most case table entries address the same statement'); end; { with curstmt^ ... } 1: end {gencase}; procedure gengoto(curstmt: stptr); { Enhanced fed then temp^.next := labrefs else begin isrefed := true; temp^.next := NIL; end; labrefs := temp; temp^.pc := lbl; end; emit1(bra,op); end else { non-local goto } begin op.smallval := 9; emit1(trap,op); 9/26/91 JWH to fix FSDdt07193 } { except for variables, all changes are } { bewteen the lines =================== } var lbl: addrrange; op: attrtype; temp: reflistptr; label_temp,found_it : labelp; i : integer; done : boolean;  { TRAP 9 } if staticlevel = 1 then { destination is main program } outputcodeword(-1) else outputcodeword(level-staticlevel); {DC.W static delta} if not isnlrefed then begin uniquelabid := uniquenumber; isnlrefed := true; end;  assigncasentry(otherlist); outputcodeword(codephile.bytecount - ljmptab); nomatchrefs := nomatchrefs+1; holes := true; i := i+1; end; end; { while curclabp <> NIL } releaseattr; {generate code for cases} with firstmt^ do begin f upper_lim : integer; begin with curstmt^.target^ do if (level = staticlevel) or fprocp^.ismodulebody then { local goto } begin {==================================================================} found_it := NIL; done := FALSE; ixreflist(tablelist); maxrefs := refcount; nextstmt := next; next := NIL; end; gencode(firstmt); stmt := nextstmt; while stmt <> NIL do begin new(p); getbrattr(p^.pc,false,op1); p^.next := exitcaserefs; exitcaserefs := p; e label_temp := display[top].flabel; { local labels in this scope } while not done do begin if label_temp <> NIL then begin if labval = label_temp^.labval then begin found_it := label_temp; done := TRUE; end; label_tmit1(bra,op1); { BRA out of case } with stmt^ do begin fixreflist(tablelist); nextstmt := next; next := NIL; clear(false); if maxrefs < refcount then maxrefs := refcount; end; gencode(stmt); emp := label_temp^.nextlab; end else done := TRUE; end; { while not done do } if found_it <> NIL then begin upper_lim := (body_try_level - (found_it^.try_level)); { writeln('upper lim is : ',upper_lim); } for  stmt := nextstmt; end; end; {if minlab <> NIL} if holes or (otherwyse <> NIL) then begin new(p); getbrattr(p^.pc,false,op1); p^.next := exitcaserefs; exitcaserefs := p; emit1(bra,op1); { BRA out of case } if holes ani := 1 to upper_lim do begin SBind.gloptr := NIL; SPind.offset := 2*ptrsize; SBind.offset := lastrecovdisp; SBind.storage := long; SBind.gloptr := sysglobalptr; emit2(move,SPind,SBind); { MOVE.L offset(SP),lastrecovd (otherlist <> NIL) then fixreflist(otherlist); if otherwyse <> NIL then begin clear(false); fixreflist(addr(otherref1)); fixreflist(addr(otherref2)); gencode(otherwyse); end else {holes only} if RANGECHECK then with op1 do beg } SPind.offset := 0; { must restore SPind.offset to 0 } with op do begin addrmode := immediate; op.smallval := 3*ptrsize; end; SPdir.storage := wrd; emit2(adda,op,SPdir); { ADDA.L 3*ptrsize,SP in smallval := 6; emit1(trap,op1); { TRAP #6 } end; if maxrefs < nomatchrefs then maxrefs := nomatchrefs; end; {fix up all branches to the end of the case stmt} fixreflist(exitcaserefs); clear(fa} end; { For } end; { found_it <> NIL } {==================================================================} { Now same as before : JWH 9/26/91 } lbl := location; getbrattr(lbl,defined,op); if not defined then begin new(temp); if isre"      outputref(curglobalname^ + '_' + itostr(uniquelabid) + '_' + itostr(labval),codephile.bytecount,rel32); outputcodelong(-codephile.bytecount); end; end; procedure genif(curstmt: stptr); var lbl1: reflistptr; lbl2: localref; op: ,-(SP) } with op do begin addrmode := prel; offset := 0; indexed := false; absaddr.intval := true; absaddr.ival := 0; end; { REF lrecov } lrecovref.next := NIL; lrecovref.pc := codephile.bytecount + 2; emit1(pea,op); attrtype; begin with curstmt^ do begin gencond(ifcond,lbl1,false); releaseattr; gencode(tru); if fals <> NIL then begin lbl2.next := NIL; getbrattr(lbl2.pc,false,op); emit1(bra,op); end; fixreflist(lbl1);  { PEA lrecov } emit2(move,SPdir,SBind); { MOVE.L SP,lastrecov } SBind.gloptr := NIL; body_try_level := body_try_level + 1; { JWH 9/26/91 } gencode(tbody); body_try_level := body_try_leve clear(false); if fals <> NIL then begin gencode(fals); fixreflist(addr(lbl2)); clear(false); end; end; end {genif}; procedure genrep(curstmt: stptr); var lbl: reflistptr; blist: localref; begin with curstmt^ do bl - 1; { JWH 9/26/91 } SPind.offset := 2*ptrsize; SBind.offset := lastrecovdisp; SBind.storage := long; SBind.gloptr := sysglobalptr; emit2(move,SPind,SBind); { MOVE.L offset(SP),lastrecov } SPind.offset :=egin lbl := addr(blist); blist.pc := codephile.bytecount; blist.next := NIL; clear(false); gencode(rbody); if debugging then begin emit1(trap,immed0); outputcodeword(lineno); end; globalattrlist := addr(attrlis 0; { must restore SPind.offset to 0 } with op do begin addrmode := immediate; op.smallval := 3*ptrsize; end; SPdir.storage := wrd; emit2(adda,op,SPdir); { ADDA.L 3*ptrsize,SP } with op do begin addrmode :=tptr); gencond(rcond,lbl,true) end; end {genrep}; procedure genwhile(curstmt: stptr); var lbl1: addrrange; lbl2: reflistptr; op: attrtype; begin with curstmt^ do begin lbl1 := codephile.bytecount; clear( prel; offset := 0; storage := wrd; absaddr.intval := true; absaddr.ival := 0; end; { REF lout } loutref.next := NIL; loutref.pc := codephile.bytecount + 2; emit1(jmp,op); { JMP lout } { DEF lrecov } ffalse); if debugging then begin emit1(trap,immed0); outputcodeword(linenum); end; globalattrlist := addr(attrlistptr); { reset for current statement } gencond(rcond,lbl2,false); releaseattr; gencode(rbody); getbrattrixreflist(addr(lrecovref)); clear(false); A6dir.storage := long; emit2(movea,SPplus,A6dir); { MOVEA.L (SP)+,localbase } emit2(move,SPplus,SBind); { MOVE.L (SP)+,lastrecov } SBind.gloptr := NIL; genco(lbl1,true,op); emit1(bra,op); end; fixreflist(lbl2); clear(false); end {genwhile}; procedure gentry(curstmt: stptr); var op: attrtype; lrecovref, loutref: localref; begin with curstmt^ do begin SBind.offsde(recov); { DEF lout } fixreflist(addr(loutref)); clear(false); end; end {gentry}; procedure genwith(curstmt: stptr); var op1,op2: attrtype; procedure getwithrecattr(var attrec: attrtype); { initialize access to WITet := lastrecovdisp; SBind.storage := long; SBind.gloptr := sysglobalptr; SPminus.storage := long; emit2(move,SBind,SPminus); { MOVE.L lastrecov,-(SP) } emit2(move,A6dir,SPminus); { MOVE.L localbaseH record base in local storage. } begin getlocstorage(ptrsize,attrec); attrec.access := indirect; end; {getwithrecattr} begin {genwith} with curstmt^ do begin genexpr(refexpr); with refexpr^,attr^ do begin if packd and (b"     then { local files } begin SPminus.storage := long; emit2(move,A6dir,SPminus); callstdproc('ASM_CLOSEFILES'); end; if odd(lcmax) then lcmax := lcmax-1; if modulebody then emit0(rts) else begin emit1(unlk,A6dir); og}; begin {gencode} while curstmt <> NIL do with curstmt^ do begin oldlc := lc; { set codegen variables to reflect curstmt^ } linenum := lineno; rangecheck := sflags.rangecheck; ovflcheck := sflags.ovflcheck; iocheck := sflags.i{ UNLK A6 } if proclev > 0 then begin with fprocp^ do begin popsize := paramlc+ptrsize*ord(proclev>1); if klass=func then if idtype^.form >= prok then popsize := popsize+ptrsize; if (popsize<>0) and (popsize<>4) then begin withocheck; shortcircuit := sflags.shortcircuit; callmode := sflags.callmode; if labp <> NIL then with labp^ do begin clear(false); if nonlocalref then begin outputdef(itostr(uniquelabid) + '_' + itostr(labval), codephile.byitoffset.variable <> -1) then begin getlocstorage(intsize,op1); refbit := op1.offset; op1.storage := long; with op2 do begin addrmode := inDreg; regnum := bitoffset.variable; end; emit2(move,op2,op1); freeit(D,bitoffset.variable); opnd2 do begin addrmode := inAreg; regnum := 0; storage := long end; emit2(movea,SPplus,opnd2); { MOVEA.L (SP)+,A0 } with opnd1 do begin addrmode := immediate; smallval := popsize; end; if popsize < 32768 then SPdir.sto end else refbit := 0; {no bit offset saved} if indexed or (access = indirect) or (addrmode = locinreg) and (regnum <> localbase) and (regnum <> SB) then begin {base is non-constant or intermediate so save it} if (reg[A,regnum].usage <rage := wrd else SPdir.storage := long; emit2(add,opnd1,SPdir); { ADDQ/I #popsize,SP } with opnd2 do begin addrmode := locinreg; offset := 0; indexed := false; regnum:= 0; gloptr := NIL; end; emit1(jmp,opnd2);> withrecbase) and addrinreg(refexpr) then {Base is currently in "A" register. Mark register usage and save accessing info in register.} with reg[A,regnum] do begin usage:= withrecbase; allocstate := allocated; u { JMP (A0) } end else begin if popsize = 4 then begin SPind.storage := long; emit2(move,SPplus,SPind); { MOVE.L (SP)+,SP } end; emit0(rts); { RTS } end; end; sesleft := 1; oldcontents := attr^; {initialize} getwithrecattr(oldcontents); curcontents := attr; moveaddress(refexpr,oldcontents); end else {base not loaded, save access info in refexpr} begin op1 := attr^; { Thi end else emit0(rts); {main program} end; { Used by the tree dump routine for debug info } fprocp^.exit_location := codephile.bytecount - 2; if $IF MC68020$ (proclev = 0) and $END$ (lcmax < LClimit) then $if bigsets$ errorwithinfo( s is a "cheap" initialization } getwithrecattr(op1); moveaddress(refexpr,op1); attr^ := op1; freeregs(attr); end; end { save base } else freeregs(attr); gencode(wbody); with reg[A,regnum] do if (usage = withrecbase) then 683, 'Refer to manual for details of stack allocation.') $end$ $if not bigsets$ error(683) $end$ else if not modulebody then while maxLCpatch <> NIL do begin $IF MC68020$ if (maxLCpatch^.next = NIL) and gstackcheck then { last one  if curcontents = attr then usage := other; end; end; {with curstmt^} end {genwith}; procedure genepilog(curstmt: stptr); var popsize: addrrange; opnd1,opnd2: attrtype; begin if (display[top].ffile <> NIL) and (proclev > 0) } fixlong(maxLCpatch^.pc,-(lcmax-1073741824)) { convert trap #1 disp } else fixlong(maxLCpatch^.pc,lcmax); $END$ $IF not MC68020$ fixword(maxLCpatch^.pc,lcmax); $END$ maxLCpatch := maxLCpatch^.next; end; end {genepil#     tecount,relocatable,0); $IF MC68020$ if maxLCpatch <> NIL then { not main prog } begin SPdir.storage := long; emit2(movea,A6dir,SPdir); new(p); p^.next := maxLCpatch; maxLCpatch := p; p^.pc := codephile.bytecount + t); releaseattr end; whilest: genwhile(curstmt); tryst: begin gentry(curstmt); end; withst: begin genwith(curstmt); releaseattr end; endofbodyst: genepilog(curstmt); emptyst: ; otherwise es2; opnd.addrmode := immediate; opnd.smallval := 0; emit2(adda,opnd,SPdir); end else { main prog : always has link.w a6,#0 } begin A6ind.offset := -1; emit2(lea,A6ind,SPdir); fixword(codephile.bytecount-2,1); cape(-8); end; {case sclass ...} lc := oldlc; curstmt := next; end; {with curstmt^...} end; {gencode} procedure getprocinfo; begin curproc := fprocp; with curproc^ do begin lcmax := lc; proclev := pflev; bend; $END$ $IF not MC68020$ if maxLCpatch <> NIL then { not main prog } begin new(p); p^.next := maxLCpatch; maxLCpatch := p; p^.pc := codephile.bytecount + 2; end; A6ind.offset := -1; emit2(lea,A6ind,SPdir); odylev := pflev+1; if klass = prox then modulebody := ismodulebody else modulebody := false; end; rangecheck := curbody^.sflags.rangecheck; { use value from first statement } callmode := curbody^.sflags.callmode; end {getpro fixword(codephile.bytecount-2,1); $END$ end; location := codephile.bytecount; defined := true; if isrefed then fixreflist(labrefs); end; if debugging and not modulebody and not (sclass in [emptyst,compndst,repst,whilest]) then bcinfo}; procedure genprolog; var i: shortint; parmp,varid: ctp; op1,op2,op3 : attrtype; temp: string[idlength+1]; nametemp: alpha; procedure copyvalueparm; { move value parm whose address has parameter offsetegin emit1(trap,immed0); outputcodeword(linenum); end; if (sclass <> emptyst) and (initlistmode = listfull) and listpc and listopen then begin if PCcount = 0 then incrlinecount; write(lp,linenum:8,'-',c parmp^.vptraddr to offset given by parmp^.vaddr } var destreg, sourcereg, sourcesize: regrange; wdstomove, curmove: integer; op1,op2,op3 : attrtype; begin if (parmp^.idtype^.form = power) or strgtype(parmp^.idtype) then with parmp^ do odephile.bytecount:7,' '); PCcount := PCcount + 1; if PCcount = PCperline then begin writeln(lp); PCcount := 0; end; if ioresult <> ord(inoerror) then begin listabort := true; list := listnone; listopen := false; warning(linenum,'Li begin sourcereg := getreg(A); destreg := getreg(A); sourcesize := getreg(D); { load source address } A6ind.offset := vptraddr; with op2 do begin addrmode := inAreg; regnum:= sourcereg; storage:= long; end; emisting aborted'); end; end; attrlistptr := NIL; globalattrlist := addr(attrlistptr); case sclass of becomest: begin genbecomes(curstmt); releaseattr end; pcallst: begin genproc(psymptr,actualp); releaseattr; t2(movea,A6ind,op2); { MOVEA.L vptraddr(A6),Areg } { load size in a reg } op2.addrmode := postincr; with op1 do begin addrmode := inDreg; regnum := sourcesize; end; if idtype^.form = power then op1.storage := wrd  end; casest: gencase(curstmt); compndst: gencode(curstmt^.cbody); forst: begin genfor(curstmt); releaseattr end; gotost: gengoto(curstmt); ifst: genif(curstmt); repst: begin genrep(curstm else op1.storage := bytte; op2.storage := op1.storage; emit2(move,op2,op1); if RANGECHECK then if idtype^.form = power then begin with op2 do begin addrmode := immediate; smallval := idtype^.unpacksize-2; end; #     power then storage := wrd else storage := bytte; end; $end$ $if not bigsets$ op2.storage := bytte; emit2(move,op1,op2); with op1 do begin addrmode := immediate; smallval := 1; end; with op2 do begire callmodulebodies; var s: modstateptr; op: attrtype; found: boolean; i: shortint; begin with display[top] do begin s := available_module; while s <> NIL do with s^, modinfo^ do begin if needscall then begin n addrmode := inDreg; regnum := sourcesize; storage := bytte; end; emit2(subq,op1,op2); with op1 do begin offset := -6; storage := bytte end; $end$ emit1(bhi,op1); freeit(A,destreg); freeit(D,sourcesize);  found := false; i := 1; while not found and (i <= overlaytop) do if modinitbody^.namep^ = overlaylistptr^[i] then found := true else i := i + 1; if found then { don't emit call } else begin needscall := fals emit2(chk,op2,op1); end else if idtype^.maxleng<>255 then begin with op2 do begin addrmode := immediate; smallval := idtype^.maxleng; end; emit2(cmpi,op2,op1); with op1 do begin offset:= 2; storage:= bytte end; emit1(blfreeit(A,sourcereg); end else if parmp^.idtype^.form = cnfarrays then begin getcnfsize(parmp^.idtype,op1); if op1.addrmode <> inDreg then with op2 do begin addrmode := inDreg; regnum := getreg(D); storage := long; ems,op1); { BLS.S *+4 } op1.smallval := 7; emit1(trap,op1); { TRAP #7 } end; { get destination address in a register } A6ind.offset := vaddr; with op2 do begin addrmode := inAreg; regnum := destreg;it2(move,op1,op2); op1 := op2; end; { make the value even } with op2 do begin addrmode := immediate; smallval := 1; emit2(add,op2,op1); smallval := 0; emit2(bclr,op2,op1); end; { Make room storage := long; end; emit2(lea,A6ind,op2); { move size field to destination } with op1 do begin addrmode := inDreg; regnum := sourcesize; end; with op2 do begin addrmode := postincr; if idtype^.form  in stack frame } SPdir.storage := long; emit2(suba,op1,SPdir); { copy } A6ind.offset := parmp^.vptraddr; SPminus.storage := long; emit2(move,A6ind,SPminus); SPind.offset := 4; emit1(pea,SPind); SPind.offset := = power then storage := wrd else storage := bytte; end; emit2(move,op1,op2); { loop back to this point } with op1 do begin addrmode := postincr; regnum := sourcereg; end; $if bigsets$ if idtype^.for0; emit2(move,op1,SPminus); freeit(D,op1.regnum); saveregs; forgetbaseregs; callstdproc('ASM_MOVEL'); reloadregs; A6ind.storage := long; emit2(move,SPdir,A6ind); end else begin sourcereg := getreg(Am = power then op2.storage := wrd else op2.storage := bytte; emit2(move,op1,op2); with op1 do begin addrmode := immediate; if idtype^.form = power then smallval := 2 else smallval := 1; end; with o); with parmp^ do begin wdstomove := (idtype^.unpacksize+1) div 2; A6ind.offset := vptraddr; with op2 do begin addrmode := inAreg; regnum := sourcereg; storage := long; end; { set up source pointer } emit2(mp2 do begin addrmode := inDreg; regnum := sourcesize; if idtype^.form = power then storage := wrd else storage := bytte; end; emit2(subq,op1,op2); with op1 do begin offset := -6; if idtype^.form = ovea,A6ind,op2); { MOVEA.L vptraddr(A6),Areg } op2.addrmode := postincr; A6ind.offset := vaddr; end; bigmove(op2,A6ind,wdstomove,true,false); freeit(A,sourcereg); end; end; {copyvalueparm} procedu$     e; getprokconst(modinitbody,op); emit1(jsr,op); end; end; s := s^.nextmodule; end; end; end; begin { genprolog } if not modulebody then begin if debugging then begin outputcodeword(curbody^.lineno); tem {move any copied-value parameters} parmp := fprocp^.next; while parmp <> NIL do with parmp^ do begin if vtype = cvalparm then copyvalueparm; parmp := next; end; end; {not modulbody} end; { proclev <> 0... } varid := dip := fprocp^.namep^; if not odd(strlen(temp)) then begin temp[0] := chr(ord(temp[0])+1); temp[strlen(temp)] := ' '; end; for i := 0 to strlen(temp) do outputcodebyte(ord(temp[i])); outputcodebyte(strlen(temp)+1); end else { not debsplay[top].ffile; while varid <> NIL do with varid^ do begin initlocvar(varid,NIL,0,idtype,isnew); varid := varid^.next; end; callmodulebodies; end {genprolog}; begin {genbody} getprocinfo; clear(true); genprolog; stugging } outputcodebyte(0); outputcodebyte(ord(proclev>1)); end; if proclev = 0 then {main program} begin {define main program entry point} maxLCpatch := NIL; with fprocp^ do begin location := codephile.bytecount;ringhead := NIL; sethead := NIL; reelhead := NIL; enumhead := NIL; $IF MC68020$ wrdpairhead := NIL; longpairhead := NIL; $END$ freeattr := NIL; PCcount := 0; PCperline := pagewidth DIV 17; gencode(curbody); dumpconsts;  isdumped := true; end; startaddr := codephile.bytecount; outputdef(fprocp^.namep^,codephile.bytecount,relocatable,0); A6dir.storage := wrd; emit1(link,A6dir); { LINK localbase } if heapdispose then callstdproc('HPM_HESTABLI if (PCcount <> 0) and listopen and listpc then writeln(lp); end; {genbody} procedure codegeninit; type filesiztype = string[5]; var lok: boolean; i: integer; defaultfilename: fid; codevid: vid; sourcevid: vid; sourcefidSH'); end { proclev = 0... } else begin {define procedure entry point} startaddr := -1; with fprocp^ do begin location := codephile.bytecount; isdumped := not alias; if isexported or isrefed then if not isexported then : fid; dummy2: integer; dummy3: filekind; function filetag(var fname:fid): boolean; var lok: boolean; dummy1: fid; dummy2: integer; dummy3: filekind; begin fixname(fname,codefile); lok := scantitle(fname,c begin nametemp := itostr(forwid) + namep^; outputdef(nametemp,codephile.bytecount,relocatable,0); end else outputdef(namep^,codephile.bytecount,relocatable,0); end; { with fprocp^ } if not modulebody then begin {establish odevid, dummy1,dummy2,dummy3); if lok then begin rewrite(codephile.fileid,fname); {Try to Open new file} i := ioresult; close(codephile.fileid,'PURGE'); if i<>ord(inoerror) then begin if i = ord(inoroom) thendynamic link, allocate local storage} new(maxLCpatch); maxLCpatch^.next := NIL; maxLCpatch^.pc := codephile.bytecount + 2; if gstackcheck then begin op1.smallval := 1; emit1(trap,op1); { trap #1 stack overflow check } outputcodeword(0 begin error(900); escape(-1); end else if i <> ord(inofile) then begin file_warn(903,i); escape(-1); end else filetag := false; end else filetag := true; end else filetag := false; end; begin {codeg); $IF MC68020$ outputcodeword(0); { room for 32 bit displacement on 68020 } $END$ end else begin $IF MC68020$ A6dir.storage := long; $END$ $IF not MC68020$ A6dir.storage := wrd; $END$ emit1(link,A6dir); end;eninit} new(libraryptr); new(codephile.buffer); new(refile.buffer); new(defile.buffer); genutilsinit; lok := scantitle(sourcefilename,sourcevid, sourcefid,dummy2,dummy3); defaultfilename := sourcevid + ':' + getfid(sourcefid) + '.CODE'; if userin$      { file GENEXPRDEF } import genutils,codegen,assemble,globals, symtable,compinit,genmove,sysglobals,float_hdw; export procedure genexpr (fexp: exptr); procedure callvar (formalp: ctp; actualp: elistptr; isfunc: boolean); t(varexp); if packd then unpack(varexp); end; end; {makeaddressable} procedure extend(*fexp: exptr; fstorage: stortype*); {extend is a general routine called to ensure that its parameter is of a given storage (size). The desired final  procedure pushparms(formalp: ctp; actualp: elistptr); procedure relCMP(fexp: exptr; var fdestonleft,fsigned: boolean); procedure gensetop (fexp: exptr); procedure extend(fexp: exptr; fstorage: stortype); procedure genaddr(fexp,dest:storage could be smaller, the same, or larger then the current storage} var op: attrtype; begin genexpr(fexp); with fexp^, attr^ do begin if packd then makeaddressable(fexp); { if eclass = litnode then fixliteral(fexp,fstorafo^.gotsym then begin file_name := defaultfilename; if not filetag(file_name) then userinfo^.gotsym := false; end else begin writeln(output); write(output,'Output file (default is "',defaultfilename,'") ? '); repeat readln(input,fil exptr); procedure makeaddressable(varexp: exptr); procedure genshortand(fexp: exptr; var truelist,falselist: reflistptr; onright,falsedefined,value: boolean; valueattr : attrptr); procedure genshortor(fexp: exptr; var truee_name); if file_name='' then file_name := defaultfilename; lok := filetag(file_name); if not lok then write(output,'Invalid file name. File ? '); until lok; end; codefileopen := false; if refvolname = '' then refvolname := list,falselist: reflistptr; onright,falsedefined,value: boolean; valueattr : attrptr); procedure ovflck; procedure getattrec(fexp: exptr); procedure pushvarstring(fexp: exptr); procedure pushsubstr(fexp: exptr); function branccodevid + ':'; fanonfile(refile.fileid,refvolname, codefile,refilesize); i := ioresult; if i<>ord(inoerror) then begin if i = ord(inoroom) then error(901) else file_warn(904,i); escape(-1); end; if defvolname = '' then defvolname := hmatch(exp1,exp2: exptr): boolean; procedure stringassign(source,dest: exptr); function getstorageinfo(fsp: stp): stortype; procedure saveregs; procedure reloadregs; type calltype = (gencall,getaddress); function isoverlcodevid + ':'; fanonfile(defile.fileid,defvolname, codefile,defilesize); i := ioresult; if i<>ord(inoerror) then begin if i = ord(inoroom) then error(902) else file_warn(905,i); escape(-1); end; writeln(output); codeinit; dedicatedregsay(pfptr: ctp; callt: calltype): boolean;  := [SB,localbase,SP]; memorymodes := [locinreg,shortabs,longabs,prel,labelledconst,namedconst]; { Used by "extend" for "emitcheck" } ensure_valid_condition_code := false; OVERLAY := 'OVERLAY'; EXEC := 'EXEC'; ADDRESS := 'ADDRESS'; force_unpack := false; { file GENEXPR } implement {genexprmod} var {save/reload regs stuff} rstring, disp: attrtype; numsavedregs: 0..15; onereg : record { if there is only one register this is it } rt: regtype; rn: regrange; end; procedure (* default condition, do not force unpacking of unsigned 8 or 16 bit fields *) end; {codegeninit}  makeaddressable{varexp: exptr}; { ensure addressability of variable } begin genexpr(varexp); with varexp^.attr^ do begin if packd then bitaddress(varexp); if access = indirect then loadaddress(varexp,false) else checkoffse%     ge,true); } { BUG FIX 10/14/88 - JWH } if addrmode = immediate then fixliteral(fexp,fstorage,true); if storage <> fstorage then begin if fstorage > storage then begin if (not signbit) then begin getregattr(D,op); em begin pexp^.attr^.storage := long; if callmode = relcall then begin loadaddress(pconst,false); pconst^.attr^.addrmode := inAreg; emit2(cmpa,pexp^.attr^,pconst^.attr^); freeit(A,pconst^.attr^.regnum); end else emit2(cmpi,pconst^.attr^it2(moveq,immed0,op); makeaddressable(fexp); op.storage := storage; emit2(move,attr^,op); freeregs(attr); addrmode := inDreg; regnum := op.regnum; signbit := true; if ensure_valid_condition_code then begin ,pexp^.attr^); { CMPI.L pconst,pexp } freeregs(pexp^.attr); end; begin {relprok} makeaddressable(lop); makeaddressable(rop); if lop^.ekind <> cnst then if rop^.ekind <> cnst then begin rop^.attr^.storage := long; {to f op.storage := fstorage; emit1(tst,op); end; end else begin loadvalue(fexp); $IF MC68020$ if (storage = bytte) and (fstorage = long) then emit1(extb,attr^) else $END$ while storage < fstoraool loadvalue} loadvalue(rop); emit2(cmp,lop^.attr^,rop^.attr^); { CMP.L lop,rop } freeregs(lop^.attr); freeregs(rop^.attr); end else relprokVC(lop,rop) else relprokVC(rop,lop); end; {relprok} begin {relCMP} with fexp^ do ige do begin storage := succ(storage); emit1(ext,attr^); end; end; end else {fstorage < storage} begin if addrmode = topofstack then loadvalue(fexp) else makeaddressable(fexp); if storage = wrd then offset := offset + 1 else {f opnd1^.etyptr^.form = prok then begin relprok(opnd1,opnd2); fdestonleft := false {don't care} end else {not prok compare} begin {select CMP or CMPI, and order of operands} cmpwith0 := false; if opnd1^.ekind > opnd2^.ekind then begin makeaddrstorage = long} if fstorage = wrd then offset := offset + 2 else if fstorage = bytte then offset := offset + 3; end; storage := fstorage; end; end; end; {extend} procedure checkstackandextend(exp1,exp2: exptr; len: stortype); {if essable(opnd1); makeaddressable(opnd2) end else begin makeaddressable(opnd2); makeaddressable(opnd1) end; maskboolexpr(opnd1); maskboolexpr(opnd2); with opnd1^.attr^ do begin lmode := addrmode; lstorage := storage; lsigned := signbit; end; exp2's storage <> len then extend it, checking for exp2 at topofstack-1 } begin with exp2^.attr^ do if storage <> len then begin if (addrmode=topofstack) and (exp1^.attr^.addrmode=topofstack) then loadvalue(exp1); {pop} extendwith opnd2^.attr^ do begin rmode := addrmode; rstorage := storage; rsigned := signbit; end; if rmode = immediate then begin destonleft := true; cmptype := cmpi; fixliteral(opnd2,lstorage,lsigned); with opnd2^.attr^ do begin rstor(exp2,len); end; end; {checkstackandextend} procedure relCMP(* fexp: exptr; var fdestonleft,fsigned: boolean *); var destonleft,cmpwith0: boolean; lmode,rmode: addrtype; lstorage,rstorage: stortype; signed,lsigned,rsigned: boolean; cage := storage; rsigned := signbit; if rmode = immediate then if (smallval = 0) and (lmode <> namedconst) then cmpwith0 := true else if (smallval >= -128) and (smallval <= 127) then begin loadvalue(opnd2); cmptype := cmp end; mptype: opcodetype; procedure relprok(lop,rop: exptr); { compare procedure objects for (in)equality. note: const relop const handled by front end } procedure relprokVC(pexp,pconst: exptr); {compare prok var or expr with prok const}  end; end else if lmode = immediate then begin destonleft := false; cmptype := cmpi; fixliteral(opnd1,rstorage,rsigned); with opnd1^.attr^ do begin lstorage := storage; lsigned := signbit; if lmode = immediate then if (smallva%     en begin destonleft := (opnd2^.attr^.addrmode <> inDreg); if destonleft then loadvalue(opnd1); end; {emit appropriate code} if destonleft then begin if not cmpwith0 then { CMP[I].size op2,op1 } emit2(cmptype,opnd2^vem,disp,rstring) else emit2(move,disp,rstring); end; if float = flt_on then reloadrealregs; end; procedure gensetop {fexp: exptr}; const attos = true; inloc = false; procedure stackops (fopnd1,fopnd2 : exptr); { operan.attr^,opnd1^.attr^) else if (opnd1^.attr^.addrmode<>inDreg) or (opnd1^.eclass=modnode) or ((opnd1^.eclass=shftnode) and (not opnd1^.attr^.signbit)) then emit1(tst,opnd1^.attr^); { TST.size op1 } end else if not cmpwith0 then ds appear on the stack in the following order: address of left operand (+8) address of right operand (+4) } begin {stackops} pushaddress(fopnd1); pushaddress(fopnd2); end; {stackops} procedure stackresult (fexp : exptr ; fattos : bl = 0) and (rmode <> namedconst) then cmpwith0 := true else if (smallval >= -128) and (smallval <= 127) then begin loadvalue(opnd1); cmptype := cmp end; end; end else cmptype := cmp; if (lstorage = rstorage) and (lsigned = rsigned)  { CMP[I].size op1,op2 } emit2(cmptype,opnd1^.attr^,opnd2^.attr^) else if (opnd2^.attr^.addrmode<>inDreg) or (opnd2^.eclass=modnode) or ((opnd2^.eclass=shftnode) and (not opnd2^.attr^.signbit)) then emit1(tst,opnd2^.attr^then signed := lsigned else if rstorage = long then begin signed := true; if lstorage <> long then extend(opnd1,long); end else if lstorage = long then begin signed := true; if rstorage <> long then checkstackandextend(opnd1,opnd2,); { TST.size op2 } freeregs(opnd1^.attr); freeregs(opnd2^.attr); fdestonleft := destonleft; fsigned := signed; end; {not prok compare} end; {relCMP} procedure saveregs; { save allocated registers in local storage using MOVEM.L ...,disp(Along); end else if (rstorage = wrd) and rsigned and (lstorage = bytte) then begin signed := true; extend(opnd1,wrd) end else if (lstorage = wrd) and lsigned and (rstorage = bytte) then begin signed := true; checkstackandextend(opnd1,opnd2,wrd) e6). Save register list in rstring for reloading. } var rt: regtype; rn: regrange; begin if float = flt_on then saverealregs; with rstring do begin numsavedregs := 0; for rt := A to D do for rn := 0 to maxreg do if nd else if (lstorage = bytte) and not lsigned then begin if rsigned then {opnd2 is signed byte} begin signed := true; extend(opnd1,wrd); checkstackandextend(opnd1,opnd2,wrd); end else {opnd2 is unsigned word} begin signed := freg[rt,rn].allocstate = allocated then begin numsavedregs := numsavedregs+1; regs[rt,rn] := true; onereg.rt := rt; onereg.rn := rn; end else regs[rt,rn] := false; if numsavedregs <> 0 then begin getlocstorage(numsavedregalse; extend(opnd1,wrd) end end else if (rstorage = bytte) and not rsigned then begin if lsigned then {opnd1 is signed byte} begin signed := true; extend(opnd1,wrd); checkstackandextend(opnd1,opnd2,wrd); end else {opnd1 is unsigs*4,disp); disp.storage := long; if numsavedregs = 1 then begin regnum := onereg.rn; if onereg.rt = A then addrmode := inAreg else addrmode := inDreg; emit2(move,rstring,disp); end else begin addrmode := multiple; emit2(movned word} begin signed := false; checkstackandextend(opnd1,opnd2,wrd) end end else {unsigned word vs signed or word signed byte} begin signed := true; extend(opnd1,long); checkstackandextend(opnd1,opnd2,long); end; if cmptype <> cmpi them,rstring,disp); end; end; end; end; {saveregs} procedure reloadregs; { reload allocated registers from local storage } begin if numsavedregs > 0 then begin rstring.storage := long; if numsavedregs > 1 then emit2(mo&     oolean); { fill in attributes for result of set operation } begin with fexp^,attr^ do if fattos then addrmode := topofstack { boolean result } else { set result } begin getlocstorage(etyptr^.unpacksize,attr^); pushaddress(fexp) { t2(move,op1,SPminus); end; pushaddress(fexp); end; procedure pushsubstr(fexp: exptr); var op: attrtype; temp: integer; begin with fexp^ do begin if strgtype(arayp^.etyptr) then pushvarstring(arayp) else { paoc } result address on stack (at +12) } end; end; {stackresult} begin {gensetop} with fexp^ do begin { set up for external routines for =,<>,<=,>=,+,*,-,in } case eclass of unionnode,intersectnode,diffnode : begin stackresult(fexp,inloc begin with op do begin addrmode := immediate; getbounds(arayp^.etyptr^.inxtype,temp, smallval); end; SPminus.storage := long; emit2(move,op,SPminus); pushaddress(arayp); end; extend(indxp,long); pus); { set result in local storage } stackops(opnd1,opnd2); end; eqnode,nenode,subsetnode : begin stackresult(fexp,attos); { boolean result at tos } stackops(opnd1,opnd2); end; supersetnode : begin stackresult(fexp,attos); { boolean result hvalue(indxp); if lengthp <> NIL then begin extend(lengthp,long); pushvalue(lengthp); end; end; end; procedure genconcat(dest,tree: exptr); forward; function branchmatch(exp1,exp2: exptr): boolean; begin if exp1^.eat tos } { reverse arguments => subset operation } stackops(opnd2,opnd1); end; innode: begin stackresult(fexp,attos); extend(opnd1,long); pushvalue(opnd1); pushaddress(opnd2); end; otherwise escape(-8); end; {case} saveregs; foclass <> exp2^.eclass then branchmatch := false else case exp1^.eclass of eqnode..andnode: branchmatch := branchmatch(exp1^.opnd1,exp2^.opnd1) and branchmatch(exp1^.opnd2,exp2^.opnd2); negnode..truncnode: branchmatch := branchmatrgetbaseregs; case fexp^.eclass of diffnode : callstdproc('ASM_DIFFERENCE'); intersectnode : callstdproc('ASM_INTERSECT'); unionnode : callstdproc('ASM_UNION'); supersetnode, subsetnode : callstdproc('ASM_INCLUch(exp1^.opnd,exp2^.opnd); idnode: branchmatch := exp1^.symptr = exp2^.symptr; subscrnode: branchmatch := branchmatch(exp1^.arayp,exp2^.arayp) and branchmatch(exp1^.indxp,exp2^.indxp); selnnode: branchmatch := branchmatch(exp1SION'); eqnode : callstdproc('ASM_EQUAL'); nenode : callstdproc('ASM_NEQUAL'); innode : $if not bigsets$ callstdproc('ASM_IN'); $end$ $if bigsets$ callstdproc('ASM_XIN'); $end$ end; {case} re^.recptr,exp2^.recptr) and (exp1^.fieldptr = exp2^.fieldptr); unqualfldnode: branchmatch := (exp1^.withstptr = exp2^.withstptr) and (exp1^.fieldref = exp2^.fieldref); litnode: if exp1^.litval.intval then if exp2^.litval.iloadregs; end {with} end; {gensetop} procedure ovflck; begin if ovflcheck then emit0(trapv); end; procedure pushvarstring(fexp: exptr); var op1: attrtype; begin genexpr(fexp); SPminus.storage := bytte; with fexp^,attr^ do ifntval then branchmatch := exp1^.litval.ival = exp2^.litval.ival else branchmatch := false else branchmatch := false; otherwise branchmatch := false; end; {case} end; {branchmatch} procedure stringassign(source,dest: exptr); var  etyptr = strgptr then begin {actual is var string} offset := offset+4; emit2(move,attr^,SPminus); offset := offset-4; end else begin op1.addrmode := immediate; op1.smallval := etyptr^.maxleng; emi op1,op2, sourceattr,destattr: attrtype; checking: boolean; lexp: exptr; lstp: stp; begin { string assign } if source^.eclass = concatnode then begin getlocstorage(256,op1); new(lexp); new(lstp); with lexp^ do &      emit2(lea,dest^.attr^,destattr); freeregs(dest^.attr); destattr.addrmode := postincr; destattr.storage := bytte; emit2(move,op1,destattr); emit2(move,sourceattr,destattr); with op2 do begin addrmode := immediate 4 then dope_element.offset := hiboundid^.vaddr + 4 else dope_element.offset := hiboundid^.vaddr + 2; emit2(move,dope_element,op); op.storage := long; emit1(ext,op); emit2(move,op,SPminus); {push length} if inx; smallval := 1; end; emit2(subq,op2,op1); op2.offset := -6; emit1(bhi,op2); freeit(A,destattr.regnum); freeit(D,op1.regnum); freeit(A,sourceattr.regnum); end; { string } end; { stringassign } procedure pushpartype^.unpacksize = 4 then dope_element.offset := dope_element.offset - 4 else dope_element.offset := dope_element.offset - 2; op.storage := wrd; emit2(move,dope_element,op); op.storage := long; emit1(ext,op); e begin attr := addr(op1); lstp^:= strgptr^; lstp^.unpacksize := 256; etyptr := lstp; eclass := idnode; symptr := NIL; end; genconcat(lexp,source); stringassign(lexp,dest); end else { string } if nms{formalp: ctp; actualp: elistptr}; var formaltype: stp; op1: attrtype; procedure pushdopevector(formalpidtype: stp; dopevec: stp); var lo,hi: integer; op, dope_element : attrtype; begin if formalpidtype^.aeltype^.form = cot branchmatch(source,dest) then begin with source^ do begin makeaddressable(source); with sourceattr do begin addrmode := inAreg; regnum := getreg(A); end; emit2(lea,{source^.}attr^,sourceattr); freeregs({source^.}attr); sournfarrays then pushdopevector(formalpidtype^.aeltype,dopevec^.aeltype); with dopevec^ do begin case formalpidtype^.inxtype^.unpacksize of 1: SPminus.storage := bytte; 2: SPminus.storage := wrd; 4: SPminus.storage := long; end; if form =ceattr.addrmode := postincr; with op1 do begin addrmode := inDreg; regnum := getreg(D); storage := bytte; end; emit2(move,sourceattr,op1); {load source size} checking := false; if rangecheck then if dest^.etyptr = strgptr then { var stri cnfarrays then begin with dope_element do begin addrmode := locinreg; regnum := getbasereg(dopevec^.cnf_index^.hiboundid^.vlev); indexed := false; gloptr := NIL; end; with cnf_index^ do if formalpidtype^.inxtypeng } begin genexpr(dest); with dest^, attr^ do begin offset := offset + 4; emit2(cmp,attr^,op1); offset := offset - 4; end; checking := true; end else if ({source^.}eclass <> litnode) and s^.unpacksize = inxtype^.unpacksize then begin if SPminus.storage = long then dope_element.offset := hiboundid^.vaddr + 4 else dope_element.offset := hiboundid^.vaddr + 2; emit2(move,dope_element,SPminus); {push length} trgtype({source^.}etyptr) then begin with op2 do begin addrmode := immediate; storage := bytte; smallval := dest^.etyptr^.maxleng; end; emit2(cmpi,op2,op1); checking := true; end; end; { with source^ }  if SPminus.storage = long then dope_element.offset := dope_element.offset - 4 else dope_element.offset := dope_element.offset - 2; emit2(move,dope_element,SPminus); {push upper bound} dope_element.offset := loboundid^.vaddr;  if checking then begin with op2 do begin offset := 2; storage := bytte; end; emit1(bls,op2); op2.smallval := 7; emit1(trap,op2); end; with destattr do begin addrmode := inAreg; regnum := getreg(A); end; makeaddressable(dest); emit2(move,dope_element,SPminus); {push lower bound} end else { extend word to long before pushing } begin with op do begin addrmode := inDreg; storage := wrd; regnum := getreg(D); end; if inxtype^.unpacksize ='     mit2(move,op,SPminus); {push upper bound} dope_element.offset := loboundid^.vaddr; op.storage := wrd; emit2(move,dope_element,op); op.storage := long; emit1(ext,op); emit2(move,op,SPminus); {push lower bound} s.storage := long; if symptr^.pflev > 1 then movestatic(symptr^.pflev,SPminus) else emit1(clr,SPminus); {assumes nilvalue = 0} if not isoverlay(symptr,getaddress) then { OVERLAY MODULE } emit1(pea,attr^); end else begin  freeit(D,op.regnum); end; freeregs(addr(dope_element)); end else {form = arrays} begin op.addrmode := immediate; if (aeltype^.form = arrays) then op.smallval := aelsize else if aispackd then op.smallval := aelbi if not rangecheck then maskboolexpr(expptr); pushvalue(expptr); end; end; if vtype <> dopeparm then actualp := actualp^.nextptr; formalp := next; end; end; {pushparms} procedure genaddr(* fexp,dest: exptr *); { code gen for adtsize else op.smallval := aelsize; getbounds(inxtype,lo,hi); emit2(movei,op,SPminus); {push length} op.smallval := hi; emit2(movei,op,SPminus); {push upper bound} op.smallval := lo; emit2(movei,op,SPminus); {push lower boundr function. Fexp is the fcallnode; if dest is NIL result goes to stack, else to dest. } var offsetexpr: exptr; destattr: attrtype; procedure moveaddr(fexp: exptr); begin if dest=NIL then pushaddress(fexp) else moveaddress(fd} end; end; end; begin { pushparms } while formalp <> NIL do with formalp^ do begin if rangecheck and (vtype = valparm) then emitcheck(actualp^.expptr,idtype,true); { cvalparms will be rangechecked in the routine itself } exp,destattr); end; begin {genaddr} with fexp^.actualp^ do begin if dest <> NIL then destattr := dest^.attr^ else begin SPind.storage := long; destattr := SPind; end; genexpr(expptr); if nextptr = NIL then movea if (vtype = cvalparm) then pushaddress(actualp^.expptr) else if (vtype = refparm) or (vtype = anyvarparm) then pushaddress(actualp^.expptr) else if vtype = strparm then {var str formal} pushvarstring(actualp^.expptr) elddr(expptr) else begin {optional offset supplied} offsetexpr := nextptr^.expptr; genexpr(offsetexpr); with offsetexpr^.attr^ do if addrmode = immediate then if expptr^.attr^.access = indirect then begin moveaddr(expptr); if sse if vtype = dopeparm then { conformant array dope vector } pushdopevector(formalp^.idtype,actualp^.expptr^.etyptr) else with actualp^ do begin {valparm} with formalp^ do if klass = vars then formaltype := idtype else formaltype :=mallval <> 0 then emit2(add,offsetexpr^.attr^,destattr); end else begin {direct access} expptr^.attr^.offset := expptr^.attr^.offset+smallval; moveaddr(expptr); end else begin {non-constant offset} loa proktype; makeaddressable(expptr); case formaltype^.unpacksize of 0 : {empty record}; 1 : if expptr^.attr^.storage <> bytte then extend(expptr,bytte); 2 : if expptr^.attr^.storage <> wrd then extend(expptr,wrd); 3,4: if expptr^.attr^.stordvalue(offsetexpr); if expptr^.attr^.indexed or (expptr^.attr^.access = indirect) then begin moveaddr(expptr); extend(offsetexpr,long); emit2(add,offsetexpr^.attr^,destattr); freeit(D,regnum); end else age <> long then extend(expptr,long); 8 : {real or procedure variable or constant}; end; if formaltype^.form in [prok,funk] then with expptr^ do if ekind <> cnst then pushvalue(expptr) else {actual is prok constant} begin SPminu{make offset the index reg} begin if storage = bytte then extend(offsetexpr,wrd); if (storage = wrd) and not signbit then extend(offsetexpr,long); expptr^.attr^.indexed := true; expptr^.attr^.indexreg := regnum; '      2: getstorageinfo := wrd; 4: getstorageinfo := long; otherwise getstorageinfo := multi end; end; {getstorageinfo} procedure getattrec(fexp: exptr); begin with fexp^ do begin if freeattr = NIL then new(attr) else ); bptr^.next := falselist; falselist := bptr; end; getbrattr(falselist^.pc,falsedefined,op); case conditionis of { use opposite } beq: emit1(bne,op); bne: emit1(beq,op); blt: emit1(bge,op); bcs: e begin attr := freeattr; freeattr := freeattr^.next; end; attr^.next := globalattrlist^; globalattrlist^ := attr; with attr^ do begin storage := getstorageinfo(etyptr); packd := false; access := direct; mit1(bcc,op); ble: emit1(bgt,op); bls: emit1(bhi,op); bgt: emit1(ble,op); bhi: emit1(bls,op); bge: emit1(blt,op); bcc: emit1(bcs,op); otherwise escape(-8); end; { case } end; fixreflist(newtruelexpptr^.attr^.indexstorage := storage; $IF MC68020$ expptr^.attr^.indexscale := 0; $END$ moveaddr(expptr); end; end; {non-constant offset} end; {optional offset} end; {with actualp^} end; {genaddr} proc indexed := false; offset := 0; regnum := 0; signbit := false; gloptr := NIL; {ensure known values for packed fields} bitsize := 0; with bitoffset do begin static := 0; variable := -1; end; end; end; edure callvar (* formalp: ctp; actualp: elistptr; isfunc: boolean *); {call prok var, prok or func param} var op1: attrtype; patchloc: addrrange; begin with actualp^ do begin pushparms(formalp,nextptr); genexpr(expptr); if end; procedure genshortand(fexp: exptr; VAR truelist,falselist: reflistptr; onright,falsedefined, value: boolean; valueattr : attrptr); var bptr,newtruelist, templist1,templist2: reflistptr; op: attrtype; begin with fexp^ do begi isfunc then {in case genexpr found generalized func} expptr^.attr^.access := direct; makeaddressable(expptr); with expptr^,attr^ do begin offset := offset+4; storage := long; emit1(tst,attr^); { code sequence assumes nilvalue = 0 } n newtruelist := NIL; if opnd1^.eclass = andnode then genshortand(opnd1,newtruelist,falselist,false,falsedefined, value,valueattr) else if opnd1^.eclass = ornode then begin genshortor(opnd1,newtruelist,falselist,false,falsedefine patchloc := codephile.bytecount + 2; op1.offset := 0; op1.storage := bytte; emit1(beq,op1); SPminus.storage := long; emit2(move,attr^,SPminus); offset := offset-4; fixbyte(patchloc-1,codephile.bytecount - patchloc); freeregs(attr); d, value,valueattr); {generate jump to false} if not falsedefined then begin new(bptr); bptr^.next := falselist; falselist := bptr; end; getbrattr(falselist^.pc,falsedefined,op); emit1(bra,op) getregattr(A,op1); emit2(movea,attr^,op1); freeit(A,op1.regnum); with op1 do begin addrmode := locinreg; indexed := false; gloptr := NIL; end; if isfunc then begin saveregs; forgetbaseregs end; emit1(jsr,op1); {  end else if not value then if falsedefined then gencond(opnd1,falselist,true) else begin gencond(opnd1,templist2,false); templist1 := templist2; if templist2 <> NIL then begin while templist2^.next jsr (A0) } if isfunc then reloadregs else clear(false); end; end; end; function getstorageinfo(fsp: stp): stortype; begin if fsp = NIL then getstorageinfo := wrd else case fsp^.unpacksize of 1: getstorageinfo := bytte; <> NIL do templist2 := templist2^.next; templist2^.next := falselist; falselist := templist1; end; end else begin movevalue(opnd1,valueattr^); conditionis := bne; if not falsedefined then begin new(bptr(     ist); if opnd2^.eclass = andnode then genshortand(opnd2,truelist,falselist,onright,falsedefined, value,valueattr) else if opnd2^.eclass = ornode then begin genshortor(opnd2,truelist,falselist,onright,falsedefined, value,valelist^.pc,false,op); emit1(bra,op) end else if opnd1^.eclass = ornode then genshortor(opnd1,truelist,newfalselist,false,false, value,valueattr) else begin if value then begin movevalue(opnd1,valueattr^);ueattr); {generate jump to false} if not falsedefined then begin new(bptr); bptr^.next := falselist; falselist := bptr; end; getbrattr(falselist^.pc,falsedefined,op); emit1(bra,op) end else  conditionis := bne; end else begin conditionis := bne; loadvalue(opnd1); freeregs(opnd1^.attr); end; new(bptr); bptr^.next := truelist; truelist := bptr; getbrattr(truelist^.pc,fals if value then begin movevalue(opnd2,valueattr^); conditionis := bne; if not onright then begin if not falsedefined then begin new(bptr); bptr^.next := falselist; falselist := bptr; end; getbrattr(false,op); emit1(conditionis,op) end; fixreflist(newfalselist); if opnd2^.eclass = andnode then begin genshortand(opnd2,truelist,falselist,onright,falsedefined, value,valueattr); new(bptr); bptr^.next := truelist; elist^.pc,falsedefined,op); case conditionis of { use opposite } beq: emit1(bne,op); bne: emit1(beq,op); blt: emit1(bge,op); bcs: emit1(bcc,op); ble: emit1(bgt,op); bls: emit1(bhi,op); bgt: emit1(ble,op); bhi: emit1(bls,op truelist := bptr; getbrattr(truelist^.pc,false,op); emit1(bra,op) end else if opnd2^.eclass = ornode then genshortor(opnd2,truelist,falselist,onright,falsedefined, value,valueattr) else begin if value then ); bge: emit1(blt,op); bcc: emit1(bcs,op); otherwise escape(-8); end; { case } end; end else if falsedefined then gencond(opnd2,falselist,true) else begin gencond(opnd2,templist2,false); templ begin movevalue(opnd2,valueattr^); conditionis := bne; end else begin conditionis := bne; loadvalue(opnd2); freeregs(opnd2^.attr); end; if not onright or not value then begin ist1 := templist2; if templist2 <> NIL then begin while templist2^.next <> NIL do templist2 := templist2^.next; templist2^.next := falselist; falselist := templist1; end; end; end; { with fexp } forgetbaseregs; en new(bptr); bptr^.next := truelist; truelist := bptr; getbrattr(truelist^.pc,false,op); emit1(conditionis,op); end; end; end; { with fexp } forgetbaseregs; end; { genshortor } procedure genconcd; { genshortand } procedure genshortor(fexp: exptr; VAR truelist,falselist: reflistptr; onright,falsedefined,value: boolean; valueattr : attrptr); var bptr,newfalselist: reflistptr; op: attrtype; begin with fexp^ do begin newfaat(dest,tree: exptr); var op: attrtype; procedure genappend(dest,tree: exptr); begin if tree^.eclass = concatnode then begin genappend(dest,tree^.opnd1); genappend(dest,tree^.opnd2); end else begin makeaddressable(tree); lselist := NIL; if opnd1^.eclass = andnode then begin genshortand(opnd1,truelist,newfalselist,false,false, value,valueattr); {generate jump to true} new(bptr); bptr^.next := truelist; truelist := bptr; getbrattr(tru genexpr(dest); pushvarstring(dest); if strgtype(tree^.etyptr) then pushaddress(tree) else escape(-8); saveregs; forgetbaseregs; callstdproc('ASM_SAPPEND'); reloadregs; end; end; { genappend } procedure findfarleft(dest,(     IL; litval.intval := false; new(litval.valp); with litval.valp^ do begin cclass := strng; slgth := strlen(nametemp); strmove(slgth,nametemp,1,sval,1); end; end; genexpr(expptr); pushaddress(expptr); new(trim,sprtrim,spmemavail: begin if spkey in [spstrrpt,spltrim,sprtrim] then begin {string-valued func} getlocstorage(etyptr^.unpacksize,attr^); emit1(pea,attr^); end else begin resultsize := etyptr^.unpacksize; if odd(resctptemp); ctptemp^ := pfptr^; ctptemp^.othername := addr(OVERLAY); if callt = getaddress then ctptemp^.namep := addr(ADDRESS) else ctptemp^.namep := addr(EXEC); getprokconst(ctptemp,op); emit1(jsr,op); isoveultsize) then resultsize := resultsize+1; with op do begin addrmode := immediate; smallval := resultsize; end; SPdir.storage := long; emit2(subq,op,SPdir); attr^.addrmode := topofstack; getsignbit(etyptr,attr); end; if spkeytree: exptr); begin if tree^.eclass = concatnode then begin findfarleft(dest,tree^.opnd1); genappend(dest,tree^.opnd2); end else begin loadaddress(dest,false); if reg[A,dest^.attr^.regnum].usage = withrecbase then with op rlay := true; end; { if found } end; { othername <> NIL } end; end; procedure genexpr{fexp: exptr}; var lform: structform; lop,rop,oldattr,op: attrtype; lexp: exptr; lstp: stp; procedure genfcall(fexp: exptr); var destdo begin addrmode := inAreg; storage := long; regnum := getreg(A); emit2(movea,dest^.attr^,op); dest^.attr^.regnum := regnum; end; with reg[A,dest^.attr^.regnum] do begin usage := basereg; offset,resultsize: addrrange; offsetexpr,source,letter,lngth: exptr; sexp: elistptr; op: attrtype; $IF MC68020$ i: shortint; lbl1,lbl2: localref; at: attrptr; $END$ begin with fexp^,fptr^ do if (klass <> func) or (pusesleft := maxint; baselevel := 0; end; stringassign(tree,dest); end; end; begin { genconcat } findfarleft(dest,tree^.opnd1); genappend(dest,tree^.opnd2); with reg[A,dest^.attr^.regnum] do begin usage := other; fdeckind = declared) then begin if etyptr^.form >= prok then begin getlocstorage(etyptr^.unpacksize,attr^); emit1(pea,attr^); end else begin resultsize := etyptr^.unpacksize; if odd(resultsize) then results allocstate := allocated; usesleft := 0; end; end; function isoverlay(pfptr: ctp; callt: calltype): boolean; var found: boolean; i: shortint; nametemp: string255; expptr: exptr; ctptemp: ctp; op: attrtype; begin isoverlize := resultsize+1; with op do begin addrmode := immediate; smallval := resultsize end; SPdir.storage := long; emit2(subq,op,SPdir); attr^.addrmode := topofstack; getsignbit(etyptr,attr); end; if klass = roay := false; if not(pfptr^.alias) and not(pfptr^.isdumped) then begin if pfptr^.othername <> NIL then begin found := false; i := 1; while not found and (i <= overlaytop) do if pfptr^.othername^ = overlaylistptr^[i] then founutineparm then callvar(proktype^.params,actualp,true) else {function constant} begin pushparms(next,actualp); if pflev > 1 then begin SPminus.storage := long; movestatic(pflev,SPminus) end; saveregs; forgetbaseregs; d := true else i := i + 1; if found then { overlay } begin nametemp := pfptr^.othername^ + '_' + pfptr^.namep^; new(expptr); with expptr^ do begin eclass := litnode; etyptr := NIL; attr := N if not isoverlay(fptr,gencall) then begin getprokconst(fptr,op); emit1(jsr,op); end; reloadregs; end; end else case spkey of spunitbusy,speoln,speof,spposition, spmaxpos,sppos,spstrpos,spstrrpt, spl)      in [spposition, spmaxpos,speoln,speof] then pushaddress(actualp^.expptr) else pushparms(next,actualp); saveregs; forgetbaseregs; if (spkey=speoln) or (spkey=speof) or (spkey=spposition) or (spkey=spmaxpos) then  spscan: begin extend(actualp^.expptr,wrd); pushvalue(actualp^.expptr); { 0 for until 1 for while } actualp := actualp^.nextptr; with actualp^ do begin source := expptr; letter := nextptr^.expptr; lngth := nextptr^.nextptr^.expcallIOproc('FS_F' + namep^) else if (spkey = spstrpos) or (spkey = sppos) then callstdproc('ASM_POS') else case spkey of spunitbusy: callstdproc('UIO_UNITBUSY'); spstrrpt,spltrim,sprtrim, spmemavail: callstdptr; end; pushaddress(source); extend(letter,bytte); pushvalue(letter); extend(lngth,long); pushvalue(lngth); saveregs; forgetbaseregs; callstdproc('ASM_SCAN'); reloadregs; with attr^ do begin addrmode := topofstack; signbit :proc('ASM_' + namep^); end; reloadregs; end; spstr,spcopy: begin getlocstorage(etyptr^.unpacksize,op); op.storage := long; emit1(pea,op); { PEA localtemp } attr^.addrmode := loconstack; attr^.access := ind= true; storage := long; end; end; spblockread, spblockwrite: with attr^ do begin storage:=long; signbit:=true; addrmode:=topofstack; with op do begin addrmode := immediate; smallval := 4; end; SPdir.storage := long; irect; SPminus.storage := long; emit2(move,SPind,SPminus); { MOVE.L (SP),-(SP) } pushparms(next,actualp); saveregs; forgetbaseregs; callstdproc('ASM_SCOPY'); reloadregs; end; spconcat: begin getlocstorage(etyptr^.unpack emit2(subq,op,SPdir); { SUBQ.L #4,SP } sexp := actualp; pushaddress(sexp^.expptr); {file} sexp := sexp^.nextptr; pushaddress(sexp^.expptr); {buffer} sexp := sexp^.nextptr; extend(sexp^.expptr, long); pushvalue(sexp^.expptr); size,op); op.storage := bytte; emit1(clr,op); { CLR.B dest temp } op.storage := long; emit1(pea,op); { PEA dest temp } sexp := actualp; with op do begin addrmode := immediate; smallval := etyptr^.unpa {# of blocks} sexp := sexp^.nextptr; extend(sexp^.expptr, long); pushvalue(sexp^.expptr); {block number} with op do begin addrmode := immediate; if spkey=spblockread then smallval := 1cksize - 1; end; repeat SPminus.storage := bytte; emit2(move,op,SPminus); SPminus.storage := long; SPind.offset := 2; emit2(move,SPind,SPminus); SPind.offset := 0; { MOVE.L (SP),-(SP) } pushaddress(sexp^.expptr else smallval := 0; end; SPminus.storage := bytte; emit2(move,op,SPminus); { MOVE.B 1or0,-SP } saveregs; forgetbaseregs; callIOproc('FS_FBLOCKIO'); reloadregs; end; spsin,spcos,spsqrt,spln,spexp,sp); saveregs; forgetbaseregs; callstdproc('ASM_SAPPEND'); reloadregs; sexp := sexp^.nextptr; until sexp = NIL; attr^.addrmode := loconstack; attr^.access := indirect; end; spesccode: with attr^ do begin storage := wrd;arctan: $IF MC68020$ if (float = flt_test) then begin {Emit test for card present} with op do begin storage := bytte; addrmode := longabs; offset := 0; indexed := false; absaddr.intval := false; new addrmode := locinreg; regnum := SB; offset := escapecodedisp; signbit := true; indexed := false; gloptr := sysglobalptr; end; spaddr: begin attr^.addrmode := topofstack; attr^.signbit := false; genaddr(fexp,NIL); end; (absaddr.valp); with absaddr.valp^ do begin cclass := paofch; slgth := strlen(float_flag); for i := 1 to slgth do sval[i] := float_flag[i]; end; end; emit1(tst,op); {TST.B fl)     ; end; end; otherwise escape(-8); end; {case spkey} end; {genfcall} procedure unaryops(fexp: exptr); var lsp: stp; op: attrtype; chkovfl: boolean; lbl1,lbl2: localref; at: attrptr; i: shortint; begin if (floattr(fexp,opnd); storage := opnd^.attr^.storage; { copy storage too } end else begin if not opnd^.attr^.signbit then extend(opnd,succ(opnd^.attr^.storage)); emit1(neg,opnd^.attr^); { NEG.z Dregnum } liftattr(fexpat = flt_test) and (fexp^.etyptr^.form = reals) and (fexp^.eclass in [negnode,absnode,sqrnode,floatnode,roundnode]) then begin {Emit test for card present} with op do begin storage := bytte; addrmode := longabs; offset := 0,opnd); storage := opnd^.attr^.storage; { copy storage too } end; end; notnode: begin if opnd^.ekind = xpr then maskboolexpr(opnd); liftattr(fexp,opnd); emit2(bchg,immed0,attr^); { BCHG #0,Dregnumoat_flag} lbl1.next := NIL; getbrattr(lbl1.pc,false,op); emit1(bne,op); {BNE card present code} {Generate code for libraries} float := flt_off; genfcall(fexp); at := fexp^.attr; NIL_attributes(fexp); indexed := false; absaddr.intval := false; new(absaddr.valp); with absaddr.valp^ do begin cclass := paofch; slgth := strlen(float_flag); for i := 1 to slgth do sval[i] := float_flag[i]; end; e; fexp^.attr := at; lbl2.next := NIL; getbrattr(lbl2.pc,false,op); emit1(bra,op); {BRA convergence point} {Generate code for card} fixreflist(addr(lbl1)); float:= flt_on; genfcall(fexp); pushvalnd; emit1(tst,op); {TST.B float_flag} lbl1.next := NIL; getbrattr(lbl1.pc,false,op); emit1(bne,op); {BNE card present code} {Generate code for libraries} float := flt_off; unaryops(fexp)ue(fexp); {Result must be same place as library result} fixreflist(addr(lbl2)); {Convergence point} float := flt_test; forgetbaseregs; end else if (float = flt_on) then realop(fexp) else $END$ with attr^ do ; at := fexp^.attr; forgetbaseregs; NIL_attributes(fexp); fexp^.attr := at; lbl2.next := NIL; getbrattr(lbl2.pc,false,op); emit1(bra,op); {BRA convergence point} {Generate code for card} fixreflist(addr( begin storage := multi; addrmode := topofstack; signbit := true; pushvalue(actualp^.expptr); saveregs; forgetbaseregs; case spkey of spsin: callstdproc('ASM_SIN'); spcos: callstdproc('ASM_COS'); spsqrt: callstdplbl1)); float:= flt_on; realop(fexp); pushvalue(fexp); {Result must be save place as library result} fixreflist(addr(lbl2)); {Convergence point} float := flt_test; forgetbaseregs; end else with fexp^,attr^ do beroc('ASM_SQRT'); spln: callstdproc('ASM_LN'); spexp: callstdproc('ASM_EXP'); sparctan: callstdproc('ASM_ARCTAN'); end; reloadregs; end; sphex,spoctal,spbinary: begin pushaddress(actualp^.expptr); saveregs; forgetgin lsp := opnd^.etyptr; if (float = flt_on) and (etyptr^.form = reals) then {no op} else if (etyptr^.form = reals) and (eclass=negnode) then pushvalue(opnd) else if eclass in [negnode,notnode,oddnode] then loadvalue(opnd) else genexpr(opnd); baseregs; case spkey of sphex: callstdproc('ASM_HEX'); spoctal: callstdproc('ASM_OCTAL'); spbinary: callstdproc('ASM_BINARY'); end; reloadregs; with attr^ do begin addrmode := topofstack; signbit := true; storage := long case eclass of negnode: begin if etyptr^.form = reals then if float = flt_on then realop(fexp) else begin op.addrmode := immediate; op.smallval := 7; emit2(bchg,op,SPind); { BCHG #7,(SP) } lift*      } conditionis := beq; end; absnode: begin if etyptr^.form = reals then if float = flt_on then realop(fexp) else begin pushvalue(opnd); SPind.storage := wrd; emit1(tst,SPind); { TSTstorage := long; SPind.offset := 4; {now push a copy} emit2(move,SPind,SPminus); { MOVE.L 4(sp),-(sp) } emit2(move,SPind,SPminus); { MOVE.L 4(sp),-(sp) } SPind.offset := 0; {restore} saveregs; forgetbasereg.W (SP) } with op do begin offset := 4; storage := bytte end; emit1(bge,op); { BGE.S *+6 } op.smallval := 7; emit2(bchg,op,SPind); { BCHG #7,(SP) } liftattr(fexp,opnd); storage := opns; callstdproc('ASM_RMUL'); reloadregs; addrmode := topofstack; storage := multi; signbit := true; end else begin if opnd^.attr^.packd then makeaddressable(opnd); if opnd^.eclass = litnode then fixliteral(opnd,wrd,true) d^.attr^.storage; end else begin if opnd^.attr^.signbit then with opnd^.attr^ do begin loadvalue(opnd); chkovfl := true; if storage <> long then begin extend(opnd,succ(storage)); chkovfl := else with opnd^.attr^ do if (storage = wrd) and not signbit then extend(opnd,long); if opnd^.attr^.storage = long then begin $IF MC68020$ loadvalue(opnd); emit2(muls,opnd^.attr^,opnd^.attr^); ovflck; liftattr(fexp,opn false; end; with op do begin offset := 2; storage := bytte end; emit1(bge,op); { BGE *+4 } emit1(neg,opnd^.attr^); { NEG.z Dregnum } if chkovfl then ovflck; end; liftd); $END$ $IF not MC68020$ pushvalue(opnd); SPminus.storage := long; emit2(move,SPind,SPminus); { MOVE.L (SP),-(SP) } saveregs; forgetbaseregs; callstdproc('ASM_MPY'); reloadregs; addrmode := toattr(fexp,opnd); storage := opnd^.attr^.storage; end; end; ordnode: begin maskboolexpr(opnd); liftattr(fexp,opnd); storage := opnd^.attr^.storage; end; strlennode: begin liftattr(fexp,oppofstack; $END$ storage := long; signbit := true; end else begin extend(opnd,wrd); loadvalue(opnd); emit2(muls,opnd^.attr^,opnd^.attr^); { MULS Dr,Dr } liftattr(fexp,opnd); storage := long; end; end; roundnodend); storage := bytte; signbit := false; end; strmaxnode: begin liftattr(fexp,opnd); access := direct; storage := bytte; offset := offset+4; signbit := false; end; chrnode: beg,truncnode: { no support on float card } begin pushvalue(opnd); saveregs; forgetbaseregs; case eclass of roundnode: callstdproc('ASM_ROUND'); truncnode: callstdproc('ASM_TRUNC'); end; storage := long; rein if opnd^.attr^.addrmode <> immediate then begin if rangecheck then emitcheck(opnd,char_ptr,true); extend(opnd,bytte); end; liftattr(fexp,opnd); signbit := false; end; {chrnode} oddnode: begin liftattr(loadregs; addrmode := topofstack; signbit := true; end; {roundnode, truncnode} floatnode: if float = flt_on then realop(fexp) else begin extend(opnd,long); pushvalue(opnd); saveregs; forgetbaseregs; if opndfexp,opnd); signbit := false; op.addrmode := immediate; op.smallval := 1; emit2(andd,op,attr^); end; sqrnode: if etyptr^.form = reals then if float = flt_on then realop(fexp) else begin pushvalue(opnd); SPminus.^.etyptr^.form = reals then liftattr(fexp,opnd) else callstdproc('ASM_FLOAT'); storage := multi; reloadregs; signbit := true; addrmode := topofstack; end; end; {case eclass} end; {with fexp^} end; {unaryops} procedure re*      genode: if signed then begin emit1(sge,fexp^.attr^); conditionis := bge; end else begin emit1(scc,fexp^.attr^); conditionis := bcc; end; end else case fexp^.eclass of eqnode: begin emit1(seq,= power_table[i] then power := i; end; procedure alops(fexp: exptr); { +,-,*,div,mod,and,or } type opindextype = (tos,mem,reg,slowlit,fastlit,quicklit,zilchlit); optype = array[addnode..andnode] of opcodetype; const op = optype [add,sfexp^.attr^); conditionis := beq; end; nenode: begin emit1(sne,fexp^.attr^); conditionis := bne; end; ltnode: if signed then begin emit1(sgt,fexp^.attr^); conditionis := bgt; end else begin emit1(shi,feub, muls,divs,swap,divs, {dummies - only add,sub,andd,orr are needed} orr,andd]; var lopindex,ropindex: opindextype; lsigned,rsigned: boolean; lstorage,rstorage: stortype; lmode,rmode: addrtype; procedure genrealop; var oalrelCMP ( fexp : exptr ); begin with fexp^, attr^ do begin pushvalue(opnd2); pushvalue(opnd1); saveregs; forgetbaseregs; case eclass of eqnode: callstdproc('ASM_EQ'); nenode: callstdproc('ASM_NE'); gtnode: callstdproc('ASM_GT'xp^.attr^); conditionis := bhi; end; lenode: if signed then begin emit1(sge,fexp^.attr^); conditionis := bge; end else begin emit1(scc,fexp^.attr^); conditionis := bcc; end; gtnode: if signed then); genode: callstdproc('ASM_GE'); ltnode: callstdproc('ASM_LT'); lenode: callstdproc('ASM_LE'); end; { case } reloadregs; addrmode := topofstack; end; { with } end; { realrelCMP } procedure relxpr(fexp: exptr); { code  begin emit1(slt,fexp^.attr^); conditionis := blt; end else begin emit1(scs,fexp^.attr^); conditionis := bcs; end; genode: if signed then begin emit1(sle,fexp^.attr^); conditionis := ble; end elsgen for relational node when a boolean result is required } var destonleft,signed: boolean; begin if fexp^.opnd1^.etyptr^.form = reals then realrelCMP(fexp) else begin relCMP(fexp,destonleft,signed); getregattr(D,fexp^.attr^); fexp^.attre begin emit1(sls,fexp^.attr^); conditionis := bls; end; end; end; { if } end; {relxpr} procedure relpaofchxpr(fexp: exptr); { generate a boolean result for a packed array of char relation} var flbl: reflistptr; op^.storage := bytte; if destonleft then case fexp^.eclass of eqnode: begin emit1(seq,fexp^.attr^); conditionis := beq; end; nenode: begin emit1(sne,fexp^.attr^); conditionis := bne; end; ltnode: if signed then ,r: attrtype; begin getregattr(D,r); new(flbl); flbl^.next := NIL; genpaofchcond(fexp,flbl,false); {forward branch} { if true then } op.smallval := 1; emit2(moveq,op,r); { MOVEQ #1,Dr } with op do begin begin emit1(slt,fexp^.attr^); conditionis := blt; end else begin emit1(scs,fexp^.attr^); conditionis := bcs; end; lenode: if signed then begin emit1(sle,fexp^.attr^); conditionis := ble; end else offset := 2; storage := bytte end; emit1(bra,op); { BRA.S *+4 } { if false then } fixreflist(flbl); { flbl EQU * } r.storage := long; emit1(clr,r); { C begin emit1(sls,fexp^.attr^); conditionis := bls; end; gtnode: if signed then begin emit1(sgt,fexp^.attr^); conditionis := bgt; end else begin emit1(shi,fexp^.attr^); conditionis := bhi; end; LR.L Dr } with fexp^.attr^ do begin addrmode := inDreg; regnum := r.regnum end; end; { relpaofchxpr } procedure powerof2(elsize:integer; var power:shortint); var i: shortint; begin power := 0; for i := 1 to bitsperword-2 do if elsize +     p: attrtype; lbl1,lbl2: localref; at: attrptr; i: shortint; {real + - * /} begin if float = flt_test then begin {Emit test for card present} with op do begin storage := bytte; addrmode := longabs; offset  and (storage = wrd) then extend(opnd2,long); if storage = long then pushvalue(opnd2); end; makeaddressable(opnd1); if opnd1^.attr^.addrmode = immediate then fixliteral(opnd1,wrd,true); if (opnd1^.attr^.storage = long) or (opnd2^.attr:= 0; indexed := false; absaddr.intval := false; new(absaddr.valp); with absaddr.valp^ do begin cclass := paofch; slgth := strlen(float_flag); for i := 1 to slgth do sval[i] := float_flag[i]; end; end; emit1(tst,op); ^.storage = long) or (opnd1^.attr^.storage = wrd) and not opnd1^.attr^.signbit then begin with opnd2^.attr^ do if storage <> long then begin if addrmode = immediate then begin storage := long; signbit := true end  {TST.B float_flag} lbl1.next := NIL; getbrattr(lbl1.pc,false,op); emit1(bne,op); {BNE card present code} {Generate code for libraries} float := flt_off; genrealop; at := fex else checkstackandextend(opnd1,opnd2,long); pushvalue(opnd2); end; with opnd1^.attr^ do if storage <> long then if addrmode = immediate then begin storage := long; signbit := true end else extend(opnd1,long); pushvp^.attr; NIL_attributes(fexp); fexp^.attr := at; lbl2.next := NIL; getbrattr(lbl2.pc,false,op); emit1(bra,op); {BRA convergence point} {Generate code for card} fixreflist(addr(lbl1)); alue(opnd1); saveregs; forgetbaseregs; callstdproc('ASM_MPY'); reloadregs; with attr^ do begin addrmode := topofstack; storage := long; signbit := true; end; end else begin {in-line MPY} extend(opnd1,wrd); checkstack float:= flt_on; realop(fexp); pushvalue(fexp); {Result must be save place as library result} fixreflist(addr(lbl2)); {Convergence point} float := flt_test; forgetbaseregs; end else if float = flandextend(opnd1,opnd2,wrd); if opnd2^.attr^.addrmode = inDreg then begin emit2(muls,opnd1^.attr^,opnd2^.attr^);{ MULS op1,Dop2 } liftattr(fexp,opnd2); freeregs(opnd1^.attr); end else begin loadvalue(opnd1); emit_on then realop(fexp) else with fexp^,attr^ do begin pushvalue(opnd2); pushvalue(opnd1); saveregs; forgetbaseregs; case eclass of addnode: callstdproc('ASM_RADD'); subnode: callstdproc('ASM_RSUB'); mulnode: callstdproc('ASM_t2(muls,opnd2^.attr^,opnd1^.attr^); { MULS op2,Dop1 } liftattr(fexp,opnd1); freeregs(opnd2^.attr); end; attr^.storage := long; end; etyptr := intptr; end else begin {DIV or MOD} makeaddressable(opnd1); if opnd2^.eclass RMUL'); divnode: callstdproc('ASM_RDIV'); end; { case } reloadregs; addrmode := topofstack; storage := multi; signbit := true; end; {with} end; procedure genmulop; {code gen for *, DIV, MOD} var op: attr= litnode then powerof2(opnd2^.litval.ival,res) else res := 0; if (eclass = modnode) and (res <> 0) then begin opnd2^.litval.ival := opnd2^.litval.ival - 1; loadvalue(opnd1); genexpr(opnd2); fixliteral(opnd2,opnd1^.attr^.storage,true); type; patchloc: addrrange; res: shortint; begin with fexp^ do if eclass = mulnode then begin makeaddressable(opnd2); with opnd2^.attr^ do begin if addrmode = immediate then fixliteral(opnd2,wrd,true) else if not signbit extend(opnd1,opnd2^.attr^.storage); emit2(andi,opnd2^.attr^,opnd1^.attr^); liftattr(fexp,opnd1); attr^.storage := opnd1^.attr^.storage; opnd2^.litval.ival := opnd2^.litval.ival + 1; { undo damage } end else begin with opnd1^.attr^ +      begin emit2(divs,opnd2^.attr^,opnd1^.attr^); liftattr(fexp,opnd1); with attr^ do begin storage := long; signbit := true; end; ovflck; end else begin divsl_reg := getreg(D); emit2(divsl,opnd2^.attr^,opnd1^.attr^); ; etyptr := shortintptr; freeregs(opnd2^.attr); end; {in-line div or mod} end; {with opnd2^.attr^} end; end; {div or mod} end; {genmulop} procedure genshft; var op: attrtype; temp: shortint; patchl liftattr(fexp,opnd1); with attr^ do begin freeit(D,regnum); regnum := divsl_reg; storage := long; signbit := true; end; if (opnd1^.eclass <> litnode) or ((opnd1^.eclass = litnode) and (opnd1^.litval.ival < 0)) then oc: addrrange; ovflpossible: boolean; begin with fexp^ do begin if opnd2^.litval.ival > 0 then { multiply } begin ovflpossible := false; makeaddressable(opnd1); if opnd1^.attr^.storage <> long then if opnd2^.litval.ival >= do begin if addrmode = immediate then fixliteral(opnd1,wrd,true) else if not signbit and (storage = wrd) then extend(opnd1,long); if storage = long then $IF not MC68020$ pushvalue(opnd1) $END$ else  begin emit1(tst,attr^); patchloc := codephile.bytecount + 2; op.offset := 0; op.storage := bytte; emit1(bge,op); emit2(add,opnd2^.attr^,attr^); fixbyte(patchloc - 1, codephile.bytecount - patchloc); end; freeregs(opnd2 if ((opnd2^.eclass = fcallnode) and (opnd2^.etyptr^.unpacksize = 4{bytes})) or (opnd2^.ekind = xpr) then begin extend(opnd1,long); $IF not MC68020$ pushvalue(opnd1) $END$ end; end; $IF MC68020$ loadvalue(opnd1); $END^.attr); end; $END$ etyptr := intptr; end else begin {in-line div or mod} with opnd1^.attr^ do if addrmode = immediate then begin storage := long; signbit := true; end else if (addrmode = topofstack) and $ makeaddressable(opnd2); with opnd2^.attr^ do begin if addrmode = immediate then fixliteral(opnd2,wrd,true) else if not signbit and (storage = wrd) then extend(opnd2,long); if (storage = long) or (opnd1^.attr^.storage = lo (opnd2^.attr^.addrmode = topofstack) then loadvalue(opnd2); loadvalue(opnd1); extend(opnd1,long); extend(opnd2,wrd); if RANGECHECK and (eclass = modnode) and (opnd2^.eclass <> litnode) then begin loadvalue(opnd2); ng) then begin $IF not MC68020$ extend(opnd1,long); pushvalue(opnd1); extend(opnd2,long); pushvalue(opnd2); saveregs; forgetbaseregs; if eclass = divnode then callstdproc('ASM_DIV') else callwith op do begin addrmode := immediate; smallval := 32767; end; emit2(chk,op,opnd2^.attr^); end; opnd1^.attr^.storage := wrd; emit2(divs,opnd2^.attr^,opnd1^.attr^); { DIVS op2,Dop1 } liftattr(fexp,opnd1); stdproc('ASM_MOD'); reloadregs; with attr^ do begin addrmode := topofstack; storage := long; signbit := true; end; $END$ $IF MC68020$ extend(opnd1,long); loadvalue(opnd1); extend(opnd2,long);  with attr^ do begin storage := wrd; signbit := true; if eclass = modnode then begin emit1(swap,attr^); if (opnd1^.eclass <> litnode) or ((opnd1^.eclass = litnode) and (opnd1^.litval.ival < 0)) then begin emit1(tstif RANGECHECK and (eclass = modnode) and (opnd2^.eclass <> litnode) then begin loadvalue(opnd2); with op do begin addrmode := immediate; smallval := maxint; end; emit2(chk,op,opnd2^.attr^); end; if eclass = divnode then,attr^); patchloc := codephile.bytecount + 2; op.offset := 0; op.storage := bytte; emit1(bge,op); emit2(add,opnd2^.attr^,attr^); fixbyte(patchloc-1,codephile.bytecount - patchloc); end; end else ovflck; end,     8 then extend(opnd1,long) else extend(opnd1,succ(opnd1^.attr^.storage)) else ovflpossible := true; loadvalue(opnd1); emitshift(opnd2^.litval.ival, opnd1^.attr^.regnum,asl, opnd1^.attr^.storage); if ovflpossible then ovflck; end else { loadvalue(opnd1); opnd1^.attr^.storage := bytte; liftattr(fexp,opnd1); emit2(op[eclass],opnd2^.attr^,opnd1^.attr^); freeregs(opnd2^.attr); end; end; end; { genandor } function getopindex(attr: attrptr): opindextype; divide } begin loadvalue(opnd1); if opnd1^.attr^.signbit then begin patchloc := codephile.bytecount + 2; op.offset := 0; op.storage := bytte; emit1(bge,op); op.smallval := 1; for temp := 1 to -opnd2^.litval.ival do op.smallval := begin with attr^ do case addrmode of topofstack: getopindex := tos; locinreg,shortabs, namedconst, longabs,prel: getopindex := mem; inDreg: getopindex := reg; immediate: if smallval = 0 th op.smallval * 2; op.smallval := op.smallval - 1; op.addrmode := immediate; emit2(add,op,opnd1^.attr^); { ADD #fudge,opnd } fixbyte(patchloc-1,codephile.bytecount - patchloc); with opnd1^.attr^ do emitshift(-opnd2^.litval.ival, en getopindex := zilchlit else if (smallval >= 1) and (smallval <= 8) then getopindex := quicklit else if (smallval >= -128) and (smallval <= 127) then getopindex := fastlit else getopindex := slowlit; end; {case} end; {getopindex} regnum,asr,storage); end else with opnd1^.attr^ do emitshift(-opnd2^.litval.ival, regnum,lsr,storage); end; liftattr(fexp,opnd1); {fexp^}attr^.storage := opnd1^.attr^.storage; if attr^.storage = long then etyptr := in procedure couldbequick(fexp: exptr); { case 1: fexp is addnode or subnode and opnd2 is a litnode. If opnd2^.litval is in [-8..-1] then flip its sign and change fexp from addnode to subnode or vice versa. case 2: fexp is addnode atptr else etyptr := shortintptr; end; end; procedure genandor; var truelist,falselist: reflistptr; begin if shortcircuit then begin truelist := NIL; falselist := NIL; with fexp^.attr^ do begin addrmode := innd opnd1 is a litnode. If opnd1^.litval is in [-8..-1] then flip its sign, change fexp to subnode, and exchange opnd1 and opnd2 } var exptemp: exptr; function quickexceptforsign(fattr: attrptr): boolean; begin with Dreg; regnum := getreg(D); storage := bytte; end; if fexp^.eclass = andnode then genshortand(fexp,truelist,falselist,true,false,true,fexp^.attr) else { fexp^.eclass = ornode } genshortor(fexp,truelist,falselist,true,false,true,fexp^.attr);fattr^ do quickexceptforsign := (addrmode = immediate) and (smallval >= -8) and (smallval <= -1); end; begin {couldbequick} with fexp^ do begin if quickexceptforsign(opnd2^.attr) then begin with opnd2^.attr^ do smallval := fixreflist(truelist); fixreflist(falselist); forgetbaseregs; end else with fexp^, attr^ do begin if opnd1^.num_ops >= opnd2^.num_ops then begin makeaddressable(opnd1); makeaddressable(opnd2); end else begin makeaddressable(op -smallval; if eclass = addnode then eclass := subnode else eclass := addnode; end; if eclass = addnode then if quickexceptforsign(opnd1^.attr) then begin with opnd1^.attr^ do smallval := -smallval; eclass := subnode; exptemp := opnd1nd2); makeaddressable(opnd1); end; if opnd2^.attr^.addrmode = inDreg then begin opnd2^.attr^.storage := bytte; liftattr(fexp,opnd2); emit2(op[eclass],opnd1^.attr^,opnd2^.attr^); freeregs(opnd1^.attr); end else begin; opnd1 := opnd2; opnd2 := exptemp; end; end; end; {couldbequick} begin {alops} with fexp^,attr^ do if etyptr = realptr then genrealop $IF MC68020$ else if eclass in [divnode,modnode] then genmulop $END$ $IF not ,      couldbequick(fexp); lopindex := getopindex(opnd1^.attr); ropindex := getopindex(opnd2^.attr); case ord(lopindex)*10+ord(ropindex) of 00, {stack op stack} 01, {stack op mem} 10, {mem op stack} 11, {mem op mem} 13, {mem op slowlitack} 52: {quicklit op reg} begin if eclass = addnode then begin liftattr(fexp,opnd2); if ropindex = tos then begin SPind.storage := storage; emit2(add,opnd1^.attr^,SPind); end else emit2(add,opnd1^.attr^,o} 15, {mem op quicklit} 31, {slowlit op mem} 40, {fastlit op stack} 41, {fastlit op mem} 42, {fastlit op reg} 51: {quicklit op mem} begin loadvalue(opnd1); liftattr(fexp,opnd1); emit2(op[eclass],opnd2^.attr^,opnd1^.attr^); freeregs(opnd2^pnd2^.attr^); freeregs(opnd1^.attr); end else if eclass = subnode then begin loadvalue(opnd1); liftattr(fexp,opnd1); emit2(sub,opnd2^.attr^,opnd1^.attr^); freeregs(opnd2^.attr); end $IF MC68020$ else {mulnodeMC68020$ else if eclass in [mulnode,divnode,modnode] then genmulop $END$ else if eclass = shftnode then genshft else if eclass in [andnode,ornode] then genandor else { integer ADD,SUB and MUL for 68020 } begin if opnd1^.ekin.attr); ovflck; end; 02, {stack op reg} 04: {stack op fastlit} begin if ropindex = fastlit then loadvalue(opnd2); if eclass = addnode then begin liftattr(fexp,opnd2); emit2(add,opnd1^.attr^,opnd2^.attr^);{ ADD.z (SP)+,Dop2 } d > opnd2^.ekind then begin makeaddressable(opnd1); makeaddressable(opnd2) end else begin makeaddressable(opnd2); makeaddressable(opnd1) end; with opnd1^.attr^ do begin lmode := addrmode; lstorage := storage; lsigned := signbit; end;  end else if eclass = subnode then begin SPind.storage := storage; liftattr(fexp,opnd1); emit2(sub,opnd2^.attr^,SPind); { SUB.z Dop1,(SP) } freeregs(opnd2^.attr); end $IF MC68020$ else if eclass = mulnodwith opnd2^.attr^ do begin rmode := addrmode; rstorage := storage; rsigned := signbit; end; if lmode = immediate then begin if (rstorage = long) or (rstorage = wrd) and not rsigned then fixliteral(opnd1,long,true) else fixliteral(opnd1,wrd,te then begin liftattr(fexp,opnd2); emit2(muls,opnd1^.attr^,opnd2^.attr^);{ MUL.z (SP)+,Dop2 } end $END$; ovflck; end; 03, {stack op slowlit} 05, {stack op quicklit} 20, {reg op stack} 21, {reg op mem} 22, {reg op rerue); with opnd1^.attr^ do begin lstorage := storage; lsigned := signbit end; end else if rmode = immediate then begin if (lstorage = long) or (lstorage = wrd) and not lsigned then fixliteral(opnd2,long,true) else fixliteral(opnd2,wrd,trueg} 23, {reg op slowlit} 25: {reg op quicklit} begin liftattr(fexp,opnd1); if lopindex <> tos then emit2(op[eclass],opnd2^.attr^,opnd1^.attr^) else $IF MC68020$ if eclass = mulnode then begin loadvalue(opnd1); ); with opnd2^.attr^ do begin rstorage := storage; rsigned := signbit end; end; if (lstorage = long) or (rstorage = long) or (lstorage = wrd) and not lsigned or (rstorage = wrd) and not rsigned then begin extend(opnd1,long); checkstackan liftattr(fexp,opnd1); emit2(muls,opnd2^.attr^,opnd1^.attr^); end else $END$ begin SPind.storage := storage; emit2(op[eclass],opnd2^.attr^,SPind); end; freeregs(opnd2^.attr); ovflck; end; 06,16dextend(opnd1,opnd2,long); storage := long; etyptr := intptr; end else begin extend(opnd1,wrd); checkstackandextend(opnd1,opnd2,wrd); storage := wrd; etyptr := shortintptr; end; $IF MC68020$ if not (eclass = mulnode) then $END$ ,26,36,46,56,66: {opnd2 is zero} begin $IF MC68020$ if eclass = mulnode then liftattr(fexp,opnd2) else $END$ liftattr(fexp,opnd1); end; 12, {mem op reg} 30, {slowlit op stack} 32, {slowlit op reg} 50, {quicklit op st-     } begin loadvalue(opnd2); liftattr(fexp,opnd2); emit2(muls,opnd1^.attr^,opnd2^.attr^); freeregs(opnd1^.attr); end $END$; ovflck; end; 14: {mem op fastlit} begin loadvalue(opnd2); liftattr(fexp,opnd2); h fexp^, attr^, ffldptr^ do begin genexpr(frecptr); { obtain address info for base of record } if (fldaddr <> 0) or fispackd then begin if frecptr^.attr^.access = indirect then loadaddress(frecptr,false); liftattr(fexp,frecptr); getsignb emit2(op[eclass],opnd1^.attr^,opnd2^.attr^); freeregs(opnd1^.attr); ovflck; if eclass = subnode then begin emit1(neg,attr^); ovflck; end; end; 24: {reg op fastlit} begin loadvalue(opnd2); liftattr(fexp,opnd1);it(etyptr,attr); offset := offset + fldaddr; if fispackd then begin packd := true; bitsize := idtype^.bitsize; signbit := idtype^.signbit; bitoffset.static := bitoffset.static + fldfbit; combineoffsets(attr,idtype^.unpacksize); end; en emit2(op[eclass],opnd2^.attr^,opnd1^.attr^); freeregs(opnd2^.attr); ovflck; end; 60,61,62,63,64,65: {opnd1 is zilchlit} begin if eclass = subnode then begin if ropindex = mem then loadvalue(opnd2); if ropindex <>d else begin {unpacked, offset=0} liftattr(fexp,frecptr); getsignbit(idtype,attr); end; end; {with} end; {genrecsel} procedure gensubscr(fexp : exptr); var arraytype : stp; arrayattr : attrptr; lobound,hibound, temp : integ tos then emit1(neg,opnd2^.attr^) else begin SPind.storage := storage; emit1(neg,SPind); end; ovflck; end; $IF MC68020$ if eclass = mulnode then liftattr(fexp,opnd1) else $END$ ler; elementsize : addrrange; op,xop : attrtype; $IF MC68020$ type two_to_the_type = array[0..3] of 1..8; const two_to_the = two_to_the_type[1,2,4,8]; $END$ procedure cnf_subscr; var lobound_attr, hiboiftattr(fexp,opnd2); end; end; {case} $IF MC68020$ if eclass = mulnode then storage := long; $END$ end; { integer ADD or SUB or MUL for 68020} end; {alops} procedure combineoffsets(fattr: attrptr; fsize: addrrange); und_attr, cnfsize_attr, op1,op2: attrtype; lbl: localref; savelink: attrptr; begin with fexp^ do begin if arrayattr^.access = indirect then loadaddress(arayp,false); liftattr(fexp,arayp); getsignbit(etyptr{ for fattr^, attempt to set PACKD to false by consolidating bit offset and offset information. Fsize is unpacksize of type associated with fattr } begin with fattr^ do begin offset := offset + mydiv(bitoffset.static,16) * 2; bitoff,attr); makeaddressable(indxp); maskboolexpr(indxp); if indxp^.attr^.storage = bytte then extend(indxp,wrd); if (indxp^.attr^.storage = wrd) and not (indxp^.attr^.signbit) then extend(indxp,long); loadvalue(indxp); {Subtset.static := (bitoffset.static mod 16); if (bitoffset.static = 8) and (bitsize = 8) then begin offset := offset + 1; bitoffset.static := 0; end; if ((bitoffset.static = 0) and (bitoffset.variable = -1)) and (fsize = bitsize div ract lower bound} with lobound_attr do begin addrmode := locinreg; regnum := getbasereg(arraytype^.cnf_index^.loboundid^.vlev); offset := arraytype^.cnf_index^.loboundid^.vaddr; indexed := false; gloptr := NIL; bitsperaddr) then packd := false; end; end; procedure genrecsel ( fexp,frecptr : exptr; ffldptr : ctp); { fexp^ is a selection node. frecptr^ is the node of the record selected into. ffldptr is the field id pointer. } begin wit case arraytype^.inxtype^.unpacksize of 1: storage := bytte; 2: storage := wrd; 4: storage := long; end; if ord(indxp^.attr^.storage) < ord(storage) then extend(indxp,storage); end; { with lobound_attr } if RANGECHECK then b-      with op1 do begin addrmode := inDreg; regnum := getreg(D); storage := wrd; end; emit2(move,lobound_attr,op1); op1.storage := long; emit1(ext,op1); end end else op1 := lobound_attr; emit2(sub,op1,indxp^.attr^ saveregs; forgetbaseregs; callstdproc('ASM_MPY'); reloadregs; indxp^.attr^.addrmode := topofstack; $END$ end else {in line multiply} begin emit2(muls,op2,indxp^.attr^); indxp^.attr^.storage :); if op1.addrmode = inDreg then freeit(D,op1.regnum); end; {with lobound_attr} if RANGECHECK then { greater than or equal to lower bound ? } with op1 do begin offset := 2; storage := bytte; emit1(bge,op1); fixreflist(addr= long; if op2.addrmode = inDreg then freeit(D,op2.regnum); end; if (arraytype^.aispackd) then begin if indxp^.attr^.addrmode <> inDreg then loadvalue(indxp); with fexp^.attr^ do begin packd := true; bitoffset.variablegin with hibound_attr do begin addrmode := locinreg; regnum := lobound_attr.regnum; { loboundid and hiboundid are at the same level } offset := arraytype^.cnf_index^.hiboundid^.vaddr; indexed := false; gloptr := NIL; storage := lobound_(lbl)); op1.smallval := 7; emit1(trap,op1); { TRAP #7 } end; {multiply by size} cnfsize_attr := lobound_attr; cnfsize_attr.offset := arraytype^.cnf_index^.hiboundid^.vaddr; with cnfsize_attr do begin case arraytyattr.storage; { less than or equal to upper bound ? } if ord(storage) < ord(indxp^.attr^.storage) then begin if (storage = bytte) then begin with op1 do begin addrmode := inDreg; regnum := getreg(D); storape^.inxtype^.unpacksize of 1: begin storage := bytte; offset := offset + 2; end; 2: begin storage := wrd; offset := offset + 2; end; 4: begin storage := long; offset := offset + 4; end; end; if storage <> ge := long; end; emit1(clr,op1); op1.storage := bytte; emit2(move,hibound_attr,op1); op1.storage := indxp^.attr^.storage; end else {storage = wrd} begin with op1 do begin addrmode := inDreg; regnumindxp^.attr^.storage then begin if storage = bytte then begin with op2 do begin addrmode := inDreg; regnum := getreg(D); storage := long; end; emit1(clr,op2); op2.storage := bytte; emit2(move,cnfsize_attr,op2); op2.s := getreg(D); storage := wrd; end; emit2(move,hibound_attr,op1); op1.storage := long; emit1(ext,op1); end; end else op1 := hibound_attr; emit2(cmp,op1,indxp^.attr^); if op1.addrmode = inDreg then freeit(D,op1.torage := op1.storage; end else {storage = wrd} begin with op2 do begin addrmode := inDreg; regnum := getreg(D); storage := wrd; end; emit2(move,cnfsize_attr,op2); op2.storage := long; emit1(ext,op2); end endregnum); lbl.next := NIL; getbrattr(lbl.pc,false,op1); emit1(bgt,op1); end; end; { with hibound_attr } with lobound_attr do begin if ord(storage) < ord(indxp^.attr^.storage) then begin if (storage = bytte) then begin with  else op2 := cnfsize_attr; end; {with cnfsize_attr} freeregs(addr(lobound_attr)); if op2.storage = long then {call routine} begin $IF MC68020$ emit2(muls,op2,indxp^.attr^); ovflck; if op2.addrmode = inDreop1 do begin addrmode := inDreg; regnum := getreg(D); storage := long; end; emit1(clr,op1); op1.storage := bytte; emit2(move,lobound_attr,op1); op1.storage := indxp^.attr^.storage; end else {storage = wrd} begin g then freeit(D,op2.regnum); $END$ $IF not MC68020$ SPminus.storage := long; emit2(move,indxp^.attr^,SPminus); freeregs(indxp^.attr); emit2(move,op2,SPminus); if op2.addrmode = inDreg then freeit(D,op2.regnum); .     e := indxp^.attr^.regnum; bitoffset.static := 0; bitoffset.storage := long; bitsize := arraytype^.aelbitsize; signbit := arraytype^.aeltype^.signbit; if arrayattr^.indexed then begin indexed := true; indexreg := arrayattr^.indexreg; indexs begin emit2(muls,op2,xop); { MULS #fsize,Dx } xstorage := long; end else { xop.storage = long } begin $IF MC68020$ emit2(muls,op2,xop); ovflck; $END$ $IF not MC68020$ SPminus.storage := long; emittorage := arrayattr^.indexstorage; $IF MC68020$ indexscale := arrayattr^.indexscale; $END$ end else indexed := false; end; end else begin if arrayattr^.indexed then {add index regs} begin with op2 do begin add2(move,xop,SPminus); emit2(move,op2,SPminus); reg[D,xop.regnum].allocstate := free; saveregs; forgetbaseregs; callstdproc('ASM_MPY'); reloadregs; reg[D,xop.regnum].allocstate := allocated; emit2(move,SPplus,xop); $END$ end; endrmode := inDreg; regnum := arrayattr^.indexreg; storage := long; end; emit2(add,indxp^.attr^,op2); freeregs(indxp^.attr); savelink := indxp^.attr^.next; indxp^.attr^ := op2; indxp^.attr^.next := savelink; end; if indxp^.attr^.addrmode ; end; {multiplyindex} begin {gensubscr} with fexp^, attr^ do begin genexpr(arayp); { obtain array accessing info } arrayattr := arayp^.attr; arraytype := arayp^.etyptr; if arraytype^.form = cnfarrays then cnf_subscr else<> inDreg then loadvalue(indxp); with fexp^.attr^ do begin indexreg := indxp^.attr^.regnum; indexstorage := long; indexed := true; $IF MC68020$ indexscale := 0; $END$ end; end; end; end; {cnf_subscr} procedure multiplyindex  begin if strgtype(arraytype) then begin lobound := 0; hibound := arraytype^.maxleng; end else getbounds(arraytype^.inxtype,lobound,hibound); elementsize := arraytype^.aelsize; if arrayattr^.access = indirect then loadaddres (fsize: integer; xreg: regrange; var xstorage: stortype); { multiply value in xreg by fsize, the array element size or bitsize. Modify xstorage as needed } var power : shortint; { 0..8 } xop,op2: attrtype; begin ps(arayp,false); if RANGECHECK and strgtype(arraytype) then makeaddressable(arayp); liftattr(fexp,arayp); getsignbit(etyptr,attr); if (indxp^.eclass = litnode) then {constant index} begin if RANGECHECK and strgtype(arraytype) thowerof2(fsize,power); with xop do begin addrmode := inDreg; regnum := xreg; storage := xstorage; end; if power <> 0 then begin if xstorage = wrd then begin xop.storage := long; emit1(ext,xop); en begin extend(indxp,bytte); getregattr(D,op); {for string length} if indxp^.attr^.storage <> bytte then emit2(moveq,immed0,op); { MOVEQ #0,Dr } op.storage := bytte; emit2(move,arrayattr^,op); { MOVE. { EXT.L Dx } end; if power = 1 then emit2(add,xop,xop) { ADD.L Dx,Dx } else emitshift(power,xreg,asl,long); if xstorage = long then ovflck else xstorage := long; end else {fsize not a powB string[0],Dr } op.storage := indxp^.attr^.storage; emit2(cmpi,indxp^.attr^,op); freeit(D,op.regnum); with op do begin offset := 2; storage := bytte; emit1(bcc,op); {BCC.S *+4} smallval := 7; emit1(trap,op); {TRAP #7}er of 2} if fsize <> 1 then begin op2.addrmode := immediate; op2.smallval := fsize; if (xop.storage = wrd) and (fsize > 32767) then begin xop.storage := long; emit1(ext,xop); xstorage := long; end; if xop.storage = wrd then  end; end; IF arraytype^.AISPACKD THEN begin PACKD := TRUE; BITSIZE := arraytype^.AELBITSIZE; SIGNBIT := arraytype^.AELTYPE^.SIGNBIT; temp := BITOFFSET.STATIC + (INDXP^.LITVAL.IVAL - LOBOUND) * arraytype^.AELBITSIZE; offset .     T.VARIABLE := INDEXREG; bitoffset.storage := indexstorage; BITSIZE := arraytype^.AELBITSIZE; SIGNBIT := arraytype^.AELTYPE^.SIGNBIT; IF arrayattr^.INDEXED THEN BEGIN INDEXED := TRUE; INDEXREG := arrayattr^.INDEXREG; indexstorage  arrayattr^.indexstorage := long; end; if indexstorage < arrayattr^.indexstorage then begin xop.storage := long; emit1(ext,xop); { EXT.L DfexpX } indexstorage := long; end; emit2(add,op,xop); := arrayattr^.indexstorage; $IF MC68020$ indexscale := arrayattr^.indexscale; $END$ END ELSE INDEXED := FALSE; multiplyindex(arraytype^.aelbitsize, bitoffset.variable,bitoffset.storage); BITOFFSET.STATIC := BITOFFSET.STAT { ADD.xsize DarrayX,DfexpX } freeit(D,arrayattr^.indexreg) end; { adjust displacement } offset := offset - lobound * elementsize; with arraytype^ do IF AISPACKD and (AELTYPE^.UNPACKSIZE <> ELEMENTSIZE) THEN if elem:= offset + mydiv(temp,16) * 2; bitoffset.static := (temp mod 16); combineoffsets(attr,etyptr^.unpacksize); end { AISPACKD } else { add index to displacement } offset := offset + (indxp^.litval.ival - lobound) * elementsize; end {litnIC - LOBOUND * BITSIZE; END ELSE {bytte, word, or unpacked array} BEGIN with arraytype^ do IF AISPACKD THEN begin ELEMENTSIZE := AELBITSIZE DIV BITSPERADDR; attr^.signbit := aeltype^.signbit; end; $IF not MC68ode} else { non-constant index } begin makeaddressable(indxp); maskboolexpr(indxp); if RANGECHECK then ensure_valid_condition_code := true; if indxp^.attr^.storage = bytte then extend(indxp,wrd); if (indxp^.attr^.storage=wrd) and not(indxp020$ multiplyindex(elementsize,indexreg,indexstorage); $END$ $IF MC68020$ case elementsize of 2: indexscale := 1; 4: indexscale := 2; 8: indexscale := 3; otherwise begin indexscale := 0; multiplyindex(e^.attr^.signbit) then extend(indxp,long); ensure_valid_condition_code := false; loadvalue(indxp); indexreg := indxp^.attr^.regnum; indexstorage := indxp^.attr^.storage; indexed := true; $IF MC68020$ indexscale := 0; $END$ if RANGECHECK then lementsize,indexreg,indexstorage); end; end; if arrayattr^.indexed then { account for scale factors } begin if (arrayattr^.indexscale <> 0) then if (indexscale <> 0) then multiplyindex(two_to_the[arrayattr^.indexscale-index if strgtype(arraytype) then begin if not ucsd then {prohibit s[0]} with op do begin offset := 2; storage := bytte; emit1(bgt,op); {BGT.S *+4} smallval := 7; emit1(trap,op); {TRAP #7} end; getregattr(D,op); {forscale], arrayattr^.indexreg,arrayattr^.indexstorage) else multiplyindex(two_to_the[arrayattr^.indexscale], arrayattr^.indexreg,arrayattr^.indexstorage) else if indexscale <> 0 then begin multiplyindex(two_to_th string length} emit2(moveq,immed0,op); { MOVEQ #0,Dr } op.storage := bytte; emit2(move,arrayattr^,op); { MOVE.B string[0],Dr } xop.addrmode := inDreg; xop.regnum := indexreg; emit2(chk,op,xop); e[indexscale],indexreg,indexstorage); indexscale := 0; end; end; $END$ if arrayattr^.indexed then { add index regs } begin with op do begin addrmode := inDreg; regnum := arrayattr^.indexreg; storage := arr { CHK Dr,Dindexreg } freeit(D,op.regnum); end else emitcheck(indxp,arraytype^.inxtype,true); IF (arraytype^.AISPACKD) AND (arraytype^.AELBITSIZE<>8) AND (arraytype^.AELBITSIZE<>16) THEN begin PACKD := TRUE; BITOFFSEayattr^.indexstorage; end; xop.addrmode := inDreg; xop.regnum := indexreg; xop.storage := indexstorage; if arrayattr^.indexstorage < indexstorage then begin op.storage := long; emit1(ext,op); { EXT.L DarrayX }/     entsize = 1 then storage := bytte else if elementsize = 2 then storage := wrd else storage := long; END; {bytte,word, or unpacked array} end; {non-constant index} end; { standard array subscript } en minint; if (possible_low < etyptr^.setmin) or (possible_hi > etyptr^.setmax) then begin lbl2 := NIL; loadvalue(lowptr); extend(lowptr,long); loadvalue(hiptr); extend(hiptr,long); emit2(cmp,lowpd; { with fexp^,attr^ } end; { gensubscr } procedure genset(fexp: exptr); {generate a set having variable part} var ptr: elistptr; op: attrtype; checkstp : stp; possible_low, possible_hi : integer; lbltemp, lbl1, lbl2 tr^.attr^,hiptr^.attr^); {CMP low,hi} new(lbl1); lbl1^.next := NIL; lbl1^.pc := 0; getbrattr(lbl1^.pc,false,op); { branch around rangecheck code if hi < low } emit1(blt,op); {BLT lbl1}: reflistptr; begin with fexp^, attr^ do begin getlocstorage(etyptr^.unpacksize,op); emit1(pea,op); { PEA temp } ekind := cnst; {deal with the constant part first} pushaddress(fexp); ptr:=setvarpart; saveregs;  if (possible_hi < etyptr^.setmax) then begin { Test for low range only } with op do begin addrmode := immediate; smallval := etyptr^.setmin; end; emit2(cmpi,op,lowptr^.attr^); {CMPI min,low} new(lbltemp); lbltem repeat with ptr^ do if lowptr = hiptr then begin if RANGECHECK then begin new(checkstp); with checkstp^ do begin form := subrange; min := etyptr^.setmin; max := etyptr^.setmax; end; emitp^.next := lbl1; lbltemp^.pc := 0; lbl1 := lbltemp; getbrattr(lbl1^.pc,false,op); emit1(bge,op); {BGE lbl1} end else begin if (possible_low < etyptr^.setmin) then begin with op do begin addrcheck(expptr,checkstp,false); end; { RANGECHECK } extend(expptr,long); pushvalue(expptr); forgetbaseregs; $if bigsets$ if etyptr^.setmax > setdefaulthigh then callstdproc('ASM_XXADELEMENT') else callstdproc('ASM_XADELEMENT'); $mode := immediate; smallval := etyptr^.setmin; end; emit2(cmpi,op,lowptr^.attr^); {CMPI min,low} new(lbl2); lbl2^.next := NIL; lbl2^.pc := 0; getbrattr(lbl2^.pc,false,op); emit1(blt,op); {Bend$ $if not bigsets$ callstdproc('ASM_ADELEMENT'); $end$ end else { range with variable limit } begin if RANGECHECK then begin genexpr(hiptr); genexpr(lowptr); with hiptr^.attr^ do if packd then if (bitsize = 31)LT lbl2} end; with op do begin addrmode := immediate; smallval := etyptr^.setmax; end; emit2(cmpi,op,hiptr^.attr^); {CMPI max,hi} new(lbltemp); lbltemp^.next := lbl1; lbltemp^.pc := 0; lbl1 := lbltemp; getbrattr and not signbit then possible_hi := maxint else possible_hi := power_table[bitsize-ord(signbit)]-1 else case storage of bytte: if signbit then possible_hi := 127 else possible_hi := 255; wrd: if signbit then (lbl1^.pc,false,op); emit1(ble,op); {BLE lbl1} end; if lbl2 <> NIL then {lbl2:} fixreflist(lbl2); op.smallval := 7; emit1(trap,op); {TRAP #7} fixreflpossible_hi := 32767 else possible_hi := 65535; long: possible_hi := maxint; end; if lowptr^.attr^.signbit then possible_low := 0 else { minint is good enough since sets don't have negative elems } possible_low :=ist(lbl1); {lbl1:} end; end; { RANGECHECK } $if bigsets$ extend(lowptr,long); extend(hiptr,long); $end$ $if not bigsets$ extend(lowptr,wrd); extend(hiptr,wrd); $end$ pushvalue(lowptr); pushvalue(hip/      strparm) or (vtype = anyvarparm) or ((vtype = cvalparm) and (idtype^.form = cnfarrays)) then access := indirect else if (vtype = funcparm) then if idtype^.form >= prok then access := indirect; $IF not partt} begin with lop do begin addrmode := locinreg; offset := refbit; indexed := false; if bodylev = 1 then regnum := SB else regnum := localbase; gloptr := NIL; end; getregattr(D,rop); emit2(move,lop,rop); refexpr^.attr^.bitoffsialevaling$ $PARTIAL_EVAL OFF$ $END$ gloptr := globalptr; end; getsignbit(etyptr,attr); end; {vars} func: if ekind = cnst then begin getprokconst(symptr,attr^); if not constptr^.isdumped then et.variable := rop.regnum; end; if addrinreg(refexpr) then with reg[A,refexpr^.attr^.regnum] do begin allocstate := allocated; usesleft := usesleft+1; genrecsel(fexp,refexpr,fieldref); end else begin {record base not loaded} tr); forgetbaseregs; $if bigsets$ if etyptr^.setmax > setdefaulthigh then callstdproc('ASM_XXADDSETRANGE') else callstdproc('ASM_XADDSETRANGE'); $end$ $if not bigsets$ callstdproc('ASM_ADDSETRANGE'); $end$ end; ptr := ptr^.nextp callmode := abscall; end else begin addrmode := locinreg; regnum := getbasereg(pflev+1); offset := pfaddr; gloptr := NIL; if etyptr^.form >= prok then access := indirect; end; prox: begin getprokctr; if ptr <> NIL then begin SPminus.storage := long; emit2(move,SPind,SPminus); { MOVE.L (SP),-(SP) } end; until ptr = NIL; addrmode := loconstack; access := indirect; reloadregs; end; end; (*genset*) begin {gonst(symptr,attr^); if not constptr^.isdumped then callmode := abscall; end; otherwise escape(-8); end; litnode: with litval do if intval then begin addrmode := immediate; smallval := ival end else with valp^ do enexpr} with fexp^ do if attr = NIL then begin getattrec(fexp); with attr^ do case eclass of eqnode..andnode: {binops} begin lform := opnd2^.etyptr^.form; if lform = power then gensetop(fexp) else if lform =  if cclass <> strctconst then begin addrmode := labelledconst; valp := poolit(valp); constvalp := valp; end else {structured constant} begin addrmode := namedconst; constptr := valp; callmode := abscall; arrays then relpaofchxpr(fexp) else if eclass <= genode then relxpr(fexp) else alops(fexp) end; negnode,notnode,floatnode, absnode,chrnode,oddnode,ordnode, strlennode,strmaxnode,roundnode, sqrnode,truncnode: unaryops(fexp);  end; fcallnode: genfcall(fexp); concatnode: begin getlocstorage(256,op); new(lexp); new(lstp); with lexp^ do begin attr := addr(op); lstp^:= strgptr^; lstp^.unpacksize := 256; etyptr := l idnode: with symptr^ do case klass of vars,routineparm: begin if (vtype < localvar) then begin case vtype of shortvar: addrmode := shortabs; longvar: addrmode := longabs; relvar: addrmode := prelstp; symptr := NIL; { Added 04NOV92 - CFB } end; genconcat(lexp,fexp); liftattr(fexp,lexp); end; substrnode: with fexp^ do begin genexpr(arayp); liftattr(fexp,arayp); genex; end; gloptr := NIL; attr^.absaddr := {symptr^.}absaddr; end else begin offset := vaddr; addrmode := locinreg; regnum := getbasereg(vlev); $PARTIAL_EVAL$ if (vtype = refparm) or (vtype =pr(indxp); if lengthp <> NIL then genexpr(lengthp); end; subscrnode: gensubscr(fexp); selnnode: genrecsel(fexp,recptr,fieldptr); unqualfldnode: with withstptr^ do begin if refbit <> 0 then {load variable bit offse0      oldattr := refexpr^.attr^; if oldattr.access = indirect then loadaddress(refexpr,false); genrecsel(fexp,refexpr,fieldref); if addrinreg(refexpr) then with reg[A,refexpr^.attr^.regnum] do begin usage := withrecbase; allocstate := ,opnd^.attr^) else emit2(subq,op,opnd^.attr^); ovflck; if RANGECHECK then emitcheck(opnd,opnd^.etyptr,false); liftattr(fexp,opnd); storage := opnd^.attr^.storage; end; otherwise escape(-8); end; {case eclasallocated; usesleft := 1; curcontents := refexpr^.attr; oldcontents := oldattr; end; end; end; bufnode: begin rop.addrmode := immediate; rop.smallval := 4; SPdir.storage := long; emit2(subq,rop,SPdir); {SUBQs} end; {if attr = NIL} end; {genexpr} .L #4,SP} pushaddress(opnd); saveregs; forgetbaseregs; callIOproc('FS_FBUFFERREF'); reloadregs; addrmode := loconstack; loadaddress(fexp,false); getsignbit(etyptr,attr); end; derfnode: begin genexpr(opnd);  { file GENMOVE } import assemble,genexprmod,symtable,genutils,float_hdw; implement {moveit} var { used by needscheck, emitcheck } targetlo,targethi: integer; procedure maskboolexpr(*fexp: exptr*); var op: attrtype;  with opnd^.attr^ do begin if access = indirect then loadaddress(opnd,false); if addrmode = inDreg then extend(opnd,long); end; liftattr(fexp,opnd); getsignbit(etyptr,attr); access := indirect; if range begin with fexp^ do if etyptr = boolptr then if ((ekind = xpr) and (attr^.addrmode <> topofstack) and (not attr^.packd)) then with op do begin storage := bytte; addrmode := immediate; smallval := 1; emit2(andi,op,attcheck and (addrmode <> immediate) then begin {check for NIL pointer} if addrmode <> inDreg then begin loadaddress(fexp,false); getregattr(D,rop); lop.addrmode := inAreg; lop.regnum := regnum; emit2(move,lop,rop); { MOVE.r^); end; end; function needscheck (fexp: exptr; target: stp; assignstmt: boolean):boolean; var sourcelo,sourcehi: integer; source: stp; sourceattr: attrptr; begin needscheck := false; if (target^.L Aregnum,Dr } freeit(D,rop.regnum); end; with rop do begin offset:=2; storage := bytte end; emit1(bne,rop); { BNE.S *+4 (assumes nilvalue = 0) } rop.smallval:=8; emit1(trap,rop); { TRAP #8 } end; form <= subrange) and (target <> intptr) and (fexp^.eclass <> litnode) then begin genexpr(fexp); { get attribute record } source := fexp^.etyptr; sourceattr := fexp^.attr; getbounds(target,targetlo,targethi); withend; {derfnode} setdenonode: begin addrmode := labelledconst; setcstpart.valp := poolit(setcstpart.valp); constptr := setcstpart.valp; if ekind <> cnst then genset(fexp); end; succnode,prednode: begin genexpr(o sourceattr^ do begin if packd then begin if (bitsize = 31) and not signbit then sourcehi := maxint else sourcehi := power_table[bitsize-ord(signbit)]-1; end else { not packed } case storage of bytte: if signbit then pnd); if not opnd^.attr^.signbit then extend(opnd,succ(opnd^.attr^.storage)); loadvalue(opnd); with op do begin addrmode := immediate; smallval := 1; end; if eclass = succnode then emit2(addq,opsourcehi := 127 else sourcehi := 255; wrd: if signbit then sourcehi := 32767 else sourcehi := 65535; long: sourcehi := maxint; end; if signbit then sourcelo := -sourcehi-1 else sourcelo := 0; end; if ((fexp^.eclass 0      := attr^.regnum else begin { use scratch register for check} r.regnum := getreg(D); emit2(move,attr^,r); with op do begin addrmode := immediate; smallval := targetlo end; emit2(sub,op,r); end; {targetlo <> 0} wit with op do begin offset := 2; storage := bytte end; emit1(ble,op); { BLE *+4 } op.smallval := 7; emit1(trap,op); { TRAP #7 } $END$ end; {recover} end; {emitcheck} PROCEDURE BITADDRESS{FEXP: EXPTR}; h op do begin addrmode := immediate; smallval := targethi-targetlo end; emit2(chk,op,r); if targetlo <> 0 then freeit(D,r.regnum); $END$ end; {with} RECOVER begin if (escapecode <> 0) and (escapecode <> -4) then escape(esca VAR op1,op2,op3: attrtype; BEGIN { BITADDRESS } WITH FEXP^.ATTR^ DO BEGIN OFFSET := OFFSET + mydiv(BITOFFSET.STATIC,16) * 2; BITOFFSET.STATIC := (BITOFFSET.STATIC mod 16); IF BITOFFSET.VARIABLE <> -1 THEN BEGIN op2.addrmode := inDr= succnode) or (fexp^.eclass = prednode)) and (fexp^.etyptr = target) and assignstmt then needscheck := false else if (sourcelo < targetlo) or (sourcehi > targethi) then needscheck := true; end; end; {needscheck} procpecode); $IF MC68020$ with fexp^,attr^ do begin r.addrmode := inDreg; r.storage := long; r.regnum := attr^.regnum; extend(fexp,long); end; if targetlo = 0 then {use chk} begin with op do begin addrmode := immediate; smallvaedure emitcheck(fexp: exptr; target: stp; assignstmt: boolean); var r, op: attrtype; branchoffset: shortint; begin if needscheck(fexp,target,assignstmt) then TRY maskboolexpr(fexp); loadvalue(fexp); $IF MC68020$ if l := targethi; end; emit2(chk,op,r); end else begin with op do begin addrmode := labelledconst; offset := 0; new(constvalp); with constvalp^ do begin cclass := chk2_bounds; lower := targetlo; (targethi > 32767) or (targetlo < -32768) then escape(0); $END$ $ovflcheck on$ $IF not MC68020$ if (targethi - targetlo) < 0 then escape(0); { overflow check } if (targethi - targetlo) > 32767 then escape(0); $END$ $if not ovflchecking$ $ovflche upper := targethi; size := long; end; constvalp := poolit(constvalp); end; emit2(chk2,op,r); end; $END$ $IF not MC68020$ ensure_valid_condition_code := true; if (targetlo<-32768) or (targethi>32767) or (fexp^.attr^ck off$ $end$ with fexp^,attr^ do begin r.addrmode := inDreg; r.storage := wrd; if storage = long then escape(0); if storage = bytte then extend(fexp,wrd); $IF MC68020$ r.regnum := attr^.regnum; if targetlo = 0 then {use chk} .storage = long) or not (fexp^.attr^.signbit) then begin extend(fexp,long); branchoffset := 8; end else begin extend(fexp,wrd); branchoffset := 6; end; ensure_valid_condition_code := false; if targetlo <> 0 then with op d begin with op do begin addrmode := immediate; smallval := targethi; end; emit2(chk,op,r); end else begin with op do begin addrmode := labelledconst; offset := 0; new(constvalp); with co begin addrmode := immediate; smallval := targetlo; emit2(cmpi,op,fexp^.attr^); { CMPI targetlo,source } end else { if condition code not valid emit TST } if fexp^.eclass in [succnode,prednode] then emit1(tst,fexp^.attr^onstvalp^ do begin cclass := chk2_bounds; lower := targetlo; upper := targethi; size := wrd; end; constvalp := poolit(constvalp); end; emit2(chk2,op,r); end; $END$ $IF not MC68020$ if targetlo = 0 then r.regnum); with op do begin offset := branchoffset; storage := bytte; end; emit1(blt,op); { BLT *+10 } with op do begin addrmode := immediate; smallval := targethi end; emit2(cmpi,op,fexp^.attr^); { CMPI targethi,source } 1     eg; op2.regnum := bitoffset.variable; op2.storage := bitoffset.storage; IF BITOFFSET.STATIC <> 0 THEN BEGIN { ADD CONSTANT BITOFFSET TO VARIABLE BITOFFSET } op1.addrmode := immediate; op1.smallval := bitoffset.static; emit2(add,opdexscale := 0; $END$ END; END; { IF BITOFFSET.VARIABLE } END; { WITH } END; { BITADDRESS } PROCEDURE UNPACK ( FEXP : EXPTR ); VAR op1,op2: attrtype; SHIFTEMP : REGRANGE; BEGIN WITH FEXP^.ATTR^ DO BEGIN IF BITOF1,op2); { ADD #static,variable } bitoffset.static := 0; END; { EXTRACT WORD COMPONENT OF BITOFFSET.VARIABLE } op1.addrmode := inDreg; op1.regnum := getreg(D); op1.storage := bitoffset.storage; emit2(move,op2,op1); FSET.VARIABLE = -1 THEN BEGIN { CONSTANT BITOFFSET } if bitsize = 1 then begin if bitoffset.static >= 8 then begin offset := offset + 1; bitoffset.static := bitoffset.static - 8; checkoffset(fexp); end; op1.addrmode { MOVE variable,temp } with op3 do begin addrmode := immediate; smallval := 4; end; emit2(asr,op3,op1); { LSR #4,temp } op3.smallval := 1; emit2(lsl,op3,op1); { LSL #1,temp } op3.smallval := 15; $ := immediate; op1.smallval := 7-bitoffset.static; emit2(btst,op1,fexp^.attr^); { BTST 7-static,oprnd } freeregs(fexp^.attr); with op2 do begin addrmode := inDreg; regnum := getreg(D); storage := bytte; end; emitIF MC68020$ op2.storage := long; { bit field instructions need long value } $END$ emit2(andi,op3,op2); { AND #15,variable } IF INDEXED THEN BEGIN $IF MC68020$ {account for scale factor} if indexscale <> 0 then 1(sne,op2); { SNE temp } emit1(neg,op2); { NEG.B temp } storage := bytte; end else IF (BITSIZE = 8) AND (BITOFFSET.STATIC IN [0,8]) and ((not force_unpack) or signbit) THEN BEGIN  begin op3.regnum := indexreg; op3.storage := long; if indexstorage <> long then begin emit1(ext,op3); indexstorage := long; end; op2.addrmode := immediate; op2.smallval := indexscale; emit2(lsl,op2,o IF BITOFFSET.STATIC = 8 THEN OFFSET := OFFSET + 1; packd := false; STORAGE := BYTTE; checkoffset(fexp); end ELSE IF (BITSIZE = 16) AND (BITOFFSET.STATIC = 0) and ((not force_unpack) or signbit) THEN BEGIN p3); indexscale := 0; end; $END$ if indexstorage < bitoffset.storage then begin op3.regnum := indexreg; op3.storage := long; emit1(ext,op3); { EXT.L Dindexreg } indexstorage := long; e packd := false; STORAGE := WRD; end ELSE BEGIN with op2 do begin addrmode := inDreg; regnum := getreg(D); end; $IF MC68020$ if signbit then emit2(bfexts,fexp^.attr^,op2) else begin { mnd else if bitoffset.storage < indexstorage then begin op1.storage := long; emit1(ext,op1); { EXT.L temp } bitoffset.storage := long; end; op3.addrmode := inDreg; op3.regnum := indexreg; op3.stake sure status register bit N is cleared } emit2(bfextu,fexp^.attr^,op2); op2.storage := long; with op1 do begin addrmode := immediate; if fexp^.attr^.bitsize = 31 then smallval := maxint else smallval := power_table[fexporage := indexstorage; emit2(add,op1,op3); { ADD temp,indexreg } FREEIT(D,op1.regnum); END ELSE BEGIN INDEXED := TRUE; INDEXREG := op1.regnum; indexstorage := bitoffset.storage; $IF MC68020$ in^.attr^.bitsize] - 1; end; emit2(andi,op1,op2); end; freeregs(fexp^.attr); storage := long; signbit := true; $END$ $IF not MC68020$ if ((bitoffset.static MOD 8)+bitsize <= 8) and (not signbit) then begin1     ^.attr); FREEIT(D,BITOFFSET.VARIABLE); storage := long; signbit := true; $END$ $IF not MC68020$ emit2(move,fexp^.attr^,op2); { MOVE.L fexp,temp } freeregs(fexp^.attr); op1.addrmode := inDreg; op1.regnum :; emit1(ext,op2); end; emit2(add,op2,op1); freeit(D,op2.regnum); end else begin indexed := true; indexreg := op2.regnum; indexstorage := bitoffset.storage; $IF MC68020$ indexscale := 0; = bitoffset.variable; emit2(lsl,op1,op2); FREEIT(D,BITOFFSET.VARIABLE); if signbit then emitshift(32-bitsize,op2.regnum,asr,long) else emitshift(32-bitsize,op2.regnum,lsr,long); signbit := true; STORAGE := LONG; $END$ $END$ end; end; packd := false; end; { if packd } if addrmode = inFreg then pushrealaddress(fexp) else if (addrmode in memorymodes) or (access = indirect) and (addrmode <> loconstack) then begin checkoffset(fexp); if acce offset := offset + (bitoffset.static DIV 8); bitoffset.static := (bitoffset.static MOD 8) + 24; op2.storage := bytte; end else if ((bitoffset.static+bitsize) <= 16) and (not signbit) then begin bitoffset.static := bitoffset.static + 16; END; { VARIABLE BITOFFSET } if packd then begin ADDRMODE := inDreg; REGNUM := op2.regnum; ACCESS := DIRECT; INDEXED := FALSE; OFFSET := 0; PACKD := FALSE; end; END; { WITH } END; { UNPACK } procedu op2.storage := wrd; end else op2.storage := long; emit2(move,fexp^.attr^,op2); { MOVE fexp,temp } freeregs(fexp^.attr); if signbit then begin { unpack using left shift, right shift } emitshift(bitoffset.statire pushaddress(*fexp: exptr*); var op1,op2: attrtype; begin genexpr(fexp); with fexp^,attr^ do begin if packd then begin { handle field of a packed structure } offset := offset + mydiv(bitoffset.static,8); if bitoffset.variablc,op2.regnum,lsl,long); emitshift(32-bitsize,op2.regnum,asr,long); end else begin { unpack with a right shift, AND } emitshift(32-(bitoffset.static+bitsize),op2.regnum,lsr,long); getcomplmaskattr(0,32-bitsize,32,op1); op2.storage := longe <> -1 then begin { extract byte component of bitoffset.variable } with op1 do begin addrmode := immediate; smallval := 3; end; with op2 do begin addrmode := inDreg; regnum := attr^.bitoffset.variable; sto; emit2(andi,op1,op2); { AND.L mask,temp } signbit := true; end; STORAGE := LONG; $END$ END; END { CONSTANT BITOFFSET } ELSE { VARIABLE BITOFFSET } BEGIN with op2 do begin addrmodrage := attr^.bitoffset.storage; end; emit2(lsr,op1,op2); if indexed then begin with op1 do begin addrmode := inDreg; regnum := attr^.indexreg; storage := attr^.indexstorage; $IF MC68020$ if indexscale <> 0 then e := inDreg; regnum := getreg(D); storage := long; end; $IF MC68020$ if signbit then emit2(bfexts,fexp^.attr^,op2) else begin { make sure status register bit N is cleared } emit2(bfextu,fexp^.attr^,op2); o begin if storage = wrd then begin storage := long; emit1(ext,op1); end; if indexscale = 1 then emit2(add,op1,op1) else emitshift(indexscale,regnum,asl,long); if indexstorage = long then ovflck elsep2.storage := long; with op1 do begin addrmode := immediate; if fexp^.attr^.bitsize = 31 then smallval := maxint else smallval := power_table[fexp^.attr^.bitsize] - 1; end; emit2(andi,op1,op2); end; freeregs(fexp indexstorage := long; end; $END$ end; if indexstorage < bitoffset.storage then begin op1.storage := long; emit1(ext,op1); indexstorage := long; end else if bitoffset.storage < indexstorage then begin op2.storage := long2     ss = direct then emit1(pea,attr^) else begin SPminus.storage := long; emit2(move,attr^,SPminus); end; freeregs(attr); end else if (addrmode = topofstack) and (etyptr = realptr) then begin { real VALUE is on stack } OVE.L #d, - indirect MOVE.L d, indexed - direct LEA d,Ar LEA 0(Ar,Dx),As MOVE.L As, - indirect LEA d,Ar MOVE.L 0(Ar,Dx), } label 1; var op: getlocstorage(8,op1); op1.storage := long; emit2(move,attr^,op1); op1.offset := op1.offset + 4; emit2(move,attr^,op1); op1.offset := op1.offset - 4; emit1(pea,op1); freeregs(attr); end else if addrmode <> loconst attrtype; begin dest.storage := long; genexpr(fexp); with fexp^, attr^ do 1: if addrmode = locinreg then if access = direct then begin loadaddress(fexp,false); op.addrmode := inAreg; op.regnum := regnum; emitack then escape(-8); end; {with} end; {pushaddress} procedure loadaddress(fexp: exptr; fromcheckoffset: boolean); var op: attrtype; storagetemp: stortype; begin genexpr(fexp); with fexp^, attr^ do begin if addrm2(move,op,dest); freeit(A,regnum); end else begin checkoffset(fexp); emit2(move,attr^,dest); freeregs(fexp^.attr); end else if addrmode = inDreg then begin emit2(move,attr^,dest); freeit(D,regnum) end else if addrmode ode = loconstack then begin getregattr(A,op); emit2(movea,SPplus,op); end else if (addrmode in memorymodes) or (access = indirect) then if addrinreg(fexp) then op.regnum := regnum {i.e.,do nothing} else begin = immediate then emit2(move,attr^,dest) else {absolute,namedconst} if ((access = direct) and (indexed or (addrmode = prel) or (addrmode = namedconst) and (callmode = relcall))) or (addrmode = labelledconst) then begin loadaddress(fe if not fromcheckoffset then checkoffset(fexp); freeregs(attr); getregattr(A,op); { Emit2 overwrites source storage } $range off$ storagetemp := storage; if access = direct then emit2(lea,attr^,op) exp,false); goto 1 {treat as locinreg} end else begin if access = indirect then begin checkoffset(fexp); {load base reg} emit2(move,attr^,dest); freeregs(attr); end else {not indexed, access = direct} lse emit2(movea,attr^,op); storage := storagetemp; $if rangechecking$ $range on$ $end$ end else begin escape(-8); op.regnum := 0; end; addrmode := locinreg; regnum := op.regnum; access := direct; i emit2(moveI,attr^,dest); end; end; {moveaddress} procedure movevalue{fexp: exptr; var at: attrtype}; { generate MOVE ; fexp points to source expression, caller must provide destination in "at" } begin makeaddressndexed := false; offset := 0; gloptr := NIL; end; {with} end; {loadaddress} procedure moveaddress(* fexp: exptr; var dest: attrtype *); { Generate 'MOVE.L' ,. Code produced for various source modes: locinreg nable(fexp); with fexp^ do if attr^.addrmode = inFreg then moverealvalue(fexp,at) else begin if (attr^.addrmode = topofstack) and (etyptr = realptr) then begin { real VALUE is on stack } at.storage := long; emitot indexed - direct LEA d(Ar),As MOVE.L As, - indirect MOVE.L d(Ar), indexed - direct LEA d(Ar,Dx),As MOVE.L As, - indirect MOVE.L d(Ar,Dx), absolute not indexed - direct M2(move,attr^,at); at.offset := at.offset + 4; emit2(move,attr^,at); at.offset := at.offset - 4; at.storage := multi; end else emit2(move,attr^,at); freeregs(attr); end; end; {movevalue} pr2     op,regtemp,reg2 : attrtype; begin with fcond^ do if opnd1^.etyptr^.unpacksize = 0 then case eclass of eqnode, lenode, genode : {do nothing} flbl := NIL; nenode, ltnode, gtnode : begin getbrattr(flbl^.pc,definepnd1^.etyptr^.unpacksize; emit2(move,op,regtemp); { MOVE(Q/.L) #unpacksize,Dregtemp} end; loop := codephile.bytecount; opnd2^.attr^.addrmode := postincr; with opnd1^.attr^ do begin addrmode := postincr; storage := bytte d,op); emit1(bra,op); end; end { case } else begin loadaddress(opnd1,false); loadaddress(opnd2,false); getregattr(D,regtemp); if opnd1^.etyptr^.aisstrng then begin if (eclass <> eqnode) and (eclass <> nenode) thenend; emit2(cmpm,opnd2^.attr^,opnd1^.attr^);{loop CMPM.B (Aopnd2)+,(Aopnd1)+} tlbl.next := NIL; if eclass = eqnode then getbrattr(flbl^.pc,defined,op) else getbrattr(tlbl.pc,false,op); emit1(bne,op); { BNE flbl/tlbocedure pushvalue(*fexp: exptr*); var i : shortint; begin makeaddressable(fexp); with fexp^, attr^ do if addrmode = inFreg then pushrealvalue(fexp) else begin if addrmode <> topofstack then begin if etyptr^.unpac begin getregattr(D,reg2); emit2(moveq,immed0,reg2); { MOVEQ #0,Dregtemp } reg2.storage := bytte; opnd1^.attr^.addrmode := postincr; emit2(move,opnd1^.attr^,reg2); { MOVE.B (Aopnd1)+,Dregtemp } ksize = 8 then { reals and prok vars } begin SPminus.storage := long; offset := offset + 4; for i := 0 to 1 do begin offset := offset - (i*4); checkoffset(fexp); emit2(move,attr^,SPminus); end; end else if etyptr^.unpacks regtemp.storage := wrd; emit2(move,reg2,regtemp); emit1(swap,regtemp); emit2(move,reg2,regtemp); regtemp.storage := bytte; opnd2^.attr^.addrmode := postincr; emit2(move,opnd2^.attr^,reg2); emit2(cmp,reg2ize <> 0 then begin SPminus.storage := storage; if (addrmode = immediate) and (smallval = 0) then emit1(clr,SPminus) else emit2(move,attr^,SPminus); end; freeregs(attr); addrmode := topofstack; end; end; { with } ,regtemp); { CMP.B Dreg2,Dregtemp } lbl3.next := NIL; getbrattr(lbl3.pc,false,op); emit1(bls,op); { BLS lbl3 } with opnd2^.attr^ do begin addrmode := locinreg; offset := -1; gloptr := NIL; e end; procedure loadvalue(*fexp: exptr*); { fetch value to D register, update value and machine images } var op: attrtype; begin makeaddressable(fexp); with fexp^, attr^ do if etyptr^.form = reals then loadrealvalue(fexp) elsnd; emit2(move,reg2,regtemp); fixreflist(addr(lbl3)); emit1(tst,regtemp); { lbl3 TST.B Dregtemp } lbl4.next := NIL; getbrattr(lbl4.pc,false,op); emit1(beq,op); { BEQ lbl4 e if addrmode <> inDreg then begin freeregs(attr); getregattr(D,op); op.storage := storage; emit2(move,attr^,op); addrmode := inDreg; regnum := op.regnum; indexed := false; end; end;} end else { = , <> } begin emit2(moveq,immed0,regtemp); { MOVEQ #0,Dregtemp } regtemp.storage := bytte; emit2(move,opnd1^.attr^,regtemp); { MOVE.B (Aopnd1),Dregtemp } op.addrmode := immediate {loadvalue} procedure genpaofchcond(fcond: exptr; var flbl: reflistptr; defined: boolean); { generate code for a packed array of char comparison, emitting a false jump to flbl} var loop : addrrange; tlbl,lbl3,lbl4 : localref; ; op.smallval := 1; regtemp.storage := wrd; emit2(addq,op,regtemp); { ADDQ #1,Dregtemp } end; end else {compare pa of char} begin regtemp.storage := long; op.addrmode := immediate; op.smallval := o3     l } op.addrmode := immediate; op.smallval := 1; emit2(subq,op,regtemp); { SUBQ #1,Dregtemp } getbrattr(loop,true,op); emit1(bne,op); { BNE loop } if eclass = nenode then begin getbrattr(flbc,defined,op); emit1(beq,op); { BEQ flbl } end else if lform = arrays then genpaofchcond(fcond,flbl,defined) else begin relCMP(fcond,destonleft,signed); getbrattr(flbl^.pc,defined,op); if destonleft then case ecl^.pc,defined,op); emit1(bra,op); { BRA flbl } end else if opnd1^.etyptr^.aisstrng then if eclass <> eqnode then begin fixreflist(addr(lbl4)); { lbl4 EQU * } emit1(swap,reglass of eqnode: emit1(bne,op); nenode: emit1(beq,op); ltnode: if signed then emit1(bge,op) else emit1(bcc,op); lenode: if signed then emit1(bgt,op) else emit1(bhi,op); gtnode: if signed then emitemp); regtemp.storage := bytte; emit2(cmp,reg2,regtemp); freeit(D,reg2.regnum); end; if eclass <> eqnode then fixreflist(addr(tlbl)); { tlbl EQU * } if (eclass <> eqnode) and (eclass <> nenode) tt1(ble,op) else emit1(bls,op); genode: if signed then emit1(blt,op) else emit1(bcs,op); end else case eclass of eqnode: emit1(bne,op); nenode: emit1(beq,op); ltnode: if signed then emit1(ble,op) else emithen getbrattr(flbl^.pc,defined,op); case eclass of eqnode,nenode: ; ltnode: emit1(bcc,op); { BCC flbl } lenode: emit1(bhi,op); { BHI flbl } gtnode: emit1(bls,op); { BLS flbl 1(bls,op); lenode: if signed then emit1(blt,op) else emit1(bcs,op); gtnode: if signed then emit1(bge,op) else emit1(bcc,op); genode: if signed then emit1(bgt,op) else emit1(bhi,op); end; end; end; } genode: emit1(bcs,op); { BCS flbl } end; freeit(A,opnd1^.attr^.regnum); freeit(A,opnd2^.attr^.regnum); forgetbasereg(opnd1^.attr^.regnum); forgetbasereg(opnd2^.attr^.regnum); freeit(D,regtemp.regnum); end;  andnode, ornode: if shortcircuit then begin truelist := NIL; if not defined then flbl := NIL; if eclass = andnode then genshortand(fcond,truelist,flbl,true,defined,false,NIL) else { eclass = ornode } begin genshortor(fc end; { genpaofchcond } procedure gencond(*fcond: exptr; var flbl: reflistptr; defined: boolean*); { generate code for a condition, emitting a false jump to lbl; if defined = true, the jump is backward; otherwise, fixup info is returned in ond,truelist,flbl,true,defined,false,NIL); if not defined then begin new(bptr); bptr^.next := flbl; flbl := bptr; end; getbrattr(flbl^.pc,defined,op); emit1(bra,op); end; fixreflist(truelist); forgetbaseregflbl } var lform: structform; destonleft,signed: boolean; op: attrtype; bptr,truelist: reflistptr; begin {gencond} if not defined then begin new(flbl); flbl^.next := NIL; end; with fcond^ do case eclass of eqnode..sups; end else begin genexpr(fcond); freeit(D,attr^.regnum); getbrattr(flbl^.pc,defined,op); emit1(beq,op); { BEQ flbl } end; notnode: begin genexpr(opnd); if (opnd^.attr^.addrmode <> inDreg) or ersetnode: begin lform := opnd2^.etyptr^.form; if (lform=power) or (lform = reals) then begin {call runtime support function, test returned byte} genexpr(fcond); emit1(tst,fcond^.attr^); { TST.size attr } getbrattr(flbl^.p (shortcircuit) then {cc not valid} begin makeaddressable(opnd); $IF MC68020$ emit1(tst,opnd^.attr^); { TST.size attr } $END$ $IF not MC68020$ if opnd^.attr^.addrmode = namedconst then begin op.addrmode := immediate; 3     lbl^.pc := -1; { no Bcc emitted } end; {case} end; {gencond} PROCEDURE PACK (LHS, RHS : EXPTR); VAR op1,op2,op3: attrtype; lstorage : stortype; xfersize : stortype; BEGIN { PACK } WITH LHS^, ATTR^ DO BEGIN ; end else if rhs^.attr^.storage = wrd then if bitsize >= 17 then extend(rhs,long); emit2(bfins,rhs^.attr^,lhs^.attr^); freeit(D,rhs^.attr^.regnum); freeregs(lhs^.attr); end; $END$ $IF not MC68020$ BE MAKEADDRESSABLE(RHS); if bitsize <= 8 then lstorage := bytte else if bitsize <= 16 then lstorage := wrd else lstorage := long; if rhs^.attr^.storage < lstorage then extend(rhs,lstorage); BITADDRESS(LHS); IF ACCESS = INDIRECT THEN LOADADDRESS(LHS,GIN if (bitsize = 1) then begin maskboolexpr(rhs); if bitoffset.static >= 8 then begin offset := offset + 1; bitoffset.static := bitoffset.static - 8; end; op1.addrmode := immediate; op1.smallval := 7-bitoffset.stat op.smallval := 0; emit2(cmpi,op,opnd^.attr^); end else emit1(tst,opnd^.attr^); $END$ end; freeregs(opnd^.attr); getbrattr(flbl^.pc,defined,op); emit1(bne,op); { BNE flbl } end; oddnodfalse) ELSE checkoffset(lhs); IF BITOFFSET.VARIABLE = -1 THEN { CONSTANT BITOFFSET } begin if (bitsize = 1) and (rhs^.eclass = litnode) then begin if bitoffset.static >= 8 then begin offset := offset + 1; bitoffset.ste: begin makeaddressable(opnd); with opnd^.attr^ do if not (addrmode in memorymodes) then loadvalue(opnd) else begin case storage of bytte: {ok}; wrd: offset := offset + 1; long: offset := offset + 3; atic := bitoffset.static - 8; end; op1.addrmode := immediate; op1.smallval := 7-bitoffset.static; if rhs^.litval.ival = 0 then emit2(bclr,op1,lhs^.attr^) else emit2(bset,op1,lhs^.attr^); freeregs(attr); end else IF (BI end; { case } checkoffset(opnd); end; emit2(btst,immed0,opnd^.attr^); { BTST #0,attr } freeregs(opnd^.attr); getbrattr(flbl^.pc,defined,op); emit1(beq,op); { BEQ flbl } end; { oddnodTSIZE = 8) AND (BITOFFSET.STATIC IN [0,8]) THEN BEGIN if rhs^.attr^.addrmode = topofstack then loadvalue(rhs); IF BITOFFSET.STATIC = 8 THEN OFFSET := OFFSET + 1; with rhs^.attr^ do case storage of bytte: {ok}; wrd: offset := e } idnode, succnode, { Added 9/5/89 JWH } fcallnode, derfnode, subscrnode, selnnode, unqualfldnode: begin makeaddressable(fcond); $IF MC68020$ emit1(tst,attr^); { TST.size attr } offset+1; long: offset := offset+3; end; storage := bytte; emit2(move,rhs^.attr^,{lhs}attr^); FREEREGS(RHS^.ATTR); FREEREGS({LHS}ATTR); END ELSE IF (BITSIZE = 16) AND (BITOFFSET.STATIC = 0) THEN BEGIN if rhs^. $END$ $IF not MC68020$ if attr^.addrmode = namedconst then begin op.addrmode := immediate; op.smallval := 0; emit2(cmpi,op,attr^); end else emit1(tst,attr^); $END$ freeregs(attr); getbrattr(flbl^.pc,definattr^.addrmode = topofstack then loadvalue(rhs); with rhs^.attr^ do case storage of bytte: extend(rhs,wrd); wrd: {ok}; long: offset := offset+2; end; {lhs^.attr^}storage := wrd; emit2(move,rhs^.attr^,{lhs^}attr^); FREEREGed,op); emit1(beq,op); { BEQ flbl } end; litnode: if fcond^.litval.ival = 0 then begin getbrattr(flbl^.pc,defined,op); emit1(bra,op); { BRA flbl } end else if not defined then fS(RHS^.ATTR); FREEREGS({LHS^}ATTR); END ELSE $IF MC68020$ begin loadvalue(rhs); if rhs^.attr^.storage = bytte then begin if bitsize >= 17 then extend(rhs,long) else if bitsize >= 9 then extend(rhs,wrd)4     ic; emit2(bclr,op1,lhs^.attr^); offset := offset + (bitoffset.static DIV 8); bitoffset.static := (bitoffset.static MOD 8) + 24; xfersize := bytte; end else if (bitoffset.static MOD 8) + bitsize <= 8 then begine = bytte then begin if bitsize >= 17 then extend(rhs,long) else if bitsize >= 9 then extend(rhs,wrd); end else if rhs^.attr^.storage = wrd then if bitsize >= 17 then extend(rhs,long); emit2(bfins,rhs^.attr^,lhs^.attr^); f offset := offset + (bitoffset.static DIV 8); bitoffset.static := (bitoffset.static MOD 8) + 24; getcomplmaskattr(bitoffset.static-24,bitsize,8,op2); {lhs^.attr^}storage := bytte; emit2(andi,op2,{lhs^}attr^); xfersreeit(D,rhs^.attr^.regnum); freeregs(lhs^.attr); freeit(D,bitoffset.variable); end; $END$ $IF not MC68020$ begin maskboolexpr(rhs); with op2 do begin addrmode := inDreg; regnum := getreg(D); storage := long; end; getize := bytte; end else if (bitoffset.static + bitsize) <= 16 then begin bitoffset.static := bitoffset.static + 16; getcomplmaskattr(bitoffset.static-16,bitsize,16,op2); {lhs^.attr^}storage := wrd; emit2(andi,ocomplmaskattr(0,(32-bitsize),32,op1); emit2(move,op1,op2); { MOVE.L mask,temp } op1.addrmode := inDreg; op1.regnum := bitoffset.variable; op1.storage := bytte; emit1(neg,op1); op3.addrmode := immediate; op3.smallval := 32-bip2,{lhs^}attr^); xfersize := wrd; end else begin getcomplmaskattr(bitoffset.static,bitsize,32,op2); {lhs^.attr^}storage := long; emit2(andi,op2,{lhs^}attr^); xfersize := long; end; loadvaluetsize; emit2(add,op3,op1); emit2(lsl,op1,op2); { locate mast temp } IF SIGNBIT THEN BEGIN with op3 do begin addrmode := inDreg; regnum := getreg(D); storage := long; end; emit2(move,op2,op3); (rhs); extend(rhs,xfersize); emitshift(32-(bitsize+bitoffset.static),rhs^.attr^.regnum, lsl,long); IF SIGNBIT and (bitoffset.static <> 0) THEN BEGIN {strip off extra sign bits} case xfersize of bytte: begin rh END; emit1(nott,op2); { complement mask } lhs^.attr^.storage := long; emit2(andd,op2,lhs^.attr^); { AND.L mask,destination } freeit(D,op2.regnum); loadvalue(rhs); extend(rhs,long); rhs^.attr^.storage := lons^.attr^.storage := bytte; getcomplmaskattr(0,bitoffset.static-24,8,op2); end; wrd: begin rhs^.attr^.storage := wrd; getcomplmaskattr(0,bitoffset.static-16,16,op2); end; long: begin rhs^.attr^.storage := g; emit2(lsl,op1,rhs^.attr^); { position source in reg } FREEIT(D,BITOFFSET.VARIABLE); IF SIGNBIT THEN BEGIN emit2(andd,op3,rhs^.attr^); { mask off extra sign bits } FREEIT(D,op3.regnum); END; emit2(orr,rhslong; getcomplmaskattr(0,bitoffset.static,32,op2); end; end; { case } emit2(andi,op2,rhs^.attr^); END; case xfersize of bytte: storage := bytte; wrd: storage := wrd; long: storage := long; ^.attr^,lhs^.attr^); FREEIT(D,rhs^.attr^.regnum); FREEREGS(LHS^.ATTR); END; { VARIABLE BITOFFSET } $END$ END; { WITH } END; { PACK } procedure packtopack(*lhs,rhs: exptr*); var shiftcount,masksize,maskoffset,shiftsize: short end; emit2(orr,rhs^.attr^,{lhs^}attr^); FREEIT(D,rhs^.attr^.regnum); FREEREGS(LHS^.ATTR); END; $END$ END { CONSTANT BITOFFSET } ELSE { VARIABLE BITOFFSET } $IF MC68020$ begin loadvalue(rhs); if rhs^.attr^.storagint; xfersize,shiftopsize: stortype; signextend: boolean; op1,op2: attrtype; begin $IF MC68020$ pack(lhs,rhs); $END$ $IF not MC68020$ if (lhs^.attr^.bitoffset.variable <> -1) or (rhs^.attr^.bitoffset.variable <> -1) then pack(lhs,rhs) e4     fset.static + 16; op1.storage := wrd; end else op1.storage := long; emit2(move,{rhs^}attr^,op1); { MOVE rhs,reg } freeregs({rhs^}attr); end; { with rhs^} {clear lhs destination field} {lhs^.attr^}storage :=ssary } if bitsize > rhs^.attr^.bitsize then begin masksize := rhs^.attr^.bitsize; maskoffset := rhs^.attr^.bitoffset.static - shiftcount; end else if bitsize < rhs^.attr^.bitsize then begin masksize := b xfersize; case xfersize of bytte: if bitsize <> 8 then begin getcomplmaskattr(bitoffset.static-24,bitsize,8,op2); emit2(andi,op2,{lhs^}attr^); { ANDI mask,lhs } end; wrd: if bitsize <> 16 then begin getcomplmaskattitsize; maskoffset := bitoffset.static; end else if (bitsize = 8) and (xfersize = bytte) then masksize := 0 else if (bitsize = 16) and (xfersize = wrd) then masksize := 0 else begin masksize := bitsize; maskoffsetlse with lhs^, attr^ do begin bitaddress(lhs); if (bitsize = 8) and (bitoffset.static in [0,8]) then pack(lhs,rhs) else if (bitsize = 16) and (bitoffset.static = 16) then pack(lhs,rhs) else begin { this is a pack to pack special case } if r(bitoffset.static-16,bitsize,16,op2); emit2(andi,op2,{lhs^}attr^); { ANDI mask,lhs } end; long: begin getcomplmaskattr(bitoffset.static,bitsize,32,op2); emit2(andi,op2,{lhs^}attr^); { ANDI mask,lhs } end; end; {access = indirect then loadaddress(lhs,false) else checkoffset(lhs); {determine access size for the destination} if (bitoffset.static MOD 8) + bitsize <= 8 then begin offset := offset + (bitoffset.static DIV 8); b case xfersize } {position the rhs correctly in the register to match the destination field location} shiftcount := (rhs^.attr^.bitoffset.static + rhs^.attr^.bitsize) - (bitoffset.static + bitsize); if (rhs^.attr^.signbit) and (rhsitoffset.static := (bitoffset.static MOD 8) + 24; xfersize := bytte; end else if (bitoffset.static + bitsize) <= 16 then begin bitoffset.static := bitoffset.static + 16; xfersize := wrd; end else xfersize^.attr^.bitsize < bitsize) then with rhs^.attr^ do begin {unpack rhs using sign extension} case xfersize of bytte: shiftcount := bitoffset.static - 24; wrd: shiftcount := bitoffset.static - 16; long: shiftcount := bitoffset.static;  := long; {load the rhs in a register} bitaddress(rhs); with rhs^, attr^ do begin if access = indirect then loadaddress(rhs,false) else checkoffset(rhs); signextend := signbit and (bitsize < lhs^.attr^.bitsize);  end; while shiftcount < 0 do shiftcount := shiftcount + 8; shiftsize := shiftcount + 32 - bitoffset.static; if shiftsize <= 8 then shiftopsize := bytte else if shiftsize <= 16 then shiftopsize := wrd else shiftopsiz with op1 do begin addrmode := inDreg; regnum := getreg(D); end; { get rhs in a register without unpacking then field yet } if ((bitoffset.static MOD 8)+bitsize <= 8) and (not signextend or (xfersize = bytte)) then begin offset := ofe := long; emitshift(shiftcount,op1.regnum,lsl,shiftopsize); shiftcount := shiftcount - (bitoffset.static + bitsize) + lhs^.attr^.bitoffset.static + lhs^.attr^.bitsize; emitshift(shiftcount,op1.regnum,asr,shiftopsize); bitsize := bitsize + shfset + (bitoffset.static DIV 8); bitoffset.static := (bitoffset.static MOD 8) + 24; op1.storage := bytte; end else if ((bitoffset.static+bitsize) <= 16) and (not signextend or (xfersize <= wrd)) then begin bitoffset.static := bitofiftcount; end { with rhs^.attr^ } else if shiftcount > 0 then emitshift(shiftcount,op1.regnum,lsl,xfersize) else if shiftcount < 0 then emitshift(-shiftcount,op1.regnum,lsr,op1.storage); { maskoff the rhs garbage bits if nece5      := bitoffset.static; end; if masksize <> 0 then begin case xfersize of bytte: getmaskattr(maskoffset-24,masksize,8,op2); wrd: getmaskattr(maskoffset-16,masksize,16,op2); long: getmaskattr(maskoffset,masksize,32,op2); iting '; begin error(errornum); setstrlen(s,0); strwrite(s,1,i,iores:1); message := ' file, ioresult(' + s + ')'; case errornum of 903: message := error_opening + 'code' + message; 904: message := error_opening + 'ref' + message; 905: mess end; op1.storage := xfersize; emit2(andi,op2,op1); end; { store into the destination field } {lhs^.attr^}storage := xfersize; if (xfersize = bytte) and (bitsize = 8) then emit2(move,op1,{lhs^}attr^) else if age := error_opening + 'def' + message; 906: message := error_writing + 'code' + message; 907: message := error_writing + 'ref' + message; 908: message := error_writing + 'def' + message; end; warning(linenumber,message); end; procedure (xfersize = wrd) and (bitsize = 16) then emit2(move,op1,{lhs^}attr^) else emit2(orr,op1,{lhs^}attr^); freeit(D,op1.regnum); freeregs({lhs^}attr); end; {pack to pack special case} end; {with lhs^, attr^} $END$ end; {pdumpbuffer; var block: shortint; begin with codephile do begin if totalerrors = 0 then begin if not codefileopen then begin reset(fileid,file_name); close(fileid,'PURGE'); { Purge any existing file } fmakeacktopack} type(fileid,file_name, nullstring,dot_code); if ioresult <> 0 then file_warn(903,ioresult); codefileopen := true; end; block := startblock + (windowptr DIV 512); if blockwrite(fileid,buffer^,coderecs,block) <> coderecs t { file GENUTIL } import assemble,genmove,ci,fs; implement type pachstring = packed array[1..strglgth] of char; var codelinestart: 0..1023; nullstring: string[1]; dot_code: string[5]; procedure codeinit; begin chen file_warn(906,ioresult); end; windowptr := bytecount; end; end; { dumpbuffer } procedure outputcodebyte (* b: shortint *); var block, bite: shortint; begin with codephile do begin modulecodeout := true; odeout := false; startaddr := -1; codephile.headerblock := 2; nextmodule := 1; end; procedure moduleinit (* modulenameptr: alphaptr *); begin uniquenum := 0; currentglobal := modulenameptr; modulecodeout := false; with codephile do beblock := (bytecount - windowptr) DIV 512 + 1; bite := (bytecount - windowptr) MOD 512; buffer^[block,bite] := b; bytecount := bytecount + 1; if (block = coderecs) and (bite = 511) then { buffer is full } dumpbuffer; end; engin bytecount := 0; windowptr := 0; startblock := headerblock + 1; sourceblock := 1; sourcesize := 0; end; with defile do begin block := 0; bite := 0; end; def_ext_top := 1; with refile do begin block := 0; bite :=d; { outputcodebyte } procedure outputcodeword (* w: shortint *); var variantrec: packed record case boolean of true: (w: shortint); false: (b1: byt; b2: byt); end; begin variantrec.w := w; outputcodebyte(variantrec.b1); 0; end; outputdef('_BASE',0,relocatable,0); end; { codeinit } procedure file_warn(errornum,iores: shortint); var s: string[10]; i: integer; message: string[50]; const error_opening = 'Error opening '; error_writing = 'Error wr outputcodebyte(variantrec.b2); end; { outputcodeword } procedure outputcodelong (* l: integer *); var i: shortint; variantrec: record case boolean of true: (l: integer); false: (b: packed array[0..3] of byt); end; begin 5      windowptr + 1) MOD 512; block2 := (pc - windowptr + 1) DIV 512 + 1; variantrec.b2 := buffer^[block2,bite2]; variantrec.w := variantrec.w + value; buffer^[block1,bite1] := variantrec.b1; buffer^[block2,bite2] := variantrertint); false: (b1: byt; b2: byt); end; bite1,block1, bite2,block2: shortint; begin with codephile do begin block1 := startblock + (pc DIV 512); bite1 := pc MOD 512; if block1 <> patchblock then c.b2; end else { patch up on disk } begin block1 := startblock + (pc DIV 512); bite1 := pc MOD 512; if bite1 < 511 then numberofblocks := 1 {word is all in one block} else numberofblocks := 2;{word crosses bo if (block1 <> patchblock + 1) or (bite1 = 511) then begin if patchblock <> 0 then if blockwrite(fileid,patchbuf,blocksin,patchblock)<>blocksin then begin ioresult := ord(zcatchall); escape(-10); end; if bite1 < 511 then blocksin  variantrec.l := l; for i := 0 to 3 do outputcodebyte(variantrec.b[i]); end; { outputcodelong } procedure fixbyte (* pc: addrrange; value: shortint *); var fixbuffer: bytebufs; bite,block: shortint; begin if (pc >= 0) and (value <> 0)undry} if blockread(fileid,fixbuffer,numberofblocks,block1) <> numberofblocks then begin ioresult := ord(zcatchall); escape(-10); end; variantrec.b1 := fixbuffer[1,bite1]; block2 := 1 + (bite1 + 1) DIV 512; bite2 := (b then with codephile do if pc >= windowptr then { byte is in current buffer } begin bite := (pc - windowptr) MOD 512; block := (pc - windowptr) DIV 512 + 1; buffer^[block,bite] := buffer^[block,bite] + value; end ite1 + 1) MOD 512; variantrec.b2 := fixbuffer[block2,bite2]; variantrec.w := variantrec.w + value; fixbuffer[1,bite1] := variantrec.b1; fixbuffer[block2,bite2] := variantrec.b2; if blockwrite(fileid,fixbuffer,numberofbloc else { patch up on disk } begin block := startblock + (pc DIV 512); bite := pc MOD 512; if blockread(fileid,fixbuffer,1,block) <> 1 then begin ioresult := ord(zcatchall); escape(-10); end; fixbuffer[bite] := fixbufferks,block1) <> numberofblocks then begin ioresult := ord(zcatchall); escape(-10); end; end; end; { fixword } $IF MC68020$ procedure fixlong ( pc: addrrange; value: integer ); { Assumes that the location being fixed currently[bite] + value; if blockwrite(fileid,fixbuffer,1,block) <> 1 then begin ioresult := ord(zcatchall); escape(-10); end; end; end; { fixbyte } procedure fixword ( pc: addrrange; value: shortint ); var fixbuffer: array[1..2] of byte has a value of 0 } var variantrec : record case boolean of true: (i: integer); false:(s1: shortint; s2: shortint); end; begin variantrec.i := value; fixword(pc,variantrec.s1); fixword(pc+2,variantrec.s2); end; {fixlong} bufs; numberofblocks: shortint; bite1,block1, bite2,block2: shortint; variantrec: packed record case boolean of true: (w: shortint); false: (b1: byt; b2: byt); end; begin if totalerrors = 0 then if (pc >= 0) and (value <> $END$ procedure fixreflist (* listptr: reflistptr *); { listptr is a ptr to a linked list of 16-bit pc relative references to the current pc. This routine patches all of those references. } var patchbuf: array[1..2] of bytebufs; patc 0) then with codephile do if pc >= windowptr then { word is in current buffer } begin bite1 := (pc - windowptr) mod 512; block1 := (pc - windowptr) DIV 512 + 1; variantrec.b1 := buffer^[block1,bite1]; bite2 := (pc -hblock, {indicates the current block(s) in the patchbuf} blocksin: shortint; {number of blocks read into patchbuf} procedure diskpatch (pc: addrrange; value: shortint); var variantrec: packed record case boolean of true: (w: sho6     := 1 else blocksin := 2; patchblock := block1; if blockread(fileid,patchbuf,blocksin,patchblock) <> blocksin then begin ioresult := ord(zcatchall); escape(-10); end; end else if blocksin <> 2 then { read in second part of buffealerrors = 0 then with refile do begin upc(name); { added 4/12/84 } buffer^[bite] := strlen(name); bite := bite + 1; if bite > 511 then dumprefbuffer; for i := 1 to strlen(name) do begin buffer^[r } begin if blockread(fileid,patchbuf[2],1,patchblock+1) <> 1 then begin ioresult := ord(zcatchall); escape(-10); end; blocksin := 2; end; block1 := 1 + block1 - patchblock; block2 := block1 + (bite1 + 1) DIV bite] := ord(name[i]); bite := bite +1; if bite > 511 then dumprefbuffer; end; buffer^[bite] := ord(t); bite := bite + 1; if bite > 511 then dumprefbuffer; variantrec.l := loc; for i := 0 to 3 do begin 512; bite2 := (bite1 + 1) MOD 512; variantrec.b1 := patchbuf[block1,bite1]; variantrec.b2 := patchbuf[block2,bite2]; variantrec.w := variantrec.w + value; patchbuf[block1,bite1] := variantrec.b1; patchbuf[block2,bi buffer^[bite] := variantrec.b[i]; bite := bite + 1; if bite > 511 then dumprefbuffer; end; end; end; { outputref } procedure outputdef(name: string255; loc: addrrange; t: reloctype; extnumber: shortintte2] := variantrec.b2; end; end; { diskpatch } procedure dumpatches; begin if patchblock <> 0 then with codephile do if blockwrite(fileid,patchbuf,blocksin,patchblock) <> blocksin then begin ioresult := ord(zcatchall); es); var i: shortint; variantrec: record case boolean of true: (l: integer); false: (b: packed array[0..3] of byt); end; flags: flagtype; procedure dumpdefbuffer; begin with defile do begin if blockwrite(fileidcape(-10); end; end; { dumpatches } begin { fixreflist } if totalerrors = 0 then begin patchblock := 0; while listptr <> NIL do with listptr^ do begin if pc <> -1 then { -1 => branch not emitted } if (codephile.bytecou,buffer^,1,block) <> 1 then file_warn(908,ioresult); block := block + 1; bite := 0; end; end; { dumpdefbuffer } begin if curglobalname <> NIL then name := curglobalname^ + '_' + name; if totalerrors = 0 then with defile nt - pc) > 32767 then error(671) else if pc >= codephile.windowptr then fixword(pc,codephile.bytecount-pc) else diskpatch(pc,codephile.bytecount-pc); listptr := next; end; { with listptr^ } dumpatches; end; endo begin buffer^[bite] := strlen(name); bite := bite + 1; if bite > 511 then dumpdefbuffer; for i := 1 to strlen(name) do begin upc(name); buffer^[bite] := ord(name[i]); bite := bite + 1; if bite d; { fixreflist } procedure outputref(name: alpha; loc: addrrange; t: reftype); { temporarily output refs to a file } var i: shortint; variantrec: record case boolean of true: (l: integer); false: (b: packed array[0..3] of byt); > 511 then dumpdefbuffer; end; if not(odd(strlen(name))) then { pad to an even byte } begin bite := bite + 1; if bite > 511 then dumpdefbuffer; end; with flags do begin typ := t; size := sl; end; procedure dumprefbuffer; begin with refile do begin if blockwrite(fileid,buffer^,1,block) <> 1 then file_warn(907,ioresult); block := block + 1; bite := 0; end; end; { dumprefbuffer } begin if tot patchable := false; valueextend := true; longoffset := false; end; buffer^[bite] := flags.b; bite := bite + 1; if bite > 511 then dumpdefbuffer; { output length of GVR in offset field } if t = general t6     temp := curglobalname; curglobalname := NIL; outputdef(name,loc,general,extnumber); curglobalname := globalnametemp; end; procedure codewrapup (* term: termtype *); procedure libraryheader; begin with libraryptr^[0] do begin  if putcode and (totalerrors = 0) then begin for i := 1 to 7 do outputcodebyte(ord(modu[i])); for i := 1 to strlen(s^) do outputcodebyte(ord(s^[i])); outputcodebyte(ord(';')); outputcodebyte(13{EOL}); end; end; procedure dfirstblk := 0; dlastblk := 2; dfkind := untypedfile; if strlen(outerblock^.namep^) > vnlength then outerblock^.namep^[0] := chr(vnlength); dvid := outerblock^.namep^; deovblk := dlastblk - 1; dnumfiles := ne outputsymbol; { Output the symblo that is between symbolstart and symcursor. Do not let the symbol cross a block boundry on the code file. } var symbolsize,i: shortint; begin if putcode and (totalerrors = 0) then with codephile do hen { has ref pointer } buffer^[bite] := 8 else buffer^[bite] := 6; bite := bite + 1; if bite > 511 then dumpdefbuffer; { output value extension } variantrec.l := loc; for i := 0 to 3 do begin buffextmodule - 1; dloadtime := 0; dlastboot:= globaldate; end; if blockwrite(codephile.fileid,libraryptr^,2,0) <> 2 then begin ioresult := ord(zcatchall); escape(-10); end; end; begin { codewrapup } if (term = normal) ar^[bite] := variantrec.b[i]; bite := bite + 1; if bite > 511 then dumpdefbuffer; end; if t = general then { has ref pointer } begin variantrec.l := extnumber + 1; for i := 2 to 3 do begin buffer^[bite] := nd codeout and (totalerrors = 0) then begin libraryheader; close(codephile.fileid,'lock'); if ioresult <> 0 then escape(-10); with userinfo^ do begin gotcode := true; codefid := file_name; evariantrec.b[i]; bite := bite + 1; if bite > 511 then dumpdefbuffer; end; end; end; { with defile } end; { outputdef } procedure outputextdef(name: alpha; loc: addrrange; ext: alpha); { output a def which referencnd; end else begin writeln; writeln('No codefile generated.'); close(codephile.fileid,'purge'); end; close(refile.fileid,'purge'); close(defile.fileid,'purge'); end; procedure endofcode; { append current memoes an ext } var i,extnumber: shortint; found: boolean; globalnametemp: alphaptr; begin if ext = currentglobal^ then extnumber := 4 {global delta } else begin extnumber := 8; found := false; i := 1; while (i < def_ext_top) andry code buffer to code file } var numberofblocks, block: shortint; begin if totalerrors = 0 then with codephile do begin numberofblocks := (bytecount - windowptr + 511) DIV 512; if numberofblocks > 0 then begin bloc not found do begin if def_ext_table[i] = ext then found := true else extnumber := extnumber + strlen(def_ext_table[i]) + 4 - (strlen(def_ext_table[i]) mod 4); i := i + 1; end; if not found then if dk := startblock + windowptr DIV 512; if not codefileopen then begin reset(fileid,file_name); close(fileid,'PURGE'); { Purge any existing file } fmaketype(fileid,file_name, nullstring,dot_code); codefileopen := true; end; if ef_ext_top <= max_module_nesting then begin def_ext_table[def_ext_top] := ext; def_ext_top := def_ext_top + 1; end else error(663); { poor error number } end; { output def without module name prefix } globalnameblockwrite(fileid,buffer^,numberofblocks,block) <> numberofblocks then file_warn(906,ioresult); end; end; end; { endofcode } procedure importexportstart(s: alphaptr); var i: shortint; const modu = 'MODULE '; begin 7      begin symbolsize := symcursor - symbolstart - 1; if odd(bytecount DIV 512) and ((bytecount+symbolsize+2) DIV 512 > bytecount DIV 512) then begin outputcodebyte(13{EOL}); outputcodebyte(0); end; if (bytecount+symfield } for i := 0 to strlen(name) do exttop^.name[i] := name[i]; exttop^.nextext := NIL; end else begin exptr := exttop; done := false; repeat if exptr^.name = name then done := true else begbolsize+1) DIV 512 > bytecount DIV 512 then begin while (bytecount+symbolsize+1) DIV 512 > (bytecount+1) DIV 512 do outputcodebyte(32{blank}); outputcodebyte(13{EOL}); end; for i := symbolstart to symcursor-1 do in result := result + strlen(exptr^.name) + 4 - (strlen(exptr^.name) MOD 4); if exptr^.nextext = NIL then begin newwords(exptr^.nextext,(strlen(name)+2) DIV 2 + 4); { cannot use string assignment for name field } for  outputcodebyte(ord(symbuf[i])); end; end; procedure importexportwrapup; begin with codephile do begin if putcode and (totalerrors = 0) then begin if odd(bytecount DIV 512) and ((bytecount+6) DIV 512 > bytecount i := 0 to strlen(name) do exptr^.nextext^.name[i] := name[i]; exptr^.nextext^.nextext := NIL; done := true; end; end; exptr := exptr^.nextext; until done; end; extaddress := result; end; { extaddress } DIV 512) then outputcodebyte(0); while (bytecount+6) DIV 512 > bytecount DIV 512 do outputcodebyte(32{blank}); outputcodebyte(ord('E')); outputcodebyte(ord('N')); outputcodebyte(ord('D')); outputcodebyte(ord(';') procedure copydefs; { append defile to codefile } var dontcare,i: shortint; alphavar: alpha; begin with defile do begin defstartblock := codephile.startblock+totalbytesofcode DIV 512 + 1; sizeofdefs := block *); outputcodebyte(13{EOL}); outputcodebyte(3); { import export text terminator } sourcesize := bytecount; endofcode; startblock := startblock + (sourcesize+511) DIV 512; end; { dump buffer to file } bytecount : 512 + bite; if block <> 0 then { dump last def block to defile } begin if bite > 0 then begin if blockwrite(fileid,buffer^,1,block) <> 1 then file_warn(908,ioresult); end else begin block := block - 1; bite := 51= 0; windowptr := 0; modulecodeout := false; end; end; procedure modulewrapup(countglobals: boolean); type extptr = ^extentry; extentry = record nextext: extptr; name: alpha; end; var curglobaltemp: alph2; end; if blockread(fileid,buffer^,1,0) <> 1 then begin ioresult := ord(zcatchall); escape(-10); end; end; if (block <> 0) or (bite <> 0) then for i := 0 to block do begin if blockwrite(codephile.fileid,buffer^,1,defstartblockaptr; exttop: extptr; function extaddress (var name: alpha) : integer; { search the exttable for "name" and return its position. If it is not in the table put it at the end and return its position. } var exptr: extptr; done: +i) <> 1 then file_warn(906,ioresult); if i <> block then if blockread(fileid,buffer^,1,i+1) <> 1 then begin ioresult := ord(zcatchall); escape(-10); end; end; { for } end; for i := 1 to def_ext_top - 1 do beginboolean; result: integer; i: shortint; begin result := 8; { first two entries are reserved } if exttop = NIL then begin newwords(exttop,(strlen(name)+2) DIV 2 + 4); { cannot use normal string assignment for name  alphavar := def_ext_table[i]; dontcare := extaddress(alphavar); end; end; { copydefs } procedure copyrefs; var copyblock,copybite: shortint; flags: flagtype; previousref: addrrange; procedure copyexts; var expt7     chall); escape(-10); end; end; { bumprefbuffer } begin with refile do begin name[0] := chr(buffer^[copybite]); copybite := copybite + 1; if copybite > 511 then bumprefbuffer; for i := 1 to ord(name[0]) do begin name[i] begin variantrec.l := -variantrec.l; for i := 0 to 3 do outputcodebyte(variantrec.b[i]); sizeofrefs := sizeofrefs + 4; end; if flags.typ = general then begin if not (t in [rel16,rel16v,rel32]) then {only one ref pointer (bit 0  := chr(buffer^[copybite]); copybite := copybite + 1; if copybite > 511 then bumprefbuffer; end; if strlen(name) <> 0 then extoffset := extaddress(name); t := reftype(buffer^[copybite]); copybite := copybite + 1; if copybite > 511 then on)} extoffset := extoffset + 1; outputcodeword(extoffset); sizeofrefs := sizeofrefs + 2; end; if t in [rel16,rel16v,rel32] then begin outputcodeword(3); { subtract recocation delta } sizeofrefs := sizeofrefs + 2; end; r: extptr; i: shortint; begin { copyexts } with codephile do { use codefile buffer routines for exts } begin extstartblock := refstartblock + (sizeofrefs + 511) DIV 512; sizeofexts := 8; { first 8 bytes are reserved } bytecount :bumprefbuffer; for i := 0 to 3 do begin variantrec.b[i] := buffer^[copybite]; copybite := copybite + 1; if copybite > 511 then bumprefbuffer; end; relativetoprevious := variantrec.l - previousref; previousref := variantrec.l; wi= (extstartblock - startblock) * 512; windowptr := bytecount; bytecount := bytecount + 8; exptr := exttop; while exptr <> NIL do begin sizeofexts := sizeofexts + strlen(exptr^.name) + 4 - (strlen(exptr^.name) MOD 4); {upc(exptrth flags do begin if t = rel16v then valueextend := true else valueextend := false; case t of abs16: begin if strlen(name) = 0 then typ := relocatable else typ := general; size := sw; patchable :^.name); DELETED 4/12/84 } for i := 0 to strlen(exptr^.name) do outputcodebyte(ord(exptr^.name[i])); for i := 1 to 3 - strlen(exptr^.name) MOD 4 do outputcodebyte(0); exptr := exptr^.nextext; end; endofcode; { dump cod= false; end; abs32: begin if strlen(name) = 0 then typ := relocatable else typ := general; size := sl; patchable := false; end; rel16,rel16v: begin typ := general; efile buffer to the file } end; end; { copyexts } procedure copy1ref; var name: alpha; relativetoprevious: addrrange; extoffset: integer; flags: flagtype; t: reftype; i: shortint; variantrec2size := sw; patchable := true; end; glob16: begin typ := global; size := sw; patchable := false; end; rel32: begin typ := general; size := sl; patchable := , variantrec: record case boolean of true: (l: integer); false: (b: packed array[0..3] of byt); end; procedure bumprefbuffer; { Not to be confused with dumprefbuffer. This routine handles the buffering for reading false; end; end; if relativetoprevious < 256 then longoffset := false else longoffset := true; end; { with flags } outputcodebyte(flags.b); sizeofrefs := sizeofrefs + 1; if relativetoprevious < 256 then begin ouin the temporary ref file. } begin copyblock := copyblock + 1; copybite := 0; with refile do if (block <> copyblock) or (bite <> 0) then if blockread(fileid,buffer^,1,copyblock) <> 1 then begin ioresult := ord(zcattputcodebyte(relativetoprevious); sizeofrefs := sizeofrefs + 1; end else begin variantrec2.l := relativetoprevious; for i := 1 to 3 do outputcodebyte(variantrec2.b[i]); sizeofrefs := sizeofrefs + 3; end; if t = rel16v then 8      end; end; { copy1ref } begin { copyrefs } with refile do begin refstartblock := defstartblock + (sizeofdefs + 511) DIV 512; sizeofrefs := 0; codephile.bytecount := (refstartblock - codephile.startblock) * 512; codephil ord(currentglobal^[i]); {even byte allign} i := morebytes[0] + 1 + ord(not odd(morebytes[0])); if startaddr <> -1 then { put out start address } begin morebytes[i] := 82; { signed long, relocatable, value extend } i := i + 1; e.windowptr := codephile.bytecount; if block <> 0 then { dump lst ref block to refile } begin if bite > 0 then if blockwrite(fileid,buffer^,1,block) <> 1 then file_warn(907,ioresult); if blockread(fileid,buffer^,1,0) <> 1 thmorebytes[i] := 6; { offset = 6 } i := i + 1; variantrec.l := startaddr; for j := 0 to 3 do morebytes[i+j] := variantrec.b[j]; i := i + 4; end; variantrec.l := codephile.startblock - codephile.headerblock; for j := 0 to 3 do morebyen begin ioresult := ord(zcatchall); escape(-10); end; end; previousref := 0; copyblock := 0; copybite := 0; while (copyblock <> block) or (copybite <> bite) do copy1ref; endofcode; { dump codefile buffer^ to the file } cotes[i+j] := variantrec.b[j]; i := i + 4; variantrec.l := totalbytesofcode; for j := 0 to 3 do morebytes[i+j] := variantrec.b[j]; i := i + 4; variantrec.l := refstartblock - codephile.headerblock; for j := 0 to 3 dopyexts; end; end; { copyrefs } procedure fixheaderecord; { output a module header at the beginning of the codefile } var i,j: shortint; variantrec: record case boolean of true: (l: addrrange); false: (b: packed array[0. morebytes[i+j] := variantrec.b[j]; i := i + 4; variantrec.l := sizeofrefs; for j := 0 to 3 do morebytes[i+j] := variantrec.b[j]; i := i + 4; { load address general value record (gvr) } morebytes[i] := 82; { signed.3] of byt); end; directory: module_directory; begin with directory do begin date := globaldate; revision := crevid; { produced by compiler } if modcal then producer := 'M' else producer := 'P';  long, relocatable, value extend } i := i + 1; morebytes[i] := 6; { offset = 6 } i := i + 1; for j := 0 to 3 do morebytes[i+j] := 0; i := i + 4; directory_size := fixedpart + i; module_size := ((extstartblo system_id := ord(crevno[1]) - ord('0'); notice := gcopyright; executable := (startaddr <> -1); { -1 means no main program } relocatable_size := totalbytesofcode; relocatable_base := 0; if countglobals then begin if cck - codephile.headerblock) + (sizeofexts + 511) DIV 512) * 512; end; { with directory } with codephile do begin if blockwrite(fileid,directory,1,headerblock) <> 1 then begin ioresult := ord(zcatchall); escape(-10); end; urproc = outerblock then global_size := -lcmax else global_size := -lc; end else global_size := 0; global_base := 0; ext_block := extstartblock - codephile.headerblock; ext_size := sizeofexts; def_block := defstartblo with libraryptr^[nextmodule] do begin dfirstblk := headerblock; dlastblk := headerblock + directory.module_size DIV 512; if strlen(currentglobal^) > fnlength then currentglobal^[0] := chr(fnlength); dtid := currentglobal^; { no. of byck - codephile.headerblock; def_size := sizeofdefs; source_block := sourceblock; source_size := sourcesize; text_records := 1; morebytes[0] := strlen(currentglobal^); for i := 1 to morebytes[0] do morebytes[i] :=tes in last block } dlastbyte := ((sizeofexts-1) MOD 512) + 1; daccess := globaldate; dfkind := codefile; headerblock := dlastblk; end; end; { with codephile } if nextmodule + 1 <= maxdir then nextmodule := nextmodule + 1 8      emit1(trap,op); end; end; {callIOproc} procedure getprokconst(fprocp: ctp; var at: attrtype); var nametemp: alpha; begin at.callmode := callmode; with at do begin addrmode := namedconst; storage := long; offset := 0; new(consltattr(* rcount: shortint; A1isfree: boolean; var at: attrtype *); {get register list attributes for move multiple using 'rcount' registers. Assumes D0-D7 and A2-A5 are available; use of A1 is controlled by 'A1isfree'} const numDregs = 8;tptr); with constptr^ do if fprocp^.alias then begin namep := fprocp^.othername; fprocp^.isrefed := true; isdumped := false; end else if fprocp^.isdumped then begin isdumped := true; loca minmove = 2; maxmove = 13; var i : shortint; j : regtype; begin if (rcount < minmove) or (rcount > maxmove-1+ord(A1isfree)) then escape(-8); with at do begin for j := A to D do for i := 0 to 7 do regs[j,i] := faelse error(705); end; { fixheaderecord } begin { modulewrapup } if totalerrors = 0 then if modulecodeout then begin if countglobals then begin curglobaltemp := curglobalname; curglobalname := NIL; outputdef(cution := fprocp^.location; end else begin if not fprocp^.extdecl and not fprocp^.isexported then nametemp := itostr(fprocp^.forwid) + fprocp^.namep^ else nametemp := fprocp^.namep^; if fprocp^.othername <>rrentglobal^,0,global,0); curglobalname := curglobaltemp; end; totalbytesofcode := codephile.bytecount; endofcode; { dump all buffered code bytes to the file } exttop := NIL; copydefs; { append all defs  NIL then newident(namep, fprocp^.othername^ + '_' + nametemp) else newident(namep,nametemp); fprocp^.isrefed := true; isdumped := false; end; end; end; {getprokconst} procedure getbrattr {var flbl: to the end of the code file } copyrefs; { append all refs to the end of the code file } fixheaderecord; { fix up the module header information } codeout := true; end; end; { modulewrapup } procedure pactos(plgth: saddrrange; defined: boolean; var battr: attrtype}; { Returns attributes for a Bcc instruction in battr^. If defined, the branch is backward to flbl. Otherwise, the PC, byte, and block numbers for the forward reference are returned in flbl } var hortint; var pa: pachstring; var s: string); begin s[0] := chr(plgth); moveleft(pa[1],s[1],plgth); end; procedure callstdproc( s: alpha ); var lattr: attrtype; begin lattr.callmode := callmode; with lattr do begin addrmode := namedcons PCtemp: addrrange; begin PCtemp := codephile.bytecount + 2; with battr do if defined then begin offset := flbl - PCtemp; if offset >= -128 then storage := bytte else storage := wrd; end else begt; offset := 0; new(constptr); with constptr^ do begin isdumped := false; newident(namep,s) end; end; emit1(jsr,lattr); end; procedure callIOproc( s: alpha ); var op: attrtype; begin callstdproc(s); if iocheck then begin witin offset := 0; storage := wrd; flbl := PCtemp; end; end; {getbrattr} procedure emitstringlit(sp: csp); var s: 0..strglgth; begin with sp^ do begin s := 0; if slgth = 0 then outputcodeword(0) else whileh SBind do begin storage := long; offset := ioresultptr^.vaddr; gloptr := sysglobalptr; end; emit1(tst,SBind); SBind.gloptr := NIL; with op do begin storage := bytte; offset := 2 end; emit1(beq,op); op.smallval := 3; s < slgth do begin if s=0 then if cclass = STRNG then outputcodebyte(slgth); s := s+1; outputcodebyte(ord(sval[s])); end; if odd(codephile.bytecount) then outputcodebyte(0); end; end; {emitstringlit} procedure getmu9     lse; addrmode := multiple; if rcount <= numDregs then for i := 0 to rcount-1 do regs[D,i] := true else begin for i := 0 to numDregs-1 do regs[D,i] := true; for i := (2-ord(A1isfree)) to (rcount-numDregs+1-ord(A1is; variantrec.bit1 := 1; mask := variantrec.i; end; end; end; end; { getmask } procedure getcomplmaskattr(* bitoffset, bitsize, masksize: shortint; var at :attrtype *); begin getmask(bitoffset,bitsize,masksize,at.smafree)) do regs[A,i] := true; end; end; { with at } end; {getmultattr} procedure emitshift(*shiftcount: bitrange; reg: regrange; shiftype: opcodetype; shiftsize: stortype*); var shiftemp : regrange; opnd1, opnd2 : attrtyllval); with at do begin if smallval = maxint then smallval := minint else smallval := -(smallval + 1); { 1's complement } case masksize of 8: storage := bytte; 16: storage := wrd; 32: storage := lope; begin if shiftcount <> 0 then if shiftcount > 8 then begin shiftemp := getreg(D); opnd1.smallval := shiftcount; with opnd2 do begin addrmode := inDreg; regnum := shiftemp; end; emit2(moveq,opnd1,opnd2); witng; end; {case} addrmode := immediate; end; end; { getcomplmaskattr } procedure getmaskattr (* bitoffset, bitsize, masksize: shortint; var at : attrtype *); begin getmask(bitoffset,bitsize,masksize,at.smallval); with h opnd1 do begin addrmode := inDreg; regnum := reg; storage := shiftsize; end; emit2(shiftype,opnd2,opnd1); freeit(D,shiftemp); end else begin with opnd1 do begin addrmode := immediate; smallval := shiftcount; end; at do begin case masksize of 8: storage := bytte; 16: storage := wrd; 32: storage := long; end; {case} addrmode := immediate; end; end; procedure dumpstconst(*fsp: stp; var fvalu: valu*); { Inserts struc with opnd2 do begin addrmode := inDreg; regnum := reg; storage := shiftsize; end; emit2(shiftype,opnd1,opnd2); end; end; {emitshift} procedure getmask(bitoffset,bitsize,masksize: shortint; var mask:integer); { Games are tured constant into code file. Modified for M68K by Sam Sands; original VPM version by Donn Terry} const wbytes = 2; {number of bytes in a DC.W} lbytes = 4; {number of bytes in a DC.L} var offset: addrrange; {bytes generatedplayed here because 32 bit UNSIGNED math is not available } var topbit : (on,off); variantrec : packed record case boolean of true: (i: integer); false: (bit1: 0..1); end; begin mask := 0; if bitsize <> 0 then begin  so far} packbuf: shortint; {16 bit (DC.W) code bit buffer} packbit: shortint; {number of bits in packword} curglobaltemp: alphaptr; procedure flush; {output the code bit buffer} var variantrec: packed record case boolean of true bitoffset := bitoffset + (32-masksize); if bitoffset = 0 then { avoid 32 bit math overflow } begin topbit := on; bitoffset := 1; bitsize := bitsize - 1; end else topbit := off; if bitsize = 31 then : (w: shortint); false: (b1: byt; b2: byt); end; begin if packbit >0 then if packbit > 8 then begin outputcodeword(packbuf); offset := offset + wbytes; end else begin variantrec.w := pmask := maxint else begin if bitsize = 0 then mask := 0 else mask := (power_table[bitsize]-1) * power_table[32-(bitoffset + bitsize)]; if topbit = on then { turn on sign bit in mask} begin variantrec.i := maskackbuf; outputcodebyte(variantrec.b1); offset := offset + 1; end; packbuf := 0; packbit := 0; end; procedure dmpcnst(fsp: stp; fvalu: valu; packing: boolean; posn, width: shortint); $if bigsets$ const oldsetwor9     begin flush; if odd(offset) then outbyte(0); posn := 0; packbit := width; end; if width < 32 then begin if i < 0 then i := i - minint; if width < 31 then begin z := 1; for j:= 1 to width do); end; vctmp := vctmp^.vcnxt; end; end; end; {inner array} begin {dumparray} flush; if odd(offset) then outbyte(0); with fvalu.valp^.kstruc^ do if (scstp^.aeltype = char_ptr) and scstp^.aispackd then if  z := z + z; i := i mod z; end; end; z := i; j := 16 - packbit; while j<0 do begin if z < 0 then z := (z + 32768) div 2 + 16384 else z := z div 2; j := j + 1; end; while j>0 do begin if z < 16384 then scvcp^.vcval.valp^.cclass = paofch then {packed array of char literal is treated specially} with scvcp^.vcval.valp^ do outputpaoc(fsp^.aisstrng, fsp^.unpacksize, slgth, sval) else if scvcp^.vcval.valp^.cclass = bigpaodsize = (oldsethigh + 1 + setelemsize - 1) div setelemsize; $end$ var vctmp: vcref; i,w,b: integer; setsize: shortint; variantrec: record case boolean of true: (r: real); false: (l1: integer; l2: integer); endz := z + z else z := (z - 16384)*2 - 32768; j := j - 1; end; packbuf := packbuf + z; if packbit >= 16 then begin flush; width := width - (16 - posn); posn := 16; if width > 0 then outpacked(i); ; $if bigsets$ s : setrecptr; (* current set record item *) j : shortint; (* simple local counter *) limit : shortint; (* ordinal limit for set rec *) variantset : record case boolean of true: (sett: set of setlow..old end; end; {outpacked} procedure outputpaoc (aisstrng: boolean; unpacksize: integer; lgth: integer; anyvar val: bigpac); var i: shortint; begin flush; if odd(offset) then outbyte(0); if aisstsethigh); false: (pad: shortint; words: packed array [0..oldsetwordsize-1] of shortint) end; $end$ procedure outbyte(i: shortint); {output a bool or a char} begin flush; outputcodebyte(i); rng then begin outputcodebyte(lgth); { DC.B } offset := offset + 1; end; for i := 1 to lgth do begin $RANGE OFF$ outputcodebyte(ord(val[i])); { DC.B } $IF rangechecking$ $RANGE ON$ $END$ offs{ DC.B } offset := offset + 1; end; procedure outword(i: shortint); {output an enumerated type} begin flush; outputcodeword(i); { DC.W } offset := offset + wbytes; end; procedure outlong(i: inteet := offset + 1; end; for i := lgth + 1 to unpacksize-ord(aisstrng) do begin outputcodebyte(ord(' ')); { DC.B } offset := offset + 1; end; end; {outputpaoc} procedure dumparray; var elpos: bitrange; ger); begin flush; outputcodelong(i); { DC.L } offset := offset + lbytes; end; procedure outpacked(i: integer); {pack a 32 bit quantity} var z,j: integer; begin {outpacked} if posn = 0 then i: integer; procedure innerarray; begin with fvalu.valp^.kstruc^ do begin vctmp := scvcp; elpos := 0; while vctmp <> NIL do with scstp^,vctmp^ do begin if aispackd then begin dmpcnst(aeltype,vcval, begin flush; {starting over} if width > 16 then if odd(offset) then outbyte(0); end; if posn >= 16 then posn := posn - 16; packbit := posn + width; {right end of field} if packbit > 32 then true,elpos,aelbitsize); elpos := elpos+aelbitsize; if elpos+aelbitsize > bitsperword then elpos := 0; end else begin dmpcnst(aeltype,vcval,false,0,0); if aelsize <> aeltype^.unpacksize then outbyte(0:     c then {big packed array of char literal is treated specially} with scvcp^.vcval.valp^ do outputpaoc(fsp^.aisstrng, fsp^.unpacksize, paoclgth, paocval) else {not paofch literal} innerarray else {not pa of char tyilvalue = 0) } end else if fsp^.form = reals then begin flush; if odd(offset) then outbyte(0); variantrec.r := fvalu.valp^.rval; outlong(variantrec.l1); outlong(variantrec.l2); end else {not a scalar or pointer} if valp <> NILpe} innerarray; flush; end; {dumparray} procedure dumprecord; var end_offset: addrrange; {for short variants} k: integer; fieldbit: bitrange; begin {inner record} with fvalu.valp^.kstruc^ do begin flush; if ( then with valp^ do case cclass of strctconst: {structure within the structure} if kstruc <> NIL then with kstruc^ do if scstp <> NIL then case scstp^.form of arrays: dumparray; records: dumprecord; pscstp^.align <> 1) and odd(offset) then outbyte(0); end_offset:=offset+scstp^.unpacksize; vctmp := scvcp; while vctmp <> NIL do begin with vctmp^ do if vid <> NIL then with vid^ do begin if fispackd then begin ower: if scvcp <> NIL then with scvcp^ do dmpcnst(scstp,vcval,packing,posn,width) end; {case form} pset: begin flush; if odd(offset) then outbyte(0); setsize := ((plgth+setelembits-1) div setelembits)  if scstp^.unpacksize <> 1 then fieldbit := (fldfbit+(8*ord(odd(offset)))) MOD 16 else fieldbit := fldfbit; dmpcnst(idtype,vcval,true, fieldbit,idtype^.bitsize); end else dmpcnst(idtype,vcval,false,0,0); vctmp := vctmp^.vc * setelemsize; outword(setsize); (* size in bytes *) $if bigsets$ if plgth > 0 then begin s := pval; while s <> NIL do with s^ do begin variantset.pad := 0; for j := 0 to oldsetwordsize-nxt; end end; if end_offset>offset then flush; if end_offset>offset then begin {fill out remainder of short variant} { DS.B end_offset-offset } for k := 1 to end_offset-offset do outputcodebyte(0); offset := end_offset; 1 do variantset.words[j] := 0; variantset.sett := val; if nxt = NIL then (* last set record *) limit := (plgth-1) MOD (oldsethigh+1) else limit := oldsethigh; for j := 0 to (limit div setelembits) do outwordend; end; end; {dumprecord} begin {dmpcnst} if fsp <> NIL then with fvalu do begin if fsp^.form = subrange then fsp := fsp^.rangetype; if fsp^.form = scalar then if packing then outpacked(ival) else {not packing(variantset.words[j]); s := nxt; end; end; $end$ $if not bigsets$ for w:=0 to mydiv(plgth-1,setelembits) do begin if w*16 in pval then packbuf:=packbuf+(-32768); b:=1; for i:=15 downto 1 do begin if (} if (fsp = boolptr) or (fsp = char_ptr) then outbyte(ival) else if fsp = intptr then begin flush; if odd(offset) then outbyte(0); outlong(ival); end else begin flush; if odd(offset) then outbyte(w*16)+i in pval then packbuf:=packbuf+b; if i>1 then b:=b+b; end; outword(packbuf); packbuf:=0; end; $end$ for w := 1 to fsp^.unpacksize - (setsize+setlensize) do outbyte(0); end; paofch: outpu0); if intval {enumerated type or shortint} then outword(ival) else escape(-8); end else if fsp^.form = pointer then begin flush; if odd(offset) then outbyte(0); offset := offset+4; outputcodelong(0); { DC.L 0 (ntpaoc(fsp^.aisstrng, fsp^.unpacksize, slgth, sval); bigpaoc: outputpaoc(fsp^.aisstrng, fsp^.unpacksize, paoclgth, paocval); otherwise error(682) end {case cclass}; end; {w:     wrdpair(fconexp,fwrdpairptr^.next) end else insertwrdpair := insertwrdpair(fconexp,fwrdpairptr^.next); end; end; { insertwrdpair } function insertlongpair(fconexp : csp; var flongpairptr : csp): csp; { add long size bound pair to pvar fstrptr : csp) : csp; var lgth: 0..strglgth; function scompare(length: shortint; var a,b: paoc): boolean; var i: 0..strglgth; equal: boolean; begin i:=0; equal:=true; while (i NIL) and putcode and (totalerrors = 0) then begin with fvalu.valp^ do begin isdumped := true; if (namep <> NIL) and (level = 1) then begin curglobaltemp := curairptr^.lower then begin if upper < flongpairptr^.upper then insertlongpair := insertnode(fconexp,flongpairptr) else if upper = flongpairptr^.upper then insertlongpair := flongpairptr else insertlongpair := insertloglobalname; curglobalname := NIL; outputdef(namep^,codephile.bytecount,relocatable,0); curglobalname := curglobaltemp; end; location := codephile.bytecount; end; offset := 0; packbit := 0; packbuf := 0; dmpngpair(fconexp,flongpairptr^.next) end else insertlongpair := insertlongpair(fconexp,flongpairptr^.next); end; end; { insertlongpair } $END$ function insertreel(fconexp: csp; var freelptr: csp): csp; {insert real constant icnst(fsp,fvalu,false,0,0); flush; if odd(codephile.bytecount) then outputcodebyte(0); end; end; {dumpstconst} function insertnode (fconexp : csp; var fpoolptr : csp) : csp; { add constant to pool list } begin {insertnode} with fconn list, ordered according to value} begin with fconexp^ do begin if freelptr = NIL then insertreel := insertnode(fconexp,freelptr) else if rval < freelptr^.rval then insertreel := insertnode(fconexp,freelptr) else if rexp^ do begin insertnode := fconexp; conlbl := NIL; next := fpoolptr ; fpoolptr := fconexp; end {with} end; {insertnode} $IF MC68020$ function insertwrdpair(fconexp : csp; var fwrdpairptr : csp): csp; { add word sizeval = freelptr^.rval {already in} then insertreel := freelptr else insertreel := insertreel(fconexp,freelptr^.next); end; end; {insertreel } function insertset (fconexp : csp; var fsetptr : csp) : csp; { insert set constant  bound pair to pool list } begin with fconexp^ do begin if fwrdpairptr = NIL then insertwrdpair := insertnode(fconexp,fwrdpairptr) else if lower < fwrdpairptr^.lower then insertwrdpair := insertnode(fconexp,fwrdpairptr) else if lowein list, ordered according to length } begin {insertset} with fconexp^ do begin if fsetptr = NIL then insertset := insertnode(fconexp,fsetptr) else if plgth < fsetptr^.plgth then insertset := insertnode(fconexp,fsetptr) r = fwrdpairptr^.lower then begin if upper < fwrdpairptr^.upper then insertwrdpair := insertnode(fconexp,fwrdpairptr) else if upper = fwrdpairptr^.upper then insertwrdpair := fwrdpairptr else insertwrdpair := insert else if (plgth = fsetptr^.plgth) and (pval = fsetptr^.pval) { already in } then insertset := fsetptr else insertset := insertset(fconexp,fsetptr^.next) end end; {insertset} function insertstring (fconexp : csp; ;     ptr^.slgth; if slgth < lgth then insertstring := insertnode(fconexp,fstrptr) else if (slgth = lgth) and (cclass = fstrptr^.cclass) and scompare(lgth,sval,fstrptr^.sval) {already in} then insertstring := fstlean of true: (r: real); false: (l1: integer; l2: integer); end; procedure dumpenum; var lcp: ctp; k: shortint; begin while enumhead <> NIL do begin fixreflist(enumhead^.enumlbl); lcp := enumhearptr else insertstring := insertstring(fconexp,fstrptr^.next) end end; {insertstring} function poolit ( konst : csp) : csp; { add constant to pool, if not already in, and return the csp for the constant in the pool } begin {d^.fconst; k := 0; while lcp <> NIL do {count 'em} begin k := k+1; lcp := lcp^.next; end; outputcodeword(k); lcp := enumhead^.fconst; while lcp <> NIL do with lcp^ do begin for k := 0 to spoolit} case konst^.cclass of paofch, strng : poolit := insertstring(konst,stringhead); pset : poolit := insertset(konst,sethead); reel : poolit := insertreel(konst,reelhead); $IF MC68020$ chk2_bounds : if konst^.siztrlen(namep^) do outputcodebyte(ord(namep^[k])); if odd(codephile.bytecount) then outputcodebyte(0); lcp := lcp^.next; end; enumhead := enumhead^.next; end; end; begin {dumpconsts} { emit set constants } p := setheae = wrd then poolit := insertwrdpair(konst,wrdpairhead) else {size = long} poolit := insertlongpair(konst,longpairhead); $END$ otherwise escape(-8); end {case} end; {poolit} procedure poolenum(* fsp: stp *); d; while p <> NIL do begin { for each set constant } fixreflist(p^.conlbl); { fix local refs to pooled constant } with p^ do begin { emit word containing size of set (in bytes) } $if bigsets$ outputcodeword( ( (plgt label 1; var lsp: stp; begin lsp := enumhead; while lsp <> NIL do if lsp = fsp then goto 1 else lsp := lsp^.next; fsp^.next := enumhead; fsp^.enumlbl := NIL; enumhead := fsp; 1: end; procedure dumpconsh + (setelembits-1)) div setelembits ) * setelemsize ); $end$ $if not bigsets$ outputcodeword(((plgth + 15) div 16) * 2) ; { DC.W } $end$ if plgth<>0 then begin $if bigsets$ s := pval; while s <> NIL do with s^ do ts; { emit the constant pool } $if bigsets$ const oldsetwordsize = (oldsethigh + 1 + setelemsize - 1) div setelemsize; $end$ var w : shortint; p : csp; $if bigsets$ s : setrecptr; (* current set record item *) j : shortin begin variantrec.pad := 0; for w := 0 to oldsetwordsize-1 do variantrec.words[w] := 0; variantrec.sett := val; if nxt = NIL then (* last set record *) limit := (plgth-1) MOD (oldsethigh+1) else limit :t; (* simple local counter *) limit : shortint; (* ordinal limit for set rec *) variantrec : record case boolean of true: (sett: set of setlow..oldsethigh); false: (pad: shortint; words: packed array [0..oldsetwo= oldsethigh; for w := 0 to (limit div setelembits) do outputcodeword(variantrec.words[w]); s := nxt; end; $end$ $if not bigsets$ variantrec.sett := pval; for w := 0 to (plgth - 1) div 16 do { for each word } rdsize-1] of shortint) end; $end$ $if not bigsets$ variantrec : record case boolean of true: (sett: set of setlow..sethigh); false: (pad: shortint; words: packed array[0..15] of shortint); end; $end$ variant : record case boo outputcodeword(variantrec.words[w]); $end$ end; {plgth<>0} end; {with} p := p^.next end; {while} { emit string constants } p := stringhead; while p <> NIL do { for each string constant } begin fixreflist(p^.;     locked; end; {clear} procedure getlocstorage(size: addrrange; var at: attrtype); begin lc := lc-size; if odd(lc) then lc := lc-1; if lc < lcmax then lcmax := lc; with at do begin addrmode := locinreg; if bodylev = 1 then llocated; end; {getreg} procedure getregattr( classwanted: regtype; var attr: attrtype ); begin with attr do begin regnum := getreg(classwanted); if classwanted = D then addrmode := inDreg else addrmode := inAreg; storage  begin regnum := SB; gloptr := currentglobal; end else begin regnum := localbase; gloptr := NIL; end; offset := lc; indexed := false; packd := false; access := direct; end; end; procedure free:= long; packd := false; end; end; {getregattr} function closestbasereg (* flevel: addrrange; var fdist: levrange): levrange *); var r: -1..maxreg; dist: levrange; tempdist: shortint; begin dist := reg[A,localbase].baselevconlbl); emitstringlit(p); p := p^.next; end; {while} { emit real constants } p := reelhead; while p <> NIL do begin fixreflist(p^.conlbl); variant.r := p^.rval; outputcodelong(variant.l1); outpuit( rt: regtype; rn: regrange ); begin with reg[rt,rn] do begin if (rt=A) and (usage <> other) then if usesleft > 0 then usesleft := usesleft-1 else escape(-8); if ((usesleft=0) or (usage=other)) and (allocstate <> locked) then tcodelong(variant.l2); p := p^.next; end; $IF MC68020$ { emit chk2 bound pairs } p := wrdpairhead; while p <> NIL do begin fixreflist(p^.conlbl); outputcodeword(p^.lower); outputcodeword(p^.upper);  allocstate := free; end; end; {freeit} function getreg(classwanted: regtype): regrange; label 1; var r: regrange; freewithreg,freebasereg: -1..maxreg; freelevel: shortint; { static level of free base register } begin  p := p^.next; end; p := longpairhead; while p <> NIL do begin fixreflist(p^.conlbl); outputcodelong(p^.lower); outputcodelong(p^.upper); p := p^.next; end; $END$ dumpenum; {emit enumerated consts} if classwanted = D then for r := 0 to maxreg do begin if reg[D,r].allocstate = free then goto 1 end else if classwanted = A then {requested A register} begin freewithreg := -1; freebasereg := -1; freelevel := maxplevel+1; for r := 0 to SB- end; {dumpconsts} procedure clear(newproc: boolean); { initialize register descriptors. Newproc = true for initial call for each procedure body } var rn: regrange; rt: regtype; begin for rt := A to F do for rn := 0 to maxreg1 do with reg[A,r] do if allocstate = free then case usage of other: goto 1; {allocate} basereg: if baselevel < freelevel then begin freebasereg := r; freelevel := baselevel end; withrecbase: freewithreg := r; end; {case}  do if not((rt=A) and (rn in dedicatedregs)) then with reg[rt,rn] do begin allocstate := free; usesleft := 0; if not newproc and (usage = withrecbase) then curcontents^ := oldcontents; usage := other; end; with reg[A,localbase] dif freebasereg >= 0 then begin r := freebasereg; forgetbasereg(r); goto 1 end else if freewithreg >= 0 then begin r := freewithreg; forgetbasereg(r); goto 1 end; end {requested A register} else if classwanted = F then for r := 0 to maxreg doo begin allocstate := locked; usesleft := maxint; usage := basereg; baselevel := bodylev; end; with reg[A,SB] do begin allocstate := locked; usesleft := maxint; usage := basereg; baselevel := 1; end; reg[A,SP].allocstate :=  begin if reg[F,r].allocstate = free then goto 1 end; errorwithinfo(684, 'Expression too complex in line ' + itostr(linenum)); r := 0; clear(false); { aviod same error again } 1: getreg := r; reg[classwanted,r].allocstate := a<     el-flevel; closestbasereg := localbase; r := SB-1; while (dist > 0) and (r >= 0) do begin with reg[A,r] do if usage = basereg then begin tempdist := baselevel-flevel; if tempdist >= 0 then if tempdist < dist then begin disldist); if ldist = 0 then with reg[A,r1] do begin getbasereg := r1; usesleft := usesleft+1; allocstate := allocated; end else {chase static link} begin with lop do begin addrmode := locinreg; regnum :t := tempdist; closestbasereg := r end; end; r := r-1; end; fdist := dist; end; {closestbasereg} procedure movestatic(* flevel: addrrange; var at: attrtype *); { generate code to move base address of accessible activation having = r1; indexed := false; offset := staticdisp; gloptr := NIL; end; getregattr(A,rop); emit2(movea,lop,rop); if ldist >= 2 then begin lop.regnum := rop.regnum; for k:=2 to ldist do emit2(movea,lop,rop); static level flevel. Emits ' MOVE.L ,"at" } var ldist,k: levrange; closereg: regrange; op1,op2: attrtype; begin ldist := bodylev-flevel; if ldist = 0 then {base of current activation} with op1 do begin addrmode := in end; getbasereg := rop.regnum; with reg[A,rop.regnum] do begin usage := basereg; baselevel := flevel; allocstate := allocated; usesleft := 1 end; end; {ldist<>0} end; {flevel<>bodylev} end; {getbAreg; regnum := localbase; emit2(move,op1,at); end else {intermediate} begin closereg := closestbasereg(flevel,ldist); if ldist <= 1 then with op1 do begin if ldist = 0 then begin addrmode := inAreg; regnum := closerasereg} procedure forgetbasereg(* r: regrange *); { erase unallocated activation or WITH record base register contents for register A.r } begin with reg[A,r] do if allocstate = free then begin if usage = withrecbase then curconeg; end else begin addrmode := locinreg; regnum := closereg; offset := staticdisp; indexed := false; gloptr := NIL; end; emit2(move,op1,at); end else {2 or more levels distant} begin with op1 do begin tents^ := oldcontents; usage := other; end; end; {forgetbasereg} procedure forgetbaseregs; { erase unallocated activation or WITH record base register contents for all A registers } var r: regrange; begin for r := 0 to m addrmode := locinreg; regnum := closereg; offset := staticdisp; indexed := false; gloptr := NIL; end; getregattr(A,op2); emit2(movea,op1,op2); op1.regnum := op2.regnum; for k := 1 to ldist-2 do emit2(moveaaxreg do forgetbasereg(r); end; {forgetbaseregs} function addrinreg(* fexp: exptr): boolean *); begin with fexp^.attr^ do addrinreg := (addrmode = locinreg) and (offset = 0) and (access = direct) and (gloptr = NIL) and not in,op1,op2); with reg[A,op2.regnum] do begin usage := basereg; baselevel := flevel+1; allocstate := free; end; emit2(move,op1,at); end; { >= 2 levels distant} end; {intermediate} end; {movestatic} function gedexed; end; procedure liftattr(* father,son: exptr *); { propagate attributes up tree, but preserve father's storage size and next attribute pointer } var s: stortype; p: attrptr; begin with father^,attr^ do begin s :tbasereg(* flevel: addrrange): regrange *); var r1,r2: regrange; ldist,k: levrange; lop,rop: attrtype; begin if flevel = 1 then getbasereg := SB else if flevel = bodylev then getbasereg := localbase else begin r1 := closestbasereg(flevel,= storage; p := next; attr^ := son^.attr^; storage := s; next := p; end; end; {liftattr} procedure getsignbit(fsp: stp; fattr: attrptr); var lo,hi: valu; begin if fsp^.form = subrange then fsp := fsp^.rangetype;<     num; offset := 0; gloptr := NIL; storage := tstorage; end else { simulate forgetbasereg } begin if usage = withrecbase then curcontents^ := oldcontents; usage := other; end; if toffset <> 0 then begin taddrmode := adnd (ival <= 32767) then begin storage := wrd; signbit := true; end else if (ival >= 0) and (ival <= 65535) then begin storage := wrd; signbit := false; end else begin storage := long; signbit := true; end; { consider desired storagedrmode; {fexp^.attr^.}addrmode := inAreg; tstorage := storage; if (toffset < -32768) or (toffset > 32767) then {fexp^.attr^.}storage := long else {fexp^.attr^.}storage := wrd; with op do begin addrmode := immed and signbit } if store > storage then if (not signed) and (ival < 0) then begin storage := succ(store); signbit := true; end else begin storage := store; signbit := signed; end else if store = storage then if signed and  fattr^.signbit := (fsp <> boolptr) and (fsp <> char_ptr); end; {getsignbit} procedure checkoffset(fexp: exptr); var op: attrtype; offsetmin,offsetmax : shortint; toffset: integer; taccess : accesstype; tstorage : stortype; taiate; smallval := toffset; emit2(adda,op,fexp^.attr^); end; storage := tstorage; addrmode := taddrmode; end; indexed := tindexed; access := taccess; end; end; $END$ end; procedure freeregs(* atddrmode : addrtype; tindexed : boolean; begin with fexp^, attr^ do $IF MC68020$ if indexed and (addrmode in [shortabs,longabs,prel,namedconst,labelledconst]) then begin tindexed := indexed; indexed := false; taccess := atrp: attrptr *); begin with attrp^ do if addrmode = inDreg then freeit(D,regnum) else if addrmode = inFreg then begin freeit(F,regnum); $IF not MC68020$ freeit(F,regnum+1); $END$ end else if addrmode in memorymccess; access := direct; loadaddress(fexp,true); indexed := tindexed; access := taccess; end; $END$ $IF not MC68020$ begin if indexed then begin offsetmin := -128; offsetmax := 127; end else begin offsetmin :odes then begin if addrmode = locinreg then freeit(A,regnum); if indexed then freeit(D,indexreg); end; end; {freeregs} function min(a,b: integer): integer; begin if a NIL)))) or (offset < offsetmin) or (offset > offsetmax) then begin tindtion mydiv(a,b: integer): integer; begin mydiv := (a - (a mod b)) div b; end; procedure fixliteral(* fexp: exptr; store: stortype; signed: boolean *); { fexp is a literal node. Storage and signed are the desired values for fexexed := indexed; indexed := false; taccess := access; access := direct; if (offset > 32767) or (offset < -32768) or ((gloptr <> NIL) and (offset <> 0)) then begin toffset := offset; offset := 0; end else toffset := p^.attr^.storage and fexp^.attr^.signbit. If this literal cannot be represented in a data item with those attributes, its attributes will be set to reflect the minimum size that it can be represented in.} begin with fexp^, attr^, litval do be0; if not addrinreg(fexp) then loadaddress(fexp,true) else with reg[A,regnum] do if (usage <> other) then if (usesleft > 1) then {make copy} begin getregattr(A,op); tstorage := storage; emit2(lea,attr^,op); regnum := op.reggin { determine minimum necessary } if (ival >= -128) and (ival <= 127) then begin storage := bytte; signbit := true; end else if (ival >= 0) and (ival <= 255) then begin storage := bytte; signbit := false; end else if (ival >= -32768) a=     not signbit then begin storage := succ(storage); signbit := true; end else if not signed and signbit then if ival < 0 then begin storage := succ(storage); signbit := true; end else signbit := false else {store < storage} es: shortint); procedure moduleinit(modulenameptr: alphaptr); procedure modulewrapup(countglobals: boolean); procedure outputcodebyte (b : shortint); procedure outputcodeword (w : shortint); procedure outputcodelong (l : integer); p if not signbit then begin storage := succ(storage); signbit := true; end; end; end; { fixliteral} function itostr(i:integer) : string80; var s: string80; j: shortint; chrstr: string[1]; begin s := ''; chrstr[0] := crocedure dumpstconst(fsp: stp; var fvalu: valu); procedure importexportstart(s: alphaptr); procedure importexportwrapup; procedure outputextdef(name:alpha;loc: addrrange; ext: alpha); type lstring = string[255]; var chr(1); while i > 0 do begin j := i MOD 10; i := i DIV 10; chrstr[1] := chr(ord('0')+j); s := chrstr + s; end; itostr := s; end; procedure genutilsinit; begin {genutils} codeerror := false; nullstring := ''; odeerror,codeout,modulecodeout: boolean; force_unpack : boolean; (* force unpacking of 8 or 16 bit unsigned integer subrange fields ? *) procedure fixbyte( pc: addrrange; value: shortint ); procedure fixword( pc: addrrange; value: s dot_code := '.CODE'; with SBdir do begin addrmode := inAreg; regnum := SB; storage := long; end; with SBind do begin addrmode := locinreg; regnum := SB; indexed := false; gloptr := NIL; end; with A6dir do begin addrmode hortint ); $IF MC68020$ procedure fixlong( pc: addrrange; value: integer ); $END$ procedure fixreflist( listptr: reflistptr ); procedure outputdef(name: string255; loc: addrrange; t: reloctype; extnumber: shortint); procedure := inAreg; regnum := localbase; storage := long; end; with A6ind do begin addrmode := locinreg; regnum := localbase; indexed := false; gloptr := NIL; end; with SPdir do begin addrmode := inAreg; regnum := SP end; with SPind do getmultattr (rcount: shortint; A1isfree: boolean; var at: attrtype); procedure callstdproc(s: alpha); procedure callIOproc(s: alpha); procedure getprokconst(fprocp: ctp; var at : attrtype); procedure getbrattr (var flbl: addrrange; d begin addrmode := locinreg; regnum := SP; offset := 0; indexed := false; gloptr := NIL; end; with SPplus do begin addrmode := postincr; regnum := SP end; with SPminus do begin addrmode := predecr; regnum := SP end; with immed0 do beefined: boolean; var battr: attrtype); procedure emitshift(shiftcount: bitrange; reg: regrange; shiftype: opcodetype; shiftsize: stortype); procedure getcomplmaskattr (bitoffset, bitsize, masksize: shortint; var at : attrtype); procedugin addrmode := immediate; smallval := 0 end; end; {genutilsinit} re getmaskattr (bitoffset, bitsize, masksize: shortint; var at : attrtype); {standard scratch attribute records} var SBdir,SBind,A6dir,A6ind,SPdir,SPind,SPplus,SPminus,immed0: attrtype; {constant pool stuff} var sethead,stringhead,re { file GENUTILDEF } import globals,sysglobals,compinit,codegen,loader, symtable,compio; export procedure outputref(name: alpha; loc: addrrange; t: reftype); procedure codewrapup(term: termtype); procedure file_warn(errornum,iorelhead: csp; enumhead: stp; $IF MC68020$ wrdpairhead, longpairhead : csp; $END$ function poolit (konst : csp): csp; procedure poolenum(fsp: stp); procedure dumpconsts; {run-time simulation stuff} type alloctype = (free,all=      {file GENDEFINE} import globals,symtable,compio,compinit,loader, sysglobals; export type opcodetype = (add,adda,addi,addq,andd,andi,asl,asr, bra,bdummy,bhi,bls,bcc,bcs,bne,beq,bvc, bvs,bpl,bmi,bge,blt,bgt,ble, bchg,bclr,bsebute records } maxLCpatch: reflistptr; linenum: integer; bodylev,proclev: levrange; PCperline: integer; modulebody,ovflcheck,iocheck, rangecheck,shortcircuit: boolean; callmode: callmodetype; curproc: ctp; Pt,btst,chk,clr, cmp,cmpa,cmpm,cmpi,divs, $IF MC68020$ divsl,extb,bfexts,bfextu,bfins,chk2, $END$ ext,jmp,jsr,lea,link,lsl,lsr, move,movea,movetoCCR,movefromSR,moveI,movem,moveq, muls,neg,nott,orr,pea,rts, st,sf,shi,sls,scc,scs,sne,sCcount: integer; {Structured Constants} dedicatedregs: set of regrange; memorymodes: set of addrtype; conditionis: opcodetype; {Files} codefileopen: boolean; file_name: fid; codephile: record fileid: file;ocated,locked); usetype = (basereg,withrecbase,other); register = record allocstate: alloctype; usesleft: 0..maxint; case usage: usetype of basereg: (baselevel: levrange); withrecbase: (curcontents: attrptr; eq,svc, svs,spl,smi,sge,slt,sgt,sle, sub,suba,subi,subq,swap,trap,trapv,tst,unlk $IF MC68020$ {68881 instructions} ,fmovem,fmove,fsqrt,fabs,fcos,fsin,flogn, fatan,fetox,fadd,fcmp,fdiv,fneg,fmul,fsub, flognp1,fblt $END$ ); oldcontents: attrtype); other: () end; var reg: array[regtype,regrange] of register; sourceblock,sourcesize: integer; procedure clear(newproc: boolean); procedure getlocstorage(size: addrrange; var at: attrtype);  reftype = (abs16,abs32,rel16,rel16v,glob16,rel32); procedure genbody(curbody: stptr; fprocp: ctp); procedure codegeninit; const SB = 5; (* A5 is the stack base pointer *) localbase = 6; (* A6 is local stack frame base regiprocedure freeit(rt: regtype; rn: regrange); function getreg(classwanted: regtype): regrange; procedure getregattr(classwanted: regtype; var attr: attrtype); function closestbasereg(flevel: addrrange; var fdist: levrange): levrange; procester *) SP = 7; (* A7 is top of stack pointer *) escapecodedisp = -2; FIBptrdisp = -6; lastrecovdisp = -10; heapptrdisp = -14; staticdisp = 8; (* displacement of static link from stack marker *) {stackdure movestatic(flevel: addrrange; var at: attrtype); function getbasereg(flevel: addrrange): regrange; procedure forgetbasereg(r: regrange); procedure forgetbaseregs; function addrinreg(fexp: exptr): boolean; procedure liftattr(fathefudge = 700; (* allowance for run time stack temporaries *) coderecs = 4; (* number of 512 byte code buffers *) maxdir = 38; type dirange = 0..maxdir; libdirectory = array[dirange] of direntry; bytebufs = packed array[0.r,son: exptr); procedure getsignbit(fsp: stp; fattr: attrptr); procedure checkoffset(fexp: exptr); procedure freeregs(attrp: attrptr); function mydiv(a,b: integer): integer; procedure fixliteral(fexp: exptr; store: stortype; signed: .511] of byt; codebuffer = array[1..coderecs] of bytebufs; sizetype = (sby,sw,sl,fp,ub,uw); masktype = packed array[0..15] of boolean; flagtype = packed record case boolean of{8 bits} true: (typ: reloctype; size: sizetype; boolean); procedure codeinit; function itostr(i: integer) : string80; procedure genutilsinit;  patchable: boolean; valueextend: boolean; longoffset: boolean); false: (b: byt); end; var globalattrlist: ^attrptr; { points to the current statements attr list } freeattr: attrptr; { points to a list of free attri>      buffer: ^codebuffer; bytecount, windowptr: addrrange; headerblock, startblock: shortint; end; defile: record fileid: file; buffer: ^bytebufs; bite, block: shortint; end; refile: record fileid: file; buf {file GLOBALS} (*BASIC SYMBOLS*) SYMBOLS = (IDENT,COMMA,COLON,SEMICOLON,LPARENT, RPARENT,DOSY,TOSY,DOWNTOSY,ENDSY, UNTILSY,OFSY,THENSY,ELSESY,BECOMES, LBRACK,RBRACK,ARROW,PERIOD,BEGINSY, IFSY,CASESY,REPEATSY,WHILESY,FORSY, WITfer: ^bytebufs; bite, block: shortint; end; totalbytesofcode : addrrange; startaddr : addrrange; { relative start address } defstartblock,refstartblock,extstartblock : shortint; sizeofdefs,sizeofrefs,sizeofHSY,GOTOSY,LABELSY,CONSTSY,TYPESY, VARSY,PROCSY,FUNCSY,PROGSY,INTCONST, REALCONST,STRINGCONST,NOTSY,MULOP, ADDOP,RELOP,SETSY,PACKEDSY,ARRAYSY, RECORDSY,FILESY,modulesy,importsy, exportsy,implmtsy,othrwisesy,rangesy, dollarsy,OTHERSY, {exts : integer; libraryptr : ^libdirectory; nextmodule : dirrange; const max_module_nesting {minus 2} = 8; var def_ext_table: array[1..max_module_nesting] of string[15]; def_ext_top: shortint; ensure_valid_cond***** MODCAL SYMBOLS *****} FORWARDSY,externlsy,trysy,recoversy, anyvarsy); OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS, OROP,LTOP,LEOP,GEOP,GTOP,NEOP,EQOP, INOP,NOOP); SETOFSYS = SET OF SYMBOLS; optionlist = (emptyop,aliasop,allowition_code: boolean; OVERLAY,ADDRESS: string[7]; EXEC: string[4]; packed,ansiop,callabsop, ccifop,ccendop,codeop,copyrightop, debugop,defop,floatop,heapdisposeop, inclop,iochkop,linesop,listop, numop,modcalop,overlayop, overlaysizeop,ovlfchkop,pageop, pagewidthop,partevalop,PCop, {file GENMOVEDEF} import globals,codegen,sysglobals; export PROCEDURE PACK (LHS, RHS : EXPTR); procedure packtopack(lhs,rhs: exptr); procedure maskboolexpr(fexp: exptr); procedure emitcheck(fexp: exptr; target: stp; ass rangeop,refop,saveop,searchsizeop, searchop,stackchkop,strposop, sysprogop,tablesop,ucsdop,warnop,illegal); optionarraytype = array[optionlist] of string[optnsize]; listswitch = (listnone,listerronly,listfull); termtype = (normaignstmt: boolean); function needscheck (fexp: exptr; target: stp; assignstmt: boolean): boolean; PROCEDURE BITADDRESS(FEXP: EXPTR); PROCEDURE UNPACK (FEXP : EXPTR); procedure loadaddress(fexp: exptr; fromcheckoffset: booleal,abort); infolist = (predeclared,mustinitialize, cantassign,nonstandard, modcalreq,sysprogreq,ucsdreq); infobits = set of infolist; CURSRANGE = 0..MAXCURSOR; SYMBUFARRAY = PACKED ARRAY [CURSRANGE] OF CHAR; (*DATA STRUCTURES*) BITRANGn); procedure pushaddress(fexp: exptr); procedure moveaddress(fexp: exptr; var dest: attrtype); procedure loadvalue(fexp: exptr); procedure pushvalue(fexp: exptr); procedure movevalue(fexp: exptr; var at: attrtype); procedure genpaoE = 0..BITSPERWORD; LEVRANGE = 0..MAXPLEVEL; DISPRANGE = 0..DISPLIMIT; dope = record loboundid,hiboundid: ctp; end; dopeptr = ^dope; STRUCTFORM = (SCALAR,SUBRANGE,reals,POINTER, prok,funk,POWER,cnfarrays,ARRAYS,substring, RECORDS,fchcond (fcond: exptr; var flbl: reflistptr; defined: boolean); procedure gencond(fcond: exptr; var flbl: reflistptr; defined: boolean); FILES,TAGFLD,VARIANT); varlab = record lo,hi: integer; end; DECLKIND = (STANDARD,DECLARED,SPECIAL); STRUCTURE = RECORD unpacksize: addrrange; align: shortint; sizeoflo: boolean; ispackable: boolean; bitsize: bitrange; >     tread,spunitwrite,spblockread, spblockwrite,spsetstrlen,spconcat, spstrmove,spmoveleft,spmoveright,spscan, spgotoxy,spfillchar, {Preceding are SPECIAL, rest are STANDARD} spmark,sprelease,spescape,spesccode, spget,spput,spsin,spcos,spexp, spe); (*LABELS*) LABELP = ^ USERLABEL; USERLABEL = RECORD LABVAL: shortint; {user's label number} NEXTLAB: LABELP; {link to next label in block} defined: boolean; {label has been seen on a stmt} isrefed: boolean; {label has beeln,spsqrt,sparctan,spmemavail,spnewwords, spdelete,spinsert,spcopy,sppos, spltrim,sprtrim,spstrrpt, {**** the following HP 'clone' string routines must be grouped together with current 'first' and 'last' for analysis and codegen} spstrden used} labrefs: reflistptr; {refs to this label} nonlocalref: boolean; {target of a nonlocal goto} staticlevel: levrange; location: addrrange; {relative location in the codefile} isnlrefed: boolean; {a nonlocal ref has been seen (in c signbit: boolean; info: infobits; {Modcal characteristics} CASE FORM: STRUCTFORM OF SCALAR: (CASE SCALKIND: DECLKIND OF DECLARED: (FCONST: CTP; enumlbl: reflistptr; next: stp) ); SUBRANGE: (RANGETYPElete,spstrinsert,spstr,spstrpos, spstrappend, {****} spunitclear,spunitbusy,spunitwait); (*NAMES (reprise) *) IDCLASS = (TYPES,KONST,VARS,FIELD,PROX,FUNC,ROUTINEPARM); SETOFIDS = SET OF IDCLASS; vartype = (shortvar,longvar,relvar,localvar, : STP; MIN,MAX: integer); prok,funk:(params: ctp; parmlc: addrrange); POINTER: (ELTYPE: STP); POWER: (ELSET: STP; $if bigsets$ setmin, setmax : integer $end$ $if not bigsets$ setmin,setmax: shortint $end$ );  valparm,cvalparm,refparm,anyvarparm, strparm,procparm,funcparm,boundparm,dopeparm); IDENTIFIER = RECORD namep: alphaptr; LLINK, RLINK: CTP; IDTYPE: STP; NEXT: CTP; info: infobits; CASE KLASS: IDCLASS OF KONST: (VALUEScnfarrays, ARRAYS: (AELTYPE,INXTYPE: STP; cnf_index : dopeptr; { only used for cnfarrays } case AISPACKD: BOOLEAN of false: (AELSIZE: addrrange; strucwaspackd: boolean); true: (AELBITSIZE: bitrange; : valu); ROUTINEPARM, VARS: (VLEV: LEVRANGE; VADDR: ADDRRANGE; globalptr: alphaptr; case VTYPE: vartype of cvalparm: (VPTRADDR: ADDRRANGE); shortvar,longvar,relvar: (absaddr: valu); procparm,funcparm: (proktype: CASE AISSTRNG: BOOLEAN OF TRUE: (MAXLENG: 0..STRGLGTH))); substring: (); RECORDS: (FSTFLD: CTP; RECVAR: STP); FILES: (FILTYPE: STP); TAGFLD: (TAGFIELDP: CTP; FSTVAR: STP; hasfixedpart: boolean); VARIANT: (NXstp); dopeparm: (firstparm: ctp)); FIELD: (FLDADDR: ADDRRANGE; CASE FISPACKD: BOOLEAN OF TRUE: (FLDFBIT: BITRANGE); false: (strucwaspackd: boolean) ); PROX, FUNC: (CASE PFDECKIND: DECLKIND OF SPECIAL,STANDARTVAR,SUBVAR: STP; VARVAL: varlab; vflds: ctp); END; (*Predeclared procedures and functions*) spkeys = (spabs,spsqr,spchr,spodd,spord,spround,sptrunc, splength,spstrlen,spstrmax,sppred,spsucc, sphex,spoctal,spbinary,spnew,spdispose, spaddr,spD: (SPKEY: spkeys); DECLARED: (PFLEV: LEVRANGE; alias: boolean; othername: alphaptr; paramlc: ADDRRANGE; FORWDECL,extdecl,isrefed, isexported,isdumped,inscope: BOOLEAN; location : addrrange; {rel addr} exit_location: addsizeof,spcall,spclose,spwrite, spwriteln,spread,spreadln,spreaddir, spwritedir,spstrwrite,spstrread,spreset, sprewrite,spopen,spappend,spseek,spposition, spmaxpos,splinepos,sppage,spprompt,spoverprint, speoln,speof,sppack,spunpack,sphalt, spunirrange; forwid: shortint; { used to make a forward proc unique } case idclass of prox: (ismodulebody: boolean); func: (pfaddr: addrrange; assignedto: boolean) ) ) END; DISPLAYSCOPE = (RECORDscope,MODULEscope,BLOCKscope,WITHscop?     ode gen)} uniquelabid: shortint; {used in conjunction with isnlrefed} try_level : integer; { JWH 9/26/91 } END; (* Modules *) modstateptr = ^modulestaterec; modinfoptr = ^moduleinforec; modulestaterec = record {Describes one attr: attrptr; num_ops: shortint; { Number of operands below this point in the tree } case eclass: exprs of eqnode,nenode,ltnode,lenode,gtnode, genode,innode,subsetnode,supersetnode, unionnode,diffnode,intersectnode, concatnode,addno instance of a module} modinfo: modinfoptr; {link to module's inforec} defineids: ctp; {tree of IDs defined in this instance} nextmodule, {link in list containing this state} defmodule, {list of modules in my define sectde,subnode,mulnode, divnode,modnode,shftnode,ornode,andnode: (opnd1,opnd2: exptr); negnode,notnode,floatnode,derfnode,bufnode, absnode,chrnode,oddnode,ordnode,succnode, prednode,strlennode,strmaxnode,roundnode, sqrnode,truncnode: ion} contmodule: {previous instance of this module} modstateptr; end; moduleinforec = record {Describes a module} modinitbody: ctp; laststate: modstateptr;{last instance} needscall, {module body called?} isimplement (opnd: exptr); idnode: (symptr: ctp); subscrnode,substrnode: (arayp,indxp: exptr; case exprs of substrnode: (lengthp: exptr) ); selnnode: (recptr: exptr; fieldptr: ctp); unqualfldnode: (withstptr: stpted: boolean;{concrete def'n seen?} impmodule, usemodule: modstateptr;{modules USEd by me} modulefwptr, {used to implement dangling pointers} useids: ctp; {IDs USEd by me} curindefine: boolean; {within my define section?} { ** Hour; fieldref: ctp); litnode: (litval: valu); fcallnode: (fptr: ctp; actualp: elistptr); setdenonode: (setcstpart: valu; setvarpart: elistptr); end (*expr*); (* Statements *) clabptr = ^clabrec; {CASE sekeeping info ** } {these fields save global variables between instances} {of a module; they are NOT valid within it.} svffile: ctp; svLC: addrrange; end; (* Expressions *) exptr = ^expr; stptr = ^stmt; elistptr = ^explist; explist = recordstatement labels} clabrec = record temptr, {links labels of same stmt} clabp: clabptr; {links all labels in CASE, in order} cstmt: stptr; {stmt labelled by this label} lowval,hival: integer; {label value(s nextptr: elistptr; case (* *) boolean of false: (expptr: exptr); true: (lowptr,hiptr: exptr) end; exprkind = (cnst,vrbl,xpr); exprs = (eqnode,nenode,ltnode,lenode,gtnode, genode,innode,subsetnode,superset)} end; stmts = (becomest,pcallst,casest,compndst,forst, gotost,ifst,repst,tryst,whilest, withst,emptyst,endofbodyst); stmt = record next: stptr; lineno: integer; sflags: packed record rangecheck,shortcircuit, iocheck,ovfnode,unionnode, diffnode,intersectnode,addnode,subnode,mulnode, divnode,modnode,shftnode,ornode,andnode, negnode,notnode,floatnode,derfnode,bufnode, absnode,chrnode,oddnode,ordnode,succnode, prednode,strlennode,strmaxnode,roundnode,sqrnode, lcheck: boolean; callmode: callmodetype; end; $IF FULLDUMP$ snum: shortint; (* for printing tree *) $END$ labp: labelp; (* user label for stmt *) tablelist: reflistptr; (* used only if member of a CASE *) truncnode,idnode,subscrnode,concatnode,substrnode, selnnode,unqualfldnode,litnode,fcallnode,setdenonode); expr = record ekind: exprkind; etyptr: stp; $IF FULLDUMP$ echain: exptr; enum: shortint; (* for printing tree *) $END$  refcount: shortint; (* used only if member of a CASE *) case sclass: stmts of becomest: (lhs,rhs: exptr); pcallst: (psymptr: ctp; actualp: elistptr); casest: (selecter: exptr; maxlab,minlab: clabptr; ?      {not used} notice: string[80]; {whatever comments may be desired} directory_size: integer; {size of module directory,in bytes} module_size: integer; {total size of module, in bytes} executable: boolean; {module is exs*) (* Compiler-OS interface *) systemglobals: alpha; sysglobalptr: alphaptr; (* Allocation control *) LC,LCMAX:ADDRRANGE; (* LOCATION COUNTER *) (*SWITCHES*) PRTERR,GRANGECHECK,gshortcircuit,Decutable, has start address} relocatable_size: integer; {relocatable bytes requested} relocatable_base: integer; {current origin relocatable code} global_size: integer; {number of global bytes requested} global_base: inEBUGGING, UCSD,MODCAL,stdpasc,sysprog,aliasok, GIOCHECK,govflcheck,switch_strpos, gstackcheck,BPTONLINE,tables,putcode, saveconst,DP,oldDP,syntxerr,warn, listabort,list_option_L, beforefirsttoken,listPC,heapdispose, sawkeyboard, firstmt, otherwyse: stptr; nrlabs, nrstmts: shortint); compndst: (cbody: stptr); forst: (ctrl,init,limit: exptr; incr: shortint; fbody: stptr); gotost: (target: labelp); ifst: (ifcond: exptr; tru,fateger; {A5 relative origin of global area} ext_block, {module relative block of EXT table} ext_size, {size of EXT table, in bytes} def_block, {module relative block of DEF table} def_size, {sizls: stptr); repst, whilest: (rcond: exptr; rbody: stptr); tryst: (tbody,recov: stptr); withst: (wbody: stptr; refexpr: exptr; refbit: addrrange); emptyst, endofbodyst:() end (*stmt*); DISPLAYFRAME = RECORD e of DEF table, in bytes} source_block, {module relative block of DEFINE SOURCE} source_size, {size of source, in bytes} text_records: integer; {number of TEXT records} morebytes: packed array[0..(255-fixedpart FNAME: CTP; CASE OCCUR: DISPLAYscope OF BLOCKscope,MODULEscope: (FFILE: CTP; FLABEL: LABELP; FMODULE, available_module: MODSTATEPTR); WITHscope: (wnodeptr: stptr); END; structnodeptr = ^structnodetype; structnodetype )] of byt; end; (*--------------------------------------------------------------------*) VAR (* Scanner *) (* These 4 vars MUST be in this order *) (* for IDSEARCH !! *) SYMCURSOR: CURSRANGE; (*CURRENT SCANNING INDE= record sp: stp; val: valu; next: structnodeptr; end; floatoptype = (flt_on, flt_off, flt_test); fkind = (norml,specil); searchlisttype = array[1..maxint] of fid; string10 = string[10]; string15 = string[15]; overlaylisttype = arrayX IN SYMBUF*) SY: SYMBOLS; (*SYMBOL FOUND BY INSYMBOL*) OP: OPERATOR; (*CLASSIFICATION OF LAST OPERATOR SYMBOL*) ID: ALPHA; (*LAST IDENTIFIER FOUND*) symbuf: symbufarray; symblk[1..maxint] of string15; sourceinfotype = array[1..maxinfiles] of record oldsymblk,oldfilepos,oldrelinum: integer; oldsymcursor,oldlinestart: cursrange; filename: fid; oldftype: fkind; end; { declarations for module header } const : integer; (* LAST BLOCK READ *) filepos: INTEGER; (* Next block in source file*) LINESTART: CURSRANGE; (* Index into SYMBUF*) ftype: fkind; srcindex: 1..maxinfiles; (* Top of SOURCE fixedpart = 142; { bytes } type module_directory = packed record date: daterec; {date of creation} revision: daterec; {producer's revision date number} producer: char; {C = compiler} system_id: 0..255; INFO stack*) sourceinfoptr: ^sourceinfotype; VAL: valu; (*VALUE OF LAST CONSTANT*) LGTH: INTEGER; (*LENGTH OF LAST STRING CONSTANT*) uminus: boolean; (*if previous symbol was unary minu@     sawlisting,strpos_warn, sawinput,sawoutput: BOOLEAN; allow_packed : boolean; temp_put : boolean; float: floatoptype; gcopyright: string[80]; timestring: string[8]; float_flag: string[8]; refilesize,defilesize: integer; points *) totalwarnings, totalerrors, relinum, (* relative line no in current input file *) lasterrln, SCREENDOTS, (* number of lines seen so far *) STARTDOTS: INTEGER; todaysdate: stri refvolname,defvolname: string[vidleng+1]; { allow for ':' } gcallmode: callmodetype; aliasptr: alphaptr; initial_heap: anyptr; inbody, (*Parsing in executable code *) indefinesection: boolean; (*Parng[9]; (* date in form dd-mmm-yy *) linelevel,linlevatstart: shortint; maxoverlays,maxsearchfiles, searchfilestop,overlaytop: shortint; overlaylistptr: ^overlaylisttype; searchlistptr: ^searchlisttype; modulectp: ctp; sing in define section of a module *) INTPTR,shortintptr,REALPTR, (*Pointers to standard type nodes*) CHAR_PTR,BOOLPTR,anyptrptr,cant_deref, anyfileptr,TEXTPTR,STRGPTR: STP; ioresultptr, keyboardptr,listingptr, inputptr,output globaldate: daterec; globaltime: timerec; curglobalname,gnamep,currentglobal: alphaptr; importexportext,idinimport: boolean; symbolstart: cursrange; CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS, BLOCKBEGSYS,modulebegsys,SELECTSYS, FAptr: CTP; (*Pointers to standard variable nodes*) (* Trees *) curexp: exptr; (*points to current expression*) $IF FULLDUMP$ firstexp,lastexp: exptr; (*'echain' list of expressions*) sctr,ectr: shortintCBEGSYS,STATBEGSYS,TYPEDELS: SETOFSYS; power_table: array[0..bitsperword-2] of integer; uniquenum: shortint; save_escape: integer; save_ioresult: shortint; gen_error: boolean; body_try_level : integer; { JWH 9/26/91 } pa; (* for tree printout *) $END$ (* Symbol table *) LEVEL,levelatstart: LEVRANGE; (*CURRENT STATIC LEVEL*) display_ok_to_import, TOP: DISPRANGE; (*TOP OF DISPLAY*) disdef: record {describes type id brsing_try_level : integer; { JWH 9/26/91 } (*--------------------------------------------------------------------*) CONST optionarray = optionarraytype ['','ALIAS','ALLOW_PACKED','ANSI','CALLABS','IF','END', 'CODE','COPYRIGHT','DEBUG','DEF','eing defined} level: -1..displimit; id: alphaptr; end; DISX: -1..displimit; (*LEVEL OF LAST ID FOUND BY SEARCHID*) gstate,gcurstate: modstateptr; (*MODULE of last id found by SEARCHID*) sysinfo: infobits; FLOAT_HDW', 'HEAP_DISPOSE','INCLUDE','IOCHECK','LINES', 'LIST','LINENUM','MODCAL','OVERLAY', 'OVERLAY_SIZE','OVFLCHECK','PAGE', 'PAGEWIDTH','PARTIAL_EVAL','CODE_OFFSETS', 'RANGE','REF','SAVE_CONST','SEARCH_SIZE', 'SEARCH','STA (*info for structures and identifiers*) DISPLAY: ARRAY [DISPRANGE] OF DISPLAYFRAME; structconstlist: structnodeptr; UTYPPTR,UCSTPTR,UVARPTR, UFLDPTR,UPRCPTR,UFCTPTR: CTP; (*POINTERS TO UNDECLARED IDS*) OUTERBLOCK, CKCHECK','SWITCH_STRPOS', 'SYSPROG','TABLES','UCSD','WARN',''];  (*PROCEDURE RECORD FOR OUTER BLOCK*) FWPTR: CTP; (*LIST OF FORWARD REFERENCED TYPE IDS*) (* Listing *) LIST,initlistmode,gtemplist: listswitch; gtemplinenumber,linenumber, (* line no for listing/break * PROCEDURE IDSEARCH(DESCRIBE: DESCPTR; BUFFER: BUFPTR); * * TYPE NODE = PACKED RECORD * KEY: ^STRING; * LLINK, RLINK: ^NODE; * SY, OP: 0..255; * END; * * DESCPTR = ^ RECORD * @      IN IDENTIFIER) L3 CMP.B #'z',C ELSE IF C <= 'z' THEN (...ELSE EXIT) BHI.S L5 SUB.B #'a'-'A',C CONVERT TO UPPERCASE L4 ADDQ.W #1,COUNT C IS IN IDENTIFIER MOVE.B C,0(IDPTR,COtodaysdate[9] := chr(year mod 10 + ord('0')); end else todaysdate := ' '; {Invalid date} end; end; {initdate} PROCEDURE ENTSTDTYPES; BEGIN NEW(INTPTR,SCALAR,STANDARD); WITH INTPTR^ DO BEGIN ispackable :UNT.W) IDENT[COUNT] := C ADDQ.W #1,CURS BRA L1 LOOP BACK FOR NEXT CHARACTER * (END OF IDENTIFER LOOP) L5 MOVE.B COUNT,(IDPTR) IDENT[0] := CHR(COUNT), SET LENGTH SUBQ.W #1,CURS DESCP= false; sizeoflo := false; unpacksize := INTSIZE; align := INTALIGN; FORM := SCALAR; SCALKIND := STANDARD; info := sysinfo; END; new(shortintptr,scalar,standard); with shortintptr^ do begin ispackable := true; sizeoflo := f ID: STRING[80]; * OP: 0..20; * SY: 0..70; * CURSOR: CURSRANGE; {shortint} * END; * NOSYMS REFR SYMTREE ROOT NODE OF RESERVED IDENTIFIER TREE REFR TREESTR^.CURSOR := CURS - 1 MOVE.W CURS,CURSOR(DESCPTR) MOVE.L DESCPTR,-(SP) SAVE REGISTERS SUBQ.L #8,SP RESERVE SPACE FOR RESULTS PEA SYMTREE PEA 8(SP) ADDRESS OF SYNODE PEA (IDPTR) BSR TEARCH SY EQU 12 NODE FIELD OFFSETS OP EQU 13 DOP EQU 82 DESCRIPTOR FIELD OFFSETS DSY EQU 84 CURSOR EQU 86 DESCPTR EQU A4 BUFPTR EQU A3 RETURN EQU A2 SYNODE EREESEARCH MOVEM.L (SP)+,TRS/SYNODE/DESCPTR RETRIEVE RESULTS, RESTORE REGS CLR.L DOP(DESCPTR) DESCPTR^.OP & SY := 0 TST.L TRS IF TREESEARCH = 0 THEN BNE.S L6 MOVE.B SY(SYNODE),DSY+1(DESCPTR) IDENTIFIER IS A RESQU A1 IDPTR EQU DESCPTR COUNT EQU D7 C EQU D6 CURS EQU D5 TRS EQU D4 IDSEARCH EQU * MOVEM.L (SP)+,RETURN/BUFPTR/DESCPTR FETCH PARAMETERS FROM STACK MOVE.L RETURN,-(SP) MOVE.W CURSOR(DESCPTR),CURS CERVED WORD MOVE.B OP(SYNODE),DOP+1(DESCPTR) SO COPY OVER SY AND OP FIELDS L6 RTS END DEF IDSEARCH END URS := DESCPTR^.CURSOR CLR.W COUNT COUNT := 0 * ASCII SEQUENCE: DIGITS UPPERCASE '_' lowercase L1 MOVE.B 0(BUFPTR,CURS.W),C C := BUFPTR^[CURS]; CMP.B #'Z',C IF C <= 'Z' THEN BHI.S L2 CMP.B # {file INIT} implement procedure init; var seconds: shortint; i: integer; procedure initdate; {Initialize TODAYSDATE to current date as 'dd-mmm-yy'.} {Uses system procedure sysdate(var d: daterec)} begin {initdate} sysdate'A',C IF C < 'A' THEN (...ELSE LETTER) BCC.S L4 CMP.B #'9',C IF C <= '9' THEN BHI.S L5 CMP.B #'0',C IF C < '0' THEN (...ELSE DIGIT) BCC.S L4 BRA.S L5 (globaldate); systime(globaltime); with globaldate do begin {LAF 880101 added "mod 10" to "div 10" and removed "year<100" test} if (month in [1..12]) and (day>0) then begin {Valid date} todaysdate EXIT LOOP (NOT IN IDENTIFIER) L2 CMP.B #'a',C ELSE IF C < 'a' THEN BCC.S L3 CMP.B #'_',C IF C <> '_' THEN (...ELSE OK) BEQ.S L4 BRA.S L5 EXIT LOOP (NOT := ' -' + str('JanFebMarAprMayJunJulAugSepOctNovDec', month*3-2,3) + '- '; if day>9 then todaysdate[1] := chr(day div 10 + ord('0')); todaysdate[2] := chr(day mod 10 + ord('0')); todaysdate[8] := chr(year div 10 mod 10 + ord('0')); A     alse; unpacksize := shortintsize; align := intalign; bitsize := shortintsize*bitsperchar; signbit := true; form := scalar; scalkind := standard; info := sysinfo; END; NEW(REALPTR,reals); WITH REALPTR^ DO BEGIN ispackab info := []; {NOT predeclared} END; END (*ENTSTDTYPES*) ; PROCEDURE ENTSTDNAMES; VAR CP,CP1: CTP; I: INTEGER; BEGIN NEW(CP,TYPES); WITH CP^ DO BEGIN newident(namep,'REAL'); IDTYPE := REALPTR; KLASS := TYPES; infle := false; sizeoflo := false; unpacksize := REALSIZE; align := REALALIGN; FORM := reals; info := sysinfo; END; NEW(CHAR_PTR,SCALAR,STANDARD); WITH CHAR_PTR^ DO BEGIN ispackable := true; sizeoflo := false; bitsize := o := sysinfo END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN newident(namep,'LONGREAL'); IDTYPE := REALPTR; KLASS := TYPES; info := sysinfo + [nonstandard]; END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BITSPERCHAR; signbit := false; unpacksize := CHARSIZE; align := CHARALIGN; FORM := SCALAR; SCALKIND := STANDARD; info := sysinfo; END; NEW(BOOLPTR,SCALAR,DECLARED); WITH BOOLPTR^ DO BEGIN ispackable := true; sizeoflo := fals BEGIN newident(namep,'INTEGER'); IDTYPE := INTPTR; KLASS := TYPES; info := sysinfo END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN newident(namep,'CHAR'); IDTYPE := CHAR_PTR; KLASS := TYPES; info := sysinfo Ee; bitsize := 1; signbit := false; unpacksize := BOOLSIZE; align := BOOLALIGN; FORM := SCALAR; SCALKIND := DECLARED; info := sysinfo; END; NEW(ANYFILEPTR,FILES); WITH ANYFILEPTR^ DO BEGIN ispackable := false; sizeoflo ND; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN newident(namep,'BOOLEAN'); IDTYPE := BOOLPTR; KLASS := TYPES; info := sysinfo END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN newident(namep,'STRING'); IDT:= false; unpacksize := FILESIZE; align := WORDALIGN; FORM := FILES; FILTYPE := NIL; info := sysinfo; END; NEW(ANYPTRPTR,POINTER); WITH ANYPTRPTR^ DO BEGIN ispackable := false; sizeoflo := false; unpacksize := PTRSIZE;YPE := STRGPTR; KLASS := TYPES; info := sysinfo + [nonstandard]; END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN newident(namep,'TEXT'); IDTYPE := TEXTPTR; KLASS := TYPES; info := sysinfo END; ENTERID(CP);  align := PTRALIGN; FORM := POINTER; ELTYPE := NIL; info := sysinfo; END; NEW(cant_deref,POINTER); cant_deref^ := anyptrptr^; NEW(TEXTPTR,FILES); WITH TEXTPTR^ DO BEGIN ispackable := false; sizeoflo := false; unpacks NEW(CP,KONST); WITH CP^ DO BEGIN newident(namep,'MAXINT'); IDTYPE := INTPTR; KLASS := KONST; info := sysinfo; with VALUES do begin intval := true; ival := MAXINT end; END; ENTERID(CP); NEW(CP,KONST); ize := FILESIZE+CHARSIZE; align := WORDALIGN; FORM := FILES; FILTYPE := CHAR_PTR; info := sysinfo + [mustinitialize, cantassign]; END; NEW(STRGPTR,ARRAYS,TRUE,TRUE); WITH STRGPTR^ DO {var template & string parm} BEGIN ispackWITH CP^ DO BEGIN newident(namep,'MININT'); IDTYPE := INTPTR; KLASS := KONST; info := sysinfo + [nonstandard]; with VALUES do begin intval := true; ival := MININT end; END; ENTERID(CP); CP1 := NIL; FOR I := able := false; sizeoflo := false; unpacksize := ptrsize+shortintsize; align := WORDALIGN; FORM := ARRAYS; AELTYPE := CHAR_PTR; INXTYPE := INTPTR; AISPACKD := TRUE; aelbitsize := bitsperchar; AISSTRNG := TRUE; MAXLENG := 255; 0 TO 1 DO BEGIN NEW(CP,KONST); WITH CP^ DO BEGIN IDTYPE := BOOLPTR; IF I = 0 THEN newident(namep,'FALSE') ELSE newident(namep,'TRUE'); NEXT := CP1; KLASS := KONST; with VALUES do begin intval := true; IVAL := I end; A     ,false); WITH UFLDPTR^ DO BEGIN namep := zip; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0; fispackd := false; KLASS := FIELD; info := sysinfo END; NEW(UPRCPTR,prox,DECLARED); WITH UPRCPTR^ DO BEGIN namep := zip; IDTYPE := NIL; FOnewident(NA[spreadln ],'READLN'); newident(NA[spclose ],'CLOSE'); newident(NA[spreset ],'RESET'); newident(NA[sprewrite ],'REWRITE'); newident(NA[spappend ],'APPEND'); newident(NA[spreaddir ],'READDIR'); RWDECL := FALSE; extdecl := false; NEXT := NIL; paramlc := 0; PFLEV := 0; inscope := false; KLASS := prox; ismodulebody := false; isexported := false; PFDECKIND := DECLARED; info := sysinfo; isrefed := false; END; NEW(UFCTPTR,FU newident(NA[spwritedir ],'WRITEDIR'); newident(NA[spstrread ],'STRREAD'); newident(NA[spstrwrite ],'STRWRITE'); newident(NA[spstrmove ],'STRMOVE'); newident(NA[spopen ],'OPEN'); newident(NA[spseek ],'SEEK');  info := sysinfo END; ENTERID(CP); CP1 := CP END; BOOLPTR^.FCONST := CP; NEW(CP,KONST); WITH CP^ DO BEGIN newident(namep,'NIL'); IDTYPE := ANYPTRPTR; NEXT := NIL; KLASS := KONST; with values do begin intval := true; ival :=NC,DECLARED); WITH UFCTPTR^ DO BEGIN namep := zip; IDTYPE := NIL; FORWDECL := FALSE; extdecl := false; NEXT := NIL; paramlc := 0; PFLEV := 0; KLASS := FUNC; pfaddr := 0; PFDECKIND := DECLARED; info := sysinfo; isexported := fals nilvalue end; info := sysinfo; END; ENTERID(CP); new(cp,types); with cp^ do begin newident(namep,'ANYPTR'); idtype := anyptrptr; next := nil; klass := types; info := sysinfo + [nonstandard,modcalreq,sysprogreq]; e; isrefed := false; inscope := false; END; END (*ENTUNDECL*) ; PROCEDURE ENTSPCPROCS; const spc1st = spabs; {special procedure indices} spclast = spfillchar; VAR LCP: CTP; I: spkeys; ISFUNC: BOOLEAN; NA: ARRAY [spc1 end; enterid(cp); new(ioresultptr, vars); with ioresultptr^ do begin newident(namep, 'IORESULT'); idtype := intptr; next := nil; klass := vars; info := sysinfo + [nonstandard,ucsdreq,sysprogreq,modcalreq]; glst..spclast] OF ALPHAPTR; procedure fillna; begin newident(NA[spabs ],'ABS'); newident(NA[spchr ],'CHR'); newident(NA[spodd ],'ODD'); newident(NA[spord ],'ORD'); newident(NA[spround ],'ROobalptr := sysglobalptr; vlev := 1; vaddr := -22; vtype := localvar; end; enterid(ioresultptr); END (*ENTSTDNAMES*) ; PROCEDURE ENTUNDECL; var zip: alphaptr; BEGIN newident(zip,'*undecl*'); NEW(UTYPPTR,TYPES); WITUND'); newident(NA[sptrunc ],'TRUNC'); newident(NA[spsqr ],'SQR'); newident(NA[sppred ],'PRED'); newident(NA[spsucc ],'SUCC'); newident(NA[sphex ],'HEX'); newident(NA[spoctal ],'OCTAL'); H UTYPPTR^ DO BEGIN namep := zip; IDTYPE := NIL; KLASS := TYPES; info := sysinfo END; NEW(UCSTPTR,KONST); WITH UCSTPTR^ DO BEGIN namep := zip; IDTYPE := NIL; NEXT := NIL; KLASS := KONST; values.intval := true; VALUES.IVAL : newident(NA[spbinary ],'BINARY'); newident(NA[spnew ],'NEW'); newident(NA[spdispose ],'DISPOSE'); newident(NA[spaddr ],'ADDR'); newident(NA[spsizeof ],'SIZEOF'); newident(NA[spcall ],'CALL'); n= 0; info := sysinfo END; NEW(UVARPTR,VARS,localvar); WITH UVARPTR^ DO BEGIN namep := zip; IDTYPE := NIL; NEXT := NIL; KLASS := VARS; globalptr := NIL; VLEV := 0; VADDR := 0; vtype := localvar; info := sysinfo END; NEW(UFLDPTR,FIELDewident(NA[sppage ],'PAGE'); newident(NA[spoverprint ],'OVERPRINT'); newident(NA[spprompt ],'PROMPT'); newident(NA[spwrite ],'WRITE'); newident(NA[spwriteln ],'WRITELN'); newident(NA[spread ],'READ'); B      newident(NA[spposition ],'POSITION'); newident(NA[spmaxpos ],'MAXPOS'); newident(NA[splinepos ],'LINEPOS'); newident(NA[speoln ],'EOLN'); newident(NA[speof ],'EOF'); newident(NA[sphalt ],'HALT'); ad,spstrwrite, spreaddir,spwritedir, spappend,splinepos, spstrmove,spseek,spposition, spmaxpos,splinepos,sphalt, spstrmax,spsetstrlen, spopen,spclose,spstrlen, sphex,spoctal,spbinary]) then  newident(NA[spstrlen ],'STRLEN'); newident(NA[spstrmax ],'STRMAX'); newident(NA[spsetstrlen ],'SETSTRLEN'); newident(NA[sppack ],'PACK'); newident(NA[spunpack ],'UNPACK'); newident(NA[spunitread ],'UNITREAD'info := sysinfo + [nonstandard] else if (i in [spcall,spaddr]) then info := sysinfo + [nonstandard,modcalreq,sysprogreq] else info := sysinfo; END; ENTERID(LCP) END; END (*ENTSPCPROCS*) ; PROCEDURE ENTSTDPROCS; const std1st = s); newident(NA[spunitwrite ],'UNITWRITE'); newident(NA[spblockread ],'BLOCKREAD'); newident(NA[spblockwrite],'BLOCKWRITE'); newident(NA[splength ],'LENGTH'); newident(NA[spconcat ],'CONCAT'); newident(NA[spmoveleftpmark; {standard procedure indices} stdlast = spunitwait; VAR LCP,PARAM: CTP; FTYPE,MAXSTRINGP: STP; I: spkeys; ISFUNC: BOOLEAN; NA: ARRAY [std1st..stdlast] OF ALPHAPTR; procedure makeparm (typ: stp; kind: vartype); { sets  ],'MOVELEFT'); newident(NA[spmoveright ],'MOVERIGHT'); newident(NA[spscan ],'SCAN'); newident(NA[spgotoxy ],'GOTOXY'); newident(NA[spfillchar ],'FILLCHAR'); end; (* fillna *) BEGIN fillna; FOR I := spc1st up a parameter record. Call in right-to-left order } var parm: ctp; begin new(parm,vars,refparm); with parm^ do begin namep := nil; idtype := typ; next := param; info := sysinfo; klass := vars; vtype := kind; globalptr := NIL; TO spclast DO BEGIN ISFUNC := I IN [spabs,spchr,spodd,spord,spround, sptrunc,spsqr,sppred,spsucc,sphex, spoctal,spbinary,spaddr,splength, spstrlen,spstrmax,spconcat,spsizeof, spblockread,spblockwrite,spscan,speof, speoln,spposition,send; param := parm; end; procedure fillna; begin newident(NA[spmemavail ],'MEMAVAIL'); newident(NA[sppos ],'POS'); newident(NA[spinsert ],'INSERT'); newident(NA[spdelete ],'DELETE'); newidenpmaxpos,splinepos]; IF ISFUNC THEN NEW(LCP,FUNC,SPECIAL) ELSE NEW(LCP,prox,SPECIAL); WITH LCP^ DO BEGIN NAMEP := NA[I]; NEXT := NIL; if I <> spconcat then IDTYPE := NIL else begin new(IDTYPE,arrays,true,true); IDTYPE^:=strgptr^; t(NA[spcopy ],'COPY'); newident(NA[spstr ],'STR'); newident(NA[spunitclear ],'UNITCLEAR'); newident(NA[spunitbusy ],'UNITBUSY'); newident(NA[spunitwait ],'UNITWAIT'); newident(NA[spescape ],'ESCAPE'); newIDTYPE^.maxleng:=strglgth; idtype^.unpacksize := strglgth+1; end; IF ISFUNC THEN KLASS := FUNC ELSE KLASS := prox; PFDECKIND := SPECIAL; SPKEY := I; if (i in [spunitread,spunitwrite, spblockread,spblockwrite, splength,spconcat,spgotoxy, ident(NA[spesccode ],'ESCAPECODE'); newident(NA[spnewwords ],'NEWWORDS'); newident(NA[spmark ],'MARK'); newident(NA[sprelease ],'RELEASE'); newident(NA[spsin ],'SIN'); newident(NA[spcos ],'COS'); ne spmoveright,spmoveleft, spscan,spfillchar]) then info := sysinfo + [nonstandard,ucsdreq] else if (i in [spsizeof]) then info := sysinfo + [nonstandard,ucsdreq, modcalreq,sysprogreq] else if (i in [spoverprint,spprompt, spstrrewident(NA[spexp ],'EXP'); newident(NA[spln ],'LN'); newident(NA[spsqrt ],'SQRT'); newident(NA[sparctan ],'ARCTAN'); newident(NA[spget ],'GET'); newident(NA[spput ],'PUT'); newident(NA[spsB     elete: {var string, integer, integer} begin makeparm(intptr,valparm); makeparm(intptr,valparm); makeparm(strgptr,refparm);{no max len} end; spstrinsert, spinsert: {string, var string, integer} begin makeparm(intptr,valparm); tcode:=true; uminus := false; inbody := false; indefinesection := false; FWPTR := NIL; gshortcircuit := false; LC := initlc; DP := TRUE; refilesize := refiledefault; defilesize := defiledefault; refvolname := ''; defvolname := '';  makeparm(strgptr,strparm); makeparm(maxstringp,cvalparm); end; spstrpos, sppos: {integer func of string, string} begin ftype := intptr; makeparm(maxstringp,cvalparm); makeparm(maxstringp,cvalparm); end; spstrrpt: {strin oldDP := true; importexportext := false; linenumber := 0; SCREENDOTS := 0; STARTDOTS := 0; PRTERR := TRUE; BPTONLINE := FALSE; DEBUGGING := FALSE; GRANGECHECK := TRUE; GIOCHECK := TRUE; stdpasc := false; saveconst := true; govflcheck := trrpt ],'STRRPT'); newident(NA[spstrpos ],'STRPOS'); newident(NA[spstrappend ],'STRAPPEND'); newident(NA[spltrim ],'STRLTRIM'); newident(NA[sprtrim ],'STRRTRIM'); newident(NA[spstrinsert ],'STRINSERT'); newg fcn of string, integer} begin ftype := maxstringp; makeparm(intptr,valparm); makeparm(maxstringp,cvalparm); end; spstr, spcopy: {string fcn of string,int,int} begin ftype := maxstringp; makeparm(intptr,valparm); makeparm(inident(NA[spstrdelete ],'STRDELETE'); end; BEGIN (*ENTSTDPROCS*) fillna; new(maxstringp,arrays,true,true); maxstringp^ := strgptr^; maxstringp^.maxleng := strglgth; maxstringp^.unpacksize := strglgth+1; FOR I := std1st TO tptr,valparm); makeparm(maxstringp,cvalparm); end; spstrappend: {var string, string} begin makeparm(maxstringp,cvalparm); makeparm(strgptr,strparm); end; spltrim,sprtrim: {string fcn of string} begin ftype := maxstringp; makeparm(stdlast DO BEGIN ISFUNC := I IN [spesccode,spmemavail,spstrpos,sppos, spstrrpt,spcopy,spstr,spltrim,sprtrim, spunitbusy,spsin,spcos,spexp,spln, spsqrt,sparctan]; IF ISFUNC THEN NEW(LCP,FUNC,STANDARD) ELSE NEW(LCP,prox,STANDARmaxstringp,cvalparm); end; END; {case} WITH LCP^ DO BEGIN NAMEP := NA[I]; IDTYPE := FTYPE; NEXT := PARAM; IF ISFUNC THEN KLASS := FUNC ELSE KLASS := prox; PFDECKIND := STANDARD; SPKEY := I; if (i in [spescape,spesccode]) then info := sysiD); FTYPE := NIL; PARAM := NIL; CASE I OF spmark: {var anyptr} makeparm(anyptrptr,refparm); sprelease: {anyptr} makeparm(anyptrptr,valparm); spunitbusy: {bool func of integer} begin ftype := boolptr; makeparm(intptrnfo + [nonstandard,sysprogreq] else if (i in [sppos,spinsert, spdelete,spcopy, spunitclear,spunitbusy, spunitwait]) then info := sysinfo + [nonstandard,ucsdreq] else if (i in [spmark,sprelease, spstrrpt,spstrpos, ,valparm); end; spunitclear, spunitwait: makeparm(intptr,valparm); spescape: {integer} makeparm(shortintptr,valparm); spesccode, spmemavail: {integer fcn} ftype := intptr; spsin,spcos, spexp,spln, spsqrt,sparctan: {real func of r spstrappend,spltrim, sprtrim,spstrinsert,spstr, spstrdelete]) then info := sysinfo + [nonstandard] else if i = spmemavail then info := sysinfo + [nonstandard,ucsdreq,modcalreq] else if i = spnewwords then info := sysinfoeal} begin ftype := realptr; makeparm(realptr,valparm) end; spget,spput: {var anyfile} makeparm(anyfileptr,refparm); spnewwords: {var anyptr, integer} begin makeparm(intptr,valparm); makeparm(anyptrptr,refparm) end; spstrdelete, spd + [nonstandard,modcalreq] else info := sysinfo; END; ENTERID(LCP); END; END (*ENTSTDPROCS*) ; PROCEDURE INITSCALARS; BEGIN tables := false; gcallmode := abscall; gcopyright := ''; totalerrors:=0; totalwarnings := 0; puC     true; gstackcheck := true; ucsd := false; modcal := false; sysprog := false; warn := true; $IF MC68020$ float := flt_on; $END$ $IF not MC68020$ float := flt_off; $END$ switch_strpos := false; strpos_warn := true; hen strwrite(timestring,i,i,'0'); strwrite(timestring,i,i,seconds:1); WRITELN(OUTPUT,compilername, ' [Rev ',crevno,' ',crevid.month:2,'/',crevid.day:2, '/',crevid.year:2,']',todaysdate:12,' ',timestring); writeln(output); writeln(output maxsearchfiles := 0; maxoverlays := 0; beforefirsttoken := true; syntxerr := false; heapdispose := false; gtemplist := listnone; systemglobals := 'SYSGLOBALS'; sysglobalptr := addr(systemglobals); float_flag := 'FLTPTHDW'; sawinput,copyright1); writeln(output,'':14,copyright2); writeln(output); compioinit; bodyanalyzerinit; INITSCALARS; INITSETS; initpowertable; LEVEL := 0; TOP := 0; linelevel := 0; levelatstart := 0; linlevatstart := 0; WITH DISPLAY[0] DO BEGIN OC := false; sawoutput := false; sawkeyboard := false; sawlisting := false; disdef.level := -1; aliasok := false; uniquenum := 0; listabort := false; allow_packed := false; temp_put := false; END; (*INITSCALARS*) PROCEDURE INITSETSCUR := BLOCKscope; FNAME := NIL; FFILE := NIL; FLABEL := NIL; fmodule := nil; available_module := nil; END; sysinfo := [predeclared]; {std attribute} ENTSTDTYPES; ENTUNDECL; INSYMBOL; { must not access option flags ; BEGIN CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT, lbrack,lparent,notsy]; SIMPTYPEBEGSYS := [addop,intconst,realconst,stringconst,ident,LPARENT]; TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY]; TYPEBEGSYS := [ARROW,P before this call to insymbol } ENTSTDNAMES; ENTSPCPROCS; ENTSTDPROCS; LEVEL := 1; TOP := 1; WITH DISPLAY[1] DO BEGIN OCCUR := BLOCKscope; FNAME := NIL; FFILE := NIL; FLABEL := NIL; fmodule := nil; available_module := nil; END; ACKEDSY,procsy] + TYPEDELS + SIMPTYPEBEGSYS; BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY, PROCSY,FUNCSY,BEGINSY,modulesy,importsy, forwardsy,externlsy]; modulebegsys := blockbegsys + [importsy,exportsy,implmtsy]; SELECTSYS := [ARROW,PERIOD,Ldisplay_ok_to_import := 2; codegeninit; { process $def or $ref before initializing code files } if maxsearchfiles = 0 then begin newbytes(searchlistptr,(122*searchdefault)); maxsearchfiles := searchdefault; searchfilestop := 1; BRACK]; FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY]; STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY,CASESY, trysy]; END (*INITSETS*) ; procedure initpowertable; var i: integer; begi searchlistptr^[1] := syslibrary; end; if maxoverlays = 0 then begin newbytes(overlaylistptr,(16*overlaydefault)); maxoverlays := overlaydefault; overlaytop := 0; end; beforefirsttoken := false; FOR I := 1 TO 8 DO WRITELN(OUn power_table[0] := 1; for i := 1 to bitsperword-2 do power_table[i] := power_table[i-1]*2; end; BEGIN (*INIT*) initdate; userinfo^.gotcode := false; setstrlen(timestring,0); i := 1; if globaltime.hour < 10 then strwritTPUT); WRITE(OUTPUT,'< 0>'); NEW(OUTERBLOCK,prox,DECLARED); WITH OUTERBLOCK^ DO BEGIN NEXT := NIL; paramlc := 0; newident(namep,'PROGRAM'); IDTYPE := NIL; KLASS := prox; PFDECKIND := DECLARED; PFLEV := 0; ismodulebody := false; e(timestring,i,i,'0'); strwrite(timestring,i,i,globaltime.hour:1,':'); if globaltime.minute < 10 then strwrite(timestring,i,i,'0'); strwrite(timestring,i,i,globaltime.minute:1,':'); seconds := globaltime.centisecond div 100; if seconds < 10 t FORWDECL := FALSE; extdecl := false; inscope := false; alias := false; othername := nil; info := []; END; sysinfo := []; {std attributes for user names} END (*COMPINIT*) ; C     re buildreal(inputstr: string80; var realval: real); procedure getnextpage; procedure compioinit; function getfid(anyvar s: fid) : fid; procedure upc(var s: string); function uniquenumber: shortint; KBEGSYS; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4); END; level := 0; top := 0; if sawinput or ucsd then enterid(inputptr) else inputptr := NIL; if sawoutput or ucsd then enterid(outputptr) else outputptr := NIL; lh1 oschema ldxCOPYRIGHT (C) 1984 BY HEWLETT-PACKARD COMPANY iSCHEMA tttts232 tts66 tts42 ts164 ts342 tts168 ttiCOMPLIB ts372 lkq if ucsd then begin enterid(keyboardptr); enterid(listingptr); end; level := 1; top := 1; if sawinput then enterid(inputptr); if sawoutput then enterid(outputptr); IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14) end elprogram initcount; var f: file of integer; begin rewrite(f,'COUNTFILE'); write(f,0); close(f,'save'); end. lh1 pTEMP oschema ldxCOPYRIGHT (C) 1984 BY HEWLETT-PACKARD COMPANY iSCHEMA tttts232 tts66 tts42 ts164 ts342 tts168 ttiCOMPLIB ts372 lkq  {INITDEFINE} import compio,compdebug,symtable,genutils,codegen, bodyanalyzer,declanalyzer,ci,asm,sysdevs; export procedure wrapup(term: termtype); procedure init;  {file MAINBODY} mark(initial_heap); init; try makefileident(inputptr,'INPUT',-94); makefileident(outputptr,'OUTPUT',-90); makefileident(keyboardptr,'KEYBOARD',-86); makefileident(listingptr,'LISTING',-78); curglobalname := NIL; if not (sy {file IODEFINE} import globals,compinit,genutils,sysglobals, fs,ci,convert_text,asm,sysdevs; {$Z4000} export type BCDdigit = 0..15; {0..9 are used} bcd_strtype = record signbit: (pls,mnus); mantissa: packed a in [modulesy,forwardsy,externlsy]) then begin IF SY = PROGSY THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN newident(OUTERBLOCK^.NAMEP,ID); ENTERID(OUTERBLOCK); curglobalname := outerblock^.namep; insymbol; END ELSE ERrray[1..16] of BCDdigit; exponent: shortint; end; var sourcefilename: fid; source: text; {Source textfile} lp: text; {Listing file} width,gtempwidth, pagewidth: shortint; endofprog,listopen, printlastlineROR(2); IF SY = LPARENT THEN BEGIN REPEAT insymbol; if sy <> ident then error(6) else begin if id = 'INPUT' then begin if sawinput then error(101); sawinput := true; end else if id = 'OUTPUT' then beg: boolean; gsymcursor: cursrange; procedure error (errornum: shortint); procedure errorwithinfo(errornum: shortint; infostring: string80); procedure warning(linenum: integer; infostring: string80); function opensource (fname: fid; sin if sawoutput then error(101); sawoutput := true; end else if id = 'KEYBOARD' then begin if sawkeyboard then error(101); sawkeyboard := true; end else if id = 'LISTING' then begin if sawlisting then error(101); sawlistinrclevel: shortint; must: boolean) : boolean; procedure incrlinecount; procedure newident(var namep: alphaptr; newid: alpha); procedure insymbol; procedure skip (fsys: setofsys); procedure iowrapup(term: termtype); procedug := true; end else error(104); insymbol; end; if (sy <> comma) and (sy <> rparent) then begin error(20); if not (sy in [ident]+blockbegsys) then insymbol; end; UNTIL SY IN [RPARENT]+BLOCD     se error(6); BLOCK(BLOCKBEGSYS+STATBEGSYS-[CASESY],PERIOD,OUTERBLOCK); END else {sy = modulesy} begin moduleinit(curglobalname); level := 0; top := 0; enterid(inputptr); enterid(outputptr); enterid(keyboardptr); enterioCOMPILER ldxCOPYRIGHT HEWLETT-PACKARD COMPANY, 1982, 1990 iDEV aiCOMPLIB alkq eCCONSTS f/allowmodcal =/x TRUE; ˙c f/MC68020 =/x TRUE; ˙c qse f rDEV.CODE rDEV.CODE rMODCAL20.CODE q cDEV nDEV lh1 oMODCAL20 ldxCOPYRIGHT HEWLETT-PACKARD COMPANY, 1982d(listingptr); level := 1; top := 1; enterid(inputptr); enterid(outputptr); repeat case sy of modulesy: moduledeclaration([period]+blockbegsys+statbegsys-[casesy], false,false,display[top].available_module,true); forwardsy: , 1990 iDEV aiCOMPLIB alkq eCCONSTS f/allowmodcal =/x FALSE; ˙c f/MC68020 =/x TRUE; ˙c qse f rDEV.CODE rCOMP20.CODE q cDEV nDEV lh1 oCOMP20 ldxCOPYRIGHT HEWLETT-PACKARD COMPANY, 1982, 1990 iDEV aiCOMPLIB alkq f rDEV.CODE q *********************** begin insymbol; moduledeclaration([period]+blockbegsys+statbegsys-[casesy], true,true,display[top].available_module,true); end; externlsy: begin insymbol; moduledeclaration([period]+blockbegsys+statbegsys-[casesy], true,false,d***************************** * * MAKE_COMP DONE * **************************************************** isplay[top].available_module,true); end; end; until not (sy in [modulesy,forwardsy,externlsy]); end; if sy <> period then error(21); endofprog := true; try {see if additional text remains} insymbol; { there should be no more tex { file MC68881 } import sysglobals, codegen, assemble, genutils, genexprmod; implement var rmask,fregloc : attrtype; fregcount: shortint; procedure NIL_attributes(fexp: exptr); { Called as part of the $FLOAT TEST$ option } t } gen_error := true; recover gen_error := false; if gen_error then begin printlastline := true; error(100); wrapup(abort); end else wrapup(normal); recover begin save_escape := escapecode; save_ioresult := iorevar ptr: elistptr; begin with fexp^ do begin attr := NIL; case eclass of eqnode, nenode, ltnode, lenode, gtnode, genode, innode, subsetnode, supersetnode, unionnode, diffnode, intersectnode, concatnode, addnode, subnode, sult; release(initial_heap); if (save_escape >= -9) and (save_escape <= -3) then error(400-save_escape); wrapup(abort); ioresult := save_ioresult; escape(save_escape); end; mulnode, divnode, modnode, shftnode, ornode, andnode: begin NIL_attributes(opnd1); NIL_attributes(opnd2); end; negnode, notnode, floatnode, derfnode, succnode, bufnode, absnode, chrnode, oddnode, ordnode, prednode, strlennode, strmaxnode, ro*************************************************************** * MAKE THE 4 DIFFERENT COMPILERS : * COMPILER * COMP20 * MODCAL * MODCAL20 **************************************************************** eCCONSTS f/allowmodcal =/x TRUE; ˙c f/MC68020 =/undnode, sqrnode, truncnode: NIL_attributes(opnd); subscrnode: begin NIL_attributes(arayp); NIL_attributes(indxp); end; substrnode: begin NIL_attributes(arayp); NIL_attributes(indxp); NIL_attributes(lengthp); end; selnnode:x FALSE; ˙c qse f rDEV.CODE rMODCAL.CODE q cDEV nDEV lh1 oMODCAL ldxCOPYRIGHT HEWLETT-PACKARD COMPANY 1982, 1990 iDEV aiCOMPLIB alkq eCCONSTS f/allowmodcal =/x FALSE; ˙c f/MC68020 =/x FALSE; ˙c qse f rDEV.CODE rCOMPILER.CODE q cDEV nDEV lh1  NIL_attributes(recptr); fcallnode: begin ptr := actualp; while ptr <> NIL do begin NIL_attributes(ptr^.expptr); ptr := ptr^.nextptr; end; end; setdenonode: begin ptr := setvarpart; while ptr <> NIL do begD     to a temporary. Push the address of the temporary.} var op: attrtype; begin makerealaddressable(fexp); getlocstorage(8,op); op.storage := multi; emit2(fmove,fexp^.attr^,op); emit1(pea,op); freeregs(fexp^.attr); drmode := inFreg; regnum := getreg(F); end; end; case spkey of spsin: emit2(fsin,{actualp^.}expptr^.attr^,op1); spcos: emit2(fcos,{actualp^.}expptr^.attr^,op1); spsqrt: emit2(fsqrt,{actualp^.}expptr^.attr^,o end; procedure moverealvalue(fexp: exptr; var at: attrtype); { Addrmode is inFreg. Move 64 bit real from the floating point registers to the address in at. } var op: attrtype; begin makerealaddressable(fexp); emit2(fmp1); spexp: emit2(fetox,{actualp^.}expptr^.attr^,op1); sparctan: emit2(fatan,{actualp^.}expptr^.attr^,op1); spln: begin loadrealvalue(expptr); new(valp); with valp^ do begin cclass := reel; rval := 0.5; end; in NIL_attributes(ptr^.lowptr); NIL_attributes(ptr^.hiptr); ptr := ptr^.nextptr; end; end; otherwise { Terminal node } end; { case } end; { with } end; { NIL_attributes } procedure makerealaddressable( fexp : expove,fexp^.attr^,at); freeregs(fexp^.attr); end; procedure saverealregs; var rn: regrange; begin with rmask do begin addrmode := fmultiple; fregcount := 0; for rn := 0 to maxreg do if reg[F,rn].allocstatr ); { Make operand addressable while handling float node } begin force_unpack := true; makeaddressable(fexp); force_unpack := false; with fexp^.attr^ do if ((storage = bytte) or (storage = wrd)) and not signbit then extend(fete = allocated then begin fregcount := fregcount + 1; fregs[rn] := true; end else fregs[rn] := false; if fregcount > 0 then begin getlocstorage(fregcount*12,fregloc); emit2(fmovem,rmask,fregloc); { Save registers in temporary stoxp,succ(storage)); end; procedure loadrealvalue(fexp: exptr); { Load 64 bit real into a floating point register } var op : attrtype; begin makerealaddressable(fexp); if fexp^.attr^.addrmode <> inFreg then begin rage } end; end; end; procedure reloadrealregs; begin if fregcount > 0 then emit2(fmovem,fregloc,rmask); { Restore registers from temporary storage } end; procedure realop(fexp: exptr); var op1,op2: attrtype;  with op do begin regnum := getreg(F); addrmode := inFreg; storage := multi; end; with fexp^ do begin with attr^ do if ((storage = bytte) or (storage = wrd)) and not signbit then extend(fexp,succ(storage)); freeregs(attr); emit2(fmov valp : csp; begin with fexp^, attr^ do case eclass of fcallnode: with fptr^, actualp^ do begin if {actualp^.}expptr^.eclass = floatnode then begin makerealaddressable({actualp^.}expptr^.opnd); getattrece,attr^,op); attr^.storage := multi; attr^.addrmode := inFreg; attr^.regnum := op.regnum; end; { with fexp^ } end; end; procedure pushrealvalue(fexp: exptr); { Addrmode is inFreg. Move the 64 bit real number onto the stack. } ({actualp^.}expptr); liftattr({actualp^.}expptr,{actualp^.}expptr^.opnd); {actualp^.}expptr^.attr^.storage := {actualp^.}expptr^.opnd^.attr^.storage; end else makerealaddressable({actualp^.}expptr); if spkey <> sp begin makerealaddressable(fexp); SPminus.storage := multi; emit2(fmove,fexp^.attr^,SPminus); freeregs(fexp^.attr); fexp^.attr^.addrmode := topofstack; end; procedure pushrealaddress(fexp: exptr); { Addrmode is inFreg. Move ln then if {actualp^.}expptr^.attr^.addrmode = inFreg then with op1 do begin addrmode := inFreg; regnum := {actualp^.}expptr^.attr^.regnum; end else begin freeregs({actualp^.}expptr^.attr); with op1 do begin adE      with op1 do begin addrmode := labelledconst; valp := poolit(valp); constvalp := valp; storage := multi; offset := 0; end; emit2(fcmp,op1,expptr^.attr^); op1.offset := 14; emit1(fblt,op1); with op1 do begin addrbnode then emit2(fsub,opnd2^.attr^,opnd1^.attr^) else emit2(fdiv,opnd2^.attr^,opnd1^.attr^); freeregs(opnd2^.attr); liftattr(fexp,opnd1); end; addnode, mulnode: { 64 bit } begin { Evaluate a complicated operand first } if opmode := immediate; smallval := 1; storage := wrd; end; emit2(fsub,op1,expptr^.attr^); emit2(flognp1,expptr^.attr^,expptr^.attr^); op1.offset := 4; op1.storage := bytte; emit1(bra,op1); emit2(flogn,expptr^.attr^,expptr^.attr^); op1nd1^.num_ops >= opnd2^.num_ops then begin if opnd1^.eclass = floatnode then begin makerealaddressable(opnd1^.opnd); getattrec(opnd1); liftattr(opnd1,opnd1^.opnd); opnd1^.attr^.storage := opnd1^.opnd^.attr^.stora.regnum := expptr^.attr^.regnum; end; end; addrmode := inFreg; regnum := op1.regnum; storage := multi; signbit := true; end; negnode,absnode: { 64 bit } begin makerealaddressable(opnd); freeregs(opnd^.attr); ge; end else makerealaddressable(opnd1); if opnd2^.eclass = floatnode then begin makerealaddressable(opnd2^.opnd); getattrec(opnd2); liftattr(opnd2,opnd2^.opnd); opnd2^.attr^.storage := opnd2^.opnd with op1 do begin addrmode := inFreg; regnum := getreg(F); end; if eclass = negnode then emit2(fneg,opnd^.attr^,op1) else emit2(fabs,opnd^.attr^,op1); addrmode := inFreg; regnum := op1.regnum; storage := multi;^.attr^.storage; end else makerealaddressable(opnd2); end else begin if opnd2^.eclass = floatnode then begin makerealaddressable(opnd2^.opnd); getattrec(opnd2); liftattr(opnd2,opnd2^.opnd);  signbit := true; end; sqrnode: begin loadrealvalue(opnd); emit2(fmul,opnd^.attr^,opnd^.attr^); liftattr(fexp,opnd); end; floatnode: { int to 64 bit } begin loadrealvalue(opnd); liftattr(fexp,opnd); end; subnode, divnode opnd2^.attr^.storage := opnd2^.opnd^.attr^.storage; end else makerealaddressable(opnd2); if opnd1^.eclass = floatnode then begin makerealaddressable(opnd1^.opnd); getattrec(opnd1); liftattr(opnd1,op: { 64 bit } begin { Evaluate a complicated operand first } if opnd1^.num_ops >= opnd2^.num_ops then begin loadrealvalue(opnd1); if opnd2^.eclass = floatnode then begin makerealaddressable(opnd2^.opnd); getattrend1^.opnd); opnd1^.attr^.storage := opnd1^.opnd^.attr^.storage; end else makerealaddressable(opnd1); end; if opnd2^.attr^.addrmode = inFreg then begin if eclass = addnode then emit2(fadd,opnd1^.attr^,opnd2c(opnd2); liftattr(opnd2,opnd2^.opnd); opnd2^.attr^.storage := opnd2^.opnd^.attr^.storage; end else makerealaddressable(opnd2); end else begin if opnd2^.eclass = floatnode then begin makereal^.attr^) else emit2(fmul,opnd1^.attr^,opnd2^.attr^); freeregs(opnd1^.attr); liftattr(fexp,opnd2); end else if opnd1^.attr^.addrmode = inFreg then begin if eclass = addnode then emit2(fadd,opnd2^.attr^,opnd1^.aaddressable(opnd2^.opnd); getattrec(opnd2); liftattr(opnd2,opnd2^.opnd); opnd2^.attr^.storage := opnd2^.opnd^.attr^.storage; end else makerealaddressable(opnd2); loadrealvalue(opnd1); end; if eclass = suttr^) else emit2(fmul,opnd2^.attr^,opnd1^.attr^); freeregs(opnd2^.attr); liftattr(fexp,opnd1); end else begin loadrealvalue(opnd2); if eclass = addnode then emit2(fadd,opnd1^.attr^,opnd2^.attr^) elseE     *) label 1; var k: 1..2; smode,sreg: 0..7; flip: boolean; procedure andoraddsub; (* process vanilla and, or, add or sub instruction *) begin with dest,instruction do begin opmode := ord(storage)-ord(bytte); if addrmode <> inDreg= 2; opmode := ord(dest.storage)-ord(bytte); if (source.addrmode = shortabs) and (dest.storage = long) then source.addrmode := longabs; makeEA(source); { produce extension, ignore fields in instr } makeEA(dest); end;  then begin opmode := opmode+4; reg1 := source.regnum; makeEA(dest); end else begin reg1 := regnum; makeEA(source) end; end; end; (*andoraddsub*) procedure addorsub; var opa,opi,opq,altopq: opcodetype; begin if opcode = addq,subq: begin reg1 := source.smallval mod 8; opmode := ord(dest.storage) - ord(bytte) + 4*(ord(opcode = subq)); makeEA(dest); end; andd,orr: andoraddsub; asl,asr,lsl,lsr: begin bit8 := (opcode = asl) or (opcode = lsl emit2(fmul,opnd1^.attr^,opnd2^.attr^); freeregs(opnd1^.attr); liftattr(fexp,opnd2); end; end; end; { case eclass } end; { realop }  add then begin opa := adda; opi := addi; opq := addq; altopq := subq end else (* op = sub *) begin opa := suba; opi := subi; opq := subq; altopq := addq end; with source,instruction do if (addrmode = immediate) and (smallval <= 8) and (smallvalum; extendint(0,long); end else $END$ begin reg1 := 7; opmode := 1; eamode := 2; eareg := dest.regnum; extendint(0,wrd); end; movetoCCR,movefromSR: begin reg1 := 2*ord(opcode = movetoCCR);  >= -8) and (smallval <> 0) then (*quick*) if smallval > 0 then opcode := opq else begin smallval := -smallval; opcode := altopq end else if dest.addrmode = inAreg then opcode := opa else if (addrmode = immediate) and (dest.addrmode <> opmode := 3; makeEA(dest); end; pea: begin reg1 := 4; opmode := 1; makeEA(dest); end; st..sle: begin size := 3; cond := ord(opcode) - ord(st); makeEA(dest); end; trap: begin reg1 := 7; op inDreg) then opcode := opi else andoraddsub; end; (*addorsub*) begin (*emit2*) extension[1].size := 0; extension[2].size := 0; flip := false; if (source.addrmode = immediate) and (opcode <> moveq) $IF MC68020$ andmode := 1; eamode := dest.smallval div 8; eareg := dest.smallval mod 8; end; unlk: begin reg1 := 7; opmode := 1; eamode := 3; eareg := dest.regnum; end; $IF MC68020$ fblt: begin coprocid := 1; zeros :=  (dest.addrmode <> inFreg) $END$ then source.storage := dest.storage else if (source.addrmode = shortabs) and (dest.storage = long) and (opcode in [moveI,addi,andi,cmpi,subi]) then begin flip := true; source.addrmode := longabs end; with i2; morezeros := 20; extendint(dest.offset,wrd); end; $END$ end; (*case*) outputcodeword(instrout); with extension[1] do if size = 2 then outputcodeword(wext) else if size = 4 then outputcodelong(lext) $IF MC68020$ else ifnstruction do begin 1: instropcode := numopcode[opcode]; immediateop := opcode in immediateops; case opcode of add: begin addorsub; if opcode <> add then goto 1; end; adda,suba: with dest do begin reg1 := regnum;  size = 6 then begin outputcodeword(w_ext); outputcodelong(l_ext); end $END$; end; {with instruction} end; (*emit1*) procedure emit2(*opcode: opcodetype; var source,dest: attrtype*); (* emit two-address instruction  opmode := 3+4*ord(storage = long); makeEA(source); end; addi,subi,andi,cmpi: begin if opcode = andi then reg1 := 1 else if opcode = cmpi then reg1 := 6 else if opcode = addi then reg1 := 3 else (*subi*) reg1 :F     ); eamode := ord(opcode > asr); with dest do begin eareg := regnum; size := ord(storage) - ord(bytte); end; with source do if addrmode = immediate then reg1 := smallval mod 8 else begin reg1 := regnum; eaislong := true; scale := 0; bigdisplacement := false; disp := 0; end; makeEA(source); end; $END$ chk,lea,divs,muls: begin reg1 := dest.regnum; if opcode = chk then begin $IF MC68020$ mode := eamode+4 end; end; bchg,bclr,bset,btst: begin if source.addrmode = inDreg then begin reg1 := source.regnum; bit8 := true end else begin reg1 := 4; bit8 := false; extendint(source.smallval,wrd);  if dest.storage = long then opmode := 4 else $END$ opmode := 6; end $IF MC68020$ else if ((opcode = muls) or (opcode = divs)) and (dest.storage = long) then begin instropcode := 4; reg1 := 6; end; case opcode of btst: size := 0; bchg: size := 1; bclr: size := 2; bset: size := 3; end; makeEA(dest); end; $IF MC68020$ bfexts, bfextu: begin if opcode = bfexts then reg1 := with extension[getextension] do begin size := 2; regclass := 0; reg := dest.regnum; islong := true; scale := 0; bigdisplacement := false; if opcode = muls then begin opmode := 0; disp := 0; end else {opmode = divs} 5 else {opcode = bfextu} reg1 := 4; opmode := 7; with extension[getextension] do begin size := 2; regclass := 0; reg := dest.regnum; if source.bitoffset.variable = -1 then begin Doffset := imm;  begin opmode := 1; disp := reg; end; end; end $END$ else opmode := 7; makeEA(source); end; $IF MC68020$ divsl: begin reg1 := 6; with extension[getextension] do begin size :=  D_offset := source.bitoffset.static; end else begin Doffset := inreg; D_offset := source.bitoffset.variable; end; Dwidth := imm; D_width := source.bitsize; end; makeEA(source); end; bfins: begin 2; regclass := 0; reg := dest.regnum; islong := true; scale := 0; bigdisplacement := false; opmode := 1; disp := divsl_reg; end; makeEA(source); end; $END$ cmp,cmpa: with dest do reg1 := 7; opmode := 7; with extension[getextension] do begin size := 2; regclass := 0; reg := source.regnum; if dest.bitoffset.variable = -1 then begin Doffset := imm; D_offset := dest.bitoffset.static; begin reg1 := regnum; if addrmode = inAreg then opmode := 3 + 4*ord(storage = long) else opmode := ord(storage)-ord(bytte); makeEA(source); end; cmpm: with dest do begin eareg := source.regnum; eamode := 1 end else begin Doffset := inreg; D_offset := dest.bitoffset.variable; end; Dwidth := imm; D_width := dest.bitsize; end; makeEA(dest); end; chk2: begin if dest.storage = wrd then reg1 := 1 { s; opmode := 4+ord(storage)-ord(bytte); reg1 := regnum; end; move,movea,moveI: begin if dest.addrmode = inDreg then with source do if addrmode = immediate then if (smallval >= -128) and (smallval <= 127) then torage = long} else reg1 := 2; opmode := 3; with extension[getextension] do begin size := 2; if dest.addrmode = inDreg then regclass := 0 {dest.addrmode = inAreg} else regclass := 1; reg := dest.regnum;  begin opcode := moveq; goto 1 end; instropcode := 2*ord(dest.storage <> bytte)+ord(dest.storage<> long); makeEA(source); smode := eamode; sreg := eareg; makeEA(dest); opmode := eamode; reg1 := eareg; eamode := smodF     ith extension[getextension] do begin size := 2; coprocid := 1; zeros := 0; fop := numsubopcode[opcode]; if (source.addrmode = inFreg) and (dest.addrmode = inFreg) then begin morezeros := 0; sourceFreg := sourCREENDOTS; syntxerr := false; $IF FULLDUMP$ sctr := 1; ectr := 1; new(firstexp); firstexp^.echain := nil; lastexp := firstexp; $END$ body_try_level := 0; { JWH 9/26/91 } parsing_try_level := 0; { JWH 9/26/91 } stmtlist(curbody,lastmt,fsyce.regnum; destFreg := dest.regnum; sourcetype := 0; end else if source.addrmode = inFreg then begin makeEA(dest); sourcetype := 3; destFreg := source.regnum; case dest.storage of bytte: sourceFreg := 6; wrd: sourceFreg :s+[semicolon,endsy]); lastmt^.next := newstmt(endofbodyst,not fprocp^.ismodulebody); IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13); LLP := DISPLAY[TOP].FLABEL; (* CHECK UNDEFINED LABELS *) WHILE LLP <> NIL DO WITH LLP^ DO BEGIN IF NOTe; eareg := sreg; if opcode = moveI then { MOVE.L #, ... } eareg := 4; { change abs or named const to immediate } end; movem: begin instropcode := 4; opmode := 2+ord(dest.storage = long); if= 4; long: sourceFreg := 0; multi: sourceFreg := 5; end; {case} end else {dest.addrmode = inFreg} begin makeEA(source); sourcetype := 2; destFreg := dest.regnum; case source.storage of bytte: sourceFreg := 6; wrd:  dest.addrmode = multiple then begin reg1 := 6; maskext(dest,source.addrmode = predecr); makeEA(source); end else begin reg1 := 4; maskext(source,dest.addrmode = predecr); makeEA(dest); end;  sourceFreg := 4; long: sourceFreg := 0; multi: sourceFreg := 5; end; {case} end; end; $END$ end; (*case*) outputcodeword(instrout); for k := 1 to 2 do with extension[k] do if size = 2 then outputcodeword(wext)  end; moveq: begin reg1 := dest.regnum; bit8 := false; with source do if smallval >= 0 then displ := smallval else displ := 256+smallval; end; sub: begin addorsub; if opcode <> sub then goto 1; end; else if size = 4 then outputcodelong(lext) $IF MC68020$ else if size = 6 then begin outputcodeword(w_ext); outputcodelong(l_ext); end $END$; end; {with instruction} if flip then source.addrmode := shortabs; $IF MC68020$ fmovem: begin coprocid := 1; zeros := 0; with extension[getextension] do begin size := 2; fivebits := 16; if source.addrmode = fmultiple then begin sourcetype := 7; fp0 := source.fregs end; (*emit2*) [0]; fp1 := source.fregs[1]; fp2 := source.fregs[2]; fp3 := source.fregs[3]; fp4 := source.fregs[4]; fp5 := source.fregs[5]; fp6 := source.fregs[6]; fp7 := source.fregs[7]; makeEA(dest); end else begin sourcetype := 6; fp0 := {file BODY} procedure body (*fsys: setofsys; fprocp: ctp*); var llp: labelp; curbody,lastmt: stptr; lmark: ^integer; i: integer; s: string[10]; function max(i,j: shortint): shortint; begin if i > j then max := i els dest.fregs[0]; fp1 := dest.fregs[1]; fp2 := dest.fregs[2]; fp3 := dest.fregs[3]; fp4 := dest.fregs[4]; fp5 := dest.fregs[5]; fp6 := dest.fregs[6]; fp7 := dest.fregs[7]; makeEA(source); end; end; end; fmove..flognp1: we max := j; end; BEGIN {body} mark(lmark); WRITELN(OUTPUT); IF FPROCP <> NIL THEN writeln(output,fprocp^.namep^, ' ':max(17-strlen(fprocp^.namep^),0), '[',memavail:1,']'); WRITE(OUTPUT,'<',linenumber:5,'>'); STARTDOTS := SG      DEFINED THEN begin setstrlen(s,0); strwrite(s,1,i,labval:1); ERRORwithinfo(168,'Label: '+s); end; defined := false; isrefed := false; { for later use in codegen } LLP := NEXTLAB; END; if putcode and (totalerrors = 0) then genb pos := ord(anyvarsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'ARRAY'; pos := ord(arraysy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'BEGIN'; pos :ody(curbody,fprocp); if tables and not syntxerr then dumptree(curbody,fprocp); release(lmark); inbody := false; END (*body*); procedure bodyanalyzerinit; begin {bodyanalyzer initialization body} donteval := false; varparm := false; end; = ord(beginsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'CASE'; pos := ord(casesy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'CONST'; pos := ord(consprogram makesymtree; type shortint = -32768..32767; keywordnode = record name: string[20]; left,right: shortint; pos,kind: shortint; end; SYMBOL = (IDENT,COMMA,COLON,SEMICOLON,LPARENT, RPARENT,DOSY,TOSY,DOWNTOSY,Etsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'DIV'; pos := ord(mulop); kind := 3; end; last := last + 1; with keyword[last] do begin name := 'DO'; pos := ord(dosy); kind := NDSY, UNTILSY,OFSY,THENSY,ELSESY,BECOMES, LBRACK,RBRACK,ARROW,PERIOD,BEGINSY, IFSY,CASESY,REPEATSY,WHILESY,FORSY, WITHSY,GOTOSY,LABELSY,CONSTSY,TYPESY, VARSY,PROCSY,FUNCSY,PROGSY,INTCONST, REALCONST,STRINGCONST,NOTSY,MUL0; end; last := last + 1; with keyword[last] do begin name := 'DOWNTO'; pos := ord(downtosy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'ELSE'; pos := ord(elsesy); kind := 0; eOP, ADDOP,RELOP,SETSY,PACKEDSY,ARRAYSY, RECORDSY,FILESY,modulesy,importsy, exportsy,implmtsy,othrwisesy,rangesy, dollarsy,OTHERSY, {***** MODCAL SYMBOLS *****} FORWARDSY,externlsy,trysy,recoversy, anyvarsy); varnd; last := last + 1; with keyword[last] do begin name := 'END'; pos := ord(endsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'EXPORT'; pos := ord(exportsy); kind := 0; end; last keyword: array[1..50] of keywordnode; middle,i,last: shortint; outfile: text; function split(lo,hi: shortint): shortint; var middle: shortint; begin if hi > lo then begin middle := (hi + lo) div 2; keywor := last + 1; with keyword[last] do begin name := 'EXTERNAL'; pos := ord(externlsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'FILE'; pos := ord(filesy); kind := 0; end; last := ld[middle].left := split(lo,middle-1); keyword[middle].right := split(middle+1,hi); split := middle; end else if hi = lo then begin split := lo; keyword[lo].left := 0; keyword[lo].right := 0; end else ast + 1; with keyword[last] do begin name := 'FOR'; pos := ord(forsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'FORWARD'; pos := ord(forwardsy); kind := 0; end; last := last + 1;split := 0; end; begin rewrite(outfile,'symtree.text'); last := 1; with keyword[last] do begin name := 'AND'; pos := ord(mulop); kind := 2; end; last := last + 1; with keyword[last] do begin name := 'ANYVAR';  with keyword[last] do begin name := 'FUNCTION'; pos := ord(funcsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'GOTO'; pos := ord(gotosy); kind := 0; end; last := last + 1; with G     s := ord(procsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'PROGRAM'; pos := ord(progsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'RECORD'; pos := ore(outfile,' '); writeln(outfile,' DC.L ','S',i:1,',', 'N',keyword[i].left:1,',', 'N',keyword[i].right:1); writeln(outfile,' DC.B ', keyword[i].pos:1,',',keyword[i].kind:1); end; writeln(outfile); writeln(outfid(recordsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'RECOVER'; pos := ord(recoversy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'REPEAT'; pos := ord(le,' DEF SYMTREE'); writeln(outfile,' END'); close(outfile,'lock'); end. keyword[last] do begin name := 'IF'; pos := ord(ifsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'IMPLEMENT'; pos := ord(implmtsy); kind := 0; end; last := last + 1; with keyword[lrepeatsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'SET'; pos := ord(setsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'THEN'; pos := ord(thensy); ast] do begin name := 'IMPORT'; pos := ord(importsy); kind := 14; end; last := last + 1; with keyword[last] do begin name := 'IN'; pos := ord(relop); kind := 14; end; last := last + 1; with keyword[last] do  kind := 0; end; last := last + 1; with keyword[last] do begin name := 'TO'; pos := ord(tosy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'TRY'; pos := ord(trysy); kind := 0; en begin name := 'LABEL'; pos := ord(labelsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'MOD'; pos := ord(mulop); kind := 4; end; last := last + 1; with keyword[last] do begin d; last := last + 1; with keyword[last] do begin name := 'TYPE'; pos := ord(typesy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'UNTIL'; pos := ord(untilsy); kind := 0; end; last  name := 'MODULE'; pos := ord(modulesy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'NOT'; pos := ord(notsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := ':= last + 1; with keyword[last] do begin name := 'VAR'; pos := ord(varsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'WHILE'; pos := ord(whilesy); kind := 0; end; last := last + 1;OF'; pos := ord(ofsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'OR'; pos := ord(addop); kind := 7; end; last := last + 1; with keyword[last] do begin name := 'OTHERWISE'; pos with keyword[last] do begin name := 'WITH'; pos := ord(withsy); kind := 0; end; middle := split(1,last); writeln(outfile,'N0 EQU 0'); for i := 1 to last do begin writeln(outfile); write(outfile,'S',i:1);  := ord(othrwisesy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'PACKED'; pos := ord(packedsy); kind := 0; end; last := last + 1; with keyword[last] do begin name := 'PROCEDURE'; po if i < 10 then write(outfile,' '); writeln(outfile,' DC.B ', strlen(keyword[i].name):1, ',''',keyword[i].name,''''); if i = middle then write(outfile,'SYMTREE') else write(outfile,'N',i:1); if i < 10 then writH      {file DEBGDEFINE} import globals,compio,sysglobals; {$Z600} export procedure dumptree (curbody: stptr; fprocp: ctp); - - - - - - - - - - - - - - - - - - - - - - -} module genutils; {utilities for code generation} $INCLUDE 'GENUTIL'$ end; {genutils} $LINENUM 9000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module genexprmod; {code generation for expr{Schema file: DEVDR- compile entire compiler} $SEARCH 'CONVERT'$ $IOCHECK OFF$ $UCSD,MODCAL,DEBUG$ program Compiler (input,output); $INCLUDE 'CHEADING'$ {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} module globals; $INCLUDE 'CCONSTessions} $INCLUDE 'GENEXPDEF'$ $INCLUDE 'GENEXPR'$ end; {genexprmod} $LINENUM 12000${- - - - - - - - - - - - - - - - - - - - - - - - - - } module float_hdw; {code generation for float card} $IF MC68020$ $INCLUDE 'MC68881'$ $END$ S'$ $INCLUDE 'GLOBALS'$ const { Conditional compilation constants } ovflchecking = true; $OVFLCHECK ON$ rangechecking = true; $RANGE ON$ partialevaling = false; $PARTIAL_EVAL OFF$ implement end; {- - - - - - - - - - - - -  $IF not MC68020$ $INCLUDE 'FLOAT'$ $END$ end; {float_hdw} $LINENUM 13000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module genmove; {expression utilities, packing} $INCLUDE 'GENMOVE'$ end; {genmove} $LINENUM 15000${- - - - - - - - - - - - - - - - - -} $INCLUDE 'FORWINIT'$ {abstract module COMPINIT} $INCLUDE 'FORWUTILS'$ $LINENUM 1000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compio; {source input, listing output, lexical analysi- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module codegen; {module codegen: implement section} $INCLUDE 'GENCODE'$ end; {codegen} $LINENUM 18000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module bodyanalyzer; {Ss} $INCLUDE 'IODEF'$ $INCLUDE 'SCANNER'$ end; {compio} $LINENUM 3000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module compdebug; {compiler debugging utilities - all empty routines in production copies} $INCLUDE 'DEBGDEF'$ $INCLyntax analysis for executable statements; tree building} $INCLUDE 'BODYDEF'$ $INCLUDE 'BODYHEAD'$ $INCLUDE 'EXPRESSN'$ $INCLUDE 'STATEMENT'$ $INCLUDE 'BODY'$ end; {bodyanalyzer} $LINENUM 21000${- - - - - - - - - - - - - - - - - - - - - - - - UDE 'DUMPTREE'$ end; {compdebug} $LINENUM 4000${- - - - - - - - - - - - - - - - - - - - - - - - - - -} module symtable; {symbol table entry/lookup, structure manipulation} $INCLUDE 'SYMDEF'$ $INCLUDE 'SYMTABLE'$ $INCLUDE 'STRUCTS'$ end; {sym- - -} module declanalyzer; {Syntax analysis for declarations; symbol table building} $INCLUDE 'DECLDEF'$ $INCLUDE 'PARAMLIST'$ $INCLUDE 'TYP'$ $INCLUDE 'BLOCK'$ end; {declanalyzer} $LINENUM 24000${- - - - - - - - - - - - - - - - - - - - - -table} {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} forward module codegen; {Code generation for the target machine} $INCLUDE 'GENDEF'$ end; forward module genutils; $INCLUDE 'GENUTLDEF'$ end; forward module genmove; $INCL - - - - -} module compinit; {compiler initialization plus general purpose utilities} $INCLUDE 'INITDEF'$ $INCLUDE 'INIT'$ $INCLUDE 'UTILITIES'$ end; {compinit} $LINENUM 26000${- - - - - - - - - - - - - - - - - - - - - - - - - -} import globaUDE 'GENMOVDEF'$ end; forward module float_hdw; $INCLUDE 'FLOATDEF'$ end; $LINENUM 5000${- - - - - - - - - - - - - - - - - - - - - - - - - - - -} module assemble; $INCLUDE 'ASSMDEF'$ $INCLUDE 'ASSEMBLE'$ end; {assemble} $LINENUM 6000${- - - ls,compinit,compio,symtable, declanalyzer,codegen,genutils; begin {Modcal_Cross_Compiler} $INCLUDE 'MAINBODY'$ end. H     I     I     J     J     K     K     L     L