!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