section "bgpm"
get "libhdr"
global $(
s:200; t:201; h:202; p:203
f:204; c:205; e:206; ch:207
sysin:208; sysout:209; fromstream:210; tostream:211
base:212; upb:213; rec.p:214; rec.l:215
getch:216; putch:217; wrn:218; error:219
exp:220; bexp:221
wrc:222; wrs:223; chpos:224
$)
manifest $(
s.eof = -1; s.eom = -2; s.def = -3; s.set = -4; s.eval = -5
s.lquote = -6; s.rquote = -7
c.call = '['; c.apply = ']'; c.sep = '\'; c.skip = '`'
c.lquote = '{'; c.rquote = '}'; c.arg = '^'
$)
let start() = valof
$( let argv = vec 40
if rdargs("FROM,TO/K,UPB/K", argv, 40)=0 do
$( writes("Bad arguments for BGPM*n"); resultis 20 $)
upb := 20000
unless argv!2=0 do upb := str2numb(argv!2)
if upb<500 do upb := 500
base := getvec(upb)
if base=0 do
$( writef("Unable to allocate work space (upb = %n)*n", upb)
resultis 20
$)
sysin := input()
fromstream := sysin
unless argv!0=0 do
$( fromstream := findinput(argv!0)
if fromstream=0 do
$( writef("Unable to read file %s*n", argv!0); resultis 20 $)
$)
selectinput(fromstream)
sysout := output()
tostream := sysout
unless argv!1=0 do
$( tostream := findoutput(argv!1)
if tostream=0 do
$( writef("Unable to write to file %s*n", argv!1)
unless fromstream=sysin do endread()
resultis 20 $)
$)
selectoutput(tostream)
bgpm()
unless fromstream=sysin do endread()
unless tostream=sysout do endwrite()
selectinput(sysin)
selectoutput(sysout)
freevec(base)
resultis 0
$)
and putch(ch) be test h=0 then wrch(ch) else push(ch)
and push(ch) = valof $( if t=s do error("Insufficient work space")
s := s + 1
!s := ch
resultis s
$)
and getch() = c=0 -> rdch(), valof $( c := c+1; resultis !c $)
and arg(a, n) = valof $( if !a<0 do error("Too few arguments")
if n=0 resultis a
a, n := a+!a+1, n-1
$) repeat
and lookup(a) = valof
$( let q, i, len = e, 0, !a
until q=0 | i>len test q!(i+2)=a!i then i := i+1
else q, i := !q, 0
if q=0 do error("Macro not defined")
resultis q
$)
and define(name, code) be
$( let s1 = s
push(e); push(t)
for i = 0 to name%0 do push(name%i)
push(1); push(code); push(s.eom)
until s=s1 do $( !t := !s; t, s := t-1, s-1 $)
e := t+1
$)
and bgpm(v, n) be
$( rec.p, rec.l := level(), ret
s, t, h, p, f, e, c := base-1, base+upb, 0, 0, 0, 0, 0
define("def", s.def)
define("set", s.set)
define("eval", s.eval)
define("lquote", s.lquote)
define("rquote", s.rquote)
define("eof", s.eof)
$( ch := getch() // Start of main scanning loop.
sw: switchon ch into
$( default: putch(ch); loop
case c.lquote:
$( let d = 1
$( ch := getch()
if ch<0 do error("Non character in quoted string")
if ch=c.lquote do d := d+1
if ch=c.rquote do $( d := d-1; if d=0 break $)
putch(ch)
$) repeat
loop
$)
case c.call:
f := push(f); push(h); push(?); push(?)
h := push(?)
loop
case c.sep:
if h=0 do $( putch(ch); loop $)
!h := s-h
h := push(?)
loop
case c.arg:
if p=0 do $( putch(ch); loop $)
ch := getch()
$( let a = arg(p+4, rdn())
for q = a+1 to a+!a do putch(!q)
$)
goto sw
case c.apply:
$( let a = f
if h=0 do $( putch(ch); loop $)
!h := s-h
push(s.eom)
f, h := a!0, a!1
a!0, a!1, a!2, a!3 := p, c, e, t
$( !t := !s; t, s := t-1, s-1 $) repeatuntil s<a
p := t+1
c := arg(lookup(p+4)+2, 1)
loop
$)
case c.skip:
ch := getch() repeatwhile ch='*s'| ch='*t' | ch='*n'
goto sw
case s.lquote: putch(c.lquote); loop
case s.rquote: putch(c.rquote); loop
case s.eof: return
case s.eom:
ret: if p=0 loop
c, e, t := p!1, p!2, p!3
p := p!0
loop
case s.def:
$( let a1 = arg(p+4, 1)
let a2 = arg(p+4, 2)
a2!(!a2+1) := s.eom
e := a1 - 2
e!0, e!1 := p!2, p!3
c, t := p!1, e-1
p := p!0
loop
$)
case s.set:
$( let name = arg(p+4, 1)
let val = arg(p+4, 2)
let len = !val
let a = lookup(name)
let b = arg(a+2, 1)
let max = a!1 - b - 1 // Max length of the value.
if len>max do error("New value too long")
for i = 0 to len do b!i := val!i
b!(len+1) := s.eom
goto ret
$)
case s.eval:
c := arg(p+4, 1)
wrn(exp(0))
goto ret
$)
$) repeat
$)
and rdn() = valof $( let val = 0
while '0'<=ch<='9' do $( val := 10*val + ch - '0'
ch := getch()
$)
resultis val
$)
and bexp() = valof
$( ch := getch()
switchon ch into
$( default: error("Bad expression")
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
resultis rdn()
case '+': resultis exp(2)
case '-': resultis -exp(2)
case '(': $( let res = exp(1)
ch := getch()
resultis res
$)
$)
$)
and exp(n) = valof
$( let a = bexp()
$( switchon ch into
$( default: if n>1 | n=1 & ch=')' | n=0 & ch=s.eom resultis a
error("Bad expression")
case '**': if n<3 do $( a := a * exp(3); loop $); resultis a
case '/': if n<3 do $( a := a / exp(3); loop $); resultis a
case '%': if n<3 do $( a := a rem exp(3); loop $); resultis a
case '+': if n<2 do $( a := a + exp(2); loop $); resultis a
case '-': if n<2 do $( a := a - exp(2); loop $); resultis a
$)
$) repeat
$)
and wrn(n) be $( if n<0 do $( putch('-'); n := -n $)
if n>9 do wrn(n/10)
putch(n rem 10 + '0')
$)
and wrc(ch) be
$( if ch='*n' do $( newline(); chpos := 0; return $)
if chpos>70 do wrc('*n')
unless '*s'<=ch<127 do ch := '?' // Assume 7 bit ASCII.
wrch(ch)
chpos := chpos+1
$)
and wrs(s) be for i = 1 to s%0 do wrc(s%i)
and error(mess) be
$( selectoutput(sysout)
wrs("*nError: "); wrs(mess)
wrs("*nIncomplete calls: ")
test f=0 then wrs("none") else prcall(20, f, h, s)
wrs("*nActive calls:*n"); btrace(p, 20)
wrs("Environment:*n"); wrenv(e, 4)
wrs("End of error message*n")
selectoutput(tostream)
longjump(rec.p, rec.l)
$)
and prcall(n, f, h, s) be unless f=0 test n=0
then wrs("...")
else $( prcall(n-1, !f, f!1, f-1)
!h := s-h
wrcall(f+4, s)
$)
and btrace(p, n) be
$( if n=0 do wrs("...*n")
if p=0 | n=0 return
wrcall(p+4, p!3); wrc(c.apply); wrc('*n')
p, n := !p, n-1
$) repeat
and wrcall(a, b) be
$( let sep = c.call
until a>=b do $( wrc(sep); wrarg(a)
a := a + !a + 1
sep := c.sep
$)
$)
and wrarg(a) be for ptr = a+1 to a + !a do wrc(!ptr)
and wrenv(e, n) be unless n=0 | e=0 do
$( wrs("Name: "); wrarg(arg(e+2, 0))
wrs(" Value: "); wrarg(arg(e+2, 1))
wrc('*n')
wrenv(!e, n-1)
$)