1: .title fltg 2: 3: .ident /27dec3/ 4: 5: .mcall (at)always,xmit,genedt,error 6: .mcall (at)sdebug,ndebug 7: 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: xitsec ;start in default sector 20: 21: 22: flt4: inc r3 23: flt2: 24: inc r3 ;make it 1 or 2 25: asl r3 ;now 2 or 4 26: fp.1: call tstarg 27: beq fp.9 28: mov fltpnt-2(r3),-(sp) ;evaluate number 29: call @(sp)+ 30: bne fp.2 ;branch if non-null 31: error 9,a,<empty floating point number> ; null, flag error 32: fp.2: mov r3,r2 ;get a working count 33: mov #fltbuf,r1 ;point to floating point buffer 34: 3$: mov (r1)+,(r4) ;move in next number 35: call stcode ;place on code roll 36: sob r2,3$ ;loop on word count 37: br fp.1 ;continue 38: 39: fp.9: return 40: 41: entsec dpure 42: fltpnt: .word fltg2w, fltg4w 43: xitsec 44: 45: .if ndf xedfpt 46: genedt fpt ;floating point truncation 47: .endc 48: 49: fltg4w: inc fltwdc ;floating point number evaluator 50: fltg2w: inc fltwdc 51: fltg1w: 52: call savreg ;save registers 53: mov chrpnt,-(sp) ;stack current character pointer 54: mov #fltbuf,r3 ;convenient copy of pointers 55: mov #fltsav,r4 ; to buffer and save area 56: mov r4,r1 57: 1$: clr -(r1) ;init variables 58: cmp r1,#fltbeg 59: bhi 1$ ;loop until done 60: mov #65.,fltbex ;init binary exponent 61: cmp #'+,r5 ; "+"? 62: beq 10$ ; yes, bypass and ignore 63: cmp #'-,r5 ; "-"? 64: bne 11$ ; no 65: mov #100000,fltsgn ;yes, set sign and bypass char 66: 10$: call getchr ;get the next character 67: 11$: cmp r5,#'0 ;numeric? 68: blo 20$ 69: cmp r5,#'9 70: bhi 20$ ; no 71: bit #174000,(r3) ;numeric, room for multiplication? 72: beq 12$ ; yes 73: inc fltexp ;no, compensate for the snub 74: br 13$ 75: 76: 12$: call fltm50 ;multiply by 5 77: call fltgls ;correction, make that *10 78: sub #'0,r5 ;make absolute 79: mov r4,r2 ;point to end of buffer 80: add r5,-(r2) ;add in 81: adc -(r2) ;ripple carry 82: adc -(r2) 83: adc -(r2) 84: 13$: add fltdot,fltexp ;decrement if processing fraction 85: clr (sp) ;clear initial char pointer (we're good) 86: br 10$ ;try for more 87: 88: 20$: cmp #'.,r5 ;decimal point? 89: bne 21$ ; no 90: com fltdot ;yes, mark it 91: bmi 10$ ;loop if first time around 92: 21$: cmp #105,r5 ;exponent?(routine is passed upper case) 93: bne fltg3 ; no 94: call getnb ;yes, bypass "e" and blanks 95: mov cradix,-(sp) ;stack current radix 96: mov #10.,cradix ;set to decimal 97: call abstrm ;absolute term 98: mov (sp)+,cradix ;restore radix 99: add r0,fltexp ;update exponent 100: ; br fltg3 ;fall through 101: fltg3: mov r3,r1 102: mov (r1)+,r0 ;test for zero 103: bis (r1)+,r0 104: bis (r1)+,r0 105: bis (r1)+,r0 106: jeq fltgex ;exit if so 107: 31$: tst fltexp ;time to scale 108: beq fltg5 ;fini if zero 109: blt 41$ ;divide if .lt. zero 110: cmp (r3),#031426 ;multiply, can we *5? 111: bhi 32$ ; no 112: call fltm50 ;yes, multiply by 5 113: inc fltbex ; and by two 114: br 33$ 115: 116: 32$: call fltm54 ;multiply by 5/4 117: add #3.,fltbex ; and by 8 118: 33$: dec fltexp ; over 10 119: br 31$ 120: 121: 40$: dec fltbex ;division, left justify bits 122: call fltgls 123: 41$: tst (r3) ;sign bit set? 124: bpl 40$ ; no, loop 125: mov #16.*2,-(sp) ;16 outer, 2 inner 126: call fltgrs ;shift right 127: call fltgsv ;place in save buffer 128: 42$: bit #1,(sp) ;odd lap? 129: bne 43$ ; yes 130: call fltgrs ;move a couple of bits right 131: call fltgrs 132: 43$: call fltgrs ;once more to the right 133: call fltgad ;add in save buffer 134: dec (sp) ;end of loop? 135: bgt 42$ ; no 136: tst (sp)+ ;yes, prune stack 137: sub #3.,fltbex 138: inc fltexp 139: br 31$ 140: fltg5: dec fltbex ;left justift 141: call fltgls 142: bcc fltg5 ;lose one bit 143: add #200,fltbex ;set excess 128. 144: ble 2$ ;branch if under-flow 145: tstb fltbex+1 ;high order zero? 146: beq fg53$ ; yes 147: 2$: error 10,n,<floating point overflow> ;no, error 148: fg53$: mov r4,r2 ;set to shift eight bits 149: mov r2,r1 150: tst -(r1) ;r1 is one lower than r2 151: 4$: cmp -(r1),-(r2) ;down one word 152: movb (r1),(r2) ;move up a byte 153: swab (r2) ;beware of the inside-out pc!! 154: cmp r2,r3 ;end? 155: bne 4$ 156: call fltgrs ;shift one place right 157: ror (r4) ;set high carry 158: .if ndf xedfpt 159: bit #ed.fpt,edmask ;truncation? 160: beq fp57$ ; yes 161: .endc 162: mov fltwdc,r2 ;get size count 163: asl r2 ;double 164: bne 8$ ;preset type 165: inc r2 ;single word 166: 8$: asl r2 ;convert to bytes 167: bis #077777,fltbuf(r2) 168: sec 169: 5$: adc fltbuf(r2) 170: dec r2 171: dec r2 172: bge 5$ 173: tst (r3) ;test sign position 174: bpl fp57$ ;ok if positive 175: 6$: error 11,t,<trunctation error> 176: fp57$: add fltsgn,(r3) ;set sign, if any 177: fltgex: clr mode ;make absolute 178: clr fltwdc ;clear count 179: mov (r3),value ;place first guy in value 180: mov (sp)+,r0 ;origional char pointer 181: beq 1$ ;zero (good) if any digits processed 182: mov r0,chrpnt ;none, reset to where we came in 183: clr r3 ;flag as false 184: 1$: mov r3,r0 ;set flag in r0 185: jmp setnb ;return with non-blank 186: fltm54: ;*5/4 187: cmp (r3),#146314 ;room? 188: blo 1$ 189: call fltgrs 190: inc fltbex 191: 1$: call fltgsv ;save in backup 192: call fltgrs ;scale right 193: call fltgrs 194: br fltgad 195: 196: fltm50: ;*5 197: call fltgsv 198: call fltgls 199: call fltgls 200: 201: fltgad: ;add save buffer to fltbuf 202: mov r4,r2 ;point to save area 203: 1$: add 6(r2),-(r2) ;add in word 204: mov r2,r1 ;set for carries 205: 2$: adc -(r1) ;add in 206: bcs 2$ ;continue ripple, if necessary 207: cmp r2,r3 ;through? 208: bne 1$ ; no 209: return 210: fltgrs: clc ;right shift 211: mov r3,r1 ;right rotate 212: ror (r1)+ 213: ror (r1)+ 214: ror (r1)+ 215: ror (r1)+ 216: return 217: 218: fltgls: ;left shift 219: mov r4,r2 220: asl -(r2) 221: rol -(r2) 222: rol -(r2) 223: rol -(r2) 224: return 225: 226: fltgsv: mov r3,r1 ;move fltbuf to fltsav 227: mov r4,r2 228: xmit 4 229: return 230: 231: 232: entsec impure 233: fltbeg: ;start of floating point impure 234: fltsgn: .blkw ;sign bit 235: fltdot: .blkw ;decimal point flag 236: fltexp: .blkw ;decimal exponent 237: fltbex: .blkw 1 ;binary exponent (must preceed fltbuf) 238: fltbuf: .blkw 4 ;main ac 239: fltsav: .blkw 4 240: 241: entsec implin 242: fltwdc: .blkw ;word count 243: 244: xitsec 245: 246: 247: .endc 248: 249: .end
|
Last modified: 1982-12-11
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 1753 |
|