Annotation of gforth/fsl-util.fs, revision 1.2

1.1       pazsan      1: \ fsl-utilg.fth      An auxiliary file for the Forth Scientific Library
                      2: \                    For GForth
                      3: 
                      4: \ Contains commonly needed definitions for the FSL modules.
                      5: 
                      6: \ S>F  F>S                 conversion between (single) integer and float
                      7: \ -FROT                    reverse the effect of FROT
                      8: \ cell-                    back up one cell
                      9: \ F2DUP                    FDUP two floats
                     10: \ F2DROP                   FDROP two floats
                     11: \ PI  F1.0                 floating point constants
                     12: \ dxor, dor, dand          double xor, or, and
                     13: \ sd*                      single * double = double_product
                     14: \ %                        parse next token as a FLOAT
                     15: \ v: defines use( &        for defining and settting execution vectors
                     16: \ Public: Private: Reset_Search_Order   control the visibility of words
                     17: \ INTEGER, DOUBLE          for setting up array types
                     18: \ ARRAY DARRAY             for declaring static and dynamic arrays
                     19: \ }                        for getting an ARRAY or DARRAY element address
                     20: \ &!                       for storing ARRAY aliases in a DARRAY
                     21: \ PRINT-WIDTH              number of elements per line for printing arrays
                     22: \ }IPRINT  }FPRINT         print out integer or fp arrays
                     23: \ }FCOPY                   copy one array into another
                     24: \ }FPUT                    move values from fp stack into an array
                     25: \ MATRIX  DMATRIX          for declaring a static or dynamic 2-D array
                     26: \ }}                       gets a Matrix element address
                     27: \ }}IPRINT  }}FPRINT       print out an integer or fp matrix
                     28: \ }}FCOPY                  copy one matrix into another
                     29: \ }}FPUT                   move values from fp stack into a matrix
                     30: \ FRAME| |FRAME            set up/remove a local variable frame
                     31: \ a b c d e f g h          local FVARIABLE values
                     32: \ &a &b &c &d &e &f &g &h  local FVARIABLE addresses
                     33: \    The words  F,  F=  F2*  F2/  PI  FLOAT  are already present in Gforth
                     34: 
                     35: \ This code is released to the public domain Everett Carter July 1994
                     36: 
                     37: \ CR .( FSL-UTILG.FTH    V1.17        12 Jun 1996 10:13:12      EFC )
1.2     ! dvdkhlng   38: \ CR .(  fsl-utilg.fth     V2.0         Thursday 16 October 2008  )
1.1       pazsan     39: \    cgm:   reorganized file,
                     40: \           removed words already in Gforth,
                     41: \           Gforth DEFER and IS used for vectoring,
                     42: \           alternative definition for fp locals.
                     43: 
                     44: \ The code conforms with ANS requiring:
                     45: \   1. Words from the wordsets CORE, CORE-EXT, BLOCK-EXT, EXCEPTION-EXT,
                     46: \       FILE, FLOAT, FLOAT-EXT, LOCAL, SEARCH, SEARCH-EXT, and TOOLS-EXT
                     47: \   2. Gforth words  Defer  Alias  -rot  float  f,
                     48: \
                     49: 
                     50: BASE @ DECIMAL
                     51: 
                     52: \ ================= compilation control =============================
                     53: 
                     54: \ for control of conditional compilation of test code
                     55: FALSE VALUE TEST-CODE?
                     56: FALSE VALUE ?TEST-CODE          \ obsolete, for backward compatibility
                     57: 
                     58: \ for control of conditional compilation of Dynamic memory
                     59: TRUE CONSTANT HAS-MEMORY-WORDS?
                     60: 
                     61: \ ================= FSL NonANS words ================================
                     62: 
                     63: : -frot FROT FROT  ;
                     64: : cell-  [ 1 CELLS ] LITERAL - ;   \ back up one cell
                     65: : F2DUP   FOVER FOVER ;
                     66: : F2DROP  FDROP FDROP ;
                     67: 1.0E0 FCONSTANT F1.0
                     68: 
                     69: : dxor  ( d1 d2 -- d )  ROT XOR >R XOR R>  ;          \ double xor
                     70: : dor   ( d1 d2 -- d )  ROT OR >R OR R>    ;          \ double or
                     71: : dand  ( d1 d2 -- d )  ROT AND >R AND R>  ;          \ double and
                     72: 
                     73: : sd*   ( multiplicand multiplier_double -- product_double )
                     74:       2 PICK * >R   UM*   R> +  ;                \ single * double = double
                     75: 
                     76: : % BL WORD COUNT >FLOAT 0= ABORT" NAN"
                     77:                   STATE @ IF POSTPONE FLITERAL THEN ; IMMEDIATE
                     78: 
                     79: \ ================= function vector definition ======================
                     80: \  use Forth200x words  DEFER  and  IS  for FSL words  v: and  defines
                     81: \  defines  is already a synonym for  IS  in Gforth
                     82: 
                     83: ' Defer Alias v:
                     84: 
                     85: : use(  STATE @ IF POSTPONE ['] ELSE ' THEN ;  IMMEDIATE
                     86: : &     POSTPONE use( ; IMMEDIATE
                     87: 
                     88: \ ================= vocabulary management ===========================
                     89: 
                     90: WORDLIST CONSTANT hidden-wordlist
                     91: 
                     92: : Reset-Search-Order
                     93:         FORTH-WORDLIST 1 SET-ORDER
                     94:         FORTH-WORDLIST SET-CURRENT
                     95: ;
                     96: 
                     97: : Public:
                     98:         FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
                     99:         FORTH-WORDLIST SET-CURRENT
                    100: ;
                    101: 
                    102: : Private:
                    103:         FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
                    104:         hidden-wordlist SET-CURRENT
                    105: ;
                    106: 
                    107: : Reset_Search_Order   Reset-Search-Order ;     \ for backward compatibility
                    108: 
                    109: \ ================= array words =====================================
                    110: 
                    111: 0 VALUE TYPE-ID               \ for building structures
                    112: FALSE VALUE STRUCT-ARRAY?
                    113: 
                    114: \ for dynamically allocating a structure or array
                    115: TRUE  VALUE is-static?     \ TRUE for statically allocated structs and arrays
                    116: : dynamic ( -- )     FALSE TO is-static? ;
                    117: 
                    118: 1 CELLS CONSTANT INTEGER        \ size of a regular integer
                    119: 2 CELLS CONSTANT DOUBLE         \ size of a double integer
                    120: \  1 FLOATS CONSTANT FLOAT      \ size of a regular float
                    121: 1 CELLS CONSTANT POINTER        \ size of a pointer (for readability)
                    122: 
                    123: \ 1-D array definition
                    124: \    -----------------------------
                    125: \    | cell_size | data area     |
                    126: \    -----------------------------
                    127: 
                    128: : MARRAY ( n cell_size -- | -- addr )             \ monotype array
                    129:      CREATE
                    130:        DUP , * ALLOT
                    131:      DOES> CELL+
                    132: ;
                    133: 
                    134: \    -----------------------------
                    135: \    | id | cell_size | data area |
                    136: \    -----------------------------
                    137: 
                    138: : SARRAY ( n cell_size -- | -- id addr )          \ structure array
                    139:      CREATE
                    140:        TYPE-ID ,
                    141:        DUP , * ALLOT
                    142:      DOES> DUP @ SWAP [ 2 CELLS ] LITERAL +
                    143: ;
                    144: 
                    145: : ARRAY
                    146:      STRUCT-ARRAY? IF   SARRAY FALSE TO STRUCT-ARRAY?
                    147:                    ELSE MARRAY
                    148:                    THEN
                    149: ;
                    150: 
                    151: \ word for creation of a dynamic array (no memory allocated)
                    152: 
                    153: \ Monotype
                    154: \    ------------------------
                    155: \    | data_ptr | cell_size |
                    156: \    ------------------------
                    157: 
                    158: : DMARRAY   ( cell_size -- )  CREATE  0 , ,
                    159:                               DOES>
                    160:                                     @ CELL+
                    161: ;
                    162: 
                    163: \ Structures
                    164: \    ----------------------------
                    165: \    | data_ptr | cell_size | id |
                    166: \    ----------------------------
                    167: 
                    168: : DSARRAY   ( cell_size -- )  CREATE  0 , , TYPE-ID ,
                    169:                               DOES>
                    170:                                     DUP [ 2 CELLS ] LITERAL + @ SWAP
                    171:                                     @ CELL+
                    172: ;
                    173: 
                    174: : DARRAY   ( cell_size -- )
                    175:      STRUCT-ARRAY? IF   DSARRAY FALSE TO STRUCT-ARRAY?
                    176:                    ELSE DMARRAY
                    177:                    THEN
                    178: ;
                    179: 
                    180: \ word for aliasing arrays,
                    181: \  typical usage:  a{ & b{ &!  sets b{ to point to a{'s data
                    182: 
                    183: : &!    ( addr_a &b -- )
                    184:         SWAP cell- SWAP >BODY  !
                    185: ;
                    186: 
                    187: 
                    188: : }   ( addr n -- addr[n])       \ word that fetches 1-D array addresses
                    189:           OVER [ 1 CELLS ] LITERAL -  @ * + 
                    190: ;
                    191: 
                    192: VARIABLE print-width      6 print-width !
                    193: 
                    194: : }iprint ( n addr -- )       \ print n elements of an integer array
                    195:         SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
                    196:                   DUP I } @ . LOOP
                    197:         DROP
                    198: ;
                    199: 
                    200: : }fprint ( n addr -- )       \ print n elements of a float array
                    201:         SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
                    202:                   DUP I } F@ F. LOOP
                    203:         DROP
                    204: ;
                    205: 
                    206: : }fcopy ( 'src 'dest n -- )         \ copy one array into another
                    207:      0 DO      OVER I } F@     DUP  I } F!    LOOP
                    208:         2DROP
                    209: ;
                    210: 
                    211: : }fput ( r1 ... r_n n 'a -- )   \ store r1 ... r_n into array of size n
                    212:      SWAP DUP 0 ?DO   1- 2DUP 2>R } F! 2R>   LOOP  2DROP ;
                    213: 
                    214: \ 2-D array definition,
                    215: 
                    216: \ Monotype
                    217: \    ------------------------------
                    218: \    | m | cell_size |  data area |
                    219: \    ------------------------------
                    220: 
                    221: : MMATRIX  ( n m size -- )           \ defining word for a 2-d matrix
                    222:         CREATE
                    223:            OVER , DUP ,
                    224:            * * ALLOT
                    225:         DOES>  [ 2 CELLS ] LITERAL +
                    226: ;
                    227: 
                    228: \ Structures
                    229: \    -----------------------------------
                    230: \    | id | m | cell_size |  data area |
                    231: \    -----------------------------------
                    232: 
                    233: : SMATRIX  ( n m size -- )           \ defining word for a 2-d matrix
                    234:         CREATE TYPE-ID ,
                    235:            OVER , DUP ,
                    236:            * * ALLOT
                    237:         DOES>  DUP @ TO TYPE-ID
                    238:                [ 3 CELLS ] LITERAL +
                    239: ;
                    240: 
                    241: 
                    242: : MATRIX  ( n m size -- )           \ defining word for a 2-d matrix
                    243:      STRUCT-ARRAY? IF   SMATRIX FALSE TO STRUCT-ARRAY?
                    244:                    ELSE MMATRIX
                    245:                    THEN
                    246: ;
                    247: 
                    248: : DMATRIX ( size -- )      DARRAY ;
                    249: 
                    250: : }}    ( addr i j -- addr[i][j] )    \ word to fetch 2-D array addresses
                    251:                >R >R
                    252:                DUP cell- cell- 2@     \ &a[0][0] size m
                    253:                R> * R> + *
                    254:                +
                    255: ;
                    256: 
                    257: : }}iprint ( n m addr -- )       \ print nXm elements of an integer 2-D array
                    258:         ROT ROT SWAP 0 DO    DUP 0 DO    OVER J I  }} @ .
                    259:                                    LOOP
                    260:                              CR
                    261:                        LOOP
                    262:         2DROP
                    263: ;
                    264: 
                    265: 
                    266: : }}fprint ( n m addr -- )       \ print nXm elements of a float 2-D array
                    267:         ROT ROT SWAP 0 DO    DUP 0 DO    OVER J I  }} F@ F.
                    268:                                    LOOP
                    269:                              CR
                    270:                        LOOP
                    271:         2DROP
                    272: ;
                    273: 
                    274: : }}fcopy ( 'src 'dest n m  -- )      \ copy nXm elements of 2-D array src to dest
                    275:         SWAP 0 DO    DUP 0 DO    2 PICK J I  }} F@
                    276:                                  OVER   J I  }} F!
                    277:                            LOOP
                    278:                LOOP
                    279:         DROP 2DROP
                    280: ;
                    281: 
                    282: : }}fput ( r11 r12 ... r_nm  n m 'A -- | store r11 ... r_nm into nxm matrix )
                    283:       -ROT 2DUP * >R 1- SWAP 1- SWAP }} R> 
                    284:       0 ?DO  DUP >R F! R> FLOAT -  LOOP  DROP ;
                    285: 
                    286: \ ================= Floating-point local variables ==================
                    287: (
                    288:   loosely based upon Wil Baden's idea presented at FORML 1992.
                    289:   The idea is to have a fixed number of variables with fixed names.
                    290: 
                    291:   example:  : test  2e 3e FRAME| a b |  a F. b F. |FRAME ;
                    292:             test <cr> 3.0000 2.0000 ok
                    293: 
                    294:   Don't forget to use |FRAME before leaving a word that uses FRAME|.
                    295: )
                    296: 
                    297: 8 CONSTANT /FLOCALS       \ number of variables provided
                    298: 
                    299: : (frame) ( n -- ) FLOATS ALLOT ;
                    300: : (unframe) ( addr -- ) HERE - ALLOT ;
                    301: 
                    302: : FRAME|
                    303:         POSTPONE HERE POSTPONE FALIGN POSTPONE >R
                    304:         0 >R
                    305:         BEGIN   BL WORD  COUNT  1 =
                    306:                 SWAP C@  [CHAR] | =
                    307:                 AND 0=
                    308:         WHILE   POSTPONE F,  R> 1+ >R
                    309:         REPEAT
                    310:         /FLOCALS R> - DUP 0< ABORT" too many flocals"
                    311:         POSTPONE LITERAL  POSTPONE (frame) ; IMMEDIATE
                    312: 
                    313: : |FRAME ( -- ) POSTPONE R> POSTPONE  (unframe) ; IMMEDIATE
                    314: 
                    315: \ use a defining word to build locals   cgm
                    316: : lcl  ( n -- ) CREATE ,
                    317:                 DOES>  @ FLOATS NEGATE HERE +
                    318: ;
                    319: 
                    320: 8 lcl &a      7 lcl &b      6 lcl &c      5 lcl &d
                    321:   : a &a F@ ;   : b &b F@ ;   : c &c F@ ;   : d &d F@ ; 
                    322: 4 lcl &e      3 lcl &f      2 lcl &g      1 lcl &h
                    323:   : e &e F@ ;   : f &f F@ ;   : g &g F@ ;   : h &h F@ ; 
                    324: 
                    325: BASE !
                    326: \                   end of file

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