         Edinburgh IMP77 Compiler - Version 8.4

    1  %begin
    2  !%externalstring(255)%fnspec itos(%integer i,n)
    3  !%externalroutinespec openinput(%integer stream, %string(255) filename)
    4  !%externalroutinespec openoutput(%integer stream, %string(255) filename)
    5  
    6  %routinespec load
    7  %routinespec nextch
    8  %routinespec find(%integer x)
    9  %routinespec monitor(%integer n)
   10  %constinteger marker=16_ffffc000
   11  %conststring(1) snl = "
   12+ "
   13  %ownshortintegerarray st(0:10000)=%c
   14+    -1,4,'d','e','f',-1,
   15+    0,4,'v','a','l',-2,
   16+    6,7,'u','p','d','a','t','e',-3,
   17+    12,4,'b','i','n',-4,
   18+    21,4,'d','e','c',-5,
   19+    27,4,'b','a','r',-6,
   20+    0(9962)
   21  %owninteger e=33, s=39
   22  %integer a, w, w1, h, p, f, c, q, e0, f0, h0, r
   23  %string(63) filename
   24  %switch mcm(1:6)
   25  
   26    %on %event {0,} 9 %start
   27      %if eventno{event_event} = 9 %then %start
   28        select input(0)
   29        ->start
   30      %finish %else print string(snl."GPM terminated".snl)
   31      %stop
   32    %finish
   33  
   34     a=0
   35     w=0
   36     w1=0
   37     h=0
   38     p=0
   39     f=0
   40     c=0
   41     q=1
   42  
   43  start:nextch
   44     %if a='@' %then %start
   45       read(filename)
   46       openinput(1,filename)
   47       select input(1)
   48       ->start ; %finish
   49     %if a='/' %then %start
   50       read(filename)
   51       openoutput(1,filename)
   52       select output(1)
   53       ->start ; %finish
   54     %if a='<' %then q=q+1 %and ->q2
   55     %if a='$' %then ->fn
   56     %if a=',' %then ->next item
   57     %if a=';' %then ->apply
   58     %if a='#' %then ->load arg
   59     %if a=marker %then ->endfn
   60     %if a='>' %then ->exit
   61  copy:load
   62     %if q=1 %then ->start
   63  q2:nextch
   64     %if a='<' %then q=q+1 %and ->copy
   65     %if a#'>' %then ->copy
   66     q=q-1
   67     %if q=1 %then ->start %else ->copy
   68  fn:st(s)=h
   69     st(s+1)=f
   70     st(s+2)=0
   71     st(s+3)=0
   72     h=s+3
   73     f=s+1
   74     s=s+4
   75     ->start
   76  
   77  next item:%if h=0 %then ->copy
   78     st(h)=s-h-st(h)
   79     st(s)=0
   80     h=s
   81     s=s+1
   82     ->start
   83  
   84  apply:%if p>f %then monitor(1)
   85     %if h=0 %then ->copy
   86     st(h)=s-h
   87     st(s)=marker
   88     h0=st(f-1)
   89     f0=st(f)
   90     st(f-1)=s-f+2
   91     st(f)=p
   92     st(f+1)=c
   93     p=f
   94     f=f0
   95     h=h0
   96     s=s+1
   97     %unless h=0 %then st(h)=st(h)+st(p-1)
   98     find(p+2)
   99     %if st(w)<0 %then ->mcm(-st(w))
  100     c=w+1
  101     ->start
  102  
  103  loadarg:%if p=0 %then %start
  104       %if h=0 %then ->copy %else monitor(2)
  105       %finish
  106     nextch
  107     w=p+2
  108     %if a<'0' %then monitor(3)
  109     %if a>'0' %then %start
  110       %for r=0,1,a-'0'-1 %cycle
  111       w=w+st(w)
  112       %if st(w)=marker %then monitor(4)
  113       %repeat
  114       %finish
  115     %for r=1,1,st(w)-1 %cycle
  116     a=st(w+r)
  117     load
  118     %repeat
  119     ->start
  120  
  121  endfn:%if f>p %then monitor(5)
  122     st(s)=e
  123     a=s
  124     %while st(a)>=p-1+st(p-1) %cycle
  125       e0=st(a)
  126       st(a)=e0-st(p-1)
  127       a=e0
  128    %repeat
  129     w=st(a)
  130     w=st(w) %while w>p-1
  131     st(a)=w
  132     e=st(s)
  133     %unless h=0 %then %start
  134       %if h>p %then h=h-st(p-1) %else st(h)=st(h)-st(p-1)
  135       %finish
  136     a=p-1
  137     w=a+st(p-1)
  138     c=st(p+1)
  139     s=s-st(p-1)
  140     p=st(p)
  141     st(a)=st(w) %and a=a+1 %and w=w+1 %while a#s
  142     ->start
  143  
  144  exit:%unless c=h=0 %then monitor(8)
  145     %stop
  146  
  147  mcm(1):! def
  148     %unless h=0 %then st(h)=st(h)-st(p-1)+6
  149     st(p-1)=6
  150     st(p+5)=e
  151     e=p+5
  152     ->endfn
  153  
  154  mcm(2):! val
  155     find(p+6)
  156     a=st(w+1) %and w=w+1 %and load %while st(w+1)#marker
  157     ->endfn
  158  
  159  mcm(3):! update
  160     find(p+9)
  161     a=p+9+st(p+9)
  162     %if st(a)>st(w) %then monitor(9)
  163     %for r=1,1,st(a) %cycle
  164     st(w+r)=st(a+r)
  165     %repeat
  166     ->endfn
  167  
  168  mcm(4):! bin
  169     w=0
  170     %if st(p+7)='+' %or st(p+7)='-' %then a=p+8 %else a=p+7
  171     %while st(a)#marker %cycle
  172       %unless '0'<=st(a)<='9' %then monitor(10)
  173       w=10*w+st(a)-'0'
  174       a=a+1
  175       %repeat
  176     %if st(p+7)='-' %then st(s)=-w %else st(s)=w
  177     s=s+1
  178     ->endfn
  179  
  180  mcm(5):! dec
  181     w=st(p+7)
  182     %if w<0 %then w=-w %and a='-' %and load
  183     r=1
  184     r=10*r %while 10*r<=w
  185     a=w//r+'0' %and load %and w=w-r*(a-'0')%and r=r//10 %while r>=1
  186     ->endfn
  187  
  188  mcm(6):! bar
  189     w=st(p+9)
  190     a=st(p+11)
  191     %if st(p+7)='+' %then a=w+a
  192     %if st(p+7)='-' %then a=w-a
  193     %if st(p+7)='*' %then a=w*a
  194     %if st(p+7)='/' %then a=w//a
  195     %if st(p+7)='r' %then a=w-w//a*a
  196     load
  197     ->endfn
  198  
  199  {------------------------------------------------------------------------------}
  200  
  201  %routine load
  202     %if h=0 %then print symbol(a) %else st(s)=a %and s=s+1
  203  %end
  204  
  205  {------------------------------------------------------------------------------}
  206  
  207  %routine nextch
  208     %if c=0 %then read symbol(a) %else a=st(c) %and c=c+1
  209  %end
  210  
  211  {------------------------------------------------------------------------------}
  212  
  213  %routine find(%integer x)
  214     a=e
  215     w=x
  216  again: %for r=0,1,st(w)-1 %cycle
?Non-local
  217        %if st(w+r)#st(a+r+1) %then ->next
  218     %repeat
  219     w=a+1+st(w)
  220     %return
  221  next:a=st(a)
  222     ->again %unless a<0
  223     monitor(7)
  224  %end
  225  
  226  {------------------------------------------------------------------------------}
  227  
  228  %routine monitor(%integer n)
  229  %routinespec item(%integer x)
  230  %switch fault(1:10)
  231  
  232     print string(snl."Monitor : ")
  233     ->fault(n)
  234  
  235  fault(1):print string("Unmatched semicolon in definition of ")
  236     item(p+2)
  237     ->end
  238  
  239  fault(2):print string("Unquoted # in argument list of ")
  240     item(f+2)
  241     ->end
  242  
  243  fault(3):print string("Impossible argument number in definition of ")
  244     item(p+2)
  245     ->end
  246  
  247  fault(4):print string("No argument ")
  248     print symbol(a)
  249     print string(" in call for ")
  250     item(p+2)
  251     ->end
  252  
  253  fault(5):print string("Terminator in ")
  254     %if c=0 %then print string("input stream; GPM error ?") %and ->end
  255     print string("argument list for ")
  256     item(f+2)
  257     print string(snl."probably due to semicolon missing from definition of ")
  258     item(p+2)
  259     ->end
  260  
  261  fault(6):print string("GPM error?")
  262     ->end
  263  
  264  fault(7):print string("Undefined name ")
  265     item(w)
  266     ->end
  267  
  268  fault(8):print string("Unmatched >; GPM error ?")
  269     ->end
  270  
  271  fault(9):print string("Update argument too long for ")
  272     item(p+9)
  273     ->end
  274  
  275  fault(10):print string("Non-digit in number ")
  276  
  277  end:
  278  
  279     ! general monitor
  280     w=20
  281     print string(snl."Current macros are :")
  282     %while p#0 %or f#0 %cycle
  283       %if p>f %then %start
  284         w1=p+2
  285         p=st(p)
  286         print string(snl."already entered :  ")
  287       %finish %else %start
  288         w1=f+2
  289         f=st(f)
  290         print string(snl."not yet entered :  ")
  291       %finish
  292       %for r=1,1,w %cycle
?Non-local
  293         item(w1)
  294         %if st(w1)=0 %then %exit
  295         w1=w1+st(w1)
  296         %if st(w1)=marker %then %exit
  297         %unless w=1 %then %start
  298           print string(snl."arg".itos(r,1)." :    ")
  299         %finish
  300       %repeat
  301       w=1
  302       %repeat
  303     print string(snl."End of monitor printing".snl)
  304     %stop
  305  
  306  %routine item(%integer x)
  307  %integer k,l
  308     %if st(x)=0 %then l=s-x-1 %else l=st(x)-1
  309     %if l>0 %then %start
  310       print symbol(st(x+k)) %for k=1, 1, l
  311     %finish
  312     %if st(x)=0 %then print string("...    (incomplete)")
  313  %end
  314  
  315  %end
  316  
  317  %endofprogram

  257 Statements compiled
