// File BCPLCASE_BCPLCASESRC

// Version: E3.1   (also alter MANIFESTs below)

// BCPL source file case conversion program

// R.D. Eager   University of Kent   MCMLXXXV

// History:
//  E1.0   - Initial version
//  E1.1   - Correction  to 'rdstrch', to improve recovery after missing
//           quotes.
//  E2.0   - Modification  so  that  'ALL'  option translates lower case
//           character constants to hexadecimal numbers.
//  E3.0   - Addition of ESCAPECASE parameter.
//  E3.1   - Correction to handle OF keyword.

SECTION "BCPLCASE"

MANIFEST $(   // Alter these if changes are made
version = 3   // Major version number
edit    = 1   // Edit number within major version
$)

/* Stop codes:-
    0 - Success
1-999 - Corresponding Subsystem error
 1000 - Workspace exhausted
*/

GET "BCPLCASE_BCPLCASEHDR"

MANIFEST $(   // Parameter decoder error codes
par.ok    = 0               // no errors
par.err   =  -320           // format error in parameter string
par.amb   =  -321           // ambiguous keyword
par.unk   =  -322           // unknown keyword
par.xs    =  -323           // too many parameters
par.dup   =  -324           // duplicated parameter
par.mis   =  -325           // missing keyword
$)

STATIC $( parptr = ?; parleng = ? $)

MANIFEST $( keymax = 7 $)

LET start() BE
$( LET keys = VEC keymax
   AND defaults = VEC keymax
   AND options = VEC maxstrlength/bytesperword + 2*keymax
   AND size = ?
   AND opt = ?

   keys!0 := keymax
   keys!1 := "INPUT";        defaults!1 := 0
   keys!2 := "OUTPUT";       defaults!2 := 0
   keys!3 := "OPTION";       defaults!3 := "LOWER"
   keys!4 := "NAMEFILE";     defaults!4 := 0
   keys!5 := "WORKSIZE";     defaults!5 := "10000"
   keys!6 := "KEYCASE";      defaults!6 := "UPPER"
   keys!7 := "ESCAPECASE";   defaults!7 := "LEAVE"

   IF param%0 = 1 & param%1 = '?' THEN  // give synopsis
   $( writes("Parameters are:*N")
      FOR i = 1 TO keys!0 DO
      $( writes(keys!i)
         IF defaults!i NE 0 & (defaults!i)%0 NE 0 THEN writef("=%S", defaults!i)
         IF i NE keys!0 THEN wrch(',')
      $)
      newline()

      stop(0)
   $)
   paramdecode(keys, options)

   IF options!0 < 0 THEN fail(ABS options!0, 0)

   FOR i = 1 TO keymax DO
      IF options!i = 0 THEN options!i := defaults!i

   IF options!1 = 0 \/ options!2 = 0 THEN fail(263,"")
                                        // Wrong number of parameters

   instream := findio(options!1, findinput)
   outstream := findio(options!2, findoutput)

   opt := options!3
   upper_, lower_, wch := FALSE, FALSE, wrch
   TEST matchstrings(opt, "UPPER") THEN upper_ := TRUE
   OR TEST matchstrings(opt, "LOWER") THEN lower_ := TRUE
   OR TEST matchstrings(opt,"ALL") THEN upper_, wch := TRUE, allupperwrch
   OR fail(326, keys!3)                 // Invalid value for parameter

   dictname := options!4

   size := strtonum(options!5)
   UNLESS 2000 LE size LE 30000 DO fail(326, keys!5)
                                        // Invalid value for parameter

   opt := options!6
   TEST matchstrings(opt, "UPPER") THEN lowerkeys_ := FALSE
   OR TEST matchstrings(opt, "LOWER") THEN lowerkeys_ := TRUE
   OR fail(326, keys!6)                 // Invalid value for parameter

   opt := options!7
   TEST matchstrings(opt, "UPPER") THEN escape_case := ec.upper
   OR TEST matchstrings(opt, "LOWER") THEN escape_case := ec.lower
   OR TEST matchstrings(opt, "LEAVE") THEN escape_case := ec.leave
   OR fail(326, keys!7)                 // Invalid value for parameter

   writef("BCPL case conversion program - version E%N.%N*N", version, edit)

   aptovec(main, size)

   stop(0)
$)

AND findio(file, r) BE
$( LET strp = r(file)

   IF strp < 0 THEN fail(strp, file)
$)

AND fail(n, info) BE
$( n := ABS n
   selectoutput(journal)

   writef("*NBCPLCASE fails -%S", ssmessage(n, info))

   stop(n)
$)

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
   param := str
   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
         DEFAULT   : parptr := parptr - 1
         CASE 'O'  : base := 8
      $)
   $)
   OR parptr := parptr - 1

   $( LET n = getnum(str)
      IF n >= 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   
$)

 .

// System-independent code

GET "BCPLCASE_BCPLCASEHDR"

LET main(t, ts) BE
$( LET cv = VEC maxstrlength
   AND wv = VEC maxstrlength/bytesperword

   charv, wordv := cv, wv

   treevec, treep := t, t + ts
   linecount := 0
   nametree := 0

   declsyswords()

   UNLESS dictname = 0 DO
   $( LET dictstream = findio(dictname, findinput)

      selectinput(dictstream)
      echo_ := FALSE
      settag_ := TRUE
      rch(FALSE)
      readprog()
      endread()
   $)

   echo_ := TRUE
   settag_ := FALSE
   selectinput(instream)
   selectoutput(outstream)
   rch(FALSE)
   readprog()
   endread()
$)

AND readprog() BE
$( SWITCHON ch INTO
   $( CASE '*P':
      CASE '*N':   linecount := linecount + 1 
      CASE '*T':
      CASE '*S':   rch(echo_) REPEATWHILE ch = '*S'
                   LOOP

      CASE '0':CASE '1':CASE '2':CASE '3':CASE '4':
      CASE '5':CASE '6':CASE '7':CASE '8':CASE '9':
                   readnum(10)
                   LOOP

      CASE 'a':CASE 'b':CASE 'c':CASE 'd':CASE 'e':
      CASE 'f':CASE 'g':CASE 'h':CASE 'i':CASE 'j':
      CASE 'k':CASE 'l':CASE 'm':CASE 'n':CASE 'o':
      CASE 'p':CASE 'q':CASE 'r':CASE 's':CASE 't':
      CASE 'u':CASE 'v':CASE 'w':CASE 'x':CASE 'y':
      CASE 'z':
      CASE 'A':CASE 'B':CASE 'C':CASE 'D':CASE 'E':
      CASE 'F':CASE 'G':CASE 'H':CASE 'I':CASE 'J':
      CASE 'K':CASE 'L':CASE 'M':CASE 'N':CASE 'O':
      CASE 'P':CASE 'Q':CASE 'R':CASE 'S':CASE 'T':
      CASE 'U':CASE 'V':CASE 'W':CASE 'X':CASE 'Y':
      CASE 'Z':
      CASE '{':
      CASE '}':
                   rdtag()
                   writetag()
                   LOOP

      CASE '$':    rch(echo_)
                   TEST ch = '(' \/ ch = ')' THEN 
                   $( rdtag()
                      writetag()
                   $)
                   ELSE rch(echo_)
                   LOOP

      CASE '/':    rch(echo_)
                   IF ch = '\' THEN
                   $( rch(echo_)
                      LOOP
                   $)
                   IF ch = '**' THEN
                   $( readcomment('/')
                      LOOP 
                   $)
                   UNLESS ch = '/' LOOP

      comment:     rch(echo_) REPEATUNTIL iscc(ch) \/ ch = endstreamch
                   LOOP

      CASE '|':    rch(echo_)
                   IF ch = '|' GOTO comment
                   UNLESS ch = '**' LOOP
                   readcomment('|')
                   LOOP

      CASE '#':    $( LET radix = 8

                      rch(echo_)
                      TEST ch = 'B' THEN
                      $( radix := 2
                         rch(echo_)
                      $)
                      ELSE TEST ch = 'O' THEN
                         rch(echo_)
                      ELSE IF ch = 'X' THEN
                      $( radix := 16
                         rch(echo_)
                      $)
                      readnum(radix)
                      LOOP
                   $)

      CASE '*"':   rch(echo_)
                   FOR i = 1 TO maxstrlength DO
                   $( IF ch = '*"' BREAK
                      rdstrch(TRUE)
                   $)
                   rch(echo_)
                   LOOP

      CASE '*'':   rch(echo_)
                   rdstrch(FALSE)            // drop through

      DEFAULT:     rch(echo_)
                   LOOP

      CASE endstreamch:
                   RETURN
   $)
$) REPEAT

AND iscc(ch) = (ch = '*N') \/ (ch = '*P') \/ (ch = '*C')

AND readcomment(term) BE
$( rch(echo_)
   $( IF iscc(ch) THEN linecount := linecount + 1
      IF ch = '**' THEN
      $( rch(echo_)
         UNLESS ch = term LOOP
         rch(echo_)
         RETURN
      $)
      IF ch = endstreamch THEN error("End of file encountered in comment")
      rch(echo_)
   $) REPEAT
$)

AND lookupword(makenew_) = VALOF
$( LET p = @nametree

   wordnode := !p

   UNTIL wordnode = 0 DO
   $( LET cmp = cmpstr(wordv, wordnode+2)

      IF cmp = 0 RESULTIS wordnode+2
      p := wordnode + (cmp < 0 -> 0, 1)
      wordnode := !p
   $)

   IF makenew_ THEN
   $( wordnode := newvec(wordsize+2)
      wordnode!0, wordnode!1 := 0, 0
      FOR i = 0 TO wordsize DO wordnode!(i+2) := wordv!i
      !p := wordnode
   $)
   RESULTIS 0
$)

AND cmpstr(s1, s2) = VALOF
$( LET len1, len2 = s1%0, s2%0

   FOR i = 1 TO len1 DO
   $( LET ch1, ch2 = s1%i, s2%i

      IF i > len2 RESULTIS 1
      IF 'a' LE ch1 LE 'z' DO ch1 := ch1 - 'a' + 'A'
      IF 'a' LE ch2 LE 'z' DO ch2 := ch2 - 'a' + 'A'
      IF ch1 > ch2 RESULTIS 1
      IF ch1 < ch2 RESULTIS -1
   $)
   IF len1 < len2 RESULTIS -1
   RESULTIS 0
$)

AND declsyswords() BE
$( d("ABS/AND/*
     *BE/BREAK/BY/*
     *CASE/*
     *DO/DEFAULT/*
     *EXTERNAL/EQ/EQV/ELSE/ENDCASE/*
     *FALSE/FOR/FINISH/*
     *GOTO/GE/GR/GLOBAL/GET/*
     *IF/INTO/*
     *LET/LV/LE/LS/LOGOR/LOGAND/LOOP/LSHIFT//")

   d("MANIFEST/*
     *NEEDS/NE/NOT/NEQV/*
     *OF/OR/*
     *RESULTIS/RETURN/REM/RSHIFT/RV/*
     *REPEAT/REPEATWHILE/REPEATUNTIL/*
     *SLCT/SECTION/SWITCHON/STATIC/*
     *TO/TEST/TRUE/THEN/TABLE/*
     *UNTIL/UNLESS/*
     *VEC/VALOF/*
     *WHILE//")

   lowerkeys_ := FALSE
$)

AND d(words) BE
$( LET i, length = 1, 0

   $( LET ch = words%i

      TEST ch = '/' THEN
      $( IF length = 0 RETURN
         charv!0 := length
         IF lowerkeys_ THEN
         $( FOR i = 1 TO length DO
               IF 'A' LE charv!i LE 'Z' THEN
                  charv!i := charv!i - 'A' + 'a'
         $)
         wordsize := packstring(charv, wordv)
         lookupword(TRUE)
 
         length := 0
      $)
      ELSE
      $( length := length + 1
         charv!length := ch
      $)
      i := i + 1
   $) REPEAT
$)

AND rch(echo_) BE
$( IF echo_ THEN wch(ch)
   ch := rdch()
$)

AND rdtag() BE
$( LET n = 1

   charv!1 := ch

   $( rch(FALSE)
      UNLESS 'A' LE ch LE 'Z' \/
             'a' LE ch LE 'z' \/
             '0' LE ch LE '9' \/
              ch = '_' \/
              ch = '.' BREAK
      n := n + 1
      charv!n := ch
   $) REPEAT

   charv!0 := n
   wordsize := packstring(charv, wordv)
$)

AND writetag() BE
$( LET mode = lookupword(settag_)

   TEST mode = 0 THEN
   $( IF upper_ THEN
      $( FOR i = 1 TO charv!0 DO
         $( LET ch = charv!i

            IF 'a' LE ch LE 'z' THEN charv!i := ch - 'a' + 'A'
         $)
         packstring(charv, wordv)
      $)
      IF lower_ THEN FOR i = 1 TO charv!0 DO
      $( LET ch = charv!i

         IF 'A' LE ch LE 'Z' THEN charv!i := ch - 'A' + 'a'
      $)
      IF echo_ THEN FOR i = 1 TO charv!0 DO wch(charv!i)
   $)
   ELSE IF echo_ DO writes(mode)
$)

AND allupperwrch(ch) BE
$( IF 'a' LE ch LE 'z' THEN ch := ch - 'a' + 'A'
   wrch(ch)
$)

AND readnum(radix) BE
   UNTIL value(ch) GE radix DO rch(echo_)

AND value(ch) = '0' LE ch LE '9' -> ch - '0',
                'a' LE ch LE 'f' -> ch - 'a' + 10,
                'A' LE ch LE 'F' -> ch - 'A' + 10,
                100

AND rdstrch(trans_) = VALOF
$( LET k = ch

   TEST (#x00 LE ch LE #x5f) \/ trans_ \/ NOT upper_ THEN
      rch(echo_)
   OR
   $( writef("**X%X2", ch)
      rch(FALSE)
   $)

   IF k = '*N' THEN
   $( error("Incorrect use of newline in string")
      k := '*"'
      ch := k
   $)

   IF k = '**' THEN
   $( IF ch = '*N' \/ ch = '*S' \/ ch = '*T' THEN
      $( $( IF ch = '*N' DO linecount := linecount + 1
            rch(echo_)
         $) REPEATWHILE ch = '*N' \/ ch = '*S' \/ ch = '*T'
         rch(echo_)
         RESULTIS rdstrch()
      $)

      SWITCHON escape_case INTO
      $( DEFAULT:
         CASE ec.leave:
            rch(echo_)
            ENDCASE

         CASE ec.upper:
            allupperwrch(ch)
            rch(FALSE)
            ENDCASE

         CASE ec.lower:
            IF 'A' LE ch LE 'Z' THEN ch := ch - 'A' + 'a'
            wch(ch)
            rch(FALSE)
            ENDCASE
      $)
   $)
   RESULTIS k
$)

AND newvec(n) = VALOF
$( treep := treep - n - 1
   IF treep LE treevec THEN
   $( error("Workspace exhausted")
      stop(1000)
   $)
   RESULTIS treep
$)

AND error(mess) BE
$( LET oldout = output()

   selectoutput(journal)
   writef("Error in or near line %N - %S*N", linecount, mess)
   selectoutput(oldout)
$)

// End of file BCPLCASE_BCPLCASESRC