externalstring (255)fnspec  itos(integer  i,n)

begin 
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  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