|
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: 13824 (0x3600)
Types: TextFile
Names: »tcomalmove«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »tcomalmove«
\f
; comalmove pss 78.06.28 page .. 1..
b. g1, e5 w.
k=0
s. g10, j50, f10, b50
h.
g0=0 ; g0=number of externals
e5 :
g1 : g2 , g2 ; head word: rel last point, absword
j6 : g0+6 , 0 ; rs entry end register expression
j13 : g0+13 , 0 ; rs entry last used
j21 : g0+21 , 0 ; rs entry general alarm
j30 : g0+30 , 0 ; rs entry save sref, save w3
g2=k-2-g1 ; end of abswords = end of points
w.
e0 : g0 ; start external list: no externals;
0 ; no perm core
s3 ; date
s4 ; time
\f
; comalmove pss 78.06.28 page .. 2..
; global working variables
f0 : 6<12 + 23 ; first formal of zone param
f1 : 0 ; count
f2 : 0 ; work count
f3 : 0 ; zero count flag
; entry
e1 : ;
rl. w2 (j13.) ; w2:=stack ref:=last used
ds. w3 (j30.) ; save stackref, save w3
; check parameters
al w3 0 ; param:=false;
rl w0(x2+20) ; get value of count
al w1 0 ; zero count flag:=if count=0 then 0
se w0 0 ; else 3;
al w1 3 ;
rs. w1 f3. ;
sh w0 0 ; if count <= 0 then
al w0 0 ; count:=0;
bs. w0 1 ; count:=count-1;
rs. w0 f1. ;
dl w1 x2+16 ; get formal of fromfield
se w0 26 ; if kind<>integer var/const/exprcompcall
al w3 1 ; then param:=true;
rl w0 x1 ;
rs w0 x2+20 ; fromfield:=call value fromfield;
dl w1 x2+12 ; get formal of tofield
se w0 26 ; if kind<>integer var/const/exprcompcall
al w3 1 ; then param:=true;
rl w0 x1 ;
rs w0 x2+18 ; tofield:=call value tofield;
\f
; comalmove pss 78.06.28 page .. 3..
se w3 0 ; if param then
jl. b0. ; goto paramerror;
dl w1 x2+8 ; get formal of base;
se. w0 (f0.) ; if type of base = zone then
jl. b1. ; begin
rl w0 x1+h2+6 ; if (zone.state <> after read,readchar,
sl w0 1 ; readstring, readall, repeatchar, write,
sn w0 4 ; inrec, outrec or swoprec) then
jl. b2. ; goto zstateerror;
sn w0 8 ;
jl. b2. ;
rl w0 x1+h3+2 ;
ws w0 x1+h3+0 ; fieldlimit:=z.last byte-z.basebufarea;
rs w0 x2+14 ;
dl w3 x2+20 ;
sl w2 1 ; if tofield<1 or
sh w3 0 ; fromfield<=0 then
jl. b3. ; goto fielderror;
wa. w2 f1. ; if tofield+count > fieldlimit or
wa. w3 f1. ; fromfield+count-1 >= fieldlimit then
al w3 x3-1 ;
sh w2 (0) ;
sl w3 (0) ;
jl. b3. ; goto fielderror;
rl. w2 (j13.) ; restore stackref;
rl w3 x1+h3+0 ; base address:=zone.base buf area;
jl. b4. ; goto compute start address;
; end <*zone*> else
\f
; comalmove pss 78.06.28 page .. 4..
b1 : ; begin
ld w0 12 ;
ls w0 -12 ;
sl w0 17 ; if kind<>boolean, integer, real
sl w0 21 ; or long array then
jl. b0. ; goto paramerror;
wa w3 x2+8 ; dopeadr:=base adr + dope rel;
rl w0 x3-2 ; fieldlimit:=dope.upper index value;
rs w0 x2+14 ;
al w0 1 ; field:=tofield;
b5 : ; rep:
am (0) ;
rl w1 x2+18 ;
sh w1(x3) ; if field <= (low index val - k) then
jl. b3. ; goto fielderror;
wa. w1 f1, ;
sh. w0 (f3.) ;
al w1 x1-1 ;
sl w1(x3-2) ; if field+count-1 >= upp index val then
jl. b3. ; goto dieldepror;
ba. w0 1 ; if field=tofield then
sh w0 2 ; begin field:=fromfield;
jl. b5. ; goto rep;
; end;
rl w3(x2+8) ; base address:=array base address;
; end array;
\f
; comalmove pss 78.06.28 page .. 4..
; compute start address:
b4 : dl w2 x2+20 ;
wa w1 6 ; to:=base address + tofield;
wa w2 6 ; from:=base address + fromfield;
rl. w3 f1. ; count;
sh w1 x2 ; if to > from then
jl. b6. ; begin
; move area starting from higher addresses
wa w1 6 ; to:=to+count;
wa w2 6 ; from:=from+count;
al w3 x3+1 ; count:=count+1;
sh w3 0 ; if count<=0 then
jl. b15. ; goto done;
sz w1 1 ; if to is even then
jl. b7. ; begin
bz w0 x2 ;
hs w0 x1 ; move one byte;
al w1 x1-1 ; to:=to-1;
al w2 x2-1 ; from:=from-1;
al w3 x3-1 ; count:=count-1;
; end;
b7 : sh w3 7 ; if count < 8 then
jl. b8. ; goto movetail;
so w2 1 ; if from is even then
jl. b9. ; goto moveright;
b10 : rs. w3 f2. ; movestraight:
dl w0 x2 ;
ds w0 x1 ;
dl w0 x2-4 ;
ds w0 x1-4 ; move 8 halfwords;
al w1 x1-8 ; t0:=to-8;
al w2 x2-8 ; from:=from-8;
rl. w3 f2. ;
al w3 x3-8 ; count:=count-8;
sl w3 8 ; if count>=8 then
jl. b10. ; goto movestraight else
jl. b8. ; goto movetail;
\f
; comalmove pss 78.06.28 page .. 5..
; moveright:
b9 :
rs. w3 f2. ;
dl w0 x2-1 ;
ld w0 12 ;
hl w0 x2 ;
ds w0 x1 ;
dl w0 x2-5 ;
ld w0 12 ;
hl w0 x2-4 ;
ds w0 x1-4 ; move 8 halfwords;
al w1 x1-8 ; to:=to-8;
al w2 x2-8 ; from:=from-8;
rl. w3 f2. ;
al w3 x3-8 ; count:=count-8;
sl w3 8 ; if count >= 8 then
jl. b9. ; goto moveright;
; movetail:
b8 : sh w3 0 ; if count <= 0 then
jl. b15. ; goto done;
b17 : bz w0 x2 ; mvrep:
hs w0 x1 ; move 1 halfword;
al w1 x1-1 ; to:=to-1;
al w2 x2-1 ; from:=from-1;
al w3 x3-1 ; count:=count-1;
se w3 0 ; if count > 0 then
jl. b17. ; goto movetail else
jl. b15. ; goto done;
; end <* move starting from higher address *>
; else
\f
; comalmove pss 78.06.28 page .. 6..
; move area starting from lower addresses
b6 : ; begin
al w3 x3+1 ; count:=count+1;
sh w3 0 ; if count<=0 then
jl. b15. ; goto done;
so w1 1 ; if to is odd then
jl. b11. ; begin
bz w0 x2 ;
hs w0 x1 ; move 1 halfword;
al w1 x1+1 ; to:=to+1;
al w2 x2+1 ; from:=from+1;
al w3 x3-1 ; count:=count-1;
; end;
b11 : sh w3 7 ; if count<8 then
jl. b12. ; goto movetl;
sz w2 1 ; if from is odd then
jl. b13. ; goto moveleft;
; movest:
b14 : rs. w3 f2. ;
dl w0 x2+2 ;
ds w0 x1+2 ;
dl w0 x2+6 ;
ds w0 x1+6 ; move 8 halfwords
al w1 x1+8 ; to:=to+8;
al w2 x2+8 ; from:=from+8;
rl. w3 f2. ;
al w3 x3-8 ; count:=count-1;
sl w3 8 ; if count >= 8 then
jl. b14. ; goto movest else
jl. b12. ; goto movetl;
; moveleft:
b13 : rs. w3 f2. ;
dl w0 x2+1 ;
ld w0 12 ;
hl w0 x2+3 ;
ds w0 x1+2 ;
dl w0 x2+5 ;
ld w0 12 ;
hl w0 x2+7 ;
ds w0 x1+6 ; move 8 halfwords
al w1 x1+8 ; to:=to+8;
al w2 x2+8 ; from:=from+8;
rl. w3 f2. ;
al w3 x3-8 ; count:=count-8;
sl w3 8 ; if count>=8 then
jl. b13. ; goto moveleft;
\f
; comalmove pss 78.06.28 page .. 7..
; movetl:
b12 : sh w3 0 ; if count <= 0 then
jl. b15. ; goto done;
b16 : bz w0 x2 ; moverep:
hs w0 x1 ; move 1 halfword;
al w1 x1+1 ; to:=to+1;
al w2 x2+1 ; from:=from+1;
al w3 x3-1 ; count:=count-1;
se w3 0 ; if count > 0 then
jl. b16. ; goto moverep;
; end;
; done:
b15 : rl. w2 (j13.) ; get last used;
dl w1 x2+20 ;
wa. w0 f1. ; tofield:=tofield+count;
wa. w1 f1. ;
al w1 x1+1 ; fromfield:=fromfield+count+1;
rs w1(x2+16) ; set return value fromfield;
rl w1 x2+14 ;
ws w1 0 ; rem:=fieldlimit-tofield;
ba. w0 1 ; tofield:=tofield+1;
rs w0(x2+12) ; set return value tofield;
jl. (j6.) ; goto rs end register expression;
\f
; comalmove pss 78.06.28 page .. 8..
; error:
b18 : <:<10>param :>
b19 : <:<10>z. state:>
b20 : <:<10>fielderr:>
; paramerror
b0 : al w1 0 ; integer:=0;
jl. b21. ;
; zone state error:
b2 : rl w1 0 ; integer:=zone state;
jl. b22. ;
; field error:
b3 : al w1 0 ; integer:=0;
am b20-b19
b22 : am b19-b18 ;
b21 : al. w0 b18. ; get textadr;
rl. w2 (j13.) ; get last used;
jl. w3 (j21.) ; goto rs general alarm;
\f
; comalmove kc 79.06.19 page .. 9..
e2: rl. w2 (j13.) ; long procedure getclock;
ds. w3 (j30.) ; begin
dl w1 110 ; getclock:=core(108..110);
jl. (j6.) ; end;
e3: rl. w2 (j13.) ; boolean procedure anyevents;
ds. w3 (j30.) ; begin
rl w1 66 ; x1:=current_process;
dl w1 x1+16 ; w0:=x1.eventqueue.next;
sn w1 (0) ; w1:=x1.eventqueue.prev;
am 1 ; anyevents:=
al w1 -1 ; -,(w0=w1)
jl. (j6.) ; end;
\f
g3 :
c. g3-g1-506
m. code 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
<:comalmove <0>:> ; alarm text
e. ; end of slang segment;
; tail for code procedure
g0: ; first:
1 ; area with 1 segment
0, 0, 0, 0 ; fill
1<23+e1-e5 ; entry point on segment;
3<18+13<12+3<6+3 ; intg proc(intg val, intg name, intg name,
41<18+0 ; undefined);
4<12+e0-e5 ; code proc, start ext list
1<12+0 ; code segments, bytes in own core;
; getclock:
1<23+4 ; kind bs
0,0,0,0 ; fill
1<23+e2-e5 ; entry point
5<18+0,0 ; long procedure
4<12+e0-e5 ; code procedure, start external list
1<12+0 ; 1 segment, no perm core
; anyevents:
g1: ; last:
1<23+4 ; kind bs
0,0,0,0 ; fill
1<23+e3-e5 ; entry point
2<18+0,0 ; boolean procedure
4<12+e0-e5 ; code procedure, start external list
1<12+0 ; 1 segment, no perm core
m. 790309 comalmove
▶EOF◀