%begin; !APM IMP Library
!** NB must not contain owns
!** Value of string FNAME must be name of MOB file
!** Some string value parameters masquerading as names
!
!IMP PRIM+PERM procedures are dealt with in one of four ways:
!  .  never called -- in-line code generated (eg store-mapping)
!  .  included in APM system and called via extracode call vector,
!     (eg floating point routines)
!  .  compiled into program as procedures (eg array access)
!  .  included in this library which is pre-loaded and referenced
!     by external call mechanism (except for CONNECT and EXTLOAD
!     which are inserted into the extracode call vector when loaded)
!
@16_1114 %routine signal(%integer code)
@16_1198 %routine phex(%integer x)
%recordformat DICT(%integer a,b,c,d)
@16_3FAC %integer cliparamad
@16_3FC0 %record(dict) FILDICT
@16_3FD0 %record(dict) EXTDICT
@16_3FE0 %record(dict) SYSDICT
@16_117C %integerfn DEFNAME(%string(255)s,%record(dict)%name d,
                                %integer size)
@16_1180 %integerfn REFNAME(%string(255)s,%record(dict)%name d)
@16_1184 %routine   TRANSNAME(%integer ref,%string(255)%name s)
@16_1110 %integerfn FCOMMR(%integer c,%string(255)p,
                               %bytename b,%integer max)
@16_1100 %routine   ETHERWRITE(%integer port,%bytename buf,
                                   %integer size)
@16_1104 %integerfn ETHERREAD(%integer port,%bytename buf,
                                  %integer max)
!
!!!!!!!!!!!!!!!!!  Floating-point input/output  !!!!!!!!!!!!!!!!!!!!!!!
%externalroutine FREAD %alias "read"(%name v)
!Called only for reals
%integer sign=0,sym
%real value,exp
  %cycle
    sym = nextsymbol
    %exit %if sym > ' '
    skipsymbol
  %repeat
  %if sym = '-' %start
    sign = 1
    skip symbol;  sym = nextsymbol
  %finish
  value = 0
  %if sym # '.' %start
    %signal 4,1,sym %unless '0' <= sym <= '9'
    %cycle
      value = value*10.0+(sym-'0')
      skip symbol;  sym = nextsymbol
    %repeat %until %not '0' <= sym <= '9'
  %finish
  %if sym = '.' %start
    exp = 10.0
    %cycle
      skip symbol;  sym = nextsymbol
      %exit %unless '0' <= sym <= '9'
      value = value+(sym-'0')/exp
      exp = exp*10.0
    %repeat
  %finish
  %if sym = '@' %start
    skipsymbol
    read(sym)
    value = value*10.0^sym
  %finish
  value = -value %if sign # 0
!  v = value
  *move v,a0
  *move value,(a0)
%end;  !fread
%externalroutine READREAL(%realname v)
  fread(v)
%end

%externalroutine PRINT(%real x, %integer n,m)
%constreal pmax = 2147483647.0
%real y,z
%integer i=0,l,count=0,sign
  sign = ' '
  sign = '-' %if x < 0
  y = |x|+0.5/10.0^m;  !modulus, rounded
  %if y > pmax %start
    count = count+1 %and y = y/10.0 %until y < 10.0
  %finish
  z = 1.0
  %cycle
    i = i+1;  z = z*10.0
  %repeat %until z > y
  spaces(n-i)
  printsymbol(sign) %unless sign = ' ' %and n <= 0
  %cycle
    z = z/10.0
    l = int pt(y/z)
    y = y-l*z
    printsymbol(l+'0')
    i = i-1
    %exit %if i+m <= 0
    print symbol('.') %if i = 0
  %repeat
  printsymbol('@') %and write(count,0) %if count # 0
%end;  !print

%externalroutine PRINTFL(%real x, %integer n)
%real y,round
%integer count=-99,sign=0
  %if x # 0 %start
    x = -x %and sign = 1 %if x < 0
   !Adjust X so that 1.0 <= rounded(X) < 10.0
    count = 0;  round = 0.5^n
    y = 1.0-round
    %if x < y %start;  !ie rounded(X) < 1.0
      count = count-1 %and x = x*10.0 %until x >= y
    %finish %else %start
      y = 10.0-round
      %while x >= y %cycle;  !ie rounded(X) > 10.0
        count = count+1;  x = x/10.0
      %repeat
    %finish
    x = -x %if sign # 0
  %finish
  print(x,1,n)
  printsymbol('@')
  write(count,0)
%end;  !printfl

%externalintegerfn int(%real r)
  %result = intpt(r+0.5)
%end

%externalrealfn fraction(%real r)
  %result = fracpt(r) %if r>=0
  %result = -fracpt(-r)
%end

%externalintegerfn round(%real r)
  %result = int(r)
%end

%externalintegerfn trunc(%real r)
  %result = intpt(r) %if r>=0
  %result = -intpt(-r)
%end


!!!!!!!!!!!!!!!!!!!!   Stream control     !!!!!!!!!!!!!!!!!!!!!!!!

%constinteger iocbsize=16, iocbshift=4
%constinteger icb0=16_35ce, ocb0=16_360e
@16_35c6 %integer icb
@16_35ca %integer ocb

%externalintegerfn INSTREAM
  %result = (icb-icb0)>>iocbshift
%end

%externalintegerfn OUTSTREAM
  %result = (ocb-ocb0)>>iocbshift
%end

!!!!!!!!!!!!!!!!!!!!   String procedures  !!!!!!!!!!!!!!!!!!!!!!!!

%externalstring(255)%fn SUBSTRING(%string(255) s, %integer from,to)
%string(255) t
  t = ""
  %while from <= to %cycle
    t = t.tostring(charno(s,from));  from = from+1
  %repeat
  %result = t
%end

%externalintegerfn INDEX(%string(*)%name var,match)
!Return index position of first occurrence of match within string
!** to be re-coded for efficiency **
%integer i=0,j,l=length(match)
  %cycle
    %result = 0 %if i > length(var)-l
    i = i+1
    j = 0
    %cycle
      %result = i %if j = l
      j = j+1
    %repeat %until charno(var,i+j-1) # charno(match,j)
  %repeat
%end

%predicate RESOLVE(%string(*)%name var,match,fore,aft)
%integer i
%routine do aft
  aft = substring(var,i+length(match),length(var)) %if addr(aft) # 0
%end
  i = index(var,match)
  %false %if i = 0
  %if addr(fore) # 0 %start
    %if addr(fore) # addr(var) %start
      fore = substring(var,1,i-1)
      do aft
    %finish %else %start
      do aft
      length(var) = i-1
    %finish
  %finish %else do aft
  %true
%end

%external%string(127)%fn ITOS(%integer v,p)
%integer vv,q,pos
%byteintegerarray store(0:127)
  vv = v;  vv = -vv %if vv > 0
  pos = 127
  %while vv <= -10 %cycle
    q = vv//10
    store(pos) = q*10-vv+'0';  pos = pos-1
    vv = q
  %repeat
  store(pos) = '0'-vv
  %if p <= 0 %start
    p = 128+p
  %else
    p = 128-p
    p = pos %if p > pos
    p = p-1
  %finish
  pos = pos-1 %and store(pos) = '-' %if v < 0
  %while pos > p %and pos > 1 %cycle
    pos = pos-1;  store(pos) = ' '
  %repeat
  pos = pos-1;  store(pos) = 127-pos
  %result = string(addr(store(pos)))
%end

%external%integer%fn STOI(%string(255) S)
%integer i,k
%integer sign=0, val=0
  i = 0
  %while i < length(s) %cycle
    i = i+1;  k = charno(s,i)
    %continue %if k <= ' '
    %if k = '-' %start
      sign = 1
    %else %if '0' <= k <= '9'
      val = val<<3+val+val+k-'0'
    %else
      %signal 3, 1, k
    %finish
  %repeat
  %result = val %if sign = 0
  %result = -val
%end

%externalroutinespec PRINT LINE(%string(255) s)
%externalroutine PRINT LINE
  *JSR printstring
  newline
%end

%externalroutine READ LINE(%string(255)%name s)
%integer k
  s = ""
  %cycle
    read symbol(k)
    %return %if k < ' '
    s = s.tostring(k)
  %repeat
%end

%externalroutine READ STRING(%string(*)%name s)
%integer k
  readsymbol(k) %until k>' '
  s = ""
  %cycle
    s = s.tostring(k)
    k = nextsymbol; %returnif k<=' '
    skipsymbol
  %repeat
%end

%externalstring(31)%fn DATETIME
%string(31)s
  length(s) = fcommr('G'<<8,"",charno(s,1),31)
  %result = s
%end

%externalstring(8)%fn DATE;                !** No owns
!%string(31)s
!  s = datetime; length(s) = 8; %result = s
  *BSR DATETIME;  !ad -> A0
  *MOVE.B #8,(A0);  !alter length
%end

%externalstring(5)%fn TIME;                !** No owns
!%string(31)s
!%integer p
!  s = datetime; p = addr(s)+length(s)-5
!  byteinteger(p) = 5; %result = string(p)
  *BSR DATETIME
  *LEA 10(A0),A0;  *MOVE.B #5,(A0);  !adjust start & length
%end

!!!!!!!!!!!!!!!!!!!!!!!  Parameter processing  !!!!!!!!!!!!!!!!!!!!!!!!!!

%externalstring(255)%fn CLIPARAM
!Gives effect of VAX/VMS function for obtaining command parameters
%string(255) s
!  %if cliparamad>0 %start
    s = string(cliparamad)
    %result = "" %if shortinteger(cliparamad)=511
    %result = s %unless s=""
!  %finish
  skip symbol %while nextsymbol = ' '
  read line(s)
  %result = s
%end

!!!!!!!!!!!!!!!!!!!!!!  File connection  !!!!!!!!!!!!!!!!!!!!!!!!!

%recordformat CONNINFO(%integer memstart,fstart,flim,memlim)
%externalroutine CONNECT(%string(255)%name f,%record(conninfo)%name d)
!Read in the file F to space allocated on the heap
! Allocate a total of D_FSTART + fsize + D_MEMLIM bytes
! and align file to D_FSTART within this space;
! D_MEMSTART := start of space;  D_FSTART := D_FSTART+D_MEMSTART
! D_FLIM := D_FSTART+fsize;  D_MEMLIM := D_MEMLIM+D_FLIM
@16_35C4 %short  uno
@16_372C %byte   cylock
@16_372D %byte   fsport
%integer i,j,xno,len,blocks,pos,fsize,fpos,original
%string(255) fscomm

%routine lock
  cylock = cylock+1
%end

%routine unlock
  %returnif cylock=0
  cylock = cylock-1
  cylock = 0 %and %signal 0,1 %if cylock=128
%end

%routine GET(%integername v)
!Extract numeric info from FSCOMM
%integer k
  v = 0
  %cycle
    i = i+1;  k = charno(fscomm,i)
    i = i-1 %if k < ' '
    k = k-'0'
    %return %if k < 0
    v = v<<4+k
  %repeat
%end

%routine READ FILE(%integer ok)
%integer j
  %unless fsize=0 %start
    %if fpos#0 %start
      j = fsize-4
      %while j>=0 %cycle
        j = j-4; integer(pos) = integer(fpos)
        pos = pos+4; fpos = fpos+4
      %repeat
      j = j+4-1
      %while j>=0 %cycle
        j = j-1; byteinteger(pos) = byteinteger(fpos)
        pos = pos+1; fpos = fpos+1
      %repeat
    %else
      %cycle
        j = 512; j = fsize %if fsize<j
        j = etherread(fsport,byteinteger(pos),j)
        pos = pos+j %if ok # 0;  fsize = j %unless fsize=0
      %repeatuntil j#512
    %finish
  %finish
  unlock
%end

%if f # "" %start
  j = refname(f,fildict); fpos = 0
  %if j>0 %and integer(j)>0 %start; !File already in store
    fpos = integer(j); fsize = integer(j+4)-fpos
    fpos = 0 %if fsize<=0
  %finish
  %if fpos=0 %start;                !Read file from filestore
    lock
    fscomm = "Z".tostring(uno+'0').f.tostring(nl)
    etherwrite(fsport,charno(fscomm,1),length(fscomm))
    len = etherread(fsport,charno(fscomm,1),255);!Read response
    %if charno(fscomm,1) = '-' %start
      unlock
      event_extra = charno(fscomm,2)-'0'
      charno(fscomm,2) = len-2
      event_message = string(addr(charno(fscomm,2)))
      signal(16_39)
    %finish
    i = 0
    get(blocks);  get(fsize)
    fsize = blocks<<9-fsize;  !size of file in bytes
  %finish
%finish %else fsize = 0
!Allocate space
  *MOVE D6,pos;  *MOVE A7,j;  !**Heap -><- Stack **
  %if pos+fsize+d_fstart+d_memlim >= j %start;  !no space
    read file(0)
    event_message = "*No space to connect ".f
    signal(16_49)
  %finish
  pos = pos-256;                !HP displaced by 256
  d_memstart = pos
  pos = pos+d_fstart;  d_fstart = pos
  read file(1)
  d_flim = pos
  pos = pos+d_memlim;  d_memlim = pos
  pos = (pos+259)&(\3);  !aligned
  *MOVE pos,D6
%end

%externalroutine CONNECT FILE(%string(255) f, %integer mode,
                                %integername start,len)
%record(conninfo) r
  r = 0;  connect(f,r);  start = r_fstart;  len = r_flim-start
%end

!!!!!!!!!!!!!!!!!!!!!!!  External loading  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%routine EXTLOAD
  *MOVE 4(A7),A3;  !**allow for LINK**
%integer lmax=-1, errors=0
{%integer level=0
%record(conninfo)%array LOADED(0:63)
%string(255) fid

%routine LOAD(%integer p,a)
%integer i,q,r,e,b,fref,idref
%record(conninfo)%name L
{%integer count=0
{spaces(level)
  %while shortinteger(p) # 0 %cycle;  !For each ref
{printstring(string(p))
    idref = refname(string(p),extdict);  !lookup in ext dict
    %if idref <= 0 %start
      printstring("*Unknown external: ".string(p));  newline
      errors = errors+1
    %finish %else %start
      fref = integer(idref)
      i = -1
      %cycle
        i = i+1;  l == loaded(i)
        %if i > lmax %start;  !first use of this file
          lmax = i;  l = 0;  !new cell
{printstring("=>")
{         %if integer(fref) <= 0 %start;  !not permanently loaded
            transname(fref,fid);  !recover name of file
{printstring(fid);  newline
            connect(fid,l);  !read it in
            l_memstart = fref
{%for i = 0,1,lmax %cycle
{  space;  phex(loaded(i)_memstart)
{  newline %if i&7 = 7
{%repeat
{newline
            i = l_flim-2
            i = i+shortinteger(i);  !entry point
            b = l_flim-6-shortinteger(i+6)<<1;  !start of owns
            l_flim = b
            %if i+60 < b %start;  !ext specs present
{level = level+2;  newline
              load(i+40,b)
{level = level-2;  spaces(level)
            %finish
          %finish %else %start
{           l_fstart = integer(fref);  l_memstart = fref
{         %finish
        %finish
      %repeat %until l_memstart = fref
      q = l_fstart+2;  !start of externals
      e = 0
      %while byteinteger(q) < 12 %cycle;  !find & set Q to end
        e = q %if string(q) = string(p)
        q = q+20
      %repeat
      %if e = 0 %start
        printstring("*".string(p)." no longer valid");  newline
        %stop
      %finish
      %if integer(p+12) # integer(e+12) %start
        %if (integer(p+12)!!integer(e+12))&4#0 %start
          printstring("*Class mismatch for ".string(p)); newline
          %stop
        %finish
!       printstring("*Type mismatch for ".string(p));  newline
!       %stop
      %finish
      r = integer(p+16)+a;  !disp of ref + A6
      %if integer(p+12)&4 # 0 %start;  !procedure
        shortinteger(r) = 16_2C7C;  !MOVE.L #xxxxxxxx,A6
        integer(r+2) = l_flim;  !start of owns
        shortinteger(r+6) = 16_4EF9;  !JMP xxxxxxxx
        integer(r+8) = q+integer(e+16);  !entry-point
      %finish %else %start
        integer(r) = l_flim+integer(e+16)
{phex(integer(r))
      %finish
    %finish
    p = p+20
{%if shortinteger(p) # 0 %start
{  printsymbol(',');  count = count+1
{  newline %and spaces(level) %and count = 0 %if count = 6
{%finish
  %repeat
{newline
%end
  *MOVE A3,D0; *ADDQ #4,D0
  *MOVE A6,D1
  *BSR load
  %stop %if errors # 0
%end

!Parameter records:
%recordformat INFO(%string(255) name,
                   %integer addr,%short size,flags,
                   %record(info)%name link)
!Base record
%recordformat PAMINFO(%byte groupsep,keyflag, %short allflags,
                    %record(info)%name chain)
%external%record(paminfo)%map PAM
%record(paminfo)%name p
%predicate ok(%record(info)%name p)
%integer q
  *move d6,q
  %while p ## nil %cycle
    %false %unless 16_800000 < addr(p) < q %and addr(p)&1 = 0
    p == p_link
  %repeat
  %true
%end
  p == record(refname("PAM_INFO",sysdict))
  %if addr(p) <= 0 %start
    p == record(defname("PAM_INFO",sysdict,sizeof(p)))
    p_chain == nil;  p_allflags = 0
    p_groupsep = '/';  p_keyflag = '-'
  %finish
  p_chain == nil %and p_allflags = 0 %if %not ok(p_chain)
  %result == p
%end

!Branch table entry displacement addresses:
%constinteger connted=16_11BA, loadted=16_11BE, resolted=16_11B6
%conststring(19)FNAME="I:LIB.MOB"
@16_3ff0 %integer freebot
%integer i,j

!Insert CONNECT, EXTLOAD & RESOLVE

  j = shortinteger(connted)+connted+2
  *lea connect,a0
  *move.l a0,i
  integer(j) = i

  j = shortinteger(loadted)+loadted+2
  *lea extload,a0
  *move.l a0,i
  integer(j) = i

  j = shortinteger(resolted)+resolted+2
  *lea resolve,a0
  *move.l a0,i
  integer(j) = i

!Install entry-points

  j = refname(fname,fildict)
  printstring(fname." not in dict!") %and %stop %if j <= 0
  i = integer(j)+2
  %while 1<=byteinteger(i)<=11 %cycle
    integer(defname(string(i),extdict,8)) = j
    i = i+20
  %repeat

!Lock file in store
  freebot = integer(j+4)+4

  printstring("IMPLIB loaded"); printsymbol(nl)
%endofprogram