|
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: 11520 (0x2d00)
Types: TextFile
Names: »pumptx«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦80900d603⟧ »giprocfile«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦80900d603⟧ »giprocfile«
└─⟦this⟧
; pump_tx * page 1 4 10 77, 10.02;
(
pump = set 1
movevar = set bs pump
movecase = set bs pump
pump = slang entry.no
pump movevar movecase
)
b. ; outermost block
p.<:fpnames:>
m.girc 4000 pump 07.02.77, 08.21.46
;
;
; procedure movevar( b, a );
; a (return value, undefined simple ).
; The sign-extended or extracted value of b.
; b ( call value, undefined simple ).
;
; procedure movecase( b ) case ( t ) of ( list );
; case t of list (return value, general),
; The sign-extended or extracted value of b.
; ex. of list : boolean1, integer1, boolean2, string;
; t (call value, integer value) pointing the variable in list.
; b ( call value, undefined simple ).
;
;
; real procedure pump( A );
;
; pump (return value, real) the value of the sucessor of the
; last called element of A, at the first call the pos-
; sibly ficticious element A(0) is the last called.
; NB NB NB pump operates on index only, the index is reset to
; zero when the referenced element of A contains a binary
; zero character.
; A (call value, real, long or integer array).
; The array mostly containing a
; text string. If A contains one or more binary zeroes an
; internal own variable in pump will be reset to zero after
; reference to this element, rady for use next time.
; alarm cause : index error.
; ***** For integer array with an odd number of elements the
; index is one too high and the three last characters
; are doubled.
; ***** pump is designed for use in cases where an ordinary
; for-statement is awkward or impossible, e.g. inside a write
; procedure, and very strange effects may occur if the procedure
; is used just for increasing the index.
\f
; pump_tx * page 2 4 10 77, 10.02;
b. g1, e20 ; block with names for tail and insertproc
w.
k=10000 ; load addr
s. g5 , j70, d15, f3, c0, a20 ; start of slang segm
h.
g0=0 ; number of extern.
e0:
g1: g3, g2 ; headword, rel of last point, absword
; abswords:
j4: g0+ 4, 0 ; RS entry 4: take expression
j6: g0+ 6, 0 ; do 6: stop reg expression
j8: g0+ 8, 0 ; do 8: stop by addr expr
j13: g0+13, 0 ; do 13: last used
j17: g0+17, 0 ; do 17: index alarm
j19: g0+19, 0 ; do 19: case alarm
j21: g0+21, 0 ; do 21: general alarm
j29: g0+29, 0 ; do 29: param alarm
j30: g0+30, 0 ; do 30: saved stack ref. saved w3
j0: 0, 1 ; first word in own core
g2=k-2-g1 ; fin of abswords
; points:
g3=k-2-g1 ; fin of points
; ext. list:
w.
e1: g0 ; number of ext
g4 ; number of bytes to initialize
g4 =k-e1-4
s3 ; date
s4 ; time
f3: 7 ; mask
c0: <:<10>few_case:>
\f
; pump_tx * page 3 4 10 77, 10.02;
e5:
; entrypoint move_case
; *********
am 1 ;
e6:
; entrypoint move_var
; ********
al w0 0 ;
rl. w2 (j13.) ; w2:= last used
ds. w3 (j30.) ; saved w3
rl w3 0 ; save entry case
se w0 0 ; if move_case then
jl. a7. ; goto get upper index;
; take addr a:
a1: dl w1 x2+12 ; load formals a ( or t );
hs w3 x2+10 ; save upper index (entry_case)
so w0 16 ; if expr. then
jl. w3 (j4.) ; take this;
ds. w3 (j30.) ;
bl w3 x2+10 ; load upper index ( entry_case)
sl w3 1 ; if move_case then
jl. a11. ; goto take_case_t_of;
a2: rs w1 x2+12 ; save addr( a );
; take value b:
dl w1 x2+8 ; take formals
so w0 16 ; if expressiton then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; saved w3
al w0 7 ; extract 3 bits from
la w0 x2+6 ; first formal
se w0 1 ; if -, boolean then
jl. a3. ; goto test integer
bl w0 x1 ; take boolean extend sign
jl. a4. ; goto extend to long
; test integer:
a3: se w0 2 ; if -, integer then
jl. a5. ; goto take 4-byte
rl w0 x1 ; take integer
a4: ad w1 -24 ; extend to 4-byte
jl. a6. ; gotoreslut
a5: dl w1 x1 ; load 4-byte
; result:
a6: al w3 31 ; extract 5 bits from
la w3 x2+10 ; first formal a
sl w3 8 ; if procedure
sl w3 29 ; then
jl. w3 (j29.) ; goto param alarm
la. w3 f3. ; extract 3
sn w3 1 ; if boolean then
hs w1 (x2+12) ; store boolean value else
sn w3 2 ; if integer then
rs w1 (x2+12) ; store integer value
sl w3 1 ;
sl w3 3 ; else
ds w1 (x2+12) ; store 4-byte value
\f
; pump_tx * page 4 4 10 77, 10.02;
; return by addr expr:
jl. (j8.) ; stop addr expr
; ++ movevar slut ++;
a7:
; take upper index
al w3 x2+10 ; first formal addr+2
al w1 x2+7 ; upper limit:= stackref+7+appetite
ba w1 x2+4 ;
a8: rl w0 x3-2 ; load addr of var or expr
sl w0 x2 ; if w0<x1 or w0>upper limit then
sl w0 x1 ;
jl. a9. ; goto next formals
rl w1 0 ; upper limit:= addr of var or expr
a9: al w3 x3+4 ; w3:= next formals addr
sl w1 x3 ; if past upper limit then
jl. a8. ; goto test next formals
a10: ws w3 4 ; upper index is so that the test can
al w3 x3-14 ; be made by : if t <upper index then ok
as w3 -2 ;
sl w3 1 ; if upper index > 0 then
jl. a1. ; return
rl w1 6 ; else general alarm
al. w0 c0. ;
jl. w3 (j21.) ;
a11:
; take case t of
dl w1 x1 ; evaluate case t of
rl w3 x2+10 ; test real
sz w3 1 ; if real then
cf w1 0 ; convert to integer
bl w3 6 ; load upper index
sl w1 1 ; if t < 1 or
sl w1 x3 ; t> upper index then
jl. w3 (j19.) ; casealarm
ls w1 2 ; 4 * t
am x2 ; addr of formals(t-3)
dl w1 x1+12 ;
rs w0 x2+10 ; save kind of param(t)
so w0 16 ;
jl. w3 (j4.) ; take expr
ds. w3 (j30.) ; saved w3
jl. a2. ; return
; ++ movecase slut ++;
\f
; pump_tx * page 5 4 10 77, 10.02;
e7:
; entry pump
; ****
rl. w2 (j13.) ; w2:= last used
ds. w3 (j30.) ; save w3
rl. w1 (j0.) ; load own integer i
al w1 x1+1 ; i := i + 1;
rs. w1 (j0.) ; save own integer i
bz w0 x2+7 ; load kind of array
sh w0 20 ; check type of array
sh w0 17 ;
jl. a18. ; goto check zone.
rl w3 x2+8 ; load second formal A
ba w3 x2+6 ; w3 := abs addr( dope );
sn w0 18 ; if integer array then
jl. a16. ; goto integer check;
as w1 2
sh w1 (x3-2) ; if i > upper index
sh w1 (x3) ; or i < lower index then
jl. w3 (j17.) ; index alarm
a12: rl w3 0 ; move kind;
wa w1 (x2+8) ; addr( A(i) );
dl w1 x1 ; w1:= A(i);
sn w3 17 ; if kind=short then
rl w0 2 ; move w1;
ds w1 x2+8 ; save in stack;
; test for null character
al w3 6 ; chars to check;
jl. a14. ;
a13: al w3 x3-1 ; chars left to check;
sn w3 0 ; if last_char then
jl. a15. ; goto zero char not found;
ld w1 -8 ; shift to next char;
a14: sz w1 255 ; if char <> 0 then
jl. a13. ; goto check next char;
al w1 0 ; set own integer i
rs. w1 (j0.) ; i := 0;
a15: dl w1 x2+8 ; load four-bytes;
jl. (j6.) ; stop reg expr
; integer check;
a16: ls w1 2 ;
sh w1 (x3-2) ; if i<=index then
jl. a17. ; goto check low;
al w0 17 ; kind := short;
al w1 x1-2 ; 4i:= 4i - 2;
a17: as w1 -1 ; to get integer check;
as w1 1 ;
sh w1 (x3-2) ; if i > upper index
sh w1 (x3) ; or i < lower index then
jl. w3 (j17.) ; goto index alarm;
jl. a12. ; goto move kind;
\f
; pump_tx * page 6 4 10 77, 10.02;
; check zone:
a18: bz w3 x2+6 ; load first byte in formal.1;
sn w3 6 ; if w3 <> 6 or
se w0 23 ; not zone then
jl. w3 (j29.) ; goto param alarm
rl w3 x2+8 ; w3 := addr(base addr)
rl w0 x3+h3+6 ; w0 := zone handled as array zero;
se w0 0 ; if w0 <> 0 then
jl. w3 (j29.) ; goto param alarm;
al w0 19 ; kind := real array;
as w1 2 ; w1 := index * 4;
sh w1 (x3+h3+4) ; if w1 <= record length then
jl. a12. ; goto move kind else
jl. w3 (j17.) ; goto index alarm;
; ++ pump slut ++;
g5:
c.g5-e0-506
m. code pump too long
z.
c.502-g5+e0
jl -1 , r.252-(:g5-e0:)>1; fill with -1
z.
<:pump<0>:>, 0, 0
i.
e.
; entry tail:
e10=1<23 + 4 ; mode_kind = backing storage
e11=4<12 + e1 - e0 ; code proc start of ext. list
e12=1<12 + 2 ; 1 code segm, 2 bytes in own core
; pump
g0: 1 ; first tail: 1 segm
0, 0, 0, 0 ; fill
1<23+0<12+e7-e0 ; entrypoint
4<18+41<12+0, 0 ; real proc, undefined
e11 ; code proc start of extern. list
e12 ;
; move_var
e10 ; modekind
0, 0, 0, 0 ; fill
1<23 + e6-e0 ; entrypoint
1<18+41<12+41<6+0, 0 ; no type proc, undefined, undefined
e11 ;
e12 ;
; move_case
g1: e10 ;
0, 0, 0, 0 ; fill
1<23 + e5-e0 ; entrypoint
1<18+39<12+13<6+41, 0 ; no type, general, integer value, undef
e11 ;
e12 ;
p.<:insertproc:>
e. ; stop outermost block
\f
; pump_tx * page 7 4 10 77, 10.02;
if ok.no
( mode 0.yes
message pump not ok
lookup pump )
look_up,
pump,
movevar,
movecase
end
finis
▶EOF◀