Main Menu

Forums SwiftForth Forum SwiftForth 2-dimensional arrays

This topic contains 2 replies, has 2 voices, and was last updated by  allen@a2d2.com 6 months, 3 weeks ago.

Viewing 3 posts - 1 through 3 (of 3 total)
  • Author
    Posts
  • #4225

    allen@a2d2.com
    Participant

    { ———————————————————————-
    I asked the ForthInc Help Desk if I should post this, and they suggested
    that I could, recommending that I provide an explanation at the end.
    Allen Anway allen@a2d2.com
    1219 North 21st Street
    Superior, WI 54880-5057
    ———————————————————————- }

    \ = = = = = = = = = = = = = = = =
    \ = = = = = = = = = = = = = = = =
    \
    \ AA array AA array AA array AA array
    \
    \ = = = = = = = = = = = = = = = =
    \ = = = = = = = = = = = = = = = =
    \
    \ Generalized arrays: 1bit, 2bit, 4bit, 8bit, 16bit, 32bit, 64bit data
    \ – -1984 original arrays in Allen Anway’s Apple Forth n dimensions
    \ – -1989 original MENU.EXE Allen Anway’s Apple Forth
    \ – -1998 arrays converted for MENU.EXE in SWIFT FORTH 2 dimensions
    \ 7-10-2003 arrays included in INVOICE.EXE in SWIFT FORTH
    \ 3-12-2007 cures addressing bugs
    \ 12- 2-2008 cures eRay and a0Ray errors
    \ 7-17-2016 vectored instead of OF … ENDOF negative index choices
    \ 7-19-2016 accelerated machine language programming
    \ 8-13-2016 1bit 2bit 4bit arrays elaborate machine language
    \ 8-19-2016 new i,j programs for direct i,j access to arrays
    \
    \ 1 cell is 32 bits, 4 bytes of RAM space
    \ pfa is ‘parameter field address’, that address given by DOES>
    \
    \ 2-dimensional i,j array, quick readout in i with j previously established
    \ specify i <name> to readout stored number from a defined array
    \ j effect is to store a j-delta-address at pfa+8
    \ j effect is persistent until one stores another j
    \ i = 0, 1, 2, … last.index.i are possible values of i
    \ j = 0, 1, 2, … last.index.j are possible values of j
    \ pfa i’ = 1 + last.index.i permanent constant at pfa minimum 1
    \ pfa+4 j’ = 1 + last.index.j permanent constant at pfa+4 minimum 1
    \ pfa+8 j effect address: set by ( j ) j!Ray <name> or other j means
    \ j effect address: byte distance from pfa to pfaj,i=0 data
    \ j effect address: j=0 makes pfa+8 address value 12
    \ pfa+12 starts data storage, ie, cell 3 starts 0,0 data location
    \ i groups of data are without gaps, allocated in CELLS
    \ j groups of data may have gaps between each i group
    \
    \ definition of new array ( j’ i’ ) ARRAY <name> ( )
    \ fetch stored value n ( i ) <name> ( n )
    \ store value n ( n i !Ray ) <name> ( )
    \ store new j effect ( j j!Ray ) <name> ( )
    \ address.of.byte ( i aRay ) <name> ( pfaj,i )
    \ address.of.byte ( a0Ray ) <name> ( pfaj,i=0 )
    \ store j effect, get add ( j j0Ray ) <name> ( pfaj,i=0 )
    \ erase all cells ( eRay ) <name> ( )
    \ blank all cells ( bRay ) <name> ( )
    \ convert data*10, 32 bit ( i 10Ray ) <name> ( )
    \ no-op future expansion ( noRay ) <name> ( )
    \ no-op future expansion ( NoRay ) <name> ( )
    \ i j indices fetch n ( i j ij@Ray ) <name> ( n )
    \ store n with i j indices ( n i j ij!Ray ) <name> ( )
    \ recall fixed constant i’ ( i?Ray ) <name> ( i’ )
    \ recall fixed constant j’ ( j?Ray ) <name> ( j’ )
    \ -index fault program ( /Ray ) <name> ( )
    \ _special_
    \ _negative_
    \ _constants_
    \
    \ bytes at pfa (parameter field address), pfa is given by DOES>
    \ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
    \ |—-pfa—– |—pfa+4—- |—pfa+8—- |—pfa+12—-
    \ i’ j’ jdelta.ad+12 |–data cell–
    \ j effect

    12 CONSTANT d-pfa \ byte distance from pfa to data cell i,j = 0,0

    ICODE d-pfa+ d-pfa # EBX ADD RET END-CODE \ ( n — n+12 )

    ICODE 0>= \ ( n — flag ) works by inverting 0<
    EBX EAX MOV \ move into eax for cdq
    CDQ \ 4>8 byte sign extend into EDX
    EDX EBX MOV \ tos now 0 or -1
    EBX NOT \ invert bits
    RET END-CODE \ reference 1ARA>

    ICODE AAU>= \ ( u1 u2 — u1 flag ) keep u1 intact
    EBX 0 [EBP] CMP
    EBX EBX SBB
    EBX NOT \ opposite of AAU<
    RET END-CODE \ reference <1j!Ray> 1b\p>ad

    ICODE AA! \ ( n addr — n ) keep n intact
    0 [EBP] EAX MOV
    EAX 0 [EBX] MOV
    0 [EBP] EBX MOV \ drop one stack number
    4 # EBP ADD \ rather than two
    RET END-CODE \ reference 1ARA>

    ICODE R@@ \ ( — n ) ( R: addr — addr ) general
    PUSH(EBX) \ ( — i’ ) ( R: pfa — pfa ) specific
    0 [ESP] EBX MOV \ read top of return stack to tos
    0 [EBX] EBX MOV \ replace address in ebx with contents
    RET END-CODE \ reference <1j!Ray>

    ICODE >R-R@@ \ ( addr — n ) ( R: — addr ) general
    EBX PUSH \ ( pfa — i’ ) ( R: — pfa ) specific
    0 [EBX] EBX MOV \ replace address in ebx with contents
    RET END-CODE \ reference 1b\p>ad

    ICODE 4+@ \ ( addr — n ) general
    4 [EBX] EBX MOV \ ( pfa — j’ ) specific
    RET END-CODE \ reference 1array

    ICODE >R-R@4+@ \ ( addr — n ) ( R: — addr ) general
    EBX PUSH \ ( pfa — j’ ) ( R: — pfa ) specific
    4 [EBX] EBX MOV \ replace address in ebx+4 with contents
    RET END-CODE \ reference <1j!Ray>

    ICODE R>8+! \ ( n — ) ( R: addr — ) general
    EAX POP \ ( delta-j-ad+12 — ) ( R: pfa — ) specific
    EBX 8 [EAX] MOV \ store delta-j-ad+12 into pfa+8
    POP(EBX) \ use of j effect
    RET END-CODE \ reference <1j!Ray>

    \ : a+8@+ \ ( addr — addr+(addr+8@) ) general
    \ DUP 2 CELLS + @ + ; \ ( pfa — pfaj,i=0 ) specific
    ICODE a+8@+ \ use of j effect
    8 [EBX] EBX ADD \ with stored number at pfa+8
    RET END-CODE \ reference <1j0Ray> 1b\p>ad

    \ Apply following negative indices to array <name> for special effects
    \ Wrong negative indices are no-op, show a warning from ARabort
    \ Invoking j is persistent until another j is invoked
    \ +index i = 0 to i’-1 ( i — n ) fetch stored value n
    -8 CONSTANT !Ray \ ( n i !Ray — ) store value n
    -16 CONSTANT j!Ray \ ( j j!Ray — ) store new j effect
    -24 CONSTANT aRay \ ( i aRay — pfaj,i ) address.of.byte
    -32 CONSTANT a0Ray \ ( a0Ray — pfaj,i=0 ) address.of.byte
    -40 CONSTANT j0Ray \ ( j j0Ray — pjaj,i=0 ) store j effect, get addr
    -48 CONSTANT eRay \ ( eRay — ) erase all cells
    -56 CONSTANT bRay \ ( bRay — ) blank all cells
    -64 CONSTANT 10Ray \ ( i 10Ray — ) convert data*10, 32 bit
    -72 CONSTANT noRay \ ( noRay — ) no-op future expansion
    -80 CONSTANT NoRay \ ( NoRay — ) no-op future expansion
    -88 CONSTANT ij@Ray \ ( i j ij@Ray — n ) i j indices fetch n
    -96 CONSTANT ij!Ray \ ( n i j ij!Ray — ) store n with i j indices
    -104 CONSTANT i?Ray \ ( i?Ray — i’ ) recall fixed constant i’
    -112 CONSTANT j?Ray \ ( j?Ray — j’ ) recall fixed constant j’
    -120 CONSTANT /Ray \ ( /Ray — ) -index fault program
    /Ray NEGATE \ fault, wrong -index may abort by <esc> key
    CONSTANT //Ray \ reference CODE ar-idx

    \ ————————————————prototype program
    \ : ar-idx \ ( -index pfa — pfa +index’ ) special ops with neg indices
    \ SWAP NEGATE DUP 7 AND 10 LSHIFT + \ wrong +index made giant
    \ //Ray MIN 2/ 4- ;
    \ prototype program————————————————

    \ starting -index -8 -16 -24 -32 . . . -112 -120 (fault, can abort)
    \ other negative indices are incorrect, becoming -120 (fault, can abort)
    \ ending +index’ 0 4 8 12 . . . 44 48 (fault, can abort)
    CODE ar-idx \ ( -index pfa — pfa +index’ ) accelerated code program
    0 [EBP] EAX MOV \ EAX ..-index SWAP original -index
    EBX 0 [EBP] MOV \ SWAP pfa > down one stack
    EAX NEG \ EAX ..+index +index
    EAX EBX MOV \ EBX posindex SWAP final step
    7 # EAX AND \ EAX ….mod? +index modulus 0<> is fault
    EAX 10 # SHL \ EAX mod?…. residue becomes giant
    EAX EBX ADD \ EBX mod?indx same +index or giant index
    //Ray # EAX MOV \ EAX +bigindx highest legal index //Ray
    \ fault program with warning
    \ operator may abort with <esc>
    EAX EBX CMP \ MIN make comparison
    > IF \ MIN 7E02 branch if ….
    EAX EBX MOV \ EBX +bigindx MIN index for fault program
    THEN \ MIN
    EBX SAR \ EBX +index/2 effect of EBX 1 # SHR
    4 # EBX SUB \ EBX +ind/2-4
    RET END-CODE \

    \ MIN alternative program //Ray # EBX CMP
    \ MIN alternative program > IF
    \ MIN alternative program //Ray # EBX MOV
    \ MIN alternative program THEN

    \ remember negative index for fault display
    VARIABLE idxV \ reference ARabort

    ICODE 4* EBX 2 # SHL RET END-CODE \ same as CELLS
    ICODE 8* EBX 3 # SHL RET END-CODE \ extension
    ICODE 4/ EBX 2 # SHR RET END-CODE \ same as CELL/
    ICODE 8/ EBX 3 # SHR RET END-CODE \ extension
    ICODE 16/ EBX 4 # SHR RET END-CODE \ extension
    ICODE 32/ EBX 5 # SHR RET END-CODE \ extension

    \ c u s t o m f o r 1 2 4 b i t a r r a y s
    \ for faster retrieval and storage of data in smaller bit arrays

    HEX \ 1 bit, 2 bit, 4 bit arrays: 124 arrays arrays 124
    1073 CONSTANT 1arC \ for bARRAY 321 0th pattern i index / 842
    3132 CONSTANT 2arC \ for 2ARRAY 731 1st pattern i modulus
    F211 CONSTANT 4arC \ for 4ARRAY 012 2nd pattern i modulus * 124
    DECIMAL \ 13F 3rd pattern data bits AND
    \ XarC means constants 1arC 2arC 4arC
    CODE 124calc \ ( i pfaj,i=0 XarC — pfaj,i )

    15 # EDX MOV \ EDX ….1111 AND masking for XarC
    4 [EBP] EAX MOV \ EAX …index i index
    EBX ECX MOV \ ECX XarConst XarC constant
    EDX ECX AND \ ECX divid842 321 pattern shift
    EAX CL SHR \ EAX ..in/842 i index divided
    0 [EBP] EAX ADD \ EAX ..pfaj,i address pfaj,i
    EAX PUSH \ pfaj,i > return stk
    4 [EBP] EAX MOV \ EAX …index i index
    EBX ECX MOV \ ECX XarConst XarC constant
    ECX 4 # SHR \ ECX XarCo/16 XarC shifted 4 bits
    ECX EBX MOV \ EBX XarCo/16 XarC shifted 4 bits
    EDX ECX AND \ ECX mask.731 731 pattern idx mod
    ECX EAX AND \ EAX indexmod i index modulus
    EBX ECX MOV \ ECX XarCo/16 XarC shifted 4 bits
    ECX 4 # SHR \ ECX XarC/256 XarC shifted 8 bits
    ECX EBX MOV \ EBX XarC/256 XarC shifted 8 bits
    EDX ECX AND \ ECX …**012 012 pattern *124
    EAX CL SHL \ EAX ind**012 final n to shift data
    EAX ECX MOV \ ECX ind**012 final n to shift data
    EBX EAX MOV \ EAX XarC/256 XarC shifted 8 bits
    EAX 4 # SHR \ EAX Xar/1024 XarC shifted 12 bits
    EAX EDX MOV \ EDX ……11 13F pattern data mask
    EDX CL SHL \ EDX ..11…. 13F left shifted
    EDX NOT \ EDX 11..1111 bit pattern not
    EBX POP \ EBX ..pfaj,i address pfaj,i
    8 # EBP ADD \ discard 2 lower stack numbers
    RET END-CODE
    \ ( i pfaj,i=0 XarC — pfaj,i )
    \ EBX is byte address pfaj,i where data exists
    \ EAX is AND mask for data at lowest position (i modulus = 0)
    \ EDX is left shifted mask, bits reversed with NOT, for AND and OR
    \ ECX is left/right shift of the data part in the byte from/to home
    \ value of ECX depends on xbit array and i index modulus

    \ elaborate program above sets up simple programs below of 124b@ and 124b!

    \ below codes MUST follow immediately CODE 124calc
    \ code relies on previous intact registers EDX ECX EBX EAX
    CODE 124b@ \ ( pfaj,i — data ) data ends up in right-most home position
    0 [EBX] EBX MOV \ EBX 32datbit full cell of data
    EBX CL SHR \ EBX …32dat part cell home position
    EAX EBX AND \ EBX …..dat 124 bits only home pos
    RET END-CODE

    \ code relies on previous intact registers EDX ECX EBX EAX
    CODE 124b! \ ( data pfaj,i — ) data is in right-most home position
    \ 32datbit OLD data in 0 [EBX]
    0 [EBX] EDX AND \ EDX 32…bit OLD data punch out hole
    0 [EBP] EAX AND \ EAX …..dat NEW data home position
    EAX CL SHL \ EAX ..dat… NEW data shift left
    EDX EAX OR \ EAX 32datbit NEW 32 bits data
    AL 0 [EBX] MOV \ C! only store 8 bits, not 32 bits
    4 [EBP] EBX MOV \ 2DROP update tos
    8 # EBP ADD \ 2DROP discard 2 cells
    RET END-CODE

    \ given i’ find cells required or bytes required
    \ 1bit array 32 bits in CELL
    : 1BiTS>CELL 1- 32/ 1+ ; \ ( i’ — cells )
    : 1BiTS>BYTE 1- 32/ 1+ 4* ; \ ( i’ — bytes )

    \ 2bit array 16 half-nybbles in CELL
    : 2BiTS>CELL 1- 16/ 1+ ; \ ( i’ — cells )
    : 2BiTS>BYTE 1- 16/ 1+ 4* ; \ ( i’ — bytes )

    \ 4bit array 8 nybbles in CELL
    : 4BiTS>CELL 1- 8/ 1+ ; \ ( i’ — cells )
    : 4BiTS>BYTE 1- 8/ 1+ 4* ; \ ( i’ — bytes )

    \ 8bit array 4 bytes in CELL
    : 8BiTS>CELL 1- 4/ 1+ ; \ ( i’ — cells )
    : 8BiTS>BYTE 1- 4/ 1+ 4* ; \ ( i’ — bytes )

    \ 16bit array 2 half-cells in CELL
    : 16BiT>CELL 1- 2/ 1+ ; \ ( i’ — cells )
    : 16BiT>BYTE 1- 2/ 1+ 4* ; \ ( i’ — bytes )

    \ high level calls up lower-level R@, specifically, pfa for <.nam>
    \ two methods give same results
    ICODE RSUB@ PUSH(EBX) 4 [ESP] EBX MOV RET END-CODE
    \ CODE RSUB@ PUSH(EBX) 8 [ESP] EBX MOV RET END-CODE
    \ reference .nam

    : <.nam> \ ( pfa — ) type array name for fault description
    BODY> >NAME COUNT TYPE SPACE ;

    : .nam \ ( i — 0 ) ( R: pfa RET — pfa RET )
    \ error-default 0 becomes new index for i or j
    .” index error ” . RSUB@ <.nam> 0 ;

    \ j entry changes the address at pfa+8, persistent j effect
    : <1j!Ray> \ ( j pfa — )
    >R-R@4+@ AAU>=
    IF
    .” 1bit array j” .nam
    THEN
    R@@ 1BiTS>BYTE * d-pfa+ R>8+! ;

    : <2j!Ray> \ ( j pfa — )
    >R-R@4+@ AAU>=
    IF
    .” 2bit array j” .nam
    THEN
    R@@ 2BiTS>BYTE * d-pfa+ R>8+! ;

    : <4j!Ray> \ ( j pfa — )
    >R-R@4+@ AAU>=
    IF
    .” 4bit array j” .nam
    THEN
    R@@ 4BiTS>BYTE * d-pfa+ R>8+! ;

    : <8j!Ray> \ ( j pfa — )
    >R-R@4+@ AAU>=
    IF
    .” 8bit array j” .nam
    THEN
    R@@ 8BiTS>BYTE * d-pfa+ R>8+! ;

    : <16j!Ray> \ ( j pfa — )
    >R-R@4+@ AAU>=
    IF
    .” 16bit array j” .nam
    THEN
    R@@ 16BiT>BYTE * d-pfa+ R>8+! ;

    : <32j!Ray> \ ( j pfa — )
    >R-R@4+@ AAU>=
    IF
    .” 32bit array j” .nam
    THEN
    R@@ 4* * d-pfa+ R>8+! ;

    : <64j!Ray> \ ( j pfa — )
    >R-R@4+@ AAU>=
    IF
    .” 64bit array j” .nam
    THEN
    R@@ 8* * d-pfa+ R>8+! ;

    \ j entry changes the address at pfa+8, persistent j effect
    \ also gives the new address of j,i=0 data
    \ ( j pfa — pfaj,i=0 )
    : <1j0Ray> >R-R@ <1j!Ray> R> a+8@+ ;
    : <2j0Ray> >R-R@ <2j!Ray> R> a+8@+ ;
    : <4j0Ray> >R-R@ <4j!Ray> R> a+8@+ ;
    : <8j0Ray> >R-R@ <8j!Ray> R> a+8@+ ;
    : <16j0Ray> >R-R@ <16j!Ray> R> a+8@+ ;
    : <32j0Ray> >R-R@ <32j!Ray> R> a+8@+ ;
    : <64j0Ray> >R-R@ <64j!Ray> R> a+8@+ ;

    : ARabort \ ( pfa — )
    BRIGHT
    0 1 AT-XY .” wrong neg index ” idxV @ . <.nam>
    NORMAL
    EKEY <esc> = IF ABORT THEN ;

    \ Scheme for 1 bit, 2 bits, 4 bits arrays
    \ One must preserve registers EDX ECX EBX EAX between programs
    \ First use eg 1b\p>a to make address of i,j data,
    \ then MUST use 124b@ and 124b! immediately
    \ No intervening programs allowed because they might change EDX ECX EAX
    \ For 1b@ 2b@ 4b@ use 124b@
    \ For 1b! 2b! 4b! use 124b!

    \ j effect invoked previously, these deal only with i
    : 1b\p>ad \ ( i pfa — pfaj,i )
    >R-R@@ AAU>=
    IF
    .” 1bit array i” .nam
    THEN \ 124calc sets up EDX ECX EBX EAX registers
    R> a+8@+ 1arC 124calc ;

    : 2b\p>ad \ ( i pfa — pfaj,i )
    >R-R@@ AAU>=
    IF
    .” 2bit array i” .nam
    THEN \ 124calc sets up EDX ECX EBX EAX registers
    R> a+8@+ 2arC 124calc ;

    : 4b\p>ad \ ( i pfa — pfaj,i )
    >R-R@@ AAU>=
    IF
    .” 4bit array i” .nam
    THEN \ 124calc sets up EAX EBX ECX EDX registers
    R> a+8@+ 4arC 124calc ;

    : 8b\p>ad \ ( i pfa — pfaj,i )
    >R-R@@ AAU>=
    IF
    .” 8bit array i” .nam
    THEN
    R> a+8@+ + ;

    : 16\p>ad \ ( i pfa — pfaj,i )
    >R-R@@ AAU>=
    IF
    .” 16bit array i” .nam
    THEN
    2* R> a+8@+ + ;

    : 32\p>ad \ ( i pfa — pfaj,i )
    >R-R@@ AAU>=
    IF
    .” 32bit array i” .nam
    THEN
    4* R> a+8@+ + ;

    : 64\p>ad \ ( i pfa — pfaj,i )
    >R-R@@ AAU>=
    IF
    .” 64bit array i” .nam
    THEN
    8* R> a+8@+ + ;

    \ j effect invoked previously, these deal only with i
    \ store data n at i address location
    \ ( n i pfa — )
    : 1b\p>1b! 1b\p>ad 124b! ;
    : 2b\p>2b! 2b\p>ad 124b! ;
    : 4b\p>4b! 4b\p>ad 124b! ;
    : 8b\p>8b! 8b\p>ad C! ;
    : 16\p>16! 16\p>ad H! ;
    : 32\p>32! 32\p>ad ! ;
    : 64\p>64! 64\p>ad 2! ;

    \ j entry changes the address at pfa+8, persistent j effect
    \ fetch data n from i j address location
    \ ( i j pfa — n )
    : 1ij@ 2DUP <1j!Ray> NIP 1b\p>ad 124b@ 0<> ;
    : 2ij@ 2DUP <2j!Ray> NIP 2b\p>ad 124b@ ;
    : 4ij@ 2DUP <4j!Ray> NIP 4b\p>ad 124b@ ;
    : 8ij@ 2DUP <8j!Ray> NIP 8b\p>ad C@ ;
    : 16ij@ 2DUP <16j!Ray> NIP 16\p>ad H@ ;
    : 32ij@ 2DUP <32j!Ray> NIP 32\p>ad @ ;
    : 64ij@ 2DUP <64j!Ray> NIP 64\p>ad 2@ ;

    \ j entry changes the address at pfa+8, persistent j effect
    \ store data n at i j address location
    \ ( n i j pfa — )
    : 1nij! 2DUP <1j!Ray> NIP 1b\p>ad 124b! ;
    : 2nij! 2DUP <2j!Ray> NIP 2b\p>ad 124b! ;
    : 4nij! 2DUP <4j!Ray> NIP 4b\p>ad 124b! ;
    : 8nij! 2DUP <8j!Ray> NIP 8b\p>ad C! ;
    : 16nij! 2DUP <16j!Ray> NIP 16\p>ad H! ;
    : 32nij! 2DUP <32j!Ray> NIP 32\p>ad ! ;
    : 64nij! 2DUP <64j!Ray> NIP 64\p>ad 2! ;

    \ j effect is previously invoked, this deals only with i
    \ multiply i number by 10 and store it again, 32bit array only
    : 10*i\p>ad 32\p>ad DUP @ 10 * SWAP ! ; \ ( i pfa — )

    CODE <<eRay>> \ ( pfa — pfa+12 j’ i’ )
    8 # EBP SUB
    4 [EBX] EAX MOV \ j’
    EAX 0 [EBP] MOV \ j’
    EBX 4 [EBP] MOV \ pfa
    d-pfa # 4 [EBP] ADD \ pfa+12
    0 [EBX] EBX MOV \ i’
    RET END-CODE

    \ erase all cells of an array
    \ ( pfa — )
    : <1eRay> <<eRay>> 1BiTS>BYTE * ERASE ;
    : <2eRay> <<eRay>> 2BiTS>BYTE * ERASE ;
    : <4eRay> <<eRay>> 4BiTS>BYTE * ERASE ;
    : <8eRay> <<eRay>> 8BiTS>BYTE * ERASE ;
    : <16eRay> <<eRay>> 16BiT>BYTE * ERASE ;
    : <32eRay> <<eRay>> 4* * ERASE ;
    : <64eRay> <<eRay>> 8* * ERASE ;

    \ blank all cells of an array
    \ ( pfa — )
    : <1bRay> <<eRay>> 1BiTS>BYTE * BLANK ;
    : <2bRay> <<eRay>> 2BiTS>BYTE * BLANK ;
    : <4bRay> <<eRay>> 4BiTS>BYTE * BLANK ;
    : <8bRay> <<eRay>> 8BiTS>BYTE * BLANK ;
    : <16bRay> <<eRay>> 16BiT>BYTE * BLANK ;
    : <32bRay> <<eRay>> 4* * BLANK ;
    : <64bRay> <<eRay>> 8* * BLANK ;

    \ @EXECUTE look up tables for negative indices, special effects
    \ ‘ 2DROP , is a no-op
    CREATE 1array
    ‘ 1b\p>1b! , ‘ <1j!Ray> , ‘ 1b\p>ad , ‘ a+8@+ ,
    ‘ <1j0Ray> , ‘ <1eRay> , ‘ <1bRay> , ‘ 2DROP ,
    ‘ 2DROP , ‘ 2DROP , ‘ 1ij@ , ‘ 1nij! ,
    ‘ @ , ‘ 4+@ , ‘ ARabort ,

    CREATE 2array
    ‘ 2b\p>2b! , ‘ <2j!Ray> , ‘ 2b\p>ad , ‘ a+8@+ ,
    ‘ <2j0Ray> , ‘ <2eRay> , ‘ <2bRay> , ‘ 2DROP ,
    ‘ 2DROP , ‘ 2DROP , ‘ 2ij@ , ‘ 2nij! ,
    ‘ @ , ‘ 4+@ , ‘ ARabort ,

    CREATE 4array
    ‘ 4b\p>4b! , ‘ <4j!Ray> , ‘ 4b\p>ad , ‘ a+8@+ ,
    ‘ <4j0Ray> , ‘ <4eRay> , ‘ <4bRay> , ‘ 2DROP ,
    ‘ 2DROP , ‘ 2DROP , ‘ 4ij@ , ‘ 4nij! ,
    ‘ @ , ‘ 4+@ , ‘ ARabort ,

    CREATE 8array
    ‘ 8b\p>8b! , ‘ <8j!Ray> , ‘ 8b\p>ad , ‘ a+8@+ ,
    ‘ <8j0Ray> , ‘ <8eRay> , ‘ <8bRay> , ‘ 2DROP ,
    ‘ 2DROP , ‘ 2DROP , ‘ 8ij@ , ‘ 8nij! ,
    ‘ @ , ‘ 4+@ , ‘ ARabort ,

    CREATE 16array
    ‘ 16\p>16! , ‘ <16j!Ray> , ‘ 16\p>ad , ‘ a+8@+ ,
    ‘ <16j0Ray> , ‘ <16eRay> , ‘ <16bRay> , ‘ 2DROP ,
    ‘ 2DROP , ‘ 2DROP , ‘ 16ij@ , ‘ 16nij! ,
    ‘ @ , ‘ 4+@ , ‘ ARabort ,

    CREATE 32array
    ‘ 32\p>32! , ‘ <32j!Ray> , ‘ 32\p>ad , ‘ a+8@+ ,
    ‘ <32j0Ray> , ‘ <32eRay> , ‘ <32bRay> , ‘ 10*i\p>ad ,
    ‘ 2DROP , ‘ 2DROP , ‘ 32ij@ , ‘ 32nij! ,
    ‘ @ , ‘ 4+@ , ‘ ARabort ,

    CREATE 64array
    ‘ 64\p>64! , ‘ <64j!Ray> , ‘ 64\p>ad , ‘ a+8@+ ,
    ‘ <64j0Ray> , ‘ <64eRay> , ‘ <64bRay> , ‘ 2DROP ,
    ‘ 2DROP , ‘ 2DROP , ‘ 64ij@ , ‘ 64nij! ,
    ‘ @ , ‘ 4+@ , ‘ ARabort ,

    \ DOES> ( pfa ) execution part of CREATE … DOES>, defining arrays
    \ required k is i or negative-index or incorrect-index
    : 1ARA> \ ( ? k pfa — ? ) depending on program
    OVER idxV AA! 0>=
    IF
    1b\p>ad 124b@ 0<> EXIT
    THEN
    ar-idx 1array + @EXECUTE ;

    : 2ARA> \ ( ? k pfa — ? ) depending on program
    OVER idxV AA! 0>=
    IF
    2b\p>ad 124b@ EXIT
    THEN
    ar-idx 2array + @EXECUTE ;

    : 4ARA> \ ( ? k pfa — ? ) depending on program
    OVER idxV AA! 0>=
    IF
    4b\p>ad 124b@ EXIT
    THEN
    ar-idx 4array + @EXECUTE ;

    : 8ARA> \ ( ? k pfa — ? ) depending on program
    OVER idxV AA! 0>=
    IF
    8b\p>ad C@ EXIT
    THEN
    ar-idx 8array + @EXECUTE ;

    : 16ARA> \ ( ? k pfa — ? ) depending on program
    OVER idxV AA! 0>=
    IF
    16\p>ad H@ EXIT
    THEN
    ar-idx 16array + @EXECUTE ;

    : 32ARA> \ ( ? k pfa — ? ) depending on program
    OVER idxV AA! 0>=
    IF
    32\p>ad @ EXIT
    THEN
    ar-idx 32array + @EXECUTE ;

    : 64ARA> \ ( ? k pfa — ? ) depending on program
    OVER idxV AA! 0>=
    IF
    64\p>ad 2@ EXIT
    THEN
    ar-idx 64array + @EXECUTE ;

    : AR-CREATE \ ( j’ i’ — j’ i’ )
    CREATE \ <name> of array is required
    2DUP , , d-pfa , ;

    : AR-CR2 \ ( j’*i’modified — )
    0 DO 0 , LOOP ;

    \ end j+1 = j’ i’ = i+1 end minimum j’ is 1
    \ form array ( j’ i’ ) bARRAY <name> \ 1bit 2-dimensional array
    : bARRAY AR-CREATE 1BiTS>CELL * AR-CR2 DOES> 1ARA> ;
    : 2ARRAY AR-CREATE 2BiTS>CELL * AR-CR2 DOES> 2ARA> ;
    : 4ARRAY AR-CREATE 4BiTS>CELL * AR-CR2 DOES> 4ARA> ;
    : cARRAY AR-CREATE 8BiTS>CELL * AR-CR2 DOES> 8ARA> ;
    : hARRAY AR-CREATE 16BiT>CELL * AR-CR2 DOES> 16ARA> ;
    : ARRAY AR-CREATE * AR-CR2 DOES> 32ARA> ;
    : DARRAY AR-CREATE 2* * AR-CR2 DOES> 64ARA> ;

    \ end of arrays = = = = = = = = = = = =
    \ end of arrays = = = = = = = = = = = =

    \ Explanation, how one may use these arrays.
    \ One most often uses arrays to store numbers by index.
    \ Another use is to store characters by index, typically read only.

    \ Simple CELL number storage in an array
    \ A typical single dimensional array
    \ I name each of my arrays RAxxxx, so that the name leaps out to me
    \ that my program deals with an array.

    1 6 ARRAY RAtest1 \ ( y’ x’ — ) <name>
    \ definition of a new array, legal i = 0,1,2,3,4,5
    \ y’ dimension 1, x’ dimension 6

    1111 5 !Ray RAtest1 \ ( n i !Ray — ) store a number into RAtest1
    CR
    5 RAtest1 . \ ( i — n ) fetch a number
    \ will print out stored number
    \ 1111 ok
    CR
    6 RAtest1 . \ ( i — n ) fetch a number, illegal too high index
    \ will print out
    \ 32bit array i index error 6 RAtest1 0 ok
    \ the error prints out, but no ABORT
    \ the error renders i=0, the stack depth is correct

    \ most often I use single dimensional arrays
    \ but one can use two dimensional arrays if desired

    3 6 ARRAY RAtest2 \ ( y’ x’ — ) <name>
    \ definition of a new array, legal i = 0,1,2,3,4,5
    \ y’ dimension 3, x’ dimension 6 j = 0,1,2

    2222 5 !Ray RAtest2 \ ( n i !Ray — ) store a number into RAtest2
    CR
    5 RAtest2 . \ ( i — n ) fetch a number
    \ 2222 ok

    \ what is j? j is 0 persistently one may change j various ways
    1 j!Ray RAtest2 \ ( j j!Ray — ) will change j persistently to 1
    3333 5 !Ray RAtest2 \ ( n i !Ray — ) store a number into RAtest2
    CR
    5 RAtest2 .
    \ 3333 ok
    CR \ direct entry of i and j
    5 0 ij@Ray RAtest2 . \ ( i j ij@Ray — n ) j is now 0 persistently
    \ 2222 ok

    4444 3 2 ij!Ray RAtest2 \ ( n i j ij!Ray — ) direct entry of n i j
    CR \ j is now 2 persistently
    3 RAtest2 .
    \ 4444 ok

    \ reference j0Ray in array constants to estab j and give i=0 address
    \ reference a0Ray in array constants to give i=0 for already given j

    \ example of arrays holding strings, load read-only character arrays
    \ two examples, uncounted string storage, counted string storage

    3 CONSTANT jfiles \ we will store 3 strings
    9 CONSTANT ichars \ string of 9 characters

    jfiles ichars cARRAY RAufiles \ uncounted string, char array 8 bits
    jfiles ichars 1+ cARRAY RAcfiles \ counted string, char array 8 bits

    S” file0.dat” 0 j0Ray RAufiles SWAP CMOVE \ load
    S” file1.dat” 1 j0Ray RAufiles SWAP CMOVE \ arrays
    S” file2.dat” 2 j0Ray RAufiles SWAP CMOVE \ with characters

    ichars 0 j0Ray RAcfiles C! S” file0.dat” a0Ray RAcfiles 1+ SWAP CMOVE
    ichars 1 j0Ray RAcfiles C! S” file1.dat” a0Ray RAcfiles 1+ SWAP CMOVE
    ichars 2 j0Ray RAcfiles C! S” file2.dat” a0Ray RAcfiles 1+ SWAP CMOVE

    : .TESTFILES
    jfiles 0
    DO
    CR
    I j0Ray RAufiles ichars TYPE 5 SPACES \ uncounted string
    I j0Ray RAcfiles COUNT TYPE \ counted string
    LOOP ;
    { ————— prints as
    file0.dat file0.dat
    file1.dat file1.dat
    file2.dat file2.dat ok
    ————————- }

    #4630

    edward wicks
    Participant

    I am newbie member. essaydone how do we participate in multiple posts ?

    #4635

    allen@a2d2.com
    Participant

    Not sure how to answer. I imagine just by filling in the “Reply To: ………”
    Best wishes — Allen

Viewing 3 posts - 1 through 3 (of 3 total)

You must be logged in to reply to this topic.