Add basic (non-balancing binary tree) hash-table implementation & test.

src/hash-table.rls

@@ -0,0 +1,85 @@
+;; Requires: make-structure equal?
+   
+(define s:hash-table-node (make-structure '() 5))
+(define (make-hash-table-node hash key val [left #f] [right #f])
+  (let ([node (make-struct s:hash-table-node)])
+    (struct-set! node 0 hash)
+    (struct-set! node 1 key)
+    (struct-set! node 2 val)
+    (struct-set! node 3 left)
+    (struct-set! node 4 right)
+    node))
+
+(define (hash-table-node-hash node)        (struct-ref node 0))
+(define (hash-table-node-key node)         (struct-ref node 1))
+(define (hash-table-node-value node)       (struct-ref node 2))
+(define (hash-table-node-left-child node)  (struct-ref node 3))
+(define (hash-table-node-right-child node) (struct-ref node 4))
+
+(define (hash-table-node-hash-set! node v)        (struct-set! node 0 v))
+(define (hash-table-node-key-set! node v)         (struct-set! node 1 v))
+(define (hash-table-node-value-set! node v)       (struct-set! node 2 v))
+(define (hash-table-node-left-child-set! node v)  (struct-set! node 3 v))
+(define (hash-table-node-right-child-set! node v) (struct-set! node 4 v))
+
+(define s:hash-table (make-structure '() 3))
+(define (make-hash-table [hash-fn (lambda (x) (hash-value x))]
+                         [eq-fn (lambda (x y) (equal? x y))])
+  (let ([ht (make-struct s:hash-table)])
+    (struct-set! ht 0 hash-fn)
+    (struct-set! ht 1 eq-fn)
+    (struct-set! ht 2 #f)
+    ht))
+
+(define (hash-table-hash-function ht) (struct-ref ht 0))
+(define (hash-table-eq-function ht)   (struct-ref ht 1))
+(define (hash-table-root-node ht)     (struct-ref ht 2))
+
+(define (hash-table-hash-function-set! ht v) (struct-set! ht 0 v))
+(define (hash-table-eq-function-set! ht v)   (struct-set! ht 1 v))
+(define (hash-table-root-node-set! ht v)     (struct-set! ht 2 v))
+
+(define (hash-table-lookup ht key [not-found (lambda () #f)])
+  (let ([hash ((hash-table-hash-function ht) key)]
+        [eq-fn (hash-table-eq-function ht)])
+    (let search ([node (hash-table-root-node ht)])
+      (if node
+          (let ([node-hash (hash-table-node-hash node)])
+            (cond
+              [(and (fix= hash node-hash)
+                    (eq-fn (hash-table-node-key node) key))
+                (hash-table-node-value node)]
+              [(fix<= hash node-hash)
+                (search (hash-table-node-left-child node))]
+              [else
+                (search (hash-table-node-right-child node))]))
+          (not-found)))))
+
+; TODO: Implement balancing
+(define (hash-table-insert ht key val [collision (lambda (oldv) val)])
+  (let ([hash ((hash-table-hash-function ht) key)]
+        [eq-fn (hash-table-eq-function ht)])
+    (if (not (hash-table-root-node ht))
+        (hash-table-root-node-set! ht
+         (make-hash-table-node hash key val))
+        (let search ([node (hash-table-root-node ht)])
+          (let ([node-hash (hash-table-node-hash node)])
+            (cond
+              [(and (fix= hash node-hash)
+                    (eq-fn (hash-table-node-key node) key))
+                (hash-table-node-value-set! node
+                 (collision (hash-table-node-value node)))]
+              [(fix<= hash node-hash)
+                (let ([child (hash-table-node-left-child node)])
+                  (if child
+                      (search child)
+                      (hash-table-node-left-child-set! node
+                       (make-hash-table-node hash key val))))]
+              [else
+                (let ([child (hash-table-node-right-child node)])
+                  (if child
+                      (search child)
+                      (hash-table-node-right-child-set! node
+                       (make-hash-table-node hash key val))))]))))))
+
+; vim:set syntax=scheme sw=2 expandtab:

src/reader.rls

@@ -1,3 +1,6 @@
+(load "util.rls")
+(load "hash-table.rls")
+
 (define s:symbol (struct-type 'a))
 (define *symbols* '())
 
@@ -64,6 +67,19 @@
           [(eq? current-char #\|)
              (next-char)
              (read-symbol #t)]
+          [(eq? current-char #\')
+             (next-char)
+             (list 'quote (read-one-value))]
+          [(eq? current-char #\`)
+             (next-char)
+             (list 'backquote (read-one-value))]
+          [(eq? current-char #\,)
+             (next-char)
+             (if (eq? current-char #\@)
+                 (begin
+                   (next-char)
+                   (list 'unquote-splicing (read-one-value)))
+                 (list 'unquote (read-one-value)))]
           [(symbol-char? current-char)
              (read-symbol)]
           [else
@@ -72,13 +88,16 @@
       (define (read-special)
         (cond
           [eof? (unexpected-eof)]
+          [(eq? current-char #\;)
+             (next-char)
+             (read-one-value)
+             (read-one-value)]
           [(eq? current-char #\!)
              (unless (and (eq? line 1) (eq? column 2)) (unexpected-char))
-             (define (skip-until-newline)
+             (let skip-until-newline ()
                (next-char)
                (unless (or eof? (eq? current-char #\Newline))
                  (skip-until-newline)))
-             (skip-until-newline)
              (read-one-value)]
           [(memq? current-char '(#\F #\f))
              (next-char)
@@ -183,21 +202,56 @@
                        (fix< (digit->integer current-char) radix))
             (unexpected-char))
    
-          (define (iter accum)
+          (let ([pos-val (let iter ([accum 0])
-            (if eof?
+                           (if eof?
-                accum
+                               accum
-                (let ([val (digit->integer current-char)])
+                               (let ([val (digit->integer current-char)])
-                  (if (and val (fix< val radix))
+                                 (if (and val (fix< val radix))
-                      (begin
+                                     (begin
-                        (next-char)
+                                       (next-char)
-                        (iter (fix+ (fix* accum radix) val)))
+                                       (iter (fix+ (fix* accum radix) val)))
-                      accum))))
+                                     accum))))])
-   
-          (let ([pos-val (iter 0)])
             (if neg? (fix- pos-val) pos-val))))
 
       (define (read-number)
-        (read-fixnum))
+        (let ([negative (cond [(eq? current-char #\-) (next-char) #t]
+                              [(eq? current-char #\+) (next-char) #f]
+                              [else #f])])
+          (unless (decimal-char? current-char) (unexpected-char))
+          (let ([radix (if (eq? current-char #\0)
+                           (begin
+                             (next-char)
+                             (cond [(memq current-char '(#\X #\x)) (next-char) 16]
+                                   [(memq current-char '(#\B #\b)) (next-char)  2]
+                                   [(decimal-char? current-char)                8]
+                                   [else                                       10]))
+                           10)])
+            (let ([num (let iter ([num 0])
+                         (if (alphanumeric-char? current-char)
+                             (let ([digit (digit->integer current-char)])
+                               (if (fix< digit radix)
+                                   (begin
+                                     (next-char)
+                                     (iter (fix+ (fix* num radix) digit)))
+                                   num))
+                             num))])
+              (if (or (not (eq? radix 10))
+                      (not (memq current-char '(#\. #\E #\e))))
+                  (if negative (fix- num) num)
+                  (let ([flt (make-float num)])
+                    (when (eq? current-char #\.)
+                      (next-char)
+                      (let iter ([pv (if negative -0.1 0.1)])
+                        (if (decimal-char? current-char)
+                            (let ([digit (make-float (digit->integer current-char))])
+                              (set! flt (float+ flt (float* digit pv)))
+                              (next-char)
+                              (iter (float/ pv 10)))
+                            (values))))
+                    (when (memq current-char '(#\E #\e))
+                      (next-char)
+                      (set! flt (float* flt (pow 10.0 (make-float (read-fixnum 10))))))
+                    (if negative (float- flt) flt)))))))
 
       (define (read-box)
         (make-box (read-one-value)))
@@ -263,14 +317,13 @@
                       (skip-ws #t)
                       (read-one-char)]
                    [(eq? current-char #\;)
-                      (define (skip-to-nl+ws)
+                      (let skip-to-nl+ws ()
                         (when eof? (unexpected-eof))
                         (if (eq? current-char #\Newline)
                             (skip-ws #t)
                             (begin
                               (next-char)
                               (skip-to-nl+ws))))
-                      (skip-to-nl+ws)
                       (read-one-char)]
                    [else
                       (let ([item (findf (lambda (x) (eq? (car x) current-char))
@@ -296,32 +349,30 @@
           read-chars
           (lambda (revchars len)
             (let ([str (make-byte-string len #\Null)])
-              (define (iter n rc)
+              (let iter ([n (fix- len 1)]
+                         [rc revchars])
                 (when (fix>= n 0)
                   (byte-string-set! str n (car rc))
                   (iter (fix- n 1) (cdr rc))))
-              (iter (fix- len 1) revchars)
               str))))
 
       (define (read-vector)
         (let* ([items (read-list)]
                [len (list-length items)]
                [vec (make-vector len #f)])
-          (define (iter n rst)
+          (let iter ([n 0] [rst items])
             (when (pair? rst)
               (vector-set! vec n (car rst))
               (iter (fix+ n 1) (cdr rst))))
-          (iter 0 items)
           vec))
 
       (define (read-struct)
         (let* ([items (read-list)]
                [struct (make-struct (car items))])
-          (define (iter n rst)
+          (let iter ([n 0] [rst (cdr items)])
             (when (pair? rst)
               (struct-set! struct n (car rst))
               (iter (fix+ n 1) (cdr rst))))
-          (iter 0 (cdr items))
           struct))
 
       (define (read-symbol [quoted? #f])
@@ -349,11 +400,10 @@
         (let* ([chars (read-chars)]
                [len (list-length chars)]
                [str (make-byte-string len #\Null)])
-          (define (iter n rst)
+          (let iter ([n 0] [rst chars])
             (when (fix< n len)
               (byte-string-set! str n (car rst))
               (iter (fix+ n 1) (cdr rst))))
-          (iter 0 chars)
           (intern str)))
 
       (define (skip-whitespace)
@@ -363,12 +413,11 @@
                (next-char)
                (skip-whitespace)]
             [(eq? current-char #\;)
-               (define (skip-until-newline)
+               (let skip-until-newline ()
                  (let ([ch current-char])
                    (next-char)
                    (unless (eq? ch #\Newline)
-                     (skip-until-newline))))
+                     (skip-until-newline))))])))
-               (skip-until-newline)])))
 
       (define (next-char)
         (if eof?
@@ -438,11 +487,10 @@
       newcdr))
 
 (define (list-length lst)
-  (define (iter n rst)
+  (let iter ([n 0] [rst lst])
     (if (pair? rst)
         (iter (fix+ n 1) (cdr rst))
-        n))
+        n)))
-  (iter 0 lst))
 
 (define (digit->integer ch)
   (cond
@@ -453,113 +501,4 @@
 
 (read-from-fd 0)
 
-; static value_t read_number(reader_state_t *state)
-; {
-;   bool negative = false;
-;   fixnum_t num = 0;
-;   native_float_t flt;
-;   int radix;
-; 
-;   if (state->ch == '-')
-;   {
-;     negative = true;
-;     next_char(state);
-;   }
-;   else if (state->ch == '+')
-;   {
-;     next_char(state);
-;   }
-; 
-;   release_assert(isdigit(state->ch));
-; 
-;   if (state->ch == '0')
-;   {
-;     next_char(state);
-; 
-;     switch (state->ch)
-;     {
-;     case 'X':
-;     case 'x':
-;       radix = 16;
-;       next_char(state);
-;       break;
-;     case 'B':
-;     case 'b':
-;       radix = 2;
-;       next_char(state);
-;       break;
-;     case '0' ... '9':
-;       radix = 8;
-;       break;
-;     default:
-;       radix = 10;
-;       break;
-;     }
-; 
-;     if (radix != 10)
-;     {
-;       release_assert(isalnum(state->ch));
-;       release_assert(char_to_digit(state->ch) < radix);
-;     }
-;   }
-;   else
-;   {
-;     radix = 10;
-;   }
-; 
-;   while (isalnum(state->ch))
-;   {
-;     fixnum_t digit = char_to_digit(state->ch);
-; 
-;     if (digit >= radix)
-;       break;
-; 
-;     release_assert(num <= (FIXNUM_MAX/radix));
-; 
-;     num *= radix;
-;     num += digit;
-; 
-;     next_char(state);
-;   }
-; 
-;   if ((radix != 10) || ((state->ch != '.') && (state->ch != 'E') && (state->ch != 'e')))
-;   {
-;     if (negative)
-;       num = -num;
-;     release_assert(!issymbol(state->ch));
-;     release_assert((FIXNUM_MIN <= num) && (num <= FIXNUM_MAX));
-;     return fixnum_value(num);
-;   }
-; 
-;   /*
-;    * Floating-point. No guarantees as to precision... really should use binary/hex.
-;    */
-; 
-;   flt = num;
-; 
-;   if (state->ch == '.')
-;   {
-;     next_char(state);
-; 
-;     for (native_float_t pv = negative ? -0.1 : 0.1; isdigit(state->ch); pv /= 10)
-;     {
-;       flt += (state->ch - '0') * pv;
-;       next_char(state);
-;     }
-;   }
-; 
-;   if ((state->ch == 'E') || (state->ch == 'e'))
-;   {
-;     next_char(state);
-;     num = read_fixnum(state, 10);
-;     flt *= pow(10, _get_fixnum(num));
-;   }
-; 
-;   if (negative)
-;     flt = -flt;
-; 
-;   release_assert(!issymbol(state->ch));
-;   return make_float(flt);
-; }
-
 ; vim:set syntax=scheme sw=2 expandtab:

src/test-hash-table.rls

@@ -0,0 +1,17 @@
+(load "util.rls")
+(load "hash-table.rls")
+
+(define ht (make-hash-table))
+
+(hash-table-insert ht "test" 5)
+(hash-table-insert ht "a longer key" '(4 5 6))
+(hash-table-insert ht '(9 8 7) "backwards")
+
+(values
+  (hash-table-lookup ht "test")
+  (hash-table-lookup ht "no such key")
+  (hash-table-lookup ht "a longer key")
+  (hash-table-lookup ht '(7 8 9))
+  (hash-table-lookup ht '(9 8 7)))
+
+; vim:set syntax=scheme sw=2 expandtab:

src/util.rls

@@ -0,0 +1,35 @@
+(define (copy-list lst)
+  (if (pair? lst)
+      (cons (car lst) (copy-list (cdr lst)))
+      lst))
+
+(define (make-structure supers nslots [callable #f])
+  (let ([s (make-struct structure)])
+    (struct-set! s 0 (copy-list supers))
+    (struct-set! s 1 nslots)
+    (struct-set! s 2 callable)
+    (freeze! s)))
+
+(define (eqv? x y)
+  (or (eq? x y)
+      (and (float? x)
+           (float? y)
+           (float= x y))
+      (and (byte-string? x)
+           (byte-string? y)
+           (byte-string= x y))))
+
+; Caveat: does not handle cyclic lists
+(define (equal? x y)
+  (or (eqv? x y)
+      (and (pair? x)
+           (pair? y)
+           (equal? (car x) (car y))
+           (equal? (cdr x) (cdr y)))))
+
+(define (trace tag [val #f])
+  (posix-write 1 tag (byte-string-size tag))
+  (posix-write 1 "\n" 1)
+  val)
+
+; vim:set syntax=scheme sw=2 expandtab: