|
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: 177408 (0x2b500)
Types: TextFile
Names: »tcodepr«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦545a06c52⟧ »tcodeproc«
└─⟦this⟧
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tcodepr«
└─⟦this⟧ »tcodeproc/tcodepr«
lookup codelist
if ok.yes
mode listing.yes list.yes
message anders lindgård
message 1980.01.26
message initcode
lookup initcode
if ok.yes
(scope temp initcode
clear temp initcode
)
initcode=set 1 drum
((initcode=slang fpnames type.yes insertproc entry.no
initcode )
)
; b. ; fpnames dummy block
b. g1,e20 ; block with names for tails
k=0 ; and insertproc.
m.initcode
s. g6,j48,d6,f24,i24 ; start of slang segment for proc.
h.
g0=0 ; g0:=no of externals;
e20:
g1: g2 , g2 ; headword: rel of last point,
; rel of last abs word
j4: g0+4 , 0 ; RS entry 4, take expression
j6: g0+6 , 0 ; RS entry 6, end register expr.
j12: g0+12, 0 ; RS entry 12, UV
j13: g0+13, 0 ; RS entry 13, last used
j16: g0+16, 0 ; RS entry 16, segment table base
j21: g0+21, 0 ; RS entry 21, general alarm
j29: g0+29, 0 ; RS entry 29, param alarm
j30: g0+30, 0 ; RS entry 30, saved stack ref, saved w3
j42: g0+42, 0 ; RS entry 42, victim
g2=k-2-g1 ; end of abs word:=end of points;
w.
e0: g0 ; start of external list
0 ; number of bytes to initialize
w. 14 01 73, 19 00 00; date, time
f0: 2.111 ; mask
f1: 3<12 ; input message
f4: 0,r.10 ; tail
f5: <:<10>claim:> ;
; integer procedure init_code(A,name,one or more source parameters);
; <any type> array A; string name; <any type> source;
; init_code:=number of source parameters;
; Loads the array A with a preassembled slang code from the
; backing store area name. All the addresses of source parameters
; are stored in the array, too.
e1: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ;
jl. w3 d2. ; find first address of A
rs w1 x2+8 ;
al w3 0 ;
rs w3 x1+2 ;
al w3 x2+6 ;
ba w3 x2+4 ;
rl w0 x2+10 ;
sn w0 24 ; i:=if short string then 4
al w3 x3-4 ; else 0;
rs w3 x2+6 ; upper limit:=stack ref+appetite+6-i;
dl w1 x2+16 ; take first param
rs w3 x2+16 ;
al w3 x2+16 ;
jl. i3. ; goto First param;
i2: sl w3 (x2+6) ; Next:
jl. i5. ; if cur param>=upper limit then
dl w1 x3 ; goto End source param;
i3: rs w3 (x2+8) ; First param:
rs w0 x2+14 ; save formal1
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w0 x2+14 ;
jl. w3 d2. ; addr:=absaddr;
sl w1 (x2+6) ; if addr<upper limit and
jl. i4. ; addr>=first param then
sl w1 x2+6 ; upper limit:=addr;
rs w1 x2+6 ;
i4: la. w3 f0. ; kind:=kind mod 8;
sl w3 3 ; if kind not of type integer or boolean
al w1 x1+1 ; then make addr odd;
sh w1 x2 ; if addr point to data then
jl. 6 ;
sh w1 (x2+16) ; make addr negative;
ac w1 x1 ;
am (x2+8) ;
rl w3 2 ;
am (x2+8) ;
rs w1 x3+10 ; A.pointer:=addr;
al w3 x3+2 ; pointer:=pointer+2;
am (x2+8) ;
rs w3 2 ;
rl w3 (x2+8) ;
al w3 x3+4 ; cur param:=cur param+4;
jl. i2. ; goto Next;
i5: rl w3 x2+8 ; End source param:
rl w1 x3+2 ;
rs w1 x3+4 ; A(2):=appetite of source param;
rs w1 x2+16 ;
wa w3 2 ; first addr of data:=
al w3 x3+8 ; last addr of param in A;
rs w3 (x2+8) ;
al w3 0 ;
i7: rs w3 x2+14 ; Nextaddr:
am (x2+8) ;
rl w0 x3+10 ; addr:=saved addr in A;
sl w0 0 ; if addr>=0 then
jl. i10. ; goto Positive;
ac w0 (0) ; addr:=-addr;
rl w1 (x2+8) ;
sz w0 1 ; if addr points to long data then
jl. i8. ; goto Long;
al w1 x1+2 ; update first addr of data
rl w0 (0) ; move short data
rs w0 x1 ;
jl. i9. ; goto Save;
i8: al w1 x1+4 ; Long:
dl w0 (0) ; update first addr of data
ds w0 x1 ; move long data
i9: rs w1 (x2+8) ; Save:
jl. i11. ; goto Correctaddr;
i10: rl w1 0 ; Positive:
sz w1 1 ; if addr of type real or long then
al w1 x1-1 ; set addr to third byte in the doubleword;
i11: rl w3 x2+14 ; Correctaddr:
am (x2+8) ;
rs w1 x3+10 ; set correct addr in A
al w3 x3+2 ;
se w3 (x2+16) ; if more param then
jl. i7. ; goto Nextaddr;
dl w1 x2+12 ; take param: name
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
al w2 x2+10 ;
jl. w3 d0. ; w3:=takestring(name);
al w2 x2-10 ;
al. w1 f4. ; w1:=tail address;
jd 1<11+42 ; lookup entry
sn w0 0 ;
jl. i14. ; if result>0 then
i13: rl w1 0 ; Error:
al w0 x3 ; alarm(string name,result);
jl. w3 (j21.) ;
i14: jd 1<11+52 ; create area process
se w0 0 ; if result>0 then
jl. i13. ; goto Error;
rs. w0 f1.+6 ;
rl w1 (x2+8) ; first addr:=first addr of A
al w0 x1+2 ;
wa. w1 f4.+18 ; to use of code;
al w1 x1+512 ; last addr:=length+510+first addr;
ds. w1 f1.+4 ;
ws w0 x2+8 ; save bytes used
rs. w0 (j12.) ;
rl w2 x2+8 ;
bl. w1 f4.+17 ; A(1):=absolute address of the
al w1 x1+2 ; first instruction to
wa w1 x2 ; execute;
rs w1 x2+2 ;
rl. w1 j42. ;
rl w0 x1+32 ; A(3):=RS base; (victim)
rx w1 0 ;
; A(4):=FP base; (core base)
ds w1 x2+8 ;
al. w1 f1. ; w1:=message address;
jd 1<11+16 ; send message
se w2 0 ; if buffer claim exceeded then
jl. i17. ; alarm(<:claim:>,0);
al. w0 f5. ;
al w1 0 ;
jl. w3 (j21.) ;
i17: al. w1 f4. ; w1:=answer address;
jd 1<11+18 ; wait answer
sn w0 1 ; if result>1 then
jl. i18. ; alarm(<:claim:>,result);
al. w3 f5. ;
jl. i13. ;
i18: jd 1<11+64 ; remove process
rl. w1 (j12.) ; initcode:=bytes used;
jl. (j6.) ; end register expr.
; integer procedure absaddr;
; Finds the address of a variable or the first
; address of an array. A zone is treated as a real array.
; at entry at return
; w0 formal1 destroyed
; w1 formal2 abs address
; w2 not used unchanged
; w3 link kind
b. b6,w.
b0: 0 ; link
b1: 0 ; formal2
d2: rs. w3 b0. ; save link
rs. w1 b1. ; save formal2
al w3 2.11111 ;
la w3 0 ; kind:=formal1 extract 5;
sn w3 23 ; if kind=zone then
al w3 19 ; kind:=real array;
sl w3 16 ; if kind<16
sl w3 23 ; or kind>22 then
jl. b2. ; begin
; absaddr:=addr(variable);
; end else
ba w1 0 ; begin
rl w1 x1 ; w1:=abs dope addr;
wa. w1 (b1.) ; w1:=lower index-1; (even)
am 2 ; absaddr:=abs addr of first element;
b2: al w1 x1-1 ;
jl. (b0.) ; end;
e. ; return
; procedure take string;
; registers at entry at return
; w0 not used destroyed
; w1 abs addr of string/elem destroyed
; w2 addr of first formal unchanged
; w3 link addr of start of name
b. a8,c6,b24 ; begin
w.
c0: 0, c1: 0 ; first formal,link
c2: 0,r.5 ; name
c3: 0 ; work
c4: 0 ; work
d0: ;entry get string
ds. w3 c1. ;save link , save w2
rl w0 x2 ;w0:=first formal
al w3 2.11111;
la w3 0 ;w3:=kind+()
se w3 10 ;if integer expression
sn w3 26 ;or integer then
jl. w3 (j29.) ; param alarm;
se w3 24 ;if -,string variable or
sn w3 8 ;-,string expression
jl. a1. ;begin comment array;
sh w3 22 ;if variable or
sh w3 15 ;procedure or expression then
jl. w3 (j29.) ;param alarm
ba w1 0 ;w1:=abs dope addr
rl w3 x1 ;w3:=lower index-K (K=2)
wa w3 (x2+2) ;w3:=first addr-2
al w3 x3+2 ;w3:=first addr
jl. (c1.) ;end;
a1:
dl w1 x1 ;w1w0:=string value
sh w0 0 ;if layout then
jl. w3 (j29.) ;param alarm
sh w1 -1 ;if long string then
jl. a3. ;goto long string
al. w3 c2. ;w3:=name addr
ds w1 x3+2 ;store string value
ld w1 -65 ;w1w0:=0;
ds w1 x3+6 ;last part name:=0;
jl. (c1.) ;end get string
a3: ;long string:
ds. w1 c4. ;store item
ld w1 -65 ;w1w0:=0
ds. w1 c2.+6 ;name(3):=name(4):=0;
rl. w0 c1. ;w0:=return addr
al. w3 a7. ;w3:=exit addr
ws w0 6 ;w0:=rel return adr
rs. w0 (j12.) ;save rel return in UV
dl. w1 c4. ;w1w0:=item
a4: ;find first part:
bz w3 0 ;w3:=rel segm no
ls w3 1 ;w3:=w3*2
wa. w3 (j16.) ;w3:=segment addr
rl w3 x3 ;w3:=first addr(segment);
bz w0 1 ;w0:=rel
wa w3 0 ;w3:=segment+rel
dl w1 x3 ;w1:=item (ref out of this segment)
sh w1 -1 ;if long string then goto long string
jl. a4. ;goto long string
ds w1 x2+2 ;save first part
al w3 x3-4 ;x3:=addr next
a5: dl w1 x3 ;take next: (ref out of this segment?)
sh w1 -1 ;if long string then
jl. a6. ;goto next long
al. w3 c2. ;w3:=name addr
ds w1 x3+6 ;name 3,4:=second part
dl w1 x2+2 ;w1w0:=first part
ds w1 x3+2 ;name 1,2:=first part
rl. w1 (j12.) ;w1:=rel return addr
a7: jl. x1+0 ;return
a6: ;long string second item
bz w3 0 ;w3:=rel segm no
ls w3 1 ;w3:=w3*2
wa. w3 (j16.) ;w3:=segment
rl w3 x3 ;w3:=first addr(segment);
bz w0 1 ;w0:=rel
wa w3 0 ;w3:=addr second item
jl. a5. ;goto take second
e. ; end take string;
m. end code of this segment
h. 0,r.(:504-k:) ; fill up the segment
w. <:initcode <0>:>; alarm text
e. ; end slang segment
w.
; initcode:
g1:
g0: 1 ; first tail: area with 1 segment
0,0,0,0 ; fill
1<23+e1-e20 ; entry point initcode
3<18+40<12+41<6+41,0; integer procedure(undef,undef,general addr);
4<12+e0-e20 ; code proc , start of external
1<12+00 ; 1 code segment , bytes in perm. core
n.
message regretmess
lookup regretmess
if ok.yes
(scope temp regretmess gcdl
clear temp regretmess gcdl)
(regretmess=set 1
(regretmess=slang fpnames type.yes insertproc entry.no
regretmess gcdl )
scope project.drum gcdl
if ok.no
end
)
; HCØ 30 04 1974.
; b. ; fpnames dummy block
b. g1,e20 ; block with names for tails
k=0 ; and insertproc.
s. g2,j64,d2 ; start of slang segment for proc.
h.
g0=0 ; g0:=no of externals;
e20:
g1: g2 , g2 ; headword: rel of last point,
; rel of last abs word
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 expr
j8: g0+8 , 0 ; RS entry 8, end addres expression
j13: g0+13, 0 ; RS entry 13, last used
j30: g0+30, 0 ; RS entry 30, saved stack ref, saved w3
j42: g0+42, 0 ; RS entry 42, victim (start of RS-table)
g2=k-2-g1 ; end of abs word:=end of points;
w.
e0: g0 ; start of external list:
0 ; number of bytes to initialize
16 02 76,12 00 00 ; date and time of this version
; integer procedure regretmess(buf);
; address integer buf;
; regretmess:=result of monitor procedure regret message
e1: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take formals: buf
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression;
rl w2 x1 ;
jd 1<11+82 ; regret message
jl. (j8.) ; end address expr.
; long procedure gcdl(u,v);
; This algorithm finds the greatest common divisor
; of the two longs u and v.
; Special cases:
; gcdl(0,0) = 0
; gcdl(u,0) = abs u
b. i24, w. ; begin
0, i0: 0 ; u
0, i1: 0 ; v
0, i2: 1 ; long constant
i3: -1 ;
i4: 0 ; p
e2: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take formals: u
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
rs w1 x2+8 ;
dl w1 x2+12 ; take formals: v
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w0 x1 ;
sl w3 0 ; if v<0 then
jl. 8 ; v:=-v;
lx. w0 i3. ;
lx. w3 i3. ;
aa. w0 i2. ;
ds. w0 i1. ;
dl w0 (x2+8) ;
sl w3 0 ; if u<0 then
jl. 8 ; u:=-u;
lx. w0 i3. ;
lx. w3 i3. ;
aa. w0 i2. ;
ds. w0 i0. ;
lo w0 6 ;
sn w0 0 ;
jl. i6. ; if u>0
dl. w0 i1. ; and v>0 then
lo w0 6 ; goto Power of 2;
se w0 0 ;
jl. i8. ;
am -4 ; Special cases:
i6: dl. w1 i1. ; gcdl:=if u=0 then v else u;
jl. (j6.) ; end register expression
i8: al w1 0 ; Power of 2:
rs. w1 i4. ;
dl. w0 i0. ;
dl. w2 i1. ;
i10: sz w0 1 ;
jl. i12. ; for p:=0, p+1 while
sz w2 1 ; u is even and
jl. i14. ; v is even do
rx. w1 i4. ; begin
al w1 x1+1 ; u:=u/2;
rx. w1 i4. ; v:=v/2;
ld w0 -1 ; end;
ld w2 -1 ; p:=p-1;
ds. w0 i0. ;
ds. w2 i1. ;
jl. i10. ;
i12: lx. w1 i3. ;
lx. w2 i3. ; t:=if u is odd then -v
dl. w0 i2. ; else u;
aa w0 4 ;
i14: sz w0 1 ; Check t:
jl. i18. ; if t is odd then goto Reset;
i16: ad w0 -1 ; Halve t:
jl. i14. ; goto Check t;
i18: sl w3 1 ; Reset:
jl. i19. ;
sn w3 0 ;
sn w0 0 ;
jl. i20. ; if t>0 then
i19: ds. w0 i0. ; u:=t else
jl. i22. ; v:=-t;
i20: lx. w3 i3. ;
lx. w0 i3. ;
aa. w0 i2. ;
ds. w0 i1. ;
i22: dl. w0 i0. ; Sub:
ss. w0 i1. ; t:=u-v;
sn w3 0 ;
se w0 0 ; if t<>0 then
jl. i16. ; goto Halve t;
dl. w1 i0. ;
ld. w1 (i4.) ; gcdl:=u* 2**p;
jl. (j6.) ; end register expr.
e. ; end gcdl;
c.-1
; integer procedure calledfrom(skip);
; address integer skip;
; The stack is unwinded skip times. If the corresponding segment
; to this point of stack is not a main algol segment then lower
; line becomes negative.
; calledfrom:=lower line;
; skip:=-upper line;
b. i36, w. ; begin
i0: 0 ; first of prg.; upper line
i1: 0 ; stack bottom; inf1
i2: 31 ; mask: last 5 bits
i3: 3 ; mask: last 2 bits
i5: 0 ; current last used
0 ; current stack ref
0 ; current segment
0 ; current app, rel
e3: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take formals
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rs w1 x2+8 ;
rl w1 x1 ;
la. w1 i2. ;
rl. w3 j42. ;
rl w0 x3+46 ;
rl w3 x3+66 ; save first of prg. and stack bottom
ds. w0 i1. ;
rl w3 x2 ;
ds. w3 i5.+2 ; save cur last used and cur sref
dl w0 x2+4 ;
ds. w0 i5.+6 ; save return point;
i6: sn w1 0 ; for k:=upper step -1 until 0 do
jl. i8. ; unwind;
jl. w3 i24. ;
al w1 x1-1 ;
jl. i6. ;
i7: al w1 0 ; Set zero:
rs. w1 i0. ; upper line:=lower line:=0;
jl. i18. ; goto Lower found;
i8: rl. w3 (i5.+4) ; Find line interval:
rl. w0 i5.+6 ;
hs. w0 i13. ; relsegm:=rel of return point;
rl w1 x3+504 ;
ls w1 -11 ; upper line:=first line_inf shift (-11);
rs. w1 i0. ;
dl w1 x3+510 ;
rl. w2 i3. ;
la w2 2 ; save segment type
hs. w2 i19. ;
al w2 512 ; rel:=512;
ld w1 -3 ; inf:=last line_inf shift (-3);
i12: rs. w1 i1. ; Rep:
la. w1 i2. ; inf1:=inf extract 24;
sn w1 31 ; if inf1 extract 5 = 31 then
jl. i16. ; goto Lower on previous segment;
ac w1 x1 ;
wa. w1 i0. ; upper line:=upper line - inf1 extract 5;
rs. w1 i0. ;
al w2 x2-32 ; rel:=rel-32;
i13=k+1
sh w2 0 ; Note ; if rel<=relsegm then
jl. i18. ; goto Lower found;
rl. w1 i1. ;
ld w1 -5 ; inf:=inf shift (-5);
sn w2 512-9*32 ; if rel=limit for last line_inf then
dl w1 x3+506 ; inf:=first line_inf;
jl. i12. ; goto Rep;
i16: rl w0 x3+510 ; Lower on previous segment:
al w1 1 ; lower line:=1;
sz w0 4 ; if segment type = first segment then
jl. i18. ; goto Lower found;
rl. w3 i5.+4 ;
rl w3 x3-2 ; lower line:=prev segment.first line_inf
rl w1 x3+504 ; shift (-11);
ls w1 -11 ;
i18: rl. w2 (j13.) ; Lower found:
ac. w0 (i0.) ;
rs w0 (x2+8) ; upper:=-upper line;
i19=k+1
am 0 ; Note ;
se w1 x1-2 ; if segment type <> algol then
ac w1 x1 ; lower line:=-lower line;
jl. (j6.) ; calledfrom:=lower line;
; end register expr
; procedure unwind;
i22: 0,0 ; w3, w1
i24: rs. w3 i22. ; save w3
rs. w1 i22.+2 ; save w1
rl. w3 (i5.+4) ; k:=segment table(cur last used+2);
rl w0 x3+510 ; segment type:=segment.k.last two bits;
la. w0 i3. ;
sh w0 2 ; if segment type <> algol then
sh w0 0 ; goto Unwind call;
jl. i32. ;
rl. w1 i5.+2 ;
i28: sh. w1 (i1.) ; Next: if cur sref > stack bottom
sh. w1 (i0.) ; or cur sref <= first of prg. then
jl. i30. ; goto Unwind thunk;
rl w0 x1-2 ;
am. (i5.) ; if last used in block > cur last used then
sl w0 1 ; goto Unwind thunk;
jl. i30. ;
rs. w1 i5. ; Unwind block:
sl. w1 (i1.) ; current last used:=current stack ref;
jl. i7. ; if cur sref >= stack bottom then
; goto Set zero;
am (x1-4) ;
rl w1 x1+2 ; current stack ref:=word(blockno.+2);
jl. i28. ; goto Next;
i30: am -2 ; Unwind thunk: k:=cur last used;
i32: rl. w1 i5.+2 ; Unwind call: k:=cur stack ref;
bl w3 x1+4 ;
al w3 x3+6 ;
wa w3 2 ; cur last used:=k + appetite + 6;
rs. w3 i5. ;
dl w0 x1+4 ; save cur segment and cur app, rel
ds. w0 i5.+6 ;
rl w1 x1 ;
rs. w1 i5.+2 ; cur stack ref:=sref of return point;
rl. w1 i22.+2 ; restore w1
jl. (i22.) ; return;
e. ; end calledfrom;
z.
m. end code of this segment
h. 0,r.(:504-k:) ; fill up the segment
w. <:monproc <0>:>; alarm text
e. ; end slang segment
w.
; regretmess:
g0: 1 ; first tail: area with 1 segment
0,0,0,0 ; fill
1<23+e1-e20 ; entry point regretmess
3<18+19<12,0 ; integer procedure(addr integer);
4<12+e0-e20 ; code proc, start of external list
1<12+14 ; 1 code segment, bytes in perm core
; gcdl:
g1: 1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e2-e20 ; entry point gcdl
5<18+21<12+21<6,0 ; long procedure(addr long, addr long);
4<12+e0-e20 ; code proc, start of external list
1<12+14 ; 1 code segment, bytes in perm core
c.-1
; calledfrom:
g1: 1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e3-e20 ; entry point calledfrom
3<18+19<12,0 ; integer procedure(addr integer);
4<12+e0-e20 ; code proc, start of external list
1<12+14 ; 1 code segment, bytes in perm core
z.
n.
message alarm
lookup alarm
if ok.yes
(scope temp alarm gcd changebase alarmterm
clear temp alarm gcd changebase alarmterm)
(alarm=set 1
(alarm=slang fpnames type.yes insertproc entry.no
alarm gcd changebase alarmterm )
if ok.no
end
scope project.drum gcd changebase alarmterm
message permanent ok)
; HCØ 1 06 1973.
; b. ; fpnames dummy block
b. g1,e20 ; block with names for tails
k=0 ; and insertproc.
s. g12,j64,b18,d2,f12 ; start of slang segment for proc.
i24 ;
h.
g0=1 ; g0:=no of externals;
e20:
g1: g2 , g2 ; headword: rel of last point,
; rel of last abs word
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 expr
j8: g0+ 8, 0 ; RS entry 8, end address expr
j12: g0+12, 0 ; RS entry 12, UV
j13: g0+13, 0 ; RS entry 13, last used
j16: g0+16, 0 ; RS entry 16, segment table base
j21: g0+21, 0 ; RS entry 21, general alarm
j24: g0+24, 0 ; RS entry 24, blocksread
j27: g0+27, 0 ; RS entry 27, zone out
j29: g0+29, 0 ; RS entry 29, param alarm
j30: g0+30, 0 ; RS entry 30, saved stack ref, saved w3
j42: g0+42, 0 ; RS entry 42, victim
j48: 0, 11 ; start of stack chain: 8 bytes in perm core
j49: 1, g7 ; write, first ext., chain for rel point
j50: 0, 1 ; alarmterm
g2=k-2-g1 ; end of abs word:=end of points;
w.
e0: g0 ; start of external list:
2 ; number of bytes to initialize
0 ; alarmterm
w.
<:write:>,0,0 ; name
3<18+40<12+8<6,0 ; integer procedure(zone,general address);
02 03 77, 15 00 00; date and time of this version
; Constants:
f3: 6<12+23 ; zone formal
<:<10>:>
f9: 4<12+0 ; appetite increment
f10: <:<10>***alarm:> ;
; procedure alarm(source);
; general address source;
; The procedure works as if a call of write(out,source) and
; after this a call of the running system procedure
; general alarm has been called.
b. i12, w. ; begin
i0: 0 ; new stack top
e2: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
rl. w0 (j50.) ;
sn w0 2 ; if alarmterm = 2 then
jl. (j8.) ; end address expression;
al w1 -4 ;
jl. w3 (j3.) ; reserve 4 bytes in stack
rs. w1 i0. ; save new stack top
rl. w1 j42. ;
rl w1 x1+32 ;
rl w0 x2+4 ;
rs w0 x1+6 ; save old return information
dl w0 x2+2 ;
ds w0 x1+4 ;
rl. w1 i0. ;
rl. w0 g1. ;
rl w3 x2 ;
ds w0 x1+2 ; set return information
rl w0 x2+4 ;
wa. w0 f9. ;
al w3 g10 ;
hs w3 1 ;
rs w0 x1+4 ;
rl. w0 j27. ;
rl. w3 f3. ;
ds w0 x1+8 ;
rl. w3 (j49.) ; w3:=segment table(write);
g7=k+1-g1
g9=k+1-g1
jl x3 ; goto write and ; chain stops
g10=k-g1 ; Return to here:
rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
al w1 -6 ;
jl. w3 (j3.) ; reserve 6 bytes in stack
rl. w2 j42. ;
rl w2 x2+32 ;
dl w0 x2+4 ; restore old return
ds w0 x1+2 ;
bz w0 x2+7 ;
rs w0 x1+4 ;
ds. w2 (j30.) ;
rl. w0 (j50.) ;
sn w0 1 ; if alarmterm = 1 then
jl. (j8.) ; end address expression;
al. w0 f10. ;
rl. w1 (j24.) ;
jl. w3 (j21.) ; general alarm
e. ; end alarm;
; integer procedure gcd(u,v);
; This algorithm finds the greatest common divisor
; of the two integers u and v.
; Special cases:
; gcd(0,0) = 0
; gcd(u,0) = abs u
b. i24, w. ; begin
e3: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take formals: u
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
rs w1 x2+8 ;
dl w1 x2+12 ; take formals: v
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w3 x1 ;
rl w2 (x2+8) ;
sh w2 -1 ; if u<0 then
ac w2 x2 ; u:=-u;
sh w3 -1 ; if v<0 then
ac w3 x3 ; v:=-v;
sn w2 0 ; if u>0
jl. i2. ; and v>0 then
se w3 0 ; goto Power of 2;
jl. i4. ;
am -2 ; Special cases:
i2: rl w1 6 ; gcd:=if u=0 then v else u;
jl. (j6.) ; end register expr.
i4: al w1 0 ; Power of 2:
i6: sz w2 1 ;
jl. i8. ;
sz w3 1 ; for p:=0,p+1 while
jl. i10. ; u is even and
al w1 x1+1 ; v is even do
ls w2 -1 ; begin u:=u/2; v:=v/2; end;
ls w3 -1 ; p:=p-1;
jl. i6. ;
i8: ac w0 x3 ; if u is odd then
jl. i12. ; t:=-v else t:=u;
i10: al w0 x2 ;
i12: sz w0 1 ; Check t:
jl. i14. ; if t is odd then goto Reset;
i13: as w0 -1 ; Halve t: t:=t/2;
jl. i12. ; goto Check t;
i14: sh w0 0 ; Reset:
jl. i16. ; if t>0 then
rl w2 0 ; u:=t else
jl. i18. ; v:=-t;
i16: ac w3 (0) ;
i18: al w0 x2 ; Sub:
ws w0 6 ; t:=u-v;
se w0 0 ; if t<>0 then
jl. i13. ; goto Halve t;
ls w2 x1 ;
al w1 x2 ; gcd:=u*2**p;
jl. (j6.) ; end register expr.
e. ; end gcd;
; integer procedure change_base(name,displacement);
; undef name; integer dispalcement;
; Changes the address base of the internal process
; specified by name;
b. i2, w.
e4: ; entry change_base
rl. w2 (j13.) ; w2:=last used
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+12 ; take param displacement
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; saved stack ref, save w3
rs w1 x2+12 ; save displacement
dl w1 x2+8 ; get param name
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; saved stack ref, saved w3
jl. w3 d1. ; w3:=takestring name
rl w1 (x2+6) ; w1:=displ
jd 1<11+98 ; change base
rl w1 0 ; w1:=result
jl. (j6.) ; end register expression
e.
p.<:takestring:>
m. end code of this segment
h. 0,r.(:504-k:) ; fill up the segment
w. <:conproc <0>:>; alarm text
e. ; end slang segment
w.
; alarm:
g0: 1 ; modekind=backing store
0,0,0,0 ; fill
1<23+e2-e20 ; entry point alarm
1<18+40<12,0 ; procedure(general address);
4<12+e0-e20 ; code proc, start of external list
1<12+10 ; 1 code segment, bytes in perm core
; gcd:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e3-e20 ; entry point gcd
3<18+19<12+19<6,0 ; integer procedure(addr integer, addr integer);
4<12+e0-e20 ; code proc, start of external list
1<12+10 ; 1 code segment, bytes in perm core
; change_base:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e4-e20 ; entry point change_base
3<18+19<12+41<6,0; integer procedure(undef, addr integer);
4<12+e0-e20 ; code proc, start of external list
1<12+10 ; 1 code segment, bytes in perm core
; alarmterm:
g1: 1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1 ; byte address in own perm core
9<18, 0 ; integer variable
4<12+e0-e20 ; code proc, start of external list
1<12+10 ; 1 code segment, bytes in perm core
n.
message checkpda
lookup checkpda
if ok.yes
(scope temp checkpda packtext
clear temp checkpda packtext)
(checkpda=set 1
(checkpda=slang fpnames type.yes insertproc entry.no
checkpda packtext )
if ok.no
end
scope project.drum packtext
if ok.yes
message permanent ok)
; HCØ 01 03 1973.
; b. ; fpnames dummy block
b. g1,e20 ; block with names for tails
k=0 ; and insertproc
s. g6,j48,b18,d6 ; start of slang segment for proc.
h.
g0=0 ; g0:=no of externals;
e20:
g1: g2 , g2 ; headword: rel of last point,
; rel of last abs word
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 expr.
j8: g0+8 , 0 ; RS entry 8, end addres expr.
j12: g0+12, 0 ; RS entry 12, UV
j13: g0+13, 0 ; RS entry 13, last used
j16: g0+16, 0 ; RS entry 16, segment table base
j29: g0+29, 0 ; RS entry 29, param alarm
j30: g0+30, 0 ; RS entry 30,saved stack ref, saved w3
j42: g0+42, 0 ; RS entry 42, first of rs-table (victim)
g2=k-2-g1 ; end of abs word:=end of points;
w.
e0: g0 ; start of external list
0 ; number of bytes to initialize
03 08 73, 16 00 00; date, time
; boolean procedure check_pda(pda);
; address integer pda;
; It is checked about the pda is a process description
; or not.
w.
b. i6,w. ; begin
e1: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take param: pda
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w0 x1 ;
al w1 -1 ;
rl w2 72 ;
i2: sn w2 (80) ; for pd:=first process, next process
jl. i4. ; while pd<>pda and
sn w0 (x2) ; pd<>last process do;
jl. (j6.) ;
al w2 x2+2 ; checkpda:=if pd=pda then true
jl. i2. ; else false;
i4: al w1 0 ;
jl. (j6.) ; end register expr
e. ; end;
; procedure packtext(A,source);
; real array A; general address source;
; Every array is treated as a one-dimensional real array.
; The specified strings are packed into the array in this
; way:
; first string portion A(low+0) and A(low+1),
; second string portion A(low+2) and A(low+3),
; etc.
; At most 12 characters are moved from every string and
; unused elements are cleared.
b. i12, w. ; begin
e2: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
al w0 2.11111 ;
la w0 x2+6 ;
sh w0 22 ;
sh w0 15 ; if not array or zone then
jl. w3 (j29.) ; param alarm;
rl w1 x2+8 ;
ba w1 x2+6 ;
rl w3 x1 ;
wa w3 (x2+8) ; get absolute addres of
al w3 x3+4 ; the array A
rs w3 x2+8 ;
rl. w3 j42. ;
rl w3 x3+32 ;
al w0 x2+6 ;
ba w0 x2+4 ;
rs w0 x3 ; upper limit:=stack ref + appetite + 6;
al w1 x2+6 ;
rs w1 x2+6 ; cur param:=second param;
i2: rl w1 x2+6 ;
al w1 x1+4 ; cur param:=cur param+4;
rs w1 x2+6 ;
rl. w3 j42. ;
rl w3 x3+32 ;
am (x3) ;
sl w1 -3 ; if cur param>=upper limit then
jl. (j8.) ; end address expression;
dl w1 x1+2 ; take formals
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl. w3 j42. ;
rl w3 x3+32 ;
sl w1 (x3) ; if abs address<upper limit and
jl. i4. ; abs address>=first param then
sl w1 x2+6 ; upper limit:=abs address;
rs w1 x3 ;
i4: rl w2 x2+6 ; w2:=address of first formal;
jl. w3 d0. ; take string;
rl. w2 (j13.) ; w2:=last used;
dl w1 x3+2 ;
ds w1 (x2+8) ; move string to
dl w1 x3+6 ; the array
am (x2+8) ;
ds w1 4 ;
rl w1 x2+8 ;
al w1 x1+8 ;
rs w1 x2+8 ;
jl. i2. ; goto LOOP;
e. ; end packtext;
c.-1
; integer procedure cleanbuf(pda);
; The message buffer pool is scanned for message buffers with a
; sender equal to pda, and then they are regretted.
; The value of pda should either be zero or an internal process
; description address. When zero the current internal process
; is understood.
; The result when positive of cleanbuf is the number of
; unsuccesfully attempt to regret, otherwise when negative pda
; does not descripe an internal process.
; address integer pda;
b. i24, w. ; begin
i0: 0 ;
e3: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take formals: pda
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w0 x1 ;
se w0 0 ; if pda=0 then
jl. i4. ; begin
rl w0 66 ; pda:=current internal process;
jl. i8. ; goto Found;
; end;
i4: rl w1 78 ;
i6: rl w3 x1 ; Loop:
sn w0 x3 ; for P:=first internal, next internal
jl. i8. ; while P<>pda
al w1 x1+2 ; and P<>last process do;
se w1 (80) ; if P<>pda then
jl. i6. ; begin
al w1 -1 ; cleanbuf:=-1; return;
jl. (j6.) ; end;
i8: rl. w1 j42. ; Found:
rl w1 x1+48 ; sp_buf:=spare mess buf;
rs. w1 i0. ;
rl w3 0 ;
rl w2 86 ;
al w1 0 ; k:=0;
i10: al w0 0 ; for buf:=first message buffer,
se w3 (x2+6) ; next message buffer
jl. i16. ; while buf<message pool end do
se w3 (66) ; if buf.sender=pda then
jl. i12. ; begin
sn. w2 (i0.) ; if pda<>cur internal process
jl. i16. ; and buf<>sp_buf then
i12: jd 1<11+84 ; begin
se w0 0 ; if regretmessage(buf)<>0 then
al w1 x1+1 ; k:=k+1;
i16: wa w2 90 ; end;
sl w2 (88) ; end buf;
jl. (j6.) ; cleanbuf:=k;
jl. i10. ; end register expression.
e. ; end cleanbuf;
z.
p.<:takestring:>
m. end code of this segment
h. 0,r.(:504-k:) ; fill up the segment
w. <:intproc <0>:>; alarm text
e. ; end slang segment
w.
; checkpda:
g0: 1 ; first tail: area with 1 segment
0,0,0,0 ; fill
1<23+e1-e20 ; entry point checkpda
2<18+19<12,0 ; boolean procedure(address integer);
4<12+e0-e20 ; code proc , start of external
1<12+00 ; 1 code segment , bytes in perm. core
; packtext:
g1: 1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e2-e20 ; entry point packtext
1<18+40<12+26<6,0 ; procedure(real,general address);
4<12+e0-e20 ; code proc , start of external
1<12+00 ; 1 code segment , bytes in perm. core
c.-1
; cleanbuf:
g1: 1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e3-e20 ; entry point cleanbuf
3<18+19<12+00<6,0 ; procedure(address integer);
4<12+e0-e20 ; code proc , start of external
1<12+00 ; 1 code segment , bytes in perm. core
z.
n.
\f
message unstackcuri
lookup unstackcuri
if ok.yes
(scope temp unstackcuri connectcuri unstackcuro connectcuro outendcur,
incharcur outcharcur closeout
clear temp unstackcuri connectcuri unstackcuro connectcuro outendcur,
incharcur outcharcur closeout)
(unstackcuri=set 1
(unstackcuri=slang fpnames type.yes insertproc entry.no
unstackcuri connectcuri unstackcuro,
connectcuro outendcur incharcur outcharcur closeout)
if ok.no
end
scope project.drum connectcuri,
unstackcuro connectcuro outendcur,
incharcur outcharcur closeout
message permanent ok)
; HCØ 12 02 1973.
; Heinrich Bjerregaard.
; b. ; fpnames dummy block
b. g1,e20 ; block with names for tails
k=0 ; and insertproc.
s. g6,j64,b18,d2,f12,i24; start of slang segment for proc.
h.
g0=2 ; g0:=no of externals;
e20:
g1: g2 , g2 ; headword: rel of last point,
; rel of last abs word
j4: g0+ 4, 0 ; RS entry 4, take expression
j6: g0+ 6, 0 ; RS entry 6, end register expr
j8: g0+ 8, 0 ; RS entry 8, end address expr
j12: g0+12, 0 ; RS entry 12, UV
j13: g0+13, 0 ; RS entry 13, last used
j16: g0+16, 0 ; RS entry 16, segment table base
j29: g0+29, 0 ; RS entry 29, param alarm
j30: g0+30, 0 ; RS entry 30, saved stack ref, saved w3
j42: g0+42, 0 ; RS entry 42, victim
j48: 0, 1 ; start of stack chain: 8 bytes in perm core
j49: 1, 0 ; instacked
j50: 2, 0 ; outstacked
g2=k-2-g1 ; end of abs word:=end of points;
w.
e0: g0 ; start of external list:
0 ; number of bytes to initilise
w. <:instacked:>,0 ;
9<18,0 ;
<:outstacked:> ;
9<18,0 ;
12 02 73, 15 00 00; date and time of this version
; Constants:
f8: 8.377<16
; procedure stackcuri and connectcuri;
; Makes a FP-call as descriped in the fp-
; manual.
e2: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
am. (j42.) ;
am (32) ;
jl w3 h29-4 ; stack current input
jl. e4. ; end addresss expr
; procedure unstackcuri;
; Makes a fp-call as descriped in the fp-
; manual.
e3: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
rl. w2 j42. ;
rl w2 x2+32 ;
jl w3 x2+h79-4 ; terminate current input
jl w3 x2+h30-4 ; unstack current input
rl. w3 (j49.) ;
al w3 x3-1 ;instacked:=instacked-1
rs. w3 (j49.) ;
jl. (j8.) ; end address expr
; integer procedure connectcuri(name);
; connectcuri:=status;
; Makes a fp-call as descriped in the fp-
; manual.
e4: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take param: name
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
jl. w3 d1. ; w3:=takestring1(name);
al w2 x3 ; w2:=address of name;
am. (j42.) ;
am (32) ;
jl w3 h27-2 ; connect current input
rl w1 0 ; connectcuri:=result;
rl. w3 (j49.) ;
al w3 x3+1 ; instacked:=instacked+1
rs. w3 (j49.) ;
jl. (j6.) ; end register expr
; procedure stackcuro and connectcuro;
; Stacks current output by use of then filepro-
; cesser as descriped in the fp-manual.
e5: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
rl. w3 j42. ;
rl w3 x3+32 ; get base of fileprocesser
al w1 x3+h21 ; get current output zone
rl. w2 j48. ; get stack chain for current output
jl w3 x3+h29 ; stack current output
jl. e7. ; end address expr.
; procedure unstackcuro;
; Makes a fp-call to unstack current output as
; descriped in the fp-manual.
e6: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
i0: rl. w2 j42. ;
rl w2 x2+32 ; get base of fileprocesser
jl w3 x2+h79-2 ; terminate current output
rl. w3 j48. ;
rx w2 6 ; get stack chain for current output
jl w3 x3+h30 ; unstack current output
rl. w3 (j50.) ;
al w3 x3-1 ;outstacked:=outstacked-1
rs. w3 (j50.) ;
jl. (j8.) ; end address expr.
; procedure connectcuro(name);
; string or <any type array> name;
; Makes a fp-call to connect current output as
; descriped in the fp-manual.
e7: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; get param: name
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
jl. w3 d1. ; w3:=takestring1(name);
al w2 x3 ; w2:=address of name;
am. (j42.) ;
am (32) ;
al w1 x2+h21 ;
al w0 2 ;
am. (j42.) ;
am (32) ;
jl w3 h28-2 ; connect current output
rl w1 0 ; connectcuro:=result;
rl. w3 (j50.) ;
al w3 x3+1 ;outstacked:=outstacked+1
rs. w3 (j50.) ;
jl. (j6.) ; end register expr.
; procedure outendcur(char);
; Makes a call of the FP-procedure outend with
; the parameter char as the character to be output.
e8: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take param: char
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w2 x1 ;
am. (j42.) ;
am (32) ;
jl w3 h33-2 ; outend(out,false add char);
jl. (j8.) ; end address expr.
; integer procedure incharcur;
; This procedure makes a call of the fp-procedure
; inchar, as descriped in the fp-manual page 47.
e9: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
am. (j42.) ;
am (32) ;
jl w3 h25-2 ; inchar:=next char from current
al w1 x2 ; input;
jl. (j6.) ; end register expr.
; integer procedure outcharcur(char);
; address integer char;
; Makes a call of the fp-procedure outchar as descriped
; in the fp-manual page 47.
; charout:=numbers of characters printed;
e10: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take param: char
so w0 16 ; if exppr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
al w0 0 ;
rs. w0 b0. ; count:=0;
rl w0 x1 ;
al. w3 2 ;
rl w2 0 ; for c:=1,2,3 do
la. w2 f8. ; begin
sn w0 0 ; if char.c=NULL then else
al. w3 g5. ; begin
ls w0 8 ;
sn w2 0 ;
jl x3 ;
rx. w2 b0. ;
al w2 x2+1 ; count:=count+1;
rx. w2 b0. ;
ls w2 -16 ;
am. (j42.) ;
am (32) ; outchar(char.c);
jl h26-2 ; end;
g5: rl. w1 b0. ; end;
jl. (j6.) ; end register expr.
; procedure closeout;
; Makes a call of the fp-procedure closeup as
; descriped in the fp-manual page ***. After this the procedure
; unstackcuro is called;
e11: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
al w2 25 ;
am. (j42.) ;
am (32) ;
jl w3 h34-2 ; closeup on current output
jl. i0. ;
b0: 0 ; work area
p.<:takestring:>
m. end code of this segment
h. 0,r.(:504-k:) ; fill up the segment
w. <:fpproc <0>:>; alarm text
e. ; end slang segment
w.
; unstackcuri:
g0: 1 ; first tail: area with 1 segment
0,0,0,0 ; fill
1<23+e3-e20 ; entry point unstackcuri
1<18,0 ; procedure;
4<12+e0-e20 ; code proc, start of external list
1<12+08 ; 1 code segment, bytes in perm core
; connectcuri:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e2-e20 ; entry point connectcuri
3<18+40<12,0 ; procedure(undef);
4<12+e0-e20 ; code proc, start of external list
1<12+08 ; 1 code segment, bytes in perm core
; unstackcuro:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e6-e20 ; entry point unstackcuro
1<18,0 ; procedure;
4<12+e0-e20 ; code proc, start of external list
1<12+08 ; 1 code segment, bytes in perm core
; connectcuro:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e5-e20 ; entry point connectcuro
3<18+40<12,0 ; integer procedure(undef);
4<12+e0-e20 ; code proc, start of external list
1<12+08 ; 1 code segment, bytes in perm core
; outendcur:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e8-e20 ; entry point outend
1<18+19<12,0 ; procedure(address integer);
4<12+e0-e20 ; code proc, start of external list
1<12+08 ; 1 code segment, bytes in own perm core
; incharcur:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e9-e20 ; entry point inchar
3<18+00<12,0 ; integer procedure;
4<12+e0-e20 ; code proc, start of external list
1<12+08 ; 1 code segment, bytes in perm core
; outcharcur:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e10-e20 ; entry point charout
3<18+19<12,0 ; integer procedure(address integer);
4<12+e0-e20 ; code proc, start of external list
1<12+08 ; 1 code segment, bytes in own perm core
; closeout:
g1: 1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e11-e20 ; entry point closeout
1<18+00<12,0 ; procedure;
4<12+e0-e20 ; code proc, start of external list
1<12+08 ; 1 code segment, bytes in perm core
n.
message starti
lookup starti
if ok.yes
(scope temp starti stopi sendm waita waitevent getevent testbit moveb,
wordl senda gencopy messadd pda ba from to bytes coreaddr result
clear temp starti stopi sendm waita waitevent getevent testbit moveb ,
wordl senda gencopy messadd pda ba from to bytes coreaddr result)
(starti=set 1
(starti=slang fpnames type.yes insertproc entry.no
starti stopi sendm waita waitevent getevent,
testbit moveb wordl senda gencopy messadd pda ba from to bytes,
coreaddr result)
if ok.no
end
scope project.drum stopi sendm waita waitevent,
getevent testbit moveb wordl senda gencopy messadd,
pda ba from to bytes coreaddr result
if ok.yes
message permanent ok)
;HCØ 1980-02-06
; These code procedures uses 8 std. variabels:
; 1. messadd address of a message_area
; 2. pda address of the internal process descrip-
; tion address
; 3. ba buffer address
; 4. from start address of an array
; 5. to start address of an array
; 6. bytes no of bytes to be moved
; 7. coreaddr address of a storage word
; 8. result normally the result of the monitor proc.
; b. ; fpnames dummy block
b. g1,e20 ; block with names for tails
k=10000 ; and insertproc
s. g6,j58,b6,f6,i1 ; start of slang segment for proc.
h.
g0=0 ; g0:=no of externals;
e20:
g1: g2 , g2 ; headword: rel of last point,
; rel of last abs word
j4: g0+4 , 0 ; RS entry 4, take expression
j6: g0+6 , 0 ; RS entry 6, end register expr.
j8: g0+8 , 0 ; RS entry 8, end addres expr.
j13: g0+13, 0 ; RS entry 13, last used
j30: g0+30, 0 ; RS entry 30,saved stack ref, saved w3
j41: g0+41, 0 ; RS entry 41,parent process address
j51: 0, 1 ; 1. std. variable: messadd
j52: 0, 3 ; 2. std. variable: pda
j53: 0, 5 ; 3. std. variable: ba
j54: 0, 7 ; 4. std. variable: from
j55: 0, 9 ; 5. std. variable: to
j56: 0, 11 ; 6. std. variable: bytes
j57: 0, 13 ; 7. std. variable: coreaddr
j58: 0, 15 ; 8. std. variable: result
g2=k-2-g1 ; end of abs word:=end of points;
w.
e0: g0 ; start of external list
0 ;
26 06 73, 18 00 ;
b0: 0, b1: 0,r.4 ; process name
; integer procedure starti;
; starti:=result of monitorproc;
e1: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref,saved w3
rl. w2 (j52.) ;
al. w3 b0. ; w3:=process name address
dl w1 x2+4
ds w1 x3+2
dl w1 x2+8
ds w1 x3+6
jd 1<11+58 ; start internal process;
rl w1 0 ; starti:=result;
jl. (j6.) ; end of register expr.
; integer procedure stopi;
; stopi:=buffer address;
e2: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
rl. w2 (j52.) ;
al. w3 b0. ; w3:=process name address
dl w1 x2+4
ds w1 x3+2
dl w1 x2+8
ds w1 x3+6
jd 1<11+60 ; stop internal process
rs. w0 (j58.) ; result:=w0;
al w1 x2 ; stopi:=buffer address;
jl. (j6.) ; end of register expr.
; integer procedure sendm;
; sendm:=buffer address;
e3: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
al. w3 b0. ; w3:=process name address;
rl. w2 (j52.) ; w2:=process description address;
rs w2 x3+8 ; saved description address
dl w1 x2+4 ;
ds w1 x3+2 ; move process name
dl w1 x2+8 ;
ds w1 x3+6 ;
rl. w1 (j51.) ; w1:=message address;
jd 1<11+16 ; send message
al w1 x2 ; sendm:=buffer address;
jl. (j6.) ; end register expr.
; integer procedure waita;
; waita:=result of monitorproc;
e4: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
rl. w1 (j51.) ; w1:=answer address;
rl. w2 (j53.) ; w2:=buffer address;
jd 1<11+18 ; wait answer;
rl w1 0 ; waita:=result;
jl. (j6.) ; end register expr.
; integer procedure waitevent(ba);
; integer ba;
; waitevent:=result of monitorproc;
; the spare message buffer is however sorted out
e5: rl. w2 (j13.) ; w2:=last used
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take integer param
so w0 16 ; if expression then
jl. w3 (j4.) ; goto RS take expression
ds. w3 (j30.) ; saved stack ref, saved w3
rl w2 x1 ; w2:=last buffer address
i0: jd 1<11+24 ; wait event
am. (j41.) ; if
rl w1 -2 ; buffer address=spare then
sn w1 x2 ; goto
jl. i0. ; next;
rl w1 4 ; w1:=buf
rx w1 0 ; w1:=result, w0:=buf
dl. w3 (j30.) ; w3:=stack ref
rs w0 (x2+8) ; buffer_address:=next_buffer_address
jl. (j6.) ; end regeister expression
; procedure getevent(ba);
; integer ba;
e6: rl. w2 (j13.) ; w2:=last used
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take param ba
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; save stack ref, save w3
rl w2 x1 ; w2:=buffer_address
jd 1<11+26 ; get event
jl. (j8.) ; end address expression
; boolean procedure testbit(word,bitno);
; integer word,bitno;
; testbit:=if bitno of word is on then true else false;
e8: rl. w2 (j13.) ; w2:=last used
ds. w3 (j30.) ; save stack ref, save w3
dl w1 x2+8 ; take param word
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; save stack ref, save w3
rs w1 x2+8 ;
dl w1 x2+12 ; take param bitno
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; save stack ref, save w3
rl w1 x1 ; w1:=bitno
al w3 1 ;
ls w3 x1 ; w3:=1 shift bitno
rl w1 (x2+8) ; w1:=word
so w1 x3 ; if bit=1 then
am 1 ; true else
al w1 -1 ; false
jl. (j6.) ; end register expression
; procedure moveb;
; std. variabels used: from,to and bytes.
; Nothing is done if bytes is less than or equal
; to zero - no of bytes must be even.
e9: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
rl. w3 (j56.) ; w3:=no of bytes to transfer;
sh w3 1 ; if bytes<=1 then
jl. (j8.) ; end address expr.;
rl. w1 (j54.) ;
rl. w2 (j55.) ; saved address' of form and to
ds. w2 b1. ;
f0: al w3 x3-4 ;
sh w3 -1 ; for bytes:=bytes-4 while bytes>=0 do
jl. f1. ; begin long L;
am. (b0.) ; L:=bytes;
dl w1 x3+2 ; to.L:=from.L;
am. (b1.) ; end;
ds w1 x3+2 ;
jl. f0. ;
f1: sn w3 0 ; if bytes=0 then
jl. (j8.) ; end address expr.;
rl. w1 (b0.) ; L:=0;
rs. w1 (b1.) ; to.L:=from.L;
jl. (j8.) ; end address expr.
; integer procedure word_l;
; std. variable used: coreaddr
; wordl:=word(coreaddr);
e10: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
am. (j57.) ;
rl w1 (0) ; wordl:=word(coreaddr);
jl. (j6.) ; end register expr.
; procedure send_a;
; std. variables used: result,ba,messadd
e11: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
rl. w0 (j58.) ; w0:=result;
rl. w1 (j51.) ; w1:=answer address;
rl. w2 (j53.) ; w2:=buffer address;
jd 1<11+22 ; send answer;
jl. (j8.) ; end address expr.
e12: ; entry general copy
rl. w2 (j13.) ; w2:=last used
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take param buffer
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; save stack ref, save w3
rs w1 x2+6 ; save address(buffer);
dl w1 x2+12 ; take param params
ba w1 0 ; w1:=abs dope
rl w3 x1 ; w3:=lower index-2
wa w3 (x2+12) ;
al w1 x3+2 ; w1:=first addr(param)
rl w2 (x2+6) ; w2:=buf
jd 1<11+84 ; general copy
rx w1 0 ; w1:=result, w0:=moved
rl. w2 (j13.) ; w2:=last used
rs w0 (x2+16) ;
jl. (j6.) ; end register expression
m. end code of this segment
h. 0,r.(:10504-k:) ; fill
w. <:p-proc <0>:> ; alarm text
e. ; end slang segment;
w.
; starti:
g0: 1 ; first tail: area with 1 segment
0,0,0,0 ; fill
1<23+e1-e20 ; entry point starti
3<18+0,0 ; integer procedure;
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment , bytes in permanent store
; stopi:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e2-e20 ; entry point stopi
3<18+0,0 ; integer procedure;
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment , bytes in permanent store
; sendm:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e3-e20 ; entry point sendm
3<18+0,0 ; integer procedure;
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment , bytes in permanent store
; waita:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e4-e20 ; entry point waita
3<18+0,0 ; integer procedure;
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment , bytes in permanent store
; waitevent:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e5-e20 ; entry point waitevent
3<18+19<12,0 ; integer procedure(address integer);
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment , bytes in permanent store
; getevent:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e6-e20 ; entry point getevent
1<18+19<12,0 ; procedure(address integer);
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment , bytes in permanent store
; testbit:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e8-e20 ; entry point testbit
2<18+19<12+19<6,0 ; boolean procedure(integer,integer);
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment , bytes in permanent store
; moveb:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e9-e20 ; entry point moveb
1<18+0,0 ; procedure;
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment , bytes in permanent store
; wordl:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e10-e20 ; entry point wordl
3<18+0,0 ; integer procedure;
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment, bytes in perm. store
; senda:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e11-e20 ; entry point senda
1<18+0,0 ; procedure;
4<12+e0-e20 ; code proc , start of external
1<12+16 ; 1 code segment, bytes in perm. store
; gencopy:
1<23+4 ; mode kind=bs
0,0,0,0 ; fill
1<23+e12-e20 ; entry point gencopy
3<18+19<12+25<6+19,0; integer procedure(integer,integer array,integer);
4<12+e0-e20 ; code proc, start external
1<12+16 ; 1 code segemnt. bytes in own core
; messadd:
1<23+4 ; modekind=backingstore
0,0,0,0 ; fill
1 ; byte 1 in permanent store
9<18+0,0 ; integer variabel;
4<12 ; code proc
1<12+16 ; 1 code segment , bytes in permanent store
; pda:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
3 ; byte 3 in permanent store
9<18+0,0 ; integer variabel;
4<12 ; code proc
1<12+16 ; 1 code segment , bytes in permanent store
; ba:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
5 ; byte 5 in permanent store
9<18+0,0 ; integer variabel;
4<12 ; code proc
1<12+16 ; 1 code segment , bytes in permanent store
; from:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
7 ; byte 7 in permanent store
9<18+0,0 ; integer variabel;
4<12 ; code proc
1<12+16 ; 1 code segment , bytes in permanent store
; to:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
9 ; byte 9 in permanent store
9<18+0,0 ; integer variabel;
4<12 ; code proc
1<12+16 ; 1 code segment , bytes in permanent store
; bytes:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
11 ; byte 11 in permanent store
9<18+0,0 ; integer variabel;
4<12 ; code proc
1<12+16 ; 1 code segment , bytes in permanent store
; coreaddr:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
13 ; byte 13 in permanent store
9<18+0,0 ; integer variabel;
4<12 ; code proc
1<12+16 ; 1 code segment , bytes in permanent store
; result:
g1: 1<23+4 ; modekind=backing store
0,0,0,0 ; fill
15 ; byte 15 in permanent store
9<18+0,0 ; integer variabel;
4<12 ; code proc
1<12+16 ; 1 code segment , bytes in permanent store
n.
message callpr
lookup callcode
if ok.yes
(scope temp callcode
clear temp callcode)
callcode=set 1
((callcode=slang fpnames type.yes insertproc entry.no
callcode )
if ok.no
end
)
; b. ; fpnames dummy block
b. g1,e20 ; block with names for tails
k=0 ; and insertproc.
m.callcode
s. g6,j48,d6,i24 ; start of slang segment for proc.
h.
g0=0 ; g0:=no of externals;
e20:
g1: g2 , g2 ; headword: rel of last point,
; rel of last abs word
j4: g0+4 , 0 ; RS entry 4, take expression
j6: g0+6 , 0 ; RS entry 6, end register expr.
j13: g0+13, 0 ; RS entry 13, last used
j30: g0+30, 0 ; RS entry 30,saved stack ref, saved w3
g2=k-2-g1 ; end of abs word:=end of points;
w.
e0: g0 ; start of external list
0 ; number of bytes to initialize
w. 14 01 73, 18 00 00; date, time
; integer procedure call_code(A,relative);
; <any type> array A; address integer relative;
; call_code:=what the user specifies;
; Initialize the working registers, save a return
; address in A and jumps to the first instr. to execute
; in A with w3 as link.
e2: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+12 ; take second param: relative
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rs w1 x2+12 ;
dl w1 x2+8 ;
jl. w3 d2. ; find first addr of A
al. w0 i20. ;
rs w0 x1+0 ; A(0):=return address;
rl w3 x1+2 ; first instr:=A(1)+relative;
wa w3 (x2+12) ;
al w0 0 ; w0:=0;
rl w2 x1+4 ; w2:=appetite; (A(2))
jl w3 x3 ; goto first instr. to execute;
i20: jl. (j6.) ; end register expr.
; integer procedure absaddr;
; Finds the address of a variable or the first
; address of an array. A zone is treated as a real array.
; at entry at return
; w0 formal1 destroyed
; w1 formal2 abs address
; w2 not used unchanged
; w3 link kind
b. b6,w.
b0: 0 ; link
b1: 0 ; formal2
d2: rs. w3 b0. ; save link
rs. w1 b1. ; save formal2
al w3 2.11111 ;
la w3 0 ; kind:=formal1 extract 5;
sn w3 23 ; if kind=zone then
al w3 19 ; kind:=real array;
sl w3 16 ; if kind<16
sl w3 23 ; or kind>22 then
jl. b2. ; begin
; absaddr:=addr(variable);
; end else
ba w1 0 ; begin
rl w1 x1 ; w1:=abs dope addr;
wa. w1 (b1.) ; w1:=lower index-1; (even)
am 2 ; absaddr:=abs addr of first element;
b2: al w1 x1-1 ;
jl. (b0.) ; end;
e. ; return
m. end code of this segment
h. 0,r.(:504-k:) ; fill up the segment
w. <:callcode <0>:>; alarm text
e. ; end slang segment
w.
; callcode:
g0:
g1: 1 ; first tail: area with 1 segment
0,0,0,0 ; fill
1<23+e2-e20 ; entry point callcode
3<18+19<12+41<6,0 ; integer procedure(undef,address integer);
4<12+e0-e20 ; code proc , start of external
1<12+00 ; 1 code segment , bytes in perm. core
n.
message sendmessid
lookup sendmessid
if ok.yes
(scope temp redefarray sendmessid generaten zonedes releaseproc rstable,
integerexor exclude include
clear temp redefarray sendmessid generaten zonedes releaseproc rstable,
integerexor exclude include)
(sendmessid=set 1
(sendmessid=slang fpnames type.yes insertproc entry.no
sendmessid redefarray generaten zonedes,
releaseproc rstable integerexor exclude include)
if ok.no
end
scope project.drum,
redefarray generaten zonedes releaseproc rstable ,
integerexor exclude include
if ok.yes
message permanent ok)
; HCØ 29 08 1972.
; b. ; fpnames dummy block
b. g1,e20 ; block with names for tails
k=0 ; and insertproc
s. g6,j48,b18,d6 ; start of slang segment for proc.
h.
g0=0 ; g0:=no of externals;
e20:
g1: g2 , g2 ; headword: rel of last point,
; rel of last abs word
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 expr.
j8: g0+8 , 0 ; RS entry 8, end addres expr.
j12: g0+12, 0 ; RS entry 12, UV
j13: g0+13, 0 ; RS entry 13, last used
j16: g0+16, 0 ; RS entry 16, segment table base
j29: g0+29, 0 ; RS entry 29, param alarm
j30: g0+30, 0 ; RS entry 30,saved stack ref, saved w3
j42: g0+42, 0 ; RS entry 42, victim
g2=k-2-g1 ; end of abs word:=end of points;
w.
e0: g0 ; start of external list
0 ; number of bytes to initialize
w. 17 12 72, 16 00 00; date, time
b0: 0, b1: 0,r.3 ; work area
b2: 0,r.5 ;
j48: rl w1 0 ; END: pr:=result;
jl. (j6.) ; end register expr.
; integer procedure send_mess_id(name,id,M);
; undef name; integer id;
; integer array M;
; send_mess_id:=result of monitor procedure;
;
e2: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+12 ;
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rs w1 x2+12 ; saved second param
dl w1 x2+16 ;
ba w1 0 ; w1:=abs dope
rl w3 x1 ; w3:=lower index -2
wa w3 (x2+16) ;
al w3 x3+2 ;
rs w3 x2+14 ; save mess add
dl w1 x2+8 ;
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
jl. w3 d1. ; w3:=takestring name
al w2 x2-6 ; adjust last used
rl w1 x2+14 ; w1:=messadd;
rl w2 x2+12 ; w2:=id
jd 1<11+16 ; send message
rl w1 4 ; result:=buffer address
jl. (j6.) ; end register expression
; procedure redef_array(A,first,elements);
; value first,elements; integer first,elements;
; <any type> array A;
; comment changes the base and dope such that first is the
; first byte of the new array and elements is the
; number of elements;
e4: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref,saved w3
dl w1 x2+16 ;
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rs w1 x2+16 ; saved third param
dl w1 x2+12 ;
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w1 x1 ; w1:=first;
al w1 x1-2 ;
rs w1 (x2+8) ; base word:=first;
bz w0 x2+7 ; kind:=byte1.formal1;
al w3 4 ; K:= 4;
sn w0 17 ; if kind=boolean then
al w3 1 ; K:= 1;
sn w0 18 ; if kind=integer then
al w3 2 ; K:= 2;
rl w1 x2+8 ;
ba w1 x2+6 ; w1:=absolute dope address;
al w0 0 ; dope:=0;
rs w0 x1 ;
wm w3 (x2+16) ; low index:=0;
rs w3 x1-2 ; upper index:=elements*K;
jl. (j8.) ; end address expr.
; integer procedure generate_n(A);
; <any type> array A;
; generate_n:=result of monitor proc;
e5: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ;
ba w1 0 ; w1:=abs dope address;
rl w3 x1 ; w3:=low index-K;
wa w3 (x2+8) ;
al w3 x3+2 ; w3:=addr of first element;
jd 1<11+68 ; generate name
jl. j48. ; goto END;
; integer procedure zone_des(z);
; zone or zone array z;
; zonedes:=absolute address of the zone descriptor;
e6: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w1 x2+8 ; zonedes:=addr of zone;
jl. (j6.) ; end register expression.
; procedure release_proc(name);
; string or <any type array name;
e7: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take parameter name
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
jl. w3 d1. ; w3:=take string1(name);
jd 1<11+10 ; release process
jl. (j8.) ; end address expr.
; integer procedure rstable;
; rstable:=first address of the RS-table (victim);
e8: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
rl. w1 j42. ; rstable:=first addr of rs-table;
jl. (j6.) ; end register expr.
; integer procedure integer_exor(i1,i2);
; address integer i1,i2;
; The machine operation lx is made on i1 and i2,
; and the result is delivered in the procedure.
e9: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take first param
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rs w1 x2+8 ;
dl w1 x2+12 ; take second param
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w1 x1 ;
lx w1 (x2+8) ; integerexor:=i1 lx i2;
jl. (j6.) ;
; integer procedure exclude(name,devno);
; string or <any type array> name;
; address integer devno;
e10: rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref ,save w3
dl w1 x2+12 ;take second parm: devno
so w0 16 ;if expr then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
rs w1 x2+12 ;
dl w1 x2+8 ;take first param: name
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save satck ref ,save w3
jl. w3 d1. ;w3:=take string
rl w1 (x2+ 6) ;
jd 1<11+14 ;exclude
jl. j48. ;goto end;
; integer procedure include(name,devno);
; string or <any type array> name;
; address integer devno;
e11: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+12 ; take second param: devno
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3 (new stack top)
rs w1 x2+12 ;
dl w1 x2+8 ; take first param: name
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
jl. w3 d1. ; w3:=take string1(name);
rl w1 (x2+ 6) ;
jd 1<11+ 12 ;include
jl. j48. ; goto END;
p.<:takestring:>
b11: 0, b12: 0 ; zeroes
b13: 0, b14: 0 ; work area item
b15: 2.1 1111 ; kind mask
m. end code of this segment
h. 0,r.(:504-k:) ; fill up the segment
w. <:mixproc <0>:>; alarm text
e. ; end slang segment
w.
; send_mess_id:
g0: 1 ; modekind=backing store
0,0,0,0 ; fill
1<23+e2-e20 ; entry point send_mess_id
3<18+25<12+19<6+41; integer procedure(undef,
0 ; address integer,integer array);
4<12+e0-e20 ; code proc , start of external
1<12+0 ; 1 code segment , bytes in perm. core
; redefarray:
1<23+4 ; first tail: area with 1 segment
0,0,0,0 ; fill
1<23+e4-e20 ; entry point redefarray
1<18+19<12+19<6+41; procedure(undef,address integer,
0 ; address integer);
4<12+e0-e20 ; code proc , start of external
1<12+0 ; 1 code segment , bytes in perm. core
; generaten:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e5-e20 ; entry point generaten
3<18+41<12,0 ; integer procedure(undef);
4<12+e0-e20 ; code proc , start of external
1<12+0 ; 1 code segment , bytes in perm. core
; zonedes:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e6-e20 ; entry point zonedes
3<18+41<12,0 ; integer procedure(undef);
4<12+e0-e20 ; code proc , start of external
1<12+0 ; 1 code segment , bytes in perm. core
; releaseproc:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e7-e20 ; entry point release _proc
1<18+41<12,0 ; procedure(undef);
4<12+e0-e20 ; code proc, start of external
1<12+0 ; 1 code segment, bytes in perm. core
; rstable:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e8-e20 ; entry point rs_table
3<18,0 ; integer procedure;
4<12+e0-e20 ; code proc, start of external
1<12+0 ; 1 code segment, bytes in perm. core
; integerexor:
1<23+4 ; modekink=backing store
0,0,0,0 ; fill
1<23+e9-e20 ; entry point integerexor
3<18+19<12+19<6,0 ; integer procedure(addr int,addr int);
4<12+e0-e20 ; code proc, start of externallist
1<12+0 ; 1 code segment, bytes in perm core
; exclude:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e10-e20 ; entry point exclude
3<18+19<12+41<6,0 ; integer procedure(undef,address integer);
4<12+e0-e20 ; code proc, start of external list
1<12+0 ; 1 code segment, bytes in own perm core
; include:
g1: 1<23+4 ; modekind=backingstore
0,0,0,0 ; fill
1<23+e11-e20 ; entry point include
3<18+19<12+41<6,0 ; integer procedure(undef,address integer);
4<12+e0-e20 ; code proc, start of external list
1<12+0 ; 1 code segment, bytes in own perm core
n.
message lookupentry
lookup lookupentry
if ok.yes
(scope temp lookupentry lookuptail createentry permentry removeentry,
careaproc program createper
clear temp lookupentry lookuptail createentry permentry removeentry,
careaproc program createper)
(lookupentry=set 1
(lookupentry=slang fpnames type.yes insertproc entry.no
lookupentry lookuptail createentry permentry,
removeentry careaproc program createper )
if ok.no
end
scope project.drum lookuptail createentry,
careaproc program createper,
permentry removeentry
if ok.yes
message permanent ok)
;hcø 31-7-72
;code procedures for communication with the backing store
;the value of the procedures is the result of the
;corresponding monitorprocedures
;all parameters are call values
;integer procedure lookup_entry(name);
;string or <any type> array name;
;integer procedure lookup_tail(name,tail);
;integer array tail;
;string or <any type> array name;
;integer procedure create_entry(name,tail);
;integer array tail;
;string or <any type> array name;
;integer procedure perm_entry(name,key);
;value key; integer key;
;string or <any type> array name;
;integer procedure remove_entry(name);
;string or <any type> array name;
;integer procedure c_area_proc(name);
;string or <any type> array name;
;comment creates an area process with the given name;
;integer procedure program;
;comment the address of the name of the program
;document;
;integer procedure create_per(name,devno);
;value devno; integer devno;
;string or <any type> array name;
;b. ;fpnames dummy block
b. g1, e20 w. ;block with names for tails and insertproc
k=10000
s. g6,j48,f7,b15,i10,d3;start of slang segment for procedures
h.
g0=0 ;g0:=no of externals
e20:
g1: g2 , g2 ;head word: rel of last point, rel of last abs word
j13: g0 + 13 , 0 ;RS entry 13, last used
j30: g0 + 30 , 0 ;RS entry 30, saved stack ref, saved w3
j4: g0 + 4 , 0 ;RS entry 4, take expression
j6: g0 + 6 , 0 ;RS entry 6, end register expression
j8: g0 + 8 , 0 ;RS entry 8, end address expression
j12: g0 + 12 , 0 ;RS entry 12, UV
j16: g0 + 16 , 0 ;RS entry 16, segment table base
j29: g0 + 29 , 0 ;RS entry 29, param alarm
j40: g0 + 40 , 0 ;RS entry 40, program name
g2 = k-2-g1 ;end of abs words:=end of points
w.
e0: g0 ;start external list
0
25 04 73,14 00 00
b0: 0 , b1: 0,r.4 ;name
b2: 0 , b3: 0,r.9 ;tail
w.
i0: rl w1 0 ; w1:=result;
jl. (j6.) ; end register expression
e1: ;entry lookup_entry
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take param name
so w0 16 ;if string expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w:=take string1(name)
al. w1 b2. ;w1:=tail address
jd 1<11+42 ;monitor call
jl. i0. ;end register expression
e2: ;entry lookup_tail
rl. w2 (j13.) ;w2:=stack ref
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take name param
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=takestring1(name);
dl w1 x2+ 6 ;take param tail
ba w1 0 ;w1:=abs dope addr
rl w1 x1 ;w1:=lower index-k
wa w1 (x2+ 6) ;
al w1 x1+2 ;w1:=first addr
jd 1<11+42 ;lookup entry
jl. i0. ;end register expression
e3: ;entry create_entry
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+12 ;take integer array param tail
ba w1 0 ;w1:=abs dope address
rl w3 x1 ;w3:=lower index-K(K=2)
wa w3 (x2+12) ;
al w1 x3+2 ;w3:=addr of first element
rs w1 x2+10 ;store tail addr
dl w1 x2+8 ;take param name
so w0 16 ;if string expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=take string1(name);
rl w1 x2+ 4 ;w1:=message addr
jd 1<11+40 ;create entry
jl. i0. ;end register expression
e5: ;entry perm_entry
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref , saved w3
dl w1 x2+12 ;take param key
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x1 ;w1:=value
rl w3 x2+10 ;w3:=formal.1
sz w3 1 ;if real then
cf w1 0 ;convert to integer
rs w1 x2+10 ;save key
dl w1 x2+8 ;take param name
so w0 16 ;if expr then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;saved stack ref,saved w3
jl. w3 d1. ;w3:=take string1(name);
rl w1 x2+ 4 ;w1:=key
jd 1<11+50 ;perm_entry
jl. i0. ;end register expression
e6: ;entry remove_entry
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take integer param
so w0 16 ;if expression then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;saved stack ref, saved w3
jl. w3 d1. ;w3:=take string1(name);
jd 1<11+48 ;remove entry
jl. i0. ;end regeister expression
e7: ;entry c_area_proc:
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take param name
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=take string1(name);
jd 1<11+52 ;create area process
jl. i0. ;end register expresssion
e8: ;entry program:
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref, save w3
rl. w1 j40. ;w1:=addr program name
jl. (j6.) ;end register expression
e10: ;entry create per
rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref,saved w3
dl w1 x2+12 ; take param devno
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rs w1 x2+12 ; saved devno
dl w1 x2+8 ; take param name
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
jl. w3 d1. ; w3:=takestring1(name);
rl w1 (x2+ 6) ; w1:=devno;
jd 1<11+54 ; create peripheral process
jl. i0. ; end register expr.
p.<:takestring:>
b13: 0, b14: 0 ;work area item
b15: 2.11111 ;kind mask
m. end code of this segment
h. 0,r.(:10504-k:) w.
<:bsproc <0>:>
e. ;end slang segment
;lookup_entry:
g0: 1 ;first tail: area with 1 segment
0,0,0,0 ;fill
1<23+e1-e20 ;entry point lookup_entry
3<18+41<12,0 ;integer procedure(string);
4<12+e0-e20 ;code proc start of external
1<12+00 ;1 code segment
;lookup_tail:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e2-e20 ;entry point lookup_tail
3<18+25<12+41<6,0;integer procedure(string, integer array);
4<12+e0-e20 ;code proc , start of external
1<12+00 ;1 code segment
;create_entry:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e3-e20 ;entry point create_entry
3<18+25<12+41<6,0;integer procedure(string,integer array);
4<12+e0-e20 ;code proc , start of external
1<12+00 ;1 code segment
;perm_entry:
1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e5-e20 ;entry point perm_entry
3<18+13<12+41<6,0;integer procedure(string,value integer);
4<12+e0-e20 ;code proc , start of external
1<12+00 ;1 code segment
;remove_entry:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e6-e20 ;entry point remove entry
3<18+41<12 ,0 ;integer procedure(string);
4<12+e0-e20 ;code proc , start of external
1<12+00 ;1 code segm
;c_area_proc:
1<23+4 ;modekind:=backing store
0,0,0,0 ;fill
1<23+e7-e20 ;entry point c_area_proc
3<18+41<12,0 ;integer procedure(undef);
4<12+e0-e20 ;code proc , start external
1<12+00 ;1 code segment
;program:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e8-e20 ;entry point program
3<18,0 ;integer procedure;
4<12+e0-e20 ;code proc , start external
1<12+00 ;1 code segment
;create_per:
g1: 1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e10-e20 ;entry point create_per
3<18+19<12+41<6;integer procedure(undef,address integr);
0 ;
4<12+e0-e20 ;code proc, start of external
1<12+00 ;1 code segment
n.
message movetext
lookup movetext
if ok.yes
(scope temp movetext movebytes
clear temp movetext movebytes)
movetext=set 2
((movetext=slang fpnames type.yes insertproc entry.no
movetext movebytes)
if ok.no
end
scope project.drum movebytes
if ok.yes
message permanent ok)
;hcø 28-7-72
;procedure move bytes and move text
; b. h100 ; fpnames dummy block
b. g1, e6 w. ; block with names for tails and insertproc
k= 10000
s. g6, j48, b1, c0, i12; start of slang segment for procedures
h.
g0 = 0 ; g0 = number of externals
e5:
g1: g2 , g2 ; head word: rel of last point, rel of last abs word
j13: g0 + 13 , 0 ; RS entry 13, last used
j30: g0 + 30 , 0 ; - 30, saved stack ref, saved w3
j6: g0 + 6 , 0 ; - 6, end register expression
j4: g0 + 4 , 0 ; - 4, take expression
j8: g0 + 8 , 0 ; - 8, end addres expression
j16: g0 + 16 , 0 ; - 16, segment table base
j21: g0 + 21 , 0 ; - 21, general alarm
j29: g0 + 29 , 0 ; - 29, param alarm
j46: 1<11o.1 , 0 ; segment table address of next segment
g2 = k-2-g1 ; end of abs words = end of points
w.
e0: g0 ; start of external list: number of externals
0 ; number of bytes in own permanent core to be
; initialized
15 12 72, 17 00 00; date and time of this version
; integer procedure movetext(addr,s);
; value addr; integer addr; string s;
; Moves a string s to an address addr and forward. The
; procedure terminates if and only if a Null-character
; is met.
e1: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take first param
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w1 x1 ;
rs w1 x2+6 ;
rs w1 x2+8 ;
i0: dl w1 x2+12 ; String:
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x1 ; item:=doubelword(;
sh w1 -1 ; if item.second word<0 then
jl. i2. ; goto Long string;
sl w0 0 ; if item.first word>=0 then
jl. i1. ; goto Short string;
am (x2+8) ; Layout:
ds w1 2 ; move layout to addr and addr+2
al w1 4 ; movetext:=4;
jl. (j6.) ; end register expr.
i1: jl. w3 c0. ; Short string: store(item);
al. w0 i5. ; alarm(<:string:>,0);
al w1 0 ;
jl. w3 (j21.) ;
i2: hs. w0 i12. ; Long string:
bz w3 0 ; Note w0=point=segm number<12+segm rel
ls w3 1 ; segm table addr:=segment number*2
wa. w3 (j16.) ; +segment table base;
rl w3 x3 ;
i12=k+1
i3: dl w1 x3+0 ; Next:
sh w1 -1 ; item:=core(w3+segment relative);
jl. i2. ; if item.second word<0 then
rs. w3 i4. ; goto Long string;
jl. w3 c0. ; store(item);
rl. w3 i4. ;
al w3 x3-4 ; w3:=w3-4;
jl. i3. ; goto Next;
i4: 0 ; work
i5: <:<10>string :> ; alarm text
; procedure store(item);
; Stores an item integer by integer and returns to
; calling program if a Null- character is met.
; at entry at return
; w0,w1 item destroyed
; w2 last used last used
; w3 link destroyed
b. b6, w. ; begin
b0: 0 ; link
b1: 8.377 000 000 ; constant
b2: 0,0 ; work
c0: rs. w3 b0. ; save return;
rl w3 x2+8 ;
ds. w1 b2.+2 ;
al w1 0 ;
b3: rl. w0 x1+b2. ;
rs w0 x3 ; for i:=item.first word,
al w3 x3+2 ; item.second word do
rs w3 x2+8 ; begin
sz. w0 (b1.) ;
jl. 4 ;
jl. b4. ; core(addr):=i;
ls w0 8 ; addr:=addr+2;
sz. w0 (b1.) ;
jl. 4 ;
jl. b4. ; for j:=-16,-8,0 do
ls w0 8 ; if i shift j extract 8=0 then
sz. w0 (b1.) ; goto FIN;
jl. 4 ;
jl. b4. ;
se w1 0 ; end i;
jl. (b0.) ;
al w1 2 ;
jl. b3. ;
b4: rl w1 x2+8 ; FIN:
ws w1 x2+6 ; movetext:=number of bytes used;
jl. (j6.) ; end register expr.
e. ; end store;
;procedure move_bytes(from,to,bytes);
;address integer from,to;
;value bytes; integer bytes;
b. i1, d2, c0, a1 , f7 ; block for move_bytes
w.
f0: 0 ; base next segm
f1: 0 ; bytes
f2: 0 ; from
f3: 0 ; to
f5: 2 ; length decrement
f7: 2.11 ; mask for modulo 4
e2: ;entry move_bytes
rl. w2 (j13.) ;w2:=stack ref
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take integer param from
so w0 16 ;if expression
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+12 ;take integer param to
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+16 ;take integer param bytes
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x1 ;take integer value
rl w3 x2+14 ;w3:=bytes formal.1
sz w1 0 ;if real then
cf w1 0 ;convert to integer
rs w1 x2+14 ;save bytes
rl. w3 (j46.) ; w3:=segment table addr
al. w1 d0. ; w3:= segment table(next segment);
rs w1 x3+f6 ; w1:= address of return from next segm;
; store w1 on next segment;
;This is the first reference to the next segment. It may change
;the segment allocation, but this segment will stay in core.
;Note that no references to RS-routines or other segments are
;performed after this point, except exits from the procedure.
;As a consequence the working locations on this segment are used
;freely.
rs. w3 f0. ; save the adjusted base of next segment;
rl w0 x2+14 ; w0:=bytes
rl w1 (x2+8) ;w1:=from;
al w1 x1-2 ;w1:=from-2;
ds. w1 f2. ;store from,bytes
rl w3 (x2+12) ;w3:=to
al w3 x3-2 ;w3:=from-2;
rs. w3 f3. ;store to
rl w2 2 ;w2:=to
rl w1 0 ;
sh w0 0 ;if bytes<=0 then
jl. w3 (j8.) ;end address expression
sl w3 9 ;if to<8 or
sh w2 8 ;or from <8 then
jl. w3 (j29.) ;param alarm
;In the following code w2 and w3 will always contain the current
;base addresses for the parts of A and B to be moved.
;W0 is temporarily used for length = number of bytes still to
;be moved.
;W1 is temporarily used for portion = - number of bytes to be
;moved in this round.
d0: rl. w0 f1. ; return from segm 2: w0:= length;
al w1 i0 ; w1:= portion:= -maxbytes for 1 round;
sl w0 i1 ; if length > maxbytes
jl. d1. ; then goto move;
ac w1 (0) ; portion:= - length;
la. w0 f7. ; portion:= portion +
wa w1 0 ; length mod 4;
rl. w0 f1. ;
sl w0 4 ; if length >= 4
jl. d1. ; then goto move;
a1: rl w1 x2+2 ; more:
sn w0 1 ; if length = 1 then
jl. a0. ; goto byte;
sh w0 0 ; if length <= 0
jl. (j8.) ; then goto rs end addr expr;
rs w1 x3+2 ; move word from A to B;
al w2 x2+2 ; from:= from + 2;
al w3 x3+2 ; to:= to + 2;
ws. w0 f5. ; length:= length - 2;
jl. a1. ; goto more;
a0: bz w1 2 ; byte:
hs w1 x3+1 ; move last byte from A to B;
jl. (j8.) ; goto rs end address expression;
d1: wa w0 2 ; move:
rs. w0 f1. ; length:= length + portion;
ws w2 2 ; from:= from - portion;
ws w3 2 ; to:= to - portion;
am. (f0.) ; goto movelist(portion + maxbytes);
jl x1+g6 ;
;Note: The next segment is already in core. Thus w3 nedd not be
;used in the jump.
g3:
c. g3 - g1 - 506
m.code on segment 1 too long
z.
c.502-g3+g1, jl -1 , r. 252-(:g3-g1:)>1 z.
;fill rest of segment with the illegal instruction jl -1
<:move proc <0>:> ; alarm text segment 1
;start of segment 2 containing the movelist
g5: 0 ; head word: no abs words or points
f6=k-g5 , 0 ; return addr to previous segment
;movelist:
; moves a number of bytes = portion from A to B. Last word
; moved is from word to to word.
dl w1 x2-500 , ds w1 x3-500 , dl w1 x2-496 , ds w1 x3-496
dl w1 x2-492 , ds w1 x3-492 , dl w1 x2-488 , ds w1 x3-488
dl w1 x2-484 , ds w1 x3-484 , dl w1 x2-480 , ds w1 x3-480
dl w1 x2-476 , ds w1 x3-476 , dl w1 x2-472 , ds w1 x3-472
dl w1 x2-468 , ds w1 x3-468 , dl w1 x2-464 , ds w1 x3-464
dl w1 x2-460 , ds w1 x3-460 , dl w1 x2-456 , ds w1 x3-456
dl w1 x2-452 , ds w1 x3-452 , dl w1 x2-448 , ds w1 x3-448
dl w1 x2-444 , ds w1 x3-444 , dl w1 x2-440 , ds w1 x3-440
dl w1 x2-436 , ds w1 x3-436 , dl w1 x2-432 , ds w1 x3-432
dl w1 x2-428 , ds w1 x3-428 , dl w1 x2-424 , ds w1 x3-424
dl w1 x2-420 , ds w1 x3-420 , dl w1 x2-416 , ds w1 x3-416
dl w1 x2-412 , ds w1 x3-412 , dl w1 x2-408 , ds w1 x3-408
dl w1 x2-404 , ds w1 x3-404 , dl w1 x2-400 , ds w1 x3-400
dl w1 x2-396 , ds w1 x3-396 , dl w1 x2-392 , ds w1 x3-392
dl w1 x2-388 , ds w1 x3-388 , dl w1 x2-384 , ds w1 x3-384
dl w1 x2-380 , ds w1 x3-380 , dl w1 x2-376 , ds w1 x3-376
dl w1 x2-372 , ds w1 x3-372 , dl w1 x2-368 , ds w1 x3-368
dl w1 x2-364 , ds w1 x3-364 , dl w1 x2-360 , ds w1 x3-360
dl w1 x2-356 , ds w1 x3-356 , dl w1 x2-352 , ds w1 x3-352
dl w1 x2-348 , ds w1 x3-348 , dl w1 x2-344 , ds w1 x3-344
dl w1 x2-340 , ds w1 x3-340 , dl w1 x2-336 , ds w1 x3-336
dl w1 x2-332 , ds w1 x3-332 , dl w1 x2-328 , ds w1 x3-328
dl w1 x2-324 , ds w1 x3-324 , dl w1 x2-320 , ds w1 x3-320
dl w1 x2-316 , ds w1 x3-316 , dl w1 x2-312 , ds w1 x3-312
dl w1 x2-308 , ds w1 x3-308 , dl w1 x2-304 , ds w1 x3-304
dl w1 x2-300 , ds w1 x3-300 , dl w1 x2-296 , ds w1 x3-296
dl w1 x2-292 , ds w1 x3-292 , dl w1 x2-288 , ds w1 x3-288
dl w1 x2-284 , ds w1 x3-284 , dl w1 x2-280 , ds w1 x3-280
dl w1 x2-276 , ds w1 x3-276 , dl w1 x2-272 , ds w1 x3-272
dl w1 x2-268 , ds w1 x3-268 , dl w1 x2-264 , ds w1 x3-264
dl w1 x2-260 , ds w1 x3-260 , dl w1 x2-256 , ds w1 x3-256
dl w1 x2-252 , ds w1 x3-252 , dl w1 x2-248 , ds w1 x3-248
dl w1 x2-244 , ds w1 x3-244 , dl w1 x2-240 , ds w1 x3-240
dl w1 x2-236 , ds w1 x3-236 , dl w1 x2-232 , ds w1 x3-232
dl w1 x2-228 , ds w1 x3-228 , dl w1 x2-224 , ds w1 x3-224
dl w1 x2-220 , ds w1 x3-220 , dl w1 x2-216 , ds w1 x3-216
dl w1 x2-212 , ds w1 x3-212 , dl w1 x2-208 , ds w1 x3-208
dl w1 x2-204 , ds w1 x3-204 , dl w1 x2-200 , ds w1 x3-200
dl w1 x2-196 , ds w1 x3-196 , dl w1 x2-192 , ds w1 x3-192
dl w1 x2-188 , ds w1 x3-188 , dl w1 x2-184 , ds w1 x3-184
dl w1 x2-180 , ds w1 x3-180 , dl w1 x2-176 , ds w1 x3-176
dl w1 x2-172 , ds w1 x3-172 , dl w1 x2-168 , ds w1 x3-168
dl w1 x2-164 , ds w1 x3-164 , dl w1 x2-160 , ds w1 x3-160
dl w1 x2-156 , ds w1 x3-156 , dl w1 x2-152 , ds w1 x3-152
dl w1 x2-148 , ds w1 x3-148 , dl w1 x2-144 , ds w1 x3-144
dl w1 x2-140 , ds w1 x3-140 , dl w1 x2-136 , ds w1 x3-136
dl w1 x2-132 , ds w1 x3-132 , dl w1 x2-128 , ds w1 x3-128
dl w1 x2-124 , ds w1 x3-124 , dl w1 x2-120 , ds w1 x3-120
dl w1 x2-116 , ds w1 x3-116 , dl w1 x2-112 , ds w1 x3-112
dl w1 x2-108 , ds w1 x3-108 , dl w1 x2-104 , ds w1 x3-104
dl w1 x2-100 , ds w1 x3-100 , dl w1 x2- 96 , ds w1 x3- 96
dl w1 x2- 92 , ds w1 x3- 92 , dl w1 x2- 88 , ds w1 x3- 88
dl w1 x2- 84 , ds w1 x3- 84 , dl w1 x2- 80 , ds w1 x3- 80
dl w1 x2- 76 , ds w1 x3- 76 , dl w1 x2- 72 , ds w1 x3- 72
dl w1 x2- 68 , ds w1 x3- 68 , dl w1 x2- 64 , ds w1 x3- 64
dl w1 x2- 60 , ds w1 x3- 60 , dl w1 x2- 56 , ds w1 x3- 56
dl w1 x2- 52 , ds w1 x3- 52 , dl w1 x2- 48 , ds w1 x3- 48
dl w1 x2- 44 , ds w1 x3- 44 , dl w1 x2- 40 , ds w1 x3- 40
dl w1 x2- 36 , ds w1 x3- 36 , dl w1 x2- 32 , ds w1 x3- 32
dl w1 x2- 28 , ds w1 x3- 28 , dl w1 x2- 24 , ds w1 x3- 24
dl w1 x2- 20 , ds w1 x3- 20 , dl w1 x2- 16 , ds w1 x3- 16
dl w1 x2- 12 , ds w1 x3- 12 , dl w1 x2- 8 , ds w1 x3- 8
dl w1 x2- 4 , ds w1 x3- 4 , dl w1 x2- 0 , ds w1 x3- 0
g6 = k - g5 ; base of movelist
jl. (g5.+f6 ) ; return to previous segment
0 ; fill
i0= -504 ; - max number of bytes to be moved in one round
i1= 503 ; max bytes - 1
;this code segment need no alarm text, as no alarms can occur
i.e. ; end of block for move array
i.e. ; end of slang segment
; move_text:
g0: 2 ; first tail: area entry with 2 segments
0,0,0,0 ; fill
1<23+e1-e5 ; entry point movetext
3<18+9<12+19<6,0 ; integer procedure(addr integer,string);
4<12+e0-e5 ; code proc, start of external list
2<12+0 ; 2 code segments, bytes in perm core
; move_bytes
g1: 1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23 + e2-e5 ; entry point for move_bytes on first segment
1<18+13<12+19<6+19,0; procedure(addr int,addr int, value int);
4<12 + e0-e5 ; code proc, start of externallist
2<12 + 0 ; 2 code segments, bytes in perm core
n.
message initproc
lookup initproc
if ok.yes
(scope temp initproc reserveproc sendmessage waitanswer getclock,
description nameentry renameentry cpseudoproc
clear temp initproc reserveproc sendmessage waitanswer getclock,
description nameentry renameentry cpseudoproc)
(initproc=set 1
(initproc=slang fpnames type.yes insertproc entry.no
initproc reserveproc sendmessage waitanswer getclock ,
description nameentry renameentry cpseudoproc)
if ok.no
end
scope project.drum reserveproc sendmessage,
waitanswer getclock description nameentry renameentry cpseudoproc
if ok.yes
message permanent ok)
;hcø 31-7-72
;code procedures for message and answer handling
;if nothing else explicitly stated the
;value of the procedure is the result of the
;corresponding monitorprocedure
;integer procedure init_proc(name,param);
;value param; integer param;
;string or <any type> array name;
;comment param is stored in w0 (only significant for DOT);
;integer procedure reserve_proc(name,param);
;value param; integer param;
;string or <any type> array name;
;comment param is stored in w0 (only significant for DOT);
;integer procedure send_message(name,message);
;integer array message;string or <any type> array name;
;comment message is the message area
;the value of the procedure is the bufferaddress;
;integer procedure wait_answer(buffer_address,answer);
;value buffer_address; integer buffer_address;
;integer array answer;
;comment answer is the array where the answer is stored
;must have at least 8 elements;
;long procedure get_clock;
;integer procedure description(name);
;string or <any type> array name;
;comment the procedure gives the process description address;
;b. ;fpnames dummy block
b. g1, e20 w. ;block with names for tails and insertproc
k=10000
s. g6,j46,f7,b15,i10,d3,c1;start of slang segment for procedures
h.
g0=0 ;g0:=no of externals
e20:
g1: g2 , g2 ;head word: rel of last point, rel of last abs word
j13: g0 + 13 , 0 ;RS entry 13, last used
j30: g0 + 30 , 0 ;RS entry 30, saved stack ref, saved w3
j3: g0 + 3 , 0 ;RS entry 3, reserve stack
j4: g0 + 4 , 0 ;RS entry 4, take expression
j6: g0 + 6 , 0 ;RS entry 6, end register expression
j8: g0 + 8 , 0 ;RS entry 8, end address expression
j12: g0 + 12 , 0 ;RS entry 12, UV
j16: g0 + 16 , 0 ;RS entry 16, segment table base
j21: g0 + 21 , 0 ;RS entry 21, general alarm
j29: g0 + 29 , 0 ;RS entry 29, param alarm
j43: 0 , 1 ;name entry 1.std variable
g2 = k-2-g1 ;end of abs words:=end of points
w.
e0: g0 ;start external list
0
30 04 74,11 00 00
w.
e1: ;entry init_proc
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref,saved w3
dl w1 x2+8 ;take param name
so w0 16 ;if string expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ;saved stack ref ,save w3
jl. w3 d1. ;w3:=take string1(name);
jd 1<11+6 ;monitor call:init_proc
rl w1 0 ;w1:= result
jd 1<11+4 ;process description
sn w0 0 ;if not found then
jl. i0. ;goto end;
rl w2 74 ;w2:=nametable
al w2 x2-2 ;
jl. i1. ;search entry
e2: ; entry reserve proc:
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take param name
so w0 16 ;if string expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=takestring1(name);
jd 1<11+8 ;reserve process
rl w1 0 ;w1:=result
jd 1<11+4 ;process description
sn w0 0 ;if -,found then
jl. i0. ;goto end
rl w2 74 ;w2:=name table entry
al w2 x2-2
i1: al w2 x2+2 ;search entry
rl w3 x2 ;w3:=addr
se w3 (0) ;if addr=proc descr
jl. i1. ;then
rs. w3 (j43.) ;name entry:=addr
i0: jl. (j6.) ;end register expression
e3: ;entry send_message
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+12 ;take integer array param message
ba w1 0 ;w1:=abs dope address
rl w3 x1 ;w3:=lower index-K(K=2)
wa w3 (x2+12) ;
al w1 x3+2 ;w3:=addr of first element
rs w1 x2+10 ;store message addr
dl w1 x2+8 ;take param name
so w0 16 ;if string expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=take string1(name);
al w2 x2-6 ;w2:=last used
rl w1 x2+10 ;w1:= message address
rl. w2 (j43.) ;w2:=name entry
rl w0 x3+8 ;if name entry<>0
sh w0 0 ;then
rs w2 x3+8 ;store name entry
jd 1<11+16 ;send message
rl w1 4 ;w1:=result:=buffer_address
jl. (j6.) ;end register expression
e4: ;entry wait answer
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref , saved w3
dl w1 x2+8 ;take param ba
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref ,save w3
rl w3 x1 ;w3:=ba
dl w1 x2+12 ;take integer array parameter answer
ba w1 0 ;w1:=abs dope address
rl w1 x1 ;w1:=lower index-K(K=2)
wa w1 (x2+12) ;
al w1 x1+2 ;w1:=addr of first element
al w2 x3 ;w2:=ba
jd 1<11+18 ;wait answer
rl w1 0 ;w1:=result
jl. (j6.) ;end register expression
e8: ;entry get_clock
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
jd 1<11+36 ;get clock
jl. (j6.) ;end register expression
e9: ;entry process description
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take param name
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=take string1(name);
jd 1<11+4 ;process description
rl w1 0 ;w1:=process description address
jl. (j6.) ;end register expression
; integer procedure rename_entry(old,new);
; string or <any type> array old,new;
; rename_entry:=result of monitor proc;
e11: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
al w1 -8 ;
jl. w3 (j3.) ; reserve 8 bytes in stack
ds. w2 (j30.) ; saved new stack ref, saved w3
dl w1 x2+12 ; take param: new
al w2 x2-8 ;
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
al w2 x2+12 ;
jl. w3 d1. ; w3:=take string1(abs result,new.formal1);
al w2 x2-18 ;
dl w1 x3+2 ; move name to reserved locations
ds w1 x2+2 ;
dl w1 x3+6 ;
ds w1 x2+6 ;
dl w1 x2+16 ; take param: old
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
al w2 x2+8 ;
jl. w3 d1. ; w3:=take string1(abs result,old.formal1);
al w2 x2-6 ;
rs. w2 (j13.) ; release reserved locations
al w1 x2-8 ; w1:=abs address of name new;
jd 1<11+46 ; rename entry
rl w1 0 ; renameentry:=result;
jl. (j6.) ; end register expr.
; integer procedure c_pseudo_proc(name);
; string or <any type> array name;
; cpseudoproc:=result of monitor proc;
e12: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take formals: name
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
al w2 x2+6 ;
jl. w3 d1. ; w3:=take string1(name);
jd 1<11+80 ; create pseudo process
rl w1 0 ; cpseudoproc:=result;
jl. (j6.) ; end register expr.
p.<:takestring:>
w.
b7: 0,
b8: 0,r.7
m. end code of this segment
h. 0,r.(:10504-k:) w.
<:messproc <0>:>
e. ;end slang segment
;init_proc:
g0: 1 ;first tail: area with 1 segment
0,0,0,0 ;fill
1<23+e1-e20 ;entry point init_proc
3<18+19<12+41<6,0;integer procedure(string,address integer);
4<12+e0-e20 ;code proc start of external
1<12+02 ;1 code segment
;reserve_proc:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e2-e20 ;entry point reserve_proc
3<18+19<12+41<6,0;integer procedure(string,address integer);
4<12+e0-e20 ;code proc , start of external
1<12+02 ;1 code segment
;send_message:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e3-e20 ;entry point send_message
3<18+25<12+41<6,0;integer procedure(string,integer array);
4<12+e0-e20 ;code proc , start of external
1<12+02 ;1 code segment
;wait_answer:
1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e4-e20 ;entry point wait_answer
3<18+25<12+19<6,0;integer procedure(address integer,integer array);
4<12+e0-e20 ;code proc , start of external
1<12+02 ;1 code segment
;get_clock:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e8-e20 ;entry point get_clock
5<18+0,0 ;long procedure;
4<12+e0-e20 ;code proc , start of external
1<12+02 ;1 code segment
;description:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e9-e20 ;entry point description
3<18+41<12,0 ;integer procedure(string param);
4<12+e0-e20 ;code proc , start of external
1<12+02 ;1 code segment
;name entry:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1 ;byte address in own permanent core
9<18+0 ,0 ;integer variable
4<12 ;code var , start of external
1<12+02 ;1 code segm, bytes
; renameentry:
1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e11-e20 ; entry point renameentry
3<18+41<12+41<6,0 ; integer procedure(undef,undef);
4<12+e0-e20 ; code proc , start of external
1<12+02 ; 1 code segment , bytes in perm. core
; cpseudoproc:
g1: 1<23+4 ; modekind=backing store
0,0,0,0 ; fill
1<23+e12-e20 ; entry point: cpseudoproc
3<18+41<12,0 ; integer procedure(undef);
4<12+e0-e20 ; code proc, start of external list
1<12+02 ; 1 code segment, bytes in perm core
n.
message lookupaux
lookup monitorproc
if ok.yes
(scope temp lookupaux clearstat permaux monitorproc procidbit
clear temp lookupaux clearstat permaux monitorproc procidbit
)
(lookupaux=set 1
(lookupaux=slang fpnames type.yes insertproc entry.no
lookupaux clearstat permaux monitorproc procidbit)
if ok.no
end
scope project.drum procidbit monitorproc clearstat permaux
if ok.yes
message permanent ok)
;hcø 19 6 72
;procedure monitor_proc(no,w);
;integer no; integer array w;
;comment makes a call of the monitor procedure given by no
;taking the working register values from the integer
;array w;
;b. ;fpnames dummy block
b. g1, e20 w. ;block with names for tails and insertproc
k=10000
s. g6,j46,f7,b15,i10,d3;start of slang segment for procedures
h.
g0=0 ;g0:=no of externals
e20:
g1: g2 , g2 ;head word: rel of last point, rel of last abs word
j13: g0 + 13 , 0 ;RS entry 13, last used
j30: g0 + 30 , 0 ;RS entry 30, saved stack ref, saved w3
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
j12: g0 + 12 , 0 ;RS entry 12, UV
j16: g0 + 16 , 0 ;RS entry 16, segment table base
j29: g0 + 29 , 0 ;RS entry 29, param alarm
g2 = k-2-g1 ;end of abs words:=end of points
w.
e0: g0 ;start external list
0
80 01 28,14 00 00
b0: rl w1 0 ; result:=result monitor proc
jl. (j6.) ; end register expression
b1: rs. w1 b2. ; save link
dl w1 x3+2 ; move name to reserved locations
ds w1 x2+2 ;
dl w1 x3+6 ;
ds w1 x2+6 ;
jl. (b2.) ; return
b2: 0
w.
e1: ;entry lookup_aux
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+16 ; take param tail
ba w1 0 ; w1:=abs dope
rl w3 x1 ; w3:=lower index - 2
wa w3 (x2+16) ;
al w1 x3+2 ; w3:=addr first elem
rs w1 x2+14 ;
al w1 -8 ; reserve 8 bytes in stack
jl. w3 (j3.) ;
ds. w2 (j30.) ; save stack ref, save w3
dl w1 x2+12 ;take param docname
al w2 x2-8 ;
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
al w2 x2+12 ;
jl. w3 d1. ;take param name
al w2 x2-18 ;
jl. w1 b1. ; move docname
dl w1 x2+16 ; take param 1 name
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; save stack ref, save w3
al w2 x2+8 ;
jl. w3 d1. ; w3:=takestring
al w2 x2-6 ; release reserved locations
rs. w2 (j13.) ;
rl w1 x2+14 ; w1:=tail
al w2 x2-8 ; w2:=doc
jd 1<11+86 ; lookup auxillary entry
jl. b0. ;end register expression
e2: ;entry clear_stat
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
al w1 -8 ; reserve 8 bytes in stack
jl. w3 (j3.) ;
ds. w2 (j30.) ; save stack ref, save w3
dl w1 x2+12 ;take param docname
al w2 x2-8 ;
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
al w2 x2+12 ;
jl. w3 d1. ;take param name
al w2 x2-18 ;
jl. w1 b1. ; move docname
dl w1 x2+16 ; take param 1 name
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; save stack ref, save w3
al w2 x2+8 ;
jl. w3 d1. ; w3:=takestring
al w2 x2-6 ; release reserved locations
rs. w2 (j13.) ;
al w2 x2-8 ; w2:=doc
jd 1<11+88 ; clear statics in auxillary entry
jl. b0. ;end register expression
e4: ;entry perm_aux
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+16 ; take param key
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; save stack ref, save w3
rs w1 x2+14 ;
al w1 -8 ; reserve 8 bytes in stack
jl. w3 (j3.) ;
ds. w2 (j30.) ; save stack ref, save w3
dl w1 x2+12 ;take param docname
al w2 x2-8 ;
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
al w2 x2+12 ;
jl. w3 d1. ;take param name
al w2 x2-18 ;
jl. w1 b1. ; move docname
dl w1 x2+16 ; take param 1 name
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ; save stack ref, save w3
al w2 x2+8 ;
jl. w3 d1. ; w3:=takestring
al w2 x2-6 ; release reserved locations
rs. w2 (j13.) ;
rl w1 x2+14 ; w1:=key
al w2 x2-8 ; w2:=doc
jd 1<11+90 ; permanent entry in auxillary catalog
rl w1 0 ; result:=monitor result
jl. (j6.) ;end register expression
e6: ;entry monitor_proc:
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take param no
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+12 ;take w
ba w1 0 ;w1:=abs dope
rl w1 x1 ;w1:=lower index-k
wa w1 (x2+12) ;w1:=first addr-2
al w1 x1+4 ;w1:=first+2
al w0 -2048 ;w0:=1<11
ba w0 (x2+8) ;w0:=addr part monitor call
hs. w0 i6. ;store addr part
rl w0 x1-2 ;w0:=w(1);
dl w3 x1+4 ;w3:=w(4);
rs. w1 i7. ;save first addr(w)+2;
rl w1 x1 ;w1:=w(2);
i6=k+1 ;addr of addr part monitor call
jd 0 ;monitor call
rs. w1 (i7.) ;w(2):=w1
rl. w1 i7. ;w1:=first addr(w)+2
rs w0 x1-2 ;w(1):=w0;
ds w3 x1+4 ;w(4):=w3;
jl. (j6.) ;end address expression
i7: 0 ;save addr(w(1));
; integer procedure procidbit(bitno);
; address integer bitno;
; According to bitno the procedure return with a
; process description address of an internal process.
; If it do not exsist it return with the value 0.
e8: rl. w2 (j13.) ; w2:=last used;
ds. w3 (j30.) ; saved stack ref, saved w3
dl w1 x2+8 ; take param: bitno
so w0 16 ; if expr then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref, saved w3
rl w1 x1 ;
ns. w1 i9. ; j:=bit no count from left;
i9=k+1
ac w3 0 ;
sl w3 24 ; if bitno=0 then
jl. i10. ; goto STOP;
sl w1 0 ; if bitno.0=0 then
ba. w3 1 ; j:=j+1;
al w1 74 ;
wm w1 6 ; j:=j*length of internal proc;
wa w1 (78) ; procidbit:=j+addr of first internal;
sn w3 0 ; if first internal then
jl. (j6.) ; procidbit:=j;
rl w3 x1+2 ; if internal proc removed then
sn w3 0 ; STOP: procidbit:=0;
i10: al w1 0 ;
jl. (j6.) ; end register expr.
p.<:takestring:>
m. end code of this segment
h. 0,r.(:10504-k:) w.
<:prproc <0>:>
e. ;end slang segment
; lookup_aux
g0: 1 ;first tail: area with 1 segment
0,0,0,0 ;fill
1<23+e1-e20 ;entry point read_dev
3<18+25<12+41<6+41,0;integer procedure(undef,undef,integer array);
4<12+e0-e20 ;code proc start of external
1<12 ;1 code segment
;clear_stat
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e2-e20 ;entry point clear_stat
3<18+41<12+41<6,0;undef procedure(undef,undef);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;perm_aux:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e4-e20 ;entry point perm_aux
3<18+19<12+41<6+41,0;integer procedure(undef,undef,integer)
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;monitor_proc:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e6-e20 ;entry point monitorproc
1<18+25<12+19<6,0;procedure(integer, integer array);
4<12+e0-e20 ;code proc, start external
1<12 ;1 code segment
; procidbit:
g1: 1<23+4 ; modekind=backingstore
0,0,0,0 ; fill
1<23+e8-e20 ; entry point procidbit
3<18+19<12,0 ; integer procedure(addr integer);
4<12+e0-e20 ; code proc, start of external list
1<12+00 ; 1 code segment, bytes in perm core
n.
message waitmessage
lookup waitmessage
if ok.yes
(scope temp waitmessage modifyint createint startint stopint removeproc,
copyzone includeall
clear temp waitmessage modifyint createint startint stopint removeproc,
copyzone includeall)
(waitmessage=set 1
(waitmessage=slang fpnames type.yes insertproc entry.no
waitmessage modifyint createint startint stopint,
removeproc copyzone includeall)
if ok.no
end
scope project.drum,
modifyint,
createint,
startint,
stopint,
removeproc,
copyzone,
includeall
if ok.yes
message permanent ok)
;hcø 3-8-72
;code procedures for communication with the monitor for operating system purposes
;the value of the procedures is the result of the
;corresponding monitorprocedures
;all parameters are call values
;if not explicitly stated
;integer procedure wait_message(name,result,message);
;integer result;
;integer array message;
;<any type> array name;
;comment result is a return value the result of the
;monitor procedure. The value of the procedure is
;the buffer address;
;integer procedure modify_int(name,registers);
;string or integer or <any type> array name;
;integer array registers;
;integer procedure create_int(name,param);
;string or <any type> array name;
;integer array param;
;integer procedure start_int(name);
;string or <any type> array name;
;integer procedure stop_int(name,result);
;integer result;
;string or <any type> array name;
;integer proceger procedure remove_proc(name);
;string or <any type> array name;
;integer procedure copy_zone(buffer_address,first,last);
;value buffer_address; integer buffer_address,first,last;
;comment makes a copy call jd 1<11+70
;with first and last in w1,w3 and delivers
;bytes and chars;
;integer procedure include_all(name);
;string or <any type> array name;
;b. ;fpnames dummy block
b. g1, e20 w. ;block with names for tails and insertproc
k=10000
s. g6,j46,f7,b15,i10,d3;start of slang segment for procedures
h.
g0=0 ;g0:=no of externals
e20:
g1: g2 , g2 ;head word: rel of last point, rel of last abs word
j13: g0 + 13 , 0 ;RS entry 13, last used
j30: g0 + 30 , 0 ;RS entry 30, saved stack ref, saved w3
j4: g0 + 4 , 0 ;RS entry 4, take expression
j6: g0 + 6 , 0 ;RS entry 6, end register expression
j8: g0 + 8 , 0 ;RS entry 8, end address expression
j12: g0 + 12 , 0 ;RS entry 12, UV
j16: g0 + 16 , 0 ;RS entry 16, segment table base
j21: g0 + 21 , 0 ;RS entry 21, general alarm
j29: g0 + 29 , 0 ;RS entry 29, param alarm
g2 = k-2-g1 ;end of abs words:=end of points
w.
e0: g0 ;start external list
0
03 08 72,17 00 00
b0: 0 , b1: 0,r.4 ;name
b2: 0 , b3: 0,r.9 ;tail
w.
e1: ;entry wait_message
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take param name
ba w1 0 ;w1:=abs dope addr
rl w1 x1 ;w1:=lower index-K
wa w1 (x2+8) ;
al w3 x1+2 ;w3:=name addr
dl w1 x2+16 ;take param message
ba w1 0 ;w1:=abs dope addr
rl w1 x1 ;w1:=lower index-K
wa w1 (x2+16) ;
al w1 x1+2 ;w1:=message addr
jd 1<11+20 ;wait_message
rl w1 4 ;w1:=buffer_address
rl. w2 (j13.) ;w2:=stack ref
rl w3 x2+10 ;w3:=first formal buffer addr
sz w3 16 ;if -,expression then
rs w0 (x2+12) ;store result
jl. (j6.) ;end register expression
e3: ;entry modify_int
rl. w2 (j13.) ;w2:=stack ref
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take param name
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=take string1(name);
dl w1 x2+ 6 ;take integer array registers
ba w1 0 ;w1:=abs dope
rl w1 x1 ;w1:=lower
wa w1 (x2+ 6) ;
al w1 x1+2 ;w1:=first addr
jd 1<11+62 ;modify_int
rl w1 0 ;w1:=result
jl. (j6.) ;end register expression
e4: ;entry create_int
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref,save w3
dl w1 x2+8 ;take param name
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=takestring1(name);
al w2 x2-6 ;w2:=last used
dl w1 x2+12 ;take param param
ba w1 0 ;w1:=abs dope addr
rl w1 x1 ;w1:=lower index-K(K=2)
wa w1 (x2+12) ;
al w1 x1+2 ;w1:=first addr
jd 1<11+56 ;create_int
rl w1 0 ;w1:=result
jl. (j6.) ;end register expression
e5: ;entry start_int
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref , saved w3
dl w1 x2+8 ;take param name
so w0 16 ;if expr then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;saved stack ref,saved w3
jl. w3 d1. ;w3:=take string1(name);
jd 1<11+58 ;start_int
rl w1 0 ;w1:=result
jl. (j6.) ;end register expression
e6: ;entry stop_internal
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;tape param name
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=take string1(name);
jd 1<11+60 ;stop internal process
rl w1 4 ;w1:=buffer_address
rl. w2 (j13.) ;w2:=stack ref
rs w0 (x2+12) ;store result
jl. (j6.) ;end register expression
e7: ;entry remove_proc
rl. w2 (j13.) ;w2:=stack ref
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take param name
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=takestring1(name);
jd 1<11+64 ;remove process
rl w1 0 ;w1:=result
jl. (j6.) ;end register expression
e8: ;entry copy_zone
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref,save w3
dl w1 x2+8 ;take buffer_addr
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
dl w1 x2+12 ;take param first
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+16 ;take param last
so w0 16 ;if expression then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;save stack ref, save w3
rl w3 x1 ;w3:=last
rl w1 (x2+12) ;w1:=first
rl w2 (x2+8) ;w2:=buffer_address
jd 1<11+70 ;copy
rl. w2 (j13.) ;w2:=last used
rs w1 (x2+12) ;save bytes
rs w3 (x2+16) ;save chars
rl w1 0 ;w1:=result
jl. (j6.) ;end register expression
e9: ;entry include_all
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take param name
so w0 16 ;if expression then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;saved stack ref, saved w3
jl. w3 d1. ;w3:=takestring1(name);
rl w1 76 ;w1:=
ws w1 74 ;no of
ls w1 -1 ;devices
i2: ;include
jd 1<11+12 ;include user
al w1 x1-1 ;devno:=devno-1;
sl w1 0 ;if devno>=0 then
jl. i2. ;goto include
jl. (j8.) ;end address expression
p.<:takestring:>
b11: 0, b12: 0 ;zeroes
b13: 0, b14: 0 ;work area item
b15: 2.11111 ;kind mask
m. end code of this segment
h. 0,r.(:10504-k:) w.
<:opsproc <0>:>
e. ;end slang segment
;wait_message:
g0: 1 ;first tail: area with 1 segment
0,0,0,0 ;fill
1<23+e1-e20 ;entry point wait_message
3<18+25<12+19<6+41,0;integer procedure(undef,integer,integer array);
4<12+e0-e20 ;code proc start of external
1<12 ;1 code segment
;modify_int:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e3-e20 ;entry point modify_int
3<18+25<12+41<6,0;integer procedure(undef,integer);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;create_int:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e4-e20 ;entry point create_int
3<18+25<12+41<6,0;integer procedure(undef,value integer);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;start_int:
1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e5-e20 ;entry point start_int
3<18+41<12,0;integer procedure(undef);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;stop_internal:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e6-e20 ;entry point stop_internal
3<18+19<12+41<6,0;integer procedure(undef,integer);
4<12+e0-e20 ;code proc , start external
1<12 ;1 code segment
;remove_proc:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e7-e20 ;entry point remove_proc
3<18+41<12,0 ;integer procedure(undef);
4<12+e0-e20 ;code proc , start external
1<12 ;1 code segment
;copy_zone:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e8-e20 ;entry point copy_zone
3<18+19<12+19<6+19,0;integer procedure(int,int,int);
4<12+e0-e20 ;code proc , start external
1<12 ;1 code segment
;include_all:
g1: 1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e9-e20 ;entry point remove entry
1<18+41<12 ,0 ;integer procedure(string);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segm, bytes
n.
message byteload
lookup byteload
if ok.yes
(scope temp byteload shortload wordload doubleload bytestore wordstore ,
doublestore firstaddr integerand integerneg nameload cleararray setbit integeror
clear temp byteload shortload wordload doubleload bytestore wordstore ,
doublestore firstaddr integerand integerneg nameload cleararray setbit integeror)
(byteload=set 1
(byteload=slang fpnames type.yes insertproc entry.no
byteload shortload wordload doubleload bytestore ,
wordstore doublestore firstaddr integerand integerneg ,
nameload cleararray setbit integeror)
if ok.no
end
scope project.drum shortload wordload doubleload ,
firstaddr integerand integerneg,
nameload ,
setbit integeror,
cleararray,
bytestore wordstore doublestore
if ok.yes
message permanent ok)
;hcø 31-7-72
;code procedures for register handling
;the load and store procedures uses addr
;as the address where to load or store
;the load procedures gives if possible the
;storage word addressed as the result
;integer procedure byte_load(addr);
;value addr; integer addr;
;comment work exactly as the mashineinstruction
;bytezero;
;integer procedure short_load(addr);
;value addr; integer addr;
;integer procedure word_load(addr);
;value addr; integer addr;
;long procedure double_load(addr);
;value addr; integer addr;
;procedure byte_store(addr,byte);
;value addr,byte; integer addr;
;procedure word_store(addr,word);
;value addr,word; integer addr,word;
;procedure double_store(addr,double);
;value addr,double; integer addr; long double;
;integer procedure first_addr(a);
;undef a;
;comment finds the first address of an array
;or a variable. In case of a simple
;double word variable it is the the last
;word which is the address;
;integer procedure integerand(i1,i2);
;value i1,i2; integer i1,i2;
;comment the value of the procedure is an
;logical and bit for bit of the two integers;
;integer procedure integerneg(i);
;value i; integer i;
;comment the value of the procedure is a logical
;negation of the integer;
;procedure name_load(addr,a);
;value addr; integer addr;
;<any type> array a;
;comment the two double words from addr and
;forwards is stored in the first elements of a;
;integer procedure io(dev_no,command,data);
;integer dev_no,command,data;
;comment the value of the procedure is the value of the
;exseption register;
;procedure clear_array(a);
;<any type> array a;
;comment sets all elements of a equal to zero (bitpattern);
;integer procedure own_descr;
;comment finds the process description address of the process
;integer console;
;comment process description address of parent console
;it is not defined here but is set as:
;console=set 0 0 0 576.38 0 4.0 0
;integer parent;
;comment the parent process description address
;it is not defined here but is set in the catalog as:
;parent=set 0 0 0 576.41 0 4.0 0;
;integer procedure set_bit(word,bitno,bitvalue);
;integer word,bitno,bitvalue;
;comment the result is the integer word where
;the bit given by bitno is changed acording to
;bitvalue (0 or 1);
;integr procedure integer_or(i1,i2);
;value i1,i2, integer i1,i2;
;comment the valu of the procedure is a logical
;or bit for bit of two integers;
;b. ;fpnames dummy block
b. g1, e20 w. ;block with names for tails and insertproc
k=10000
s. g6,j46,f7,b15,i4 ;start of slang segment for procedures
h.
g0=0 ;g0:=no of externals
e20:
g1: g2 , g2 ;head word: rel of last point, rel of last abs word
j13: g0 + 13 , 0 ;RS entry 13, last used
j30: g0 + 30 , 0 ;RS entry 30, saved stack ref, saved w3
j4: g0 + 4 , 0 ;RS entry 4, take expression
j6: g0 + 6 , 0 ;RS entry 6, end register expression
j8: g0 + 8 , 0 ;RS entry 8, end address expression
j29: g0 + 29 , 0 ;RS entry 29, param alarm
g2 = k-2-g1 ;end of abs words:=end of points
w.
e0: g0 ;start external list
0
31 07 72,18 00 00
w.
e1: ;entry byte_load
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take integer param
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
rl w1 x1 ;w1:=addr
bz w1 x1 ;w1:=byte;
jl. (j6.) ;end register expression
e2: ;entry short_load
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take integer param
so w0 16 ;if expr then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
rl w1 x1 ;w1:=addr
bl w1 x1 ;w1:=extended byte
jl. (j6.) ;end register expression
e3: ;entry word_load
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref , saved w3
dl w1 x2+8 ;take integer param addr
so w0 16 ;if expr then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;saved stack ref,saved w3
rl w1 x1 ;w1:=addr
rl w1 x1 ;w1:=word
jl. (j6.) ;end register expression
e4: ;entry double_load
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take integer param
so w0 16 ;if expression then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;saved stack ref, saved w3
rl w1 x1 ;w1:= address
dl w1 x1 ;w1w0:=double word
jl. (j6.) ;end register expression
e5: ;entry byte_store
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take integer param addr
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
rs w1 x2+8 ;store addr
dl w1 x2+12 ;take integer param byte
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
rl w0 x1 ;w0:=byte
rl w1 (x2+8) ;w1:=addr
hs w0 x1 ;store byte
jl. (j8.) ;end address expression
e6: ;entry word_store
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take param
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
rs w1 x2+8 ;store addr
dl w1 x2+12 ;take integer param word
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
rl w0 x1 ;w0:=word
rl w1 (x2+8) ;w1:=addr
rs w0 x1 ;store word
jl. (j8.) ;end address expression
e7: ;entry double_store
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take integer param addr
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
rs w1 x2+8 ;store addr
dl w1 x2+12 ;take long param double
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w0 x1 ;w0w3:=double
rl w1 (x2+8) ;w1:=addr
ds w0 x1 ;store double
jl. (j8.) ;end address expression
e8: ;entry first_addr
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take param
al w3 2.11111;w3:=check mask
la w3 0 ;kind:=bits(19:23).formal1
sn w3 23 ;if kind=zone then
al w3 19 ;kind=real array
sh w3 22 ;if kind>22 then begin
jl. i2.
rl w1 x2+8 ;first_addr:=addr(variable);
jl. (j6.) ;end register expression
i2: sh w3 16 ;kind<17 then
jl. w3 (j29.) ;param alarm
ba w1 0 ;w1:=abs dope addr
rl w3 x1 ;w3:=lower index-K(K=2)
wa w3 (x2+8) ;
al w1 x3+2 ;w1:=abs addr first element
jl. (j6.) ;end register expression
e9: ;entry integerand:
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take integer param i1
so w0 16 ;if expression then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;saved stack ref, saved w3
rs w1 x2+8 ;store i1
dl w1 x2+12 ;take integer param i2
so w0 16 ;if expression then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;saved stack ref, saved w3
rl w1 (x2+12) ;w1:=i2
la w1 (x2+8) ;w1:=i1 and i2
jl. (j6.) ;end register expression
e10: ;entry integerneg:
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take integer param i
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;saved stack ref, saved w3
rl w1 x1 ;w1:=i
lx. w1 b10. ;i:=-,i
jl. (j6.) ;end register expression
e11: ;entry name_load
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take param addr
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref , save w3
rl w3 x1 ;w3:=addr
dl w1 x2+12 ;take param a
la. w0 b11. ;w0:=kind
sh w0 23 ;if kind=zone then
al w0 19 ;kind:=array
sh w0 20 ;if kind=variable or
sh w0 16 ;kind=expression or procedure then
jl. w3 (j29.) ;goto param alarm
ba w1 x2+10 ;w1:=dope addr
rl w0 x1-2 ;w0:=lower index
ws w0 x1 ;
rl w1 x1 ;w1:=first addr - K
wa w1 (x2+12) ;w1:=first addr
rl w2 2 ;w2:=first addr
dl w1 x3+2 ;get first double
ds w1 x2+4 ;store first double
dl w1 x3+6 ;get last double
ds w1 x2+8 ;store last double
jl. (j8.) ;end address expression
c.-1
e12: ;entry i_o:
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take param dev_no
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+12 ;take param command
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+16 ;take param data
so w0 16 ;if expression then
jl. w3 (j4.) ;goto take expression
ds. w3 (j30.) ;save stack ref, save w3
rl w0 x1 ;w0:=data
rl w1 (x2+8) ;w1:=dev_no
ls w1 6 ;devno:=devno shift 6
lo w1 (x2+12) ;or command
io w0 x1 ;io commando (pr 0 pk 0)
rs w0 (x2+16) ;store data
xs 3 ;w1:=exseption
la. w1 i0. ;w1:=busy or disconnect
jl. (j6.) ;end register expression
i0: 2.11 ;mask
z.
e13: ;entry clear array:
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take param a
la. w0 b11. ;w0:=kind
sh w0 23 ;if kind=zone then
al w0 19 ;kind:=array
sh w0 20 ;if kind=variable or
sh w0 16 ;kind=procedure or expression then
jl. w3 (j29.) ;goto RS param alarm
ba w1 x2+6 ;w1:=abs dope addr
rl w3 x1 ;w3:=lower-K
wa w3 (x2+8) ;
al w3 x3+2 ;w3:=first
rl w1 x1-2 ;w1:=upper
wa w1 (x2+8) ;w1:=last
al w0 0 ;w0:=0;
i1: ;loop
rs w0 x3 ;a(i):=0;
al w3 x3+2 ;i:=i+1;
sh w3 x1+1 ;if i>upper then
jl. i1. ;goto loop else
jl. (j8.) ;end address expression
e15: ;entry set_bit:
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take param word
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+12 ;take param bitno
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+16 ;take param bit
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
rl w1 x1 ;w1:=bitvalue
se w1 0 ;if bitvalue=1 then
jl. i3. ;goto set
al w1 1 ;clear:
rl w3 (x2+12) ;shift
ls w1 x3 ;shift bit
al w3 -1
lx w1 6 ;w1:=-,shift bit
la w1 (x2+8) ;word and w1
jl. (j6.) ;end register expression
i3: rl w3 (x2+12) ;shift
ls w1 x3 ;shift bit
lo w1 (x2+8) ;result:=word or bitmask
jl. (j6.) ;end register expression
e16: ;entry integer_or:
rl. w2 (j13.) ;w2:=last used;
ds. w3 (j30.) ;saved stack ref, saved w3
dl w1 x2+8 ;take param i1
so w0 16 ;if expr then
jl. w3 (j4.) ;take expression;
ds. w3 (j30.) ;saved stack ref, saved w3
rs w1 x2+8 ;saved param i1
dl w1 x2+12 ;take param i2
so w0 16 ;if expr then
jl. w3 (j4.) ;take expression;
ds. w3 (j30.) ;saved stack ref, saved w3
rl w1 x1 ;
lo w1 (x2+8) ;integeror:=i1 <logical or> i2;
jl. (j6.) ;end register expr.
b10: -1
b11: 2.11111 ;array mask
m. end code of this segment
h. 0,r.(:10504-k:) w.
<:registerpro<0>:>
e. ;end slang segment
;byte_load:
g0: 1 ;first tail: area with 1 segment
0,0,0,0 ;fill
1<23+e1-e20 ;entry point byte_load
3<18+19<12,0 ;integer procedure(address integer);
4<12+e0-e20 ;code proc start of external
1<12 ;1 code segment
;short_load:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e2-e20 ;entry point short_load
3<18+19<12,0 ;integer procedure(address integer);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;word_load:
1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e3-e20 ;entry point word_load
3<18+19<12,0 ;integer procedure(address integer);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;double_load:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e4-e20 ;entry point double_load
5<18+19<12,0 ;long procedure(address integer);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;byte_store:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e5-e20 ;entry point byte_store
1<18+19<12+19<6,0;procedure(address integer,address integer);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;word_store:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e6-e20 ;entry point word_store
1<18+19<12+19<6,0;procedure(address integer,address integer);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;double_store:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e7-e20 ;entry point double_store
1<18+21<12+19<6,0;procedure(address integer,address long);
4<12+e0-e20 ;code proc ext list
1<12 ;1 code segment
;first_addr:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e8-e20 ;entry point first addr
3<18+41<12,0 ;integer procedure(undefined);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;integerand:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e9-e20 ;entry point integerand
3<18+19<12+19<6,0;integer procedure(value integer,value integer);
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;integerneg:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e10-e20 ;entry point integerneg
3<18+19<12,0 ;integer procedure(value integer)
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
;nameload:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e11-e20 ;entry point name_load
1<18+41<12+19<6,0;procedure(address integer,undef)
4<12+e0-e20 ;code proc , start of external
1<12 ;1 code segment
c.-1
;i_o:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e12-e20 ;entry point i_o
3<18+19<12+19<6+19,0;integer procedure(int,int,int);
4<12+e0-e20 ;code proc, start external
1<12 ;1 code segment
z.
;clear_array:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e13-e20 ;entry point clear_array
1<18+41<12,0 ;procedure(undef);
4<12+e0-e20 ;code proc, start external
1<12 ;1 code segment
;set_bit:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e15-e20 ;entry point set_bit
3<18+19<12+19<6+19,0;integer procedure(int, int, int);
4<12+e0-e20 ;code proc, start external
1<12 ;1 code segment
;integer_or:
g1: 1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e16-e20 ;entry point integer_or
3<18+19<12+19<6 ;integer procedure(address integer,
0 ; address integer);
4<12+e0-e20 ;code proc, start of external
1<12 ;1 code segment
;end
n.
(message scopepro
lookup scopepro
if ok.yes
(scope temp scopepro scopeuser
clear temp scopepro scopeuser)
scopepro=set 1
(scopepro=slang fpnames list.no type.yes insertproc entry.no
scopepro scopeuser)
if ok.no
end
message slang ok
scope project.drum scopeuser
message permanent ok)
;b. ;fpnames dummyblock
b. g1, e20 w. ;block with names for tail and insertproc
k=10000
s. g2,b4,j45,i5,h4,d1 ;start of slang segment for procedures
h.
g0=0 ;g0:= no of externals
e20:
g1: g2 , g2 ;head word: rel of last point, rel of last abs word
j4: g0 + 4, 0 ;RS entry 4, take expression
j6: g0 + 6, 0 ;RS entry 6, end register expression
j12: g0 + 12, 0 ;Rs entry 12, uv
j13: g0 + 13, 0 ;RS entry 13, last used
j16: g0 + 16, 0 ;RS entry 16, segment table base
j29: g0 + 29, 0 ;RS entry 29, param alarm
j30: g0 + 30, 0 ;RS entry 30, saved stack ref, saved w3
j42: g0 + 42, 0 ;RS entry 42, victim (start of RS-table)
g2 = k-2-g1 ; end of abs words:= end of points
w.
e0: g0 ;start externals list
0
30 08 78,15 00 00
b2: 8
b3: 16 ;
b4: 24 ;
h0: 0, h1: 0,r.9 ;tail address
h2: 0 ; name address
h3: 0,r.10 ;
h4: <:drum:>,0,0,0 ;
p.<:takestring:>
w.
;integer procedure scope_pro(name)
;the procedure change the permkey of the entry specifided by the name
;to 3,and change the base so that they follow standard.
e1: rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref save w3
dl w1 x2+8 ;get param name
so w0 16 ;if string expression then
jl. w3 (j4.) ;
ds. w3 (j30.) ;
jl. w3 d1. ;w3:=take string1(name);
al w1 3 ;permkey:=3
jd 1<11+50 ;permentry
se w0 0 ;if result not ok then
jl. i0. ; end register expression
al. w1 h0. ;w1:=tail address
jd 1<11+42 ;lookup entry
sn w0 0 ;if result not ok then
jl. i1. ;
wa. w0 b3. ;result:=result+16;
jl. i0. ;
i1: rl. w2 h0. ;w2:=size
sl w2 0 ;if size < 0 then perm entry in auxcat
jl. i3. ;
dl. w1 h4.+2 ; docname:=drum
ds. w1 h3.+4 ;
dl. w1 h4.+6 ;
ds. w1 h3.+8 ;
rs. w3 h2. ; save w3
al. w3 h1.
al. w1 h3. ; w2:= name
jd 1 < 11 + 42 ; lookup up entry
rl. w3 h2. ;
rl. w2 h3.+2 ; w2:=docname address
al w1 3 ;w1:=permkey
jd 1<11+90 ;permentry in auxcat
sn w0 0 ;
jl. i3. ;end register expression
wa. w0 b4. ;
jl. i0. ;
i3: rl w1 66 ;w1:=current process
dl w1 x1+74 ;set max bese
jd 1<11+74 ;set entry base
se w0 0 ;if result not ok then
wa. w0 b2. ;result:=result+8
i0: rl w1 0 ; w1:=result
jl. (j6.) ; end register expression
;integer procedure scope_user(name)
;the procedure change the permkey of the entry specifided by the name
;to 3,and change the base so that they follow standard.
e2: rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref save w3
dl w1 x2+8 ;get param name
so w0 16 ;if string expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;
jl. w3 d1. ;w3:=take string1(name);
al w1 3 ;permkey:=3
jd 1<11+50 ;permentry
se w0 0 ;if result not ok then
jl. i0. ; end register expression
al. w1 h0. ;w1:=tail address
jd 1<11+42 ;lookup entry
sn w0 0 ;if result not ok then
jl. w0 i4. ;
wa. w0 b3. ;result:=result+16;
jl. i0. ;
i4: rl. w2 h0. ;w2:=size
sl w2 0 ;if size < 0 then perm entry in auxcat
jl. i5. ;
dl. w1 h4.+2 ; docname:=drum
ds. w1 h3.+4 ;
dl. w1 h4.+6 ;
ds. w1 h3.+8 ;
rs. w3 h2. ; save w3
al. w3 h1. ; w3:= name
al. w1 h3. ; w1:=docname
jd 1 < 11 + 42 ; lookup entry
rl. w3 h2. ;
rl. w2 h3.+2 ;w2:=docname
al w1 3 ;w1:=permkey
jd 1<11+90 ;permentry in auxcat
sn w0 0 ;
jl. w0 i5. ;end register expression
wa. w0 b4. ;
jl. i0. ;
i5: rl. w2 j42. ;
rl w1 x2+32 ;get base of filprocessor
rl w0 x1+h58-2 ;w0:=lower user base
rl w1 x1+h58 ;w1:=upper user base
jd 1<11+74 ;set entry base
se w0 0 ;if result not ok then
wa. w0 b2. ;result:=result+8
jl. i0. ;end register expression
w.
m. end code of this segment
h. 0,r.(:10504-k:) w.
<:scopepro <0>:>
e.
;scope project
g0: 1 ;first tail: area with 1 segment
0,0,0,0 ;fill
1<23+e1-e20 ;entry point scope project.disc
3<18+41<12,0 ;integer procedure scope_project(name)
4<12+e0-e20 ;code proc,start of externals
1<12 ;1 code segment
;scope user
g1: 1<23 +4 ;modekind backingstore
0,0,0,0 ;fill
1<23+e2-e20 ;entry point scope user
3<18+41<12,0 ;integer procedure scope_user(name)
4<12+e0-e20 ;code proc start of externals
1<12 ;1 code segment
n.
clear project trapbase lastused console parent
trapbase=set 0 drum 0 576.39 0 4.0 0
lastused=set 0 drum 0 576.13 0 4.0 0
console=set 0 drum 0 576.38 0 4.0 0
parent=set 0 drum 0 576.41 0 4.0 0
scope project.drum trapbase lastused console parent
(message setcatbase
lookup setcatbase
if ok.yes
(scope temp setcatbase setenbase setbsclaims scopetemp scopelogin
clear temp setcatbase setenbase setbsclaims scopetemp scopelogin)
setcatbase=set 1
(setcatbase=slang fpnames list.no type.yes insertproc entry.no
setcatbase setenbase setbsclaims,
scopetemp scopelogin )
if ok.no
end
message slang ok
scope project.drum setenbase setbsclaims,
scopetemp scopelogin
message permanent ok)
;b. ;fpnames dummyblock
b. g1, e20 w. ;block with names for tail and insertproc
k=10000
s. g2,b3,j45,i3,h3,d1 ;start of slang segment for procedures
h.
g0=0 ;g0:= no of externals
e20:
g1: g2 , g2 ;head word: rel of last point, rel of last abs word
j4: g0 + 4, 0 ;RS entry 4, take expression
j6: g0 + 6, 0 ;RS entry 6, end register expression
j12: g0 + 12, 0 ;Rs entry 12, uv
j13: g0 + 13, 0 ;RS entry 13, last used
j16: g0 + 16, 0 ;RS entry 16, segment table base
j29: g0 + 29, 0 ;RS entry 29, param alarm
j30: g0 + 30, 0 ;RS entry 30, saved stack ref, saved w3
j42: g0 + 42, 0 ;RS entry 42, victim (start of RS-table)
g2 = k-2-g1 ; end of abs words:= end of points
w.
e0: g0 ;start externals list
0
30 08 78,15 00 00
b2: 8
b3: 16 ;
h0: 0, h1: 0,r.9 ;tail address
p.<:takestring:>
w.
i0: rl w1 0 ; w1:= result
jl. (j6.) ; end register expression
;integer procedure set_cat_base(name,lower base,upper base)
;The procedure changes the catalog base of an intenal process.
e1:
rl. w2 (j13.) ;w2:= last used
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ;take param name
so w0 16 ;if string expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=takestring1(name);
al w2 x2-6 ;
rs w3 x2+8 ;b0:=name adress
dl w1 x2+12 ;take param lower base
so w0 16 ;if expr then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
rs w1 x2+12 ;w1:=lower base
dl w1 x2+16 ;take param upper base
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
rl w3 x2+8 ;w3:=name adress
rl w0 (x2+12) ;w1:=lower base
rl w1 x1 ;
jd 1<11+72 ;set_catalog base
jl. i0. ;end register expression
;integer procedure set_entry_base(name,lower_base,upper_base)
;The procedure will set the base of main catalog entry specified
;by the name, provided the entry is not projected against the calling
;process.
e2: rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref,save w3
dl w1 x2+8 ;take param name
so w0 16 ;if string expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
jl. w3 d1. ;w3:=take string1(name);
al w2 x2-6 ;
rs w3 x2+8 ;b0:=name adress
dl w1 x2+12 ;take param lower base
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
rs w1 x2+12 ;b1:=adress of lower base
dl w1 x2+16 ;take param upper base
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref ,save w3
rl w3 x2+8 ;w3:=name adress
rl w0 (x2+12);w0:=lower base
rl w1 x1 ;
jd 1<11+74 ;set catalog entry
jl. i0. ;end register expression
;integer procedure set_backings_claims(name,documentname,claimlistadres)
;The procedure will transfer backing storage claims,corresponding to
;the document specified by the document name, between the calling process
;and the process specified by the process name.
e3: rl. w2 (j13.) ;w2:= last used
ds. w3 (j30.) ;save stack ref ,save w3
dl w1 x2+8 ;take param name
so w0 16 ;if string expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
jl. w3 d1. ;w3:=take string1(name);
al w2 x2-6 ; w2:=last used
rs w3 x2+8 ;save name adress
dl w1 x2+12 ;take param document name
so w0 16 ;if string expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;svae stack ref, save w3
al w2 x2+10 ;w2:=first formal
jl. w3 d0. ;takestring
al w2 x2-10 ;w2:=last used
rs w3 x2+12 ;b1:=document name adress
dl w1 x2+16 ; take param integer array
ba w1 0 ;w1:=abs dope
rl w1 x1 ; w1:=lower index-K
wa w1 (x2+16) ;
al w1 x1+2 ; w1:=abs address integer array
rl w3 x2+8 ; w3:=name adress
rl w2 x2+12 ; w2:=document address
jd 1<11+78 ;set_backings_claim
rl w1 0 ;set_backings_claim:= result
jl. (j6.) ;end register expression
;integer procedure scope_temp(name)
;The procedure will change the permkey of the entry specified by name
;to 0, and change the base so that they follow the standard for an tem-
;porari entry.
e4: rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;svae stack ref, save w3
dl w1 x2+8 ;get parameter name
so w0 16 ;if string expression
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
jl. w3 d1. ;w3:=take string1(name);
al w1 0 ;permkey:=0;
jd 1<11+50 ;permentry
se w0 0 ;if result not ok then
jl. i0. ;end register expression
rl w1 66 ;w1:=current process
dl w1 x1+78 ;set standard base
jd 1<11+74 ;set entry base
se w0 0 ;if result not ok then
wa. w0 b2. ;result:=result+8;
jl. i0. ;end register expression
;integer procedure scope_login(name);
;The procedure will change the permkey to 2 of the entry specified by the name
;and change the entryes bases so that they follow the standard.
e5: rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref,save w3
dl w1 x2+8 ;get param name
so w0 16 ;if string expression then
jl. w3 (j4.) ; take expression
ds. w3 (j30.) ;save stack ref,save w3
jl. w3 d1. ;w3:=takestring1(name);
al w1 2 ;permkey:= 2;
jd 1<11+50 ;permentry
se w0 0 ;if result not ok then
jl. i0. ;end register expression
rl w1 66 ;w1:=current process
dl w1 x1+78 ;set std base
jd 1<11+74 ; set entry base
se w0 0 ; if result not ok then
wa. w0 b2. ;result:=result+8
jl. i0. ;end register expression
w.
m. end code of this segment
h. 0,r.(:10504-k:) w.
<:setcatbase <0>:>
e.
;setcatbase
g0: 1 ;first tail:area with 1 segment
0,0,0,0 ;fill
1<23+e1-e20 ;Entry point set catalogbase
3<18+19<12+19<6+41,0;Integer procedure setcatbase(name,lower,Upper)
4<12+e0-e20 ;code proc ,start of externals
1<12 ; 1 code segment
;setentrybase
1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e2-e20 ;entry point setentrybase
3<18+19<12+19<6+41,0;integer procedure setentrybase(name lower upper)
4<12+e0-e20 ;code proc ,start of externals
1<12 ;1 code segment
;setbackingstoreclaim
1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e3-e20 ;entry point setbackingsclaims
3<18+25<12+41<6+41,0;integer procedure setbackingsclaim(name,dname,cla
4<12+e0-e20 ;code proc ,start of externals
1<12 ;1 code segment
;scope_temp
1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e4-e20 ;entry point scopetemp
3<18+41<12,0 ;integer procedure scope_temp(name)
4<12+e0-e20 ;code proc, start of externals
1<12 ;1 code segment
;scope login
g1: 1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e5-e20 ;entry point scope login
3<18+41<12,0 ;integr procedure scope_login(name)
4<12+e0-e20 ;code proc start of externals
1<12 ;1 code segment
n.
(message changetail
lookup changetail
if ok.yes
(scope temp changetail headandtail reservesegm wait sendanswer owndescr
clear temp changetail headandtail reservesegm wait sendanswer owndescr)
changetail=set 1
(changetail= slang fpnames list.no type.yes insertproc entry.no
changetail headandtail reservesegm wait,
sendanswer owndescr)
if ok.no
end
message slang ok
scope project.drum headandtail reservesegm wait sendanswer owndescr
message permanent ok)
;hcø 31-7-72
;code procedures for communication with the backing store
;the value of the procedures is the result of the
;corresponding monitorprocedures
;all parameters are call values
;integer procedure head and tail;
;integer procedure reserve_segm(name,segm);
;value segm; integer segm;
;string or <any type> array name;
;integer procedure change_tail(name,tail);
;integer array tail;
;string or <any type> array name;
;procedure wait(sec);
;comment sends a message to the clock and waits for the answer;
;value sec;integer sec;
;procedure send answer(result,bufferaddres,answer);
;addres result,bufferaddress;integer result,bufferaddres;
;integer array answer;
;integer procedure owndescr;
;comment finds the process description address of current process;
;b. ;fpnames dummy block
b. g1, e20 w. ;block with names for tails and insertproc
k=10000
s. g6,j48,f7,b15,i10,d3;start of slang segment for procedures
h.
g0=0 ;g0:=no of externals
e20:
g1: g2 , g2 ;head word: rel of last point, rel of last abs word
j4: g0 + 4 , 0 ;RS entry 4, take expression
j6: g0 + 6 , 0 ;RS entry 6,end register expression
j8: g0 + 8 , 0 ;RS entry 8,end address expression
j12: g0 + 12 , 0 ;RS entry 12, UV
j13: g0 + 13 , 0 ;RS entry 13, last used
j16: g0 + 16 , 0 ;RS entry 16, segment table base
j29: g0 + 29 , 0 ;RS entry 29, param alarm
j30: g0 + 30 , 0 ;RS entry 30,saved stack ref, saved w3
g2 = k-2-g1 ;end of abs words:=end of points
w.
e0: g0 ;start external list
0
25 04 73,14 00 00
b0: 0 , b1: 0,r.4 ;name
b2: 0 , b3: 0,r.9 ;tail
p. <:takestring:>
w.
i0: rl w1 0 ; w1:=result;
jl. (j6.) ; end register expression
e1: ; entry changetail
rl. w2 (j13.) ;w2:=last used;
ds. w3 (j30.) ;saved stack ref , saved w3
dl w1 x2+8 ;get parameter name
so w0 16 ;if expr then
jl. w3 (j4.) ;take expression;
ds. w3 (j30.) ;saved stack ref , saved w3
jl. w3 d1. ;w3:=takestring1(name);
dl w1 x2+ 6 ;get parameter tail
ba w1 0 ;w1:=abs dope addr;
rl w1 x1 ;w1:=lower index-K (K=2);
wa w1 (x2+ 6) ;
al w1 x1+2 ;w1:=first addr;
jd 1<11+44 ;change entry;
jl. i0. ;end register expression
e2: ; entry head and tail
rl. w2 (j13.) ;w2:= stack ref
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+8 ; take name param
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ; save stack ref, save w3
jl. w3 d1. ;w3:=take string1(name);
dl w1 x2+ 6 ;take param tail
ba w1 0 ;w1:=abs dope addr
rl w1 x1 ;w1:=lower index-k
wa w1 (x2+ 6) ;
al w1 x1+2 ;w1:=first addr
jd 1<11+76 ; lookup head and tail
jl. i0. ; end regiater expression
e3: ; entry reserve segm
rl. w2 (j13.) ;w2:=stack segm
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+12 ;take integer param segm
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
dl w1 x1 ;w1w0:=value
rl w3 x2+10 ;w3:=first formal
sz w3 1 ;if real then
cf w1 0 ;conver to integer
rs w1 x2+10 ;save variable
dl w1 x2+8 ;take param name
so w0 16 ;if expressionthen
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
jl. w3 d1. ;w3:=take string1(name);
rl w0 x2+ 4 ;w0:=segm
al. w1 b2. ;w1:=tail addr
rs w0 x1+0 ;store segment
al w0 0 ;
rs w0 x1+2 ;
rs w0 x1+4 ;
rs w0 x1+6 ;
rs w0 x1+8 ;
rs w0 x1+10 ;
rs w0 x1+12 ;
rs w0 x1+14 ;
rs w0 x1+16 ;
rs w0 x1+18 ;
jd 1<11+40 ;create entry
jl. i0. ;end registerexpression
e4: ;entry wait
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;saved stack ref,save w3
dl w1 x2+8 ;take integer param
so w0 16 ;if expression then
jl. w3 (j4.) ;goto RS take expression
ds. w3 (j30.) ;save stack ref, save w3
rl w0 x1 ;w0:=sec
rs. w0 b8. ;store sec
al. w1 b7. ;w1:=message area
al. w3 b9. ;w3:=answer area
jd 1<11+16 ;send message(<:clock:>);
jd 1<11+18 ;wait answer
jl. (j8.) ;end addres expression
e5: ;send answer
rl. w2 (j13.) ;w2:=stack ref
ds. w3 (j30.) ;save stack ref,save w3
dl w1 x2+12 ;take buffer-address param
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref,save w3
dl w1 x2+8 ;take param result
so w0 16 ;if expression then
jl. w3 (j4.) ;take expression
ds. w3 (j30.) ;save stack ref, save w3
dl w1 x2+16 ;take param answer
ba w1 0 ;w1:= abs dope addr
rl w1 x1 ;w1:=lower index-k
wa w1 (x2+16);
al w1 x1+2 ;w1:=first addr
rl w0 (x2+8) ;w0:=result
rl w2 (x2+12);w2:=buffer address
jd 1<11+22 ;send answer
jl. (j8.) ;end addres expression
e6: ;entry own descr
rl. w2 (j13.) ;w2:=last used
ds. w3 (j30.) ;save stack ref, save w3
rl w1 66 ;w1:=cur
jl. (j6.) ;end register expression
w.
b7: 0,
b8: 0,r.7
b9: <:clock:>,0,0,0
b13:13 0, b14: 0 ;work area item
b15: 2.11111 ;kind mark
f0: <:<10>arr size:>
m. end code of this segment
h. 0,r.(:10504-k:) w.
<:bsproc2 <0>:>
e. ;
;change_tail:
g0: 1 ;first tail:area with 1 segment
0,0,0,0 ;fill
1<23+e1-e20 ;tail point change entry
3<18+25<12+41<6;integer procedure(undef,integer array)
0 ;
4<12+e0-e20 ;code proc, start of external
1<12+00 ;1 code segment
;head_and_tail:
1<23+4 ;modekind=backing store
0,0,0,0 ;fill
1<23+e2-e20 ;entry point head_and_tail
3<18+25<12+41<6,0;integer procedure(string, integer array);
4<12+e0-e20 ;code proc , start of external
1<12+00 ;1 code segment
;reserve segm:
1<23+4 ;modekind =backingstore
0,0,0,0 ;fill
1<23+e3-e20 ;entry point reserve segm
3<18+13<12+41<6,0;integer procedure(string,integer array);
4<12+e0-e20 ;code proc , star of externals
1<12+00 ;1 code segment
;wait
1<23+4 ;modekind = backing store
0,0,0,0 ;fill
1<23+e4-e20 ;entry point wait
1<18+19<12,0 ;procedure wait(value integer);
4<12+e0-e20 ;code proc , start af external
1<12+00 ;1 code segment
;send answer:
1<23+4 ;modekind=backingstore
0,0,0,0 ;fill
1<23+e5-e20 ;entry point send answer
1<18+25<12+19<6+19,0;procedure(integer,integer,integer array);
4<12+e0-e20 ;code proc , satrt of externals
1<12 ;1 code segm
;owndescr:
g1: 1<23+4 ;modekind = backingstore
0,0,0,0 ;fill
1<23+e6-e20 ;entry point owndescr
3<18,0 ;integer procedure
4<12+e0-e20 ;codeproc, start external
4<12 ;1 code segment
n.
mode list.yes
initcode=compresslib alarm regretmess checkpda unstackcuri starti callcode,
sendmessid lookupentry movetext initproc lookupaux,
waitmessage byteload scopepro setcatbase changetail
scope project initcode
scope project.drum alarm regretmess checkpda unstackcuri starti callcode,
sendmessid lookupentry movetext initproc lookupaux,
waitmessage byteload scopepro setcatbase changetail
mode list.no
▶EOF◀