kim@amdahl.UUCP (Kim DeVaughn) (01/14/87)
[ "Send lawyers, guns, and money ..." (Really!) ]
Phil Burk (of Delta Research) sent me this reply concerning the recent
postings about JForth. I'm posting it for him, as he's just learning
how to use the WELL to access the net. It's really a shame if the info
he has on selling s/w in Italy is true.
/kim
vvvvvvvvvvvvvvvvvvvvvvvvvvvv from Phil vvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
Yes, Delta Research is alive and well.
I am responding to a comment that someone had trouble getting
JForth for the Amiga. This may be have been due to one of two
reasons. The Delta Research marketing effort was hampered
in December of a combination of the Holidays and
some unfortunate family emergencies. Also, inquiries from
Italy have been put on hold. This is because several international
distributors have warned us that Italy has no effective copy
protection laws. We have heard that pirates can copy software
and redistribute it FOR PROFIT and only face a $50 fine.
If anyone has information that refutes or confirms this,
please, let me know. I am on the WELL!PLBURK.
This is very unfortunate for the honest citizens of Italy
because many software vendors are reluctant to sell their
code there. We are trying to work out some legal and technical
protection schemes that would allow us to distribute in Italy.
It would probably save us money if we simply did not
distribute in Italy, but this would be very unfair
to the honest Forth/Amiga fans with whom we sympathize.
Perhaps these programmers could impress upon their government
the impact this policy has on the software industry in Italy.
We apologize for any delays that these two problems have
caused anyone. We, of course, would like to see as many people
as possible get to use JForth. We are busy negotiating with
distributors, and establishing our sales channels.
There should be nbo problem, therefore, in getting the release
version of JForth when it is ready.
In response to Kim's comments: Yes we are planning
to have an extensive index in the release version. We are also
including a tutorial, trouble-shooting tips, etc.
Our primary focus now is on improving the manual.
We are also adding support for MIDI (the Musical Instruments
Device Interface), local sound, and TURNKEY.
The final release date is planned for late February.
The pre-release version is available now, however, from Delta
Research. Free updates will be sent out to those who have this
preliminary version. See our ad in Amiga World for details.
Phil Burk, Delta Research
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
--
UUCP: {sun,decwrl,hplabs,pyramid,ihnp4,seismo,oliveb,cbosgd}!amdahl!kim
DDD: 408-746-8462
USPS: Amdahl Corp. M/S 249, 1250 E. Arques Av, Sunnyvale, CA 94086
CIS: 76535,25
[ Any thoughts or opinions which may or may not have been expressed ]
[ herein are my own. They are not necessarily those of my employer. ]cheung@vu-vlsi.UUCP (Wilson Cheung) (01/11/88)
Its been about a year since the last release of JFORTH. Has all work on JFORTH been stopped? I am very eagerly awaiting for a useable floating point package and the optimizing compiler. My version of JFORTH only supports about 4 decimal places of accuracy and often rounds off incorrectly! Wilson Cheung
rap@dana.UUCP (Rob Peck) (01/13/88)
In article <1286@vu-vlsi.UUCP>, cheung@vu-vlsi.UUCP (Wilson Cheung) writes: > > Its been about a year since the last release of JFORTH. Has all work > on JFORTH been stopped? I am very eagerly awaiting for a useable floating > point package and the optimizing compiler. My version of JFORTH only supports > about 4 decimal places of accuracy and often rounds off incorrectly! I spoke to someone (believed to be associated) with JFORTH at the most recent FAUG meeting and he said that their compiler is in beta test --- if I had an application that was just waiting for compilation, I should bring it to their offices and the'd compile it for me. He also mentioned that the floating point was fixed and for a release date, gave me the old "RSN". Rumor has it that the target compiler cuts an application typically by a factor of 4 to 5 times (30+ K rather than 150K for the group of demos on their own distribution disk). Upgrade will not be free, but will be reasonable. When upgrade happens, price of the package is expected to rise to reflect added functionality. Also rumored that Multi-FORTH price may be headed for a price increase in the near future. Disclaimer: I have no connection with the creators of JFORTH; having paid full list price directly to them at the San Francisco Amiga show about a year ago, I too am eagerly awaiting the promised target compiler and upgrade. I like FORTH and collect FORTH docs and books. Someday I might really start to use it again, I will I will (RSN) Rob Peck ...ihnp4!hplabs!dana!rap "Which way did he go George? Why the little bunny rabbit, of course." (from a not-so-recent Warner Bros. Cartoon on Bugs Bunny and Friends)
jyouells@pnet02.cts.com (John Youells) (01/13/88)
cheung@vu-vlsi.UUCP (Wilson Cheung) writes: > > Its been about a year since the last release of JFORTH. Has all work >on JFORTH been stopped? I am very eagerly awaiting for a useable floating >point package and the optimizing compiler. My version of JFORTH only supports >about 4 decimal places of accuracy and often rounds off incorrectly! > > > Wilson Cheung I have talked to Brian at Delta Research a number of times over the past couple of months about the optimizing compiler. I know that they are testing it on some soon to be released commercial products written in JForth. I hope that its available soon, the small executables would make JForth a viable developement environment for the Amiga's multitasking environment. I like JForth but without the optimizing compiler the 'turnkeyed' programs are pretty big. I keep hearing 2 or 3 months for version 2.0... I hope its soon. UUCP: {hplabs!hp-sdd!crash, cadovax}!gryphon!pnet02!jyouells INET: jyouells@pnet02.cts.com
cheung@vu-vlsi.UUCP (Wilson Cheung) (01/18/88)
Everytime I start using JFORTH I always get excited about the features explained in the manual and then become dissappointed that it doesn't work. But now its getting ridiculous! Even the simple things that are explained in the manual don't work. Take for example C,. A primitive important to have in all FORTH standards. It does not exist! I had to go searching through several include files to find out where it was defined. Then I wrote a program that depended upon strings. Again not all string functions are there as documented in the manual. Does anyone know what files I should start including to have a COMPLETE JFORTH. I don't want to waste hours searching through a bunch of files for a word that doesn't exist yet is documented in the glossary. I also don't want a 1 Meg JFORTH program by including everything in sight. Also is there anyway of redirecting all JFORTH screen output to an AmigaDos device? Wilson Cheung
zabot@cesare.dec.com (Adv.Tech.Mgr-ACT Torino) (01/20/88)
Subj: RE: JFORTH Unfortuanately you're right! Jforth promises a lot but delever a lot less! Anyway, here is something that may help you ( hopefully)! > Then I wrote a program that depended upon strings. Again not > all string functions are there as documented in the manual. The following WORDS are NOT implemented in JFORTH 1.2: $. $accum $clr $concat $ len $variable I have create my own STRINGS set with the automatic check of the legth of the receiving field. Comments are in italian, so you may also practice a little your language talent :-) Pleas enote also: the supllied $APPEND doesn't work . It always append a BLANK to the end of the receiveing field, destroing sometime important things. Summary of new WORDS: $. ( addr --- ) print $string $clr ( addr --- ) clear $string ( ll=0 ) $v equivalent of $variable usage: 20 $v name create a variable <name> with a max length of 20 crt. $m ( add-1 add-2 --- ) $move if space available $app ( add-1 add-2 --- ) $append " $array usage: 10 20 $array name create an array <name> of 10 elem ( max length 20) does> i name --> addr-i element ---- cut here ------------------ file: MY-STRINGS -------- anew task-$string : $. count type ; : $clr ( addr-1 --- , pone a zero la lungh. della stringa ) 0 swap c! ; false .if ------------------------------------------------------------------------- Le variabili STRING vengono create con controllo della lunghezza massima. Questo si ottiene premettendo sempre la lunghezza massima nel dizionario. La lunghezza massima assoluta e' 255 ( 8 bits, 1 crt ). Nel dizionario si ha: <cfa> |....| Un carattere Lunghezza-massima |....| Un carattere Lungh. Attuale |xxxxxxxx | Variabile Uso: l-max $v nome ( definizione) nome ( -- addr ) Per avere la Lungh. Max di una variable si usa $l-max ( <nome> --- l-max ) ATTENZIONE ! se la lunghezza al momento della definizione e' maggiore di 255 viene usato il valore modulo 256. I seguenti comandi effettuano la verifica sulla lunghezza del campo di arrivo. In caso di errore avviene solo la stampa di un messaggio e la operazione non ha luogo. ------------------------------------------------------------------------- .then : $v ( n --- ) ( <name> --in-- ) create dup 256 * here w! 2 + allot align does> 1+ ; : $l-max ( addr-var -- l-max ) \ Estrae la lungh. massima della variabile per controlli vari. 1- c@ ; \ WARNING !! La $append standard non funziona. Aggiunge un BLANK al fondo. \ Include? { ju:locals : $append { add-s ll add-1 } add-1 dup c@ ll + swap c! add-s add-1 c@ add-1 + ll - 1+ ll cmove ; FALSE .if \ Mettere TRUE se si vuole la versione senza variabili locali : $m ( addr-1 addr-2 --- ) \ Esegue la $move solo se c'e spazio. In caso contrario stampa \ un messaggio di errore. ( a1 a2 ) ddup ( a1 a2 a1 a2 ) $l-max ( a1 a2 a1 lm ) swap count swap drop ( a1 a2 lm c1 ) - 0< if ." Errore. Non ci sta' !" ddrop else $move then ; : $app ( addr-1 addr-2 --- ) \ Esegue la $append solo se c'e spazio. In caso contrario stampa \ un messaggio di errore. ( a1 a2 ) ddup ( a1 a2 a1 a2 ) dup $l-max ( a1 a2 a1 a2 lm ) swap count swap drop ( a1 a2 a1 lm c2 ) - swap count swap drop ( a1 a2 lm-c2 c1 ) - 0< if ." Errore. Non ci sta' !" ddrop else ( a1 a2 ) swap count ( a2 a1+1 c1 ) rot $append then ; .else \ Versione con Variabili locali. Un po' piu' di memoria ma occorrono 2.4ms in \ meno ad ogni call. : $m { addr-1 addr-2 --- } \ Esegue la $move solo se c'e spazio. In caso contrario stampa \ un messaggio di errore. addr-2 $l-max addr-1 c@ - 0< if ." Errore. Non ci sta' !" else addr-1 addr-2 $move then ; : $app { addr-1 addr-2 --- } \ Esegue la $append solo se c'e spazio. In caso contrario stampa \ un messaggio di errore. addr-2 $l-max addr-2 c@ addr-1 c@ + - 0< if ." Errore. Non ci sta' !" ddrop else addr-1 count addr-2 $append then ; .then False .if -------------------------------------------------------------------------- Matrici di variabili STRINGS. Ancora con controllo di lunghezza. Si definisce una matrice con : n-el-max l-max $array <nome> e si richiama con: n-el <nome> Viene controllato anche che il numero di elemento sia inferiore al massimo ammesso. Il primo elemento e' lo ZERO. Esempio: 10 80 $array riga 0 riga e' la prima riga 9 riga e' l'ultima riga ( 10 in totale) Struttura del dizionario: <cfa> |....| N.max. elem. |....|....| Lungh.max, lungh elem. zero |xxxxxxx| Variabile n. 0 |....|....| Lungh.max, lungh elem uno |xxxxx| Variabile n. 1 -------------------------------------------------------------------------- .then \ Ricordare che $, ( crt --- ) ( <text> --in-- ) mette nel dictionary una \ stringa con la sua lunghezza. : cc, ( crt --- ) \ Mette un crt nel dizionario. here c! 1 allot ; : $$, ( crt n --- ) \ Mette nel dizionario una stringa di 'n' caratteri 'crt' \ ATTENZIONE ! Non fa ALIGN dup cc, 0 do dup cc, loop drop ; : $array ( n-el-max l-max --- ) ( <nome> --in-- ) ( n --- addr ) ( <nome> --in-- ) create swap dup cc, 0 do 0 over $$, 0 cc, loop drop align does> count rot dup 0< if ." Errore indice negativo" ddrop drop else dup rot < if swap count 2 + rot * + else ." Errore Indice > max" ddrop then then ; -------------------end of MY_STRINGS ---------- Another thing I've done has been to create a SHELL like environment for JFORTH. The only thing so far is the HISTORY of commands issued to avoid retyping again and again the same things when prototyping something. The INTERP is a new version of STRING_INTERPRET to handle ( in some way ) at least few errors that may happen in your command line. Once again commands are in Italian. OK. Next time I'll do it in English. ------------------------ cut here ----------------- anew task-$interp : $int2 ; \ excute a string in addr cnt form ... Mike Haas, Delta Research : $INTERPRET ( string-addr string-cnt -- ???? ) 'TIB @ >r #TIB @ >r >IN @ >r FBLK @ >r BLK @ >r #TIB ! 'TIB ! >in off fblk off blk off BEGIN bl word dup c@ \ is there anything in the input stream left? WHILE find \ YES ... is it in the dictionary? IF compiling? over >name immediate? 0= and IF cfa, \ COMPILE it if in comp mode AND its not immediate ELSE execute \ otherwise, EXECUTE the thing! THEN ELSE \ if its not found in dictionary, is it a number? dup number? 0= if ." What's that ??-> " $. ." ?" else drop [compile] literal drop then THEN REPEAT \ while we did find find something, go back and check again... drop \ nothing left to EXECUTE, get rid of address on stack r> blk ! r> fblk ! r> >in ! r> #tib ! r> 'tib ! ; -----------------------next file SHELL anew task-ex .need csi hex : csi ( --- ) ( send csi to st-out ) 9b emit ; decimal .then include? $v mie-strings include? $int2 interp \ $St-mode indica lo stato del ciclo: 0 = adggiungo caratteri al fondo, \ 1 = inserisco caratteri, 2 = overstike. variable $st-mode 0 $st-mode ! ( set to adding ) variable $st-over 0 $st-over ! ( set to insert ) \ $over indica la scelta tra overstrike ( 1) e insert (0) : $over? $st-over @ ; : $ad? $st-mode @ 0= ; : $ins? $st-over @ not ; : $ov? $st-over @ ; : $ad-crt ( add-l add-c crt --- add-l add-c ) \ l = l +1 add-c = add-c +1 \ crt is inserted at the end of the string over c! swap dup dup c@ 1+ swap c! swap 1+ ; : $ins-crt { add-l add-c crt --- add-l add-c } \ l = l +1 add-c = add-c +1 \ crt is inserted \ make space first add-c dup 1+ add-l c@ add-l + add-c - 1+ cmove> \ now insert crt crt add-c c! \ move index add-c 1+ -> add-c \ update length add-l c@ 1+ add-l c! \ reset the stack add-l add-c ; : $ov-crt { add-l add-c crt --- add-l add-c } \ overwrite crt at add-c. If last crt switch $st-mode to add. crt add-c c! add-c add-l dup c@ + = if 0 $st-mode ! then add-c 1+ -> add-c add-l add-c ; : $del-crt { add-l add-c --- add-l add-c } \ delete crt at add-c abd reduce crt count add-c 1- dup 1+ swap add-l c@ add-l + add-c - 1+ cmove add-l c@ 1- add-l c! \ add-c 1- -> add-c add-l add-c ; 10 constant $hist-# 255 constant $line-ll $hist-# $line-ll $array $sh-area 255 $v $sh-line 0 variable $i-sh-store $i-sh-store ! 0 variable $i-sh-fetch $i-sh-fetch ! 80 $v $sh-prompt " F-mz-> " $sh-prompt $m variable end-loop variable end-shell variable re-fetch? : $clr-line ( --- ) csi ." M" csi ." F" csi ." E" $sh-prompt $. drop dup 0 over c! 1+ ; : $if+1 ( --- n , add 1 to i-fetch ) $i-sh-fetch @ 1+ $hist-# mod ; : $if-1 ( --- n , sub 1 to i-fetch ) $i-sh-fetch @ 1- $hist-# + $hist-# mod ; : $is+1 ( --- n , add 1 to i-fetch ) $i-sh-store @ 1+ $hist-# mod ; : $is-1 ( --- n , sub 1 to i-fetch ) $i-sh-store @ 1- $hist-# + $hist-# mod ; : $bottom? ( --- flag , verifica se siamo al bottom dello sh-area stack ) $i-sh-fetch @ $is+1 = ; : $top? ( --- flag , verifica se siamo al top dello sh-area stack ) $i-sh-fetch @ $i-sh-store @ = ; : $re-fetch ( --- add-l add-c ) \ tira fuori una riga ll <> 0 e aggiorna i-fetch e mette a punto \ il resto $clr-line $i-sh-fetch @ $sh-area dup $. $sh-line $m $sh-line dup c@ over + 1+ ; : $sh-get-line ( add --- add ) dup 0 swap c! dup 1+ ( l= 0 ;stack= add-l add-c ) 0 $st-mode ! ( set add to end ) 0 $st-over ! ( set insert mode ) FALSE end-loop ! begin ( ciclo interno = read line ) key case 155 of \ sequenza che inizia con CSI key case 65 of ( freccia su' ) $bottom? not if $if-1 $i-sh-fetch ! then re-fetch? @ not if drop $i-sh-store @ $sh-area $m true re-fetch? ! else ddrop then $re-fetch else 66 of ( freccia giu' ) $top? not if $if+1 $i-sh-fetch ! then re-fetch? @ not if drop $i-sh-store @ $sh-area $m true re-fetch? ! else ddrop then $re-fetch else 67 of ( freccia a destra ) false re-fetch? ! ddup swap - rot dup c@ rot < not >r swap r> if csi ." 1C" 1+ then else 68 of ( freccia a sinistra ) false re-fetch? ! 1- ( add-c = add-c -1 ) 8 emit ( move cursor ) $st-over @ 1 + $st-mode ! else ." Altro" endcase else 27 of ( escape = clr-line ) false re-fetch? ! $clr-line drop dup 0 over c! 1+ else 1 of $st-over @ 1 xor $st-over ! ( switch ins/over mode ) else 8 of false re-fetch? ! swap dup c@ >r swap r> if $del-crt csi ." D" csi ." 1P" then else 13 of TRUE end-loop ! ( set exit ) else 127 of false re-fetch? ! swap dup c@ >r swap r> if $ad? not if 1+ $del-crt csi ." P" then then else false re-fetch? ! $ad? if dup >r $ad-crt r> emit 2 else $ov? if dup >r $ov-crt r> emit 3 then $ins? if dup >r $ins-crt r> csi ." 1@" emit 4 then then endcase end-loop @ ( check exit ) until drop ; : shell False end-shell ! begin ( cliclo esterno = shell ) cr $sh-prompt $. $sh-line begin $sh-get-line dup c@ 0 = not until dup " quit" $= if true end-shell ! else \ Abbiamo una riga valida !! Store it ! \ ... se diversa dalla precedente dup $is-1 $sh-area $= not if dup $i-sh-store @ $sh-area $m \ Ora aggiorniamo l'indice $is+1 dup $i-sh-fetch ! $i-sh-store ! then \ esegue la stringa count $interpret then end-shell @ until drop ; : view-hist cr 10 0 do i i . $sh-area $. cr loop ; --------------------cut here----------------end of all > Take for example C,. A primitive important to have > in all FORTH standards. It does not exist! I had to go searching through > several include files to find out where it was defined. Where is it ? > Also is there anyway of redirecting all JFORTH screen output to an > AmigaDos device? LOGTO ( <filename> -- input ---, send copy to file ) seams to be what you want. I've never tried it. See man. pag. 295. Include JU:LOGTO Hope this help. marco
farren@gethen.UUCP (Michael J. Farren) (02/02/88)
In article <1315@vu-vlsi.UUCP> cheung@vu-vlsi.UUCP (Wilson Cheung) writes: > > Anyone need a better F. word for JFORTH. Well, I have an 'F-word' for FORTH in general, but I doubt you'd want to hear it :-) :-) :-) :-) :-) :-) :-) :-) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Forth fanatic flame retardants (please!) If you really want to argue about forth, my e-mail box is always open. -- Michael J. Farren | "INVESTIGATE your point of view, don't just {ucbvax, uunet, hoptoad}! | dogmatize it! Reflect on it and re-evaluate unisoft!gethen!farren | it. You may want to change your mind someday." gethen!farren@lll-winken.llnl.gov ----- Tom Reingold, from alt.flame
cheung@vu-vlsi.UUCP (Wilson Cheung) (02/03/88)
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 *** )