// File BCPL2_BCPL2SRC // Version: E2.25 (also alter MANIFESTs below) // BCPL code generator for ICL 2900 under EMAS // Copyright (C) R.D. Eager University of Kent MCMLXXXV // History: // E1.0 - Initial EMAS version (compiled on VME/K). // E1.1 - Converted for compilation on EMAS; SECTION directive // inserted, GET statements altered. // E1.2 - All GLA offsets altered to MANIFESTs. // - 'ioerror' altered to return error as stop code, so that // steering routine outputs the actual message. // - Error messages now sent to listing file as well as to error // stream. // - 'readop' buffering (not really required on EMAS) removed to // improve performance. // - Bug in static name chaining fixed. // - 'globalsize' in compiled program now initialised at load // time; run-time initialisation code removed. // E1.3 - System vector in compiled programs rearranged, and // increased to 80 words in length. // E1.4 - Manifest constant 'glahsize' (now always zero) removed from // source files. // - All GLA references converted to use CTB rather than XNB; // contingency handler finalised. // - Function names moved from GLA to SST. // - Addition of code to reinitialise entry point to 'plant' on // second and subsequent runs, in order to make codegenerator // serially reusable. // E1.5 - STATIC names moved from GLA to SST. // - Introduction of buffering in 'data' and 'sdata' output // routines, to reduce fragmentation of compiler workfile and // speed up the final 'shuffle'. // - All references to library globals altered to MANIFESTs. // E1.6 - Addition of code to read directly from OCODE file,as // connected; this enables codegenerator to be called directly // from subsystem, as a 'compiler' program. // - Contents of 'comreg(9)' used to determine whether called // from phase 1, or via command. // E1.7 - Correction to code of 'readl', to forbid use of last // (reserved!) item in 'labv'. // E1.8 - Language code for BCPL now set up in object file. // - Correction to code of 'cgbyteselector'; previous code // failed if the selector operand was already held in a // register. // E1.9 - Correction to code handling 'eqv' and 'neqv' operations; // previous code failed with certain types of expression // operand. // E1.10 - PARM(PARMX) causes strings to be put into SST rather than // GLA. // E1.11 - Correction to code of 'cgbranch', to restore contents of DR // before performing comparison; otherwise, CC is corrupted // and an erroneous branch is performed. // E1.12 - Correction to initialisation chain; labels in this chain // were previously 'profiled' if PARM(PROFILE) was set; this // led to occasional problems. // E1.13 - Names of library OCODE files removed to separate file. // E2.0 - Addition of primitive support for the CODE command. // - Addition of code to handle (but ignore) the 'endproc' // OCODE. // - Addition of code to handle the 'endfor' OCODE. // - Addition of code to handle the 'getbyte' and 'putbyte' // OCODES. // E2.1 - Removal of write to string in 'plantl', to make all strings // in codegenerator read-only. // - Correction to free ACC in 'getbyte' code. // E2.2 - Alteration to suppress profiling of library OCODE file. // E2.3 - Addition of support for the 's.abs' OCODE. // E2.4 - Correction to fault which produced wrong code when the // 'neqv' or 'eqv' operators were used in a truth-value // context (in 'cgbranch'). // - Correction to fault which produced wrong code for a routine // or function call of the form: (). // E2.5 - Correction to code handling 'getbyte' and 'putbyte' // operators, to save intermediate results in B properly. // E2.6 - Calls to 'getbyte' and 'putbyte' replaced by use of the '%' // operator. // E2.7 - Correction to code of 'cggenselector', to improve code by // removing unnecessary slave discard. // E2.8 - Correction to code of 'cgswitch', to reset DR contents // before doing tests and jumps. // E2.9 - 'max.labels' increased from 500 to 600. // E2.10 - Correction to 'ohword', so that overflow of the work area // is detected correctly. // E2.11 - Correction to 'process_section_and_needs', to translate // entries and references to upper case. // E2.12 - Correction to 'stack', to adjust SF by the correct amount // (sometimes nothing!) if 'n = ssp-1' and 'arg2 = tempv'. // E2.13 - Correction to code generated for 'res' OCODE, to // 'stack(ssp-1)' immediately after moving result to ACC. // E2.14 - Modification to accept the 's.blab' OCODE as equivalent to // the 's.lab' OCODE; for compatibility with version 6.0 // onwards of the compiler. // E2.15 - Correction to 'comp', to handle 'k.stack' items as 'k.loc'. // E2.16 - Corrections to 'cgbyteselector' and 'cggenselector', to // free ACC on 's.slctap' operation. // E2.17 - Lower case accepted in arguments to 's.mc' OCODE. // E2.18 - 's.blab' OCODE renamed to 's.labx'. // - New OCODEs 's.labr' and 's.mark' supported; treated as // 's.lab' and 's.stack' respectively. // E2.19 - Addition of '?' parameter to give details of possible // parameters to the user. // E2.20 - Minor rearrangement of code, and renaming of identifiers. // E2.21 - Correction to 'cggoto', so that jumps to labels which are // local variables are now correctly handled. // E2.22 - Correction to 'cgstring' to suppress strings in dead code. // E2.23 - Correction to 's.getbyte' and 's.putbyte' register slaving. // - Improvement to 's.getbyte' and 's.putbyte' constant code. // E2.24 - Addition of check that global references lie within the // global vector. // E2.25 - Correction to check on global vector references. SECTION "ICL9CEZBCPL2" MANIFEST $( // Alter these if changes are made version = 2 // Major version number edit = 25 // Edit number within major version $) MANIFEST $( // Parameter decoder error codes par.ok = 0 // No errors par.err = -1 // Format error par.amb = -2 // Ambiguous keyword par.unk = -3 // Unknown keyword par.xs = -4 // Too many parameters par.dup = -5 // Duplicated parameter par.mis = -6 // Missing keyword par.igv = -7 // Illegal value for GLOBSIZE parameter par.iwv = -8 // Illegal value for WORKSIZE parameter $) /* Stop codes:- 0 - Normal termination (possibly with warnings) 1-999 - Corresponding Subsystem error 1000 - Parameter error 1001 - Errors in translation */ GET "BCPL2_BCPL2HDR" // Bits in COMREG(27) MANIFEST $( cr.stack = #X00000008 // Enable use of on-stack workspace cr.nocheck = #X00000010 // Disable "unassigned variable" checking cr.notrace = #X00000040 // Disable tracing cr.profile = #X00000080 // Enable profiling cr.code = #X00004000 // Enable code listing cr.opt = #X00010000 // Disable all tracing and checks cr.debug = #X00040000 // Enable debugging code cr.dynamic = #X00100000 // Enable dynamic loading cr.parmx = #X10000000 // Put strings into SST rather than GLA $) MANIFEST $( keymax = 4 $) STATIC $( parptr = ?; parleng = ?; options = ? $) LET start() BE $( LET keys = VEC keymax AND defaults = VEC keymax AND opt = VEC maxstrlength/bytesperword + 2*keymax AND comreg27 = comreg!27 AND traced_lib_file = ? AND opt_lib_file = ? options := opt TEST comreg!9 NE 0 THEN $( param := comreg!9 >> 2 // Pick up auxiliary parameters compiler_ := FALSE $) OR compiler_ := TRUE errorstream := comreg!40 GE 0 keys!0 := keymax keys!1 := "OCODE" ; defaults!1 := compiler_ -> "T#OCODE", 0 keys!2 := "LOCODE" ; defaults!2 := 0 keys!3 := "GLOBSIZE" ; defaults!3 := "400" keys!4 := "WORKSIZE" ; defaults!4 := "16368" // 4 epages, with header writef("*N%SBCPL codegenerator - version E%N.%N*N%S", compiler_ -> "", "*N*N University of Kent ", version, edit, compiler_ -> "", "*N*N*N") paramdecode(keys, options) IF param%0 = 1 & param%1 = '?' THEN $( selectoutput(journal) writes("Parameters are:-*N") FOR i = 1 TO keymax DO $( writes(keys!i) IF defaults!i NE 0 THEN writef("=%S", defaults!i) UNLESS i = keymax DO wrch(',') $) newline() stop(0) $) IF (options!0 GE 0) & NOT compiler_ & (options!1 NE 0) THEN options!0 := par.dup // Duplicated parameter IF options!0 < 0 DO paramerr() FOR i = 1 TO keymax DO IF options!i = 0 THEN options!i := defaults!i globsize := strtonum(options!3) UNLESS 100 LE globsize LE 5000 DO options!0 := par.igv worksize := strtonum(options!4) UNLESS 5000 LE worksize LE 262128 DO options!0 := par.iwv worksize := (worksize + bytesperword - 1)/bytesperword // Convert to words IF options!0 < 0 DO paramerr() ocode := options!1 locode := options!2 checking_ := (comreg27 & cr.nocheck) = 0 tracing_ := (comreg27 & cr.notrace) = 0 profiling_:= (comreg27 & cr.profile) NE 0 codelist_ := (comreg27 & cr.code) NE 0 use_stack_:= (comreg27 & cr.stack) NE 0 dynamic := (comreg27 & cr.dynamic) NE 0 debug := (comreg27 & cr.debug) NE 0 parmx := (comreg27 & cr.parmx) NE 0 IF (comreg27 & cr.opt) NE 0 THEN tracing_, profiling_, debug, checking_ := FALSE, FALSE, FALSE, FALSE mainprog := TRUE // Until evidence appears to the contrary GET "BCPL2_LIBFILES" // Define names of library OCODE files IF locode = 0 THEN locode := tracing_ -> traced_lib_file, opt_lib_file stop(aptovec(cgen, worksize)) $) AND iocp(ep, n) BE $( EXTERNAL $( s_iocp : "S#IOCP" $) s_iocp(ep, n) $) AND con_rdch() = VALOF // Special routine to read directly from connected OCODE file $( LET c = ? IF ocode_ptr GE !ocode_conad RESULTIS endstreamch c := ocode_conad%ocode_ptr ocode_ptr := ocode_ptr + 1 RESULTIS c $) AND e_wrch(c) = VALOF // Write to error stream $( LET o = comreg!23 // Current output channel iocp(9, comreg!40) // SELECT OUTPUT(errors) iocp(5, c) // PRINTCH(C) iocp(9, o) // SELECT OUTPUT(O) RESULTIS 0 $) AND paramerr() BE $( LET mes = VALOF SWITCHON options!0 INTO $( CASE par.err: RESULTIS "Illegal format" CASE par.amb: RESULTIS "Ambiguous keyword" CASE par.unk: RESULTIS "Keyword not recognised" CASE par.xs : RESULTIS "Too many parameters" CASE par.dup: RESULTIS "A parameter has been duplicated" CASE par.mis: RESULTIS "Missing keyword" CASE par.igv: RESULTIS "Illegal value for GLOBSIZE parameter" CASE par.iwv: RESULTIS "Illegal value for WORKSIZE parameter" DEFAULT: RESULTIS "" $) selectoutput(journal) writef("%S%S*N", compiler_ -> "BCPLCGEN fails - ", "", mes) stop(1000) $) AND paramdecode(keys, pars) BE $( LET pmax, pnum = keys!0, 1 LET wksp, pn = pars + pmax + 1, ? FOR i = 0 TO pmax DO pars!i := 0 parptr := 0 parleng := param%0 $( LET c = getpar(wksp) pn := (c NE '=') -> pnum, VALOF $( LET n = findkey(keys, wksp) c := getpar(wksp) RESULTIS n $) pars!0 := VALOF $( LET l = wksp%0 IF c = '=' RESULTIS par.err IF pn = -1 RESULTIS par.amb IF pn = -2 RESULTIS par.mis IF pn = 0 RESULTIS par.unk IF pn > pmax RESULTIS par.xs IF l = 0 RESULTIS par.ok IF pars!pn NE 0 RESULTIS par.dup pars!pn := wksp wksp := wksp + l/bytesperword + 1 RESULTIS par.ok $) UNLESS pars!0 = par.ok RETURN IF c = endstreamch RETURN pnum := pnum + 1 $) REPEAT $) AND getpar(wksp) = VALOF $( LET c, spcnt = ?, 0 AND inpr, length = FALSE, 0 $( c := getch(param) SWITCHON c INTO $( CASE endstreamch: CASE ',': CASE '=': wksp%0 := length RESULTIS c CASE '*S': spcnt := spcnt + 1 ENDCASE DEFAULT: TEST inpr THEN FOR i = 1 TO spcnt DO $( length := length + 1 wksp%length := '*S' $) OR inpr := TRUE spcnt := 0 length := length + 1 wksp%length := c $) $) REPEAT $) AND findkey(keys, wksp) = VALOF $( LET f = 0 IF wksp%0 = 0 RESULTIS -2 // Missing keyword FOR i = 1 TO keys!0 DO $( IF matchstrings(wksp, keys!i) DO $( UNLESS f = 0 RESULTIS -1 f := i $) $) RESULTIS f $) AND matchstrings(a, b) = VALOF $( LET l = a%0 IF b%0 < l RESULTIS FALSE FOR i = 1 TO l DO UNLESS a%i = b%i RESULTIS FALSE RESULTIS TRUE $) AND getch(str) = VALOF $( parptr := parptr + 1 RESULTIS parptr > parleng -> endstreamch, str%parptr $) AND strtonum(str) = VALOF $( LET num = 0 parptr := 0 parleng := str%0 $( LET n = getnum(str) IF n GE 10 BREAK num := num * 10 + n $) REPEAT RESULTIS num $) AND getnum(str) = VALOF $( LET c = getch(str) RESULTIS ('0' LE c LE '9') -> c - '0', 99 // 99 is greater than // the maximum base $) AND lput(type, p1, p2, p3) BE $( EXTERNAL $( s_lput : "S#LPUT" $) IF debugging_ THEN UNLESS 00 LE type LE 07 \/ 10 LE type LE 15 \/ 17 LE type LE 19 \/ 31 LE type LE 37 \/ 41 LE type LE 47 THEN report("illegal call on LPUT - %N X%X8 X%X8 X%X8", type, p1, p2, p3) s_lput(type, p1, p2, p3) $) AND cgen(v, vsize) = VALOF $( STATIC $( copy_plant = 0 $) LET s = ? AND vv = VEC tempvsize*tempsize - 1 tempv := vv // Ensure that codegenerator is serially reusable TEST copy_plant = 0 THEN copy_plant := plant OR plant := copy_plant supportname := "B#RTSUPPORT" preludename := "B#PRELUDE" ontrapname := "B#ONTRAP" plantcopy := plant // Used to bypass code lister where necessary code_heading_done_ := FALSE IF codelist_ THEN $( code_heading() plant := plantl // Intercept calls to PLANT $) databuf := v sdatabuf := databuf + databufsize labmap := sdatabuf + databufsize globmap := labmap + (max.labels + bitsperword + 1)/bitsperword labk := globmap + (globsize + 1 + bitsperword)/bitsperword labl := labk + max.staticlabels labv := labl + max.staticlabels codev := labv + max.labels + 1 codemax := v + vsize - 4 iilv := codemax + 4 iilva := iilv datap, sdatap, codelength, iilp := svsize + globsize + 1, 0, 0, 0 datacount, sdatacount := 0, 0 size1, size2, size3, size4, size5, size6, size7, totalsize := 0, 0, 0, 0, 0, 0, 0, 0 comments, incode_, hwwork := 0, TRUE, 0 lput(0, 6, version, edit) // Open object file initialise_gla() initialise_ust() clear_globmap() IF tracing_ \/ profiling_ THEN $( // Initialise STATIC name chain static_chain := size4/bytesperword lput(a.gla, bytesperword, svstatchain*bytesperword, @static_chain << 2) sdata(0) // Initialise end of chain $) real_rdch := rdch preamble() $( LET pr = profiling_ // Turn off profiling for library OCODE file profiling_ := FALSE s := findinput(locode) // OCODE of BCPL library IF s < 0 THEN $( ioerror(locode) RESULTIS -s $) selectinput(s) ocode_conad := getconad(s) IF ocode_conad > 0 THEN $( IF ocode_conad!3 NE 3 THEN // Not a character file $( ioerror(locode) RESULTIS e.ift $) ocode_ptr := ocode_conad!1 // Length of header rdch := con_rdch $) trans("library OCODE") endread() profiling_ := pr $) rdch := real_rdch TEST compiler_ THEN $( s := findinput(ocode) // OCODE of user program IF s < 0 THEN $( ioerror(ocode) RESULTIS -s $) selectinput(s) ocode_conad := getconad(s) IF s > 0 THEN $( IF ocode_conad!3 NE 3 THEN // Not a character file $( ioerror(ocode) RESULTIS e.ift $) ocode_ptr := ocode_conad!1 // Length of header rdch := con_rdch $) $) OR $( ocode_conad := comreg!46 >> 2 TEST ocode_conad NE 0 THEN $( rdch := con_rdch ocode_ptr := ocode_conad!1 // Length of header $) OR $( prompt("CGEN: ") selectinput(sysin) $) $) trans("user OCODE") endread() postamble() IF mainprog THEN // No entry points specified - use default $( LET s = "S#GO" lput(11, #X80000000 \/ a.gla, g.entry0, s << 2) $) // Clear internal LPUT buffers flush_data() flush_sdata() size2 := datap*bytesperword // Fill in final GLA size size4 := sdatap*bytesperword // Fill in final SST size totalsize := size1 + size2 + size3 + size4 + size5 + size6 + size7 print.sizes() lput(7, 32, 0, @size1 << 2) // Close object file RESULTIS 0 $) AND initialise_gla() BE $( STATIC $( word_desc = #X29000000 // Unbounded, scaled word descriptor byte_desc = #X19000000 // Unbounded byte descriptor code_desc = #XE1000000 // Unbounded code descriptor t = TRUE // Used to initalise certain globals $) LET tbdesc = VEC 1 AND tbs = tracebuffersize // Initialise to zero lput(a.gla, (svsize + globsize + 1)*bytesperword, 0, 0) // Set up GLA header (first 8 words) lput(a.gla, bytesperword, g.entry0, @code_desc << 2) // Initialise main entry descriptor lput(19, a.gla, g.entry1*bytesperword, a.code) // Relocate address part for code base lput(19, a.gla, g.ust*bytesperword, a.ust) // Relocate UST address lput(19, a.gla, g.sst*bytesperword, a.sst) // Relocate SST address $( LET word = (language.code << 24) \/ // Language flag (version << 16) \/ // Compiler version (0 << 8) \/ // Compiler options edit // Compiler edit number lput(a.gla, bytesperword, g.compiler*bytesperword, @word << 2) $) // Initialise entry descriptor for contingency handler lput(a.gla, bytesperword, g.cont0*bytesperword, @code_desc << 2) lput(19, a.gla, g.cont1*bytesperword, a.code) // Initialise external references to run-time system lput(12, a.gla, g.support0*bytesperword, supportname << 2) // .B#RTSUPPORT lput(12, a.gla, g.prelude0*bytesperword, preludename << 2) // .B#PRELUDE lput(12, a.gla, g.ontrap0*bytesperword, ontrapname << 2) // .B#ONTRAP // Initialise SVINW and SVINB (standard descriptor types) lput(a.gla, bytesperword, svinw*bytesperword, @word_desc << 2) lput(a.gla, bytesperword, svinb*bytesperword, @byte_desc << 2) // Set up SVTBS (size of trace buffer in words) (if tracing enabled) IF tracing_ THEN lput(a.gla, bytesperword, svtbs*bytesperword, @tbs << 2) // Set up descriptor to trace buffer (if tracing enabled) IF tracing_ THEN $( tbdesc!0, tbdesc!1 := #X28000000 + tracebuffersize,0 // Descriptor to trace buffer lput(a.gla, 2*bytesperword, svtrace*bytesperword, tbdesc << 2) lput(19, a.gla, (svtrace + 1)*bytesperword, a.ust) // Relocate trace buffer address $) // Set up word descriptor to system vector (used by machine code modules) lput(a.gla, bytesperword, svgs*bytesperword, @word_desc << 2) lput(19, a.gla, (svgs + 1)*bytesperword, a.gla) // Relocate GLA address // Set up dummy entry for end of STATIC name chain lput(a.gla, bytesperword, svstatchain*bytesperword, #XFF) // Set PROFILE to TRUE if required IF profiling_ THEN lput(a.gla, bytesperword, (svsize + gv.profile)*bytesperword, @t << 2) // Set up number of globals in GLOBALSIZE lput(a.gla, bytesperword, (svsize + gv.globalsize)*bytesperword, @globsize << 2) // Set STACKVECS to TRUE if required IF use_stack_ THEN lput(a.gla, bytesperword, (svsize + gv.stackvecs)*bytesperword, @t << 2) $) AND initialise_ust() BE $( IF tracing_ THEN // Allocate trace buffer $( lput(a.ust, tracebuffersize*bytesperword, size5, 0) // Initialise to zero size5 := size5 + tracebuffersize*bytesperword $) $) AND ioerror(file) BE $( EXTERNAL $( s_setfname : "S#SETFNAME" $) LET mes = VEC maxstrlength/bytesperword + 1 FOR i = 0 TO file%0 DO mes%i := file%i s_setfname(#X18000100, mes << 2) $) AND preamble() BE $( IF codelist_ THEN writes("***N** Initialisation code*N***N") // This initialisation code MUST occupy a whole number of words, // or each BCPL segment will be non-word-aligned, and in-code literals // will not be picked up correctly. plant(i.std, v.l, 3) // Procedure strategic code plant(i.lct, v.l, 4) // Stack a descriptor to a null string, in case program is called with no parameter plant(i.lsd, v.nil, #X18) // Build a byte descriptor plant(i.shs, v.nil, 24) plant(i.rot, v.nil, 32) plant(i.iad, v.nil, 2*bytesperword) plant(i.st, v.t, 0) plant(i.ldrl, v.t, 0) // Point 2 words beyond TOS plant(i.std, v.t, 0) plant(i.lss, v.nil, 0) // Make a null string plant(i.st, v.t, 0) // Stack it // Call B#PRELUDE plant(i.prcl, v.nil, 4) plant(i.lss, v.c, 1) // Address of code area plant(i.sl, v.l, 4) // Address of GLA plant(i.st, v.t, 0) plant(i.raln, v.nil, 7) plant(i.call, v.ic, g.prelude0) // .B#PRELUDE plant(i.lxn, v.l, 4) // Set XNB equal to CTB IF debugging_ THEN IF codelength REM 4 NE 0 THEN report("in compiler - initialisation code not word-aligned") dump_code() $) AND postamble() BE $( LET temp = ? IF codelist_ THEN writes("***N** Call run-time support to enter START*N***N") plant(i.prcl, v.nil, 4) plant(i.lsd, v.l, 5) // Descriptor to parameter string plant(i.st, v.t, 0) plant(i.raln, v.nil, 7) plant(i.call, v.ic, g.support0) // .B#RTSUPPORT plant(i.exit, v.nil, -20) // Leave ACS as it is // Contingency handler temp := size1 + codelength // Address of contingency handler IF codelist_ THEN writes("***N** Contingency handler*N***N") lput(a.gla, bytesperword, g.cont1*bytesperword, @temp << 2) // Fill in entry descriptor plant(i.inca, v.nil, -g.cont0*bytesperword) // Point back to start of GLA plant(i.std, v.l, 3) // Procedure strategic code plant(i.lct, v.l, 4) // Address of GLA // Call B#ONTRAP plant(i.prcl, v.nil, 4) plant(i.lsd, v.l, 5) // Class and subclass plant(i.st, v.t, 0) plant(i.raln, v.nil, 7) plant(i.call, v.ic, g.ontrap0) // .B#ONTRAP (never returns) dump_code() $) AND print.sizes() BE $( LET temp = ? writef("*NCode %N bytes GLAP %N + %N bytes ", size1, size2, size5) writef("Diag tables %N bytes*N", size4) writef("Total %N bytes*N", totalsize) hwwork := hwwork + (codev - databuf)*bytesperword temp := hwwork*100/(worksize*bytesperword) IF temp = 0 THEN temp := 1 writef("*NCodegenerator workspace used = %N%% (%N bytes)*N", temp, hwwork) $) . GET "BCPL2_BCPL2HDR" LET trans(file) BE $( FOR i = 0 TO max.labels DO labv!i := 0 labkp := 0 clear_labmap() op := readop() IF op = s.end RETURN // End of OCODE file incode_ := TRUE process_section_and_needs() UNLESS op = s.stack DO report("corrupt OCODE file") ssf := readn() initstack(ssf) // Initialises PENDINGOP as well branch(i.j, max.labels) // Jump round main code switch_prefix := 'A' incode_ := FALSE clear_slaves() dr_a := svinw gencode(file) flush_data() // To ensure following initialisation is in phase initialise_entrypoints() incode_:= TRUE IF (codelength REM 4) NE 0 THEN // Round to whole number of words plant(i.lss, v.nil, 0) // Padding instruction, never executed IF codelist_ THEN list_iils() codelength := codelength + iilp*bytesperword complab(max.labels, TRUE) // Ensure that this label is not 'profiled' codelength := codelength - iilp*bytesperword fixup_iils() dump_code() dump_iils() // Validate LABV, to ensure all labels have been set IF debugging_ THEN FOR i = 0 TO max.labels - 1 DO IF labv!i < 0 THEN report("in compiler - labels inconsistent (label %N)", i) IF codelist_ THEN writes("***N****************************************** End of segment * ********************************************N***N") $) REPEAT AND clear_labmap() BE $( FOR i = 0 TO (max.labels + bitsperword)/bitsperword - 1 DO labmap!i := 0 $) AND clear_globmap() BE $( FOR i = 0 TO (globsize + bitsperword)/bitsperword - 1 DO globmap!i := 0 $) AND process_section_and_needs() BE $( SWITCHON op INTO $( DEFAULT: RETURN CASE s.section: $( LET v = VEC 7 AND l = readn() AND i = 1 WHILE i LE l DO $( LET c = readn() IF c = '*S' THEN // Ignore spaces $( l := l - 1 LOOP $) IF c = '.' \/ c = '_' THEN c := '#' // For %SYSTEM... IF 'a' <= c <= 'z' THEN c := c - 'a' + 'A' // Ensure upper case UNLESS i > 31 DO v%i := c i := i + 1 $) IF l > 31 THEN l := 31 v%0 := l mainprog := FALSE lput(11, a.gla, 0, v << 2) // Define entry point ENDCASE $) CASE s.needs: $( LET v = VEC maxstrlength/bytesperword + 1 AND l = readn() AND offset = ? AND gno, colon = ?, ? AND i = 1 WHILE i LE l DO $( LET c = readn() IF c = '*S' THEN // Ignore spaces $( l := l - 1 LOOP $) IF c = '.' THEN c := '#' // For %SYSTEM... IF 'a' <= c <= 'z' THEN c := c - 'a' + 'A' // Ensure upper case v%i := c i := i + 1 $) v%0 := l colon := VALOF $( FOR i = 1 TO l DO IF v%i = ':' RESULTIS i RESULTIS 0 $) IF colon = 0 THEN $( comment("NEEDS directive has illegal format - directive ignored") ENDCASE $) v%0 := colon - 1 // Truncate original string to exclude number and colon FOR i = colon + 1 TO l DO $( LET c = v%i UNLESS '0' LE c LE '9' DO $( comment("number in NEEDS directive has illegal format - directive ignored") ENDCASE $) gno := gno * 10 + c - '0' $) UNLESS 0 LE gno LE globsize DO comment("global base in NEEDS directive is outwith global vector") l := colon - 1 // Length of name IF l > 31 THEN $( l := 31 v%0 := l $) // Make a GLA entry for the external fixup offset := findglaentry(v) // Returns offset (in words) of new GLA entry IF codelist_ THEN writef("***N** NEEDS *"%S*"*N***N", v) plant(i.prcl, v.nil, 4) // Remember this is in the initialisation chain plant(i.lss, v.nil, gno) plant(i.st, v.t, 0) plant(i.raln, v.nil, 6) plant(i.call, v.ic, offset) plant(i.lxn, v.l, 4) // Restore XNB value ENDCASE $) $) op := readop() $) REPEAT AND findglaentry(s) = VALOF $( LET l = s%0 // Length of external name AND offset = ? IF l > 31 THEN l := 31 s%0 := l offset := datap // Word offset of new item in GLA data(0); data(0) // Reserve space lput(dynamic -> 13, 12, a.gla, offset*bytesperword, s << 2) RESULTIS offset // Return word offset of new item within GLA $) AND initialise_entrypoints() BE $( // Initialise global entry points FOR i = 1 TO globaln DO $( LET n = readn() LET l = readl() LET lab_address = size1 + labv!l // Relative to base of code area IF n > globsize DO $( comment("global %N outwith global vector - not initialised", n) LOOP $) $( LET offset = n/bitsperword LET word = globmap!offset IF ((word >> (n REM bitsperword)) & 1) NE 0 DO comment("global no %N set previously - superseded", n) globmap!offset := word \/ (1 << (n REM bitsperword)) $) lput(a.gla, bytesperword, (svsize + n)*bytesperword, @lab_address << 2) // Fill in global cell lput(19, a.gla, (svsize + n)*bytesperword, a.code) // Relocate $) // Initialise static cell entry points FOR i = 0 TO labkp - 1 DO $( LET offset = labk!i*bytesperword AND codeoffset = size1 + labv!(labl!i) lput(a.gla, bytesperword, offset, @codeoffset << 2) // Fill in static cell lput(19, a.gla, offset, a.code) // Relocate $) $) AND dump_code() BE $( LET used = codelength + iilp*bytesperword*2 lput(a.code, codelength, size1, codev << 2) size1 := size1 + codelength IF used > hwwork THEN hwwork := used codelength := 0 $) AND fixup_iils() BE UNLESS iilp = 0 DO $( LET base = codelength/2 // Base of IILs, in halfwords FOR i = 0 TO iilp - 1 DO $( LET addr = base + i*2 // Address of this IIL, in halfwords AND chain = iilva!i // Top of fixup chain for this IIL (halfword offset in CODEV) UNTIL chain = 0 DO $( LET offset = addr - chain // Offset in halfwords AND disp = chain*2 // Displacement (in bytes) of instruction within CODEV LET instruction = getword(codev, disp) putword(codev, disp, (instruction & #XFFFC0000) \/ offset) chain := instruction & #X3FFFF $) $) $) AND dump_iils() BE UNLESS iilp = 0 DO $( lput(a.code, iilp*4, size1, iilv << 2) iilv := iilv + iilp*2 // Reset to start iilva := iilv size1 := size1 + iilp*4 // Update size of code area iilp := 0 $) AND getword(v, i) = VALOF $( LET a = (v << 2) + i RESULTIS (0%a << 24) + (0%(a + 1) << 16) + (0%(a + 2) << 08) + (0%(a + 3)) $) AND putword(v, i, w) BE $( LET a = (v << 2) + i 0%a := w >> 24 0%(a + 1) := (w >> 16) & #xff 0%(a + 2) := (w >> 8) & #xff 0%(a + 3) := w & #xff $) AND report(mes, a, b, c, d, e, f, g, h, i, j, k) BE $( selectoutput(sysout) FOR i = 0 TO 1 DO $( writes("*NError - ") writef(mes, a, b, c, d, e, f, g, h, i, j, k); newline() UNLESS errorstream BREAK wrch := e_wrch $) [debugging_ -> abort, stop](1001) $) AND comment(mes, a, b, c, d, e, f, g, h, i, j, k) BE $( LET o_wrch = wrch AND o = output() selectoutput(sysout) FOR i = 0 TO 1 DO $( writes("Warning - ") writef(mes, a, b, c, d, e, f, g, h, i, j, k); newline() UNLESS errorstream BREAK wrch := e_wrch $) wrch := o_wrch // Restore previous output comments := comments + 1 selectoutput(o) $) . GET "BCPL2_BCPL2HDR" LET gencode(file) BE $( LET prev.ssp = -1 // Used for communication between the actions for the // 'STACK n' and 'RTRN' opcodes AND n = ? op := readop() $( SWITCHON op INTO $( DEFAULT: report("illegal OCODE - %N", op) CASE s.lp: loadt(k.loc, readn()); BREAK CASE s.lg: n := readn() checkglobal(n) loadt(k.ctb, n + svsize) BREAK CASE s.ln: loadt(k.numb, readn()); BREAK CASE s.ll: loadt(k.ctb, labv!readl()); BREAK CASE s.true: CASE s.false: loadt(k.numb, op = s.true); BREAK CASE s.lstr: cgstring(readn()); BREAK CASE s.llp: loadlvp(readn()) BREAK CASE s.llg: n := readn() checkglobal(n) loadlv(n + svsize) BREAK CASE s.lll: loadlv(labv!readl()) BREAK CASE s.sp: storein(k.loc, readn()); BREAK CASE s.sg: n := readn() checkglobal(n) storein(k.ctb, n + svsize) BREAK CASE s.sl: storein(k.ctb, labv!readl()); BREAK CASE s.stind: storei(); BREAK CASE s.not: IF pendingop = s.eqv THEN $( pendingop := s.neqv BREAK $) CASE s.mult: CASE s.div: CASE s.rem: CASE s.plus: CASE s.minus: CASE s.neg: CASE s.abs: CASE s.lshift: CASE s.rshift: CASE s.ge: CASE s.ls: CASE s.gr: CASE s.le: CASE s.eq: CASE s.ne: CASE s.logand: CASE s.logor: CASE s.eqv: CASE s.neqv: CASE s.getbyte: cgpendingop(r.null) pendingop := op BREAK CASE s.rv: cgrv(); LOOP CASE s.putbyte: cgputbyte(); BREAK CASE s.slctap: CASE s.slctst: cgselect(op); BREAK CASE s.endfor: cgpendingop(r.null) pendingop := s.le op := s.jt // Drop through CASE s.jt: CASE s.jf: cgbranch(op = s.jt, readl()) BREAK CASE s.goto: cggoto(); BREAK CASE s.jump: cgpendingop(r.null) store(0, ssp - 1) asf(ssp - ssf) branch(i.j, readl()) incode_ := FALSE BREAK CASE s.labr: CASE s.labx: CASE s.lab: complab(readl(), FALSE); BREAK CASE s.mark: CASE s.stack: $( LET k = ? cgpendingop(r.null) $( k := readn() op := readop() $) REPEATWHILE op = s.stack \/ op = s.mark IF op = s.rtrn THEN $( prev.ssp := k k := 2 $) stack(k) asf(k - ssf) LOOP $) CASE s.prcl: cgpendingop(r.null) store(0, ssp - 1) resetdr() plant(i.stxn, v.t, 0) plant(i.stct, v.t, 0) plant(i.std, v.t, 0) plant(i.stln, v.t, 0) // Must NOT be replaced by PRCL! plant(i.asf, v.nil, 4) ssf := ssf + 9 initstack(ssp + 9) BREAK CASE s.store: cgpendingop(r.null) store(0, ssp - 1) FOR a = tempv TO arg1 BY tempsize DO IF h1!a = k.stack THEN h1!a := k.loc asf(ssp - ssf) BREAK CASE s.query: loadt(k.numb, 0); BREAK CASE s.entry: cgentry(readn(), readl()) BREAK CASE s.endproc: readn() // Ignore for now BREAK CASE s.mc: cgcode(readn()); BREAK CASE s.save: $( LET n = readn() freereg(r.acc) freereg(r.b) clear_slaves() dr_a := svinw plant(i.stln, v.t, 0) plant(i.lsd, v.t, 0) plant(i.raln, v.nil, 60) plant(i.st, v.l, 0) IF n GE 60 THEN report("too many parameters declared in a routine or function") ssf := n initstack(n) ssf := 60 op := readop() UNLESS op = s.stack \/ op = s.mark DO asf(n - 60) LOOP $) CASE s.rtap: CASE s.fnap: cgapply(op, readn()); BREAK CASE s.rtcall: CASE s.fncall: $( LET k = readn() AND v = VEC maxstrlength/bytesperword + 1 LET l = readn() AND offset = ? FOR i = 1 TO l DO $( LET c = readn() IF c = '.' THEN c := '#' // For %SYSTEM... v%i := c $) v%0 := l offset := findglaentry(v) cgpendingop(r.null) store(0, ssp - 1) plant(i.raln, v.nil, ssp - k - 4) IF codelist_ THEN writef("***N** External reference to *"%S*"*N***N", v) plant(i.call, v.ic, offset) plant(i.ld, v.t, 0) dr_a := svinw plant(i.lct, v.t, 0) plant(i.lxn, v.t, 0) clear_slaves() ssf := k stack(k) IF op = s.fncall THEN loadt(k.reg, r.acc) BREAK $) CASE s.fnrn: CASE s.rtrn: cgpendingop(r.null) resetdr() IF op = s.fnrn THEN $( movetor(r.acc, arg1) stack(ssp - 1) $) asf(2 - ssp) plant(i.lln, v.t, 0) plant(i.j, v.t, 0) incode_ := FALSE UNLESS prev.ssp < 0 DO $( ssp := prev.ssp prev.ssp := -1 $) initstack(ssp) BREAK CASE s.res: $( LET newsf = readn() LET l = readl() cgpendingop(r.null) store(0, ssp - 2) movetor(r.acc, arg1) stack(ssp - 1) UNLESS newsf = ssp DO asf(newsf - ssp) branch(i.j, l) incode_ := FALSE BREAK $) CASE s.rstack: initstack(readn()) loadt(k.reg, r.acc) BREAK CASE s.finish: // Compile as STOP(0) cgpendingop(r.null) resetdr() stack(ssp + 2) loadt(k.numb, 0) loadt(k.ctb, svsize + gv.stop) cgapply(s.rtap, ssp - 4) incode_ := FALSE BREAK CASE s.switchon: cgswitch(); BREAK CASE s.global: globaln := readn() IF globaln LE 0 THEN comment("no globals set in %S file", file) RETURN CASE s.datalab: $( LET v = VEC maxstrlength/bytesperword + 1 LET l = readl() LET n = readn() v%0 := n FOR i = 1 TO n DO v%i := readn() FOR i = n + 1 TO n + bytesperword - n REM bytesperword - 1 DO v%i := 0 // Pad last word with nulls labv!l := datap IF NOT tracing_ \/ n = 0 THEN BREAK // Add to chain of STATIC names flush_sdata() // Ensure links are kept in phase lput(a.sst, bytesperword, static_chain*bytesperword, @sdatap << 2) static_chain := sdatap // Update pointer to end of chain sdata(0) // New end of chain FOR i = 0 TO n/bytesperword DO // Output the name sdata(v!i) sdata(datap) // Offset of associated cell in GLA BREAK $) CASE s.itemn: data(readn()); BREAK CASE s.iteml: $( LET l = readl() IF l GE max.labels THEN report("too many *'labels*' in program") labk!labkp := datap labl!labkp := l data(0) // Allocate space for label/routine cell setlabbit(l) // Mark as a label/routine cell labkp := labkp + 1 IF labkp GE max.staticlabels THEN report("out of space for static routine cells") BREAK $) CASE s.end: report("unexpected end of input file") $) $) REPEAT $) REPEAT AND readop() = VALOF $( LET n = readnumber(10) IF terminator GE 0 RESULTIS n IF terminator = endstreamch RESULTIS s.end report("failure %N on input", -terminator) $) AND readl() = VALOF $( LET a = 0 AND c = rdch() AND n = ? WHILE c = '*S' \/ c = '*N' DO c := rdch() UNLESS c = 'L' DO report("no L where label expected") n := readnumber(10) IF n GE max.labels THEN report("too many *'labels*' in program") RESULTIS n $) AND checkglobal(n) BE $( UNLESS -svsize LE n LE globsize DO comment("use of global %n which is outwith the global vector", n) $) AND cgpendingop(bestreg) BE $( LET rand1, rand2 = arg1, arg2 AND sw = FALSE AND f = ? AND r = ? IF pendingop = s.none RETURN SWITCHON pendingop INTO $( CASE s.eq: f := i.je ; GOTO rel CASE s.ne: f := i.jne; GOTO rel CASE s.ls: f := i.jl ; GOTO rel CASE s.gr: f := i.jg ; GOTO rel CASE s.le: f := i.jle; GOTO rel CASE s.ge: f := i.jge rel: movecontor(r.b, -1) IF h1!rand2 = k.numb THEN $( rand1, rand2 := arg2, arg1 f := invop(f) $) IF h1!arg1 = k.stack = h1!arg2 THEN $( rand1, rand2 := arg2, arg1 f := invop(f) $) IF regusedby(rand1) = r.acc THEN $( rand1, rand2 := arg2, arg1 f := invop(f) $) movetor(r.acc, rand2) TEST numberis(0, rand1) THEN f := accop(f) OR comp(i.icp, rand1) plant(f, v.nil, 3) movecontor(r.b, 0) lose1(r.b) ENDCASE CASE s.eqv: sw := TRUE CASE s.neqv: IF regusedby(rand1) = r.acc THEN rand1, rand2 := arg2, arg1 IF h1!arg1 = k.stack = h1!arg2 THEN rand1, rand2 := arg2, arg1 movetor(r.acc, rand2) comp(i.neq, rand1) IF sw THEN plant(i.irsb, v.nil, -1) lose1(r.acc) ENDCASE CASE s.plus: IF h1!rand2 = k.numb THEN rand1, rand2 := arg2, arg1 IF numberis(0, rand1) THEN $( h1!arg2, h2!arg2 := h1!rand2, h2!rand2 stack(ssp - 1) ENDCASE $) IF h1!arg1 = k.stack = h1!arg2 THEN rand1, rand2 := arg2, arg1 TEST bestreg = r.null THEN $( IF h1!rand1 = k.reg THEN $( LET r1, r2 = rand1, rand2 rand1, rand2 := r2, r1 $) IF regusedby(rand2) = r.b & regusedby(rand1) = r.acc THEN $( LET r1, r2 = rand1, rand2 rand1, rand2 := r2, r1 $) r := movetoanyr(rand2) $) OR $( IF regusedby(rand1) = bestreg THEN $( LET r1, r2 = rand1, rand2 rand1, rand2 := r2, r1 $) r := movetor(bestreg, rand2) $) comp(r = r.acc -> i.iad, i.adb, rand1) lose1(r) ENDCASE CASE s.minus: IF numberis(0, rand1) THEN $( stack(ssp - 1) ENDCASE $) f := i.isb IF (h1!rand2 = k.numb) \/ (h1!arg1 = k.stack = h1!arg2) \/ (h1!rand1 = k.reg) THEN $( rand1, rand2 := arg2, arg1 f := i.irsb $) TEST f = i.isb THEN r := movetoanyr(rand2) OR r := movetor(r.acc, rand2) IF r = r.b THEN f := i.sbb comp(f, rand1) lose1(r) ENDCASE CASE s.mult: IF h1!rand2 = k.numb THEN rand1, rand2 := arg2, arg1 IF numberis(0, rand1) THEN $( h1!arg2, h2!arg2 := k.numb, 0 stack(ssp - 1) ENDCASE $) IF numberis(1, rand1) THEN $( h1!arg2, h2!arg2 := h1!rand2, h2!rand2 stack(ssp - 1) ENDCASE $) IF h1!rand1 = k.reg THEN $( LET r1, r2 = rand1, rand2 rand1, rand2 := r2, r1 $) IF regusedby(rand2) = r.b & regusedby(rand1) = r.acc THEN $( LET r1, r2 = rand1, rand2 rand1, rand2 := r2, r1 $) IF h1!arg1 = k.stack = h1!arg2 THEN rand1, rand2 := arg2, arg1 r := movetoanyr(rand2) comp(r = r.acc -> i.imy, i.myb, rand1) lose1(r) ENDCASE CASE s.div: IF numberis(1, rand1) THEN $( stack(ssp - 1) ENDCASE $) f := i.idv IF (h1!rand2 = k.numb) \/ (h1!arg1 = k.stack = h1!arg2) \/ regusedby(rand1) = r.acc THEN $( rand1, rand2 := arg2, arg1 f := i.irdv $) movetor(r.acc, rand2) comp(f, rand1) lose1(r.acc) ENDCASE CASE s.rem: $( LET t = FALSE IF numberis(1, rand1) THEN $( h1!arg2, h2!arg2 := k.numb, 0 stack(ssp - 1) ENDCASE $) IF regusedby(arg1) = r.acc THEN TEST isfree(r.b) THEN $( plant(i.st, v.b, 0) slave(r.b, acc_v, acc_a, acc_k) h2!arg1 := r.b $) OR $( plant(i.st, v.c, svwork) h1!arg1, h2!arg1 := k.ctb, svwork $) IF h1!arg1 = k.stack = h1!arg2 THEN $( h1!arg2 := k.loc t := TRUE $) movetor(r.acc, rand2) comp(i.imdv, rand1) plant(i.lss, v.t, 0) IF t THEN asf(-1) lose1(r.acc) ENDCASE $) CASE s.logor: sw := TRUE CASE s.logand: IF h1!rand2 = k.numb THEN rand1, rand2 := arg2, arg1 IF numberis(sw, rand1) THEN $( h1!arg2, h2!arg2 := k.numb, sw stack(ssp - 1) ENDCASE $) IF numberis(NOT sw, rand1) THEN $( h1!arg2, h2!arg2 := h1!rand2, h2!rand2 stack(ssp - 1) ENDCASE $) IF regusedby(rand1) = r.acc THEN $( LET r1, r2 = rand1, rand2 rand1, rand2 := r2, r1 $) IF h1!arg1 = k.stack = h1!arg2 THEN rand1, rand2 := arg2, arg1 movetor(r.acc, rand2) comp(sw -> i.or, i.and, rand1) lose1(r.acc) ENDCASE CASE s.neg: CASE s.abs: sw := TRUE CASE s.not: movetor(r.acc, rand1) IF pendingop = s.abs THEN plant(i.jnn, v.nil, 3) plant(i.irsb, v.nil, sw -> 0, -1) h1!rand1, h2!rand1 := k.reg, r.acc unslave(r.acc) pendingop := s.none ENDCASE CASE s.lshift: $( LET t = FALSE IF regusedby(arg1) = r.acc THEN TEST isfree(r.b) THEN $( plant(i.st, v.b, 0) slave(r.b, acc_v, acc_a, acc_k) h2!arg1 := r.b $) OR $( plant(i.st, v.c, svwork) h1!arg1, h2!arg1 := k.ctb, svwork $) IF h1!arg1 = k.stack = h1!arg2 THEN $( h1!arg2 := k.loc t := TRUE $) movetor(r.acc, arg2) comp(i.ush, arg1) IF t THEN asf(-1) lose1(r.acc) ENDCASE $) CASE s.rshift: TEST h1!arg1 = k.numb THEN $( h2!arg1 := -h2!arg1 movetor(r.acc, arg2) comp(i.ush, arg1) $) OR $( movecontor(r.b, 0) IF regusedby(arg1) = r.acc THEN $( plant(i.st, v.c, svwork) h1!arg1, h2!arg1 := k.ctb, svwork $) movetor(r.acc, arg2) comp(i.sbb, arg1) plant(i.ush, v.b, 0) unslave(r.b) $) lose1(r.acc) ENDCASE CASE s.getbyte: $( LET op = ? IF bestreg = r.null THEN bestreg := r.acc op := bestreg = r.acc -> i.lss, i.lb IF h1!rand1 = k.stack \/ (h1!rand1 = k.reg & h2!rand1 = r.b) THEN movetor(r.acc, rand1) TEST h1!rand2 = k.numb THEN movecontor(r.b, h2!rand2*bytesperword) OR $( movetor(r.b, rand2) plant(i.myb, v.nil, bytesperword) unslave(r.b) $) TEST h1!rand1 = k.reg & h2!rand1 = r.acc THEN $( plant(i.iad, v.b, 0) plant(i.st, v.b, 0) clear_slaves() $) OR $( UNLESS numberis(0, rand1) DO $( comp(i.adb, rand1) unslave(r.b) $) IF bestreg = r.acc THEN freereg(r.acc) $) TEST dr_a = svinb THEN plant(op, v.md, 0) OR $( plant(op, v.mic, svinb) dr_a := svinb $) lose1(bestreg) ENDCASE $) DEFAULT: report("in compiler - bad op in CGPENDINGOP - %N", pendingop) $) $) AND accop(op) = VALOF SWITCHON op INTO $( CASE i.je : RESULTIS i.jz CASE i.jne: RESULTIS i.jnz CASE i.jl : RESULTIS i.jn CASE i.jg : RESULTIS i.jp CASE i.jle: RESULTIS i.jnp CASE i.jge: RESULTIS i.jnn DEFAULT : report("in compiler - bad op in ACCOP - %N", op) $) AND bop(op) = VALOF SWITCHON op INTO $( CASE i.je : RESULTIS i.jzb CASE i.jne: RESULTIS i.jnzb CASE i.jl : RESULTIS i.jnb CASE i.jg : RESULTIS i.jpb CASE i.jle: RESULTIS i.jnpb CASE i.jge: RESULTIS i.jnnb DEFAULT : report("in compiler - bad op in BOP - %N", op) $) AND invop(op) = VALOF SWITCHON op INTO $( CASE i.je : CASE i.jne: RESULTIS op CASE i.jl : RESULTIS i.jg CASE i.jg : RESULTIS i.jl CASE i.jle: RESULTIS i.jge CASE i.jge: RESULTIS i.jle DEFAULT : report("in compiler - bad op in INVOP - %N", op) $) AND movetoanyr(a) = movetor(regfor(a), a) AND regfor(a) = VALOF $( IF h1!a = k.reg RESULTIS h2!a IF slaved(r.acc, h1!a, h2!a, 0) THEN $( freereg(r.acc) RESULTIS r.acc $) IF slaved(r.b, h1!a, h2!a, 0) THEN $( freereg(r.b) RESULTIS r.b $) IF isfree(r.acc) RESULTIS r.acc IF isfree(r.b) RESULTIS r.b freereg(r.acc) RESULTIS r.acc $) AND movetor(r, a) = VALOF $( UNLESS h1!a = k.reg & h2!a = r DO $( freereg(r) IF slaved(r, h1!a, h2!a, 0) RESULTIS r TEST slaved(other(r), h1!a, h2!a, 0) THEN plant(r = r.acc -> i.lss, i.st, v.b, 0) OR comp(r = r.acc -> i.lss, i.lb, a) slave(r, h1!a, h2!a, 0) h1!a, h2!a := k.reg, r $) RESULTIS r $) AND movecontor(r, n) BE $( freereg(r) IF slaved(r, k.numb, n, 0) RETURN plant(r = r.acc -> i.lss, i.lb, v.nil, n) slave(r, k.numb, n, 0) $) AND lose1(r) BE $( ssp := ssp - 1 pendingop := s.none TEST arg2 = tempv THEN h1!arg2, h2!arg2, h3!arg2 := k.loc, ssp - 2, ssp - 2 OR $( arg1 := arg2 arg2 := arg2 - tempsize $) h1!arg1, h2!arg1, h3!arg1 := k.reg, r, ssp - 1 unslave(r) $) AND regusedby(t) = h1!t = k.reg -> h2!t, r.null AND freereg(r) BE FOR t = tempv TO arg1 BY tempsize DO IF regusedby(t) = r THEN $( LET type = k.loc IF h3!t > ssf THEN asf(h3!t - ssf) TEST h3!t = ssf THEN $( plant(r = r.acc -> i.st, i.stb, v.t, 0) type := k.stack ssf := ssf + 1 $) OR $( plant(r = r.acc -> i.st, i.stb, v.l, h3!t) IF slaved(other(r), k.loc, h3!t, 0) THEN unslave(other(r)) $) h1!t, h2!t := type, h3!t slave(r, k.loc, h3!t, 0) RETURN $) AND isfree(r) = VALOF $( FOR t = tempv TO arg1 BY tempsize DO IF regusedby(t) = r RESULTIS FALSE RESULTIS TRUE $) AND resetdr() BE $( UNLESS dr_a = svinw DO $( plant(i.ld, v.c, svinw) dr_a := svinw $) $) AND numberis(n, a) = h1!a = k.numb & h2!a = n AND storei() BE $( LET r, v = ?, ? AND k = ? cgpendingop(r.b) k := h1!arg1 IF k = k.reg & h2!arg1 = r.acc THEN $( freereg(r.b) plant(i.st, v.b, 0) h2!arg1 := r.b $) TEST k = k.reg & h2!arg1 = r.b THEN $( movetor(r.acc, arg2) TEST dr_a = svinw THEN plant(i.st, v.md, 0) OR $( plant(i.st, v.mic, svinw) dr_a := svinw $) clear_slaves() $) OR $( r := movetoanyr(arg2) resetdr() v := k = k.loc -> v.dl, k = k.ctb -> v.dc, k = k.numb -> v.d, report("in compiler - illegal K in STOREI - %N", k) plant(r = r.acc -> i.st, i.stb, v, h2!arg1) $) UNLESS (acc_v = k.svctbword) \/ (acc_v = k.lnb) DO unslave(r.acc) UNLESS (b_v = k.svctbword) \/ (b_v = k.lnb) DO unslave(r.b) stack(ssp - 2) $) AND slave(r, v, a, k) BE $( IF v = k.stack THEN v := k.loc TEST r = r.acc THEN acc_v, acc_a, acc_k := v, a, k OR TEST r = r.b THEN b_v, b_a, b_k := v, a, k OR report("in compiler - bad R in SLAVE - %N", r) $) AND unslave(r) BE TEST r = r.acc THEN acc_v := k.none OR TEST r = r.b THEN b_v := k.none OR UNLESS r = r.null DO report("in compiler - bad R in UNSLAVE - %N", r) AND clear_slaves() BE acc_v, b_v := k.none, k.none AND slaved(r, v, a, k) = VALOF TEST r = r.acc THEN RESULTIS acc_v = v & acc_a = a & acc_k = 0 OR TEST r = r.b THEN RESULTIS b_v = v & b_a = a & b_k = 0 OR report("in compiler - bad R in SLAVED - %N", r) AND other(r) = r = r.acc -> r.b, r = r.b -> r.acc, report("in compiler - bad R in OTHER - %N", r) . GET "BCPL2_BCPL2HDR" LET store(a, b) BE $( LET base, p = h3!tempv, ? AND stacking_ = FALSE AND size = 1 AND r = r.acc IF a < base THEN a := base IF b > ssp - 1 THEN b := ssp - 1 p := tempv + (a - base)*tempsize UNTIL a > b DO $( TEST local(p) THEN IF stacking_ DO $( plant(r = r.acc -> i.st, i.stb, v.t, 0) ssf := ssf + size stacking_ := FALSE r := r.acc $) OR $( IF h3!p > (stacking_ -> ssf + size, ssf) THEN asf(h3!p - ssf) TEST stacking_ THEN TEST r = r.b & regusedby(p) = r.acc THEN $( plant(i.stb, v.t, 0) slave(r.b, k.loc, ssf, 0) ssf := ssf + 1 size := 1 r := r.acc $) OR $( comp(r = r.acc -> i.slss, i.slb, p) unslave(r) ssf := ssf + size size := 1 $) OR TEST h1!p = k.reg THEN $( LET rr = regusedby(p) TEST h3!p < ssf THEN $( plant(rr = r.acc -> i.st, i.stb, v.l, h3!p) IF slaved(other(rr), k.loc, h3!p, 0) THEN unslave(other(rr)) slave(rr, k.loc, h3!p, 0) $) OR $( r := rr stacking_ := TRUE $) $) OR $( UNLESS isfree(r) DO $( LET t = VALOF $( FOR i = tempv TO arg1 BY tempsize DO IF regusedby(i) = r RESULTIS i report("in compiler - in STORE") $) TEST isfree(r.b) THEN $( plant(i.st, v.b, 0) slave(r.b, acc_v, acc_a, acc_k) h2!t := r.b $) OR $( plant(r = r.acc -> i.st, i.stb, v.c, svwork) h1!t, h2!t := k.ctb, svwork $) $) movetor(r, p) size := 1 TEST h3!p < ssf THEN $( plant(r = r.acc -> i.st, i.stb, v.l, h3!p) IF slaved(other(r), k.loc, h3!p, 0) THEN unslave(other(r)) slave(r, k.loc, h3!p, 0) $) OR stacking_ := TRUE $) h1!p, h2!p := k.stack, h3!p $) a, p := a + 1, p + tempsize $) p := p - tempsize IF stacking_ THEN $( TEST h3!p < ssf THEN $( plant(r = r.acc -> i.st, i.stb, v.l, h3!p) IF slaved(other(r), k.loc, h3!p, 0) THEN unslave(other(r)) $) OR $( plant(r = r.acc -> i.st, i.stb, v.t, 0) ssf := ssf + size $) slave(r, k.loc, h3!p, 0) $) $) AND local(a) = ((h1!a = k.loc) \/ (h1!a = k.stack)) & h2!a = h3!a AND initstack(n) BE $( arg2, arg1 := tempv, tempv + tempsize UNLESS ssf = n DO asf(n - ssf) ssp, ssf := n, n pendingop := s.none h1!arg2, h2!arg2, h3!arg2 := k.loc, n - 2, n - 2 h1!arg1, h2!arg1, h3!arg1 := k.loc, n - 1, n - 1 $) AND loadt(v, a) BE $( cgpendingop(r.null) arg2 := arg1 arg1 := arg1 + tempsize IF arg1 GE tempv + tempvsize*tempsize DO report("in compiler - overflow of simulated stack") h1!arg1, h2!arg1, h3!arg1 := v, a, ssp ssp := ssp + 1 $) AND stack(n) BE $( pendingop := s.none IF n > ssp THEN $( store(0, ssp - 1) initstack(n) RETURN $) UNTIL n = ssp DO $( IF h1!arg1 = k.stack THEN h1!arg1 := k.loc IF h1!arg1 = acc_v & h3!arg1 = acc_a THEN unslave(r.acc) IF h1!arg1 = b_v & h3!arg1 = b_a THEN unslave(r.b) IF arg2 = tempv THEN $( TEST n = (ssp - 1) THEN $( asf(n - ssf) ssp := n h1!arg1, h2!arg1, h3!arg1 := h1!arg2, h2!arg2, h3!arg2 h1!arg2, h2!arg2, h3!arg2 := k.loc, ssp - 2, ssp - 2 $) OR initstack(n) RETURN $) arg1, arg2 := arg1 - tempsize, arg2 - tempsize ssp := ssp - 1 $) IF ssf > ssp THEN asf(ssp - ssf) $) AND storein(s, n) BE $( LET r = ? cgpendingop(r.null) r := movetoanyr(arg1) IF slaved(other(r), s, n, 0) THEN unslave(other(r)) slave(r, s, n, 0) TEST s = k.loc THEN $( IF n > ssf DO asf(n - ssf) IF n = ssf THEN $( plant(r = r.acc -> i.st, i.stb, v.t, 0) ssf := ssf + 1 stack(ssp - 1) RETURN $) plant(r = r.acc -> i.st, i.stb, v.l, n) $) OR TEST s = k.ctb THEN plant(r = r.acc -> i.st, i.stb, v.c, n) OR report("in compiler - bad type in STOREIN - %N", s) stack(ssp - 1) $) AND cgapply(type, k) BE $( IF (ssp - k) GE 60 THEN report("too many parameters in a %S call", type = s.rtap -> "routine", "function") cgpendingop(r.null) resetdr() IF regusedby(arg1) = r.acc THEN $( freereg(r.b) plant(i.st, v.b, 0) h2!arg1 := r.b $) store(0, ssp - 2) IF h1!arg1 = k.stack \/ h1!arg1 = k.numb THEN movetor(r.b, arg1) asf(60 - (ssp - k - 1)) TEST regusedby(arg1) = r.b THEN plant(i.jlk, v.b, 0) OR comp(i.jlk, arg1) clear_slaves() ssf := k stack(k) IF op = s.fnap THEN loadt(k.reg, r.acc) $) AND loadlv(offset) BE $( LET r = ? cgpendingop(r.null) TEST acc_v = k.svctbword THEN $( LET a = acc_a freereg(r.acc) plant(i.iad, v.nil, offset - a) $) OR $( freereg(r.acc) plant(i.lss, v.c, svctbword) plant(i.iad, v.nil, offset) $) slave(r.acc, k.svctbword, offset, 0) loadt(k.reg, r.acc) $) AND loadlvp(offset) BE $( cgpendingop(r.null) TEST acc_v = k.lnb THEN $( LET a = acc_a freereg(r.acc) plant(i.iad, v.nil, offset - a) $) OR $( freereg(r.b) freereg(r.acc) plant(i.stln, v.b, 0) plant(i.lss, v.b, 0) plant(i.ush, v.nil, -2) plant(i.iad, v.nil, offset) unslave(r.b) $) slave(r.acc, k.lnb, offset, 0) loadt(k.reg, r.acc) $) AND loadlvc(offset) BE $( LET r = ? cgpendingop(r.null) TEST acc_v = k.svsstword THEN $( LET a = acc_a freereg(r.acc) plant(i.iad, v.nil, offset - a) $) OR $( freereg(r.acc) plant(i.lss, v.c, svsstword) plant(i.iad, v.nil, offset) $) slave(r.acc, k.svsstword, offset, 0) loadt(k.reg, r.acc) $) AND cgrv() BE $( LET v = ? AND r = r.acc cgpendingop(r.b) IF h1!arg1 = k.reg & h2!arg1 = r.acc THEN $( freereg(r.b) plant(i.st, v.b, 0) h2!arg1 := r.b $) IF h1!arg1 = k.reg & h2!arg1 = r.b THEN $( op := readop() IF op = s.rv THEN r := r.b IF r = r.acc THEN freereg(r.acc) $( LET inst = (r = r.acc -> i.lss, i.lb) TEST dr_a = svinw THEN plant(inst, v.md, 0) OR $( plant(inst, v.mic, svinw) dr_a := svinw $) $) h1!arg1, h2!arg1 := k.reg, r unslave(r.b) unslave(r) RETURN $) v := h1!arg1 = k.loc -> v.dl, h1!arg1 = k.ctb -> v.dc, h1!arg1 = k.numb -> v.d, report("in compiler - bad K in CGRV - %N", h1!arg1) op := readop() IF op = s.rv THEN r := r.b freereg(r) unslave(r) resetdr() plant(r = r.acc -> i.lss, i.lb, v, h2!arg1) h1!arg1, h2!arg1 := k.reg, r $) AND cgputbyte() BE $( LET r, op = ?, ? cgpendingop(r.null) store(0, ssp - 4) IF h1!arg1 = k.stack \/ (h1!arg1 = k.reg & h2!arg1 = r.b) THEN movetor(r.acc, arg1) TEST h1!arg2 = k.numb THEN movecontor(r.b, h2!arg2*bytesperword) OR $( movetor(r.b, arg2) plant(i.myb, v.nil, bytesperword) unslave(r.b) $) TEST h1!arg1 = k.reg & h2!arg1 = r.acc THEN $( plant(i.iad, v.b, 0) plant(i.st, v.b, 0) clear_slaves() $) OR UNLESS numberis(0, arg1) DO $( comp(i.adb, arg1) unslave(r.b) $) stack(ssp - 2) movetor(r.acc, arg1) TEST dr_a = svinb THEN plant(i.st, v.md, 0) OR $( plant(i.st, v.mic, svinb) dr_a := svinb $) stack(ssp - 1) clear_slaves() $) AND cgselect(op) BE $( LET size = readn() LET shift = readn() LET offset = readn() TEST size = bitsperbyte & (shift REM bitsperbyte = 0) THEN cgbyteselector(op, shift, offset) OR cggenselector(op, size, shift, offset) $) AND cgbyteselector(op, shift, offset) BE $( LET index = bytesperword - shift/bitsperbyte - 1 + offset*bytesperword AND r = ? AND inst = (op = s.slctap -> i.lss, i.st) cgpendingop(r.null) r := movetoanyr(arg1) TEST r = r.acc THEN $( plant(i.ush, v.nil, 2) UNLESS index = 0 DO plant(i.iad, v.nil, index) freereg(r.b) plant(i.st, v.b, 0) $) OR TEST r = r.b THEN $( plant(i.myb, v.nil, bytesperword) UNLESS index = 0 DO plant(i.adb, v.nil, index) IF op = s.slctap THEN freereg(r.acc) $) OR report("in compiler - bad R in CGBYTESELECTOR - %N", r) IF op = s.slctst THEN comp(i.lss, arg2) TEST dr_a = svinb THEN plant(inst, v.md, 0) OR $( plant(inst, v.mic, svinb) dr_a := svinb $) clear_slaves() TEST op = s.slctap THEN h1!arg1, h2!arg1 := k.reg, r.acc OR stack(ssp - 2) $) AND cggenselector(op, size, shift, offset) BE $( cgpendingop(r.b) IF h1!arg1 = k.reg & h2!arg1 = r.acc THEN $( freereg(r.b) plant(i.st, v.b, 0) h2!arg1 := r.b $) movetor(r.b, arg1) UNLESS offset = 0 DO $( plant(i.adb, v.nil, offset) unslave(r.b) $) TEST op = s.slctap THEN $( freereg(r.acc) TEST dr_a = svinw THEN plant(i.lss, v.md, 0) OR $( plant(i.lss, v.mic, svinw) dr_a := svinw $) UNLESS shift = 0 DO plant(i.ush, v.nil, -shift) UNLESS (size + shift) = bitsperword DO plant(i.and, v.nil, mask(size)) h1!arg1, h2!arg1 := k.reg, r.acc $) OR $( movetor(r.acc, arg2) UNLESS (size + shift) = bitsperword DO plant(i.and, v.nil, mask(size)) UNLESS shift = 0 DO plant(i.ush, v.nil, shift) TEST dr_a = svinw THEN plant(i.slss, v.md, 0) OR $( plant(i.slss, v.mic, svinw) dr_a := svinw $) plant(i.and, v.nil, NOT (mask(size) << shift)) plant(i.or, v.t, 0) plant(i.st, v.md, 0) clear_slaves() stack(ssp - 2) $) $) AND mask(n) = (1 << n) - 1 AND cggoto() BE $( LET a = h2!arg1 cgpendingop(r.b) store(0, ssp - 2) resetdr() SWITCHON h1!arg1 INTO $( CASE k.ctb: plant(i.j, v.c, a) ENDCASE CASE k.reg: IF a = r.acc THEN $( freereg(r.b) plant(i.st, v.b, 0) $) plant(i.j, v.b, 0) ENDCASE CASE k.loc: plant(i.j, v.l, a) ENDCASE DEFAULT: report("in compiler - bad K in CGGOTO - %N", h1!arg1) $) stack(ssp - 1) incode_ := FALSE $) AND data(v) BE $( databuf!datacount := v datap := datap + 1 datacount := datacount + 1 IF datacount GE databufsize THEN flush_data() $) AND sdata(v) BE $( sdatabuf!sdatacount := v sdatap := sdatap + 1 sdatacount := sdatacount + 1 IF sdatacount GE databufsize THEN flush_sdata() $) AND flush_data() BE UNLESS datacount = 0 DO $( lput(a.gla, datacount*bytesperword, (datap - datacount)*bytesperword, databuf << 2) datacount := 0 $) AND flush_sdata() BE UNLESS sdatacount = 0 DO $( lput(a.sst, sdatacount*bytesperword, (sdatap - sdatacount)*bytesperword, sdatabuf << 2) sdatacount := 0 $) AND cgstring(n) BE $( LET wordlength = n/bytesperword + 1 AND m, a = 0, n IF incode_ THEN $( TEST parmx THEN loadlvc(sdatap) OR loadlv(datap) $) FOR i = 1 TO wordlength DO $( LET w = 0 FOR j = 0 TO bytesperword - 1 DO $( (@w)%j := a m := m + 1 a := (m > n) -> 0, readn() $) IF incode_ THEN [parmx -> sdata, data](w) $) $) AND cgcode(n) BE $( STATIC $( c_ptr = ?; c_max = ?; c_vec = ? $) LET s_rdch() = VALOF $( IF c_ptr = c_max RESULTIS endstreamch c_ptr := c_ptr + 1 $( LET c = c_vec%c_ptr IF 'a' LE c LE 'z' THEN c := c - 'a' + 'A' RESULTIS c $) $) AND s_unrdch() BE c_ptr := c_ptr - 1 AND match(a, b) = VALOF $( FOR i = 1 TO a%0 DO $( LET ac, bc = a%i, b%i IF 'a' LE ac LE 'z' THEN ac := ac - 'a' + 'A' IF 'a' LE bc LE 'z' THEN bc := bc - 'a' + 'A' UNLESS ac = bc RESULTIS FALSE $) RESULTIS TRUE $) LET v = VEC maxstrlength/bytesperword + 1 AND word = 0 AND save_rdch = rdch AND item_read = FALSE AND size = ? v%0 := n FOR i = 1 TO n DO v%i := readn() IF n = 6 & match(v, "CODEON") THEN $( plant := plantl // Turn on code listing codelist_ := TRUE TEST code_heading_done_ THEN newline() OR code_heading() RETURN $) IF n = 7 & match(v, "CODEOFF") THEN $( plant := plantcopy // Turn off code listing codelist_ := FALSE RETURN $) cgpendingop(r.null) store(0, ssp - 1) asf(ssp - ssf) clear_slaves() resetdr() c_ptr, c_max, c_vec := 0, n, v terminator := '*S' rdch := s_rdch $( LET radix = 10 UNTIL terminator = '#' \/ '0' LE terminator LE '9' \/ terminator = '*N' \/ terminator = endstreamch DO terminator := rdch() IF terminator = endstreamch BREAK IF terminator = '*N' THEN $( UNLESS item_read DO // Blank line $( terminator := '*S' LOOP $) item_read := FALSE terminator := '*S' codeout(size, word) word := 0 LOOP $) TEST terminator = '#' THEN $( radix := 8 terminator := rdch() IF 'a' LE terminator LE 'z' THEN terminator := terminator - ('a' - 'A') TEST terminator = 'X' THEN radix := 16 OR TEST terminator = 'O' THEN radix := 8 OR TEST terminator = 'B' THEN radix := 2 OR s_unrdch() $) OR s_unrdch() IF terminator = endstreamch BREAK TEST item_read THEN word := word \/ readnumber(radix) OR $( item_read := TRUE size := readnumber(radix) $) IF terminator = endstreamch BREAK $) REPEAT rdch := save_rdch IF item_read THEN codeout(size, word) $) AND codeout(size, word) BE IF incode_ THEN $( IF codelist_ THEN writeaddress(size1 + codelength) SWITCHON size INTO $( CASE 2: IF codelist_ THEN writef(" HWORD*TX*'%X4*' %X4*N", word, word) ohword(word) ENDCASE CASE 4: IF codelist_ THEN writef(" WORD*TX*'%X8*' %X8*N", word, word) ofword(word) ENDCASE DEFAULT: IF codelist_ THEN newline() comment("invalid item size in CODE section - %N", size) $) $) AND cgentry(n, l) BE $( LET wordlength = n/bytesperword + 1 LET p, m, a = sdatap, 0, n IF codelist_ THEN writes("***N** Entry point of ") FOR i = 1 TO wordlength DO $( LET w = 0 FOR j = 0 TO bytesperword - 1 DO $( (@w)%j := a m := m + 1 a := (m > n) -> '*S', readn() IF codelist_ THEN wrch(a) $) IF tracing_ \/ profiling_ THEN sdata(w) $) IF codelist_ THEN writes("*N***N") complab(l, TRUE) IF tracing_ \/ profiling_ THEN $( freereg(r.acc) freereg(r.b) plant(i.lss, v.nilf, p) plant(i.jlk, v.c, svtrentry) $) IF profiling_ DO plant_profile() $) AND plant_profile() BE $( LET p = datap data(0) // Allocate space for the profile counter freereg(r.b) plant(i.lb, v.b, 0) // No-op (unique pattern marking profile code) plant(i.lb, v.c, p) plant(i.adb, v.nil, 1) plant(i.stb, v.c, p) unslave(r.b) $) AND set_sf(newsf) BE $( freereg(r.acc) freereg(r.b) clear_slaves() plant(i.stsf, v.b, 0) plant(i.stln, v.t, 0) plant(i.lss, v.b, 0) plant(i.isb, v.t, 0) plant(i.ush, v.nil, -2) plant(i.irsb, v.nil, newsf) plant(i.st, v.b, 0) plant(i.asf, v.b, 0) ssf := newsf $) AND asf(n) BE UNLESS n = 0 DO $( plant(i.asf, v.nil, n) IF n < 0 THEN FOR i = ssf - 1 TO ssf - n - 1 DO $( IF slaved(r.acc, k.loc, i, 0) THEN unslave(r.acc) IF slaved(r.b, k.loc, i, 0) THEN unslave(r.b) $) ssf := ssf + n $) AND comp(f, arg) BE $( LET v = h1!arg AND var = ? AND factor = storeop(f) -> 1, -1 IF v = k.reg & h2!arg = r.acc THEN TEST f = i.lb THEN $( plant(i.st, v.b, 0) slave(r.b, acc_v, acc_a, acc_k) RETURN $) OR $( plant(i.st, v.t, 0) v := k.st $) IF v = k.stack & h2!arg = (ssf - 1) THEN $( v := k.st ssf := ssf + factor $) var := v = k.loc -> v.l, v = k.stack -> v.l, v = k.ctb -> v.c, v = k.st -> v.t, v = k.numb -> v.nil, v = k.reg & h2!arg = r.b -> v.b, report("in compiler - bad variant in COMP - %N", v) plant(f, var, h2!arg) $) AND storeop(op) = (op = i.st) \/ (op = i.stb) \/ (op = i.std) \/ (op = i.stln) \/ (op = i.stsf) \/ (op = i.stxn) \/ (op = i.stct) AND plant(op, var, addr) BE $( LET k, k., k.. = #B11, 0, 0 UNLESS incode_ RETURN IF var = v.lab \/ var = v.mlab THEN // Branch, or label placement $( TEST op = i.lab THEN complabx(addr, var) OR branchx(op, addr, var) RETURN $) IF (op & #XF0000000) = 0 THEN // Tertiary format $( UNLESS var = v.nil DO report("in compiler - illegal variant for tertiary format opcode - %N*N", var) ofword(op \/ (addr & #X3FFFF)) RETURN $) SWITCHON var INTO $( CASE v.l: k., k.. := 0, 2 IF usmall(addr) THEN k := #B01 ENDCASE CASE v.nil: IF (op = i.j) & (addr GE 0) THEN ENDCASE // Forward jumps must not be shortened IF small(addr) THEN // Short form of literal $( k := #B00 addr := addr & #X7F ENDCASE $) IF medium(addr) THEN // Long form of literal $( addr := addr & #X3FFFF ENDCASE $) $( LET n = const(addr) // Get appropiate IIL LET chain = iilva!n iilva!n := codelength/2 // Add to chain plantcopy(op, v.p, chain) RETURN $) CASE v.nilf: // Guaranteed 18-bit literal UNLESS medium(addr) DO report("in compiler - 18-bit literal too big") addr := addr & #X3FFFF ENDCASE CASE v.t: k., k.. := 0, 6 ENDCASE CASE v.b: k., k.. := 0, 7 ENDCASE CASE v.d: k., k.. := 1, 0 IF addr = 0 THEN k., k.. := 2, 7 UNLESS medium(addr) DO $( LET n = const(addr) LET chain = iilva!n iilva!n := codelength/2 plantcopy(op, v.dp, chain) RETURN $) addr := addr & (small(addr) -> #X7F, #X3FFFF) ENDCASE CASE v.md: k., k.. := 3, 7 ENDCASE CASE v.x: k., k.. := 0, 3 ENDCASE CASE v.ix: k., k.. := 2, 3 ENDCASE CASE v.p: k., k.. := 0, 4 ENDCASE CASE v.c: k., k.. := 0, 5 ENDCASE CASE v.dt: k., k.. := 1, 6 ENDCASE CASE v.dl: k., k.. := 1, 2 ENDCASE CASE v.dc: k., k.. := 1, 5 ENDCASE CASE v.dp: k., k.. := 1, 4 ENDCASE CASE v.mic: k., k.. := 3, 5 ENDCASE CASE v.ic: k., k.. := 2, 5 ENDCASE DEFAULT: report("in compiler - illegal variant in PLANT") $) UNLESS k = #B11 DO $( ohword((op >> 16) \/ (k << 7) \/ addr) RETURN $) IF (k.. = 6) \/ (k.. = 7) DO $( ohword((op >> 16) \/ (k << 7) \/ (k. << 5) \/ (k.. << 2)) RETURN $) ofword(op \/ (k << 23) \/ (k. << 21) \/ (k.. << 18) \/ addr) $) AND small(addr) = -64 LE addr LE 63 AND usmall(addr) = 0 LE addr LE 127 AND medium(addr) = -131072 LE addr LE 131071 AND const(value) = VALOF $( FOR i = 0 TO iilp - 1 DO // See if value allocated already IF iilv!i = value RESULTIS i // New IIL is to be allocated codemax := codemax - 2 // Steal space from code area IF codemax*4 LE codelength THEN report("out of space for code and IILs (use WORKSIZE parameter to increase)") // Move base of IIL values down by 2 words iilv := iilv - 2 FOR i = 0 TO iilp - 1 DO iilv!i := iilv!(i + 2) // Move base of IIL chain pointers down by 1 word iilva := iilva - 1 FOR i = 0 TO iilp - 1 DO iilva!i := iilva!(i + 1) iilv!iilp, iilva!iilp := value, 0 iilp := iilp + 1 RESULTIS iilp - 1 $) AND ofword(w) BE $( ohword(w >> 16) ohword(w) $) AND ohword(hw) BE $( codev%codelength := hw >> 8 codev%(codelength + 1) := hw codelength := codelength + 2 IF codev*4 + codelength GE codemax*4 DO report("out of space for code and IILs (use WORKSIZE parameter to increase)") $) AND complab(l, routine_entry) BE compl(l, routine_entry, v.lab) AND mcomplab(l) BE compl(l, FALSE, v.mlab) AND compl(l, routine_entry, v) BE $( cgpendingop(r.null) store(0, ssp - 1) asf(ssp - ssf) IF v = v.lab THEN resetdr() incode_ := TRUE clear_slaves() plant(i.lab, v, l) UNLESS routine_entry \/ v = v.mlab DO $( IF goto_destination(l) THEN set_sf(ssp) IF profiling_ THEN plant_profile() $) $) AND complabx(l, v) BE $( LET lvec = v = v.lab -> labv, mlabv IF l GE (v = v.lab -> max.labels + 1, maxswitchlabels) THEN report("too many *'labels*' in program") IF (lvec!l < 0) \/ (l = max.labels & v = v.lab) THEN // Forward references exist to this label $( LET addr = codelength/2 // Address of label, in halfwords AND chain = -lvec!l // Top of fixup chain for this label (byte offset in CODEV) $( LET offset = addr - chain/2 // Offset in halfwords AND disp = chain // Displacement (in bytes) of instruction in CODEV LET instruction = getword(codev, disp) putword(codev, disp, (instruction & #XFFFC0000) \/ offset) chain := instruction & #X3FFFF $) REPEATUNTIL chain = 0 $) lvec!l := codelength // Place the label $) AND goto_destination(lab) = VALOF $( IF lab > max.labels THEN report("in compiler - bad label in GOTO.DESTINATION - %N", lab) $( LET offset = lab/bitsperword LET word = labmap!offset RESULTIS ((word >> (lab REM bitsperword)) & 1) NE 0 $) $) AND setlabbit(lab) BE $( LET offset = lab/bitsperword LET bit = 1 << (lab REM bitsperword) labmap!offset := labmap!offset \/ bit $) AND branch(op, lab) BE $( resetdr() plant(op, v.lab, lab) $) AND mbranch(op, lab) BE plant(op, v.mlab, lab) AND branchx(op, lab, v) BE $( LET lvec = v = v.lab -> labv, mlabv IF lab GE (v = v.lab -> max.labels + 1, maxswitchlabels) THEN report("too many *'labels*' in program") TEST lvec!lab > 0 THEN // Label already set $( LET offset = (lvec!lab - codelength)/2 plantcopy(op, v.nil, offset) $) OR $( TEST lvec!lab = 0 THEN // First use of label $( lvec!lab := -codelength plantcopy(op, v.nil, 0) // Zero is end of chain $) OR $( LET p = codelength plantcopy(op, v.nil, -lvec!lab) // Add to chain lvec!lab := -p // New end of chain $) $) $) AND cgbranch(b, l) BE $( LET f = ? AND rand1, rand2 = arg1, arg2 AND r = ? SWITCHON pendingop INTO $( DEFAULT: cgpendingop(r.null) store(0, ssp - 2) resetdr() // Do this here to avoid corrupting CC later r := movetoanyr(arg1) f := b -> i.jne, i.je f := [r = r.acc -> accop, bop](f) stack(ssp - 1) branch(f, l) RETURN CASE s.ne: b := NOT b CASE s.eq: f := b -> i.je, i.jne ENDCASE CASE s.ls: b := NOT b CASE s.ge: f := b -> i.jge, i.jl ENDCASE CASE s.le: b := NOT b CASE s.gr: f := b -> i.jg, i.jle ENDCASE $) store(0, ssp - 3) IF (h1!rand2 = k.numb) \/ (h1!rand1 = k.stack = h1!rand2) \/ (regusedby(rand1) = r.acc) THEN $( rand1, rand2 := arg2, arg1 f := invop(f) $) r := movetoanyr(rand2) resetdr() // Do this here to avoid corrupting CC later TEST numberis(0, rand1) THEN f := [r = r.acc -> accop, bop](f) OR comp(r = r.acc -> i.icp, i.cpb, rand1) stack(ssp - 2) branch(f, l) $) . GET "BCPL2_BCPL2HDR" STATIC $( defaultlabel = ? $) STATIC $( caselv = ?; caseuv = ?; casel = ?; mlabno = ? $) LET cgswitch() BE $( LET clv = VEC maxswitchlabels AND cuv = VEC maxswitchlabels AND clab = VEC maxswitchlabels AND mlv = VEC maxswitchlabels AND n = readn() // Number of CASEs resetdr() mlabv := mlv IF n > maxswitchlabels THEN report("too many CASEs in a SWITCHON") FOR i = 0 TO maxswitchlabels DO mlv!i := 0 mlabno := 0 defaultlabel := readl() cgpendingop(r.acc) store(0, ssp - 2) movetor(r.acc, arg1) stack(ssp - 1) FOR i = 1 TO n DO $( LET k = readn() LET l = readl() AND j = i - 1 UNTIL j = 0 DO $( IF k GE clv!j BREAK clv!(j + 1), cuv!(j + 1), clab!(j + 1) := clv!j, cuv!j, clab!j j := j - 1 $) clv!(j + 1), cuv!(j + 1), clab!(j + 1) := k, k, l $) // Merge adjoining CASEs FOR i = n - 1 TO 1 BY -1 DO $( LET pll, plu = labv!(clab!i), labv!(clab!(i + 1)) UNLESS pll = plu LOOP // They don't label the same code UNLESS (cuv!i + 1) = clv!(i + 1) LOOP // They aren't adjacent values cuv!i := cuv!(i + 1) n := n - 1 FOR j = i + 1 TO n DO clv!j, cuv!j, clab!j := clv!(j + 1), cuv!(j + 1), clab!(j + 1) $) caselv, caseuv, casel := clv, cuv, clab resetdr() // Do this here to avoid corrupting CC later switch(1, n, FALSE, FALSE) switch_prefix := switch_prefix + 1 IF switch_prefix = ('Z' + 1) THEN switch_prefix := 'a' IF switch_prefix = ('z' + 1) THEN switch_prefix := 'A' $) AND switch(b, t, lwb, upb) BE $( LET instns, ncases = 0, t - b + 1 AND l = caselv!b // Lowest CASE value AND u = caseuv!t // Highest CASE value LET range = u/2 - l/2 + 3 FOR i = b TO t DO instns := instns + (caselv!i = caseuv!i -> 2, 4) TEST instns/2 < range THEN $( TEST ncases LE 5 THEN $( FOR i = b TO t DO $( TEST caselv!i = caseuv!i THEN reljump(i.je, caselv!i, branch, casel!i) OR $( LET lab = nextmlab() reljump(i.jl, caselv!i, mbranch, lab) reljump(i.jle, caseuv!i, branch, casel!i) mcomplab(lab) $) $) branch(i.j, defaultlabel) $) OR $( LET half = b + ncases/2 AND lab = nextmlab() reljump(i.jg, caseuv!half, mbranch, lab) switch(b, half, lwb, TRUE) mcomplab(lab) switch(half + 1, t, FALSE, upb) $) $) OR $( UNLESS lwb DO reljump(i.jl, l, branch, defaultlabel) UNLESS upb DO reljump(i.jg, u, branch, defaultlabel) UNLESS l = 0 DO plant(i.isb, v.nil, l) // Normalise plant(i.jlk, v.c, svswsupport) FOR i = l TO u DO $( TEST (b > t) \/ (caselv!b > i) THEN branch(i.jccf, defaultlabel) OR $( branch(i.jccf, casel!b) IF i = caseuv!b THEN b := b + 1 $) $) $) $) AND nextmlab() = VALOF $( mlabno := mlabno + 1 RESULTIS mlabno $) AND reljump(op, val, r, lab) BE $( TEST val = 0 THEN op := accop(op) OR plant(i.icp, v.nil, val) r(op, lab) $) AND plantl(op, var, addr) BE $( LET codeaddr = size1 + codelength AND largeconst = FALSE AND v = var TEST v = v.lab \/ v = v.mlab THEN $( LET c = v = v.lab -> "L", VALOF $( LET s = (TABLE 0, 0) s%0 := 2 // Form a string s%1 := 'M' s%2 := switch_prefix RESULTIS s $) IF incode_ THEN $( writeaddress(codeaddr) TEST op = i.lab THEN // Placement of label writef("%S%N*N", c, addr) OR // Branch $( LET length = (v = v.lab -> 15, 14) AND a = addr writef(" %S*T%S", opcode(op), c) TEST op = i.jccf THEN $( writen(addr) writes(",X*'F*'") WHILE a > 0 DO $( length := length - 1 a := a/10 $) FOR i = 1 TO length - 5 DO wrch('*S') $) OR writeljn(addr, length) $) $) plantcopy(op, var, addr) v := v.lab $) OR $( IF incode_ THEN $( plantcopy(op, var, addr) writeaddress(codeaddr) IF v = v.nil \/ v = v.d THEN UNLESS small(addr) \/ medium(addr) DO $( writef(" %S.%S*TI", opcode(op), v = v.nil -> "P", "DP") writeljn(const(addr), 15) largeconst := TRUE $) UNLESS largeconst DO $( writef(" %S%S%S*T", opcode(op), v = v.nil \/ v = v.nilf -> "", ".", variant(v)) TEST completing_variant(v) THEN writes(" ") OR writeljn(addr, 16) $) $) $) UNLESS (v = v.lab) & (op = i.lab) DO $( LET length = codelength - (codeaddr - size1) AND instruction = getword(codev, codeaddr - size1) IF length = 2 THEN instruction := instruction >> 16 UNLESS length = 0 DO $( writehex(instruction, length*2) IF largeconst THEN writef(" ** IIL, value = X*'%X8*' (%N)", addr, addr) newline() $) $) $) AND writeaddress(addr) BE writef(" C+%X6 ", addr) AND writeljn(n, w) BE $( TEST (n NE 0) & ((n << 1) = 0) THEN $( writes("-2147483648") w := w - 11 $) OR $( IF n < 0 THEN $( wrch('-') w := w - 1 n := -n $) wlj(n, @w) $) FOR i = 1 TO w DO wrch('*S') $) AND wlj(n, atw) BE $( IF n > 9 DO wlj(n/10, atw) wrch(n REM 10 + '0') !atw := !atw - 1 $) AND opcode(op) = VALOF SWITCHON op INTO $( CASE i.adb : RESULTIS "ADB" CASE i.and : RESULTIS "AND" CASE i.asf : RESULTIS "ASF" CASE i.call: RESULTIS "CALL" CASE i.cpb : RESULTIS "CPB" CASE i.exit: RESULTIS "EXIT" CASE i.iad : RESULTIS "IAD" CASE i.icp : RESULTIS "ICP" CASE i.idv : RESULTIS "IDV" CASE i.imdv: RESULTIS "IMDV" CASE i.imy : RESULTIS "IMY" CASE i.inca: RESULTIS "INCA" CASE i.irdv: RESULTIS "IRDV" CASE i.irsb: RESULTIS "IRSB" CASE i.isb : RESULTIS "ISB" CASE i.j : RESULTIS "J" CASE i.jccf: RESULTIS "JCC" CASE i.je : RESULTIS "JE" CASE i.jg : RESULTIS "JG" CASE i.jge : RESULTIS "JGE" CASE i.jl : RESULTIS "JL" CASE i.jle : RESULTIS "JLE" CASE i.jlk : RESULTIS "JLK" CASE i.jn : RESULTIS "JN" CASE i.jnb : RESULTIS "JNB" CASE i.jne : RESULTIS "JNE" CASE i.jnn : RESULTIS "JNN" CASE i.jnnb: RESULTIS "JNNB" CASE i.jnp : RESULTIS "JNP" CASE i.jnpb: RESULTIS "JNPB" CASE i.jnz : RESULTIS "JNZ" CASE i.jnzb: RESULTIS "JNZB" CASE i.jp : RESULTIS "JP" CASE i.jpb : RESULTIS "JPB" CASE i.jz : RESULTIS "JZ" CASE i.jzb : RESULTIS "JZB" CASE i.lab : RESULTIS "LAB" CASE i.lb : RESULTIS "LB" CASE i.lct : RESULTIS "LCT" CASE i.ld : RESULTIS "LD" CASE i.ldrl: RESULTIS "LDRL" CASE i.lln : RESULTIS "LLN" CASE i.lsd : RESULTIS "LSD" CASE i.lsq : RESULTIS "LSQ" CASE i.lss : RESULTIS "LSS" CASE i.lxn : RESULTIS "LXN" CASE i.myb : RESULTIS "MYB" CASE i.neq : RESULTIS "NEQ" CASE i.or : RESULTIS "OR" CASE i.prcl: RESULTIS "PRCL" CASE i.raln: RESULTIS "RALN" CASE i.rot : RESULTIS "ROT" CASE i.sbb : RESULTIS "SBB" CASE i.shs : RESULTIS "SHS" CASE i.sl : RESULTIS "SL" CASE i.slb : RESULTIS "SLB" CASE i.slsd: RESULTIS "SLSD" CASE i.slsq: RESULTIS "SLSQ" CASE i.slss: RESULTIS "SLSS" CASE i.st : RESULTIS "ST" CASE i.stb : RESULTIS "STB" CASE i.stct: RESULTIS "STCT" CASE i.std : RESULTIS "STD" CASE i.stln: RESULTIS "STLN" CASE i.stsf: RESULTIS "STSF" CASE i.stxn: RESULTIS "STXN" CASE i.uad : RESULTIS "UAD" CASE i.usb : RESULTIS "USB" CASE i.ush : RESULTIS "USH" DEFAULT : report("in compiler - illegal opcode - %N", op) $) AND variant(v) = VALOF SWITCHON v INTO $( CASE v.b : RESULTIS "B" CASE v.c : RESULTIS "C" CASE v.d : RESULTIS "D" CASE v.dt : RESULTIS "DT" CASE v.ix : RESULTIS "IX" CASE v.l : RESULTIS "L" CASE v.md : RESULTIS "MD" CASE v.p : RESULTIS "P" CASE v.t : RESULTIS "T" CASE v.x : RESULTIS "X" CASE v.dl : RESULTIS "DL" CASE v.dc : RESULTIS "DC" CASE v.dp : RESULTIS "DP" CASE v.mic : RESULTIS "MIC" CASE v.ic : RESULTIS "IC" CASE v.nilf: CASE v.nil : RESULTIS "" DEFAULT : report("in compiler - illegal variant in VARIANT") $) AND list_iils() BE UNLESS iilp = 0 DO $( writes("*N*N*T*TImplied in-code literals*N*N") writes(" Address Value*N") writes("*T Hexadecimal Decimal*N*N") FOR i = 0 TO iilp - 1 DO $( LET value = iilv!i writeaddress(size1 + codelength + i*4) writef("I%N", i) writef("*T%X8 %N*N", value, value) $) newline() $) AND completing_variant(v) = v = v.b \/ v = v.dt \/ v = v.md \/ v = v.t AND code_heading() BE $( writes("*N*T*T Listing of generated code *N*N") writes(" Address Opcode*TOperand Code*N*N") code_heading_done_ := TRUE $) // End of file BCPL2_BCPL2SRC