github.com/open-simh.simtools
1
0
Fork 0
mirror of https://github.com/open-simh/simtools.git synced 2026-05-03 06:28:37 +00:00
Code Issues Projects Releases Wiki Activity
Files
13f0fb4d2b77ff4582bced65113f36bcbb7f760b
open-simh.simtools/tests/2.11BSD-m11-fltg.lst.ok
Olaf Seibert 0ab2a4fa16 Add consistency checking for symbol flags 
while also adding some consistency.
All listings now list . (dot) as defined so they need updating.
2021-05-30 13:19:39 +02:00

1007 lines
58 KiB
Plaintext
Raw Blame History

1 ;;;; Wrapper for 2.11BSD/m11/fltg.m11
2 .list
3 .list
4 .list
5 000001 debug = 1
6 .include "2.11BSD/m11/at.sml"
1 .title at.sml - assembler/translator system macros
2 ; @(#)at.sml 1.3 11/3/82
3
4 .ident /10may4/
5
6 .macro always ;all files of macro
7
8 .macro .data
9 entsec .data
10 .endm .data
11
12 .macro .text
13 entsec .text
14 .endm
15
16 .macro .bss
17 entsec .bss
18 .endm
19
20 mk.symbol=1 ;one to make symbols, 0 otherwise
21 x40= 0
22 pdpv45= 0 ; host machine has 'mul', 'div', sob' instrucs.
23 ; if not you will have to write macros for them
24 $timdf= 7 ; California Time Zone
25 ; should really use ftime(2) for this and for
26 ; DST.
27 ;xfltg= 0 ;define to assmbl out floating hardware
28 rsx11d = 0 ; rsx11d features
29 debug = 0 ; <<< REEDS if non zero includes debug junk
30
31 ft.id= 1 ;have set i & d. set =0 if not
32
33 ft.unx = 1 ; this macro-11 is for UNIX. =0 if not.
34
35 .nlist bex
36
37 tab= 11
38 lf= 12
39 vt= 13
40 ff= 14
41 cr= 15
42 space= 40
43
44 bpmb = 20 ;bytes per macro block
45
46
47
48
49
50 .psect .text con, shr, gbl,ins
51 .psect .data con, dat, prv, gbl
52 .psect .bss con, bss, gbl
53
54 .psect dpure con, dat, prv, gbl
55 .psect mixed con, prv, gbl
56 .psect errmes con, dat, prv, gbl
57 .psect impure con, bss, gbl
58 .psect imppas con, bss, gbl
59 .psect implin con, bss, gbl
60 .psect swtsec con, dat, prv, gbl ; unix command line flags
61 .psect cndsec con, dat, prv, gbl ; gt, le, equ, etc. for '.if'
62 .psect crfsec con, dat, prv, gbl ; args for -cr flag
63 .psect edtsec con, dat, prv, gbl ; args for .enabl
64 .psect lctsec con, dat, prv, gbl ; args for .list
65 .psect psasec con, dat, prv, gbl
66 .psect pstsec con, dat, prv, gbl
67 .psect rolbas con, dat, prv, gbl ; core allocation: starts of tables
68 .psect rolsiz con, dat, prv, gbl ; sizes of table entries
69 .psect roltop con, dat, prv, gbl ; tops of tables
70 .psect xpcor con,bss , gbl ; this one MUST come last in core
71
72
72
73 .macro entsec name ;init a section
74 .psect name con
75 .endm entsec
76
77
78
79 .macro jeq x,?fred
80 bne fred
81 jmp x
82 fred:
83 .endm
84 .macro jne x,?fred
85 beq fred
86 jmp x
87 fred:
88 .endm
89 .macro xitsec
90 entsec .text
91 .endm xitsec
92
93
94 .macro call address
95 jsr pc,address
96 .endm
97
98 .macro return
99 rts pc
100 .endm
101
102
103 .macro always
104 .nlist bex
105 .endm always
106 .endm always
107
108
109 000001 .if ne debug
110
111 .macro ndebug n
112 .globl ndebug,..z
113 mov n,..z
114 call ndebug
115 .endm
116
117 .macro sdebug string
118 .globl sdebug,..z,..zbuf
119 x = 0
120 .irpc t,<string>
121 movb #''t,..zbuf+x
122 x = x+1
123 .endm
124 movb #0,..zbuf+x
125 mov #..zbuf,..z
126 call sdebug
127 .endm
128
129 .iff
130
131 .macro ndebug n
132 .endm
133
134 .macro sdebug string
135 .endm
136
137 .endc
138
139
140 .macro param mne, value ;define default parameters
141 .iif ndf mne, mne= value
142 .list
143 mne= mne
144 .nlist
145 .endm
145
146 .macro putkb addr ;list to kb
147 .globl putkb
148 mov addr,r0
149 call putkb
150 .endm
151
152 .macro putlp addr ;list to lp
153 .globl putlp
154 mov addr,r0
155 call putlp
156 .endm
157
158 .macro putkbl addr ;list to kb and lp
159 .globl putkbl
160 mov addr,r0
161 call putkbl
162 .endm
163
164
165 .macro xmit wrdcnt ;move small # of words
166 .globl xmit0
167 call xmit0-<wrdcnt*2>
168 .endm xmit
169
170
171 ;the macro "genswt" is used to specify a command
172 ;string switch (1st argument) and the address of
173 ;the routine to be called when encountered (2nd arg).
174 ; the switch is made upper-case.
175
176 .macro genswt mne,addr,?label
177 entsec swtsec
178 label: .irpc x,mne
179 .if ge ''x-141
180 .if le ''x-172
181 .byte ''x-40
182 .iff
183 .byte ''x
184 .endc
185 .iff
186 .byte ''x
187 .endc
188 .endm
189 .iif ne <.-label&1>, .byte 0
190 .word addr
191 xitsec
192 .endm
192
193 .macro zread chan
194 .globl zread
195 mov #chan'chn,r0
196 call zread
197 .endm zread
198
199 .macro zwrite chan
200 .globl zwrite
201 mov #chan'chn,r0
202 call zwrite
203 .endm zwrite
203
204 .macro genedt mne,subr ;gen enable/disable table
205 entsec edtsec
206 .rad50 /mne/
207 .if nb subr
208 .word subr
209 .iff
210 .word cpopj
211 .endc
212 .word ed.'mne
213 xitsec
214 .endm genedt
215
216
217 ;the macro "gencnd" is used to specify conditional
218 ;arguments. it takes two or three arguments:
219
220 ; 1- mnemonic
221 ; 2- subroutine to be called
222 ; 3- if non-blank, complement condition
223
224 .macro gencnd mne,subr,toggle ;generate conditional
225 entsec cndsec
226 .rad50 /mne/
227 .if b <toggle>
228 .word subr
229 .iff
230 .word subr+1
231 .endc
232 xitsec
233 .endm
233
234 .macro ch.mne
235
236 ch.ior= '!
237 ch.qtm= '"
238 ch.hsh= '#
239 ch.dol= '$
240 ch.pct= '%
241 ch.and= '&
242 ch.xcl= ''
243
244 ch.lp= '(
245 ch.rp= ')
246 ch.mul= '*
247 ch.add= '+
248 ch.com= ',
249 ch.sub= '-
250 ch.dot= '.
251 ch.div= '/
252
253 ch.col= ':
254 ch.smc= ';
255 ch.lab= '<
256 ch.equ= '=
257 ch.rab= '>
258 ch.qm= '?
259
260 ch.ind= '@
261 ch.bsl= '\
262 ch.uar= '^
263
264 let.a= 'a&^c40
265 let.b= 'b&^c40
266 let.c= 'c&^c40
267 let.d= 'd&^c40
268 let.e= 'e&^c40
269 let.f= 'f&^c40
270 let.g= 'g&^c40
271 let.o= 'o&^c40
272 let.p= 'p&^c40
273 let.r= 'r&^c40
274 let.z= 'z&^c40
275
276 dig.0= '0
277 dig.9= '9
278 .macro ch.mne
279 .endm ch.mne
280 .endm ch.mne
281
282 .macro error num,arg, mess ,?x
283 sdebug <num>
284 .globl err.'arg,ern'num, errbts,errref
285 .if b <mess>
286 deliberate error mistake
287 .endc
288 .if dif 0,num
289 .globl err.xx
290 tst err.xx
291 bne x
292 mov #ern'num,err.xx
293 x:
294 .endc
295 bis #err.'arg,errbts
296 .endm
297
298
299
300 .macro setnz addr ;set addr to non-zero for t/f flags
301 mov sp,addr
302 .endm
303
304
305 .macro bisbic arg ; used by .list/.nlist, .enabl/.dsabl
306 .globl bisbic
307 mov #arg,-(sp)
308 call bisbic
309 tst (sp)+
310 .endm
310
311 ;roll handler calls
312
313 .macro search rolnum ;binary search
314 mov #rolnum,r0
315 .globl search
316 call search
317 .endm
318
319 .macro scan rolnum ;linear scan
320 mov #rolnum,r0
321 .globl scan
322 call scan
323 .endm
324
325 .macro scanw rolnum ;linear scan, one word
326 mov #rolnum,r0
327 .globl scanw
328 call scanw
329 .endm
330
331 .macro next rolnum ;fetch next entry
332 mov #rolnum,r0
333 .globl next
334 call next
335 .endm
336
337 .macro append rolnum ;append to end of roll
338 mov #rolnum,r0
339 .globl append
340 call append
341 .endm
342
343 .macro zap rolnum ;clear roll
344 mov #rolnum,r0
345 .globl zap
346 call zap
347 .endm
348
349 ; call insert ;insert (must be preceded by one
350 ;of the above to set pointers)
351 ; call setrol ;save and set regs for above
351
352 ;flags used in symbol table mode
353
354 .macro st.flg
355
356 .if le ft.unx
357
358 ovrflg= 000004 ;overlay (psect only)
359 defflg= 000010 ;defined
360 relflg= 000040 ;relocatable
361 glbflg= 000100 ;global
362 dfgflg= 000200 ; default global <rsx11d>... reeds's guess
363
364
365 .endc
366
367 .if gt ft.unx
368
369 ; ****** these should not be changed!! ******
370 shrflg= 000001 ;shareable (psect only)
371 .if gt ft.id
372 insflg= shrflg*2 ;instruction space (psect only)
373 bssflg= insflg*2 ;blank section (psect only)
374 m.idf= shrflg!insflg!bssflg ;mask to turn them off
375 .iff
376 bssflg= shrflg*2
377 m.idf= shrflg!bssflg
378 .endc
379 b.idf= 1 ;shift count to make above bits word offset
380 ; ***********************************
381 defflg= 000010 ;defined
382 ovrflg= 000020 ;overlay (psect only)
383 relflg= 000040 ;relocatable
384 glbflg= 000100 ;global
385 dfgflg= 000200 ; default global <rsx11d>... reeds's guess
386
387 .endc
388
389 ;
390 ; default psect attribs.
391 ; can be changed, but make sure all customers know about
392 ; it, including all the linkers.
393 ;
394 pattrs=relflg!defflg ; For .psects and blank .csects
395 aattrs=glbflg!defflg!ovrflg ; For .asect
396 cattrs=glbflg!relflg!defflg!ovrflg ; For named .csects
397
398 regflg= 000001 ;register
399 lblflg= 000002 ;label
400 mdfflg= 000004 ;multilpy defined
401 .macro st.flg
402 .endm
403 .endm st.flg
404
405
406
407 .macro ct.mne
408 .globl cttbl
409 ct.eol = 000 ; eol
410 ct.com = 001 ; comma
411 ct.tab = 002 ; tab
412 ct.sp = 004 ; space
413 ct.pcx = 010 ; printing character
414 ct.num = 020 ; numeric
415 ct.alp = 040 ; alpha, dot, dollar
416 ct.lc = 100 ; lower case alpha
417 ct.smc = 200 ; semi-colon (sign bit)
418
419 ct.pc = ct.com!ct.smc!ct.pcx!ct.num!ct.alp
420 .macro ct.mne
421 .endm ct.mne
422 .endm ct.mne
423
424
425 .end
425
7 .include "2.11BSD/m11/fltg.m11"
1 .title fltg
2
3 .ident /27dec3/
4
5 .mcall (at)always,xmit,genedt,error
6 .mcall (at)sdebug,ndebug
7 000000 always
1
2 .macro .data
3 entsec .data
4 .endm .data
5
6 .macro .text
7 entsec .text
8 .endm
9
10 .macro .bss
11 entsec .bss
12 .endm
13
14 000001 mk.symbol=1 ;one to make symbols, 0 otherwise
15 000000 x40= 0
16 000000 pdpv45= 0 ; host machine has 'mul', 'div', sob' instrucs.
17 ; if not you will have to write macros for them
18 000007 $timdf= 7 ; California Time Zone
19 ; should really use ftime(2) for this and for
20 ; DST.
21 ;xfltg= 0 ;define to assmbl out floating hardware
22 000000 rsx11d = 0 ; rsx11d features
23 000000 debug = 0 ; <<< REEDS if non zero includes debug junk
24
25 000001 ft.id= 1 ;have set i & d. set =0 if not
26
27 000001 ft.unx = 1 ; this macro-11 is for UNIX. =0 if not.
28
29 .nlist bex
30
31 000011 tab= 11
32 000012 lf= 12
33 000013 vt= 13
34 000014 ff= 14
35 000015 cr= 15
36 000040 space= 40
37
38 000020 bpmb = 20 ;bytes per macro block
39
40
41
42
43
./2.11BSD/m11/fltg.m11:7->ALWAYS:44: ***ERROR Unknown flag SHR given to .PSECT directive
44 .psect .text con, shr, gbl,ins
./2.11BSD/m11/fltg.m11:7->ALWAYS:45: ***ERROR Unknown flag DAT given to .PSECT directive
45 .psect .data con, dat, prv, gbl
./2.11BSD/m11/fltg.m11:7->ALWAYS:46: ***ERROR Unknown flag BSS given to .PSECT directive
46 .psect .bss con, bss, gbl
47
./2.11BSD/m11/fltg.m11:7->ALWAYS:48: ***ERROR Unknown flag DAT given to .PSECT directive
48 .psect dpure con, dat, prv, gbl
./2.11BSD/m11/fltg.m11:7->ALWAYS:49: ***ERROR Unknown flag PRV given to .PSECT directive
49 .psect mixed con, prv, gbl
./2.11BSD/m11/fltg.m11:7->ALWAYS:50: ***ERROR Unknown flag DAT given to .PSECT directive
50 .psect errmes con, dat, prv, gbl
./2.11BSD/m11/fltg.m11:7->ALWAYS:51: ***ERROR Unknown flag BSS given to .PSECT directive
51 .psect impure con, bss, gbl
./2.11BSD/m11/fltg.m11:7->ALWAYS:52: ***ERROR Unknown flag BSS given to .PSECT directive
52 .psect imppas con, bss, gbl
./2.11BSD/m11/fltg.m11:7->ALWAYS:53: ***ERROR Unknown flag BSS given to .PSECT directive
53 .psect implin con, bss, gbl
./2.11BSD/m11/fltg.m11:7->ALWAYS:54: ***ERROR Unknown flag DAT given to .PSECT directive
54 .psect swtsec con, dat, prv, gbl ; unix command line flags
./2.11BSD/m11/fltg.m11:7->ALWAYS:55: ***ERROR Unknown flag DAT given to .PSECT directive
55 .psect cndsec con, dat, prv, gbl ; gt, le, equ, etc. for '.if'
./2.11BSD/m11/fltg.m11:7->ALWAYS:56: ***ERROR Unknown flag DAT given to .PSECT directive
56 .psect crfsec con, dat, prv, gbl ; args for -cr flag
./2.11BSD/m11/fltg.m11:7->ALWAYS:57: ***ERROR Unknown flag DAT given to .PSECT directive
57 .psect edtsec con, dat, prv, gbl ; args for .enabl
./2.11BSD/m11/fltg.m11:7->ALWAYS:58: ***ERROR Unknown flag DAT given to .PSECT directive
58 .psect lctsec con, dat, prv, gbl ; args for .list
./2.11BSD/m11/fltg.m11:7->ALWAYS:59: ***ERROR Unknown flag DAT given to .PSECT directive
59 .psect psasec con, dat, prv, gbl
./2.11BSD/m11/fltg.m11:7->ALWAYS:60: ***ERROR Unknown flag DAT given to .PSECT directive
60 .psect pstsec con, dat, prv, gbl
./2.11BSD/m11/fltg.m11:7->ALWAYS:61: ***ERROR Unknown flag DAT given to .PSECT directive
61 .psect rolbas con, dat, prv, gbl ; core allocation: starts of tables
./2.11BSD/m11/fltg.m11:7->ALWAYS:62: ***ERROR Unknown flag DAT given to .PSECT directive
62 .psect rolsiz con, dat, prv, gbl ; sizes of table entries
./2.11BSD/m11/fltg.m11:7->ALWAYS:63: ***ERROR Unknown flag DAT given to .PSECT directive
63 .psect roltop con, dat, prv, gbl ; tops of tables
./2.11BSD/m11/fltg.m11:7->ALWAYS:64: ***ERROR Unknown flag BSS given to .PSECT directive
64 .psect xpcor con,bss , gbl ; this one MUST come last in core
65
66
67
68 .macro entsec name ;init a section
69 .psect name con
70 .endm entsec
71
72
73
74 .macro jeq x,?fred
75 bne fred
76 jmp x
77 fred:
78 .endm
79 .macro jne x,?fred
80 beq fred
81 jmp x
82 fred:
83 .endm
84 .macro xitsec
85 entsec .text
86 .endm xitsec
87
88
89 .macro call address
90 jsr pc,address
91 .endm
92
93 .macro return
94 rts pc
95 .endm
96
97
98 .macro always
99 .nlist bex
100 .endm always
8
9 .globl savreg, abstrm, chrpnt, cpopj, cradix
10 .globl getchr, getnb, mode
11 .globl setnb, stcode, tstarg, value
12 .globl edmask, ed.fpt
13
14
15 .if ndf xfltg
16
17 .globl flt2, flt4, fltg1w
18
19 000000 xitsec ;start in default sector
1 000000 entsec .text
1 000000 .psect .text con
20
21
22 000000 005203 flt4: inc r3
23 flt2:
24 000002 005203 inc r3 ;make it 1 or 2
25 000004 006303 asl r3 ;now 2 or 4
26 000006 fp.1: call tstarg
1 000006 004767 000000G jsr pc,tstarg
27 000012 001440 beq fp.9
28 000014 016346 177776' mov fltpnt-2(r3),-(sp) ;evaluate number
29 000020 call @(sp)+
1 000020 004736 jsr pc,@(sp)+
30 000022 001024 bne fp.2 ;branch if non-null
31 000024 error 9,a,<empty floating point number> ; null, flag error
1 000024 sdebug <9>
1 .globl sdebug,..z,..zbuf
2 000000 x = 0
3 .irpc t,<9>
4 movb #''t,..zbuf+x
5 x = x+1
6 .endm
1 000024 112767 000071 000000G movb #'9,..zbuf+x
2 000001 x = x+1
7 000032 112767 000000 000001G movb #0,..zbuf+x
8 000040 012767 000000G 000000G mov #..zbuf,..z
9 000046 call sdebug
1 000046 004767 000000G jsr pc,sdebug
2 .globl err.a,ern9, errbts,errref
3 .if b <empty floating point number>
4 deliberate error mistake
5 .endc
6 .if dif 0,9
7 .globl err.xx
8 000052 005767 000000G tst err.xx
9 000056 001003 bne 32768$
10 000060 012767 000000G 000000G mov #ern9,err.xx
11 32768$:
12 .endc
13 000066 052767 000000G 000000G bis #err.a,errbts
32 000074 010302 fp.2: mov r3,r2 ;get a working count
33 000076 012701 000010' mov #fltbuf,r1 ;point to floating point buffer
34 000102 012114 3$: mov (r1)+,(r4) ;move in next number
35 000104 call stcode ;place on code roll
1 000104 004767 000000G jsr pc,stcode
36 000110 077204 sob r2,3$ ;loop on word count
37 000112 000735 br fp.1 ;continue
38
39 000114 fp.9: return
1 000114 000207 rts pc
40
41 000116 entsec dpure
1 000000 .psect dpure con
42 000000 000122' 000116' fltpnt: .word fltg2w, fltg4w
43 000004 xitsec
1 000004 entsec .text
1 000116 .psect .text con
44
45 .if ndf xedfpt
46 000116 genedt fpt ;floating point truncation
1 000116 entsec edtsec
1 000000 .psect edtsec con
2 000000 024024 .rad50 /fpt/
3 .if nb
4 .word
5 .iff
6 000002 000000G .word cpopj
7 .endc
8 000004 000000G .word ed.fpt
9 000006 xitsec
1 000006 entsec .text
1 000116 .psect .text con
47 .endc
48
48
49 000116 005267 000000' fltg4w: inc fltwdc ;floating point number evaluator
50 000122 005267 000000' fltg2w: inc fltwdc
51 fltg1w:
52 000126 call savreg ;save registers
1 000126 004767 000000G jsr pc,savreg
53 000132 016746 000000G mov chrpnt,-(sp) ;stack current character pointer
54 000136 012703 000010' mov #fltbuf,r3 ;convenient copy of pointers
55 000142 012704 000020' mov #fltsav,r4 ; to buffer and save area
56 000146 010401 mov r4,r1
57 000150 005041 1$: clr -(r1) ;init variables
58 000152 020127 000000' cmp r1,#fltbeg
59 000156 101374 bhi 1$ ;loop until done
60 000160 012767 000101 000006' mov #65.,fltbex ;init binary exponent
61 000166 022705 000053 cmp #'+,r5 ; "+"?
62 000172 001406 beq 10$ ; yes, bypass and ignore
63 000174 022705 000055 cmp #'-,r5 ; "-"?
64 000200 001005 bne 11$ ; no
65 000202 012767 100000 000000' mov #100000,fltsgn ;yes, set sign and bypass char
66 000210 10$: call getchr ;get the next character
1 000210 004767 000000G jsr pc,getchr
67 000214 020527 000060 11$: cmp r5,#'0 ;numeric?
68 000220 103431 blo 20$
69 000222 020527 000071 cmp r5,#'9
70 000226 101026 bhi 20$ ; no
71 000230 032713 174000 bit #174000,(r3) ;numeric, room for multiplication?
72 000234 001403 beq 12$ ; yes
73 000236 005267 000004' inc fltexp ;no, compensate for the snub
74 000242 000413 br 13$
75
76 000244 12$: call fltm50 ;multiply by 5
1 000244 004767 000660 jsr pc,fltm50
77 000250 call fltgls ;correction, make that *10
1 000250 004767 000730 jsr pc,fltgls
78 000254 162705 000060 sub #'0,r5 ;make absolute
79 000260 010402 mov r4,r2 ;point to end of buffer
80 000262 060542 add r5,-(r2) ;add in
81 000264 005542 adc -(r2) ;ripple carry
82 000266 005542 adc -(r2)
83 000270 005542 adc -(r2)
84 000272 066767 000002' 000004' 13$: add fltdot,fltexp ;decrement if processing fraction
85 000300 005016 clr (sp) ;clear initial char pointer (we're good)
86 000302 000742 br 10$ ;try for more
87
88 000304 022705 000056 20$: cmp #'.,r5 ;decimal point?
89 000310 001003 bne 21$ ; no
90 000312 005167 000002' com fltdot ;yes, mark it
91 000316 100734 bmi 10$ ;loop if first time around
92 000320 022705 000105 21$: cmp #105,r5 ;exponent?(routine is passed upper case)
93 000324 001015 bne fltg3 ; no
94 000326 call getnb ;yes, bypass "e" and blanks
1 000326 004767 000000G jsr pc,getnb
95 000332 016746 000000G mov cradix,-(sp) ;stack current radix
96 000336 012767 000012 000000G mov #10.,cradix ;set to decimal
97 000344 call abstrm ;absolute term
1 000344 004767 000000G jsr pc,abstrm
98 000350 012667 000000G mov (sp)+,cradix ;restore radix
99 000354 060067 000004' add r0,fltexp ;update exponent
100 ; br fltg3 ;fall through
100
101 000360 010301 fltg3: mov r3,r1
102 000362 012100 mov (r1)+,r0 ;test for zero
103 000364 052100 bis (r1)+,r0
104 000366 052100 bis (r1)+,r0
105 000370 052100 bis (r1)+,r0
106 000372 jeq fltgex ;exit if so
1 000372 001002 bne 32768$
2 000374 000167 000440 jmp fltgex
3 32768$:
107 000400 005767 000004' 31$: tst fltexp ;time to scale
108 000404 001461 beq fltg5 ;fini if zero
109 000406 002424 blt 41$ ;divide if .lt. zero
110 000410 021327 031426 cmp (r3),#031426 ;multiply, can we *5?
111 000414 101005 bhi 32$ ; no
112 000416 call fltm50 ;yes, multiply by 5
1 000416 004767 000506 jsr pc,fltm50
113 000422 005267 000006' inc fltbex ; and by two
114 000426 000405 br 33$
115
116 000430 32$: call fltm54 ;multiply by 5/4
1 000430 004767 000440 jsr pc,fltm54
117 000434 062767 000003 000006' add #3.,fltbex ; and by 8
118 000442 005367 000004' 33$: dec fltexp ; over 10
119 000446 000754 br 31$
120
121 000450 005367 000006' 40$: dec fltbex ;division, left justify bits
122 000454 call fltgls
1 000454 004767 000524 jsr pc,fltgls
123 000460 005713 41$: tst (r3) ;sign bit set?
124 000462 100372 bpl 40$ ; no, loop
125 000464 012746 000040 mov #16.*2,-(sp) ;16 outer, 2 inner
126 000470 call fltgrs ;shift right
1 000470 004767 000472 jsr pc,fltgrs
127 000474 call fltgsv ;place in save buffer
1 000474 004767 000520 jsr pc,fltgsv
128 000500 032716 000001 42$: bit #1,(sp) ;odd lap?
129 000504 001004 bne 43$ ; yes
130 000506 call fltgrs ;move a couple of bits right
1 000506 004767 000454 jsr pc,fltgrs
131 000512 call fltgrs
1 000512 004767 000450 jsr pc,fltgrs
132 000516 43$: call fltgrs ;once more to the right
1 000516 004767 000444 jsr pc,fltgrs
133 000522 call fltgad ;add in save buffer
1 000522 004767 000416 jsr pc,fltgad
134 000526 005316 dec (sp) ;end of loop?
135 000530 003363 bgt 42$ ; no
136 000532 005726 tst (sp)+ ;yes, prune stack
137 000534 162767 000003 000006' sub #3.,fltbex
138 000542 005267 000004' inc fltexp
139 000546 000714 br 31$
139
140 000550 005367 000006' fltg5: dec fltbex ;left justift
141 000554 call fltgls
1 000554 004767 000424 jsr pc,fltgls
142 000560 103373 bcc fltg5 ;lose one bit
143 000562 062767 000200 000006' add #200,fltbex ;set excess 128.
144 000570 003403 ble 2$ ;branch if under-flow
145 000572 105767 000007' tstb fltbex+1 ;high order zero?
146 000576 001427 beq fg53$ ; yes
147 000600 2$: error 10,n,<floating point overflow> ;no, error
1 000600 sdebug <10>
1 .globl sdebug,..z,..zbuf
2 000000 x = 0
3 .irpc t,<10>
4 movb #''t,..zbuf+x
5 x = x+1
6 .endm
1 000600 112767 000061 000000G movb #'1,..zbuf+x
2 000001 x = x+1
3 000606 112767 000060 000001G movb #'0,..zbuf+x
4 000002 x = x+1
7 000614 112767 000000 000002G movb #0,..zbuf+x
8 000622 012767 000000G 000000G mov #..zbuf,..z
9 000630 call sdebug
1 000630 004767 000000G jsr pc,sdebug
2 .globl err.n,ern10, errbts,errref
3 .if b <floating point overflow>
4 deliberate error mistake
5 .endc
6 .if dif 0,10
7 .globl err.xx
8 000634 005767 000000G tst err.xx
9 000640 001003 bne 32768$
10 000642 012767 000000G 000000G mov #ern10,err.xx
11 32768$:
12 .endc
13 000650 052767 000000G 000000G bis #err.n,errbts
148 000656 010402 fg53$: mov r4,r2 ;set to shift eight bits
149 000660 010201 mov r2,r1
150 000662 005741 tst -(r1) ;r1 is one lower than r2
151 000664 024142 4$: cmp -(r1),-(r2) ;down one word
152 000666 111112 movb (r1),(r2) ;move up a byte
153 000670 000312 swab (r2) ;beware of the inside-out pc!!
154 000672 020203 cmp r2,r3 ;end?
155 000674 001373 bne 4$
156 000676 call fltgrs ;shift one place right
1 000676 004767 000264 jsr pc,fltgrs
157 000702 006014 ror (r4) ;set high carry
158 .if ndf xedfpt
159 000704 032767 000000G 000000G bit #ed.fpt,edmask ;truncation?
160 000712 001450 beq fp57$ ; yes
161 .endc
162 000714 016702 000000' mov fltwdc,r2 ;get size count
163 000720 006302 asl r2 ;double
164 000722 001001 bne 8$ ;preset type
165 000724 005202 inc r2 ;single word
166 000726 006302 8$: asl r2 ;convert to bytes
167 000730 052762 077777 000010' bis #077777,fltbuf(r2)
168 000736 000261 sec
169 000740 005562 000010' 5$: adc fltbuf(r2)
170 000744 005302 dec r2
171 000746 005302 dec r2
172 000750 002373 bge 5$
173 000752 005713 tst (r3) ;test sign position
174 000754 100027 bpl fp57$ ;ok if positive
175 000756 6$: error 11,t,<trunctation error>
1 000756 sdebug <11>
1 .globl sdebug,..z,..zbuf
2 000000 x = 0
3 .irpc t,<11>
4 movb #''t,..zbuf+x
5 x = x+1
6 .endm
1 000756 112767 000061 000000G movb #'1,..zbuf+x
2 000001 x = x+1
3 000764 112767 000061 000001G movb #'1,..zbuf+x
4 000002 x = x+1
7 000772 112767 000000 000002G movb #0,..zbuf+x
8 001000 012767 000000G 000000G mov #..zbuf,..z
9 001006 call sdebug
1 001006 004767 000000G jsr pc,sdebug
2 .globl err.t,ern11, errbts,errref
3 .if b <trunctation error>
4 deliberate error mistake
5 .endc
6 .if dif 0,11
7 .globl err.xx
8 001012 005767 000000G tst err.xx
9 001016 001003 bne 32768$
10 001020 012767 000000G 000000G mov #ern11,err.xx
11 32768$:
12 .endc
13 001026 052767 000000G 000000G bis #err.t,errbts
176 001034 066713 000000' fp57$: add fltsgn,(r3) ;set sign, if any
177 001040 005067 000000G fltgex: clr mode ;make absolute
178 001044 005067 000000' clr fltwdc ;clear count
179 001050 011367 000000G mov (r3),value ;place first guy in value
180 001054 012600 mov (sp)+,r0 ;origional char pointer
181 001056 001403 beq 1$ ;zero (good) if any digits processed
182 001060 010067 000000G mov r0,chrpnt ;none, reset to where we came in
183 001064 005003 clr r3 ;flag as false
184 001066 010300 1$: mov r3,r0 ;set flag in r0
185 001070 000167 000000G jmp setnb ;return with non-blank
185
186 fltm54: ;*5/4
187 001074 021327 146314 cmp (r3),#146314 ;room?
188 001100 103404 blo 1$
189 001102 call fltgrs
1 001102 004767 000060 jsr pc,fltgrs
190 001106 005267 000006' inc fltbex
191 001112 1$: call fltgsv ;save in backup
1 001112 004767 000102 jsr pc,fltgsv
192 001116 call fltgrs ;scale right
1 001116 004767 000044 jsr pc,fltgrs
193 001122 call fltgrs
1 001122 004767 000040 jsr pc,fltgrs
194 001126 000406 br fltgad
195
196 fltm50: ;*5
197 001130 call fltgsv
1 001130 004767 000064 jsr pc,fltgsv
198 001134 call fltgls
1 001134 004767 000044 jsr pc,fltgls
199 001140 call fltgls
1 001140 004767 000040 jsr pc,fltgls
200
201 fltgad: ;add save buffer to fltbuf
202 001144 010402 mov r4,r2 ;point to save area
203 001146 066242 000006 1$: add 6(r2),-(r2) ;add in word
204 001152 010201 mov r2,r1 ;set for carries
205 001154 005541 2$: adc -(r1) ;add in
206 001156 103776 bcs 2$ ;continue ripple, if necessary
207 001160 020203 cmp r2,r3 ;through?
208 001162 001371 bne 1$ ; no
209 001164 return
1 001164 000207 rts pc
209
210 001166 000241 fltgrs: clc ;right shift
211 001170 010301 mov r3,r1 ;right rotate
212 001172 006021 ror (r1)+
213 001174 006021 ror (r1)+
214 001176 006021 ror (r1)+
215 001200 006021 ror (r1)+
216 001202 return
1 001202 000207 rts pc
217
218 fltgls: ;left shift
219 001204 010402 mov r4,r2
220 001206 006342 asl -(r2)
221 001210 006142 rol -(r2)
222 001212 006142 rol -(r2)
223 001214 006142 rol -(r2)
224 001216 return
1 001216 000207 rts pc
225
226 001220 010301 fltgsv: mov r3,r1 ;move fltbuf to fltsav
227 001222 010402 mov r4,r2
228 001224 xmit 4
1 .globl xmit0
2 001224 call xmit0-<4*2>
1 001224 004767 177770G jsr pc,xmit0-<4*2>
229 001230 return
1 001230 000207 rts pc
230
231
232 001232 entsec impure
1 000000 .psect impure con
233 fltbeg: ;start of floating point impure
234 000000 fltsgn: .blkw ;sign bit
235 000002 fltdot: .blkw ;decimal point flag
236 000004 fltexp: .blkw ;decimal exponent
237 000006 fltbex: .blkw 1 ;binary exponent (must preceed fltbuf)
238 000010 fltbuf: .blkw 4 ;main ac
239 000020 fltsav: .blkw 4
240
241 000030 entsec implin
1 000000 .psect implin con
242 000000 fltwdc: .blkw ;word count
243
244 000002 xitsec
1 000002 entsec .text
1 001232 .psect .text con
245
246
247 .endc
248
249 .end
249
250
250
7
Symbol table
$TIMDF = 000007 32768$3 000400R L 002 EDMASK = ****** G FLTG2W 000122R 002 FT.UNX = 000001
. 001232R 002 32768$4 000650R L 002 ERN10 = ****** G FLTG3 000360R 002 GETCHR = ****** G
..Z = ****** G 32768$5 001026R L 002 ERN11 = ****** G FLTG4W 000116R 002 GETNB = ****** G
..ZBUF = ****** G 33$3 000442R L 002 ERN9 = ****** G FLTG5 000550R 002 LF = 000012
1$2 000150R L 002 4$5 000664R L 002 ERR.A = ****** G FLTGAD 001144R 002 MK.SYM = 000001
1$6 001066R L 002 40$3 000450R L 002 ERR.N = ****** G FLTGEX 001040R 002 MODE = ****** G
1$7 001112R L 002 41$3 000460R L 002 ERR.T = ****** G FLTGLS 001204R 002 PDPV45 = 000000
1$8 001146R L 002 42$3 000500R L 002 ERR.XX = ****** G FLTGRS 001166R 002 RSX11D = 000000
10$2 000210R L 002 43$3 000516R L 002 ERRBTS = ****** G FLTGSV 001220R 002 SAVREG = ****** G
11$2 000214R L 002 5$5 000740R L 002 ERRREF = ****** G FLTM50 001130R 002 SDEBUG = ****** G
12$2 000244R L 002 6$5 000756R L 002 FF = 000014 FLTM54 001074R 002 SETNB = ****** G
13$2 000272R L 002 8$5 000726R L 002 FG53$ 000656R 002 FLTPNT 000000R 005 SPACE = 000040
2$4 000600R L 002 ABSTRM = ****** G FLT2 000002RG 002 FLTSAV 000020R 008 STCODE = ****** G
2$8 001154R L 002 BPMB = 000020 FLT4 000000RG 002 FLTSGN 000000R 008 TAB = 000011
20$2 000304R L 002 CHRPNT = ****** G FLTBEG 000000R 008 FLTWDC 000000R 010 TSTARG = ****** G
21$2 000320R L 002 CPOPJ = ****** G FLTBEX 000006R 008 FP.1 000006R 002 VALUE = ****** G
3$1 000102R L 002 CR = 000015 FLTBUF 000010R 008 FP.2 000074R 002 VT = 000013
31$3 000400R L 002 CRADIX = ****** G FLTDOT 000002R 008 FP.9 000114R 002 X = 000002
32$3 000430R L 002 DEBUG = 000000 FLTEXP 000004R 008 FP57$ 001034R 002 X40 = 000000
32768$0 000066R L 002 ED.FPT = ****** G FLTG1W 000126RG 002 FT.ID = 000001 XMIT0 = ****** G
Program sections:
. ABS. 000000 000 (RW,I,GBL,ABS,OVR,NOSAV)
000000 001 (RW,I,LCL,REL,CON,NOSAV)
.TEXT 001232 002 (RW,I,LCL,REL,CON,NOSAV)
.DATA 000000 003 (RW,I,LCL,REL,CON,NOSAV)
.BSS 000000 004 (RW,I,LCL,REL,CON,NOSAV)
DPURE 000004 005 (RW,I,LCL,REL,CON,NOSAV)
MIXED 000000 006 (RW,I,LCL,REL,CON,NOSAV)
ERRMES 000000 007 (RW,I,LCL,REL,CON,NOSAV)
IMPURE 000030 008 (RW,I,LCL,REL,CON,NOSAV)
IMPPAS 000000 009 (RW,I,LCL,REL,CON,NOSAV)
IMPLIN 000002 010 (RW,I,LCL,REL,CON,NOSAV)
SWTSEC 000000 011 (RW,I,LCL,REL,CON,NOSAV)
CNDSEC 000000 012 (RW,I,LCL,REL,CON,NOSAV)
CRFSEC 000000 013 (RW,I,LCL,REL,CON,NOSAV)
EDTSEC 000006 014 (RW,I,LCL,REL,CON,NOSAV)
LCTSEC 000000 015 (RW,I,LCL,REL,CON,NOSAV)
PSASEC 000000 016 (RW,I,LCL,REL,CON,NOSAV)
PSTSEC 000000 017 (RW,I,LCL,REL,CON,NOSAV)
ROLBAS 000000 018 (RW,I,LCL,REL,CON,NOSAV)
ROLSIZ 000000 019 (RW,I,LCL,REL,CON,NOSAV)
ROLTOP 000000 020 (RW,I,LCL,REL,CON,NOSAV)
XPCOR 000000 021 (RW,I,LCL,REL,CON,NOSAV)
Reference in New Issue View Git Blame Copy Permalink