         Edinburgh IMP77 Compiler - Version 8.4

    1  !Graham Toal - new development version of SKIMPD 13/02/80 13.27
    2  
    3  %const %string (1) snl = "
    4+ "
    5  
    6  %external %integer %array %spec a(1 : 500)
    7  
    8  %external %byte %integer %array %spec named(1 : 1024)
    9  
   10  %external %integer %array %spec namedlink(0 : 255)
   11  
   12  %external %integer %array %spec taglink(0 : 255)
   13  
   14  %external %integer %array %spec tag(1 : 512)
   15  
   16  %external %integer %array %spec link(1 : 512)
   17  
   18  %external %integer %array %spec nextrad(0 : 15)
   19  
   20  %external %integer %array %spec rt(0 : 15)
   21  
   22  %external %integer %array %spec parms(0 : 15)
   23  
   24  %external %string (5) %array %spec display(0 : 15)
   25  
   26  %external %integer faults = 0
   27  %external %integer %spec tagasl, level, tagsopt, nextcad, namedp, %c
   28+  traceopt, aopt, pstr
   29  !-----------------------------------------------------------------------
   30  %external %integer %fn %spec intstr(%string (6) val)
   31  %external %routine %spec expr(%integer exprp)
   32  %routine %spec popitem(%integer %name f, l)
   33  ! Local
   34  %external %integer %fn %spec outstream
   35  !-----------------------------------------------------------------------
   36  %own %integer %array used(0 : 15) = 0(*)
   37  
   38  %own %integer %array worklist(0 : 15) = 0(16)
   39  
   40  %own %integer %array namelist(0 : 15) = 0(16)
   41  
   42  %own %integer %array branchlist(0 : 15) = 0(16)
   43  
   44  %own %integer %array startlist(0 : 15) = 0(16)
   45  
   46  %own %integer %array cot(0 : 127)
   47  
   48  %own %integer cotp, params
   49  !-----------------------------------------------------------------------
   50  %external %string (255) %fn strint(%integer n, p)
   51     %string (255) r
   52     %string (1) s
   53     %if n < 0 %then s = "-" %and n = -n %else s = ""
   54     r = ""
   55     r = tostring(n - n // 10 * 10 + '0') . r %and n = n // 10 %until n = 0
   56     r = s . r
   57     r = " " . r %while length(r) < p
   58     %result = r
   59  %end
   60  !-----------------------------------------------------------------------
   61  %external %string (7) %fn s(%integer i)
   62     %result = strint(i, 0)
   63  %end
   64  !-----------------------------------------------------------------------
   65  %external %string (8) %fn strhex(%integer n)
   66     %const %string (1) %array h(0 : 15) = %c
   67+ "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F"
   68  
   69     %integer i
   70     %string (8) sh
   71     sh = ""
   72     %for i = 1, 1, 8 %cycle
   73        sh = h(n & 16_F) . sh
   74        n = n >> 4
   75     %repeat
   76     %result = sh
   77  %end
   78  !-----------------------------------------------------------------------
   79  %external %routine fault(%string (63) mess)
   80     %integer st
   81     printstring("?  " . mess . "
   82+ 
   83+ ")
   84     st = outstream
   85     selectoutput(0)
   86     printstring("*" . mess . snl)
   87     selectoutput(st)
   88     faults = faults + 1
   89  %end
   90  !-----------------------------------------------------------------------
   91  %external %routine dump(%string (7) lab, op, reg, addr)
   92     %own %string (7) label = ""
   93     %routine %spec codeout(%string (7) l, o, r, a)
   94     %if label # "" %start
   95        %if lab = "" %then lab = label %else %start
   96           codeout(label, "EQU", "", "*")
   97           label = ""
   98        %finish
   99     %finish
  100     %if (op = "ADD" %or op = "SUB" %or op = "EOR" %or op = "OR") %and addr = "#0" %then %return
  101     %if (op = "AND" %or op = "LD") %and reg # "D" %and addr = "#0" %then op = "CLR" %and addr = ""
  102     %if op = "ADD" %and addr = "#1" %and reg # "D" %then %start
  103        op = "INC"
  104        addr = ""
  105     %finish
  106     %if op = "SUB" %and addr = "#1" %and reg # "D" %then %start
  107        op = "DEC"
  108        addr = ""
  109     %finish
  110     %if op = "CMP" %and addr = "#0" %and reg # "D" %then op = "TST" %and addr = ""
  111     %if op = "EQU" %and addr = "*" %then label = lab %c
  112+    %else label = "" %and codeout(lab, op, reg, addr)
  113  
  114     %routine codeout(%string (7) lab, op, reg, addr)
  115        %string (6) nums
  116        %integer i
  117        %routine dump2(%string (7) lab, op, reg, addr)
  118           %own %string (7) lastop = "silly"
  119           %own %integer inhibit = 0
  120           %if reg = "B" %and op = "LD" %and addr -> ("#") . nums %c
  121+            %and (%not nums -> ("-") . nums) %and intstr(nums) > 255 %then reg = "D"
  122           %if lab # "" %then %start
  123              %if op = "EQU" %and addr = "*" %then inhibit = 0
  124              %if op # "EQU" %then inhibit = 0
  125           %finish
  126           %if inhibit = 0 %or op = "EQU" %then %start
  127              lastop = op
  128              %return %if op = "TST" %and reg = "B" %and lab = ""
  129              !   ****FRIG****
  130              %if op = "CMP" %and addr = "#1" %then addr = "" %and op = "DEC"
  131              printstring(lab)
  132              spaces(10 - length(lab))
  133              op = op . reg
  134              printstring(op)
  135              spaces(10 - length(op))
  136              printstring(addr)
  137              newline
  138              nextcad = nextcad + 1
  139           %finish
  140           %if op = "LBRA" %or op = "SWI2" %or (op = "SWI" %and reg = "2") %c
  141+            %then inhibit = 1
  142           %return %unless op = "LBSR"
  143           %if addr = "SHL" %then used(12) = 1
  144           %if addr = "SHR" %then used(13) = 1
  145           %if addr = "EXP" %then used(14) = 1
  146           %if addr = "DIV" %then used(15) = 1
  147        %end
  148        %own %string (7) %array l(1 : 2) = ""(2)
  149  
  150        %own %string (7) %array o(1 : 2) = ""(2)
  151  
  152        %own %string (7) %array r(1 : 2) = ""(2)
  153  
  154        %own %string (7) %array a(1 : 2) = ""(2)
  155  
  156        %own %integer buffptr = 0
  157        %switch load(0:2)
  158        %switch store(0:2)
  159        %routine flushbuffer
  160           %integer i
  161           %for i = 1, 1, buffptr %cycle
  162              dump2(l(i), o(i), r(i), a(i))
  163           %repeat
  164           buffptr = 0
  165        %end
  166        %routine checklabel(%integer buff)
  167           %if buff = 3 %then %start
  168              %if lab # "" %then dump2(lab, "EQU", "", "*")
  169              %return
  170           %finish
  171           %if l(buff) # "" %then dump2(l(buff), "EQU", "", "*")
  172        %end
  173        %routine savethisinstr
  174           buffptr = buffptr + 1
  175           %if buffptr > 2 %then %start
  176              printstring("*?????Buffer full..." . snl)
  177              flushbuffer
  178           %finish
  179           l(buffptr) = lab
  180           o(buffptr) = op
  181           r(buffptr) = reg
  182           a(buffptr) = addr
  183        %end
  184        %if op = "SEX" %and buffptr # 0 %and o(buffptr) = "LD" %c
  185+       %and a(buffptr) -> ("#") . nums %and (%not nums -> ("-") . nums) %c
  186+       %and intstr(nums) > 255 %then %return
  187        %if reg # "B" %then %start
  188           flushbuffer
  189           dump2(lab, op, reg, addr)
  190           %return
  191        %finish
  192        %if op = "LD" %then %start
  193           -> load(buffptr)
  194  load(0): 
  195           savethisinstr
  196           %return
  197  load(1): 
  198           %if o(1) = "LD" %then checklabel(1) %and buffptr = 0 %else %start
  199              %if o(1) = "ST" %and a(1) = addr %then %start
  200                 %if lab # "" %then %start
  201                    flushbuffer
  202                    savethisinstr
  203                    %return
  204                 %finish %else %return
  205              %finish
  206           %finish
  207           savethisinstr
  208           %return
  209  load(2): 
  210           dump2(l(1), o(1), r(1), a(1))
  211           l(1) = l(2)
  212           r(1) = r(2)
  213           o(1) = o(2)
  214           a(1) = a(2)
  215           buffptr = 1
  216           printstring("?***** Unexpected third el = load" . snl)
  217           -> load(1)
  218        %finish
  219        %if op = "ST" %then %start
  220           -> store(buffptr)
  221  store(0): 
  222           savethisinstr
  223           %return
  224  store(1): 
  225           %if o(1) = "LD" %or o(1) = "ST" %then %start
  226              %if a(1) = addr %then %start
  227                 %if lab # "" %then %start
  228                    flushbuffer
  229                    savethisinstr
  230                    %return
  231                 %finish %else %return
  232              %finish %else %start
  233                 flushbuffer
  234                 savethisinstr
  235                 %return
  236              %finish
  237           %finish
  238           %if o(1) = "CLR" %then %start
  239              checklabel(1)
  240              buffptr = 0
  241              dump2(lab, "CLR", "", addr)
  242              %return
  243           %finish
  244           flushbuffer
  245           savethisinstr
  246           %return
  247  store(2): 
  248           %if o(1) = "LD" %and a(1) = addr %and (o(2) = "INC" %or o(2) = "DEC" %c
  249+            %or o(2) = "NEG" %or o(2) = "COM") %then %start
  250              checklabel(2)
  251              checklabel(3)
  252              dump2(l(1), o(2), "", addr)
  253              buffptr = 0
  254              %return
  255           %finish
  256           dump2(l(1), o(1), r(1), a(1))
  257           l(1) = l(2)
  258           o(1) = o(2)
  259           r(1) = r(2)
  260           a(1) = a(2)
  261           buffptr = 1
  262           -> store(1)
  263        %finish
  264        %if op = "TST" %then %start
  265           %if buffptr # 0 %then %start
  266              %if o(buffptr) = "LD" %then %start
  267                 dump2(l(buffptr), op, "", a(buffptr))
  268                 checklabel(3)
  269                 buffptr = buffptr - 1
  270                 %return
  271              %finish
  272           %finish
  273           flushbuffer
  274           dump2(lab, op, reg, addr)
  275           %return
  276        %finish
  277        %if op = "INC" %or op = "DEC" %or op = "CLR" %or op = "NEG" %c
  278+         %or op = "COM" %then %start
  279           %if buffptr = 2 %then %start
  280              dump2(l(1), o(1), r(1), a(1))
  281              l(1) = l(2)
  282              o(1) = o(2)
  283              r(1) = r(2)
  284              a(1) = a(2)
  285              l(2) = lab
  286              o(2) = op
  287              r(2) = reg
  288              a(2) = addr
  289              buffptr = 2
  290              %return
  291           %finish
  292           savethisinstr
  293           %return
  294        %finish
  295        flushbuffer
  296        dump2(lab, op, reg, addr)
  297     %end
?I unused
  298  %end
  299  !-----------------------------------------------------------------------
  300  %external %string (255) %fn name(%integer ident)
  301     %unless 0 <= ident <= 255 %and namedlink(ident) # 0 %then %result = ""
  302     %result = string(addr(named(namedlink(ident))))
  303  %end
  304  !-----------------------------------------------------------------------
  305  %external %integer %fn newtag
  306     %integer i
  307     %if tagasl = 0 %then fault("TAG SPACE FULL") %and %stop
  308     i = tagasl
  309     tagasl = link(tagasl)
  310     %result = i
  311  %end
  312  !-----------------------------------------------------------------------
  313  %external %integer %fn returntag(%integer tagi)
  314     %integer l
  315     l = link(tagi)
  316     link(tagi) = tagasl
  317     tagasl = tagi
  318     %result = l
  319  %end
  320  !-----------------------------------------------------------------------
  321  %external %integer %fn getwork
  322     !%integername cell
  323     !  cell==worklist(level)
  324     !  %while cell#0 %cycle
  325     !    %if tag(cell)<0 %then tag(cell)=-tag(cell) %and %result=tag(cell)
  326     !    cell==link(cell)
  327     !  %repeat
  328     !  cell=newtag
  329     !  tag(cell)=nextrad(level)
  330     !  nextrad(level)=nextrad(level)+1
  331     !  link(cell)=0
  332     !  %result=tag(cell)
  333     %result = 0
  334  %end
  335  !-----------------------------------------------------------------------
  336  %external %routine returnwork(%integer work)
  337     !%integer cell
  338     !  cell=worklist(level)
  339     !  %while cell#0 %cycle
  340     !    %if tag(cell)=work %then tag(cell)=-work %and %return
  341     !    cell=link(cell)
  342     !  %repeat
  343  %end
?WORK unused
  344  !-----------------------------------------------------------------------
  345  %external %routine clearwork
  346     %integer cell
  347     cell = worklist(level)
  348     cell = returntag(cell) %while cell # 0
  349     worklist(level) = 0
  350  %end
  351  !-----------------------------------------------------------------------
  352  %external %integer %fn getcoti(%integer const)
  353     %integer coti
  354     %if cotp > 0 %then %start
  355        %for coti = 0, 1, cotp - 1 %cycle
  356           %if cot(coti) = const %then %result = coti
  357        %repeat
  358     %finish
  359     %if cotp = 128 %then fault("CONSTANT TABLE FULL") %and %stop
  360     cot(cotp) = const
  361     cotp = cotp + 1
  362     %result = cotp - 1
  363  %end
  364  !-----------------------------------------------------------------------
  365  %external %routine pushtag(%integer ident, form, type, dim, level, rad)
  366     %integer tagi
  367     %if taglink(ident) # 0 %and tag(taglink(ident)) >> 16 & 16_F = level %c
  368+    %then fault("NAME " . name(ident) . " DECLARED TWICE")
  369     tagi = newtag
  370     tag(tagi) = form << 28 ! type << 24 ! dim << 20 ! level << 16 ! rad
  371     link(tagi) = taglink(ident)
  372     taglink(ident) = tagi
  373     tagi = newtag
  374     tag(tagi) = ident
  375     link(tagi) = namelist(level)
  376     namelist(level) = tagi
  377  %end
  378  !-----------------------------------------------------------------------
  379  %external %routine poptags
  380     %integer cell, ident, nametag, params
  381     %string (63) s
  382     %if tagsopt = 1 %then newline
  383     cell = namelist(level)
  384     %while cell # 0 %cycle
  385        ident = tag(cell)
  386        cell = returntag(cell)
  387        nametag = tag(taglink(ident))
  388        taglink(ident) = returntag(taglink(ident))
  389        %if tagsopt = 1 %then %start
  390           s = name(ident)
  391           printstring(strint(ident, 3) . "   " . s)
  392           spaces(10 - length(s))
  393           printstring(strhex(nametag))
  394        %finish
  395        %if nametag >> 28 = 4 %then %start
  396           ! procedure type
  397           params = nametag >> 20 & 16_F
  398           %while params # 0 %cycle
  399              %if tagsopt = 1 %then printstring("
  400+                     " . strhex(tag(taglink(ident))))
  401              taglink(ident) = returntag(taglink(ident))
  402              params = params - 1
  403              ! pop up parameter tags
  404           %repeat
  405        %finish
  406        %if tagsopt = 1 %then newline
  407        %if taglink(ident) = 0 %then namedp = namedlink(ident) %and namedlink(ident) = 0
  408        ! backtrack name dictionary
  409     %repeat
  410     %if tagsopt = 1 %then newline
  411     namelist(level) = 0
  412  %end
  413  !-----------------------------------------------------------------------
  414  %external %integer %fn getlabel(%integer constp)
  415     %integer label
  416     label = a(constp + 1)
  417     %if label > 9999 %then fault("LABEL " . strint(label, 1) . " TOO LARGE") %c
  418+      %and %result = -1 %else %result = label
  419  %end
  420  !-----------------------------------------------------------------------
  421  %external %routine filllabel(%integer label)
  422     !%integer cell
  423     %return %if label < 0
  424     ! for conditional statements
  425     !  cell=branchlist(level)
  426     !  %while cell#0 %cycle
  427     !    %if tag(cell)>>16=label %then %start
  428     !      %if tag(cell)&16_8000=0 %then fault("DUPLICATE LABEL ". !        strint(label,1)) %else %start
  429     dump("L" . s(label), "EQU", "", "*")
  430     !        tag(cell)=label<<16!nextcad
  431     !      %finish
  432     !      %return
  433     !    %finish
  434     !    cell=link(cell)
  435     !  %repeat
  436     !  cell=newtag
  437     !  link(cell)=branchlist(level)
  438     !  branchlist(level)=cell
  439     !  tag(cell)=label<<16!nextcad
  440  %end
  441  !-----------------------------------------------------------------------
  442  %external %integer %fn fillbranch(%integer label)
  443     %integer cell, cad
  444     %result = 0 %if label < 0
  445     cell = branchlist(level)
  446     %while cell # 0 %cycle
  447        %if tag(cell) >> 16 = label %then %start
  448           cad = tag(cell) & 16_7FFF
  449           %if tag(cell) & 16_8000 # 0 %then tag(cell) = label << 16 ! 16_8000 ! nextcad
  450           %result = cad
  451        %finish
  452        cell = link(cell)
  453     %repeat
  454     cell = newtag
  455     link(cell) = branchlist(level)
  456     branchlist(level) = cell
  457     tag(cell) = label << 16 ! 16_8000 ! nextcad
  458     %result = 0
  459  %end
  460  !-----------------------------------------------------------------------
  461  %external %routine poplabels
  462     %integer cell
  463     cell = branchlist(level)
  464     %while cell # 0 %cycle
  465        %if tag(cell) & 16_8000 # 0 %then fault("LABEL " . strint(tag(cell) >> 16, 1) . %c
  466+         " NOT SET (BRANCH LIST " . strint(tag(cell) & 16_7FFF, 1) . ")")
  467        cell = returntag(cell)
  468     %repeat
  469     branchlist(level) = 0
  470  %end
  471  !-----------------------------------------------------------------------
  472  %external %integer %fn nextplabel
  473     %own %integer plabel = 9999
  474     plabel = plabel + 1
  475     %result = plabel
  476  %end
  477  !-----------------------------------------------------------------------
  478  %external %routine pushstart(%integer flag, plab)
  479     %integer cell
  480     cell = newtag
  481     tag(cell) = flag << 16 ! plab & 16_FFFF
  482     ! plab may be -1
  483     link(cell) = startlist(level)
  484     startlist(level) = cell
  485  %end
  486  %external %predicate find(%integer type, %integer %name t, lab)
  487     %integer cell
  488     cell = startlist(level)
  489     %while cell # 0 %cycle
  490        t = tag(cell) >> 16
  491        %if t & 2 = type %then %start
  492           lab = tag(cell) & 16_FFFF
  493           %true
  494        %finish
  495        cell = link(cell)
  496     %repeat
  497     t = 0
  498     lab = 0
  499     %false
  500  %end
  501  %external %routine findcontinue(%integer %name type, lab)
  502     %if find(2, type, lab) %then lab = lab + 1 %c
  503+    %else type = 0 %and lab = 0 %and fault("%CYCLE MISSING")
  504  %end
  505  %external %routine findexit(%integer %name type, lab)
  506     %if find(2, type, lab) %then lab = lab + 2 %c
  507+    %else type = 0 %and lab = 0 %and fault("%CYCLE MISSING")
  508  %end
  509  %predicate findcycle
  510     %integer t, l
  511     %if find(2, t, l) %then %true
  512     %false
  513  %end
  514  %predicate findstart
  515     %integer t, l
  516     %if find(0, t, l) %then %true
  517     %false
  518  %end
  519  %external %routine popcycle(%integer %name type, lab)
  520     popitem(type, lab)
  521     %if type & 2 = 0 %then %start
  522        %if findcycle %then %start
  523           fault("%FINISH MISSING {Or spurious %REPEAT??}")
  524        %finish %else %start
  525           fault("SPURIOUS %REPEAT")
  526           pushstart(type, lab) %if lab # 0
  527        %finish
  528        lab = 0
  529        type = 3
  530     %finish
  531  %end
  532  %external %routine popstart(%integer %name type, lab)
  533     popitem(type, lab)
  534     %if type & 2 = 2 %or lab = 0 %then %start
  535        %if findstart %then %start
  536           fault("%REPEAT MISSING {Or spurious %FINISH??}")
  537        %finish %else %start
  538           fault("SPURIOUS %FINISH")
  539           pushstart(type, lab) %if lab # 0
  540        %finish
  541        lab = 0
  542        type = 0
  543     %finish
  544  %end
  545  !-----------------------------------------------------------------------
  546  %routine popitem(%integer %name flag, plab)
  547     %integer cell
  548     cell = startlist(level)
  549     %if cell = 0 %then %start
  550        flag = 0
  551        plab = 0
  552     %finish %else %start
  553        flag = tag(cell) >> 16
  554        plab = tag(cell) & 16_FFFF
  555        %if plab = 16_FFFF %then plab = -1
  556        startlist(level) = returntag(cell)
  557     %finish
  558  %end
  559  !-----------------------------------------------------------------------
  560  %external %routine clearstart
  561     %integer cell
  562     %const %string (7) %array what(0 : 1) = "%FINISH", "%REPEAT"
  563  
  564     cell = startlist(level)
  565     %while cell # 0 %cycle
  566        fault(what(tag(cell) >> 17) . " MISSING")
  567        cell = returntag(cell)
  568     %repeat
  569     startlist(level) = 0
  570  %end
  571  !-----------------------------------------------------------------------
  572  %external %integer %fn enter
  573     %own %string (4) %array regs(1 : 2) = "A", "A,B"
  574  
  575     %string (4) base
  576     %integer alloc, dim
  577     %if level = 1 %then %start
  578        %if nextcad # 1 %then fault("%BEGIN NOT FIRST STATEMENT")
  579        dump("", "ORG", "", "$F800")
  580        dump("START", "EQU", "", "*")
  581        dump("", "SWI", "3", "") %if traceopt = 1
  582        dump("", "LD", "U", "#STACK")
  583        dump("", "LEA", "X", "-USTK,U")
  584        base = ",X"
  585        alloc = 34
  586        ! Already set up by calling program
  587        ! Rest for I/O buffers and perm locations.
  588     %finish %else %start
  589        ! STORE STP (=Y) IF NECCESARY
  590        %if level > 2 %start
  591           dump("", "ST", "Y", display(level - 1))
  592        %finish
  593        dump("", "PSH", "S", "Y")
  594        dump("", "TFR", "", "S,Y")
  595        alloc = 0
  596        base = ",Y"
  597     %finish
  598     !  cad=nextcad
  599     %if level # 1 %then %start
  600        ! REMOVED TO 'SKIMPB'
  601     %finish %else %start
  602        dump("", "LEA", "S", "-A" . s(rt(level)) . ",X")
  603     %finish
  604     nextrad(level) = alloc
  605     %result = alloc
  606  %end
?DIM unused
?REGS unused
  607  !-----------------------------------------------------------------------
  608  %external %routine dumpreturn
  609     dump("", "TFR", "", "Y,S")
  610     dump("", "PUL", "S", "Y,PC")
  611  %end
  612  !-----------------------------------------------------------------------
  613  %external %routine array(%integer arrayp)
  614     %integer namep, actualp, exprp, exprsp, ident, nametag, basep, disp
  615     %string (4) base
  616     namep = a(arrayp + 1)
  617     actualp = a(arrayp + 2)
  618     ident = a(namep + 1)
  619     %if a(actualp) = 1 %then %start
  620        dump("  ", "CLR", "A", "")
  621        dump("", "ANDCC", "", "0")
  622        exprp = a(actualp + 1)
  623        exprsp = a(actualp + 2)
  624        expr(exprp)
  625        nametag = tag(taglink(ident))
  626        basep = nametag >> 16 & 16_F
  627        base = display(basep)
  628        base = ",Y" %if basep = level
  629        base = ",X" %if basep = 1
  630        disp = nametag & 16_FFFF
  631        dump("", "BCC", "", "*+3")
  632        dump("", "INC", "A", "")
  633        %if basep = 1 %or basep = level %start
  634           dump("", "ADD", "D", "-" . s(disp) . base)
  635        %finish %else %start
  636           dump("", "PSH", "U", "A,B")
  637           dump("", "LD", "D", display(basep))
  638           dump("", "SUB", "D", "#" . s(disp))
  639           dump("", "ST", "D", "0,X")
  640           dump("", "LD", "D", "[0,X]")
  641           dump("", "ADD", "D", ",U++")
  642        %finish
  643        dump("", "ST", "D", "0,X") %if aopt = 0
  644        aopt = 0
  645        !    dump("ADD","ACC",display(nametag>>16&16_f),nametag&16_ffff)
  646        %if a(exprsp) = 1 %then fault("ARRAY " . name(ident) . " HAS EXTRA INDEX")
  647     %finish %else fault("ARRAY " . name(ident) . " HAS NO INDEX")
  648  %end
  649  !-----------------------------------------------------------------------
  650  %external %routine proc(%integer procp)
  651     %string (4) opn, base, reg
  652     %integer namep, ident, nametag, ptagl, l, actualp, exprp, unaryp, operandp, %c
  653+      npars, ptag, pnamep, pident, pnametag, pactualp, disp, exprrestp, exprsp, %c
  654+      oldparams, basep, size
  655     !  %if params>2 %then dump("LDA","STP","STP",params)
  656     !***! hack !***!
  657     %if params >= 2 %then dump("", "LEA", "S", "-" . s(params + 1) . ",S")
  658     !***! hack !***!
  659     oldparams = params
  660     params = 4
  661     namep = a(procp + 1)
  662     actualp = a(procp + 2)
  663     ident = a(namep + 1)
  664     l = taglink(ident)
  665     nametag = tag(l)
  666     ptagl = link(l)
  667     npars = nametag >> 20 & 16_F
  668     %if npars = 0 %then %start
  669        %if a(actualp) = 1 %then fault(name(ident) . " HAS PARAMETERS") %and %return
  670     %finish %else %start
  671        %if a(actualp) = 2 %then fault(name(ident) . " MISSING PARAMETERS") %and %return
  672        exprp = a(actualp + 1)
  673        exprsp = a(actualp + 2)
  674        %cycle 
  675           ! for each parameter
  676           ptag = tag(ptagl)
  677           %if ptag >> 28 = 0 %then expr(exprp) %and reg = "B" %else %start
  678              reg = "D"
  679              unaryp = a(exprp + 1)
  680              operandp = a(exprp + 2)
  681              exprrestp = a(exprp + 3)
  682              %unless a(unaryp) = 4 %and a(operandp) = 1 %and a(exprrestp) = 2 %c
  683+          %then fault("NOT A %NAME PARAMETER") %else %start
  684                 pnamep = a(operandp + 1)
  685                 pactualp = a(operandp + 2)
  686                 pident = a(pnamep + 1)
  687                 !?          %if taglink(pident)=0 %then fault(name(pident). !?            " NOT DECLARED") %else %start
  688                 %if taglink(pident) = 0 %then %start
  689                    dump("", "LD", "B", name(pident))
  690                 %finish %else %start
  691                    pnametag = tag(taglink(pident))
  692                    %if pnametag >> 28 = 4 %then fault(name(pident) . " NOT A %NAME") %else %start
  693                       basep = pnametag >> 16 & 16_F
  694                       base = display(basep)
  695                       disp = pnametag & 16_FFFF
  696                       base = "Y" %if basep = level
  697                       base = "X" %if basep = 1
  698                       %if ptag >> 28 = 1 %then %start
  699                          ! %name
  700                          %if pnametag >> 28 >= 2 %then aopt = 1 %and array(operandp) %else %start
  701                             %if pnametag >> 28 = 1 %then %start
  702                                %if 1 < basep < level %start
  703                                   dump("", "LD", reg, base)
  704                                   dump("", "SUB", reg, "#" . s(disp))
  705                                   dump("", "ST", reg, "0,X")
  706                                   dump("", "LD", reg, "[0,X]")
  707                                %finish %else %start
  708                                   dump("", "LD", reg, "-" . s(disp) . "," . base)
  709                                %finish
  710                             %finish %else %start
  711                                %if 1 < basep < level %start
  712                                   dump("", "LD", reg, base)
  713                                   dump("", "SUB", reg, "#" . s(disp))
  714                                %finish %else %start
  715                                   %if basep = 1 = level %then %start
  716                                      dump("", "LEA", "Y", "-" . s(disp) . ",X")
  717                                      reg = "Y"
  718                                   %finish %else %start
  719                                      dump("", "TFR", "", base . ",D")
  720                                      dump("", "SUB", reg, "#" . s(disp))
  721                                   %finish
  722                                   ! GET ADDRESS OF A %NAME INTO B
  723                                %finish
  724                             %finish
  725                             !   CHECK FOR SILLY BASE REGISTER
  726                             !                  dump(opn,"ACC",base,disp)
  727                             %if a(pactualp) = 1 %then fault(name(pident) . " DECLARED AS SCALAR")
  728                          %finish
  729                       %finish %else %start
  730                          !                dump("LOAD","ACC",base,disp)    ;! %array
  731                          %if base = "Y" %or base = "X" %start
  732                             dump("", "LD", reg, "-" . s(disp) . "," . base)
  733                          %finish %else %start
  734                             dump("", "LD", reg, base)
  735                             dump("", "SUB", reg, "#" . s(disp))
  736                             dump("", "ST", reg, "0,X")
  737                             dump("", "LD", reg, "[0,X]")
  738                          %finish
  739                          !   CHECK SILLY BASE REGISTER
  740                          %if a(pactualp) = 1 %then fault("%ARRAYNAME " . name(pident) . " HAS INDEX")
  741                       %finish
  742                    %finish
  743                 %finish
  744              %finish
  745           %finish
  746           !      dump("STR","ACC","STP",params)
  747           %if reg = "D" %or reg = "Y" %then size = 2 %else size = 1
  748           params = params + size
  749           dump("", "ST", reg, "-" . s(params) . ",S")
  750           npars = npars - 1
  751           %if npars = 0 %then %start
  752              %if a(exprsp) = 1 %then fault(name(ident) . " HAS EXTRA PARAMETERS")
  753              %exit
  754           %finish
  755           ptagl = link(ptagl)
  756           %if a(exprsp) = 2 %then fault(name(ident) . " IS MISSING PARAMETERS") %and %exit
  757           exprp = a(exprsp + 1)
  758           exprsp = a(exprsp + 2)
  759        %repeat
  760     %finish
  761     ! external i/o routines at level 0
  762     %if nametag >> 16 & 16_F = 0 %then base = "EXT" %else base = "E"
  763     %if nametag >> 16 & 16_F = 0 %then %start
  764        used(nametag & 16_F) = 1
  765     %finish
  766     dump("", "LBSR", "", base . s(nametag & 16_FFFF))
  767     params = oldparams
  768     !                      EH??????
  769     !***! frig !***!
  770     %if params >= 2 %then dump("", "LEA", "S", s(params + 1) . ",S")
  771     !  %if params>2 %then dump("SUB","STP","COT",getcoti(params))
  772  %end
?OPN unused
  773  !-----------------------------------------------------------------------
  774  %external %routine endofprog
  775     %integer i
  776     dump("", "SWI", "2", "")
  777     dump("STACK", "EQU", "", "$0800-1")
  778     dump("USTK", "EQU", "", "$20")
  779     !  DUMP("EXT1","EQU","","") %IF USED(1)=1
  780     !  DUMP("EXT2","EQU","","") %IF USED(2)=1
  781     !  DUMP("EXT3","EQU","","") %IF USED(3)=1
  782     !  DUMP("EXT4","EQU","","") %IF USED(4)=1
  783     !  DUMP("EXT5","EQU","","") %IF USED(5)=1
  784     !  DUMP("EXT6","EQU","","") %IF USED(6)=1
  785     !  DUMP("EXT7","EQU","","") %IF USED(7)=1
  786     !  DUMP("EXT8","EQU","","") %IF USED(8)=1
  787     !  DUMP("EXT9","EQU","","") %IF USED(9)=1
  788     !  DUMP("EXT10","EQU","","") %IF USED(10)=1
  789     !! READSYMBOL POSING AS READ
  790     !  DUMP("EXT11","EQU","","") %AND USED(15)=1 %IF USED(11)=1
  791     %if used(12) = 1 %then %start
  792        dump("DOSHL", "LSL", "B", "")
  793        dump("", "SUB", "A", "#1")
  794        dump("SHL", "CMP", "A", "#0")
  795        dump("", "BGT", "", "DOSHL")
  796        dump("", "RTS", "", "")
  797     %finish
  798     %if used(13) = 1 %then %start
  799        dump("DOSHR", "LSR", "B", "")
  800        dump("", "SUB", "A", "#1")
  801        dump("SHR", "CMP", "A", "#0")
  802        dump("", "BGT", "", "DOSHR")
  803        dump("", "RTS", "", "")
  804     %finish
  805     %if used(14) = 1 %then %start
  806        dump("EXP", "PSH", "S", "B")
  807        dump("EXP2", "CMP", "A", "#1")
  808        dump("", "BGT", "", "DOEXP")
  809        dump("", "LEA", "S", "1,S")
  810        dump("", "RTS", "", "")
  811        dump("DOEXP", "PSH", "U", "A")
  812        dump("", "LDA", "", "0,S")
  813        dump("", "MUL", "", "")
  814        dump("", "PUL", "U", "A")
  815        dump("", "SUB", "A", "#1")
  816        dump("", "BRA", "", "EXP2")
  817     %finish
  818     %if used(15) = 1 %then %start
  819        ! 'B'//'A'
  820        dump("DIV", "EQU", "", "*")
  821        dump("", "CLR", "", "-1,S")
  822        dump("", "CLR", "", "-2,S")
  823        dump("", "INC", "", "-2,S")
  824        dump("", "TST", "B", "")
  825        dump("", "BGE", "", "TRYA")
  826        dump("", "NEG", "B", "")
  827        dump("", "CLR", "", "-2,S")
  828        dump("TRYA", "TST", "A", "")
  829        dump("", "BGE", "", "OK")
  830        dump("", "NEG", "A", "")
  831        dump("", "TST", "", "-2,S")
  832        dump("", "BNE", "", "OK")
  833        dump("", "INC", "", "-2,S")
  834        dump("OK", "TST", "B", "")
  835        dump("", "BLT", "", "DONE")
  836        dump("", "INC", "", "-1,S")
  837        dump("", "PSH", "U", "A")
  838        dump("", "SUB", "B", ",U+")
  839        dump("", "BRA", "", "OK")
  840        dump("DONE", "DEC", "", "-1,S")
  841        dump("", "TST", "", "-2,S")
  842        dump("", "BNE", "", "RET")
  843        dump("", "NEG", "", "-1,S")
  844        dump("RET", "LD", "B", "-1,S")
  845        dump("", "RTS", "", "")
  846     %finish %else dump("DIV", "EQU", "", "0")
  847     !  newline
  848     %if pstr # 0 %then %start
  849        dump("OUTCH", "LD", "A", "ACIAS")
  850        dump("", "AND", "A", "#2")
  851        dump("", "BEQ", "", "OUTCH")
  852        dump("", "ST", "B", "ACIAD")
  853        dump("WAITX", "LD", "B", "#$FF")
  854        dump("", "DEC", "B", "")
  855        dump("", "BNE", "", "WAITX")
  856        dump("PSTR", "LD", "B", "[0,S]")
  857        dump("", "INC", "", "1,S")
  858        dump("", "BNE", "", "NOCAR")
  859        dump("", "INC", "", "0,S")
  860        dump("NOCAR", "CMP", "B", "#$80")
  861        dump("", "BNE", "", "OUTCH")
  862        dump("", "RTS", "", "")
  863     %finish
  864     %if faults > 0 %start
  865        %begin
  866           %integer st
  867           st = outstream
  868           selectoutput(0)
  869           printstring("Program contains " . s(faults) . " fault")
  870           printsymbol('s') %if faults > 1
  871           newline
  872           selectoutput(st)
  873        %end
  874     %finish
  875     newline
  876     %if faults > 0 %then printstring("?" . strint(faults, 4)) %else printstring("*NO")
  877     printstring(" FAULT")
  878     printsymbol('S') %if faults # 1
  879     printstring(" IN THIS PROGRAM
  880+ ")
  881     %signal %event 13
  882     ! Not again!!!
  883  %end
?I unused
  884  %end %of %file

  724 Statements compiled
