File:  [gforth] / gforth / fsl-util.4th
Revision 1.1: download - view: text, annotated - select for diffs
Sat May 8 17:14:30 2004 UTC (15 years, 5 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added fsl-util.4th (IIRC from Kryshna Myeni)
made F.S output nicer and moved it from float.fs to stuff.fs
added CLEARSTACKS
exceptions caught by QUIT now clear the stacks (instead of resetting them to
  the depth when first entering QUIT)

    1: \ fsl-utilg.fth      An auxiliary file for the Forth Scientific Library
    2: \                    For GForth
    3: \
    4: \                       contains commonly needed definitions.
    5: \ Revisions:
    6: \	2003-11-16      Fixed bug in }}, added }}FCOPY  KM
    7: \	2004-02-12	Applied fixes to } and }} given by Marcel Hendrix
    8: \
    9: \ dxor, dor, dand       double xor, or, and
   10: \ sd*                   single * double = double_product
   11: \ v: defines use( &     For defining and settting execution vectors
   12: \ %                     Parse next token as a FLOAT
   13: \ S>F  F>S              Conversion between (single) integer and float
   14: \ F,                    Store FLOAT at (aligned) HERE
   15: \ F=                    Test for floating point equality
   16: \ -FROT                 Reverse the effect of FROT
   17: \ F2*  F2/              Multiply and divide float by two
   18: \ F2DUP                 FDUP two floats
   19: \ F2DROP                FDROP two floats
   20: \ INTEGER, DOUBLE, FLOAT   For setting up ARRAY types
   21: \ ARRAY DARRAY              For declaring static and dynamic arrays
   22: \ }                         For getting an ARRAY or DARRAY element address
   23: \ &!                        For storing ARRAY aliases in a DARRAY
   24: \ PRINT-WIDTH               The number of elements per line for printing arrays
   25: \ }FPRINT                   Print out a given array
   26: \ Matrix                    For declaring a 2-D array
   27: \ }}                        gets a Matrix element address
   28: \ Public: Private: Reset_Search_Order   controls the visibility of words
   29: \ frame unframe             sets up/removes a local variable frame
   30: \ a b c d e f g h           local FVARIABLE values
   31: \ &a &b &c &d &e &f &g &h   local FVARIABLE addresses
   32: 
   33: 
   34: \ This code conforms with ANS requiring:
   35: \     	1. The Floating-Point word set
   36: \       2. The words umd* umd/mod and d* are implemented
   37: \          for ThisForth in the file umd.fo
   38: 
   39: \ This code is released to the public domain Everett Carter July 1994
   40: 
   41: \ CR .( FSL-UTILG.FTH    $Revision: 1.1 $       $Date: 2004/05/08 17:14:30 $   EFC )
   42: 
   43: CR .( FSL-UTIL          V1.17c        12 February 2004  EFC, KM )
   44: 
   45: \ ================= compilation control ==============================
   46: 
   47: \ for control of conditional compilation of test code
   48: FALSE VALUE TEST-CODE?
   49: FALSE VALUE ?TEST-CODE          \ obsolete, for backward compatibility
   50: 
   51: 
   52: \ for control of conditional compilation of Dynamic memory
   53: TRUE CONSTANT HAS-MEMORY-WORDS?
   54: 
   55: \ ====================================================================
   56: 
   57: 
   58: 
   59: \ FSL NonANS words
   60: 
   61: : S>F    S>D D>F ;
   62: 
   63: \ Words to control nested includes.  Use as follows:
   64: \ C" filename" ~INCLUDED [IF]
   65: \ FILE: filename
   66: \ ......the file contents...
   67: \ [THEN]
   68: 
   69: TRUE VALUE verbose_file?       \ true to echo comment string on load
   70: 
   71: WORDLIST CONSTANT <file-list>
   72: 
   73: \ file name in <file-list>
   74: : FILE:   <file-list> SET-CURRENT CREATE  FORTH DEFINITIONS
   75:         [CHAR] ) WORD
   76: 	verbose_file? IF COUNT DUP IF CR TYPE ELSE 2DROP THEN
   77: 	              ELSE DROP THEN
   78: ;
   79: 
   80: \ check for included file name
   81: : ~INCLUDED  COUNT <file-list> SEARCH-WORDLIST
   82:              IF DROP FALSE ELSE TRUE THEN
   83: ;
   84: 
   85: 
   86: WORDLIST CONSTANT hidden-wordlist
   87: 
   88: : Reset-Search-Order
   89: 	FORTH-WORDLIST 1 SET-ORDER
   90: 	FORTH-WORDLIST SET-CURRENT
   91: ;
   92: 
   93: : Public:
   94: 	FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
   95: 	FORTH-WORDLIST SET-CURRENT
   96: ;
   97: 
   98: : Private:
   99: 	FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
  100: 	hidden-wordlist SET-CURRENT
  101: ;
  102: 
  103: : Reset_Search_Order   Reset-Search-Order ;     \ these are
  104: \ : reset-search-order   Reset-Search-Order ;	\ for backward compatibility
  105: 
  106: 
  107: CREATE fsl-pad	84 CHARS ( or more ) ALLOT
  108: 
  109: : dxor       ( d1 d2 -- d )             \ double xor
  110: 	ROT XOR >R XOR R>
  111: ;
  112: 
  113: : dor       ( d1 d2 -- d )              \ double or
  114: 	ROT OR >R OR R>
  115: ;
  116: 
  117: : dand     ( d1 d2 -- d )               \ double and
  118: 	ROT AND >R AND R>
  119: ;
  120: 
  121: \ : >=     < 0= ;                        \ greater than or equal to
  122: 
  123: \ : <=       > 0= ;                        \ less than or equal to
  124: 
  125: \ single * double = double
  126: : sd*   ( multiplicand  multiplier_double  -- product_double  )
  127:              2 PICK * >R   UM*   R> +
  128: ;
  129: 
  130: 
  131: : CELL-    [ 1 CELLS ] LITERAL - ;           \ backup one cell
  132: 
  133: 
  134: 0 VALUE TYPE-ID               \ for building structures
  135: FALSE VALUE STRUCT-ARRAY?
  136: 
  137: \ for dynamically allocating a structure or array
  138: 
  139: TRUE  VALUE is-static?     \ TRUE for statically allocated structs and arrays
  140: : dynamic ( -- )     FALSE TO is-static? ;
  141: 
  142: \ size of a regular integer
  143: 1 CELLS CONSTANT INTEGER
  144: 
  145: \ size of a double integer
  146: 2 CELLS CONSTANT DOUBLE
  147: 
  148: \ size of a regular float
  149: \ 1 FLOATS CONSTANT FLOAT
  150: 
  151: \ size of a pointer (for readability)
  152: 1 CELLS CONSTANT POINTER
  153: 
  154: : % BL WORD COUNT >FLOAT 0= ABORT" NAN"
  155:                   STATE @ IF POSTPONE FLITERAL THEN ; IMMEDIATE
  156:                   
  157: \ 3.1415926536E0 FCONSTANT PI
  158: 1.0E0 FCONSTANT F1.0
  159: 
  160: \ 1-D array definition
  161: \    -----------------------------
  162: \    | cell_size | data area     |
  163: \    -----------------------------
  164: 
  165: : MARRAY ( n cell_size -- | -- addr )             \ monotype array
  166:      CREATE
  167:        DUP , * ALLOT
  168:      DOES> CELL+
  169: ;
  170: 
  171: \    -----------------------------
  172: \    | id | cell_size | data area |
  173: \    -----------------------------
  174: 
  175: : SARRAY ( n cell_size -- | -- id addr )          \ structure array
  176:      CREATE
  177:        TYPE-ID ,
  178:        DUP , * ALLOT
  179:      DOES> DUP @ SWAP [ 2 CELLS ] LITERAL +
  180: ;
  181: 
  182: : ARRAY
  183:      STRUCT-ARRAY? IF   SARRAY FALSE TO STRUCT-ARRAY?
  184:                    ELSE MARRAY
  185:                    THEN
  186: ;
  187: 
  188: 
  189: \ : Array   ARRAY ;
  190: 
  191: \ word for creation of a dynamic array (no memory allocated)
  192: 
  193: \ Monotype
  194: \    ------------------------
  195: \    | data_ptr | cell_size |
  196: \    ------------------------
  197: 
  198: : DMARRAY   ( cell_size -- )  CREATE  0 , ,
  199:                               DOES>
  200:                                     @ CELL+
  201: ;
  202: 
  203: \ Structures
  204: \    ----------------------------
  205: \    | data_ptr | cell_size | id |
  206: \    ----------------------------
  207: 
  208: : DSARRAY   ( cell_size -- )  CREATE  0 , , TYPE-ID ,
  209:                               DOES>
  210:                                     DUP [ 2 CELLS ] LITERAL + @ SWAP
  211:                                     @ CELL+
  212: ;
  213: 
  214: 
  215: : DARRAY   ( cell_size -- )
  216:      STRUCT-ARRAY? IF   DSARRAY FALSE TO STRUCT-ARRAY?
  217:                    ELSE DMARRAY
  218:                    THEN
  219: ;
  220: 
  221: 
  222: \ word for aliasing arrays,
  223: \  typical usage:  a{ & b{ &!  sets b{ to point to a{'s data
  224: 
  225: : &!    ( addr_a &b -- )
  226:         SWAP CELL- SWAP >BODY  !
  227: ;
  228: 
  229: 
  230: : }   ( addr n -- addr[n])       \ word that fetches 1-D array addresses
  231:           OVER CELL-  @
  232:           * SWAP + ( ALIGNED FALIGNED )
  233: 	  \        ^^^^^^ commented out per bug fix of Marcel Hendrix 2/12/04
  234: ;
  235: 
  236: VARIABLE print-width      6 print-width !
  237: 
  238: : }fprint ( n addr -- )       \ print n elements of a float array
  239:         SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
  240:                   DUP I } F@ F. LOOP
  241:         DROP
  242: ;
  243: 
  244: : }iprint ( n addr -- )       \ print n elements of an integer array
  245:         SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
  246:                   DUP I } @ . LOOP
  247:         DROP
  248: ;
  249: 
  250: : }fcopy ( 'src 'dest n -- )         \ copy one array into another
  251: 
  252:      0 DO
  253:                 OVER I } F@
  254:                 DUP  I } F!
  255:           LOOP
  256: 
  257:           2DROP
  258: ;
  259: 
  260: \ 2-D array definition,
  261: 
  262: \ Monotype
  263: \    ------------------------------
  264: \    | m | cell_size |  data area |
  265: \    ------------------------------
  266: 
  267: : MMATRIX  ( n m size -- )           \ defining word for a 2-d matrix
  268:         CREATE
  269:            OVER , DUP ,
  270:            * * ALLOT
  271:         DOES>  [ 2 CELLS ] LITERAL +
  272: ;
  273: 
  274: \ Structures
  275: \    -----------------------------------
  276: \    | id | m | cell_size |  data area |
  277: \    -----------------------------------
  278: 
  279: : SMATRIX  ( n m size -- )           \ defining word for a 2-d matrix
  280:         CREATE TYPE-ID ,
  281:            OVER , DUP ,
  282:            * * ALLOT
  283:         DOES>  DUP @ TO TYPE-ID
  284:                [ 3 CELLS ] LITERAL +
  285: ;
  286: 
  287: 
  288: : MATRIX  ( n m size -- )           \ defining word for a 2-d matrix
  289:      STRUCT-ARRAY? IF   SMATRIX FALSE TO STRUCT-ARRAY?
  290:                    ELSE MMATRIX
  291:                    THEN
  292: 
  293: ;
  294: 
  295: 
  296: : DMATRIX ( size -- )      DARRAY ;
  297: 
  298: 
  299: : }}    ( addr i j -- addr[i][j] )    \ word to fetch 2-D array addresses
  300:                \ 2>R                    \ indices to return stack temporarily
  301: 	       \ ^^^ above is bug in v1.17; replaced with line below  KM
  302: 	       >R >R
  303:                DUP CELL- CELL- 2@     \ &a[0][0] size m
  304:                R> * R> + *
  305:                +
  306:                ( ALIGNED FALIGNED ) \ <-- MH bug fix 2/12/04
  307: ;
  308: 
  309: 
  310: : }}fprint ( n m addr -- )       \ print nXm elements of a float 2-D array
  311:         ROT ROT SWAP 0 DO
  312:                          DUP 0 DO
  313:                                   OVER J I  }} F@ F.
  314:                          LOOP
  315: 
  316:                          CR
  317:                   LOOP
  318:         2DROP
  319: ;
  320: 
  321: 
  322: : }}fcopy ( 'src 'dest n m  -- )      \ copy nm elements of 2-D array src to dest
  323:         SWAP 0 DO
  324:                  DUP 0 DO
  325:                             2 PICK J I  }} F@
  326:                             OVER   J I  }} F!
  327:                         LOOP
  328:                   LOOP
  329:         DROP 2DROP
  330: ;
  331: 
  332: 
  333: \ function vector definition
  334: 
  335: \ : noop ; 
  336: 
  337: : v: CREATE ['] noop , DOES> @ EXECUTE ;
  338: : defines   ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE !
  339:                             ELSE ! THEN ;   IMMEDIATE
  340: 
  341: : use(  STATE @ IF POSTPONE ['] ELSE ' THEN ;  IMMEDIATE
  342: : &     POSTPONE use( ; IMMEDIATE
  343: 
  344: 
  345: 
  346: (
  347:   CODE for local fvariables, loosely based upon Wil Baden's idea presented
  348:   at FORML 1992.
  349:   The idea is TO have a fixed number OF variables with fixed names.
  350:   I believe the CODE shown HERE will work with any, CASE insensitive,
  351:   ANS Forth.
  352: 
  353:   i/tForth users are advised TO use FLOCALS| instead.
  354: 
  355:   example:  : test  2e 3e FRAME| a b |  a F. b F. |FRAME ;
  356:             test <cr> 3.0000 2.0000 ok
  357: 
  358:   PS: Don't FORGET TO use |FRAME before an EXIT .
  359: )
  360: 
  361: 8 CONSTANT /flocals
  362: 
  363: : (frame) ( n -- ) FLOATS ALLOT ;
  364: 
  365: : FRAME|
  366:         0 >R
  367:         BEGIN   BL WORD  COUNT  1 =
  368:                 SWAP C@  [CHAR] | =
  369:                 AND 0=
  370:         WHILE   POSTPONE F,  R> 1+ >R
  371:         REPEAT
  372:         /FLOCALS R> - DUP 0< ABORT" too many flocals"
  373:         POSTPONE LITERAL  POSTPONE (frame) ; IMMEDIATE
  374: 
  375: : |FRAME ( -- ) [ /FLOCALS NEGATE ] LITERAL (FRAME) ;
  376: 
  377: : &h            HERE [ 1 FLOATS ] LITERAL - ;
  378: : &g            HERE [ 2 FLOATS ] LITERAL - ;
  379: : &f            HERE [ 3 FLOATS ] LITERAL - ;
  380: : &e            HERE [ 4 FLOATS ] LITERAL - ;
  381: : &d            HERE [ 5 FLOATS ] LITERAL - ;
  382: : &c            HERE [ 6 FLOATS ] LITERAL - ;
  383: : &b            HERE [ 7 FLOATS ] LITERAL - ;
  384: : &a            HERE [ 8 FLOATS ] LITERAL - ;
  385: 
  386: : a             &a F@ ;
  387: : b             &b F@ ;
  388: : c             &c F@ ;
  389: : d             &d F@ ;
  390: : e             &e F@ ;
  391: : f             &f F@ ;
  392: : g             &g F@ ;
  393: : h             &h F@ ;
  394: 
  395: \ stuff from jvn-util.fo
  396: 
  397: : FINIT ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>