|
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: 10752 (0x2a00)
Types: TextFile
Names: »tdiablo«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦1a9e12e70⟧ »ccompose«
└─⟦this⟧
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦25442efea⟧ »ccompose«
└─⟦this⟧
\f
; call: diablo <area> first.last
(
diablo=set 2
diablo=slang entry.no list.no xref.no
diablo
if ok.yes
scope user diablo
lookup diablo
end)
b. g1,e3 w.
p.<:fpnames:>
k=h55
s. c9,g9 w.
0,0
c0: 0 ; fp-base
c1: 0 ; program name addr.
c2: 4<12-1 ; end command.
c3: <:*** :>
c4: <: param <0>:>
c5: <: call<0>:>
c7: 0 ; saved return addr.
c8: 0 ; saved error text addr.
c9: 0 ; saved error text addr.
; procedure init program
;
; at entry at return
;
; w0 destroyed
; w1 fp-base current command pt
; w2 link fp-base
; w3 cammand pt. destroyed
;
; save fp-base and program name addr.
; If left side in call return to <link> else to
; <link+2>
; In h8 the pointer to program name in command stack is saved.
g9: rs. w1 c0. ; save fp-base
rx w1 4 ; w2:=fp-base; w1:=return;
al w0 x3+2 ;
rs. w0 c1. ; save program name addr
bl w0 x3 ;
rx w3 2 ; w3:=return; w1:=program name addr.
rx w1 x2+h8 ; h8:=addr for program name in stack;
se w0 6 ; w1:=current command pt.
am 2 ; if left side in call then goto <link>
jl x3 ; elsegoto <link+2>
; end init program
; procedure next param
;
; at entry at return
;
; w0 del,kind
; w1 current command pt.
; w2 fp-base
; w3 link unchanged
;
; if end of command return to <link> else to <link+2>
g2: rl. w2 c0. ; w2:=fp-base;
rl w1 x2+h8 ;
ba w1 x1+1 ; pt:=pt+command stack(pt+1);
rl w0 x1 ;
sh. w0 (c2.) ; if end of command then
jl x3 ; return to <link>
rs w1 x2+h8 ; else return to <link+2>;
jl x3+2 ;
; end next param
; procedure param error
;
; at entry at return
;
; w0 destroyed
; w1 --
; w2 --
; w3 link --
;
; search through the command stack for a parameter with
; (del,kind)=(space,nams), whit listing the parameters
; and delimiters, ifend of command is met, return to end
; program
b. a10 ; begin block: param error.
w.
g3: rs. w3 c7. ; save return
al w0 1 ;
hs. w0 g5. ; ok.bit:=<:no:>;
rl. w2 c0. ; w2:=fp-base;
al. w0 c3. ;
jl w3 x2+h31-2 ; write(cur out,<:***:>);
rl. w0 c1. ;
jl w3 x2+h31 ; write(cur out,program name);
al. w0 c4. ;
jl w3 x2+h31 ; write(cur out,<:param:>);
rl w1 x2+h8 ; pt:=addr og current command;
bl w0 x1 ; del:=del for current command
a1: se w0 8 ; if del=point then
am -14 ; outchar(cur out,point)
al w2 46 ; else outchar(cur out,space);
am. (c0.) ;
jl w3 h26-2 ;
rl. w2 c0. ; w2:=fp-base;
al. w3 a2. ; w3:=return addr from write;
rl w1 x2+h8 ;
al w0 x1+2 ; kind:=kind for current command
bz w1 x1+1 ; if kind=text then
se w1 4 ; write(cou out,currrent command)
jl x2+h31-2 ; else writeinteger(cor out,current command);
rl w0 (0) ;
jl w3 x2+h32-2 ;
1 ;
a2: rl w1 x2+h8 ; current command:=
ba w1 x1+1 ; next command in stack;
bl w0 x1 ; if end of command in stack then
sh w0 3 ; goto end prog;
jl. g8. ;
sh w0 4 ; if del<>sp then
jl. a3. ; goto ret;
rs w1 x2+h8 ;
jl. a1. ; goto list next;
a3: am. (c0.) ;
jl w3 h33-4 ; outend(nl);
jl. (c7.) ; return;
e. ; end block: param error
; terminate program with error message
;
; write one or two error messages on current output, and
; return to fp with ok.bit:=<:no:>,
; entry at g7, w0:=addr of text 1, w1:=addr. of text 2
; entry at g4, only one text, addr. in w0
g7: rs. w1 c9. ; save text addr 2;
jl. g4. ;
al. w0 c5. ; error text 1:=<:call:>;
g4: rs. w0 c8. ; save text addr 1;
rl. w2 c0. ; w2:=fp-base;
al. w0 c3. ;
jl w3 x2+h31-2 ; write(cur out,<:***:>);
rl. w0 c1. ;
jl w3 x2+h31 ; write(cur out,program name);
al w2 32 ;
am. (c0.) ;
jl w3 h26 ; outchar(space);
rl. w2 c0. ;
rl. w0 c8. ;
jl w3 x2+h31 ; write(cur out,error text 1);
rl. w0 c9. ; if error text addr 2<>0 then
se w0 0 ; write(cur out, error text 2);
jl w3 x2+h31 ;
g8: jl w3 x2+h33-4 ;
al w2 1 ; ok.bit:=<:no:>;
am. (c0.) ;
jl h7 ;
; end terminate program
; end program
g5=k+1
g6: al w2 0 ; set ok.bit
am. (c0.) ;
jl h7 ; return to fp;
b. a30,i10 w.
a0=1
a10: 4<12+10 ; sp,name
a11: 4<12+4 ; sp,integer
a12: 0,r.4 ; name
a13: 8<12+4 ; dot integer
a16: 0 ; first page
a17: 1 000 000 ; last page
a18: 0 ; page
a20: a30.
0,r.18
a21: 0,r.7 ; zone descr
a22: 0,r.11 ; share descr
a23: <:end. connect source<0>:>
a24: <:<27><10>:>
a25: <:<27><30><9><13><10>diablo end.<13><10><0>:>
a26: <:diablo begin.<13><10><0>:>
e1: jl. w2 g9. ; init program;
jl. g4.-2 ; if left side then call error
jl. w3 g2. ; next param
jl. g4.-2 ; if end of com then call error;
se. w0 (a10.) ; if (del,kind)<>(sp,name) then
jl. i5. ; goto param;
dl w0 x1+4 ;
ds. w0 a12.+2 ; move name
dl w0 x1+8 ;
ds. w0 a12.+6 ;
am. (a20.) ; init input zone
al. w3 a20. ;
rs. w3 a22.+2 ;
al w3 x3-1 ;
rs. w3 a21.+h0 ;
al w3 x3+513 ;
rs. w3 a21.+h0+2 ;
al. w3 a22. ;
rs. w3 a21.+h0+6 ;
al. w1 a21. ;
al. w2 a12. ;
jl. w3 h27. ; connect in
se w0 0 ; if not ok then
jl. i6. ; goto connect in error;
jl. w3 g2. ; next param;
jl. i0. ; if end of param then goto copy;
se. w0 (a11.) ; if (del,kind)<>sp,integer) then
jl. i4. ; goto param;
rl w0 x1+2 ; first:=integer;
rs. w0 a16. ;
rs. w0 a17. ; last:=first;
jl. w3 g2. ; next param;
jl. i0. ; if end com then goto copy;
se. w0 (a13.) ; if (del,kind)<>(dot,integer) then
jl. i4. ; goto param;
rl w0 x1+2 ; last:=integer;
rs. w0 a17. ;
i0: al. w0 a26. ; copy:
jl. w3 h31.-2 ; outtext(<:diablo begin.:>);
c. a0-1
rl. w1 h21.+h0+4 ;
al w0 4 ;
lo w0 x1+6 ;
rs w0 x1+6 z. ; mode for current out := 4;
; copy
i1: al. w1 a21. ; read:
jl. w3 h25. ; readchar(w2);
sl w2 140 ; if w2>=140 then
jl. i3. ; goto fin;
se w2 139 ; if w2=139 then
jl. i2. ; page:=page+1;
rl. w3 a18. ;
al w3 x3+1 ;
rs. w3 a18. ;
i2: rl. w3 a18. ;
am. (a17.) ;
sl w3 1 ; if last page<page then
jl. i3. ; goto fin;
am. (a16.) ;
sh w3 -1 ; if first page<page then
jl. i1. ; goto read;
al. w3 i1. ;
sn w2 139 ; if w2=139 then
jl. i8. ; wait em;
c.a0-1
se w2 10 ; if w2=10 then
jl. i10. ; outchar(13);
al w2 13 ;
jl. w3 h26.-2 ;
al w2 10 z.;
i10: c.-a0
se w2 10 ;
sl w2 32 ; if w2<32 and <>10 then
jl. 4 ; w2:=w2+128;
al w2 x2+128 z. ;
jl. w3 h26.-2 ; outchar(w2);
jl. i1. ; goto read;
i3: ; FIN:
jl. w3 i8. ; wait em;
i9: al. w0 a25. ; TER:
jl. w3 h31.-2 ; outtext(<:diablo end:>);
al w2 0 ;
jl. w3 h34.-2 ; close up current out;
al. w1 a21. ;
jl. w3 h79. ; terminate in zone;
c.a0-1
rl. w1 h21.+h0+4 ;
al w0 -5 ;
la w0 x1+6 ;
rs w0 x1+6 ; mode for current out :- 4;
z. jl. g6. ; return to fp;
i4: al. w1 a21. ; param:
jl. w3 h79. ; terminate in zone;
c.a0-1
rl. w1 h21.+h0+4 ;
al w0 -5 ;
la w0 x1+6 ;
rs w0 x1+6 ; mode for current out :- 4;
z.
i5: al. w3 g6. ; return:=end of program;
jl. g3. ; param error;
i6: al. a23. ; connect in error;
jl. g4. ; terminate;
; procedure wait em
b. a5 w.
i8: rs. w3 a3. ; save return;
al w2 0 ;
jl. w3 h34.-2 ; close up(NULL);
a1: jl. w3 h25.-2 ; rep: inchar(w2);
sn w2 64 ; if w2=64 then goto TER;
jl. i9. ;
se w2 10 ; if w2=10 then goto rep;
jl. a1. ;
al. w0 a24. ;
jl. w3 h31.-2 ; outtext(<:<27><30>:>);
jl. (a3.) ; return;
a3: 0
e.
a30:
e.
e0=k-h55
0,h.r.512-(:k a. 8.777:) w.
e.
g0:g1:
(:e0+511:)>9
0,r.7
2<12+e1-h55
e0
p.<:insertproc:>
▶EOF◀