|
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: 23040 (0x5a00)
Types: TextFile
Names: »conout«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »conout«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »conout«
b4. ; goto time
;ks-1201
; date
; w0 - year
; w1 - month
; w2 - day
ds. w3 b5.+6 ;
rl w1 0 ;
jl. w2 b10. ; pack into chars
rl. w3 b0.+2 ;
rs w0 x3 ; alfa(1) := year
rl. w1 b5.+6 ;
jl. w2 b10. ;
rs w0 x3+2 ; alfa(2) := month
rl. w1 b5.+4 ;
jl. w2 b10. ;
rs w0 x3+4 ; alfa(3) := day
jl. b6. ; return
; time
; a9 - hour
; a9-2 - minute
b4: rl. w1 a9. ;
jl. w2 b10. ;
rl. w3 b0.+2 ;
rs w0 x3 ; alfa(1) := hour
rl. w1 a9.-2 ;
jl. w2 b10. ;
rs w0 x3+2 ; alfa(2) := minute
rs w1 x3+4 ; alfa(3) := <: :>
b6: rs w1 x3+6 ; alfa(4) := <: :>
jl. d11. ; return
; pack an integer to a string
; w1 - number to split into characters
; w2 - return
b10: al w0 0 ;
wd. w1 b1. ;
ls w1 16 ; first digit < 16
ls w0 8 ; +second digit < 8
lo w0 2 ;
wa. w0 b2. ; +space
rl. w1 b3. ;
jl x2 ;
e.
e.
\f
; segment 4
;slang subroutines: arctan, arg, cos, sin, monitor
;by ns adapted from nsa
; changed 78 03 30 by bbj to fit pascal
0, r.(:2050-k:)>1
b. b12,c27,d14,g6,w.
jl. d1. ; entry arctan
jl. d2. ; entry arg
jl. d3. ; entry cos
jl. d4. ; entry sin
0 ; saved w2
d0: 0 ; save return adress
w.
; working locations
0
g0: 0 ; double cell
0
g1: 0 ; double cell
0
g2: 0 ; double cell
g3: 0
g4: 0
g5: 0
g6: 0
; floating point constants
h. 0 , 0
c0: 0 ,-2048 ; 0
1024 , 0
c1: 0 , 1 ; 1
-2048 , 0
c2: 0 , 0 ;-1
1024 , 0
c3: 0 , 2 ; 2
8.3110 , 8.3755
c4: 8.2421 , 0 ; pi/4
8.3110 , 8.3755
c5: 8.2421 , 1 ; pi/2
8.3110 , 8.3755
c6: 8.2421 , 2 ; pi
8.3110 , 8.3755
c7: 8.2421 , 3 ; pi*2
8.3240 , 8.4746
c8: 8.3177 ,-1 ; sqrt2 - 1
; constants for arctan
w. c20=c1 ; d0
h. 8.4005 , 8.1433
c21: 8.5135 ,-6 ; d1
8.2063 , 8.3675
c22: 8.1510 , 2 ; d2
8.3173 , 8.7332
c23: 8.5776 , 1 ; d3
8.5521 , 8.2144
c24: 8.6150 , 0 ; e1
8.4513 , 8.6070
c25: 8.1005 ,-1 ; e2
; constants for sin
8.4317 , 8.1351
c26: 8.3444 ,-18 ; a5
8.2500 , 8.1775
8.7702 ,-12 ; a4
8.5464 , 8.5673
8.3771 ,-7 ; a3
8.2431 , 8.5357
8.7411 ,-3 ; a2
8.5325 , 8.0414
8.3304 , 0 ; a1
8.3110 , 8.3755
8.2420 , 1 ; a0
\f
w.
; real procedure arctan(u)
d1: ds.w3 d0. ; store return address (entry from complex)
al w2 d10
hs.w2 d7.
d5: ds.w1 g0.
sh w0 -1 ; absu := abs(u)
jl. b0.
dl.w3 c4.
jl. b1.
b0: dl.w1 c0. ; phi := if u >= 0 then pi/4
ds w1 6 ; else -pi/4
fs.w1 g0.
fs.w3 c4.
b1: ds.w1 g1.
fs.w1 c8.
sl w0 0 ; if absu < sqrt2-1 then
jl. b2. ; begin
dl.w1 g0. ; t := u; phi := 0
dl.w3 c0. ; end
jl. b4. ;
b2: fs.w1 c3. ; else
sl w0 0 ; if absu < sqrt2 + 1 then
jl. b3. ; begin
dl.w1 g1.
fs.w1 c2.
ds.w1 g2.
dl.w1 g1.
fa.w1 c2.
fd.w1 g2. ; t := (absu - 1)/(absu + 1)
rx.w3 g0.-2
sh w3 -1 ; if u <= 0 then
fm.w1 c2. ; t := -t
rx.w3 g0.-2 ; end
jl. b4. ; else
b3: dl.w1 c2. ; begin
fd.w1 g0. ; t := -1/u
al w3 x3+1 ; phi := 2*phi
b4: ds.w3 g1. ; end;
ds.w1 g0. ; comment (g0) := t , (g1) := phi
bl w3 3 ; if exponent(t) <= -18 then
sh w3 -18 ; arc := t
jl. b5. ; else
fm w1 2 ; begin
ds.w1 g2. ; t2 := t**2
fa.w1 c23.
dl.w3 c25.
fd w3 2
fa.w3 g2.
fa.w3 c22.
dl.w1 c24.
fd w1 6
fa.w1 c21.
fm.w1 g2.
fa.w1 c20.
fm.w1 g0. ; arc := t*(d0+t2*(d1+e1/(d2+t2+e2/(t2+d3))))
; end
b5: fa.w1 g1. ; arctan := phi + arc
d7 = b5+3
d9: jl. 0 ; if called from arg then return to arg
; end arctan
\f
d2: ds.w3 d0. ; return address; comment entry from complex
m.***** 'arg' can't be called like this...
dl w3 x2
ds.w3 g4. ; commment (g4) := x
ds.w1 g6. ; comment (g6) := y
bl w1 3
bs w1 7 ; n := exponent(y) - exponent(x)
sh w1 36 ; if n > 36 then
jl. b7. ; b6:
b6: dl.w1 c5. ; begin
rl.w2 g5. ; arg := pi/2
sh w2 -1 ; if y < 0
fm.w1 c2. ; then arg := -pi/2
jl. d11. ; end
d10=k-2-d9 ; else
b7: sl w1 -2047 ; if n < -2047 then
jl. b9. ; b8: begin
b8: dl.w1 c0. ; arg := 0
rl.w2 g3.
sh w2 -1 ; if x < 0
dl.w1 c6. ; then arg := sign(y)*pi
jl. b6.+2 ; end
b9: dl.w1 g6. ; else
; begin
sn w0 0 ; if y = 0
jl. b8. ; then goto b8
sn w2 0 ; if x = 0
jl. b6. ; then goto b6
fd w1 6
al w2 d8
hs.w2 d7.
jl. d5. ; arg := phi := arctan(y/x)
d6: rl.w2 g3.
d8 = d6-d9
sl w2 0 ; if x < 0
jl. d11.
rl.w2 g5. ;
sh w2 -1 ; if y < 0
fs.w1 c6. ;
sl w2 0 ;
fa.w1 c6. ; arg := phi + sign(y)*pi
jl. d11. ; end arg
\f
; real procedure cos(u)
d3: ds.w3 d0. ; store return address ( entry from complex )
dl.w3 c5.
fs w3 2
dl w1 6 ; u := pi/2 - u
jl. b10. ; cos := sin(u)
; real procedure sin(u)
d4: ds.w3 d0. ; store return address ( entry from complex )
b10: bl w3 3
sh w3 -18 ; if exponent(u) <= 18 then
jl. d11. ; sin := u
fd.w1 c5. ; else
bl w2 3 ; if exponent(u/pi/2) > 35 then
sh w2 35 ; sin := 0
jl. b11.
dl.w1 c0. ; else
jl. d11. ; begin
b11: sh w2 22 ; z := u/pi/2
jl. b12. ; if exponent(z) > 22 then
rs w0 6 ; begin
as w3 x2-43
ci w3 20 ; z1 := entier(z*2**(-20))*2**20
fs w1 6 ; z := z - z1
; end
b12: rs w0 6
bl w2 3
as w3 x2-23
al w3 x3+1
as w3 -1
rs.w3 g5. ; n := (entier(z)+1)2
ci w3 1
fs w1 6 ; x := z-float(2*n)
rl.w2 g5.
sz w2 1 ; if n is odd
fm.w1 c2. ; then x := -x
ds.w1 g2.
fm w1 2 ; x2 := x*x
ds.w1 g4. ; p := x2
fm.w1 c26. ; p := p*a5
fa.w1 c26.+4 ; p := p + a4
fm.w1 g4. ; p := p * x2
fa.w1 c26.+8 ; p := p + a3
fm.w1 g4. ; p := p * x2
fa.w1 c26.+12 ; p := p + a2
fm.w1 g4. ; p := p * x2
fa.w1 c26.+16 ; p := p + a1
fm.w1 g4. ; p := p * x2
fa.w1 c26.+20 ; p := p + a0
fm.w1 g2. ; sin := x*p
jl. d11. ; end sin
d11: dl. w3 d0. ;
rl w2 x2+8 ;
jl x3+2 ; return
0,r.(:2562-k:)>1
e.
\f
; segment 5-6
; file handling procedures
; call parameters :
; w0 - see each procedure
; w1 - add of zone descriptor + -h0 (+36)
; w2 - abs add of proc table entry
; w3 - return - 2
;
; the stack picture looks like (if not input or output) :
; name of file (8 halfwords)
; zone descriptor (h5 halfwords)
; share - (h6 - )
; data buffer (512 - )
; file buffer (if binary file)
;
; the following free parameters in a zone descriptor
; are used by the pascal i/o system :
;
; z+h2+6 (halfword) : zone state (almost as in algol)
; (see definition of s-names)
; z+h2+7 (halfword) : file type
; 0 = binary
; 1 = text
; 2 = iso
; z+h3+6 (word) : (not used, but could be used for recsize)
; z+h4+0 (halfword) : eof
; 0 = false
; 1 = true
; z+h4+1 (halfword) : eoln
; 0 = false
; 1 = true
; z+h4+2 (word) : length of binary file (irrell if text file)
; read: remaining halfwords
; write: number of halfwords written
; z+h4+4 (word) : file buffer
; binary file: address of filebuf
; text file : next character
;
; the following field is used in the share descriptor:
;
; first share+(14:20) : file name
;
; the organization of the code :
;
; init and select
; file initialization (i1) 4<12 + 0
; reset (i2) 4<12 + 2
; rewrite (i3) 4<12 + 4
; close (i4) 4<12 + 6
; remove (i5) 4<12 + 8
; replace (i9) 4<12 + 10
; monitor (i10) 4<12 + 12
; error return
;
; b-variables are global variables for all procedures
; c-variables are error returns
;
\f
b. b20, c10, i10 w.
jl. i0. ;+0
jl. i0. ;+2
jl. i0. ;+4
jl. i0. ;+6
jl. i0. ;+8
jl. i0. ;+10
jl. i0. ;+12
b0: 0 ; saved w0: (sometimes addr of name)
b1: 0 ; saved w1: zone address
b2: 0 ; saved w2: proc table entry
b3: 0 ; saved w3: (increased) return
b4: 0 ; first of process
b5: 0, r.10 ; tail for lookup entry
i0: ; common entry:
al w3 x3+2 ; (increase entry);
ds. w1 b1. ;
ds. w3 b3. ; save (registers);
bl w2 x3-1 ; w2 := rel entry;
am (66) ;
rl w3 +22 ; w3 := first of process;
rs. w3 b4. ; save (first of process);
bl w0 x1+h2+6 ; w0 := zone state;
; w0 = zone state
; w1 = zone
; w2 = rel entry
; w3 = first of process
jl. x2+2 ; switch to:
jl. i1. ; file init
jl. i2. ; reset
jl. i3. ; rewrite
jl. i4. ; close
jl. i5. ; remove
jl. i9. ; replace
jl. i10. ; monitor
\f
; file initialization
; this procedure has two parameters in the original call :
; +0 4<12 + 0
; +2 text (1) / binary (0) / iso (2)
;
; the procedure initializes a zone and share descriptor :
; base buffer area
; set share to base buffer area + 1
; last add of buffer
; used share
; first share
; last share
; give up mask
; give up action
;
; also the private variables are set:
; zone state
; file type
; eof
; length of binary file
; file buffer
; file name
;
; if zone is 'current in' or 'current out' then the zone
; is stacked prior to initializing private variables
;
; call parameters :
; w0 - add of external file name
; w1 - zone add
;
b. a10 w.
i1: ; file init:
se w1 x3+h20 ; if zone = current input then
jl. a1. ;
jl w3 x3+h29-4 ; stack current input
jl. a5. ; else
a1: ;
se w1 x3+h21 ; if zone = current output then
jl. a2. ; begin
al w2 x3+h55+30 ; chain := std chain for output;
jl w3 x3+h29 ; stack zone;
jl. a5. ; end
a2: ; else
m.*** 'fileinit': midlertidigt ingen test af zonestate
c.-1
se w0 s4 ; if zonestate <> after decl then
jl. c6. ; error(illegal zone state);
z.
; the following initialization ougth to be done in a separate call
al w2 x1+h0+h5 ; w2 := address of share 0 := first free after zone;
al w3 x2+h6-1 ; w3 := base buffer := last of share descr;
al w0 x3+512 ; w0 := last of buffer; (* bufsize = 512 *)
ds w0 x1+h0+2 ;
ba. w0 1 ; first of file buffer :=
rs w0 x1+h4+4 ; top of buffer;
al w3 x3+1 ; first shared (share 0) :=
rs w3 x2+2 ; first of buffer;
rs w2 x1+h0+4 ; used share := share;
rs w2 x1+h0+6 ; first share:= share;
rs w2 x1+h0+8 ; last share := share;
al w0 0 ;
rs w0 x2+14 ; filename(0) (in share 0) := 0; <* prepare rewrite *>
rs w0 x1+h2+0 ; giveup mask := 0;
rl. w3 b4. ;
rl w0 x3+h20+h2+2; (use same giveup action as in primary input);
rs w0 x1+h2+2 ; giveup action := pascal runtime system;
rl. w3 b3. ;
bl w0 x3+1 ; filetype := param from call;
hs w0 x1+h2+7 ;
a5: ; common init:
al w0 s8 ; zone state := after open;
hs w0 x1+h2+6 ;
rl. w3 b0. ; w3 := file name param;
rl w2 x1+h0+6 ; w2 := file name addr;
al w2 x2+14 ;
dl w1 x3+2 ; move filename from param
ds w1 x2+2 ; to share 0 (* for later use by 'reset' etc *)
dl w1 x3+6 ;
ds w1 x2+6 ;
jl. w3 i8. ; replace trailing spaces by nulls;
rl. w3 b3. ;
al w3 x3+2 ; increase (return); i.e. skip filename param;
rs. w3 b3. ;
jl. i7. ; return;
e.
\f
; reset
; the procedure has the following function :
; terminate transfers
; if file does not exist then error
; connect input
; copy file length to zone description
b. a10 w.
i2: ; reset:
sn w0 s4 ; if zone state = after decl then
jl. c6. ; error (illegal zone state);
jl. w3 i6. ; terminate transfer;
rl w3 x1+h0+6 ; w3 := file name addr;
al w3 x3+14 ;
al. w1 b5. ;
jd 1<11+42; lookup entry;
se w0 0 ; if not ok then
jl. c2. ; error (file does not exist);
al w2 x3 ;
rl. w1 b1. ; w1 := zone;
am. (b4.) ;
jl w3 +h27 ; connect input (zone, filename);
se w0 0 ; if not ok then
jl. c5. ; error (file not connected);
rs w0 x1+h4+0+1 ; eof := eoln := false;
rl. w0 b5.+18 ; zone.filelength :=
rs w0 x1+h4+2 ; tail.length; <* irrell for text files *>
bl w0 x1+h2+7 ; zonestate :=
sn w0 0 ; if filetype = binary then
am s5-s1 ; after read binary
al w0 s1 ; else
hs w0 x1+h2+6 ; after read char;
m.*** 'reset': midlertidig opdigtet 'newline'
c.+1
al w2 10 ;
sn w0 s1 ; if read char then
rs w2 x1+h4+4 ; filebuf := newline;
al w2 1 ;
sn w0 s1 ; if readchar then
hs w2 x1+h4+1 ; eoln := true;
z.
jl. i7. ; return;
e.
\f
; rewrite
; the function of the procedure :
; terminate transfer
; connect output
; reset filelength
b. a10 w.
i3: ; rewrite:
; notice: the check on zonestate is not needed, because the
; filename is initialized to zero by 'file init'
sn w0 s4 ; if zonestate = after decl then
jl. c6. ; error (illegal zonestate);
jl. w3 i6. ; terminate transfer;
rl w2 x1+h0+6 ; w2 := filename addr;
al w2 x2+14 ;
al w0 1<1+1 ; w0 := 1 slice, pref. on disc;
am. (b4.) ;
jl w3 +h28 ; connect output (zone, filename, w0);
se w0 0 ; if not ok then
jl. c5. ; error (file cannot be connected);
; notice: fp will initialize filename, if it was empty
m.***** rewrite: ad hoc metode: nulstil segm count
rs w0 x1+h1+16 ; segment count := 0;
rs w0 x1+h4+2 ; filelength := 0;
rl w2 x1+h0+6 ; w2 := file name addr;
al w2 x2+14 ;
se w0 (x2+0) ; if filename was empty then
jl. a1. ; begin
dl w0 x1+h1+4 ;
ds w0 x2+2 ; move zonename to filename;
dl w0 x1+h1+8 ;
ds w0 x2+6 ;
a1: ; end;
al w2 1 ; eof := true;
hs w2 x1+h4+0 ;
bl w0 x1+h2+7 ; zonestate :=
sn w0 0 ; if filetype = binary then
am s6-s3 ; after write binary
al w0 s3 ; else
hs w0 x1+h2+6 ; after write char;
jl. i7. ; return;
e.
\f
; close
; the function of the procedure:
; if file not used then the procedure is blind
; terminate transfers
; if 'current in' and not 'i-bit' then unstack
; if 'current out' then unstack
b. a10 w.
i4: ; close:
sn w0 s4 ; if zonestate = after decl then
jl. i7. ; return;
jl. w3 i6. ; terminate transfer;
al w0 s4 ; zonestate :=
hs w0 x1+h2+6 ; after decl;
rl. w3 b4. ; w3 := first of process;
se w1 x3+h20 ; if zone = 'current in' then
jl. a1. ; begin
rl w0 x1+h2+0 ; if 'i-bit' not set in giveup mask then
so w0 2.1 ;
jl w3 x3+h30-4 ; unstack current input;
jl. i7. ; end
a1: ; else
al w2 x3+h55+30 ;
sn w1 x3+h21 ; if zone = 'current out' then
jl w3 x3+h30 ; unstack (current output chain);
jl. i7. ; return;
e.
; remove entry
; the procedure cancels files
; no matter the result of the remove it is assumed to be ok. (30/11/78)
;
b. w.
i5: ; remove:
rl w3 x1+h0+6 ; w3 := file name addr;
al w3 x3+14 ;
jd 1<11+48 ; remove entry
;ks-820
; sn w0 0 ; if entry removed then
jl. i7. ; return
; jl. c4. ; else error(entry not removed)
e.
\f
; terminate (help procedure)
; the procedure has the following function :
; if after write char then closeup text
; if after write binary then outblock, in case of data in share
; if after read or write then terminate zone
; if output to bs area then
; begin
; set shortclock in catalog entry
; cut area to used size
; set filelength in tail, in case of binary file
; end
;
; call: w1 = zone
; w3 = return
; exit: w1 = zone, other regs undef
b. a10, f10 w.
f0: 0 ; saved return
i6: ; terminate transfer:
rs. w3 f0. ; save (return);
bl w0 x1+h2+6 ; w0 := zone.state;
rl. w2 b4. ; w2 := first of process;
se w0 s3 ; if zonestate = after write char then
jl. a1. ; begin
jl w3 x2+h95 ; close up text (zone);
rl. w2 b4. ; w2 := first of process;
jl. a5. ; goto terminate;
a1: ; end;
se w0 s6 ; if zonestate = after write binary then
jl. a2. ; begin
rl w0 x1+h3+0 ; w0 := record base;
rl w3 x1+h0+4 ; w3 := used share;
sl w0 (x3+2) ; if recbase >= first shared(used share) then
jl w3 x2+h23 ; outblock;
jl. a5. ; goto terminate;
a2: ; end;
se w0 s1 ; if zonestate = after read char or
sn w0 s5 ; zonestate = after read binary then
a5: ; terminate:
jl w3 x2+h79 ; terminate zone (zone);
bl w2 x1+h1+1 ; w2 := kind (zone);
bl w0 x1+h2+6 ; w0 := zonestate;
se w0 s3 ; if (zonestate = after write char or
sn w0 s6 ; zonestate = after write binary)
se w2 4 ; and zonekind = 'bs' then
jl. a10. ; begin
rl w3 x1+h0+6 ; w3 := filename addr;
al w3 x3+14 ;
al. w1 b5. ; w1 := tail addr;
jd 1<11+42; lookup entry (name, tail);
se w0 0 ; if not ok then
jl. c2. ; error (file does not exist);
rl. w0 b5.+0 ; w0 := size.tail;
sh w0 -1 ; if size < 0 then
jl. a9. ; return;
jd 1<11+36; tail.shortclock :=
ld w1 5 ; getclock shift (-19) extract 24;
rs. w0 b5.+10 ;
rl. w1 b1. ; w1 := zone addr;
rl w0 x1+h1+16 ; size.tail := segment count (zone);
rs. w0 b5.+0 ;
bl w0 x1+h2+7 ; if filetype = binary then
rl w2 x1+h4+2 ;
sn w0 0 ;
rs. w2 b5.+18 ; filelength.tail := filelength (zone);
al. w1 b5. ;
jd 1<11+44; change entry (name, tail);
a9: ; end;
; return:
rl. w1 b1. ; w1 := zone;
a10: jl. (f0.) ; return;
e.
\f
; replace of spaces with binary zero in file name
; call: w2 = filename addr
; w3 = return
; exit: all regs undef
b. a10, f10 w.
f0: 0 ; start of filename
f1: 0 ; saved return
i8: ; replaces spaces:
ds. w3 f1. ; save (filename addr, return);
al w2 x2+8 ; wordaddr := top of filename;
a0: ; next word:
al w2 x2-2 ; decrease (wordaddr);
rl w0 x2 ; word := filename (wordaddr);
al w3 0 ; shift := 0;
a1: ; next char:
al w3 x3-8 ; shift := shift - 8;
ld w1 x3 ; w0 := first char(s);
ls w1 -16 ; w1 := char (shift);
se w1 32 ; if char <> space then
jl. (f1.) ; return;
ac w1 x3 ;
ls w0 x1 ; w0 := first char(s) leftjustified;
rs w0 x2 ; filename (wordaddr) := word;
se w3 -24 ; if not all cha