|
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: 42240 (0xa500)
Types: TextFile
Names: »system3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »system3tx «
; jz.fgs 1986.04.04 algol 8, system(fnc,i,arr or s), page ...1...
; the segments also contain increase, check, blockproc,
; stderror. see page 9
; after evaluation of the three parameters: fnc (integer),
; i (integer) and arr or s (array or string), the contents
; of the formal locations are:
; last used : return information (unchanged)
; + 2 : - - -
; + 4 : - - -
; + 6 : value of fnc
; + 8 : abs address of value of i
; +10 : kind of third parameter (0=string,1=boo,2=int,3=real or long,
; 4=complex or double)
; +12 : abs address of dope (array), or unchanged (string)
; +14 : abs address of first array elem (array), or unchanged (string)
; +16 : abs address of last array elem (array), or unchanged (string)
; b. ; begin block fpnames
; w. ;
b. e7, g1 ; global block for tail parts
w. ; used by insertproc
e6 = 0 ; segments := 0;
s. i6 ;begin 3 segments for system, check, increase,
; blockproc and stderror
\f
; jz.fgs 1987.07.08 algol 8, system(fnc, i, arr or s), page ...2...
b. a21, b6, c30, d1, f1, g5, j104 ; begin segment 1
w. ;
k = 0, g0 = 0 ; no of externals + no of globals = 0
h. ;
d0: g1 , g2 ; rel of last point , rel of last absword
j3: g0+ 3 , 0 ; rs entry 3 : reserve
j4: g0+ 4 , 0 ; rs entry 4 : take expression
j6: g0+ 6 , 0 ; rs entry 6 : end register expression
j13: g0+13 , 0 ; rs entry 13: last used
j15: g0+15 , 0 ; rs entry 15: first of program
j21: g0+21 , 0 ; rs entry 21: general alarm
j26: g0+26 , 0 ; rs entry 26: in (current input zone address)
j29: g0+29 , 0 ; rs entry 29: param alarm
j30: g0+30 , 0 ; rs entry 30: saved stackreference , saved w3
j38: g0+38 , 0 ; rs entry 38: console process address
j39: g0+39 , 0 ; rs entry 39: trap base
j40: g0+40 , 0 ; rs entry 40: name of program document
j41: g0+41 , 0 ; rs entry 41: parent process address
j42: 1<11+1 , 0 ; ref to second segment
j43: 1<11+2 , 0 ; ref to third segment
j54: g0+54 , 0 ; rs entry 54: field alarm
j74: g0+74 , 0 ; rs entry 74: max last used
j104: g0+104, 0 ; rs entry 104 : own proc descr addr
g2 = k - d0 - 2 ; define rel of last absword
g1 = k - d0 - 2 ; define rel of last point
w. ;
e0: 0 ; start of external list:
0 ;
s3 ; date
s4 ; time
\f
; jz.fgs 1986.04.04 algol 6, system(fnc,i,arr or s), page ...3...
w. ;
b0: <:<10>entry<32><32><32>:>;
e1: rl. w2 (j13.) ; entry system:
ds. w3 (j30.) ; save(stack ref,w3);
al w1 -2 ;
jl. w3 (j3.) ; reserve two halfs for
ds. w3 (j30.) ; type of third parameter;
dl w1 x2+8 ; take first parameter:
so w0 16 ; if param 1 is expr or proc
jl. w3 (j4.) ; then take expression;
ds. w3 (j30.) ; save(stack ref,w3);
rl w1 x1 ; w1 := value(fnc);
al. w0 b0. ; w0 := addr(<:entry:>);
sh w1 g3 ; if fnc > no of entries
sh w1 0 ; or fnc < 0 then
jl. w3 (j21.) ; general alarm(<:entry:>,fnc);
rs w1 x2+6 ; formal(6) := value of fnc;
dl w1 x2+12 ; take second parameter:
so w0 16 ; if param 2 is expr or proc
jl. w3 (j4.) ; then take expression;
ds. w3 (j30.) ; save(stack ref,w3);
rs w1 x2+8 ; formal(8) := address of value of i;
al w0 2.111 ; take third parameter:
la w0 x2+14 ; type := formal (14) extract 3;
rs w0 x2-2 ; work := type;
se w0 2.111 ; if zone
sn w0 2.100 ; or long
al w0 3 ; then type:=3
se w0 2.101 ; if double precision
sn w0 2.110 ; or complex
al w0 4 ; then type:= 4
al w1 1 ;
ls w1 (0) ; type1 := 1 shift type;
am (x2+6) ;
bz. w3 f0. ; check type:
so w3 x1 ; if type1 is not in type table(fnc)
jl. w3 (j29.) ; then param alarm;
rs w0 x2+10 ; formal(10) := type;
ls w1 -1 ; type1 := type1 shift -1;
al w0 2.11111 ; test string:
la w0 x2+14 ;
se w0 8 ; if kind = string expression
sn w0 24 ; or kind = string variable
jl. a0. ; then goto call action;
sh w0 23 ; test array or zone:
sh w0 16 ; if kind is not zone or array
jl. w3 (j29.) ; then param alarm;
\f
; jz.fgs 1987.11.06 algol 6, system(fnc,i,arr or s), page ...4...
rl w3 x2+16 ; array:
ba w3 x2+14 ; formal(12) := abs address of dope :=
rs w3 x2+12 ; abs address of baseword + dope rel;
am (x2+6) ; maybe check array:
el. w0 f1. ;
so w0 1 ; if check array then
jl. a0. ; begin <*compute first address*>
rl w0 x3 ; w0 := lower index value - k;
al w1 2 ; w1 := field := 2; <*word field index 1*>
sh w1 (x3-2) ; if field > upper index value
sl w0 x1-1 ; or field < lower index value - k then
jl. w3 (j54.) ; goto field alarm;
wa w1 (x2+16) ; formal (14) := addr first word index 1 :=
rs w1 x2+14 ; field + baseword;
rl w1 (x2+16) ; <*compute last address*>
wa w1 x3-2 ; formal (16) := last array :=
rs w1 x2+16 ; base word + upper index;
al w1 5 ;
sn w1 (x2+6) ; if fnc <> 5 then
jl. a0. ; begin
al w1 8 ; w1 := field := 8; <*word field index 7*>
am (x3-2) ;
sl w1 1 ; if field >= upper index value + 1 then
jl. w3 (j54.) ; goto field alarm;
; end;
; end;
a0: am (x2+6) ; call action:
el. w3 f1. ; action := action table (fnc);
d1: jl. x3 ; goto action;
; exit conditions :
;
; w0 : return value of i
; w1 : - - - system
; w2 : sref
; w3 : addr of first word of text to be moved to array
; from (x3, x3+2), ... to ((x2+14), (x2+14)+2), ...
;
c21: ds w1 x2+12 ; exit 0: (from system (4, ...) save w0, w1;
rl w1 x2+16 ; array length :=
ws w1 x2+14 ; first array - last array +
al w0 x1+2 ; 2;
zl w1 x2+13 ; halfs to move :=
al w1 x1-2 ; seplength extract 12 - 2; <*multiple of 8*>
sh w0 x1 ; if halfs to move >= array length then
rl w1 0 ; halfs to move := array length;
jl. a4. ; goto continue system (4, ...;
c11: ds w1 x2+12 ; exit 1: (from system (2, ... and (6, ...) save w0, w1;
al w1 8 ; halfs to move := 8;
a4: am (x2+14) ; to__index :=
al w2 2 ; addr first double word of array;
al w3 x3+2 ; fromindex := addr first double word of text;
wa w1 6 ; from__top :=
rs. w1 b1. ; fromindex + halfs to move;
a3: dl w1 x3 ; repeat
ds w1 x2 ; move 4 halfs from fromindex to to__index;
al w2 x2+4 ; increment to__index;
al w3 x3+4 ; increment fromindex;
se. w3 (b1.) ; until
jl. a3. ; fromindexx = from__top;
dl. w3 (j30.) ; restore w2, w3;
dl w1 x2+12 ; restore w0, w1;
c12: rs w0 (x2+8) ; exit 2: i := w0; system := w1;
c0: rs. w2 (j13.) ; exit 3: release reservation;
jl. (j6.) ; end register expression;
\f
; jz.fgs 1987.11.06 algol 6, system(fnc,i,arr or s), page ...5...
; entry 1, floating point precision (note that third parameter
; of the call is not used)
; fgs 1982.09.06 : the entry is emptied to spare 8 instructions
c1: al w1 0 ;
; xs 3 ; second byte(w1) := exception register;
; ls w1 -2 ; system := exception(21);
; rl w0 (x2+8) ;
; sh w0 1 ;
; sh w0 -1 ; if i > 1 or i < 0 then
; jl. w3 (j29.) ; param alarm;
; js w0 2 ;
; xl 1 ; exception(21) := i;
jl. c0. ; goto exit3;
; entry 2, free core, program name
c2: rl. w1 (j13.) ; free core:
rl. w0 (j74.) ; w1:=last used; w0 := max last used;
se w0 0 ; if max last used = 0 then
jl. a21. ; begin
rl. w0 (j15.) ; w0 := first of program;
al w1 x1-1024 ; w1 := w1 - 1024;
a21: ws w1 0 ; end;
al w1 x1+8 ; system := w1 :=
ba w1 x2+4 ; last used - w0 + 2 + 6 + appetite;
al w0 x1 ; (two halfs reserved for type third param)
rl. w3 j40. ;
jl. c11. ; w3 := program name addr; goto exit 1;
; entry 3, array bounds
c3: rl. w3 (j42.) ; goto system entry 3
jl x3+i0 ; on next segment;
; entry 4, fileprocessor parameter
c4: rl. w3 j26. ; fileprocessor parameter:
rl w3 x3+h8-h20 ; w3 := abs address(fp current command);
rl w0 (x2+8) ; w0 := i;
rs. w0 b1. ; parameter no := i;
al w1 0 ; count := 0;
a2: sn. w1 (b1.) ; next parameter:
jl. a5. ; if count = parameter no then
al w1 x1+1 ; goto get parameter;
ba w3 x3+1 ; count:=count+1; next param;
bl w0 x3 ;
sl w0 3 ; if separator <> end command
jl. a2. ; then goto next parameter;
al w1 0 ; illegal parameter no:
jl. c0. ; w1 := 0; goto exit3;
b1: 0 ; parameter no, from_top in c11, c21, exit 0 and exit 1
\f
; jz.fgs 1987.07.08 algol 6, system(fnc,i,arr or s), page ...6...
; entry 4 (continued)
a5: bl w0 x3+1 ; get parameter:
rl w1 x3 ; system := w1 := separator and length(param);
se w0 4 ; if length (param) <> 4 then
jl. a7. ; goto text parameter;
rl w0 x3+2 ; integer parameter:
rl. w3 b3. ; w3 :=
sl w0 0 ; sign extension of w0;
al w3 0 ; if type third param = long array then
am (x2-2) ; arr(first) := value of param
se w3 x3-4 ; else
ci w0 0 ;
am (x2+14) ; arr(first) := float(value of param);
ds w0 2 ;
jl. c0. ; goto exit3;
a7: al w3 x3+2 ; text parameter:
rl w0 (x2+8) ; w0 := i; w3 := address(value of param);
jl. c21. ; goto exit 1;
; entry 5, move core area
b2: jl. (2) ; trap instruction;
b3: -1 ; sign extension of neg values;
c5: rl. w1 j39. ; modify trap routine:
dl w0 x1+2 ; formal(10:12) :=
ds w0 x2+12 ; instruction(trap base:trap base+2);
al. w0 a10. ; new instruction :=
rl. w3 b2. ; goto outside core;
ds w0 x1+2 ; comment: executed on illegal interrupts;
rl w1 (x2+8) ; attempt move:
rl w3 x2+14 ; index := first index;
a9: rl w0 x1 ; move next:
rs w0 x3 ; arr(index) := core(i);
al w1 x1+2 ; i := i + 2;
al w3 x3+2 ; index := index+2;
sh w3 (x2+16) ; if index =< upper then
jl. a9. ; goto move next;
am 1 ; moving ok: if true then w1 := 1 else
a10: al w1 0 ; outside core: w1 := 0;
dl. w3 (j30.) ; restore sref;
dl w0 x2+12 ; reset trap routine:
am. (j39.) ; instruction(trap base:trap base+2) :=
ds w0 2 ; formal(10:12);
jl. c0. ; goto exit3;
\f
; jz.fgs 1985.03.08 algol 8, system(fnc,i,arr or s), page ...7...
; entry 6, any message, own process
;prepared for system 3, but also valid in system 1 and 2
; ***danger*** uses knowledge of rs key variables!!!!
c6: ; any message:
al. w3 (j38.) ; w3 := addr of rs38, console addr;
rl w2 x3-6 ; w2:=spare mess buffer address
al w1 x3-38 ; w1:=answer address
jd 1<11 + 18 ; wait answer, spare mess buffer
al w1 x3-52 ; w1:=addr of dummy message
al w3 x3-18 ; w3:=addr of program name
jd 1<11 + 16 ; send message, i.e. link ans to the
al. w3 (j38.) ; w3 := addr of rs38, console proc addr;
rs w2 x3-6 ; save new spare buffer addr
ld w2 24 ; w1:=spare buff addr; w2:=0
a12: jd 1<11 + 24 ; next in q: wait event
sn w2 x1 ; if spare buffer seen then goto qmt
jl. a13. ;
sn w0 1 ; if answer then goto next in q
jl. a12.
sh w2 0 ; if buf claim exceeded
am -1 ; then result:=-1
am x2 ; buffer found
a13: al w0 0 ; qmt:
dl. w3 (j30.) ; restore stackref
rl. w1 (j104.) ; own process descr addr
a14: al w3 x1+2 ; process name
jl. c11. ; goto exit 1
; entry 7, console description
c7: rl. w1 (j38.) ; console description: w1 := console proc addr;
jl. a6. ; goto kind;
; entry 8, parent description
c8: rl. w1 (j41.) ; parent description: w1 := parent descr addr;
a6: rl w0 x1 ; kind: w0 := kind(process descr);
jl. a14. ; goto move process name;
\f
; jz.fgs 1986.04.04 algol 8, system (fnc,i,arr or s), page ...8...
; entry 9, run time alarm
c9: rl. w3 (j42.) ; goto system entry 9
jl x3+i1 ; on next segment
; entry 10, parent message
c10: rl. w3 (j42.) ; goto system entry 10
jl x3+i2 ; on next segment
; entry 11, intervals
c13: rl. w3 (j42.) ; goto system entry 11
jl x3+i3 ; on next segment
; entry 12, activity description
c14: rl. w3 (j43.) ; goto system entry 12
jl x3+i4 ; on third segment;
; entry 13, fp absent, release<12+subrelease, year<12+date, rs segments
c15: rl. w3 (j42.) ; goto system entry 13
jl x3+i5 ; on next segment;
; entry 14, get latest answer
c16: rl. w3 (j43.) ; goto system entry 14
jl x3+i6 ; on third segment;
\f
; jz.fgs 1987.11.06 algol 8, system(fnc,i,arr or s), page ...9...
; type table (type requirements for third parameter:
; (cmplx or double)<4+(long or real)<3+integer<2+boolean<1+string):
h. ;
f0 = k - 1 ;
; ; fnc:
1<4+1<3+1<2+1<1+1 ; 1 floating point precision
1<4+1<3 ; 2 free core, program name
1<4+1<3+1<2+1<1 ; 3 array bounds
1<4+1<3 ; 4 fileprocessor parameter
1<4+1<3+1<2 ; 5 move core area
1<4+1<3 ; 6 any message, own process
1<4+1<3 ; 7 console description
1<4+1<3 ; 8 parent description
1 ; 9 run time alarm
1<4+1<3+1<2 +1 ; 10 parent message
1<4+1<3+1<2 ; 11 intervals
1<4+1<3+1<2 ; 12 activity description
1<4+1<3+1<2 ; 13 fp, release, rs segments
1<4+1<3+1<2 ; 14 latest answer
; action table (+1 means that third parameter in the call
; must be real array with length >=2):
h. ;
f1 = k - 1 ;
; ; fnc:
c1 -d1 ; 1 floating point precision
c2 -d1+1 ; 2 free core, program name
c3 -d1 ; 3 array bounds
c4 -d1+1 ; 4 fileprocessor parameter
c5 -d1+1 ; 5 move core area
c6 -d1+1 ; 6 any message, own process
c7 -d1+1 ; 7 console description
c8 -d1+1 ; 8 parent description
c9 -d1 ; 9 run time alarm
c10-d1+1 ; 10 parent message
c. h57 < 3 ; if system 3 then include
c13-d1+1 ; 11 intervals
z. c14-d1+1 ; 12 activity description
c15-d1+1 ; 13 fp, release, rs segments
c16-d1+1 ; 14 latest answer
g3 = k - f1 - 1 ; no of entries in system
w. ;
g4:
c. k - 506
m. code too long
z.
c. 502 - g4, 0,r.252 - g4>1 z. ; fill segment with 0
<:system0<0>:>, 0 ; alarm text
i. ; id list
e. ; end first segment
e6 = e6 + 1 ; segments := segments + 1;
\f
; jz.fgs 1987.11.06 algol 8, system, page ...10...
b. a9, b5, c5, d1, g4, j104 ; begin of segment 2
h.
d0: g1 , g2 ; rel of last point, rel of last absword
j3: 3 , 0 ; rs entry 3: reserve
j4: 4 , 0 ; rs entry 4: take expression
j6: 6 , 0 ; rs entry 6: end register expression
j13: 13 , 0 ; rs entry 13: last used
j16: 16 , 0 ; rs entry 16: segment table base
j18: 18 , 0 ; rs entry 18: zone alarm, prints the text <:index:>
j21: 21 , 0 ; rs entry 21: general alarm
j26: 26 , 0 ; rs entry 26: current in zone
j30: 30 , 0 ; rs entry 30: saved sref, saved w3
j41: 41 , 0 ; rs entry 41: parent descr address
j50: 50 , 0 ; rs entry 50: dr2 (double prec. reg.), used for text
j60: 60 , 0 ; rs entry 60: last of segment table
j97: 97 , 0 ; rs entry 97: fp absent
j98: 98 , 0 ; rs entry 98: release<12+subrelease, date
j102: 102 , 0 ; rs entry 102: rs segments
j103: 103 , 0 ; rs entry 103: compiler version
j104: 104 , 0 ; rs entry 104: own process descr addr
g2=k - d0 - 2 ; define rel of last absword
g1=k - d0 - 2 ; define rel of last point
; entry 3, array bounds
w.
c4: dl w1 (x2+12) ; array bounds:
ac w3 (x2+10) ; k := -type;
as w0 x3+1 ; i := upper//k;
as w1 x3+1 ; system := (lower//k) + 1;
al w1 x1+1 ;
rs w0 (x2+8) ; <*i := w0; system := w1;*>
rs. w2 (j13.) ; release reservation;
jl. (j6.) ; goto end register expression;
\f
; jz.fgs 1987.11.06 algol 8, system, page ...10a...
;procedure take string
; the procedure takes a string described in x2+14 and x2+16 and
; stores it in the stack from the address given in w1 to, but
; not including the address given in w2.
;
;registers entry exit
; w0 irrelevant spoiled
; w1 first address spoiled
; w2 top address, stackref unchanged
; w3 return point spoiled
;
; cells
; x2+6 used for work
; x2+10 - - -
; x2+12 - - -
; x2+14 reference to string unchanged
; x2+16 - - - unchanged
b. a5, b0 ; procedure take string
w. ;
c0: al. w0 d0. ; make return relative to segment start
ws w3 0 ;
rs w3 x2+10 ;
rs w1 x2+12 ; save return, start of storage area
a0: dl w1 x2+16 ; take string param
so w0 16 ; if expression
jl. w3 ( j4. ); then take expression
ds. w3 ( j30.);
dl w1 x1 ; get string portion
sh w1 -1 ; if long string
jl. a1. ; then goto longstr
sh w0 -1 ; if layout then
ld w1 -100 ; simulate null string
jl. w3 a5. ; store string
jl. a0. ; goto take string param
\f
; jz.fgs 1981.05.26 algol 6, system, page 11
; procedure take string ctd
a1: hs. w0 a2. ; longstr:
bz w3 0 ; fetch address of string
ls w3 1 ; relative is stored in a2
rl. w0 ( j60.); and segment number * 2 in w3
wa. w3 ( j16.); w3:= segment tab base+segm no * 2
sh w0 x3-1 ; if w3>last of segment table
jl. a4. ; then goto string error
rl w3 x3 ;
a2=k+1 ; address of segment relative
a3: dl w1 x3+0 ; next: fetch string portion
sh w1 -1 ; if long string
jl. a1. ; then goto longstr
rs. w3 ( j30.); save w3
jl. w3 a5. ; store string
rl. w3 ( j30.); restore w3
al w3 x3-4 ; next portion:=next portion - 4
jl. a3. ; goto next
a4: ws. w3 ( j16.); segment no :=(w3-segment tab base)//2
al w1 x3 ;
ls w1 -1 ;
al. w0 b0. ;
jl. ( j21.); general alarm(<:segment:>, segment no)
b0: <:<10>segment :>
a5: ; subprocedure store string portion
; checks if string contains nulls or area
; is filled, and returns in these cases
rs w3 x2+6 ; save return
rl w3 x2+12 ; to_pointer:=to_pointer + 4
al w3 x3+4 ;
ds w1 x3 -2 ; textarea(to_pointer):= portion;
rs w3 x2+12 ;
sl w3 x2-2 ; if textarea full
al w1 0 ; then signal finished
rl w3 x2+10 ; fetch return point
sz w1 8.377; if text extract 8 <> 0
jl (x2+6) ; then goto return from store
jl. x3+d0. ; else goto return from take string
i. ; id list
e. ; end procedure take string
\f
; jz.fgs 1982.09.08 algol 8, system, page ...12...
w.
; entry system 9, run time alarm simulates call from call point
c1: ds. w3 (j30.) ; entry system 9: save sref, w3;
rs. w2 (j13.) ; release prev reservation (type third param);
rl w1 (x2+8) ; save i parameter as it may
rs w1 x2+8 ; be located in uv
al w1 -8 ;
jl. w3 ( j3.) ; reserve 8 bytes new top in w1
jl. w3 c0. ; take string
rl. w3 j50. ; w3 := addr(dr2);
dl w1 x2-6 ; store alarm text in
ds w1 x3-2 ; dr2 - 4
rl w1 x2-4 ; dr2 - 2
rs w1 x3+0 ; and dr;
dl w0 x2+4 ; fetch calling segment
rl w3 x3+0 ; ie provoke it to be in core by
rl w1 x3+0 ; referring its first word
hs. w0 a0. ;
a0=k+1 ; rel of call point on segment
al w3 x3+0 ; w3:=abs address of return point
rl. w1 j50. ; w3 := addr(dr2);
al w0 x1-4 ; w0 := pointer to alarmtext;
ls w0 -1 ; even textaddress to ensure
ls w0 1 ; that integer parameter is printed;
bl w1 x2+4 ; last used in call:=
am x2 ; stackref + apetite
al w1 x1+8+6 ; +reserved + 6
rs. w1 ( j13.); last used:=last used in call
rl w1 x2+8 ; take i value
rl w2 x2 ; w2:=w2 in call
jl. ( j21.); goto general alarm
\f
; jz.fgs 1982.09.02 algol 6, system, page ...13...
; constants and working cells for system 10
b0: 8<13 + 0<5 + 0 ; first word of a print message
b1: 0, r. 8 ; room for parent name and name table address
; also room for answer, if wait bit=0
; entry system 10 parent message, sends either a text string
; of max 21 chars as a print message or the first 8 words
; of an array as a message to the parent. the contents of
; the array is not checked in any way. the answer from the
; parent is copied into the array, and the value of
; system is set to 0 if buffer claim is exceeded otherwise
; to the result of the answer
c2: ds. w3 (j30.) ; entry system 10: save sref, w3;
rs. w2 (j13.) ; release previous reservation (type third param);
am (x2+10) ; comment type of string = 0;
se w1 x1 ; if type <> string
jl. a1. ; then then goto array
;
al w1 -18 ; string:
jl. w3 ( j3.) ; reserve 18 bytes
ld w0 -100 ;
ds w0 x2-4 ; and initialize them
ds w0 x2-8 ; to contain a print
ds w0 x2-12 ; message with an empty string
rl w3 (x2+8) ;
se w3 1 ; if i=1
al w3 0 ; then wait:=true
lo. w3 b0. ;
ds w0 x2-16 ;
al w1 x1+2 ; let the text start in last used +2
jl. w3 c0. ; take string
rs. w2 (j13.) ; release reservation as no change in segment
; alocation can happen any more
al w1 x2-18 ; w1:=message address
jl. a2. ; goto send mess
\f
; rc 26.04.72 algol 6, system page 14
; system entry 10 ctd
a1: dl w2 x2+16 ; array:
sl w1 x2-13 ; if length of array < 16 bytes
jl. a3. ; then goto length error
a2: rl. w2 ( j41.); send mess:
dl w0 x2+8 ; parent name(4:7):=
ds. w0 b1.+6; parent descr(6:9)
dl w0 x2+4 ; parent name(0:3):=
ds. w0 b1.+2; parent descr(2:5);
al. w3 b1. ; w3:=name address
al w0 0 ; w0=result, if buffer claim exceeded
jd 1<11 +16 ; send message
rl w3 x1 ; if first word of message
so w3 1 ; has wait_bit <> 1
al. w1 b1. ; then recieve answer here on segment
se w2 0 ; if buf claim not exceeded
jd 1<11 +18 ; then wait answer
rl. w2 ( j13.); restore stackref
rl w1 0 ; system:= result
jl. (j6.) ; end register expression
a3: rl. w2 ( j13.); lengtherror: restore stackref
al w0 16 ; byte index:=16
ac w3 (x2+10) ; w3:=-type; comment -log2(k);
rl w1 (x2+12) ; lower bound:=
as w1 x3+1 ; lower bound // k
as w0 x3+1 ; index:=byte index // k
wa w1 0 ; alarm index:= lower bound + index
jl. w3 ( j18.); zone alarm, prints the text <:index:>
\f
; jz.fgs 1985.03.08 algol 8, system page ...15...
; system entry 11 intervals:
c3: ds. w3 (j30.) ; entry system 11: save sref, w3;
rs. w2 (j13.) ; release prev reservation (type third param);
dl w2 x2+16 ;
sl w1 x2-13 ; if length < 16 bytes
jl. a3. ; then goto length error;
rl. w2 (j104.) ; w2 := own process descr addr;
dl w0 x2+70 ; byte 1-4 :=
ds w0 x1+2 ; catalog base;
dl w0 x2+78 ; byte 5-8 :=
ds w0 x1+6 ; standard interval;
am. (j26.);
dl w0 h58-h20 ; byte 9-12 :=
ds w0 x1+10 ; user interval;
dl w0 x2+74 ; byte 13-16 :=
ds w0 x1+14 ; max interval;
rl. w2 (j13.) ; restore stackref;
al w1 0 ; result :=0;
jl. (j6.) ; end reg expres;
\f
; jz.fgs 1987.11.06 algol 8, system, ...16...
; system entry 13, fp absent, release<12+subrelease, date
c5: ds. w3 (j30.) ; system entry 13: save sref, w3;
rs. w2 (j13.) ; release prev reservation (type third param);
dl. w0 (j98.) ;
am (x2+14) ; array (1) := release<12 + subrelease;
ds w0 2 ; array (2) := relyear<12 + mmdd ;
dl. w0 (j102.) ;
am (x2+14) ; array (3) := no of resident rs segments;
ds w0 6 ; array (4) := no of rs segments;
rl. w0 (j103.) ; i :=
rs w0 (x2+8) ; compiler version;
jl. w3 (j97.) ; w1 :=
rl w1 0 ; fp absent;
jl. (j6.) ; goto end reg expression;
i0= c4 - d0 ; define rel entry for system 3 code
i1= c1 - d0 ; define rel entry for system 9 code
i2= c2 - d0 ; define rel entry for system 10 code
i3= c3 - d0 ; define rel entry for system 11 code
i5= c5 - d0 ; define rel entry for system 13 code
g4: c. k-(:512+506:)
m. code on segment 2 too long
z.
c. (:502+512:)-g4, jl -1, r.(:252+256:)-g4>1 ; fill segment with jl-1
z.
<:system1<0>:>, 0 ; alarm text
i. ; id list
e. ; end segment 2
e6 = e6 + 1 ; segments := segments + 1;
\f
; jz.fgs 1984.01.27 algol 8, system, page ...17...
b. a12, b5, c5, d1, g5, j103 ; begin of segment 3
h.
d0: g1 , g2 ; rel of last point, rel of last absword
j4: 4 , 0 ; rs entry 4: take expression
j5: 5 , 0 ; rs entry 5: goto point
j6: 6 , 0 ; rs entry 6: end register expression
j13: 13 , 0 ; rs entry 13: last used
j18: 18 , 0 ; rs entry 18 : zone alarm, prints the text <:index:>
j21: 21 , 0 ; rs entry 21: general alarm
j23: 23 , 0 ; rs entry 23: youngest zone
j30: 30 , 0 ; rs entry 30: saved sref, saved w3
j32: 32 , g5 ; rs entry 32: stderror with chain for rel
j61: 61 , 0 ; rs entry 61: csr, cza
j75: 75 , 0 ; rs entry 75: limit last used
j78: 78 , 0 ; rs entry 78: no of activities
j79: 79 , 0 ; rs entry 79: base of activity table
j80: 80 , 0 ; rs entry 80: (azone, aref)
j85: 85 , 0 ; rs entry 85: current activity no
j91: 91 , 0 ; rs entry 91: trap chain
j99 : 99 , 0 ; rs entry 99: saved parity count
j101: 101 , 0 ; rs entry 101:latest answer
g2=k - d0 - 2 ; define rel of last absword
j33: 33 , 0 ; rs point 33 : check
g1=k - d0 - 2 ; define rel of last point
\f
; jz.fgs 1984.01.27 algol 8, system, page ...18...
; system entry 12, get activity description
; constants and procedures
w.
b1: 0 ; activity no
b2: 0 ; activity table size
b3: 0 ; top activity table or top address of answer area
b4: 0 ; activity table address
; procedure store in array
; call: value:
; w0: value value
; w1: rel index index
; w2: sref sref
; w3: link link
;
a3: am (x2+14) ; store in array:
al w1 x1 ; index := addr first array elem + rel index;
sh w1 (x2+16) ; if index <= addr last array elem then
rs w0 x1 ; array (index) := value;
jl x3 ; return;
; procedure activity number alarm;
a5: al. w0 b5. ; actno alarm:
jl. w3 (j21.) ; general alarm;
b5: <:<10>act no :>
i4 = k - d0 ; define rel entry system 12
ds. w3 (j30.) ; entry system 12: save sref, w3;
rs. w2 (j13.) ; release prev reservation (type third param);
rl. w3 (j78.) ;
sn w3 0 ; no := no of activities;
jl. a6. ; if no=0 then goto finis;
am. (j80.) ;
rl w1 -2 ; size :=
al w1 x1+h4 ; zone address(azone) + h4
ws. w1 (j79.) ; - activity table base;
sh w3 -1 ; if no < 0 then
ac w3 x3 ; no := -no;
al w3 x3+1 ; no of activities + 1;
al w0 0 ;
wd w1 6 ; activity table size :=
rs. w1 b2. ; size//no;
rl w1 (x2+8) ; activity no := value (sec. param);
rs. w1 b1. ;
sn w1 0 ; if activity no = 0 then
jl. a6. ; goto finis;
sl w1 1 ; if activity no < 1
sl w1 x3 ; or activity no >= no of activities + 1
jl. a5. ; then goto activity no alarm;
\f
; jz.fgs 1982.09.06 algol 8, system, page ...19...
; system 12 (continued)
wm. w1 b2. ; activity table address := base activity table +
wa. w1 (j79.) ; activity no * activity table size;
rs. w1 b4. ;
wa. w1 b2. ; top activity table :=
rs. w1 b3. ; activity table address + activity table size;
rl. w1 b4. ; acindex := activity table address;
rl w3 x2+14 ; index := first array;
al w3 x3+6 ; index := index + 6;
a4: rl w0 x1 ; move activity table entry:
rs w0 x3 ; array(index) := act. table(acindex);
al w1 x1+2 ; acindex := acindex + 1;
sl. w1 (b3.) ; if acindex >= top activity table
jl. a2. ; then goto check ego;
al w3 x3+2 ; index := index + 1;
sh w3 (x2+16) ; if index <= last index then
jl. a4. ; goto move activity table entry;
a2: rl w3 x2+14 ; check ego: w3 := addr first array elem;
rl. w1 (j85.) ; w1 := current activity number;
rs w1 x3+4 ; array (3) := w1;
sh w1 -1 ; if w1 < 0 then
ac w1 x1 ; w1 := -w1;
se. w1 (b1.) ; if current activity no <> activity no then
jl. a8. ; goto check implicit passivate;
rl. w1 (j13.) ;
al w0 x1+6 ;
ba w0 x2+4 ;
al w1 10 ;
jl. w3 a3. ; save last used+6+appetite in array(6);
rl. w0 (j23.) ;
al w1 16 ;
jl. w3 a3. ; save youngest zone in array (9);
dl. w0 (j61.) ;
al w0 x3 ;
al w1 18 ;
jl. w3 a3. ; save csr in array (10);
rl. w0 (j61.) ;
al w1 20 ;
jl. w3 a3. ; save cza in array (11);
rl. w0 (j91.) ;
al w1 22 ;
jl. w3 a3. ; save trap chain in array (12);
rl. w0 (j75.) ;
al w1 24 ;
jl. w3 a3. ; save limit last used in aray (13);
rl w3 x2+14 ;
al w0 0 ;
rs w0 x3+0 ; array (1) := 0; <*buff addr*>
rl. w0 b1. ;
rs w0 x3+2 ; array (2) := activity no;
jl. a6. ; goto finis;
\f
; jz.fgs 1984.01.27 algol 8, system, page ...20...
; system 12 (continued)
a8: al w0 0 ; check implicit passivate: buf := 0;
rl. w1 b4. ; w1 := activity table address;
am (x1+8) ;
se w1 x1-2 ; if activity.state = 2 <*implicitly pass*> then
jl. a9. ; begin <*find buffer addr*>
rl w1 (x1+4) ; w1 := cont (activity.last used);<*zone addr*>
rl w0 (x1+h0+4) ; buf := zone.used share.share state;
; end;
a9: rs w0 x3+0 ; array(1) := buf;
rl w1 x3+6 ; pending activity := 0;
al w0 0 ; first core := array(4);
sh w1 0 ; if first core > 0 then
jl. a7. ; begin
rl w1 x1-2 ; pending := core(first core - 2)
ws. w1 (j79.) ; - base activity table;
wd. w1 b2. ; pending activity :=
al w0 x1 ; pending//activity table size;
a7: rs w0 x3+2 ; end;
; array(2) := pending activity;
a6: rl. w1 (j78.) ; finis: w1 := no of activities;
sh w1 -1 ; if w1 < 0 then
ac w1 x1 ; w1 := -w1;
jl. (j6.) ; goto end reg. expression;
\f
; fgs 1984.01.27 algol 8, system, page ...21...
i6 = k - d0 ; define rel entry system 14
ds. w3 (j30.) ; entry system 14: save sref, w3;
rs. w2 (j13.) ; release previous reservation (work third param);
dl w1 x2+16 ;
sl w0 x1-13 ; if length of array < 16 halfs then
jl. a12. ; goto length alarm;
rl. w1 j101. ; addr := addr latest answer;
al w3 x1+24 ; top addr answer :=
rs. w3 b3. ; addr + 24;
rl w3 x2+14 ; index := addr first array element;
a10: rl w0 x1 ; array (index) :=
rs w0 x3 ; answer (addr);
al w1 x1+2 ; index := index + 2;
sn. w1 (b3.) ; if index < top answer area then
jl. a11. ; begin
al w3 x3+2 ; addr := addr + 2;
sh w3 (x2+16) ; if addr <= addr lasr array element then
jl. a10. ; goto rep;
a11: rl. w1 (j99.) ; end;
jl. (j6.) ; system := saved parity count; goto end register expr;
a12: al w0 16 ; length alarm: byte index := 16;
ac w3 (x2+10) ; w3 := -type; <*-log2 (k)*>
rl w1 (x2+12) ; lower bound :=
as w1 x3+1 ; lower bound // k;
as w0 x3+1 ; index := byte index // k;
wa w1 0 ; alarm index := lower bound + index;
jl. w3 (j18.) ; goto zone alarm; <*prints the text <:index:>*>
\f
; jz.fgs 1984.01.27 algol 6, system, page ...22...
; the procedures increase, check, blockproc and stderror
; integer procedure increase(i);
; i integer, call and return value;
e2 = k - d0 ; rel entry increase:
rl. w2 (j13.) ; entry increase:
ds. w3 (j30.) ; w2:= saved stack ref:= last used;
dl w1 x2+8 ; get i param:
so w0 16 ; if expr then take expression;
jl. w3 (j4.) ;
ds. w3 (j30.) ; saved stack ref:= w2;
rl w3 x1 ; i:= param1;
al w3 x3+1 ; increase:= i;
rx w3 x1 ; i:= i+1;
al w1 x3 ;
jl. (j6.) ; goto rs end register expression;
; procedure check(z);
; z zone, call and return value;
; calls the running system procedure check;
e3 = k - d0 ; rel entry check:
rl. w2 (j13.) ; entry check:
rl w0 x2+8 ; zone descriptor address:= param1;
ls w0 4 ; w0:= zone descriptor address shift 4;
rl. w1 j33. ; w1:= point for rs check;
jl. (j5.) ; goto rs goto point;
; procedure blockproc(z, st, b);
; z zone, call and return value;
; st integer, call and return value;
; b integer, call and return value;
; calls the block procedure belonging to the zone z;
e4 = k - d0 ; rel entry blockproc:
rl. w2 (j13.) ; entry blockproc;
rl w1 x2+8 ; z:= param1;
dl w1 x1+h4+2 ; w1:= entry point blockproc.z;
ls w0 4 ; w0:= stack ref blockproc.z shift 4;
jl. (j5.) ; goto rs goto point;
; procedure stderror(z, st, b);
; z zone, call value;
; st integer, call value;
; b integer, call value;
; calls the running system procedure stderror;
e5 = k - d0 ; rel entry stderror:
rl. w3 (j32.) ; entry stderror:
g5= k-d0+1 ; chain for rel stops here
jl x3+0 ; goto rs stderror;
g4: c. k-(:1024+506:)
m. code on segment 3 too long
z.
c. (:502+1024:)-g4, jl -1, r.(:252+512:)-g4>1 ; fill segment with jl-1
z.
<:system2<0>:>, 0 ; alarm text
i. ; id list
e. ; end segment 3
e7 = e6 ; last segment
e6 = e6 + 1 ; segments := segments + 1;
i. ; id list
e. ; end slang segments
\f
; jz.fgs 1984.01.27 algol 8, system, page ...23...
; tails to be inserted in the catalog:
w.
g0:
; system
e6 ; three segments
0, r.4 ; fill 4 words
1<23 + e1 ; entry point
3<18+41<12+19<6+19 ; integer proc, spec undef, spec int, spec int
0 ;
4 <12+ e0 ; 4, start of external list
e6<12+ 0 ; three code segments, 0 owns
; increase
1<23+4 ; kind bs
0,0,0,0 ; room for name
1<23+e7<12+e2 ; entry point
3<18+19<12, 0 ; integer proc(integer addr)
4<12+e0 ; code proc, external list
e6<12+0 ; e6 segments, no owns
; check
1<23+4 ; kind backing storage
0,0,0,0 ; room for name
1<23+e7<12+e3 ; entry point
1<18+8<12, 0 ; proc no type(zone)
4<12+e0 ; code proc, external list
e6<12+0 ; e6 segments, no owns
; blockproc
1<23+4 ; kind backing storage
0,0,0,0 ; room for name
1<23+e7<12+e4 ; entry point
1<18+3<12+3<6+8,0; proc no type(zone, int name, int name)
4<12+e0 ; code proc, external list
e6<12+0 ; e6 segments, no owns
; stderror
g1: 1<23+4 ; kind backing storage
0,0,0,0 ; room for name
1<23+e7<12+e5 ; entry point
1<18+3<12+3<6+8,0; proc no type(zone, int name, int name)
4<12+e0 ; code proc, external list
e6<12+0 ; e6 segments, no owns
i. ; id list
m. fgs 1987.11.06 algol 8 proc,
m. system, increase, check, blockproc, stderror
\f
▶EOF◀