// (C) Copyright 1978 Tripos Research Group
//     University of Cambridge
//     Computer Laboratory
//
// (C) Copyright 1981 Network Development Group
//     Rutherford Appleton Laboratory

SECTION "BLIB1"

GET "LIBHDR"
GET "IOHDR"
GET "MANHDR"
GET "FH2HDR"

LET fault(code) BE callseg("SYS:C.FAULT", -1, code)

AND unpackstring(s, v) BE
    FOR i = s%0 TO 0 BY -1 DO v!i := s%i


AND packstring(v, s) = VALOF
 $( LET n = v!0 & 255
    LET size = n/bytesperword
    FOR i = 0 TO n DO s%i := v!i
    FOR i = n+1 TO (size+1)*bytesperword-1 DO s%i := 0
    RESULTIS size
 $)


AND endtask(seg) BE
 $( unloadseg(seg)
    deletetask(taskid)
    abort(180)
 $)


AND delay(ticks) = sendpkt(-1, -1, 0, ?, ?, ticks)


AND sendpkt(link, id, type, res1, res2,
      arg1, arg2, arg3, arg4, arg5, arg6) = VALOF
 $( LET destination = id
    TEST qpkt(@link)=0
    THEN abort(181)
    ELSE
    $( UNTIL pktwait(destination, @link)=@link DO abort(182)
       result2 := res2
       RESULTIS res1
    $)
 $)

AND pktwait(/*Destination, Pkt*/) = taskwait()

AND returnpkt(packet, res1, res2) = VALOF
 $( packet!pkt.res1, packet!pkt.res2 := res1, res2
    RESULTIS qpkt(packet)
 $)


AND initio() BE
 $( cis, cos := 0, 0
    currentdir, consoletask := 0, task.consolehandler
 $)


AND rdch() = VALOF
$( LET pos, end = cis!scb.pos, cis!scb.end
   IF pos>=end RESULTIS replenish(end)
      || First call, buffer exhausted or stream exhausted.
   cis!scb.pos := pos+1; RESULTIS cis!scb.buf%pos
$)


AND unrdch() = VALOF
$( LET pos = cis!scb.pos
   IF pos<=0 RESULTIS cis!scb.end=0
      || Attempt to 'UnRdch' past buffer origin.
   cis!scb.pos := pos-1; RESULTIS TRUE
$)


AND wrch(ch) BE
$( LET pos, end = cos!scb.pos, cos!scb.end
   IF pos>=end DO
   $( UNLESS deplete() DO abort(189)
      pos := 0
   $)
   cos!scb.buf%pos := ch
   cos!scb.pos := pos+1
   IF ch<'*S' & cos!scb.type<0 &
      (ch='*N' | ch='*E' | ch='*P' | ch='*C') DO
   $( UNLESS deplete() DO abort(189)
      cos!scb.pos := 0
   $)
$)


AND replenish(end) = VALOF
$( LET func = cis!scb.func1
   UNLESS cis!scb.id=id.inscb DO abort(186)
   IF end=0 RESULTIS endstreamch
      || End of stream was detected earlier.
   result2 := 0
   IF func=0 | NOT func(cis) DO
   $( UNLESS result2=0 DO abort(188)
      cis!scb.pos, cis!scb.end := 0, 0
      RESULTIS endstreamch
   $)
   cis!scb.pos := 1; RESULTIS cis!scb.buf%0
$)


AND deplete() = VALOF
$( LET func = cos!scb.func2
   LET res2 = result2
   LET res = TRUE
   UNLESS cos!scb.id=id.outscb DO abort(187)
   UNLESS func=0 DO res := func(cos)
   result2 := res2
   RESULTIS res
$)


AND findinput(string) =
     find(string, act.findinput, id.inscb)


AND findoutput(string) =
     find(string, act.findoutput, id.outscb)


AND findupdate(string) = findoutput(string)


AND ObjLock(String, Request, Vector) = VALOF
$( LET Prefix = VEC 30/BytesPerWord
   LET Req = Action.LocateObject
   LET Len = String%0
   LET Ptr = 1
   LET Task = CurrentDir=0 -> Task.FileHandler, CurrentDir!Lock.Task
   LET Dir = 0

   Ptr := Split(Prefix, ':', String, Ptr)
   TEST Ptr=0
   THEN
   $( Ptr := 1
      Dir := CurrentDir
   $)
   ELSE TEST Prefix%0=0
      THEN UNLESS CurrentDir=0 DO Task := CurrentDir!Lock.Task
      ELSE
      $( LET LVTask = DeviceName(Prefix)
         IF LVTask=0 | !LVTask=0 THEN
         $( Result2 := 218
            RESULTIS 0
         $)
         Task := !LVTask
      $)
   || watch carefully
   dir := sendpkt(-1, task,
        [dir=0 -> action.locateobject, action.copyobject], ?, ?,
        dir, "$", FALSE, TRUE)
   $( Ptr := Split(Prefix, '.', String, Ptr)
      IF Ptr=0 THEN
      $( IF request=action.locatedir THEN
         $( FOR i = 0 TO 30/bytesperword DO vector!i := prefix!i
                                            // copy last component
            RESULTIS dir // return directory lock
         $)
         req := request
      $)
      Dir := SendPkt(-1, Task, req, ?, ?,
                     Dir,       // Default directory
                     Prefix,    // Lookup string
                     Req=Action.CreateObject,   // TRUE -> exclusive, shared
                     TRUE)   // TRUE => free directory lock
      IF Dir=0 RESULTIS 0
   $) REPEATUNTIL Ptr=0
   RESULTIS Dir
$)

AND Split(Prefix, Ch, String, Ptr) = VALOF
$( LET Len = String%0-Ptr
   FOR i = 0 TO 255 DO
   $( Prefix%0 := i>30 -> 30, i
      IF i>Len RESULTIS 0
      IF String%[Ptr+i]=Ch RESULTIS Ptr+i+1
      IF i<30 THEN Prefix%[i+1] := String%[Ptr+i]
   $)
$)

AND find(string, act, id) = VALOF
$( LET scb = getvec(scb.upb)
   LET res, task = ?, ?
   IF scb=0 RESULTIS 0

   FOR i = 0 TO scb.upb DO scb!i := -1
   FOR i = scb.funcs TO scb.args-1 DO scb!i := 0

   scb!scb.id := id
   scb!scb.func3 := actend
   TEST findarg("Console:=**", string)=0
   THEN
   $( scb!scb.type := -consoletask
      res := sendpkt(-1, consoletask, act, 0, 0, scb)
   $)
   ELSE
   $( res := objlock(string,
        [act=act.findinput -> action.locateobject, action.createobject])
      TEST res\=0
      THEN
      $( scb!scb.type := res!lock.task
         res := sendpkt(-1, scb!scb.type,
                 [act=act.findinput -> action.findinput, action.findoutput],
                 ?, ?,
                 scb, res)
      $)
      ELSE IF result2=218 THEN
      $( res := callseg("SYS:L.FIND", act, scb, string)
         UNLESS res=0 THEN scb := res
      $)
   $)
   IF res=0 DO
   $( freevec(scb)
      RESULTIS 0
   $)
   RESULTIS scb
$)

AND actend(scb) = VALOF
$( let task = abs scb!scb.type
   let act = task\=task.filehandler -> act.end,
             scb!scb.id=id.inscb -> action.closeinput,
                                    action.closeoutput
   resultis sendpkt(-1, task, act, 0, 0, [act=act.end -> scb, scb!scb.arg1])
$)


AND selectinput(scb) = VALOF
$( UNLESS scb=0 | scb!scb.id=id.inscb DO abort(186)
   cis := scb; RESULTIS TRUE
$)


AND selectoutput(scb) = VALOF
$( UNLESS scb=0 | scb!scb.id=id.outscb DO abort(187)
   cos := scb; RESULTIS TRUE
$)


AND endread() BE
 $( endstream(cis)
    cis := 0
 $)


AND endwrite() BE
 $( endstream(cos)
    cos := 0
 $)


AND endstream(scb) BE UNLESS scb=0 DO
 $( LET func = scb!scb.func3
    LET res2 = result2
    UNLESS func=0 DO func(scb)
    freevec(scb)
    result2 := res2
 $)


AND input() = cis

AND output() = cos


AND readn() = VALOF
 $( LET sum, ch = 0, 0
    AND neg = FALSE

l:  ch := rdch()
    UNLESS '0'<=ch<='9' DO
       SWITCHON ch INTO
      $( DEFAULT:    unrdch()
                     result2 := -1
                     RESULTIS 0
          CASE '*S':
          CASE '*T':
          CASE '*N': GOTO l

          CASE '-':  neg := TRUE
          CASE '+':  ch := rdch()
    $)

    WHILE '0'<=ch<='9' DO
    $( sum := 10*sum + ch - '0'
       ch := rdch() $)

    IF neg DO sum := -sum
    unrdch()
    result2 := 0
    RESULTIS sum
 $)


AND newline() BE wrch('*N')



.
SECTION "BLIB2"

GET "LIBHDR"
GET "IOHDR"
GET "MANHDR"
GET "FH2HDR"


LET writed(n, d) BE
 $( LET t = VEC 10
    AND i, k = 0, -n
    IF n<0 DO d, k := d-1, n
    t!i, k, i := -(k REM 10), k/10, i+1 REPEATUNTIL k=0
    FOR j = i+1 TO d DO wrch('*S')
    IF n<0 DO wrch('-')
    FOR j = i-1 TO 0 BY -1 DO wrch(t!j+'0')
 $)

AND writen(n) BE writed(n, 0)

AND writehex(n, d) BE
 $( IF d>1 DO writehex(n>>4, d-1)
    wrch((n&15)!TABLE
         '0','1','2','3','4','5','6','7',
         '8','9','A','B','C','D','E','F' )
 $)

AND writeoct(n, d) BE
 $( IF d>1 DO writeoct(n>>3, d-1)
    wrch((n&7)+'0')
 $)

AND writes(s) BE
    FOR i = 1 TO s%0 DO wrch(s%i)

AND writet(s, n) BE
 $( writes(s)
    FOR i = 1 TO n-s%0 DO wrch('*S')
 $)

AND writeu(n, d) BE
 $( LET m = (n>>1)/5
    UNLESS m=0 DO
    $( writed(m, d-1)
       d := 1 $)
    writed(n-m*10, d)
 $)

AND writef(format, a, b, c, d, e, f, g, h, i, j, k) BE
$(1 LET t = @ a

    FOR p = 1 TO format%0 DO
    $(2 LET k = format%p

        TEST k='%'

          THEN $(3 LET f, arg, n = 0, t!0, 0
                   p := p + 1
                $( LET type = capitalch(format%p)
                   SWITCHON type INTO
                $( DEFAULT: wrch(type); ENDCASE

                   CASE 'S': f := writes; GOTO l
                   CASE 'T': f := writet; GOTO m
                   CASE 'C': f := wrch; GOTO l
                   CASE 'O': f := writeoct; GOTO m
                   CASE 'X': f := writehex; GOTO m
                   CASE 'I': f := writed; GOTO m
                   CASE 'N': f := writen; GOTO l
                   CASE 'U': f := writeu; GOTO m

                m: p := p + 1
                   n := format%p
                   n := '0'<=n<='9' -> n-'0',
                        10+n-'A'

                l: f(arg, n)

                   CASE '$':
                   t := t + 1
               $)3

          ELSE wrch(k)
    $)2
$)1


AND capitalch(ch) = 'a' <= ch <= 'z' -> ch + 'A' - 'a', ch


AND compch(ch1, ch2) = capitalch(ch1) - capitalch(ch2)


AND compstring(s1, s2) = VALOF
    $(
    LET lens1, lens2 = s1%0, s2%0
    LET smaller = lens1 < lens2 -> s1, s2

    FOR i = 1 TO smaller%0
    DO
        $(
        LET res = compch(s1%i, s2%i)

        UNLESS res = 0 RESULTIS res
        $)

     IF lens1 = lens2 RESULTIS 0

    RESULTIS smaller = s1 -> -1, 1
    $)



/*
AND RDARGS(KEYS, ARGV, SIZE) = CALLSEG("SYS:L.RDARGS", KEYS, ARGV, SIZE)
*/


/**/
AND rdargs(keys, argv, size) = VALOF
 $( LET w = argv
    LET numbargs = ?

    !w := 0
    FOR p = 1 TO keys%0 DO
      $( LET kch = keys%p
         IF kch = '/' DO
           $( LET c = capitalch(keys%(p+1))
              IF c = 'A' THEN !w := !w | 1
              IF c = 'K' THEN !w := !w | 2
              IF c = 'S' THEN !w := !w | 4
              LOOP
           $)
         IF kch = ',' THEN
           $( w := w+1
              !w := 0
           $)
      $)
    w := w+1
    numbargs := w-argv

// At this stage, the argument elements of argv have been
// initialised to  0    -
//                 1   /A
//                 2   /K
//                 3   /A/K
//                 4   /S
//                 5   /S/A
//                 6   /S/K
//                 7   /S/A/K

    $( LET argno = -1
       LET wsize = size + argv - w

       SWITCHON rditem(w, wsize) INTO
       $( DEFAULT:
 err:     $( LET ch = ?
             ch := rdch() REPEATUNTIL ch='*E' | ch='*N' |
                        ch=';' | ch=endstreamch
             result2 := 120
             RESULTIS 0
          $)

          CASE 0:  // *N, *E, ;, endstreamch
             FOR i = 0 TO numbargs - 1 DO
               $( LET a = argv!i
                  IF 0 <= a <= 7 THEN
                  TEST (a & 1) = 0 THEN
                    argv!i := 0
                   ELSE
                    GOTO err
               $)
             rdch()
             RESULTIS w

          CASE 1:  // ordinary item
             argno := findarg(keys, w)
             TEST argno>=0 THEN  // get and check argument
               TEST 4 <= argv!argno <= 7 THEN
                 $( // no value for key.
                    argv!argno := -1
                    LOOP
                 $)
               ELSE
                 $( LET item = rditem(w,wsize)
                    IF item = -2 THEN
                       item := rditem(w,wsize)
                    IF item <= 0 THEN
                       GOTO err
                 $)
             ELSE
               TEST rdch()='*N' & compstring("?", w)=0 THEN
                 $( // help facility
                    writef("%S: *E", keys)
                    ENDCASE
                 $)
               ELSE
                 unrdch()

          CASE 2:  // quoted item (i.e. arg value)
             IF argno<0 THEN
               FOR i = 0 TO numbargs-1 DO
                 SWITCHON argv!i INTO
                   $( CASE 0: CASE 1:
                        argno := i
                        BREAK
                      CASE 2: CASE 3:
                        GOTO err
                   $)
             UNLESS argno>=0 GOTO err

             argv!argno := w
             w := w + w%0/bytesperword + 1
       $)

    $) REPEAT
 $)
/**/


// Read an item from command line
// returns -2    "=" Symbol
//         -1    error
//          0    *N, *E, ;, endstreamch
//          1    unquoted item
//          2    quoted item
AND rditem(v, size) = VALOF
 $( LET p = 0
    LET pmax = (size+1)*bytesperword-1
    LET ch = ?
    LET quoted = FALSE

    FOR I = 0 TO size DO v!i := 0

    ch := rdch() REPEATWHILE ch='*S'

    IF ch='"' DO
    $( quoted := TRUE
       ch := rdch()
    $)

    UNTIL ch='*E' | ch='*N' | ch=endstreamch DO
    $( TEST quoted THEN
       $( IF ch='"' RESULTIS 2
          IF ch='**' DO
          $( ch := rdch()
             IF capitalch(ch)='E' DO ch := '*E'
             IF capitalch(ch)='N' DO ch := '*N'
          $)
       $)
       ELSE
          IF ch=';' | ch='*S' | ch='=' BREAK
       p := p+1
       IF p>pmax RESULTIS -1
       v%p := ch
       v%0 := p
       ch := rdch()
    $)

    unrdch()
    IF quoted RESULTIS -1
    TEST p=0 THEN
    $( IF ch='=' DO
       $( rdch()
          RESULTIS -2
       $)
       RESULTIS 0
    $)
    ELSE
       RESULTIS 1
 $)


AND findarg(keys, w) = VALOF  // =argno if found
                              // =-1 otherwise
  $( MANIFEST $( matching = 0; skipping = 1 $)

     LET state, wp, argno = matching, 0, 0

     FOR i = 1 TO keys % 0 DO
       $( LET kch = keys % i
          IF state = matching THEN
            $( IF (kch = '=' | kch= '/' | kch =',') &
                  wp = w % 0 THEN
                 RESULTIS argno
               wp := wp + 1
               UNLESS compch(kch,w % wp) = 0 THEN
                 state := skipping
            $)
          IF kch = ',' | kch = '=' THEN
            state,wp := matching,0
          IF kch=',' THEN
            argno := argno+1
       $)
     IF state = matching & wp = w % 0 THEN
       RESULTIS argno
     RESULTIS -1
  $)


AND loadseg(file) = VALOF
 $( LET list = 0
    LET liste = @list
    LET oldinput = input()
    LET newinput = findinput(file)

    IF newinput=0 RESULTIS 0
    selectinput(newinput)

    $( LET base = 0
       LET baseseg = 0
       LET dbase = 0
       LET limit = -1
       LET dlimit = -1

       $( LET type = 0

          IF readwords(@type, 1)=0 DO
             IF limit=-1 GOTO ok

          SWITCHON type INTO
          $( CASE t.hunk:
             $( LET space = ?
                readwords(@limit,1)
                readwords(@dlimit,1)
                space := getvec(dlimit+2)  // at least three words for pointers

                if space=0 goto err
                !liste := space
                liste := space
                dbase := space+3
                !space := 0
                space!1 := 0
                space!2 := 0

                unless limit-dlimit=0 do
                $( space := getcodevec(limit-dlimit-1) // returns mc addr
                   if space=-1 goto err
                   liste!1 := result2
                   liste!2 := space
                $)

                base := result2
                baseseg := space
                readcodewords(base, baseseg, limit-dlimit)
                readwords(dbase, dlimit)
                LOOP
             $)

             CASE t.relocb:       //***** 8086
             $( LET climit = limit-dlimit
                LET climit2 = climit*2
                LET its = ?
                LET n = 0
                readwords(@n, 1)
                FOR i = 1 to n do
                $( let a = -1
                   LET crel = FALSE
                   readwords(@a, 1)
                   unless 0<=a<=limit*2 goto err121

                test a>=climit2 do        // relocating data word
                $( a := a-climit2
                   its := dbase%a | (dbase%(a+1) << 8)
                   test its>=climit2 do its := its-climit2+dbase*mcaddrinc
                                     or $( its := its+base; crel := TRUE
                                        $)
                    dbase%a := its
                    dbase%(a+1) := its>>8

                    IF crel DO // must also fill in segment
                    $( a := a+2
                       UNLESS (dbase%a=0) & (dbase%(a+1)=0) GOTO err121
                       dbase%a := baseseg
                       dbase%(a+1) := baseseg>>8
                    $)
                $)
                or // relocating code word
                $( its := getcodebyte(base,baseseg,a) |
                         (getcodebyte(base,baseseg,a+1) << 8)
                   test its>=climit2 do its := its-climit2+dbase*mcaddrinc
                                     or its := its+base
                   putcodebyte(base,baseseg,a,its)
                   putcodebyte(base,baseseg,a+1,its>>8)
                $)
                $)
                LOOP
             $)

             CASE t.end:
                BREAK

          $)
          GOTO err121

       $) REPEAT

    $) REPEAT

err121:             // hunk format error
    result2 := 121
err:unloadseg(list)
    list := 0
ok: endread()
    selectinput(oldinput)
    RESULTIS list
 $)


AND unloadseg(seg) BE
 $( UNTIL seg=0 DO
    $( LET s = !seg
       LET s1 = seg!1
       LET s2 = seg!2
       UNLESS s1=0 & s2=0 DO freecodevec(s1,s2)
       freevec(seg)
       seg := s
    $)
 $)


AND callseg(file, arg1, arg2, arg3, arg4) = VALOF
 $( LET res = 0
    LET seg = loadseg(file)
    LET s = start
    UNLESS seg=0 | globin(seg)=0 DO
       res := start(arg1, arg2, arg3, arg4)
    unloadseg(seg)
    start := s
    RESULTIS res
 $)


AND datstring(v) = VALOF
    $(
    LET datv = VEC 2
    datstamp(datv)
    RESULTIS callseg("SYS:L.DAT-TO-STRINGS", datv, v)
    $)

AND datstamp(v) = VALOF
    $(
    LET days, mins, ticks = ?, ?, ?
    LET days1, mins1, ticks1 = ?, ?, ?

    $(
    days   := rootnode ! rtn.days
    mins   := rootnode ! rtn.mins
    ticks  := rootnode ! rtn.ticks
    days1  := rootnode ! rtn.days
    mins1  := rootnode ! rtn.mins
    ticks1 := rootnode ! rtn.ticks
    $) REPEATUNTIL (days = days1) & (mins = mins1) &
                   (ticks = ticks1)

    v!0, v!1, v!2 := days, mins, ticks
    RESULTIS v
    $)

AND deleteobj(name) = objlock(name, action.deleteobject)

AND renameobj(fromname, toname) = VALOF
$( let fromv = vec 30/bytesperword
   let tov = vec 30/bytesperword
   let fromdir = objlock(fromname, action.locatedir, fromv)
   let todir = objlock(toname, action.locatedir, tov)
   let res, res2 = 0, result2
   unless fromdir=0 | todir=0 then
      res := sendpkt(-1, fromdir!lock.task, action.renameobject, 0, 0,
                     fromdir, fromv, todir, tov)
   res2 := result2
   unless fromdir=currentdir then freeobj(fromdir)
   unless todir  =currentdir then freeobj(todir)
   result2 := res2
   resultis res
$)

AND locatedir(dirname) = locateobj(dirname)

AND locateobj(objname) = objlock(objname, action.locateobject)

AND createdir(name) = objlock(name, action.createobject)

AND freeobj(lock) = lock=0 -> 0,
   sendpkt(-1, lock!lock.task, action.freelock, 0, 0, lock)

AND readwords(v, n) = VALOF readwords.generic(v, ?, n, 'R')

AND readcodewords(v, seg, n) = VALOF readwords.generic(v, seg, n, 'C')

AND readwords.generic(v, seg, n, c) = VALOF
$( LET task = ABS [cis!scb.type]
   IF task=0 RESULTIS 0
   RESULTIS sendpkt(-1, task, c, ?, ?, cis!scb.arg1, v, n, seg)
$)


AND writewords(v, n) = VALOF
$( LET task = ABS [cos!scb.type]
   IF task=0 RESULTIS TRUE
   RESULTIS sendpkt(-1, task, 'W', ?, ?, cos!scb.arg1, v, n)
$)

and copyobj(lock) = lock=0 -> 0,
     sendpkt(-1, lock!lock.task, action.copyobject, ?, ?, lock)