begin
!%externalstring(255)%fnspec itos(%integer i,n)
!%externalroutinespec openinput(%integer stream, %string(255) filename)
!%externalroutinespec openoutput(%integer stream, %string(255) filename)

routinespec load
routinespec nextch
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 eventno{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:nextch
   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:nextch
   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
   nextch
   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 nextch
   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