Elliott 803 Algol 60 Compiler (reconstructed)

File: iosupp.t2

For general comments see here
LineAddressObject Code LabelF1N1BF2N2CommentsCheck
1 0  ; tape2/iosupp.t2
2 0  ;----------------
3 0  ; digits(n) set number of digits in printed integers
4 0  ;
5 0  =7462 
6 7462  Digits::; 
7 7462  Digits:; 
8 7462 0600016 lod arg1   ; @7462
9 7462+1136450 jn .1   ;<0, error
10 7463 1156450 jz .1   ;=0, error @7463
11 7463+0136214 sub K13   ;=13
12 7464 1136451 jn .2   ;<13, OK @7464
13 7464+ .1:; 
14 7464+0056223 o02 K4   ;=4+1=>5
15 7465 0020000 neg 0   ;=-5 @7465
16 7465+ .2:; 
17 7465+0116214 add K13   ;=13
18 7466 0400075 sto Ndigits   ;store new setting @7466
19 7466+1016043 jmp RetClr   ;and return
20 7467  ;--------------------------------------------------------------------
21 7467  Scaled:; 
22 7467   calln ,   ;check arg1 OK @7467
22+17467 7300101016462 lnk arg3:jmp chkrfmt 
23 7468 0040000 o02 0   ;=1 @7468
24 7468+1320024 sll 20   ;
25 7469 0100016 add arg1   ; @7469
26 7469+0116227 add Signbit   ;=04000000000000 (sign bit)
27 7470  setrfmt:; 
28 7470 0400074 sto Rfmt   ; @7470
29 7470+1016043 jmp RetClr   ;return
30 7471  ;--------------------------------------------------------------------
31 7471  ; sameline, suppress CR,LF before each print item
32 7471  ; set prefix string pointer to 1, non-zero, but effectively a
33 7471  ; Null string
34 7471  ;
35 7471  Sameline:; 
36 7471 0040000 o02 0   ;=1 special value for prefix @7471
37 7471+ setprefix:; 
38 7471+1320024 sll 20   ;shift to N1 position
39 7472 0200076 exa prtfmt   ;present setting @7472
40 7472+0076505 and W7493   ;=<77 0 / 77 8191> mask out N1
41 7473 0500076 ads prtfmt   ;combine with new flag @7473
42 7473+1016043 jmp RetClr   ;and return
43 7474  ;--------------------------------------------------------------------
44 7474  ; check arg1 is OK for real formats
45 7474  ;
46 7474  chkrfmt:; 
47 7474 0600016 lod arg1   ;get value @7474
48 7474+1056466 jz errfmt   ;=0, error
49 7475 1036466 jn errfmt   ;<0, error @7475
50 7475+0176211 bus K10a   ;=10
51 7476 0116210 add N1   ;=-1 @7476
52 7476+1036466 jn errfmt   ;>11, error
53 7477 0000103000001 o00 arg3/jmp 1;back to caller @7477
54 7478  ;
55 7478  errfmt:; 
56 7478 0615154 lod W6764   ;=<10 8:00 8> @7478
57 7478+0400074 sto Rfmt   ;set default format
58 7479 1016043 jmp RetClr   ; @7479
59 7479+ ;--------------------------------------------------------------------
60 7479+ ; prefix(str) - set string to print before each number
61 7479+ ; argument is address of string
62 7479+ ;
63 7479+ Prefix:; 
64 7479+0600016 lod arg1   ;get argument value
65 7480 0076202 and K8191   ;=8191 mask address to 13 bits @7480
66 7480+1116457 jmp setprefix   ;join with Sameline code
67 7481  ;--------------------------------------------------------------------
68 7481  ; freepoint(n) - set floating point format
69 7481  ; set digits before=digits after=n
70 7481  ;
71 7481  Freepoint:; 
72 7481   calln ,   ;check arg1 OK @7481
72+17481 7300101016462 lnk arg3:jmp chkrfmt 
73 7482 0600016 lod arg1   ; @7482
74 7482+1320024 sll 20   ;shift n to N1 position
75 7483  L7483:; 
76 7483 0116545 add W7525   ;=<10 0:00 0> @7483
77 7483+0100016 add arg1   ;+arg1
78 7484 1016456 jmp setrfmt   ; @7484
79 7484+ ;--------------------------------------------------------------------
80 7484+ ; aligned(b,a) - b digits before point, a after. (reals only)
81 7484+ ;
82 7484+ Aligned::; 
83 7484+ Aligned:; 
84 7484+0600017 lod arg2   ;check for b<0
85 7485 1036466 jn errfmt   ;error, freepoint(8) @7485
86 7485+0700016 las arg1   ;check a<0, add b
87 7486 1036466 jn errfmt   ;error, freepoint(8) @7486
88 7486+0200016 exa arg1   ;get total (a+b), arg1:=a
89 7487 0176220 bus K15a   ;=15 @7487
90 7487+1036466 jn errfmt   ;a+b>15, error
91 7488 0176220 bus K15a   ;get a+b back @7488
92 7488+1016506 jmp .1   ;-> to patch
93 7489  ;
94 7489  ;
95 7489  =7494 
96 7494  .1:; 
97 7494 0200016 exa arg1   ;digits before point (a) @7494
98 7494+1320024 sll 20   ;shift to N1
99 7495 0116545 add W7525   ;=<10 0:00 0> @7495
100 7495+1016473 jmp L7483   ;common with freepoint above
101 7496  =7489 
102 7489  ;--------------------------------------------------------------------
103 7489  ; leadzero(str)
104 7489  ;
105 7489  LeadZero::; 
106 7489  LeadZero:; 
107 7489 0000072600000 o00 arg1/lod 0;get 1st word of string @7489
108 7490 1220036 srl 30   ;shift first char @7490
109 7490+0076212 and K63   ;=63 and mask off sign etc.
110 7491 1015761 jmp .1   ;-> to patch @7491
111 7491+ =7153 
112 7153  .1:; 
113 7153 1055762 jz .2   ;character is null @7153
114 7153+1115762 jmp .3   ;character OK
115 7154  ;
116 7154  .2:; 
117 7154 0616215 lod K27   ;=27 use fig shift @7154
118 7154+ .3:; 
119 7154+0700076 las prtfmt   ;load old value, add new char
120 7155 1116503 jmp .4   ;-->> @7155
121 7155+ ;
122 7155+ =7491+ 
123 7491+ .4:; 
124 7491+0076212 and K63   ;=63 mask old leadzero char
125 7492 0560076 o27 prtfmt   ;subtract from store @7492
126 7492+1016043 jmp RetClr   ;and return
127 7493  ;
128 7493 7700003777777W7493:+07700003777777;o77 0 / o77 8191 @7493
129 7494  ;--------------------------------------------------------------------
130 7494  =7496 
131 7496  ;--------------------------------------------------------------------
132 7496  ; grouping(n)
133 7496  ;
134 7496  Grouping::; 
135 7496  Grouping:; 
136 7496 0616515 lod W7501   ;=<77 8191/00 8191> @7496
137 7496+0460076 ans prtfmt   ;remove previous grouping
138 7497 0600016 lod arg1   ;check value given @7497
139 7497+1036514 jn .errfmt   ;bad value
140 7498 1056514 jz .errfmt   ;bad value @7498
141 7498+1320015 sll 13   ;OK, shift to F2 position
142 7499 0500076 ads prtfmt   ;and add to format @7499
143 7499+1016043 jmp RetClr   ;then return
144 7500  ;
145 7500  .errfmt:; 
146 7500 0540076 cls prtfmt   ;set default format @7500
147 7500+1016043 jmp RetClr   ;then return
148 7501  ;
149 7501 7777776017777W7501:+07777776017777;o77 8191 / o00 8191 @7501
150 7502  ;--------------------------------------------------------------------
151 7502  ; special(n)
152 7502  ; n=1 suppress space before positive number on output
153 7502  ; n=2 replace space with '+' before positive number
154 7502  ; n=3 don't float the sign
155 7502  ; n=4 ignore spaces on input
156 7502  ;
157 7502  Special::; 
158 7502  Special:; 
159 7502 0600016 lod arg1   ;get argument @7502
160 7502+1036546 jn .err   ;<0, error
161 7503 1056546 jz .err   ;=0, error @7503
162 7503+0136223 sub K4   ;=4
163 7504 1136521 jn .1   ;1-3, OK @7504
164 7504+1056526 jz .4   ;4, OK, but different
165 7505 1016546 jmp .err   ;>4, error @7505
166 7505+ =7526 
167 7526  .err:; 
168 7526 0616230 lod MaxInt   ;=03777777777777 (maxint) @7526
169 7526+0460025 ans indev   ;remove possible sign bit
170 7527 1016514 jmp Grouping.errfmt   ;reset standard format @7527
171 7527+ ;
172 7527+0000000 o00 0   ;
173 7528  =7505+ 
174 7505+ ;
175 7505+ ; cases 1-3, affect printing
176 7505+ ;
177 7505+ .1:; 
178 7505+0600076 lod prtfmt   ;check if specified bit already set
179 7506 0000073317777 o00 arg1/sll -1;shift it top top place @7506
180 7507 1036043 jn RetClr   ;bit set, return @7507
181 7507+1016550 jmp .11   ;not set, set it
182 7508  =7528 
183 7528  ;
184 7528  .11:; 
185 7528 0600076 lod prtfmt   ; @7528
186 7528+1036555 jn .14   ;special(1) already set, clear it
187 7529 0040000 o02 0   ;=1 @7529
188 7529+0120016 sub arg1   ;
189 7530 1036554 jn .13   ;2,3 @7530
190 7530+0616230 lod MaxInt   ;=03777777777777, 1 cancels 2&3
191 7531 1220002 srl 2   ;shift mask to clear 1,2&3 @7531
192 7531+ .12:; 
193 7531+0460076 ans prtfmt   ;clear excluded bits
194 7532  .13:; 
195 7532 0616227 lod Signbit   ;=04000000000000 @7532
196 7532+1016524 jmp .2   ;
197 7533  ;
198 7533  .14:; 
199 7533 0616230 lod MaxInt   ;=03777777777777 @7533
200 7533+1116553 jmp .12   ;
201 7534  ;
202 7534  =7508 
203 7508  .2:; 
204 7508 0000073217777 o00 arg1/srl -1; @7508
205 7509 0500076 ads prtfmt   ; @7509
206 7509+1016043 jmp RetClr    
207 7510  ;
208 7510  ; case 4, affects reading
209 7510  ;
210 7510  .4:; 
211 7510 0600025 lod indev   ; @7510
212 7510+1036043 jn RetClr   ;already set
213 7511  .5:; 
214 7511 0616227 lod Signbit   ;=04000000000000 (sign bit) @7511
215 7511+0500025 ads indev   ;set sign bit to indicate special(4)
216 7512 1016043 jmp RetClr   ;and return @7512
217 7512+ ;--------------------------------------------------------------------
218 7512+ ; reader(n) - set input device (1 or 2)
219 7512+ ; 3 seems to be allowed!
220 7512+ ;
221 7512+ Reader::; 
222 7512+ Reader:; 
223 7512+0600016 lod arg1   ;device number
224 7513 1036533 jn .err   ;error, <0 @7513
225 7513+1056533 jz .err   ;error, =0
226 7514 0136223 sub K4   ;=4 @7514
227 7514+1036534 jn .1   ;1-3, OK
228 7515  .err:; 
229 7515 0540025 cls indev   ;input device = reader 1 @7515
230 7515+1016043 jmp RetClr   ;
231 7516  ;
232 7516  .1:; 
233 7516 0600016 lod arg1   ;reload argument @7516
234 7516+0116210 add N1   ;=-1
235 7517 1320013 sll 11   ;shift for H/W @7517
236 7517+0200025 exa indev   ;set device, check previous
237 7518 1036527 jn Special.5   ; @7518
238 7518+1016043 jmp RetClr   ;
239 7519  ;--------------------------------------------------------------------
240 7519  ; punch(n) - set output device, n = 1-3
241 7519  ;
242 7519  Punch::; 
243 7519  Punch:; 
244 7519 0600016 lod arg1   ;get argument @7519
245 7519+1136541 jn .p1   ;<0, error, set 0
246 7520 1156541 jz .p1   ;=0, OK, set 0 @7520
247 7520+0136223 sub K4   ;=4
248 7521 1136542 jn .p2   ;1-3 @7521
249 7521+ .p1:; 
250 7521+0540077 cls outdev   ;set output device = punch 1
251 7522 1016043 jmp RetClr   ; @7522
252 7522+ ;
253 7522+ .p2:; 
254 7522+0600016 lod arg1   ;reload argument
255 7523 0116210 add N1   ;=-1 @7523
256 7523+1320013 sll 11   ;shift into position
257 7524 0400077 sto outdev   ;and store @7524
258 7524+1016043 jmp RetClr   ;return to caller
259 7525  ;--------------------------------------------------------------------
260 7525  ;
261 7525 1000000000000W7525:+01000000000000; @7525
262 7526  ;

Page created by Bill Purvis, last updated: January 09 2004