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

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: 
        !            41: \ CR .( FSL-UTILG.FTH    $Revision:   1.17  $       $Date:   12 Jun 1996 10:13:12  $   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>