!Graham Toal - last working version of SKIMPA 10/02/81  11.57

!!%external %string (127) %fn %spec cliparam
external integer fn spec outstream
external routine spec resetinput
external routine spec closeinput
external routine spec closeoutput
external routine spec openinput(integer stream, string (255) file)
external routine spec openoutput(integer stream, string (255) file)
const string (1) snl = "
"

external integer spec faults

routine do(string (127) text)
!?%EXTERNALROUTINESPEC M6809
  !! For invoking assembler after successful compilation...
  ! system(text)
  printstring(text); newline
end

external integer array a(1 : 500)

! initialisation for i/o routines
external byte integer array named(1 : 1024) = c
  10, 'R', 'E', 'A', 'D', 'S', 'Y', 'M', 'B', 'O', 'L',
  10, 'N', 'E', 'X', 'T', 'S', 'Y', 'M', 'B', 'O', 'L',
  10, 'S', 'K', 'I', 'P', 'S', 'Y', 'M', 'B', 'O', 'L',
  11, 'P', 'R', 'I', 'N', 'T', 'S', 'Y', 'M', 'B', 'O', 'L',
   5, 'S', 'P', 'A', 'C', 'E',
   6, 'S', 'P', 'A', 'C', 'E', 'S',
   7, 'N', 'E', 'W', 'L', 'I', 'N', 'E',
   8, 'N', 'E', 'W', 'L', 'I', 'N', 'E', 'S',
   7, 'N', 'E', 'W', 'P', 'A', 'G', 'E',
   4, 'R', 'E', 'A', 'D',
   5, 'W', 'R', 'I', 'T', 'E',
   0(930)

external integer array namedlink(0 : 255) = 0, 76, 0(12), 89, 0(54), 84,
 0(118), 52, 0(11), 1, 12, 23, 34, 0(4), 67, 0(23), 46, 0(5), 59, 0(17)

external integer array taglink(0 : 255) = 0, 13, 0(12), 16, 0(54), 14,
 0(118), 8, 0(11), 1, 3, 4, 5, 0(4), 11, 0(23), 7, 0(5), 10, 0(17)

external integer array tag(1 : 512) = 16_40100001, 16_11010002, 16_41000002,
 16_40000003, 16_40100004, 16_01010002, 16_40000005, 16_40100006, 16_01010002,
 16_40000007, 16_40100008, 16_01010002, 16_40000009, 16_4010000A, 16_11010002,
 16_4020000B, 16_01010002, 16_01010003, 0(494)

external integer array link(1 : 512) = 2, 0, 0, 0, 6, 0, 0, 9, 0, 0, 12, 0,
 0, 15, 0, 17, 18, 0, 0(494)

external integer namedp = 95
external integer tagasl = 19
external integer expropt = 0
external integer condopt = 0
external integer tagsopt = 0
external integer traceopt = 0
external integer checkopt = 0
external integer infoopt = 0
!-----------------------------------------------------------------------
external routine spec statement(integer statementp)
external string (255) fn spec strint(integer n, p)
external routine spec fault(string (63) mess)
external routine spec dump(string (7) opn, reg, base, integer disp)
external string (255) fn spec name(integer ident)
!-----------------------------------------------------------------------
external routine skimp(string (255) cliparam)
   string (63) s, param
   routine spec readps
   routine spec readstatement
   routine spec rpsym(integer name l)
   integer fn spec findk(string (*) name k)
   integer fn spec compare(integer p)
   record format kdf(byte integer l, n, a, b)
   record (kdf) array kd(1 : 255)
   string (15) array pn(256 : 319)
   integer array pp(256 : 319)
   integer array ps(1 : 512)
   integer array t, tt(1 : 256)
   integer tp, ap, ttp, i, j, psflag
   string (63) file, options, option, as
   own integer lexopt = 0
   own integer analopt = 0
   own integer codeopt = 1
   own integer listopt = 1
   own integer assmopt = 0
   own integer shift = 32
   own string (63) assopt = ""
   s = cliparam
   if s -> ("/") . options then start
      unless options -> options . (" ") . file then file = ""
      cycle 
         unless options -> option . ("/") . options then c
           option = options and options = ""
         if option -> ("NO") . option then i = 0 else i = 1
         if option = "LEX" then lexopt = i and continue c
         else if option = "ANAL" then analopt = i and continue c
         else if option = "EXPR" then expropt = i and continue c
         else if option = "COND" then condopt = i and continue c
         else if option = "TAGS" then tagsopt = i and continue else start
            if option -> ("OPT=") . assopt then assmopt = i and continue c
            else if option = "TRACE" then traceopt = i and continue c
            else if option = "CHECK" then checkopt = i and continue c
            else if option = "LIST" then listopt = i and continue c
            else if option = "CODE" then codeopt = i and continue c
            else if option = "INFO" then infoopt = i and continue
         finish
         printstring(option . " OPTION ?
")
         stop
      repeat until options = ""
   finish else file = s
   begin
   on event 9, 13 start
      closeinput
      closeoutput
      printstring("FILE NOT FOUND - OR SOME OTHER ERROR!" . snl) ;! %if event_event = 9
      stop if file = "" or codeopt = listopt = 0 or faults > 0
      param = ""
      if codeopt = 0 then param = param . "/NOOBJECT"
      if listopt = 1 then param = param . "/LIST"
      do("ass68 " . file . " " . param)
      stop
   finish
   readps
   if file = "" then openoutput(1, "/dev/stdout") else openoutput(1, file . ".asm")
   selectoutput(1)
   printstring("          NAM " . file . snl) if file # ""
   printstring("          OPT " . assopt . snl) if assmopt = 1
   printstring("
*                File: " . file . "
*                Options: ")
   if lexopt = 1 then printstring("/LEX ")
   if analopt = 1 then printstring("/ANAL ")
   if expropt = 1 then printstring("/EXPR ")
   if condopt = 1 then printstring("/COND ")
   if tagsopt = 1 then printstring("/TAGS ")
   if infoopt = 1 then printstring("/INFO ")
   if traceopt = 1 then printstring("/TRACE ")
   if checkopt = 1 then printstring("/CHECK ")
   if listopt = 0 then printstring("/NOLIST ")
   if codeopt = 0 then printstring("/NOCODE ")
   if assmopt = 1 then printstring("/OPT=" . assopt)
   newline
   if psflag # 0 then fault("PHRASE STRUCTURE FAULTY") and stop
   if file = "" then openinput(1, "/dev/stdout") else openinput(1, file . ".imp")
   selectinput(1)
   ! set up tags available space list
   for i = tagasl, 1, 511 cycle
      link(i) = i + 1
   repeat
   !  PRINTSTRING("          NAM ".FILE.SNL) %IF FILE#""
   !  PRINTSTRING("          OPT ".ASSOPT.SNL) %IF ASSMOPT=1
   cycle 
      ! for each statement
      readstatement
      ttp = tp - 1
      tp = 1
      ap = 1
      if compare(259) = 0 or tp # ttp then fault("SYNTAX ?") else start
         !**FRIG** above for printtext...
         if analopt = 1 then start
            newline
            j = 0
            for i = 1, 1, ap - 1 cycle
               ! print analysis record
               if a(i) < 0 then as = "  (" . strint(i, 1) . "/" . pn(a(i) << 1 >> 17) . ")" c
                 and printstring(as) and j = j + length(as) and a(i) = a(i) & 16_FFFF
               write(a(i), 4)
               j = j + 5
               if j > 60 then newline and j = 0
            repeat
            newlines(2)
         finish else start
            for i = 1, 1, ap - 1 cycle
               ! remove phrase numbers
               if a(i) < 0 then a(i) = a(i) & 16_FFFF
            repeat
         finish
         statement(1)
         ! generate code for statement
      finish
   repeat
   end
   !-----------------------------------------------------------------------
   routine readps
      ! read phrase structure from file 'SKIMPPS' and reduce it
      string (31) array ka(1 : 128)
      integer array kna(1 : 128)
      string (31) k
      integer kap, kdasl, kn, i, l, psp, pnp, alt
      integer name np
      routine spec insert(string (15) k)
      routine spec extract(integer i, string (15) k)
      routine spec assign(integer i)
      integer fn spec newkd
      routine spec returnkd(integer i)
      routine spec returnlist(integer i)
      integer fn spec phrase
      routine spec literal
      routine spec keyword
      openinput(2, "skimpps.new")
      selectinput(2)
      if infoopt = 1 then openoutput(2, "skimpps.lis") else openoutput(2, "/dev/null")
      selectoutput(2)
      printstring("

PHRASE STRUCTURE

")
      ! scan file to build keyword dictionary
      kap = 1
      cycle 
         rpsym(l)
         if l = '$' then exit
         if l = '"' then start
            k = ""
            cycle 
               rpsym(l)
               if l = '"' then exit
               if 'A' <= l <= 'Z' then k = k . tostring(l)
            repeat
            ka(kap) = k
            kap = kap + 1
         finish
      repeat
      for i = 1, 1, 26 cycle
         kd(i) = 0
      repeat
      for i = 27, 1, 254 cycle
         kd(i)_b = i + 1
      repeat
      kdasl = 27
      i = 1
      insert(ka(i)) and i = i + 1 until i = kap
      kn = 128
      for i = 1, 1, 26 cycle
         if kd(i)_l # 0 then assign(i)
      repeat
      kap = 1
      for i = 1, 1, 26 cycle
         if kd(i)_l # 0 then extract(i, "")
      repeat
      printstring("

KEYWORDS

")
      for i = 1, 1, kap - 1 cycle
         printstring(strint(kna(i), 3) . "  " . ka(i) . "
")
      repeat
      ! reread file and reduce phrase structure
      resetinput
      pn(256) = "NAME"
      pp(256) = 0
      pn(257) = "CONST"
      pp(257) = 0
      pn(258) = "STRING"
      pp(258) = 0
      pnp = 259
      psp = 1
      cycle 
         ! for each phrase definition
         readsymbol(l)
         if l = '$' then exit
         if l = '<' then start
            ! start of phrase definition
            pp(phrase) = psp
            cycle 
               ! for each alternative
               alt = psp
               np == ps(psp + 1)
               np = 0
               ! number of phrases
               psp = psp + 2
               cycle 
                  ! for each item
                  readsymbol(l)
                  if l = '<' then ps(psp) = phrase and psp = psp + 1 and np = np + 1
                  if l = '''' then literal
                  if l = '"' then keyword
                  if l = ',' or l = ';' then exit
               repeat
               ps(alt) = psp
               if l = ';' then exit
            repeat
            ps(psp) = 0
            psp = psp + 1
         finish
      repeat
      psflag = 0
      for i = 259, 1, pnp - 1 cycle
         if pp(i) = 0 then fault("<" . pn(i) . "> NOT DEFINED") and psflag = 1
      repeat
      printstring("

PHRASES

")
      for i = 256, 1, pnp - 1 cycle
         printstring(strint(i, 3) . strint(pp(i), 6) . "   " . pn(i) . "
")
      repeat
      printstring("

REDUCED PHRASE STRUCTURE

")
      for i = 1, 1, psp - 1 cycle
         if (i - 1) & 15 = 0 then printstring("
" . strint(i, 3) . "   ")
         write(ps(i), 3)
      repeat
      newlines(2)
      return
      !-----------------------------------------------------------------------
      routine insert(string (15) k)
         ! search for and insert keyword into dictionary
         integer i, j, l
         l = charno(k, 1)
         k -> (tostring(l)) . k
         i = l - 'A' + 1
         if kd(i)_l # 0 then start
search: 
            if k = "" then start
               if kd(i)_a # 0 then extract(kd(i)_a, "") c
               and returnlist(kd(i)_a) and kd(i)_a = 0
               return
            finish
            if kd(i)_a = 0 then insert(k) and return
            l = charno(k, 1)
            k -> (tostring(l)) . k
            i = kd(i)_a
            cycle 
               if kd(i)_l = l then -> search
               if kd(i)_b = 0 then exit
               i = kd(i)_b
            repeat
            j = i
            i = newkd
            kd(j)_b = i
         finish
         ! insert remainder of letters
         cycle 
            kd(i)_l = l
            if k = "" then return
            l = charno(k, 1)
            k -> (tostring(l)) . k
            j = i
            i = newkd
            kd(j)_a = i
         repeat
      end
      !-----------------------------------------------------------------------
      routine extract(integer i, string (15) k)
         string (15) kk
         if i = 0 then return
         kk = k . tostring(kd(i)_l)
         if kd(i)_a = 0 then ka(kap) = kk and kna(kap) = kd(i)_n c
           and kap = kap + 1 else extract(kd(i)_a, kk)
         extract(kd(i)_b, k)
      end
      !-----------------------------------------------------------------------
      routine assign(integer i)
         if i = 0 then return
         if kd(i)_a = 0 then kd(i)_n = kn and kn = kn + 1 else assign(kd(i)_a)
         assign(kd(i)_b)
      end
      !-----------------------------------------------------------------------
      integer fn newkd
         integer i
         if kdasl = 0 then printstring("KD ASL EMPTY") and stop
         i = kdasl
         kdasl = kd(i)_b
         kd(i) = 0
         result = i
      end
      !-----------------------------------------------------------------------
      routine returnkd(integer i)
         kd(i)_b = kdasl
         kdasl = i
      end
      !-----------------------------------------------------------------------
      routine returnlist(integer i)
         if i = 0 then return
         returnlist(kd(i)_a)
         returnlist(kd(i)_b)
         returnkd(i)
      end
      !-----------------------------------------------------------------------
      integer fn phrase
         string (15) p
         integer i, l
         p = ""
         cycle 
            readsymbol(l)
            if l = '>' then exit else p = p . tostring(l)
         repeat
         for i = 256, 1, pnp - 1 cycle
            if pn(i) = p then result = i
         repeat
         pn(pnp) = p
         pp(pnp) = 0
         pnp = pnp + 1
         result = pnp - 1
      end
      !-----------------------------------------------------------------------
      routine literal
         integer l
         cycle 
            readsymbol(l)
            if l = '''' then return else ps(psp) = l and psp = psp + 1
         repeat
      end
      !-----------------------------------------------------------------------
      routine keyword
         string (31) k
         integer l
         k = ""
         cycle 
            readsymbol(l)
            if l = '"' then exit
            if 'A' <= l <= 'Z' then k = k . tostring(l)
         repeat
         ps(psp) = findk(k) and psp = psp + 1 until k = ""
      end
   end
   !-----------------------------------------------------------------------
   routine readstatement
      routine spec store(integer l)
      routine spec keyword
      routine spec name
      routine spec const
      routine spec stringconst
      integer i, l, ksh, ttp, ttpp
      ! line reconstruct phase
      newlines(2)
      ttp = 1
      ksh = 0
      cycle 
         ! for each character
         rpsym(l)
         if l = '%' then ksh = 128 else start
            unless 'A' <= l <= 'Z' then ksh = 0
            if l # ' ' then start
               ! discard spaces
               if l = '!' and ttp = 1 then start
                  rpsym(l) until l = ';' or l = nl
                  ! discard comments
               finish else start
                  store(l)
                  if l = '"' then start
                     shift = 0
                     rpsym(l) and store(l) until l = '"'
                     shift = 32
                  finish else start
                     if l = '''' then start
                        shift = 0
                        rpsym(l) and store(l) until l = ''''
                        shift = 32
                     finish else start
                        if l = ';' or l = nl then start
                           if ttp = 2 then ttp = 1 else start
                              if l = ';' then newline and exit
                              if tt(ttp - 2) = 'C' + 128 then ttp = ttp - 2 else exit
                           finish
                        finish
                     finish
                  finish
               finish
            finish
         finish
      repeat
      ! lexical phase
      tp = 1
      ttpp = 1
      cycle 
         ! for each lexical item
         i = tt(ttpp)
         if i >= 128 then keyword else start
            if 'A' <= i <= 'Z' then name else start
               if i = '"' then stringconst else start
                  if '0' <= i <= '9' or i = '''' or i = '$' then c
                    const else t(tp) = i and tp = tp + 1 and ttpp = ttpp + 1
               finish
            finish
         finish
      repeat until ttpp = ttp
      if lexopt = 1 then start
         newline
         for ttpp = 1, 1, tp - 2 cycle
            write(t(ttpp), 4)
            if ttpp & 16_F = 0 then newline
         repeat
         newline
      finish
      return
      !-----------------------------------------------------------------------
      routine store(integer l)
         if ttp > 256 then fault("STATEMENT TOO LONG") and stop
         tt(ttp) = l + ksh
         ttp = ttp + 1
      end
      !-----------------------------------------------------------------------
      routine keyword
         string (255) k
         integer i
         k = ""
         k = k . tostring(tt(ttpp) - 128) and ttpp = ttpp + 1 while tt(ttpp) > 128
         i = findk(k) and t(tp) = i and tp = tp + 1 until k = "" or i = 0
      end
      !-----------------------------------------------------------------------
      routine name
         string (*) name sname
         integer i, l, hash
         sname == string(addr(named(namedp)))
         hash = 0
         sname = ""
         l = tt(ttpp)
         cycle 
            if namedp + length(sname) >= 1022 then fault("NAME DICTIONARY FULL") and stop
            if length(sname) = 255 then fault("NAME TOO LONG") and stop
            sname = sname . tostring(l)
            hash = hash << 8 ! l
            ttpp = ttpp + 1
            l = tt(ttpp)
         repeat until l < '0' or '9' < l < 'A' or l > 'Z'
         hash = hash - hash // 251 * 251
         i = hash
         cycle 
            ! scan dictionary
            if namedlink(i) = 0 then namedlink(i) = namedp c
              and namedp = namedp + length(sname) + 1 and exit
            ! insert name
            if sname = string(addr(named(namedlink(i)))) then exit
            i = (i + 1) & 255
            if i = hash then fault("NAME DICTIONARY FULL") and stop
         repeat
         t(tp) = 256
         ! <name>
         t(tp + 1) = i
         ! ident
         tp = tp + 2
      end
      !-----------------------------------------------------------------------
      routine const
         integer l, value, flag, count, maxby10, maxld
         value = 0
         flag = 0
         if tt(ttpp) = '$' then start
            cycle 
               ttpp = ttpp + 1
               exit unless '0' <= tt(ttpp) <= '9' or 'A' <= tt(ttpp) <= 'F'
               if tt(ttpp) < 'A' then value = value << 4 ! (tt(ttpp) - '0') c
               else value = value << 4 ! (tt(ttpp) - 'A' + 10)
               flag = 1 and exit if value > 16_FFFF
            repeat
         finish else start
            if tt(ttpp) = '''' then start
               count = 0
               cycle 
                  ttpp = ttpp + 1
                  if tt(ttpp) = '''' then start
                     ttpp = ttpp + 1
                     if tt(ttpp) # '''' then exit
                  finish
                  value = value << 8 ! tt(ttpp)
                  count = count + 1
               repeat
               unless count <= 2 then flag = 1
               ! Only one char per word on M6809
            finish else start
               maxby10 = 16_7FFF // 10
               maxld = 16_7FFF - maxby10 * 10 + '0'
               ! Bug fixed.
               l = tt(ttpp)
               cycle 
                  if value > maxby10 or (value = maxby10 and l > maxld) c
                  then flag = 1 else value = value * 10 + l - '0'
                  ttpp = ttpp + 1
                  l = tt(ttpp)
               repeat until l < '0' or l > '9'
            finish
         finish
         t(tp) = 257
         ! <const>
         if flag # 0 then fault("CONSTANT INVALID") and value = 0
         t(tp + 1) = value
         tp = tp + 2
      end
      !-----------------------------------------------------------------------
      routine stringconst
         t(tp) = 258
         ! <STRING>
         if tt(ttpp) # '"' then start
            fault("INVALID STRING")
            t(tp + 1) = 16_80
            return
         finish
         cycle 
            tp = tp + 1
            ! Skip the first quote
            ttpp = ttpp + 1
            if tt(ttpp) = '"' then start
               if tt(ttpp + 1) = '"' then ttpp = ttpp + 1 c
              and t(tp) = '"' and continue
               t(tp) = 16_80
               tp = tp + 1
               ttpp = ttpp + 1
               return
            finish
            t(tp) = tt(ttpp)
         repeat
      end
   end
   !-----------------------------------------------------------------------
   routine rpsym(integer name l)
      own integer flag = 1
      readsymbol(l)
      if flag = 1 and outstream = 1 then printstring("*     ") and flag = 0
      printsymbol(l)
      if outstream = 1 and l = ';' and shift # 0 then newline
      if outstream = 1 and (l = nl or (l = ';' and shift # 0)) then flag = 1
      if 'a' <= l <= 'z' then l = l !! shift
   end
   !-----------------------------------------------------------------------
   integer fn findk(string (*) name k)
      ! look keyword up in dictionary
      integer i, l
      l = charno(k, 1)
      k -> (tostring(l)) . k
      i = l - 'A' + 1
      if kd(i)_l = 0 then result = 0
search: 
      if k = "" or kd(i)_a = 0 then result = kd(i)_n
      l = charno(k, 1)
      k -> (tostring(l)) . k
      i = kd(i)_a
      cycle 
         if kd(i)_l = l then -> search
         if kd(i)_b = 0 then result = 0
         i = kd(i)_b
      repeat
   end
   !-----------------------------------------------------------------------
   integer fn compare(integer p)
      integer app, tpp, alt, altend, psp, psi
      a(ap) = p << 16 ! 16_80000001
      ! phrase number & alternative 1
      if p <= 257 then start
         ! <name> or <const>
         if p = t(tp) then start
            ! success
            a(ap + 1) = t(tp + 1)
            ap = ap + 2
            tp = tp + 2
            result = 1
         finish else result = 0
      finish
      if p = 258 then start
         if t(tp) # p then result = 0
         alt = 1
         a(ap + alt) = t(tp + alt) and alt = alt + 1 until t(tp + alt) = 16_80
         a(ap + alt) = 16_80
         ap = ap + alt + 1
         tp = tp + alt + 1
         result = 1
      finish
      tpp = tp
      ! preserve text pointer
      app = ap
      ! preserve analysis record pointer
      psp = pp(p)
      ! start of phrase definition
      cycle 
         ! for each alternative
         alt = ap + 1
         altend = ps(psp)
         ap = alt + ps(psp + 1)
         ! leave gap for forward pointers
         if ap > 255 then fault("ANALYSIS RECORD TOO LONG") and stop
         psp = psp + 2
         cycle 
            ! for each item
            if psp = altend then result = 1
            ! success
            psi = ps(psp)
            if psi >= 256 then start
               ! phrase
               a(alt) = ap
               ! forward pointer
               if compare(psi) = 0 then exit
               alt = alt + 1
            finish else start
               ! literal or keyword
               if psi # t(tp) then exit
               tp = tp + 1
            finish
            psp = psp + 1
         repeat
         if ps(altend) = 0 then result = 0
         ! failure
         psp = altend
         tp = tpp
         ! backtrack text pointer
         ap = app
         ! backtrack analysis record pointer
         a(ap) = a(ap) + 1
         ! next alternative number
      repeat
   end
end
end of file