|
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: 67584 (0x10800)
Types: TextFile
Names: »algpas123tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »algpas123tx «
\f
; jz 1979.06.22 algol 8, pass 12, page ...1...
s. c9, d29, f35, g10, h24, j32
w.
k = e0
j0: g1 ; number of bytes in pass 12
h. d0 ; entry address relative to first word
12 < 1 ; pass mode bits
; variables, supposed to be input-parameters: std value:
; f0 == mask for connection wanted h0+h1+h2
; f24 == first line (lineno-interval) 0
; f25 == last line + 1 (lineno-interval) maximum
; f29 == first line (ident-names interv) 0
; f30 == last line + 1 (ident-names interv) maximum
; j19 == name of sortarea wrk......
; j27 == size of sortarea h18
; slang-help-variables:
h0 = 4 ; use
h1 = 2 ; assign
h2 = 1 ; declare
h3 = 135 ; error
h4 = 136 ; new line
h5 = 133 ; last normal terminator
h6 = 139 ; space
h7 = 134 ; end pass1
h8 = 2 ; addrlength (in bytes)
h9 = 116 ; last of lettertable
h11 = 512 ; bufferlength (in bytes)
h12 = h11-2; displacement for chain corresponding to element
h13 = 4 ; length (in bytes) for element
h14 = 60 ; maxpos
h15 = 6 ; printpos
h16 = 8 ; std ident lgth
h17 = 3 ; packing factor for identno.
h18 = 100; standard sortsize
h19 = -1 ; false segmno
h20 = 144; identifier (internal byte value)
h21 = 140; context
h22 = 141; exit
h23 = 142; continue
h24 = 145; stop special bytes
\f
; rc 1977.11.09 algol 6, pass 12, page ...2...
; variables: meaning, local to program scan routine
w.
f0 = e71 ; mask for connection wanted
f1: 0 ; stored identno
f2: 0 ; stored lineno
f3: 0 ; identno
f4: 0 ; lineno
f5: 0 ; old identno
f6: 0 ; old lineno
f7: 0 ; old state
f9: c7 ; state
f10: 0 ; paran no
f11: 0 ; class
f12: 14 ; mask14
f13: 0 ; first char, char
f14: 0 ; current word addr
f15: 0 ; main top addr
f16: 0 ; aux top addr
f17: 0 ; current aux addr , main link
f18: 0 ; search word
f19: 0 ; aux main word addr
f20: 127 < 14 ; mask for word filled
f21: 1 < 23 ; end mark
f22: 1 < 22 - 1 + 1 < 22 ; top addr for wanted identifier
f23: 0 ; line interval ok ( 0 => false, 2 => true)
f24= e72 ; first line
f25= e73 ; last line + 1
1<22-1+1<22-1 ; f26-2: maximum-1
f26: 1 < 22 - 1 + 1 < 22 ; maximum number, used to mask off signbit
f28: 0 ; requestmark (0 => not requested, 1 => requested)
f29= e74 ; first request line;
f30= e75; last request line + 1;
f31: 0 ; available segments of pass 0 work area;
b. a18, i41
w.
d1: jl. w3 i38. ; program scan: w2 := inbyte;
sh w2 58 ; if inbyte < 59 then goto first char;
jl. d3. ;
; central logic:
hs. w2 f13.+1 ; save (inbyte);
i1: bz. w2 x2+j13. ; class := class(inbyte);
i0: sn w2 0 ; examine class:
jl. i4. ; if class = 0 then goto special bytes;
rs. w2 f11. ;
rl. w1 x2+a0. ; control word := main control table(class);
rl. w3 f9. ; last state := state;
ls w1 x3 ; delimiter control word number :=
la. w1 f12. ; (control word shift state) and mask14;
sn w1 0 ; if d c w n = 0 then
jl. i4. ; goto reset, special bytes;
wa w2 2 ; control word :=
rl. w1 x2+a0. ; main control(class + d c w n);
bl w0 2 ; state := controlword(part1);
rs. w0 f9. ;
bz w1 3 ;
a0: jl. x1+a0. ; goto switchpart(controlword);
\f
; rc 1977.11.09 algol 6, pass 12, page ...2a...
h. ; special bytes:
f32: 3,15,14,20, 5,24,20, h24; context
f33: 5,24, 9,20, h24; exit
f34: 3,15,14,20, 9,14,21, 5,h24; continue
w.
f35: 0 ; special
i35: am f32-f33 ; context: start := start context else
i36: am f33-f34 ; exit : start := start exit else
i37: al. w3 f34. ; continue:start := start continue;
rs. w3 f35. ; special := start;
al w0 x2 ;
jl. w3 e3. ; outbyte(inbyte);
hs. w2 i40. ; special in := true;
hs. w2 i41. ; special out := true;
jl. d1. ; goto program scan;
i40 = k + 1; special in; inbyte:
i38: sn w3 x3+0 ; if -,special in then
jl. e2. ; goto pass0-inbyte;
rl. w2 f35. ; special input:
al w2 x2+1 ; special :=
rs. w2 f35. ; special + 1;
bz w2 x2-1 ; byte := special bytes(special - 1);
se w2 h24 ; if byte <> end special then
jl x3 ; return;
al w2 0 ; end special:
hs. w2 i40. ; special in := false;
hs. w2 i41. ; special out := false;
jl. e2. ; goto pass0-inbyte;
i41 = k +1; special out; outbyte:
i39: sn w3 x3 ; if -,special out then
jl. e3. ; goto pass0-outbyte;
jl x3 ; return;
\f
; rc 1977.11.09 algol 6, pass 12, page ...3...
i4: bz. w2 f13.+1 ; reset, special bytes: restore (inbyte);
d4: sh w2 h5 ; special bytes:
jl. i26. ; if inbyte <= last normal terminator then
sn w2 h21 ; if inbyte = context then
jl. i35. ; goto context;
sn w2 h22 ; if inbyte = exit then
jl. i36. ; goto exit;
sn w2 h23 ; if inbyte = continue then
jl. i37. ; goto continue;
sn w2 h20 ; goto input1;
jl. d1. ; if inbyte = identifier then goto program scan;
sl w2 h6 ;
jl. i26. ; if inbyte >= space then goto input1;
sn w2 h4 ;
jl. i27. ; if inbyte = new line then goto newline;
sn w2 h3 ;
jl. i25. ; if inbyte = error then goto input2;
sn w2 h7 ;
jl. d10. ; if inbyte = end pass then goto ident sorting;
jl. w1 i32. ; out and inbyte;
jl. w1 i32. ; out and inbyte;
jl. w1 i32. ; out and inbyte;
i25: jl. w1 i32. ; input2: out and inbyte;
i26: al w0 x2 ; input1:
jl. w3 i39. ; outbyte;
jl. d1. ; goto program scan;
i32: al w0 x2 ; procedure out and inbyte;
jl. w3 i39. ; outbyte;
jl. w3 i38. ; inbyte;
jl x1 ; return;
i27: al w0 x2 ; new line:
jl. w3 e3. ; outbyte(new line);
jl. w3 e1. ; newline; comment in pass0;
d2: rl. w2 e6. ;
al w0 2 ; line wanted := true;
al w1 1 ; request := true;
sl. w2 (f24.) ; if current line < first line
sl. w2 (f25.) ; or current line > last line then
al w0 0 ; line wanted := false;
i28: sl. w2 (f29.) ; if current line < first request line
sl. w2 (f30.) ; or current line > last request line then
al w1 0 ; request := false;
i30: rs. w0 f23. ; line interval wanted := line wanted;
rs. w1 f28. ; requestmark := request;
lo w1 0 ; identifier wanted :=
hs. w1 i9. ; line wanted or request;
se. w2 (f30.) ; if current line = last request line + 1 then
jl. i31. ;
rl. w1 f15. ; top addr for wanted identifier :=
rs. w1 f22. ; main top addr;
; comment: this ensures, that as soon as all
; identifiers in the interval (first-,
; last request line) have been found
; and included in main/aux tables,
; no more identifiers are stored. this
; reduces the needs for core area if
; a xref of only a few identifiers is
; wanted;
i31: jl. d1. ; goto program scan;
\f
; rc 3.2.1971 algol 6, pass 12, page 4
; first char:
d3: hs. w2 f13. ; first char := inbyte;
al w0 0 ; main(top-1) := main(top) := 0;
; i9 == identifier wanted, 0 => false;
i9 = k + 1
sn w0 0 ; if identifier not wanted then
jl. i26. ; goto input1;
al w1 0 ;
ds. w1 (f15.) ;
i10: jl. w1 i32. ; next char: out and inbyte;
sl w2 69 ; w2 := inbyte;
jl. i11. ; if inbyte < 69 then begin
hs. w2 f13.+1 ; char := inbyte;
jl. w3 d5. ; packchar;
jl. i10. ; goto next char end;
i11: sn w2 h3 ; if inbyte <> error then
jl. i12. ; begin
jl. w3 e11. ; repeat inputbyte;
al w2 h20 ; inbyte := identifier;
hs. w2 f13.+1 ; save (inbyte);
jl. w3 d6. ; search;
am j11 ; class := if identifier not wanted
al w2 j10 ; then 0 else identifier class;
jl. i0. ; goto examine class; end;
i12: jl. w1 i32. ; out and inbyte; comment-error and identification;
jl. i10. ; goto next char;
; procedure packchar shifts the current word 7 bits, adds
; char and restores the result in the main table if there
; is space in a main word, otherwise in an aux word.
d5: rl. w1 (f14.) ; procedure packchar;
sz. w1 (f20.) ; if current word not filled then
jl. i13. ; begin
ls w1 7 ; current word := current word * 128
ba. w1 f13.+1 ; + char;
rs. w1 (f14.) ; return;
jl x3 ; end
i13: rl. w2 f17. ; else begin
al w2 x2-2 ; current aux addr := current aux addr - 2;
sh. w2 (f15.) ; if current aux addr <= main top addr then
jl. d12. ; goto stack overflow;
rs. w2 f17. ; current word addr := current aux addr;
rs. w2 f14. ; current aux word + 2 := current word;
bz. w0 f13.+1 ; current word := char;
ds w1 x2+2 ; return;
bz. w2 f13.+1 ;
jl x3 ; end;
\f
; rc 3.2.1971 algol 6, pass 12, page 5
; procedure search ensures that the current word is filled up
; with nulls. bit0 of the current word is set to 1. the search
; then proceeds through the main table for linking and then
; through either the main or aux table looking for an identifier
; equal to the last packed identifier. it is then examined
; whether the identifier is to be selected or not. if it is
; wanted, it is included in the main and/or the aux table.
d6: rl. w1 f14. ; procedure search;
rl w2 x1 ;
sz. w2 (f20.) ; repeat: if current word not filled then
jl. i15. ; begin current word := current word * 128;
ls w2 7 ; goto repeat;
sz. w2 (f20.) ;
jl. i15. ;
ls w2 7 ; end;
i15: lo. w2 f21. ; current word := current word or 1 (bit0);
rs w2 x1 ;
rs. w2 f18. ; search word := current word;
bz. w2 f13. ; w0 := letter table (first char);
ls w2 1 ;
al. w2 x2+g0. ;
rl w0 x2-2 ;
se. w1 (f15.) ; if current word addr <> main top addr then
jl. i18. ; goto aux search;
i16: sh w0 1 ; check link: if link =< 1 then
jl. i22. ; goto not found
rl w2 0 ; else if main(link) = search word then
dl w1 x2 ; goto found;
se. w1 (f18.) ; else goto check link;
jl. i16. ;
jl. i23. ;
\f
; rc 3.2.1971 algol 6, pass 12, page 6
i17: rl. w0 f17. ; load link: w0 := main link;
rl. w2 f19. ; w2 := aux main word addr;
i18: sh w0 1 ; aux search:
jl. i21. ; if link > 1 then
rl w2 0 ; begin
dl w1 x2 ;
sz. w1 (f21.) ; if bit0 (main(link)) = 1 then
jl. i18. ; goto aux search;
rs. w0 f17. ; main link := link;
rs. w2 f19. ; aux main word addr := last link;
rl. w2 f16. ;
i19: rl w0 x1 ; for w1 := main(link) step -1,
se w0 (x2) ; and w2 := aux top addr step -1
jl. i17. ; while aux(w1) = aux(w2) do
sz. w0 (f21.) ; if bit0 (aux(w1)) = 1 then
jl. i20. ; begin
al w1 x1-2 ; current aux addr := aux top addr;
al w2 x2-2 ; goto found;
jl. i19. ; end;
i20: rl. w2 f19. ; goto load link; comment compare new strings;
rl. w1 f16. ;
rs. w1 f17. ;
jl. i23. ; end
i21: rl. w1 f16. ; else
rl. w0 f15. ; if identifier not wanted then
sl. w0 (f22.) ; current aux addr := aux top addr
jl. i33. ; else
rs. w1 (f15.) ; begin
rl. w1 f14. ; main(top) := aux top addr;
al w1 x1-2 ; aux top addr := current aux addr :=
sh. w1 (f15.) ; current word addr - 2;
jl. d12. ; if aux top addr <= main top addr
rs. w1 f16. ; then goto stack overflow;
i33: rs. w1 f17. ; end;
i22: al w1 x2 ; not found: save (last link);
rl. w2 f15. ; w2 := main top addr;
sl. w2 (f22.) ; if identifier not wanted then
jl. i23. ; goto found;
lo w2 x1-2 ; last iden(link) := main top addr;
rs w2 x1-2 ; comment: last identifier may be
rl. w2 f15. ; requestmarked;
al w1 x2+4 ; w1 := main top addr + 4;
sl. w1 (f16.) ; if w1 >= aux top addr then
jl. d12. ; goto stack overflow;
rs. w1 f15. ; main top addr := w1;
i23: ; found:
rl. w1 f15. ; identno:
i24: rs. w1 f14. ; current word addr := main top addr;
sl. w2 (f22.) ; if identifier not wanted then
jl x3 ; not wanted return;
rl w0 x2-2 ; if identifier requested then
lo. w0 f28. ; request mark;
rs w0 x2-2 ;
am 2047 ;
al. w0 g3. ; identifierno :=
ws w2 0 ; (identifier addr - main bottom addr) // 4;
ls w2 -2 ;
ls w2 h17 ; identno := identifierno shift h17;
rs. w2 f3. ;
rl. w2 e6. ; lineno := current lineno;
rs. w2 f4. ; if -, line interval wanted then
am. (f23.) ; not wanted return else
jl x3 ; wanted return;
\f
; rc 3.2.1971 algol 6, pass 12, page 7
; output stored identifier (if any) as:
a1: am w0 h0-h1 ; connection := use;
a2: am w0 h1-h2 ; connection := assign;
a3: al w0 h2 ; connection := declare;
a4: wa. w0 f1. ; w0 := stored identno + connection;
rl. w1 f2. ; w1 := stored lineno;
sz. w0 (f0.) ; if connection wanted
sh w0 h0+h1+h2 ; and stored identno <> 0 then
jl. a5. ;
jl. w3 d14. ; put 2 words;
; store new identifier (if any):
a5: dl. w1 f4. ; stored lineno := lineno;
rl. w3 f11. ; stored identno :=
se w3 j10 ; if class <> identifier class then
i5: al w0 0 ;
ds. w1 f2. ; 0 else identno;
jl. i4. ; goto reset, special bytes;
; first point:
a11: am -1 ; paran no := 0;
; first parantesis: store old identifier:
a6: al w1 1 ; paran no := 1;
rs. w1 f10. ;
dl. w1 f2. ; old identno := stored identno;
ds. w1 f6. ; old lineno := stored lineno;
rs. w3 f7. ; old state := last state;
jl. i5. ; goto store new identifier;
; comment but there is no new ident... ;
; further parantesis:
a7: rl. w1 f10. ; paran no := paran no + 1;
al w1 x1+1 ;
rs. w1 f10. ;
jl. i4. ; goto reset, special bytes;
; right parantesis:
a8: rl. w1 f10. ; paran no := paran no - 1;
al w1 x1-1 ;
rs. w1 f10. ;
sh w1 -1 ; if paran no < 0 then
jl. a9. ; goto reset all;
se w1 0 ; if paran no > 0 then
jl. a1. ; goto output as use;
a14: dl. w1 f6. ; identno := old identno;
ds. w1 f4. ; lineno := old lineno;
al w1 j10 ; class := identifier class;
rs. w1 f11. ;
rl. w1 f7. ; state := old state;
rs. w1 f9. ;
jl. a1. ; goto output as use;
\f
; jz.fgs 1985.10.28 algol 6, pass 12, page ...8...
; reset all:
a9: al w2 c7 ; state := 7;
rs. w2 f9. ;
; reset:
a10: al w1 0 ; paran no := 0;
rs. w1 f10. ;
jl. a5. ; goto store new identifier;
; reset parenthesis error:
a16: al w1 0 ; paren no:=0;
rs. w1 f10. ;
; first delimiter after field:
a13: jl. w3 e11. ; repeat inputbyte;
al w3 h20 ; inbyte := dummy byte;
rs. w3 f13.+1 ;
jl. a14. ; goto take old identifier;
; first parantesis after field:
a15: al w3 c4 ; oldstate := after identifier;
rs. w3 f7. ;
al w1 1 ; paran no := 1;
rs. w1 f10. ;
jl. a1. ; goto output (use);
d23: al. w3 a17. ; end pass 12: writetext(out,<:
jl. w1 e13. ; no. of identifiers=:>);
<:<10>no. of identifiers=<0>:>
a17: rl. w0 f0. ;
jl. w3 e14. ; write(out,<<d>,maxidentno);
32<12+1 ;
al w0 12 ;
jl. w3 e12. ; printchar (ff);
jl. a18. ; goto set return;
d25: hs. w0 d29. ; backing store fault:
am e69-e5 ; save result
d12: am e5-e7 ; stack overflow:
d22:
a18: al. w2 e7. ; set return:
c. e77<3 ; if system 3 then begin
al. w1 g0. ; w1 := tail address;
al. w3 j19. ; w3 := sort name address;
jd 1<11+42 ; lookup entry(sort area);
al w0 0 ; tail(1) := 0;
rs. w0 g0. ;
jd 1<11+44 ; change entry (sort area);
al w0 e86 ; 1 slice left for erroroutput
al w1 0 ; no zone
rs. w2 g0. ; save w2
al. w2 e79. ; work area name
am -1000 ;
jl. w3 e78.+11000 ; connect output
rl. w2 g0. ; restore w2
al. w1 g0. ; lookup area
al. w3 e79. ;
jd 1<11+42 ; lookup(work)
rl. w0 g0. ;
rs. w0 e9.-2 ; restore(available segm);
z. ; end system 3;
\f
;rc 1977.11.09 algol 6, pass 12, page ...8a...
se. w2 e5. ; if not stack overflow
am j32; =j24-e10; then w1:=answer address
al. w1 e10. ; else w1:= addr(<:stack:>);
d28 = k + 1 ; selfmade sortarea: 0<10 == false , 1<10 == true
al w0 0 ; w0 := pass 12 mode bits;
al. w3 j19. ; w3 := sortname address;
sz w0 1<10 ; if selfmade sortarea then
jd 1<11+48 ; remove entry;
d29=k+1 ; saved transport result:
al w0 0 ; w0:=result;
jl x2 ; goto next pass or alarm; comment in pass 0;
; ************* stepping stone ******************
c9: jl. e12. ; goto pass0-writechar;
; letter table:
w.
g0 = k
0 , r. 58 ; lettertable, used for linking to main table
g8 = k-1 ; connection identification:
h. 68 ; d
65 ; a
85 ; u
g7 = k-1 ; output table:
h.
97, 98, 99, 100, 101, 102, 103 ; a b c d e f g
104, 105, 106, 107, 108, 109, 110 ; h i j k l m n
111, 112, 113, 114, 115, 116, 117 ; o p q r s t u
118, 119, 120, 121, 122, 123, 124, 125 ; v w x y z æ ø å
65, 66, 67, 68, 69, 70, 71 ; a b c d e f g
72, 73, 74, 75, 76, 77, 78 ; h i j k l m n
79, 80, 81, 82, 83, 84, 85 ; o p q r s t u
86, 87, 88, 89, 90, 91, 92, 93 ; v w x y z æ ø å
48, 49, 50, 51, 52, 53, 54 ; 0 1 2 3 4 5 6
55, 56, 57 ; 7 8 9
\f
; rc 12.11.1975 algol 6, pass 12, page 9
; shortnames for states : meaning : preceding symbol (class numbers)
c1 = -20 ; state 1 == expecting decl : 1
c2 = -17 ; state 2 == in decl : 2
c3 = -14 ; state 3 == in value : 3
c4 = -11 ; state 4 == after identifier : 7, 10
c5 = -8 ; state 5 == after fieldpoint : 8, 10
c6 = -5 ; state 6 == in parantesislist : 6, 7, 10
c7 = -2 ; state 7 == in neutral : 4, 5, 9
; state 8 == not used
; main control table
; states new state switchpart
w. k = k - a0
; begin end <;> :
w. j1: 8.0123 4520 , h. c1 , a3 -a0 ; output(decl)
c1 , i4 -a0 ; reset, special bytes
c1 , a1 -a0 ; output(use)
c1 , a13-a0 ; first delimiter after field
c1 , a16-a0 ; reset parenthesis error
; integer long real boolean zone field array procedure label switch string:
w. j2: 8.1000 0000 , h. c2 , i4 -a0 ; reset, special bytes
; value:
w. j3: 8.1000 0000 , h. c3 , i4 -a0 ; reset, special bytes
; <:>:
w. j4: 8.0001 0000 , h. c7 , a3 -a0 ; output(decl)
; <:=>:
w. j5: 8.0102 3400 , h. c7 , a3 -a0 ; output(decl) (i.e. switch)
c7 , a2 -a0 ; output(ass)
c7 , a13-a0 ; first delimiter after field
c7 , a16-a0 ; reset parenthesis error
; <(> :
w. j6: 8.0101 2300 , h. c6 , a6 -a0 ; first parantesis
c6 , a15-a0 ; first parantesis after field
c6 , a7 -a0 ; further parantesis
; <)> :
w. j7: 8.0000 0100 , h. c6 , a8 -a0 ; right parantesis
; <.> :
w. j8: 8.0001 0000 , h. c5 , a11-a0 ; first field point;
; other delimiters:
w. j9: 8.1001 2000 , h. c7 , a1 -a0 ; output(use)
c7 , a13-a0 ; first delimiter after field
; identifiers:
w. j10: 8.1203 4510 , h. c4 , a5 -a0 ; store new identifier
c2 , a3 -a0 ; output(decl)
c4 , a1 -a0 ; output(use)
c5 , a1 -a0 ; output(use)
c6 , a1 -a0 ; output(use)
j11 = - j10
\f
; jz 1979.06.22 algol 8, pass 12, page ...10...
w. k = k + a0 h.
; class table
j13 = k - 59
; class ; input
0, r.10 ; numbers 0-9
0, j8, j9, j9, j4 ; ' . + - :
0, j1, 0, 0, j9 ; goto begin external for if
0, j2, r.11 ; own integer ... label
j3, j1, j1, j9, j6 ; value ; end else (
0, j9, j9, j9, j9 ; -, step until while ,
j5, j9, 0, j9, 0 ; := then trouble do abs
j9, j9, 0,r.3, j9 ; case of round ... extend fatcomma
j7,j2,0, 0, j9, r.18 ; ) disable true false * / ** ... add
0,r.6, j2, 0,0,0 ; endpass ... context ... wordterminator
; bufferdescriptors:
w.
j14: 2 + 0 ; inbuffer 1 : displacement, first byte (and input)
g5 ; bufferbase (relative to d13)
0 ; absolute address of inputword(s)
j15: 2 + 0 ; inbuffer 2 : displacement, first byte (and input)
g6 ; bufferbase (relative to d13)
0 ; absolute address of inputword(s)
j16: 2 + 1 ; outbuffer : displacement, first byte (and output)
g4 ; bufferbase (relative to d13)
0 ; absolute address of next outputword(s)
; miscelaneous i/o - variables:
j17: 0 ; returnaddress (used at close)
j18: h19 , r.3 ; queue of free segmentno.es
j19= e76 ; name and name table addr
j27: h18 ; tail (predefined standard sortsize)
j20: 0 ; message: operation code
j21: 0 ; first core
j22: 0 ; last core
j23: 0 ; segm.no
j24: 0,0,0,0,0,0,0,0; answer
j32=j24-e10 ;used in stack overflow and end pass
0 ; saved w2 (used at transfer)
j25: 0 ; saved w3 (used at transfer)
j26: 0 ; relative address of queue (rel. to j18)
j28: 0 ; returnaddr (for put and get)
0 ; saved w0 (for put and get)
j29: 0 ; saved w1 (for put and get)
i.
e.
; end of program scan routine ;
\f
; rc 3.2.1971 algol 6, pass 12, page 11
; entries to i/o :
b. i19
w.
; variables, used with the earlier content and meaning:
; f26 == maximum
d13: al. w2 j16. ; put (textpart): put 1 word:
rs. w3 j28. ; save (returnaddr);
rs. w1 j29. ; save (textpart);
al w1 2 ; length := 2 bytes;
jl. w3 i2. ; buffering;
rl. w1 j29. ;
rs w1 (x2+4) ; store (textpart);
c. (:e15 > 12 a. 1:) - 1 ; if special testoutput pass12 then
jl. i13. ; goto testoutput 1 word;
z.
c. -(:e15 > 12 a. 1:) ;
jl. (j28.) ; else return;
z.
d14: al. w2 j16. ; put (element): put 2 words:
rs. w3 j28. ; save (returnaddr);
ds. w1 j29. ; save (element);
al w1 4 ; length := 4 bytes;
jl. w3 i2. ; buffering;
dl. w1 j29. ;
ds w1 (x2+4) ; store (element);
c. (:e15 > 12 a. 1:) - 1 ; if special testoutput pass12 then
jl. i12. ; goto testoutput 2 words;
z.
c. -(:e15 > 12 a. 1:) ;
jl. (j28.) ; else return;
z.
d15: al. w2 j14. ; get (textpart) : get 1 word;
al w1 2 ; length := 2 bytes;
rs. w3 j28. ; save (returnaddr);
jl. w3 i2. ; buffering;
rl w1 (x2+4) ;
c. (:e15 > 12 a. 1:) - 1 ; if special testoutput pass12 then
jl. i13. ; goto testoutput 1 word;
z.
c. -(:e15 > 12 a. 1:) ;
jl. (j28.) ; else return;
z.
d16: am j14-j15 ; get elem (inbuffer1) : get 2 words;
d17: al. w2 j15. ; get elem (inbuffer2) : get 2 words;
al w1 4 ; length := 4 bytes;
rs. w3 j28. ; save (returnaddr);
jl. w3 i2. ; buffering;
dl w1 (x2+4) ;
c. (:e15 > 12 a. 1:) - 1 ; if special testoutput pass12 then
jl. i12. ; goto testoutput 2 words;
z.
c. -(:e15 > 12 a. 1:) ;
jl. (j28.) ; else return;
z.
\f
; rc 03.06.1975 algol 6, pass 12, page 12
; open input:
d11: rs. w0 (j14.+2) ; store segmno.es in first word of buffers;
rs. w1 (j15.+2) ;
al w0 h11 ; displacements := too much...;
hs. w0 j14. ;
hs. w0 j15. ;
al w0 0 ; queuebase := 0;
rs. w0 j26. ;
jl x3 ; return;
d19: bl. w1 j16.+1 ; open output;
hs. w1 j16. ; displacement := first byte;
wa. w1 j16.+2 ; abs address := bufferstart + disp;
rs. w1 j16.+4 ;
rs. w0 (j16.+2) ; store segmno in first word of buffer;
jl x3 ; return;
d20: rs. w3 j17. ; close output: save (returnaddress);
rl. w2 (j16.+2) ; first segmno of queue :=
al w3 h19 ; first word in buffer;
ds. w3 j18.+2 ; second segmno of queue := false segmno;
i1: dl. w1 f26. ; repeat:
al. w3 d9. ; if close ident then
sl. w3 (j17.) ;
am d14-d13 ; put 1 word (maximum)
d24 = k + 2 ; comment: this address is used at
; initialize outputtransfer to select
; linked output of the segments;
jl. w3 d13. ; else put 2 words (maximum);
rl w1 (x2+2) ; if first word of buffer <>
se w1 h19 ; false segmentno then
jl. i1. ; goto repeat;
jl. (j17.) ; return;
d27: al. w2 j16. ; empty outbuffer:
rs. w3 j28. ; save return
bl w1 x2 ; length := 0;
jl. i5. ; transfer and return;
\f
; rc 1975.9.9 algol 6, pass 12, page 13
; buffering:
; register usage:
; w1 = length of element (2 or 4 bytes)
; w2 = addr of buffer-descriptor
; w3 = return addr
; bufferdescriptor is built like this:
; byte x2 : displacement , bytenumber in buffer (to be used by
; the next load or store.
; byte x2+1 : first byte , bytenumber in buffer of first relevant
; byte.
; nb uneven for output, even for input.
; word x2+2 : bufferstart , address of first byte of buffer
; word x2+4 : abs address , absolute address of the bytes to
; be used by next load or store.
i2: ba w1 x2 ; displacement := displacement + length;
sl w1 h11 ; if displacement < bufferlength then
jl. i5. ; begin
hs w1 x2 ;
wa w1 x2+2 ; absaddress := bufferstart + disp;
rs w1 x2+4 ; return;
jl x3 ; end;
; a segment transfer is needed. the bufferdescriptor
; is initialized.
i5: bs w1 x2 ; w1 := length;
ba w1 x2+1 ; displacement := first byte + length;
hs w1 x2 ;
wa w1 x2+2 ; absaddress := bufferstart + disp;
rs w1 x2+4 ;
bz w1 x2+1 ;
sz w1 1 ; if first byte is uneven then
jl. i7. ; goto initialize outputtransfer;
; initialize inputtransfer:
rl w0 (x2+2) ; segmno := first word in buffer;
rs. w0 j23. ;
rl. w1 j26. ; store segmno in queue;
rs. w0 x1+j18. ;
se w0 h19 ; if segmno = false segmno then
jl. i3. ; begin
rl. w1 f26. ; w0w1:=end of string;
al w0 x1 ;
ds w1 (x2+4) ;
jl x3+2 ; exception return; end;
i3: al. w1 d21. ; if list output then
sh. w1 (j28.) ;
jl. i6. ; goto set code;
rl. w1 j26. ; store segm.no in queu
rs. w0 x1+j18. ;
al w1 x1+2 ; increase (queuerelative);
rs. w1 j26. ;
i6: al w0 3 ; set code: operationcode := input;
jl. i10. ; goto transfer;
\f
; rc 03.06.75 algol 6, pass 12, page 14
; initialize outputtransfer:
i7: rl. w1 j28. ; if called from close or
se. w1 d24. ; called from sort-merge of linenumbers
sl. w1 d9. ; then goto linked output;
jl. i8. ;
rl w1 (x2+2) ; segmno := first word in buffer;
rs. w1 j23. ;
al w1 x1+1 ; first word in buffer := segmno + 1;
rs w1 (x2+2) ;
jl. i9. ; goto set output code;
i8: rl. w1 j26. ; linked output:
al w1 x1-2 ; decrease queue;
rs. w1 j26. ;
rl. w1 j18. ; segmno := first segmno of queue;
rs. w1 j23. ;
dl. w1 j18.+4 ; first word of buffer :=
rs w0 (x2+2) ; second segmno of queue;
ds. w1 j18.+2 ;
i9: al w0 5 ; operationcode := output;
i10: hs. w0 j20. ; transfer: move operationcode to message;
ds. w3 j25. ; save (w2, w3);
c. (:e15 > 12 a. 1:) - 1 ; if special testoutput pass12 then
al. w1 i19. ; begin
jl. w3 e13. ; writetext (<:oper: :>);
jl. w3 e14. ; write (<<dd>, operationcode);
32 < 12 + 2 ; end;
z.
rl w1 x2+2 ;
rs. w1 j21. ; move first core to message;
al w1 x1+h11-2 ; move last core to message;
rs. w1 j22. ;
c. (:e15 > 12 a. 1:) - 1 ;
rl. w0 j23. ; if special testoutput pass12 then
jl. w3 e14. ; write (<<dddd>, segmentno);
32 < 12 + 4 ;
z.
rl. w0 j23. ; if segmentno > sortareasize then
sh. w0 (j27.) ; begin
jl. i11. ; set return (end pass 12);
al w0 0 ; writetext (<:***xref too big:>);
al. w3 d23. ; end;
jl. w1 e13. ;
<:<10>***xref too big<0>:>);
i11: al. w3 j19. ; repeat message: w3 := name address
al. w1 j20. ; w1 := message address;
jd 1<11 + 16 ; send message;
al. w1 j24. ; w1 := answer address;
jd 1<11 + 18 ; wait answer;
am (x1) ;
sn w3 x3 ; if statusword <> 0
se w0 1 ; or result <> 1 then
jl. d25. ; goto backing store fault;
am (x1+2) ;
sn w3 x3 ; if no of bytes transferred = 0 then
jl. i11. ; goto repeat message;
dl. w3 j25. ; restore (w2, w3);
jl x3 ; return;
\f
; rc 3.2.1971 algol 6, pass 12, page 15
c. (:e15 > 12 a. 1:) - 1 ; if special testoutput pass12 then
i12: am i16 ; testoutput 2 words:
i13: al. w3 i14. ; testoutput 1 word:
rl. w1 e17. ; if -, testoutput then
so w1 1<5 ;
jl. i17. ; goto reestablish registers;
al w1 x2+i18 ; writetext (case buffer of
jl. e13. ; <:in1: :>, <:in2: :>, <:out: :>);
; goto case testoutput of (1 word, 2 words);
i14: rl w1 (x2+4) ; 1 word:
ls w1 3 ;
jl. w3 i15. ; writechar (1. char);
jl. w3 i15. ; writechar (2. char);
jl. w3 i15. ; writechar (3. char);
jl. i17. ; goto reestablish registers;
i15: al w0 0 ; procedure writechar (char);
ld w1 7 ; unpack (char);
am (0) ;
bz. w0 +g7. ; w0 := converted char;
jl. e12. ; write (char) and return;
i16 = k - i14
dl w1 (x2+4) ; 2 words:
ld w1 -h17 ; unpack (identno);
jl. w3 e14. ; write (<<ddddd>, identno);
32 < 12 + 5 ;
al w0 0 ;
ld w1 h17 ; unpack (connection);
jl. w3 e14. ; write (<<dd>, connection);
32 < 12 + 2 ;
rl w0 (x2+4) ;
jl. w3 e14. ; write (<<dddddddd>, lineno);
32 < 12 + 8 ;
i17: dl w1 (x2+4) ; reestablish registers:
jl. (j28.) ; return;
i18 = k - j14
<:<10>in1: :>, 0 ;
<:<10>in2: :>, 0 ;
<:<10>out: :>, 0 ; comment the length of the text must be the
i19: <:<10>oper: <0>:> ; same as the buffer-descriptor length;
z. ; end of special testoutput;
i.
e.
; end of i/o-routines ;
\f
; rc 1977.02.11 algol 6, pass 12, page ...16...
b. i20
w.
; meaning of variables, local to ident sort:
; f0 == no of identifiers
; f1 == pointer to addr of current smallest identifier
; f2 == addr of current smallest identifier
; f3 == addr of textstart of current smallest identifier
; f4 == pointer to addr of current identifier
; f5 == addr of current identifier
; f6 == addr of textstart of current identifier
; f7 == saved w2
; f9 == letteraddr
; f28 == segmentbase of identifiernames
; variables, used with the earlier content and meaning
; f15 == main top addr
; f21 == end mark (i.e. nul characters with end-mark)
; f26 == maximum (mask off signbit)
; variables, passed on to next phase:
; f0
; f26
; f28
d10: al w0 x2 ; ident sorting:
jl. w3 e3. ; outbyte (endpass);
jl. w3 d20. ;
rl. w0 j23. ; close output;
ba. w0 1 ;
rs. w0 f28. ; save ident-segmentbase;
jl. w3 d19. ; open output;
al w2 0 ;
rs. w2 f0. ; no. of identfiers:=0;
; i1 + 1 == letterrelative
i1: al w2 0 ; next letter:
al w2 x2+h8 ; letterrelative := letterrelative + addrlength;
sl w2 h9+2 ; if letterrelative > last of lettertable then
jl. i19. ; goto create new identno-table:
hs. w2 i1.+1 ;
al. w2 x2+g0. ; letter addr := letterrelative
rs. w2 f9. ; + lettertable base;
i2: ; restart same letter:
rl w3 x2-2 ; addr of smallest := head (letter addr);
sh w3 1 ; if addr of smallest =< 1 then
jl. i1. ; goto next letter;
rl w1 x3-2 ; if addrpart of smallest not requestmarked then
sz w1 1 ; begin
jl. i4. ; remove from letterchain
rs w1 x2-2 ; (first identifier);
rl. w1 f26. ; head (first identifier) := maximum;
rs w1 x3-2 ; comment see below: ident out;
jl. i2. ; goto restart same letter;
; end;
i4: ds. w3 f2. ; pointer to addr of smallest := letter addr;
al w2 x3 ; current identifier := first identifier;
jl. w1 i3. ; find textstart;
rs. w3 f3. ;
jl. i12. ; goto check for last ident;
\f
; rc 3.2.1971 algol 6, pass 12, page 17
; procedure find textstart returns register w3 with
; the address of the identifiertext, addressed by w3.
; the text is in main or aux table depending on
; bit0 of w0.
i3: rl w0 x3 ; procedure find textstart;
sl w0 0 ; if bit0 = 1 then text in main table
rl w3 0 ; else text in aux table;
jl x1 ; return;
; the next identifier from the unsorted chain is
; selected as the current identifier and is compared
; to the current smallest identifier.
; at entry register w3 holds the address of the next
; identifier, and w2 holds the addr of the old
; current identifier.
i5: ds. w3 f5. ; next identifier: store pointers to current ident;
jl. w1 i3. ; find textstart;
rs. w3 f6. ;
rl. w1 f3. ;
; register usage:
; w0 = textpart of smallest identifier
; w1 = addr of this textpart
; w2 = textpart of current identifier
; w3 = addr of this textpart
i8: rl w0 x1 ; compare textparts:
rl w2 x3 ; load w0 and w2 with textparts
la. w0 f26. ; and remove (bit0);
la. w2 f26. ;
se w0 x2 ; if textparts equal then
jl. i9. ; begin
rl w0 x1 ; if textpart of smallest identifier
sh w0 -1 ; stops here then
jl. i10. ; goto same smallest;
rl w2 x3 ; if textpart of current identifier
sh w2 -1 ; stops here then
jl. i11. ; goto new smallest;
al w1 x1-2 ; select the next textparts;
al w3 x3-2 ; goto compare textparts;
jl. i8. ; end;
i9: sl w0 x2 ; if textpart(smallest) >=
jl. i11. ; textpart(current) then goto new smallest;
; the comparison is ended.
; if the current identifier is found to be smaller
; than the current smallest, the current identifier
; is selected as the current smallest identifier.
; register w2 is reestablished, pointing at the
; current identifier.
i10: rl. w2 f5. ; same smallest: reestablish;
jl. i12. ; goto check for last identifier;
i11: dl. w2 f5. ; new smallest: reestablish;
ds. w2 f2. ; smallest identifier := current identifier;
rl. w3 f6. ;
rs. w3 f3. ;
\f
; rc 1977.02.11 algol 6, pass 12, page ...18...
; register usage:
; w0 not used
; w1 destroyed
; w2 = addr of current identifier
; w3 = addr of next identifier
i12: rl w3 x2-2 ; check for last identifier:
sh w3 1 ; if addr of next ident > 1 then
jl. i13. ; begin
rl w1 x3-2 ; if addrpart of next ident request marked then
sz w1 1 ; goto next identifier;
jl. i5. ; remove from letterchain
al w0 1 ; ensure that current identifier
lo w1 0 ; is requestmarked;
rs w1 x2-2 ; (next identifier);
rl. w1 f26. ; head (next identifier) := maximum;
rs w1 x3-2 ; comment see below: ident out;
jl. i12. ; goto check for last identifier;
; end;
i13: dl. w2 f2. ; remove from unsorted chain
rl w0 x2-2 ; (smallest identifier);
rs w0 x1-2 ;
rl. w3 f0. ;
al w3 x3+1 ; increase(
rs. w3 f0. ; no. of identifiers);
rs w3 x2-2 ; head(cur ident):=new identno;
; the identifiertext, addressed by register w2, is dumped on the
; current textsegment;
rs. w2 f7. ; save (w2);
bz. w1 i1.+1 ; first char := letterrelative // 2;
ls w1 -1 ;
jl. w3 d13. ; put 1 word (first char);
rl. w2 f7. ; restore (w2);
rl w1 x2 ;
sl w1 0 ; if text in aux then adjust w2;
al w2 x1 ;
i15: rl w1 x2 ; next: load textpart in w1;
rs. w2 f7. ; save (w2);
jl. w3 d13. ; put (textpart);
rl. w2 f7. ; restore (w2);
rl w1 x2 ;
sh w1 -1 ; if text is longer then
jl. i16. ; begin
al w2 x2-2 ; select next textpart;
jl. i15. ; goto next;
i16: sz w1 127 ; end
jl. i17. ; else
jl. i18. ; if last char <> nul then
i17: al. w2 f21. ; begin insert nul characters;
jl. i15. ; goto next; end;
i18: rl. w2 f9. ;
jl. i2. ; goto restart same letter;
\f
; rc 1977.02.11 algol 6, pass 12, page ...19...
i19: ; create new identno-table:
rl. w2 f15. ; main table addr := main top addr - 4;
al w2 x2-4 ;
rl. w1 e9.+4 ; new table addr := last word in pass;
; the new identno-table is stored in the upper end of storage.
i20: sh. w2 g9. ; next comprime:
jl. d9. ; if w2 =< main bottom addr then goto presorting;
rl w0 x2-2 ; new table(new table addr) :=
rs w0 x1 ; main table(main table addr);
al w2 x2-4 ; select new values;
al w1 x1-2 ;
jl. i20. ; goto next comprime;
i.
e.
; end of ident sorting routine;
\f
; rc 3.2.1971 algol 6, pass 12, page 20
; the sorting is accomplished by means of a binary
; tree-sorting, the elements being placed in inbuffer1
; and the links at the corresponding places in
; inbuffer2 (which for this purpose is called chain).
b. i9 ; presorting:
w.
; meaning of variables, local to presort:
; f1 == new identno table base
; f2 == addr of first chain
; f3 == saved w1
; variables, used with the earlier content and meaning:
; f26 == maximum
; variables, passed on to next phase:
; f0
; f26
; f28
d9: sh. w1 g10. ; if newtable addr <= last byte of inbuffer2 then
jl. d12. ; goto stack overflow;
rs. w1 f1. ; new table base := new table addr;
jl. w3 d20. ; close ident;
bz. w1 j15.+1 ; addr of first chain :=
am. (j15.+2) ; (addr of first-use-byte
al w1 x1+h13-2 ; of inbuffer2) + length of element - 2;
rs. w1 f2. ;
jl. w3 d19. ; open output;
al w0 0 ; elem := segmentno := 0;
jl. w3 d11. ; open input;
\f
; rc 1977.02.11 algol 6, pass 12, page ...21...
; register usage:
; w0 == elem
; w1 == pointer
; w2 == addr of inbuffer1-descriptor (= j14)
; w3 miscellaneous purposes
; select a new element and prepare it for being hooked
; on to the tree.
i1: jl. w3 d16. ; next to tree: get next elem;
sl. w0 (f26.-2) ; if next element<=maximum-1 then proceed;
jl. i9. ;
; replace the old identno by the corresponding new identno.
ld w1 -h17 ; w0 := old identno(elem);
ls w0 1 ;
wa. w0 f1. ;
rl w0 (0) ; w0 := new identno(old identno);
ld w1 h17 ;
i9: rl w1 x2+4 ; w1 := addr of elem;
rs w0 x1-2 ; elem := w0;
al w1 x1+h12 ; pointer := displacement + addr of elem;
al w3 0 ;
rs w3 x1 ; chain(pointer) :=
rs w3 x1+2 ; chain(pointer+1) := 0;
rl. w3 f2. ; w3 := addr of first chain;
sn w3 x1 ; if pointer = addr of first chain
jl. i1. ; then goto next to tree;
; the search starts at the top of the tree.
; if the present elem is less than the current outpointed element
; in the tree, the search continues via the left branch -
; indicated by chain(pointer) - else via the rigth branch -
; indicated by chain(pointer+1) - until a free place is found.
i2: rl w1 6 ; search: pointer := w3;
se w0 (x1-h12-2) ; if elem = inbuffer(pointer - disp)
jl. i3. ;
rl w3 (x2+4) ; and
sl w3 (x1-h12) ; lineno(elem) >= lineno(inbuffer)
jl. i4. ;
jl. i5. ;
i3: sl w0 (x1-h12-2) ; or elem >= inbuffer(pointer - disp)
i4: al w1 x1+2 ; then pointer := pointer + 1;
i5: rl w3 x1 ; w3 := chain(pointer);
se w3 0 ; if w3 <> 0 then
jl. i2. ; goto search;
; a free place is found, and the present elem is hooked on to the tree.
am (x2+4) ; chain(pointer) :=
al w3 + h12 ; addr of elem + displacement;
rs w3 x1 ;
bz w1 x2 ; if the element is not the last
sh w1 h11-h13 ; in the inbuffer then
jl. i1. ; goto next to tree;
\f
; rc 07.06.1972 algol 6, pass 12, page 22
; the tree is broken down and output. (postorder-traversing).
; the routine starts at the top of the tree.
; if there is a left-branch (there is an element smaller than
; the topelement) the tree is rearranged, so that the node
; of this branch becomes the top of the tree, while still keeping
; the structure of the tree.
; else the topelement is the smallest and can be output. the
; top is cut off, and the node of the rigth-branch becomes
; the new top.
; when there is no rigth-branch the routine is ended.
; register usage:
; w0 == chain(nextpointer+1)
; w1 == pointer
; w2 == next pointer
; w3 == chain (next pointer)
rl. w1 f2. ; pointer := addr of first chain;
; examine top:
i6: rl w2 x1 ; next pointer := chain(pointer);
i7: sn w2 0 ; examine the left-branch:
jl. i8. ; if next pointer <> 0 then begin
; there is a left-branch. rearrange.
rl w0 x2+2 ; chain(pointer) := chain(nextpointer+1);
rs w0 x1 ;
rs w1 x2+2 ; chain(nextpointer+1) := pointer;
al w1 x2 ; pointer := nextpointer;
jl. i6. ; goto examine top; end;
i8: rs. w1 f3. ; output top and examine rigth-branch:
dl w1 x1-h12 ; put (top-element);
jl. w3 d14. ;
rl. w1 f3. ;
rl w1 x1+2 ; pointer := chain(pointer+1);
se w1 0 ; if pointer <> 0 then
jl. i6. ; goto examine top;
al. w3 i1. ; prepare return from procedure empty outbuffer;
rl. w1 (j14.+2) ; if next segment no of input
se w1 h19 ; is not false segment no then
jl. d27. ; goto next to tree after empty outbuffer;
i.
e.
; end of presorting-routine;
\f
; rc 3.2.1971 algol 6, pass 12, page 23
b. i4
w.
; meaning of variables, local to merge-routine:
; f1 == last segmno
; f2 == no of strings
; f3 == first segmno
; f4 == string length
; f5 == saved w0
; f6 == saved w1
; variables, used with the earlier content and meaning:
; f26 == maximum
; f28 == segmentbase for identifiernames
; variables, passed on to next phase:
; f0
; f28
d18: al w0 h11>9 ; merge: stringlength := bufferlength/512;
rl. w2 f28. ; last segmno :=
rs. w2 f1. ; segmentbase for identifiernames;
ad w3 -24 ; no of strings :=
wd w3 0 ; last segmno // stringlength;
rs. w3 f2. ;
jl. i1. ; stringlength := stringlength/2;
i0: rl. w0 f4. ; next total merge:
wa w0 0 ; stringlength := 2 * stringlength;
i1: rs. w0 f4. ;
rl. w1 f2. ; if no of strings =< 1 then
sh w1 1 ;
jl. d21. ; goto list output;
ac w0 (0) ; first segmno := 0 - stringlength;
rs. w0 f3. ;
\f
; rc 3.2.1971 algol 6, pass 12, page 24
i2: dl. w1 f4. ; next string merge:
wa w0 2 ; w0 := first segmno + stringlength;
wa w1 0 ; w1 := w0 + stringlength;
rs. w1 f3. ; first segmno := w1;
sl. w1 (f1.) ; if w1 >= last segmno then
jl. i0. ; goto next total merge;
; comment: if there is only one string left un-paired in this round,
; it is left for next round;
rl. w2 f2. ; no of strings := no of strings -1;
al w2 x2-1 ;
rs. w2 f2. ;
ds. w1 f6. ; save (w0, w1);
jl. w3 d27. ; empty outbuffer;
dl. w1 f6. ; restore (w0, w1);
jl. w3 d11. ; open input;
jl. w3 d16. ; get 2 words 1;
jl. w3 d17. ; get 2 words 2;
i3: dl. w1 (j15.+4) ; next elem:
ss. w1 (j14.+4) ; if compareelem (inbuffer1)
sl w0 0 ; > compareelem (inbuffer2) then
jl. i4. ; begin
dl. w1 (j15.+4) ;
jl. w3 d14. ; put 2 words;
jl. w3 d17. ; get 2 words 2;
jl. i3. ; end
i4: dl. w1 (j14.+4) ; else begin
sl. w0 (f26.) ; if compareelem(inbuffer1) = maximum then
jl. i2. ; goto next string merge;
jl. w3 d14. ; put 2 words;
jl. w3 d16. ; get 2 words 1;
jl. i3. ; end;
; goto next elem;
i.
e.
; end of merge;
\f
; rc 1977.02.11 algol 6, pass 12, page ...25...
; the last phase... list output:
; the output is listed on the current output.
b. i15
w.
; meaning of variables, local to list output:
; f1 == old ident (i.e. identno and connection)
; f2 == old lineno
; f3 == saved w0
; f4 == saved w3
; f5 == saved return
; f6 == old identno (without connection)
; variables, used with the earlier content and meaning:
; f0 == no of identifiers
; f28 == segmentbase for identifiernames
d21: jl. w3 d27. ; list output: empty outbuffer;
rl. w0 f28. ; w0 := first segmno for identifiernames;
al w1 0 ; w1 := first segmno for occurrencies;
rs. w1 f1. ; old ident := 0;
rs. w1 f6. ; oldidentno:=0;
jl. w3 d11. ; open input;
i1: jl. w3 d17. ; read: w0w1 := (new ident, new lineno);
i2: se. w0 (f1.) ; comp: if new ident = old ident then
jl. i6. ; begin
sh. w1 (f3.) ; if new lineno =< old lineno then
jl. i1. ; goto read;
al w0 x1 ;
rs. w0 f3. ; output lineno: old lineno := new lineno;
; i4 + 1 = linepos;
i4: al w1 0 ;
sh w1 h14-h15 ; if linepos+printpos > maxpos then
jl. i5. ; begin
al w1 h16+2 ; w1 := linepos := std ident lgth + 2;
jl. w3 i13. ; newline(linepos);
rl. w0 f3. ;
i5: al w1 x1+h15 ; end;
hs. w1 i4.+1 ; linepos := linepos + printpos;
jl. w3 e14. ; writeinteger(out, layout, new lineno);
w. 32 < 12 + h15 ; comment layout;
jl. i1. ; goto read;
; end of comp;
\f
; rc 1977.11.09 algol 6, pass 12, page ...26...
; an extra lineshift - accompanied by some text - is requested.
; the text may be either a new identifiertext or a
; connection-identification (i.e. d,a,u) or both.
i6: rl. w2 f6. ; new text:
ld w1 -h17 ; unpack (new ident);
sn w0 x2 ; if new identno = old identno then
jl. i12. ; goto new connection;
; output next identifiertext.
am -2000 ;
rl. w3 f0.+2000 ;
sl w2 x3 ; if old identno >= no of identifiers then
jl. d23. ; goto end pass 12;
al w2 x2+1 ; old identifier := old identifier + 1;
rs. w2 f6. ;
ls w2 h17 ; old ident := pack (old identno);
rs. w2 f1. ;
al w2 0 ; no of identletters := 0;
hs. w2 i4.+1 ;
jl. w3 d15. ; w1 := first char;
al w0 10 ; writetext(<:<10>:>);
jl. w3 e12. ;
ls w1 17 ;
al w0 x1 ;
jl. w3 i10. ; writechar (first char);
i8: jl. w3 d15. ; output identifier textpart:
ls w1 3 ; for ever while char <> 0 do begin
jl. w3 i10. ; writechar(1. char);
jl. w3 i10. ; writechar(2. char);
al. w3 i8. ; writechar(3. char); end;
; goto repeat input;
i10: rl. w2 i4.+1 ; procedure writechar(char);
al w0 0 ; w2 := linepos;
ld w1 7 ; w0 := char;
sn w0 0 ; if char = 0 then
jl. i11. ; goto repeat input;
al w2 x2+1 ; linepos := linepos + 1;
hs. w2 i4.+1 ;
am (0) ; w0 := outputtable(char);
bz. w0 +g7. ; write(char);
jl. e12. ; return;
i11: al w1 0 ; repeat input:
rs. w1 f3. ; old lineno := 0;
dl. w1 (j15.+4) ; repeat input(inbuffer 2);
jl. i2. ; goto comp;
\f
; rc 1977.11.09 algol 6, pass 12, page ...27...
; output next connection.
i12: ld w1 h17 ; next connection:
rs. w0 f1. ; old ident := new ident;
al w1 h0+h1+h2 ; w1 := mask;
la w0 2 ; w0 := connection bits;
sl w0 4 ; w0 := min (3, w0);
al w0 3 ;
am (0) ;
bz. w0 +g8. ; w0 := connection identification;
rs. w0 f4. ; save (w0);
al w1 h16 ; w1 := std ident lgth;
bz. w2 i4.+1 ; w2 := linepos;
sh w2 x1 ; if w2 > w1 then
am i14 ; new line(std ident lgth)
jl. w3 i13. ; else spaces(std ident lgth - linepos);
al w1 x1+2 ; linepos := std ident lgth + 2;
hs. w1 i4.+1 ;
rl. w0 f4. ; restore (w0);
jl. w3 c9. ; writechar( d, a or u );
al w0 58 ; write (colon);
jl. w3 c9. ;
jl. i11. ; goto repeat input;
i13: rs. w3 f5. ; procedure newline(linepos);
al w0 10 ; save (return);
jl. w3 c9. ; writecr;
al w2 0 ; spaces(linepos);
jl. i15. ; return;
i14 = k - i13
rs. w3 f5. ; procedure spaces(linepos);
i15: sh w1 x2-1 ; save (return);
jl. (f5.) ; for w2 := w2+1 while w2 < w1 do
al w2 x2+1 ;
al w0 32 ; writesp;
jl. w3 c9. ; return;
jl. i15. ;
i.
e.
; end of list output;
\f
; jz.fgs 1981.03.03 algol 6, pass 12, page ...28...
g4 = k ; outbuffer
g5 = g4 + h11 ; inbuffer 1
g6 = g5 + h11 ; inbuffer 2
g2 = g5 + 2 ; main top
g3 = g2 -4-2047; main bottom
g9 = g2 -2 ; main bottom
g10= g6 + h11-1; last byte of inbuffer2;
b. i3
w.
d0 = k - j0 ; start pass 12:
al w2 -2048 ;
al. w1 g2. ; current word addr :=
rs. w1 f14. ; main top addr :=
rs. w1 f15. ; lower main limit;
rl. w1 x2+e9.+4+2048; current aux addr :=
rs. w1 f16. ; aux top addr :=
rs. w1 f17. ; last word in pass;
al. w0 g5. ; compute bufferbases
rs. w0 j14.+2 ; (inbuffer 1,
al. w0 g6. ;
rs. w0 j15.+2 ; inbuffer 2,
al. w0 g4. ;
rs. w0 j16.+2 ; outbuffer);
al. w0 g6.+h11-1 ; w0 := last core (inbuffer2);
sl w0 x1 ; if w0 >= last word in pass then
jl. d12. ; goto stack overflow;
al w0 0 ;
jl. w3 d19. ; open output;
am -2048 ; w2 := name address;
al. w2 j19.+2048 ;
c. e77<3 ; if system 3 then begin
rl w0 x2-j19+e9-4 ; available segments := used segments;
rs w0 x2-j19+e9-2 ;
z. ; end system 3;
am (x2) ; if first parts of name = 0 then
se w2 x2 ; begin
jl. i0. ;
c. e77<2 ; if system 2 then begin
al w3 x2 ; w3 := name address;
al. w1 j27. ; w1 := tail address;
jd 1<11+40 ; create entry(sort area);
se w0 0 ; if result <> 0 then
jl. i1. ; goto error;
z. ; end system 2;
c. e77<3 ; if system 3 then begin
al w3 x2-j19+e79 ; w3 := pass 0 work area name address;
al. w1 g6. ; w1 := tail address;
jd 1<11+42 ; lookup entry (work area);
rl w0 x2-j19+e9-4 ; tail(1) := used segments;
rs. w0 g6. ;
jd 1<11+44 ; change entry (work area);
se w0 0 ; if result <> 0 then
jl. i1. ; goto error;
z. ; end system 3;
\f
; jz.fgs.1986.03.14 algol 6, pass 12, page ...29...
al w0 1<10 ; selfmade sortarea := true;
hs. w0 d28. ; end selfmade sortarea;
i0: al w1 0 ; prepare connect: comment: no zone;
al w0 e81 ; comment: take standard actions for sortarea;
am (x2-j19+e23) ;
jl w3 +e78 ; connect output;
bz w1 x2+1 ; if connect trouble
sn w0 0 ; or kind of sortarea <> bs then
se w1 4 ; goto error;
jl. i1. ;
am -2048 ; move name of sort area to name address;
al. w3 j19.+2048 ;
dl w1 x2+4 ;
ds w1 x3+2 ;
dl w1 x2+8 ;
ds w1 x3+6 ;
jd 1<11+8 ; reserve process;
jd 1<11+4 ; process description (sort area);
se w0 0 ; if process does not exist then
jl. i2. ; begin
i1: al. w3 d22. ; error: set return (end pass 12);
jl w1 x3-d22+e13 ; outtext(<:***algol sort area:>);
<:***algol sort area<10><0>:> ;
; end;
i2: am (0) ; comment: find number of segments
rl w1 +18 ; in area process;
al w1 x1-1 ; sortsize := segments - 1;
rs. w1 j27. ; comment: see transfer;
c.e77<3 ; if system 3 then
am -2048 ;
al. w2 j19.+2048 ;
al w0 0 ; segm number of
rs w0 x2-j19+e79+16 ; byteoutput:= -1;
z.
jl. d2. ;
i.
e.
; end of initialize pass 12;
g1 = k - j0 ; number of bytes in pass 12
e30=e30+g1
i.
e.
m. jz 1986.03.20 algol 8, pass 12
\f
▶EOF◀