Loesung der hausaufgabe vom 10.08.2020

dictionary-based-on-array.fs

: BOUNDS ( addr len -- limit start )
 over + swap ;

\ simple 1 Byte hash 0-$FF
: HASH ( addr -- hash )
 count         \ get addr len from string addr
 $1F AND       \ limit length of string
 tuck bounds   \ setup loop
 ?DO           \ loop over string
   I C@ +      \ add char values
 LOOP
 $FF AND ;     \ limit to 255 values

: persist ( addr len -- addr )
  HERE >R    \ save current directory pointer
  DUP C,     \ store length of string
  DUP ALLOT  \ reserve space for string
  R@  1+     \ get saved directory pointer and adjust
  SWAP CMOVE \ save string
  R>         \ return address
;

: DICTIDX ( n -- 'n )
  2 * CELLS ;

: (DICTERROR     ABORT" Array out of bounds!" ;

: DICTIONARY ( -- )
 CREATE                \ create word header
 HERE >R               \ save current directory pointer
    $100 DICTIDX ALLOT \ allocate memory for dictionary
 R> $100 DICTIDX ERASE \ erase memory -- fill with zero
 DOES> (  addr )       \ runtime: place own address on stack
;

: dict-put ( value key dict-addr -- )
  SWAP DUP >R           ( value dict-addr key )
  HASH DICTIDX          ( value dict-addr key-idx )
  + DUP                 ( value addr addr )
  R> SWAP !             ( value addr )
  CELL + !
;

: dict-clear ( dict-addr -- )
  $100 DICTIDX ERASE ;

: dict-get    ( key dict-addr default-xt -- xt )
  >R                            ( key dict-addr )
  SWAP HASH DICTIDX + CELL + @  ( value )
  DUP 0= IF
   DROP R>                      ( default-xt )
  ELSE
    R> DROP                     ( value-xt )
  THEN
;

: dict-items  ( dict-addr -- addr-x ... addr-1 cnt )
  0 $100 0 DO              ( addr cnt )
    SWAP DUP               ( cnt addr addr )
    I DICTIDX + CELL +  @  ( cnt addr val  )
    DUP IF
      ROT 1 +              ( addr val cnt  )
      ROT SWAP             ( val addr cnt  )
    ELSE
      DROP SWAP            ( addr cnt )
    THEN
  LOOP                     ( addr cnt )
  NIP
;

: dict-keys ( dict-addr -- k-addr-x ... k-addr-1 cnt )
  0 $100 0 DO              ( addr cnt )
    SWAP DUP               ( cnt addr addr )
    I DICTIDX +  @         ( cnt addr key  )
    DUP IF
      ROT 1 +              ( addr key cnt  )
      ROT SWAP             ( key addr cnt  )
    ELSE
      DROP SWAP            ( addr cnt )
    THEN
  LOOP                     ( addr cnt )
  NIP
;

: dict> ( key dict-addr default-xt -- xt )
  >R                    ( key dict-addr )
  SWAP HASH DICTIDX +   ( addr )
  DUP CELL + @ SWAP     ( value addr )
  DUP 0 SWAP !          ( value addr )
  CELL + 0 SWAP !       ( value )
  DUP 0= IF
   DROP R>              ( default-xt )
  ELSE
    R> DROP             ( value )
  THEN
;

\ Test 

dictionary mydict    \ creating the dictionary

' words  S" woerter"     persist mydict  dict-put
' .s     S" zeige-stack" persist mydict  dict-put
' +      S" addiere"     persist mydict  dict-put

: noop ." Nix" cr ;

: 'noop ( -- xt )  \ returns XT of noop
 ['] noop ;

'noop execute     \ should print "Nix"

\ this should run "words"
S" woerter"  persist  mydict  'noop  dict-get execute

\ this should print "Nix"
S" undefined"  persist  mydict 'noop dict-get execute

CR
.( Done )