|
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: 65280 (0xff00)
Types: TextFile
Names: »read4tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »read4tx «
; jz.fgs 87.08.21 algol 8, char input, segment 0 page ...0...
;standard procedures for reading on character level.
;the procedures are distributed on four segments as follows:
;segment 0: external list
; standard input table page 4
; define conversion table page 5
; check state further page 6
; repeatchar page 7
; intable page 8
; init pseudozone page 9
; set maxcharcount page 10
;segment 1: readchar page 14
; read page 14
; subprocedure inchar page 18
;segment 2: subprocedure readnumber page 22
;segment 3: readstring page 37
; readall page 42
\f
; jz.fgs 1982.12.15 algol 8, char input, segment 0 page ...1...
; b. h50 ; outer block with fp names already defined
b. g1, b25, c0, p8 ; global block with tail names
w. ;
d.
p. <:fpnames:>
l.
s. i34, g15, e25 ; block global to all segments
h. ;
;names used:
; a names: local to each (sub)procedure
; b - : locals and communication of entries to tail part
; c - : - - - -
; d - : - - - -
; e - : global entries to procedures
; f - : local to each (sub)procedure
; g - : global auxiliary variables and entries
; h - : file processor names
; i - : variables in stack and formal cells
; j - : addr. of abs-words and points, local to each segment
;entries:
; e0: entry to readchar, p12.
; e1: common return from segment 1, p14.
; e2: entry to read, p12.
; e3: entry to inchar, p18.
; e4: return point in inchar, p19.
; e5: entry to readnumber from readall, p24.
; e6: entry to readnumber from read, p24.
; e7: entry to repeatchar, p6.
; e8: entry to intable, p7.
; e9: entry to readstring, p34.
; e10: common return from segment 3, p39.
; e11: entry to readall, p34.
; e13: return to readall from readnumber, p43.
; e14: return to read from readnumber, p15.
; e15: proc check state further,segment 0, p4.
\f
; jz.fgs 82.12.02 algol 8, char input, segment 0 page ...2...
;variables in stack and formal cells:
i21 = 8; record base address, zone formals, used by all procs
i31 = 6; maxcharcount , - - - - - -
; used by read , used by readall
i23= 18; not used , old index
i20= 20; not used , i
i4 = -54; -no of bytes to reserve in stack
i34= -50; pseudozone , pseudozone
i24= -44; limit char count , limit char count
i33= -42; saved old type , saved old type
i19= -40; incr , incr
i18= -38; formal addr , 2
i17= -36; last addr=in array, last val
i16= -34; current addr , val inx
i15= -32; max , cl inx
i14= -30; no of read<2+error, last cl
; used by readnumber
i13= -28; number
i12= -26; number (double word)
i11= -24; factor
i10= -22; digit
i9 = -20; digit (double word)
i8 = -18; exp
i7 = -16; exp sign
i6 = -14; sign
i5 = -12; state
i3 = - 8; (return seg,return rel - doubleword
i2 = - 6; type
i1 = - 4; class , address af formal2.index
i0 = - 2; value , entry to readstring, -all
\f
; jz.fgs 82.12.15 algol 8, char input, segment 0 page ...3...
g10=0 ; no of externals + no of globals
b. j20, b5, a6 ; block for check date further and segment 0
k=0
h.
b0: b1 , b2 ; head word: rel of last point, - last abs word
j1: g10+13, 0 ; rs entry 13, last used
j2: g10+30, 0 ; rs entry 30, saved stack ref
j4: g10+ 4, 0 ; rs entry 4, take expression
j6: g10+21, 0 ; rs entry 21, general alarm
j7: g10+ 6, 0 ; rs entry 6, end reg. expr.
j8: 0, p6 ; permanent core: intable base address
j10: 0, p7 ; permanent core: intable lower
j14: g10+ 8, 0 ; rs entry 8, end addr. expr.
j17: 1<11+3, 0 ; segment 3 address.
j18: g10+29, 0 ; rs entry 29, param alarm
b1=k - 2 - b0, b2 = b1 ; relative of last point, - abs word
w. ; start of external list:
c0: 0 ; no of externals = 0
p0 ; no of halfwords in own core to initialize (= no of owns)
b3: 0 ; own core(0:1): intable.base
0 ; own core(2:3): intable.upper_index
0 ; own core(4:5): intable.lower_index
0 ; own core(6:7): tableindex
p6=1, p7=5, p8=7
b5: 0 ; table base
0 ; table.upper
0 ; table.lower
0 ; table_index_address
p1=b5-b3+1, p3=b5+4-b3+1, p4=b5+6-b3+1
\f
; jz.fgs 82.12.15 algol 8, char input, segment 0 page ...4...
; standard input table containing the classes:
h.
p5 = k - b3
0, 7, 7, 7; 0 nul 1 soh 2 stx 3 etx
7, 7, 7, 7; 4 eot 5 enq 6 ack 7 bel
7, 7, 8, 7; 8 bs 9 ht 10 nl 11 vt
8, 0, 7, 7; 12 ff 13 cr 14 so 15 si
7, 7, 7, 7; 16 dle 17 dc1 18 dc2 19 dc3
7, 7, 7, 7; 20 dc4 21 nak 22 syn 23 etb
7, 8, 7, 7; 24 can 25 em 26 sub 27 esc
7, 7, 7, 7; 28 fs 29 gs 30 rs 31 us
7, 7, 7, 7; 32 sp 33 34 35
7, 7, 7, 5; 36 37 38 39
7, 7, 7, 3; 40 ( 41 ) 42 * 43 +
7, 3, 4, 7; 44 , 45 - 46 . 47 /
2, 2, 2, 2; 48 0 49 1 50 2 51 3
2, 2, 2, 2; 52 4 53 5 54 6 55 7
2, 2, 7, 7; 56 8 57 9 58 : 59 ;
7, 7, 7, 7; 60 < 61 = 62 > 63
7, 6, 6, 6; 64 65 a 66 b 67 c
6, 6, 6, 6; 68 c 69 e 70 f 71 g
6, 6, 6, 6; 72 h 73 i 74 j 75 k
6, 6, 6, 6; 76 l 77 m 78 n 79 o
6, 6, 6, 6; 80 p 81 q 82 r 83 s
6, 6, 6, 6; 84 t 85 u 86 v 87 w
6, 6, 6, 6; 88 x 89 y 90 z 91 æ
6, 6, 7, 7; 92 ø 93 94 95 _
7, 6, 6, 6; 96 97 a 98 b 99 c
6, 6, 6, 6; 100 d 101 e 102 f 103 g
6, 6, 6, 6; 104 h 105 i 106 j 107 k
6, 6, 6, 6; 108 l 109 m 110 n 111 o
6, 6, 6, 6; 112 p 113 q 114 r 115 s
6, 6, 6, 6; 116 t 117 u 118 v 119 w
6, 6, 6, 6; 120 x 121 y 122 z 123 æ
6, 6, 7, 0; 124 ø 125 126 127 del
w.
\f
; jz.fgs 1982.12.15 algol 8, char input, segment 0 page ...5...
b4: 0 ; saved return
e19 = k - b3
rs. w3 b4. ; define conversion table:
rl w3 x2+8 ; save return;
rl w0 x3+h4+2 ; w0 := entry point(zone.block procedure);
se w3 x2+i34 ; if zone = pseudozone
so w0 1 ; or zone = old external zone
jl. a6. ; then goto external intable;
rl w3 x3+h0+0 ; w3 := zone.base buffer;
dl w1 x3-12 ;
sn w0 0 ; if zone.intable_base = 0 then
jl. a6. ; goto external intable;
ds. w1 b5.+2 ; move
rl w0 x3-10 ; intable description from
al w1 x3-8 ; zone
ds. w1 b5.+6 ; to own core;
jl. (b4.) ; return;
a6: dl. w1 b3.+2 ; external intable:
ds. w1 b5.+2 ; move
rl. w0 b3.+4 ; intable description from
al. w1 b3.+6 ; own core
ds. w1 b5.+6 ; to zone;
jl. (b4.) ; return;
; end external list:
p0 = k - b3 ; define no of own halfs
s3, s4 ; date and time
\f
; jz.fgs 82.12.17 algol 8, char input, segment 0 page ...6...
e15: sn w0 2 ; procedure check state further;
jl. a2. ; begin
se w0 0 ; if state.zone descr<>after repeatchar
jl. a1. ; then
rs w0 x1+h2+4 ; begin if state.zone descr=after open
rl w0 x1 ; then
rs w0 x1+h3+2 ; begin partial word:= 0;
jl x3 ; last used:= record base
a1: al. w1 a0. ; end else
rx w1 0 ; alarm(<:z.state:>, state);
jl. w3 (j6.) ; end else
a2: rs. w3 (j2.) ; begin save(return);
am (x1+h3) ; current address:= record base.zone descr+2;
rl w3 2 ; w3:= buffer(current address);
rl. w0 a5. ; w0:= empty;
se w0 (x1+h2+4) ; if w0<>partial word.zone descr
ld w0 -8 ; then w30:= w30 shift (-8);
sn w0 (x1+h2+4) ; if w0<>partial word.zone descr
jl. a3. ; then goto shift char;
ld w0 -8 ; w30:= w30 shift (-8);
se w0 (x1+h2+4) ; if w0<>partial word.zone descr
jl. a4. ; then return;
rl w2 x1+h3 ;
al w2 x2-2 ; record base.zone descr:=
rs w2 x1+h3 ; record base.zone descr - 2;
al w3 1 ; w30:= 1 shift 24;
al w0 0 ;
a3: ld w0 -8 ; shift char: w30:= w30 shift (-8);
rs w0 x1+h2+4 ; partial word.zone descr:= w0;
a4: dl. w3 (j2.) ; restore(stack ref,return);
jl x3 ; end
a0: <:<10>z.state :> ; end;
a5: 1<16 ; empty.
\f
; jz.fgs 1982.12.17 algol 8, char input, segment 0 page ...7...
; procedure repeatchar(z);
; zone z;
; procedure to back up the latest read character from the zone z,
; i.e. it sets the zone state to: after repeatchar.
; in all cases of illegal use, the call is considered blind.
w.
b7:
e7: rl. w2 (j1.) ; repeatchar(zone);
ds. w3 (j2.) ; w2:= saved stack ref:= last used;
rl w2 x2+8 ; zone descr:= formal 2;
rl w0 x2+h2+6 ;
se w0 1 ; if state.zone descr<>after read then
jl. (j7.) ; return;
al w0 2 ;
rs w0 x2+h2+6 ; state.zone descr:= after repeatchar;
al w0 0 ;
rs w0 x2+h3+4 ; record length.zone descr:= 0;
jl. (j7.) ; return;
m.repeatchar
\f
; jz.fgs 82.12.17 algol 8, char input, segment 0 page ...8...
; procedure intable(param);
; undef param;
; procedure which substitutes the current input table according to
; the parameter:
; 1. param is an integer array identifier: this array will replace
; the current input table by setting the new array description
; into the variables in the permanent core: intable base address,
; intable upper and intable lower.
; 2. param is an zero, in this case treated as if it was specified
; integer value: the standard input table replaces the
; current table by setting the variable in the permanent core,
; intable base address, to zero.
; the contents of the registers are undefined both by entry and exit.
b. a5 ; intable block begin
w.
b8:
e8: rl. w2 (j1.) ; intable(param);
ds. w3 (j2.) ; w2:= saved stack ref:= last used;
dl w1 x2+8 ; get formals:
al w3 2.11111;
la w3 0 ; kind:= formal1 and mask31;
se w3 18 ; if kind <> integer array then
jl. a0. ; goto not integer array;
ba w1 0 ; dope:= formal2 + byte1.formal1;
dl w1 x1 ; intable upper:= store(dope - 2);
ds. w1 (j10.) ; intable lower:= store(dope);
rl w1 (x2+8) ; base := store(formal1);
a1: rs. w1 (j8.) ; out: intable base address:= base;
jl. w3 (j14.) ; return;
a0: ls w3 -1 ; not integer array:
al w1 0 ; base:= 0;
se w3 13 ; if kind=simple arithm variable
sn w3 5 ; or kind=arithm expr then goto out
jl. a1. ; else
jl. w3 (j18.) ; alarm(<:param:>);
m.intable
i.
e. ; end intable;
\f
; jz.fgs 88.05.31 algol 8, char input, segment 0 page ...9...
; init pseudo zone;
; call: w0 = first param(0) extract 12; <* kind bits *>
; w1 = first param(1)
; w2 = stack ref
; w3 = return
; x2+6 : first param(0);
; x2+8 : work used by read
; the routine terminates with param alarm, if the first paraneter of read,readall or readstring
; integer, real or long array, and with index alarm if byteindex = 1
; is > 1 in the array formal. otherwise a pseudozone is created,
; defining the array as the actual (and only) zonerecord in char
; input.
b. a1, b1
w.
b1: <:<10>oddfield :> ;
a1: al. w0 b1. ; oddfield alarm:
al w1 1 ; param := 1;
jl. w3 (j6.) ; general alarm (<:oddfield:>, param);
e12: ; init pseudo zone:
rs w3 x2+i3 ; save(return);
sh w0 22 ; if kind > 22 <* complex array *>
sh w0 16 ; or kind < 17 <* boolean array *>
jl. w3 (j18.) ; then param alarm;
; se w0 17 ; if kind <> boolean array then
; am 1 ; lower lim := 2
; al w0 1 ; else
; hs. w0 b0. ; lower lim := 1;
sl w1 (x2+i15) ; if baseword addr < max
jl. a0. ; and
sl w1 x2+6 ; baseword addr >= first formal then
rs w1 x2+i15 ; max := basewordaddress;
a0: rl w3 x1 ; w3 := baseword;
so w3 1 ; if baseword even then
jl. a1. ; goto oddfield alarm;
ba w1 x2+6 ; (w0, w1) :=
dl w1 x1 ; arrayparam.(upper index, lower index);
b0=k+1 ; lower lim:
sl w1 2 ; if lower index >= lower lim then
jl. e20. ; index alarm;
al w1 x2+i34 ; w1 := address of pseudozone;
rs w1 x2+8 ; save zone address;
wa w0 6 ; pseudozone.(recordbase,last byte) :=
al w3 x3-2 ; (baseword - 2,
ds w0 x1+h3+2 ; baseword + upper index);
al w3 0 ; pseudozone.partial word := 0;
al w0 1 ; pseudozone.state := after read;
ds w0 x1+h2+6 ;
jl (x2+i3) ; return;
e. ;
\f
; jz.fgs 82.12.02 algol 8, char input, segment 0 page ...10...
; set maxcharcount:
; this routine is called from readstring only, and checks if
; an optional 4th parameter is arithmetic - if it is not a
; parameter alarm is called, otherwise the parameter value is
; used as value of maxcharcount.
b. a0 w. ;
e17: al w0 2.111 ; set maxcharcount:
rs w1 x2+i0 ; save (char)
rl w1 x2+18 ; kind := formal0; type := kind extract 3;
la w0 2 ; if kind = array
so w1 8 ; or kind = procedure then
jl. w3 (j18.) ; param alarm;
sl w0 2 ; if type < 2 <* integer *>
sl w0 5 ; or type > 4 <* long *>
jl. w3 (j18.) ; then param alarm;
dl w1 x2+20 ; (w0,w1) := formal;
so w0 16 ; if kind = expression then
jl. w3 (j4.) ; take expression;
sl w1 (x2+i15) ; if address(value) < max
jl. a0. ; and
sl w1 x2+6 ; address(value) >= first formal address
rs w1 x2+i15 ; then max := address(value);
a0: al w0 x2+26 ;
sh w0 (x2+i15) ; if more parameters then
jl. w3 (j18.) ; param alarm;
dl w1 x1 ; take value:
rl w3 x2+18 ; if type(param) = real
sz w3 1 ; then
cf w1 0 ; convert real to integer;
al w1 x1-1 ;
rs w1 x2+i31 ; limit char count := value(param) - 1;
rl w1 x2+i0 ; restore (char)
rl. w3 (j17.) ; w3 := segment3 address;
jl x3+e18 ; return to readstring;
e. ;
\f
; jz.fgs 88.05.31 algol 8, char input, segment 0 page ...11...
b. b1 w. ;
b0: <:<10>index <0>:>;
b1=k-1 ; shift (type) table:
h.
0, 1, 2, 2, 3, 3 ;
w.
e20: al w3 2.111 ; index alarm1:
la w3 x2+6 ; type := param1.formal0 extract 3;
zl. w0 x3+b1. ; shifts := case (type) of (0, 1, 2, 2, 3, 3);
al w3 1 ; typelength :=
ls w3 (0) ; 1 < shifts;
wa w1 6 ; index := lower index + type length;
ac w0 (0) ; shifts := - shifts;
ls w1 (0) ; index := index > shifts;
al. w0 b0. ; w0 := text address;
jl. w3 (j6.) ; general alarm(<:index:>);
e. ;
j20:
c.j20-506
m.code on segment 0 too long
z.
c.502-j20,0,r.252-j20>1 z.; fill rest of segm 0 with zeroes
<:char input<0>:> ; alarm text of segm 0
m.check state further and segment 0
i.
e. ; end block for check state further and segment 0
\f
; jz.fgs 82.12.17 algol 8, char input, segment 1 page ...12...
; readchar
b. j20, a5, d6 ; block for segment 1
k=0
h.
g11: g2 , g3 ; rel of last point, rel of last abs word
j1: g10+13, 0 ; rs entry 13 last used
j2: g10+30, 0 ; - - 30 saved stack ref
j3: g10+ 3, 0 ; - - 3 reserve
j4: g10+ 4, 0 ; - - 4 take expr
j5: g10+17, 0 ; - - 17 index alarm
j7: g10+ 6, 0 ; - - 6 end reg expr
j18: g10+29, 0 ; - - 29 param alarm
j6: 1<11 o. (:-1:), 0; addr of segment 0
j16: 1<11+1, 0 ; addr of segment 2
j8: 0, p1 ; permanent core, intable base addr
j10: 0, p3 ; permanent core, intable lower
j11: 0, p4 ; permanent core, tableindex
j14: 0, p5 ; permanent core, input class table
j9: 0, e19 ; permanent core, define conversion table
g3=k-2 - g11 ; no of abs words
j12: 1<11+0, e4 ; point in inchar
j13: g10+34, 0 ; point in inblock
g2= k-2-g11 ; rel of last point
; permanent core is initialized to zero by pass 9
\f
; jz.fgs 87.11.27 algol 8, char input, segment 1 page ...13...
w.
; common entry segment 1
b2:e2:am d3 ; read entry: entry:= read; goto inn;
b0:e0:al w1 d2 ; readchar entry: entry:= readchar;
rl. w2 (j1.) ; inn: w2:= saved stackref:= last used;
ds. w3 (j2.) ; get zone formals:
se w1 d5 ; if entry=read then
jl. a0. ; begin
al w1 i4 ; appetite := -stacksize;
jl. w3 (j3.) ; reserve(appetite);
ds. w3 (j2.) ; save(stackref, w3);
al w3 x2+6 ; max := stackref+6+appetite;
ba w3 x2+4 ; no of read := 0;
al w0 0 ;
ds w0 x2+i14 ; entry := read;
al w3 x2+9 ; formal := stack ref + 9;
rs w3 x2+i18 ;
al w1 d5 ; end;
a0: hs. w1 d6. ; save entry;
bz w0 x2+7 ; kind := first param.formal0 extract 12;
rl w1 x2+8 ; w1 := zone address;
rl. w3 (j6.) ; w3 := segtable(char input.segment0);
se w0 23 ; if kind <> 23 <* zone *> then
jl w3 x3+e12 ; init pseudozone;
rl w0 x1+h2+6 ; w0 := zone state;
se w0 1 ; if zone state <> after read then
jl w3 x3+e15 ; check state further;
jl. w3 (j9.) ; define conversion table;
al w0 -1 ;
rs w0 x2+i31 ; maxcharcount := -1;
d0: jl. 0 ; goto entry;
d6 = d0 + 1; saved entry
\f
; jz.fgs 82.11.15 algol 8, char input, segment 1 page ...14...
; readchar, read
; integer procedure readchar(z,val);
; zone z; address integer val;
; the procedure inputs a character from the zone z and assigns
; the internal value of the character to val.
; the value of the procedure is the class of the character.
; the registers are undefined by entry and exit.
d1: d2=k-d0 ; readchar:
dl w1 x2+12 ; get val address:
so w0 16 ; val address:=
jl. w3 (j4.) ; if expr then take expr
ds. w3 (j2.) ;
rs w1 x2+12 ; else formal 2;
jl. w3 e3. ; class:= inchar(int value);
rs w1 (x2+12) ;
rl w1 0 ; val:= int value; readchar:= class;
e1: rl w3 x2+i21 ; common return segm 1:
al w0 1 ; comment w1=procvalue, called also from read;
rs w0 x3+h2+6-h3; state.zone descr:= after read;
al w0 0 ;
rs w0 x3+4 ; record length.zone descr:= 0;
rs. w2 (j1.) ; last used:= w2;
jl. (j7.) ; goto end reg expr;
; end readchar;
; integer procedure read(z,v);
; zone or <int,long or long> array z; general v;
; an integer procedure which reads numbers form the zone or array z,
; converts them to the proper internal representation and
; assigns them to the variables given by the parameter list.
; in case of array parameter, the whole array is filled with
; values;
; if v is the parameter pair: (boolean, arith. expr), the value of
; the expression is assigned to 'maxcharcount', which defines the
; maximum number of characters read for the next parameter (cf. write)
; the value of the procedure is the number of read numbers.
b. a15, b0 ; read block begin
w.
\f
; jz.fgs 87.11.27 algol 8, char input, segment 1 page ...15...
; read
; after readnumber
; w1=class: 1==error, 2==number
e14: lo w1 x2+i14 ; error:=error or new error;
al w1 x1+1<2 ; increase no of read;
rs w1 x2+i14 ;
al w1 -1 ;
rs w1 x2+i31 ; maxcharcount := -1;
dl w1 x2+i0 ;
jl. w3 a9. ; test stop;
dl w1 x2+i16 ;
se w0 0 ; if in array then
jl. a3. ; goto next array element;
d3 = k-d1, d5 = d2 + d3; read:
rs w0 x2+i33 ; oldtype := -1;
a1: al w3 -1 ; take next formal:
rs w3 x2+i24 ; limit char count := -1;
a5: rl w3 x2+i18 ; take next formal 1:
al w3 x3+4 ; formal:= formal + 4;
sl w3 (x2+i15) ; if formal >= max then
jl. a10. ; goto end read;
rs w3 x2+i18 ;
dl w1 x3 ;
rs w0 x2+i2 ; type := formal0;
so w0 16 ; if expression then
jl. w3 (j4.) ; take expression;
ds. w3 (j2.) ; save(stackref,w3);
sl w1 (x2+i15) ; if addr(result) < max
jl. a11. ; and
sl w1 x2+6 ; addr(result) >= first formal then
rs w1 x2+i15 ; max := addr(result);
a11: al w3 2.11111; kind test:
la w3 x2+i2 ; kind := bits(12,23,formal0);
sl w3 9 ; if kind < 9 <* boolean expression *> or
sl w3 29 ; kind > 28 <* long variable *> then
jl. w3 (j18.) ; alarm(<:param:>);
al w0 2.111 ; test old type:
la w0 6 ; old type := saved old type;
rx w0 x2+i33 ; saved old type := kind extract 3;
sh w3 24 ; if kind >=25 <* boolean variable *>
sh w3 12 ; or kind <=12 <* long expression *>
jl. a4. ; then goto simple;
\f
; jz.fgs 82.11.23 algol 8, char input, segment 1 page ...16...
sn w0 1 ; if old type = boolean then
jl. w3 (j18.) ; param alarm;
se w3 23 ; if kind <> zone and
sh w3 20 ; kind > long array and
sh w3 17 ; kind < integer array then
jl. w3 (j18.) ; alarm(<:param:>);
sl w3 19 ; take array:
am 2 ; incr := if kind <> integer then
al w3 2 ; 4 else 2;
rs w3 x2+i19 ;
dl w1 (x2+i18) ; (w0,w1) := array formal;
rl w3 x1 ; base:= store(formal2);
ba w1 0 ; dope:= formal2 + byte1.formal1;
rl w0 x1-2 ;
wa w0 6 ; last:= base + store(dope - 2);
rl w1 x1 ;
wa w1 6 ; next array element:
a3: wa w1 x2+i19 ; current addr:= base + store(dope) + incr;
sh w1 (0) ; if current addr <= last then
jl. a7. ; goto read next else goto take next formal;
jl. a1. ; comment array list exhausted;
\f
; jz.fgs 82.12.02 algol 8, char input, segment 1 page ...17...
; read
a4: rl w3 x2+i33 ; simple:
se w0 1 ; if old type = boolean then
jl. a6. ; begin
sn w3 1 ; if new type = boolean then
jl. w3 (j18.) ; param alarm;
dl w1 x1 ; value := value(formal);
sz w3 1 ; if type(formal) is real then
cf w1 0 ; value := round(value);
sh w1 0 ; if value <= 0 then
jl. a1. ; goto take next formal;
al w1 x1-1 ; limit char count :=
rs w1 x2+i24 ; value - 1;
jl. a5. ; goto take next formal 1;
a6: sn w3 1 ; end;
jl. a1. ; if newtype = boolean then
al w0 0 ; goto next formal;
a7: ds w1 x2+i16 ; read next:
a8: jl. w3 e3. ; for class:= inchar while class>5 do teststop;
sh w0 5 ; comment skip leading terminators;
jl. a2. ; goto number read;
al. w3 a8. ; comment w0=class,w1=int value of first char;
a9: sn w1 25 ; teststop:
se w0 8 ; if int val <> 25 or class <> 8 then return;
jl x3 ;
a10: rl w1 x2+i14 ; end read: read:= no of read;
al w0 x1 ;
ls w1 -2 ; remove classbits;
sz w0 1 ; if any error then
ac w1 x1 ; read:=-no of reads;
jl. e1. ; goto common return segm 1;
a2: rl w3 x2+i24 ; number read:
rs w3 x2+i31 ; maxcharcount := limit char count;
rl. w3 (j16.) ; w3 := segment 2 address;
jl x3+e6 ; goto segment1.read number;
m.read
i.
e. ; end read;
\f
; jz.fgs 82.12.17 algol 8, char input, segment 1 page ...18...
;'inchar': which reads a character from the current zone and supplies
;the corresponding value and class from the standard table or from
;the user table if any.
;the procedure is called from all the reading procedures exept
;repeatchar and intable.
;registers: entry exit
; w0: irrelevant class of the read character
; w1: - internal value of the read character
; w2: stack ref unchanged
; w3: return addr undefined
;if a block transport is needed, the segment allocation may be
;changed.
b. a10 ; inchar block begin
w.
e3: rl w1 x2+i31 ; inchar:
sn w1 0 ; if maxcharcount = 0 then
jl. a10. ; goto terminator;
am (x2+i21) ;
rl w1 h2+4 ; w1 := partial word;
al w0 0 ; begin
ld w1 8 ; if partial word = empty then
sn w1 0 ; goto next word;
jl. a2. ; char:= partial word//2**16;
a0: am (x2+i21) ; partial word := partial word shift 8;
rs w1 h2+4 ; set word:
rl w1 0 ; val:= char;
rl. w0 (j8.) ;
se w0 0 ; if intable base <> 0 then
jl. a1. ; goto user table;
sl w1 128 ; standard table:
jl. w3 (j5.) ; if char > 127 then alarm(<:index:>);
am. (j14.) ; class :=
bl w0 x1 ; input class table(char);
a6: sn w0 0 ; testcl: if class=blind then goto inchar;
jl. e3. ; inchar:= class;
se w0 1 ; if class <> case shift then
jl. a7. ; goto exit;
rl. w0 (j11.) ;
rs w1 (0) ; table_index := val;
;comment table index is not used in connection with standard table.
\f
; jz.fgs 82.12.15 algol 8, char input, segment 1 page ...19...
; inchar
a8=k+1; oldchar ;
al w1 ; after case shift: char:= oldchar;
a1: hs. w1 a8. ; user table:
rl. w0 (j11.) ; oldchar := char;
wa w1 (0) ;
rx. w3 j10. ;
ls w1 1 ; index:= (char + table index) * 2;
sh w1 (x3-2) ; if index > intable upper or
sh w1 (x3) ; index < intable lower then
jl. w3 (j5.) ; alarm(<:index:>);
rx. w3 j10. ;
wa. w1 (j8.) ;
rl w0 x1 ; word:= user table(index);
bl w1 1 ; val:= signed byte2.word;
bz w0 0 ; inchar:= class:= unsigned byte1.word;
jl. a6. ; goto testcl;
a2: rl w1 (x2+i21) ; next word:
al w1 x1+2 ; recordbase:= recordbase+2;
a5: am (x2+i21) ; test empty:
sl w1 (2) ; if record base>= last byte then
jl. a3. ; next block;
rs w1 (x2+i21) ;
rl w1 x1+2 ; partial word:= buffer(record base + 2);
al w0 0 ;
ld w1 8 ; char:= partial word // 2**16;
al w1 x1+1 ; partial word:= partial word shift 8 +
jl. a0. ; emptymark;
; goto set word;
\f
; jz.fgs 82.12.20 algol 8, char input, segment 1 page ...20...
a3: rl w0 x2+i21 ; next block: w0 := zonedescr addr;
rl. w1 j12. ; w1 := point(e4); <* on this segment *>
se w0 x2+i34+h3 ; if zoneaddr <> pseudozoneaddr then
jl. (j4.) ; take expression; <* stack return point *>
am w1 -7 ; char := 25 <* em *> else
a10: al w1 32 ; terminator:
al w0 8 ; char := 32; <* sp *> inchar := class := 8;
a7: rx w1 x2+i31 ; exit:
al w1 x1-1 ;
rx w1 x2+i31 ; maxcharcount := maxcharcount - 1;
jl x3 ; return;
e4: dl. w3 (j2.) ; return from take expression: save(w2,w3);
rl w0 x2+i21 ; w0 := zonedescr addr;
ls w0 4 ; w0:= zone descr shift 4;
rl. w1 j13. ; w1:= rsentry point inblock;
jl. w3 (j4.) ; take expression;
ds. w3 (j2.) ; saved stack ref:= w2;
jl. w3 (j9.) ; define conversion table;
rl. w1 (j1.) ; get stacked return point:
al w1 x1+6 ; last used:= last used + 6;
rs. w1 (j1.) ; segment table(return segm):=
rl w3 (x1-4) ; return segment.return point;
rl w0 x3 ; get return segment into core;
a9=k+1; return rel ;
ba w3 x1-1 ; return rel:= segm+return rel.ret point;
rl w1 (x2+i21) ;
jl. a5. ; goto test empty;
m.inchar
i.
e. ; end inchar
\f
; jz.fgs 82.11.23 algol 8, char input, segment 1 page ...21...
w.
j20:
c.j20-506
m.code on segment 1 too long
z.
c.502-j20,0,r.252-j20>1 z.; fill with zeroes
<:char input<0>:>; alarm text from segment 1
m.segment 1
i.
e. ; end segment 1
\f
; fgs 87.09.10 algol 5, char input, segment 2 page ...22...
; readnumber
b. j20, a1 ; block for segment 2
k=0
h.
g4: g5 , g5 ; rel of last point, rel of last abs word
j0: g10+37 , 0 ; rs entry 37 overflows
j2: g10+30 , 0 ; - - 30 saved stack ref
j4: g10+22 , 0 ; - - 22 underflows
j6: g10+21 , 0 ; - - 21 general alarm
j15: 1<11 o. (:-1:),0 ; addr of segment 1
j17: 1<11 o. 2 ,0 ; - - - 4
g5= j17 - g4 ; no of abs words
w.
; integer procedure readnumber (number);
; general number;
; subprocedure which reads a number and converts it to the required
; type.
; called from read (entry e6) and from readall (entry e5).
; registers: entry exit
; w0: class of read symbol undefined
; w1: internal value of symbol class of the read number
; w2: stack ref unchanged
; w3: undefined undefined
; number limits:
; integer: abs(number) <= 2**23 - 1 = 8 388 607
; longs: abs(number) <= 140 737 488 355 327
; reals: the range given by the 48 bits integer can be used
; in spite of the fact that a standard procedure is not
; allowed to cause an integer overflow interrupt.
; So the test to avoid this
; must be performed before the statement: number:= number*10
; +digit. the test is carried out by first testing the double
; word against maxlong//10. if less , there are no troubles. if
; greater, troubles will come. if equal, digit is tested against
; 7 (number*10+digit<=(maxlong//10)*10+7).
; in short, the full range of positive longs becomes available
; to abs(number).
\f
; jz.fgs 82.11.23 algol 8, char input, segment 2 page ...23...
b.g3, f15, d10, c20, b5, a15; read number block begin
; constants
f.
f1: -1; -1.0 floated
w.
f0: 9; number of states
f2: 0, 1<10; round const
f7: 0, 1; round constant
f3: 10; 10 integer
838 860; first word of maxlong//10
f4: -3 355 444; sec. word of maxlong//10
h.
f5: 2047,4095, f6: 4095,2047; f5=max integer, f6=max floated.
w.
\f
; fgs 87.09.10 algol 5, char input, segment 2 page ...24...
; read number
e5: am j17-j15; entry from readall: returnsegm := segm 4;
e6: rl. w3 j15. ; entry from read: returnsegm := segm 1;
ds w1 x2+i0 ;
se. w3 (j15.) ;
am e13 ;
al w0 e14 ; w0 := return rel on segments;
ds w0 x2+i3 ; init number:
ld w1 49 ;
ds w1 x2+i12 ; number:=
ds w1 x2+i10 ; factor:=
rs w1 x2+i8 ; exp:=
rs w1 x2+i5 ; state:= 0;
al w3 -5 ;
rs w3 x2+i6 ; sign:= pos;
rs w3 x2+i7 ; expsign:= pos;
dl w1 x2+i0 ;
jl. d4. ; goto next1;
c0: rl w3 x2+i11 ; digit after point:
al w3 x3+1 ; factor:= factor+1;
rs w3 x2+i11 ; state:= 4;
am 2 ; goto mult;
c1: al w3 2 ; digit before point: state:= 2;
dl w1 x2+i12 ; mult:
ss. w1 f4. ;
sh w0 -1 ; if f.w.(number)<f.w.(maxlong//10) then
jl. a3. ; goto number_ok;
; maybe_error1:
a4: sn w0 0 ; if f.w.(number)>f.w.(maxlong//10) then
se w1 0 ;
jl. c5. ; goto error1;
rl w0 x2+i9 ; comment f.w.(number)=f.w.(maxlong//10);
sl w0 8 ; if digit>=8 then
jl. c5. ; goto error1;
\f
; jz.fgs 82.11.23 algol 8, char input, segment 2 page ...25...
a3: dl w1 x2+i12 ; number_ok:
ad w1 2 ;
aa w1 x2+i12 ; number:= number*10 + digit;
ad w1 1 ;
aa w1 x2+i9 ;
ds w1 x2+i12 ;
d0: rs w3 x2+i5 ; next:
rl. w3 (j15.) ;
jl w3 x3+e3 ; class:= inchar(value);
ds w1 x2+i0 ;
d4: al w1 x1-48 ; next1:
rs w1 x2+i9 ; digit:= value - 48;
sl w0 7 ; if class > 6 then
al w0 6 ; class:= 6;
wm. w0 f0. ;
rl w3 0 ;
wa w3 x2+i5 ;
bl. w3 x3+g0. ; action:= number table(class,state);
jl. x3+c0. ; goto action;
c2: rl w0 x2+i8 ; digit in exp:
wm. w0 f3. ; goto error 1;
wa w0 x2+i9 ; exp:= exp*10 + digit;
rs w0 x2+i8 ;
sl w0 1000 ; if exp >= 1000 then
am 1 ; state := 8 else
al w3 7 ; state:= 7;
jl. d0. ; goto next;
c3: dl. w1 f7.+2 ; ten1: number := 1;
ds w1 x2+i12 ;
c4: al w3 5 ; ten 2: state:= 5;
jl. d0. ; goto next;
\f
; jz.fgs 1983.01.04 algol 5, char input, segment 2 page ...26...
; read number
c8: rs w1 x2+i7 ; expsign: expsign:= digit; comment
am -2 ; pos=-5 (43-48), neg=-3 (45-48);
; state := 6; goto next;
c5: ; error1:
am 5 ; error in not yet finished number: state:=8;
c6: al w3 3 ; point: state:= 3;
jl. d0. ; goto next;
c9: rs w1 x2+i6 ; sign: sign:= digit;
al w3 1 ; state:= 1;
jl. d0. ; goto next;
c10: dl. w0 f6. ; error 2:
rl w1 x2+i2 ; w3w0 := real maximum; w3 := integer maximum;
sz w1 4 ; if type = long then
lo. w0 f5. ; w3w0 := long maximum;
rs w3 (x2+i16) ; number := w3;
sz w1 5 ; if type <> integer then
ds w0 (x2+i16) ; number := w3w0;
al w1 1 ; class := 1;
jl. d5. ; goto return;
c12: rl w3 x2+i6 ; finish long:
ds w1 x2+i12 ; save(number);
sn w3 -5 ; if sign <> pos then
jl. d7. ;
ld w1 -65 ; number := -number;
ss w1 x2+i12 ;
jl. d7. ; class := 2; goto return;
c11: rl w3 x2+i2 ; finish integer:
sz w3 1 ; if type = real then
jl. c13. ; goto finish real;
dl w1 x2+i12 ;
d1: sz w3 4 ; finish no real type:
jl. c12. ; if type = long then goto finish long;
sn w0 0 ;
sh w1 -1 ; if integer overflow then
jl. c10. ; goto error 2;
rl w3 x2+i6 ; exit signed int:
se w3 -5 ; if sign <> pos then
ac w1 x1 ; number:= - number;
rs w1 (x2+i16) ;
jl. d6. ; class:= 2; goto return;
\f
; rc 80.08.23 algol 8, char input, segment 2 page ...27...
; read number
c13: ; finish real:
dl w0 x2+i7 ; final exp:
se w0 -5 ;
ac w3 x3 ; if expsign <> pos
ws w3 x2+i11 ; then exp:= -exp;
rs w3 x2+i8 ; exp:= exp - factor;
dl w1 x2+i12 ; convert:
nd. w1 b0. ; normalize(number);
b0=k+1; norm exp ; norm exp:= -no of shifts;
al w3 ;
sn w3 -2048 ; if norm exp=-2048 then goto set exp;
jl. a7. ; comment number = 0 ;
al w3 x3+48 ; norm exp:= norm exp+48;
ld w1 -1 ; round:
aa. w1 f2.+2 ; number:= number>1 + round const;
nd w1 3 ; exp:= normalize(number);
ba w3 3 ; norm exp:= norm exp+exp;
a7: hs w3 3 ; set exp: exppart.number:= norm exp;
rl. w3 (j0.) ; comment make final floated number;
rs w3 x2+i11 ; old ovfl:= overflows;
rl. w3 (j4.) ;
rs w3 x2+i7 ; old underflows:=underflows;
al w3 0 ;
rs. w3 (j0.) ; overflows:=
rs. w3 (j4.) ; underflows:=0;
rl w3 x2+i8 ;
ns w3 5 ; comment stack reference in w2 destroyed;
bl w2 5 ; n:= number of significant bits.abs(exp);
\f
; jz.fgs 82.11.23 algol 8, char input, segment 2 page ...28...
; l:= 14;
ls w2 2 ; comment if positive exp then w2 uneven
al w2 x2+1+14<2 ; so booolean exp<-512 not true for pos exp;
sl w3 0 ; if exp < 0 then
jl. a0. ; begin
ls w3 1 ; l:= 23 - (n-2);
al w2 x2-5 ; number:= number/10**(2**n)
sn w2 0 ; end;
am -4 ;
fd. w1 x2+g2. ;
a0: hs. w2 b2. ;
a2: ls w3 1 ; for j:= l step 1 until 23 do
al w2 x2-4 ; if bit(j).exp = 1
sn w3 0 ; then
jl. a1. ; number:= number*10**(2**(23-j));
sh w3 0 ;
fm. w1 x2+g1. ;
jl. a2. ;
b2=k+1; bool, exp< -512; if exp < -512
a1: sn w1 x1 ; then number:= number/10**(2**9);
fd. w1 g1. ;
dl. w3 (j2.) ; w2:= saved stack ref;
rl. w3 (j0.) ;
wa. w3 (j4.) ;
rx w3 x2+i11 ; i11:=overflows+underflows;
rs. w3 (j0.) ; overflows:=old overflows;
rl w3 x2+i7 ;
rs. w3 (j4.) ; underflows:=old underflows;
rl w3 x2+i11 ;
se w3 0 ; if i11>0 then
jl. c10. ; goto error2;
\f
; jz.fgs 82.11.23 algol 8, char input, segment 2 page ...29...
; comment floating over/underflow has occurred
; or underflow has occurred;
d2: rl w3 x2+i2 ; check type:
sz w3 1 ; if type <> real then
jl. d3. ; begin
bl w3 3 ; comment: test if it is possible to
sl w3 48 ; convert the assembled real into a long;
jl. c10. ; if exponent > 47 then goto error 2;
ld w1 -12 ; clear exponent;
ld w1 x3-34 ;
aa. w1 f7.+2 ; round(number);
ld w1 -1 ; number := entier(number);
rl w3 x2+i2 ; w3 := type of parameter;
jl. d1. ; goto finish no real type;
d3: rl w3 x2+i6 ; exit signed float:
se w3 -5 ; if sign <> pos then
fm. w1 f1. ; number:= -number;
d7: ds w1 (x2+i16) ;
d6: al w1 2 ; class:= 2;
d5: dl w0 x2+i3 ; return:
rl w3 x3 ;
hs. w0 b1. ;
b1=k+1 ; rel ; goto(return segm + return rel);
jl x3 ;
\f
; jz.fgs 82.11.23 algol 8, char input, segment 2 page ...30...
; action table for number reading.
; the states are:
; 0 before number
; 1 following sign before number
; 2 following digit before point
; 3 following point
; 4 following digit after point
; 5 following exponent base
; 6 following exponent sign
; 7 following exponent digit
; 8 in erroneous number
; action addresses relative to c0
c1 = c1 -c0; digit before point
c2 = c2 -c0; digit in exp
c3 = c3 -c0; ten 1
c4 = c4 -c0; ten 2
c5 = c5 -c0; error 1
c6 = c6 -c0; point
c8 = c8 -c0; expsign
c9 = c9 -c0; sign
c10= c10-c0; error 2
c11= c11-c0; finish integer
c13= c13-c0; finish real
c0 = c0 -c0; digit after point
h. g0= k-18; number table base
;number table:
;state
; 0 1 2 3 4 5 6 7 8 class
c1 , c1 , c1 , c0 , c0 , c2 , c2 , c2 , c5 ; 2 digit
c9 , c5 , c5 , c5 , c5 , c8 , c5 , c5 , c5 ; 3 sign
c6 , c6 , c6 , c5 , c5 , c5 , c5 , c5 , c5 ; 4 point
c3 , c3 , c4 , c5 , c4 , c5 , c5 , c5 , c5 ; 5 exp ten
c5 , c10 , c11 , c10 , c13 , c10 , c10 , c13 , c10 ; 6 terminator
\f
; jz.fgs 82.11.23 algol 8, char input, segment 2 page ...31...
w.h.
;exponent table for generating real numbers
1280, 0, 0, 4; 10**(2**0)
1600, 0, 0, 7; 10**(2**1)
1250, 0, 0, 14; 10**(2**2)
1525, 3600, 0, 27; 10**(2**3)
1136, 3556, 3576, 54; 10**(2**4)
1262, 726, 3393, 107; 10**(2**5)
1555, 3087, 2640, 213; 10**(2**6)
1181, 3363, 3660, 426; 10**(2**7)
1363, 3957, 4061, 851; 10**(2**8)
1816, 3280, 1397, 1701; 10**(2**9)
g1=k-2, g2=g1+4
w.
m.readnumber
i.
e. ; end read number;
\f
; jz.fgs 82.11.23 algol 8, char input, segment 2 page ...32...
j20:
c.j20-506
m.code on segment 2 too long
z.
c.502-j20,0,r.252-j20>1 z.; fill rest of segm 2 with zeroes
<:char input<0>:> ; alarm text of segm 2
m.segment 2
i.
e. ; end segment 2
\f
; jz.fgs 1987.08.21 algol 8, char input, segment 3 page ...33...
; readall, readstring
b. j20, a5, d5 ; block for segment 3
k=0
h.
g6: g7 , g7 ; rel of last point, rel of last abs word
j1: g10+13 , 0 ; rs entry 13 last used
j2: g10+30 , 0 ; - - 30 saved stack ref
j3: g10+ 3 , 0 ; - - 3 reserve
j4: g10+ 4 , 0 ; - - 4 take expr
j5: g10+17 , 0 ; - - 17 index alarm
j7: g10+ 6 , 0 ; - - 6 end reg expr
j11: 1<11 o. (:-3:), 0 ; addr of segm 0
j15: 1<11 o. (:-2:), 0 ; addr of segm 1
j17: 1<11 o. (:+1:), 0 ; addr of segm 4
j18: g10+29 , 0 ; rs entry 29 param alarm
j6: 0 , e19 ; permanent core: define conversion table;
g7 = k - 2 - g6 ; rel of last abs word = rel of last point
w.
\f
; jz.fgs 88.06.01 algol 8, char input, segment 3 page ...34...
; common entry segment 3
; common entry segment 3:
b11:e11: am d3 ; readall entry: entry:= readall; goto inn:
b9: e9: al w0 d2 ; readstring entry: entry:= readstring;
rl. w2 (j1.) ; inn: w2:= saved stack ref:= last used;
ds. w3 (j2.) ; get zone formals:
al w1 i4 ; reserve(stacksize);
jl. w3 (j3.) ;
rs w0 x2+i0 ; save (entry);
al w0 x2+6 ; max :=
ba w0 x2+4 ; addr first formal0 +
rs w0 x2+i15 ; appetite;
bz w0 x2+7 ; kind := first param.formal0 extract 12;
rl w1 x2+8 ; w1 := first param.formal1;
rl. w3 (j11.) ; w3 := segtable(charinput.segment0);
se w0 23 ; if kind <> 23 <* zone *> then
jl w3 x3+e12 ; init pseudo zone;
rl w0 x1+h2+6 ; w0 := zone.state;
se w0 1 ; if zone state <> after read then
jl w3 x3+e15 ; check state further;
jl. w3 (j6.) ; define conversion table;
al w0 -1 ;
rs w0 x2+i31 ; maxcharcount := -1;
rl w0 x2+i0 ; w0 := entry to readstring or -all;
se w0 d2 ;
am 4 ;
al w3 x2+16 ; w3 := address of formal2.index;
rs w3 x2+i1 ; save (w3);
\f
; jz.fgs 87.08.21 algol 8, char input, segment 3 page ...35...
al w0 2.111 ; get index formals:
rl w1 x3-2 ; kind := formal0; type := kind extract3;
la w0 2 ; if kind = array
so w1 8 ; or kind = procedure then
jl. w3 (j18.) ; param alarm;
sl w0 2 ; if type < 2 <* integer *>
sl w0 5 ; or type > 4 <* long *>
jl. w3 (j18.) ; param alarm;
dl w1 x3 ; (w0,w1) := formal.index;
so w0 16 ; if expr then
jl. w3 (j4.) ; address := take expression;
ds. w3 (j2.) ;
sl w1 (x2+i15) ; if address(value) < max
jl. a2. ; and
sl w1 x2+6 ; address(value) >= first formal
rs w1 x2+i15 ; max := address(param);
a2: dl w0 (x2+i1) ; w3 := formal0.index;
dl w1 x1 ; (w0,w1) := value(index);
sz w3 1 ; if real then
cf w1 0 ; round(index);
rs w1 (x2+i1) ; comment: the indexvalue is saved
; in the formal2 part
bz w0 x2+10+1 ; get val array:
rs w0 x2+i2 ; type := kind of formal1.valarray;
rl w3 x2+i0 ; upper limit :=
se w0 23 ; if type = 23 <*zone*>
sn w3 d2 ; or readstring then
am 2 ; 23 <*zone variable*> else
al w3 22 ; 21 <*long array *> ;
sl w0 18 ; if type < 18 <*integer array*>
sl w0 x3 ; or type > upper limit then
jl. w3 (j18.) ; goto param alarm;
\f
; jz.fgs 87.08.21 algol 8, char input, segment 3 page ...36...
se w0 18 ; incr := if type = integer then
am 2 ; 2 else 4;
al w3 2 ;
se w0 21 ; if type = 21 <*double real*>
sn w0 22 ; or type = 22 <*complex *> then
al w3 8 ; incr := 8;
al w0 2 ; comment: incr for cl.array;
ds w0 x2+i18 ;
ls w3 -1 ; typ := incr//2;
hs. w3 a0. ;
rl w3 x2+12 ;
sl w3 (x2+i15) ; if absword addr < max
jl. a3. ; and
sl w3 x2+6 ; absword addr >= first formal
rs w3 x2+i15 ; then max := absword addr;
a3: ba w3 x2+10 ; dope := dope rel + base addr;
a0 = k + 1; typ
ls w1 ; index := index shift typ;
sh w1 (x3-2) ; if index > upper or
sh w1 (x3) ; index < lower then
jl. w3 (j5.) ; alarm(<:index:>);
wa w1 (x2+12) ; w1 := base + index;
rl w0 x3-2 ;
wa w0 (x2+12) ; w0 := base + upper;
am (x2+i0) ; goto entry;
d1: jl. +0 ;
\f
; jz.fgs 87.08.20 algol 8, char input, segment 3 page ...37...
; readstring
; integer procedure readstring(z,a,index,optional);
; value index; integer index; zone or array z; real array a;
; optional is an optional value parameter ;
; procedure which reads a string(max <optional> characters)
; from the zone or array z into the one-dimensional
; real array a starting at element no index.
; the string is packed with six characters per double word. if exit is
; caused by a terminator, the remaining characters are null characters
; and the value of the procedure is the number of filled elements.
; if exit is caused by a full array, no null character is packed
; and the value of the procedure is -(number of filled elements).
; the registers are undefined by entry and exit.
b. a9, b5 ; read string block begin
w.
;the procedure utilizes the formal cells as variables:
b0= 12 ; last address
b1= 14 ; current address
b2= 16 ; first address
d2=k-d1
al w1 x1+2 ; readstring:
ws w1 x2+i19 ; first address := current addr :=
rs w1 x2+b2 ; w1 + 2 - incr;
ds w1 x2+b1 ; last address := w0;
al w1 1 ;
rs w1 (x2+b1) ; current word:= endmark;
\f
; jz.fgs 87.08.21 algol 8, char input, segment 3 page ...38...
a5: rl. w3 (j15.) ; for class:= inchar(val) while class>6 do
jl w3 x3+e3 ; if class=8 and val=25 then
sh w0 6 ; begin
jl. a8. ; comment end medium character;
sn w1 25 ; readstring:= 0;
se w0 8 ; goto common return segm 3
jl. a5. ; end;
al w1 0 ; goto test optional param;
jl. a7. ; comment skip leading terminators;
a0: al w1 1 ; new word:
rs w1 (x2+b1) ; current word:= endmark;
a1: rl. w3 (j15.) ; next char: class:= inchar(val);
jl w3 x3+e3 ;
sl w0 7 ; if class > 6 then
jl. a2. ; goto finish string;
e18: ; return from segment 0:
a6: rx w1 (x2+b1) ; pack:
ld w1 8 ; w01:= current word shift 8 + char;
wa w1 (x2+b1) ; current word:= w1;
rs w1 (x2+b1) ; endword:= bit23.w0;
so w0 1 ; if endword=0 then
jl. a1. ; goto next char;
rl w1 x2+b1 ; test current address:
sn w1 (x2+b0) ; if current address = last address then
jl. a3. ; goto array full;
al w1 x1+2 ; current address:= current address + 2;
rs w1 x2+b1 ;
jl. a0. ; goto new word;
a8: rl. w3 (j11.) ; test optional param:
al w0 x2+22 ;
sh w0 (x2+i15) ; if there exists a fourth parameter then
jl x3+e17 ; take maxcharcount;
jl. a6. ; goto pack;
\f
; jz.fgs 1987.08.20algol 5, char input, segment 3 page ...39...
; readstring
a2: rl w0 (x2+b1) ; finish string:
ns w0 (x2+b1) ; fill rest of current word with
ls w0 2 ; null-characters;
rs w0 (x2+b1) ;
am 2 ; sign:= pos; goto exit;
a3: al w0 -1 ; array full: sign:= neg;
rl w1 x2+b1 ; exit:
ws w1 x2+b2 ; dist:= current address - first address;
rl w3 x2+i19 ;
se w3 2 ; if incr <> 2 and
sz w1 2.11 ; dist mod 4 = 0 then
jl. a4. ; begin
al w3 0 ; store(current address+2):= 0; comment
am (x2+b1) ; fill rest of double word with zeroes;
rs w3 2 ; end;
a4: rs w0 6 ; saved w0 := w0;
al w0 0 ;
wd w1 x2+i19 ; no of elem := dist // incr;
rl w0 6 ; w0 := saved w0;
e10: al w1 x1+1 ; exit: no of elem := no of elem + 1;
e16: se w0 1 ; if sign = neg then
ac w1 x1 ; readstring:= - no of elem;
a7: rl w3 x2+i21 ; common return segm 3:
al w0 1 ; comment w1 = proc value;
rs w0 x3+h2+6-h3; state.zone descr:= after read;
al w0 0 ;
rs w0 x3+4 ; record length. zone descr:= 0;
rs. w2 (j1.) ; last used:= w2; comment release stack;
jl. (j7.) ; return;
m.readstring
i.
e. ; end readstring;
d3=k-d2-d1 ; entry readall:
rl. w3 (j17.) ; goto readall
jl x3+e21 ; on segment 4;
\f
; jz.fgs 1987.08.21 algol 5, char input, segment 3 page ...40...
j20:
c.j20-506
m.code on segment 3 too long
z.
c.502-j20,0,r.252-j20>1 z.; fill rest of segment 3 with zeroes
<:char input<0>:> ; alarm text segment 3
m.segment 3
i.
e. ; end segment 3
\f
; jz.fgs 1987.08.21 algol 8, char input, segment 4 page ...41...
; readall, readstring
b. j20 ; block for segment 4
k=0
h.
g8: g9 , g9 ; rel of last point, rel of last abs word
j5: g10+17 , 0 ; - - 17 index alarm
j15: 1<11 o. (:-3:), 0 ; addr of segm 1
j16: 1<11 o. (:-2:), 0 ; addr of segm 2
j17: 1<11 o. (:-1:), 0 ; addr of segm 3
g9 = k - 2 - g8 ; rel of last abs word = rel of last point
w.
\f
; jz.fgs 87.08.21 algol 8, char input, segment 4 page ...42...
; integer procedure readall(z, val, cl, index);
; value index; integer index; zone or array z; general val;
; integer array cl;
;procedure which reads a string consisting of a mixture of numbers,
;texts and terminators from the zone or array z and stores the constituents
;in the one-dimensional integer or real array val together with the
;corresponding classes in the one-dimensional integer array cl,
;both arrays starting at element no index.
;textstrings and numbers are treated as in the procedures readstring
;and read respectively.
;the value of the procedure is the number of filled array elements.
;if exit is caused by a terminator, the procedure value is positive,
;if exit is caused by a filled array, whether it is val or cl, the
;procedure value is negative. in this case a character too much
;is read but not stored.
;the registers are undefined by entry and exit.
b. b5, a20 ; readall block begin
w.
e21: ; readall:
ds w1 x2+i16 ; valinx := w1;
rl w1 x2+i20 ; lastval := w0;
rl w3 x2+16 ; get cl array:
ba w3 x2+14 ; dope:= dope rel + base addr;
ls w1 1 ; index:= index*2;
sh w1 (x3-2) ; if index > upper or
sh w1 (x3) ; index < lower then
jl. w3 (j5.) ; alarm(<:index:>);
rl w0 x3-2 ;
wa w0 (x2+16) ; lastcl:= upper + base address;
al w3 x1 ; old clinx:=
wa w3 (x2+16) ; clinx:= index + base address;
rs w3 x2+i23 ;
ds w0 x2+i14 ;
rl. w3 (j15.) ; class:= inchar(int value);
jl w3 x3+e3 ;
\f
; jz.fgs 87.08.21 algol 8, char input, segment 4 page ...43...
; readall
a0: sl w0 7 ; testcl: if class >= 7 then
jl. a5. ; goto terminator;
rl. w3 (j16.) ;
se w0 6 ; if class <= 5 then
jl x3+e5 ; readnumber;
jl. w3 a15. ; string: init string words;
a2: rx w1 (x2+i20) ; pack:
ld w1 8 ; w01:= val(i) shift 8 + int value;
wa w1 (x2+i20) ; val(i):= w1;
rs w1 (x2+i20) ; endword:= bit23.w0;
sz w0 1 ; if endword=1 then
jl. a4. ; goto word filled;
a3: rl. w3 (j15.) ; next:
jl w3 x3+e3 ; class:= inchar(int value);
a13: sh w0 6 ;
jl. a2. ; test next: if class<=6 then goto pack;
rl w3 (x2+i20) ; finish:
ns w3 x2+i11 ; fill rest of val(i) with
ls w3 2 ; zeroes;
rs w3 (x2+i20) ;
jl. a9. ; goto after read;
a4: rl. w3 (j15.) ; word filled:
jl w3 x3+e3 ; class:= inchar(int value);
rl w3 x2+i16 ; if i<>valinx then
sn w3 (x2+i20) ; begin
jl. a14. ;
rs w3 x2+i20 ; i:= i + 2;
al w3 1 ; val(i):= endmark;
rs w3 (x2+i20) ; end else
jl. a13. ; begin
a14: jl. w3 a12. ; test incr arr;
jl. w3 a15. ; init string words;
jl. a13. ; end; goto test next;
\f
; jz.fgs 87.08.21 algol 8, char input, segment 4 page ...44...
a15: ds w0 x2+i3 ; init string words:
al w0 6 ; save(return,class);
rs w0 (x2+i15) ; cl(cl inx):= class string;
bz w3 x2+i2+1 ; if type=integer then
sn w3 18 ; begin
; comment text is always packed into
a16: jl. w3 a12. ; double words; test incr arr;
rs w0 (x2+i15) ; cl(cl inx):= class string;
a1: al w0 0 ; end;
rl w3 x2+i16 ;
rs w0 x3 ; val(val inx):= 0;
al w3 x3-2 ;
rs w3 x2+i20 ; i:= val inx - 2;
al w0 1 ; val(i):= endmark;
rs w0 x3 ;
dl w0 x2+i3 ; restore(return,class);
jl x3 ; return;
\f
; jz.fgs 87.08.21 algol 8, char input, segment 4 page ...45...
; readall
e13 = k-e14
rs w1 (x2+i15) ; readall after number:
dl w1 x2+i0 ; restore(class,value); cl(clinx):= class;
jl. a9. ; goto after read;
a5: rx w0 2 ; terminator:
bz w3 x2+i2+1 ;
rs w0 (x2+i16) ;
sh w3 18 ;
jl. a7. ;
al w3 x3-20 ; comment: test if type=long...;
se w3 0 ; if type = real then
a6: ci w0 0 ; float(int value);
ds w0 (x2+i16) ; val(val inx):= int value;
a7: rs w1 (x2+i15) ; cl(cl inx):= class;
sn w1 8 ; if class= 8 then
jl. a11. ; goto exit;
a8: rl. w3 (j15.) ; read char:
jl w3 x3+e3 ; class:= inchar(int value);
a9: al. w3 a0. ; after read: set return(test cl);
a12: ds w1 x2+i0 ; test incr arr:
dl w1 x2+i15 ;
se w0 (x2+i17) ; if val inx = last val or
sn w1 (x2+i14) ; cl inx = last cl then
jl. a10. ; goto exit full array;
aa w1 x2+i18 ; cl inx:= cl inx + 2;
ds w1 x2+i15 ; val inx:= val inx + incr;
dl w1 x2+i0 ;
jl x3 ; return;
a10: am x3-3 ; exit full array: sign:= neg; goto l;
a11: al w0 1 ; exit: sign:= pos;
rl w1 x2+i15 ; l:
ws w1 x2+i23 ; readall:= no of elem:=
ls w1 -1 ; (cl inx - old clinx)//2 + 1;
rl. w3 (j17.) ;
se. w0 a16. ; if sign = neg then readall:= - no of elem;
jl x3+e10 ; goto common return segm 3;
jl x3+e16 ; comment full array in init string words;
m.readall
i.
e. ; end readall;
\f
; jz.fgs 87.08.21 algol 5, char input, segment 4 page ...46...
j20:
c.j20-506
m.code on segment 4 too long
z.
c.502-j20,0,r.252-j20>1 z.; fill rest of segment 4 with zeroes
<:char input<0>:> ; alarm text segment 4
m.segment 4
i.
e. ; end segment 4
m.global slang block
i.
e. ; end global slang segment
m.rc 88.06.01 algol 8, character input procedures.
\f
; jz.fgs 87.08.21 algol 8, char input page ...47...
; tails to be inserted in catalog
g0: ; first entry:
;read ; read is the area entry
5 ; 5 segments
0,r.4 ; fill
1<23+1<12+b2 ; entry point
3<18+39<12+41<6+0,0 ; integer proc, sp general, sp undefined
4<12+c0 ; 4, start of ext list
5<12 + p0; code segments, bytes in permanent core
;readchar
1<23+4 ; mode= backing store
<:read:>,0,0 ; document name
1<23+1<12+b0 ; entry point
3<18+19<12+8<6+0,0 ; integer proc, sp addr integer, sp zone
4<12 ; 4, fill
5<12 + p0; code segments, bytes in perm. core
;repeatchar
1<23+4 ; mode
<:read:>,0,0 ; document name
1<23+0<12+b7 ; entry point
1<18+8<12+0,0 ; no type proc, spec zone
4<12 ; 4, fill
5<12 + p0; code segments, bytes in perm core
;intable
1<23+4 ; mode
<:read:>,0,0 ; document name
1<23+0<12+b8 ; entry point
1<18+41<12+0,0 ; no type proc, spec undef
4<12 ; 4, fill
5<12 + p0; code segments, bytes in perm core
;readstring
1<23+4 ; mode
<:read:>,0,0 ; document name
1<23+3<12+b9 ; entry point
3<18+39<12+41<6+41,0; integer proc, sp general, sp undef, sp undef
4<12 ; 4, fill
5<12 + p0; code segments, bytes in perm core
\f
;jz.fgs 87.08.21, char input page ...48...
;tails to be inserted in catalog
;readall
1<23+4 ; mode
<:read:>,0,0 ; document name
1<23+3<12+b11 ; entry point
3<18+13<12+25<6+41 ; integer proc, sp val integer,
41<18+0 ; sp integer array, sp undef, sp undefined
4<12 ; 4, fill
5<12 + p0; code segments, bytes in perm core
g1: ;last entry
;tableindex
1<23+4 ; mode
<:read:>,0,0 ; document name
p8 ; byte p8 in permanent core
9<18+0,0 ; integer variable
4<12 ; 4, fill
5<12 + p0; code segments, bytes in perm core
\f
d.
p. <:insertproc:>
▶EOF◀