!**************
!* load18s  *
!* 14.jun.82  *
!**************


%control x'4001'

%constrecord (*) %name null == 0


!***********************************
!*                                  *
!*       loader  faults             *
!*                                  *
!*   1 -  no core                   *
!*   2 -  init block too long       *
!*   3 -  init block short          *
!*   4 -  checksum wrong            *
!*   5 -  out of range              *
!*   6 -  end of file/ no file      *
!*   7 -  max no of tasks reached   *
!*  8 -  requested shared seg does not exist
!************************************


%externalintegerfnspec map virt %alias "$FMAPVIRT"(%integer id, fromseg,toseg)

%begin
     %constinteger delete = 5
     %constinteger get core = 6
      %constinteger insert c = 4
     %constinteger schedule t = 9
     %constinteger map psect = 16
      %constinteger r0=0,r1=1,r2=2
      %label loop

     %constinteger task low limit = 30
                                       ! see supervisor for updates
     %owninteger task limit = 48

     %constinteger load ser = 5;       ! main loader service


     %recordformat uregsf((%integer r0, r1, r2, r3, r4, r5, pc, ps, sp %or %c
      %byte r0a, r0b, r1a, r1b, r2a, r2b, r3a, r3b, r4a, r4b, r5a, r5b, %c
            pca, pcb, psa, psb, spa, spb))
     %recordformat segf(%integer par, pdr, dadd, use)
     %recordformat psectf(%integer q, %c
       %byteinteger id, state, %byteintegerarray %c
       name(0:3), %byteinteger prio, %integer poffq, %record (uregsf %c
       )urs, %integer trapv, %record (segf) %array seg(0:8))

     %recordformat pf(%byteinteger service, reply, (%integer a, b, c %or %c
               %byte a1, a2, b1, b2, c1, c2))


     %recordformat glasf(%integerarray fixed(1:12), %byteinteger id, %c
       callid, %integerarray strpts(0:7), %integer top, %byteinteger %c
       unit, fsys, %integer gla, intchr, spare, %integerarray grot %c
       (1:11), %byteintegerarray input(0:70))

     %constrecord (glasf) %name glas == k'100000'
                                       ! mapped to my seg 4




     %record (psectf) %name newpsect, spst

     %record (pf)p
     %record (segf) %name s


     %integer id, i, len, bc, j, segs, entry, n, newid, inpt, x
     %integer max2, load pt, nchar, stk, oseg, q, tt no
      %integer pt, gla disp, old, tflag, ttflag, ltype, kill
     %integer oload, obc
     %byteinteger char, cksm
     %owninteger unit = 0, fsys = 0, npc, fault = 0, comfau
     %owninteger reply to here = load ser

      %ownbyteintegerarray store(0:70)

     %integerfnspec word
      %routinespec schedule(%integer task id, param)
      %routinespec delete task(%integer id)
      %integerfnspec get store(%integer len, segs)
      %record (psectf) %mapspec insert task(%integer x, y)
     %routinespec release(%integer seg)
     %routinespec map shared seg(%integer id, seg, shared no)
     %record (psectf) %mapspec insert
      %record (psectf) %map %spec get psect(%integer id)
      %record (psectf) %map %spec get name(%byteintegername st)

     %integer dummy

     %integerarray lsegm(0:7);         ! holds extent of user seg

     %switch sw(0:7)

      %on 9 %start
eof:
!              %if instr1_fsys # 0 %start
!                instr1_fsys = 0
!                close input;  -> inp
!             %finish
              fault = 3
              -> step down
     %finish


     id = getid
     %cycle
        gla disp = 0
        p_service = 0
        poff(p)
        !* valid services are:- 
        !*                       p_service = loadid - loader request

           %if p_a1 = 1 %start;        ! request to load
                                       !  p_a = 1  - request to load
                                       !  p_b = address of load
                                       !   p_c1 = call flag
              !! tflag (call flag) 
              !!        = 0  - normal load
              !!        = 1  - shared load (if possible)
              !!        = 3  - shared load (loader ownes)
              !!        = 4  - shared load - replies when loaded
              !!        = k'101010' - set t bit
              reply to here = p_reply
              tflag = p_c1;  fsys = p_a2; tt no = p_c2
              %if tflag = 4 %then ttflag = p_reply %else ttflag = 0
              segs = p_b >> 13
              q = map virt(p_reply, segs, 4)
              pt = k'100000'!(p_b&k'17777')
              inpt = 1; x = 0
              %cycle
                 i = byteinteger(pt);  store(inpt) = i
                 %if i <= ' ' %and x = 0 %then x = inpt
                 pt = pt+1;  inpt = inpt+1
              %repeat %until i = nl %or inpt > 69
              nchar = inpt-1
              store(0) = x-1;             ! just the file spec
              release(0)

           oseg = -1

           inpt = 1;  old = 0
           open input(1, string(addr(store(0))))


inp:       select input(1);            ! consider effects of no file?
           readsymbol(i) %until i = 1
           newpsect == insert;         ! allocate the new psect

           %if newpsect == null %start
              fault = 7;  -> error
           %finish

           readsymbol(i);              ! skip the '0'
           !! read the first block   ( task descriptor block)
           bc = word-10;               ! byte count
           i = word;                   ! skip load address
           %cycle i = 0, 1, 3
              readsymbol(j)
              newpsect_name(i) = j;    ! fill in the name
           %repeat
           n = id
           %if tflag > 0 %start
              spst == get name(newpsect_name(0))
              %if spst == null %then tflag = 0 %elsestart
                 n = spst_id
                 newpsect_name(3) = newpsect_name(3)+1 %c
                    %until getname(newpsect_name(0)) == null
                 !! this changes the name until it is unique
              %finish
           %finish

           kill = 0

           spst == get psect(n)
           stk = word;                 ! pickup initial value of sp
           bc = bc-2;                  ! and step down bc
           %cycle segs = 0, 1, 7
              lsegm(segs) = 0
              %if bc <= 0 %then fault = 3 %and -> error
              s == newpsect_seg(segs)
              readsymbol(entry);  bc = bc-1
              %if entry > 3 %start;    ! new format
                 readsymbol(i);        ! throw away spare byte
                 bc = bc-1;            ! -3 eventually
              %finish
              %if entry = 3 %then printsymbol('*') %and old = old+1
              -> sw(entry) %unless entry > 7

sw(4):                                 ! no segment (new format)
              len = word;              ! throw dummy len away
              bc = bc-2
sw(0):                                 ! no segment
              s = 0
              %continue

sw(6):                                 ! read/write (new format)
sw(2):                                 ! read/write
              %if gla disp = 0 %then gla disp = segs << 13
sw(5):                                 ! read only  (new format)
sw(1):                                 ! normal,  1=read only
              %if tflag <= 0 %or gla disp #0 %start
                 len = word+k'77'
                 bc = bc-2
                 lsegm(segs) = len&k'37700'
                 len = len >> 6
                 n = get store(len, segs)
                 fault = 1 %and -> error %if n = 0
                  %if segs = 0 %start; ! special to load shared seg
                     kill = 1;         !kill the loading program
                     q = map virt(newid, 0, 0); ! hold the segment
                  %finish
                 -> read only %if entry = 5
              %else

sw(7):                                 ! shared seg (new format)
sw(3):                                 ! shared seg
                 n = word
                 bc = bc-2
                 n = spst_seg(segs)_dadd
                 map shared seg(newid, segs, n)
read only:
                s == new psect_seg(segs)
                s_pdr = s_pdr&(\4); ! delete write bit
               %if s_pdr = 0 %then fault = 8 %and -> error
              %finish
           %repeat

           !! all space allocated
            %if bc = 2 %start;        ! for non-default pc
               npc = word
            %else
               npc = k'020010';      ! default pc
               %if bc # 0 %then fault = 2 %and -> error
            %finish
            skipsymbol;         ! skip the checksum of 1st block

           !! place rest of input line in virtual space (seg 6)
           %cycle segs = 1, 1, 7
              i = lsegm(segs)
              %if i > 0 %start
                 q = map virt(newid, segs, 4)
                                       ! to loader seg 4
                 q = i+k'100000';     ! top address to be cleared+2
                 *mov_#k'100000',r0;     ! pt into store
                 *mov_q,r1;             ! top address
                 *clr_r2;               ! put in zero, to avoid parity probs
loop:            *mov_r2,(r0)+
                 *cmp_r0,r1
                 *blo_loop;             ! continue till finished
                 %if segs = 7 %start
                    glas_top = i;               ! limit of area
                    %if i > k'200' %then ltype = 0 %else ltype = 2
                    store(nchar) = nl; ! ensure nl at end
                     x = x-1 %if x = nchar; ! allways plant a nl
                    store(x) = nchar-x
                    string(k'100111') = string(addr(store(x)))
                                                 ! plant rest of string in users area
                    release(0)
                 %finish
              %finish
           %repeat

           !! now load it
           %cycle
              readsymbol(i) %until i = 1;  readsymbol(i)
              cksm = 1
              bc = word-6;  loadpt = word
              %if bc = 0 %thenexit;    ! start block
              obc = bc; oload = loadpt
              segs = loadpt >> 13;     ! get seg no
newsg:        x = loadpt&k'17777'!k'100000'
              %if tflag <= 0 %or loadpt>>1 >= gladisp>>1 %start
                 !! 'gla disp' is usually negative !
              max2 = k'100000'!lsegm(segs)
              %if oseg # segs %start;  ! new segment
                 release(oseg);        ! release if allocated
                 q = map virt(newid, segs, 4)
                                       ! map to me k'100000'-k'117776'
                 oseg = segs
              %finish
              %while bc > 0 %cycle
                 %if x > max2 %then fault = 5 %and -> error
                 readsymbol(n)
                 -> eof %if n < 0;      ! end of file
                 cksm = cksm+n
                 byteinteger(x) = n
                 x = x+1;  bc = bc-1
                 %if x&k'17777' = 0 %start
                    segs = segs+1;  loadpt = 0;  -> newsg
                 %finish
              %repeat
              readsymbol(n);  cksm = cksm+n
              %if cksm # 0 %and old = 0 %start
                 fault = 4;  -> error
              %finish
              %else
                 !* read only seg of shared prog
                 readsymbol(n) %and bc=bc-1 %while bc>=0
              %finish
           %repeat

            %if kill # 0 %then -> error;  ! shared lib prog
           %if tflag = k'101010' %then i = k'140020' %else i = k'140000'
           newpsect_prio = 1;          ! one is std prio for tasks
           newpsect_urs_pc = npc
           newpsect_urs_ps = i
           newpsect_urs_sp = stk
           newpsect_urs_r1 = gla disp
           newpsect_urs_r0 = k'160112'
                                       ! map to stream definitions
           newpsect_urs_r2 = ltype;    ! normal load
           newpsect_urs_r3a = unit
           newpsect_urs_r3b = fsys
           newpsect_urs_r4a = reply to here
           newpsect_urs_r4b = tt no
           newpsect_urs_r5 = gla disp
           release(oseg)
           schedule(newid, 0)
             -> do reply
           %finish
         %continue

error:  
        release(oseg)
            delete task(newid)
        ->clse %if kill # 0
step down:
        newid = 0;                     ! prog stopping to cli
         ttflag = reply to here; p_c = 1
do reply:
      %if ttflag # 0 %start;            ! reply to caller
         p_service = ttflag; p_reply = 5
         p_a = newid;  p_b = fault
         pon(p)
      %finish
clse:
      close input
     %repeat


     %integerfn word
        %integer s, t
         readsymbol(comfau); readsymbol(t); ! nb: compiler/perm fault using s
        cksm = cksm+comfau+t
        %result = t << 8+(comfau&x'ff')
     %end


      %routine schedule(%integer task id, param)
         *mov_r1, r0;   ! id is in r1
         *mov_r2, r1;   ! param is in r2
         *emt_schedule t
      %end

      %routine delete task(%integer id)
         *mov_r1,r0;    ! id is in r1
         *emt_delete
      %end

      %integerfn get store(%integer len, segs)
         %integer n
         *mov_r1, r0;                   ! len -> r1
         *mov_r2, r1;                   ! seg -> r0
         *emt_get core
         *mov_r0,n
         %result = n
      %end

      %record (psectf) %map insert task(%integer x, y)
         %integer n
         *mov_r1, r0
         *mov_r2, r1
         *emt_insertc
         *mov_r0, n
         %result == record(n)
      %end

     %routine release(%integer seg)
        %if seg #- 1 %start
           q = map virt(0, -1, 4);         ! always release loader seg 4
        %finish
     %end


     %routine map shared seg(%integer id, seg, shared no)
         *mov_id, r0
         *mov_seg, r1
         *mov_shared no,r2
         *emt_14;                       ! map shared
     %end

     %record (psectf) %map insert
        %constinteger insertc = 4;     ! svc insert

        %recordformat xf(%integer x)
        %record (xf) %name x
        %record (psectf) %name ps

        ps == insert task(3, 3)
        %result == null %if ps == null
        newid = ps_id

        %if task limit < newid %then task limit = newid

        ps = 0;                        ! zero the psect
        ps_id = newid;                 ! replace the id
        %result == ps
     %end


     %record (psectf) %map get psect(%integer id)
        %integer n
        *mov_#5,r1
        *mov_id,r0
        *emt_map psect
        *mov_r0,n
        %result == record(n)
     %end

     %record (psectf) %map get name(%byteintegername st)
        %record (psectf) %name pst
        %integer pt, id, j, char, match
        %cycle id = task low limit, 1, task limit
           pst == get psect(id)
           %unless pst == null %start
              %cycle j = 0, 1, 3
                 char = byteinteger(st+j);  match = pst_name(j)
                 %exitif char <= ' ' >= match
                 -> no %if char # match
              %repeat
              %result == pst %unless pst_state = 0
           %finish
no:     %repeat
        %result == null
     %end


%endofprogram
     %record (psectf) %map get psect(%integer id)
                 -> no %if char # match