; contract and pack * page 1 20 06 80, 14.19; contract = set 1 contract = algol connect.no survey.yes begin <* pack/unpack/offpack/listpack ()0/8388607 all programs uses a contractfile on user scope with the name _ pack where is the users initials in usercat. the program contract may be used on the same file. function ******** pack the list is contracted on pack, _ and the file is initialized on disc2, if not found. _ The init call as in contract is not needed. unpack the list is contracted from pack offpack the list is deleted from pack listpack the content of pack is listed exsample of pack ************************** the user logs in as : ke 1 3002 the pack is then : packke *> <* contract and pack * page 2 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 *> <* call of program : contract .(.)0/1 0/1 ::= init/on/clear/list/all/from/temp/set/proc/text function of program : init : The contractfile is initiated on _ (if specified then else main) bs_device. _ no further are allowed. _ The may not exist in the catalog. on : The contractfile is extended by the entries _ specified in and if is specified then _ moved to that bs_device. _ if an entry from exists in _catalog _ then is the _catalog entry replaced. _ no activity take place when claims are exceeded. _ any kind of entry may be contracted. _ in case of break_actions the old file is still present _ or in worst case the updated file as a wrk_name. clear : The entries in is removed from the contract- _ file catalog. _ when the catalog becommes enpty the is removed. list : The contractfile catalog is listed in short form. all : The contractfile catalog is listed format as _ lookup. from : The entries in are contracted from contractfile _ and set on the original backing storage on login _ scope. If the claims on the original bs is exceeded then _ is the entry set on main bs. _ If claims are exceeded no entry is set. temp : As from but with temp scope. set : The entries in are set on main bs with temp _ scope as a refer to the contractfile : _ = set bs . . . _ Warning procedures may not be set and any procedure named _ ******* in is considered unknown. proc : All procedures in the contractfile catalog is _ contracted as called by temp. No used. text : All textfiles in the contractfile catalog is con- _ tracted as called by set. No used. *> <* contract and pack * page 3 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 *> <* contractfile organization : +++++++++++++++++++++++++ == == 1:((entries+14)//15) == 1:15, length 34 bytes : _ integer content _ 1 (content position) shift 18 ,max pos = 262145 _ (head_and_tail(1) extract 3) _ 2 base low _ 3 base high _ 4:7 entryname _ 8 length or modekind _ 9:12 document name _ 13:17 last of tail == total entries in contractfile == () _ 1 : (no of entries where head_and_tail(8) > 0) == () head_and_tail(1) shift (-6) : _ head_and_tail(8)-1+head_and_tail(1) shift (-6) *> <* contract and pack * page 4 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 *> integer i, t, twb, yc, prog_nr, max_pos, _ b_skift, c_skift; boolean init, on, from, list, all, clear, temp, set, _ text, proc, ok_no; real array devi, iofpar, myst(1:2); integer array headm(1:17), tail(1:20); integer array field word; long array field lng_f; zone zm(128, 1, std_error); procedure stop(s); __________________ string s; system(9, 0*write(out, <:<10>***:>, s), <:<10>contract:>); procedure stap(a, s); _____________________ array a; string s; begin long array field lafl; lafl := 0; system(9, 0*write(out, <:<10>*** :>, (a.lafl), s), <:<10>contract:>); end; boolean procedure mess(a, s, warning); ______________________________________ array a; string s; boolean warning; begin long array field lafl; lafl := 0; write(out, true, 12, (a.lafl), s, "nl", 1); if warning then begin set_fpmode(0, true); ok_no := true; end; mess := false; end; <* ; read_param_tx * page 1 27 09 77, 11.35; ; read_param ; ************ if listing.yes char 10 12 10 read_param=set 1 read_param=algol external*> integer procedure read_param _______________________________________ _ (a); array a; comment the procedure reads the parameters in the FP command activating the program. read_param: kind of item stored in a _ -1 = (at first call and after wrap around) _ 0 end_of_parameter_list _ 1 _ 2 _ 3 . _ 4 . a: (return value, real array, length >=2). an integer is floated into the first element of a, a text item is assigned into a(1:2). the parameter list is scanned by means of system(4, q, a). at the end_of_parameter_list reading continues with the first first parameter again. the program name is always skipped; begin own integer q; integer i; q := q + 1; i := system(4, q, a); if q<>1 or i <> (6 shift 12) + 10 then begin comment not first nor = sign; if i <> 0 then read_param := (if i shift(-12)=8 then 2 else 0) _ +(if i extract 12=10 then 2 else 1) else read_param := q := 0; end not first nor =sign else begin comment first and = sign; system(4, 0, a); read_param := -1; end first and = sign; end read_param; procedure outshortclock(shortclock); _____________________________________ integer shortclock; begin real r; write(out, <:d.:>, <, systime(4, (if shortclock>0 then shortclock else shortclock + extend 1 shift 24) /625*1 shift 15+12, r), <:.:>, <, r/100) end outshortclck; integer procedure shortclock; shortclock:=systime(6,0,0.0); comment contract and pack * page 5 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; procedure mess_create(name, i, warning); ________________________________________ value i, warning; array name; integer i; boolean warning; begin write(out, <:*** create trouble : :>, _ case i of ( <:catalog function forbidden:>, _ <:catalog i/o error:>, <:entry exists:>, _ <:catalog full:>, <:contigous area not available:>, _ <:name format illegal:>), "nl", 1); mess(name, <: create trouble:>, warning); end; integer procedure blocksizeproc(zio, zwork, pos); ______________________________________________________ zone zio, zwork; integer pos; begin comment transfers zio to zwork, computes size; integer t, i, size; set_position(zwork, 0, pos); size := 0; repeat size := size + 1; out_rec6(zwork, 512); i := read_string(zio, zwork, 1); until i >= 0; if i > 0 or size > 1 then begin if i = 0 then begin i := 1; zwork(i) := real <::>; end; if zwork(i) = real <::> then _ zwork(i) := real <:<25><25><25>:> else begin t := 0; while (zwork(i) shift t) extract 8 = 0 do t := t - 8; zwork(i) := real(long zwork(i) _ + long<:<25><25><25>:> shift (-48-t)); end; pos := pos + size end else size := -1; blocksizeproc := size; end blocksizeproc; comment contract and pack * page 6 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; procedure allsort(a, ix, n); ____________________________ value n; long array a; integer array ix; integer n; begin integer i, j, k, m; long array field f1, f2; for i := 1 step i until n do m := i + i -1; for m := m//2 while m <> 0 do begin k := n - m; for j := 1 step 1 until k do begin for i := j step -m until 1 do begin f1 := ix(i); f2 := ix(i+m); if ( if a.f2(1) < a.f1(1) then true else _ if a.f2(1) > a.f1(1) then false else _ if a.f2(2) < a.f1(2) then true else _ if a.f2(2) > a.f1(2) then false else _ ( a.f2(3) > a.f1(3) ) ) then begin ix( i ) := f2; ix(i+m) := f1; end else i := 1; end; end; end; end alsort; comment contract and pack * page 7 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; integer procedure find_bs(devi_name, tail, antal); __________________________________________________ value antal; long array devi_name; integer array tail; integer antal; begin long array field df, tf; find_bs := 0; antal := antal * 8; t_f := 2; for d_f := 0 step 8 until antal do if devi_name.d_f(1) = tail.tf(1) and _ devi_name.d_f(2) = tail.tf(2) then begin find_bs := df // 8; df := antal; end; end find_bs; integer procedure movesizeproc(zio, zwork, pos, segm); ______________________________________________________ value segm; zone zio, zwork; integer pos, segm; begin integer i; set_position(zwork, 0, pos); for i := segm step -1 until 1 do begin inrec6(zio, 512); outrec6(zwork, 512); tofrom(zwork, zio, 512); end; pos := pos + segm; movesizeproc := segm; end movesizeproc; comment contract and pack * page 8 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; boolean procedure out_mode_kind(h_tail); ________________________________________ integer array h_tail; begin integer i, j, mdk; long array field name; name := 16; j := -1; mdk := h_tail(8) extract 23; for i := 1 step 1 until 21 do if case i of ( 0, 4, 8, 10, 2 shift 12 + 10, 4 shift 12 + 10, _ 6 shift 12 + 10, 12, 2 shift 12 + 12, 4 shift 12 + 12, _ 6 shift 12 + 12, 8 shift 12 + 12, 14, 16, 8 shift 12 + 16, _ 10 shift 12 + 16, 18, 2 shift 12 + 18, 4 shift 12 + 18, _ 6 shift 12 + 18, 20) = mdk then begin j := i; i := 21; end; if j > 0 then _ write(out, case j of (<:ip:>, <:bs:>, <:tw:>, <:tro:>, _ <:tre:>, <:trn:>, <:trf:>, <:tpo:>, <:tpe:>, <:tpn:>, _ <:tpf:>, <:tpt:>, <:lp:>, <:crb:>, <:crd:>, <:crc:>, _ <:mto:>, <:mte:>, <:nrz:>, <:nrze:>, <:pl:>)) else write(out, <, 1 shift 11 + mdk shift (-12), _ <:.:>, mdk extract 12); if h_tail(9) = 0 or h_tail(9) = 1 then _ write(out, << z>, h_tail(9)) else write(out, "sp", 1, h_tail.name); out_char(out, 32); out_mode_kind := j <> 1 and j <> 2; end; comment contract and pack * page 9 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; b_skift := c_skift := 6; max_pos := (1 shift (24-b_skift)) - 1; ok_no := false; lng_f := word := 0; yc := readparam(iofpar); if yc = -1 then _ stop(<:param error +lefthand:>); prog_nr := prog_entry(i, 5, case i of ( <*1*> <:contract:>, <*2*> <:pack:>, <*3*> <:unpack:>, <*4*> <:listpack:>, <*5*> <:offpack:>)); if prognr <> 1 then begin system(6)own_process:(i)name:(iofpar); for i := 1 step 1 until 2 do for t := -40 step 8 until 0 do if iof_par(i) shift t extract 8 < 97 then begin iofpar(i) := (iofpar(i) shift (t-8)) shift (8-t); if i = 1 then iofpar(2) := real <::>; i := 2; t := 0; end; myst(1) := real<:pack:> add ((iofpar(1) shift (-32)) extract 16); myst(2) := (iofpar(1) shift 16) add _ (((iofpar(2) shift (-40)) shift 8) extract 16); init := on := proc := temp := text := set := from := list := all := clear := false; end else if readparam(myst) <> 4 then _ stop(<:param error -contractfile:>); comment contract and pack * page 10 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; case prog_nr of begin begin <*contract*> init := real <:init:> = iofpar(1); on := real <:on:> = iofpar(1); proc := real <:proc:> = iofpar(1); temp := real <:temp:> = iofpar(1) or proc; text := real <:text:> = iofpar(1); set := real <:set:> = iofpar(1) or text; from := real <:from:> = iofpar(1); list := real <:list:> = iofpar(1); all := real <:all:> = iofpar(1); clear := real <:clear:> = iofpar(1); end; begin <*pack*> open(zm, 4, myst, 0); i := monitor(76, zm, 0, headm); close(zm, false); twb := 0; init := i <> 0; on := true; end; <*unpack*> from := true; <*listpack*> list := true; <*offpack*> clear := true; end prog_nr case; if -, init and -, on and -, from and -, list and -, all and -, clear and -, temp and -, set then stap(iofpar, <: param error not contract prog call:>); open(zm, 4, myst, 0); i := monitor(76, zm, 0, headm); if i = 0 and init then stap(myst, <: exist allready:>); if -, init and i > 0 then stap(myst, <:-contractfile does not exist:>); if -, init and headm(16) shift(-12) <> 10 then stap(myst, <:-contractfile not initiated:>); if -, init then begin inrec_6(zm, 512); twb := zm.word(256); if twb > 0 and zm.word(1) shift (-12) = (twb+14)//15 then _ c_skift := 12; end; comment contract and pack * page 11 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; repeat <* to include on after init of pack *> if list or all then begin integer array bases( 1 : 8 ); long array field wolng_f, lj; integer array field fld; fld := -34; lj := 6; wolng_f := 16; system(11)bases:(i, bases); i := write(out, "nl", 1, headm.lj); write(out, "sp", 15-i); outshortclock(headm(13)); write(out, "nl", 1, <, <:entries =:>, "sp", 7, twb, "nl", 1, <:size =:>, "sp", 7, headm(8), "nl", 1); for t := 1 step 1 until twb do begin if fld = 476 <* = 15 * 34 - 34 *> then begin fld := 0; inrec_6(zm, 512); end else fld := fld + 34; i := write(out, "nl", 1, zm.fld.lj); if list then begin write(out, "sp", 15-i); if zm.fld(8) >= 0 then begin i := zm.fld(16) shift (-12); if i <> 4 and i < 32 then outshortclock(zm.fld(13)) _ else write(out, <:procedure:>); end else begin write(out, <:= set :>); out_mode_kind(zm.fld); end; end else begin <* all *> comment contract and pack * page 12 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; write(out, "sp", 12 - i, <:= set :>); i := 14; if zm.fld(8) >= 0 then begin write(out, <, zm.fld(8), "sp", 1, zm.fld.wolng_f, "sp", 2); if zm.fld(16) shift (-12) <> 4 and zm.fld(16) shift (-12) < 32 then outshortclock(zm.fld(13)) else i := 13; end else if out_mode_kind(zm.fld) then _ out_shortclock(zm.fld(13)) else i := 13; for i := i step 1 until 17 do if zm.fld(i) < 4096 then _ write(out, "sp", 1, <, zm.fld(i)) else write(out, "sp", 1, <, zm.fld(i) shift(-12), _ <:.:>, zm.fld(i) extract 12); write(out, false add 59<* ; *>, 1, "sp", 1); i := if zm.fld(1) extract 3 > 3 then 6 else case zm.fld(1) extract 3 + 1 of ( <* key 0, maybe temp *> _ if extend zm.fld(2) = extend bases(3) _ and extend zm.fld(3) = extend bases(4) _ then 1 else 6, <* key 1 : undefined *> 6, <* key 2, maybe login *> _ if extend zm.fld(2) = extend bases(3) _ and extend zm.fld(3) = extend bases(4) _ then 2 else 6, <* key 3, user, project or system *> _ if extend zm.fld(2) = extend bases(5) _ and extend zm.fld(3) = extend bases(6) then 3 _ else _ if extend zm.fld(2) = extend bases(7) _ and extend zm.fld(3) = extend bases(8) then 4 _ else _ if extend zm.fld(2) <= extend bases(7) _ and extend zm.fld(3) >= extend bases(8) then 5 _ else 6 ); write(out, case i of( _ <:temp:>, <:login:>, <:user:>, _ <:project:>, <:system:>, <:***:>), _ "nl", 1, "sp", 14, false add 59, 1, "sp", 4, _ zm.fld(1) shift(-c_skift), <: bases:>, _ zm.fld(2), zm.fld(3)); end; end; write(out, "nl", 1); if twb = 0 then write(out, <:storage file empty<10>:>); end <* list or all *> else <* contract and pack * page 13 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 *> if init then begin real array field name; for t := 1 step 1 until 10 do tail(t) := 0; name := 2; if prog_nr = 1 then begin i := read_param(devi); t := if i = 0 then 0 else -1; if i > 0 then i := read_param(iofpar); if i <> 0 then stap(iofpar, <: + param :>); end else begin devi(1) := real <:disc2:>; devi(2) := real <::>; t := -1; end; if -, claim_proc(0, t, devi.lngf, t, t, t) then _ stap(devi, <: unknown bs<95>device :>); tail(1) := 1; tail.name(1) := devi(1); tail.name(2) := devi(2); tail(6) := short_clock; tail(9) := 10 shift 12; if monitor(40)create_entry:(zm, 0, tail) > 0 then _ stop(<: contractfile not created:>); if monitor(50) permanent entry:(zm, 3, tail)<>0 then stop(<: no permanent resources:>); system(11)bases:(i, tail); tail(1) := tail(5); tail(2) := tail(6); if monitor(74)set entry base:(zm, 0, tail) <> 0 then write(out, "nl", 1, <: base:>, tail(1), tail(2)); out_rec_6(zm, 512); zm(1) := real <::>; name := 4; to_from(zm.name, zm, 508); if prog_nr = 2 then begin set_position(zm, 0, 0); in_rec6(zm, 512); monitor(76)lookup_head_and_tail:( zm, 0, headm); end; init := init shift 1; end <* init *> else <* contract and pack * page 14 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 *> begin if prognr = 1 then yc := read_param(devi); if yc = 4 then t := 0 else begin devi(1) := devi(2) := real <::>; t := 1; end; if yc > 0 or text or proc then begin i := t; while readparam(iofpar) <> 0 do i := i + 1; for t := (if prog_nr = 1 then 3 else 1) - t _ step -1 until 1 do _ read_param(iofpar); t := (if text or proc then twb else i) + twb; <* max entries *> if from or temp or set then begin system(5, 92, tail); i := (tail(3) - tail(1)) // 2 - 1; <* bs_devices inclusive zero : 0 *> yc := 4 * 4; end else begin i := 0; yc := 3 * 4 + 2; end; comment contract and pack * page 15 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; begin boolean exist; integer j, bs_devices, tot_entries, twob; integer array ix(1:t), headio(1:20), _ bs_entr, bs_segm, bs_length(0:i); long array scope(1:2), devinames(1:2*i+2), _ y(1 : (yc * t) // 4 + 1); integer array field fld; long array field lj, ix_f, devi_f; real array field rf; zone zio(128, 1, std_error); procedure read_text_or_proc; ____________________________ begin for t := 1 step 1 until twb do begin if fld = 476 <* = 15 * 34 - 34 *> then begin in_rec6(zm, 512); fld := 0; end else fld := fld + 34; j := zm.fld(16) shift (-12); if ( _ if text then j = 0 and zm.fld(8) > 0 _ else j = 4 or j >= 32) then begin y.ix_f(1) := zm.fld.lj(1); y.ix_f(2) := zm.fld.lj(2); y.ix_f(3) := -1; scope(1) := 0; j := lookup_proc(scope, y.ixf, tail); y.ix_f(4) := if j <> 0 or _ ( scope(1) <> long <:login:> and _ scope(1) <> long <:temp:>) _ then -1 _ else if tail(1) <= 0 then 0 _ else (extend(tail(1)) shift 24 _ add find_bs(devinames, tail, bs_devices)); ix_f := ix_f + yc; end; end; fld := -34; setposition(zm, 0, 0); inrec_6(zm, 512); end read_text or proc; comment contract and pack * page 16 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; bs_devices := i; fld := -34; tot_entries := rf := ix_f := 0; lj := 6; exist := true; if -, clear and -, on then begin devi_f := -8; t := if from then 2 else 0; for i := 0 step 1 until bs_devices do begin devi_f := devi_f + 8; claim_proc(t, i, devi_names.devi_f, bs_entr(i), _ bs_segm(i), bs_length(i)); end; end; if text or proc then read_text_or_proc else while readparam(iofpar) <> 0 do begin comment readpar_to_p_long-1; if on then begin open(zio, 4, iofpar.lngf, 0); if monitor(76, zio, 0, headio) <> 0 then exist := mess(iofpar, <: file does not exist :>, false) else y.ix_f.word(7) := if headio(8) > 0 then headio(8) else 0; close(zio, true); end else if clear then y.ix_f.word(7) := 0 else begin scope(1) := 0; i := lookup_proc(scope, iofpar.lng_f, tail); y.ix_f(4):= if i <> 0 or _ (scope(1) <> long<:login:> and _ scope(1) <> long<:temp:>) _ then -1 _ else if tail(1) <= 0 then 0 _ else (extend(tail(1)) shift 24 _ add find_bs(devi_names, tail, bs_devices)); end; if exist then begin y.ix_f(1) := iofpar.lng_f(1); y.ix_f(2) := iofpar.lng_f(2); y.ix_f(3) := -1; ix_f := ix_f + yc; end else exist := true; end readpar_to_p_long-1; tot_entries := ix_f // yc; comment contract and pack * page 17 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; if totentries > 0 then begin i := 0; devi_f := 14; twob := tot_entries + twb; for t := totentries + 1 step 1 until twob do begin comment read_zm_to twb_long-2; if fld = 476 <* = 15 * 34 - 34 *> then begin inrec_6(zm, 512); i := i + 1; fld := 0; end else fld := fld + 34; if ( if -, set then true _ else zm.fld(16) shift (-12) <> 4 and _ zm.fld(16) shift (-12) < 32 ) then begin y.ix_f(1) := zm.fld.lj(1); y.ix_f(2) := zm.fld.lj(2); y.ix_f(3) := extend(i) shift 24 + fld; y.ix_f(4) := if zm.fld(8) > 0 then _ (extend( zm.fld(8) ) shift 24 + _ (if from then find_bs(devinames, _ zm.devif.fld, bs_devices) else 0)) _ else 0; ix_f := ix_f + yc; end; end read_zm_to_twb_long-2; tot_entries := twob := ix_f // yc; for t := 1 step 1 until tot_entries do ix(t) := (t-1) * yc; allsort(y, ix, totentries); if on or (clear and twb > 0) then begin integer first_segment, max_lng; integer array alpha(0:255); integer array field seac_f; real array field rf; zone seac_zn, zwork(128, 1, stderror); max_lng := seac_f := 0; for t := 0 step 1 until 127 do _ alpha(t) := 6 shift 12 add t; alpha(0) := alpha(127) := 0; alpha(25) := 8 shift 12 add 25; intable(alpha); comment contract and pack * page 18 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; lj := ix(1); for i := 2 step 1 until tot_entries do begin ix_f := lj; lj := ix(i); if y.lj(1) = y.ix_f(1) and y.lj(2) = y.ix_f(2) then begin twob := twob - 1; if y.ix_f(3) < 0 then write(out, true, 11, y.ix_f, _ <: doublet in param : skipped:>, "nl", 1) else if on then max_lng := max_lng + y.lj.word(7); y.lj.word(7) := 0; if clear then begin y.lj(3) := -6; if y.ix_f(3) >= 0 then twob := twob - 1; end; y.ix_f(3) := -7; end else max_lng := max_lng + y.ix_f.word(7); end; max_lng := max_lng + y.lj.word(7); if clear then for ix_f := (tot_entries-1) * yc step -yc until 0 do if y.ix_f(3) = -1 then begin twob := twob - 1; y.ix_f(3) := -7; mess(y.ix_f.rf, <: not in textstorage:>, true); end; comment contract and pack * page 19 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; firstsegment := (twob + 14) // 15; if first_segment > 0 then begin comment build_up_workstore; open(zwork, 4, <::>, 0); tail(1) := 1; for t := 2 step 1 until 10 do tail(t) := headm(7+t); lj := 2; if devi(1) <> real <::> then begin tail.lj(1) := long devi(1); tail.lj(2) := long devi(2); end; ixf := 0; i := -1; if -, claim_proc(3, i, tail.lj, bs_entr(0), bs_segm(0), j) then system(9, 0 * write(out, "nl", 1, <:unknown bs :>, _ tail.lj, "nl", 1, <:***:>), <:contract:>); if bs_segm(0) - max_lng - first_segment < 0 _ or bs_entr(0) < 1 then begin write(out, "nl", 1, <:***claims exceeded on :>, _ tail.lj, "nl", 1, <:available:>, _ <: entries, needed segm ::>, bs_entr(0), _ max_lng+first_segment-bs_segm(0)); stop(<::>); end; if monitor(40)create_entry:(zwork, 0, tail) > 0 then _ stop(<:workstore not created:>); getzone(zwork, headio); write(out, "nl", 2, <:tempfile = :>, headio.lj, "nl", 1); open(seac_zn, 4, headio.lj, 0); outrec_6(seac_zn, 512); lj := 6; comment contract and pack * page 20 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; for i := 1 step 1 until totentries do if firstsegment <= maxpos then begin comment y_one_to_z; ix_f := ix(i); if y.ix_f(3) > -6 then begin if y.ix_f(3) < 0 then begin open(zio, 4, y.ix_f, 0); if monitor(76, zio, 0, headio) = 0 then begin comment parentrihead; for t := 2 step 1 until 17 do _ seac_zn.seac_f(t) := headio(t); if headio(8) > 0 then begin seac_zn.seac_f(1) := first_segment shift (b_skift) _ + headio(1) extract b_skift; seac_zn.seac_f(8) := if headio(16) shift (-12) = 0 _ then blocksizeproc(zio, zwork, firstsegment) _ else movesizeproc(zio, zwork, firstsegment, _ headio(8)); if seaczn.seac_f(8) < 0 then _ stap(y.ix_f.rf, <: no text : empty :>); end else <* catalog entry *> seac_zn.seac_f(1) := ((i-1)//15) shift b_skift _ + headio(1) extract b_skift; seac_f := seac_f + 34; end else stap(y.ix_f.rf, <: could not be contracted:>); close(zio, true); end else begin comment zm_entry; fld := y.ix_f.word(6); setposition(zm, 0, y.ix_f.word(5)); inrec_6(zm, 512); j := zm.fld(8); seac_zn.seac_f(1) := (if j > 0 then _ firstsegment else ((i-1)//15)) _ shift b_skift _ + zm.fld(1) extract b_skift; for t := 2 step 1 until 17 do _ seac_zn.seac_f(t) := zm.fld(t); seac_f := seac_f + 34; setposition(zm, 0, zm.fld(1) shift (-c_skift)); if j > 0 then movesizeproc(zm, zwork, firstsegment, j); end zm_entry; end ulig_minus_seks_syv; if seac_f = 510 then begin comment seac_to_catalog; seac_zn.seac_f(1) := twob; outrec_6(seac_zn, 512); seac_f := 0; end seac_to_catalog; end y_one_to_z else stap(myst, <: file is full max 262145 segm :>); comment contract and pack * page 21 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; if seac_f > 0 then begin while seac_f < 510 do begin seac_f := seac_f + 2; seac_zn.seac_f(0) := 0; end; seac_zn.seac_f(1) := twob; end else changerec_6(seac_zn, 0); close(seac_zn, false); tail(1) := firstsegment; tail(6) := short_clock; monitor(44)change entry:(zwork, i, tail); tail(1) := headm(2); tail(2) := headm(3); i := monitor(50)permanent entry:(zwork, 3, tail) ; if i <> 0 then begin write(out, case i of ( <:dummy:>, <:catalog i/o error, doc. not mounted or doc. not ready:>, <:entry not found, name conflict - in aux catalog:>, <:entry protected, i e base of entry name not con- tained in max base of calling process- key illegal:>, <:dummy:>, <:name format illegal -- claims exeeded:>, <:catalog inconsistent:> )); stop(<:troubles with monitor 50 ---claims? :>); end; if monitor(74)set entry base:(zwork, 0, tail) <> 0 then begin monitor(48)remove entry:(zwork, 0, tail); stop(<:workstorebase not allowed:>); end; end <* build up workstore *> else mess(myst, <: file empty : removed:>, false); close(zm, true); monitor(48)remove entry:(zm, 0, headm); if firstsegment > 0 then begin close(zwork, false); monitor(46)rename entry:(zwork, 0, myst.word); end; end <* on or (clear and twb > 0) *> else if clear then _ write(out, <:empty storagefile:>, "nl", 1) else <* contract and pack * page 22 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 *> <* from or temp or set *> begin lj := ix(1); if y.lj(3) < 0 then y.lj(3) := -7; for i := 2 step 1 until tot_entries do begin ix_f := lj; lj := ix(i); if y.ix_f(1) = y.lj(1) and y.ix_f(2) = y.lj(2) then begin if y.ix_f(3) >= 0 then <* ixf is a zm_entry *> begin <* lj is a wanted entry *> if y.lj(4) > -1 then begin t := y.lj.word(8); bs_entr(t) := bs_entr(t) + 1; bs_segm(t) := bs_segm(t) + ((y.lj.word(7) - 1) _ // bs_length(t) + 1) * bs_length(t); end; t := y.ix_f.word(8); if bs_entr(t) > 0 and _ bs_segm(t) > y.ixf.word(7) then begin bs_entr(t) := bs_entr(t) - 1; if -, set then _ bs_segm(t) := bs_segm(t) - ((y.ixf.word(7) - 1) _ // bs_length(t) + 1) * bs_length(t); end else begin y.ix_f.word(8) := 0; bs_entr(0) := bs_entr(0) - 1; if -, set then _ bs_segm(0) := bs_segm(0) - ((y.ixf.word(7) - 1) _ // bs_length(0) + 1) * bs_length(0); end; end else write(out, true, 11, y.ixf, _ <: doublet in param : skipped:>, "nl", 1); end <* equality *> else begin if y.ixf(3) >= 0 then y.ixf(3) := -2; <* zm_entry not wanted *> if y.lj(3) = -1 then y.lj(3) := -7; <* wanted but unknown *> end; end; if y.lj(3) > 0 then y.lj(3) := -2; comment contract and pack * page 23 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; if bs_entr(0) < 0 or bs_segm(0) < 0 then begin write(out, "nl", 1, <:***claims wanted on disc: entries, segm ::>, _ -bs_entr(0), -bs_segm(0)); stop(<:claims exceeded:>); end; for j := 1 step 1 until tot_entries do begin ixf := ix(j); if y.ixf(3) >= 0 then begin setposition(zm, 0, y.ixf.word(5)); inrec6(zm, 512); fld := y.ixf.word(6); for i := 1 step 1 until 10 do tail(i) := zm.fld(i+7); if (temp or (from and y.ixf.word(8) = 0)) _ and tail(1) > 0 then begin lj := 2; tail.lj(1) := long <:disc:>; tail.lj(2) := 0; end; if set then begin lj := 2; tail.lj(1) := headm.lj(2); tail.lj(2) := headm.lj(3); tail(8) := zm.fld(1) shift (-c_skift); tail(1) := 1 shift 23 add 4; end; open(zio, 4, y.ixf, 0); j := j + 1; lj := ix(j); if y.lj(4) > -1 then monitor(48)remove_entry:(zio, 0, tail); i := monitor(40, zio, 0, tail); if i <> 0 then mess_create(y.ixf.rf, i, true); comment contract and pack * page 24 20 06 80, 14.19 0 1 2 3 4 5 6 7 8 9 ; if (-, set) and zm.fld(8) > 0 then begin set_position(zm, 0, zm.fld(1) shift (-c_skift)); movesizeproc(zm, zio, 0, tail(1)); close(zio, true); <*change entry*> monitor(44, zio, i, tail); end else close(zio, true); if from then begin if monitor(50)permanent entry:(zio, 2, tail)<>0 then _ mess(y.ixf.rf, <:no login resources:>, true); end; end else if y.ixf(3) = -7 then begin write(out, "nl", if ok_no then 0 else 1, true, 12, y.ixf, <: not in contractfile catalog:>, "nl", 1); set_fpmode(0, true); ok_no := true; end ; end stp tot_entries; end <* from or temp or set *>; end <* totentries > 0 *> else write(out, <:contractfile was not changed:>, "nl", 1); end <* declare block *>; end else ok_no := write(out, <:missing parameters:>, "nl", 1) > 0; init := false; <* to stop repeat loop when program = pack *> end <* on or clear or from or temp or set or text or proc *>; <* last of : repeat init on pack *> until -, (init shift (-1)) or prog_nr <> 2; close(zm, true); trap_mode := 1 shift 10; if ok_no then system(9, 0*write(out, "nl", 2, <:*** warning :>), <:contract:>); end; ; contract and pack * page 25 20 06 80, 14.19; ; if warning.yes (mode 0.yes message contract not ok lookup contract) if 0.no ( pack = entry bs contract contract contract, _ contract contract contract unpack = assign pack listpack = assign pack offpack = assign pack if 1.yes (scope user, contract, pack, unpack, listpack, offpack) if 2.yes (scope project, contract, pack, unpack, listpack, offpack) lookup, contract, pack, unpack, listpack, offpack ) end finis roc *>; <* last of : repeat init on pack *> until -, (init shift (-1)) or prog_nr <> 2; close(zm, true); trap_mode := 1 shift 10; if ok_no then system(9, 0*write(out, "nl", 2, <:*** warning :>), <:contract:>); end; ; contract and pack * page 25 20 06 80, 14.19; ; if warning.yes (mode 0.yes message contract not