%begin

%routinespec load
%routinespec gpmnextch
%routinespec find(%integer x)
%routinespec monitor(%integer n)
%constinteger marker=16_ffffc000
!%conststring(1) snl = "
!"
%ownshortintegerarray st(0:10000)=%c
   -1,4,'d','e','f',-1,
   0,4,'v','a','l',-2,
   6,7,'u','p','d','a','t','e',-3,
   12,4,'b','i','n',-4,
   21,4,'d','e','c',-5,
   27,4,'b','a','r',-6,
   0(9962)
%owninteger e=33, s=39
%integer a, w, w1, h, p, f, c, q, e0, f0, h0, r
%string(63) filename
%switch mcm(1:6)

  %on %event 0, 9 %start
    %if event{_event} = 9 %then %start
      select input(0)
      ->start
    %finish %else print string(snl."GPM terminated".snl)
    %stop
  %finish

   a=0
   w=0
   w1=0
   h=0
   p=0
   f=0
   c=0
   q=1

start:gpmnextch
   %if a='@' %then %start
     read(filename)
     openinput(1,filename)
     select input(1)
     ->start ; %finish
   %if a='/' %then %start
     read(filename)
     openoutput(1,filename)
     select output(1)
     ->start ; %finish
   %if a='<' %then q=q+1 %and ->q2
   %if a='$' %then ->fn
   %if a=',' %then ->next item
   %if a=';' %then ->apply
   %if a='#' %then ->load arg
   %if a=marker %then ->endfn
   %if a='>' %then ->exit
copy:load
   %if q=1 %then ->start
q2:gpmnextch
   %if a='<' %then q=q+1 %and ->copy
   %if a#'>' %then ->copy
   q=q-1
   %if q=1 %then ->start %else ->copy
fn:st(s)=h
   st(s+1)=f
   st(s+2)=0
   st(s+3)=0
   h=s+3
   f=s+1
   s=s+4
   ->start

next item:%if h=0 %then ->copy
   st(h)=s-h-st(h)
   st(s)=0
   h=s
   s=s+1
   ->start

apply:%if p>f %then monitor(1)
   %if h=0 %then ->copy
   st(h)=s-h
   st(s)=marker
   h0=st(f-1)
   f0=st(f)
   st(f-1)=s-f+2
   st(f)=p
   st(f+1)=c
   p=f
   f=f0
   h=h0
   s=s+1
   %unless h=0 %then st(h)=st(h)+st(p-1)
   find(p+2)
   %if st(w)<0 %then ->mcm(-st(w))
   c=w+1
   ->start

loadarg:%if p=0 %then %start
     %if h=0 %then ->copy %else monitor(2)
     %finish
   gpmnextch
   w=p+2
   %if a<'0' %then monitor(3)
   %if a>'0' %then %start
     %for r=0,1,a-'0'-1 %cycle
     w=w+st(w)
     %if st(w)=marker %then monitor(4)
     %repeat
     %finish
   %for r=1,1,st(w)-1 %cycle
   a=st(w+r)
   load
   %repeat
   ->start

endfn:%if f>p %then monitor(5)
   st(s)=e
   a=s
   %while st(a)>=p-1+st(p-1) %cycle
     e0=st(a)
     st(a)=e0-st(p-1)
     a=e0
  %repeat
   w=st(a)
   w=st(w) %while w>p-1
   st(a)=w
   e=st(s)
   %unless h=0 %then %start
     %if h>p %then h=h-st(p-1) %else st(h)=st(h)-st(p-1)
     %finish
   a=p-1
   w=a+st(p-1)
   c=st(p+1)
   s=s-st(p-1)
   p=st(p)
   st(a)=st(w) %and a=a+1 %and w=w+1 %while a#s
   ->start

exit:%unless c=h=0 %then monitor(8)
   %stop

mcm(1):! def
   %unless h=0 %then st(h)=st(h)-st(p-1)+6
   st(p-1)=6
   st(p+5)=e
   e=p+5
   ->endfn

mcm(2):! val
   find(p+6)
   a=st(w+1) %and w=w+1 %and load %while st(w+1)#marker
   ->endfn

mcm(3):! update
   find(p+9)
   a=p+9+st(p+9)
   %if st(a)>st(w) %then monitor(9)
   %for r=1,1,st(a) %cycle
   st(w+r)=st(a+r)
   %repeat
   ->endfn

mcm(4):! bin
   w=0
   %if st(p+7)='+' %or st(p+7)='-' %then a=p+8 %else a=p+7
   %while st(a)#marker %cycle
     %unless '0'<=st(a)<='9' %then monitor(10)
     w=10*w+st(a)-'0'
     a=a+1
     %repeat
   %if st(p+7)='-' %then st(s)=-w %else st(s)=w
   s=s+1
   ->endfn

mcm(5):! dec
   w=st(p+7)
   %if w<0 %then w=-w %and a='-' %and load
   r=1
   r=10*r %while 10*r<=w
   a=w//r+'0' %and load %and w=w-r*(a-'0')%and r=r//10 %while r>=1
   ->endfn

mcm(6):! bar
   w=st(p+9)
   a=st(p+11)
   %if st(p+7)='+' %then a=w+a
   %if st(p+7)='-' %then a=w-a
   %if st(p+7)='*' %then a=w*a
   %if st(p+7)='/' %then a=w//a
   %if st(p+7)='r' %then a=w-w//a*a
   load
   ->endfn

{------------------------------------------------------------------------------}

%routine load
   %if h=0 %then print symbol(a) %else st(s)=a %and s=s+1
%end

{------------------------------------------------------------------------------}

%routine gpmnextch
   %if c=0 %then a = next symbol %else a=st(c) %and c=c+1
   !%if c=0 %then read symbol(a) %else a=st(c) %and c=c+1
%end

{------------------------------------------------------------------------------}

%routine find(%integer x)
   a=e
   w=x
again: %for r=0,1,st(w)-1 %cycle
      %if st(w+r)#st(a+r+1) %then ->next
   %repeat
   w=a+1+st(w)
   %return
next:a=st(a)
   ->again %unless a<0
   monitor(7)
%end

{------------------------------------------------------------------------------}

%routine monitor(%integer n)
%routinespec item(%integer x)
%switch fault(1:10)

   print string(snl."Monitor : ")
   ->fault(n)

fault(1):print string("Unmatched semicolon in definition of ")
   item(p+2)
   ->end

fault(2):print string("Unquoted # in argument list of ")
   item(f+2)
   ->end

fault(3):print string("Impossible argument number in definition of ")
   item(p+2)
   ->end

fault(4):print string("No argument ")
   print symbol(a)
   print string(" in call for ")
   item(p+2)
   ->end

fault(5):print string("Terminator in ")
   %if c=0 %then print string("input stream; GPM error ?") %and ->end
   print string("argument list for ")
   item(f+2)
   print string(snl."probably due to semicolon missing from definition of ")
   item(p+2)
   ->end

fault(6):print string("GPM error?")
   ->end

fault(7):print string("Undefined name ")
   item(w)
   ->end

fault(8):print string("Unmatched >; GPM error ?")
   ->end

fault(9):print string("Update argument too long for ")
   item(p+9)
   ->end

fault(10):print string("Non-digit in number ")

end:

   ! general monitor
   w=20
   print string(snl."Current macros are :")
   %while p#0 %or f#0 %cycle
     %if p>f %then %start
       w1=p+2
       p=st(p)
       print string(snl."already entered :  ")
     %finish %else %start
       w1=f+2
       f=st(f)
       print string(snl."not yet entered :  ")
     %finish
     %for r=1,1,w %cycle
       item(w1)
       %if st(w1)=0 %then %exit
       w1=w1+st(w1)
       %if st(w1)=marker %then %exit
       %unless w=1 %then %start
         print string(snl."arg".itos(r,1)." :    ")
       %finish
     %repeat
     w=1
     %repeat
   print string(snl."End of monitor printing".snl)
   %stop

%routine item(%integer x)
%integer k,l
   %if st(x)=0 %then l=s-x-1 %else l=st(x)-1
   %if l>0 %then %start
     print symbol(st(x+k)) %for k=1, 1, l
   %finish
   %if st(x)=0 %then print string("...    (incomplete)")
%end

%end

%endofprogram