#! /bin/csh -f # script to compile BCPL modules # # usage: compile File # # compiles File.bpl to give File.o # must have an argument if ($#argv == 0) then echo "usage: compile File : compiles File.bpl to File.o" exit 7 endif # cannot have more than one argument if ($#argv != 1) then echo "compile takes only one argument" exit 7 endif $bcplv/bcpl < 0 THEN # { # _write ( Stream, @Buff, Count ) # Count := 0 # } # # Write: (except Sysout) # # Buff%Count := Char # Count := Count + 1 # IF Count = Max THEN # { # _write ( Stream, @Buff, Count ) # Count := 0 # } # # Write: (Sysout) # # Buff%Count := Char # Count := Count+1 # IF Char = '*N' \/ Char = '*P' \/ Count = Max THEN # { # _write ( Sysout, @Buff, Count ) # Count := 0 # } # The Stream Blocks # --- ------ ------ .set NBlocks, 10 # add more if necessary .align 2 # SBlock : [] REF StreamBlock SBlock: .long Sblock0 .long Sblock1 .long Sblock2 .long Sblock3 .long Sblock4 .long Sblock5 .long Sblock6 .long Sblock7 .long Sblock8 .long Sblock9 # add more upto NBlocks-1 (O for a decent Macro Assembler!) # Components of a Stream Block .set flags, 0 .set char, 1 .set stream, 2 .set count, 4 .set max, 8 .set buff, 12 .set bufsize, 1024 .set isfree, 0 .set isEOF, 1 .set isunread,2 .set isnormal,6 .set iswrite, 3 .set flagread, 0 .set flaginit, 1 .set flageof, 2 .set flagunread,4 .set flagwrite, 8 .set nl,012 .set ff,014 Sblock0: # Sysin .byte flagread # Open for Read .byte nl # NL .word 0 # Unix fildes - 0 for Sysin .long 0 # count .long bufsize # max .space bufsize # the buffer Sblock1: # Sysout .byte flagwrite # Open for Write .byte nl # NL .word 1 # Unix fildes - 1 for Sysout .long 0 # count .long bufsize # max .space bufsize # the buffer Sblock2: # Errout .byte flagwrite # Open for Write .byte nl # NL .word 2 # Unix fildes - 2 for Errout .long 0 # count .long bufsize # max .space bufsize # the buffer Sblock3: .byte 1 # Free .byte nl # NL .word -1 # Unix fildes - unset .long 0 # count .long bufsize # max .space bufsize # the buffer Sblock4: .byte 1 .byte nl .word -1 .long 0 .long bufsize .space bufsize Sblock5: .byte 1 .byte nl .word -1 .long 0 .long bufsize .space bufsize Sblock6: .byte 1 .byte nl .word -1 .long 0 .long bufsize .space bufsize Sblock7: .byte 1 .byte nl .word -1 .long 0 .long bufsize .space bufsize Sblock8: .byte 1 .byte nl .word -1 .long 0 .long bufsize .space bufsize Sblock9: .byte 1 .byte nl .word -1 .long 0 .long bufsize .space bufsize # Sblock indices for Sysin and Sysout .set sysin,0 .set sysout,1 .set G16,sysin .set G17,sysout # and for Errout .set errout,2 .set G90,errout # Hidden variables holding current Input and Output Streams curri: .long sysin curro: .long sysout currib: .long Sblock0 currob: .long Sblock1 # String buffers for file name operations sbuff1: .space 256 sbuff2: .space 256 ebuff: .space 256 # unix parameters .set readmode,0 .set readwritemode,2 .set protection,0664 # rw-rw-r-- # CODE OF BCPLIB # ============== # Call Conventions for Internal procedures # # Call/Return by bsbw/rsb # Parameters in r0,r1,... # Results in r0,r1,... # Registers r6 and up PRESERVED .text # Initio ( ) # ------ # # Initialise the IO Library # # None needed - it is all set up statically G38: initio: rsb # Endio ( ) # ----- # # Closedown the IO library # # Close all open streans except Sysin and Sysout # # Flush Sysout G39: endio: movl $2,r8 1: movl SBlock[r8],r0 bbss $isfree,flags(r0),2f movl r8,r0 bsbw close 2: aoblss $NBlocks,r8,1b bsbw flushsysout rsb # FindInput ( Name ) : Stream # --------- # # Open a File for Input # # The Name is a string designating the file # # We recognise two special conventions # # (a) The string "/" designates Sysin or Sysout # # (b) If the string begins with '?', it is a prompt. # The prompt is sent to Sysout and the reply on Sysin # (upto the next newline) is the filename # # We recognise case (a) in the reply to case (b) findinput: G10: movab sbuff1,r1 bsbw getname tstl r0 bneq 1f # not special rsb # special - return Sysin (ie 0) 1: bsbw getblock movl r0,r8 bgeq 2f rsb # no free block 2: movl SBlock[r8],r7 pushl $readmode pushab sbuff1 calls $2,_open tstl r0 bgeq 3f # error on open - free block and return movb $flaginit,flags(r7) rsb 3: clrb flags(r7) movb $nl,char(r7) movw r0,stream(r7) clrl count(r7) movl r8,r0 # Index in r0 rsb # FindOutput ( Name ) : Stream # ---------- # # Likewise, open a file for output # # The file is created by _creat # # Unfortunately, that automatically opens the file in Write mode # We however require the file to be in ReadWrite mode, to allow # for a ReadBack # # Hence, we _create, _close, and _open ! # (too bad the Unix nerds never heard of orthogonality) findoutput: G11: movab sbuff1,r1 bsbw getname tstl r0 bneq 1f # special? movl $sysout,r0 # yes - return Sysout rsb 1: bsbw getblock movl r0,r8 bgeq 2f rsb # no free block 2: movl SBlock[r8],r7 pushl $protection pushab sbuff1 calls $2,_creat pushl r0 calls $1,_close pushl $readwritemode pushab sbuff1 calls $2,_open tstl r0 bgeq 3f # error on open - free block and return movl $flaginit,flags(r7) rsb 3: movb $flagwrite,flags(r7) clrb char(r7) movw r0,stream(r7) clrl count(r7) movl $bufsize,max(r7) movl r8,r0 # Index in r0 rsb # Input ( ) : Stream # ----- # # Return the current input stream input: G24: movl curri,r0 rsb # Output ( ) : Stream # ------ # # Return the current output stream output: G25: movl curro,r0 rsb # SelectInput ( Stream ) # ----------- # # Set the current input to the given Stream selectinput: G14: movl r0,curri movl SBlock[r0],currib rsb # SelectOutput ( Stream ) # ------------ # # Set the current output to the given Stream selectoutput: G15: movl r0,curro movl SBlock[r0],currob rsb # Rdch ( ) : Char # ---- # # Read a character from the current stream rdch: G22: movl currib,r8 # get stream block bitb $isnormal,flags(r8) # normal? beql 2f # no - is unread or EOF bbcc $isunread,flags(r8),1f # unread? movzbl char(r8),r0 rsb 1: mcoml $0,r0 # must be EOF : return -1 rsb 2: movl count(r8),r0 bneq 5f # refill? tstl curri bneq 3f bsbw flushsysout # interlock 3: pushl $bufsize pushab buff(r8) movzwl stream(r8),-(sp) calls $3,_read movl r0,max(r8) # chars read bgtr 4f # EOF? bisb2 $flageof,flags(r8) mcoml $0,r0 rsb 4: movl count(r8),r0 5: movzbl buff(r8)[r0],r0 movb r0,char(r8) aoblss max(r8),count(r8),6f # end of input chunk? clrl count(r8) # yes - next call will refill 6: # char in r0 rsb # Wrch ( Char ) # ---- # # Write the character to the current output # # The output is buffered until the buffer is full, or, # in the case of Sysout, until either the buffer is full # or a vertical format effector (NL,FF) is written wrch: G23: movl currob,r8 movl count(r8),r1 movb r0,buff(r8)[r1] aoblss max(r8),count(r8),2f 1: # we flush the buffer if it is full movl curro,r0 bsbw flush rsb 2: cmpl curro,$sysout bneq 3f # or if the stream is Sysout... cmpb r0,$nl # ...and the char is '*N'... beql 1b cmpb r0,$ff # ...or '*P' beql 1b 3: rsb # Unrdch ( ) # ------ # # Unread the last character read # # This is a one-character unread only, ie it is idempotent # We simply set the unread flag, since rdch() stores the # char last read in a safe place in the stream block # # Note that unrdch() after EOF puts back the last real char # Note also that we have arbitrarily defined unrdch() before # any read as returning NL. unrdch: G26: movl currib,r0 bisb2 $flagunread,flags(r0) rsb # Endrd ( ) # ----- # # Close the current input stream endrd: G18: movl curri,r0 brb close # Endwt ( ) # ----- # # Close the current output stream endwt: G19: movl curro, r0 # fall through # Close ( Steam ) # ----- # # Close the given stream # # Any data in the buffer of an output stream must be flushed # # The file must be closed and the stream block reset close: pushl r8 movl SBlock[r0],r8 bbc $iswrite,flags(r8),1f # if write stream bsbw flush # flush 1: movzwl stream(r8),-(sp) calls $1,_close movb $flaginit,flags(r8) # reset stream block movl (sp)+,r8 rsb # FlushSysout ( ) # ----------- # # Flush any pending output on Sysout flushsysout: movl $sysout,r0 # fall through # Flush ( Stream ) # ----- # # Flush any pending output on the given stream # # If there is no pending output, do nothing flush: pushl r8 movl SBlock[r0],r8 tstl count(r8) beql 1f pushl count(r8) pushab buff(r8) movzwl stream(r8),-(sp) calls $3,_write clrl count(r8) 1: movl (sp)+,r8 rsb # GetBlock # -------- # # Get the next free Stream Block and return its index # # If there is no free block, return a negative value getblock: movl $2,r0 1: movl SBlock[r0],r1 bbsc $isfree,flags(r1),2f aoblss $NBlocks,r0,1b # failed! mnegl $2,r0 rsb 2: # found one! rsb # Getname ( Name, StringBlock ) : Boolean # ------- # # Get a file name # # This routine implements the IO conventions for a file name # # The text of the name (or prompt) is passed in R0 as an Ocode string # The true filename will be stored in the StringBlock as a C string, ie # NUL-terminated # # The result returned is FALSE if the file name is in fact the special # string designating sysin or sysout, and TRUE otherwise # # We also (as a temporary measure) convert the name to lower case # # We also implement a limited form of parsing for environment variables: # # if the string BEGINS with '$' we take the following chars, # upto the first '/' or NUL, to be a possible environment variable getname: movq r7,-(sp) # save r7,r8 movl r1,r7 mull3 $4,r0,r8 movzbl (r8)+,r0 cmpb (r8),$'? # prompt? bneq 1f # yes - send to sysout pushl r0 pushl r8 pushl $sysout calls $3,_write # and read reply into buffer pushl $256 pushl r7 # string buffer to be read into pushl $sysin calls $3,_read decl r0 clrb (r7)[r0] # overwrite NL at end with NUL brb PromptDone 1: movl r0,r4 # length count movl r7,r2 # buffer to copy name into 2: movb (r8)+,r3 cmpb r3,$'A blssu 3f cmpb r3,$'Z bgtru 3f addb2 $32,r3 3: movb r3,(r2)+ sobgtr r4,2b clrb (r2)+ PromptDone: # at this point the string is in the buffer # (with trailing NUL) # now check for a possible environment variable movl r7,r8 cmpb (r8)+,$'$ # begins with '$'? bneq EnvDone # no - skip movab ebuff,r1 # yes 1: movb (r8)+,r2 # copy into ebuff beql 2f # all between '$' and first NUL or '/' cmpb r2,$'/ beql 2f movb r2,(r1)+ brb 1b 2: clrb (r1) # pad with NUL pushab ebuff calls $1,_getenv tstl r0 # was it a name? beql EnvDone # no # yes - copy value into ebuff movab ebuff,r1 3: movb (r0)+,(r1)+ bneq 3b # and append rest of old name cmpb -(r1),-(r8) 4: movb (r8)+,(r1)+ bneq 4b # and copy concatenated result back into string buff movab ebuff,r0 movl r7,r1 5: movb (r0)+,(r1)+ bneq 5b EnvDone: cmpb (r7)+,$'/ bneq 1f tstb (r7) bneq 1f clrl r0 # special case "/" movq (sp)+,r7 rsb 1: mcoml $0,r0 # general case movq (sp)+,r7 rsb # Rewind ( ) : Stream # ------ # # Rewind the current input stream # # Return as result the (possibly new) stream designating the rewound file rewind: G20: movl curri,r7 movl SBlock[r7],r8 pushl $0 pushl $0 movzwl stream(r8),-(sp) calls $3,_lseek # resets pointer to beginning bicb2 $isEOF,flags(r8) # can't be EOF any more clrl count(r8) # reset count movl r7,r0 # result is stream index rsb # ReadBack ( ) : Stream # -------- # # Also known as EndToInput # # Rewind the current output stream for reading back as input # # Return the (possibly new) stream designating the rewound file # # NOTE that this routine is INDIVISIBLE readback: G21: movl curro,r7 movl r7,r0 bsbw flush # flush output file movl SBlock[r7],r8 pushl $0 pushl $0 movzwl stream(r8),-(sp) calls $3,_lseek # and rewind bicb2 $iswrite,flags(r8)# change to read mode clrl count(r8) # reset count movl $sysout,curro # must unset current output! movl r7,r0 # result is stream index rsb # Direct Access IO # ------ ------ -- # # Since this is done to or from buffers supplied by the caller, # there is no need for any of the Stream Block apparatus # # We therefore use the Unix "fildes" directly as the stream code # However, to prevent any confusion with a stream block index, we # bias the value .set dbias,50 # The transput procedures use the following conventions # # blocks are 512 bytes # the first block is #1 # the buffer is designated by its scaled longword address # OpenDirect ( Name ) : Stream # ---------- # # Open the given file for bidirectional direct access opendirect: G30: movab sbuff1,r1 bsbw getname # no special cases pushl $readwritemode pushab sbuff1 calls $2,_open addl2 $dbias,r0 # result is fildes + bias rsb # ReadDirect ( Stream, BlockNumber, Buffer ) # ---------- # # Read the given block into the buffer readdirect: G31: subl2 $dbias,r0 # fildes = stream - bias decl r1 # 1-origin # parameters of _read pushl $512 mull3 $4,r2,-(sp) pushl r0 # parameters of _lseek pushl $0 mull3 $512,r1,-(sp) pushl r0 calls $3,_lseek calls $3,_read rsb # WriteDirect ( Stream, BlockNumber, Buffer ) # ----------- # # Write the given block from the buffer writedirect: G32: subl2 $dbias,r0 # fildes = stream - bias decl r1 # 1-origin # parameters of _write pushl $512 mull3 $4,r2,-(sp) pushl r0 # parameters of _lseek pushl $0 mull3 $512,r1,-(sp) pushl r0 calls $3,_lseek calls $3,_write rsb # CloseDirect ( Stream ) # ----------- # # Close the direct access stream closedirect: G33: subl3 $dbias,r0,-(sp) calls $1,_close rsb statusfile: G40: # DeleteFile ( Name ) # ---------- # # Delete the given file # # Note that the file name conventions are still in force! deletefile: G41: movab sbuff1,r1 bsbw getname pushab sbuff1 calls $1,_unlink rsb # RenameFile ( OldName, NewName ) # ---------- # # Rename the given file # # This is done on Unix by _linking the new name and the _unlinking the old renamefile: G42: pushl r1 # save r1 movab sbuff1,r1 bsbw getname # old name into sbuff1 movl (sp)+,r0 movab sbuff2,r1 bsbw getname # new name into sbuff2 pushab sbuff2 pushab sbuff1 calls $2,_link tstl r0 # good new link? bneq 1f # NO! - DO NOT DELETE OLD LINK! pushab sbuff1 # yes - delete old link calls $1,_unlink 1: rsb # END of BCPLIB # ============= || CGVAX || ===== || The Ocode Codegenerator for the DEC VAX-11 || || Version 1.65 PILOT || || Robert Firth RMCS Shrivenham March 1981 || || Versions and Dates || || Begun 3 Mar 81 || V 1.00 22 Jun 81 || V 1.20 29 Jun 81 || V 1.40 24 Jul 81 || V 1.50 14 Aug 81 || V 1.60 20 Jan 82 || V 1.65 8 Oct 82 || || This computer software is Crown Copyright 1981 || Unix Version || ============ || || U 1.65 - 1 15 Nov 84 || || This version has been amended to generate code for Vax/Unix. || The major change is of course in the lexical form of the || Assembler, which follows the Unix "standard", copied from || the old PDP-11 "standard". In principle, there is no reason || why the generated code should not be identical, but unfortunately, || the Unix Assembler and Linker cannot handle many of the idioms || emitted for VAX/VMS, so the generated code is substantially worse. || || In particular || || Externals and relocatable symbols may not be combined in || the same experession. This precludes use of a base register || pointing to static data, and so we must use longword offsets. || The code is no longer position independent || || Forms such as "relocatable / 4" are not allowed, so we must || construct a scaled address the hard way, even when the base || is statically known || || The Global Vector cannot be initialised piecemeal in several || modules, so we must go back to the stupid PE3200 design, and || define 400 global symbols to initialise the vector. || || The location counter cannot be referenced explicitly, so idioms || such as ".+4" must be replaced by jumps to labels. However, || the "nf" convention is used to avoid creating more L labels || || All generated labels now begin with L since the "as" default || seems to be to make all other labels global (!) || || None of this would be necessary were Unix (TM) software not || for the most part truly disgusting cruft. || || (TM): Unix is a trademark of Bell Labs, who for some incomprehensible || reason want their part in its creation to be publicised || This codegenerator converts Ocode into symbolic Assembler || for the VAX-11. It is the back end of the RMCS BCPL, || Coral, Algol &c compilers. || For a full description of the design considerations behind || the codegeneration process, please refer to CGVAX.DOC GET "CGVAX.HDR" || Start ( ) || ----- || || The codegenerator starts here || || The input file is set up, and all files opened. || Options are read, the codegenerator initialised, || and codegeneration performed. The program then || cleans up and exits LET start() BE { writes("VAX-11 Codegenerator V1.66U*N") ocodefile := "TEMP.OCD" openfiles() options() initialise() || since codegeneration may take more or less space, || the space to be used is the value of StatSize, || which may be set by an option. We therefore call || CodeGenerate indirectly via Aptovec aptovec(codegenerate,statsize) finalise() } || OpenFiles ( ) || --------- || || Open the Codegenerator input and output files || || The input file is in OcodeFile, and must be opened first || The output file is given as the first line of OcodeFile || || File opening is done by a separate routine that checks for errors || || The name of the output file, with any device or user stripped, || is emitted as its TITLE AND openfiles() BE { LET outfile = VEC filenamemax/bytesperword AND fp,tp = 0,0 ocode := getfile(findinput,ocodefile) selectinput(ocode) || read first line of Ocode file || and accumulate as a string in OutFile || fp points to end || np points to end of any path ('/') { ch := rdch() IF ch='*N' BREAK fp := fp + 1 IF ch='/' DO tp := fp putbyte(outfile,fp,ch) } REPEAT putbyte(outfile,0,fp) palout := getfile(findoutput,outfile) selectoutput(palout) || strip device or user from file name, || then write identification and title to Assembler file UNLESS tp=0 DO { LET len = fp - tp FOR i=1 TO len DO putbyte(outfile,i, getbyte(outfile,i+tp)) putbyte(outfile,0,len) } writef(" # CGVAX V1.66U*N*N", outfile) } || GetFile ( openfunction, filename ) : Stream || ------- || || Open a file, checking for errors || || If a file is correctly opened, the stream is returned as result || If an error occurs, the user is given a chance to correct it. || If he fails, the program is abandoned || || Note that this function reqires the current output to be sysout AND getfile(openfunction,filename) = VALOF { LET stream = openfunction(filename) IF stream>=0 RESULTIS stream || valid open writef("Error %N with file %S*N", -stream, filename) stream := openfunction("?Alternative ") IF stream>=0 RESULTIS stream || valid alternative stop(2) } || Options ( ) || ------- || || Read codegenerator options AND options() BE { || set up default values iscoral := FALSE || BCPL - labels and routines are first-class objects double := FALSE || floating single precision flosize := 1 || size of floating argument flotype := t.f || type of floating argument noopt := FALSE || perform optimisation xref := 0 || cross reference file posind := FALSE || is PIC wanted smallarray := FALSE || lots of arrays addprocname:= FALSE || don't include routine names in code vglob := globmax || all globals are genuine statsize := 5000 || default free storage space || read options { ch := rdch() IF ch='*N' BREAK IF ch>='a' DO ch := ch + ('A'-'a') SWITCHON ch INTO { CASE 'C' : smallarray := TRUE; LOOP || arrays total <32k bytes CASE 'E' : double,flosize,flotype := TRUE,2,t.d; LOOP CASE 'J' : xref := findoutput("xref.lst"); LOOP CASE 'K' : addprocname := TRUE; LOOP CASE 'M' : posind := TRUE || PIC - requires IsCoral CASE 'Q' : iscoral := TRUE; LOOP || Coral/Algol - labels and || procs cannot be assigned CASE 'S' : statsize := readn(); ENDCASE CASE 'U' : noopt := TRUE; LOOP || no optimisation CASE 'T' : vglob := readn(); ENDCASE || globals above this || are overlay entry points DEFAULT : LOOP } unrdch() } REPEAT || compute size of floating values (in longwords) flosize := double -> 2,1 flotype := double -> t.d,t.f } || Report ( Message, Argument ) || ------ || || Emit an error report || || The report is sent on Sysout, and comprises the || message, possibly with an argument. || The source line number can usually be given, since it is || indicated by the Ocode Line directive || Afterwards, the Palout stream is restored, since || that is the normally current output stream AND report(message,argument) BE { selectoutput(sysout) writef("Codegenerator error near source line %N: ", sourceline) writef(message,argument) newline() selectoutput(palout) } || Initialise ( ) || ---------- || || Set up the Codegenerator initial state AND initialise() BE { || set counters to zero codesize, rosize, rwsize, instructions := 0,0,0,0 || set up the PSECT cues || || readonly data (preset) and strings are stored in the same || Psect as the code, to allow them to be referenced by word || offsets from PC rather than longword offsets || However, to allow counting of code and data separately, the || relevant Psect strings must be distinct || Hence, the same string is repeated cue.code := ".text" cue.string := ".text" cue.preset := ".text" cue.static := ".data 0" cue.statarr := ".data 1" cue.global := "" || initial section is null cue := 0 || write the Assembler header writes(" .globl GG*N*N") || define base of Global Vector // setcue(cue.global) // writes("G=.*N") } || Finalise ( ) || -------- || || End of Codegeneration || || Finish Assembler output, print report, and close files AND finalise() BE { writes("*N # End*N") endwrite() selectoutput(sysout) writef("%N bytes code, %N data RO, %N data RW, %N instructions*N", codesize, rosize*4, rwsize*4, instructions) endread() deletefile(ocodefile) } || CodeGenerate ( ) || ------------ || || Perform codegeneration from Ocode to VAX Assembler || || The codegenerator data areas are set up once for all || || Then, the Ocode segments are read and translated AND codegenerate(statvec,statsize) BE { || set up data areas || only the last - DataV - is of variable size labv := statvec || label values labt := labv+labmax || label states labbias:= labt+labmax || stack bias at label argv := labbias+labmax || pending operand vector slaves := argv+argmax || saved register slaves mainslave := slaves+(slavemax+1) || current register slave valslave := mainslave + (slavesize+10)|| value tracking cells datav := valslave + (vsmax+1) || static data vector datat := statvec+statsize || top of data vector || set section letter || this is used to form label names in each section || so the labels are always unique sect := 'A' || set up table of conditional branch inversions invert := (TABLE bneq,beql,bgeq,bleq,bgtr,blss,bgequ,blequ,bgtru,blssu) - beql || and table to convert signed branches into unsigned unsigned := (TABLE beql,bneq,blssu,bgtru,blequ,bgequ) - beql || and table of bit masks mask := TABLE 0, #1,#3,#7, #17,#37,#77, #177,#377,#777, #1777,#3777,#7777, #17777,#37777,#77777, #177777,#377777,#777777, #1777777,#3777777,#7777777, #17777777,#37777777,#77777777, #177777777,#377777777,#777777777, #1777777777,#3777777777,#7777777777, #17777777777 || translate the Ocode segments { op := readop() || At end we are returned a special opcode IF op=s.end BREAK || set up segment initial state loadp := 0 datap,dataf := datav,datat labnumber := labmax FOR i=0 TO labmax DO labt!i,labbias!i := l.null,0 redlab := 0 labv!0 := 30000 initslaves() || initialise the code section sourceline := 0 setcue(cue.code) initstack(framesize) incode,frame,bias := FALSE,0,0 || Read the Ocode scan() || emit the data section cgstatics() || emit the linkage directives setcue(cue.global) FOR i=0 TO labmax DO IF labt!i=l.global DO { LET g = labv!i IF g'E',ch) ch := rdch() } REPEATUNTIL ch<='*S' putbyte(v,0,p) RESULTIS storevec(v,p) } || GetString ( Length ) : String || --------- || || Read an Ocode string operand, store it in the DataV vector, || and return a pointer to it AND getstring(length) = VALOF { LET v = VEC 255/bytesperword FOR i=1 TO length DO putbyte(v,i,readn()) putbyte(v,0,length) IF (length/\1)=0 DO putbyte(v,length+1,0) RESULTIS storevec(v) } || StoreVec ( V ) : Pointer || -------- || || Store the vector V in the DataV area and return a pointer to it || || The vector is stored in the upper part of DataV, || that is, the part controlled by DataF || It is necessary to check that DataV is not exhausted AND storevec(v) = VALOF { LET words = stringlength(v)/bytesperword dataf := dataf - (words+1) checkdata() FOR i=0 TO words DO dataf!i := v!i RESULTIS dataf } || InitStack ( Size ) || --------- || || Initialise the Ocode simulated stack with a local space || of the given size || || The simulated stack pointer SSP is set to Size || || It is assumed that there are no pending operands and || no pending operator, so Arg1, Arg2, and PendingOp are || set appropriately AND initstack(size) BE { ssp := size arg2,arg1 := argv,argv+argsize pendingop := s.none typeof!arg2,modeof!arg2,valueof!arg2,locof!arg2 := t.i,k.p,ssp-2,ssp-2 typeof!arg1,modeof!arg1,valueof!arg1,locof!arg1 := t.i,k.p,ssp-1,ssp-1 } || Stack ( Size ) || ----- || || Modify the Ocode stack to be of the given size. || || It is assumed that there is no pending operation, || so PendingOp is reset || || There are three cases || || a. Op is s.stack and new size is bigger than old || || we are elaborating local declarations. All operands are || properly stacked (using Store) and we reinitialise. || || NOTE that this assumes all pending operands are the values || of the corresponding local variables || || b. new size is smaller than old || || we are deleting operands or local space; there may be || stacked operands, so we lower the stack. However, we || must do so by discarding values one at a time, and we || must not fall through the bottom of ArgV || || c. new size is bigger than old (and Op is s.mark) || || we are creating a stack frame: there may be stacked || operands, so we load dummy arguments to fill the space AND stack(size) BE { pendingop := s.none TEST size > ssp+3 /\ op=s.stack THEN { store(0,TRUE) initstack(size) } OR { WHILE ssp>size DO { IF arg2=argv DO { TEST size = ssp-1 THEN { ssp := size typeof!arg1,modeof!arg1,valueof!arg1,locof!arg1 := typeof!arg2,modeof!arg2,valueof!arg2,ssp-1 typeof!arg2,modeof!arg2,valueof!arg2,locof!arg2 := t.i,k.p,ssp-2,ssp-2 } OR initstack(size) BREAK } ssp := ssp - sizeof(arg1) arg1,arg2 := arg1-argsize,arg2-argsize } WHILE size>ssp DO loadint(op=s.mark->k.mark,k.p, ssp) } } || Store ( Down, Force ) || ----- || || Store the operands in the topmost Down cells of the Ocode || simulated stack onto the true stack || || This is called in two circumstances || || a. On a true stack reinitialisation, when all operands must || be stored. This is shown by Force=TRUE || || b. Before a routine call or similar, when only the volatile || operands (those using registers) must be stacked. This || is shown by Force=FALSE. AND store(down,force) BE { LET arg,loc = argv,locof!argv IF down>=0 DO down := -1 perform(k.p,0) down := ssp + down UNTIL loc>down DO { IF force \/ regusedby(arg)>=0 DO storeloc(arg) loc := loc + sizeof(arg) arg := arg + argsize } } || StoreLoc ( Arg ) || -------- || || Store the given argument in its correct position on the Ocode stack AND storeloc(arg) BE UNLESS islocal(arg) DO { movearg(arg,k.p,locof!arg) } . GET "CGVAX.HDR" || CGstatics ( ) || --------- || || Emit the static data and linkage cues for the current segment || || There are three kinds of data || || read only : to go in PSECT PRESET || || read write: to go in PSECT STATIC || || strings : || flo consts: to go in PSECT STRING || || These are distinguished by being preceded by labels || ConstLab, DataLab, and StringLab respectively || || Flo consts are representations of in-line floating operands, which || could in principle be emitted in line. However, the VAX assembler || generated incorrect code for double precision constants (and also || for G and H format constants) as immediate operands, so for the || present this indirect approach is necessary || || The data directives are held in DataV, in two word cells; || the first cell is the directive and the second the value || || Two passes are made over the structure || || First pass: emit preset and static || || Second pass: emit strings and flo consts || || During both passes, the size of the generated data is added || to the approprate count, usually by the output directive LET cgstatics() BE { LET oddword = FALSE compalign() FOR i=datav TO datap-1 BY 2 DO { LET k,v,c = i!0,i!1,cue.static SWITCHON k INTO { CASE s.lnf: CASE s.stringlab: i := i+2 ENDCASE CASE s.constlab: c := cue.preset CASE s.arraylab: IF c=cue.static DO c := cue.statarr CASE s.datalab: IF oddword Do { compalign() oddword := FALSE } setcue(c) compdl(v) ENDCASE CASE s.root: i := i+2 { LET os,r = i!0,i!1 writef(" .set LX%C%N, L%C%N + %N*N", sect,r, sect,v, os) c := cue setcue(cue.preset) comproot(v,os,r) setcue(c) } ENDCASE CASE s.iteml: compwl(v) ENDCASE CASE s.items: compstrl(v) ENDCASE CASE s.itemn: compd(v) ENDCASE CASE s.itemb: CASE s.itemh: comphw(v) oddword := ~oddword IF oddword DO addsize(1) ENDCASE CASE s.itfz: CASE s.itfi: v := "0.0" CASE s.itemf: compf(v) ENDCASE CASE s.space: compblk(v) ENDCASE } } || emit strings and floating constants setcue(cue.string) FOR i=datav TO datap-1 BY 2 DO SWITCHON i!0 INTO { CASE s.root: i := i+2 ENDCASE CASE s.stringlab: compdl(i!1) compstr(i!3) ENDCASE CASE s.lnf: compdl(i!1) compf(i!3) ENDCASE } } || SetGlobal ( G ) || --------- || || Emit the directive establishing the global cell G || as the current context || || Cell G should be a true Global, not a linker cue AND setglobal(g) BE { setcue(cue.global) writef(" .globl G%N", g) } || CGdata ( k, v ) || ------ || || Store the data directive K with value V || || Data directives are stored in the DataV vector, and the || current position is pointed to by DataP || || There are two special cases || || byte data: this is generated as a sequence of ItemB directives || but is stored as halfwords. Each ItemB is therefore || collapsed with any preceding ItemB to make an ItemH || || code cells: BCPL procedures and labels are first class objects, || and so generate static cells initialised with their || code values. However, there is an optimisation that || removes this facility, controlled by option IsCoral || The case is detected by a group || || (DataLab L), (ItemL L+1) || || Both directives are deleted, and the label state of L || (in LabT) is set to indicate the optimisation AND cgdata(k,v) BE { LET a,b = datap!-1,datap!-2 TEST k=s.itemb /\ b=s.itemb THEN datap!-2,datap!-1 := s.itemh,a+v*256 OR TEST iscoral /\ k=s.iteml /\ b=s.datalab THEN labt!a,labt!v,datap := l.proc,l.proc,datap-2 OR { || normal case datap!0,datap!1,datap := k,v,datap+2 checkdata() } } || Checkdata ( ) || --------- || || Check that the static data vector DataV is not exhausted || || The space is claimed upwards by DataP and downwards by DataT, || and when they meet, the space is exhausted || || No recovery is possible so we abandon AND checkdata() BE { IF datap>=dataf DO { report("Static space full") stop(2) } } . GET "CGVAX.HDR" || Scan ( ) || ---- || || Read an Ocode segment || || This is the main driving routine of the codegenerator. || It reads each Ocode operation in turn and switches into || the appropriate translation code. Operations are read || in turn until the end of the segment, which is indicated || by the S.GLOBAL directive LET scan() BE { LET f,g,n = loadint,loadflo,0 SWITCHON op INTO { || Load and Store Directives || ------------------------- || integer addressed indirectly by local CASE s.sip: f := storeint CASE s.lip: stackvar(f,k.ip); ENDCASE || integer addressed indirectly by label CASE s.sil: f := storeint CASE s.lil: f(k.il,readl()); ENDCASE || integer addressed indirectly by number (ie absolute) CASE s.sin: f := storeint CASE s.lin: f(k.abs,readn()); ENDCASE || floating addressed indirectly by local or nonlocal CASE s.sipf: g := storeflo CASE s.lipf: stackvar(g,k.ip); ENDCASE || floating addressed indirectly by label CASE s.silf: g := storeflo CASE s.lilf: g(k.il,readl()); ENDCASE || floating addressed absolutely CASE s.sinf: g := storeflo CASE s.linf: g(k.abs,readn()); ENDCASE || integer local or nonlocal CASE s.sp: f := storeint CASE s.lp: stackvar(f,k.p); ENDCASE || integer global CASE s.sg: storeint(k.g,readn()); ENDCASE || note that a load of a cell above the top of the Global Vector || is a reference to an external cue and the GLOBAL directive must || be emitted (the addressing is handled by CompArg) CASE s.lg: n := readn() IF n>=vglob DO writef(" .globl G%N*N", n) loadint(k.g,n) ENDCASE || integer static CASE s.sl: storeint(k.l,readl()); ENDCASE CASE s.ll: n := readl() TEST labt!n=l.proc THEN loadint(k.al,n-1) OR TEST labt!n=l.extern THEN loadint(k.al,n) OR loadint(k.l,n) ENDCASE || floating local or nonlocal CASE s.spf: g := storeflo CASE s.lpf: stackvar(g,k.p); ENDCASE || floating global CASE s.sgf: g := storeflo CASE s.lgf: g(k.g,readn()); ENDCASE || floating static CASE s.slf: g := storeflo CASE s.llf: g(k.l,readl()); ENDCASE || true addresses CASE s.lap: n := readn() IF frame=0 DO { loadint(k.ap,n) ENDCASE } getframe(frame) loadint(k.anr+(r.e<<6), 4*n) frame := 0 ENDCASE CASE s.lag: loadint(k.ag,readn()); ENDCASE CASE s.lal: loadint(k.al,readl()); ENDCASE || scaled addresses || load true address and generate a scaling operator || || NOTE: these are a BCPL historical relic CASE s.llp: loadint(k.ap,readn()); pendingop := s.atoi; ENDCASE CASE s.llg: loadint(k.ag,readn()); pendingop := s.atoi; ENDCASE CASE s.lll: loadint(k.al,readl()); pendingop := s.atoi; ENDCASE || constants CASE s.ln: loadint(k.n,readn()); ENDCASE CASE s.true: n := -1 CASE s.false:loadint(k.n,n); ENDCASE CASE s.lfi: CASE s.lfz: loadflo(k.n,0); ENDCASE || floating constant || || the original code read || || CASE s.lnf: loadflo(k.fc,getflo()); ENDCASE || || Unfortunately, there is a bug in the DEC VAX assembler that || causes double precision immediate operands to be rounded to || single precision. The present code therefore addresses such || constants indirectly via a label into String space || || When the bug is fixed, the old code may be restored CASE s.lnf: f := getflo() // IF double DO // bug not in Unix // { // n := nextlab() // loadflo(k.l,n) // labt!n := l.preset // cgdata(s.lnf,n) // cgdata(0,f) // ENDCASE // } loadflo(k.fc,f) ENDCASE CASE s.lstr: n := nextlab() cgdata(s.stringlab,n) cgdata(0,getstring(readn())) loadint(k.string,n) ENDCASE || undefined operand CASE s.query: loadint(k.query,0); ENDCASE || indirection CASE s.itof: UNLESS double ENDCASE CASE s.rv: CASE s.rvb: CASE s.rvf: CASE s.rvtf: CASE s.itoa: CASE s.ftoa: cgrv(TRUE) ENDCASE CASE s.rvs: cgrvs() ENDCASE CASE s.stind: CASE s.stindb: CASE s.stindf: CASE s.stindtf: cgstind() ENDCASE || byte addresses are true addresses CASE s.atob: CASE s.btoa: ENDCASE || operations for which special treatment is possible CASE s.index: op := s.plus CASE s.plus: CASE s.minus: CASE s.mult: CASE s.div: CASE s.neg: CASE s.plusf: CASE s.minusf: CASE s.mulf: CASE s.divf: CASE s.negf: CASE s.eqv: CASE s.not: CASE s.logand: CASE s.atoi: CASE s.atof: combine() IF op=0 ENDCASE || operations for which there is no special treatment CASE s.rem: CASE s.eq: CASE s.ne: CASE s.ls: CASE s.gr: CASE s.le: CASE s.ge: CASE s.eqf: CASE s.nef: CASE s.lsf: CASE s.grf: CASE s.lef: CASE s.gef: CASE s.logor: CASE s.neqv: CASE s.lshift: CASE s.rshift: CASE s.power: CASE s.ipower: CASE s.fix: CASE s.float: CASE s.rfloat: UNLESS cgadd() DO perform(k.r,-1) pendingop := op checkconst() checkreverse() checkspecial() ENDCASE || partword operations CASE s.bitslv: perform(k.r,-1) n := readn() cgbitslv(n,readn()) ENDCASE CASE s.bitsrv: CASE s.signrv: cgbits(); LOOP || stack operations CASE s.mark: CASE s.stack: perform(k.p,0) IF op=s.mark DO { store(0,FALSE) lastreg := r.last } stack(readn()) ENDCASE CASE s.reload: n := readn() arg1 := arg1 + n*argsize arg2 := arg1 - argsize ssp := locof!arg1 + sizeof(arg1) ENDCASE CASE s.store: store(0,TRUE) ENDCASE CASE s.level: loadframe(readn()) ENDCASE CASE s.frame: frame := readn(); ENDCASE || jumps CASE s.longjump: cglongjump() ENDCASE CASE s.jump: n := readl() store(0,TRUE) setlabbias(n) n := testlab(n) IF n=0 LOOP GOTO labset CASE s.jt: n := TRUE CASE s.jf: cgbranch(n,readl()) ENDCASE CASE s.goto: perform(k.r,-1) store(-2,TRUE) setbias(0) cgjump() ENDCASE CASE s.switchon: cgswitch(readn()) ENDCASE || conditional expressions CASE s.fres: CASE s.dres: CASE s.res: n := readl() cgresult(n) n := testlab(n) IF n=0 LOOP GOTO labset CASE s.rfstack: CASE s.rdstack: CASE s.rstack: stack(readn()) loadarg(op=s.rfstack->flotype,t.i, k.r,r.first) IF op=s.rdstack DO loadint(k.r,r.second) ENDCASE || labels CASE s.labr: CASE s.lab: perform(k.p,0) n := readl() labset: IF n>=labnumber DO { report("Code segment too big") stop(2) } TEST op=s.lab THEN { IF labt!n=l.null ENDCASE setlabbias(n) restoreslave(n) clearallvs() } OR { labbias!n := bias clearallregs() } compcl(n) incode := TRUE ENDCASE CASE s.labx: n := readl() setbias(0) clearallregs() compdl(n) UNLESS labt!n=l.proc \/ labt!n=l.global DO labt!n,labv!n := l.set,loadp incode := TRUE ENDCASE || procedure operations CASE s.entry: n := readn() cgentry(n,readl()) ENDCASE CASE s.save:cgsave(readn()) ENDCASE CASE s.startproc: cgstartproc(n,readn()) ENDCASE CASE s.ffnap: CASE s.fnap: CASE s.rtap: perform(k.p,-1) n := readn() TEST n<=1 THEN cgapply(n,readn()) OR cgapply(0,n) ENDCASE CASE s.ffnrn: CASE s.fnrn: CASE s.rtrn: cgreturn() ENDCASE CASE s.endproc: n := readn() writef(" # End of L%C%N with stack %N*N", sect,readl(),n) ENDCASE || directives, code inserts &c CASE s.root: { LET m = readl() LET os = readn() LET v = readl() IF labt!v=l.proc ENDCASE labt!v,labv!v := l.root,labt!m cgdata(s.root,m) cgdata(os,v) } ENDCASE CASE s.line: sourceline := readn() writef(" # Line %N*N", sourceline) ENDCASE CASE s.xref: cgxref(); ENDCASE CASE s.code: cgcode(); ENDCASE || data directives CASE s.datalab: n := readl() labt!n := l.static cgdata(op,n) ENDCASE CASE s.arraylab: n := readl() labt!n := l.statarr cgdata(op,n) ENDCASE CASE s.constlab: n := readl() UNLESS labt!n=l.proc DO labt!n := l.preset cgdata(op,n) ENDCASE CASE s.iteml: cgdata(op,readl()) ENDCASE CASE s.itm: n := maxint CASE s.itz: cgdata(s.itemn,n) ENDCASE CASE s.itfi: CASE s.itfz: cgdata(op,0) ENDCASE CASE s.space: CASE s.itemb: CASE s.itemn: cgdata(op,readn()) ENDCASE CASE s.itemf: cgdata(op,getflo()) ENDCASE CASE s.items: n := nextlab() cgdata(s.items,n) cgdata(s.stringlab,n) cgdata(0,getstring(readn())) ENDCASE || Linkage directives CASE s.setgv: n := readn() setglobal(n) compd(readn()) op := readop() IF op=s.setgv LOOP setcue(cue.code) LOOP CASE s.setgl: n := readn() { LET l = readl() labt!l,labv!l := l.global,n } ENDCASE CASE s.setext: { LET n = readn() LET l = readl() LET s = getstring(n) labt!l := l.extern labv!l := s writef(" .globl %S*N", s) } ENDCASE || End of segment or program CASE s.segend: CASE s.end: RETURN CASE s.assop: perform(k.r,-1) pendingop := readop() storearg(typeof!arg2,modeof!arg2,valueof!arg2) ENDCASE || default is error DEFAULT: report("Unknown Ocode op %N", op) } op := readop() } REPEAT .