|
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: 27648 (0x6c00)
Types: TextFile
Names: »retload3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »retload3tx «
mode list.yes
load4tx=edit load3tx
; ignore parity error in magtape
; prepare for sizes different than the ones wanted
; connect output : segm < 2 + key
l./page ... 36/, l./message stack current output/, l-1, r/81.12.07/88.09.08/
l./result := 2;/, r/2/1 shift 2/, r/1<1/1<2/, r/preferably on drum/temporary/
l./page ...38/, l./message connect output/, l-1, r/84.04.25/88.09.08/
l./size shift 1/, r/shift 1/shift 2/, r/pref drum/temporary/
l./message decl. second level page 1;/, l-1, r/84.10.31/88.11.17/
l./boolean/, l./inc_dump/, i/
reading_savecat ,
/, p-1
l./boolean array/, l./expell_zone/, i/
parity ,
/, p1
;********************************************
l./dummy,/, i/
speedlimit ,
monrelease ,
/, p1
;********************************************
l./message connect wrk or exist page 2;/, l-1, r/84.09.19/88.11.25/
l./headtail.base (1) = entry.base (1)/, d1, i/
if headtail .base (1) = entry .base (1) and
headtail .base (2) = entry .base (2) and <*bases*>
headtail (1) extract 3 = entry (1) extract 3 and <*permkey*>
(headtail .size >= 0 and <*areas*>
entry .size >= 0
or headtail .size < 0 and <*descr*>
entry .size < 0) then
/, l1, p-8
l./tofrom/, i/
if entry.size >= 0 then
/, l1, r/tofrom/ tofrom/, p-1
l./message rename wrk /, l-1, r/84.07.10/88.02.04/
l./integer array field base/, r/;/, tail;/
l./size := 16/, i/
tail := 14; <* - - tail*>
/, p1
l./page 2/, l-1, r/84.11.09/88.02.04/
l./if result > 0 and result <> 3 then/, i#
if result = 0 then
begin <*reopen zone z*>
close (z, true);
open (z, 0, entry_name, 0);
end;
if (result = 0 <*renamed *>
or result = 3) and <*name overlap*>
entry.size >= 0 then
begin <*check whether or not to cut area*>
integer result1;
result1 := monitor (76) head and tail :(z, 1, headtail);
if test then
begin
integer array zdescr (1:20);
integer array field zname;
zname := 2;
getzone6 (z, zdescr);
write (out,
"nl", 1, <:lookup head and tail : :>, zdescr.zname,
"nl", 1, <:result : :>, result1 );
end;
if result1 = 0 and
entry.size <> headtail.size then
begin <*cut area*>
result1 := monitor (44) change entry :(z, 1, entry.tail);
if test then
begin
integer array zdescr (1:20);
integer array field zname;
zname := 2;
getzone6 (z, zdescr);
write (out,
"nl", 1, <:change entry : :>, zdescr.zname,
"nl", 1, <:entry.size : :>, entry.size ,
"nl", 1, <:result : :>, result1);
end;
if result1 > 0 then
begin <*could not be changed*>
reset_catbase;
monitor_alarm (out, 44, entry.name, result1);
end;
end <*cut area*>;
end <*check whether ...*>;
\f
<* sw8010/2, load entry procedures page ... xx...
1988.02.04*>
message rename wrk page 1a;
#, p1
l./begin <*name equivalence*>/, i/
if entry.size <> headtail.size then
write (out,
"nl", 1, "*", 3, "sp", 1, true, 12, headtail.name, <:not renamed:>)
else
/, p1
l./message monitor alarm/,
l./page 2;/,l-1, r/85.02.06/88.02.04/
l./errorbits := 3;/, r/3/2/, r/ok.no/ok.yes/
l./procedure terminate_alarm (z/, d./end terminate_alarm;/, i#
procedure terminate_alarm (z, text, name, val, text1, val1);
value val, val1 ;
zone z ;
string text, text1 ;
long array name ;
integer val, val1 ;
<***********************************************************>
<* *>
<* The procedure terminates with an invisible runtime alarm*>
<* after having written an alarm message on the zone z. *>
<* *>
<* Call: terminate_alarm (z, text, name, val, text1, val1);*>
<* *>
<* z (call and return value, zone). The document, the *>
<* buffering and the position of the document where *>
<* to write the alarm message. *>
<* text (call value, string). *>
<* text1 *>
<* name (call value, long array). *>
<* val (call value, integer). All values which are writ- *>
<* val1 ten on the zone z. *>
<* *>
<***********************************************************>
begin
write_alarm (z, text);
write (z, "nl", 1, "sp", 4,
true, 12, name, <: :>, val, text1, val1);
trapmode := 1 shift 13; <*ignore output of trap alarm*>
trap (1); <*alarm*>
end terminate_alarm;
\f
<* sw8010/2, load entry procedures page ... xx...
1988.01.28*>
message continue warning page 1;
procedure continue_warning (z, text, name, val, text1, val1);
value val, val1 ;
zone z ;
string text, text1 ;
long array name ;
integer val, val1 ;
<***********************************************************>
<* *>
<* The procedure continues after having written an warning *>
<* message on the zone z. The fp mode bits are set *>
<* warning.yes ok.yes *>
<* *>
<* Call: continuewarning (z, text, name, val, text1, val1);*>
<* *>
<* z (call and return value, zone). The document, the *>
<* buffering and the position of the document where *>
<* to write the alarm message. *>
<* text (call value, string). *>
<* text1 *>
<* name (call value, long array). *>
<* val (call value, integer). All values which are writ- *>
<* val1 ten on the zone z. *>
<* *>
<***********************************************************>
begin
write_alarm (z, text);
write (z, "nl", 1, "sp", 4,
true, 12, name, <: :>, val, text1, val1);
errorbits := 2; <*warning.yes, ok.yes*>
end continue_warning;
#, l1, p-5
l./message mount param page 1;/, l-1, r/81.12.04/88.08.21/
l./<********/, d, d./<*******/, i/
<***************************************************************>
<* *>
<* The procedure returns the kind of the item given. *>
<* *>
<* Call : mount_param (seplength, item); *>
<* *>
<* mount_param (return value, integer). The kind of the *>
<* item : *>
<* 0 seplength<> <s> or ., item not below *>
<* 1 seplength = <s> or ., item = mountspec *>
<* 2 -"- , -"- release *>
<* 3 -"- , -"- mt62, mtlh, mto *>
<* 4 -"- , -"- mte *>
<* 5 -"- , -"- mt16, mtll, nrz *>
<* 6 -"- , -"- nrze *>
<* 7 -"- , -"- mt32 *>
<* 8 -"- , -"- mt08 *>
<* 9 -"- , -"- mthh *>
<* 10 -"- , -"- mthl *>
<* seplength (call value, integer). Separator < 12 + *>
<* length as for system (4, ...). *>
<* item (call value, array). An item in *>
<* item (1:2) as for system (4, ...). *>
<* *>
<***************************************************************>
/
l./message mount param page 2;/, l-1, r/84.05.20/88.08.21/
l./for i := 1 step 1/, d./i := 8/, i/
for i := 1 step 1 until
(if seplength <> space_txt and
seplength <> point_txt then 0 else 10) do
if item (1) = real ( case i of (
<:mount:> add 's',
<:relea:> add 's',
<:mt62:> ,
<::> ,
<:mt16:> ,
<::> ,
<:mt32:> ,
<:mt08:> ,
<::> ,
<::> ) ) and
item (2) = real ( case i of (
<:pec:> ,
<:e:> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ) )
or item (1) = real ( case i of (
<::> ,
<::> ,
<:mtlh:> ,
<::> ,
<:mtll:> ,
<::> ,
<::> ,
<::> ,
<:mthh:> ,
<:mthl:> ) ) and
item (2) = real ( case i of (
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ) )
or item (1) = real ( case i of (
<::> ,
<::> ,
<:mto:> ,
<:mte:> ,
<:nrz:> ,
<:nrze:> ,
<::> ,
<::> ,
<::> ,
<::> ) ) and
item (2) = real ( case i of (
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ) ) then
begin j := i; i := 10; end;
/
l./message in savecat head page 2;/, l-1, r/84.10.04/87.04.29/
l./terminate_alarm/,
l2, r/);/, <: in save catalog : :>, local_maxnoofvol);/
l./procedure load_entries ( za/, l./message load entries page 5;/,
l-1, r/86.10.10/78.04.29/
l./terminate_alarm (out/, r/terminate_alarm/continue_warning/
l./<:incorrect no of segments of part/,
r/incorrect no of segments of/incomplete/
l1, r/segments/partcatsize/, r/);/, <: transferred : :>, abs (segments));/
l./page 6;/, l1, l./page 6;/, l-1, r/84.11.15/87.04.29/
l./setposition (za (1)/, d, i/
blockno (copycount) := blockno (copycount) + 1;
/, l1, p-2
l./if zpart.size > 0/, r/and/ and/
l1, r/and/ and/
l1, r/and/ and/
l1, r/segments/abs (segments)/
l1, i/
begin <*warning and correct zpart.size*>
/
l1, r/terminate_alarm/continue_warning/
l1, r/segments/abs (segments)/, r/<:not/
<:warning : not/, r/else/
else/
l1, r/<:/ <:warning : /,
l1, r/segments/zpart.size/, r/);/, <: transferred : :>, abs (segments));/
l1, i/
zpart.size := abs (segments);
end <*warning and correct ...*>;
/
l./if entry_found and/, r/and/ and/
l1, r/and/ and/
l1, r/then/ and/
l1, i/
(segments >= 0
or connect ) then
/
l./total_segm__count :=/, r/segments/abs (segments)/, l-1, r/1;/ 1;/, p1
l./if load and/, r/and/ and/
l1, r/then/ and/
l1, i/
(segments >= 0
or connect ) then
/
l./slice_count (discno)/, i/
segments := abs (segments);
/
l./message list entry page 2;/, l-1, r/81.12.30/88.08.11/
l./write (z, "sp", 3, true, 7, case modekind/, d./<:mte:>/, i/
if monrelease < 80 shift 12 + 0 then
write (z, "sp", 3, true, 7, case modekind of (
<: ip:>, <: bs:>, <: tw:>, <: tro:>, <: tre:>, <: trn:>,
<: trf:>, <: trz:>, <: tpo:>, <: tpe:>, <: tpn:>, <: tpf:>,
<: tpt:>, <: lp:>, <: crb:>, <: crd:>, <: crc:>, <:mtlh:>,
<: mte:>, <:mtll:>, <:nrze:>, <:mt32:>, <:mt08:>, <:mthh:>,
<:mthl:>, <: pl:> ))
else
write (z, "sp", 3, true, 7, case modekind of (
<: ip:>, <: bs:>, <: tw:>, <: tro:>, <: tre:>, <: trn:>,
<: trf:>, <: trz:>, <: tpo:>, <: tpe:>, <: tpn:>, <: tpf:>,
<: tpt:>, <: lp:>, <: crb:>, <: crd:>, <: crc:>, <:mt62:>,
<: mte:>, <:mt16:>, <:nrze:>, <:mt32:>, <:mt08:>, <:mthh:>,
<:mthl:>, <: pl:> ));
/
l./message modekind case page 1;/, l-1, r/81.12.30/88.08.11/
l./until 24/, r/24/26/
l./<*mto, mtlh*>/, d./<*mthl*>/, i/
1 shift 23 + 0 shift 12 + 18, <* mt62, mto, mtlh*>
1 shift 23 + 2 shift 12 + 18, <* mte*>
1 shift 23 + 4 shift 12 + 18, <* mt16, nrz, mtll*>
1 shift 23 + 6 shift 12 + 18, <* nrze*>
1 shift 23 + 8 shift 12 + 18, <* mt32*>
1 shift 23 + 12 shift 12 + 18, <* mt08*>
1 shift 23 +128 shift 12 + 18, <* mthh*>
1 shift 23 +132 shift 12 + 18, <* mthl*>
/, p-8
l./i := 24/, r/24/26/
l./message open tape/, l-1, r/84.09.26/88.02.11/
l./open (z, modekind/, r/modekind extract 18, doc/
logand (modekind, -(1 shift 19 + 1)) extract 23, <*clear speed bit*>
doc/, p-1
l./procedure transfer (za/,
l./message transfer page 3;/, l-1, r/84.11.12/88.02.03/
l./boolean tapemark/, r/;/, rem_parity;/
l1, r/user (1:2)/user (1:16)/
l./tapemark :=/, l1, i/
rem_parity:= false ;
/, p-1
l.#if (segments // segm) > 4#, d5, i#
if modekind (i) shift 4 < 0 then
begin <*high speed bit specified*>
getzone6 (za (1), zdescr);
zdescr (1) :=
if segments <
speedlimit / (if modekind (i) shift 9 < 0 then 4 else 1) then
logand (modekind (i), -(1 shift 19 + 1)) extract 23 <*clear*>
else
logor (modekind (i), 1 shift 19 ) extract 23;<*set *>
if test then
write (out,
"nl", 1, <:speed bit = :>, zdescr (1) shift (-19) extract 1);
setzone6 (za (1), zdescr);
end;
#, p1
l./"sp", 2, <:n.t. addr/, i/
"sp", 2, <:area name = :>, procname,
"sp", 2, <:pos in area :>, file (area), block (area),
/, p1
l./if hwds > 2 then/, i/
if parity (1) then
begin <*parity error input tape zone*>
parity (1) := false;
rem_parity := true ;
if sumsegs < segments - segments mod segm then
segs := segm
else
begin
segs := segments mod segm; <*last block*>
if segs * 512 < hwds then
hwds := segs * 512;
end;
write (out,
"nl", 1, "sp", 4, <:loading to:>,
"nl", 1, "sp", 4, true, 12, procname,
<: last :>, segs * 512 - hwds, <: halfwords of segments :>,
sumsegs, <: - :>, sumsegs + segs - 1,
if expell then <: would be:> else <: are:>, <: zeroed:>,
"nl", 1);
end;
/, p1
l./if segs <> segm then segments := sumsegs + segs;/, d, i/
if segs <> segm
or hwds = aux_sync_length then
begin <*data blocks expired too early*>
if hwds = aux_sync_length then
begin <*sync block read as last data block*>
segs := 0; <*regret record*>
hwds := 0; <*makes the coming changerecio regret record*>
changerecio (za, hwds); <*regret record*>
getposition (za (1), file (i ), block (i )); <*log pos before sync*>
setposition (za (1), file (i ), block (i )); <*phys pos = logical*>
getposition (za (2), file (area), block (area));
setposition (za (2), file (area), block (area));
end;
segments := sumsegs + segs; <*to terminate loop*>
end <*data blocks expired too early*>;
/, p1
l./changerecio/, r/ch/if hwds > 0 then
ch/
l./page 4;/, l-1, r/84.11.08/88.11.17/
l./transfer (za, i/, l-1, i/
reading_savecat := true;
/, p-1
l./transfer (za, i/, l2, i/
reading_savecat := false;
/, p-1
l./if j <> savecatsize/, r/j/abs (j)/
l2, r/incorrect no of segments of/incomplete/
l1, r/);/, <: transferred : :>, abs (j));/
l./page 5;/, l-1,r/1894.11.12/1988.11.17/
l./<*stop zones, maybe tap/, i/
getzone6 (za (1), zdescr);
if aux_sync_length > 0 and
zdescr (16) > 0 and
not reading_savecat then <*record length*>
begin
<*sync blocks present and present record not one, *>
<*check that next share has input a sync block and*>
<*- if not : read on until sync block *>
<*- if : leave *>
integer array sdescr1, sdescr2, sdescr3 (1:12);
integer used_share, next_share, reclength;
getzone6 (za (1), zdescr);
used_share := zdescr (17); <*save used share*>
next_share := used_share + 1; <*save next share*>
if next_share > zdescr (18) then
next_share := 1;
zdescr (17) := next_share;
getshare6 (za (1), sdescr1, used_share);
getshare6 (za (1), sdescr2, next_share);
<* if test then
begin
write (out, "nl", 1, <:zone and shares before check next share ::>,
"nl", 1, <:used share = :>, used_share,
"sp", 1, <:next share = :>, next_share);
writezone (za (1), 1);
writeshare (za (1), used_share);
writeshare (za (1), next_share);
end;
*>
setzone6 (za (1), zdescr); <*used share updated*>
check (za (1) ); <*check it*>
getshare6 (za (1), sdescr3, next_share); <*get checked share*>
sdescr2 (1) := sdescr3 (1) := 1; <*share.state := ready*>
setshare6 (za (1), sdescr3, next_share); <*reset the share*>
<* if test then
begin
write (out, "nl", 1, <:zone and shares after check next share ::>);
writezone (za (1), 1);
writeshare (za (1), used_share);
writeshare (za (1), next_share);
end;
*>
reclength :=
sdescr3 (12) - sdescr3 (5) ;
<*sh.top xferred - sh.first addr*>
zdescr (17) := used_share;
setzone6 (za (1), zdescr); <*reset zone*>
setshare6 (za (1), sdescr1, used_share); <*and shares*>
<* if test then
begin
integer i;
write (out,
"nl", 1, <:zone and shares before set share next share ::>,
"nl", 1, <:reclength = :>, reclength,
"nl", 1, <:zdescr(16)= :>, zdescr(16));
writezone (za (1), 1);
writeshare (za (1), used_share);
writeshare (za (1), next_share);
write (out, "nl", 1, <:sdescr2 = :>);
for i := 1 step 1 until 12 do
write (out, "nl", 1, "sp", 10, << dddddd>, sdescr2 (i));
end;
*>
setshare6 (za (1), sdescr2, next_share);
if reclength > aux_sync_length then
begin <*too many data blocks, read on until sync block*>
getposition (za (1), file (i ), block (i )); <*log pos before last block*>
getposition (za (2), file (area), block (area));
closeinout (za); <*terminate zones, reinit zone array*>
block (i) := block (i) + 1; <*log pos after last block*>
setposition (za (1), file (i ), block (i )); <*phys = log pos*>
setposition (za (2), file (area), block (area));
<* if test then
write (out,
"nl", 1, <:position before transfer : :>,
file (i), block (i),
"nl", 1, <:- in area : :>,
file (area), block (area));
*>
segs :=
transfer (za, i, copies, file, block, 8388607, endtape, expell);
<*transfer until sync block, but expell disc zone*>
sumsegs := sumsegs + segs;
setposition (za (1), file (i), block (i)); <*save pos in zone*>
<* if test then
write (out,
"nl", 1, <:position after transfer : :>,
file (i), block (i),
"nl", 1, <:- in area : :>,
file (area), block (area));
*>
end <*too many full length blocks*>;
end <*aux_sync_length > 0*>;
/, p1
l./<*stop zones, maybe/, i#
\f
<* sw8010/2, load tape handling procedures page ... xx...
1988.02.02*>
message transfer page 6;
#
l./if test then/, i/
getzone6 (za (2), zdescr);
name_table_addr := zdescr (6);
if zdescr (13) >= 32 then <*z.state < 32 == closeinout was here before*>
closeinout (za); <*reallocate buffer area*>
/
l./getzone6 (za (2)/, d2
l./"nl", 1, <:proc bases/, r/));/),
"nl", 1, <:segments = :>, user (12));/, p-1
l./getzone_6 (za (1)/, d2
l./transfer :=/, r/sumsegs/
if rem_parity then
- sumsegs
else
sumsegs/, p-4
l./message next volume page 3;/, l-1, r/85.02.11/87.04.29/
l./terminate_alarm (/, l2, r/);/, <: block number : :>, block (index));/
l./terminate_alarm (/, l2, r/);/, <: block number : :>, block (index));/
l./procedure end_of_document (ztape,/,
l./page 2;/, l-1, r/84.10.04/87.04.24/
;**************************************
;l./if status/, i/
; write (out,
; "nl", 1, "*" , 3, <:blockprocedure end of doc : :>,
; "nl", 1, "sp", 3, <:status = :>, status);
;
;/, p1
;***************************************
l./if status extract 1 = 1/, r/then/ and/, r/extract/ extract/
l1, i/
(status shift (-22) extract 1 = 0 <*not parity*>
or status shift (-13) extract 1 = 1) then <*read error*>
/, l1, r/;/; <*hard error, not parity or read error*>/, p-2
;l./if status shift (-18)/,
;**********************************
;i/
;
; write (out,
; "nl", 1, "sp", 3, <:index = :>, index ,
; "nl", 1, "sp", 3, <:oper. = :>, operation);
;
;/, p-5
;**********************************
l./if status shift (-18)/,
r/if status/if status shift (-22) extract 1 = 1 then
begin <*parity error*>
if operation <> 3 then
give_up (ztape, status, hwds); <*not input*>
getposition (ztape, i, j);
write_alarm (out,
<:warning : persistent parity error in input from tape:>);
errorbits := 2; <*warning.yes, ok.yes*>
write (out,
"nl", 1, "sp", 4, true, 12, zdescr.docname,
<: file, block no :>, i, <:, :>, j);
parity (index) := true;
if hwds < 4 then
hwds := 4; <*not filemark*>
end <*parity error*> else
if status/,
p-12
l./begin <*mode error*>/, l./for i := 1 step 1/, r/6/8/
l2, r/128/8, 12, 128/
l1, r/6/8/
l1, r/6/8/
l2, r/128/8, 12, 128/
l./if nextmode = startmode/, d1, i#
getstate (ztape, i);
if nextmode = startmode <*all modes h been tried*>
or i shift (-5) extract 1 = 1 <*after inoutrec/chrecio*> then
give_up (ztape, status, hwds);
#, p-5
l./<:*mode error on/, l2, r#mtlh#mt62/mtlh#, r#mtll#mt16/mtll#, r#<:mthh:>,#
<:mt32:>, <:mt08:>, <:mthh:>, #
l./message program page 2;/, l-1, r/85.01.16/88.08.11/
l./<*obtain area and buffer claim*>/, i/
<*get monitor release*>
system (5) move core :(64, dummyia);
monrelease := dummyia (1); <*rel shift 12 + subrel*>
/, p-3
l./message program page 3;/, l-1, r/85.02.06/87.04.24/
l./end_of_doc/, i/
parity (i) :=
/,p1
;*********************************************
l./tape_param_ok :=/, l1, i/
<*write (out, "nl", 1, <:speed limit : :>, "<", 1);
*>
<*stopzone (out, false);*>
<*read (in, speedlimit);
write (out, "nl", 1, <:speed limit : :>, speedlimit, "nl", 1);
*>
<*stopzone (out, false);*>
speedlimit := 100;
/
;**********************************************
l./message program page 4;/, l-1, r/81.12.15/88.08.21/
l./mode_kind (copy_count) := 1 shift 23/, d./1 shift 23+132/, i/
modekind (copycount) := 1 shift 23 + 18; <*mt62, mtlh, mto*>
modekind (copycount) := 1 shift 23 + 2 shift 12 + 18; <*mte*>
modekind (copycount) := 1 shift 23 + 4 shift 12 + 18; <*mt16, mtll, nrz*>
modekind (copycount) := 1 shift 23 + 6 shift 12 + 18; <*nrze*>
modekind (copycount) := 1 shift 23+ 8 shift 12 + 18; <*mt32*>
modekind (copycount) := 1 shift 23+ 12 shift 12 + 18; <*mt08*>
modekind (copycount) := 1 shift 23+128 shift 12 + 18; <*mthh*>
modekind (copycount) := 1 shift 23+132 shift 12 + 18; <*mthl*>
/
l./message prepare tapes page 1;/, l-1, r/85.02.06/87.04.29/
l./terminate_alarm/,
l2, r/);/, <: block no :>, blockno (copy_count));/
l./message prepare save-loadcat page 2;/, l-1, r/85.01.16/88.11.17/
l./transfer (ztape/, l-1, i/
reading_savecat := true;
/, p-1
l./if segments <> savecatsize/, i/
reading_savecat := false;
/, p-1
l./terminate_alarm/, l1, d, i/
<:incomplete save catalog transferred from tape:>,
/
l1, d
l./savecatsize);/, r/);/, <: transferred : :>, abs (segments));/
f
end
▶EOF◀