// File BCPLV1_MAINSRC // Version: Q1.9 (also alter MANIFESTs below) // BCPL compiler - phase 1 - system interface // Copyright (C) R.D. Eager University of Kent MCMLXXXVI // History: // Q1.0 - Initial version. // Q1.1 - Addition of LIBRARY parameter. // Q1.2 - Code for EXTERNAL, SECTION and NEEDS modified so that // strings are always read in 'host_code'. // - Default character code for 'tg.ibm' is now EBCDIC. // Q1.3 - Addition of GETLIST parameter and deletion of O flag. // - Correction to constant folder in 'recast_subtree'. // Q1.4 - Addition of SAVESPACE parameter. // Q1.5 - Alteration to ensure that ENTRY OCODE is always accompanied // by the routine or function name in ASCII, regardless of the // target character code. // Q1.6 - Correction to 'transfor' to forbid use of CASE labels // within FOR loops when the corresponding SWITCHON command is // outside the loop. // Q1.7 - Addition of date, time and source file name to compilation // listings. // - Correction to OCODE output routines to ensure that no // output record exceeds the permitted size. // Q1.8 - Addition of code to output steering line to OCODE file, // defining the character code used. // Q1.9 - Correction to 'ppdebug' code. MANIFEST $( // Alter these if changes are made version = 1 // Major version number edit = 9 // Edit number within major version $) /* Stop codes:- -N - Compilation with N semantic errors 0 - Successful compilation +N - N syntax errors 1000 - Parameter error 1001 - Fatal I/O error 1002 - Compiler error 1003 - GET files nested too deep 1004 - Steering information missing from source file */ GET "BCPLV1_SYNHDR" // Parameter decoder error codes MANIFEST $( 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.icv = -7 // Invalid value for CHARCODE parameter par.mip = -8 // Mandatory parameter INPUTFILE omitted par.mop = -9 // Mandatory parameter OUTPUTFILE omitted par.itv = -10 // Invalid value for TARGET parameter par.isv = -11 // Invalid value for STEER parameter par.igv = -12 // Invalid value for GETLIST parameter par.ipv = -13 // Invalid value for SAVESPACE parameter $) MANIFEST $( // Character codes cc.ascii = 0 // ASCII cc.ebcdic = 1 // EBCDIC cc.1900 = 2 // ICL 1900 $) MANIFEST $( // Target machines tg.2900 = 0 // ICL 2900 tg.1900 = 1 // ICL 1900 tg.ibm = 2 // IBM $) STATIC $( options= ?; parptr = ?; parleng = ?; param_pos = ? $) STATIC $( icl1900_table = ? $) MANIFEST $( keymax = 10 $) LET start() BE $( LET keys = VEC keymax AND defaults = VEC keymax AND opt = VEC maxstrlength/bytesperword + 2*keymax AND datevec = VEC 2 AND timevec = VEC 2 AND treesize = ? AND title = "University of Kent BCPL compiler - version Q%N.%N*N" AND target, target_code = ?, ? AND steering_ = ? AND libn = VEC maxstrlength/bytesperword lib_name := libn sysout := journal selectoutput(sysout) writef(title, version, edit) // Set default options domapstore_ := FALSE ppdebug_, pptrace_ := FALSE, FALSE prsource_ := FALSE treelist_, enablecode_, noget_, fold_const_ := FALSE, FALSE, FALSE, TRUE treesize, dvect, globdeclt, caset := 8000, 2400, 100, 150 reportmax, total_reports, syntax_errors_ := maxreports, 0, FALSE icl1900_table := (TABLE -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, #x10, #x11, #x12, #x13, #x3c, #x15, #x16, #x17, #x18, #x19, #x1a, #x1b, #x1c, #x1d, #x1e, #x1f, #x00, #x01, #x02, #x03, #x04, #x05, #x06, #x07, #x08, #x09, #x0a, #x0b, #x0c, #x0d, #x0e, #x0f, #x20, #x21, #x22, #x23, #x24, #x25, #x26, #x27, #x28, #x29, #x2a, #x2b, #x2c, #x2d, #x2e, #x2f, #x30, #x31, #x32, #x33, #x34, #x35, #x36, #x37, #x38, #x39, #x3a, #x3b, -1, #x3d, #x3e, #x3f, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1) options := opt keys!0 := keymax keys!1 := "INPUTFILE" ; defaults!1 := 0 keys!2 := "OUTPUTFILE" ; defaults!2 := 0 keys!3 := "SAVELIST" ; defaults!3 := 0 keys!4 := "FLAGS" ; defaults!4 := "" keys!5 := "CHARCODE" ; defaults!5 := 0 keys!6 := "TARGET" ; defaults!6 := "2900" keys!7 := "STEER" ; defaults!7 := "YES" keys!8 := "LIBRARY" ; defaults!8 := "" keys!9 := "GETLIST" ; defaults!9 := "NO" keys!10 := "SAVESPACE" ; defaults!10 := -1 FOR i = 1 TO param%0 DO $( LET c = param%i IF 'a' LE c LE 'z' THEN param%i := c - 'a' + 'A' $) paramdecode(keys, options) FOR i = 1 TO keymax DO IF options!i = 0 THEN options!i := defaults!i TEST options!1 = 0 THEN options!0 := par.mip // Mandatory parameter INPUTFILE omitted OR TEST options!2 = 0 THEN options!0 := par.mop // Mandatory parameter OUTPUTFILE omitted OR $( LET x = options!6 TEST matchstrings(x, "2900") THEN target := tg.2900 OR TEST matchstrings(x, "1900") THEN target := tg.1900 OR TEST matchstrings(x, "IBM") THEN target := tg.ibm OR options!0 := par.itv // Invalid value for TARGET parameter $) IF options!5 = 0 THEN options!5 := target = tg.1900 -> "1900", target = tg.ibm -> "EBCDIC", "ASCII" IF options!0 >= 0 THEN $( LET x = options!5 TEST matchstrings(x, "ASCII") THEN target_code := cc.ascii OR TEST matchstrings(x, "EBCDIC") THEN target_code := cc.ebcdic OR TEST matchstrings(x, "1900") THEN target_code := cc.1900 OR options!0 := par.icv // Invalid value for CHARCODE parameter $) IF options!0 >= 0 THEN $( LET x = options!7 TEST matchstrings(x, "YES") THEN steering_ := TRUE OR TEST matchstrings(x, "NO") THEN steering_ := FALSE OR options!0 := par.isv // Invalid value for STEER parameter $) IF options!0 >= 0 THEN $( LET x = options!9 TEST matchstrings(x, "YES") THEN list_gets_ := TRUE OR TEST matchstrings(x, "NO") THEN list_gets_ := FALSE OR options!0 := par.igv // Invalid value for GETLIST parameter $) IF options!0 >= 0 THEN TEST options!10 >= 0 THEN $( LET n = strtonum(options!10) TEST 1 LE n LE 50 THEN savespacesize := n OR options!0 := par.ipv // Invalid value for SAVESPACE parameter $) OR savespacesize := -1 IF options!0 >= 0 THEN $( LET x = options!8 FOR i = 0 TO x%0 DO lib_name%i := x%i $) IF options!0 < 0 THEN $( LET mes = VALOF SWITCHON options!0 INTO $( CASE par.err: RESULTIS "illegal format" CASE par.amb: RESULTIS "ambiguous keyword" CASE par.unk: RESULTIS "unknown keyword" CASE par.xs: RESULTIS "too many parameters" CASE par.dup: RESULTIS "a parameter has been duplicated" CASE par.mis: RESULTIS "missing keyword" CASE par.icv: RESULTIS "invalid value for CHARCODE parameter" CASE par.mip: RESULTIS "mandatory parameter INPUTFILE omitted" CASE par.mop: RESULTIS "mandatory parameter OUTPUTFILE omitted" CASE par.itv: RESULTIS "invalid value for TARGET parameter" CASE par.isv: RESULTIS "invalid value for STEER parameter" CASE par.igv: RESULTIS "invalid value for GETLIST parameter" CASE par.ipv: RESULTIS "invalid value for SAVESPACE parameter" DEFAULT: RESULTIS "???" $) writef("Error in parameter list - %S*N", mes) stop(1000) $) real_rdch := rdch param_pos := 1 $( rdch := s_rdch // Takes input from FLAGS string $( ch := rdch() sw:SWITCHON ch INTO $( CASE endstreamch: BREAK CASE'*S': CASE'*N': ENDCASE CASE 'P': ppdebug_ := TRUE; ENDCASE CASE 'T': treelist_ := TRUE; ENDCASE CASE 'M': domapstore_ := TRUE; ENDCASE CASE 'N': noget_ := TRUE; ENDCASE CASE 'C': enablecode_ := TRUE; ENDCASE CASE 'E': pptrace_ := TRUE; ENDCASE CASE 'L': treesize := readn() IF treesize > maxtreesize THEN $( selectoutput(journal) writef("Warning - L flag has invalid value - %N assumed*N", maxtreesize) selectoutput(sysout) treesize := maxtreesize $) ch := terminator GOTO sw CASE 'A': reportmax := readn() ch := terminator GOTO sw CASE 'U': fold_const_ := FALSE; ENDCASE CASE 'D': dvect := readn() ch := terminator GOTO sw CASE 'G': globdeclt := readn() ch := terminator GOTO sw CASE 'K': caset := readn() ch := terminator GOTO sw DEFAULT : writef("Warning - flag *'%C*' not recognised*N", ch) $) $) REPEAT rdch := real_rdch // Restore 'rdch' $) sourcestream := findio(findinput, options!1) selectinput(sourcestream) ocode := findio(findoutput, options!2) // Copy the steering information to the OCODE file if required IF steering_ THEN $( LET o = output() AND nlsw_ = TRUE AND c = ? selectoutput(ocode) $( c := rdch() IF c = endstreamch THEN $( selectoutput(journal) writes("Error - steering information missing from source file*N") stop(1004) $) IF c = '**' & nlsw_ THEN // * at start of line $( LET c2 = rdch() // Inspect next non-space character AND spaces = 0 WHILE c2 = '*S' DO $( spaces := spaces + 1 c2 := rdch() $) IF c2 = '*N' BREAK // Asterisk was only thing on line wrch('**') FOR i = 1 TO spaces DO wrch('*S') c := c2 $) nlsw_ := c = '*N' wrch(c) $) REPEAT // Add a steering line indicating the character code used writef("**CHARSET=%S*N", VALOF SWITCHON target_code INTO $( CASE cc.1900 : RESULTIS "1900" CASE cc.ascii : RESULTIS "ASCII" CASE cc.ebcdic : RESULTIS "EBCDIC" DEFAULT : RESULTIS "???" $) ) writes("***N") // Finish off selectoutput(o) $) IF options!3 NE 0 THEN $( sysout := findio(findoutput, options!3) prsource_ := TRUE selectoutput(sysout) writes("*N*N*N*T*T") writef(title, version, edit) writef("*N*N*N*T*T Date: %S*N", date(datevec)) writef("*N*T*T Time: %S*N", timeofday(timevec)) writef("*N*T*TSource file: %S*N*N*N", options!1) $) set_target_options(target, target_code) aptovec(comp, treesize) IF domapstore_ THEN mapstore() advise("Phase 1 complete*N") IF total_reports NE 0 THEN advise("Program contains %N fault%S*N", total_reports, total_reports = 1 -> "", "s") selectoutput(ocode) endwrite() stop(syntax_errors_ -> total_reports, -total_reports) $) AND set_target_options(target, target_code) BE $( SWITCHON target INTO $( CASE tg.2900: // ICL 2900 target_bitsperword := 32 minselectoroffset := -262144 maxselectoroffset := 262143 backstack_ := FALSE precallsize := 9 UNLESS savespacesize >= 0 DO savespacesize := 2 globlist_ := TRUE ENDCASE CASE tg.1900: // ICL 1900 target_bitsperword := 24 minselectoroffset := -32768 maxselectoroffset := 32767 backstack_ := FALSE precallsize := 9 UNLESS savespacesize >= 0 DO savespacesize := 2 globlist_ := TRUE wrn := wrn24 ENDCASE CASE tg.ibm: // IBM target_bitsperword := 32 minselectoroffset := -262144 maxselectoroffset := 262143 backstack_ := FALSE precallsize := 9 UNLESS savespacesize >= 0 DO savespacesize := 10 globlist_ := TRUE ENDCASE $) charcode := target_code = cc.ascii -> host_code, target_code = cc.1900 -> icl1900_code, ebcdic_code $) AND s_rdch() = VALOF // Read from FLAGS string $( IF param_pos > (options!4)%0 RESULTIS endstreamch param_pos := param_pos + 1 RESULTIS (options!4)%(param_pos - 1) $) AND findio(r, fn) = VALOF $( LET strp = r(fn) IF strp = 0 THEN ioerror(result2, fn) RESULTIS strp $) AND ioerror(ecode, name) BE $( LET mes = VALOF SWITCHON ABS ecode INTO $( CASE e.syn: RESULTIS "Syntax error in filename *'%S*'*N" DEFAULT: RESULTIS "File *'%S*' - response %N (%S%X8)*N" $) selectoutput(journal) writef(mes, name, ecode, ecode < 0 -> "-", "", ABS ecode) stop(1001) $) AND advise(m, a, b, c) BE $( LET o = output() selectoutput(journal) writef(m, a, b, c) IF prsource_ THEN $( selectoutput(sysout) writef(m, a, b, c) $) selectoutput(o) $) AND host_code(ch) = ch AND ebcdic_code(ch) = astoeb%ch AND icl1900_code(ch) = VALOF $( LET c = icl1900_table!ch IF c < 0 THEN // No equivalent $( synreport(27, ch) c := #x10 // Map to space $) RESULTIS c $) AND report(mes, a, line, info, infopar) BE $( LET o = output() reportcount := reportcount + 1 selectoutput(sysout) newline() writef(mes, a) writef(" near line %N*N", line) info(infopar) IF reportcount GE reportmax THEN writes("Abort*N") selectoutput(o) IF reportcount GE reportmax THEN longjump(abort_p, abort_l) $) 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 base, num, minus = 10, 0, FALSE parptr := 0 parleng := str%0 TEST getch(str) = '-' THEN minus := TRUE OR parptr := parptr - 1 TEST getch(str) = '#' THEN SWITCHON getch(str) INTO $( CASE 'X' : base := 16 ENDCASE CASE 'B' : base := 2 ENDCASE DEFAULT : parptr := parptr - 1 CASE 'O' : base := 8 $) OR parptr := parptr - 1 $( LET n = getnum(str) IF n GE base BREAK num := num * base + n $) REPEAT RESULTIS minus -> -num, num $) AND getnum(str) = VALOF $( LET c = getch(str) RESULTIS ('0' LE c LE '9') -> c - '0', ('A' LE c LE 'F') -> c - 'A' + 10, 99 // 99 is greater than the maximum base $) . GET "BCPLV1_SYNHDR" LET pushget() BE $( LET savecharcode = charcode charcode := host_code nextsymb() charcode := savecharcode UNLESS symb = s.string DO synreport(5) IF noget_ RETURN IF getp GE gett THEN $( advise("GET file *'%S*' nested too deep*N", wordv) stop(1003) $) getv!getp := sourcestream getv!(getp + 1) := linecount getv!(getp + 2) := ch getp := getp + getitemsize linecount := 1 sourcestream := findinput(wordv) IF sourcestream = 0 THEN // File not found - try in library $( LET len = lib_name%0 AND v = VEC maxstrlength/bytesperword + 1 FOR i = 1 TO len DO v%i := lib_name%i FOR i = 1 TO wordv%0 DO v%(len + i) := wordv%i v%0 := len + wordv%0 sourcestream := findinput(v) $) IF sourcestream = 0 THEN ioerror(result2, wordv) selectinput(sourcestream) rch() $) AND popget() BE $( endread() getp := getp - getitemsize sourcestream := getv!getp selectinput(sourcestream) linecount := getv!(getp+1) ch := getv!(getp+2) $) AND smallnumber(n) = 0 < n <= 255 // End of file BCPLV1_MAINSRC