// File BCPLO_BCPLOSRC
 
// Version:  E1.7   (also alter MANIFESTs below)
 
// Program to convert a numeric OCODE file to symbolic format
 
// Copyright R.D. Eager UKC  MCMLXXXIII
 
 
// History:
//  E1.0   - Initial EMAS version.
//  E1.1   - Addition   of   'abs',   'endfor',  'blab',  'getbyte'  and
//           'putbyte' OCODEs.
//  E1.2   - Calls to 'getbyte' and 'putbyte' replaced by use of the '%'
//           operator.
//  E1.3   - Correction to code of 'outsym',  to  accept  'section'  and
//           'needs'.
//  E1.4   - Correction to code of 'outsym', to accept 'mc'.
//  E1.5   - 's.blab' OCODE renamed to 's.labx'.
//         - Addition of 's.labr' and 's.mark' OCODES.
//  E1.6   - Addition of the '?' parameter facility, to print out a list
//           of possible parameters for the user.
//  E1.7   - Addition of 's.segend' and 's.setgl' OCODEs.


SECTION "BCPLOCLIST"
 
 
MANIFEST $(   // Alter these if changes are made
version = 1   // Major version number
edit    = 7   // Edit number within major version
$)
 
 
/* Stop codes:-
 0 - Normal termination
1-999 - Corresponding Subsystem error
 1000 - INPUT parameter omitted
 1001 - 'L' not found where expected
 1002 - Illegal OCODE encountered
*/
 
 
GET "BCPLO_BCPLOHDR"
 
MANIFEST $( keymax = 2 $)   // Number of keywords
 
LET start() BE
$( LET keys = VEC keymax
   AND defaults = VEC keymax
   AND opt = VEC maxstrlength/bytesperword + 2*keymax
   AND pb = VEC (linemax - 1)*pagedepth - 1
 
   is, os := 0, 0
 
   keys!0  := keymax
   keys!1  := "INPUT"        ; defaults!1  := 0
   keys!2  := "OUTPUT"       ; defaults!2  := ".LP"
 
   IF param%0 = 1 & param%1 = '?' THEN
   $( 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)
   $)

   options := opt
   pagebuffer := pb
 
   paramdecode(keys, options)
 
   FOR i = 1 TO keymax DO
      IF options!i = 0 DO options!i := defaults!i
 
   IF options!0 < 0 THEN
   $( LET ec = -options!0

      fail(ssmessage(ec, ""), ec)
   $)
 
   IF options!1 = 0 THEN
      fail(" Mandatory parameter *'INPUT*' omitted*N", 1000)

   iname, oname := options!1, options!2

   is := findinput(iname)
   IF is < 0 THEN
   $( LET ec = -is

      fail(ssmessage(ec, iname), ec)
   $)
   selectinput(is)
 
   os := findoutput(oname)
   IF os < 0 THEN
   $( LET ec = -os

      fail(ssmessage(ec, oname), ec)
   $)

   writef("*NBCPL OCODE lister - version E%N.%N*N", version, edit)

   selectoutput(os)
 
   old_stop := stop

   clear_pagebuffer()
 
   terminator := '*S'   // Initialise
 
   $( LET dv = VEC 2
      AND tv = VEC 2
      AND heading = "Symbolic listing of OCODE file *'%S*' - on %S at %S"
      LET length = heading%0 + (options!1)%0 + 10
      LET pad = (linemax - length)/2
 
      FOR i = 1 TO 20 DO newline()
      FOR i = 1 TO pad DO wrch('*S')
      writef(heading, options!1, date(dv), tod(tv))
      writef("*T*TE%N.%N*N", version, edit)
      FOR i = 1 TO pad DO wrch('*S')
      FOR i = 1 TO length DO wrch('-')
      writes("*N*P")
   $)
 
   main()
 
   clearup(0)
$)
 
AND main() BE
$( LET code = ?
   AND l, n = ?, ?
 
   WHILE terminator = '*S' \/ terminator = '*N' DO
      terminator := rdch()
   IF terminator < 0 RETURN
 
   unrdch()
   code := readn()
 
   outsym(code)   // Illegal values detected by 'outsym'
 
   SWITCHON code INTO
   $( CASE s.res: CASE s.setgl:
         outn(readn())
 
      CASE s.ll: CASE s.lll: CASE s.sl: CASE s.jump: CASE s.jt:
      CASE s.jf: CASE s.lab: CASE s.iteml: CASE s.endfor: CASE s.labx:
      CASE s.labr:
         outl(readl())
         ENDCASE
 
      CASE s.fnap: CASE s.lp: CASE s.llp: CASE s.rtap: CASE s.sp: CASE s.stack:
      CASE s.rstack: CASE s.save: CASE s.endproc: CASE s.itemn: CASE s.ln:
      CASE s.lg: CASE s.llg: CASE s.sg: CASE s.mark:
         outn(readn())
 
      CASE s.true: CASE s.false: CASE s.rv: CASE s.mult: CASE s.div: CASE s.rem:
      CASE s.plus: CASE s.minus: CASE s.query: CASE s.neg: CASE s.eq: CASE s.ne:
      CASE s.ls: CASE s.gr: CASE s.le: CASE s.ge: CASE s.not: CASE s.lshift:
      CASE s.rshift: CASE s.logand: CASE s.logor: CASE s.eqv: CASE s.neqv: CASE s.goto:
      CASE s.finish: CASE s.stind: CASE s.store: CASE s.fnrn: CASE s.rtrn:
      CASE s.prcl: CASE s.abs: CASE s.getbyte: CASE s.putbyte:
      CASE s.segend:
         ENDCASE
 
      CASE s.rtcall: CASE s.fncall:
         outn(readn())
 
      CASE s.lstr: CASE s.mc: CASE s.section: CASE s.needs:
         n := readn()
         outn(n)
         FOR i = 1 TO n DO
            outn(readn())
         ENDCASE
 
      CASE s.datalab:
         outl(readl())
         FOR i = 1 TO readn() DO
            outn(readn())
         ENDCASE
 
      CASE s.global:
         n := readn()
         outn(n)
         FOR i = 1 TO n DO
         $( outn(readn())
            outl(readl())
         $)
         wrs("*N*N************************ End of segment *************
                **************N*N")
         ENDCASE
 
      CASE s.switchon:
         n := readn()
         outn(n); outl(readl())
         FOR i = 1 TO n DO
         $( outn(readn())
            outl(readl())
         $)
         ENDCASE
 
      CASE s.entry:
      $( LET n = readn()
         outn(n); outl(readl())
         FOR i = 1 TO n DO
            outn(readn())
         ENDCASE
      $)
 
      CASE s.slctap:CASE s.slctst:
         FOR i = 1 TO 3 DO
            outn(readn())
         ENDCASE
   $)
   wrc('*N')
$) REPEAT
 
AND outn(n) BE
$( wrc('*S')
   wrn(n)
$)
 
AND outl(n) BE
$( wrc('*S')
   wrc('L')
   wrn(n)
$)
 
AND readl() = VALOF
$( WHILE terminator = '*S' \/ terminator = '*N' DO
      terminator := rdch()
 
   UNLESS terminator = 'L' DO
   $( wrs("*N*NNo *'L*' where label expected*N")
      wrs("Next few values are:*N")
      FOR i = 1 TO 50 DO
      $( LET c = rdch()
         IF c < 0 BREAK
         wrc(c)
      $)
      wrc('*N')
      clearup(1001)
   $)
   RESULTIS readn()
$)
 
AND wrn(n) BE
$( LET t = VEC 10
   AND i, k = 0, n
 
   IF (n NE 0) & ((n << 1) = 0) THEN
   $( LET s = "-2147483648"
      FOR j = 1 TO s%0 DO
         wrc(s%j)
      RETURN
   $)
   IF n < 0 THEN k := -n
   $( t!i := k REM 10
      k := k / 10
      i := i + 1
   $) REPEATUNTIL k = 0
   IF n < 0 DO wrc('-')
   FOR j = i - 1 TO 0 BY -1 DO wrc(t!j + '0')
$)
 
AND wrs(s) BE
   FOR i = 1 TO s%0 DO wrc(s%i)
 
AND wrc(ch) BE
$( IF ch = '*N' THEN
   $( pageptr := pageptr + 1
      IF pageptr GE pagedepth - 1 THEN
      $( colptr := colptr + 1
         IF colptr GE maxcol THEN
         $( dump_pagebuffer(pagedepth - 1,FALSE)
            RETURN
         $)
         pageptr := 0
      $)
      chptr := colptr*colsize
      RETURN
   $)
   IF (chptr GE (colptr*colsize + colsize - 12)) & (ch = '*S') THEN
   $( wrc('*N')
      chptr := chptr + 9
   $)
   pagebuffer!(pageptr*(linemax - 1) + chptr) := ch
   chptr := chptr + 1
$)
 
AND outsym(sym) BE
$( LET mes = VALOF SWITCHON sym INTO
   $( CASE s.true       :  RESULTIS "TRUE     "
      CASE s.false      :  RESULTIS "FALSE    "
      CASE s.rv         :  RESULTIS "RV       "
      CASE s.mult       :  RESULTIS "MULT     "
      CASE s.div        :  RESULTIS "DIV      "
      CASE s.rem        :  RESULTIS "REM      "
      CASE s.plus       :  RESULTIS "PLUS     "
      CASE s.minus      :  RESULTIS "MINUS    "
      CASE s.query      :  RESULTIS "QUERY    "
      CASE s.neg        :  RESULTIS "NEG      "
      CASE s.abs        :  RESULTIS "ABS      "
      CASE s.eq         :  RESULTIS "EQ       "
      CASE s.ne         :  RESULTIS "NE       "
      CASE s.ls         :  RESULTIS "LS       "
      CASE s.gr         :  RESULTIS "GR       "
      CASE s.le         :  RESULTIS "LE       "
      CASE s.ge         :  RESULTIS "GE       "
      CASE s.not        :  RESULTIS "NOT      "
      CASE s.lshift     :  RESULTIS "LSHIFT   "
      CASE s.rshift     :  RESULTIS "RSHIFT   "
      CASE s.logand     :  RESULTIS "LOGAND   "
      CASE s.logor      :  RESULTIS "LOGOR    "
      CASE s.eqv        :  RESULTIS "EQV      "
      CASE s.neqv       :  RESULTIS "NEQV     "
      CASE s.goto       :  RESULTIS "GOTO     "
      CASE s.finish     :  RESULTIS "FINISH   "
      CASE s.stind      :  RESULTIS "STIND    "
      CASE s.store      :  RESULTIS "STORE    "
      CASE s.fnrn       :  RESULTIS "FNRN     "
      CASE s.rtrn       :  RESULTIS "RTRN     "
      CASE s.prcl       :  RESULTIS "PRCL     "
      CASE s.rtcall     :  RESULTIS "RTCALL   "
      CASE s.fncall     :  RESULTIS "FNCALL   "
      CASE s.fnap       :  RESULTIS "FNAP     "
      CASE s.lp         :  RESULTIS "LP       "
      CASE s.llp        :  RESULTIS "LLP      "
      CASE s.rtap       :  RESULTIS "RTAP     "
      CASE s.sp         :  RESULTIS "SP       "
      CASE s.stack      :  RESULTIS "STACK    "
      CASE s.mark       :  RESULTIS "MARK     "
      CASE s.rstack     :  RESULTIS "RSTACK   "
      CASE s.save       :  RESULTIS "SAVE     "
      CASE s.ll         :  RESULTIS "LL       "
      CASE s.lll        :  RESULTIS "LLL      "
      CASE s.sl         :  RESULTIS "SL       "
      CASE s.jump       :  RESULTIS "JUMP     "
      CASE s.jt         :  RESULTIS "JT       "
      CASE s.jf         :  RESULTIS "JF       "
      CASE s.endfor     :  RESULTIS "ENDFOR   "
      CASE s.labr       :  RESULTIS "LABR     "
      CASE s.labx       :  RESULTIS "LABX     "
      CASE s.lab        :  RESULTIS "LAB      "
      CASE s.res        :  RESULTIS "RES      "
      CASE s.datalab    :  RESULTIS "DATALAB  "
      CASE s.iteml      :  RESULTIS "ITEML    "
      CASE s.lg         :  RESULTIS "LG       "
      CASE s.llg        :  RESULTIS "LLG      "
      CASE s.sg         :  RESULTIS "SG       "
      CASE s.ln         :  RESULTIS "LN       "
      CASE s.itemn      :  RESULTIS "ITEMN    "
      CASE s.endproc    :  RESULTIS "ENDPROC  "
      CASE s.lstr       :  RESULTIS "LSTR     "
      CASE s.mc         :  RESULTIS "MC       "
      CASE s.global     :  RESULTIS "GLOBAL   "
      CASE s.switchon   :  RESULTIS "SWITCHON "
      CASE s.entry      :  RESULTIS "ENTRY    "
      CASE s.slctap     :  RESULTIS "SLCTAP   "
      CASE s.slctst     :  RESULTIS "SLCTST   "
      CASE s.getbyte    :  RESULTIS "GETBYTE  "
      CASE s.putbyte    :  RESULTIS "PUTBYTE  "
      CASE s.section    :  RESULTIS "SECTION  "
      CASE s.needs      :  RESULTIS "NEEDS    "
      CASE s.segend     :  RESULTIS "SEGEND   "
      CASE s.setgl      :  RESULTIS "SETGL    "
 
      DEFAULT  :  wrs("*N*NIllegal OCODE - value = ")
                  wrn(sym); wrc('*N')
                  wrs("Next few values are:*N")
                  FOR i = 1 TO 50 DO
                  $( LET c = rdch()
                     IF c < 0 BREAK
                     wrc(c)
                  $)
                  wrc('*N')
                  clearup(1002)
   $)
   wrs(mes)
$)
 
AND clearup(n) BE
$( selectinput(is); endread()
   IF n = 1001 \/ n = 1002 \/ n = 0 THEN
      dump_pagebuffer(colptr = 0 -> pageptr , pagedepth, TRUE)
   selectoutput(os); endwrite()
 
   stop := old_stop
   stop(n)
$)
 
AND fail(mes, ec) BE
$( writef("*NBCPLOCLIST fails -%S", mes)
   stop(ec)
$)

AND clear_pagebuffer() BE
$( FOR i = 0 TO (linemax - 1)*pagedepth - 1 DO
      pagebuffer!i := '*S'
 
   pageptr, colptr, chptr := 0, 0, 0
$)
 
AND dump_pagebuffer(max, last) BE
$( FOR i = 0 TO (linemax - 1)*(max - 1) BY (linemax - 1) DO
   $( FOR j = 0 TO linemax - 2 DO
         wrch(pagebuffer!(i + j))
      newline()
   $)
   UNLESS last DO newpage()
   clear_pagebuffer()
$)
 
 .
 
// Parameter decoder
 
GET "BCPLO_BCPLOHDR"
 
STATIC $( parptr = ?; parleng = ? $)
 
LET 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
$)
 
// End of file BCPLO_BCPLOSRC