Borland Programmer's Resource/Borland_Programmers_Resource_CD_1995.iso/ntcode/jx4nt125/obj4th/dimarray.utf

Null Bytes Alternating | 1995-05-19 | 12.0 KB | 155 lines

\ dimarray.utf ... n-dimensional self-indexing cell array
\ ANS Forth compliant source code is Copyright (c)1994 by
\ Jack J. Woehr, P.O. Box 51, Golden, Colorado 80402-0051
\ [e-mail] [e-mail]
\ SYSOP RCFB [phone] 2400/9600/14400
\ All Rights Reserved
\ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\ This is free software and can be modified and redistributed under
\ certain conditions described in the file COPYING.TXT. The
\ Disclaimer of Warranty and License for this free software are also
\ contained in the file COPYING.TXT.
\ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

\ A Standard System still exists after this code is loaded.

\ the structure of a dimarray object:
\ /#stored-indices/n1/n2/ .. /nn/ptr-to-data/

MARKER dimarray.utf

\ Execution engine
: DO-DIMARRAY ( i*n a-addr1 -- a-addr2)
    SWAP            \ index n does not need a multiplier
    OVER            \ object address to TOS
    @               \ get #dims
    1- 0            \ that number, minus one is the number ...
    ?DO             \ ... of multipliers to obtain
        1 I 1+ 0    \ base multiplicand, for n times
        ?DO         \ get size(n+i(m)) * size(n+i(m+1))
            I 1+ CELLS 3 PICK + @ *
        LOOP        \ prepare to shift multiplier out of way
        >R ROT      \ then bring runtime index to top
        R> *        \ bring back multiplier
        +           \ add product to cumulative index
    LOOP
    CELLS           \ that many cells
    SWAP
    DUP @           \ plus those consumed by the compiled indices
    1+ CELLS
    +               \ yields data ptr address
    @               \ data base address
    +               \ added to caculated offset yields data address
;

\ This version works under RAM/ROM systems, e.g., VFSE-332.
\ The non-standard words MODE? ( -- mid) and ?MODE ( mid --)
\ obtain and restore the current compilation mode, RAM or ROM.
\ For more information on RAM and ROM see
\ : DIMARRAY ( i*n i --)
\    DUP 1 < ABORT" Positive dimension count only."
\    MODE? >R ROM       \ the overhead has to be ROMmed if a ROM system
\    CREATE             \ create the dimarray object described above
\    DUP ,              \ save the #indices
\    DUP >R             \ keep a copy for later    R: -- n1 n2
\    0
\    ?DO
\    I PICK ,           \ loop while embedding copies of indices ..
\                       \ .. without removing originals from stack
\    LOOP
\    RAM HERE ROM ,     \ point to base of data storage
\    R> 1- 0            \ get back number of indices    R: -- n1
\    ?DO
\      *                \ calculate data space requirements
\    LOOP
\    CELLS RAM ALLOT    \ ALLOT the data space
\    R> ?MODE           \ restore data space pointer to before DIMARRAY R: --
\    DOES> DO-DIMARRAY
\ ;

\ This version works under RAM-only systems, e.g., Jax4th and ZEN.
: DIMARRAY ( i*n i --)
    DUP 1 <             \ If used in a program, substitute a THROW for ABORT"
    ABORT" Positive dimension count only."
    CREATE              \ create the dimarray object described above
    DUP ,               \ store the #indices
    DUP >R              \ and save a copy
    0
    ?DO
    I PICK ,            \ embed indices without removing originals from stack
    LOOP
    HERE 1 CELLS + ,    \ point to base of data storage
    R> 1- 0             \ get back number of indices
    ?DO
      *                 \ calculate data space requirements
    LOOP
    CELLS ALLOT         \ ALLOT the data space
    DOES> DO-DIMARRAY
;

\ "So after you've created those multi-dimensional variable-length
\ arrays with DIMARRAY, how do you keep track of the indices for
\ error checking? The answer is DIMLIMS which
\ checks indices for n-dimensioned array prior to
\ execution of the array-in-question's cfa.
\ If indices out of bounds, abort with message.

: DO-DIMLIMS ( i*n xt -- a-addr)
    DUP >R                  \ save that token! we'll need it later
    >BODY                   \ address of indices & address overhead reside
    DUP                     \ base addr of overhead, #indices field
    @ DUP                   \ get # of indices
    DEPTH 2 - < 0=          \ stack too shallow?
    ABORT" Dimarray dimension error - stack depth"
    0                       \ for #-of-indices iterations ...
    ?DO
        I 1+ PICK           \ get one runtime index
        OVER I 1+ CELLS + @ \ get corresponding compiled index
        OVER >              \ is zero-based runtime less?
        SWAP -1 >           \ is it non-negative?
        AND 0=              \ but if test(s) fail ...
    ABORT" Dimarray dimension error - index size"
    LOOP
    DROP                    \ the overhead data address, but the xt ...
    R> EXECUTE              \ ... gets executed as normal
;

: DIMLIMS \ index1 .. indexn --TIB-- ---
    '                       \ execution token for the dimarray-created word
    STATE @                 \ compiling?
    IF                      \ yes
        POSTPONE LITERAL POSTPONE DO-DIMLIMS
    ELSE                    \ interpreting!
        DO-DIMLIMS
    THEN
; IMMEDIATE

\ USAGE ...
\
\        4 4 5 6 4 DIMARRAY MY-4D-ARRAY
\
\ creates a 4-dimensional array consisting of 4*4*5*6 cell-length
\ entries organised into a zero-based indexing system which yields
\ possible indices between 0-3 for the first dimension, 0-3 for
\ the second dimension, 0-4 for the third and 0-5 for the last
\ dimension in MY-4D-ARRAY. Now
\
\        3 3 4 5 MY-4D-ARRAY
\
\ yields the address of the last entry in MY-4D-ARRAY, but typing
\
\        3 3 5 7 MY-4D-ARRAY
\
\ also yields an address, though an invalid one. So the usage
\
\        3 3 5 7 DIMLIMS MY-4D-ARRAY
\
\ will abort with an error message, instead of yielding a spurious
\ address. DIMLIMS will also abort if any index is negative or on
\ stack underflow.

\ ~~~~~~~~~~~~~~~~~~~
\ End of DIMARRAY.UTF
\ ~~~~~~~~~~~~~~~~~~~