|
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: 13824 (0x3600)
Types: TextFile
Names: »uti29«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦f8e4b63af⟧ »trcfput«
└─⟦this⟧
; fp-utility rubout:
;
; this program rubouts one or more backing-storage-files with a
; specified scope by filling them with a mixture of em-characters
; and nul-characters.
; at start all available core-area (from end of program to top of
; fp command stack) is filled with dummy information. this buffer
; is then copied to the specified areas until they are filled.
; if the parameter clear.yes has been interpreted, the entries to
; the following files are removed from the catalog, otherwise
; they are changed (setting: size=0 and the time for the change).
; at scope own all areas of the specified name are rubout: temp,
; login, user or project.
b. g10 w.
d.
p.<:fpnames:>
l.
k=h55
s. a30, b30, c30, e30, m30, n30, s30, t30 w.
b0: 0 ; stackpointer
b2: 0 ; number of zerosegments
b3: 0 ; number of zerobytes
b4: 0 ; clear.no
c0=k+2, 0, 0 ; old cat base
c1: 0 ; pointer to curr. cat base
c2=k+2, 0, 0 ; std base
c3=k+2, 0, 0 ; user base
c4=k+2, 0, 0 ; max base
n0: 0, r.5 ; name buffer
m0: 5<12, 0, r.3 ; message buffer
t0: 0, r.17 ; entry head and tail - used as answer buffer, too
t1: <:temp:>,0,0
<:login:>,0,0
<:user:>,0,0
<:project:>,0
<:own:>,0,0,0
t2: <:***rubout :>
t3: <: call<10><0>:>
t4: <: illegal scope<10><0>:>
t5: <: unknown<10><0>:>
t6: <: catalog error<10><0>:>
t7: <: entry in use<10><0>:>
t13: <: not bs-area<10><0>:>
t8: <:param :>
t9: <:( <0>:>
<:= <0>:>
<:. <0>:>
t10: <:clear:>,0,0
t11: <:yes:>
t12: <:no:>
t14: 0 ; saved size
s0: 0 ; state of scope all
; 4=entry found
; else entry not found yet
s1: 0 ; scope: 0 = temp
; 1 = login
; 2 = user
; 3 = project
; 4 = own
m1: 7 ; mask
m2: 4<12+10 ; separator shift 12 + length of item
m3: 8<12+10 ; separator shift 12 + length of item
m4: 25<16 + 25<8 + 25 ; three em'characters
g2: rs. w3 b0. ; save commandpointer
dl. w1 h58. ;
ds. w1 c3. ; save user base
rl. w3 h16. ; w2:=process descr. addr.
dl w1 x3+70 ;
ds. w1 c0. ; save old base
dl w1 x3+78 ;
ds. w1 c2. ; save std base
dl w1 x3+74 ;
ds. w1 c4. ; save max base
al. w3 a5. ; w3:=start of zerobytes
rs. w3 m0.+2 ;
ld w1 -100 ; clear w0,w1
rl. w0 m4. ; w0:=em'characters
a0: al w3 x3+4 ; step upwards
ds w1 x3 ; clear double word
sh w3 x2-6 ; if not upper bound then
jl. a0. ; continue
rs. w3 m0.+4 ; last of zerobytes
ws. w3 m0.+2 ;
ls w3 -9 ; w3:=number of zerosegments
rs. w3 b2. ;
ls w3 9 ; w3:=number of zerobytes
rs. w3 b3. ;
rl. w3 b0. ; w3:=commandpointer
se w3 x2 ; if left hand side then
jl. e1. ; error 1
ba w3 x3+1 ;
rl w2 x3 ; w2:=next item in command stack
rs. w3 b0. ; b0:=commandpointer
se. w2 (m2.) ; if item<>space then
jl. e8. ; error 8
al. w1 t1. ; w1:=first of scopes
a6: rl w0 x1 ; w0:=first caracters of scope
sn w0 (x3+2) ; if caracters equal then
jl. a7. ; goto testscope
sl. w1 t2. ; if last of scopes then
jl. e2. ; error 2
al w1 x1+8 ; else
jl. a6. ; continue
a7: rl w0 x1+2 ; testscope:
se w0 (x3+4) ; test caracters
jl. e2. ; error 2
rl w0 x1+4 ;
se w0 (x3+6) ;
jl. e2. ; error 2
rl w0 x1+6 ;
se w0 (x3+8) ;
jl. e2. ; error 2
al. w2 t1. ; compute scope
ws w1 4 ;
ls w1 -3 ;
rs. w1 s1. ; s1:=scope
al w3 x1 ; w3:=scope
dl. w1 c2. ; w01:=standardbase
sn w3 2 ; if scope user then
dl. w1 c3. ; get user base
sn w3 3 ; if scope project then
dl. w1 c4. ; get max base
al. w3 a5. ;
jd 1<11+72; set catalog base
rl. w3 b0. ; w3:=commandpointer
ba w3 x3+1 ;
a1: rs. w3 b0. ;
rl w2 x3 ; w2:=next item of command stack
rs. w3 s0. ; state(own):=no file found yet
se. w2 (m2.) ; if item <> space then
jl. e8. ; error 8
dl w1 x3+4 ; move name
ds. w1 n0.+2 ;
dl w1 x3+8 ;
ds. w1 n0.+6 ;
al. w3 n0. ; w3:=file name
al w2 -2 ; initialize w2
a20: al w2 x2+2 ; step upwards
sl w2 8 ; if last of name then
jl. a21. ; goto analyze clear (yes/no)
rl. w0 x2+n0. ;
sn. w0 (x2+t10.) ; if characters equal then
jl. a20. ; continue
a8: al. w1 t0. ; w1:=start of entry
jd 1<11+76; lookup entry head and tail
se w0 0 ; if entry not looked up then
jl. e3. ; error 3
rl. w0 s1. ; w0:=scope
sl w0 4 ; if scope<>own then
jl. a11. ; begin
rl w3 x1 ; w3:=catalog key
la. w3 m1. ;
sn w0 0 ; if scope=temp and
sl w3 2 ; catalog key=0 or 1
jl. 4 ; then
jl. a11. ; ok else
sn w0 1 ; if scope=login and
se w3 2 ; catalog key=2
jl. 4 ; then
jl. a11. ; ok else
se w3 3 ; if catalog key<>3 then
jl. e3. ; error 3
dl w3 x1+4 ; w23:=catalog base
rl. w1 h16. ; w1:=process description
sn w2 (x1+68) ; if bases do not fit
se w3 (x1+70) ; then
jl. e3. ; error 3
a11: al. w3 n0. ; end
rl. w0 t0.+14 ; w0:=area description
sh w0 -1 ; if not area then
jl. e9. ; error 9
rs. w0 t14. ; saved size
jd 1<11+52; create area process
se w0 0 ; if not created then
jl. e4. ; error 4
jd 1<11+8 ; reserve process
se w0 0 ; if not reserved then
jl. e4. ; error 4
a2: al. w1 m0. ; w1:=first of mess.buf.
rs. w0 m0.+6 ; set first segment
jd 1<11+16; send message
al. w1 t0. ; w1:=first of answer buffer
jd 1<11+18; wait answer
se w0 1 ; if answer not normal then
jl. e4. ; error 4
rl w0 x1+2 ; if all bytes transferred then
se. w0 (b3.) ;
jl. a3. ; goto remove
rl. w0 b2. ; compute new first segment
wa. w0 m0.+6 ;
jl. a2. ; continue
a21: rl. w3 b0. ; w3:=stackpointer
ba w3 x3+1 ; next item
rl w2 x3 ;
se. w2 (m3.) ; if separator,length<>8,10
jl. e8. ; then error 8
rl w0 x3+2 ;
sn. w0 (t11.) ; if yes then
jl. a22. ; set clear.yes
se. w0 (t12.) ; if not no then
jl. e8. ; error 8
am -1 ;
a22: al w0 1 ; set clear
rs. w0 b4. ;
ba w3 x3+1 ; w3:= next item
jl. a1. ; goto next item
a3: rl. w0 b4. ; remove: w0:=clear switch
se w0 0 ; if clear.no then
jl. a24. ;
rl. w1 t14. ;
rs. w1 t0.+14 ; length:=oldsize
rs. w0 t0.+30 ; contry:=0
rs. w0 t0.+32 ; load-length:=0
dl w1 110 ;
ld w1 5 ; w0:=short clock
rs. w0 t0.+24 ; word 6(entry tail):=clock
al. w1 t0.+14 ; w1:=entry tail;
jd 1<11+44; change entry
se w0 0 ; if entry not changed then
jl. e7. ; entry in use
jl. a23. ;
a24: jd 1<11+48; remove entry
se w0 0 ;
jl. e7. ; entry in use
a23: rl. w0 s1. ; if scope <> own
se w0 4 ; then
jl. a9. ; goto new name
rs. w0 s0. ; else state(all):=file found
rl. w1 c1. ;
sl w1 12 ; if scope project then
jl. e3. ; stop
al w1 x1+4 ;
rs. w1 c1. ; act base:=next base
dl. w1 x1+c1. ;
al. w3 a5. ;
jd 1<11+72; set cat base
al. w3 n0. ;
jl. a8. ; try new scope
a9: rl. w3 b0. ; new name: w3:=commandpointer
ba w3 x3+1 ;
bl w2 x3 ; w2:=next item
se w2 2 ; if w2<>new line then
jl. a1. ; continue
a25: al w2 0 ;
a10: dl. w1 c0. ; else
al. w3 a5. ;
jd 1<11+72; restore catalog base
am -2000 ;
jl. h7.+2000; stop.
a12: al. w0 t2. ;
jl. w3 h31.-2 ; write(out,<:***rubout :>)
jl x2 ; return
32<16
a13: rl. w1 s1. ;
ls w1 3 ;
al. w0 x1+t1. ;
jl. w3 h31.-2 ; write(out,<:<scope>:>)
al. w0 a13.-2 ;
jl. w3 h31.-2 ; outchar(out,space)
al. w0 n0. ;
jl. w3 h31.-2 ; write(out,<:<name>:>)
jl x2 ; return
e1: jl. w2 a12. ; -> ***rubout
al. w0 t3. ;
jl. w3 h31.-2 ; -> call
jl. e6. ; stop after error
e2: jl. w2 a12. ; -> ***rubout
rl. w3 b0. ;
al w0 x3+2 ;
jl. w3 h31.-2 ; -> <scope>
al. w0 t4. ;
jl. w3 h31.-2 ; -> scope illegal
jl. e6. ; stop after error
e3: rl. w2 s0. ; if scope=all and
sh w2 4 ; at least one file has been destroyed
jl. a9. ; then goto next name
jl. w2 a12. ; -> ***rubout
jl. w2 a13. ; -> <scope> <s> <name>
al. w0 t5. ;
jl. w3 h31.-2 ; -> unknown
jl. a9. ; goto next name
e4: jl. w2 a12. ; -> ***rubout
jl. w2 a13. ; -> <scope> <s> <name>
al. w0 t6. ;
jl. w3 h31.-2 ; -> impossible
jl. a9. ; goto next name
e7: jl. w2 a12. ; -> ***rubout
jl. w2 a13. ; -> <scope> <s> <name>
al. w0 t7. ;
jl. w3 h31.-2 ; -> entry in use
jl. a9. ; goto next name
0
e8: rs. w2 e8.-2 ; save w2
ls w2 -12 ;
sh w2 4 ; if item>4
sn w2 0 ; or item=0 then
jl. 4 ; fejl(param) else
jl. a25. ; stop.
jl. w2 a12. ; -> ***rubout
al. w0 t8. ;
jl. w3 h31.-2 ; -> param
bl. w2 e8.-2 ;
ls w2 -1 ;
al. w0 x2+t9. ;
jl. w3 h31.-2 ; -> separator
bl. w2 e8.-1 ;
se w2 10 ;
jl. a15. ;
rl. w3 b0. ; w3:=stackpointer
al w0 x3+2 ;
jl. w3 h31.-2 ; -> <text>
al w2 10 ;
jl. w3 h26.-2 ; -> new line
jl. e6. ; goto stop after error
e9: jl. w2 a12. ; -> ***rubout
jl. w2 a13. ; -> <scope> <s> <name>
al. w0 t13. ;
jl. w3 h31.-2 ; -> not bs-area
jl. a9. ; goto new name
a15: se w2 4 ;
jl. e6. ;
rl. w3 b0. ;
rl w0 x3+2 ;
jl. w3 h32.-2 ; -> <integer>
1<23+32<12+2 ; <<-d>
al w2 10 ;
jl. w3 h26.-2 ; -> new line
jl. e6. ; goto stop after error
e6: al w2 1 ; w2:=ok.no
jl. a10. ; goto stop
a5: 0
e.
g6=k-h55 ; length of program
g9=g2-h55 ; entry point
g0:g1: (:g6+511:)>9 ; segments
0, r.4 ; room for doc. name
s2 ; date
0 ; file
0 ; block
2<12+g9 ; entry point
g6 ; load length
m. rc 1976.06.10 rubout
d.
p.<:insertproc:>
e.
▶EOF◀