|
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: 31488 (0x7b00)
Types: TextFile
Names: »retmain4 «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »retmain4 «
job fgs 2 274001 time 5 0 stat 2
mode list.yes
; editering af maintenance tekster
; magtapes :
;
;
; mt543054 : - 1.01, version 2
; mt543332 : - 2.00, version 2
; mt543286 : - 3.00, version 2
; mt543023 : - 5.00, version 2
;
; mt295430 : release 3.00, version 2
;
; overskrives og bliver kopi af :
;
; mt543023 : - 5.00, version 2
;
head 1
message ret maintenance tekster
message rettelse fra mt543286 til mt543023 1989.08.01
n=set nrz mt543023
g=set mto mt543286
opmess ring on mt543023
mount n
opmess no ring mt543286
mount g
message subpackage ident fil 1
nextfile n g
lookup n g
n=copy list.yes 7
tape identification
contents : source code
package number : sw8010/2
package name : system utility
release : 5.00, 1989.08.01
subpackage : maintenance
release : 5.00, 1989.08.01
message translate job fil 2
nextfile n g
lookup n g
n=edit
m e
v n
i!
mains=edit
i/
maintenance,
,autoload,
,base,
basemove,
,ccpm,
,changekit,
checkio,
,cpm,
,cpmbak,
,cpmsys,
clean,
,createlink,
deletelink,
disccopy,
discinfo,
discstat,
disctell,
do,
,fdformat,
,fpastat,
,initamx,
kitlabel,
kitname,
kitoff,
kiton,
,lookupdev,
,lookuplink,
,linkcentral,
mainstat,
makelink,
montest,
,movedump,
packoff,
packon,
printzones,
,releaselink,
scatop,
scatup,
slicelist,
termspec
/,f
mainareas=edit
i/
basemove,
checkio,
clean,
deletelink,
disccopy,
discinfo,
discstat,
disctell,
do,
mainstat,
makelink,
montest,
printzones,
scatop,
scatup,
slicelist,
termspec
/
f
scopemains=edit mains
i/
scope user,
/,f
lookupmains=edit mains
i/
head 1
lookup,
/,f
clearmains=edit mains
i/
clear user,
/, f
mode list.yes
sorry=algol
begin
trapmode := 1 shift 10;
write (out,
"nl", 2, <:***********************************************:>,
"nl", 1, <:* *:>,
"nl", 1, <:* *:>,
"nl", 1, <:* *:>,
"nl", 1, <:* *:>,
"nl", 1, <:* *:>,
"nl", 1, <:* S O R R Y *:>,
"nl", 1, <:* *:>,
"nl", 1, <:* *:>,
"nl", 1, <:* *:>,
"nl", 1, <:* *:>,
"nl", 1, <:* *:>,
"nl", 1, <:***********************************************:>);
endaction := -1;
end;
c=message oversæt slang del af maintenance
copy list.yes message.no main1
compress=slang main.3
if ok.no
sorry
(clean=slang main.4
clean)
if ok.no
sorry
(checkio=slang main.5
checkio)
if ok.no
sorry
;i trdo4tx
(do=slang main.6 main.7
do)
if ok.no
sorry
maintenance=set 1 3
maintenance=compress clean checkio do
c=message slut over sættelse af slang del af maintenance
c=message oversæt algol del af maintenance
;i trdisccopy4
disccopy=algol connect.no main.8
if warning.yes
sorry
packon = assign disccopy
packoff = assign disccopy
kiton = assign disccopy
kitoff = assign disccopy
kitlabel= assign disccopy
kitname = assign disccopy
;i trdstat4tx
discstat=algol connect.no main.9
if warning.yes
sorry
;i trmstat4tx
discstat=algol connect.no main.10
if warning.yes
sorry
;i trscatop4tx
scatop=algol connect.no main.11
if warning.yes
sorry
;i trsll4tx
slicelist=algol connect.no main.12
if warning.yes
sorry
;i trmont4tx
montest=algol connect.no main.13
if warning.yes
sorry
;i trterms4tx
termspec=algol connect.no main.14
if warning.yes
sorry
;i trdtell4tx
disctell=algol connect.no main.15
if warning.yes
sorry
;i trbasem4tx
basemove=algol connect.no main.16
if warning.yes
sorry
;i trprz4tx
printzones=algol connect.no main.17
if warning.yes
sorry
;i trscatup4tx
scatup=algol connect.no main.18
if warning.yes
sorry
;i trmakelink
makelink = algol connect.no main.19
if warning.yes
sorry
;i trdeletlink
deletelink = algol connect.no main.20
if warning.yes
sorry
;i trdinfo5tx
discinfo = algol connect.no main.21
if warning.yes
sorry
i scopemains
i lookupmains
release main
char ff
end
!
f
message compress text fil 3
nextfile n g
lookup n g
n=edit g
; connect output : segm < 2 + key
;
l./; connect output zone.../, l./jl. w3 h28./, l-3, r/1<1+1/1<2+0/
l./m. rc/, r/85.03.13/88.09.08/
f
message clean text fil 4
nextfile n g
lookup n g
n=edit g
f
message checkio text fil 5
nextfile n g g; base gl text fil 5 skippes
n=edit g
f
message do text 1 fil 6
nextfile n g g; changekit gl text fil 7 skippes
lookup n g
n=edit g
; fp connect output : segm<2 + key
;
l./jl.w3 h28./, l-1, r/<1+1/<2+0/
f
message do text 2 fil 7
nextfile n g
lookup n g
n=edit g
; ny dato
;
l./m.rc do 1977.09.26/, r/77.09.26/88.09.12/
f
message disccopy packon packoff kitton kitoff kitlabel kitname text fil 8
nextfile n g g; autoload gl text fil 10 skippes
lookup n g
n=edit disccopy5tx
f
message discstat text fil 9
nextfile n g
lookup n g
n=edit discstat4tx
; release process in all cases
;
l./slutlabel:/, l./if proc_created then/, i/
close (z, true); <*release process*>
/, p1
f
message mainstat text fil 10
nextfile n g
lookup n g
n=edit mainstat4tx
; split dump in monitor release 80.0
;
l./page ...3/, r/88.09.23/89.07.05/
l./<*9*>/, r/),/,/, l1, i/
<*10*><:addr outside dump area:>),
/, p-1
l./page ...17/, i#
\f
<* fgs 1988.09.23 mainstat page ...16a...*>
procedure position (zdump, first_addr);
value first_addr ;
zone zdump ;
integer first_addr ;
begin
integer segment, relative;
segment :=
seg (zdump, first_addr, relative);
setposition (zdump, 0, segment );
inrec6 (zdump, relative);
end procedure position;
integer
procedure seg (zdump, first_addr, rel);
value first_addr ;
zone zdump ;
integer first_addr, rel ;
begin
own
integer first_addr_low__part, top_addr_low__part,
no_of_segs_low__part,
first_addr_high_part, top_addr_high_part,
no_of_segs_high_part;
integer segment, relative, monrel, no_of_segs_in_dump,
addr_last_w_of_dumptable, first_addr_in_dump,
no_of_words_in_dump, segm_offset;
integer field ifld;
integer array proc (1:10), iadummy (1:1);
\f
<* fgs 1988.09.23 mainstat page ...16b...*>
if testoutput then
write (out,
"nl", 2, <:procedure seg : first addr = :>, first_addr,
"nl", 1, <:seen this dump before = :>,
if seen_this_dump_before then <:true:> else <:false:>);
if not seen_this_dump_before then
begin <*this dumpfile just connected*>
seen_this_dump_before := true;
ifld := 2;
segment := 0;
relative := 64;
setposition (zdump, 0, segment);
inrec6 (zdump, relative );
inrec6 (zdump, 2 );
system (5) move core :(
monitor (4) proc descr addr :(zdump, 0, iadummy), proc);
no_of_segs_in_dump := proc (10);
monrel := zdump.ifld;
if testoutput then
write (out,
"nl", 1, <:monrel = :>, monrel shift (-12), <:.:>, monrel extract 12);
if monrel < 80 shift 12 then
begin <*contigous dump area*>
first_addr_low_part := 0;
no_of_segs_low_part := no_of_segs_in_dump;
top___addr_low_part := no_of_segs_in_dump * 512;
end else
\f
<* fgs 1988.09.23 mainstat page ...16c...*>
begin <*split dump*>
relative := 12;
setposition (zdump, 0, segment);
inrec6 (zdump, relative );
inrec6 (zdump, 2 );
addr_last_w_of_dumptable := zdump.ifld;
relative := addr_last_w_of_dumptable - 8;
if testoutput then
write (out,
"nl", 1, <:addr l w of dumptable = :>, relative);
setposition (zdump, 0, segment);
inrec6 (zdump, relative );
inrec6 (zdump, 2 );
first_addr_low_part := zdump.ifld;
inrec6 (zdump, 2 );
no_of_segs_low_part := zdump.ifld;
top_addr_low_part :=
first_addr_low_part + 512 * no_of_segs_low_part;
inrec6 (zdump, 2 );
first_addr_high_part := zdump.ifld;
inrec6 (zdump, 2 );
no_of_segs_high_part := zdump.ifld;
top_addr_high_part :=
first_addr_high_part + 512 * no_of_segs_high_part;
if testoutput then
write (out,
"nl", 1, <:f. addr low part = :>, first_addr_low_part,
"nl", 1, <:t. addr low part = :>, top___addr_low_part,
"nl", 1, <:n. segs low part = :>, no_of_segs_low_part,
"nl", 1, <:addr. l. w d.tabl = :>, addr_last_w_of_dumptable,
"nl", 1, <:f. addr high part = :>, first_addr_high_part,
"nl", 1, <:t. addr high part = :>, top___addr_high_part,
"nl", 1, <:n. segs high part = :>, no_of_segs_high_part);
end <*split dump*>;
end <*dump file just connected*>;
\f
<* fgs 1988.09.23 mainstat page ...16d...*>
if first_addr >= first_addr_low_part and
first_addr < top___addr_low_part then
begin <*low part*>
first_addr__in_dump := first_addr_low_part;
no_of_words_in_dump := (top_addr_low_part - first_addr) / 2;
segm_offset := 0;
if testoutput then
write (out,
"nl", 1, <:low part ::>,
"nl", 1, <:first addr in dump = :>, first_addr_in_dump,
"nl", 1, <:no of wrds in dump = :>, no_of_words_in_dump,
"nl", 1, <:segment offset = :>, segm_offset);
end else
if first_addr >= first_addr_high_part and
first_addr < top___addr_high_part then
begin <*high part*>
first_addr__in_dump := first_addr_high_part;
no_of_words_in_dump := (top_addr_high_part - first_addr) / 2;
segm_offset := no_of_segs_low_part;
if testoutput then
write (out,
"nl", 1, <:high part ::>,
"nl", 1, <:first addr in dump = :>, first_addr_in_dump,
"nl", 1, <:no of wrds in dump = :>, no_of_words_in_dump,
"nl", 1, <:segment offset = :>, segm_offset);
end else
error (10); <*outside dump*>
segment := segm_offset + (first_addr - first_addr_in_dump) shift (-9);
relative := (first_addr - first_addr_in_dump) extract 9 ;
if testoutput then
write (out,
"nl", 1, <:segment = :>, segment,
"nl", 1, <:relative = :>, relative);
seg := segment;
rel := relative;
end procedure seg;
#
l./page ...17/, r/88.09.23/89.07.05/
l./boolean/, r/testoutput/testoutput, seen_this_dump_before/
l./page ...20/, r/89.01.12/89.07.06/
l./begin <*dump*>/, l3, i/
seen_this_dump_before := false;
/, p-1
l./page ...22/, r/88.09.23/89.07.06/
l./setposition (dz, 0, ia(0)/, d1, i/
position (dz , ia (0));
/, p-2
l./setposition (dz1/, d1, i/
position (dz1, pda );
/, p-2
l./page ...23/, r/88.09.23/89.07.06/
l./inrec6 (dz, 2);/, d1, i/
if main_kind = 80 then
begin
inrec6 (dz, 2); rpd := dz.ifi;
inrec6 (dz, 2); tpd := dz.ifi;
end;
/, p-5
l./setposition (dz, 0, (ia(0)/, d6, i/
position (dz , ia (0) + 2 * devno);
inrec6 (dz , 2 );
pda := dz.ifi ;
position (dz1, pda );
inrec6 (dz1, 2 );
/, p-6
l./inrec6 (dz, 2); rpd :=/, d1, i/
if main_kind = 80 then
begin
inrec6 (dz, 2); rpd := dz.ifi;
inrec6 (dz, 2); tpd := dz.ifi;
end;
/, p-5
l./page ...26/, r/88.09.23/89.07.06/
l./if monrelease > 15 shift/, r/>/>=/
l./page ...27/, r/88.09.23/89.07.06/
l./if monrelease > 15 shift/, r/>/>=/
f
message scatop text fil 11
nextfile n g g; movedump gl fil 14 skipped
lookup n g
n=edit scatop4tx
f
message slicelist text fil 12
nextfile n g g; fpproc gl text fil 16 skippes
lookup n g
n=edit g
; connect output : segm < 2 + key
; rc82xx/rc83xx rettes til rc92xx/rc82xx/rc83xx
;
l.#RC82xx/RC83xx#, r#RC82xx/RC83xx#RC92xx/RC82xx/RC83xx#
l./ size := 3; <* size := no. of segm. add device *>/,
r/3; /1 shift 2;/, r/device/key /
l.#rc82xx/rc83xx#, r#rc82xx/rc83xx#rc92xx/rc82xx/rc83xx#
l./BS-area/, r/BS/bs/
l.#rc82xx/rc83xx#, r#rc82xx/rc83xx#rc92xx/rc82xx/rc83xx#
l./on rc83xx discs/, r#rc83xx#rc92xx/rc83xx#
f
message montest text fil 13
nextfile n g g g g; writeall, releaselink, linkcentral gl fil 18, 19, 20 skippes
lookup n g
montest4tx=edit g
; connect output : segm < 2 + key
;
l./procedure dump;/, l./typeerror (s_text/, i/
begin
/, p1
l./init_pointers/, i/
dump_area := false; <*initpointers as for core*>
end;
/, p-2
l./procedure info;/,
l./internal all/, l1, i/
used
free
/, p-2
l./buf all/, l1, i/
used
free
/, p-2
l./external all/, l1, i/
used
free
kind.<kind>
/, p-3
l./area all/, l1, i/
used
free
kind.<kind>
/, p-3
l./ result := 2; <*1 < 1 : 1 segment, preferably drum*>/,
r/2/1 shift 2/, r/1 < 1/1 < 2/, r/preferably drum/temporary/, p1
l./procedure read_params(/,
l./<* specif/, d./8 - undefined/, i/
<* specif : 1 - user.<name>
2 - reserver.<name>
3 - name.<name>
4 - all
5 - devno.<integer>
6 - devno.<integer>.all
7 - main.<name>
8 - used
9 - free
10 - kind.<kind>
11 - undefined specification *>
/
l./specif:=8/, r/8/11/
l./if param(1) = real<:user/, i/
if param(1) = real<:used:> then specif := 8 else
if param(1) = real<:free:> then specif := 9 else
/, p-1
l1,l./specif:=8/, r/8/11/
l./specif:=8/, r/8/11/
l./else specif:=8/, r/8/11/
l./end read_params;/, l-2, i/
if param (1) = real <:kind:> then
begin
if nextparam (p_number) then
begin
devno := round param (1);
name (1) := param (1);
specif := 10;
end else
typeerror (anything, <:parameter error ::>, dummy);
end else
/, l1, p-3
l./procedure external;/, l./specif:= 4/, r/4/8/, r/all/used/
l1,l./specif < 8/, r/8/11/
l./<* main.<name> *>/, l2, i/
<* used *>
if contents.eprocname (1) shift (-40) extract 8 <> 0 then
type_external;
<* free *>
if contents.eprocname (1) shift (-40) extract 8 = 0 then
type_external;
<* kind.<kind> *>
if contents.eprocname (0) extract 24 = devno then
type_external;
/, p-3
l./<:not found : user.:>/, d2, i/
<:not found : user.:> , <:not found : reserver.:>,
<:not found : name.:> , <:not found : all:> ,
<:not found : devno.:>, <:not found : devno.:> ,
<:not found : main.:> , <:not found : used:> ,
<:not found : free:> , <:not found : kind.:>) , name);
/
l./procedure area_process;/,
l./addr, moves/, r/addr/addr, kind/
l./specif:= 4/, r/4/8/, r/all/used/
l./read_params(/, r/i);/kind);/
l./specif < 8/, r/8/11/
l./<* main *>/, l2, i/
<* used *>
if contents.eprocname (1) shift (-40) extract 8 <> 0 then
type_areaprocess;
<* free *>
if contents.eprocname (1) shift (-40) extract 8 = 0 then
type_areaprocess;
<* kind.<kind> *>
if contents.eprocname (0) extract 24 = kind then
type_areaprocess;
/, p-6
l./type_error (s_text,/, r/s_text/if specif <> 10 then s_text else s_number/
l./<:not found : user.:>/, d1, i/
<:not found : user.:> , <:not found : reserver.:>,
<:not found : name.:> , <:not found : all:> ,
<::> , <::> ,
<:not found : main.:> , <:not found : used:> ,
<:not found : free:> , <:not found : kind.:>) , name);
/
l./procedure buf;/, l./check := 6;/, r/6/8/
l./if param(1) = real<:sende:>/, i/
if param(1) = real<:used:> then check := 6 else
if param(1) = real<:free:> then check := 7 else
/, p-2
l./ok := false; <*param error*>/, i/
ok := true; <*used*>
ok := true; <*free*>
/, p-2
l./ok:= start_addr + addr >= buf_addr ;/, l1, i/
ok := contents.base (4) <> 0
or contents.base (5) <> 0;
ok := contents.base (4) = 0 and
contents.base (5) = 0 ;
/, p-5
l./type_error (s_text , <:not found/, d5, i/
type_error (s_text , <:not found : all:> , dummy );
type_error (s_text , <:not found : sender.:> , sender_name );
type_error (s_text , <:not found : receiver.:>, receiver_name);
type_error (s_text , <:not found : receiver.:>, receiver_name);
type_error (s_number, <:not found : addr.:> , param );
type_error (s_number, <:not found : addr.:> , param );
type_error (s_number, <:not found : used:> , param );
type_error (s_number, <:not found : free:> , param );
/
l./procedure internal;/, l./<:interrupt m/, r/interrupt m/(unused) /
l./boolean found,/, r/;/, type_used, type_free;/
l./type_all := true;/, r/true/type_free := false/, r/;/; type_used := true;/
l./if param (1) = real <:name/, i/
if param (1) = real <:used:> then
begin
type_all := type_free := false;
type_used := ok := true;
end else
if param (1) = real <:free:> then
begin
type_all := type_used := false;
type_free := ok := true;
end else
/, l1, p-2
l./type_all := false;/, r/false/type_used := type_free := false/
l./<* search internal proc descr *>/,
l./if type_all then type_descr/, d2, i/
if type_all then
typedescr
else
if type_used and contents.raf (1) shift (-40) extract 8 <> 0 then
typedescr
else
if type_free and contents.raf (1) shift (-40) extract 8 = 0 then
typedescr
else
if name (1) = contents.raf (1) and
name (2) = contents.raf (2) then
typedescr;
/, l1, p-12
f
n=edit montest4tx
; split dump i monitor release 80.0 og frem
; max internals og max chains i monitor release 81.0 og frem
; forbedrede feltnavne i internals
;
l./integer sep,/,
l./bit, all/, r/bit/bit, bit12/
l./main;/, r/main;/main, no_of_segs_in_dump,
internals, max_internals, chains, max_chains;/
l1, r/quit;/quit, first_time_this_dump, testout;/
l./procedure dump;/, l./integer array iadummy/, r/;/, proc (1:14);/
l./if i > 0 then/, d1, i/
if i = 0 then
begin <*area process created*>
first_time_this_dump := true;
system (5) move core :(
monitor (4) proc descr addr :(zdump, 0, iadummy), proc);
no_of_segs_in_dump := proc (10);
end else
begin
/, p-8
l./dump_area := false/, r/d/ d/, l1, r/e/ e/, p-1
l./procedure commands;/, l./write (out/, l1, r/<:/<:<10>/
l./<:core/, r/core /mem /
l./procedure info;/, l./write(out/, r/(out,<:/ (out,
<:<10>/, p-1
l./dump <dumparea>/, l./core/, r/core/mem /
l1, d3, i/
<:
core
' further commands will refer to the resident core
system, cf. the command dump ':>,
/
l./lines <first line> (.<last line>)/, l./string infor/, d, i/
<:
mem
' further commands will refer to the resident
memory system, cf. the command dump ':>,
/
l./procedure init_pointers;/,
l./if contents(11) <*start of interrupt stack/, d9,i/
monitor_release := contents(13);
oldmon := false ;
move (90, contents);
/, p-5
l./if old_mon/, d2
l./28;/, d, i/
if monitor_release < 80 shift 12 + 0 then
28
else
contents (1);
/, p-4
l./userid:=/, i$
internals := (name_table_end - first_internal) // 2;
chains := (last_bs - first_drum ) // 2;
if monitor_release <= 80 shift 12 + 0 then
begin
max_internals := internals;
max_chains := chains ;
end else
begin
move (1232, contents);
max_internals := contents (1);
max_chains := contents (2);
end;
$, p-12
l./id_array_size:=/, r$(name_table_end-first_internal)//2$max_internals$
l./end init_pointers;/, i/
if dump_area then
write (out, "nl", 1, true, 12, area)
else
write (out, "nl", 1, <:memory :>);
write (out, <:monitor release : :> , <<dd>,
monitor_release shift (-12), <:.:>, <<zd>,
monitor_release extract 12 , <:<10>:>);
outend (out);
/, l1, p-8
l./procedure veri;/, l./else <:core:>/, r/core/memory/
l./procedure type_usernames (/, l./internals,/, r/internals,//
l./internals:=/, d
l./procedure type_names (/, l./internals,/, r/internals,//
l./internals:=/, d
l./integer procedure identification_mask(/, l./internals,/, r/internals,//
l./internals:=/, d
l./procedure external;/, l./<:core:>/, r/core/memory/
l./procedure area_process;/, l./<:core:>/, r/core/memory/
l./procedure chain;/, l./<:core:>/, r/core/memory/
l./<:first slice of chaintable area/,
r/first slice of chaintable area/number of keys /, p-2
l./chains, /, r/chains, //
l./chains:=/, d
l./procedure buf;/, l./<:core:>/, r/core/memory/
l./procedure internal;/, l./<:core:>/, r/core/memory/
l./<:ident/, r/ident /relative, id /, p-1
l./<* stop count/, l./write_formatted/, r/ + bit//
l./for j:= 1 step 1 until 10 do/, r/10/12/
l1, r/72/72,11,200/
l./<:running/, l1, i/
<:running:>,
<:waiting for cpu:>,
/, p-2
l./<* identification/, l1, d, i$
begin
write_formatted ((contents (9) shift (-12) shift 12)//4096, int);
write_formatted ( contents (9) extract 12 , bit12);
end;
$, p-4
l./<* parent description/, l1, d, i$
begin
writeformatted (contents (28), int);
if contents (28) > 0 then
begin
real array pname (1:2);
getdescr_or_name (pname, contents (28), false);
write (out, <: (:>, pname, <:):>);
end;
end;
$, p-8
l./<* quantum /, l1, d, i$
write (out, <<-ddddddd.dddd>,
contents (29)/10000, <: secs:>);
$, p-3
l./<* run time/, l1, d1, i$
write (out, <<-ddddddd.dddd>,
((extend 0 + contents (30)) shift 24 add contents (31))/10000,
<: secs:>);
$, p-3
l./<* start run/, l1, d1, i/
write_clock (contents (32), contents (33));
/, p-1
l./<* start wait/, l1, d1, i/
write_clock (contents (34), contents (35));
/, p-1
l./integer i, j, type/, r/internals, //
l./internals:=/, d
l./procedure write_formatted (/,
l./for i:= 0 step 1 until 7 do/, r/7/8/
l./end case;/, i$
begin <*12 bits*>
for j := 12 step 1 until 23 do
write (out, if word shift j < 0 then <:1:> else <:.:>);
write (out, sp, 2);
end;
$, p-5
l./procedure type_text(/, l6, i$
procedure write_clock (int1, int2);
value int1, int2 ;
integer int1, int2 ;
begin
long l;
real r;
l := (extend 0 + int1) shift 24 add int2;
r := l / 10000;
write (out, << zd dd dd>, systime (4, r, r), r, sp, 2);
end;
$, p-9
l./procedure move (first_addr/, l./integer present_segment/, l1, r/;/, monrel,
addr_last_w_of_dumptable,
first_addr_in_dump, no_of_words_in_dump, segm_offset;/,p-4
l./first_index :=/, i/
own
integer first_addr__low_part, top_addr__low_part, no_of_segs_low__part,
first_addr_high_part, top_addr_high_part, no_of_segs_high_part;
real array ra (1:1);
/, p-4
l./segment := first_addr shift (-9);/, d1, i#
if testout then
write (out,
"nl", 1, <:first time this dump = :>,
if first_time_this_dump then <:true:> else <:false:>);
if first_time_this_dump then
begin <*this dumpfile just connected*>
first_time_this_dump := false;
ifld := 2;
segment := 0;
relative := 64;
setposition (zdump, 0, segment);
inrec6 (zdump, relative );
inrec6 (zdump, 2 );
monrel := zdump.ifld;
if testout then
write (out,
"nl", 1, <:monrel = :>, monrel shift (-12), <:.:>, monrel extract 12);
if monrel < 80 shift 12 then
begin <*contigous dump area*>
first_addr_low_part := 0;
no_of_segs_low_part := no_of_segs_in_dump;
top___addr_low_part := no_of_segs_in_dump * 512;
end else
begin <*split dump*>
relative := 12;
setposition (zdump, 0, segment);
inrec6 (zdump, relative );
inrec6 (zdump, 2 );
addr_last_w_of_dumptable := zdump.ifld;
relative := addr_last_w_of_dumptable - 8;
if testout then
write (out,
"nl", 1, <:addr l w of dumptable = :>, relative);
setposition (zdump, 0, segment);
inrec6 (zdump, relative );
inrec6 (zdump, 2 );
first_addr_low_part := zdump.ifld;
inrec6 (zdump, 2 );
no_of_segs_low_part := zdump.ifld;
top_addr_low_part :=
first_addr_low_part + 512 * no_of_segs_low_part;
inrec6 (zdump, 2 );
first_addr_high_part := zdump.ifld;
inrec6 (zdump, 2 );
no_of_segs_high_part := zdump.ifld;
top_addr_high_part :=
first_addr_high_part + 512 * no_of_segs_high_part;
if testout then
write (out,
"nl", 1, <:f. addr low part = :>, first_addr_low_part,
"nl", 1, <:t. addr low part = :>, top___addr_low_part,
"nl", 1, <:n. segs low part = :>, no_of_segs_low_part,
"nl", 1, <:addr. l. w d.tabl = :>, addr_last_w_of_dumptable,
"nl", 1, <:f. addr high part = :>, first_addr_high_part,
"nl", 1, <:t. addr high part = :>, top___addr_high_part,
"nl", 1, <:n. segs high part = :>, no_of_segs_high_part);
end <*split dump*>;
end <*dump file just connected*>;
if first_addr >= first_addr_low_part and
first_addr < top___addr_low_part then
begin <*low part*>
first_addr__in_dump := first_addr_low_part;
no_of_words_in_dump := (top_addr_low_part - first_addr) / 2;
segm_offset := 0;
if testout then
write (out,
"nl", 1, <:low part ::>,
"nl", 1, <:first addr in dump = :>, first_addr_in_dump,
"nl", 1, <:no of wrds in dump = :>, no_of_words_in_dump,
"nl", 1, <:segment offset = :>, segm_offset);
end else
if first_addr >= first_addr_high_part and
first_addr < top___addr_high_part then
begin <*high part*>
first_addr__in_dump := first_addr_high_part;
no_of_words_in_dump := (top_addr_high_part - first_addr) / 2;
segm_offset := no_of_segs_low_part;
if testout then
write (out,
"nl", 1, <:high part ::>,
"nl", 1, <:first addr in dump = :>, first_addr_in_dump,
"nl", 1, <:no of wrds in dump = :>, no_of_words_in_dump,
"nl", 1, <:segment offset = :>, segm_offset);
end else
begin <*outside dump*>
ra (1) := first_addr;
type_error (s_number, <:addr outside dump area, addr = :>, ra);
first_addr :=
first_addr__in_dump := first_addr_low_part;
no_of_words_in_dump := (top_addr_low_part - first_addr) / 2;
segm_offset := 0;
end;
segment := segm_offset + (first_addr - first_addr_in_dump) shift (-9);
relative := (first_addr - first_addr_in_dump) extract 9 ;
if testout then
write (out,
"nl", 1, <:segment = :>, segment,
"nl", 1, <:relative = :>, relative);
#, p1
l./for word := 1, /, r/ while/
while/, r/ do/ and
word <= no_of_words_in_dump do/, p-1
l./procedure convert_to_number(/, l./real <::>/,
r/real <::> /real <:mem:>/
l1, r/<::> /<:test:>/
l1, r/<::> /<:notes:> add 't'/
l./<* m a i n p r o g r a m *>/,
l./code:= 1 shift 7/, l1, i/
bit12:= 1 shift 8;
/, p-7
l./quit := false;/, l1, i/
first_time_this_dump := false;
testout := false;
/, p-1
l./init_pointers;/, l./;;;/, d, i/
core;
testout := true;
testout := false;
/, p-3
f
message termspec text fil 14
nextfile n g g; initamx gl text fil 22 skippes
lookup n g
n=edit g
; connect output : segm < 2 + key
;
l./procedure stack_current_output (file_name);/,
l./result := 2; <*1<1 <=> 1 segment, preferably disc*>/,
r/2/1 shift 2/, r/1<1/1<2/, r/preferably disc/temporary/
f
message disctell text fil 15
nextfile n g
lookup n g
n=edit disctell4tx
; ændret layout aht større proc descr addresser
;
l./page ... 5/, r/88.09.27/89.07.14/
l./write(out, <:physical disc : device no. :>,/,
r/device no/dev no/
l./page ... 6/, r/88.09.27/89.07.14/
l./write (out, <:logical disc : device no. :>,/, r/disc / disc /,
r/device no/dev no/
f
message basemove text fil 16
nextfile n g
lookup n g
n=edit g
; connect output : segm < 2 + key
;
l./procedure stack_current_output (file_name);/,
l./result := 2;/,r/2/1 shift 2/
l1, r/1<1/1<2/, r/preferably disc/temporary/
f
message printzones text fil 17
nextfile n g
lookup n g
n=edit g
; connect output
;
l./procedure stack_current_output (file_name);/,
l./result := 2; <*1<1 <=> 1 segment, preferably disc*>/,
r/2/1 shift 2/, r/1<1/1<2/, r/preferably disc/temporary/
f
message scatup text fil 18
nextfile n g g g g g g; ccpm, cpm, -bak, -sys, fdformat gl fil 27-31 skippes
lookup n g
n=edit scatup4tx
f
message makelink text fil 19
nextfile n g
lookup n g
n=edit makelinktx
f
message deletelink text fil 20
nextfile n g
lookup n g
n=edit deletlinktx
f
message discinfo text fil 21
nextfile n g
lookup n g
n=edit discinfo5tx
f
lookup n g
message slut editering af maintenance texter
end
finis
▶EOF◀