Ultrix-3.1/src/ucb/m11/fltg.m11
;//////////////////////////////////////////////////////////////////////
;/ Copyright (c) Digital Equipment Corporation 1984, 1985, 1986. /
;/ All Rights Reserved. /
;/ Reference "/usr/src/COPYRIGHT" for applicable restrictions. /
;//////////////////////////////////////////////////////////////////////
.title fltg
.ident /27dec3/
.mcall (at)always,xmit,genedt,error
.mcall (at)sdebug,ndebug
always
.globl savreg, abstrm, chrpnt, cpopj, cradix
.globl getchr, getnb, mode
.globl setnb, stcode, tstarg, value
.globl edmask, ed.fpt
.if ndf xfltg
.globl flt2, flt4, fltg1w
xitsec ;start in default sector
flt4: inc r3
flt2:
inc r3 ;make it 1 or 2
asl r3 ;now 2 or 4
fp.1: call tstarg
beq fp.9
mov fltpnt-2(r3),-(sp) ;evaluate number
call @(sp)+
bne fp.2 ;branch if non-null
error 9,a,<empty floating point number> ; null, flag error
fp.2: mov r3,r2 ;get a working count
mov #fltbuf,r1 ;point to floating point buffer
3$: mov (r1)+,(r4) ;move in next number
call stcode ;place on code roll
sob r2,3$ ;loop on word count
br fp.1 ;continue
fp.9: return
entsec dpure
fltpnt: .word fltg2w, fltg4w
xitsec
.if ndf xedfpt
genedt fpt ;floating point truncation
.endc
fltg4w: inc fltwdc ;floating point number evaluator
fltg2w: inc fltwdc
fltg1w:
call savreg ;save registers
mov chrpnt,-(sp) ;stack current character pointer
mov #fltbuf,r3 ;convenient copy of pointers
mov #fltsav,r4 ; to buffer and save area
mov r4,r1
1$: clr -(r1) ;init variables
cmp r1,#fltbeg
bhi 1$ ;loop until done
mov #65.,fltbex ;init binary exponent
cmp #'+,r5 ; "+"?
beq 10$ ; yes, bypass and ignore
cmp #'-,r5 ; "-"?
bne 11$ ; no
mov #100000,fltsgn ;yes, set sign and bypass char
10$: call getchr ;get the next character
11$: cmp r5,#'0 ;numeric?
blo 20$
cmp r5,#'9
bhi 20$ ; no
bit #174000,(r3) ;numeric, room for multiplication?
beq 12$ ; yes
inc fltexp ;no, compensate for the snub
br 13$
12$: call fltm50 ;multiply by 5
call fltgls ;correction, make that *10
sub #'0,r5 ;make absolute
mov r4,r2 ;point to end of buffer
add r5,-(r2) ;add in
adc -(r2) ;ripple carry
adc -(r2)
adc -(r2)
13$: add fltdot,fltexp ;decrement if processing fraction
clr (sp) ;clear initial char pointer (we're good)
br 10$ ;try for more
20$: cmp #'.,r5 ;decimal point?
bne 21$ ; no
com fltdot ;yes, mark it
bmi 10$ ;loop if first time around
21$: cmp #105,r5 ;exponent?(routine is passed upper case)
bne fltg3 ; no
call getnb ;yes, bypass "e" and blanks
mov cradix,-(sp) ;stack current radix
mov #10.,cradix ;set to decimal
call abstrm ;absolute term
mov (sp)+,cradix ;restore radix
add r0,fltexp ;update exponent
; br fltg3 ;fall through
fltg3: mov r3,r1
mov (r1)+,r0 ;test for zero
bis (r1)+,r0
bis (r1)+,r0
bis (r1)+,r0
jeq fltgex ;exit if so
31$: tst fltexp ;time to scale
beq fltg5 ;fini if zero
blt 41$ ;divide if .lt. zero
cmp (r3),#031426 ;multiply, can we *5?
bhi 32$ ; no
call fltm50 ;yes, multiply by 5
inc fltbex ; and by two
br 33$
32$: call fltm54 ;multiply by 5/4
add #3.,fltbex ; and by 8
33$: dec fltexp ; over 10
br 31$
40$: dec fltbex ;division, left justify bits
call fltgls
41$: tst (r3) ;sign bit set?
bpl 40$ ; no, loop
mov #16.*2,-(sp) ;16 outer, 2 inner
call fltgrs ;shift right
call fltgsv ;place in save buffer
42$: bit #1,(sp) ;odd lap?
bne 43$ ; yes
call fltgrs ;move a couple of bits right
call fltgrs
43$: call fltgrs ;once more to the right
call fltgad ;add in save buffer
dec (sp) ;end of loop?
bgt 42$ ; no
tst (sp)+ ;yes, prune stack
sub #3.,fltbex
inc fltexp
br 31$
fltg5: dec fltbex ;left justift
call fltgls
bcc fltg5 ;lose one bit
add #200,fltbex ;set excess 128.
ble 2$ ;branch if under-flow
tstb fltbex+1 ;high order zero?
beq fg53$ ; yes
2$: error 10,n,<floating point overflow> ;no, error
fg53$: mov r4,r2 ;set to shift eight bits
mov r2,r1
tst -(r1) ;r1 is one lower than r2
4$: cmp -(r1),-(r2) ;down one word
movb (r1),(r2) ;move up a byte
swab (r2) ;beware of the inside-out pc!!
cmp r2,r3 ;end?
bne 4$
call fltgrs ;shift one place right
ror (r4) ;set high carry
.if ndf xedfpt
bit #ed.fpt,edmask ;truncation?
beq fp57$ ; yes
.endc
mov fltwdc,r2 ;get size count
asl r2 ;double
bne 8$ ;preset type
inc r2 ;single word
8$: asl r2 ;convert to bytes
bis #077777,fltbuf(r2)
sec
5$: adc fltbuf(r2)
dec r2
dec r2
bge 5$
tst (r3) ;test sign position
bpl fp57$ ;ok if positive
6$: error 11,t,<trunctation error>
fp57$: add fltsgn,(r3) ;set sign, if any
fltgex: clr mode ;make absolute
clr fltwdc ;clear count
mov (r3),value ;place first guy in value
mov (sp)+,r0 ;origional char pointer
beq 1$ ;zero (good) if any digits processed
mov r0,chrpnt ;none, reset to where we came in
clr r3 ;flag as false
1$: mov r3,r0 ;set flag in r0
jmp setnb ;return with non-blank
fltm54: ;*5/4
cmp (r3),#146314 ;room?
blo 1$
call fltgrs
inc fltbex
1$: call fltgsv ;save in backup
call fltgrs ;scale right
call fltgrs
br fltgad
fltm50: ;*5
call fltgsv
call fltgls
call fltgls
fltgad: ;add save buffer to fltbuf
mov r4,r2 ;point to save area
1$: add 6(r2),-(r2) ;add in word
mov r2,r1 ;set for carries
2$: adc -(r1) ;add in
bcs 2$ ;continue ripple, if necessary
cmp r2,r3 ;through?
bne 1$ ; no
return
fltgrs: clc ;right shift
mov r3,r1 ;right rotate
ror (r1)+
ror (r1)+
ror (r1)+
ror (r1)+
return
fltgls: ;left shift
mov r4,r2
asl -(r2)
rol -(r2)
rol -(r2)
rol -(r2)
return
fltgsv: mov r3,r1 ;move fltbuf to fltsav
mov r4,r2
xmit 4
return
entsec impure
fltbeg: ;start of floating point impure
fltsgn: .blkw ;sign bit
fltdot: .blkw ;decimal point flag
fltexp: .blkw ;decimal exponent
fltbex: .blkw 1 ;binary exponent (must preceed fltbuf)
fltbuf: .blkw 4 ;main ac
fltsav: .blkw 4
entsec implin
fltwdc: .blkw ;word count
xitsec
.endc
.end