|
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: 14592 (0x3900)
Types: TextFile
Names: »movestr3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »movestr3tx «
; fgs 1987.07.02 algol 6, outdate page 1
;the code procedure outdate is stored on 1 segment. the usage
;of the procedure is found in the publication rcsl 31-d72.
;contents:
;label, page, name
;d2 2 outdate
;d5 2 initiate first two parameters of proc
;d6 4 write into zone
; 5 tail part
;b. h100 ; fpnames dummy block
b. e7, g1 w. ; block with names for tail
s. b8,d6,g2,i12,j60 ; slang segment for procedures
k=10000
i6=6,i8=8,i10=10,i12=12
h.
g0=0
e0: g2 , g1 ; rel of point ,rel of abs word
; abs words:
j3: g0+3 , 0 ; rs entry 3, reserve
j4: g0+4 , 0 ; 4, take expression
j6: g0+6 , 0 ; 6, end register expression
j8: g0+8 , 0 ; 8, end address expression
j13: g0+13 , 0 ; 13, last used
j16: g0+16 , 0 ; 16, segment table base
j17: g0+17 , 0 ; 17, index alarm
j21: g0+21 , 0 ; 21, general alarm
j29: g0+29 , 0 ; 29, param alarm
j60: g0+60 , 0 ; 60, last in segm table
j30: g0+30 , 0 ; 30, saved stack rel, saved w3
g1=k-2-e0 ; end abs words
;points:
j35: g0+35 , 0 ; rs entry 35, outblock
g2=k-2-e0 ; end rel words
w. ; start of external list
e1: 0 ; no externals
0 ; no owns
s3 ; date
s4 ; time
; constants and texts
b0: 10 ;
b6: <:<10>z. state:> ; alarm text
b7: 255 ; bit(16:23)=ones
b8: 255<16 ; bit(0:7)=ones
\f
; 01.12.71 algol 6, outdate page 2
;code procedure outdate(z,i); zone z; integer i;
b. a3 w. ; begin
e2: ; entry:
d2:
;initiate first two parameters of proc(zone,integer,...)
;saves the stack reference and checks the validity of the
;formal parameters for the zone. partial word addr and
;record base addr are stored in the words +i6 and +i8
;of the stack, respectively. the integer parameter is
;evaluated both as an integer and as a result addr.
; entry: exit:
;w0: integer mod 2**24
;w1: result addr.integer
;w2: stack
;w3:
;stack
;+i6: zone param partial word addr
;+i8: record base addr
;+i10:integer param unchanged
;+i12: destroyed
b. a0 w.
d5: rl. w2 (j13.) ; zone parameter:
ds. w3 (j30.) ; saved stack ref:= w2:= last used;
rl w3 x2+i8 ; zone descr:= zone formal 2;
rl w1 x3+h2+6 ; state:= zone state.zone descr;
se w1 3 ;
sn w1 0 ; if state<>after write
jl. a0. ; and state<>after open
; then
al. w0 b6. ; general alarm(state,alarm text);
jl. w3 (j21.) ;
a0: sn w1 0 ; if state = after open
rs w1 x3+h3+4 ; then record length:= 0;
al w1 3 ;
rs w1 x3+h2+6 ; state:= after write;
al w0 x3+h2+4 ; partial word addr:= zone descr+h2+4;
al w1 x3+h3 ; record base addr:= zone descr+h3;
ds w1 x2+i8 ;
dl w1 x2+i12 ; integer parameter:
rl. w3 (j30.) ;
rs w3 x2+i12 ;
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref:= w2;
rl w0 x1 ; w0:= integer mod 2**24;
e. ; end initiate first two parameters
\f
; 01.12.71 algol 6, outdate page 3
al w1 -8 ; reserve 8 bytes in stack
jl. w3 (j3.) ;
al w3 46 ;
hs w3 x2-3 ; stack buf(stack ref-3):=
hs w3 x2-6 ; stack buf(stack ref-6):= <:.:>;
al w1 x2-1 ; print:= stack ref-1;
a0: al w3 0 ; next char:
wd. w0 b0. ; char:= date mod 10+48;
al w3 x3+48 ; date:= date//10;
hs w3 x1 ; stack buf(print):= char;
a1: al w1 x1-1 ; print:= print-1;
sh w1 x2-9 ; if print<=stack ref-9 then
jl. a2. ; move stack buf and finish;
se w1 x2-3 ; if print= stack ref-3 or
sn w1 x2-6 ; print= stack ref-6 then
jl. a1. ; print:= print-1;
jl. a0. ; goto next char;
;move stack buf and finish:
;moves the contents of the stack buffer into the zone
;and releases the stack buffer.
a2: al w1 x1+1 ; move stack:
sn w1 x2 ; print:= print+1;
jl. a3. ; if print=stack ref then
bz w0 x1 ; goto finish;
jl. w3 d6. ; write into zone(stack buffer(print));
jl. a2. ; goto move stack;
; finish:
a3: rs. w2 (j13.) ; last used:= stack ref:
jl. (j8.) ; end address expression;
e. ; end outdate
\f
; 01.12.71 algol 6, outdate page 4
;procedure write into zone(char);
;outputs the right-most 8 bits of the character to the zone
;buffer. the block is changed if necessary.
; entry: exit:
;w0: char destroyed
;w1: uchanged
;w2: stack ref stack ref
;w3: link destroyed
;stack
; +i6: partial word addr partial word addr
; +i8: record base addr record base addr
;+i10: destroyed
;+i12: destroyed
b.a1 w.
d6: la. w0 b7. ; begin
rs w1 x2+i10 ;
rl w1 (x2+i6) ; char:= char(16:23);
sz. w1 (b8.) ; if partial word not full then
jl. a0. ; begin
ls w1 8 ; partial word:= partial word
lo w1 0 ; shift 8 or char;
rs w1 (x2+i6) ; return;
rl w1 x2+i10 ;
jl x3 ; end;
a0: ls w1 8 ; next word:
lo w0 2 ; partial word:= partial word
rl w1 (x2+i8) ; shift 8 or char;
al w1 x1+2 ; record base:= record base+2;
rs w1 (x2+i8) ; zone buf(record base):=
rs w0 x1 ; partial word;
al w0 1 ; partial word:= empty:= 1;
rs w0 (x2+i6) ;
am (x2+i8) ; if record base < last byte
sl w1 (2) ; then return;
jl. a1. ;
rl w1 x2+i10 ;
jl x3 ;
a1: al. w0 e0. ; change block:
ws w3 0 ; rel:= link-segment start;
rs w3 x2+i12 ;
rl w0 x2+i8 ;
ls w0 4 ; w0:= zone descr addr shift 4;
rl. w1 j35. ; w1:= outblock entry point;
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; saved stack ref:= w2;
rl w1 x2+i10 ;
am (x2+i12) ; link:= segment start+rel;
jl. e0. ; return (link);
\f
; fgs 1987.08.25 algol 6, movestring page 5
;integer procedure movestring(ra,ix,str);
e. ; end write into zone
; value ix; integer ix; real array ra; string str;
b. f5, d3, c0, b1, a5 ; block for move string
w.
f0: 0 ; work
f1: 0 ; return
f2: <:<10>segment<32>:>; alarm address
e3: rl. w2 (j13.) ; entry movestring:
ds. w3 (j30.) ; saved stack ref:= w2:= last used;
dl w1 x2+12 ; take index parameter:
so w0 16 ; if expression
jl. w3 (j4.) ; then take expression;
ds. w3 (j30.) ; saved stack ref:= w2;
dl w1 x1 ; take integer value:
rl w3 x2+10 ; w3:= formal1.ix;
sz w3 1 ; if real
cf w1 0 ; then round(index);
; take array parameter:
al w0 2.11111; check array param:
la w0 x2+6 ;
sh w0 23 ; if kind (param 1) > zone
sh w0 17 ; or kind (param 1) < integer array then
jl. w3 (j29.) ; goto param alarm;
se w0 18 ; typeshift :=
am 1 ; if kind = integer array then 1
al w3 1 ; else 2;
se w0 21 ; if kind = double array
sn w0 22 ; or kind = complex array then
al w3 3 ; typeshift := 3;
hs. w3 b1. ;
al w0 1 ; length :=
ls w0 x3 ; 1 shift typeshift;
rs w0 x2+12 ;
rl w3 x2+8 ; dope addr :=
ea w3 x2+6 ; dope rel + baseword addr;
b1 = k + 1 ; typeshift:
ls w1 0 ; index := index shift typeshift;
sh w1 (x3-2) ; if index > upper
sh w1 (x3 ) ; or index < lower
jl. w3 (j17.) ; then alarm(index,<:index:>);
wa w1 (x2+8) ; start addr:= next addr:=
al w1 x1+4 ; 4 -
ws w1 x2+12 ; length +
rs w1 x2+10 ; index + base addr;
rl w0 x3-2 ;
wa w0 (x2+8) ; last addr:= upper + base addr + 1;
ba. w0 1 ;
ds w1 x2+8 ; formal locations are used as working
; locations;
a3: dl w1 x2+16 ; take string param:
so w0 16 ; if expr then take expression;
jl. w3 (j4.) ; comment w1=address of string value;
ds. w3 (j30.) ; saved stack ref:= w2;
dl w1 x1 ; item:= core(param addr);
sh w1 -1 ; if second word.item < 0
jl. d1. ; then goto long string;
sl w0 0 ; if first word.item >= 0
jl. d0. ; then goto short string;
jl. w3 c0. ; layout: store(item);
jl. d2. ; goto exit normal;
d0: jl. w3 c0. ; short string: store(item);
jl. a3. ; goto take string param;
\f
; fgs 1987.08.25 algol 6, move string page 6
d1: hs. w0 b0. ; long string:
bz w3 0 ; comment w0 = point = segm number <12 +
rl. w0 (j60.) ; segm relative;
rl. w1 (j16.) ; prepare segment test:
ds. w1 f1. ;
al w1 x3 ;
al. w0 f2. ;
ls w3 1 ;
wa. w3 (j16.) ; segm table addr:= segm number*2 +
; segm table base;
sl. w3 (f1.) ; if segm table addr < segm table base
sl. w3 (f0.) ; or segm table addr >= last in segm table
jl. w3 (j21.) ; then alarm(segm no,<:segment:>);
rl w3 x3 ;
b0=k+1; segm relative ; w3:= segm table(segm table addr);
a0: dl w1 x3+0 ; next: item:= core(w3+segm relative);
sh w1 -1 ; if second word.item < 0
jl. d1. ; then goto long string;
rs. w3 f0. ;
jl. w3 c0. ; store(item);
rl. w3 f0. ;
al w3 x3-4 ; w3:= w3 - 4;
jl. a0. ; goto next;
;subprocedure store(item);
;call: w0,w1 = item, w3 = return address;
;checks whether the array is filled and, if not, stores the
;item in ra(next addr). if item contains a null character
;a jump to exit is performed.
c0: rs. w3 f1. ; entry store:
rl w3 x2+8 ; save return;
sl w3 (x2+6) ; if next addr > last addr
jl. a4. ; then goto try exit filled;
ds w1 x3 ; ra(next addr):= item;
al w3 x3+4 ; next addr:= next addr + 4;
rs w3 x2+8 ;
al w3 0 ; check null character:
jl. a2. ; for i:= 1 step 1 until 6 do
a1: al w3 x3+1 ; begin
sn w3 6 ;
jl. (f1.) ;
ld w1 -8 ; if bits 40-48.item = 0
a2: sz w1 8.377 ; then goto exit normal;
jl. a1. ; item:= item shift (-8);
; end; return;
d2: am 1 ; exit normal: negative:= false; goto a;
d3: al w3 0 ; exit full: negative:= true;
rl w1 x2+8 ; a: elements:=
ws w1 x2+10 ; (next addr - start addr)//length;
al w0 0 ;
wd w1 x2+12 ;
se w3 1 ; move string:= if not negative then
ac w1 x1 ; elements else (-elements);
jl. (j6.) ; goto rs end register expression;
; try exit filled:
a4: am (x2+6) ;
sl w3 2 ; if next addr < last addr + 2 then
jl. d3. ; begin
rs w0 x3-2 ; ra (next addr - 2) := item (1);
al w3 x3+2 ; next addr :=
rs w3 x2+8 ; next addr + 2;
jl. d3. ; goto exit filled;
e. ; end block for movestring
\f
; fgs 1987.07.02 algol 6, movestring page 7
e7:
c. e7-e0-506
m. code on segment 1 too long
z.
c. 502-e7+e0, -1,r. 252-(:e7-e0:)>1
; fill the rest of the segment with -1
z.
<:outdat/move:> ; alarm text
e. ; end slang segment
m. rc 1987.08.25 outdate movestring
; tail part
; outdate:
g0:
1 ; area entry with 1 segment
0,0,0,0 ; fill for name
1<23+e2-e0 ; entry point
1<18+3<12+8<6 ; no type proc( integer,
0 ; zone)
4<12+e1-e0 ; code proc, ext list
1<12+0 ; code segm, own bytes
;move string
g1: 1<23+4 ; modekind=backing storage
0,0,0,0 ; fill
1<23+e3-e0 ; entry point
3<18+9<12+13<6+41 ; integer procedure(undefined, value integer,
0 ; string). (specifications stored backwards)
4<12+e1-e0 ; code proc, ext list
1<12+0 ; code segm, bytes
\f
\f
▶EOF◀