|
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: »ttestbuf«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦e3baaaa97⟧ »tslprog«
└─⟦this⟧
(testbuf=set 2
testbuf=slang fpnames type.yes
availbuf=assign testbuf
availbuf=changeentry bs testbuf testbuf testbuf testbuf 2.6 testbuf
global testbuf
end)
; HCØ 8.08.73
; Heinrich Bjerregaard.
s. a6,b24,i24,c8,e12 ; begin slang segment
w.
k=h55 m.testbuf
0,0 ;standard for fp-programs
jl. e0. ; entry sender buf
jl. e2. ; entry
b0: 0 ; last parameter
b1: 0 ; fp-base
b2: 0 ; sender/receiver address
b3: 0 ; counter for available buf
b4: 0 ; sender/receiver
b5: 0 ;
b6: 0,0 ; sender, receiver
b7: 0 ; sender/receiver addr
b8: <:<0><0>r:>
b9: <:<0><0>s:>
b10: <:<10>available buf: <0>:>
b11: <: existing sender pending<10><0>:>
b12: <: existing sender received<10><0>:>
b13: <: removed sender pending<10><0>:>
b14: <: removed sender received<10><0>:>
b15: <: normal answer pending<10><0>:>
b16: <: message rejected<10><0>:>
b17: <: message unintelligible<10><0>:>
b18: <: receiver malfunction<10><0>:>
b19: <: receiver unknown<10><0>:>
b20: <:param:>
b21: <:<10>***testbuf <0>:>
b22: <: name unknown<0>:>
; procedure Next_parameter
; registers at entry at return
; w0 not used unchanged
; w1 - separator
; w2 - address of name/constant
; w3 link length of item
b. g5 ; begin
w.
g0: 0 ;
c6: rs. w3 g0. ; save link
rl. w2 b0. ;
ba w2 x2+1 ; item pointer:=item pointer
rs. w2 b0. ; + core(item pointer + 1);
bl w1 x2 ; w1:=separator;
bl w3 x2+1 ; w3:=length of item;
al w2 x2+2 ;
jl. (g0.) ; return;
e. ; end Next_parameter;
; procedure endprogram(ok);
; The procedure returns to the file processor with
; the ok-bit set to succes or not succes.
am 1 ;
c8: al w0 0 ;
al w2 10 ;
jl. w3 h33.-2 ; outend(10);
rl w2 0 ;
jl. h7. ; goto fileprocessor;
e0: rs. w3 b0. ; save param_pointer
rs. w1 b1. ; save fp-base
jl. w3 c6. ; Nextparameter;
sh w1 2 ; if no parameter then
jl. e2. ; goto Avail buf;
i5: ; Continue:
jl. w3 c0. ; i:=procaddr(name);
se w3 0 ; if name unknown then
jl. i0. ; begin
al. w0 b21. ;
jl. w3 h31.-2 ;
al w0 2 ;
wa. w0 b0. ;
jl. w3 h31. ; write(out,<:<10>***testbuf :>,
al. w0 b22. ; name,<: name unknown:>);
jl. w3 h31. ;
jl. c8.-2 ; endprogram(not succes);
; end;
i0: rs. w3 b2. ; save sender addr
ac w3 x3 ;
rs. w3 b7. ; save neg sender/receiver
jl. w3 c6. ; Nextparameter;
sn w1 8 ;
se w3 10 ; if not a text then
jl. i2. ; goto Illegal param;
al w3 0 ;
rl w0 x2 ;
ls w0 -16 ;
se. w0 (b8.) ; if name=sender then
jl. i1. ; goto S;
al w3 2 ;
jl. i3. ;
i1: sn. w0 (b9.) ; S:
jl. i3. ;
i2: al. w0 b21. ; Illegal param:
jl. w3 h31.-2 ;
al. w0 b20. ;
jl. w3 h31. ;
jl. c8.-2 ; endprogram(not succes);
i3: rs. w3 b4. ;
rl w1 86 ; w1:=message pool start;
jl. 6 ;
i4: rl. w1 b5. ;
wa w1 90 ;
rs. w1 b5. ;
am (88) ;
sl w1 2 ; if last buffer then
jl. i20. ; goto Stop;
i6: dl w3 x1+6 ;
se w3 0 ; if buffer not available then
jl. i10. ; goto Used;
rl. w2 b3. ; Avail:
al w2 x2+1 ; buffer avail:=
rs. w2 b3. ; buffer avail + 1;
jl. i4. ; goto Loop;
i10: rx w2 6 ;
ds. w3 b6.+2 ; save sender, receiver
am. (b4.) ;
rl. w0 b6. ;
sn. w0 (b7.) ;
jl. 6 ; if receiver<>message.receiver
se. w0 (b2.) ; and sender<>message.sender then
jl. i4. ; goto Loop;
al w0 x1 ;
am. (b1.) ;
jl w3 h32-2 ; write(out,<<dddddddd>,buffer addr);
32<12+8 ;
al w0 2 ;
jl. w3 c4. ; outspace(2);
sl w2 0 ; if sender>0 then
jl. i14. ; goto Pos sender;
ac w2 x2 ; Neg sender:
jl. w3 c2. ; outname(sender addr);
rl. w1 b6.+2 ;
al w2 x1 ;
sh w2 0 ; if receiver<0 then
ac w2 x2 ; receiver:=-receiver;
jl. w3 c2. ; outname(receiver addr);
al. w0 b13. ;
sh w1 0 ; write(out, state);
al. w0 b14. ;
am. (b1.) ;
jl w3 h31-2 ;
jl. i4. ; goto Loop;
i14: jl. w3 c2. ; Pos sender:
rl. w0 b6.+2 ; outname(sender addr);
rl w2 0 ;
sh w0 5 ; if receiver<1 or
sh w0 0 ; receiver>5 then
jl. i16. ; goto Exist;
am. (b1.) ; Answer:
jl w3 h32-2 ; write(out,<<dddddddddddd>,result);
32<12+12 ;
ls w2 1 ;
jl. x2 ;
am b15-b16 ;
am b16-b17 ;
am b17-b18 ;
am b18-b19 ;
al. w0 b19. ; write(out,case result of
am. (b1.) ; (-b15-,-b16-,-b17-,-b18-,-b19-));
jl w3 h31-2 ;
jl. i4. ; goto Loop;
i16: sh w0 0 ; Exist:
ac w2 x2 ;
jl. w3 c2. ; outname(receiver addr);
sh w0 0 ;
am b12-b11 ;
al. w0 b11. ;
am. (b1.) ;
jl w3 h31-2 ; write(out, state);
jl. i4. ; goto Loop;
i20: jl. w3 c6. ; Stop: Nextparameter;
sl w1 3 ; if more parameters then
jl. i5. ; goto Continue;
jl. c8. ; goto FINIS;
e2: ; Avail buf:
rl w2 86 ; w2:=start message pool;
al w1 0 ; avail buf:=0;
i22: am (88) ;
sl w2 2 ; if last buffer then
jl. i24. ; return;
dl w0 x2+6 ;
wa w2 90 ;
se w0 0 ;
jl. i22. ; if sender=0 and receiver=0 then
se w3 0 ; avail buf:=avail buf+1;
jl. i22. ;
al w1 x1+1 ;
jl. i22. ;
i24: al w2 x1 ;
al. w0 b10. ;
jl. w3 h31.-2 ;
al w0 x2 ;
jl. w3 h32.-2 ;
32<12+3 ;
jl. c8. ;
; procedure procaddr(name);
; The procedure looks for a process with a name
; name. If it exsist it returns with the according process
; description address.
; registers at entry at return
; w0,w1 not used unchanged
; w2 name addr destroyed
; w3 link 0 or pda
b. d12 ; begin
w.
d0:0,0
d1: 0
d2: 0
c0: ds. w1 d0.+2 ; save registers
rs. w3 d1. ; save return
rl w3 72 ; w3:=nametable start;
rs. w3 d2. ;
d6: rl. w3 d2. ; Loop:
sn w3 (80) ; if name table end then
jl. d8. ; goto Stop;
al w3 x3+2 ; get next item in name table
rx. w3 d2. ;
rl w3 x3 ; get proc addr
dl w1 x3+4 ;
sn w0 (x2) ;
se w1 (x2+2) ; if name <> proc name then
jl. d6. ; goto Loop;
dl w1 x3+8 ;
sn w0 (x2+4) ;
se w1 (x2+6) ;
jl. d6. ; procaddr:=pda;
jl. 4 ; goto END;
d8: al w3 0 ; Stop: procaddr:=0;
dl. w1 d0.+2 ; END:
jl. (d1.) ; return
e. ; end procaddr;
; procedure outname(addr);
; The procedure prints a name given by addr+2 and
; fill up with spaces so 12 characters are printed
; totally.
; registers at entry at return
; w0,w1 not used unchanged
; w2 addr -
; w3 link -
b. d12 ; begin
w.
d0: 0,r.4 ; saved registers
d1: 8.177 600 ; second character in a word
c2: ds. w1 d0.+2 ;
ds. w3 d0.+6 ; save registers
al w2 x2+2 ;
al w0 x2 ;
am. (b1.) ;
jl w3 h31-2 ; write(out,
rl w1 0 ; false add 32,
ws w0 4 ; 12-write(out,
rl w3 0 ; string name));
ls w3 -1 ;
wa w3 0 ;
ac w0 x3-12 ;
rl w2 x1-2 ;
sn w2 0 ;
ba. w0 1 ;
sz. w2 (d1.) ;
jl. 4 ;
ba. w0 1 ;
sz w2 8.177 ;
jl. 4
ba. w0 1 ;
jl. w3 c4. ;
dl. w1 d0.+2 ; restore registers
dl. w3 d0.+6 ;
jl x3 ; return
e. ; end outname;
; procedure outspace(no);
; The procedure outputs no spaces on current
; output.
; registers at entry at return
; w0 no of char destroyed
; w1 not used -
; w2 - unchanged
; w3 link destroyed
b. d6 ; begin
w.
d0: 0,0
c4: ds. w3 d0.+2 ; save w2, return
al. w3 2 ;
rl. w2 d0. ;
bs. w0 1 ;
sh w0 -1 ; write(out,false add 32,no);
jl. (d0.+2) ;
al w2 32 ;
am. (b1.) ;
jl w0 h26-2 ;
e. ; end outspace;
e. ; end slang segment
e.
▶EOF◀