// (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)