diff --git a/src/hash-table.rls b/src/hash-table.rls new file mode 100644 index 0000000..ee1accd --- /dev/null +++ b/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: diff --git a/src/reader.rls b/src/reader.rls index 5c29920..0ff8269 100644 --- a/src/reader.rls +++ b/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) - (if eof? - accum - (let ([val (digit->integer current-char)]) - (if (and val (fix< val radix)) - (begin - (next-char) - (iter (fix+ (fix* accum radix) val))) - accum)))) - - (let ([pos-val (iter 0)]) + (let ([pos-val (let iter ([accum 0]) + (if eof? + accum + (let ([val (digit->integer current-char)]) + (if (and val (fix< val radix)) + (begin + (next-char) + (iter (fix+ (fix* accum radix) val))) + accum))))]) (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)) - (iter 0 lst)) + n))) (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: diff --git a/src/test-hash-table.rls b/src/test-hash-table.rls new file mode 100644 index 0000000..84d789b --- /dev/null +++ b/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: diff --git a/src/util.rls b/src/util.rls new file mode 100644 index 0000000..2c4e995 --- /dev/null +++ b/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: