|
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: 19968 (0x4e00)
Types: TextFile
Names: »compress3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »compress3tx «
s. b20, c20, f20, g20, w. ; start segment...
d.
p.<:fpnames:>
l.
k = h55
g0. , 0 ; length, not used
jl. g1. ; entry: goto initialize;
; definitions of zones and shares:
b. a5, w. ; a-names used for initialization-chain...
; b0 = inputzone , b1 = input share
h.a0:4 , g2. ; h0+0: base buffer area = g2
0 , 0 ; +2: last of buffer = last of process = h8
2 , b1. ; +4: used share =
2 , b1. ; +6: first share =
a1. , b1. ; +8: last share = b1
0 , r.18 ; h1+0: process description
0 , 0 ; h2+0: give up mask = 0
a1:4 , f0. ; +2: give up action = f0
0 , 0 ; +4
a2. , h22. ; +6: free parameter = abs addr of fp inblock
b0: 0 , r.6 ; h3+0: record description
b1: 0 , 0 ; s+0: share state = 0
a2:a3. , g3. ; +2: first shared = g3
0 , r.20 ; +4
; b2 = output zone , b3 = output share
a3:4 , g2. ; h0+0: base buffer area = g2
0 , 0 ; +2: last of buffer = last of process = h8
2 , b3. ; +4: used share =
2 , b3. ; +6: first share =
a4. , b3. ; +8: last share = b2
0 , r.18 ; h1+0: process description
0 , 0 ; h2+0: give up mask = 0
a4:4 , f1. ; +2: give up action = f1
0 , 0 ; +4
a5. , h23. ; +6: free parameter = abs addr of fp outblock
b2: 0 , r.6 ; h3+0: record description
b3: 0 , 0 ; s+0: share state = 0
a5:a0. , g3. ; +2: first shared = g3
0 , r.20 ; +4
e. w. ; end a-names
\f
; other variables
b4: 0 , r.17 ; lookup area, and top entry (during cat-scan)
b5: 0 ; parameter pointer (points at item before
; current parameter, right byte)
b6: 1<23 + 4 ; constant = <bs>
b7: <:catalog:>, 0, 0 ; name and name table address for catalog
b8: 0 ; saved return from c7
b9: 0 ; fp result
b10: 0 ; saved fp start
\f
; remove parameter from parameter list
c6: rl. w3 b5. ; remove from area list:
ba w3 x3 ;
ba w3 x3 ;
ws. w3 b5. ;
hs. w3 (b5.) ;
; find the next legal item (i.e. a name not followed by a
; point) in the parameter list.
; (illegal items are removed from the parameter-chain)
c0: rl. w3 b5. ; next param:
ba w3 x3 ; w3 := item head(param);
bl w0 x3-1 ; w0 := preceding separator;
sh w0 3 ; if end param-list then
jl. c1. ; goto change descriptors;
bl w0 x3 ; if parameter <> <name> then
se w0 10 ; alarm(parameter);
jl. f2. ;
ba w3 x3 ; w3 := item head(following);
bl w0 x3-1 ; w0 := following separator;
sn w0 8 ; if point then
jl. f2. ; alarm(parameter);
; the parameter must describe a bs-area, with content <> 4
; and with an entry interval equal to the catalog base.
al w3 x3-9 ; w3 := addr of parameter name;
jl. w2 c7. ; check param(w2,w3);
se w1 0 ; if result <> ok then
jl. f5. ; alarm(error on input, w1);
; prepare for changing the catalog entry into a
; file descriptor
rl. w0 b6. ; size(catalog entry) := <bs>;
rs. w0 b4.+14 ;
dl. w1 b2.+h1+4; move areaname from output zone
ds. w1 b4.+18 ; to tail...
dl. w1 b2.+h1+8;
ds. w1 b4.+22 ;
rl. w0 b2.+h1+16; move segment count in output zone into
rs. w0 b2.+h1+14; blockcount of output zone and
rs. w0 b4.+28 ; into tail
rl. w3 b5. ; ...and into separator byte of current
ba w3 x3 ; parameter head;
hs w0 x3-1 ;
; move the file described by the parameter to output
al. w1 b0. ; connect input(input zone,
al w2 x3+1 ; parameter name);
jl. w3 h27. ;
se w0 0 ; if not ok then
jl. f6. ; alarm(connect input);
jl. w2 c2. ; readfile;
jl. w3 h79. ; terminate inputzone;
al. w1 b2. ;
jl. w2 c3. ; writefile;
\f
; change catalog entry of parameter, and increase param pointer...
; and goto next param...
al. w3 b4.+6 ; w3 := name of entry;
al. w1 b4.+14 ; w1 := tail;
jd 1<11+44; change entry(w1,w3);
sn w0 0 ; if ok then
jl. c6. ; goto remove from area list;
jd 1<11+48; remove entry(w3);
jd 1<11+40; create entry(w1,w3);
al w1 2.111 ; w1 := catalog key (param);
la. w1 b4. ;
se w1 0 ; if key > 0 then
jd 1<11+50; permanent entry(w1,w3);
rl. w3 b5. ; increase parameter pointer;
ba w3 x3 ;
rs. w3 b5. ;
jl. c0. ; goto next param;
; at end of parameter list: terminate the output zone and
; change the output entry so that it describes all the output
c1: al w3 x3-1 ; change descriptors:
rs. w3 b5. ; save end param address...
al. w1 b2. ;
jl. w3 h79. ; terminate outputzone;
al. w1 b4. ; w1 := lookup area;
al. w3 b2.+h1+2; w3 := output area name;
jd 1<11+42; lookup entry(w1,w3);
rl. w0 b2.+h1+16; length in tail :=
ls w0 9 ; segment count * 512;
rs w0 x1+18 ;
jd 1<11+44; change entry(w1,w3);
rl. w3 h8. ; w3 := start of area chain;
ba w3 x3+1 ;
sn. w3 (b5.) ; if start = end param addr then
jl. c5. ; goto finis program;
; prepare catalog scan
al. w3 b7. ; w3 := <:catalog:>;
jd 1<11+6 ; initialize process(w3)
sn w0 3 ; or
jd 1<11+52; create area process(w3);
se w0 0 ; if not ok then
jl. f7. ; alarm(cat-scan impossible);
rs. w0 b1.+12 ; segment count in input message := 0;
al. w0 g3. ; first address in message := g3;
rs. w0 b1.+8 ;
\f
; scan the catalog and find the entries whose kind is <bs>,
; and whose entry interval is equal to the catalog base, and
; whose content is not 4.
b. a5 w.
a0: al. w1 b1.+6 ; next transport:
al. w3 b7. ; w1,w3 := message and name addresses;
jd 1<11+16; send ...
al. w1 b4. ;
jd 1<11+18; and wait message;
bl w0 x1 ; if end document then
sn w0 1<6 ; goto finis program;
jl. c4. ;
rl w0 x1+2 ; segment no in message :=
ls w0 -9 ; bytes transferred // 512
wa. w0 b1.+12 ; + segment no in message;
rs. w0 b1.+12 ;
rl. w2 b1.+8 ; top entry := first of transfer
wa w2 x1+2 ; + bytes transferred;
rs. w2 b4. ;
a1: rl. w2 b4. ; next segment:
sh. w2 (b1.+8) ; if top entry <= first of transfer then
jl. a0. ; goto next transfer;
al w0 x2-512 ; entry := top entry;
rs. w0 b4. ; first of segment := top entry := top entry - 512;
a2: al w2 x2-34 ; next entry: entry := entry - 34;
sh. w2 (b4.) ; if entry <= first of segment then
jl. a1. ; goto next segment;
rl w0 x2-2 ; if empty entry then
sn w0 -1 ; goto next entry;
jl. a2. ;
; w2 now points at the lower interval of a nonempty entry...
rl w0 x2+12 ; if kind <> <bs>
bl w1 x2+28 ; or content = 4 then
sn. w0 (b6.) ; goto next entry;
sn w1 4 ;
jl. a2. ;
am. (h16.) ; if entry interval is not equal to
dl w1 +70 ; the catalog base then
sn w0 (x2) ; goto next entry;
se w1 (x2+2) ;
jl. a2. ;
\f
; scan the area chain in the parameter list to find an areaname
; equal to the documentname of the entry
rl. w3 h8. ; w3 := base of arealist;
a3: dl w1 x2+16 ; next area name:
a4: ba w3 x3+1 ; w0w1 := first part of documentname of entry;
sn. w3 (b5.) ; increase area name pointer;
jl. a2. ; if end of list then goto next entry;
sn w0 (x3+2) ; if area name is different from document name
se w1 (x3+4) ; of entry then
jl. a4. ; goto next area name;
dl w1 x2+20 ;
sn w0 (x3+6) ;
se w1 (x3+8) ;
jl. a3. ;
; change the documentname of the entry into the name of the
; output area and increase the blockcount in the entry
dl. w1 b2.+h1+4; move documentname from output zone...
ds w1 x2+16 ;
dl. w1 b2.+h1+8;
ds w1 x2+20 ;
bz w0 x3 ; increase blockcount in entry
wa w0 x2+26 ; by block no of area name;
rs w0 x2+26 ;
al w1 x2+12 ; w1 := tail of entry;
al w3 x2+4 ; w3 := name of entry;
jd 1<11+44; change entry(w1,w3);
jl. a2. ; goto next entry;
e. ; end a-names of catalog scan
\f
; finis program: set result and return to fp...
c4: jd 1<11+64; remove process(<:catalog:>);
rl. w3 h8. ; for all parameters left in
al w0 4 ; paramlist do
hs w0 x3 ; preceding separator (param)
ba w3 x3+1 ; := <s>;
se. w3 (b5.) ;
jl. -6 ;
c5: rl. w2 b9. ; w2 := fp result;
jl. h7. ; goto fp end program;
\f
; procedure readfile and writefile.
;
; call: jl. w2 c2. ; w1 = input zone => readfile
; jl. w2 c3. ; w1 = output zone => writefile
;
; the procedure transfers a whole number of segments, as
; described by the length-field of the param-entry.
;
; at return w1 and w2 are unchanged.
c3:
c2: rl. w3 b4.+32 ; w3 := length in tail of parameter;
sn w3 0 ; if length is zero then
jl x2 ; return;
al w3 x3+511 ;
as w3 -9 ;
as w3 9 ; last of transfer :=
al w3 x3-2 ; (length + 511) // 512 * 512
al. w0 x3+g3. ; + first shared - 2;
sl. w0 (b0.+h0+2); if last of transfer >=
jl. f4. ; last of buffer then alarm(process too small);
am (x1+h0+4) ; save last of transfer in share...;
rs w0 +10 ;
jl w3 (x1+h2+6) ; call fp-block...
am (x1+h0+4) ;
rl w3 +22 ; w3 := top transferred;
se w0 x3-2 ; if top transferred-2 <> last of transfer then
jl (x1+h2+2) ; call error procedure;
jl x2 ; return;
\f
; procedure check entry.
;
; call: jl. w2 c7. ; w3 = addr of entry name.
;
; the procedure checks that the entry is a legal compress-parameter.
;
; at return w1 is the result of the check:
; w1 = 0 == normal return, entry is ok
; w1 = 1 == entry is unknown
; w1 = 2 == wrong interval
; w1 = 3 == illegal content
; w1 = 4 == not area
b. a5 w.
c7: al. w1 b4. ; w1 := lookup area;
rs. w2 b8. ; save return;
jl. w2 a1. ; check single entry(w1,w3);
se w1 -1 ; if entry kind is <> bs then
jl. (b8.) ; return;
al. w1 g3. ; check the docname entry...
al. w3 b4.+16 ;
jl. w2 a1. ; if again the kind is <bs> then
sn w1 -1 ; result := 4;
al w1 4 ;
jl. (b8.) ; return;
a1: jd 1<11+76; check single entry:
se w0 0 ; if unknown then
jl. a4. ; result := 1 else
am. (h16.) ;
dl w0 +70 ; if entry interval is not equal to
sn w3 (x1+2) ; the catalog base then
se w0 (x1+4) ; result := 2 else
jl. a3. ;
bz w0 x1+30 ; if content is 4 then
sn w0 4 ; result := 3 else
jl. a2. ;
rl w0 x1+14 ; if size >= 0 then
sl w0 0 ; result := 0 else
jl. a5. ;
se. w0 (b6.) ; if kind <> <bs> then
am 4+1 ; result := 4
am -1-3 ; else result := -1;
a2: am 3-2 ;
a3: am 2-1 ;
a4: am 1-0 ;
a5: al w1 0 ;
jl x2 ; return;
e.
\f
; procedure alarm head.
;
; the procedure writes <:***<program name> :> on current out...
;
; call: jl. w2 f10. ;
b. a1 w.
f10: al. w0 a0. ; w0 := <:***<0>:>;
jl. w3 h31.-2 ; outtext;
rl. w3 h8. ;
al w0 x3+2 ;
jl. w3 h31. ; outtext(program name);
al. w0 a1. ;
jl. w3 h31. ; outtext(<: :>);
al w0 1 ; fp result := sorry;
rs. w0 b9. ;
jl x2 ; return;
a0: <:***<0>:>
a1: <: :>
e.
\f
; alarms.............
b. a10 w.
a0: h. a1 ; result = 0 , connect error
a2 ; 1 , unknown
a3 ; 2 , interval
a4 ; 3 , content
a5 ; 4 , not area
a6 ; 5 , intervals
a7 ; 6 , catalog scan impossible
a8 ; 7 , transport error
a9 ; 8 , process too small
w.
a1=k-a0 , <: connect error<10><0>:>
a2=k-a0 , <: unknown<10><0>:>
a3=k-a0 , <: interval<10><0>:>
a4=k-a0 , <: content<10><0>:>
a5=k-a0 , <: not area<10><0>:>
a6=k-a0 , <: intervals<10><0>:>
a7=k-a0 , <: catalog scan impossible<10><0>:>
a8=k-a0 , <: transport error<10><0>:>
a9=k-a0 , <: process too small<10><0>:>
a10: 0 ; saved errortext
; process too small...
f4: am 1 ; process too small: result := 8;
; transport error on input...
f0: al w2 0 ;
al. w1 b0. ; terminate input zone...
jl. w3 h79. ;
am x2 ;
; transport error on output...
f1: al w2 7 ; result := 7;
rl. w1 b2.+h1+14; segment count of output zone
rs. w1 b2.+h1+16; := block count of output zone;
am x2 ;
; alarms on input parameters...
f6: al w1 0 ; connect error: result := 0;
f5: bl. w1 x1+a0. ; other error, result is in w1...
al. w0 x1+a0. ; w0 := alarmtext
rs. w0 a10. ;
jl. w2 f10. ; alarm head...
rl. w3 b5. ;
ba w3 x3 ; w0 := parameter address;
al w0 x3+1 ;
jl. w3 h31. ; outtext(parameter);
rl. w0 a10. ; w0 := saved alarmtext;
jl. w3 h31. ; outtext.
jl. c6. ; goto remove item...
\f
; alarms on output parameter...
f3: al w1 0 ; connect error: result := 0;
f9: bl. w1 x1+a0. ; other error: result is in w1...
al. w0 x1+a0. ; w0 := alarmtext;
rs. w0 a10. ;
jl. w2 f10. ; alarm head
al. w0 b2.+h1+2; w0 := outfile name;
jl. w3 h31. ; outtext;
rl. w0 a10. ; w0 := saved alarmtext;
jl. w3 h31. ;
jl. c5. ; goto finis program;
; other alarms...
f7: am 1 ; catalog scan impossible: result := 6;
f8: al w1 5 ; intervals: result := 5;
al w0 0 ;
rs. w0 b2.+h1+2; outfilename := 0;
jl. f9. ; goto other error on output parameter...
e. ; end a-names for alarms...
\f
; parameter error...
b. a10 w.
f2: jl. w2 f10. ; alarm head...
al. w0 a0. ;
jl. w3 h31. ; outtext (<:param :>);
a1: rl. w2 b5. ; next: w2 := param pointer;
ba w2 x2 ;
bl w1 x2 ; w1 := parameter kind;
se w1 10 ; if <name> then
jl. a2. ;
al w0 x2+1 ; outtext(param name)
jl. w3 h31.-2 ;
jl. a3. ; else
a2: rl w0 x2+1 ;
jl. w3 h32.-2 ; outinteger(param);
0 ; ...layout...
a3: ba w2 x2 ;
bl w1 x2-1 ; w1 := following separator;
ws. w2 b5. ; remove item from parameterlist...
hs. w2 (b5.) ;
al w2 46 ; w2 := point-character;
al. w3 a1. ; set return to next;
sn w1 8 ; if separator is point then
jl. h26.-2 ; outchar(point);
al w2 10 ;
jl. w3 h26.-2 ; outchar(<10>);
jl. c0. ; goto next param;
a0: <:param <0>:>
e.
\f
; define the copy-buffer:
g2 = k-1 ; base buffer area
g3 = k ; first shared
0 , r.17 ; secondary lookup area
; initialize outputname
b. a1 w.
g1: am -1000 ;
rs. w3 h8.+1000; initialize: current command := program name...
rs. w1 b10. ; save fp start;
sn w2 x3 ; if leftside then
jl. a0. ; begin
al w3 x3-8 ; w3 := outfile name;
dl w1 x3+2 ; move outfile name to output zone...
ds. w1 b2.+h1+4;
dl w1 x3+6 ;
ds. w1 b2.+h1+8;
jl. w2 c7. ; check entry(w3);
sl w1 2 ; if not (unknown or ok) then
jl. f9. ; alarm(error on output);
; end;
; check catalog base and standard interval...
a0: am. ( b10.) ;
rl w3 h16 ;
dl w1 x3+70 ; w0w1 := catalog base;
al w1 x1-1 ;
sl w0 (x3+76) ; if catalog base is outside
sl w1 (x3+78) ; the standard interval then
jl. f8. ; alarm(intervals);
\f
; initialize abs addresses in zones...
al. w1 b0.+h0+1; w1 := chain start;
bl w0 x1-1 ;
a1: wa w1 0 ; next: w1 := next element;
bl w2 x1 ;
bl w0 x1-1 ;
wa w2 2 ; w2 := abs address of element;
rs w2 x1 ;
se. w1 b0.+h0+1; if not chain start then
jl. a1. ; goto next;
am -1000 ;
rl. w3 h8.+1000; param pointer := current command, rigth byte;
al w3 x3+1 ;
rs. w3 b5. ;
al w3 x3-3 ; initialize last of buffer in zones...
rs. w3 b0.+h0+2;
rs. w3 b2.+h0+2;
; connect output zone...
al w0 1<1+1 ; define area-size;
al. w1 b2. ; w1 := output zone;
al w2 x1+h1+2 ; w2 := outfile name;
jl. w3 h28. ; connect output;
se w0 0 ; if not ok then
jl. f3. ; alarm(connect error);
rl. w2 b4.+32 ; segment count of output zone :=
al w2 x2+511 ; (length + 511) // 512;
ls w2 -9 ;
rs w2 x1+h1+14 ;
rs w2 x1+h1+16 ;
jl. c0. ; goto next param;
e. ; end a-names of initialization.
g0: 0 ; length of segment, length of next segment...
i. e.
m. rc, compress 1985.03.13
e. ; end fpnames
\f
▶EOF◀