Annotation of gforth/fsl-util.4th, revision 1.2

1.1       anton       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: 
1.2     ! dbane      41: \ CR .( FSL-UTILG.FTH    $Revision: 1.1 $       $Date: 2004-05-08 17:14:30 $   EFC )
1.1       anton      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: 
1.2     ! dbane      61: [UNDEFINED] S>F [IF] : S>F    S>D D>F ; [THEN]
1.1       anton      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>