|
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: 18432 (0x4800)
Types: TextFile
Names: »fpproc3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »fpproc3tx «
\f
;rc 1984.03.29 fpproc page 1
b. ; block for fpnames
d.
p. <:fpnames:>
l.
b. g1, e5 ; block for insertproc
w.
; procedure fpproc(action, w0, w1, w2);
; integer address action;
; undefined w0, w1, w2;
; comment
; the procedure calls the fp-procedure
; determined by the h-name with the number
; action.
; the main idea is to execute
; jl w3 fpbase+hname(action)
; in a sensible way from within an
; algol program. the allowed actions
; are listed below with the meaning
; of the w-parameters.
; action w0 w1 w2
; 7 (end prog) irr irr integer
; 7 (end prog irr zone**) integer
; 14 (finis mess) irr irr irr
; 22 (inblock)*) irr zone irr
; 23 (outblock)*) irr zone irr
; 24 (wait ready)*) irr zone integer
; 25 (inchar)*) irr zone integer+)
; 26 (outchar)*) irr zone integer
; 27 (connect in) integer+) zone array
; 27 (connect in) integer+) 0 array
; 28 (connect out) integer+) zone array
; 28 (connect out) integer+) 0 array
; 29 (stack zone)*) irr zone array
; 29 (stack current in)*) irr in 0
; 30 (unstack zone)*) irr zone array
; 30 (unstac current in)*)irr in 0
; 31 (outtext)*) array zone irr
; 32 (outinteger)*) integer zone integer (layout)
; 33 (outend)*) irr zone integer
; 34 (close up)*) irr zone integer
; 35 (parent mess) irr array zone**)
; 48 (wait free)*) irr zone integer
; 67 (break mess) irr irr irr
; 79 (terminate zone)*) irr zone irr
; *) may call the give-up action
; **) a document name is taken from the zone
; +) return parameter All other parameters are
; call parameters.
\f
;rc 1984.03.29 fpproc page 2
; The length of an array is never checked.
; Violation of the above rules will terminate
; the program with a param alarm.
; Certain of the procedures may call the
; give up action of the zone. If this happens,
; the block procedure of the zone will be
; called.
; When the block procedure is called, z and
; s have their conventional meaning. The
; b-parameter however is an address
; pointing at a place where the four working
; registers are saved. The b-parameter may
; be used in a call of system(5) move_core:(b, ia)
; The answer may then be fetched by means of
; a call of system(5)movecore:(ia(1),ia).
; If the block procedure terminates by going
; through its final end, a jump to h36
; is performed.
; Implementation details
; The evaluation of the w parameters uses the
; stack in this way:
; x2+6 : pointer to next param to be evaluated
; x2+8 : value of action
; x2+10:
; .
; . : the w parameters
; .
; x2+20:
; After evaluation, the w-parameters are stored
; according to these rules:
; integer irr array zone
; first word value 0 addr index 1 zone addr
; second word addr(>0) 0 -1 -1
;
; When the entries h22-h26, h29-h34, h48 and
; h79 are called, a call of the user's
; blockprocedure is prepared. The main
; task of this preparation is to save
; the giveup action (z+h2+2) and to
; insert a new give up action. As the
; segment allocation may change during
; the call of the user's blockprocedure,
; the return address points into the stack.
; this enables the code calling the user's
; blpr to update the return point, if the
; segment allocation has changed. It also
; enables the give up action to return to
; h36.
\f
;rc 31.01.73 fpproc page 3
; The stack during execution of the i/o
; procedures has the following layout:
; last used + 0: 6 < 12+23
; - - + 2: z addr
; - - + 4: 26
; - - + 6: status addr = sref-10
; - - + 8: 26
; - - +10: ref to saved reg = srf - 18
; sref -18: addr of saved reg = sref - 16
; - -16: saved w0 ans addr
; - -14: saved w1 z descr
; - -12: saved w2 sh descr
; - -10: saved w3 status
; - - 8: layout during outinteger
; - - 6: jl. (2)
; - - 4: abs return addr
; - - 2: saved giveup action
;
; The give up action reestablishes the cell
; z+h2+2 and stores the contents of
; its registers in sref-16 to sref -10. Then
; the block procedure is called. If it
; returns, z+h2+2 and the abs return address
; is updated (blpr may be called more
; than once), and now a jump to fp base
; h36 is performed.
\f
;rc 1984.03.29 fpproc page 4
k=10000
s. a10, b5, c9, d4, g3, j97
h.
g0=0 ; g0=no. of externals
e5: ; start segment
g1: g3 , g2 ; head word
j13: g0+13 , 0 ; RS entry 13: last used
j30: g0+30 , 0 ; - - 30: savedw2w3
j4: g0+4 , 0 ; - - 4: take expr
j8: g0+8 , 0 ; - - 8: end addr expr
j29: g0+29 , 0 ; - - 29: param alarm
j3: g0+3 , 0 ; - - 3: reserve
j17: g0+17 , 0 ; - - 17: index alarm
j21: g0+21 , 0 ; - - 21: general alarm
j97: g0+97 , 0 ; - - 97: fp absent
j26: g0+26 , 0 ; - - 26: in
g2=k-2-g1 ; end of abswords
g3=k-2-g1 ; end of points
w.
e0: g0 ; external list; no ext
0 ; no. bytes
s3 , s4 ; date and clock
e1: rl. w2 (j13.) ; entry fp proc:
dl w1 x2+8 ; take action;
so w0 16 ; if action is an expr
jl. w3 (j4.) ; then take expression
ds. w3 (j30.) ; save sref;
rl w1 x1 ; convert entry no:
jl. w3 (j97.) ; call fp absent;
so w0 1 ; if fp absent then
jl. a10. ; begin
al. w0 b5. ; general alarm (<:fpproc:>, entry);
jl. w3 (j21.) ; end;
a10: sn w1 79, al w1 20 ; 79 => 20
sn w1 48, al w1 21 ; 48 => 21
sn w1 7, al w1 37 ; 7 => 37
sn w1 14, al w1 38 ; 14 => 38
sn w1 67, al w1 39 ; 67 => 39
sl w1 20 ; if entry no < 20
sl w1 40 ; or entry no >= 40
jl. w3 (j29.) ; then param alarm;
al w3 0 ;
sn w1 31 ; if entry = outtext then
hs. w3 d4. ; upper index limit := 0;
al w0 12 ; next param:= 12
ds w1 x2+8 ; save action, next param;
\f
;rc 1984.03.29 fpproc page 5
c0: am (x2+6) ; repeat
dl w1 x2 ; take param(next param);
so w0 16 ; if param is an expression
jl. w3 (j4.) ; then take expression;
ds. w3 (j30.) ;
am (x2+8) ;
bz. w3 d0. ; w3:= pattern(action no)
am (x2+6) ; shift(next param-20);
ls w3 -20 ;
am (x2+6) ;
rl w0 x2-2 ; w0:= kind(next param)
la. w0 b3. ;
se w0 10 ; if kind = integer proc
sn w0 2 ; or kind = integer expr
al w0 26 ; then kind:= integer;
sz w3 2.1000 ; if zone bit
se w0 23 ; and kind = zone then
jl. a1. ; begin
al w0 x1 ; first:= addr;
al w1 -1 ; second:= -1; goto store;
jl. a4. ; end;
a1: so w3 2.0100 ; if array bit then
jl. a2. ; begin
sl w0 17 ; if kind = array
sl w0 24 ; or kind = zone then
jl. a2. ; begin
am (x2+6) ; w3 := formal1.dope rel +
el w3 x2-2 ; formal2; <*abs addr dope*>
wa w3 2 ;
sn w0 18 ; if kind = integer array then
al w0 1 ; w0 := 1;
se w0 21 ; if kind = long real
sn w0 22 ; or kind = complex then
al w0 3 ; w0 := 3;
sl w0 4 ; if w0 neither 1 nor 3 then
al w0 2 ; w0 := 2;
hs. w0 d3. ; shifts := w0;
rl w1 x3-2 ; w1 := upper index value;
d4 = k + 1 ;
sl w1 8 ; if w1 < 8 then
jl. a9. ; begin
al. w0 b4. ; general alarm (<:length:>, upper index);
jl. w3 (j21.) ; end;
a9: al w1 1 ; index := 1;
d3 = k + 1 ; shifts:
ls w1 0 ; ix := index shift shifts;
sh w1 (x3-2) ; if ix > upper index value.dope
sh w1 (x3 ) ; or ix < lower index value.dope then
jl. w3 (j17.) ; goto index alarm;
al w1 2 ; ix := first word word (index);
am (x2+6) ; w1 := ix +
wa w1 (x2 ) ; abs addr element (0, 0, 0, ...);
al w0 -1 ; w0 := -1;
rx w1 0 ; swop (w0, w1);
; end;
jl. a4. ; end;
a2: sz w3 2.0010 ; if integer bit
se w0 26 ; and kind = integer then
jl. a3. ; begin
rl w0 x1 ; first:= value; second:= addr;
jl. a4. ; goto store;
; end;
a3: so w3 2.0001 ; if not irrelevant bit
jl. w3 (j29.) ; then param alarm;
ld w1 -100 ; first:= second:= 0;
a4: rl w3 x2+6 ; store:
am x2 ; formal(next):=
ds w1 x3 ; first con second;
al w3 x3+4 ; next:= next+4;
rs w3 x2+6 ;
sh w3 20 ; until next > 20;
jl. c0. ;
\f
;rc 31.01.73 fpproc page 6
rl w1 x2+8 ;
sh w1 34 ; if action no <= 34
jl. c1. ; then goto call acts with giveup;
jl. w3 c5. ; compute action addr;
bl. w1 x1+d2. ;
jl. x1+e5. ; goto special action(action);
c1: ; call acts with giveup:
se w1 27 ; if action = connect out
sn w1 28 ; or action = connect in
jl. c4. ; then goto connect;
al w1 -30 ; reserve 30 bytes;
jl. w3 (j3.) ;
jl. w3 c5. ; b0:= act addr.;
rs. w3 b0. ;
rl w3 x2+18 ;
rl. w0 b2. ;
ds w0 x2-6 ; stackref(-8:-6):= layout con jump
rl w1 x2+14 ; w1:= zone
al. w0 c2. ;
rx w0 x1+h2+2 ; swap giveup action
al. w3 c3. ; stackref(-4:-2):=
ds w0 x2-2 ; return addr con giveup;
dl w0 x2+10 ; w0:= w0 param;
sn w3 32 ; if action = outinteger
am -2 ; then w3 = addr of layout
al w3 x2-6 ; else w3:= addr of return;
rl w2 x2+18 ; w2:= w2 param;
jl. (b0.) ; goto fp-action;
c2: ds. w3 b0. ; give up action:
dl. w3 (j30.) ; reestablish sref;
ds w1 x2-14 ;
dl. w0 b0. ; save registers;
ds w0 x2-10 ;
rl w0 x2-2 ; reestablish give up action;
rs w0 x1+h2+2 ;
rl. w1 (j13.) ; w1:= last used;
rl. w3 b1. ;
rl w0 x2+14 ;
ds w0 x1+2 ; stack(0:2):= zone;
al w3 26 ; s
al w0 x2-10 ;
ds w0 x1+6 ; stack(4:6):= status;
al w0 x2-18 ;
ds w0 x1+10 ; stack(8:10):= register addr;
am (x2+14) ;
dl w1 h4+2 ; comment
ls w0 4 ; take users blpr;
jl. w3 (j4.) ;
ds. w3 (j30.) ; return from blpr:
rl w1 x2+14 ; w1:= zone;
al. w0 c2. ;
rx w0 x1+h2+2 ; swap give up action
al. w3 c3. ; stackref(-4:-2):=
ds w0 x2-2 ; return con saved giveup;
al w1 36 ; w1:= saved call action;
rx w1 x2+8 ; call action:= 36;
jl. w3 c5. ; compute action addr;
rs w1 x2+8 ; call action:= saved call action;
jl x3 ; goto h36;
\f
;rc 31.01.73 fpproc page 7
c3: ; return from fp:
al w1 x2 ; w1:= w2;
dl. w3 (j30.) ;
rs. w2 (j13.) ; release reservation;
rl w0 x2+8 ; if action = inchar
sn w0 25 ; then char:= w1;
rs w1 (x2+20) ;
jl. (j8.) ; end address expr;
c4: ; connect inoutput:
rl w1 x2+16 ;
sh w1 0 ; if w1 param = integer then
jl. a5. ; begin if w1 param <> 0 then
se w0 0 ; param alarm;
jl. w3 (j29.) ; end;
a5: jl. w3 c5. ; compute action address
rl w0 x2+10 ; w0:= w0 param;
rl w1 x2+14 ; w1:= w1 param;
rl w2 x2+18 ; w2:= w2 param;
jl w3 x3 ; goto fp action
dl. w3 (j30.) ; restore stackref;
rs w0 (x2+12) ; w0 param:= w0;
jl. (j8.) ; end addr expression;
; procedure compute action address;
; registers: call return
; w0 irrelevant spoiled
; w1 - saved
; w2 stackref stackref
; w3 return action address
; x2+8 must contain the action number
; b0 is used for work.
c5: rs. w3 b0. ; save return
rx w1 x2+8 ; w1:= action no;
rl. w3 j26. ; action address:=
ba. w3 x1+d1. ; address of in + relative;
se w1 29 ; if action = stack
sn w1 30 ; or action = unstack
jl. a7. ; then goto check stackact;
a6: rx w1 x2+8 ; reestablish:
jl. (b0.) ; return;
a7: rl w0 x2+20 ; check stackact;
sh w0 -1 ; if w2 param = array
jl. a6. ; then goto reestablish;
rl w0 x2+14 ;
am (x2+18) ;
sn w1 x1 ; if integer value <> 0
se. w0 (j26.) ; or zone <> in
jl. w3 (j29.) ; then param alarm;
al w3 x3-4 ; action:= stack/unstack current in;
jl. a6. ; goto reestablish;
; end procedure compute action address
\f
;rc 31.01.73 fpproc page 8
; special actions:
c6: rl w1 x2+14 ; parent message:
am (x2+18) ; w1:= addr of first part;
al w2 h1+2 ; w2:= name addr in zone
c7: ; finis message:
c8: jl w3 x3 ; break message:
jl. (j8.) ; end address expression;
c9: am (x2+14) ; end program:
al w1 h1+2 ; w1:= name addr in zone;
rl w2 x2+18 ; w2:= status;
jl x3 ; goto end program;
h. ;
d0=k-20 ; parameter table each parameter is described by the pattern:
; zone<3 + array<2 + integer<1 + irr
; for each action the parameters are packed:
; w0<8 + w1<4 + w2
2.0001<8 + 2.1000<4 + 2.0001 ; h79=20
2.0001<8 + 2.1000<4 + 2.0010 ; h48=21
2.0001<8 + 2.1000<4 + 2.0001 ; h22
2.0001<8 + 2.1000<4 + 2.0001 ; h23
2.0001<8 + 2.1000<4 + 2.0010 ; h24
2.0001<8 + 2.1000<4 + 2.0010 ; h25
2.0001<8 + 2.1000<4 + 2.0010 ; h26
2.0010<8 + 2.1010<4 + 2.0100 ; h27
2.0010<8 + 2.1010<4 + 2.0100 ; h28
2.0001<8 + 2.1000<4 + 2.0110 ; h29
2.0001<8 + 2.1000<4 + 2.0110 ; h30
2.0100<8 + 2.1000<4 + 2.0001 ; h31
2.0010<8 + 2.1000<4 + 2.0010 ; h32
2.0001<8 + 2.1000<4 + 2.0010 ; h33
2.0001<8 + 2.1000<4 + 2.0010 ; h34
;functions not calling a give_up action
2.0001<8 + 2.0100<4 + 2.1000 ; h35
0 ; not allowed ; h36
2.0001<8 + 2.1001<4 + 2.0010 ; h7=37
2.0001<8 + 2.0001<4 + 2.0001 ; h14=38
2.0001<6 + 2.0001<4 + 2.0001 ; h67=39
d1=k-20 ; entry points in fp relative
; to descriptor of in
h79-h20, h48-h20, h22-h20, h23-h20, h24-h20
h25-h20, h26-h20, h27-h20, h28-h20, h29-h20
h30-h20, h31-h20, h32-h20, h33-h20, h34-h20
h35-h20, h36-h20, h7 -h20, h14-h20, h67-h20
d2=k-35 ; entry points to special actions
c6-e5 , 0 , c9-e5 , c7-e5 , c8-e5
; h35 h36 , h7 , h14 , h67
\f
;rc 1984.03.29 fpproc page 9
w. 0 ; constants and variables
b0: 0 ; double cell used for various things
b1: 6<12+23 ; kind of a zone
b2: jl. (2) ; return jump from fp
b3: 2.11111 ; mask for kind
b4: <:<10>length<0>:> ; alarm text
b5: <:<10>fpproc<0>:> ; - -
e4:
c. e4-e5-506
m. code on segment too long
z.
c. 502-e4+e5, ks-1, r. 252-(:e4-e5:)>1 z.
<:fp proc:>, 0 ; alarm text
e. ; end segment
; tails:
g0: g1: ; first and last tail:
1 ; 1 segment
0, 0, 0, 0 ; room for name
1<23 + e1-e5 ; entry point
1<18+41<12+41<6+41 ; no type procedure
3<18 ; (integer, undef, undef, undef)
4<12 + e0-e5 ; code proc, start of ext list
1<12 + 0 ; 1 segment, no bytes
m. fpproc 1984.03.29
d.
p. <:insertproc:>
l.
e.
▶EOF◀