BMUG Revelations

home *** CD-ROM | disk | FTP | other *** search

/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Float source / fpI⁄O < prev next >

Wrap

Text File | 1993-01-27 | 13.5 KB | 367 lines | [TEXT/YERK]

\ FPI/O -- floating-point I/O support for 68000 SANE engine. \ 5/11/85 ssg Version 1.0 \ 9/26/85 cbd Modified for float heap, removed minor methods \ 2/07/86 gdc Added words atof and f.r, changed eprint to eprint, printxyz \ 8/16/86 cdn Eliminated finit & Stringer shorten \ 5/26/91 rfl Eliminated Stringer class altogether. \ 10/26/91 rfl abs in front of /mod \ 12/17/92 rfl fixed a few problems that might occur due to not locking handles \ 01/26/93 rfl protect parse: to reject a possible float if 2 decimal points are mistakenly \ adjacent. The case of " 1.234.56" is interpreted as an integer Decimal \ Some useful constants 256 constant neg 0 constant pos 256 constant FixedDecimal 0 constant FloatDecimal 0 value topxyz \ top of string being converted to float sCon zeros "000000000000000000000000000000000000000000000000000000000000000000000000000" :CLASS FPI/O <Super Object \ SANE Record Decimal ( x:= (-1)^sgn * 10^exp * SigDig ) INT sgn \ sign; 0=pos, 256=neg INT exp \ as if decimal point were to the right of SigDig 22 BYTES SigDig \ to fake string[20] ; 22 to make even \ SANE Record DecForm INT style \ Float=0; Fixed=256 INT digits \ # of sig digits,if float; # dec. places,if fixed. BasicStr outStr \ to hold formatted output string BasicStr expStr \ to hold formatted exponent string String floater \ to hold number for makefloat var places \ number of places to right of dec. pt. 2 BYTES scratch BasicStr char \ scratch character ( -- ) :M CLEAR: addr: sgn 26 erase clear: outStr clear: expstr clear: floater clear: char ;M ( -- ) \ Initialize strings etc. :M INIT: new: outStr new: expStr new: floater new: char clear: self ;M ( -- ) :M EINIT: clear: self FloatDecimal put: style 19 put: digits ;M ( -- ) \ Initialize for fixed conversion :M FINIT: clear: self FixedDecimal put: style ;M ( -- ) \ Puts a zero in decimal record :M ZERO: clear: self $ 0130 addr: sigDig w! ;M ( -- float ) \ ==== attempt to convert decimal to a float; :M DEC2FLOAT: { \ flt -- flt } abs: sgn \ Addr of decimal record new: fltMem -> flt flt 2+ +base \ Absolute Destination address $ 0009 \ FFEXT FOD2B + -- Opcode for decimal to binary; dest=extended fp68k flt \ Call FP68K ;M ( float -- ) \ ==== convert float to decimal ==== \ :M FLOAT2DEC: { flt -- } abs: style \ Absolute Addr of Decform record flt 2+ +base \ Absolute Addr of source abs: sgn \ Absolute Addr of Decimal record $ 000b \ FFEXT FOB2D + -- Opcode for binary to decimal; source=extended fp68k flt fdrop \ Call FP68K, dispose of float ;M ( width -- ) \ Set up float for in decimal record in scientific format, \ left-justified in a field of width characters. :M PRINTXYZ: { flag1 width \ expn flag -- EXPSTR OUTSTR flag } false -> flag get: sgn neg = IF ascii - ELSE bl THEN addr: sigDig count drop \ addr -- c@ CASE ascii 0 flag1 or OF emit " 0.E+0 " type width 7 - spaces ENDOF ascii I OF emit " Infinity " type width 10 - spaces ENDOF ascii N OF emit width 14 > IF " Not a number " type width 14 - spaces ELSE " NaN " type width 5 - spaces THEN ENDOF ( default ) flag1 IF 26 -> width THEN true -> flag swap +: outstr \ prefix with sign determined in first line ascii E +: expstr get: exp get: digits 1- + dup abs -> expn 0< IF ascii - ELSE ascii + THEN +: expStr \ put in sign of exponent BEGIN 2 moveto: expStr expn abs 10 /mod -> expn $ 30 + addr: scratch c! addr: scratch 1 insert: expStr expn not UNTIL bl +: expstr addr: sigDig count add: outStr \ Copy Sigdig to outStr 2 moveto: outStr ascii . addr: scratch c! addr: scratch 1 insert: outStr \ Put in decimal pt. ENDCASE flag ;M :M EPRINT: { width -- } false width printxyz: self IF ( flag from printxyz ) get: expStr dup \ addr len len -- width swap - 3 max 19 min \ addr len trlen -- get: outstr drop swap type type THEN ;M ( -- char t OR f ) \ does basicstr next for suppressing 0's :M NEXT0: { -- char t / f } next: floater next: floater drop ascii . = IF drop drop false ELSE where: floater 1- moveto: floater THEN ;M \ Converts an e. type float into a normal float \ without an E. :M MAKEFLOAT: { width decimal \ dot exp -- floater } size: expstr 1- setSize: expstr 2 moveto: expstr 0 next: expstr BEGIN WHILE ascii 0 - + 10 * next: expstr \ find size of exponent REPEAT 10 / -> exp zeros put: floater \ create initial floater lock: outStr get: outstr 1- swap 1+ swap add: floater unlock: outStr zeros add: floater 0 moveto: floater ascii . charof: floater drop -> dot \ find location of dot " ." delete: floater \ drop dot 1 moveto: expstr next: expstr drop ascii - = \ find sign of exponent IF dot exp - \ - exponent ELSE dot exp + \ + exponent THEN dup -> dot moveto: floater " ." insert: floater \ put new dot place dot decimal + get: floater drop + dup put: places BEGIN \ round off decimals c@ ascii 4 > \ if last digit is less then 5 then truncate IF get: places c@ ascii 9 > \ if carry then set digit to 0 IF ascii 0 clear: char +: char get: places get: floater drop - moveto: floater 1 substr: floater get: char replace: floater THEN get: places 1- dup dot get: floater drop + = \ check for dot IF 1- THEN dup put: places c@ 1+ clear: char +: char \ add one to digit get: places get: floater drop - moveto: floater \ insert digit 1 substr: floater get: char replace: floater get: places c@ ascii 9 > \ if there is a carry IF \ do next left digit true ELSE false THEN ELSE false THEN WHILE get: places REPEAT get: floater drop dot decimal + \ drop excess right digits put: floater 32 +: floater \ add space at end size: floater width - 0 0 moveto: floater \ drop excess left digits BEGIN 2dup <> WHILE next: floater drop ascii 0 = IF 1+ ELSE swap drop dup THEN REPEAT swap drop size: floater over - over moveto: floater substr: floater put: floater drop 0 moveto: floater 0 next0: self \ suppress leading 0's BEGIN WHILE ascii 0 = IF 1+ next0: self ELSE false THEN REPEAT dup size: floater over - swap moveto: floater substr: floater put: floater 0 moveto: floater \ add sign at front get: sgn neg = IF " -" ELSE " " THEN insert: floater 0 moveto: floater 0 \ add spaces for suppressed 0's DO " " insert: floater LOOP ;M \ Carry out f.r :M FLOATOUT: { width decimal -- } 129 width printxyz: self IF ( flag from printxyz ) width 1- decimal 1+ makefloat: self print: floater THEN ;M ( addr -- beg end dot ee t ) \ If float found; ie, decimal pt. found ( addr -- f ) \ If no decimal pt. found :M PARSE: { addr \ beg end dot ee numdec -- beg end dot ee t | f } \ ==== Parse for decimal pt. ==== \ false addr count over + dup -> topxyz swap 0 -> numDec DO ic@ ascii . = IF i -> dot i 1+ c@ ascii . <> IF drop true THEN leave THEN LOOP \ bool -- IF 1 ++> addr \ Process sign pos put: sgn addr c@ dup ascii - = IF 1 ++> addr neg put: sgn THEN ascii + = IF 1 ++> addr THEN \ ==== Skip 0's and '.'; ==== \ BEGIN addr c@ dup ascii 0 = swap ascii . = or WHILE 1 ++> addr REPEAT addr -> beg \ addr of putative leading sig digit \ ==== Test for zero ==== \ topxyz beg <= beg c@ dup dup ascii e = swap ascii E = rot bl = or or or IF -2 -> ee true \ signal that float is zero ELSE \ ==== Parse for 'E' or end of string ==== \ false -> ee ee not \ Use ee as a flag now BEGIN addr topxyz - land WHILE 1 ++> addr addr c@ CASE \ Test for blank or e; true -> ee if found bl OF -1 -> ee ENDOF ascii e OF addr -> ee ENDOF ascii E OF addr -> ee ENDOF ENDCASE ee not \ Loop flag REPEAT \ ==== Parse from end of string for last sig digit ==== \ BEGIN -1 ++> addr addr c@ dup ascii 0 = swap ascii . = or WHILE REPEAT addr -> end \ ===== Test for valid chars ===== \ true \ Innocent till proven guilty end 1+ beg DO ic@ 10 digit \ Are chars honest decimal digits? IF drop ELSE i dot <> \ Was it other than a decimal point? IF drop false leave THEN THEN LOOP THEN IF beg end dot ee true ELSE false THEN ELSE false THEN ;M ( addr -- flt t OR f ) \ Converts string to float \ Returns true if float converted successfully :M ATOF: { addr \ beg end dot ee esign -- flt t OR f } clear: self addr count swap drop 21 < \ Disqualify if longer than 20 chars IF addr parse: self IF -> ee -> dot -> end -> beg \ ==== Process exponent ==== \ 1 -> esign \ Innocent until proven guilty ee -2 = \ Zero? IF zero: self \ put a zero in decimal record ELSE ee -1 <> \ If scientific notation used IF 1 ++> ee \ Advance past 'E' ee c@ dup ascii - = IF 1 ++> ee -1 -> esign THEN ascii + = IF 1 ++> ee THEN ee -> addr \ ee to contain exponent now 0 -> ee BEGIN addr topxyz - IF addr c@ 10 digit ELSE false THEN WHILE ee 10 * + -> ee 1 ++> addr REPEAT ELSE 0 -> ee THEN ee esign * dot end - dup 0> IF 2- ELSE 1- THEN + -> ee ee put: exp \ ==== copy digit string to SigDig ==== \ 1 -> ee \ Use ee as counter end 1+ beg DO i dot <> \ Copy unless decimal point IF ic@ addr: sigDig ee + c! 1 ++> ee THEN LOOP ee addr: sigDig c! \ Store count byte THEN dec2float: self \ attempt conversion to float fdup float2dec: self \ reconvert to confirm addr: sigDig 1+ c@ dup dup ascii I = swap ascii N = rot ascii ? = or or IF fdrop false \ conversion unsuccessful ELSE true \ Success! THEN ELSE false THEN ELSE false THEN ;M ;Class fpi/o floati/o \ The default fpi/o object init: floati/o ( width -- ) ( flt -- ) \ Print a float in scientific format in a field of width chars. : e.r { flt width -- } einit: floati/o flt float2dec: floati/o width eprint: floati/o ; ( flt -- ) \ Print a float in scientific format. : e. 26 e.r ; ( addr len -- fval T ) \ Successful \ Converts a relative str255 string ( addr len -- F ) \ Unsuccessful \ into a floating point number. : atof { addr len -- fval T / F } addr len str255 -base atof: floati/o ; ( flt width decimal -- ) \ Print a float without exponents, in a field of \ width wide and of decimal places : f.r { flt width decimal -- } einit: floati/o flt float2dec: floati/o width decimal floatout: floati/o ;