File:  [gforth] / gforth / fsl-util.fs
Revision 1.2: download - view: text, annotated - select for diffs
Wed Nov 28 03:32:15 2012 UTC (6 years, 8 months ago) by dvdkhlng
Branches: MAIN
CVS tags: HEAD
keep fsl-util.fs from logging to stdout at load-time

    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 )
   38: \ CR .(  fsl-utilg.fth     V2.0         Thursday 16 October 2008  )
   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>