|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 49152 (0xc000)
Types: TextFile
Names: »utilprtx«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦baac87bee⟧ »gi«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦baac87bee⟧ »gi«
└─⟦this⟧
; rc fpproctx * page 1 10 03 80, 14.13;
(fpproc = set 1
fpproc = slang entry.no
fpproc)
b. ; outermost block
m.fpproc 31 01 73
p.<:fpnames:>
b. g1, e5 ; block for insertproc
w.
; procedure fpproc(action, w0, w1, w2);
; integer address action;
; undefined w0, w1, w2;
; comment
; the procedure calls the fp-procedure
; determined by the h-name with the number
; action.
; the main idea is to execute
; jl w3 fpbase+hname(action)
; in a sensible way from within an
; algol program. the allowed actions
; are listed below with the meaning
; of the w-parameters.
; action w0 w1 w2
; 7 (end prog) irr irr integer
; 7 (end prog irr zone**) integer
; 14 (finis mess) irr irr irr
; 22 (inblock)*) irr zone irr
; 23 (outblock)*) irr zone irr
; 24 (wait ready)*) irr zone integer
; 25 (inchar)*) irr zone integer+)
; 26 (outchar)*) irr zone integer
; 27 (connect in) integer+) zone array
; 27 (connect in) integer+) 0 array
; 28 (connect out) integer+) zone array
; 28 (connect out) integer+) 0 array
; 29 (stack zone)*) irr zone array
; 29 (stack current in)*) irr in 0
; 30 (unstack zone)*) irr zone array
; 30 (unstac current in)*)irr in 0
; 31 (outtext)*) array zone irr
; 32 (outinteger)*) integer zone integer (layout)
; 33 (outend)*) irr zone integer
; 34 (close up)*) irr zone integer
; 35 (parent mess) irr array zone**)
; 48 (wait free)*) irr zone integer
; 67 (break mess) irr irr irr
; 79 (terminate zone)*) irr zone irr
; *) may call the give-up action
; **) a document name is taken from the zone
; +) return parameter All other parameters are
; call parameters.
\f
; rc fpproctx * page 2 10 03 80, 14.13;
; The length of an array is never checked.
; Violation of the above rules will terminate
; the program with a param alarm.
; Certain of the procedures may call the
; give up action of the zone. If this happens,
; the block procedure of the zone will be
; called.
; When the block procedure is called, z and
; s have their conventional meaning. The
; b-parameter however is an address
; pointing at a place where the four working
; registers are saved. The b-parameter may
; be used in a call of system(5) move_core:(b, ia)
; The answer may then be fetched by means of
; a call of system(5)movecore:(ia(1),ia).
; If the block procedure terminates by going
; through its final end, a jump to h36
; is performed.
; Implementation details
; The evaluation of the w parameters uses the
; stack in this way:
; x2+6 : pointer to next param to be evaluated
; x2+8 : value of action
; x2+10:
; .
; . : the w parameters
; .
; x2+20:
; After evaluation, the w-parameters are stored
; according to these rules:
; integer irr array zone
; first word value 0 addr 1. elem zone addr
; second word addr(>0) 0 -1 -1
;
; When the entries h22-h26, h29-h34, h48 and
; h79 are called, a call of the user's
; blockprocedure is prepared. The main
; task of this preparation is to save
; the giveup action (z+h2+2) and to
; insert a new give up action. As the
; segment allocation may change during
; the call of the user's blockprocedure,
; the return address points into the stack.
; this enables the code calling the user's
; blpr to update the return point, if the
; segment allocation has changed. It also
; enables the give up action to return to
; h36.
\f
; rc fpproctx * page 3 10 03 80, 14.13;
; The stack during execution of the i/o
; procedures has the following layout:
; last used + 0: 6 < 12+23
; - - + 2: z addr
; - - + 4: 26
; - - + 6: status addr = sref-10
; - - + 8: 26
; - - +10: ref to saved reg = srf - 18
; sref -18: addr of saved reg = sref - 16
; - -16: saved w0 ans addr
; - -14: saved w1 z descr
; - -12: saved w2 sh descr
; - -10: saved w3 status
; - - 8: layout during outinteger
; - - 6: jl. (2)
; - - 4: abs return addr
; - - 2: saved giveup action
;
; The give up action reestablishes the cell
; z+h2+2 and stores the contents of
; its registers in sref-16 to sref -10. Then
; the block procedure is called. If it
; returns, z+h2+2 and the abs return address
; is updated (blpr may be called more
; than once), and now a jump to fp base
; h36 is performed.
\f
; rc fpproctx * page 4 10 03 80, 14.13;
k=10000
s. a7, b3, c9, d2, g3, j30
h.
g0=0 ; g0=no. of externals
e5: ; start segment
g1: g3 , g2 ; head word
j13: g0+13 , 0 ; RS entry 13: last used
j30: g0+30 , 0 ; - - 30: savedw2w3
j4: g0+4 , 0 ; - - 4: take expr
j8: g0+8 , 0 ; - - 8: end addr expr
j29: g0+29 , 0 ; - - 29: param alarm
j3: g0+3 , 0 ; - - 3: reserve
j26: g0+26 , 0 ; - - 26: in
g2=k-2-g1 ; end of abswords
g3=k-2-g1 ; end of points
w.
e0: g0 ; external list; no ext
0 ; no. bytes
31 01 73, 12 00 00 ; date and clock
e1: rl. w2 (j13.) ; entry fp proc:
dl w1 x2+8 ; take action;
so w0 16 ; if action is an expr
jl. w3 (j4.) ; then take expression
ds. w3 (j30.) ; save sref;
rl w1 x1 ; convert entry no:
sn w1 79, al w1 20 ; 79 => 20
sn w1 48, al w1 21 ; 48 => 21
sn w1 7, al w1 37 ; 7 => 37
sn w1 14, al w1 38 ; 14 => 38
sn w1 67, al w1 39 ; 67 => 39
sl w1 20 ; if entry no < 20
sl w1 40 ; or entry no >= 40
jl. w3 (j29.) ; then param alarm;
al w0 12 ; next param:= 12
ds w1 x2+8 ; save action, next param;
\f
; rc fpproctx * page 5 10 03 80, 14.13;
c0: am (x2+6) ; repeat
dl w1 x2 ; take param(next param);
so w0 16 ; if param is an expression
jl. w3 (j4.) ; then take expression;
ds. w3 (j30.) ;
am (x2+8) ;
bz. w3 d0. ; w3:= pattern(action no)
am (x2+6) ; shift(next param-20);
ls w3 -20 ;
am (x2+6) ;
rl w0 x2-2 ; w0:= kind(next param)
la. w0 b3. ;
se w0 10 ; if kind = integer proc
sn w0 2 ; or kind = integer expr
al w0 26 ; then kind:= integer;
sz w3 2.1000 ; if zone bit
se w0 23 ; and kind = zone then
jl. a1. ; begin
al w0 x1 ; first:= addr;
al w1 -1 ; second:= -1; goto store;
jl. a4. ; end;
a1: so w3 2.0100 ; if array bit then
jl. a2. ; begin
sl w0 17 ; if kind = array
sl w0 24 ; or kind = zone then
jl. a2. ; begin
rl w0 x1 ; address:= base;
am (x2+6) ; dopeaddr:= base+first formal;
ba w1 x2-2 ; first:= address+lower-k;
rl w1 x1 ; second:= -1;
al w1 x1+2 ;
wa w0 2 ; goto store;
al w1 -1 ; end;
jl. a4. ; end;
a2: sz w3 2.0010 ; if integer bit
se w0 26 ; and kind = integer then
jl. a3. ; begin
rl w0 x1 ; first:= value; second:= addr;
jl. a4. ; goto store;
; end;
a3: so w3 2.0001 ; if not irrelevant bit
jl. w3 (j29.) ; then param alarm;
ld w1 -100 ; first:= second:= 0;
a4: rl w3 x2+6 ; store:
am x2 ; formal(next):=
ds w1 x3 ; first con second;
al w3 x3+4 ; next:= next+4;
rs w3 x2+6 ;
sh w3 20 ; until next > 20;
jl. c0. ;
\f
; rc fpproctx * page 6 10 03 80, 14.13;
rl w1 x2+8 ;
sh w1 34 ; if action no <= 34
jl. c1. ; then goto call acts with giveup;
jl. w3 c5. ; compute action addr;
bl. w1 x1+d2. ;
jl. x1+e5. ; goto special action(action);
c1: ; call acts with giveup:
se w1 27 ; if action = connect out
sn w1 28 ; or action = connect in
jl. c4. ; then goto connect;
al w1 -30 ; reserve 30 bytes;
jl. w3 (j3.) ;
jl. w3 c5. ; b0:= act addr.;
rs. w3 b0. ;
rl w3 x2+18 ;
rl. w0 b2. ;
ds w0 x2-6 ; stackref(-8:-6):= layout con jump
rl w1 x2+14 ; w1:= zone
al. w0 c2. ;
rx w0 x1+h2+2 ; swap giveup action
al. w3 c3. ; stackref(-4:-2):=
ds w0 x2-2 ; return addr con giveup;
dl w0 x2+10 ; w0:= w0 param;
sn w3 32 ; if action = outinteger
am -2 ; then w3 = addr of layout
al w3 x2-6 ; else w3:= addr of return;
rl w2 x2+18 ; w2:= w2 param;
jl. (b0.) ; goto fp-action;
c2: ds. w3 b0. ; give up action:
dl. w3 (j30.) ; reestablish sref;
ds w1 x2-14 ;
dl. w0 b0. ; save registers;
ds w0 x2-10 ;
rl w0 x2-2 ; reestablish give up action;
rs w0 x1+h2+2 ;
rl. w1 (j13.) ; w1:= last used;
rl. w3 b1. ;
rl w0 x2+14 ;
ds w0 x1+2 ; stack(0:2):= zone;
al w3 26 ; s
al w0 x2-10 ;
ds w0 x1+6 ; stack(4:6):= status;
al w0 x2-18 ;
ds w0 x1+10 ; stack(8:10):= register addr;
am (x2+14) ;
dl w1 h4+2 ; comment
ls w0 4 ; take users blpr;
jl. w3 (j4.) ;
ds. w3 (j30.) ; return from blpr:
rl w1 x2+14 ; w1:= zone;
al. w0 c2. ;
rx w0 x1+h2+2 ; swap give up action
al. w3 c3. ; stackref(-4:-2):=
ds w0 x2-2 ; return con saved giveup;
al w1 36 ; w1:= saved call action;
rx w1 x2+8 ; call action:= 36;
jl. w3 c5. ; compute action addr;
rs w1 x2+8 ; call action:= saved call action;
jl x3 ; goto h36;
\f
; rc fpproctx * page 7 10 03 80, 14.13;
c3: ; return from fp:
al w1 x2 ; w1:= w2;
dl. w3 (j30.) ;
rs. w2 (j13.) ; release reservation;
rl w0 x2+8 ; if action = inchar
sn w0 25 ; then char:= w1;
rs w1 (x2+20) ;
jl. (j8.) ; end address expr;
c4: ; connect inoutput:
rl w1 x2+16 ;
sh w1 0 ; if w1 param = integer then
jl. a5. ; begin if w1 param <> 0 then
se w0 0 ; param alarm;
jl. w3 (j29.) ; end;
a5: jl. w3 c5. ; compute action address
rl w0 x2+10 ; w0:= w0 param;
rl w1 x2+14 ; w1:= w1 param;
rl w2 x2+18 ; w2:= w2 param;
jl w3 x3 ; goto fp action
dl. w3 (j30.) ; restore stackref;
rs w0 (x2+12) ; w0 param:= w0;
jl. (j8.) ; end addr expression;
; procedure compute action address;
; registers: call return
; w0 irrelevant spoiled
; w1 - saved
; w2 stackref stackref
; w3 return action address
; x2+8 must contain the action number
; b0 is used for work.
c5: rs. w3 b0. ; save return
rx w1 x2+8 ; w1:= action no;
rl. w3 j26. ; action address:=
ba. w3 x1+d1. ; address of in + relative;
se w1 29 ; if action = stack
sn w1 30 ; or action = unstack
jl. a7. ; then goto check stackact;
a6: rx w1 x2+8 ; reestablish:
jl. (b0.) ; return;
a7: rl w0 x2+20 ; check stackact;
sh w0 -1 ; if w2 param = array
jl. a6. ; then goto reestablish;
rl w0 x2+14 ;
am (x2+18) ;
sn w1 x1 ; if integer value <> 0
se. w0 (j26.) ; or zone <> in
jl. w3 (j29.) ; then param alarm;
al w3 x3-4 ; action:= stack/unstack current in;
jl. a6. ; goto reestablish;
; end procedure compute action address
\f
; rc fpproctx * page 8 10 03 80, 14.13;
; special actions:
c6: rl w1 x2+14 ; parent message:
am (x2+18) ; w1:= addr of first part;
al w2 h1+2 ; w2:= name addr in zone
c7: ; finis message:
c8: jl w3 x3 ; break message:
jl. (j8.) ; end address expression;
c9: am (x2+14) ; end program:
al w1 h1+2 ; w1:= name addr in zone;
rl w2 x2+18 ; w2:= status;
jl x3 ; goto end program;
h. ;
d0=k-20 ; parameter table each parameter is described by the pattern:
; zone<3 + array<2 + integer<1 + irr
; for each action the parameters are packed:
; w0<8 + w1<4 + w2
2.0001<8 + 2.1000<4 + 2.0001 ; h79=20
2.0001<8 + 2.1000<4 + 2.0010 ; h48=21
2.0001<8 + 2.1000<4 + 2.0001 ; h22
2.0001<8 + 2.1000<4 + 2.0001 ; h23
2.0001<8 + 2.1000<4 + 2.0010 ; h24
2.0001<8 + 2.1000<4 + 2.0010 ; h25
2.0001<8 + 2.1000<4 + 2.0010 ; h26
2.0010<8 + 2.1010<4 + 2.0100 ; h27
2.0010<8 + 2.1010<4 + 2.0100 ; h28
2.0001<8 + 2.1000<4 + 2.0110 ; h29
2.0001<8 + 2.1000<4 + 2.0110 ; h30
2.0100<8 + 2.1000<4 + 2.0001 ; h31
2.0010<8 + 2.1000<4 + 2.0010 ; h32
2.0001<8 + 2.1000<4 + 2.0010 ; h33
2.0001<8 + 2.1000<4 + 2.0010 ; h34
;functions not calling a give_up action
2.0001<8 + 2.0100<4 + 2.1000 ; h35
0 ; not allowed ; h36
2.0001<8 + 2.1001<4 + 2.0010 ; h7=37
2.0001<8 + 2.0001<4 + 2.0001 ; h14=38
2.0001<6 + 2.0001<4 + 2.0001 ; h67=39
d1=k-20 ; entry points in fp relative
; to descriptor of in
h79-h20, h48-h20, h22-h20, h23-h20, h24-h20
h25-h20, h26-h20, h27-h20, h28-h20, h29-h20
h30-h20, h31-h20, h32-h20, h33-h20, h34-h20
h35-h20, h36-h20, h7 -h20, h14-h20, h67-h20
d2=k-35 ; entry points to special actions
c6-e5 , 0 , c9-e5 , c7-e5 , c8-e5
; h35 h36 , h7 , h14 , h67
\f
; rc fpproctx * page 9 10 03 80, 14.13;
w. 0 ; constants and variables
b0: 0 ; double cell used for various things
b1: 6<12+23 ; kind of a zone
b2: jl. (2) ; return jump from fp
b3: 2.11111 ; mask for kind
e4:
c. e4-e5-506
m. code on segment too long
z.
c. 502-e4+e5, ks-1, r. 252-(:e4-e5:)>1 z.
<:fp proc:>, 0 ; alarm text
e. ; end segment
; tails:
g0: g1: ; first and last tail:
1 ; 1 segment
0, 0, 0, 0 ; room for name
1<23 + e1-e5 ; entry point
1<18+41<12+41<6+41 ; no type procedure
3<18 ; (integer, undef, undef, undef)
4<12 + e0-e5 ; code proc, start of ext list
1<12 + 0 ; 1 segment, no bytes
p.<:insertproc:>
e.
if ok.no
(mode 0.yes
message fpproc not ok
lookup fpproc)
\f
; std_table_tx * page 1 14 11 80, 11.20;
; std_table
; **********
if listing.yes
char 10 12 10
std_table = set 1
std_table = algol
external
procedure std_table(alphabet);
_____________________________
integer array alphabet;
comment
the procedure initializes "alphabet" to the standard
ISO 7-bit alphabet. normally used in connection with
the algol procedure "intable".
if "alphabet" is not an array of 128 or 256
elements the procedure calls the run time alarm.
gi no 80038
november 1980
annette lund pedersen;
\f
comment std_table_tx * page 2 14 11 80, 11.20
0 1 2 3 4 5 6 7 8 9 ;
begin
integer i, j, c, low, up;
low := system(3)bounds:(up, alphabet);
c := up - low + 1;
if c <> 128 and c <> 256 then system(9)alarm:(c-1, <:<10>stdtable:>);
for j := 0 step 128 until c - 128 do
for i := 0 step 1 until 127 do
alphabet(low + i + j) :=
_ (case i + 1 of
_ (0, 7, 7, 7, 7, 7, 7, 7, _7, 7, 8, 7, 8, 0, 7, 7,
_ 7, 7, 7, 7, 7, 7, 7, 7, _7, 8, 7, 7, 7, 7, 7, 7,
_ 7, 7, 7, 7, 7, 7, 7, 5, _7, 7, 7, 3, 7, 3, 4, 7,
_ 2, 2, 2, 2, 2, 2, 2, 2, _2, 2, 7, 7, 7, 7, 7, 7,
_ 7, 6, 6, 6, 6, 6, 6, 6, _6, 6, 6, 6, 6, 6, 6, 6,
_ 6, 6, 6, 6, 6, 6, 6, 6, _6, 6, 6, 6, 6, 6, 7, 7,
_ 7, 6, 6, 6, 6, 6, 6, 6, _6, 6, 6, 6, 6, 6, 6, 6,
_ 6, 6, 6, 6, 6, 6, 6, 6, _6, 6, 6, 6, 6, 6, 7, 0))
_ shift 12 + i;
end;
end
if warning.yes
(mode 0.yes
message std_table not ok
lookup std_table)
\f
; rc utility procedures * page 1 10 03 80, 14.07;
; util_pr
; *******
if listing.yes
char 10 12 10
util_pr = set 1
util_pr = algol
external integer procedure util_pr
__________________________________
_ (z, t, exist);
zone z;
integer t;
boolean exist;
begin
integer q_proc;
real str;
util_pr :=
q_proc := 13;
write(out, nl, 3, <:; :>, q_proc, <:_procedures:>, nl, 2,
_ <:; proc_name______________version:>, nl, 1);
for t := 1 step 1 until q_proc do
if exist then
begin
str := real (case t of (
<:util<95>pr:>,
<:change<95>area:>,
<:chng<95>entr<95>pr:>,
<:claim<95>proc:>,
<:clear<95>proc:>,
<:convert<95>proc:>,
<:list<95>tail:>,
<:lookup<95>proc:>,
<:rename<95>proc:>,
<:scope<95>proc:>,
<:set<95>proc:>,
<:fp<95>proc:>,
<:stdtable:>));
wr_date_time(z, proc_transla(string str)
+ 0*write(z, sp, 16 - write(z, nl, 1, string str, <:, :>)));
end;
end utilproc;
end
if warning.yes
(mode 0.yes
message util_pr not ok
lookup util_pr)
\f
; rc utility procedures * page 2 10 03 80, 14.07;
if listing.yes
char 10 12 10
changearea = set 1
changearea = algol
external integer procedure changearea(z, i); zone z; integer i;
<*
_ changearea: 0 ok
_ 2 cat i/o error
_ 3 name not found,
_ maybe: zone not opened
_ 4 name protected
_ 5 name in use
_ 6 name format illegal,
_ probably: zone not opened
_ 7 catalog inconsistent
_ 9 claims exceeded
_ z zone opened to the area,
_ (so that the name is found in the zonedescriptor)
_ i integer bit pattern
_ bit value 1 => change size to segment count
_ bit value 2 => set shortclock to now
*>
begin integer array tail(1:10), ia(1:20);
integer res;
res:=monitor(42<*lookup*>, z, 0, tail);
if res=3 or res=6 then goto exit_changearea;
if i extract 1=1 then
begin
getzone6(z, ia);
tail(1):=ia(9);
if ia(13) = 6 and ia(15) - ia(14) = ia(16) then
tail(1) := tail(1) + 1;
end;
if i shift(-1) extract 1=1 then tail(6):=systime(7, 0, 0.0);
res:=monitor(44<*change*>, z, 0, tail);
if res=6 then res:=9;
exit_changearea:
changearea:=res;
end changearea;
end
if ok.no
mode warning.yes
if warning.yes
(mode 0.yes
message changearea not ok
lookup changearea)
\f
; rc utility procedures * page 3 10 03 80, 14.07;
; chng_entr_pr
; ************
if listing.yes
char 10 12 10
chng_entr_pr = set 1
chng_entr_pr = algol
external integer procedure changeentryproc(name, tail);
_______________________________________________________
long array name;
integer array tail;
<*
changeentryproc (return integer) 0 ok
_ 1 change kind impossible
_ 2 cat i/o error,
_ doc. not mounted or not ready
_ 3 name not found
_ 4 name protected
_ 5 name in use
_ 6 name format illegal
_ 7 catalog inconsistent
_ 8 change bs device impossible
_ 9 claims exceeded
name (call, long array) contains the entry name
tail (call, integer array) contains new entry tail
*>
begin integer i;
integer array ia(1:10);
zone zhelp(1, 1, stderror);
i:=1; open(zhelp, 0, string name(increase(i)), 0);
i:=monitor(42<*lookup*>, zhelp, 0, ia);
if i<>0 then
begin changeentryproc:=i; goto exit_changeentryproc end;
if tail(1)<0 or ia(1)<0 then
begin
if tail(1)>=0 or ia(1)>=0 then
begin changeentryproc:=1; goto exit_changeentryproc end;
goto change
end;
if tail(2)=0 or tail(2)=1 then goto change;
if tail(3) extract 8=0 then tail(4):=tail(5):=0;
if tail(2)<>ia(2) or tail(3)<>ia(3) or
tail(4)<>ia(4) or tail(5)<>ia(5) then
begin changeentryproc:=8; goto exit_changeentryproc end;
change:
for i:=1 step 1 until 10 do ia(i):=tail(i); <*fielding possible*>
i:=monitor(44<*change*>, zhelp, 0, ia);
if i=6 then i:=9;
changeentryproc:=i;
exit_changeentryproc:
end changeentryproc;
end
if warning.yes
(mode 0.yes
message chng_entr_pr not ok
lookup chng_entr_pr)
\f
; claimproc by name * page 4 17 03 80, 12.59;
; claim_proc
; **********
if listing.yes
char 10 12 10
claim_proc = set 1
claim_proc = algol
external boolean procedure claim_proc
_____________________________________
_ (keyno, bsno, bsname, entries, segm, slicelength);
value keyno;
integer keyno, bsno, entries, segm, slicelength;
long array bsname;
<*
claimproc(return, boolean) true if bsno>=0 and bsno<=max bsno
_ and keyno is legal
_ else false. If claimproc is false then
_ all return parameters are zero.
keyno (call, integer) 0=temp
_ 1=temp( sos )
_ 2=login
_ 3=user/project
bsno (call and return, integer)
_ -1 : return bsno corresponding to bsname.
_ >-1 : the bsno is lookedup in nametable and
_ the corresponding bsname is returned.
bsname (call and return, long array 1:2)
_ if bsno = -1 then bsname(called) is lookedup
_ in nametable and bs_no is set
_ else bsname is returned corresponding to bsno.
entries (return, integer) no. of entries of key=keyno on called
_ device
segm (return, integer) no. of segm. of key=keyno on called
_ device
slicelength (return, integer) slicelength on called device
*>
begin
own boolean init;
own integer bsdevices, firstbs, ownadr;
integer i;
long array field name;
integer array core(1:18);
if -, init then
begin
long array dummy(1:2);
init:=true;
system(5, 92, core);
bsdevices:=(core(3)-core(1))//2;
firstbs:=core(1);
ownadr:=system(6, i, dummy);
end;
if bsno<-1 or bsno>=bsdevices
or keyno<0 or keyno>3 then
_ goto exitclaim;
\f
comment claimproc by name * page 5 17 03 80, 12.59
0 1 2 3 4 5 6 7 8 9 ;
begin integer array nametable(1:bsdevices);
name:=18;
i:= if bs_no<0 then 0 else bsno;
system(5, firstbs, nametable);
repeat
begin
i:=i+1;
system(5, nametable(i)-36, core);
if core(10)=0 then goto exitclaim;
if ( if bsno>=0 then true else
_ bsname(1)=core.name(1) and bsname(2)=core.name(2)) then
begin
bsname(1):=core.name(1); bsname(2):=core.name(2);
slicelength:=core(15);
system(5, ownadr+core(1), core);
entries:=core(keyno+1) shift (-12);
segm:=core(keyno+1) extract 12 * slicelength;
bsno:=i-1;
end;
end;
until i>=bsdevices or bsno>=0;
end;
if bsno<0 then
begin
exitclaim:
entries:=segm:=slicelength:=0;
bsname(1):=bsname(2):=0;
claimproc:=false;
end
else
claimproc:=true;
end claim_proc;
end
if warning.yes
(mode 0.yes
message claim_proc not ok
lookup claim_proc)
\f
; rc utility procedures * page 6 10 03 80, 14.07;
; clear_proc
; **********
if listing.yes
char 10 12 10
clear_proc = set 1
clear_proc = algol
external integer procedure clear_proc(scope, name);
___________________________________________________
long array scope, name;
<*
clearproc (return, integer) 0 cleared
_ 1 the call param scope does not contain
_ a legal scope name
_ 2 cat i/o error
_ 3 entry not found
_ 4 entry protected
_ 5 entry in use
_ 6 name format illegal
_ 7 catalog inconsistent
scope (call, long array) contains the name of a scope
name (call, long array) contains the name of the entry to be cleared
*>
begin integer scopeno, i;
integer array bases(1:8), entry(1:17), ba(1:2);
zone zhelp(1, 1, stderror);
clearproc:=0;
scopeno:=if scope(1)=long<:temp:> then 1 else
if scope(1)=long<:login:> then 2 else
if scope(1)=long<:user:> then 3 else
if scope(1)=long<:proje:> add 99 and
scope(2)=long<:t:> then 4 else
if scope(1)=long<:syste:> add 109 then 5 else 6;
if scopeno=6 then
begin clearproc:=1; goto exit_clearproc end;
system(11, i, bases);
open(zhelp, 0, <::>, 0); close(zhelp, false);
i:=if scopeno<3 then 3 else if scopeno=3 then 5 else 7;
ba(1):=bases(i); ba(2):=bases(i+1);
monitor(72<*set cat base*>, zhelp, 0, ba);
i:=1; open(zhelp, 0, string name(increase(i)), 0);
i:=monitor(76<*head and tail*>, zhelp, 0, entry);
if i<>0 then
begin clearproc:=i; goto reset_base end;
i:=entry(1) extract 3;
if scopeno=1 and i<>0 or
scopeno=2 and i<>2 or
scopeno>2 and i<>3 then goto clear_not_found;
if scopeno<>5 then
begin
if extend entry(2)<> extend ba(1) or
extend entry(3)<> extend ba(2) then goto clear_not_found
end
else
begin
if -, (extend entry(2)<extend ba(1) or
extend entry(3)>extend ba(2)) and
(extend entry(2)>extend ba(1) or
extend entry(3)<ba(2)) then goto clear_not_found;
end;
\f
comment rc utility procedures * page 7 10 03 80, 14.07
0 1 2 3 4 5 6 7 8 9 ;
clearproc:=monitor(48<*remove entry*>, zhelp, 0, entry);
if false then
clear_not_found: clearproc:=3;
reset_base:
close(zhelp, false);
open(zhelp, 0, <::>, 0);
monitor(72<*set cat base*>, zhelp, 0, bases);
exit_clear_proc:
end clear_proc;
end
if warning.yes
(mode 0.yes
message clear_proc not ok
lookup clear_proc)
\f
; rc utility procedures * page 8 10 03 80, 14.07;
; convert_proc
; ************
if listing.yes
char 10 12 10
convert_proc = set 1
convert_proc = algol
external integer procedure convert_proc(name, printer, paper);
______________________________________________________________
long array name;
long printer; integer paper;
<*
convertproc (return, integer) 0 ok
_ 1 cfbuf exceeded
_ 2 name not found
_ 3 login scope
_ 4 temp resources exceeded
_ 5 name in use
_ 6 name is not area
_ 7 name is not a text file
_ 19 attention status at remote batch term.
_ 20 device unknown
_ 21 device not printer
_ 22 parent device disconnected
name (call, long array) contains the name of the file
printer (call, long) contains the name of the printer:
_ <::> output on remote printer
_ if any is present
_ <:std:> output on standard printer,
_ local to rc4000
_ <:printername:> output on the remote printer
_ with the specified name
*>
begin integer array m(1:8);
long field lf;
m(1):=30 shift 12+1 shift 9+1;
lf:=6;
m.lf:=if printer=long<::> then long<:conv:> else printer;
m(4):=paper;
lf:=12;
m.lf:=name(1);
lf:=16;
m.lf:=if name(1) extract 8=0 then 0 else name(2);
system(10<*parent message*>, 1, m);
convertproc:=m(1);
end convert_proc;
end;
if warning.yes
(mode 0.yes
message convert_proc not ok
lookup convert_proc)
\f
; rc utility procedures * page 9 10 03 80, 14.07;
; list_tail
; *********
if listing.yes
char 10 12 10
list_tail = set 1
list_tail = algol
external procedure list_tail(zout, tail);
_________________________________________
<* the procedure lists the contents of array tail *>
zone zout; integer array tail;
<*
zout (return, zone) zone for output
tail (call, integer array contains entry tail
*>
begin integer n, i;
long array field doclaf;
procedure outshortclock(shortclock);
value shortclock; integer shortclock;
begin real r;
write(zout, <: d.:>, <<zddddd>,
_ systime(4, (if shortclock>0 then shortclock
_ else shortclock + extend 1 shift 24)
_ /625*1 shift 15+12, r),
_ <:.:>, <<zddd>, r/100)
end outshortclock;
doclaf:=2;
n:=tail(1);
if n>=0 then write(zout, <<z>, n) else
write(zout, <<z>, n shift (-12) extract 12, <:.:>, n extract 12);
n:=tail(2);
if n=0 or n=1 then write(zout, << z>, n) else
write(zout, <: :>, tail.doclaf);
n:=tail(9) shift (-12);
i:=6;
if -, (n=4 or n>=32) and tail(6)<>0 then
begin outshortclock(tail(6)); i:=7 end;
for i:=i, i+1 while i<11 do
begin
n:=tail(i);
if n<4096 then write(zout, << z>, n) else
write(zout, << z>, n shift (-12) extract 12,
<:.:>, <<z>, n extract 12);
end;
end list_tail;
end
if warning.yes
(mode 0.yes
message list_tail not ok
lookup list_tail)
\f
; rc utility procedures * page 10 10 03 80, 14.07;
; lookup_proc
; ***********
if listing.yes
char 10 12 10
lookup_proc = set 1
lookup_proc = algol
external integer procedure lookup_proc(scope, name, tail);
_________________________________________________________
long array scope, name;
integer array tail;
<*
lookupproc (return, integer) 0 found
_ 1 the call param scope does not
_ contain a legal scope name
_ 2 cat i/o error
_ 3 not found
_ 6 name format illegal
scope (call, long array) contains the name of a scope or <::>
_ if scope(1)=long<::> then scope will be
_ a return parameter, which may be <:***:>
name (call, long array) contains the name of the entry
tail (return, integer array)
_ contains tail of the entry
_ 1 size or modekind
_ 2:5 docname
_ 6 shortclock, in case shortclock
_ is found in the entry
_ 7:10 remaining tail
*>
begin integer scopeno, i;
long l1, l2;
integer array bases(1:8), ba(1:2), head_and_tail(1:17);
zone zhelp(1, 1, stderror);
lookupproc:=0;
scopeno:=if scope(1)=long<::> then 0 else
if scope(1)=long<:temp:> then 1 else
if scope(1)=long<:login:> then 2 else
if scope(1)=long<:user:> then 3 else
if scope(1)=long<:proje:> add 99 and
scope(2)=long<:t:> then 4 else
if scope(1)=long<:syste:> add 109 then 5 else 6;
if scopeno=6 then
begin
lookupproc:=1;
goto zeros
end;
system(11, i, bases);
open(zhelp, 0, <::>, 0); close(zhelp, true);
i:=if scopeno<3 then 3 else if scopeno=3 then 5 else 7;
ba(1):=bases(i); ba(2):=bases(i+1);
monitor(72<*set cat base*>, zhelp, 0, ba);
i:=1; open(zhelp, 0, string name(increase(i)), 0);
\f
comment rc utility procedures * page 11 10 03 80, 14.07
0 1 2 3 4 5 6 7 8 9 ;
i:=monitor(76<*head and tail*>, zhelp, 0, head_and_tail);
if i<>0 then
begin
lookupproc:=i;
goto zeros
end;
if scopeno>0 and scopeno<5 and (
extend head_and_tail(2)<>extend ba(1) or
extend head_and_tail(3)<>extend ba(2)) then goto lookup_not_found;
i:=head_and_tail(1) extract 3;
if scopeno=1 and i<>0 or
scopeno=2 and i<>2 or
scopeno>2 and i<>3 then goto lookup_not_found;
if scopeno=5 then
begin
if -, (extend head_and_tail(2)<extend ba(1) or
extend head_and_tail(3)>extend ba(2)) then
goto lookup_not_found
end;
if false then
begin
lookup_not_found:
lookupproc:=3;
zeros:
for i:=1 step 1 until 10 do tail(i):=0;
goto if scopeno=6 then exit_lookupproc else reset_base;
end;
if scopeno=0 then
begin
case i+1 of
begin
comment key 0, maybe temp;
if extend head_and_tail(2)=extend bases(3) and
extend head_and_tail(3)=extend bases(4)
then scopeno:=1 else scopeno:=6;
comment key 1; scopeno:=6;
comment key 2, maybe login;
if extend head_and_tail(2)=extend bases(3) and
extend head_and_tail(3)=extend bases(4)
then scopeno:=2 else scopeno:=6;
comment key 3, user, project, system;
begin
l1:=head_and_tail(2);
l2:=head_and_tail(3);
if l1=extend bases(5) and
l2=extend bases(6) then scopeno:=3
else
if l1=extend bases(7) and
l2=extend bases(8) then scopeno:=4
else
if l1<=extend bases(7) and
l2>=extend bases(8) then scopeno:=5
else scopeno:=6
end key 3;
end cases;
scope(1):=long(case scopeno of (<:temp:>, <:login:>, <:user:>,
<:proje:> add 99, <:syste:> add 109, <:***:>));
scope(2):=if scopeno=4 then long<:t:> else long<::>;
end;
\f
comment rc utility procedures * page 12 10 03 80, 14.07
0 1 2 3 4 5 6 7 8 9 ;
monitor(42<*lookup*>, zhelp, 0, tail);
reset_base:
close(zhelp, false);
open(zhelp, 0, <::>, 0);
monitor(72<*set cat bases*>, zhelp, 0, bases);
exit_lookupproc:
end lookup_proc;
end
if warning.yes
(mode 0.yes
message lookup_proc not ok
lookup lookup_proc)
\f
; rc utility procedures * page 13 10 03 80, 14.07;
; rename_proc
; ***********
if listing.yes
char 10 12 10
rename_proc = set 1
rename_proc = algol
external integer procedure rename_proc(oldname, newname);
_________________________________________________________
long array oldname, newname;
<*
renameproc (return, integer) 0 ok
_ 1 new name exists already
_ 2 cat i/o error
_ document not mounted or
_ document not ready
_ 3 oldname not found
_ 4 name protected
_ 5 name in use
_ 6 name format illegal
_ 7 catalog inconsistent
oldname (call, long array) contains old name
newname (call, long array) contains new name or <::>
_ if newname(1)=long<::> then
_ newname is a return parameter
*>
begin integer i; boolean wrk;
long array field laf;
zone zhelp(1, 1, stderror);
integer array ia(1:20);
wrk:=newname(1)=long<::>;
if wrk then
begin
generate_next:
monitor(68<*generate*>, zhelp, 0, ia);
getzone6(zhelp, ia);
laf:=2;
newname(1):=ia.laf(1); newname(2):=ia.laf(2);
end;
laf:=0;
ia.laf(1):=newname(1);
ia.laf(2):=if newname(1) extract 8=0 then long<::> else newname(2);
i:=1; open(zhelp, 0, string oldname(increase(i)), 0);
i:=monitor(46<*rename*>, zhelp, 0, ia);
renameproc:=i;
if i=3 then
begin <*name already exists*>
i:=monitor(42<*lookup*>, zhelp, 0, ia);
if i=0 then
begin
if wrk then goto generate_next else renameproc:=1
end;
end
end rename_proc;
end
if warning.yes
(mode 0.yes
message rename_proc not ok
lookup rename_proc)
\f
; rc utility procedures * page 14 10 03 80, 14.07;
; scope_proc
; **********
if listing.yes
char 10 12 10
scope_proc = set 1
scope_proc = algol
external integer procedure scope_proc(scope, kit, name);
________________________________________________________
long array scope, kit, name;
<*
scopeproc (return, integer) 0 ok
_ 1 hard error
_ 2 bs device not ready
_ 3 name not found
_ 4 name protected
_ 5 name in use
_ 6 claims exceeded
_ 7 catalog error
_ 8 change bs device impossible
_ 9 the call param scope does not
_ contain a legal scope name
_ 10 bs device unknown
scope (call, long array) contains the name of a scope
kit (call, long array) contains a kit name or <::>
name (call, long array) contains name of the entry to
_ be scoped
the procedure is a translation of the utility program scope
which explains some strange constructions
*>
begin integer i, newkey, oldkey;
boolean non_area, work_in_use;
long array field laf, laf0;
integer array newbase, catbase, stdbase, maxbase(1:2), ia(1:20),
newkit, oldkit, wrkname, ianame(1:4);
zone zname, zempty, zwrk(1, 1, stderror);
boolean procedure find_old_entry;
begin
find_old_entry:=true;
monitor(72<*catbase*>, zempty, 0, newbase);
i:=monitor(76<*lookup*>, zname, 0, ia);
if i<>0 then
begin
if i=3 then
begin find_old_entry:=false; goto exit_findentry end;
scopeproc:=7;
goto exit_scopeproc
end;
if extend ia(2)<>extend newbase(1) or
extend ia(3)<>extend newbase(2) then find_old_entry:=false;
exit_findentry:
end find_old_entry;
\f
comment rc utility procedures * page 15 10 03 80, 14.07
0 1 2 3 4 5 6 7 8 9 ;
scopeproc:=0;
open(zempty, 0, <::>, 0);
monitor(68<*generate name*>, zwrk, 0, ia);
getzone6(zwrk, ia);
laf0:=0; laf:=2;
wrkname.laf0(1):=ia.laf(1);
wrkname.laf0(2):=ia.laf(2);
i:=if scope(1)=long<:temp:> then 1 else
if scope(1)=long<:login:> then 2 else
if scope(1)=long<:user:> then 3 else
if scope(1)=long<:proje:> add 99 and
scope(2)=long<:t:> then 4 else 5;
if i=5 then
begin scopeproc:=9; goto exit1_scopeproc end;
newkey:=case i of (0, 2, 3, 3);
system(11, i, ia);
i:=if i<3 then 3 else if i=3 then 5 else 7;
newbase(1):=ia(i); newbase(2):=ia(i+1);
catbase(1):=ia(1); catbase(2):=ia(2);
stdbase(1):=ia(3); stdbase(2):=ia(4);
maxbase(1):=ia(7); maxbase(2):=ia(8);
non_area:=work_in_use:=false;
i:=1; open(zname, 0, string name(increase(i)), 0);
ianame.laf0(1):=name(1);
ianame.laf0(2):=if name(1) extract 8=0 then long<::> else name(2);
i:=monitor(76<*lookup*>, zname, 0, ia);
if i<>0 then
begin
scopeproc:=if i=3 then 3 else 7;
goto exit_scopeproc
end;
if extend ia(2)<extend maxbase(1) or
extend ia(3)>extend maxbase(2) then
begin scopeproc:=4; goto exit_scopeproc end;
newkit.laf0(1):=kit(1);
newkit.laf0(2):=if kit(1) extract 8=0 then long<::> else kit(2);
if kit(1)=long<::> then goto maybe_set_key3;
if ia(8<*size*>)>=0 then goto compare_names;
begin integer bsno, oldbsno, firstbs, bsdevices, mainchain;
integer array core(1:18);
system(5, 92, core);
bsdevices:=(core(3)-core(1))//2;
firstbs:=core(1);
mainchain:=core(4);
begin integer array nametable(1:bsdevices);
laf:=18;
system(5, firstbs, nametable);
bsdevices:=bsdevices-1;
for bsno:=0 step 1 until bsdevices do
begin
system(5, nametable(bsno+1)-36, core);
if kit(1)=core.laf(1) and
newkit.laf0(2)=core.laf(2) then goto kit_found;
end;
scopeproc:=10;
goto exit_scopeproc;
\f
comment rc utility procedures * page 16 10 03 80, 14.07
0 1 2 3 4 5 6 7 8 9 ;
kit_found:
if newkey>=2 then non_area:=true;
if ia(1) extract 3<*oldkey*> <2 then goto maybe_set_key3;
oldbsno:=ia(1) shift (-12);
if oldbsno=0 then
begin
for oldbsno:=-1, oldbsno+1 while
nametable(oldbsno+1)<>mainchain do;
end
else
oldbsno:=(oldbsno-2048)//2;
system(5, nametable(oldbsno+1)-36, core);
oldkit.laf0(1):=core.laf(1);
oldkit.laf0(2):=core.laf(2);
if oldbsno<>bsno and non_area then
begin scopeproc:=8; goto exit_scopeproc end;
goto maybe_set_key3;
end
end find bsno;
compare_names:
laf:=16;
if ia.laf(1)<>kit(1) or
ia.laf(2)<>newkit.laf0(2) then
begin scopeproc:=8; goto exit_scopeproc end;
maybe_set_key3:
if newkey<=2 then goto set_interval;
i:=monitor(if non_area then 90 else 50,
zname, newkey, newkit);
if i=0 then goto set_interval;
if work_in_use then goto repair_and_giveup;
if i=6 then goto try_rename else
begin scopeproc:=i; goto exit_scopeproc end;
set_interval:
i:=monitor(74<*entry interval*>, zname, 0, newbase);
if i=0 then goto almost_ok_finis
else if i = 5 then goto in_use;
if -, find_old_entry then
begin scopeproc:=7; goto exit_scopeproc end;
i:=monitor(48<*remove*>, zname, 0, ia);
if i=5 then
begin
in_use:
monitor(72<*catbase*>, zempty, 0, catbase);
monitor(50<*perm*>, zname, oldkey, ia);
scopeproc:=5;
goto exit_scopeproc
end
else
if i<>0 then
begin scopeproc:=7; goto exit_scopeproc end;
monitor(72<*catbase*>, zempty, 0, catbase);
goto set_interval;
\f
comment rc utility procedures * page 17 10 03 80, 14.07
0 1 2 3 4 5 6 7 8 9 ;
almost_ok_finis:
if newkey=3 then goto remove_work;
monitor(72<*catbase*>, zempty, 0, newbase);
i:=monitor(if non_area then 90 else 50,
zname, newkey, newkit);
if i<>0 then
begin scopeproc:=i; goto exit_scopeproc end;
monitor(72<*catbase*>, zempty, 0, catbase);
remove_work:
if work_in_use then monitor(48<*remove*>, zwrk, 0, ia);
goto exit_scopeproc;
try_rename:
if -, find_old_entry then
begin scopeproc:=6; goto exit_scopeproc end;
i:=monitor(46<*rename*>, zname, 0, wrkname);
if i<>0 then
begin scopeproc:=i; goto exit_scopeproc end;
monitor(74<*entrybase*>, zwrk, 0, stdbase);
monitor(72<*catbase*>, zempty, 0, stdbase);
monitor(50<*perm*>, zwrk, 0, ia);
work_in_use:=true;
monitor(72<*catbase*>, zempty, 0, catbase);
goto maybe_set_key3;
repair_and_giveup:
monitor(72<*catbase*>, zempty, 0, stdbase);
monitor(if ia(1) shift (-12)<0 then 90 else 50,
zwrk, newkey, oldkit);
monitor(74<*entrybase*>, zwrk, 0, newbase);
monitor(46<*rename*>, zwrk, 0, ianame);
scopeproc:=6;
exit_scopeproc:
monitor(72<*catbase*>, zempty, 0, catbase);
exit1_scopeproc:
end scope_proc;
end
if warning.yes
(mode 0.yes
message scope_proc not ok
lookup scope_proc)
\f
; rc utility procedures * page 18 10 03 80, 14.07;
; set_proc
; ********
if listing.yes
char 10 12 10
set_proc = set 1
set_proc = algol
external integer procedure set_proc(name, tail);
________________________________________________
long array name; integer array tail;
<*
setproc (return, integer) 0 ok
_ 1 change kind impossible
_ 2 bs device unknown
_ 3 change bs device impossible
_ 4 no resources
_ 5 in use
_ 6 name format illegal
_ 7 catalog inconsistent
name (call, long array) contains the entry name.
_ If name(1)=long<::> a wrkname is
_ created and name is return parameter.
tail (call, long array) contains the entry tail
_ 1 size or modekind
_ 2:5 docname
_ 6 shortclock, in case shortclock
_ is found in the entry
_ 7:10 remaining tail
*>
begin integer i;
long array field laf;
zone zhelp(1, 1, stderror);
integer array ia(1:20);
i:=1; open(zhelp, 0, string name(increase(i)), 0);
laf:=0; for i:=1 step 1 until 5 do ia.laf(i):=tail.laf(i);
i:=monitor(40<*create*>, zhelp, 0, ia);
setproc:=i;
if name(1)=long<::> then
begin <*get wrkname*>
getzone6(zhelp, ia);
laf:=2;
name(1):=ia.laf(1);
name(2):=ia.laf(2);
end;
if i=3 then
begin <*entry exists*>
i:=monitor(42<*lookup*>, zhelp, 0, ia);
if i<>0 then
begin setproc:=7; goto exit_setproc end;
if tail(1)<0 or ia(1)<0 then
begin
if tail(1)>=0 or ia(1)>=0 then
begin setproc:=1; goto exit_setproc end;
goto change
end;
\f
comment rc utility procedures * page 19 10 03 80, 14.07
0 1 2 3 4 5 6 7 8 9 ;
if tail(2)=0 or tail(2)=1 then goto change;
if tail(3) extract 8=0 then tail(4):=tail(5):=0;
if tail(2)<>ia(2) or tail(3)<>ia(3) or
tail(4)<>ia(4) or tail(5)<>ia(5) then
begin setproc:=3; goto exit_setproc end;
change:
laf:=0; for i:=1 step 1 until 5 do ia.laf(i):=tail.laf(i);
i:=monitor(44<*change*>, zhelp, 0, ia);
if i=6 then i:=4;
setproc:=i;
end entry exists;
exit_setproc:
end set_proc;
end
if warning.yes
(mode 0.yes
message set_proc not ok
lookup set_proc)
\f
; rc utility procedures * page 20 10 03 80, 14.07;
if 0.no
(
util_pr = compresslib,
changearea,
chng_entr_pr,
claim_proc,
clear_proc,
convert_proc,
list_tail,
lookup_proc,
rename_proc,
scope_proc,
set_proc,
fp_proc,
stdtable
if 2.yes
(
scope user,
util_pr,
changearea,
chng_entr_pr,
claim_proc,
clear_proc,
convert_proc,
list_tail,
lookup_proc,
rename_proc,
scope_proc,
set_proc,
fp_proc,
stdtable
)
lookup,
util_pr,
changearea,
chng_entr_pr,
claim_proc,
clear_proc,
convert_proc,
list_tail,
lookup_proc,
rename_proc,
scope_proc,
set_proc,
fp_proc,
stdtable
)
end
finis
▶EOF◀