         Edinburgh IMP77 Compiler - Version 8.4

    1  %externalstring(255)%fnspec date
    2  %externalstring(255)%fnspec time
    3  %systemroutinespec exit %alias "exit" (%integer rc)
    4  
    5  %externalintegerfnspec cputime
    6  %externalroutinespec getblock %alias "GETBLOCK_JSB" (%integer len, %bytename base)
    7  %externalintegerfunctionspec getlong %alias "GETLONG_JSB"
    8  %externalintegerfunctionspec getword %alias "GETWORD_JSB"
    9     %externalroutinespec get(%integername n)
   10     %externalroutinespec put(%integer n)
   11     %externalroutinespec putword(%integer n)
   12     %externalroutinespec putlong(%integer n)
   13     %externalroutinespec putblock(%integer len, %bytename b)
   14  !   Computer Science IMP77 Compiler   -   Version 8  Third pass
   15  !      23rd March 1981
   16  !      Mods by MT October/November 1981
   17  !
   18  ! Uses common include file defining constants,
   19  ! spec'ing common externals etc.
   20  !
   21  !!%include "control.imp"
   22  
   23  {%systemroutinespec exit %alias "exit" (%integer s)
   24  !%external %routine %spec  PUT (%integer n)
   25  !%external %routine %spec  PUT WORD (%integer n)
   26  !%external %routine %spec  PUT LONG (%integer n)
   27  !%external %routine %spec  PUT BLOCK (%integer n, %bytename b)
   28  %external %routine %spec  SELECT INPUT TANK (%integer n)
   29  %external %routine %spec  SELECT OUTPUT TANK (%integer n)
   30  !%external %routine %spec  GET (%integer %name ch)
   31  !%external %routine %spec  GET BLOCK (%integer len, %byte %name b)
   32  %external %routine %spec  PRINT RECORD (%integer len, %byte %name buff)
   33  %external %integer %function %spec  LOOK
   34  !%external %integer %function %spec  GETWORD
   35  !%external %integer %function %spec  GETLONG
   36  %external %integer %function %spec  TAG %alias "GETLONG";  ! For pass 2
   37  %external %string(63) %function %spec  ITOS (%integer n, p)
   38  
   39  ! streams
   40  %const %integer  report      = 0
   41  %const %integer  object file = 1
   42  %const %integer  listing     = 2
   43  %const %integer  diag stream = listing
   44  
   45  ! miscellaneous
   46  %const %integer  max ident = 31;        ! Length for external linkage
   47  %const %integer  fatal = 16_1000002C;   ! Error exit code to VMS
   48  
   49  
   50  ! external data (defined in driver)
   51  %external %string(6) %spec  version;    ! Compiler version string
   52  %external %integer %spec  command
   53  %external %integer %spec  control
   54  
   55  ! command bit meanings (set by command line)
   56  %const %integer  diag bit  = 8_00004
   57  %const %integer  line bit  = 8_00010
   58  %const %integer  log bit   = 8_00020
   59  %const %integer  time bit  = 8_01000
   60  %const %integer  entry bit = 8_02000
   61  %const %integer  init bit  = 8_04000
   62  %const %integer  pic bit   = 8_10000
   63  
   64  ! control bit meanings  (%control n, or set by driver (/check= etc))
   65  ! bit set => check on
   66  
   67  %const %integer  ass check  =   1;      ! unassigned checking
   68  %const %integer  str check  =   2;      ! string capacity checking
   69  %const %integer  for check  =   4;      ! %for checking
   70  %const %integer  arr check  =   8;      ! array bound checking
   71  %const %integer  ovf check  =  16;      ! integer overflow checking
   72  %const %integer  rec round  = 128;      ! rounding in records (turns it on)
   73  %const %integer  profiling  = 256;      ! call TRACE (line no) at bounds
   74  
   75  ! object file commands  Pass2 => Pass3
   76  
   77  %const %integer  obj extern    = 1;     ! insert external entry
   78  %const %integer  obj code      = 2;     ! code block
   79  %const %integer  obj gla       = 3;     ! gla  block
   80  %const %integer  obj pdef      = 4;     ! external proc definition
   81  %const %integer  obj pspec     = 5;     ! external proc specification
   82  %const %integer  obj ddef      = 6;     ! external data definition
   83  %const %integer  obj dspec     = 7;     ! external data specification
   84  %const %integer  obj reloc     = 8;     ! relocate gla
   85  %const %integer  obj set       = 9;     ! set gla to tag address
   86  %const %integer  obj header    = 10;    ! start of procedure
   87  %const %integer  obj call      = 11;    ! procedure call
   88  %const %integer  obj jump      = 12;    ! jump
   89  %const %integer  obj prim spec = 13;    ! prim definition
   90  %const %integer  obj end       = 14;    ! end of object file
   91  %const %integer  obj line      = 15;    ! line number
   92  %const %integer  obj term      = 16;    ! end of block
   93  %const %integer  obj diag p    = 17;    ! diags for proc header
   94  %const %integer  obj diag v    = 18;    ! diags for variable
   95  %const %integer  obj weak      = 19
   96  %const %integer  obj b lab     = 20;    ! bxxb in m/code
   97  %const %integer  obj w lab     = 21;    ! bxxw in m/code
   98  %const %integer  obj glam      = 22;    ! initialise n items in GLA
   99  %const %integer  obj modd      = 23;    ! modify displacement
  100  %const %integer  obj prim ref  = 24;    ! call to prim
  101  %const %integer  obj ext ref   = 25;    ! call to external procedure
  102  %const %integer  last obj code = 25
  103  
  104  ! directive file commands  Pass2 => Pass3
  105  
  106  %const %integer  dir used      = 1;     ! external used
  107  %const %integer  dir ldef      = 2;     ! label definition
  108  %const %integer  dir pref      = 3;     ! procedure reference
  109  %const %integer  dir cref      = 4;     ! conditional label reference
  110  %const %integer  dir uref      = 5;     ! unconditional label reference
  111  %const %integer  dir end       = 6;     ! end of procedure
  112  %const %integer  dir sizes     = 7;     ! end of directives+sizes
  113  %const %integer  dir x end     = 8;     ! end of external entry
  114  %const %integer  dir header    = 9;     ! start of procedure
  115  %const %integer  dir entry     = 10;    ! define entry label
  116  %const %integer  last dir code = 10
  117  
  118  !!%end %of %file
  119  
  120  ! Size constants
  121  %const %integer  max tag       = 4000;        ! total tags in use
  122  %const %integer  max ref       = 6000;        ! references to tags
  123  %const %integer  max procs     =  600;        ! procedures in module
  124  %const %integer  max externals =  400;        ! external defs/refs
  125  %const %integer  max rec       =  512;        ! object record size
  126  
  127  %external %routine  PASS3 (%string(63) module, %integer object, directives)
  128     %integer  check ass = control&ass check;      ! unassigned checking on
  129     %integer  diags     = command&diag bit;       ! dump diag psect
  130     %integer  ldump     = command&line bit;       ! dump lines (trace) psect
  131     %integer  pic       = command&pic bit;        ! PIC for gla
  132     %integer  init      = command&init bit;       ! initialisation needed
  133     %integer  timing    = command&time bit;       ! full timing report
  134     %integer  clog      = command&log bit;        ! summary to console
  135  
  136     %const %integer  proc enter prim = 13;        ! = "$_M"
  137  
  138     %const %integer  non zero = 1;                ! boolean
  139  
  140     ! Op-codes
  141     %const %integer  brb    = 16_11;              ! +127/-128
  142     %const %integer  brw    = 16_31;              ! +32767/-32768
  143     %const %integer  jmp    = 16_17;              ! anywhere...
  144     %const %integer  bneq   = 16_12, bnequ = 16_12
  145     %const %integer  beql   = 16_13, beqlu = 16_13
  146     %const %integer  bgtr   = 16_14
  147     %const %integer  bleq   = 16_15
  148     %const %integer  bgeq   = 16_18
  149     %const %integer  blss   = 16_19
  150     %const %integer  bgtru  = 16_1A
  151     %const %integer  blequ  = 16_1B
  152     %const %integer  bgequ  = 16_1E
  153     %const %integer  blssu  = 16_1F
  154     %const %integer  jsb    = 16_16
  155     %const %integer  calls  = 16_FB
  156     %const %integer  movl   = 16_D0
  157     %const %integer  moval  = 16_DE
  158     %const %integer  movab  = 16_9E
  159     %const %integer  subl2  = 16_C2
  160     %const %integer  movc5  = 16_2C
  161  
  162     ! Branch table - invert (branch (b)) = branch(b!!7)
  163     %const %byte %array  branch (0 : 15) =
  164+       brb,   beql,  blss,  bleq,  bgtr,  bgeq,  bneq,   0,      {signed}
  165+     { u/c     =      <      <=     >      >=      #   never }
  166+       brb,   beqlu, blssu, blequ, bgtru, bgequ, bnequ,  0       {unsigned}
  167  
  168  
  169     %const %integer  margin   = 800;              ! stretch margin for jumps
  170     %const %integer  safe low = 16_ffff8001+margin
  171     %const %integer  safe high= 16_00008000-margin
  172  
  173     %const %integer  middling = 16_1000;          ! word disp ref
  174  
  175     ! Object record constants
  176  
  177     %const %integer  obj hdr = 0
  178     %const %integer      hdr mhd = 0;             ! module header
  179     %const %integer      hdr lng = 1;             ! language sub-header
  180  
  181     %const %integer  obj gsd = 1
  182     %const %integer      gsd psc = 0;             ! P-sect def
  183     %const %integer      gsd sym = 1;             ! Symbol (def/ref)
  184     %const %integer      gsd epm = 2;             ! Ext def + mask
  185  
  186     %const %integer  obj tir = 2
  187     %const %integer      tir stag    = 0;         ! Stack global symbol
  188     %const %integer      tir stasb   = 1;         ! Stack signed byte
  189     %const %integer      tir stasw   = 2
  190     %const %integer      tir stal    = 3
  191     %const %integer      tir stpbb   = 4
  192     %const %integer      tir stpbw   = 5
  193     %const %integer      tir stpbl   = 6
  194     %const %integer      tir staub   = 7;         ! Stack unsigned byte
  195     %const %integer      tir stob    = 20;        ! Store signed byte
  196     %const %integer      tir stow    = 21;        ! Store signed word
  197     %const %integer      tir stol    = 22;        ! Store longword
  198     %const %integer      tir stold   = 25;        ! Store longword
  199     %const %integer      tir stopidr = 27;        ! Store PIC data reference
  200     %const %integer      tir stopicr = 28;        ! Store PIC reference
  201     %const %integer      tir sto rl  = 31;        ! Store repeated long
  202     %const %integer      tir stoub   = 33;        ! Store unsigned byte
  203     %const %integer      tir stogb   = 37;        ! Store general byte
  204     %const %integer      tir sto rb  = 39;        ! Store repeated byte
  205     %const %integer      tir sto rw  = 40;        ! Store repeated word
  206     %const %integer      tir add     = 51
  207     %const %integer      tir setrb   = 80
  208     %const %integer      tir augrb   = 81
  209  
  210     %const %integer  obj eom = 3
  211     %const %integer  obj dbg = 4
  212  
  213     !P-sect info
  214  
  215     %const %integer  quad = 3;                    ! 8(=2**3)-byte alignment
  216  
  217     %const %integer  ps pic = 1<<0
  218     %const %integer  ps rel = 1<<3
  219     %const %integer  ps shr = 1<<5
  220     %const %integer  ps exe = 1<<6
  221     %const %integer  ps rd  = 1<<7
  222     %const %integer  ps wrt = 1<<8
  223  
  224     %own %integer %name  ca
  225     %own %integer %name  ga
  226     %own %integer  base        =  0
  227     %own %short    ref head    =  0
  228     %own %short %name  ref chain;   ref chain == ref head
  229     %own %short    def list    =  0;      !ordered list of labels
  230     %own %integer  this line   =  0
  231     %own %integer  entry tag   = -1
  232  
  233     %const %integer  code flags = ps pic ! ps rel ! ps rd  ! ps exe ! ps shr
  234     %own   %integer  glap flags = ps rd  ! ps wrt ! ps rel ! ps pic
  235  !                    glap flags = glap flags ! ps pic %if pic # 0
  236     %const %integer  diag flags = ps pic ! ps rel ! ps rd  ! ps shr
  237     %const %integer  line flags = ps pic ! ps rel ! ps rd  ! ps shr
  238  
  239     %const %string(10)  code name = "$_CODEAREA"
  240     %own   %string(10)  glap name = "$_GLAPAREA"
  241  !                       glap name = "$_GLAPPIC"
  242     %const %string(10)  diag name = "$_DIAGAREA"
  243     %const %string(10)  line name = "$_CODELINE"
  244     %const %string(10)  init proc = "IMP$_INIT"
  245  
  246     %integer  refs, last tag
  247     %integer  code size, glap size, diag size, line size
  248     %integer  procs, events, event base, evp, specs
  249     %own %string(max ident)  text
  250  
  251     %record %format  psect fm (%integer bp, pa, dump, bs, lr, lrp,
  252+                               %integer index, lbs, bb, be, max,
  253+                               (%byte type %or
  254+                                %byte %array b (1 : maxrec)))
  255     %own %record(psect fm)  codep, glapp, workp, diagp, linep
  256     %own %record(psect fm) %name  buff;     ! Points at one of above
  257  
  258     %record %format  ref fm (%integer ca, tag, %short flag, link)
  259     %record %format  def fm (%integer ca, %short uses, link)
  260     %record(def fm) %array  def (0 : max tag)
  261     %record(ref fm) %array  ref (1 : max ref)
  262  
  263     %record %format  proc fm (%integer frame,
  264+                              %short type, mask, diag, diag ep, line ep)
  265     %record(proc fm) %array  proc tab (1 : max procs)
  266  
  267     %byte              %array  ext used (1 : max externals)
  268     %string(max ident) %array  ext text (1 : max externals)
  269  
  270  
  271     %routine  ERROR (%string(31) text, %integer extra)
  272        select output (report)
  273        newline
  274        print string ("***Pass3 fails """);  print string (text)
  275        print string (""" (");  write (extra, 0);  print symbol (')')
  276        newline
  277        %monitor
  278        exit (16_1000002c)     {1000002c is SS$_ABORT with the inhibit message bit set - could just use EXIT_FAILURE}
  279     %end
  280  
  281     %routine  GET STRING (%string(*) %name  t)
  282        %integer  len, file len
  283        get (len)
  284        file len = len
  285        error ("external size?", len) %unless 0 < len <= max ident
  286        len = len - 1 %if len = max ident {make room for '_' in Gla name}
  287        length(t) = len
  288        getblock (file len, charno(t,1))
  289     %end
  290  
  291     %routine %spec  STPB (%record(psect fm) %name p, %integer d)
  292     %routine %spec  ADD (%integer b)
  293     %routine  FLUSH BUFF
  294        %integer %name  bp
  295        bp == buff_bp
  296        %if bp > max rec %start
  297           ! over the limits!
  298           error ("buffer error - seek help!!", bp-maxrec)
  299        %finish
  300        %if buff_dump # 0 %start
  301           error ("buffer error", 1) %if buff_bs > 0;  ! Still in IMMED mode
  302           %if bp > 1 %start
  303              print record (bp, buff_b(1))
  304           %finish
  305        %finish
  306        buff_bs = 0;  buff_be = 0;  buff_lbs = 0;  buff_lr = 0
  307        bp = 1;                   ! leave type field
  308        %if buff_type = obj tir %and buff_dump # 0 %start
  309           ! fill in reloc command
  310           stpb (buff, buff_pa);  add (tir setrb)
  311           buff_lr = buff_bp;  buff_lrp = 1
  312        %finish
  313     %end
  314  
  315     %routine  NEED (%integer  b)
  316        ! ensure there are at least b bytes free in current buffer
  317        flush buff %if buff_bp + b > max rec
  318     %end
  319  
  320     %routine  SET WORK (%integer type)
  321        buff == workp;  flush buff
  322        workp = 0;  workp_dump = 1
  323        workp_type = type;  workp_bp = 1
  324     %end
  325  
  326     %routine  ADD (%integer b)
  327        %return %if buff_dump = 0
  328        buff_bp = buff_bp + 1;  buff_b(buff_bp) = b&255
  329     %end
  330  
  331     %routine  ADDW (%integer n)
  332        %return %if buff_dump = 0
  333        shortinteger(addr(buff_b(buff_bp+1))) = n
  334        buff_bp = buff_bp + 2
  335     %end
  336  
  337     %routine  ADDL (%integer n)
  338        %return %if buff_dump = 0
  339        integer(addr(buff_b(buff_bp+1))) = n
  340        buff_bp = buff_bp + 4
  341     %end
  342  
  343     %routine  ADD STRING (%integer from, %string(63) s)
  344        %integer b, l
  345        %return %if buff_dump = 0
  346        l = length(s)
  347        %if from = 0 %start
  348           string(addr(buff_b(buff_bp+1))) = s
  349           buff_bp = buff_bp + 1
  350        %else
  351           b = buff_b(buff_bp)
  352           string(addr(buff_b(buff_bp))) = s
  353           buff_b(buff_bp) = b
  354        %finish
  355        buff_bp = buff_bp + l
  356     %end
  357  
  358     %routine  ADD TEXT (%integer data)
  359        %string(max ident) t = text
  360        %return %if buff_dump = 0
  361        t = t . "_" %if data # 0
  362        add string (0, t)
  363     %end
  364  
  365     %integer %function  RANGE (%integer disp, extra)
  366        %result = 1 %if -128 <= disp <= 127
  367        %result = 2 %if 16_FFFF8000 <= disp-extra <= 16_7FFF
  368        %result = 4
  369     %end
  370  
  371     %routine  STAG (%string(max ident+3) S)
  372        need (1+1+length(S))
  373        add (tir stag);   add string (0, S)
  374     %end
  375  
  376     %routine  TIR COMMAND (%integername value, %integer param,
  377+                           %byte %array %name  clist)
  378        %integer  size
  379        size = range (value, 0)
  380        need (2+size)
  381        add (clist(size))
  382        add (param) %if param >= 0
  383        %if size = 1 %start
  384           add (value)
  385        %else %if size = 2
  386           addw (value)
  387        %else
  388           addl (value)
  389        %finish
  390        value = size
  391     %end
  392  
  393     %routine  STPB (%record(psect fm) %name p, %integer offset)
  394        %own %byte %array  stpbc (1 : 4) =
  395+          tir stpbb, tir stpbw, 0, tir stpbl
  396        tir command (offset, p_index, stpbc)
  397     %end
  398  
  399     %routine  STAK (%integer  value)
  400        %own %byte %array  stac (1 : 4) =
  401+          tir stasb,  tir stasw, 0, tir stal
  402        tir command (value, -1, stac)
  403     %end
  404  
  405     %routine  SELECT (%integer disp)
  406        %return %if buff_dump = 0
  407        need (7);                 ! Sequence must be in one record!
  408        error ("psect overflow", disp) %if disp > buff_max
  409        %if buff_lr = buff_bp %start
  410           ! Have not planted anything since last 'select'
  411           buff_bp = buff_lrp;    ! Forget last select
  412           buff_pa = -20;         ! Ensure this one planted!
  413        %finish
  414        %if buff_pa # disp %start
  415           buff_lrp = buff_bp
  416           stpb (buff, disp)
  417           add (tir setrb)
  418           buff_lr = buff_bp
  419           buff_pa = disp
  420        %finish
  421     %end
  422  
  423     %routine  START IMMED (%integer max)
  424        %return %if buff_dump = 0
  425        error ("buffer in use", 0) %if buff_bs # 0
  426        error ("immediate size error", max) %if max > 128
  427        need (max+1)
  428        %if buff_be = buff_bp %and
  429+           max + (buff_bp - buff_lbs) <= 128 %start
  430           ! Can concatenate buffers
  431           buff_bs = buff_lbs
  432        %else
  433           add (0);                            ! Length byte
  434           buff_bs = buff_bp
  435        %finish
  436        buff_bb = buff_bp;                     ! Where this block started
  437     %end
  438  
  439     %routine  END IMMED
  440        %integer  size
  441        %return %if buff_dump = 0
  442        error ("buffer not in use", 0) %if buff_bs = 0
  443        size = buff_bp - buff_bs
  444        %if size # 0 %start
  445           error ("buffer overflow", size) %if size > 128
  446           buff_b(buff_bs) = -size
  447           buff_lbs = buff_bs
  448           buff_be = buff_bp
  449        %else
  450           buff_bp = buff_bp - 1
  451        %finish
  452        buff_pa = buff_pa + buff_bp - buff_bb; ! Update psect disp.
  453        error ("Psect immediate overflow", 0) %if buff_pa > buff_max
  454        buff_bs = 0;                           ! Not buffering now
  455     %end
  456  
  457     %routine  SPEC (%integer flags, data, value, mask)
  458        %integer  def, len, psect
  459        psect = |data|
  460        data = 0 %if data < 0;                  ! no '_' for ext data def
  461        def = flags&2
  462        len = (1+1)+(data+length(text))
  463        len = len + 7 %if def # 0
  464        set work (obj gsd)
  465        %if def = 0 %start
  466           add (gsd sym)
  467        %else
  468           add (gsd epm)
  469        %finish
  470        add (0);                               ! data type - unknown
  471        addw (flags);                          ! symbol flags
  472        %if def # 0 %start;                    ! definition
  473           add (psect)
  474           addl (value)
  475           addw (mask)
  476        %finish
  477        add text (data)
  478     %end
  479  
  480     %routine  INPUT DIRECTIVES
  481        %switch  d (1 : last dir code)
  482        %short  first = 0, list = 0
  483        %short %name  ref list == first, end
  484        %record(proc fm) %name  proc
  485        %record(ref fm)  %name  r
  486        %record(def fm)  %name  t
  487        %integer %name  q
  488        %integer  proc head, n, frame, ldiag
  489        %integer  ecode, unass code, size
  490        %integer  rp, tag, block tag, dcode
  491        %own %integer  dap = 0, lap = 2
  492  
  493        procs = procs + 1
  494        proc == proc tab(procs)
  495        proc_diag ep = 0
  496        proc_line ep = 0
  497  
  498        %cycle
  499           get (dcode)
  500           -> d(dcode) %if 1 <= dcode <= last dir code
  501           error ("spurious directive", dcode)
  502  
  503     d(dir used):
  504           ext used(getword) = non zero
  505           %continue
  506  
  507     d(dir ldef):
  508           tag = getword
  509           error ("too many labels", tag) %unless 0 < tag <= max tag
  510           t == def(tag)
  511           t_ca = getlong;    ! ca
  512           end == t_link %if list = 0
  513           t_link = list;  list = tag
  514           %continue
  515  
  516     d(dir pref):
  517     d(dir cref):
  518     d(dir uref):
  519           tag = getword
  520           error ("too many labels", n) %unless 0 < tag <= max tag
  521           error ("too many references", refs) %if refs = max ref
  522           refs = refs + 1;  r == ref(refs)
  523           r_tag = tag
  524           r_ca = getlong;                     ! ca
  525           r_flag = dcode - 3
  526           ref list = refs
  527           ref list == r_link
  528           %continue
  529  
  530     d(dir entry): ! define ep
  531           entry tag = getword
  532           %continue
  533  
  534     d(dir header):
  535           input directives
  536        %repeat
  537  
  538     d(dir end):
  539        proc_type = getlong
  540        proc_mask = getword&16_CFFC
  541        frame = -getlong
  542        proc_frame = frame;               ! frame size
  543        ldiag = getword
  544        proc_diag = ldiag
  545        error ("corrupt diags", diags) %if ldiag = 0 %and diags # 0
  546        proc_diag ep = dap;  dap = dap + ldiag
  547        proc_line ep = lap;  lap = lap + getword
  548        block tag = getword
  549        ! compute length of entry code sequence
  550        ecode = 2;                             ! for entry mask
  551        %if block tag = entry tag %and init # 0 %start
  552           ecode = ecode + 7;                  ! calls #0,l^init proc
  553        %finish
  554        %if proc_type # 0 %start
  555           ecode = ecode + 7;                  ! moval l^ep_,gla
  556        %finish
  557        ecode = ecode + 3;                     ! movl fp, base
  558        %if frame # 0 %start
  559           ! locals - needs frame + unass code
  560           unass code = 8;                     ! movc5 #0,(fp),(gla),s^#f,(sp)
  561           %if frame <= 63 %start
  562              !short lit - byte's worth
  563              ecode = ecode + 3;               ! subl2 i^#f, sp
  564              unass code = 6;                  ! movc5 #0,(fp),(gla),i^#f,(sp)
  565           %else %if frame <= 16_7fff
  566              !word's worth (sheer poetry)
  567              ecode = ecode + 5;               ! moval w^-f(sp), sp
  568           %else
  569              ecode = ecode + 7;               ! subl2 s^#f, sp
  570           %finish
  571           %if check ass # 0 %start
  572              ecode = ecode + unass code
  573              proc_mask = proc_mask ! 16_003C; ! r0-r5 corrupted by MOVC5!!!
  574           %finish
  575        %finish
  576        t == def(block tag)
  577        t_ca = t_ca - ecode
  578        base = base + ecode
  579  
  580     d(dir xend):  ! end of external proc
  581  
  582        tag = list
  583        %while tag # 0 %cycle
  584           t == def(tag)
  585           t_ca = t_ca + base
  586           tag = t_link
  587        %repeat
  588        %if list # 0 %start;                   ! add labels to def list
  589           end = def list
  590           def list = list
  591        %finish
  592        ref list = 0;                          ! mark the end
  593        rp = first
  594        %while rp # 0 %cycle
  595           r == ref(rp)
  596           r_ca = r_ca + base
  597           rp = r_link
  598        %repeat
  599        size = getlong;                        ! total size
  600        base = base + size
  601        %if first # 0 %start
  602           ref chain = first
  603           ref chain == ref list
  604           ref chain = 0
  605        %finish
  606        %return
  607  
  608     d(dir sizes):   ! end of directives, totals follow
  609        glap size  = getlong
  610        last tag   = getword
  611        specs      = getword
  612        diag size  = getword
  613        events     = getword
  614        proc tab(1)_diag ep = dap
  615        line size  = lap
  616     %end
?PROCHEAD unused
?Q unused
  617  
  618     %routine  STRETCH JUMPS
  619        %integer  extra, here, there, disp, mod, tag
  620        %integer %name  pt
  621        %short %name  last, next
  622        %record(ref fm) %name  r
  623        %record(def fm) %name  t
  624        %cycle
  625           extra = 0
  626           last == ref head
  627           %while last # 0 %cycle
  628              r == ref(last)
  629              next == r_link
  630              r_ca = r_ca + extra
  631              here = r_ca + 2
  632              there = def(r_tag)_ca
  633              disp = there - here
  634              mod = 0
  635              %if r_flag&middling = 0 %and
  636+                 %not -128 <= disp <= 127 %start
  637                 r_flag = r_flag!middling
  638  !********               %if safelow <= disp <= safe high %start
  639  !********                  ! will not stretch again
  640  !********                  last = next
  641  !********                  next == last
  642  !********               %finish
  643                 mod = 1;                      ! 1-byte -> 2-byte disp
  644                 mod = 3 %if r_flag&1 # 0;     ! conditional -> skip+brw
  645              %else %unless 16_FFFF8001 <= disp <= 16_8000
  646                 ! cannot get bigger
  647                 last = next
  648                 next == last
  649                 mod = 2;                      ! word disp -> longword disp
  650                 mod = 3 %if r_flag&3 # 0;     ! brw -> jmp
  651              %finish
  652              %if mod # 0 %start
  653                 tag = def list
  654                 %while tag # 0 %cycle
  655                    t == def(tag)
  656                    pt == t_ca
  657                    %exit %if pt < here
  658                    pt = pt + mod
  659                    tag = t_link
  660                 %repeat
  661                 extra = extra + mod
  662              %finish
  663              last == next
  664           %repeat
  665           base = base + extra
  666        %repeat %until extra = 0
  667        event base = (base+7)&(\7)
  668        evp = event base
  669        code size = event base + events*16 + 4
  670     %end
  671  
  672     %routine  DUMP CODE (%integer base, btag, limit)
  673        %switch  c (1 : last obj code)
  674        %own %byte %array  base mod (5 : 15)
  675        ! Code type enables pre-selection of the appropriate
  676        ! output buffer for each command code byte from Pass 2.
  677        %const %byte %array  code type (1 : last obj code) =
  678+          0, 0, 1, 0, 0,
  679+          1, 1, 1, 1, 0,
  680+          0, 0, 0, 0, 3,
  681+          0, 2, 2, 0, 0,
  682+          0, 1, 0, 0, 0
  683        %own %record(psect fm) %name %array  buff for (0 : 3)
  684        %own %integer  called = 0
  685  
  686        %integer  disp, cond
  687        %integer  ldiag, value
  688        %integer  ocode, type
  689        %integer  gb, gx, cx, xno, pno
  690        %integer  old ca, old la, old da
  691        %integer  count, size, n, save
  692        %integer  reg, specifier, mode
  693        %integer  evlow, evep, evword
  694        %integer  tag, lim, nbase
  695        %record(proc fm) %name  proc
  696  
  697        %routine  DUMP LINE
  698           buff == linep
  699           start immed (6)
  700           addl (ca);  addw (this line)
  701           end immed
  702        %end
  703  
  704        %routine  LOAD BLOCK
  705           %integer  n
  706           get (n);  start immed (n)
  707           get block (n, buff_b(buff_bp+1))
  708           buff_bp = buff_bp + n
  709           end immed
  710        %end
  711  
  712        %routine  SET PRIM TEXT (%integer  pno)
  713           text = "$_"
  714           text = text . "_" %and pno = pno - 26 %while pno > 26
  715           text = text . tostring ('A'-1+pno)
  716        %end
  717  
  718        %routine  PLUG GLAP (%record(psect fm) %name with,
  719+                            %integer with disp, where, inst)
  720           %integer  old ga = ga
  721           %unless 0 < where < glap size %start
  722              error ("faulty glap relocation", where)
  723           %finish
  724           buff == glapp;  select (where)
  725           need (7);                   ! Must have following in one record..
  726           stpb (with, with disp)
  727           add (inst)
  728           select (old ga)
  729        %end
  730  
  731        %routine  BSEL (%integername old, %record(psect fm) %name p,
  732+                       %integer  new)
  733           buff == p
  734           old = p_pa
  735           select (new)
  736        %end
  737  
  738        %routine  INITIALISE BUFFERS
  739           buff for(0) == codep
  740           buff for(1) == glapp
  741           buff for(2) == diagp
  742           buff for(3) == linep
  743           called = non zero
  744        %end
  745  
  746        %routine  HANDLE BLOCK ENTRY
  747           %integer  mask, unsaved, reg
  748           %integer  frame
  749           base = 13 %if base = 12;            ! bottom 2 levels
  750           dump line %if ldump # 0
  751           buff == codep
  752           ! Calculate true offset from FP of args to this proc
  753           ! for benefit of inner procs referencing them.  This
  754           ! is affected by the number of regs saved on the stack
  755           ! on proc call.  Pass 2 assumes all regs saved, we now
  756           ! calculate how many aren't, and subtract this*4 from
  757           ! displacement used by pass 2.
  758           mask = proc_mask;  unsaved = 0
  759           %for reg = 2, 1, 11 %cycle
  760              unsaved = unsaved + 1 %if mask & (1<<reg) = 0
  761           %repeat
  762           base mod(base) = unsaved*4;         ! to subtract off
  763           frame = proc_frame;                 ! frame size
  764           start immed (50);                   ! For entry sequence
  765           addw (mask);                        ! entry mask
  766           %if proc_type # 0 %start
  767              ! %external entry
  768              get string (text);               ! name
  769              %if entry tag = btag %and init # 0   %start
  770                 add (calls);  add (0);        ! calls  #0,init proc
  771                 end immed
  772                 stag (init proc);             ! spec reference
  773                 add (tir stopicr);            ! store it
  774                 ca = ca + 5
  775                 start immed (1)
  776              %finish
  777              add (moval);   end immed;        ! moval
  778              need (1+1+length(text)+1+1);
  779              stag (text."_");
  780              add (tir stopicr);               !        ep_,
  781              ca = ca + 5
  782              start immed (50);  add (16_5B);  !            gla
  783           %finish
  784           add (movl);                         ! movl
  785           add (16_5D);  add (16_50+base);     !        fp, base
  786           %if frame # 0 %start
  787              %if frame <= 63 %start
  788                 add (subl2);                  ! subl2
  789                 add (frame);                  !        S^#frame
  790              %else %if frame <= 16_7fff
  791                 add (movab);                  ! movab
  792                 add (16_CE);  addw (-frame);  !        W^-frame(sp)
  793              %else
  794                 add (subl2);                  ! subl2
  795                 add (16_8F);  addl (frame);   !        I^#frame
  796              %finish
  797              add (16_5E);                     !                    , SP
  798              %if check ass # 0 %start
  799                 add (movc5);  add (0);  add (16_6D);  add (16_6B)
  800                 %if frame <= 63 %start
  801                    add (frame)
  802                 %else
  803                    add (16_8F);  addw (frame&16_7FFF)
  804                 %finish
  805                 add (16_6E)
  806                 !movc5_#0,(fp),(gla), #N, (sp)
  807              %finish
  808           %finish
  809           end immed
  810        %end
  811  
  812        initialise buffers %if called = 0
  813        procs = procs + 1
  814        proc == proc tab(procs)
  815        bsel (old da, diagp, proc_diag ep)
  816        bsel (old la, linep, proc_line ep)
  817        bsel (old ca, codep, def(btag)_ca)
  818        handle block entry %if base # 0
  819  
  820        %cycle
  821           get (ocode)
  822           buff == buff for(code type(ocode))
  823           -> c(ocode) %if 0 < ocode <= 25
  824     c(*): error ("spurious object", ocode)
  825  
  826     c(obj diag p):
  827           n = getword
  828           get string (text)
  829           ldiag = proc_diag
  830           error ("corrupt diags", 0) %if ldiag = 0
  831           start immed (50)
  832           addw (ldiag);  addw (n);  addl (limit);  add text (0)
  833           end immed
  834           %continue
  835     c(obj diag v):
  836           start immed (50)
  837           addw (getword);  addl (getlong)
  838           get string (text);  add text (0)
  839           end immed
  840           %continue
  841     c(obj code):
  842           load block
  843           %continue
  844     c(obj modd):
  845           get (ocode);  error ("faulty mod", ocode) %if ocode # 2
  846           get (n);                            ! # bytes following
  847           start immed (n)
  848           get (specifier);   n = n - 1
  849           reg = specifier & 15
  850           add (specifier)
  851           %if n = 1 %start
  852              get (disp)
  853           %else %if n = 2
  854              disp = getword
  855           %else %if n = 4
  856              disp = getlong
  857           %else
  858              error ("faulty disp in mod", n)
  859           %finish
  860           disp = disp - base mod(reg)
  861           add (disp)
  862           add (disp>>8) %if n > 1
  863           addw (disp>>16) %if n = 4
  864           end immed
  865           %continue
  866     c(obj gla):
  867           gb = getlong
  868           error ("gla pos error", gb-ga) %if gb # ga
  869           load block
  870           %continue
  871     c(obj glam):
  872           gb = getlong
  873           error ("glam pos error", gb-ga) %if gb # ga
  874           value = getlong;                    ! value
  875           count = getlong;                    ! repeat count
  876           size  = getlong;                    ! bytes in object
  877           %if count*size > 15 %start
  878              ! Worth doing as 'store repeated' type
  879              stak (value)
  880              stak (count)
  881              need (1)
  882              %if size = 1 %start
  883                 add (tir sto rb)
  884              %else %if size = 2
  885                 add (tir sto rw)
  886              %else %if size = 4
  887                 add (tir sto rl)
  888              %else
  889                 error ("Faulty glam size", size)
  890              %finish
  891              ga = ga + count*size
  892           %else
  893              start immed (count*size)
  894              %for n = 1, 1, count %cycle
  895                 %if size = 1 %start
  896                    add (value)
  897                 %else %if size = 2
  898                    addw (value)
  899                 %else %if size = 4
  900                    addl (value)
  901                 %else
  902                    error ("Faulty glam size", size)
  903                 %finish
  904              %repeat
  905              end immed
  906           %finish
  907           %continue
  908     c(obj pdef): ! proc def
  909           tag = getlong
  910           get string (text)
  911           spec (2_1010, 0,
  912+                def(tag)_ca, proc_mask);      ! ep
  913           spec (2_1010, 1, 0, 0);             ! gla (ep_)
  914           %continue
  915     c(obj pspec): ! proc spec
  916           xno = getword
  917           get string (text)
  918           %if ext used(xno) # 0 %start;         ! strong code
  919              spec (2_1000, 0, 0, 0)
  920              ext text(xno) = text
  921           %finish
  922           %continue
  923     c(obj ddef): ! data def
  924           gx = getlong
  925           get string (text)
  926           spec (2_1010, -1, gx, 0);           ! Note -1 => special
  927           %continue
  928     c(obj weak):  ! weak ref
  929     c(obj dspec): ! data ref
  930           xno = getword
  931           get string (text)
  932           ext text(xno) = text
  933           mode = 2_1000;  mode = 2_1001 %if ocode = obj weak
  934           spec (mode, 0, 0, 0)
  935           %continue
  936     c(obj ext ref):
  937           xno = getword;                      ! External number
  938           disp = getlong;                     ! Offset
  939           get (reg);                          ! Base reg (+ indirect bit)?
  940           stag (ext text(xno));               ! External address
  941           %if disp # 0 %start
  942              stak (disp);   need (1);  add (tir add)
  943           %finish
  944           need (1);   add (tir stopicr);   ca = ca + 5
  945           %if reg&16 # 0 %start
  946              !indirect ref - won't work if absolute!!
  947              need (16)
  948              add (tir augrb);   addl (-5);    ! Go back to specifier byte
  949              add (tir staub);   add (16_FF);  ! stack byte 16_FF = @L^X(PC)
  950              add (tir stoub);                 ! store byte
  951              add (tir augrb);   addl (4);     ! return to correct ca
  952           %finish
  953           %continue
  954     c(obj reloc): ! relocate gla
  955  !         error ("Not PIC", 0) %if pic # 0
  956           gb = getlong;   gx = getlong
  957           plug glap (glapp, gx, gb, tir stopidr)
  958           %continue
  959     c(obj set): !set gla
  960           cx = def(getlong)_ca;           ! Switch label address
  961           gb = getlong;                       ! Gla address to plug
  962           plug glap (codep, cx+4, gb, tir stold)
  963           %continue
  964     c(obj header):
  965           get (nbase);                        ! base
  966           tag = getword;                      ! tag
  967           lim = getword
  968           this line = getword
  969           dump code (nbase, tag, def(lim)_ca)
  970           %continue
  971     c(obj call):
  972           tag = getlong
  973           disp = def(tag)_ca-ca-2
  974           start immed (5)
  975           n = range (disp, 1)
  976           %if n = 1 %start;
  977              add (16_AF);  add (disp)
  978           %else %if n = 2
  979              add (16_CF);  addw (disp-1)
  980           %else
  981              add (16_EF);  addl (disp-3)
  982           %finish
  983           end immed
  984           %continue
  985     c(obj jump): ! jump <cond> <tag>
  986           get (cond);  tag = getword
  987           cond = cond&15
  988           disp = def(tag)_ca-ca-2
  989           size = range (disp, 1)
  990           start immed (8)
  991           %if cond = 0 %start;          !unconditional
  992              %if size = 1 %start
  993                 add (brb);  add (disp)
  994              %else %if size = 2
  995                 add (brw);  addw (disp-1)
  996              %else
  997                 add (jmp);  add (16_EF);  addl (disp-4)
  998              %finish
  999           %else;                        !conditional
 1000              %if size = 1 %start
 1001                 add (branch(cond));   add (disp)
 1002              %else %if size = 2
 1003                 add (branch(cond!!7));  add (3)
 1004                 add (brw);  addw (disp-3)
 1005              %else
 1006                 add (branch(cond!!7));  add (6)
 1007                 add (jmp);  add (16_EF);  addl (disp-6)
 1008              %finish
 1009           %finish
 1010           end immed
 1011           %continue
 1012     c(obj b lab):  ! m/code byte label reference
 1013     c(obj w lab):  !  " " " word  " "  " " " "
 1014           disp = def(getword)_ca-ca-1
 1015           start immed (2)
 1016           %if ocode = obj w lab %start;          !word
 1017              addw (disp-1)
 1018           %else;                                 !byte
 1019              error ("branch overflow", disp) %unless -128 <= disp <= 127
 1020              add (disp)
 1021           %finish
 1022           end immed
 1023           %continue
 1024     c(obj prim spec):
 1025           get (pno);  set prim text (pno)
 1026           spec (2_1000, 0, 0, 0)
 1027           %continue
 1028     c(obj prim ref):
 1029           get (pno);  set prim text (pno)
 1030           %if pno # proc enter prim %start
 1031              start immed (1);  add (jsb);   end immed
 1032           %finish
 1033           stag (text)
 1034           need (1);  add (tir stopicr);  ca = ca + 5
 1035           %continue
 1036     c(obj line): ! line number
 1037           this line = getword
 1038           dump line %if ldump # 0
 1039        %repeat
 1040  
 1041     c(obj term):!block end
 1042        %if diagp_pa # 0 %start
 1043           buff == diagp
 1044           start immed (1);  add (0);  end immed
 1045        %finish
 1046        evword = getword;                        !events
 1047        %if evword # 0 %start;                   !events trapped
 1048           evlow = getword;                      !evlow
 1049           evep  = getword;                      !evep
 1050           buff == codep;  save = ca
 1051           select (evp)
 1052           start immed (16)
 1053           addl (evword);                        !ev list
 1054           addl (def(evlow)_ca);                 !from
 1055           addl (save);                          !to (ca)
 1056           addl (def(evep)_ca);                  !entry point
 1057           end immed
 1058           evp = evp + 16
 1059        %finish
 1060  
 1061     c(obj end):
 1062        bsel (n, diagp, old da)
 1063        bsel (n, linep, old la)
 1064        bsel (n, codep, old ca)
 1065     %end
?TYPE unused
 1066  
 1067     %routine  DUMP ALL CODE
 1068        select input tank (object)
 1069        procs = 0
 1070        dump code (0, 0, 0)
 1071     %end
 1072  
 1073     %routine  DEFINE PSECT (%record(psect fm) %name ps,
 1074+                            %integer  align, flags, size,
 1075+                            %string(31) name)
 1076        %own %integer  psect no = 0
 1077        set work (obj gsd)
 1078        add (gsd psc);            ! P-sect def field
 1079        add (align);              ! Align (as power of 2)
 1080        addw (flags);             ! P-sect flags (rd,wrt,exe etc)
 1081        addl (size);              ! Allocation in bytes
 1082        add string (0, name);     ! Ident
 1083        ps = 0
 1084        ps_dump = 1;  ps_type = obj tir;  ps_bp = 1
 1085        ps_max = size
 1086        ps_index = psect no
 1087        psect no = psect no + 1
 1088        flush buff
 1089        buff == ps;  ps_pa = -999;  ! ensure SELECT happens...
 1090        select (0)
 1091     %end
 1092  
 1093     %routine  DUMP MODULE HEADER
 1094        %string(31) temp
 1095        select output (object file)
 1096        set work (obj hdr);                   !header
 1097        add (hdr mhd);                        !module header record
 1098        add (0);                              !structure level
 1099        addw (max rec);                       !max record length
 1100        add string (0, module);               !module name
 1101        add string (0, "V01.00");             !module version
 1102        temp = date . " " . time
 1103        length(temp) = length(temp) - 3;      !remove milliseconds
 1104        add string (1, temp);                 !creation date
 1105        add string (1, "IMP is wonderful!");  !last patch!!
 1106        set work (obj hdr)
 1107        add (hdr lng);                        !language sub-header
 1108        add string (1, "VAX-11 Imp77 ".version)
 1109     %end
 1110  
 1111     %routine  DEFINE PSECTS
 1112        define psect (codep, quad, code flags, code size, code name)
 1113        define psect (glapp, quad, glap flags, glap size, glap name)
 1114        %if diags # 0 %start
 1115           define psect (diagp, quad, diag flags, diag size+2, diag name)
 1116           ! add 2 to ensure 0 word at end...
 1117        %else
 1118           diagp_dump = 0
 1119        %finish
 1120        %if ldump # 0 %start
 1121           define psect (linep, quad, line flags, line size, line name)
 1122           !fill in length word
 1123           buff == linep;  select (0)
 1124           start immed (2);  addw (line size);  end immed
 1125        %else
 1126           linep_dump = 0
 1127        %finish
 1128     %end
 1129  
 1130     %routine  INITIALISE
 1131        %integer  j
 1132        ext used(j) = 0 %for j = 1, 1, max externals
 1133        select input tank (directives)
 1134        refs = 0;  procs = 0;  def(0) = 0
 1135        ca == codep_pa;  ga == glapp_pa
 1136     %end
 1137  
 1138     %routine  SPEC INIT PROC
 1139        %return %if entry tag < 0 %or init = 0
 1140        set work (obj gsd)
 1141        add (gsd sym);             ! symbol entry
 1142        add (0);                   ! unknown data type
 1143        addw (2_1000);             ! flags
 1144        add string (0, init proc); ! name
 1145        flush buff
 1146     %end
 1147  
 1148     %routine  PLUG PSECTS
 1149        buff == glapp;  select (12);       ! plug things into gla
 1150        ! code psect base
 1151        need (50)
 1152        stpb (codep, 4);     add (tir stold)
 1153        ga = ga + 4
 1154        ! diags psect base
 1155        %if diags # 0 %start
 1156           stpb (diagp, 4)
 1157        %else
 1158           stak (4)
 1159        %finish
 1160        add (tir stold)
 1161        ga = ga + 4
 1162        ! lines psect base
 1163        %if ldump # 0 %start
 1164           stpb (linep, 4)
 1165        %else
 1166           stak (4)
 1167        %finish
 1168        add (tir stold)
 1169        ga = ga + 4
 1170        start immed (10)
 1171        addw (0);                         ! null string
 1172        addl (proc tab(1)_diag ep)
 1173        addl (event base)
 1174        end immed
 1175        buff == codep;  select (evp)
 1176        stak (0);  add (tir stol)
 1177        %if diags # 0 %start
 1178           buff == diagp;  select (diag size)
 1179           start immed (2);  addw (0);  end immed
 1180        %finish
 1181     %end
 1182  
 1183     %routine  DUMP EOM
 1184        set work (obj eom)
 1185        add (0);                            ! Successful compilation
 1186        %if entry tag >= 0 %start
 1187           add (0)
 1188           addl (def(entry tag)_ca)
 1189        %finish
 1190        flush buff
 1191     %end
 1192  
 1193     %routine  FLUSH BUFFERS
 1194        buff == codep;  flush buff
 1195        buff == glapp;  flush buff
 1196        buff == diagp;  flush buff
 1197        buff == linep;  flush buff
 1198        buff == workp;  flush buff
 1199     %end
 1200  
 1201     %routine  REPORT INFO
 1202        %integer  stream
 1203        %for stream = report, listing-report, listing %cycle
 1204           %continue %if clog = 0 %and stream = report
 1205           select output (stream)
 1206           print string ("Code");            write (codep_max-4, 1)
 1207           print string (" bytes  Glap");    write (glapp_max, 1)
 1208           print string (" bytes  Diags");   write (diagp_max+linep_max, 1)
 1209           print string (" bytes   Total size")
 1210           write (codep_max-4+glapp_max+diagp_max+linep_max, 1)
 1211           print string (" bytes");  newline
 1212        %repeat
 1213     %end
 1214  
 1215     %routine  TIME (%routine  R, %string(15) name)
 1216        %external %integer %function %spec  PAGEFAULTS
 1217        %integer  t, p
 1218        %own %integer  called = 0
 1219        p = page faults;   t = cputime
 1220        R
 1221        t = cputime - t;   p = pagefaults - p
 1222        %return %if timing = 0
 1223        select output (report)
 1224        print string ("Pass 3 breakdown:") %and newline %if called = 0
 1225        called = 1
 1226        spaces (3)
 1227        print string (name);  print symbol (':')
 1228        spaces (15-length(name));  space
 1229        %if t >= 20 %start
 1230           write (t, -5);  print string ("ms,    ")
 1231        %else
 1232           print string ("negligible, ")
 1233        %finish
 1234        write (p, -3);  print string (" page fault")
 1235        print symbol ('s') %if p # 1
 1236        newline
 1237        select output (object file)
 1238     %end
 1239  
 1240     ! MAIN CODE
 1241  
 1242     initialise
 1243     time (input directives, "Directive input")
 1244     time (stretch jumps, "Jump stretching")
 1245     dump module header
 1246     define psects
 1247     spec init proc
 1248     time (dump all code, "Code dumping")
 1249     plug psects
 1250     flush buffers
 1251     dump eom
 1252     report info
 1253  
 1254  %end
?OBJDBG unused
?TIRSTOGB unused
?TIRSTOW unused
?TIRSTOB unused
?SAFEHIGH unused
?SAFELOW unused
?PIC unused
 1255  
 1256  %BEGIN
 1257  %END
 1258  
 1259  %end %of %file

 1136 Statements compiled
