Path: utzoo!mnetor!uunet!cbmvax!vu-vlsi!cheung From: cheung@vu-vlsi.UUCP (Wilson Cheung) Newsgroups: comp.sys.amiga Subject: JFORTH Message-ID: <1333@vu-vlsi.UUCP> Date: 2 Feb 88 17:20:26 GMT Organization: Villanova Univ. EE Dept. Lines: 304 Keywords: ALTERNATE "F." ROUTINE Here is an alternate FFP number printint routine. Since it depends upon some string manipulators that don't exist on JFORTH I have included some string manipulators. ( * Following Code written by Wilson Cheung 1/6/88 * ) ( * If you come up with any cleanups or addons please send them back * ) ( * UUCP: vu-vlsi!cheung * ) ( * I had to include some string utilities because again JFORTH didn't * ) ( * have them !!!! * ) INCLUDE? { JU:LOCALS \ ********************************************************************** \ Additions or modifications to JFORTHs string handlers \ ********************************************************************** : BETWEEN { N X Y ---- X<=N<=Y } N Y <= N X >= AND ; : ISEQUIVALENTO CREATE , DOES> @ ; : <=> ISEQUIVALENTO ; .NEED C, : C, ( byte -- , compile into dictionary ) dp @ c! ( always use an even number of these!! ) 1 dp +! ; .ELSE .THEN \ ********************************************************************** \ String manipulators and definers. Note that a string variable here \ consists of a maxcount byte preceding the normal FORTH string of a \ count byte followed by the string. This format since potentially \ incompatible ,opens up bugs, with external string functions remeding \ this situation is highly desireable ,if LFA should ever emerge this \ shouldn't be any problem. \ ********************************************************************** : STRING CREATE DUP C, 0 C, ALLOT DOES> 1+ ; 64 STRING BUFFER : $VAL ( N ---- STR ) 0 <# #S #> DUP ROT BUFFER 1+ ROT CMOVE BUFFER C! BUFFER ; : .$ ( STR --- ) COUNT TYPE ; : $LEN ( STR --- CURRENTLENTH ) C@ ; : $SIZE ( STR --- MAXIMUMLENGTH ) DUP PAD = IF DROP 64 ELSE 1- C@ THEN ; : $FREESPACE ( STR --- UNUSEDSPACE ) DUP $SIZE SWAP $LEN - ; : $ENDSPACE ( STR --- POSITION OF LAST CHAR ) DUP $LEN + ; : $CLR ( STR --- ) 0 SWAP C! ; : $CONCAT { STR1 STR2 --- STR1+STR2 } STR1 $LEN STR2 $LEN + STR1 $SIZE > IF STR1 $SIZE STR1 STR2 1+ STR1 $ENDSPACE 1+ STR1 $FREESPACE CMOVE C! ELSE STR1 $LEN STR2 $LEN + STR1 STR2 1+ STR1 $ENDSPACE 1+ STR2 $LEN CMOVE C! THEN ( ----------- ) ; DECIMAL VARIABLE EXTRASPACE : $RIGHTALIGN ( STR FieldWidth --- ) { STR FW --- } FW STR $LEN - DUP 0> IF EXTRASPACE ! STR 1+ EXTRASPACE @ STR + 1+ STR $LEN CMOVE> STR 1+ EXTRASPACE @ 32 FILL FW STR C! ELSE DROP THEN ; : VAL ( STR ---- N ) NUMBER ( **** WARNING HAS ITS OWN ERROR TRAPPING **** ) ; ( *** You may be able to do without the above String definitions *** ) ( *** My routines depend upon them *** ) VARIABLE DECEXPONENT VARIABLE BINEXPONENT HEX 80000000 CONSTANT BIT31 DECIMAL : D->S DROP ; : MUL10 ( N --- N*10 ) 10 U* D->S ; : DIV10 ( N --- N/10 ) 0 10 U/ SWAP DROP ; : DOWNGRADE ( CONVERTS BASE 2 WITH POSITIVE EXPONENT TO DECIMAL FLOAT ) { MANTISSA BINEXP --- } BEGIN MANTISSA DIV10 -> MANTISSA 1 DECEXPONENT +! BEGIN MANTISSA U2* -> MANTISSA BINEXP 1 - -> BINEXP MANTISSA BIT31 AND BINEXP 0= OR UNTIL BINEXP 0= UNTIL MANTISSA ; : U16/ U2/ U2/ U2/ U2/ ; : U16* U2* U2* U2* U2* ; : UPGRADE { MANTISSA BINEXP --- } MANTISSA U16/ -> MANTISSA BEGIN MANTISSA MUL10 -> MANTISSA -1 DECEXPONENT +! BEGIN MANTISSA U2/ -> MANTISSA BINEXP 1 + -> BINEXP MANTISSA [ HEX ] F0000000 AND 0= BINEXP 0= OR UNTIL BINEXP 0= UNTIL MANTISSA [ HEX ] F0000000 AND IF MANTISSA DIV10 -> MANTISSA 1 DECEXPONENT +! THEN [ DECIMAL ] MANTISSA U16* ; VARIABLE MANTISSA : CONVERTFFPTOBASE10 ( FFP# --- MANTISSA DECIMALEXPONENT SIGN ) ( var val val ) 0 0 { FFP# SIGN BINEXPONENT --- } FFP# [ HEX ] 00000080 AND -> SIGN FFP# 0000007F AND [ DECIMAL ] 64 - -> BINEXPONENT FFP# [ HEX ] FFFFFF00 AND 0 DECEXPONENT ! BINEXPONENT 0> IF BINEXPONENT DOWNGRADE ELSE BINEXPONENT 0< IF BINEXPONENT UPGRADE THEN THEN U16/ MANTISSA ! MANTISSA SIGN DECEXPONENT @ ; : 268435456/ ( PERFORMS UNSIGNED DIV ) [ HEX ] U16/ U16/ U16/ U16/ U16/ U16/ U16/ F AND ; : FFP# ( mantissavariable ---- newmantissavariable digit ) ( produces first ffp digit leaves mantissa on stack for additional convertion ) dup @ [ HEX ] A * dup [ HEX ] fffffff and swap [ DECIMAL ] 268435456/ swap ROT ! ; : ZEROUT ( var --- ) 0 SWAP ! ; VARIABLE CARRY DECIMAL 30 CARRAY NUMBUFFER : ADDBCD ( byte literal --- ) ( Bvar val --- ) { BYT LITERAL --- } BYT C@ LITERAL + DUP 9 > IF [ DECIMAL ] 10 - 1 CARRY ! ELSE CARRY ZEROUT THEN BYT C! ; : MANTISSATO"BCD" ( MANTISSA SIGFIGURES --- ) ( var val ) { MANTISSA SIGFIGURES --- } SIGFIGURES 1+ 0 DO MANTISSA FFP# I NUMBUFFER C! LOOP ( ROUNDOFF ) SIGFIGURES NUMBUFFER 5 ADDBCD SIGFIGURES 1+ 1 DO CARRY @ 0= IF LEAVE ELSE SIGFIGURES I - NUMBUFFER CARRY @ ADDBCD THEN LOOP ; 5 STRING EXPONENTSTRING : CREATEXPONENT ( EXP --- ) EXPONENTSTRING $CLR EXPONENTSTRING " E" $CONCAT DUP 0< IF EXPONENTSTRING " -" $CONCAT NEGATE THEN EXPONENTSTRING SWAP $VAL $CONCAT ; VARIABLE SIGFIG VARIABLE EFFECTIVE_FW : SCIENTIFIC { STR Mantissa sign Exp Fw decpls --- } ( var var val val val val ---- ) [ DECIMAL ] STR $CLR FW STR $SIZE MIN EFFECTIVE_FW ! SIGN 0= NOT IF STR " -" $CONCAT -1 EFFECTIVE_FW +! THEN EXP CREATEXPONENT ( IN EXPONENTSTRING ) EFFECTIVE_FW @ EXPONENTSTRING $LEN - EFFECTIVE_FW ! EFFECTIVE_FW @ DECPLS 1+ MIN SIGFIG ! SIGFIG @ 0> IF MANTISSA SIGFIG @ MANTISSATO"BCD" SIGFIG @ 0 DO 1 I = IF STR " ." $CONCAT THEN STR I NUMBUFFER C@ $VAL $CONCAT LOOP STR EXPONENTSTRING $CONCAT ELSE STR $CLR STR " FORMAT ERROR" $CONCAT THEN ; : FREEFORMAT { STR Mantissa sign Exp Fw decpls --- } ( var var val val val val ---- ) [ DECIMAL ] STR $CLR EXP -1 9 BETWEEN IF FW STR $SIZE MIN EFFECTIVE_FW ! SIGN 0= NOT IF STR " -" $CONCAT -1 EFFECTIVE_FW +! THEN EXP 0= IF STR " 0" $CONCAT -1 EFFECTIVE_FW +! THEN -1 EFFECTIVE_FW +! EFFECTIVE_FW @ EXP DECPLS + MIN SIGFIG ! SIGFIG @ 0> EXP 0 SIGFIG @ BETWEEN AND IF MANTISSA SIGFIG @ MANTISSATO"BCD" SIGFIG @ 0 DO EXP I = IF STR " ." $CONCAT THEN STR I NUMBUFFER C@ $VAL $CONCAT LOOP ELSE STR $CLR STR " FORMAT ERROR" $CONCAT THEN ELSE STR MANTISSA SIGN EXP FW DECPLS SCIENTIFIC THEN ; ( This word takes an FFP number and produces text that meet the criteria ) ( of the Fieldwidth, decimal places and mode and places that text ) ( in the supplied string ) : $FFP { STR FFPNUM FIELDWIDTH DECPLACES MODE --- } MODE 0 1 BETWEEN IF STR FFPNUM CONVERTFFPTOBASE10 FIELDWIDTH DECPLACES MODE CASE 1 OF SCIENTIFIC ENDOF 0 OF FREEFORMAT ENDOF ENDCASE ELSE STR $CLR " INVALID MODE FOR $FFP" $CONCAT THEN ; DECIMAL VARIABLE FW VARIABLE DECPL VARIABLE MODE 0 MODE ! 20 FW ! 6 DECPL ! 80 STRING TEMPSTRING : FFP. { FFPNUMBER --- } TEMPSTRING FFPNUMBER FW @ DECPL @ MODE @ $FFP TEMPSTRING .$ ; ( *** This last word can be used like F. *** ) ( *** full around with the variables FW, DECPL, and MODE *** ) ( *** MODE: 1 Scientific, 0 Freeformat *** ) ( *** FW: FieldWidth, DECPL: Decimal Places *** )