|
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: 26880 (0x6900)
Types: TextFile
Names: »scatuptx«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »scatuptx«
└─⟦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⟧
; susercat update * page 1 18 07 80, 15.43;
if listing.yes
char 10 12 10
scatup = set 1 disc1
scatup = algol connect.no
begin
comment the program handles the s_user_catalog <susercat>.
the format of <susercat> is shown in s reference manual p.74.
the following functions has been implemented:
1. create a new <susercat>. An area <susercat> must be present
_________
syntax of call:
_ *
scatup newcat.<catalog size in segm> !device name!
_ 1
2. insert an entry in <susercat>
_________
syntax of call:
_ *
_ !<dev. name>.<perm sli>.<perm ent> !
_ !temp.<temp sli dev0>.<temp ent dev0>!
_ !prio.<integer> !
_ !comm.<integer> !
_ !buf.<integer> !
_ !area.<integer> !
_ !inter.<integer> !
scatup insert.<entry name> !func.<integer> !
_ !std.<lower>.<upper> !
_ !max.<lower>.<upper> !
_ !user.<lower>.<upper> !
_ !addr.<integer> !
_ !size.<integer> !
_ !prog.<prog> !
_ 0
a negative base must be represented as n.<integer>
the default values are:
<dev 0>.5.5
buf.4 area.6
std.8388605.8388605
max.8388605.8388605
user.8388605.8388605
size.12800 prog.fp
all others are set to zero
3. delete an entry in <susercat>
_________
syntax of call:
scatup delete.<entry name>
4. list an entry in <susercat>
___________ entry 0 - -
___________ all entries - -
___________ the device names and
___________ the names of all entries - -
syntax of call:
_ 1
_ !cat !
scatup list.!<entry name>!
_ !all !
_ !names !
_ 1
;
\f
comment susercat update * page 2 18 07 80, 15.43;
procedure error(no);
______________________
integer no;
begin
case no of
begin
<*1*> write(out, "nl", 1, <:syntax:>);
<*2*> write(out, "nl", 1, param.ln_f, <: entry unknown:>);
<*3*> write(out, "nl", 1, param.ln_f, "sp", 2,
_ <:device not found in nametable:>);
<*4*> write(out, "nl", 1, <:devicename expected after catsize:>);
<*5*> write(out, "nl", 1, param.ln_f, <: parameter error:>);
<*6*> write(out, "nl", 1, param.ln_f, "sp", 2, <:action unknown:>);
<*7*> write(out, "nl", 1, <:action missing:>);
<*8*> write(out, "nl", 1, <:parameter missing:>);
<*9*> write(out, "nl", 1, <:catalog full:>);
<*10*> write(out, "nl", 1, keyword.ln_f,
_ <: unknown device name:>);
<*11*> write(out, "nl", 1, param.ln_f, <: entry already exists:>);
<*12*> write(out, "nl", 1, <:no output file allowed:>);
<*13*> write(out, "nl", 1, <:too many parameters:>);
end;
write(out, "nl", 1, <:***scatup no update performed:>);
goto stop;
end;
integer procedure hash(name, catsize);
___________________________________
comment compute hashvalue;
long array name;
integer catsize;
begin
integer nv;
long name1;
name1 := name(1) + name(2);
nv := name1 extract 24 + name1 shift (-24);
if nv < 0 then nv := - nv;
hash := nv mod catsize;
end;
boolean procedure neg;
______________________
comment the procedure reads a parameter. If the parameter = n
_ for negativ the procedure is true and it reads
_ the next parameter;
begin
neg := false;
ip := readparam(param);
if ip <> 3 and ip <> 4 then error(1);
if ip = 4 then
begin
if long param(1) = long <:n:> then
_ neg := true
else error(5);
if readparam(param) <> 3 then error(5);
end;
end neg;
\f
comment susercat update * page 3 18 07 80, 15.43;
boolean procedure search(start_segm, end_segm, proc_name, func, upd);
___________________________________________________________
comment search segment;
comment func=1 means: find <proc_name> entry in s_catalog
- 2 - : find first unused entry starting at <hash_value>;
value start_segm, end_segm;
integer start_segm, end_segm, func;
long array proc_name;
boolean upd;
begin
boolean found;
search := found := false;
setposition(s_cat, 0, start_segm);
for track := start_segm + 1 step 1 until end_segm do
begin
repeat
begin
if upd then rest := swoprec_6(s_cat, rec_lng)
else rest := inrec_6(s_cat, rec_lng);
h_key := s_cat.h_key_f;
begin
case func of
begin
<*1*>
begin
if h_key <> -1 and h_key <> -2 and
_ s_cat.name_f(1) = proc_name(1) and
_ s_cat.name_f(2) = proc_name(2) then
begin
search := found := true;
track := end_segm + 1;
end;
end;
<*2*>
begin
if h_key = -1 or h_key = -2 then
begin
search := found := true;
track := end_segm + 1;
end;
end;
end;
end;
end;
until rest < rec_lng or found;
end;
end search;
\f
comment susercat update * page 4 18 07 80, 15.43;
procedure init;
_______________
comment inrec entry 0 and initialize;
begin
inrec_6(s_cat, 4);
rec_lng := s_cat.lng_f;
rest := changerec_6(s_cat, rec_lng);
discs := s_cat.lng_0// 6 - 2;
max_tracks := s_cat.segm_f;
ln_f := 0;
for t := 1 step 2 until discs do
begin
rec_f := rec_f + 12;
d_f := d_f + 8;
disc.d_f(1) := s_cat.rec_f.lg_f1;
disc.d_f(2) := s_cat.rec_f.lg_f2;
sr(t) := s_cat.rec_f.slice_f;
sr(t+1) := s_cat.rec_f.ref_f;
end;
end init;
\f
comment susercat update * page 5 18 07 80, 15.43;
procedure newcat;
_________________
comment create new s_catalog;
begin
integer j, ref;
ln_f := 0;
ref := 44 - 8;
if readparam(param) = 3 then
max_tracks := param(1)
else error(1);
rest := outrec_6(s_cat, 512);
for l_f := 4 step 4 until 512 do
s_cat.l_f := 0;
s_cat.segm_f := max_tracks;
t := 0;
for j := readparam(param) while j <> 0 do
begin
t := t + 1;
if j = 2 then
begin
integer i, bsno;
long array par(1:2);
par(1) := long param(1);
par(2) := long param(2);
bsno := -1;
rec_f := rec_f + 12;
ref := ref + 8;
s_cat.rec_f.lg_f1 := long param(1);
s_cat.rec_f.lg_f2 := long param(2);
if -, claim_proc(3, bsno, par, i, i,
_ s_cat.rec_f.slice_f) then error(3);
s_cat.rec_f.ref_f := ref;
end
else error(4);
end;
rec_lng := s_cat.lng_f := 44 + 8 * t;
rec_0_lng := s_cat.lng_0 := 6 + 12 * t;
setposition(s_cat, 0, 0);
rest := swoprec_6(s_cat, rec_lng);
for track := 1 step 1 until max_tracks do
begin
repeat
begin
rest := swoprec_6(s_cat, rec_lng);
for l_f := 4 step 4 until rec_lng do
s_cat.l_f := 0;
s_cat.h_key_f := -1;
end;
until rest < rec_lng;
end;
end newcat;
\f
comment susercat update * page 6 18 07 80, 15.43;
procedure delete;
_________________
comment delete entry <proc_name> in s_catalog;
begin
update := true;
init;
if readparam(param) = 4 then
begin
boolean found;
integer h;
h := hash(param.ln_f, s_cat.segm_f);
found := search(h, max_tracks, param.ln_f, 1, update);
if -, found then found := search(0, h, param.ln_f, 1, update);
if found then
begin
for l_f := 4 step 4 until rec_lng do
s_cat.l_f := 0;
s_cat.h_key_f := -2;
end
else error(2);
end
else error(5);
if readparam(param) <> 0 then error(13);
end delete;
\f
comment susercat update * page 7 18 07 80, 15.43;
procedure insert;
_________________
comment insert entry <proc_name> in s_catalog;
begin
boolean found;
integer h;
integer field ent_pm_d0_f, segm_pm_d0_f;
update := true;
init;
if readparam(param) = 4 then
begin
h := hash(param.ln_f, s_cat.segm_f);
found := search(h, max_tracks, param.ln_f, 1, update);
if -, found then found := search(0, h, param.ln_f, 1, update);
if found then error(11);
found := search(h, max_tracks, param.ln_f, 2, update);
if -, found then found := search(0, h, param.ln_f, 2, update);
if found then
begin
comment standard values in process entry;
_____________________________________
for l_f := 4 step 4 until rec_lng do
s_cat.l_f := 0;
s_cat.h_key_f := h;
s_cat.name_f(1) := long param(1);
s_cat.name_f(2) := long param(2);
s_cat.buf_area_f := 4 shift 12 + 6;
s_cat.max_lo := 8388605;
s_cat.max_hi := 8388605;
s_cat.std_lo := 8388605;
s_cat.std_hi := 8388605;
s_cat.size := 12800;
s_cat.prog_f(1) := long <:fp:>;
s_cat.usr_lo := 8388605;
s_cat.usr_hi := 8388605;
ent_pm_d0_f := 50;
segm_pm_d0_f := 52;
s_cat.ent_pm_d0_f := 5;
s_cat.segm_pm_d0_f := 5 * sr(1);
comment put in parameter values;
________________________
for j := readparam(keyword) while j <> 0 do
begin
if j = 2 then
action := longstring(tp, string keyword(1), case tp of(
<:prio:>,
<:comm:>,
<:buf:>,
<:area:>,
<:inter:>,
<:func:>,
<:max:>,
<:std:>,
<:size:>,
<:prog:>,
<:user:>,
<:temp:>,
<:addr:>,
<::>))
else error(1);
\f
comment susercat update * page 8 18 07 80, 15.43;
begin
case action of
begin
<*_____1_____device name_____*>
begin
if readparam(param) = 3 then
begin
di_f := 44 - 8;
d_f := 4 - 8;
found := false;
for t := 1 step 2 until discs do
begin
di_f := di_f + 8;
d_f := d_f + 8;
if disc.d_f(1) = keyword.ln_f(1) and
_ disc.d_f(2) = keyword.ln_f(2) then
begin
found := true;
s_cat.di_f(4) := param(1) * sr(t);
if readparam(param) = 3 then
s_cat.di_f(3) := param(1)
else error(1);
end;
end;
if -, found then error(10);
end
else error(1);
end;
<*_____2_____prio_____*>
begin
if readparam(param) = 3 then
begin
ip := param(1);
s_cat.prio_com_f := ip shift 12;
end
else error(5);
end;
<*_____3_____comm_____*>
begin
if readparam(param) = 3 then
s_cat.prio_com_f := s_cat.prio_com_f + param(1)
else error(5);
end;
<*_____4_____buf_____*>
begin
if readparam(param) = 3 then
begin
ip := param(1);
s_cat.buf_area_f := ip shift 12
_ + s_cat.buf_area_f extract 12;
end
else error(5);
end;
\f
comment susercat update * page 9 18 07 80, 15.43;
<*_____5_____area_____*>
begin
if readparam(param) = 3 then
begin
ip := param(1);
s_cat.buf_area_f := s_cat.buf_area_f shift (-12)
shift 12 + ip;
end
else error(5);
end;
<*_____6_____inter_____*>
begin
if readparam(param) = 3 then
begin
ip := param(1);
s_cat.int_fnc_f := ip shift 12
+ s_cat.int_fnc_f extract 12;
end
else error(5);
end;
<*_____7_____func_____*>
begin
if readparam(param) = 3 then
begin
ip := param(1);
s_cat.int_fnc_f := s_cat.int_fnc_f shift (-12)
shift 12 + ip;
end
else error(5);
end;
<*_____8_____max_____*>
begin
if neg then s_cat.max_lo := - param(1)
else s_cat.max_lo := param(1);
if neg then s_cat.max_hi := - param(1)
else s_cat.max_hi := param(1);
end;
<*_____9_____std_____*>
begin
if neg then s_cat.std_lo := - param(1)
else s_cat.std_lo := param(1);
if neg then s_cat.std_hi := - param(1)
else s_cat.std_hi := param(1);
end;
<*____10_____size_____*>
begin
if readparam(param) = 3 then
s_cat.size := param(1)
else error(5);
end;
\f
comment susercat update * page 10 18 07 80, 15.43;
<*____11_____prog_____*>
begin
if readparam(param) = 4 then
begin
s_cat.prog_f(1) := param.ln_f(1);
s_cat.prog_f(2) := param.ln_f(2);
end
else error(1)
end;
<*____12_____user_____*>
begin
if neg then s_cat.usr_lo := - param(1)
else s_cat.usr_lo := param(1);
if neg then s_cat.usr_hi := - param(1)
else s_cat.usr_hi := param(1);
end;
<*____13_____temp dev. 0_____*>
begin
if readparam(param) = 3 then
begin
di_f := 44;
s_cat.di_f(2) := param(1) * sr(1);
if readparam(param) = 3 then s_cat.di_f(1) := param(1)
else error(5);
end
else error(5);
end;
<*____14_____addr_____*>
begin
if readparam(param) = 3 then
s_cat.addr_f := param(1)
else error(5)
end;
end case action;
end;
end while;
end
else error(9);
end
else error(5);
end insert;
\f
comment susercat update * page 11 18 07 80, 15.43;
procedure pr_cat(out_z);
________________________
comment output from entry 0 ;
zone out_z;
begin
comment output of cat reservation;
ch := ch + write(out_z,
"nl", 3, <:susercat = set 21 disc d.0 0 0 11.0 0:>,
"nl", 1, <:scope user susercat:>);
comment output of gen cat entry;
ch := ch + write(out_z, "nl", 2, <:scatup newcat:>, <<-ddddddd>,
_ <:.:>, s_cat.segm_f, <:,:>, "sp", 4,
_ <:catsize:>, "nl", 1);
d_f := 4 - 8;
for t := 1 step 2 until discs do
begin
d_f := d_f + 8;
ch := ch + write(out_z, <:,:>, "nl", 1, true, 12, disc.d_f);
end;
ch := ch + write(out_z, "nl", 2);
end pr_cat;
\f
comment susercat update * page 12 18 07 80, 15.43;
procedure pr_proc(out_z);
_________________________________
comment output from process entry;
zone out_z;
begin
integer procedure write_base(basel, baseu, text);
_________________________________________
value basel, baseu;
integer basel, baseu;
string text;
write_base :=
write(out_z, "nl", 1, text, <<ddddddd>,
_ if basel < 0 then <:n.:> else <: :>,
_ if basel >= 0 then basel else
_ - basel, <:.:> , if baseu < 0 then <:n.:> else <: :>,
_ if baseu >= 0 then baseu else
_ - baseu, <:,:>);
integer procedure write_disc(disc_a, disc_name);
________________________________________________
integer array disc_a;
long array disc_name;
begin
integer s;
s := write(out_z, <:,:>, "nl", 1, true, 12, disc_name, <:.:>);
s := s + write(out_z, <<dddddd>, disc_a(4)//sr(t), <:.:>);
s := s + write(out_z, <<dddddd>, disc_a(3));
write_disc := s;
end write_disc;
begin
integer s;
s := write(out_z, "nl", 1, <:scatup_insert.:>,
_ s_cat.name_f, <:,:>);
ch := ch + s;
if all then ch := ch + write(out_z,"nl",1,<:,:>,"*",s - 2);
ch := ch + write(out_z, "nl", 1, <:prio.:>, s_cat.prio_com_f shift (-12),
_ "sp", 1, <:comm.:>, s_cat.prio_com_f extract 12, <:,:>);
ch := ch + write(out_z, "nl", 1, <:buf.:>, s_cat.buf_area_f shift (-12),
_ "sp", 1, <:area.:>, s_cat.buf_area_f extract 12, <:,:>);
ch := ch + write(out_z, "nl", 1, <:inter.:>, s_cat.int_fnc_f shift (-12),
_ "sp", 1, <:func.:>, s_cat.int_fnc_f extract 12, <:,:>);
ch := ch + write_base(s_cat.std_lo, s_cat.std_hi, <:std .:>);
ch := ch + write_base(s_cat.usr_lo, s_cat.usr_hi, <:user.:>);
ch := ch + write_base(s_cat.max_lo, s_cat.max_hi, <:max .:>);
ch := ch + write(out_z, "nl", 1, <:addr.:>, s_cat.addr_f);
ch := ch + write(out_z, "sp", 1, <:size.:>, <<ddddddd>, s_cat.size,
_ "sp",1,<:prog.:>,s_cat.prog_f,<:,:>);
ch := ch + write(out_z,"nl",1,<:,resource____slices___entr,:>);
di_f := 44 - 8;
d_f := 4 - 8;
for t := 1 step 2 until discs do
begin
di_f := di_f + 8;
d_f := d_f + 8;
if t = 1 then ch := ch + write(out_z, "nl", 1, true, 12, <:temp:>,
_ <:.:>, <<dddddd>, s_cat.di_f(2)//sr(1),
_ <:.:>, s_cat.di_f(1));
ch := ch + write_disc(s_cat.di_f, disc.d_f);
end;
end;
ch := ch + write(out_z, "nl", 3);
end pr_proc;
\f
comment susercat update * page 13 18 07 80, 15.43;
procedure list(out_z);
_____________________
comment subprogram list;
zone out_z;
begin
init;
ch := 0; <*character counter*>
update := false;
all := false;
if readparam(param) = 4 then
begin
action := longstring(tp, string param(1), case tp of (
<:cat:>,
<:all:>,
<:names:>,
<::>));
case action of
begin
<*1_____list process_____ *>
begin
boolean found;
integer h;
h := hash(param.ln_f, s_cat.segm_f);
found := search(h, max_tracks, param.ln_f, 1, update);
if -, found then found := search(0, h, param.ln_f, 1, update);
if found then
begin
ch := ch + write(out_z, "nl", 1, <:scatup delete.:>, s_cat.name_f);
pr_proc(out_z);
end
else error(2);
end;
<*2_____list entry 0_____ *>
pr_cat(out_z);
<*3_____list all_____ *>
begin
all := true;
pr_cat(out_z);
ip := 1;
for track := 1 step 1 until max_tracks do
begin
repeat
begin
rest := inrec_6(s_cat, rec_lng);
begin
h_key := s_cat.h_key_f;
if h_key <> -1 and h_key <> -2 then
begin
if ip mod 3 = 0 then ch := ch + write(out_z, "ff",1);
pr_proc(out_z);
ip := ip + 1;
end;
end;
end;
until rest < rec_lng;
end;
ch := ch + write(out_z, <:scatup list.names:>);
end;
\f
comment susercat update * page 14 18 07 80, 15.43;
<*4_____list process names_____ *>
begin
ch := ch + write(out_z, "ff", 1, "nl", 2, <:,device names in susercat:>);
d_f := 4 - 8;
for t := 1 step 2 until discs do
begin
d_f := d_f + 8;
ch := ch + write(out_z, "nl", 1, <:,:>, disc.d_f);
end;
ch := ch + write(out_z, "nl", 1, <:,process names in susercat :>);
for track := 1 step 1 until max_tracks do
begin
repeat
begin
rest := inrec_6(s_cat, rec_lng);
begin
h_key := s_cat.h_key_f;
if h_key <> -1 and h_key <> -2 then
_ ch := ch + write(out_z, "nl", 1, <:,:>, s_cat.name_f);
end;
end;
until rest < rec_lng;
end;
end;
end;
end
else error(8);
if readparam(param) <> 0 then error(13);
end list;
\f
comment susercat update * page 15 18 07 80, 15.43;
procedure split(out_z);
________________________
comment split find subprogram;
zone out_z;
begin
comment initialize gen cat entry;
___________________________________
open(s_cat, 4, <:susercat:>, 0);
lng_f := 4;
lng_0 := 6;
segm_f := 8;
lg_f1 := 4;
lg_f2 := 8;
slice_f := 10;
ref_f := 12;
rec_f := 8 - 12;
d_f := 4 - 8;
comment initialize track process entries;
_______________________________________
h_key_f := 2;
prio_com_f := 4;
name_f := 4;
buf_area_f := 18;
int_fnc_f := 20;
pr_pk_f := 22;
max_lo := 24;
max_hi := 26;
std_lo := 28;
std_hi := 30;
size := 32;
prog_f := 32;
usr_lo := 42;
usr_hi := 44;
addr_f := 14;
action := longstring(tp, string param(1), case tp of(
<:newca:> add 116,
<:delet:> add 101,
<:inser:> add 116,
<:list:>,
<::>));
case action of
begin
error(6);
newcat;
delete;
insert;
list(out_z);
end;
close(s_cat, true);
end split;
\f
comment susercat update * page 16 18 07 80, 15.43;
comment main prog;
________________
zone s_cat(128, 1, std_error);
integer rec_lng, discs, t, rec_0_lng, pos, max_pos,
_ max_tracks, track, h_key, rest;
integer field lng_f, lng_0, segm_f, slice_f, ref_f, size,
_ h_key_f, prio_com_f, buf_area_f, int_fnc_f, pr_pk_f,
_ max_lo, max_hi, std_lo, std_hi, usr_lo, usr_hi, addr_f;
long field lg_f1, lg_f2, l_f;
long array disc (1:20), scope(1:2);
integer array sr(1:20), tail(1:10);
integer array field di_f;
long array field d_f, rec_f, name_f, prog_f, ln_f;
integer i, j, action, tp, ip,ch;
array param(1:2), keyword(1:2), outfile(1:2);
zone out_z(128, 1, stderror);
boolean update,all;
j := read_param(param);
if j <> -1 then
begin
if j = 2 then split(out) else error(7)
end
else
begin
outfile(1) := param(1); outfile(2) := param(2);
scope(1) := scope(2) := 0;
ln_f := 0;
i := lookup_proc(scope, outfile.ln_f, tail);
if (scope(1) = long <:syste:> add 109 <*m*> and scope(2) = 0)
or scope(1) = long <:***:> then i := 3;
if i <> 0 then
begin
for i := 1 step 1 until 10 do tail(i) := 0;
ln_f := 2;
tail(1) := 1; <*size*>
tail.ln_f(1) := long <:disc:>;
tail(6) := shortclock;
ln_f := 0;
i := setproc(outfile.ln_f, tail);
end create new entry;
if i = 0 then
begin
open(out_z, 4, outfile, 0);
if readparam(param) = 2 then
begin
if long param(1) = long <:list:> then split(out_z)
else error(12);
end
else error(7);
ch := ch + write(out_z, "nl", 1, <:end:>, "nl", 1, em, 3);
close(out_z, true);
tail(1) := ch // 768;
if ch mod 768 <> 0 then tail(1) := tail(1) + 1;
chngentrpr(outfile.ln_f,tail);
end
else
system(9)alarm:(i, <:<10>settroubl:>);
end;
stop: <*stop*>
end
if ok.no
mode warning.yes
if warning.yes
(mode 0.yes
message s_cat_up not ok
lookup s_cat_up)
if 0.no
(scope user s_cat_up
lookup s_cat_up susercat)
end
finis
▶EOF◀