File:  [gforth] / gforth / fsl-util.4th
Revision 1.2: download - view: text, annotated - select for diffs
Sun Jun 1 12:18:23 2008 UTC (11 years, 4 months ago) by dbane
Branches: MAIN
CVS tags: v0-7-0, HEAD
S>F is already defined in prim

    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.2 $       $Date: 2008/06/01 12:18:23 $   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: [UNDEFINED] S>F [IF] : S>F    S>D D>F ; [THEN]
   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>