|
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: 123648 (0x1e300)
Types: TextFile
Names: »pnumber4tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »pnumber4tx «
; eah 10.5.81 algol 8, text procedures page 0.1
;
m. release 1.0, 11.6.81
;
; contents page
;
; slang names
; a-names, local labels
; b-names, - constants
; c-names, global labels
; d-names, global subroutines 0.3
; e-names, procedure entries 0.4
; f-names, global constants 0.5
; g-names, tails, headword
; h-names, fp
; i-names, variables in stack 0.6
; j-names, rs-entries
; n-names, segment references
; p-names, own permanent core 0.9
; r-names, chain for rel
;
; code segments
; segment 1:
; entry of put procedures 1.2
; - - get - 1.3
; check of parameters 1.4
; segment 2:
; put_char 2.2
; put_text 2.3
; subprocedure outchar 2.7
; - outdigit 2.10
; - outspaces 2.11
; return from put/get proc 2.13
; segment 3:
; put_num (integer, long) 3.2
; segment 4:
; put_num (real) 4.2
; segment 5:
; get_text 5.2
; subprocedure inchar 5.5
; - packchar 5.8
; segment 6:
; read_number 6.2
; segment 7:
; get_num 7.2
; finis_getnum 7.5
; alarm messages (param errors) 7.6
\f
; eah 1.3.81 algol 8, text procedures page 0.2
b. e20,f60,g1 ; insertproc block
w.
d.
p.<:fpnames:>
l.
s. d100, i40 ; slang segment
w.
; slang names
;
; a-names
;
; procedure or subroutine block
; used for labels at the innermost block level
;
;
;
; b-names
;
; procedure or subroutine block
; used for variables and constants at the innermost blocklevel.
;
;
;
; c-names
;
; code segment block
; used for labels global on segment
;
\f
; eah 10.3.81 algol 8, text procedures page 0.3
;
; d-names
;
; slang segment
; global entries of subroutines and other global labels.
; two d-names are used for each entry or label:
;
; d<2n> normal slang label, used for reference from own segment
; d<2n+1> relative address on segment, used for reference from
; other segments.
;
; d-names subroutine page
;
; d0 - d1 normal return from putproc 2.13
; d2 - d3 error return 2.14
; d4 - d5 put_char_cont 2.2
; d6 - d7 put_text_cont 2.3
; d8 - d9 put_num_cont 3.2
;
; d10 - d11 outchar 2.7
; d12 - d13 outdigit 2.10
; d14 - d15 outspaces_as_digits 2.11
; d16 - d17 outspaces 2.11
;
; d20 - d21 param_error 7.6
; d22 - d23 print_number 3.6
; d24 - d25 print_real 4.2
; d26 - d27 print_exp 4.6
; d28 - d29 all_spaces_out 4.8
;
; d30 - d31 end_number 3.11
;
;
;
; d42 - d43 get_text_cont 5.2
; d44 - d45 get_num_cont 7.2
; d46 - d47 finis_getnum 7.5
;
; d50 - d51 inchar 5.5
; d52 - d53 pack_char 5.8
;
; d60 - d61 normal return from gettext/char 2.13
; d62 - d63 - - - getnum 2.13
;
;
\f
; eah 1.3.81 algol 8, text procedures page 0.4
;
; e-names
;
; insertproc block
; only used for the procedure entries
; two e-names are used for each entry, only used in tails.
;
; e<2n> segment number (rel.to first code segment)
; e<2n+1> relative entry address on code segment
;
; e-names code procedure page
;
; e0 -e1 put_number 1.2
; e2 -e3 put_fixed 1.2
; e4 -e5 put_char 1.2
; e6 -e7 put_text 1.2
;
; e8 -e9 get_number 1.3
; e10-e11 get_fixed 1.3
; e12-e13 get_char 1.3
; e14-e15 get_text 1.3
;
;
\f
; eah 1.3.81 algol 8, text procedures page 0.5
;
; f-names
;
; insertproc block
; used for global constants
;
; f-name ; use
f0 = 0 ; segment count
; f1 ; number of externals (def.segm.1)
; f2 ; start of external list (def.segm.1)
; f3 ; number of hw in permanent core (def.p-names)
f4 = 10000 ; first k-value on code segment
; f5 ; number of hw reserved in stack (def.i-names)
; f6 ; check - - - - -
f32 = 32 ; char val. of space
f39 = 39 ; - - - exponent mark
f43 = 43 ; - - - plus
f45 = 45 ; - - - minus
f46 = 46 ; - - - dec.point
;
;
;
; g-names
;
; insertproc block
; g0 first tail
; g1 last tail
;
; code segment block:
; g1 rel of last point
; g2 - - - absword
; g3 administration at end segment
;
;
\f
; eah 1.3.81 algol 8, text procedures page 0.6
;
;
; i-names
;
; slang segment
; used for variables in stack
;
f5 = 76
; i-names for put-procedures
i0 = -f5 ; word ; curr_inx (hw-index of curr.charpos in dest)
i1 = i0 + 2 ; word ; txt_inx ( - - - - - text)
; putnum puttext
i2 = i1 + 4 ; double ; spaces remaining _ string portion
i3 = i2 + 2 ; half ; b dig.tot. ) text array base
i4 = i3 + 1 ; - ; h d.bef.pt.) i3 to i9
i5 = i4 + 1 ; - ; d d.aft.pt.) must be text array upper index
i6 = i5 + 1 ; - ; pnfn ) consecutive _
i7 = i6 + 1 ; - ; s dig.exp. )
i8 = i7 + 1 ; - ; pefe ) save text param pair
i9 = i8 + 1 ; word ; spaces in layout _
i10 = i9 + 2 ; half ; procstate:
; getbit<10 + layouttype<8 + arraytype<6 + 1<procno
; getbit: 2.0 = put-procedure
; 2.1 = get-procedure
; layouttype: 2.00 = no layout
; 2.01 = integer layout
; 2.10 = real layout
; arraytype: 2.0 = 8-bits char
; 2.1 = 12-bits char
; procno: 2.0001 = put/get_number
; 2.0010 = put/get_fixed
; 2.0100 = put/get_char
; 2.1000 = put/get_text
i11 = i10 + 1 ; - ; sign_char short string (1=yes,0=no)
\f
; eah 1.5.81 algol 8, text procedures page 0.7
i12 = i11 + 1 ; word ; following zeroes / new_s text_ref (segm<12+rel)
i13 = i12 + 2 ; - ; exp10 / rep / length
i14 = i13 + 2 ; - ; last formal addr, later h_addr
i15 = i14 + 2 ; - ; conv_table base (0 = no conv_table)
i16 = i15 + 2 ; - ; - upper index
i17 = i16 + 2 ; - ; - lower index-2
i18 = i17 + 2 ; - ; last literal addr
i19 = i18 + 2 ; - ; save general return addr
i20 = i19 + 2 ; - ; dest base
i21 = i20 + 2 ; - ; - upper index
i22 = i21 + 2 ; - ; char count
i23 = i22 + 2 ; - ; max charcount
i24 = i23 + 2 ; - ; converted char value
i25 = i24 + 2 ; - ; char value
i26 = i25 + 2 ; half ; stop, <>0 when last elem of dest filled
i27 = i26 + 1 ; - ; char pointer (-16, -8, or 0)
i28 = i27 + 1 ; word ; save general return2 addr
i29 = i28 + 2 ; - ; save num.param.type save num.value
i30 = i29 + 2 ; - ; - - - addr - - -
i31 = i30 + 2 ; - ; remaining bits in spaceword
i32 = i31 + 2 ; - ; d_addr
i33 = i32 + 2 ; - ; digit_base (digit_index)
i34 = i33 + 2 ; half ; exp.sign_char
; the last 15 hw's before stackref are reserved for holding the digits
; of the converted number part (see explanation segm.3)
f6 = -i34
c. 15-f6
m. too few hw reserved in stack
z.
\f
; eah 1.5.81 algol 8, text procedures page 0.8
;
;
; i-names used for get procedures:
;
; i0 ; word ; curr_inx (hw-index of curr.charpos in source)
; i1 ; - ; txt_inx ( - - - - - text)
;
; ; get_num get_text
; i2 ; duble ; save layin, number
; i3 ; half ; no.of decimals(layin) text array base
; i4 ; - ; first letter (layin)
; i5 ; word ; factor, save_ovfl text array upper index
; i7 ; - ; digit save textparam.type
; i9 ; - ; digit (doubleword) save textparam.addr
;
; i10 ; half ; procstate
; i11 ; - ; error_in_getnum stop text, <>0 when last elem filled
;
; i12 ; word ; exp save char value extract 8
; i13 ; - ; exp_sign, save unfl / rep / length
; i14 ; - ; last formal addr
; i15 ; - ; conv_table base (0=no conv_table)
; i16 ; - ; - upper index
; i17 ; - ; - lower index-2
; i18 ; - ; last literal addr
; i19 ; - ; save general return addr
; i20 ; - ; source base
; i21 ; - ; - upper index
; i22 ; - ; charcount
; i23 ; - ; max_charcount (positions in layin)
; i24 ; - ; save class<12 + char
; i25 ; - ; pack_count (no.of packed characters)
;
; i26 ; half ; stop source, <> 0 when last elem of source exhausted
; i27 ; - ; char pointer (in source)
;
; i28 ; word ; general return2
; i29 ; - ; save numparam type
; i30 ; - ; save num/char param addr
; i31 ; - ; sign
; i32 ; - ; state
; i33 ; - ; save char_class
; i34 ; - ; save char_value char_pointer (in text)
\f
; eah 1.3.81 algol 8, text procedures page 0.9
;
;
; j-names
;
; code segment block
; used for rs-entries (abs words and points)
;
; j0 head word, segm.table.addr of own segm.
; j<n> ref.to rs-entry no <n>
;
;
;
; n-names
;
; code segment block
; used for abswords for reference to other segments
;
; n<n> ref.to segment no <n>
;
;
;
; p-names
;
; code segment block
; used for reference to own permanent core
;
; hw.no contents
; p1 1 put_get_error
f3 = 1+1 ; number of halfwords in own permanent core
;
;
; r-names
;
; code segment block
; used for chain for rel
;
\f
; eah 1.5.81 algol 8, text procedures page 0.10
;
b. j0 ; begin segment 0, external list
f1 = 0 ; no. of externals
k = 0
w.
j0: 0 ; head word
h.
0, r.494 + j0. - (:f1*12:) ; zerofill
w.
f2 = k-j0 ; rel. start of external list
f1 ; no.of externals
0 ; no.of hw to initialize in own core
; external list empty
s3, s4 ; date and clock
0, r.5 ; continueword, alarmtext
e. ; end segment 0
\f
; eah 1.3.81 algol 8, text procedures page 1.1
b. c30, g3, j100, n10, p1
f0 = f0 + 1 ; segment count
f1 = 0 ; no.of externals
k = 10000 ;
h.
j0: g1, g2 ; head word: last point, last absword
; rs-entries:
j3: f1+ 3, 0 ; rs.3, reserve
j4: f1+ 4, 0 ; rs.4, take expression
j13: f1+13, 0 ; rs.13, last used
j30: f1+30, 0 ; rs.30, save stackref, w3
n2: 1<11 o.(:2-f0:), 0 ; ref. to segment 2
n3: 1<11 o.(:3-f0:), 0 ; - - - 3
n5: 1<11 o.(:5-f0:), 0 ; - - - 5
n7: 1<11 o.(:7-f0:), 0 ; - - - 7
g2 = k-2-j0 ; rel of last absword
g1 = k-2-j0 ; rel of last point
w.
\f
; eah 1.3.81 algol 8, text procedures page 1.2
;
b. a30, b20 ; begin block start put/get procedures
w.
;
; integer procedure
; put_number (dest, pos, conv_table, <<layout>, numparam);
; put_fixed (dest, pos, conv_tabel, <<layout>, int_long_param);
; put_char (dest, pos, conv_table, char_param, rep);
; put_text (dest, pos, conv_table, text_param, length);
;
; array dest (boolean, long, or real)
; integer pos
; integer array conv_table (may be left out)
; string <<layout> ( - - - - )
; integer/long/real num_param
; integer/long int_long_param
; integer/boolean char_param
; integer rep ( - - - - )
; string/array text_param
; integer length ( - - - - )
;
e0 = f0-1 ; put_number:
e1 = k-j0 ; procno := 0;
am 1 -1<1 ;
e2 = f0-1 ; put_fixed:
e3 = k-j0 ; procno := 1;
am 1<1-1<2 ;
e4 = f0-1 ; put_char:
e5 = k-j0 ; procno := 2;
am 1<2-1<3 ;
e6 = f0-1 ; put_text:
e7 = k-j0 ; procno := 3;
al w0 1<3 ; w0:= procstate := 1 shift procno;
jl. c0. ; goto start;
\f
; eah 1.5.81 algol 8, text procedures page 1.3
;
; integer procedure
; get_number (source, pos, conv_table, <<layin>, num_param);
; get_fixed (source, pos, conv_table, <<layin>, int_long_param);
; get_char (source, pos, conv_table, char_param);
; get_text (source, pos, conv_table, text_array, length);
;
; array source (boolean, long, or real)
; integer pos
; integer array conv_table (may be left out)
; string <<layin> ( - - - - )
; integer/long/real num_param
; integer/long int_long_param
; integer/boolean char_param
; array (any type) text_array
; integer length (may be left out)
e8 = f0-1 ; get_number:
e9 = k-j0 ; procno:= 0
am 1 -1<1 ;
e10 = f0-1 ; get_fixed:
e11 = k-j0 ; procno:= 1
am 1<1-1<2 ;
e12 = f0-1 ; get_char:
e13 = k-j0 ; procno:= 2
am 1<2-1<3 ;
e14 = f0-1 ; get_text:
e15 = k-j0 ; procno:= 3
al w0 1<3 + 1<10 ; w0:= procstate:= 1 shift procno + getbit;
\f
; eah 1.5.81 algol 8, text procedures (dest/source) page 1.4
;
; start:
;
c0: ; start:
rl. w2 (j13.) ; w2:= stackref;
ds. w3 (j30.) ; save stackref, w3
al w1 -f5 ; reserve working locations
jl. w3 (j3.) ; in stack
hs w0 x2+i10 ; save procstate
al w0 0 ;
al w1 -1 ; max_charcount := -1;
ds w1 x2+i23 ; charcount := 0;
rs w0 x2+i2 ; layout:= no layout
hs w0 x2+i26 ; stop := false;
;
; first parameter, zone or array of type boolean, long, or real:
;
al w1 2.11111 ;
la w1 x2+6 ; w1:= kind (formal1);
sh w1 23 ; if kind > zone or
sh w1 16 ; kind < boolean array or
jl. c10. ; kind = integer array
sn w1 18 ; then
jl. c10. ; goto param_error (arraytype);
zl w3 x2+i10 ; w3:= procstate;
sn w1 17 ; if kind = boolean array then
al w3 x3+1<6 ; procstate := procstate + 12-bitstext;
hs w3 x2+i10 ;
al w1 x2+7 ; w1:= last literal addr :=
ea w1 x2+4 ; addr of first formal + appetite;
rs w1 x2+i18 ;
rl w1 x2+8 ; w1:= param addr;
sh w1 (x2+i18) ; if param addr <= last literal addr then
rs w1 x2+i18 ; last literal addr := w1;
;
; second parameter, start position:
;
dl w1 x2+12 ; w0w1 := formal2;
sz w0 16 ; if expression then
jl. a0. ; begin
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; save stackref, w3;
rs w1 x2+12 ; save addr of result in formal2.2;
a0: ; end;
sl w1 x2+12 ; if param addr > formal addr
sl w1 (x2+i18) ; and < last literal addr then
jl. a1. ; last literal addr := param addr;
rs w1 x2+i18 ;
\f
; eah 1.3.81 algol 8, text procedures (pos param) page 1.5
;
; check start position inside dest/source:
;
;
; in an 8-bits text hw-index corresponds to character position
; and charpointer in the following way:
;
; hw-index : ! -3, -2 ! -1, 0 ! 1 , 2 ! 3 , 4 !
; !--------!--------!--------!--------!
; pos : !-5,-4,-3!-2,-1, 0! 1, 2, 3! 4, 5, 6!
; ! ! ! ! !
; charpointer: !-16,-8,0!-16,-8,0!-16,-8,0!-16,-8,0!
;
;
a1:
rl w1 x1 ; w1:= startpos:= value (formal2);
zl w0 x2+i10 ; w0:= procstate;
sz w0 1<6 ; if 8-bitstext then
jl. a3. ; begin
al w1 x1+2 ; w1:= curr_inx :=
el w0 2 ; (startpos + 2)
el w0 0 ;
wd. w1 b1. ; // 3
ls w1 1 ; * 2; <*hw-index of startpos*>
sl w0 0 ; if remainder < 0 then
jl. a2. ; begin
al w1 x1-2 ; curr_inx:= curr_inx - 2;
wa. w0 b1. ; remainder:= remainder + 3;
a2: ; end;
ws. w0 b2. ; w0:= charpointer :=
ls w0 3 ; (remainder - 2) * 8;
hs w0 x2+i27 ; save charpointer;
; end 8-bits text
a3: ; else curr_inx = startpos;
rs w1 x2+i0 ; save curr_inx;
rl w3 x2+8 ; w3:= addr of baseword(dest);
rl w0 x3 ; w0:= dest_base:= baseword
ea w3 x2+6 ; w3:= dope addr;
sh w1 (x3-2) ; if curr_inx > upper index or
sh w1 (x3) ; < lower index then
jl. c11. ; param_error (charpos);
rl w1 x3-2 ; w1:= upper index of dest;
ds w1 x2+i21 ; save dest_base and upper index;
\f
; eah 1.3.81 algol 8, text procedures (conv_table) page 1.6
;
; third parameter, possibly conv_table:
;
al w3 x2+16 ; w3:= last formal addr:= addr.formal3;
al w1 2.11111 ;
la w1 x2+14 ; w1:= kind(formal3);
se w1 18 ; if kind = integer array then
jl. a4. ; begin
rl w1 x2+16 ; w1:= addr of baseword;
rl w0 x1 ; w0:= convtable_base:= baseword;
ds w0 x2+i15 ; save convtable_base and last formal addr;
jl. w3 c3. ; call save_last_literal_addr;
ea w1 x2+14 ; w1:= baseword addr + doperel;
dl w1 x1 ; w0w1:= upper,lower index:=
ds w1 x2+i17 ; dope vector;
jl. a5. ; end
; else
a4: ; begin <*no convtable*>
al w0 0 ; convtable_base:= 0;
al w3 x3-4 ; w3:= last formal addr := previous formal;
ds w0 x2+i15 ; save last formal addr;
; end;
;
; switch procedure type:
; (w3 = next param addr)
;
a5:
zl w1 x2+i10 ; w1:= procstate;
sz w1 1<2 ; if proc = put/get_char then
jl. c5. ; goto char_params;
sz w1 1<3 ; if proc = put/get_text then
jl. c6. ; goto text_params;
\f
; eah 1.3.81 algol 8, text procedures (num params) page 1.7
;
;
; num_params:
;
; layout parameter:
jl. w3 c1. ; get_next_parameter;
se w0 8 ; if param kind = string then
jl. a11. ; begin <*layout*>
dl w1 x1 ; w0w1 := string portion;
sl w1 0 ; if w1 < 0 or
sl w0 0 ; w0 >= 0 then
jl. c12. ; param_error (string not layout);
ds w1 x2+i2 ; save layout in stack;
jl. w3 c1. ; get_next_parameter;
; end;
a11: ; num parameter:
sl w0 10 ; if param kind < integer or
sl w0 13 ; > long then
jl. c12. ; param_error (num type);
zl w3 x2+i10 ; w3:= procstate;
so w3 1<1 ; if procedure = put_fixed
jl. a12. ; and
sn w0 11 ; param kind = real then
jl. c12. ; param_error (num type);
a12:
jl. w3 c2. ; check_last_parameter;
ds w1 x2+i30 ; save num.param pair;
zl w1 x2+i10 ; w1:= procstate;
rl. w3 (n7.) ;
sz w1 1<10 ; if proc = get_num then
jl x3+d45 ; goto get_num_cont (on segm.7)
rl. w3 (n3.) ; else
jl x3+d9 ; goto put_num_cont (on segm.3);
\f
; eah 1.3.81 algol 8, text procedures (char params) page 1.8
;
; char_params:
;
c5: ; char parameter:
jl. w3 c1. ; get_next_parameter;
sl w0 9 ; if param kind <> boolean and
sl w0 11 ; <> integer then
jl. c12. ; param_error (char type);
zl w3 x2+i10 ; w3:= procstate;
sz w3 1<10 ; if proc = put_char then
jl. a15. ; begin
zl w0 x1 ; w0:= char := param value
la. w0 b0. ; extract 8;
rs w0 x2+i25 ; save char;
al w1 1 ; w1:= rep:= 1; <*default rep-param*>
jl. w3 c4. ; get_rep_param;
rl. w3 (n2.) ; goto put_char_cont;
jl x3+d5 ; (on segm.2)
; end put_char_params
; else
a15: ; begin <*get_char*>
se w0 10 ; if param_kind <> integer then
jl. c12. ; param_error (char_type);
rs w1 x2+i30 ; save char_param_addr;
jl. w3 c2. ; check_last_parameter;
rl. w3 (n5.) ; call inchar (on segm.5)
jl w3 x3+d51 ; <*w0:=class,w1:=char*>
rs w1 (x2+i30) ; char_param:= char_value;
rl. w3 (n2.) ; goto normal_return_from getproc
jl x3+d61 ; (on segm.2)
; end get_char;
\f
; eah 10.3.81 algol 8, text procedures (text_params) page 1.9
;
;
; text_params:
;
c6: ; text parameter:
jl. w3 c1. ; get_next_parameter;
se w0 0 ; if paramtype = zone array
sl w0 9 ; or variable
jl. c12. ; or integer array
sn w0 2 ; then
jl. c12. ; param_error (text type);
ds w1 x2+i9 ; save text parameter in stack
se w0 8 ; if paramtype = string then
jl. a20. ; begin
zl w0 x2+i10 ; w0:= procstate;
sz w0 1<10 ; if proc = get_text then
jl. c12. ; param_error (texttype = string);
rl w0 x1-2 ; w0:= first word of text portion;
sh w0 -1 ; if w0 < 0 then
jl. c12. ; param_error (texttype = layout);
jl. a22. ; end
; else
a20: ; begin
al w3 1 ; txt_inx:=
se w0 1 ; if boolean array then 1
al w3 x3+1 ; else 2;
rs w3 x2+i1 ;
dl w1 (x2+i14) ; w0w1 := param pair textparam;
rl w3 x1 ; w3:= textbase:= baseword;
ea w1 0 ; w1:= dope address;
al w0 1 ;
sh w0 (x1-2) ; if 1 > upper_index or
sh w0 (x1) ; < lower_index then
jl. c30. ; param_error (text index);
rl w0 x1-2 ; w0:= upper index;
ds w0 x2+i5 ; save textbase, upper index;
; end array param;
\f
; eah 1.5.81 algol 8, text procedures (text_params) page 1.10
a22: ;
al w1 0 ; w1:= length:= 0; <*default length param*>
jl. w3 c4. ; get_length_param;
rs w1 x2+i13 ; save length;
sh w1 -1 ; w1:= maxcount:=
ac w1 x1 ; abs(length);
sn w1 0 ; if maxcount = 0 then
al w1 -1 ; maxcount:= -1;
rs w1 x2+i23 ; save maxcount;
;
zl w0 x2+i10 ; w0:= procstate;
rl. w3 (n5.) ;
sz w0 1<10 ; if proc = get_text then
jl x3+d43 ; goto get_text_cont (on segm.5)
rl. w3 (n2.) ; else
jl x3+d7 ; goto put_text_cont (on segm.2);
;
;
; local constants:
;
b0: 2.11111111 ; mask for char extract 8;
b1: 3 ;
b2: 2 ;
e. ;
\f
; eah 1.3.81 algol 8, text procedures (get_next_param) page 1.11
;
;
; local subroutine get_next_parameter
;
; call return
; w0 undef param type (kind extract 4)
; w1 undef abs addr of param
; w2 stackref unchanged
; w3 return undef
;
b. a1 ; begin block get_next_parameter:
w.
c1: ;
ac. w0 j0. ; w3:= rel.return :=
wa w3 0 ; abs return - segment start;
rs w3 x2+i19 ; save rel.return;
rl w1 x2+i14 ; w1:= last_formal_addr :=
al w1 x1+4 ; last_formal_addr + 4;
rs w1 x2+i14 ;
al w0 x1+2 ;
sl w0 (x2+i18) ; if last_formal_addr+2 > last_literal_addr then
jl. c12. ; param_error (too few parameters);
dl w1 x1 ; w0w1:= formal pair;
sz w0 16 ; if kind < 16 then
jl. a1. ; begin
so w0 8 ; if kind < 8 then
jl. c12. ; param_error (kind procedure or label);
jl. w3 (j4.) ; take expression;
ds. w3 (j30.) ; save stackref, w3;
a1: ; end;
jl. w3 c3. ; save_last_literal_addr;
al w0 2.1111 ; w0:= param type :=
am (x2+i14) ; param kind extract 4;
la w0 -2 ;
am (x2+i19) ; general return on this segment:
jl. j0. ; goto segment start + rel.return;
e. ; end get_next_parameter;
\f
; eah 10.3.81 algol 8, text procedures (check_last) page 1.12
;
;
; local subroutine check_last_parameter:
;
b. ; begin block check_last_parameter
w.
c2: ;
rs w3 x2+i19 ; save return addr
rl w3 x2+i14 ; w1:= next_param :=
al w3 x3+6 ; last_formal_addr + 6;
sl w3 (x2+i18) ; if next_param > last_literal addr then
jl (x2+i19) ; goto return;
rs w3 x2+i14 ; save next_param_addr;
jl. c12. ; param_error (too many parameters);
e. ; end check_last_parameter;
;
;
; local subroutine save_last_literal_addr;
;
; call return
; w0 undef unchanged
; w1 abs param addr -
; w2 stackref -
; w3 return -
;
b. ; begin block save_last_literal
w.
c3:
sl w1 (x2+i14) ; if param addr > last formal addr
sl w1 (x2+i18) ; and < last literal addr then
jl x3 ; then
rs w1 x2+i18 ; last literal addr := param addr;
jl x3 ; goto return;
e. ; end save_last_literal;
\f
; eah 11.3.81 algol 8, text procedures (get_rep) page 1.13
;
;
;
; local subroutine get_rep_parameter
;
; call return
; w0 undef undef
; w1 default rep value of rep param / unchanged
; w2 stackref unchanged
; w3 return undef
;
b. a1 ; begin block get_rep_parameter
w. ;
c4: ac. w0 j0. ; w3:= rel.return:=
wa w3 0 ; abs return - segment start;
rs w3 x2+i28 ; save in general return2;
rl w3 x2+i14 ; w3:= last formal addr;
al w3 x3+6 ; if next formal addr <
sl w3 (x2+i18) ; last literal addr then
jl. a1. ; begin
jl. w3 c1. ; get_next_parameter;
se w0 10 ; if param_inf <> integer then
jl. c12. ; param_error (rep_type);
jl. w3 c2. ; check_last_parameter;
rl w1 x1 ; w1:= rep:= param_value;
a1: ; end;
am (x2+i28) ; general return2 on this segment:
jl. j0. ; goto segment start + rel.return;
e. ; end get_rep_parameter;
\f
; eah 1.5.81 algol 8, text procedures page 1.14
;
; parameter errors:
;
b. ; begin block call param_error
w.
c10: am 0 -1 ; param_1:
c11: am 1 -2 ; charpos:
c12: am 2 -3 ; param_n:
c30: al w1 3 ; text_index:
rl. w3 (n7.) ; w1:= errortype;
jl x3+d21 ; goto param_error (on segment 7);
e. ; end block call param_error;
\f
; eah 10.3.81 algol 8, text procedures page 1.15
g3 = k-j0
c. g3-506
m. code on segment 1 too long
z.
c. 502-g3
0, r. 252 - g3>1
z.
<:text proc.1:>
e.
\f
; eah 1.3.81 algol 8, text procedures page 2.1
;
b. c30, g3, j100, n10, p1 ; begin segment 2
f0 = f0+1 ; segment count
k = 10000
h.
j0: g1, g2 ; head word: last point, last absword
j6: f1+ 6, 0 ; rs. 6, end register expr
j13: f1+13, 0 ; rs.13, last used
j16: f1+16, 0 ; rs.16, segm.table.base
j21: f1+21, 0 ; rs.21, general alarm
j60: f1+60, 0 ; rs.60, last of segm.table
n7: 1<11 o.(:7-f0:), 0 ; ref.to segment 7
p1: 0, 1 ; own perm.core: put_get_error
g2 = k-2-j0 ; rel of last absword
g1 = k-2-j0 ; rel of last point
w.
\f
; eah 10.3.81 algol 8, text procedures (put_char) page 2.2
;
b. a1 ; begin block put_char
w.
;
; put_char_continued:
;
d4:
d5 = k-j0
a1: sh w1 0 ; while rep > 0 do
jl. d0. ; begin <*exit to normal_return*>
al w1 x1-1 ; w1:= rep:= rep - 1;
rs w1 x2+i13 ;
rl w0 x2+i25 ; w0:= char value;
jl. w3 d10. ; call outchar;
rl w1 x2+i13 ; w1:= rep;
jl. a1. ; end while rep>0;
e. ; end block put_char_cont.
\f
; eah 10.3.81 algol 8, text procedures (put_text) page 2.3
;
b. a40, b10 ; begin block put_text
w.
;
; put_text_continued:
;
d6:
d7 = k-j0
dl w1 x2+i9 ; w0w1:= paramtype, -addr of text
sn w0 8 ; if paramtype = string then
jl. a20. ; goto put_string;
rl w1 x2+i1 ; w1:= txt_inx;
jl. a3. ; goto first_array_element;
;
; put_from_text_array:
;
a1: ; next_element:
rl w0 x2+i7 ; w0:= param type;
rl w1 x2+i1 ; w1:= txt_inx:=
se w0 1 ; if boolean array then
al w1 x1+1 ; txt_inx + 1
al w1 x1+1 ; else txt_inx + 2;
rs w1 x2+i1 ;
sh w1 (x2+i5) ; if txt_inx > upper_index then
jl. a3. ; begin
rl w0 x2+i22 ; w0:= charcount;
sl w0 (x2+i13) ; if charcount >= length then
jl. d0. ; goto normal_return
al w1 -2 ; else
jl. d2. ; goto error_return (-2); <*put exh.*>
; end;
;
; 12-bit text array:
;
a3: ; first_array_element:
se w0 1 ; if from boolean array then
jl. a10. ; begin
am (x2+i3) ;
zl w0 x1 ; w0:= char:= ba(txt_inx)
la. w0 b0. ; extract 8;
jl. w3 c0. ; check_null_char;
jl. w3 d10. ; call outchar;
jl. a1. ; goto next_element;
; end boolean array;
\f
; eah 11.3.81 algol 8, text procedures (put_text) page 2.4
;
; 8-bit text array:
;
a10: ;
am (x2+i3) ;
rl w0 x1 ; w0:= tx_word:= ia(txt_inx);
al w1 -16 ; w1:= charpointer;
a11: ; next_char:
ds w1 x2+i2 ; save tx_word, charpointer;
ls w0 x1 ; w0:= char:= tx_word shift (-16,-8,0)
la. w0 b0. ; extract 8;
jl. w3 c0. ; check_null_char;
jl. w3 d10. ; call outchar;
dl w1 x2+i2 ; w0w1:= tx_word, charpointer;
sl w1 0 ; if charpointer = 0 then
jl. a1. ; goto next_element;
al w1 x1+8 ; charpointer :+ 8;
jl. a11. ; goto next_char;
;
; put_string:
;
a20: ; put_string:
dl w1 x1 ; w0w1:= first textportion;
sl w1 0 ; if w1 >= 0 then
jl. a30. ; goto put_short_string;
al w3 0 ; short_string:= false;
hs w3 x2+i11 ;
a21: ; new_string_pointer:
rl w3 0 ; w3:= textref; (= text_segm<12 + reladdr)
a22: ; next_string_portion:
rs w3 x2+i12 ; save textref;
hs. w3 a24. ; store rel_addr;
zl w3 6 ; w3:= text_segm
ls w3 1 ; * 2
wa. w3 (j16.) ; + segm_table_base;
rl. w1 (j60.) ; w1:= last_of_segm_table;
sl w3 x1 ; if text_segm_addr > last_of_segm_table
jl. a35. ; then goto param_error (illegal string);
rl w3 x3 ; w3:= segm_table_word;
a24 = k+1
dl w1 x3+ 0 ; w0w1:= string_portion;
sh w1 -1 ; if string pointer then
jl. a21. ; goto new_string_pointer;
\f
; eah 11.3.81 algol 8, text procedures (put_text) page 2.5
;
;
; unpack_string_portion:
;
a25: ; repeat
ds w1 x2+i2 ; save string portion;
ls w0 -16 ; w0:= first char of portion;
sn w0 0 ; if char = 0 then
jl. d0. ; goto normal_return;
jl. w3 d10. ; call outchar;
dl w1 x2+i2 ; w0w1:= rest_string:=
ld w1 8 ; saved string portion shift 8
al w1 x1+255 ; + 2.11111111;
se w0 -1 ; until string portion exhausted
jl. a25. ; (rest_string = -1)
;
zl w0 x2+i11 ; if short_string
se w0 0 ; then goto normal_return;
jl. d0. ;
rl w3 x2+i12 ; w3:= textref:= textref - 4;
al w3 x3-4 ; <*string portions stored backwards*>
jl. a22. ; goto next_string_portion;
;
; put_short_string:
;
a30: ; put_short_string:
al w3 1 ; short_string:= true;
hs w3 x2+i11 ;
jl. a25. ; goto unpack_string_portion;
;
; param_error:
;
a35: ; text_param: illegal textref;
al w1 4 ; errortype:= string
rl. w3 (n7.) ; goto parameter error
jl x3+d21 ; (on segm.7)
b0: 2.11111111 ; mask for char extract 8;
e. ; end block put_text;
\f
; eah 10.3.81 algol 8, text procedures (check_null) page 2.6
;
;
; local subroutine check_null_char:
;
; call return
; w0 char unchanged
; w1 undef length
; w2 stackref unchanged
; w3 return unchanged
;
b. ; begin block check_null_char
w. ;
c0: rl w1 x2+i13 ; w1:= length;
se w0 0 ; if char = 0
jl x3 ; and
sh w1 0 ; length <= 0
jl. d0. ; then goto normal_return;
jl x3 ;
e. ; end check_null_char;
\f
; eah 1.3.81 algol 8, text procedures (outchar) page 2.7
;
; global subroutine outchar
;
;
; the subroutine inserts one character (after possible conversion by
; convtable) at the next character position in dest.
; characters are inserted as 12-bits characters in a boolean array,
; or packed as three 8-bits characters in one word otherwise.
;
; call return
; w0 char value undef
; w1 undef undef
; w2 stackref unchanged
; w3 abs return undef
;
b. a20, b10 ; begin block outchar
w.
d10: ; outchar:
d11 = k-j0
rl w1 x2+i15 ; w1:= convtable_base;
sn w1 0 ; if convtable_base <> 0 then
jl. a1. ; begin
ls w0 1 ; w0:= conv_index:= char * 2;
sh w0 (x2+i16) ; if conv_index > upper index
sh w0 (x2+i17) ; or <=lower index then
jl x3 ; return (no character put);
wa w0 2 ; w0:= entry := conv_index + convtable_base;
zl w0 (0) ; w0:= converted_char := convtable(entry);
sz w0 -1<8 ; if char > 255 or < 0 then
jl x3 ; goto return;
; end convtable_base <> 0;
\f
; eah 11.3.81 algol 8, text procedures (outchar) page 2.8
;
;
; put (converted) character:
;
a1:
zl w1 x2+i26 ; w1:= stop_mark;
se w1 0 ; if stop then
jl. c21. ; goto return (dest array full)
rl w1 x2+i22 ; w1:= charcount;
se w1 (x2+i23) ; if charcount = maxcount then
jl. a2. ; begin
zl w0 x2+i10 ; w1:= procstate;
sz w0 2.1100 ; if proc=put_char or proc=put_text then
jl. d0. ; goto normal_return_from_putproc
jl. c23. ; else goto error_return (layout);
a2: ; end;
al w1 x1+1 ; charcount:= charcount + 1;
rs w1 x2+i22 ;
rl w1 x2+i0 ; w1:= curr_inx;
rs w3 x2+i19 ; save return address;
;
; 12-bits dest:
;
zl w3 x2+i10 ; w3:= procstate;
so w3 1<6 ; if 12-bits dest then
jl. a5. ; begin
am (x2+i20) ; dest(curr_inx) :=
hs w0 x1 ; converted_char;
al w1 x1+1 ; curr_inx:= curr_inx + 1;
jl. a10. ; goto check_curr_inx;
; end 12-bits text;
\f
; eah 11.3.81 algol 8, text procedures (outchar) page 2.9
;
;
; 8-bits dest:
;
a5: ; 8-bits dest:
rs w0 x2+i24 ; save converted_char;
el w3 x2+i27 ; w3:= char_pointer; (-16, -8, or 0);
am (x2+i20) ; w0:= curr_word :=
rl w0 x1 ; dest(curr_inx);
al w1 0 ;
ld w1 x3 ; w0w1:= curr_word shift charpointer;
la. w0 b0. ; remove old character and insert
lo w0 x2+i24 ; converted char in rightmost 8 bits
ac w3 x3 ; w0:= new curr_word :=
ld w1 x3 ; w0w1 shift (-charpointer);
ac w3 x3-8 ; charpointer:= charpointer + 8;
rl w1 x2+i0 ; w1:= curr_inx;
am (x2+i20) ; dest(curr_inx):=
rs w0 x1 ; new curr_word;
sh w3 0 ; if charpointer > 0 then
jl. a11. ; begin <*prepare for next word of dest*>
al w3 -16 ; charpointer:= first char in word;
al w1 x1+2 ; curr_inx :+ 2;
a10: ; check_curr_inx: <*jump from 12-bits dest*>
rs w1 x2+i0 ; save curr_inx;
am (x2+i21) ;
sl w1 +1 ; if curr_inx > upper index (dest) then
hs w3 x2+i26 ; stop := true;
; end next word of dest;
a11: ;
hs w3 x2+i27 ; save charpointer;
jl (x2+i19) ; goto return;
;
; local constants:
;
b0: -1<8 ; mask for remove last char in word
e. ; end block outchar;
\f
; eah 20.3.81 algol 8, text procedures (outdigit) page 2.10
;
;
; global subroutine outdigit
;
; the subroutine outputs one digit as a character, possibly followed
; by a space according to the spaceword of the layout.
;
; call return
; w0 undef undef
; w1 digit undef
; w2 stackref unchanged
; w3 abs return undef
;
b. ; begin block outdigit
w.
d12: ; outdigit:
d13 = k-j0 ;
rs w3 x2+i28 ; save return addr;
al w0 x1+48 ; w0:= char:= digit + 48;
jl. w3 d10. ; call outchar (digit);
rl w1 x2+i31 ; w1:= remaining_bits_in_spaceword:=
ls w1 1 ; spaceword shift 1;
rs w1 x2+i31 ;
al w0 f32 ; w0:= char:= space;
sh w1 -1 ; if spaceword < 0 then
jl. w3 d10. ; call outchar (space);
jl (x2+i28) ; goto return;
e. ; end outdigit;
\f
; eah 20.3.81 algol 8, text procedures (outspaces) page 2.11
;
;
; global subroutine outspaces
;
; the subroutine outputs a number of space characters.
; two entries to the subroutine:
;
; d14-d15: outspaces_as_digits:
; outputs space chars in unused digit positions in the
; start or the end of the layout.
;
; d16-d17: outspaces:
; outputs leading spaces before first digit position of
; the layout, or ending spaces after the last digit position.
;
; call return
; w0 undef undef
; w1 no.of spaces undef
; w2 stack ref unchanged
; w3 abs return undef
;
b. a10 ; begin block outspaces
w.
d14: ; outspaces_as_digits:
d15 = k-j0 ;
rs w3 x2+i28 ; save return
rl w0 x2+i31 ; w0:= spaceword;
al w3 x1 ; w3:= i:= no_of_digits (no.of spaces)
a1: ; repeat
ls w0 1 ; spaceword:= spaceword shift 1;
sh w0 -1 ; if spaceword < 0 then
al w1 x1+1 ; no_of_spaces :+ 1;
al w3 x3-1 ; i:= i-1;
sl w3 1 ; until i<1;
jl. a1. ;
rs w0 x2+i31 ; save spaceword;
jl. a2. ;
\f
; eah 20.3.81 algol 8, text procedures (outspaces) page 2.12
d16: ; outspaces:
d17 = k-j0 ;
rs w3 x2+i28 ; save return;
a2: ;
al w1 x1-1 ; for spaces := spaces - 1
sh w1 -1 ; while spaces >= 0 do
jl (x2+i28) ; begin <*at loop end goto return*>
rs w1 x2+i2 ; save spaces remaining;
al w0 f32 ; w0:= char:= 'sp';
jl. w3 d10. ; call outchar (space);
rl w1 x2+i2 ;
jl. a2. ; end;
; goto return;
e. ; end block outspaces;
\f
; eah 10.3.81 algol 8, text procedures (return) page 2.13
;
b. a10, b10 ; begin block return_to_algol
w.
;
; normal_return from getproc:
;
d62: ; return_from_getnum:
d63 = k-j0
el w1 x2+i11 ; w1:= error_in_getnum;
se w1 0 ; if error then
jl. d2. ; goto error_return;
dl w1 x2+i2 ; w0w1:= number;
rs w1 (x2+i30) ; param:= integer number;
rl w3 x2+i29 ; w3:= param_type;
se w3 10 ; if paramtype <> integer then
ds w1 (x2+i30) ; param:= double number;
d60: ; return_from_gettext/getchar/getnum_default:
d61 = k-j0
am 4 ; w1:= result:= last class,value;
;
; normal_return from putproc:
;
d0: ; return_from_putproc:
d1 = k-j0 ;
rl w1 x2+i22 ; w1:= result:= charcount;
a2: ;
rl w3 (x2+12) ; w3:= pos_param:=
wa w3 x2+i22 ; startpos + charcount;
rs w3 (x2+12) ;
rs. w2 (j13.) ; last_used:= old stack top;
jl. (j6.) ; goto end_register_expression;
\f
; eah 10.5.81 algol 8, text procedures page 2.14
;
;
; error_return:
;
d2: ; error_return: (w0w1 = result)
d3 = k-j0 ;
rl. w3 (p1.) ; w3:= put_get_error
ls w3 x1 ; shift error_value;
so w3 1 ; if put_get_error.bit_error_value = 0 then
jl. a2. ; goto normal_return;
rl w3 (x2+12) ; w3:= pos_param:=
wa w3 x2+i22 ; start_pos + charcount;
rs w3 (x2+12) ;
ac w0 x1 ; w0:= abs(error_value)
ls w0 3 ; * 6;
wa w0 2 ;
wa w0 2 ;
am (0) ;
al. w0 b10. ; w0:= addr. of alarm text;
jl. w3 (j21.) ; goto general_alarm;
;
; error_return (from this segment):
;
c21: am -1 +3 ; dest_array_full: result:= -1;
c23: al w1 -3 ; layout_error: result:= -3;
jl. d2. ; goto error_return;
;
;
; alarm texts for error return
;
b10 = k-6
<:<10>put_full:> ; -1
<:<10>put exh.:> ; -2
<:<10>p.layout:> ; -3
<:<10>get exh.:> ; -4
<:<10>get full:> ; -5
<:<10>getvalue:> ; -6
e. ; end block return_to_algol
\f
; eah 1.3.81 algol 8, text procedures page 2.15
;
g3 = k-j0
c. g3-506
m. code on segment 2 too long
z.
c. 502-g3
0, r. 252 - g3>1 ; zerofill
z.
<:text procs:>
e.
\f
; eah 20.3.81 algol 8, text procedures page 3.1
;
b. c30, g3, j100, n10, r1 ; begin segment 3
f0 = f0+1 ; segment count
k = 10000
h.
j0: g1, g2 ; head word: last point, last absword
j46: f1+46, r1 ; rs.46, float long, chain for rel
n2: 1<11 o.(:2-f0:), 0 ; ref. to segment 2
n4: 1<11 o.(:4-f0:), 0 ; - - - 4
g2 = k-2-j0 ; rel of last absword
g1 = k-2-j0 ; rel of last point
w.
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.2
;
b. a40, b30 ; begin block put_num
w.
;
; put_num_continued:
;
d8: ; put_num_cont:
d9 = k-j0 ;
dl w1 x2+i2 ; w0w1:= saved layout;
sn w1 0 ; if layout specified then
jl. a1. ; begin
rs w0 x2+i9 ; spaces_in_layout:= first layout word;
al w0 0 ;
ld w1 6 ;
hs w0 x2+i3 ; b:= b-bits;
al w0 0 ; <*tot.no.of significant digits*>
ld w1 4 ; h:= h-bits;
hs w0 x2+i4 ; <*no.of digits before point*>
zl w3 x2+i10 ; w3:= procstate;
es w0 x2+i3 ;
sn w0 0 ; if h-b = 0 and
sz. w1 (b10.) ; d = s = pefe = 0
am 1<9 -1<8 ; then layouttype:= integer layout
al w3 x3 +1<8 ; else layouttype:= real layout;
hs w3 x2+i10 ; save layouttype in procstate;
al w0 0 ;
ld w1 4 ;
hs w0 x2+i5 ; d:= d-bits;
al w0 0 ; <*no.of digits after point*>
ld w1 4 ;
hs w0 x2+i6 ; pnfn:= pnfn-bits;
al w0 0 ; <*first letter and sign of number part*>
ld w1 2 ; s:= s-bits;
hs w0 x2+i7 ; <*no.of digits in exponent*>
ls w1 -20 ;
hs w1 x2+i8 ; pefe:= pefe-bits;
; <*first letter and sign of exp.part*>
; end;
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.3
a1:
dl w0 x2+i30 ; w3w0:= num_param pair;
al w3 x3-10 ; w3:= param_type:= integer/real/long;
zl w1 x2+i10 ; w1:= procstate;
zl. w3 x3+b20. ; case param_type of
c0: jl. x3 ; begin
;
; integer:
;
c1: ; 10: integer
rl w1 (0) ; w1:= integer value;
so w3 1<9 + 1<0 ; if real layout and proc = put_number then
jl. a3. ; begin
ci w1 0 ; convert integer to real;
jl. a7. ; goto real number;
a3: ; end;
el w0 2 ; w0w1:= extend num_value;
el w0 0 ;
jl. c5. ; goto whole_number;
;
; real:
;
c2: ; 11: real
dl w1 (0) ; w0w1:= real value;
a7: rl. w3 (n4.) ; real_number:
jl x3+d25 ; goto print_real (on segm.4);
;
; long:
;
c3: ; 12: long
dl w1 (0) ; w0w1:= long value;
so w3 1<9 + 1<0 ; if real layout and proc=put_number then
jl. c5. ; begin
rl. w3 (j46.) ; convert_long_to_real
jl w3 x3 +0 ;
r1 = k-j0-1 ; (chain for rel)
jl. a7. ; goto real_number;
; end
; else goto whole_number;
; end case param_type;
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.4
;
;
; explanation of integer put_num:
;
; this code is also used to output reals after they have been converted
; to one binary long representing the significant digits, and two binary
; integers giving the ten's exponent and the number of unused digit
; positions following the number part.
;
; in case of ordinary integer, the ten's exponent and the following zero
; positions are set to null.
;
; the significant digits of the - possibly long - integer are generated
; from the least significant end, and stored in the stack in the positions
; sref-1, sref-2, ... etc.
;
; when the conversion has been made, the stack variable digit_base points
; at the position just before the most significant digit.
;
; the logical position of the decimal point, d_addr, is calculated as
; d_addr:= sref + following_zeroes - d.
;
; the logical position in which printing starts is called h_addr, which
; is calculated as
; h_addr:= min (d_addr + h, digit_base + 1).
;
; the logical position where printing ends is always
; sref - 1 + following_zeroes.
;
; now, starting with the first logical position and ending with the
; last logical position, all positions before digit_base+1 are printed as
; either zero or space, depending on the layout. all positions between
; digit_base+1 and sref-1 are printed as converted digits, and all
; positions after sref-1 are printed as zero if they come before d_addr
; and as space otherwise.
;
; during the printing, sign, decimal point, and intermediate spaces are
; output according to the layout. the conversion of a possible exponent
; part is performed on segment 4.
;
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.5
;
;
; whole number:
;
c5: ; whole number:
ds w1 x2+i30 ; save number;
zl w3 x2+i10 ; w3:= procstate;
sz w3 2.11<8 ; if state = no layout then
jl. a10. ; begin
dl. w0 b0. ; layout:= unpacked << d>
ld w1 -24 ;
ds w0 x2+i6 ; b,h,d,pnfn
ds w1 x2+i9 ; s,pefe,spaces
dl w1 x2+i30 ; w0w1:= number;
a10: ; end;
al w3 2.11 ; w3:= code for sign printing
la w3 x2+i6 ; := pnfn extract 2;
zl. w3 x3+b1. ; w3:= sign_char (code);
sh w0 -1 ; if number < 0 then
al w3 f45 ; w3:= sign_char:= minus;
hs w3 x2+i11 ; save sign_char;
;
sn. w0 (b2.) ; if number <> -2**47
se w1 0 ; and
sl w0 0 ; number < 0
jl. a12. ; then
ld w1 -100 ; number:= abs number;
ss w1 x2+i30 ;
ds w1 x2+i30 ;
a12:
ld w1 -100 ;
ds w1 x2+i13 ; zeroes := exp10:= 0;
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.6
;
;
; print_number:
;
d22: ; print_number:
d23 = k-j0 ; <*jump from segm.4*>
al w0 2.11111 ;
la w0 x2+i9 ; w0:= ending_spaces:= spaceword extract 5;
wa w0 x2+i22 ; if ending_spaces <> 0 then
se w0 (x2+i22) ; max_count := ending_spaces + charcount;
rs w0 x2+i23 ;
;
al w0 -64 ;
la w0 x2+i9 ; w0:= remaining bits in spaceword:=
ns w0 3 ; bitmask for spaces between digits;
ls w0 1 ; <*i.e. normalized spaces in
rs w0 x2+i31 ; bits(0,17,layout) shift 1*>
el w1 3 ; w1:= leading_spaces:=
ac w1 x1 ; abs normalization (spaces in layout);
rl. w3 (n2.) ;
jl w3 x3+d17 ; call outspaces (leading_spaces);
;
dl w1 x2+i30 ; w0w1:= number;
sn w1 0 ;
se w0 0 ; if number = 0 then
jl. a15. ; begin
zl w3 x2+i6 ; w3:= pnfn;
so w3 2.1100 ; if pn = 11 (first letter = b) then
jl. a15. ; begin
hs w0 x2+i11 ; sign_char:= 0;
rl. w3 (n4.) ; goto all_spaces_out (segm.4);
jl x3+d29 ; end;
; end number = 0;
a15:
al w3 x2-1 ; digit_index:= sref - 1;
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.7
;
;
; long division:
;
; now the digits are extracted from the number in w0w1 to be stored
; in the stack for later printing. the scheme below shows the contents
; of the registers during each step in the long division.
;
a16: ; long division:
rs w3 x2+i33 ; save digit_index;
sn w0 0 ; while long number (w0<>0) do
jl. a17. ; begin
; digit:= number mod 10;
; a:= number:= number // 10;
;
; w0 w1 w3
; --------------------------------------
al w3 0 ; a= ( a1 , a2 ) 0
wd. w0 b11. ; (a1 // 10, -- ) a1 mod 10
rx w3 0 ; a3= (a1 mod 10, -- ) a1 // 10
wd. w1 b12. ; (a3 mod 20, a3//20 ) --
ls w1 1 ; ( -- ,2*(a3//20)) --
sl w0 10 ; if w0 >= 10 then
aa. w1 b13. ; (a3 mod 10, a3//10 ) --
rx w3 0 ; ( a // 10 ) a mod 10
; ---------------------------------------
hs w3 (x2+i33) ; stack(digit_index) := digit;
rl w3 x2+i33 ; digit_index :=
al w3 x3-1 ; digit_index - 1;
jl. a16. ; end long number;
;
; short division:
;
a17: ; short_division:
sn w1 0 ; while number <> 0 do
jl. a18. ; begin
al w0 0 ; w0:= digit:= number mod 10;
wd. w1 b11. ; w1:= number:= number // 10;
hs w0 x3 ; stack(digit_index):= digit;
al w3 x3-1 ; digit_index :- 1;
jl. a17. ; end;
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.8
;
a18:
rs w3 x2+i33 ; save digit_base (=last digit_index)
al w1 x2 ; w1:= d_addr:=
wa w1 x2+i12 ; stackref + following_zeroes
es w1 x2+i5 ; - d;
rs w1 x2+i32 ; <*the decimal point is to be placed
; just before d_addr*>
es w1 x2+i4 ; w1:= h_addr:=
sl w1 x3+1 ; min (d_addr - h, digit_base + 1);
al w1 x3+1 ; <*this will yield at least one position
rs w1 x2+i14 ; before the dec.point*>
;
zl w3 x2+i6 ; w3:= first_letter:= pnfn shift (-2);
ls w3 -2 ; goto case first_letter of
zl. w3 x3+b21. ; (d_b, f, z, d_b);
c8: jl. x3 ;
c9: ; f: <*print sign in first layout pos*>
jl. w3 c21. ; call print_front_sign;
c10: ; d_b: <*print unused digit positions as space*>
dl w1 x2+i33 ; w0:= d_addr; w1:= digit_base;
rl w3 x2+i14 ; w3:= h_addr;
sl w3 x1+1 ; if h_addr <= digit_base then
jl. c11. ; begin
sl w0 x1+2 ; w1:= leading_sp:=
jl. a20. ; if d_addr <= base + 1
rl w1 0 ; then
al w1 x1-2 ; d_addr - h_addr - 1
a20: ; else
ws w1 6 ; digit_base - h_addr + 1;
al w1 x1+1 ;
sh w1 0 ; if leading_sp > 0 then
jl. c11. ; begin
wa w3 2 ; w3:= h_addr:= h_addr + leading_sp;
rs w3 x2+i14 ;
rl. w3 (n2.) ; call outspaces_as_digits (leading_sp);
jl w3 x3+d15 ; end leading_sp > 0;
; end h_addr <= digit_base;
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.9
;
c11: ; z: <*print sign before first digit*>
jl. w3 c21. ; call print_front_sign;
a21:
rl w3 x2+i14 ; w3:= h_addr;
sl w3 (x2+i32) ; while h_addr < d_addr do
jl. a22. ; begin
al w3 x3+1 ; h_addr:= h_addr + 1;
rs w3 x2+i14 ;
zl w1 x3-1 ; digit:= stack (h_addr-1);
am (x2+i33) ;
sl w3 +2 ; if h_addr <= digit_base or
sl w3 x2+1 ; h_addr > last_digit then
al w1 0 ; digit:= 0; <*leading/ending zeroes*>
rl. w3 (n2.) ;
jl w3 x3+d13 ; call outdigit(digit) on segm.2;
jl. a21. ; end;
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.10
a22: ;
zl w3 x2+i5 ; if d <> 0 then
sn w3 0 ; begin
jl. a25. ;
al w0 f46 ; w0:= dec.point char;
rl. w3 (n2.) ;
jl w3 x3+d11 ; call outchar (dec.point);
a23: ;
rl w3 x2+i14 ; while h_addr < sref do
sl w3 x2 ; begin
jl. a24. ;
zl w1 x3 ; w1:= digit:= stack(h_addr);
sh w3 (x2+i33) ; if h_addr <= digit_base then
al w1 0 ; digit := 0;
al w3 x3+1 ; h_addr:= h_addr + 1;
rs w3 x2+i14 ;
rl. w3 (n2.) ;
jl w3 x3+d13 ; call outdigit (digit);
jl. a23. ; end h_addr < sref;
a24:
rl w1 x2+i12 ; w1:= following_zeroes;
ac w3 x2 ; w3:= d_addr - sref;
wa w3 x2+i32 ;
sl w3 1 ; if d_addr - sref > 0 then
ws w1 6 ; zeroes:= zeroes - (d_addr - sref);
rl. w3 (n2.) ;
sl w1 1 ; if zeroes > 0 then
jl w3 x3+d15 ; outspaces_as_digits (zeroes);
; end d <> 0;
a25:
zl w1 x2+i7 ; if s <> 0 or
lo w1 x2+i13 ; exp10 <> 0
rl. w3 (n4.) ; then
se w1 0 ; goto print_exp (on segm.4);
jl x3+d27 ;
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.11
;
;
; end_number:
;
d30: ; end_number:
d31 = k-j0 ; <*jump from segm.4*>
zl w0 x2+i6 ; w0:= pnfn shift (-2);
ls w0 -2 ;
se w0 1 ; if pn = f then
jl. c20. ; begin
rl w1 x2+i23 ; w1:= count:= maxcount
ws w1 x2+i22 ; - charcount
al w1 x1-2 ; - 2;
rl. w3 (n2.) ;
jl w3 x3+d17 ; outspaces (count);
; end;
c20: ; print_ending_sign:
jl. w3 c22. ; call print_sign;
rl. w3 (n2.) ;
rl w1 x2+i23 ; w1:= count:=
ws w1 x2+i22 ; maxcount - charcount;
sh w1 0 ; if count > 0 then
jl x3+d1 ; begin
jl w3 x3+d17 ; call outspaces (count);
rl. w3 (n2.) ; end;
jl x3+d1 ; goto normal_return (segm.2);
\f
; eah 20.3.81 algol 8, text procedures (putnum) page 3.12
;
; local constants:
;
h.
1, 1 ; standard integer layout << d>:
b0: 2.11<10, 0 ; b=h=1, lead_sp=1, rest = 0
b1: 0, f32, f43, 0 ; char values for sign printing:
; nothing/space/plus
w.
b2: 1<23 ; const. to test for -2**27
b10: 2.1111 0000 11 1111 ; mask for test integer/real layout
; d pnfn s pefe
b11: 10 ; constants used for long division
b12: 20 ;
-10 ;
b13: 1 ; pair (-10, 1)
h.
b20: ; table rel.addr for case num.type
c1 - c0 ; 10: integer
c2 - c0 ; 11: real
c3 - c0 ; 12: long
0 ;
b21: ; table rel.addr for switch first_letter pn:
c10- c8 ; d
c9 - c8 ; f
c11- c8 ; z
c10- c8 ; b
e. ; end block put_num;
\f
; eah 20.3.81 algol 8, text procedures (print_sign) page 3.13
;
;
; local subroutine print_sign
;
; the routine has two entries:
; c21: print_front_sign
; outputs the sign character if the layout denotes a front sign
; c22: print_sign
; outputs the sign character if this isn't null.
;
; call return
; w0 undef undef
; w1 undef undef
; w2 stackref unchanged
; w3 abs return undef
;
b.w.
c21: ; print_front_sign
rl w0 x2+i9 ; w0:= spaces_in_layout
sz w0 1<5 ; if front_sign not wanted then
jl x3 ; goto return
c22: ; print_sign:
zl w0 x2+i11 ; w0:= char := sign_char;
sn w0 0 ; if sign_char = 0 then
jl x3 ; goto return;
al w1 0 ;
hs w1 x2+i11 ; sign_char:= 0;
rs w3 x2+i28 ; save return addr;
rl. w3 (n2.) ;
jl w3 x3+d11 ; call outchar (char);
jl (x2+i28) ; goto return;
e. ; end print_sign;
\f
; eah 20.3.81 algol 8, text procedures page 3.14
;
g3 = k-j0
c. g3-506
m. code on segment 3 too long
z.
c. 502-g3
0, r. 252 - g3>1
z.
<:text proc.3:>
e.
\f
; eah 1.4.81 algol 8, text procedures page 4.1
;
b.c30, g3, j100, n10 ; begin segment 4
f0 = f0+1 ; segment count
k = 10000 ;
h.
j0: g1, g2 ; head word: last point, last absword
j30: f1+30, 0 ; rs.30: saved stackref, w3
n2: 1<11 o.(:2-f0:), 0 ; ref.to segment 2
n3: 1<11 o.(:3-f0:), 0 ; - - - 3
g2 = k-2-j0 ; rel of last absword
g1 = k-2-j0 ; rel of last point
w.
\f
; eah 1.4.81 algol 8, text procedures (put_real) page 4.2
b. a40, b40 ; begin block put_real
w.
;
; print_real:
;
d24: ; print_real:
d25 = k-j0 ; <*jump from segm.3*>
ds. w1 b20. ; save real_number;
zl w3 x2+i10 ; w3:= proc_state;
sz w3 2.11<8 ; if state = no layout then
jl. a1. ; begin
dl. w1 b0. ; layout:= unpacked << -dd.dddd>;
ds w1 x2+i6 ; b,d,h,pnfn
dl. w1 b1. ; s,pefe, spaces
ds w1 x2+i9 ;
dl. w1 b20. ; w0w1:= saved real_number;
; end;
a1:
al w3 2.11 ; w3:= code for sign printing :=
la w3 x2+i6 ; pnfn extract 2;
zl. w3 x3+b2. ; w3:= signchar(code);
sh w0 -1 ; if real_number < 0 then
al w3 f45 ; w3:= signchar:= minus;
hs w3 x2+i11 ; save signchar;
sn w0 0 ; if number = 0 then
jl. c1. ; goto real_zero;
el w1 x2+i7 ; w1:= s; <*number of digits in exponent*>
el. w1 x1+b14. ; w1:= exp_limit:= 10**s - 1;
al w3 1 ; w3:= new_zeroes:=
es w3 x2+i3 ; (if b<=12 then 1-b
sh w3 -12 ; else
al w3 -11 ; -11)
ea w3 x2+i5 ; + d
ea w3 x2+i4 ; + h;
al w0 0 ; w0:= nlim:= 0;
ds. w0 b16. ; save new_zeroes, nlim;
\f
; eah 1.4.81 algol 8, text procedures (put_real) page 4.3
al w3 x1 ; w3:= exp_limit;
wd. w1 b15. ; w0:= exp_limit mod new_zeroes
ws w0 6 ; - exp_limit
es w0 x2+i5 ; - d;
hs. w0 b16. ; nlim:= w0;
; <*nlim is stored in left half of the word
; for later use as nlim * 2**12 *>
el w0 x2+i3 ; w0:=
sl w0 13 ; if b<=12 then b
al w0 12 ; else 12;
dl. w3 b4. ; w2w3:= 1.0;
al w1 -1 ; w0w1:= first significant bit of b;
ns w0 3 ; w1 := bitno:= no.of signif.bits - 23;
as w1 2 ; w1:= bitno * 4;
a5: ; repeat
ls w0 1 ; w0(0) := next bit;
sh w0 -1 ; if bit = 1 then
fm. w3 x1+b8. ; w2w3:= w2w3 * 10**(2**(bitno+22));
al w1 x1-4 ; bitno:= bitno - 1;
sl w1 -88 ; until bitno < -22;
jl. a5. ; <*now w2w3 = number = 10**b *>
dl. w1 b20. ; w0w1:= saved real_number;
ds. w3 b20. ; save number;
el w3 7 ; w3:= (new_exp
es w3 3 ; - exp
al w3 x3-2 ; - 2)
wm. w3 b19. ; * (-l)*2**12;
; comment 0 < (log2 - l) < 0.000005;
sh. w3 (b16.) ; if w3 <= nlim * 2**12 then
rl. w3 b16. ; w3:= nlim * 2**12;
rs. w3 b16. ; nlim:= entier(max((exp-newexp+2)*l, nlim));
\f
; eah 1.4.81 algol 8, text procedures (put_real) page 4.4
al w2 -1 ; w3:= first signif.bit of n;
ns w3 5 ; w2:= bitno:= no.of signif.bits - 11;
as w2 2 ; w2:= bitno * 4;
sh w3 -1 ; if n >= 0 then
jl. a8. ; begin
sh w2 -48 ; if bitno > -11 then
al w2 -44 ; bitno:= -11;
sh w2 -8 ; if bitno > -2 then
jl. a7. ; begin
fd. w1 b6. ; w0w1:= w0w1 / 10**(2**9);
am -4 ; end;
a7: fd. w1 x2+b7. ; w0w1:= w0w1 / 10**(2**(bitno+11));
; end n >= 0;
a8:
al w2 x2-4 ; for bitno:= bitno - 1
sh w2 -48 ; while bitno > -12 do
jl. a10. ; begin
ls w3 1 ; w3(0) := next bit;
sl w3 0 ; if bit = 0 then
fm. w1 x2+b7. ; w0w1:= w0w1 * 10**(2**(bitno+11));
jl. a8. ; end while;
a10:
sl w0 0 ; if w0w1 < 0 then
jl. a11. ; begin
ld w3 -100 ; w2w3:= 0;
fs w3 2 ; w0w1:= -w0w1;
ds w3 2 ; end;
a11:
dl. w3 (j30.) ; w2:= stackref;
el. w3 b16. ; w3:= nlim:=
ea w3 x2+i5 ; nlim + d;
hs. w3 b16. ; save nlim;
\f
; eah 1.5.81 algol 8, text procedures (put_real) page 4.5
dl. w3 b20. ; w2w3:= saved number;
ds. w1 b20. ; save digits (= w0w1);
fm. w1 b5. ; w0w1:= digits * 10.0
fa. w1 b3. ; + 0.5;
fs w3 2 ; w2w3:= number - digits*10-0.5;
el. w3 b16. ; w3:= nlim;
sl w2 1 ; if number <= digits * 10 then
jl. a12. ; begin
dl. w1 b20. ; w0w1:= digits
fa. w1 b3. ; + 0.5;
al w3 x3+1 ; w3:= nlim := nlim + 1;
hs. w3 b16. ; end;
a12:
el w2 6 ; w2w3:= extend nlim;
el w2 4 ;
wd. w3 b15. ; w2:= k:= nlim mod new_zeroes;
sh w2 -1 ; if k < 0 then
wa. w2 b15. ; k:= k + new_zeroes;
el. w3 b16. ; w3:= exp10:=
ws w3 4 ; nlim - k;
rs. w3 b16. ;
el w3 3 ; w3:= exp(w0w1);
sh w3 0 ; if w0w1 <= 1 then <*exp <= 0*>
jl. c1. ; goto real_zero;
rs. w2 b15. ; new_zeroes:= w2;
ad w1 x3-47 ; w0:= last 6 digits;
c0: ; end_conversion:
dl. w3 (j30.) ; w2:= stackref;
ds w1 x2+i30 ; num_value(stack):= number;
dl. w1 b16. ; following_zeroes(stack):= new_zeroes;
ds w1 x2+i13 ; exp10(stack) := exp10(this segm);
rl. w3 (n3.) ; goto print_number
jl x3+d23 ; (on segm.3);
c1: ; real_zero:
ld w1 -100 ; w0w1:= number:= 0;
ds. w1 b16. ; new_zeroes:= exp10:= 0;
jl. c0. ; goto end_conversion;
\f
; eah 1.4.81 algol 8, test procedures (put_real) page 4.6
;
; print_exp:
;
d26: ; print_exp:
d27 = k-j0 ; <*jump from segm.3*>
rl w0 x2+i13 ; w0:= exp10(stack);
zl w1 x2+i8 ; w1:= pefe;
sn w0 0 ; if exp10 = 0 and
sz w1 2.1000 ; first_letter_exp <> z then
jl. a20. ; begin
al w1 0 ; w1:= spaces:= 0;
jl. c5. ; goto exp_as_spaces;
a20: ; end;
la. w1 b21. ; w1:= code for sign printing := pefe extract 2;
zl. w1 x1+b2. ; w1:= signchar(code);
sl w0 0 ; if exp10 < 0 then
jl. a22. ; begin
ac w0 (0) ; w0:= exp10:= - exp10;
rs w0 x2+i13 ;
al w1 f45 ; w1:= signchar:= minus;
a22: ; end;
hs w1 x2+i34 ; save signchar of exponent;
al w0 f39 ; w0:= char:= exponent mark;
rl. w3 (n2.) ; call outchar(exp.mark);
jl w3 x3+d11 ;
rl w0 x2+i13 ; w0:= exp10
zl w1 x2+i7 ; w1:= new_s:= s;
a24: ; repeat
rs w1 x2+i12 ; save new_s;
zl. w3 x1+b10. ; w3:= 10**new_s;
al w1 x1+1 ; w1:= new_s + 1;
sl w0 x3 ; until exp10 < 10**new_s;
jl. a24. ;
zl w3 x2+i8 ; w3:= first_letter_exp:=
ls w3 -2 ; pefe shift (-2);
zl. w3 x3+b22. ; goto case first_letter_exp of
a25: jl. x3 ; (d, f, z, z);
\f
; eah 1.4.81 algol 8, text procedures (put_real) page 4.7
a26: ; f: <*print sign in first layout pos*>
zl w0 x2+i34 ; w0:= saved exp.signchar;
rl. w3 (n2.) ;
se w0 0 ; if signchar <> 0 then
jl w3 x3+d11 ; outchar (signchar);
al w0 0 ; exp.signchar:= 0;
hs w0 x2+i34 ; comment continue as d;
a27: ; d: <*print unused digit positions as space*>
dl w0 x2+i13 ; w3:= new_s; w0:= exp10;
zl. w1 x3+b11. ; w1:= 10**(new_s-1); <* new_s > 0 *>
sl w0 x1 ; while exp10 < 10**(new_s-1) do
jl. a28. ; begin
al w3 x3-1 ; w3:= new_s:=
rs w3 x2+i12 ; new_s - 1;
al w0 f32 ; w0:= char:= leading_space;
rl. w3 (n2.) ;
jl w3 x3+d11 ; call outchar (leading_space);
jl. a27. ; end;
; comment continue as z;
a28: ; z: <*print sign before first digit*>
zl w0 x2+i34 ; w0:= char:= exp.sign;
a29: ; for x:= x, new_s while new_s <> 0 do
rl. w3 (n2.) ; begin
se w0 0 ; if char <> 0 then
jl w3 x3+d11 ; call outchar (char);
dl w1 x2+i13 ; w0:= new_s; w1:= exp10;
sn w0 0 ; if new_s <> 0 then
jl. a30. ; begin
es. w0 1 ; w0:= new_s := new_s - 1;
rs w0 x2+i12 ;
am (0) ;
zl. w3 +b10. ; w3:= divisor:= 10**new_s;
al w0 0 ;
wd w1 6 ; w1:= digit:= exp10 // divisor;
rs w0 x2+i13 ; w0:= exp10:= exp10 mod divisor;
al w0 x1+48 ; w0:= char:= digit + 48;
; end new_s <> 0;
jl. a29. ; end while;
; goto finito;
\f
; eah 1.4.81 algol 8, text procedures (put_real) page 4.8
;
; all_spaces_out:
;
d28: ; all_spaces_out:
d29 = k-j0 ; <*jump from segm.3*>
zl w1 x2+i4 ; w1:= spaces:=
ea w1 x2+i5 ; h + d;
zl w0 x2+i5 ;
se w0 0 ; if d <> 0 then
al w1 x1+1 ; spaces:= spaces + 1;
zl w3 x2+i6 ;
sz w3 2.11 ; if pnfn extract 2 <> 0 then
al w1 x1+1 ; spaces:= spaces + 1;
c5: ; exp_as_spaces:
zl w3 x2+i7 ;
se w3 0 ; if s <> 0 then
am x3+1 ; w1:= spaces:= spaces + s + 1;
al w1 x1 ;
zl w3 x2+i8 ;
sz w3 2.11 ; if pefe extract 2 <> 0 then
al w1 x1+1 ; spaces:= spaces + 1;
rl. w3 (n2.) ; call outspace_as_digits;
jl w3 x3+d15 ; (on segm.2)
;
; finito:
;
a30: ; finito:
rl. w3 (n3.) ; goto end_number;
jl x3+d31 ; (on segm.3)
\f
; eah 1.4.81 algol 8, text procedures (put_real) page 4.9
;
; local constants:
;
w.
; standard layout for reals: << -dd.dddd>
6<12 + 2 ; b=6, h=2
b0: 4<12 + 1 ; d=4, pnfn=1
0<12 + 0 ; s=0, pefe=0
b1: 2.11<22 ; one leading space
h.
b2: 0, f32, f43, 0 ; char values for sign printing
; floating point values:
1024, 0 ;
b3: 0, 0 ; 0.5
1024, 0 ;
b4: 0, 1 ; 1.0
; tens exponents
1280, 0 ;
b5: 0, 4 ; 10 ** (2**0) 10**1
1600, 0 ;
0, 7 ; 10 ** (2**1) 10**2
1250, 0 ;
0, 14 ; 10 ** (2**2) 10**4
1525, 3600 ;
0, 27 ; 10 ** (2**3) 10**8
1136, 3556 ;
3576, 54 ; 10 ** (2**4) 10**16
1262, 726 ;
3393, 107 ; 10 ** (2**5) 10**32
1555, 3087 ;
2640, 213 ; 10 ** (2**6) 10**64
1181, 3363 ;
3660, 426 ; 10 ** (2**7) 10**128
1363, 3957 ;
4061, 851 ; 10 ** (2**8) 10**256
1816, 3280 ;
b6: 1397, 1701 ; 10 ** (2**9) 10**512
b7 = b5+44
b8 = b5+88
b10: 1, 10, 100, 1000 ; powers of ten
b11 = b10-1 ; powers-1 of ten
b14: 0, 9, 99, 999 ; exp_limits
w.
b15: 0 ; new_zeroes
b16: 0 ; exp10 or nlim (in left half of word)
b19: -1233 ; -l = -entier (log2 * 2**12)
0 ;
b20: 0 ; save real / number / digits
b21: 2.11 ; mask for extract last two bits
h.
b22: ; table rel.addr for switch first_letter_pe:
a27 - a25 ; d
a26 - a25 ; f
a28 - a25 ; z
a28 - a25 ; b (not used)
e. ; end block put_real;
\f
; eah 1.4.81 algol 8, text procedures page 4.10
g3 = k-j0
c. g3-506
m. code on segment 2 too long
z.
c. 502-g3
0, r. 252 - g3>1 ; zerofill
z.
<:text proc.4:>
e.
\f
; eah 1.5.81 algol 8, text procedures page 5.1
;
b. b10, c30, g3, j100, n10 ; begin segment 5
f0 = f0 + 1 ; segment count
k = 10000 ;
h.
j0: g1, g2 ; head word: last point, last absword
j17: f1+17, 0 ; rs.17, index alarm
n2: 1<11 o.(:2-f0:), 0 ; ref. to segment 2
g2 = k-2-j0 ; rel of last absword
g1 = k-2-j0 ; rel of last point
w.
\f
; eah 1.5.81 algol 8, text procedures (get_text) page 5.2
;
b. a30 ; begin block get_text
w.
;
; get_text_continued:
;
d42: ; get_text:
d43 = k-j0 ;
al w0 -16 ; charpointer_text := first_char;
hs w0 x2+i34 ;
al w0 0 ;
rs w0 x2+i25 ; pack_count:= 0;
hs w0 x2+i11 ; stop_text := 0;
;
; length > 0: (copy text)
;
rl w3 x2+i13 ; w3:= length;
sh w3 0 ; if length > 0 then
jl. a10. ; begin <*copy text*>
a1: ; repeat
jl. w3 d50. ; call inchar; (w0:=class,w1:=char)
jl. w3 d52. ; call packchar(char);
rl w3 x2+i25 ; w3:= pack_count;
se w3 (x2+i13) ; until pack_count = length;
jl. a1. ;
jl. c1. ; goto text_return;
; end length > 0
; else
\f
; eah 1.5.81 algol 8, text procedures (get_text) page 5.3
;
; length = 0: (like readstring)
;
a10:
se w3 0 ; if length = 0 then
jl. a20. ; begin
a11: ; repeat <*skip leading delimiters*>
jl. w3 d50. ; call inchar (w0:=class,w1:=char)
sl w0 7 ; until class < 7;
jl. a11. ;
a12: ; repeat <*pack text, skip blind*>
sl w0 2 ; if class > 1 then
jl. w3 d52. ; call pack_char(char);
jl. w3 d50. ; call inchar; (w0:=class,w1:=char)
sh w0 6 ; until class > 6;
jl. a12. ;
jl. c1. ; goto text_return;
; end length = 0
; else
;
; length < 0: (read until terminator)
;
a20: ; begin <*length < 0*>
ac w3 x3 ; w3:= length:= abs length;
rs w3 x2+i13 ;
a21: ; repeat
jl. w3 d50. ; call inchar; (w0:=class,w1:=char)
sl w0 8 ; if class >= 8 then <*terminator*>
jl. c1. ; goto text_return;
sl w0 2 ; if class > 1 then
jl. w3 d52. ; call pack_char (char);
rl w3 x2+i25 ; w3:= pack_count;
se w3 (x2+i13) ; until pack_count = abs length;
jl. a21. ; (continue at text_return)
; end length < 0;
e. ; end block gettext;
\f
; eah 1.5.81 algol 8, text procedures (return) page 5.4
;
; text_return:
;
c1: ; text_return:
al w1 0 ; char:= null;
jl. w3 d52. ; pack_char (null);
rl w0 x2+i25 ; w0:= no_of_characters:=
es. w0 1 ; pack_count - 1;
rl. w3 (n2.) ; goto normal_return_from_getproc;
jl x3+d61 ; (on segment 2)
;
; error_return:
;
c11: am -4 +5 ; source_exhausted: result:= -4;
c12: al w1 -5 ; text_array_full: result:= -5;
al w0 -1 ; extend negative resultvalue;
rl. w3 (n2.) ;
jl x3+d3 ; goto error_return; (on segm.2)
\f
; eah 1.5.81 algol 8, text procedures (inchar) page 5.5
;
; global subroutine inchar
;
;
; the subroutine takes one character from the next character position
; in source. the character is read as a 12-bits character from a
; boolean array, or as an 8-bits character otherwise.
;
; if convtable has been specified, the character value and class are
; taken from there, otherwise the standard iso character class is
; returned.
;
; call return
; w0 undef character class
; w1 undef character value
; w2 stackref unchanged
; w3 abs return undef
;
; the packed char_class<12 + char_value is stored in x2+i24
;
b. a20 ; begin block inchar
w.
d50: ; inchar:
d51 = k-j0
zl w1 x2+i26 ; w1:= stop_mark;
se w1 0 ; if stop then
jl. c11. ; goto error_return (source exhausted);
rs w3 x2+i19 ; save return address;
rl w1 x2+i22 ; w1:= charcount:=
al w1 x1+1 ; charcount + 1;
rs w1 x2+i22 ;
rl w1 x2+i0 ; w1:= curr_inx;
;
; use of registers:
; w0 char
; w1 curr_inx
; w2 stackref
; w3 charpointer
;
\f
; eah 1.5.81 algol 8, text procedures (inchar) page 5.6
;
; 12-bits source:
;
zl w0 x2+i10 ; w0:= procstate;
so w0 1<6 ; if 12-bits source then
jl. a2. ; begin
am (x2+i20) ; w0:= char:=
zl w0 x1 ; source(curr_inx)
la. w0 b0. ; extract 8;
al w1 x1+1 ; curr_inx:= curr_inx + 1;
jl. a10. ; goto check_curr_inx;
; end;
;
; 8-bits source:
;
a2: ;
am (x2+i20) ; w0:= curr_word:=
rl w0 x1 ; source(curr_inx);
el w3 x2+i27 ; w3:= charpointer; (-16, -8, or 0)
ls w0 x3 ; w0:= char:= curr_word shift charpointer
la. w0 b0. ; extract 8;
al w3 x3+8 ; w3:= charpointer :+ 8;
sh w3 0 ; if charpointer > 0 then
jl. a12. ; begin
al w3 -16 ; charpointer:= first char in word;
al w1 x1+2 ; curr_inx :+ 2;
a10: ; check_curr_inx: (jump from 12-bits source)
rs w1 x2+i0 ; save curr_inx;
am (x2+i21) ;
sl w1 +1 ; if curr_inx > upper index (source) then
hs w3 x2+i26 ; stop:= true;
a12: ; end next word of source;
hs w3 x2+i27 ; save charpointer; <*dummy when 12-bits source*>
\f
; eah 1.5.81 algol 8, text procedures (inchar) page 5.7
;
; find character class:
;
rl w1 0 ; w1:= char;
rl w3 x2+i15 ; w3:= convtable_base;
se w3 0 ; if convtable_base = 0 (this 0 is used by index alarm)
jl. a15. ; then begin
sl w1 128 ; if char > 127 then
jl. w3 (j17.) ; goto index_alarm;
zl. w0 x1+b2. ; w0:= class:= std_table(char);
hs w0 x2+i24 ; save packed class
hs w1 x2+i24+1 ; and char;
jl (x2+i19) ; goto return;
; end no convtable
; else
a15: ; begin
ls w1 1 ; w1:= conv_index:= char*2; (this 1 is used by index alarm)
sh w1 (x2+i16) ; if conv_index > upper index
sh w1 (x2+i17) ; or <=lower index then
jl. w3 (j17.) ; goto index_alarm;
wa w1 x2+i15 ; w1:= entry:= conv_index + convtable_base;
rl w0 x1 ; w0:= conv_table(char);
rs w0 x2+i24 ; save class,char;
el w1 1 ; w1:= converted_char:= signed hw2;
zl w0 0 ; w0:= class := unsigned hw1;
jl (x2+i19) ; goto return;
; end convtable
e. ; end block inchar;
\f
; eah 1.5.81 algol 8, text procedures (pack_char) page 5.8
;
; global subroutine pack_char
;
;
; the subroutine inserts one character at the next character position
; in array text.
; characters are inserted as 12-bits characters in a boolean text array,
; or packed as three 8-bits characters in one word otherwise.
;
; call return
; w0 undef undef
; w1 char value undef
; w2 stack ref unchanged
; w3 abs return undef
;
b. a20 ; begin block pack_char
w.
d52: ; pack_char:
d53 = k-j0
zl w0 x2+i11 ; w0:= stop_text;
se w0 0 ; if stop then
jl. c12. ; goto error_return (text full);
rs w3 x2+i19 ; save return addr;
rl w3 x2+i25 ; pack_count:=
al w3 x3+1 ; pack_count + 1;
rs w3 x2+i25 ;
rl w3 x2+i1 ; w3:= txt_inx;
la. w1 b0. ; w1:= char:= char_value extract 8;
;
; 12-bits text:
;
zl w0 x2+i8 ; w0:= text array kind;
se w0 1 ; if 12-bits text then
jl. a5. ; begin
am (x2+i3) ; text(txt_inx):=
hs w1 x3 ; char;
al w1 x3+1 ; w1:= txt_inx:= txt_inx + 1;
jl. a10. ; goto check_txt_inx;
; end 12-bits text;
\f
; eah 1.5.81 algol 8, text procedures (pack_text) page 5.9
;
; 8-bits text:
;
a5: ; 8-bits text:
rs w1 x2+i12 ; save char;
am (x2+i3) ; w0:= curr_word:=
rl w0 x3 ; text(txt_inx);
el w3 x2+i34 ; w3:= char_pointer_text;
sn w3 -16 ; if char_pointer = first_char then
al w0 0 ; curr_word:= 0;
al w1 0 ;
ld w1 x3 ; w0w1:= curr_word shift charpointer;
lo w0 x2+i12 ; insert char in rightmost 8 bits of w0
ac w3 x3 ; w0:= new curr_word:=
ld w1 x3 ; w0w1 shift (-charpointer);
ac w3 x3-8 ; w3:= charpointer:= charpointer + 8;
rl w1 x2+i1 ; w1:= txt_inx;
am (x2+i3) ; text(txt_inx):=
rs w0 x1 ; new curr_word;
sh w3 0 ; if charpointer > 0 then
jl. a12. ; begin <*prepare for next word of text*>
al w3 -16 ; charpointer:= first char in word;
al w1 x1+2 ; txt_inx :+ 2;
a10: ; check_txtinx: <*jump from 12-bits text*>
rs w1 x2+i1 ; save txt_inx;
am (x2+i5) ;
sl w1 +1 ; if txt_inx > upper index (text) then
hs w3 x2+i11 ; stop_text:= true;
; end next word of text;
a12: ;
hs w3 x2+i34 ; save charpointer_text;
jl (x2+i19) ; goto return;
e. ; end block pack_text;
\f
; eah 1.5.81 algol 8, text procedures page 5.10
;
; global constants for segment 5:
;
w.
b0: 2.11111111 ; mask for extract one character;
;
; iso standard character classes:
;
h.
b2:
; 0 nul 1 soh 2 stx 3 etx 4 eot 5 enq 6 ack 7 bel
0, 7, 7, 7, 7, 7, 7, 7
; 8 bs 9 ht 10 nl 11 vt 12 ff 13 cr 14 so 15 si
7, 7, 8, 7, 8, 0, 7, 7
; 16 dle 17 dc1 18 dc2 19 dc3 20 dc4 21 nak 22 syn 23 etb
7, 7, 7, 7, 7, 7, 7, 7
; 24 can 25 em 26 sub 27 esc 28 fs 29 gs 30 rs 31 us
7, 8, 7, 7, 7, 7, 7, 7
; 32 sp 33 ! 24 " 35 36 $ 37 % 38 & 39 '
7, 7, 7, 7, 7, 7, 7, 5
; 40 ( 41 ) 42 * 43 + 44 , 45 - 46 . 47 /
7, 7, 7, 3, 7, 3, 4, 7
; 48 0 49 1 50 2 51 3 52 4 53 5 54 6 55 7
2, 2, 2, 2, 2, 2, 2, 2
; 56 8 57 9 58 : 59 ; 60 < 61 = 62 > 63 ?
2, 2, 7, 7, 7, 7, 7, 7
; 64 @ 65 A 66 B 67 C 68 D 69 E 70 F 71 G
7, 6, 6, 6, 6, 6, 6, 6
; 72 H 73 I 74 J 75 K 76 L 77 M 78 N 79 O
6, 6, 6, 6, 6, 6, 6, 6
; 80 P 81 Q 82 R 83 S 84 T 85 U 86 V 87 W
6, 6, 6, 6, 6, 6, 6, 6
; 88 X 89 Y 90 Z 91 Æ 92 Ø 93 Å 94 95 _
6, 6, 6, 6, 6, 6, 7, 7
; 96 ` 97 a 98 b 99 c 100 c 101 e 102 f 103 g
7, 6, 6, 6, 6, 6, 6, 6
;104 h 105 i 106 j 107 k 108 l 109 m 110 n 111 o
6, 6, 6, 6, 6, 6, 6, 6
;112 p 113 q 114 r 115 s 116 t 117 u 118 v 119 w
6, 6, 6, 6, 6, 6, 6, 6
;120 x 121 y 122 z 123 æ 124 ø 125 å 126 127 del
6, 6, 6, 6, 6, 6, 7, 0
w.
\f
; eah 1.5.81 algol 8, text procedures page 5.11
;
g3 = k-j0
c. g3-506
m. code on segment 2 too long
z.
c. 502-g3
0, r. 252 - g3>1 ; zerofill
z.
<:text proc.5:>
e. ; end segment 5
\f
; eah 10.5.81 algol 8, textprocedures (read_number) page 6.1
;
b. c30, g3, j100, n10 ; begin segment 6
f0 = f0+1 ; segment count
k = 10000 ;
h.
j0: g1, g2 ; head word: last point, last absword
j22: f1+22, 0 ; rs.22, underflows
j30: f1+30, 0 ; rs.30, saved stackref,w3
j37: f1+37, 0 ; rs.37, overflows
n2: 1<11 o.(:2-f0:), 0 ; ref.to segment 2
n5: 1<11 o.(:5-f0:), 0 ; ref.to segment 5
n7: 1<11 o.(:7-f0:), 0 ; ref.to segment 7
g2 = k-2-j0 ; rel of last absword
g1 = k-2-j0 ; rel of last point
w.
\f
; eah 10.5.81 algol 8, text procedures (read_number) page 6.2
;
b. a30, b20, c20, g10 ; begin block read_number
w.
;
; this code is used for reading a number and converting it to the
; required type.
;
; number limits:
; integer: abs number <= 2**23-1 = 8 388 607
; long : abs number <= 2**47-1 = 140 737 488 355 327
; real : 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.
;
; register contents at entry:
; w0 = class of first char
; w1 = value - - -
; w2 = stackref
; w3 = undef.
\f
; eah 10.5.81 algol 8, text procedures (read number) page 6.3
;
; local constants:
;
f.
b0: -1 ; -1.0 floated
b8: 10 ; 10.0 floated
w.
b1: 9 ; number of states
b2: 0, 1<10 ; round const
b3: 0, 1 ; 1 long
b4: 10 ; 10 integer
838 860 ; first word of maxlong//10
b5: -3 355 444 ; sec. - - maxlong//10
w.
\f
; eah 1.5.81 algol 8, text procedures (read_number) page 6.4
;
c0: ; digit_after_point:
rl w3 x2+i5 ; w3:= factor:=
al w3 x3+1 ; factor + 1;
rs w3 x2+i5 ;
jl. w3 d56. ; call mult_number;
al w3 4 ; state:= 4; <*following digit after point*>
jl. a2. ; goto next_char;
c1: ; digit_before_point:
jl. w3 d56. ; call mult_number;
al w3 2 ; state:= 2; <*following digit before point*>
a2: ; next_char:
rs w3 x2+i32 ; save state;
al w0 6 ;
rl w3 x2+i25 ; w3:= pack_count;
sn w3 (x2+i23) ; if pack_count = maxcount then
jl. a5. ; goto after_inchar;
; <*simulate terminator with class=6*>
al w3 x3+1 ; pack_count:= pack_count + 1;
rs w3 x2+i25 ;
a3: ; repeat
rl. w3 (n5.) ; call inchar; (on segm.5)
jl w3 x3+d51 ; <*w0:=class,w1:=char*>
sh w0 1 ; until class > 1;
jl. a3. ;
a5: ; after_inchar:
ds w1 x2+i34 ; save char, value;
;
; start read_number:
;
d54: ; first_char:
d55 = k-j0
al w1 x1-48 ; w1:= digit:=
rs w1 x2+i9 ; char_value - 48;
sl w0 7 ; if class > 6 then
al w0 6 ; class:= 6;
wm. w0 b1. ;
rl w3 0 ; w3:= class * no_of_states
wa w3 x2+i32 ; + state;
el. w3 x3+g0. ; action:= action table (class, state);
jl. x3+c0. ; goto action;
\f
; eah 10.5.81 algol 8, text procedures (read number) page 6.6
c2: ; digit_in_exp:
rl w0 x2+i12 ; w0:= exp:=
wm. w0 b4. ; exp * 10
wa w0 x2+i9 ; + digit;
rs w0 x2+i12 ;
sl w0 1000 ; if exp >= 1000 then
am 1 ; state:= 8 <*after error*>
al w3 7 ; else state:= 7; <*following exponent digit*>
jl. a2. ; goto next_char;
c3: ; ten_1:
dl. w1 b3.+2 ; w0w1:= number:= 1;
ds w1 x2+i2 ; <*continue at ten_2*>
c4: ; ten_2:
al w3 5 ; state:= 5; <*following exponent base*>
jl. a2. ; goto next_char;
c8: ; exp_sign:
rs w1 x2+i13 ; exp_sign:= digit; <*pos=-5 (43-48), neg=-3 (45-48)*>
am 6 -8 ; state:= 6; <*following exponent sign*>
; goto next_char;
c5: ; error_1: <*error in not yet finished number*>
am 8 -3 ; state:= 8; <*after error*>
; goto next_char;
c6: ; point:
al w3 3 ; state:= 3; <*following point*>
jl. a2. ; goto next_char;
c9: ; sign:
rs w1 x2+i31 ; sign:= digit; <*pos=-5 (43-48), neg=-3 (45-48)*>
al w3 1 ; state:= 1; <*following sign before number*>
jl. a2. ; goto next_char;
c10: ; error_2:
al w1 -6 ; error_in_getnum:= true;
jl. a22. ; goto terminate;
\f
; eah 10.5.81 algol 8, text procedures (read number) page 6.7
c11: ; finish_integer:
rl w3 x2+i29 ; w3:= param_type;
sn w3 11 ; if param_type = real then
jl. c13. ; goto finish_real;
zl w3 x2+i10 ; w3:= procstate;
so w3 2.10 ; if proc = get_fixed then
jl. a11. ; begin
al w3 0 ; digit := 0;
rs w3 x2+i9 ;
a10: ;
el w3 x2+i3 ; while no_of_decimals > 0 do
sh w3 0 ; begin
jl. a11. ;
al w3 x3-1 ; no_of_decimals :- 1;
hs w3 x2+i3 ;
jl. w3 d56. ; call mult_number (0);
jl. a10. ; end;
a11: ; end get_fixed;
dl w1 x2+i2 ; w0w1:= number;
a12: ; finish_no_real_type:
rl w3 x2+i29 ; w3:= param_type;
se w3 10 ; if param_type = long then
jl. c12. ; goto finish_long;
sn w0 0 ;
sh w1 -1 ; if number > max_integer then
jl. c10. ; goto error_2;
rl w3 x2+i31 ; w3:= sign;
se w3 -5 ; if sign <> pos then
ac w1 x1 ; number:= - number;
rs w1 x2+i2 ; save number;
jl. a21. ; goto terminate_ok;
c12: ; finish_long:
rl w3 x2+i31 ; w3:= sign;
sn w3 -5 ; if sign <> pos then
jl. a20. ; begin
ld w1 100 ; w0w1:= number:= - number;
ss w1 x2+i2 ; end;
jl. a20. ; goto save_number;
\f
; eah 10.5.81 algol 8, text procedures (finish real) page 6.8
c13: ; finish_real:
dl w0 x2+i13 ; w3:= exp; w0:= exp_sign;
se w0 -5 ; if sign = neg then
ac w3 x3 ; exp:= - exp;
ws w3 x2+i5 ; exp:= exp - factor;
rs w3 x2+i12 ;
; convert:
dl w1 x2+i2 ; w0w1:= number;
nd. w1 b10. ; normalize (number);
b10 = k+1
al w3 ; norm_exp:= -no_of_shifts;
sn w3 -2048 ; if norm_exp <> -2048 then
jl. a13. ; begin <*number <> 0*>
al w3 x3+48 ; norm_exp:= norm_exp + 48;
ld w1 -1 ; number:= number shift (-1)
aa. w1 b2.+2 ; + round_const;
nd w1 3 ; exponent:= normalize (number);
ea w3 3 ; norm_exp:= norm_exp + exponent;
; end number<>0;
a13: ; set_exp:
hs w3 3 ; number.exppart:= norm_exp;
rl. w3 (j37.) ; save overflows;
rs w3 x2+i5 ;
rl. w3 (j22.) ; save underflows;
rs w3 x2+i13 ;
al w3 0 ;
rs. w3 (j37.) ; overflows:=
rs. w3 (j22.) ; underflows:= 0;
rl w3 x2+i12 ; w3:= exp;
ns w3 5 ; <*obs. stackref in w2 destroyed*>
el w2 5 ; n:= number of significant bits.abs(exp);
; l:= 14;
ls w2 2 ; <*if positive exp then w2 uneven,
al w2 x2+1+14<2 ; so bool: exp<-512 not true for pos exp*>
sl w3 0 ; if exp < 0 then
jl. a14. ; begin
ls w3 1 ; l:= 23 - (n-2);
al w2 x2-5 ; number:= number / 10**(2**n);
sn w2 0 ;
am -4 ;
fd. w1 x2+g2. ; end;
\f
; eah 10.5.81 algol 8, text procedures (finish real) page 6.9
a14: ;
hs. w2 b12. ; save bool: exp<-512
a15: ;
ls w3 1 ; for j:= l step 1 until 23 do
al w2 x2-4 ; begin
sn w3 0 ;
jl. a16. ;
sh w3 0 ; if bit(j).exp = 1 then
fm. w1 x2+g1. ; number:= number * 10**(2**(23-j));
jl. a15. ; end;
a16: ;
b12 = k+1 ; bool:exp<-512
sn w1 x1 +0 ; if exp<-512 then
fd. w1 g1. ; number:= number / 10**(2**9);
dl. w3 (j30.) ; w2:= saved stackref;
zl w3 x2+i10 ; w3:= procstate;
so w3 2.10 ; if proc = get_fixed then
jl. a18. ; begin
el w3 x2+i3 ; w3:= no_of_decimals_in_layin;
a17: ;
sh w3 0 ; while no_of_decimals > 0 do
jl. a18. ; begin
al w3 x3-1 ; no_of_decimals :- 1;
fm. w1 b8. ; number:= number * 10;
jl. a17. ; end while;
; end get_fixed;
a18: ;
rl. w3 (j37.) ; w3:= ofl_ufl := new_overflows
wa. w3 (j22.) ; + new_underflows;
rx w3 x2+i5 ;
rs. w3 (j37.) ; overflows:= saved overflows;
rl w3 x2+i13 ;
rs. w3 (j22.) ; underflows:= saved underflows;
rl w3 x2+i5 ; w3:= ofl_ufl;
se w3 0 ; if ofl_ufl > 0 then
jl. c10. ; goto error_2;
; <*floating over/underflow or
; underflow has occurred*>
\f
; eah 10.5.81 algol 8, text procedures (terminate number) page 6.10
; check_type:
rl w3 x2+i29 ; w3:= param_type;
sn w3 11 ; if param_type <> real then
jl. a19. ; begin <*check that assembled real can be
; converted into a long*>
el w3 3 ; w3:= number.exp_part;
sl w3 48 ; if exponent >= 48 then
jl. c10. ; goto error2;
ld w1 -12 ; clear exponent;
ld w1 x3-34 ;
aa. w1 b3.+2 ; number := entier (number + 0.5);
ld w1 -1 ;
rl w3 x2+i29 ; w3:= param_type;
jl. a12. ; goto finish_no_real_type;
; end not real;
a19: ; exit_signed_float:
rl w3 x2+i31 ; w3:= sign;
se w3 -5 ; if sign <> pos then
fm. w1 b0. ; number:= -number;
a20: ; save_number:
ds w1 x2+i2 ; save number;
;
; terminate number:
;
a21: ; terminate_ok:
al w1 0 ; error_in_getnum:= false;
a22: ; terminate:
hs w1 x2+i11 ; save error_in_getnum;
rl w1 x2+i25 ; w1:= pack_count;
rl. w3 (n2.) ;
sl w1 (x2+i23) ; if pack_count >= maxcount then
jl x3+d63 ; goto return_from_getnum (on segm.2)
rl. w3 (n7.) ; else
jl x3+d47 ; goto finis_getnum (on segm.7);
\f
; eah 10.5.81 algol 8, text procedures (mult number) page 6.11
;
;
; local subroutine mult_number
;
; call: x2+i2 = number, x2+i9 = digit
; return: x2+i2 = number * 10 + digit
;
b. a1 ; begin block mult_number
w.
d56: ; mult_number:
d57 = k-j0
dl w1 x2+i2 ; w0w1:= number
ss. w1 b5. ; - (maxlong//10);
sh w0 -1 ; if f.w.(number) < f.w.(maxlong//10) then
jl. a1. ; goto number_ok;
; maybe_error:
sn w0 0 ; if number > (maxlong//10) then
se w1 0 ; goto error_1;
jl. c5. ;
rl w0 x2+i9 ; <*number = (maxlong//10) *>
sl w0 8 ; if digit >= 8 then
jl. c5. ; goto error_1;
a1: ; number_ok:
dl w1 x2+i2 ; w0w1:= number :=
ad w1 2 ; number
aa w1 x2+i2 ; * 10
ad w1 1 ;
aa w1 x2+i9 ; + digit;
ds w1 x2+i2 ;
jl x3 ; goto return;
e. ; end block mult_number;
\f
; eah 10.5.81 algol 8, text procedures (read number) page 6.12
;
;
; action table for number reading
;
; the states are:
; 0 before number
; 1 following sign before number
; 2 - digit before point
; 3 - point
; 4 - digit after point
; 5 - exponent base
; 6 - exponent sign
; 7 - exponent digit
; 8 in erroneous number
;
;
; action adresses 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 ; exp_sign
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 ; action table base
; action 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
; eah 10.5.81 algol 8, text procedures (read number) page 6.13
w.h. ; ensure even start address
; 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
i.e. ; end block read number;
\f
; eah 10.5.81 algol 8, text procedures page 6.14
;
g3 = k-j0
c. g3-506
m. code on segment 6 too long
z.
c. 502-g3
0, r. 252 - g3>1 ; zerofill
z.
<:text proc.6:>
e.
\f
; eah 10.5.81 algol 8, text procedures (getnum) page 7.1
b. c30, g3, j100, n10 ; begin segment 7
w.
f0 = f0+1 ; segment count
k = 10000
h.
j0: g1, g2 ; head word: last point, last absword
; rs.entries:
j18: f1+18, 0 ; rs.18, index alarm
j21: f1+21, 0 ; rs.21, general alarm
n2: 1<11 o.(:2-f0:), 0 ; ref.to segment 2
n5: 1<11 o.(:5-f0:), 0 ; - - - 5
n6: 1<11 o.(:6-f0:), 0 ; - - - 6
g2 = k-2-j0 ; rel of last absword
g1 = k-2-j0 ; rel of last point
w.
\f
; eah 10.5.81 algol 8, text procedures (getnum) page 7.2
b. a30, b1 ; begin block getnum
w.
;
; get_num_continued:
;
d44:
d45 = k-j0
; unpack_layin:
dl w0 x2+i2 ; w3w0:= saved layin;
;ks-701
se w0 0 ; if no layin then
jl. a1. ; begin
rs w0 x2+i3 ; no_of_decimals:= 0; first_letter:= 'd';
jl. a2. ; end
; else
a1: ; begin
al w1 0 ; w1:= sign_and_exppart;
ld w1 -8 ;
se w1 0 ; if sign_and_exppart <> 0 then
jl. c10. ; goto param_error (layin);
al w1 2.11 ; w1:= first_letter:=
la w1 0 ; layin.bit14-15;
se w1 2.10 ; if first_letter = z
sn w1 2.01 ; or f then
jl. c10. ; goto param_error(layin);
hs w1 x2+i4 ;
ls w0 -2 ;
al w1 2.1111 ; w1:= decimals:=
la w1 0 ; layin.bit10-13;
hs w1 x2+i3 ;
ls w0 -8 ; w0:= positions_in_layin:=
se w1 0 ; significant digits
ea. w0 1 ; + if decimals > 0 then 1 else 0;
rs w0 x2+i23 ; maxcount:= positions_in_layin;
ld w0 -5 ;
se. w3 (b1.) ; if spaces_in_layin <> 0 then
jl. c10. ; goto param_error (layin);
al w3 -1 ;
se w0 0 ; if termspace <> 0 then <*open layin*>
rs w3 x2+i23 ; maxcount:= -1;
al w0 0 ; end unpack layin;
a2: ;
rs w0 x2+i25 ; pack_count:= 0;
\f
; eah 10.5.81 algol 8, text procedures (getnum) page 7.3
;
a5: ; read_first_char:
rl. w3 (n5.) ; read_next_char:
jl w3 x3+d51 ; call inchar (w0:=class, w1:=char);
sh w0 1 ; if blind char then
jl. a5. ; goto read_next_char;
rl w3 x2+i25 ; w3:= pack_count:=
al w3 x3+1 ; pack_count + 1;
rs w3 x2+i25 ;
sh w0 5 ; if class <= 5 then
jl. a10. ; goto read_number;
zl w1 x2+i4 ; w1:= first_letter_of_layin;
se w1 0 ; if first_letter = d then
jl. a7. ; begin
se w3 (x2+i23) ; if pack_count <> maxcount then
jl. a5. ; goto read_next_char
jl. c12. ; else goto stop_num (syntax error);
; end
; else
a7: ; begin <*first letter = b*>
rl w1 x2+i23 ; w1:= maxcount;
se w1 -1 ; if maxcount = -1 <*open layin*> or
sn w1 x3 ; maxcount = packcount then
jl. c2. ; goto return_num_default;
jl. a5. ; else goto read_next_char;
; end;
a10: ; init_read_num:
ds w1 x2+i34 ; save char_class, _value;
ld w1 100 ;
ds w1 x2+i2 ; number:=
ds w1 x2+i7 ; factor:= f.w.digit:=
rs w1 x2+i12 ; exp :=
rs w1 x2+i32 ; state := 0;
al w3 -5 ;
rs w3 x2+i31 ; sign :=
rs w3 x2+i13 ; exp_sign:= pos;
dl w1 x2+i34 ; w0w1:= saved class,char;
rl. w3 (n6.) ; goto read_number
jl x3+d55 ; (on segm.6);
\f
; eah 10.5.81 algol 8, text procedures (getnum) page 7.4
;
; return_num_default:
;
c2: ; return_num_default:
rl. w3 (n2.) ; goto return_from_getnum_default
jl x3+d61 ; (on segm.2)
;
; error_return:
;
c10: ; param_error (layin):
al w1 5 ; errortype:= layin;
jl. d20. ; goto param_error;
c12: ; stop_num (syntax error in number):
al w1 -6 ; error_in_getnum:= true;
hs w1 x2+i11 ;
rl. w3 (n2.) ; goto return_from_getnum;
jl x3+d63 ; (on segm.2)
;
; local constants:
;
b1: 1<18 ; mask for check spaces in layin
e. ; end block getnum;
\f
; eah 10.5.81 algol 8, text procedures (finis getnum) page 7.5
b. a10 ; begin block finis_getnum
w.
;
; finis_getnum: read following delimiters if "closed" layin
;
d46: ; finis_getnum:
d47 = k-j0
a1: ; repeat
rl. w3 (n5.) ; call inchar; (on segm.5)
jl w3 x3+d51 ; <*w0:=class,w1:=char*>
sh w0 1 ; if class > blind then
jl. a1. ; begin
al w3 -6 ;
sh w0 5 ; if class <= 5 then
hs w3 x2+i11 ; error_in_getnum:= true;
rl w1 x2+i25 ; w1:= pack_count:=
al w1 x1+1 ; pack_count + 1;
rs w1 x2+i25 ; end not blind;
se w1 (x2+i23) ; until packcount = maxcount;
jl. a1. ;
rl. w3 (n2.) ; goto return_from_getnum;
jl x3+d63 ; (on segm.2)
e. ; end block finis_getnum;
\f
; eah 1.5.81 algol 8, text procedures (alarm) page 7.6
b. a20, b20 ; begin block alarm messages
w.
d20: ; param_error:
d21 = k-j0
zl. w1 x1+b0. ; case error_type of
a0: jl. x1 ; begin
a1: ; 0: param <1>
al w1 1 ;
jl. a5. ;
a2: ; 1: charpos:
al. w0 b2. ; w0:= addr of alarm text <:charpos:>
rl w1 (x2+12) ; w1:= value of pos-param
jl. w3 (j21.) ; goto general alarm;
a3: ; 2: param_n:
rl w1 x2+i14 ; w1:= paramno:= (last_formal_addr
ws w1 4 ; - stackref
al w1 x1-4 ; - 4 )
ls w1 -2 ; // 4;
a5:
al. w0 b3. ; w0:= addr of alarmtext <:param:>
jl. w3 (j21.) ; goto general alarm;
a10: ; 3: text_index:
al w1 1 ; goto index(1);
jl. w3 (j18.) ;
a11: ; 4: illegal string
am -6 ; w0:= addr of alarmtext <:string:>
a12: ; 5: layin:
al. w0 b5. ; w0:= addr of alarmtext <:layin:>
al w1 0 ;
jl. w3 (j21.) ; goto general alarm;
\f
; eah 10.5.81 algol 8, text procedures (alarm) page 7.7
;
; local alarm constants
;
h.
b0: ; table rel.addr for case error_type
a1 - a0 ; 0: param_1
a2 - a0 ; 1: charpos
a3 - a0 ; 2: param_n
a10- a0 ; 3: text_index
a11- a0 ; 4: illegal string
a12- a0 ; 5: illegal layin
w.
b2: <:<10>charpos :> ; charpos alarmtext
b3: <:<10>param :> ; param error -
b4: <:<10>string :> ; illegal string -
b5: <:<10>layin :> ; layin -
e. ; end block alarm messages;
\f
; eah 1.5.81 algol 8, text procedures page 7.8
g3 = k-j0
c. g3-506
m. code on segment 0 too long
z.
c. 502-g3
0, r. 252 - g3>1
z.
<:text procs:>
e.
\f
; eah 1.4.81 algol 8, text procedures page t.0
i.e. ; end slang segment
\f
; eah 1.3.81 algol 8, text procedures page t.1
;
;
; tails to be inserted in catalog:
;
g0: ; first tail:
; put_number:
f0+1 ; no of segments (incl external list)
0,0,0,0 ;
1<23 + e0<12 + e1 ; put_number:
3<18 + 40<12 + 3<6 + 41 ; int.proc(general,int.addr,undef)
0 ;
4<12 + f2 ; reladdr on first segment for start of ext.list
f0<12 + f3 ; no of segments + no of own hw
; put_fixed:
1<23 + 4
0,0,0,0
1<23 + e2<12 +e3 ; put_fixed:
3<18 + 40<12 + 3<6 + 41 ; int.proc(general,int.addr,undef)
0
4<12 + f2
f0<12 + f3
; put_char:
1<23 + 4
0,0,0,0
1<23 + e4<12 + e5 ; put_char:
3<18 + 40<12 + 3<6 + 41 ; int.proc(general,int.addr,undef)
0
4<12 + f2
f0<12 + f3
; put_text:
1<23 + 4
0,0,0,0
1<23 + e6<12 + e7 ; put_text:
3<18 + 40<12 + 3<6 + 41 ; int.proc(general,int.addr,undef)
0
4<12 + f2
f0<12 + f3
\f
; eah 1.5.81 algol 8, text procedures page t.2
; get_number:
1<23 + 4
0,0,0,0
1<23 + e8<12 + e9 ; get_number:
3<18 + 40<12 + 3<6 + 41 ; int.proc(general, int.addr,undef)
0
4<12 + f2
f0<12 + f3
; get_fixed:
1<23 + 4
0,0,0,0
1<23 + e10<12 + e11 ; get_fixed:
3<18 + 40<12 + 3<6 + 41 ; int.proc(general,int.addr,undef)
0
4<12 + f2
f0<12 + f3
; get_char:
1<23 + 4
0,0,0,0
1<23 + e12<12 + e13 ; get_char:
3<18 + 40<12 + 3<6 + 41 ; int.proc(general,int.addr,undef)
0
4<12 + f2
f0<12 + f3
; get_text:
1<23 + 4
0,0,0,0
1<23 + e14<12 + e15 ; get_text:
5<18 + 40<12 + 3<6 + 41 ; long.proc(general,int.addr,undef)
0
4<12 + f2
f0<12 + f3
g1:
; get_put_error:
1<23 + 4
0,0,0,0
1 ; put_get_error: addr hw 1
9<18 ; integer variable
0
4<12 + f2
f0<12 + f3
d.
p.<:insertproc:>
▶EOF◀