|
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: 26880 (0x6900)
Types: TextFile
Names: »too «
└─⟦110021343⟧ Bits:30007476 RC8000 Backup tape fra HT's bus-radio system
└─⟦a957ba283⟧
└─⟦this⟧ »too «
(
message copyout
copyout=set 4
oo=set bs copyout
copyproc=set 2
xxx=set 1
o xxx
copyout=slang names.yes
copyout oo
if ok.yes
(
o c
xxx=edit xxx
yyy=algol message.no
yyy xxx
clear temp xxx yyy
copyout=add copyproc
scope user copyout oo copyproc
)
if ok.no
(
o c
message copyout not ok
end
)
)
b. g1, e4 ; block for insertproc
d.
p. <:fpnames:> ;
l.
; NHP marts 1991
;
; Slang program og kode procedure til at frembringe en kopi på et
; bs-areal af det der skrives på zonen out. Kopieringen klargøres
; med programkaldet "<bs-area> = oo" og afsluttes med "oo". Algol
; programmer, der kaldes mellem disse to kald af oo og som ønsker
; at benytte faciliteten, kalder proceduren "copyout". Proceduren
; har ingen parametre og ingen returværdi, og bør kun kaldes en
; gang. Den sætter give up mask, give up action og algol blokpro-
; cedure i out's zone description samt modificerer h7, end pro-
; gram, så det sidste output kommer med, inden den retablerede h7
; kaldes.
;
; Programmet "oo" parallelforskyder adresseområdet fra h8 til h9,
; så der fra h9 til zonen in bliver plads til en blokprocedure
; for out og et bufferområde til bs-arealet. Bemærk, at koden i
; den følgende tekst kan forekomme dels i blokproceduren i nær-
; heden af h9, dels som program loadet af fp, og endelig blandt
; et algolprograms programsegmenter.
;
; Blokproceduren kan kaldes af algol_io, af fp_io og af fp via
; kodeproceduren fp_proc.
;
; b, c and e names:
;
; b0: start of copy to (h9)+2 c0: algol block procedure
; b1: message c1: procedure copy core
; b2: answer b19:
; b3: name c2: common block procedure
; b4: fp-base c3: procedure read char
; b5: top of transfer c4: procedure write char
; b6: save w1 ("record base") c5: end program action
; b7: save w3 ("partial word") c6: procedure fill segment
; b8: stack ref old block proc
; b9: point to old block proc e0: start of slang segment
; b10: constant 255 e1: external list
; b11: constant 1<18 e2: copyout entry
; save (h7:) e3: oo entry
; b12: save (h7:+2) e4: end of slang segment
; b13: flag f. blkproc called
; b17: start of buffer
; b18: used for buffer-alignment
; b19: top of buffer
; b20: length of copy
;
k=h55
w.
s. b20, c10, d10 ;
w.
e0:
b. j30, g4 ; code procedure copyout and algol
; blockprocedure segment
h.
g0=0 ; no externals
g1: g3 , g2 ; head word
j5: g0 + 5 , 0 ; RS entry 5, goto point
j8: g0 + 8 , 0 ; RS entry 8, end address exp
j13: g0 + 13 , 0 ; RS entry 13, last used
j21: g0 + 21 , 0 ; RS entry 21, general alarm
j27: g0 + 27 , 0 ; RS entry 27, out
j30: g0 + 30 , 0 ; RS entry 30, saved stack ref, w3
g2=-g1.-2 ; end of abs words
j0: 1<11 o.0, c0 ; point in this segm
g3=-g1.-2 ; end of points
w.
e1: g0 ; external list, no externals
0 ; no hw's in own core
91 03 08 ; date
s4 ; time
; De følgende data kopieres til hullet der skabes
; mellem h9 og zonen in
b0: ; (h9)+2:
; w0: answer area addr
; w1: zone descr
; w2: share descr
; w3: logical status
am ( 0 ; (h9)+2: fp-io blockproc entry
rl w0 2 ; w0:= hw transferred
jl. w1 b19. ; block_proc(
am h36-h68 ; normal_return,
al w2 h68 ; error_return);
am. ( b4. ;
al w1 h21 ; w1:= zone descr
am. ( b4. ; goto if error then
jl x2 ; std_give_up else return_to_check;
b1: 5<12+0, 0, 0, 0 ; message
b2: 0, r.8 ; answer
b3: 0, r.5 ; name, name table addr
b4: 0 ; fp base
b5: 0 ; top addr from out
b6: 0 ; saved w1
b7: 0 ; saved w3
0 ; stack ref
b9: 0 ; segm nr, relative
b10: 255 ; mask, last char in word
b11: 1<18 ; mask, end of file
0 ; saved h7:
b12: 0 ; saved h7:+2
b17: ; start of buffer
; Det følgende kopieres med, men overskrives af data fra out
; Koden i det følgende står blandt algol programsegmenterne
b. a10 ; procedure copyout;
w.
am. ( h9-h7 ; h7: goto (h9)+c5
a0: jl w3 c5 ; +2: end_action;
; +4: =w3
a1: <:<10>mon30res:> ;
e2: rl. w2 ( j13. ; copyout entry
ds. w3 ( j30. ; save stack ref;
rl. w2 j27. ; w2:= out zone descr;
ac w0 h53+1 ; w0:= -free before zones
wa w0 x2 h20+h0-h21 ; +first of in
ws w0 x2 h9-h21 ; -(h9);
se w0 b20 ; if w0<>length of copy-code
jl. ( j8. ; then return; <* oo inactive *>
al w1 2 ;
wa w1 x2 h9-h21 ; w1:= (h9)+2;
al w3 x1 b3-b0 ; w3:= addr(copyname);
rl. w0 a0.-2 ;
sn w0 (x2 h7-h21 ; if h7 already changed
jl. ( j8. ; then return;
jd 1<11+52 ; create area process(copyname)
jd 1<11+30 ; write protect(copyname)
sn w0 0 ; if result <> 0
jl. a2. ;
rl w1 0 ; then
al. w0 a1. ; alarm(<:mon30res:>,result);
jl. w3 ( j21. ;
a2: al w0 1<1 ; out.give_up_mask += 2;
lo w0 x2 h2 ; <* normal answer *>
ds w1 x2 h2+2 ; out.give_up_action:= (h9)+2;
rl. w0 ( j13. ; get stack ref
rl. w1 j0. ; and point to proc;
rx w0 x2 h4 ;
rx w1 x2 h4+2 ; exchange with out.blockproc;
ds w1 x3 b9-b3 ; save out.blockproc
dl. w1 a0. ;
rx w0 x2 h7-h21 ; change (h7) (fp end action)
rx w1 x2 h7-h21+2 ; to jump to c5;
ds w1 x3 b12-b3 ;
jl. ( j8. ; return;
e. ; end copyout;
; Koden i det følgende står blandt algol programsegmenterne
b. a10 ; procedure block_pr(z,s,b);
w.
c0=-g1. ; algol block_proc(z,s,b);
rl. w2 ( j13. ;
ds. w3 ( j30. ;
rl. w1 j27. ; w1:= out;
rl w3 (x2+12 ; w3:= s;
rl w0 (x2+16 ; w0:= b;
sh w0 512 ; if b > 512 then
jl. a0. ; <* fp_proc ! *>
rl w2 ( 0 ; w0:= word(word(w0)+2);
rl w0 x2+2 ;
a0: rl w2 x1+h0+4 ; w2:= used_share(out)
am (x1+h9-h21 ;
jl w1 c2 ; resident block-proc;
jl. ( j8. ; if ok then return;
rl. w1 j27. ; else
rl. w2 ( j13. ;
am (x1+h9-h21 ;
dl w1 2+b9-b0 ; old block_proc;
ls w0 4 ;
jl. ( j5. ;
e. ;
; Koden i det følgende står kort efter fp som et slang-program
b. a20 ; start of oo-program
w.
e3: rs. w1 b4. ; save fp-base
al w2 x2+2 ; w2:= addr(output or progname)
al w3 x3+2 ; w3:=
rs. w3 d3. ; d3:= addr(progname)
ac w0 h53+1 ;
wa. w0 h20.+h0
ws. w0 h9. ; w0:= base.in-h53-top_of_commands
se w2 x3 ; if left side
jl. a2. ; then goto output;
se w0 b20 ; if not active
jl. a7. ; then return(<:already inactive:>);
ac. w2 b0.-2 ; displacement:= top_of_commands
wa. w2 h9. ; _ + 2 - start_of_buffer;
dl. w1 x2+b3.+2 ;
ds. w1 b3.+2 ;
dl. w1 x2+b3.+6 ;
ds. w1 b3.+6 ;
rl. w0 x2+b3.+8 ;
rs. w0 b3.+8 ;
al. w3 b3. ;
a4: jd 1<11+52 ; create area process;
se w0 0 ; if w0 <> 0 then goto rep;
jl. a4. ;
rl. w1 x2+b6. ; w1:= copyout_pointer;
rl. w3 x2+b7. ; w3:= addr(write());
am 25 ; outchar(25);
a0: al w0 0 ; while not
jl w3 x3 ; buffer_change do
jl. a1. ;
se. w1 x2+b17. ; outchar(0);
jl. a0. ;
se. w3 x2+c4. ;
jl. a0. ;
al. w3 x2+b3. ;
jd 1<11+42 ; look up entry;
rl. w0 x2+b1.+6 ;
rs w0 x1 ; cut segments;
dl w1 110 ; get clock;
ld w1 5 ;
al. w1 x2+b17. ;
rs w0 x1+10 ; set shortclock;
jd 1<11+44 ; change entry;
al w0 x3 ;
jl. w3 h31.-2 ; write(out, copyname);
al w2 61 ;
jl. w3 h26. ; write(out, <:=:>);
am -1 ;
a1: al w0 1 ;
hs. w0 a3. ;
al w0 b20 ;
rl. w1 h8. ; move back
rl. w2 h9. ; fp-kommands;
jl. w3 c1. ;
rs. w1 h8. ;
rs. w2 h9. ;
rl. w0 d3. ;
jl. w3 h31.-2 ; write(out, progname);
al. w0 d5. ;
jl. w3 h31. ; write(out, <: now inactive:>);
al w2 0 ; return(ok)
a3=k-1
jl. h7. ;
a2: se w0 0 ; output:
jl. a8. ; if dist((h9),in) <> 0
rs. w2 d2. ; then goto already active;
al w0 1<2+3 ;
al w1 0 ;
jl. w3 h28. ; connect output;
se w0 0 ; if not ok
jl. a9. ; then goto connecterror;
rl w0 x2+14 ; message.segm:=
rs. w0 b1.+6 ; segm. nr.;
rl w0 x2 ;
al w2 x2+2 ;
sl w0 0 ;
rl. w2 d2. ; copyname:=
dl w1 x2+2 ; connected name;
ds. w1 b3.+2 ;
dl w1 x2+6 ;
ds. w1 b3.+6 ;
ac w0 b20 ; push h8-h9
rl. w1 h8. ; upwards to
rl. w2 h9. ; make room;
jl. w3 c1. ;
rs. w1 h8. ;
rs. w2 h9. ;
ac. w2 b0.-2 ; displacement:=
wa. w2 h9. ; _ top of commands + 2 - start of copycore;
al. w1 x2+b17. ; set up addresses:
rs. w1 b1.+2 ; message.first
rs. w1 b6. ; "record base"
al w1 x1+510 ;
rs. w1 b1.+4 ; message.last
al. w1 x2+c4. ;
rs. w1 b7. ; "partial word"
al w0 x2 ;
al. w1 b0. ;
al w2 x1+b20 ;
jl. w3 c1. ; copy to (h9)-in;
al w2 0 ;
jl. h7. ; return;
a7: jl. w2 a10. ;
<: already inactive<10><0>:>
a8: al. w0 d4. ; already active:
jl. w3 h31.-2 ; write(out,<:***:>);
ac. w2 b0.-2 ; displacement:=
wa. w2 h9. ; _ top of commands + 2 - start of buffer;
al. w0 x2+b3. ;
jl. w3 h31. ; write(out,copyname,
al w2 61 ; _ <:=:>,
jl. w3 h26. ;
jl. w2 a11. ; _ programname,
<: already active<10><0>:>
a9: jl. w2 a10. ; connecterror:
<: connect output unsucceccful<10><0>:>
a10: al. w0 d4. ;
jl. w3 h31.-2 ;
a11: rl. w0 d3. ;
jl. w3 h31. ;
al w0 x2 ;
jl. w3 h31. ;
al w2 1 ;
jl. h7. ; return(error)
e. ;
; Og nu noget for at overholde konventionerne for en kode procedure
g4:
c. g4-g1-506
m. code segment too long
z.
c. 502-g4+g1
0, r.252-(:g4-g1:)>1
z.
<:copyout:>, 0 ; alarm text
i.
e. ; end code procedure segm.
; Nu er vi tilbage i slang programmet
0 ; save link
d0: 0 ; save displacement
d2: 0 ; save addr(copyname)
d3: 0 ; save addr(programname)
d4: <:***<0>:>
d5: <: now inactive<10><0>:>
b. a10 ;
w.
; kopier intervallet w1:w2 displacement væk
; w0: displacement ?
; w1: first from first to
; w2: last from last to
; w3: link ?
c1: ds. w0 d0. ; save link, displacement;
sh w0 0 ;
jl. a2. ; if displacement > 0
wa w0 4 ; then begin
am 2 ;
a1: al w2 x2-2 ; for i:= last step -2 until first
rl w3 x2 ; do to.i:= from.i
am. ( d0. ;
rs w3 x2 ;
se w2 x1 ;
jl. a1. ;
wa. w1 d0. ;
rl w2 0 ;
jl. ( d0.-2 ; end else
a2: wa w0 2 ; begin
am -2 ;
a3: al w1 x1+2 ; for i:= first step 2 until last
rl w3 x1 ; do to.i:= last.i
am. ( d0. ;
rs w3 x1 ;
se w1 x2 ;
jl. a3. ;
rl w1 0 ;
wa. w2 d0. ;
jl. ( d0.-2 ; end;
e. ;
; Fyld op resten af den plads, som skal bruges som buffer
b18: ;
0, r.256-(:b18-b17:)>1 ;
b19: ; top of buffer
; Det følgende er den kode som, efter kopiering til området mellem
; (h9) og in, sørger for kopieringen fra out
b. a10, d10 ;
w.
; block procedure, common part
;
; w0: hw's transferred
; w1: link
; w2: share
; w3: status
c2=-b0.+2 ; b19:
rs. w1 d1. ; entry block proc
sz w3 1 ; if hard error
jl. a3. ; then goto hard;
al. w1 a2. ; finished:= normal
rs. w1 b13. ;
rl w1 x2+8 ; w1:= first addr;
wa w0 2 ; w0:= w1 + hw's transf.
a0: rs. w0 b5. ; cont:
al. w2 c3. ; top addr:= w0
rl. w3 b7. ; x2:= read 1st char;
a1: jl w2 x2 ; rep:
b13: 0 ; read char(finished);
sn w0 0 ; if char = 0
jl. a1. ; then goto rep
sn w0 25 ; if char = 25
jl. a4. ; then goto fill segm
rx. w1 b6. ;
jl w3 x3 ; write char
jl. ( b13. ; if error then goto finished;
rx. w1 b6. ;
jl. a1. ; goto rep
a2: rs. w3 b7. ; finished(normal):
jl. ( d1. ; normal return
a3: rs. w3 d3. ; hard:
al. w0 a5. ;
rs. w0 b13. ; finished:= hard;
rl w1 x2+8 ; w1:= first addr
al w0 2 ;
wa w0 x2+10 ; w0:= last addr + 2
jl. a0. ; goto cont
c6: rs. w3 d1. ; ext fill segm:
rl. w3 b7. ;
a4: am -2 ; fill segm:
a5: al w1 2 ; finished(hard):
hs. w1 a8. ;
rs. w3 b7. ; finished(hard):
rl. w1 b6. ; save w1, w3 to enable continuation
rs. w1 d0. ; if out are repaired
rl w2 x1 ;
am 25 ; outchar(25);
a6: al w0 0 ; while not
jl w3 x3 ; buffer_change do
jl. a7. ;
se. w1 b17. ; outchar(0);
jl. a6. ;
se. w3 c4. ;
jl. a6. ;
rl. w1 b1.+6 ; decrement segment count;
al w1 x1-1 ;
rs. w1 b1.+6 ;
a7: rl. w1 d0. ;
rs. w1 b6. ;
rs w2 x1 ;
dl. w3 d3. ; reestablish save w1
jl x2+2 ; error return
a8=k-1
d0: 0 ; save save w1
d1: 0 ; save link
d3: 0 ; save status
e. ;
b. a10, d10 ;
w.
d2: 0 ; save read pointer
d3: 0 ; save write pointer
; read char
; w0: ? char
; w1: word addr word addr
; w2: link link
; w3: ? unchanged
jl w2 x2+2 ;
c3: sl. w1 ( b5. ; 1st char:
jl (x2 ; if w1 >= top addr then return(finished)
zl w0 x1 ; w0:= word(w1) shift (-12)
ls w0 -4 ; _ shift (-4);
jl w2 x2+2 ; return;
rl w0 x1 ; 2nd char:
ls w0 4 ; w0:= word(w1) shift 4
hl w0 0 ; _ shift (-12)
la. w0 b10. ; _ and 255;
jl w2 x2+2 ; return;
rl w0 x1 ; 3rd char:
la. w0 b10. ; w0:= word(w1) and 255;
al w1 x1+2 ; w1:= w1 + 2;
jl. c3.-2 ; return;
; write char
; w0: char ?
; w1: word addr word addr
; w2: ? unchanged
; w3: link link
jl w3 x3+2 ;
c4: hs w0 0 ; w0:=
es w0 0 ; _ w0 shift 12
ls w0 4 ; _ shift 4;
rs w0 x1 ; word(w1):= w0;
jl w3 x3+2 ; return;
hs w0 0 ; w0:=
es w0 0 ; _ w0 shift 12
ls w0 -4 ; _ shift (-4)
lo w0 x1 ; _ or word(w1);
rs w0 x1 ; word(w1):= w0;
jl w3 x3+2 ; return;
lo w0 x1 ; w0:= w0 or word(w1);
rs w0 x1 ; word(w1):= w0;
al w1 x1+2 ; w1:= w1 + 2;
se. w1 b19. ; if w1 < top of buffer
jl. c4.-2 ; then return;
ds. w3 d3. ; save read and write pointers;
al. w3 b3. ;
jd 1<11+8 ; reserve proc(output)
se w0 0 ; if not ok
jl. a3. ; then error;
a1: al. w1 b1. ; send again:
jd 1<11+16 ; send message
al. w1 b2. ;
jd 1<11+18 ; wait answer
se w0 1 ; if not normal answer
jl. a3. ; then error;
rl w0 x1+2 ;
se w0 512 ; if not one segment transferred
jl. a2. ; then examine further;
rl. w1 b1.+6 ;
al w1 x1+1 ; increase segment count;
rs. w1 b1.+6 ;
jd 1<11+10 ; release process;
al. w1 b17. ; w1:= first of buffer;
dl. w3 d3. ; load read and write pointers;
jl. c4.-2 ; return;
a2: rl w0 x1 ; examine:
sn w0 0 ; if no status
jl. a1. ; then try again;
so. w0 ( b11. ; if not end of file
jl. a3. ; then error;
am. ( b4. ;
al w1 h54 ;
jd 1<11+42 ; look up entry;
al w0 10 ; increase segment count;
wa w0 x1 ;
rs w0 x1 ;
jd 1<11+44 ; change entry;
se w0 6 ; if claims exceeded
jl. a5. ; then begin
dl w0 x1 4 ; move discname;
ds. w0 d5. ;
dl w0 x1 8 ;
ds. w0 d7. ;
al. w1 d4. ;
al. w2 d6. ;
am. ( b4. ;
jl w3 h35 ; parent message;
al. w3 b3. ;
am. ( b4. ;
al w1 h54 ;
jd 1<11+44 ; try once more
a5: sn w0 0 ; end;
jl. a1. ; if ok then send again;
a3: jl. w1 a4. ; error:
44<12+0<5+0 ; print-message to parent
<:trouble: :> ;
a4: al w2 x3 ;
am. ( b4. ;
jl w3 h35 ;
al w3 x2 ;
al. w1 b17. ;
rs. w1 b6. ;
jl. ( d3. ; return(failure)
d4: 44<12+3<5+1 ; extend bs message
<:bs :> ;
0 ;
d5: 0 ;
d6: 0 ;
d7: 0 ;
10 ;
0 ;
e. ;
b. a10, d10 ;
w.
d0: <: Output copied to <0>:>
d1: <:...<10><10><0>:>
c5=-b0.+2 ; end program: (modified h7)
rx. w1 b12.-2 ; save name
rx. w2 b12. ; and end_action;
ds w2 x3-2 ; reestablish fp h7:;
al w2 0 ;
rs. w2 b13. ;
jl w3 x3 h33-h7-4-4 ; outend(nl);
a0: rl. w2 b13. ; while -,block_proc
se w2 0 ; called do
jl. a1. ;
jl w3 x1 h26-h21 ; outchar(out,0);
jl. a0. ;
a1: jl. w3 c6. ; fill segment;
rl. w2 b4. ;
al. w0 d0. ; write message
jl w3 x2 h31-2 ;
al. w0 b3. ;
jl w3 x2 h31 ;
al. w0 d1. ;
jl w3 x2 h31 ;
dl. w2 b12. ; load name
am. ( b4. ; and end_action;
jl h7 ; goto h7 proper;
e. ;
b20=-b0. ; half words to move
e4:
i.
e. ;
; copyout procedure
g0: 2 ; segmenter
0, r.4 ; disc
1<23+e2-e0 ; entry
1<18 ; procedure copyout
0 ;
4<12+e1-e0 ; type, start of ext. list
1<12+0 ; segments, owns
; oo program
g1: 1<23+4 ; bs
0, r.4 ; disc
s2 ; time
0 ;
0 ;
2<12+e3-e0 ; type, entry
e4-e0 ; length
d.
p. <:insertproc:> ;
d./c4=/, r/c5=//, l1,
d./c6=/, r/b0=//, l1,
d./b2=/, r/b3=//, l1,
d./b11=/, r/b12=//, l1,
d./b19=/, r/b20=//, l1,
s, f
begin
integer c5, b0, b3, b12, b20;
zone z(128, 1, stderror);
read( in, c5, b0, b3, b12, b20 );
open( z, 4, <:copyproc:>, 0 );
write( z, <<d>, <:; include-fil til slang programmer som vil benytte oo
b. a10
w.
m.copyproc
ds. w1 a0.
ds. w3 a1.
jd 1<11+5
rl w1 x1 22
al w2 x1 h21
ac w0 h53+1
wa w0 x1 h20+h0
ws w0 x1 h9
se w0 :>, b20, <:
jl. a7.
al w1 2
wa w1 x2 h9-h21
al w3 x1 :>, b3 - b0, <:
rl. w0 a2.
sn w0 (x2 h7-h21
jl. a7.
jd 1<11+52
jd 1<11+30
sn w0 0
jl. a6.
al w1 x2
al w2 x3
al. w0 a4.
jl w3 x1 h31-h21
al w0 x2
jl w3 x1 h31-h21
al. w0 a5.
jl w3 x1 h31-h21
al w2 1
jl x1 h7-h21
0
a0: 0
0
a1: 0
a2: am. ( h9-h7
a3: jl w3 :>, c5, <:
a4: <60>:***<60>0>:<62>
a5: <60>:=oo inaccessible<60>10><60>0>:<62>
a6: al w0 1<1
lo w0 x2 h2
ds w1 x2 h2+2
dl. w1 a3.
rx w0 x2 h7-h21
rx w1 x2 h7-h21+2
ds w1 x3 :>, b12 - b3, <:
a7: dl. w3 a1.
dl. w1 a0.
e.
t.
u.:>, "nl", 1, "em", 1 );
close( z, true )
end
▶EOF◀