(
 * LANGUAGE    : ANS Forth with DFW extensions
 * PROJECT     : DFW Forth Environments
 * DESCRIPTION : Associative Arrays
 * CATEGORY    : String Utilities
 * AUTHOR      : Marcel Hendrix 
 * LAST CHANGE : July 24, 1993, Marcel Hendrix 
 )



        NEEDS -miscutil
	NEEDS -arrays
	NEEDS -strings

        REVISION -assarray " Associative Arrays  Version 1.01 "

	PRIVATES


(
(
 Associative Arrays. Arrays of type integer, with string type indices.
 The index is automatically build in <assocs>, so the names do not have to be
 defined before they are used. The name can be build while compiling;

  4 ASSOCIATIVE fools

  : foo  69 TO S" Reagan" fools ; foo      \ Ok!
  : bar  69 -ROT fools ;  S" Reagan" bar   \ Is ok.
)
)

\ The string to index the array cannot be longer than 31 characters.
\ This is a Forth internal "problem" and has nothing to do with array sizes.

	WORDLIST =: <assocs> PRIVATE

STRING thead$  PRIVATE	#36 NEW thead$   S" $=: " TO thead$ ( 4 chars)
0 =: aconstant PRIVATE

: $=:		CREATE	, 			\ <n> $=: "name" -> <>
			$BADBEEF ,
			@LATEST HEAD>NAME ,
			0 ,			\ link to next index
		DOES>	2 CELLS + @ COUNT ;	\ <> --- <c-addr> <u>

\ Release memory used for array.

: RELEASE	CELL+ DUP @  SWAP OFF		\ <pfa> --- <>
		FREE ?ALLOCATE  ; PRIVATE	 

: 'ARRAY	EVAL" ILIT []CELL " ; PRIVATE	\ <index> --- <address>

: DO-ASSOC	   LOCAL pvar 			\ <?> <$id> <adr> <%var> --- <>
		@+ LOCAL size  LOCAL 'adm	
		2DUP <assocs> SEARCH-WORDLIST
		0= IF 'adm CELL+ @ size U>= ABORT" ASSOCIATIVE: bounds"
		      +TO thead$
		      GET-CURRENT   
		        <assocs> SET-CURRENT
		        'adm CELL+ @ thead$ EVALUATE
			1  'adm CELL+  +!
			@LATEST SWAP
		      SET-CURRENT
		      4 LEFT thead$ TO thead$

		      HEAD> @ >BODY 3 CELLS +	\ link all indices
		      2  'adm []CELL
		      >S   S @ OVER !  S> !

		      'adm CELL+ @ 1-
		 ELSE NIP NIP >BODY 
		      @+ SWAP @ $BADBEEF <> ABORT" ASSOCIATIVE: bad index"
		ENDIF 
		( cte\ ) 'adm @	  	\ address of data
		pvar
		CASE 
		( +to)	 -1 OF 'ARRAY 	 EVAL" +! "     ENDOF
		( from)	  0 OF 'ARRAY 	 EVAL" @ "      ENDOF
		( to)	  1 OF 'ARRAY 	 EVAL" ! "      ENDOF
		( 0to)	  2 OF 'ARRAY    EVAL" OFF "    ENDOF
		( 'of)	  3 OF 		       ALITERAL ENDOF
		( sizeof) 4 OF DROP size CELLS ILITERAL ENDOF
		( /of)	  5 OF DROP size       ILITERAL ENDOF
		( addr)   6 OF 'ARRAY	  	        ENDOF
			  DUP ABORT" ASSOCIATIVE: undefined message"
		ENDCASE ; PRIVATE


: ASSOCIATIVE	
	CREATE	DUP  , DUP CELLS ALLOCATE	\ <max ix> ASSOCIATIVE "name"
		                ?ALLOCATE 	\ max_index
		DUP  , SWAP CELLS ERASE		\ address
		1    ,				\ latest index
		HERE CELL+ ,  0 , 		\ head of list
		IMMEDIATE
	FORGET>	RELEASE
	DOES>	%VAR @  0 %VAR !  		\ <$id> --- <addr>
		STATE @ IF  SWAP ALITERAL ILITERAL 
			    POSTPONE DO-ASSOC 
			    EXIT 
		     ENDIF 
		DO-ASSOC ;


: (IN)		@ 1 ; PRIVATE		\ <addr> --- <u> <l>

: IN		' >BODY	2 CELLS +	\ IN #<name># -> <uindex> <lindex>
		STATE @ IF  ALITERAL POSTPONE (IN)
		      ELSE  (IN)
		     ENDIF ; IMMEDIATE

CREATE xx PRIVATE ," <<doesn't exist>>"

: (INDEX)	SWAP LOCAL target 	\ <n> <addr> --- <c-addr> <u>
		BEGIN @  DUP 0= IF DROP xx COUNT EXIT ENDIF
		      DUP 3 CELLS - @ target =
		UNTIL
		CELL- @ COUNT ; PRIVATE

: $-OF		' >BODY 3 CELLS +	\ <n> $-OF #<name># -> <c-addr> <u>
		STATE @ IF  ALITERAL POSTPONE (INDEX)
		      ELSE  (INDEX)
		     ENDIF ; IMMEDIATE


		DEPRIVE

                              ( End of Source )
