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) $)