• branch=trunk inherited from [dc67bca1f3]
• sym-trunk inherited from [dc67bca1f3]

Added user/crc/alexandria.retro version [86da31cff5aaaa16]

@@ -0,0 +1,128 @@
+( Alexandria ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
+( This is the start of some experiments in tracking metadata  )
+( for a personal ebook library.                               )
+( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
+( Copyright 2010, Charles Childers                            )
+( Copyright 2010, Marc Simpson                                )
+( Copyright 2010, Jay Skeer                                   )
+( Copyright 2010, Luke Parrish                                )
+( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
+
+vocab hashing
+((
+  {{
+    : abs  dup 0 <if neg then ;
+    ---reveal---
+    ( Dan Bernstein, comp.lang.c with 'abs' hack )
+    : djb2 ( $-n )
+      5381 over getLength fori push
+      dup 5 << + over pop + @ + nexti nip abs ;
+  }}
+
+  ( 193, 389, 769 are all pretty good; if you expect to have )
+  ( a lot of keys, use a larger prime.                       )
+  389 variable: hash-prime
+
+  ( Vector the favoured hash function -- we intend to offer  )
+  ( a range of implementations and allow the user to choose  )
+  : hash ( $-n ) djb2 hash-prime @ mod ;
+))
+
+vocab link-list
+((
+  : ll.make   (  -l ) here 2 allot ;
+  : ll.data   ( l-a ) 1+ ;
+  : llv.push  ( la- )  dup push @ over ( ll.next ) ! pop ! ;
+  : llv.pop   ( a-l )  dup push @ dup ( ll.next ) @ pop ! ;
+
+  0 variable: ll:freelist
+  : ll.new    ( -l )
+    ll:freelist dup @ 0 !if llv.pop ;; then drop ll.make ;
+  : ll.free   ( l-  )  ll:freelist llv.push ;
+  : llv.!+    ( xa- )  dup push @ ll.new dup pop ! !+ ! ;
+  : llv.@-    ( a-x )  llv.pop dup ll.data @ swap ll.free ;
+))
+
+vocab array
+((
+  : array{ ( C:-a ) here dup 0 , ;
+  : }array ( C:a- ) here over -  1- swap ! ;
+
+  : foreach{  ` @+ ` for ` @+ ; compile-only
+  : }loop     ` next `  drop  ; compile-only
+  : .array foreach{ . }loop ;
+))
+
+vocab associative
+((
+  : preallocate ( n- )
+    ll.make ll:freelist !  for ll.make ll.free next ;
+
+  1000 preallocate
+
+  : new-hash   (   -t ) here hash-prime @ zallot ;
+  : new-bucket ( $x-a ) here push swap , , pop ;
+
+  : add-entry ( $xt- )
+    push  over hash push new-bucket pop ( ah )
+    pop ( aht ) + ( ae ) swap
+    ll.new tuck ll.data !
+    ( el ) over @ over ! ( next pointer )
+    swap ! ;
+
+  : get-entry (  $t-xf )
+    over hash + @ ( $l )
+    repeat dup 0 =if nip 0 ;then
+    2dup ll.data @ @ compare if nip ll.data @ 1+ @ -1 ;then
+    @ again ;
+
+  {{
+    : chop (  $-$ ) dup getLength + 1- 0 swap ! ;
+    : (%{) ( "- ) char: = accept tib keepString dup chop ;
+    ---reveal---
+    : %{   ( "- ) @compiler if ahead (%{) here rot ! literal,
+                  else (%{) then ; immediate
+  }}
+
+  : }%   ( t$x- ) rot add-entry ;
+  : @"   (  t"- ) @compiler if
+                  ahead " keepString here rot ! literal, else "
+                  then ` swap ` get-entry ; immediate
+
+  : 'type'   ( $- ) char: ' emit type char: ' emit space ;
+
+  {{
+    : bkt-keys ( l- ) repeat 0; dup 1+ @ @ , @ again drop ;
+    : (keys)   ( t- ) hash-prime @ for @+ bkt-keys next drop ;
+    ---reveal---
+    : keys  ( t-a )
+      here 0 , swap  (keys)  here over - 1- over ! ;
+  }}
+
+  : keys{ ( R: t- ) ` keys  ` dup ` push `  foreach{ ; compile-only
+  : }keys ( R:  - ) ` }loop ` pop ` here ` - ` allot ; compile-only
+
+  : .keys ( t-  )
+    char: { emit space  keys{ 'type' }keys  char: } emit ;
+
+  ( xyz -> xyzx: like 'rot', but _copies_ rotated item )
+  : rover ` push ` over ` pop ` swap ; compile-only
+
+  : .table ( t- )
+    dup
+    keys{ dup cr 'type' ." => " rover get-entry drop . }keys
+    drop ;
+))
+
+( Data ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
+: $" " keepString ;
+
+new-hash constant book
+
+book %{ title = $" A Book" }%
+book %{ author = $" Charles Childers" }%
+book %{ genre = $" Fiction" }%
+
+: .title  ( a- ) @" title"  if type else drop then ;
+: .author ( a- ) @" author" if type else drop then ;
+: .genre  ( a- ) @" genre"  if type else drop then ;