%externalstring(255)%fnspec date
%externalstring(255)%fnspec time
%systemroutinespec exit %alias "exit" (%integer rc)

%externalintegerfnspec cputime
%externalroutinespec getblock %alias "GETBLOCK_JSB" (%integer len, %bytename base)
%externalintegerfunctionspec getlong %alias "GETLONG_JSB"
%externalintegerfunctionspec getword %alias "GETWORD_JSB"
   %externalroutinespec get(%integername n)
   %externalroutinespec put(%integer n)
   %externalroutinespec putword(%integer n)
   %externalroutinespec putlong(%integer n)
   %externalroutinespec putblock(%integer len, %bytename b)
!   Computer Science IMP77 Compiler   -   Version 8  Third pass
!      23rd March 1981
!      Mods by MT October/November 1981
!
! Uses common include file defining constants,
! spec'ing common externals etc.
!
!!%include "control.imp"

{%systemroutinespec exit %alias "exit" (%integer s)
!%external %routine %spec  PUT (%integer n)
!%external %routine %spec  PUT WORD (%integer n)
!%external %routine %spec  PUT LONG (%integer n)
!%external %routine %spec  PUT BLOCK (%integer n, %bytename b)
%external %routine %spec  SELECT INPUT TANK (%integer n)
%external %routine %spec  SELECT OUTPUT TANK (%integer n)
!%external %routine %spec  GET (%integer %name ch)
!%external %routine %spec  GET BLOCK (%integer len, %byte %name b)
%external %routine %spec  PRINT RECORD (%integer len, %byte %name buff)
%external %integer %function %spec  LOOK
!%external %integer %function %spec  GETWORD
!%external %integer %function %spec  GETLONG
%external %integer %function %spec  TAG %alias "GETLONG";  ! For pass 2
%external %string(63) %function %spec  ITOS (%integer n, p)

! streams
%const %integer  report      = 0
%const %integer  object file = 1
%const %integer  listing     = 2
%const %integer  diag stream = listing

! miscellaneous
%const %integer  max ident = 31;        ! Length for external linkage
%const %integer  fatal = 16_1000002C;   ! Error exit code to VMS


! external data (defined in driver)
%external %string(6) %spec  version;    ! Compiler version string
%external %integer %spec  command
%external %integer %spec  control

! command bit meanings (set by command line)
%const %integer  diag bit  = 8_00004
%const %integer  line bit  = 8_00010
%const %integer  log bit   = 8_00020
%const %integer  time bit  = 8_01000
%const %integer  entry bit = 8_02000
%const %integer  init bit  = 8_04000
%const %integer  pic bit   = 8_10000

! control bit meanings  (%control n, or set by driver (/check= etc))
! bit set => check on

%const %integer  ass check  =   1;      ! unassigned checking
%const %integer  str check  =   2;      ! string capacity checking
%const %integer  for check  =   4;      ! %for checking
%const %integer  arr check  =   8;      ! array bound checking
%const %integer  ovf check  =  16;      ! integer overflow checking
%const %integer  rec round  = 128;      ! rounding in records (turns it on)
%const %integer  profiling  = 256;      ! call TRACE (line no) at bounds

! object file commands  Pass2 => Pass3

%const %integer  obj extern    = 1;     ! insert external entry
%const %integer  obj code      = 2;     ! code block
%const %integer  obj gla       = 3;     ! gla  block
%const %integer  obj pdef      = 4;     ! external proc definition
%const %integer  obj pspec     = 5;     ! external proc specification
%const %integer  obj ddef      = 6;     ! external data definition
%const %integer  obj dspec     = 7;     ! external data specification
%const %integer  obj reloc     = 8;     ! relocate gla
%const %integer  obj set       = 9;     ! set gla to tag address
%const %integer  obj header    = 10;    ! start of procedure
%const %integer  obj call      = 11;    ! procedure call
%const %integer  obj jump      = 12;    ! jump
%const %integer  obj prim spec = 13;    ! prim definition
%const %integer  obj end       = 14;    ! end of object file
%const %integer  obj line      = 15;    ! line number
%const %integer  obj term      = 16;    ! end of block
%const %integer  obj diag p    = 17;    ! diags for proc header
%const %integer  obj diag v    = 18;    ! diags for variable
%const %integer  obj weak      = 19
%const %integer  obj b lab     = 20;    ! bxxb in m/code
%const %integer  obj w lab     = 21;    ! bxxw in m/code
%const %integer  obj glam      = 22;    ! initialise n items in GLA
%const %integer  obj modd      = 23;    ! modify displacement
%const %integer  obj prim ref  = 24;    ! call to prim
%const %integer  obj ext ref   = 25;    ! call to external procedure
%const %integer  last obj code = 25

! directive file commands  Pass2 => Pass3

%const %integer  dir used      = 1;     ! external used
%const %integer  dir ldef      = 2;     ! label definition
%const %integer  dir pref      = 3;     ! procedure reference
%const %integer  dir cref      = 4;     ! conditional label reference
%const %integer  dir uref      = 5;     ! unconditional label reference
%const %integer  dir end       = 6;     ! end of procedure
%const %integer  dir sizes     = 7;     ! end of directives+sizes
%const %integer  dir x end     = 8;     ! end of external entry
%const %integer  dir header    = 9;     ! start of procedure
%const %integer  dir entry     = 10;    ! define entry label
%const %integer  last dir code = 10

%end %of %file

! Size constants
%const %integer  max tag       = 4000;        ! total tags in use
%const %integer  max ref       = 6000;        ! references to tags
%const %integer  max procs     =  600;        ! procedures in module
%const %integer  max externals =  400;        ! external defs/refs
%const %integer  max rec       =  512;        ! object record size

%external %routine  PASS3 (%string(63) module, %integer object, directives)
   %integer  check ass = control&ass check;      ! unassigned checking on
   %integer  diags     = command&diag bit;       ! dump diag psect
   %integer  ldump     = command&line bit;       ! dump lines (trace) psect
   %integer  pic       = command&pic bit;        ! PIC for gla
   %integer  init      = command&init bit;       ! initialisation needed
   %integer  timing    = command&time bit;       ! full timing report
   %integer  clog      = command&log bit;        ! summary to console

   %const %integer  proc enter prim = 13;        ! = "$_M"

   %const %integer  non zero = 1;                ! boolean

   ! Op-codes
   %const %integer  brb    = 16_11;              ! +127/-128
   %const %integer  brw    = 16_31;              ! +32767/-32768
   %const %integer  jmp    = 16_17;              ! anywhere...
   %const %integer  bneq   = 16_12, bnequ = 16_12
   %const %integer  beql   = 16_13, beqlu = 16_13
   %const %integer  bgtr   = 16_14
   %const %integer  bleq   = 16_15
   %const %integer  bgeq   = 16_18
   %const %integer  blss   = 16_19
   %const %integer  bgtru  = 16_1A
   %const %integer  blequ  = 16_1B
   %const %integer  bgequ  = 16_1E
   %const %integer  blssu  = 16_1F
   %const %integer  jsb    = 16_16
   %const %integer  calls  = 16_FB
   %const %integer  movl   = 16_D0
   %const %integer  moval  = 16_DE
   %const %integer  movab  = 16_9E
   %const %integer  subl2  = 16_C2
   %const %integer  movc5  = 16_2C

   ! Branch table - invert (branch (b)) = branch(b!!7)
   %const %byte %array  branch (0 : 15) =
      brb,   beql,  blss,  bleq,  bgtr,  bgeq,  bneq,   0,      {signed}
    { u/c     =      <      <=     >      >=      #   never }
      brb,   beqlu, blssu, blequ, bgtru, bgequ, bnequ,  0       {unsigned}


   %const %integer  margin   = 800;              ! stretch margin for jumps
   %const %integer  safe low = 16_ffff8001+margin
   %const %integer  safe high= 16_00008000-margin

   %const %integer  middling = 16_1000;          ! word disp ref

   ! Object record constants

   %const %integer  obj hdr = 0
   %const %integer      hdr mhd = 0;             ! module header
   %const %integer      hdr lng = 1;             ! language sub-header

   %const %integer  obj gsd = 1
   %const %integer      gsd psc = 0;             ! P-sect def
   %const %integer      gsd sym = 1;             ! Symbol (def/ref)
   %const %integer      gsd epm = 2;             ! Ext def + mask

   %const %integer  obj tir = 2
   %const %integer      tir stag    = 0;         ! Stack global symbol
   %const %integer      tir stasb   = 1;         ! Stack signed byte
   %const %integer      tir stasw   = 2
   %const %integer      tir stal    = 3
   %const %integer      tir stpbb   = 4
   %const %integer      tir stpbw   = 5
   %const %integer      tir stpbl   = 6
   %const %integer      tir staub   = 7;         ! Stack unsigned byte
   %const %integer      tir stob    = 20;        ! Store signed byte
   %const %integer      tir stow    = 21;        ! Store signed word
   %const %integer      tir stol    = 22;        ! Store longword
   %const %integer      tir stold   = 25;        ! Store longword
   %const %integer      tir stopidr = 27;        ! Store PIC data reference
   %const %integer      tir stopicr = 28;        ! Store PIC reference
   %const %integer      tir sto rl  = 31;        ! Store repeated long
   %const %integer      tir stoub   = 33;        ! Store unsigned byte
   %const %integer      tir stogb   = 37;        ! Store general byte
   %const %integer      tir sto rb  = 39;        ! Store repeated byte
   %const %integer      tir sto rw  = 40;        ! Store repeated word
   %const %integer      tir add     = 51
   %const %integer      tir setrb   = 80
   %const %integer      tir augrb   = 81

   %const %integer  obj eom = 3
   %const %integer  obj dbg = 4

   !P-sect info

   %const %integer  quad = 3;                    ! 8(=2**3)-byte alignment

   %const %integer  ps pic = 1<<0
   %const %integer  ps rel = 1<<3
   %const %integer  ps shr = 1<<5
   %const %integer  ps exe = 1<<6
   %const %integer  ps rd  = 1<<7
   %const %integer  ps wrt = 1<<8

   %own %integer %name  ca
   %own %integer %name  ga
   %own %integer  base        =  0
   %own %short    ref head    =  0
   %own %short %name  ref chain;   ref chain == ref head
   %own %short    def list    =  0;      !ordered list of labels
   %own %integer  this line   =  0
   %own %integer  entry tag   = -1

   %const %integer  code flags = ps pic ! ps rel ! ps rd  ! ps exe ! ps shr
   %own   %integer  glap flags = ps rd  ! ps wrt ! ps rel ! ps pic
!                    glap flags = glap flags ! ps pic %if pic # 0
   %const %integer  diag flags = ps pic ! ps rel ! ps rd  ! ps shr
   %const %integer  line flags = ps pic ! ps rel ! ps rd  ! ps shr

   %const %string(10)  code name = "$_CODEAREA"
   %own   %string(10)  glap name = "$_GLAPAREA"
!                       glap name = "$_GLAPPIC"
   %const %string(10)  diag name = "$_DIAGAREA"
   %const %string(10)  line name = "$_CODELINE"
   %const %string(10)  init proc = "IMP$_INIT"

   %integer  refs, last tag
   %integer  code size, glap size, diag size, line size
   %integer  procs, events, event base, evp, specs
   %own %string(max ident)  text

   %record %format  psect fm (%integer bp, pa, dump, bs, lr, lrp,
                              %integer index, lbs, bb, be, max,
                              (%byte type %or
                               %byte %array b (1 : maxrec)))
   %own %record(psect fm)  codep, glapp, workp, diagp, linep
   %own %record(psect fm) %name  buff;     ! Points at one of above

   %record %format  ref fm (%integer ca, tag, %short flag, link)
   %record %format  def fm (%integer ca, %short uses, link)
   %record(def fm) %array  def (0 : max tag)
   %record(ref fm) %array  ref (1 : max ref)

   %record %format  proc fm (%integer frame,
                             %short type, mask, diag, diag ep, line ep)
   %record(proc fm) %array  proc tab (1 : max procs)

   %byte              %array  ext used (1 : max externals)
   %string(max ident) %array  ext text (1 : max externals)


   %routine  ERROR (%string(31) text, %integer extra)
      select output (report)
      newline
      print string ("***Pass3 fails """);  print string (text)
      print string (""" (");  write (extra, 0);  print symbol (')')
      newline
      %monitor
      exit (16_1000002c)     {1000002c is SS$_ABORT with the inhibit message bit set - could just use EXIT_FAILURE}
   %end

   %routine  GET STRING (%string(*) %name  t)
      %integer  len, file len
      get (len)
      file len = len
      error ("external size?", len) %unless 0 < len <= max ident
      len = len - 1 %if len = max ident {make room for '_' in Gla name}
      length(t) = len
      getblock (file len, charno(t,1))
   %end

   %routine %spec  STPB (%record(psect fm) %name p, %integer d)
   %routine %spec  ADD (%integer b)
   %routine  FLUSH BUFF
      %integer %name  bp
      bp == buff_bp
      %if bp > max rec %start
         ! over the limits!
         error ("buffer error - seek help!!", bp-maxrec)
      %finish
      %if buff_dump # 0 %start
         error ("buffer error", 1) %if buff_bs > 0;  ! Still in IMMED mode
         %if bp > 1 %start
            print record (bp, buff_b(1))
         %finish
      %finish
      buff_bs = 0;  buff_be = 0;  buff_lbs = 0;  buff_lr = 0
      bp = 1;                   ! leave type field
      %if buff_type = obj tir %and buff_dump # 0 %start
         ! fill in reloc command
         stpb (buff, buff_pa);  add (tir setrb)
         buff_lr = buff_bp;  buff_lrp = 1
      %finish
   %end

   %routine  NEED (%integer  b)
      ! ensure there are at least b bytes free in current buffer
      flush buff %if buff_bp + b > max rec
   %end

   %routine  SET WORK (%integer type)
      buff == workp;  flush buff
      workp = 0;  workp_dump = 1
      workp_type = type;  workp_bp = 1
   %end

   %routine  ADD (%integer b)
      %return %if buff_dump = 0
      buff_bp = buff_bp + 1;  buff_b(buff_bp) = b&255
   %end

   %routine  ADDW (%integer n)
      %return %if buff_dump = 0
      shortinteger(addr(buff_b(buff_bp+1))) = n
      buff_bp = buff_bp + 2
   %end

   %routine  ADDL (%integer n)
      %return %if buff_dump = 0
      integer(addr(buff_b(buff_bp+1))) = n
      buff_bp = buff_bp + 4
   %end

   %routine  ADD STRING (%integer from, %string(63) s)
      %integer b, l
      %return %if buff_dump = 0
      l = length(s)
      %if from = 0 %start
         string(addr(buff_b(buff_bp+1))) = s
         buff_bp = buff_bp + 1
      %else
         b = buff_b(buff_bp)
         string(addr(buff_b(buff_bp))) = s
         buff_b(buff_bp) = b
      %finish
      buff_bp = buff_bp + l
   %end

   %routine  ADD TEXT (%integer data)
      %string(max ident) t = text
      %return %if buff_dump = 0
      t = t . "_" %if data # 0
      add string (0, t)
   %end

   %integer %function  RANGE (%integer disp, extra)
      %result = 1 %if -128 <= disp <= 127
      %result = 2 %if 16_FFFF8000 <= disp-extra <= 16_7FFF
      %result = 4
   %end

   %routine  STAG (%string(max ident+3) S)
      need (1+1+length(S))
      add (tir stag);   add string (0, S)
   %end

   %routine  TIR COMMAND (%integername value, %integer param,
                          %byte %array %name  clist)
      %integer  size
      size = range (value, 0)
      need (2+size)
      add (clist(size))
      add (param) %if param >= 0
      %if size = 1 %start
         add (value)
      %else %if size = 2
         addw (value)
      %else
         addl (value)
      %finish
      value = size
   %end

   %routine  STPB (%record(psect fm) %name p, %integer offset)
      %own %byte %array  stpbc (1 : 4) =
         tir stpbb, tir stpbw, 0, tir stpbl
      tir command (offset, p_index, stpbc)
   %end

   %routine  STAK (%integer  value)
      %own %byte %array  stac (1 : 4) =
         tir stasb,  tir stasw, 0, tir stal
      tir command (value, -1, stac)
   %end

   %routine  SELECT (%integer disp)
      %return %if buff_dump = 0
      need (7);                 ! Sequence must be in one record!
      error ("psect overflow", disp) %if disp > buff_max
      %if buff_lr = buff_bp %start
         ! Have not planted anything since last 'select'
         buff_bp = buff_lrp;    ! Forget last select
         buff_pa = -20;         ! Ensure this one planted!
      %finish
      %if buff_pa # disp %start
         buff_lrp = buff_bp
         stpb (buff, disp)
         add (tir setrb)
         buff_lr = buff_bp
         buff_pa = disp
      %finish
   %end

   %routine  START IMMED (%integer max)
      %return %if buff_dump = 0
      error ("buffer in use", 0) %if buff_bs # 0
      error ("immediate size error", max) %if max > 128
      need (max+1)
      %if buff_be = buff_bp %and
          max + (buff_bp - buff_lbs) <= 128 %start
         ! Can concatenate buffers
         buff_bs = buff_lbs
      %else
         add (0);                            ! Length byte
         buff_bs = buff_bp
      %finish
      buff_bb = buff_bp;                     ! Where this block started
   %end

   %routine  END IMMED
      %integer  size
      %return %if buff_dump = 0
      error ("buffer not in use", 0) %if buff_bs = 0
      size = buff_bp - buff_bs
      %if size # 0 %start
         error ("buffer overflow", size) %if size > 128
         buff_b(buff_bs) = -size
         buff_lbs = buff_bs
         buff_be = buff_bp
      %else
         buff_bp = buff_bp - 1
      %finish
      buff_pa = buff_pa + buff_bp - buff_bb; ! Update psect disp.
      error ("Psect immediate overflow", 0) %if buff_pa > buff_max
      buff_bs = 0;                           ! Not buffering now
   %end

   %routine  SPEC (%integer flags, data, value, mask)
      %integer  def, len, psect
      psect = |data|
      data = 0 %if data < 0;                  ! no '_' for ext data def
      def = flags&2
      len = (1+1)+(data+length(text))
      len = len + 7 %if def # 0
      set work (obj gsd)
      %if def = 0 %start
         add (gsd sym)
      %else
         add (gsd epm)
      %finish
      add (0);                               ! data type - unknown
      addw (flags);                          ! symbol flags
      %if def # 0 %start;                    ! definition
         add (psect)
         addl (value)
         addw (mask)
      %finish
      add text (data)
   %end

   %routine  INPUT DIRECTIVES
      %switch  d (1 : last dir code)
      %short  first = 0, list = 0
      %short %name  ref list == first, end
      %record(proc fm) %name  proc
      %record(ref fm)  %name  r
      %record(def fm)  %name  t
      %integer %name  q
      %integer  proc head, n, frame, ldiag
      %integer  ecode, unass code, size
      %integer  rp, tag, block tag, dcode
      %own %integer  dap = 0, lap = 2

      procs = procs + 1
      proc == proc tab(procs)
      proc_diag ep = 0
      proc_line ep = 0

      %cycle
         get (dcode)
         -> d(dcode) %if 1 <= dcode <= last dir code
         error ("spurious directive", dcode)

   d(dir used):
         ext used(getword) = non zero
         %continue

   d(dir ldef):
         tag = getword
         error ("too many labels", tag) %unless 0 < tag <= max tag
         t == def(tag)
         t_ca = getlong;    ! ca
         end == t_link %if list = 0
         t_link = list;  list = tag
         %continue

   d(dir pref):
   d(dir cref):
   d(dir uref):
         tag = getword
         error ("too many labels", n) %unless 0 < tag <= max tag
         error ("too many references", refs) %if refs = max ref
         refs = refs + 1;  r == ref(refs)
         r_tag = tag
         r_ca = getlong;                     ! ca
         r_flag = dcode - 3
         ref list = refs
         ref list == r_link
         %continue

   d(dir entry): ! define ep
         entry tag = getword
         %continue

   d(dir header):
         input directives
      %repeat

   d(dir end):
      proc_type = getlong
      proc_mask = getword&16_CFFC
      frame = -getlong
      proc_frame = frame;               ! frame size
      ldiag = getword
      proc_diag = ldiag
      error ("corrupt diags", diags) %if ldiag = 0 %and diags # 0
      proc_diag ep = dap;  dap = dap + ldiag
      proc_line ep = lap;  lap = lap + getword
      block tag = getword
      ! compute length of entry code sequence
      ecode = 2;                             ! for entry mask
      %if block tag = entry tag %and init # 0 %start
         ecode = ecode + 7;                  ! calls #0,l^init proc
      %finish
      %if proc_type # 0 %start
         ecode = ecode + 7;                  ! moval l^ep_,gla
      %finish
      ecode = ecode + 3;                     ! movl fp, base
      %if frame # 0 %start
         ! locals - needs frame + unass code
         unass code = 8;                     ! movc5 #0,(fp),(gla),s^#f,(sp)
         %if frame <= 63 %start
            !short lit - byte's worth
            ecode = ecode + 3;               ! subl2 i^#f, sp
            unass code = 6;                  ! movc5 #0,(fp),(gla),i^#f,(sp)
         %else %if frame <= 16_7fff
            !word's worth (sheer poetry)
            ecode = ecode + 5;               ! moval w^-f(sp), sp
         %else
            ecode = ecode + 7;               ! subl2 s^#f, sp
         %finish
         %if check ass # 0 %start
            ecode = ecode + unass code
            proc_mask = proc_mask ! 16_003C; ! r0-r5 corrupted by MOVC5!!!
         %finish
      %finish
      t == def(block tag)
      t_ca = t_ca - ecode
      base = base + ecode

   d(dir xend):  ! end of external proc

      tag = list
      %while tag # 0 %cycle
         t == def(tag)
         t_ca = t_ca + base
         tag = t_link
      %repeat
      %if list # 0 %start;                   ! add labels to def list
         end = def list
         def list = list
      %finish
      ref list = 0;                          ! mark the end
      rp = first
      %while rp # 0 %cycle
         r == ref(rp)
         r_ca = r_ca + base
         rp = r_link
      %repeat
      size = getlong;                        ! total size
      base = base + size
      %if first # 0 %start
         ref chain = first
         ref chain == ref list
         ref chain = 0
      %finish
      %return

   d(dir sizes):   ! end of directives, totals follow
      glap size  = getlong
      last tag   = getword
      specs      = getword
      diag size  = getword
      events     = getword
      proc tab(1)_diag ep = dap
      line size  = lap
   %end

   %routine  STRETCH JUMPS
      %integer  extra, here, there, disp, mod, tag
      %integer %name  pt
      %short %name  last, next
      %record(ref fm) %name  r
      %record(def fm) %name  t
      %cycle
         extra = 0
         last == ref head
         %while last # 0 %cycle
            r == ref(last)
            next == r_link
            r_ca = r_ca + extra
            here = r_ca + 2
            there = def(r_tag)_ca
            disp = there - here
            mod = 0
            %if r_flag&middling = 0 %and
                %not -128 <= disp <= 127 %start
               r_flag = r_flag!middling
!********               %if safelow <= disp <= safe high %start
!********                  ! will not stretch again
!********                  last = next
!********                  next == last
!********               %finish
               mod = 1;                      ! 1-byte -> 2-byte disp
               mod = 3 %if r_flag&1 # 0;     ! conditional -> skip+brw
            %else %unless 16_FFFF8001 <= disp <= 16_8000
               ! cannot get bigger
               last = next
               next == last
               mod = 2;                      ! word disp -> longword disp
               mod = 3 %if r_flag&3 # 0;     ! brw -> jmp
            %finish
            %if mod # 0 %start
               tag = def list
               %while tag # 0 %cycle
                  t == def(tag)
                  pt == t_ca
                  %exit %if pt < here
                  pt = pt + mod
                  tag = t_link
               %repeat
               extra = extra + mod
            %finish
            last == next
         %repeat
         base = base + extra
      %repeat %until extra = 0
      event base = (base+7)&(\7)
      evp = event base
      code size = event base + events*16 + 4
   %end

   %routine  DUMP CODE (%integer base, btag, limit)
      %switch  c (1 : last obj code)
      %own %byte %array  base mod (5 : 15)
      ! Code type enables pre-selection of the appropriate
      ! output buffer for each command code byte from Pass 2.
      %const %byte %array  code type (1 : last obj code) =
         0, 0, 1, 0, 0,
         1, 1, 1, 1, 0,
         0, 0, 0, 0, 3,
         0, 2, 2, 0, 0,
         0, 1, 0, 0, 0
      %own %record(psect fm) %name %array  buff for (0 : 3)
      %own %integer  called = 0

      %integer  disp, cond
      %integer  ldiag, value
      %integer  ocode, type
      %integer  gb, gx, cx, xno, pno
      %integer  old ca, old la, old da
      %integer  count, size, n, save
      %integer  reg, specifier, mode
      %integer  evlow, evep, evword
      %integer  tag, lim, nbase
      %record(proc fm) %name  proc

      %routine  DUMP LINE
         buff == linep
         start immed (6)
         addl (ca);  addw (this line)
         end immed
      %end

      %routine  LOAD BLOCK
         %integer  n
         get (n);  start immed (n)
         get block (n, buff_b(buff_bp+1))
         buff_bp = buff_bp + n
         end immed
      %end

      %routine  SET PRIM TEXT (%integer  pno)
         text = "$_"
         text = text . "_" %and pno = pno - 26 %while pno > 26
         text = text . tostring ('A'-1+pno)
      %end

      %routine  PLUG GLAP (%record(psect fm) %name with,
                           %integer with disp, where, inst)
         %integer  old ga = ga
         %unless 0 < where < glap size %start
            error ("faulty glap relocation", where)
         %finish
         buff == glapp;  select (where)
         need (7);                   ! Must have following in one record..
         stpb (with, with disp)
         add (inst)
         select (old ga)
      %end

      %routine  BSEL (%integername old, %record(psect fm) %name p,
                      %integer  new)
         buff == p
         old = p_pa
         select (new)
      %end

      %routine  INITIALISE BUFFERS
         buff for(0) == codep
         buff for(1) == glapp
         buff for(2) == diagp
         buff for(3) == linep
         called = non zero
      %end

      %routine  HANDLE BLOCK ENTRY
         %integer  mask, unsaved, reg
         %integer  frame
         base = 13 %if base = 12;            ! bottom 2 levels
         dump line %if ldump # 0
         buff == codep
         ! Calculate true offset from FP of args to this proc
         ! for benefit of inner procs referencing them.  This
         ! is affected by the number of regs saved on the stack
         ! on proc call.  Pass 2 assumes all regs saved, we now
         ! calculate how many aren't, and subtract this*4 from
         ! displacement used by pass 2.
         mask = proc_mask;  unsaved = 0
         %for reg = 2, 1, 11 %cycle
            unsaved = unsaved + 1 %if mask & (1<<reg) = 0
         %repeat
         base mod(base) = unsaved*4;         ! to subtract off
         frame = proc_frame;                 ! frame size
         start immed (50);                   ! For entry sequence
         addw (mask);                        ! entry mask
         %if proc_type # 0 %start
            ! %external entry
            get string (text);               ! name
            %if entry tag = btag %and init # 0   %start
               add (calls);  add (0);        ! calls  #0,init proc
               end immed
               stag (init proc);             ! spec reference
               add (tir stopicr);            ! store it
               ca = ca + 5
               start immed (1)
            %finish
            add (moval);   end immed;        ! moval
            need (1+1+length(text)+1+1);
            stag (text."_");
            add (tir stopicr);               !        ep_,
            ca = ca + 5
            start immed (50);  add (16_5B);  !            gla
         %finish
         add (movl);                         ! movl
         add (16_5D);  add (16_50+base);     !        fp, base
         %if frame # 0 %start
            %if frame <= 63 %start
               add (subl2);                  ! subl2
               add (frame);                  !        S^#frame
            %else %if frame <= 16_7fff
               add (movab);                  ! movab
               add (16_CE);  addw (-frame);  !        W^-frame(sp)
            %else
               add (subl2);                  ! subl2
               add (16_8F);  addl (frame);   !        I^#frame
            %finish
            add (16_5E);                     !                    , SP
            %if check ass # 0 %start
               add (movc5);  add (0);  add (16_6D);  add (16_6B)
               %if frame <= 63 %start
                  add (frame)
               %else
                  add (16_8F);  addw (frame&16_7FFF)
               %finish
               add (16_6E)
               !movc5_#0,(fp),(gla), #N, (sp)
            %finish
         %finish
         end immed
      %end

      initialise buffers %if called = 0
      procs = procs + 1
      proc == proc tab(procs)
      bsel (old da, diagp, proc_diag ep)
      bsel (old la, linep, proc_line ep)
      bsel (old ca, codep, def(btag)_ca)
      handle block entry %if base # 0

      %cycle
         get (ocode)
         buff == buff for(code type(ocode))
         -> c(ocode) %if 0 < ocode <= 25
   c(*): error ("spurious object", ocode)

   c(obj diag p):
         n = getword
         get string (text)
         ldiag = proc_diag
         error ("corrupt diags", 0) %if ldiag = 0
         start immed (50)
         addw (ldiag);  addw (n);  addl (limit);  add text (0)
         end immed
         %continue
   c(obj diag v):
         start immed (50)
         addw (getword);  addl (getlong)
         get string (text);  add text (0)
         end immed
         %continue
   c(obj code):
         load block
         %continue
   c(obj modd):
         get (ocode);  error ("faulty mod", ocode) %if ocode # 2
         get (n);                            ! # bytes following
         start immed (n)
         get (specifier);   n = n - 1
         reg = specifier & 15
         add (specifier)
         %if n = 1 %start
            get (disp)
         %else %if n = 2
            disp = getword
         %else %if n = 4
            disp = getlong
         %else
            error ("faulty disp in mod", n)
         %finish
         disp = disp - base mod(reg)
         add (disp)
         add (disp>>8) %if n > 1
         addw (disp>>16) %if n = 4
         end immed
         %continue
   c(obj gla):
         gb = getlong
         error ("gla pos error", gb-ga) %if gb # ga
         load block
         %continue
   c(obj glam):
         gb = getlong
         error ("glam pos error", gb-ga) %if gb # ga
         value = getlong;                    ! value
         count = getlong;                    ! repeat count
         size  = getlong;                    ! bytes in object
         %if count*size > 15 %start
            ! Worth doing as 'store repeated' type
            stak (value)
            stak (count)
            need (1)
            %if size = 1 %start
               add (tir sto rb)
            %else %if size = 2
               add (tir sto rw)
            %else %if size = 4
               add (tir sto rl)
            %else
               error ("Faulty glam size", size)
            %finish
            ga = ga + count*size
         %else
            start immed (count*size)
            %for n = 1, 1, count %cycle
               %if size = 1 %start
                  add (value)
               %else %if size = 2
                  addw (value)
               %else %if size = 4
                  addl (value)
               %else
                  error ("Faulty glam size", size)
               %finish
            %repeat
            end immed
         %finish
         %continue
   c(obj pdef): ! proc def
         tag = getlong
         get string (text)
         spec (2_1010, 0,
               def(tag)_ca, proc_mask);      ! ep
         spec (2_1010, 1, 0, 0);             ! gla (ep_)
         %continue
   c(obj pspec): ! proc spec
         xno = getword
         get string (text)
         %if ext used(xno) # 0 %start;         ! strong code
            spec (2_1000, 0, 0, 0)
            ext text(xno) = text
         %finish
         %continue
   c(obj ddef): ! data def
         gx = getlong
         get string (text)
         spec (2_1010, -1, gx, 0);           ! Note -1 => special
         %continue
   c(obj weak):  ! weak ref
   c(obj dspec): ! data ref
         xno = getword
         get string (text)
         ext text(xno) = text
         mode = 2_1000;  mode = 2_1001 %if ocode = obj weak
         spec (mode, 0, 0, 0)
         %continue
   c(obj ext ref):
         xno = getword;                      ! External number
         disp = getlong;                     ! Offset
         get (reg);                          ! Base reg (+ indirect bit)?
         stag (ext text(xno));               ! External address
         %if disp # 0 %start
            stak (disp);   need (1);  add (tir add)
         %finish
         need (1);   add (tir stopicr);   ca = ca + 5
         %if reg&16 # 0 %start
            !indirect ref - won't work if absolute!!
            need (16)
            add (tir augrb);   addl (-5);    ! Go back to specifier byte
            add (tir staub);   add (16_FF);  ! stack byte 16_FF = @L^X(PC)
            add (tir stoub);                 ! store byte
            add (tir augrb);   addl (4);     ! return to correct ca
         %finish
         %continue
   c(obj reloc): ! relocate gla
!         error ("Not PIC", 0) %if pic # 0
         gb = getlong;   gx = getlong
         plug glap (glapp, gx, gb, tir stopidr)
         %continue
   c(obj set): !set gla
         cx = def(getlong)_ca;           ! Switch label address
         gb = getlong;                       ! Gla address to plug
         plug glap (codep, cx+4, gb, tir stold)
         %continue
   c(obj header):
         get (nbase);                        ! base
         tag = getword;                      ! tag
         lim = getword
         this line = getword
         dump code (nbase, tag, def(lim)_ca)
         %continue
   c(obj call):
         tag = getlong
         disp = def(tag)_ca-ca-2
         start immed (5)
         n = range (disp, 1)
         %if n = 1 %start;
            add (16_AF);  add (disp)
         %else %if n = 2
            add (16_CF);  addw (disp-1)
         %else
            add (16_EF);  addl (disp-3)
         %finish
         end immed
         %continue
   c(obj jump): ! jump <cond> <tag>
         get (cond);  tag = getword
         cond = cond&15
         disp = def(tag)_ca-ca-2
         size = range (disp, 1)
         start immed (8)
         %if cond = 0 %start;          !unconditional
            %if size = 1 %start
               add (brb);  add (disp)
            %else %if size = 2
               add (brw);  addw (disp-1)
            %else
               add (jmp);  add (16_EF);  addl (disp-4)
            %finish
         %else;                        !conditional
            %if size = 1 %start
               add (branch(cond));   add (disp)
            %else %if size = 2
               add (branch(cond!!7));  add (3)
               add (brw);  addw (disp-3)
            %else
               add (branch(cond!!7));  add (6)
               add (jmp);  add (16_EF);  addl (disp-6)
            %finish
         %finish
         end immed
         %continue
   c(obj b lab):  ! m/code byte label reference
   c(obj w lab):  !  " " " word  " "  " " " "
         disp = def(getword)_ca-ca-1
         start immed (2)
         %if ocode = obj w lab %start;          !word
            addw (disp-1)
         %else;                                 !byte
            error ("branch overflow", disp) %unless -128 <= disp <= 127
            add (disp)
         %finish
         end immed
         %continue
   c(obj prim spec):
         get (pno);  set prim text (pno)
         spec (2_1000, 0, 0, 0)
         %continue
   c(obj prim ref):
         get (pno);  set prim text (pno)
         %if pno # proc enter prim %start
            start immed (1);  add (jsb);   end immed
         %finish
         stag (text)
         need (1);  add (tir stopicr);  ca = ca + 5
         %continue
   c(obj line): ! line number
         this line = getword
         dump line %if ldump # 0
      %repeat

   c(obj term):!block end
      %if diagp_pa # 0 %start
         buff == diagp
         start immed (1);  add (0);  end immed
      %finish
      evword = getword;                        !events
      %if evword # 0 %start;                   !events trapped
         evlow = getword;                      !evlow
         evep  = getword;                      !evep
         buff == codep;  save = ca
         select (evp)
         start immed (16)
         addl (evword);                        !ev list
         addl (def(evlow)_ca);                 !from
         addl (save);                          !to (ca)
         addl (def(evep)_ca);                  !entry point
         end immed
         evp = evp + 16
      %finish

   c(obj end):
      bsel (n, diagp, old da)
      bsel (n, linep, old la)
      bsel (n, codep, old ca)
   %end

   %routine  DUMP ALL CODE
      select input tank (object)
      procs = 0
      dump code (0, 0, 0)
   %end

   %routine  DEFINE PSECT (%record(psect fm) %name ps,
                           %integer  align, flags, size,
                           %string(31) name)
      %own %integer  psect no = 0
      set work (obj gsd)
      add (gsd psc);            ! P-sect def field
      add (align);              ! Align (as power of 2)
      addw (flags);             ! P-sect flags (rd,wrt,exe etc)
      addl (size);              ! Allocation in bytes
      add string (0, name);     ! Ident
      ps = 0
      ps_dump = 1;  ps_type = obj tir;  ps_bp = 1
      ps_max = size
      ps_index = psect no
      psect no = psect no + 1
      flush buff
      buff == ps;  ps_pa = -999;  ! ensure SELECT happens...
      select (0)
   %end

   %routine  DUMP MODULE HEADER
      %string(31) temp
      select output (object file)
      set work (obj hdr);                   !header
      add (hdr mhd);                        !module header record
      add (0);                              !structure level
      addw (max rec);                       !max record length
      add string (0, module);               !module name
      add string (0, "V01.00");             !module version
      temp = date . " " . time
      length(temp) = length(temp) - 3;      !remove milliseconds
      add string (1, temp);                 !creation date
      add string (1, "IMP is wonderful!");  !last patch!!
      set work (obj hdr)
      add (hdr lng);                        !language sub-header
      add string (1, "VAX-11 Imp77 ".version)
   %end

   %routine  DEFINE PSECTS
      define psect (codep, quad, code flags, code size, code name)
      define psect (glapp, quad, glap flags, glap size, glap name)
      %if diags # 0 %start
         define psect (diagp, quad, diag flags, diag size+2, diag name)
         ! add 2 to ensure 0 word at end...
      %else
         diagp_dump = 0
      %finish
      %if ldump # 0 %start
         define psect (linep, quad, line flags, line size, line name)
         !fill in length word
         buff == linep;  select (0)
         start immed (2);  addw (line size);  end immed
      %else
         linep_dump = 0
      %finish
   %end

   %routine  INITIALISE
      %integer  j
      ext used(j) = 0 %for j = 1, 1, max externals
      select input tank (directives)
      refs = 0;  procs = 0;  def(0) = 0
      ca == codep_pa;  ga == glapp_pa
   %end

   %routine  SPEC INIT PROC
      %return %if entry tag < 0 %or init = 0
      set work (obj gsd)
      add (gsd sym);             ! symbol entry
      add (0);                   ! unknown data type
      addw (2_1000);             ! flags
      add string (0, init proc); ! name
      flush buff
   %end

   %routine  PLUG PSECTS
      buff == glapp;  select (12);       ! plug things into gla
      ! code psect base
      need (50)
      stpb (codep, 4);     add (tir stold)
      ga = ga + 4
      ! diags psect base
      %if diags # 0 %start
         stpb (diagp, 4)
      %else
         stak (4)
      %finish
      add (tir stold)
      ga = ga + 4
      ! lines psect base
      %if ldump # 0 %start
         stpb (linep, 4)
      %else
         stak (4)
      %finish
      add (tir stold)
      ga = ga + 4
      start immed (10)
      addw (0);                         ! null string
      addl (proc tab(1)_diag ep)
      addl (event base)
      end immed
      buff == codep;  select (evp)
      stak (0);  add (tir stol)
      %if diags # 0 %start
         buff == diagp;  select (diag size)
         start immed (2);  addw (0);  end immed
      %finish
   %end

   %routine  DUMP EOM
      set work (obj eom)
      add (0);                            ! Successful compilation
      %if entry tag >= 0 %start
         add (0)
         addl (def(entry tag)_ca)
      %finish
      flush buff
   %end

   %routine  FLUSH BUFFERS
      buff == codep;  flush buff
      buff == glapp;  flush buff
      buff == diagp;  flush buff
      buff == linep;  flush buff
      buff == workp;  flush buff
   %end

   %routine  REPORT INFO
      %integer  stream
      %for stream = report, listing-report, listing %cycle
         %continue %if clog = 0 %and stream = report
         select output (stream)
         print string ("Code");            write (codep_max-4, 1)
         print string (" bytes  Glap");    write (glapp_max, 1)
         print string (" bytes  Diags");   write (diagp_max+linep_max, 1)
         print string (" bytes   Total size")
         write (codep_max-4+glapp_max+diagp_max+linep_max, 1)
         print string (" bytes");  newline
      %repeat
   %end

   %routine  TIME (%routine  R, %string(15) name)
      %external %integer %function %spec  PAGEFAULTS
      %integer  t, p
      %own %integer  called = 0
      p = page faults;   t = cputime
      R
      t = cputime - t;   p = pagefaults - p
      %return %if timing = 0
      select output (report)
      print string ("Pass 3 breakdown:") %and newline %if called = 0
      called = 1
      spaces (3)
      print string (name);  print symbol (':')
      spaces (15-length(name));  space
      %if t >= 20 %start
         write (t, -5);  print string ("ms,    ")
      %else
         print string ("negligible, ")
      %finish
      write (p, -3);  print string (" page fault")
      print symbol ('s') %if p # 1
      newline
      select output (object file)
   %end

   ! MAIN CODE

   initialise
   time (input directives, "Directive input")
   time (stretch jumps, "Jump stretching")
   dump module header
   define psects
   spec init proc
   time (dump all code, "Code dumping")
   plug psects
   flush buffers
   dump eom
   report info

%end

%end %of %file