|
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: 13056 (0x3300)
Types: TextFile
Names: »rtgeotx«
└─⟦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⟧
; r_t_geo_tx * page 1 28 09 77, 11.33;
;
; long procedure r_t_geo( R, type_dec );
;
; r_t_geo (return value, long) the value of the variable R converted
; to geotype angle or distance controlled by the type in
; typedec.
; R (call value, real value) the real variable representing
; angle for typedec shift (-6) < 8 and
; distance for typedec shift (-6) >= 8
; typedec ( call value, boolean value ) describing R. The number of decimals
; and the angletype is not used.
; see read_geo_t for futher explanation.
;
; real procedure geo_t_r( G, type_dec );
; geo_t_r (return value, real) The value of the geotype variable G
; converted to real angle in radians or length in meters,
; controlled by the type in typedec.
; G (call value, long value ) the geotype variable representing
; angle for typedec shift (-6) < 8 and
; distance for typedec shift (-6) >= 8.
; typedec (call value, boolean value ) describing G. The number of
; decimals or the angletype are not used.
; se read_geo_t for futher explanation.
;
; real procedure cosh( x );
;
; cosh (return value, real ) = ( exp(x) + 1/exp(x) )/2;
;
; x (call value, real value ) see up.
;
; long procedure arc( DN, DE, s, S2 );
;
; arc (return value, long) the angle in the interval -pi/rg to
; pi/rg counted clockwize from north.
; DN (call value, long value) northing coordinate diff in units
; of '-6 m.
; DE (call value, long value) easting coordinate diff in units
; of '-6 m.
; s (return value, long) the distance in units of '-6 m.
; S2 (return value, real) the square of the distance in units
; of mm**2.
;
;
; =======================================================
;
(
rtgeo = set 1
geotr = set bs rtgeo
cosh = set bs rtgeo
arc = set bs rtgeo
rtgeo = slang entry.no
rtgeo geotr cosh arc )
\f
; r_t_geo_tx * page 2 28 09 77, 11.33;
; slang text
; **********
b. ; outermost block
p.<:fpnames:>
m.girc 4000 rtgeo 01.02.77, 09.00.02
b. g2, e20 ; block with names for tail and insertproc
w.
k=10000 ; load addr
s. g10, j70, f5, a10, b7, c1, d10 ; start of slang segm
h.
g0=3 ; number of extern.
e0:
g1: g2, g3 ; head word
; abs words
g3=k-2-g1
; last of abs words
; points:
g2=k-2-g1
; last of points
; fill with jl -1
w.
jl -1 , r.250-(:4+12*g0:)>1 ; <* g4 = 0 *>
; external list:
w.
e1: g0 ; no. of extern.
g4 ; no. of bytes to initialize
g4=k-e1-4
<:rg:>, 0,0,0 ;
10<18+0, 0 ; own real
<:exp<0>:>, 0,0 ;
4<18+41<12+0, 0 ; real proc, undefined value.
<:arg<0>:>, 0,0 ;
4<18+14<12+14<6+0, 0 ; real proc, real value, real value
g9 ; rel. continuation on next segm
g5:
c.g5-e0-506
m.code too long segm. no.0
z.
c.502-g5+e0
jl -1 , r.252-(:g5-e0:)>1; fill
z.
<:rtgeo<0><0>:>, 0
; finis first segm.
\f
; r_t_geo_tx * page 3 28 09 77, 11.33;
; start second segm.
h.
e2:
g6: g7, g8 ; head word
; abswords:
j3: g0+3 , 0 ; RS entry 3: reserve
j4: g0+ 4, 0 ; do 4: take expression
j6: g0+ 6, 0 ; do 6: stop reg expression
j13: g0+13, 0 ; do 13: last used
j30: g0+30, 0 ; do 30: saved stack ref. saved w3
j43: g0+43, b0 ;
j46: g0+46, b1 ;
j60: 1, 0 ; first of extern. rg
j61: 2, d0 ; second do exp
j62: 3, d3 ; third do arg
g8=k-2-g6 ; fin of abswords
; points:
g7=k-2-g6 ; fin of points
w.
; continuation of extern. list:
w.
g9=k-g6
s3 ; date
s4 ; time
f.
f1: '-6 ; constant used in geo_t_r and r_t_geo
f2: 1.0 ; constant used to calc x ** (-1)
w.
f3: 1 949 686 ; constant (2**(3/2)+1-2*8**(1/4))*2**21
; = 0.929 682 927 462 * 2**21 ;
h.
d2: 4, d1 ; appetite, rel return from exp
d5: 8, d4 ; appetite, rel return from arg
w.
\f
; r_t_geo_tx * page 4 28 09 77, 11.33;
e3:
; entrypoint r_t_geo
; *******
rl. w2 (j13.) ; w2:= last used;
ds. w3 (j30.) ; saved w3;
jl. w3 a2. ; goto take tpd, '-6 or rg
; return from tpd. w0w1 = R;
rl w3 x2+6 ; take first formal R
so w3 1 ; if -, real then
ci w1 0 ; convert to real
fd w1 (x2+12) ; w1:= R/dividend
a0: rl. w3 (j43.) ; load adr of convert real to long
b0=k+1-e2; rel chain ; return point
jl w3 x3+b4 ; goto conv real to long
jl. (j6.) ; goto stop reg expr
e4:
; entrypoint geo_t_r
; *******
rl. w2 (j13.) ; w2:= last used;
ds. w3 (j30.) ; save w3;
jl. w3 a2. ; goto take tpd, '-6 or rg
a1:
; subentry geo_t_r
; *******
; return from tpd. w0w1 = G;
rl. w3 (j46.) ; load addr of convert long to real
b1=k+1-e2; rel chain ; return point
jl w3 x3+b2 ; goto convert long to real
fm w1 (x2+12) ; w1:= G * factor
jl. (j6.) ; goto stop reg expr
a2:
; take tpd decide ( '-6 or rg ) , take ( R or G )
dl w1 x2+12 ; take formals tpd
rs w3 x2+10 ; save return addr
so w0 16 ;
jl. w3 (j4.) ; take expr
ds. w3 (j30.) ; saved w3
bz w1 x1 ; w1:= tpd
sl w1 512 ; if (tpd shift(-6))extract 6 < 8 then
jl. a3. ;
rl. w1 j60. ; w1:= absaddr( rg )
jl. a4. ; else
a3: al. w1 f1. ; w1:= absaddr( '-6 )
a4: rs w1 x2+12 ; save w1 in stack
dl w1 x2+8 ; take formals ( R or G )
so w0 16 ;
jl. w3 (j4.) ; goto take expr
ds. w3 (j30.) ; saved w3
dl w1 x1 ; w1:= R or G
jl (x2+10) ; return
\f
; r_t_geo_tx * page 5 28 09 77, 11.33;
e5:
; entry cos_h
; *****
al w1 -10 ;
jl. w3 (j3.) ; save 10 bytes
al w2 x1+10 ; top of stack
ds. w3 (j30.) ; saved w3
rs w2 x1 ; stack ref of call
rl. w3 g6. ; segm table addr of this segm
rl. w0 d2. ; appetite, rel return
ds w0 x1+4 ; return information
dl w0 x2+8 ; move formals x
ds w0 x1+8 ;
rl. w3 (j61.) ; load second extern. chain
d0=k+1-e2 ; ; chain stops
jl x3+0 ; goto exp(x)
d1=k-e2; ; return form exp
ds. w3 (j30.) ; saved w3
dl w1 x1 ; take exp(x)
ds w1 x2+8 ; saved y = exp(x)
dl. w1 f2. ; w0,w1:= 1.0
fd w1 x2+8 ;
fa w1 x2+8 ; w0,w1:= ( 1/y + y )
bs. w1 1 ; cos_h: = w0w1 / 2;
; <* the exponent part in w0w1 is >=1 *>
jl. (j6.) ; stop reg expr.
\f
; r_t_geo_tx * page 6 28 09 77, 11.33;
e6:
; entry arc
; ***
al w1 -14 ;
jl. w3 (j3.) ; save 14 bytes
al w2 x1+14 ; top of stack
ds. w3 (j30.) ; saved w3
rs w2 x1 ; set stack to arg
rl. w3 g6. ; segm table addr
rl. w0 d5. ; appetite, rel return
ds w0 x1+4 ;
al w3 27 ; kind = real
al w0 x2+8 ; formals n
ds w0 x1+8 ;
al w0 x2+12 ; formals e
ds w0 x1+12 ;
dl w1 x2+16 ; take formals s
so w0 16 ; if expr
jl. w3 (j4.) ; then take this;
ds. w3 (j30.) ;
rs w1 x2+14 ; save addr s
dl w1 x2+20 ; take formals S2
so w0 16 ; if expr then
jl. w3 (j4.) ; take this;
ds. w3 (j30.) ;
rs w1 x2+16 ; save addr S2
dl w1 x2+8 ; take formals N
so w0 16 ; if expr then
jl. w3 (j4.) ; take this
ds. w3 (j30.) ;
dl w1 x1 ; take N
rl. w3 (j46.) ; load addr of conv long to real
b2=k+1-e2; rel chain ; return point
jl w3 x3+b3 ; goto conv long to real
ds w1 x2+8 ; save n
dl w1 x2+12 ; take formals E
so w0 16 ; if expr then
jl. w3 (j4.) ; take this;
ds. w3 (j30.) ;
dl w1 x1 ; take E
rl. w3 (j46.) ; load addr conv long to real
b3=k+1-e2; chain stops ; return point
jl w3 x3 ; goto conv long to real
ds w1 x2+12 ; save e
; arg(n,e);
rl. w3 (j62.) ; load addr arg
d3=k+1-e2; ; return point
jl w3 x3 ; goto arg
d4=k-e2; ; return from arg
ds. w3 (j30.) ;
dl w1 x1 ; w0w1: = arg(n,e);
fd. w1 (j60.) ; w0w1: = w0w1 / rg;
ds w1 x2+20 ; save arc(real type)
\f
; r_t_geo_tx * page 7 28 09 77, 11.33;
dl w1 x2+12 ; n:=
fm w1 x2+12 ; e * e
ds w1 x2+12 ;
dl w1 x2+8 ; +
fm w1 x2+8 ; n * n;
fa w1 x2+12 ;
ds w1 x2+8 ;
fm. w1 f1. ; S2: = n * '-6;
ds w1 (x2+16) ;
dl w0 x2+8 ; load radicand;
se w3 0 ; if zero then
jl. a5. ; beginnnnnnnn
al w0 0 ; load long zero;
al w1 0 ; go to save s;
jl. a6. ; endddddddd;
a5: ; sqrt(radicand) see prog index 75015;
; first appr: a+bx; 2**43<=x<2**45
; for b = 2**(-23) min rel errors for
; a = 0.929 682 927*2**21 = 1 949 686;
; max rel error = 0.036 for x=a/b and x=2**45;
so w0 1 ; if even exponent
am -1 ; then w3:= w3//8
ls w3 -2 ; else w3:= w3//4;
rs w3 x2+10 ; store long radicand;
rl. w1 f3. ; w1:= a;
wa w1 6 ;
wa w1 6 ; w1:= a + radicand * 2**(-24)
; newton integer
wd w0 2 ; w3:= w3//w1;
wa w1 0 ; w1:= w1 + w0;
ls w1 -1 ; w1:= w1//2;
rl w3 x2+10 ; load long radicand;
wd w0 2 ; w3:= w3//w1;
wa w1 0 ; w1:= w1 + w0;
sx 2.010 ; iterand:= if -, oflow then w1
ls w1 -1 ; else w1//2;
rs w1 x2+10 ; save fraction of real iterand;
dl w1 x2+8 ; load real radicand;
bl w3 3 ; extract exponent;
al w3 x3+1 ; w3:= exponent + 1;
as w3 -1 ; w3:= (exponent+1) // 2;
bz w3 7 ; save exponent of real iterand;
rs w3 x2+12 ;
; newton real
fd w1 x2+12 ; radicand / iterand;
fa w1 x2+12 ; + iterand;
bl w3 3 ; take expo;
al w3 x3-1 ; w3:= expo - 2;
hl w1 7 ; iter:= iter / 2;
; conv real sqrt to long sqrt;
rl. w3 (j43.) ; addr conv real to long;
b4=k+1-e2; chain stops;
jl w3 x3 ; conv real to long;
a6: ds w1 (x2+14) ; save s;
dl w1 x2+20 ; load arc(real value)
jl. a0. ; goto subentry in r_t_geo;
; return from there;
\f
; r_t_geo_tx * page 8 28 09 77, 11.33;
g10:
c.g10-e2-506
m. code rtgeo too long
z.
c.502-g10+e2
jl -1 , r.252-(:g10-e2:)>1; fill with -1
z.
<:rtgeo<0><0>:>, 0
i.
e.
e10=1<23 + 4 ; mode_kind = backing storage
e11=4<12 + e1 - e0 ; code proc start of ext. list
e12=1<12 + 0 ; 1 code segm, 0 bytes in own core.
; entry tail:
; r_t_geo
g0: (:g0 / 512 :) ;
0, 0, 0, 0 ; fill
1<23 + e3-e2 ; etrypoint
5<18+12<12+14<6+0, 0 ; long proc, tpd(boolean), R(real)
e11 ;
e12 ;
; geo_t_r
e10 ;
0, 0, 0, 0 ; fill
1<23 + e4-e2 ; entrypoint
4<18+12<12+15<6+0, 0 ; real proc, tpd(boolean), G(long)
e11 ;
e12 ;
; cos_h
e10 ;
0, 0, 0, 0 ; fill
1<23 + e5-e2 ; entrypoint
4<18+14<12+0, 0 ; real proc, real value
e11 ;
e12 ;
; arc
g1: e10 ;
0, 0, 0, 0 ; fill
1<23 + e6-e2 ; entrypoint
5<18+4<12+5<6+15 ; long proc, real, long, long value
15<18+0 ; long value
e11 ;
e12 ;
p.<:insertproc:>
e. ; stop outermost block
\f
; r_t_geo_tx * page 9 28 09 77, 11.33;
if ok.no
( mode 0.yes
message rtgeo not ok
lookup rtgeo )
lookup,
rtgeo geotr,
cosh arc
end
finis
▶EOF◀