conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* renamed all hash-table primitives to their r6rs counterparts.

This commit is contained in:
Abdulaziz Ghuloum 2007-10-09 09:22:02 -04:00
parent 75692f0306
commit 241bdd8d4d
7 changed files with 87 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

25
src/ikarus.compiler.ss
View File

@ -4,6 +4,7 @@
assembler-output assembler-output
current-primitive-locations eval-core) current-primitive-locations eval-core)
(import (import
(rnrs hashtables)
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (ikarus system $pairs)
(only (ikarus system $codes) $code->closure) (only (ikarus system $codes) $code->closure)
@ -473,10 +474,10 @@
(define (optimize-letrec x) (define (optimize-letrec x)
(define who 'optimize-letrec) (define who 'optimize-letrec)
(define (extend-hash lhs* h ref) (define (extend-hash lhs* h ref)
(for-each (lambda (lhs) (put-hash-table! h lhs #t)) lhs*) (for-each (lambda (lhs) (hashtable-set! h lhs #t)) lhs*)
(lambda (x) (lambda (x)
(unless (get-hash-table h x #f) (unless (hashtable-ref h x #f)
(put-hash-table! h x #t) (hashtable-set! h x #t)
(ref x)))) (ref x))))
(define (E* x* ref comp) (define (E* x* ref comp)
(cond (cond
@ -488,11 +489,11 @@
(cond (cond
[(null? rhs*) '()] [(null? rhs*) '()]
[else [else
(let ([h (make-hash-table)]) (let ([h (make-hashtable)])
(let ([ref (let ([ref
(lambda (x) (lambda (x)
(unless (get-hash-table h x #f) (unless (hashtable-ref h x #f)
(put-hash-table! h x #t) (hashtable-set! h x #t)
(ref x) (ref x)
(when (memq x lhs*) (when (memq x lhs*)
(vector-set! vref i #t))))] (vector-set! vref i #t))))]
@ -506,12 +507,12 @@
(cond (cond
[(null? rhs*) '()] [(null? rhs*) '()]
[else [else
(let ([h (make-hash-table)] (let ([h (make-hashtable)]
[rest (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp)]) [rest (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp)])
(let ([ref (let ([ref
(lambda (x) (lambda (x)
(unless (get-hash-table h x #f) (unless (hashtable-ref h x #f)
(put-hash-table! h x #t) (hashtable-set! h x #t)
(ref x) (ref x)
(when (memq x lhs*) (when (memq x lhs*)
(vector-set! vref i #t))))] (vector-set! vref i #t))))]
@ -539,7 +540,7 @@
(values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)] (values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)]
))])) ))]))
(define (do-recbind lhs* rhs* body ref comp letrec?) (define (do-recbind lhs* rhs* body ref comp letrec?)
(let ([h (make-hash-table)] (let ([h (make-hashtable)]
[vref (make-vector (length lhs*) #f)] [vref (make-vector (length lhs*) #f)]
[vcomp (make-vector (length lhs*) #f)]) [vcomp (make-vector (length lhs*) #f)])
(let* ([ref (extend-hash lhs* h ref)] (let* ([ref (extend-hash lhs* h ref)]
@ -581,7 +582,7 @@
[(primref) x] [(primref) x]
[(bind lhs* rhs* body) [(bind lhs* rhs* body)
(let ([rhs* (E* rhs* ref comp)]) (let ([rhs* (E* rhs* ref comp)])
(let ([h (make-hash-table)]) (let ([h (make-hashtable)])
(let ([body (E body (extend-hash lhs* h ref) comp)]) (let ([body (E body (extend-hash lhs* h ref) comp)])
(make-bind lhs* rhs* body))))] (make-bind lhs* rhs* body))))]
[(recbind lhs* rhs* body) [(recbind lhs* rhs* body)
@ -600,7 +601,7 @@
(map (lambda (x) (map (lambda (x)
(record-case x (record-case x
[(clambda-case info body) [(clambda-case info body)
(let ([h (make-hash-table)]) (let ([h (make-hashtable)])
(let ([body (E body (extend-hash (case-info-args info) h ref) void)]) (let ([body (E body (extend-hash (case-info-args info) h ref) void)])
(make-clambda-case info body)))])) (make-clambda-case info body)))]))
cls*) cls*)

15
src/ikarus.fasl.write.ss
View File

@ -2,6 +2,7 @@
(library (ikarus fasl write) (library (ikarus fasl write)
(export fasl-write) (export fasl-write)
(import (import
(rnrs hashtables)
(ikarus system $codes) (ikarus system $codes)
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $records) (ikarus system $records)
@ -61,7 +62,7 @@
(define (count-unshared-cdrs x h n) (define (count-unshared-cdrs x h n)
(cond (cond
[(and (pair? x) (eq? (get-hash-table h x #f) 0)) [(and (pair? x) (eq? (hashtable-ref h x #f) 0))
(count-unshared-cdrs ($cdr x) h ($fxadd1 n))] (count-unshared-cdrs ($cdr x) h ($fxadd1 n))]
[else n])) [else n]))
@ -209,7 +210,7 @@
(lambda (x p h m) (lambda (x p h m)
(cond (cond
[(immediate? x) (fasl-write-immediate x p) m] [(immediate? x) (fasl-write-immediate x p) m]
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (mark) (lambda (mark)
(unless (fixnum? mark) (unless (fixnum? mark)
(error 'fasl-write "BUG: invalid mark ~s" mark)) (error 'fasl-write "BUG: invalid mark ~s" mark))
@ -217,7 +218,7 @@
[(fx= mark 0) ; singly referenced [(fx= mark 0) ; singly referenced
(do-write x p h m)] (do-write x p h m)]
[(fx> mark 0) ; marked but not written [(fx> mark 0) ; marked but not written
(put-hash-table! h x (fx- 0 m)) (hashtable-set! h x (fx- 0 m))
(write-char #\> p) (write-char #\> p)
(write-int m p) (write-int m p)
(do-write x p h (fxadd1 m))] (do-write x p h (fxadd1 m))]
@ -230,11 +231,11 @@
(lambda (x h) (lambda (x h)
(unless (immediate? x) (unless (immediate? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (i) (lambda (i)
(put-hash-table! h x (fxadd1 i)))] (hashtable-set! h x (fxadd1 i)))]
[else [else
(put-hash-table! h x 0) (hashtable-set! h x 0)
(cond (cond
[(pair? x) [(pair? x)
(make-graph (car x) h) (make-graph (car x) h)
@ -284,7 +285,7 @@
[else (error 'fasl-write "~s is not fasl-writable" x)])])))) [else (error 'fasl-write "~s is not fasl-writable" x)])]))))
(define fasl-write-to-port (define fasl-write-to-port
(lambda (x port) (lambda (x port)
(let ([h (make-hash-table)]) (let ([h (make-hashtable)])
(make-graph x h) (make-graph x h)
(write-char #\# port) (write-char #\# port)
(write-char #\@ port) (write-char #\@ port)

21
src/ikarus.hash-tables.ss
View File

@ -1,14 +1,12 @@
(library (ikarus hash-tables) (library (ikarus hash-tables)
(export hash-table? make-hash-table get-hash-table put-hash-table! (export make-hashtable hashtable-ref hashtable-set! hashtable?)
make-hashtable hashtable-ref hashtable-set!)
(import (import
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $vectors) (ikarus system $vectors)
(ikarus system $tcbuckets) (ikarus system $tcbuckets)
(ikarus system $fx) (ikarus system $fx)
(except (ikarus) hash-table? make-hash-table get-hash-table (except (ikarus) make-hashtable hashtable-ref hashtable-set! hashtable?))
make-hashtable put-hash-table! hashtable-ref hashtable-set!))
(define-record hasht (vec count tc)) (define-record hasht (vec count tc))
@ -178,27 +176,24 @@
(init-vec (make-vector n) 0 n))) (init-vec (make-vector n) 0 n)))
;;; public interface ;;; public interface
(define (hash-table? x) (hasht? x)) (define (hashtable? x) (hasht? x))
(define (make-hash-table) (define (make-hashtable)
(let ([x (cons #f #f)]) (let ([x (cons #f #f)])
(let ([tc (cons x x)]) (let ([tc (cons x x)])
(make-hasht (make-base-vec 32) 0 tc)))) (make-hasht (make-base-vec 32) 0 tc))))
(define get-hash-table (define hashtable-ref
(lambda (h x v) (lambda (h x v)
(if (hasht? h) (if (hasht? h)
(get-hash h x v) (get-hash h x v)
(error 'get-hash-table "~s is not a hash table" h)))) (error 'hashtable-ref "~s is not a hash table" h))))
(define put-hash-table! (define hashtable-set!
(lambda (h x v) (lambda (h x v)
(if (hasht? h) (if (hasht? h)
(put-hash! h x v) (put-hash! h x v)
(error 'put-hash-table! "~s is not a hash table" h)))) (error 'hashtable-set! "~s is not a hash table" h))))
(define hashtable-ref get-hash-table)
(define hashtable-set! put-hash-table!)
(define make-hashtable make-hash-table)
) )

54
src/ikarus.pretty-print.ss
View File

@ -1,7 +1,9 @@
(library (ikarus pretty-print) (library (ikarus pretty-print)
(export pretty-print) (export pretty-print)
(import (except (ikarus) pretty-print)) (import
(rnrs hashtables)
(except (ikarus) pretty-print))
(define (map1ltr f ls) (define (map1ltr f ls)
;;; ltr so that gensym counts get assigned properly ;;; ltr so that gensym counts get assigned properly
(cond (cond
@ -454,56 +456,56 @@
(cond (cond
[(pair? x) [(pair? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(set! rv #t) (set! rv #t)
(put-hash-table! h x (fxadd1 n)))] (hashtable-set! h x (fxadd1 n)))]
[else [else
(put-hash-table! h x 0) (hashtable-set! h x 0)
(graph (car x)) (graph (car x))
(graph (cdr x))])] (graph (cdr x))])]
[(vector? x) [(vector? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(set! rv #t) (set! rv #t)
(put-hash-table! h x (fxadd1 n)))] (hashtable-set! h x (fxadd1 n)))]
[else [else
(put-hash-table! h x 0) (hashtable-set! h x 0)
(vec-graph x 0 (vector-length x))])] (vec-graph x 0 (vector-length x))])]
[(gensym? x) [(gensym? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(set! rv #t) (set! rv #t)
(put-hash-table! h x (fxadd1 n)))])])) (hashtable-set! h x (fxadd1 n)))])]))
(define (dynamic x) (define (dynamic x)
(cond (cond
[(pair? x) [(pair? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(set! rv #t) (set! rv #t)
(put-hash-table! h x (fxadd1 n)))] (hashtable-set! h x (fxadd1 n)))]
[else [else
(put-hash-table! h x 0) (hashtable-set! h x 0)
(dynamic (car x)) (dynamic (car x))
(dynamic (cdr x)) (dynamic (cdr x))
(when (and (get-hash-table h x #f) (when (and (hashtable-ref h x #f)
(fxzero? (get-hash-table h x #f))) (fxzero? (hashtable-ref h x #f)))
(put-hash-table! h x #f))])] (hashtable-set! h x #f))])]
[(vector? x) [(vector? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(set! rv #t) (set! rv #t)
(put-hash-table! h x (fxadd1 n)))] (hashtable-set! h x (fxadd1 n)))]
[else [else
(put-hash-table! h x 0) (hashtable-set! h x 0)
(vec-dynamic x 0 (vector-length x)) (vec-dynamic x 0 (vector-length x))
(when (and (get-hash-table h x #f) (when (and (hashtable-ref h x #f)
(fxzero? (get-hash-table h x #f))) (fxzero? (hashtable-ref h x #f)))
(put-hash-table! h x #f))])])) (hashtable-set! h x #f))])]))
(if (print-graph) (if (print-graph)
(graph x) (graph x)
(dynamic x)) (dynamic x))
@ -518,7 +520,7 @@
(cond (cond
[(pair? x) [(pair? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(cond (cond
[(setbox? n) [(setbox? n)
@ -526,7 +528,7 @@
[(and (fixnum? n) (fx> n 0)) [(and (fixnum? n) (fx> n 0))
(let ([box (make-setbox counter #f)]) (let ([box (make-setbox counter #f)])
(set! counter (add1 counter)) (set! counter (add1 counter))
(put-hash-table! h x box) (hashtable-set! h x box)
(let* ([a (f (car x))] (let* ([a (f (car x))]
[d (f (cdr x))]) [d (f (cdr x))])
(set-setbox-data! box (cons a d)) (set-setbox-data! box (cons a d))
@ -547,7 +549,7 @@
(cons a d)))])] (cons a d)))])]
[(vector? x) [(vector? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(cond (cond
[(setbox? n) [(setbox? n)
@ -555,7 +557,7 @@
[(and (fixnum? n) (fx> n 0)) [(and (fixnum? n) (fx> n 0))
(let ([box (make-setbox counter #f)]) (let ([box (make-setbox counter #f)])
(set! counter (add1 counter)) (set! counter (add1 counter))
(put-hash-table! h x box) (hashtable-set! h x box)
(set-setbox-data! box (set-setbox-data! box
(list->vector (list->vector
(map1ltr f (vector->list x)))) (map1ltr f (vector->list x))))
@ -567,7 +569,7 @@
[else x]))) [else x])))
(define (unshare x) (define (unshare x)
(let ([h (make-hash-table)]) (let ([h (make-hashtable)])
(if (hasher x h) (if (hasher x h)
(rewrite-shared x h) (rewrite-shared x h)
x))) x)))

59
src/ikarus.writer.ss
View File

@ -3,6 +3,7 @@
(export write display format printf print-error error-handler (export write display format printf print-error error-handler
error print-unicode print-graph) error print-unicode print-graph)
(import (import
(rnrs hashtables)
(ikarus system $chars) (ikarus system $chars)
(ikarus system $strings) (ikarus system $strings)
(ikarus system $vectors) (ikarus system $vectors)
@ -67,8 +68,8 @@
(lambda (x p m h i) (lambda (x p m h i)
(cond (cond
[(and (pair? x) [(and (pair? x)
(or (not (get-hash-table h x #f)) (or (not (hashtable-ref h x #f))
(fxzero? (get-hash-table h x 0)))) (fxzero? (hashtable-ref h x 0))))
(write-char #\space p) (write-char #\space p)
(write-list (cdr x) p m h (write-list (cdr x) p m h
(writer (car x) p m h i))] (writer (car x) p m h i))]
@ -436,7 +437,7 @@
(let ([d ($cdr x)]) (let ([d ($cdr x)])
(and (pair? d) (and (pair? d)
(null? ($cdr d)) (null? ($cdr d))
(not (get-hash-table h x #f)))) (not (hashtable-ref h x #f))))
(assq ($car x) macro-forms)))) (assq ($car x) macro-forms))))
(define write-pair (define write-pair
@ -468,7 +469,7 @@
(define write-shareable (define write-shareable
(lambda (x p m h i k) (lambda (x p m h i k)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(cond (cond
[(fx< n 0) [(fx< n 0)
@ -478,7 +479,7 @@
(k x p m h i)] (k x p m h i)]
[else [else
(let ([i (fx- i 1)]) (let ([i (fx- i 1)])
(put-hash-table! h x i) (hashtable-set! h x i)
(write-mark i p) (write-mark i p)
(k x p m h i))]))] (k x p m h i))]))]
[else (k x p m h i)]))) [else (k x p m h i)])))
@ -541,8 +542,8 @@
[(bwp-object? x) [(bwp-object? x)
(write-char* "#!bwp" p) (write-char* "#!bwp" p)
i] i]
[(hash-table? x) [(hashtable? x)
(write-char* "#<hash-table>" p) (write-char* "#<hashtable>" p)
i] i]
[(record? x) [(record? x)
(let ([printer (record-printer x)]) (let ([printer (record-printer x)])
@ -579,63 +580,63 @@
(cond (cond
[(pair? x) [(pair? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(put-hash-table! h x (fxadd1 n)))] (hashtable-set! h x (fxadd1 n)))]
[else [else
(put-hash-table! h x 0) (hashtable-set! h x 0)
(graph (car x) h) (graph (car x) h)
(graph (cdr x) h)])] (graph (cdr x) h)])]
[(vector? x) [(vector? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(put-hash-table! h x (fxadd1 n)))] (hashtable-set! h x (fxadd1 n)))]
[else [else
(put-hash-table! h x 0) (hashtable-set! h x 0)
(vec-graph x 0 (vector-length x) h)])] (vec-graph x 0 (vector-length x) h)])]
[(gensym? x) [(gensym? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(put-hash-table! h x (fxadd1 n)))])])) (hashtable-set! h x (fxadd1 n)))])]))
(define (dynamic x h) (define (dynamic x h)
(cond (cond
[(pair? x) [(pair? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(put-hash-table! h x (fxadd1 n)))] (hashtable-set! h x (fxadd1 n)))]
[else [else
(put-hash-table! h x 0) (hashtable-set! h x 0)
(dynamic (car x) h) (dynamic (car x) h)
(dynamic (cdr x) h) (dynamic (cdr x) h)
(when (and (get-hash-table h x #f) (when (and (hashtable-ref h x #f)
(fxzero? (get-hash-table h x #f))) (fxzero? (hashtable-ref h x #f)))
(put-hash-table! h x #f))])] (hashtable-set! h x #f))])]
[(vector? x) [(vector? x)
(cond (cond
[(get-hash-table h x #f) => [(hashtable-ref h x #f) =>
(lambda (n) (lambda (n)
(put-hash-table! h x (fxadd1 n)))] (hashtable-set! h x (fxadd1 n)))]
[else [else
(put-hash-table! h x 0) (hashtable-set! h x 0)
(vec-dynamic x 0 (vector-length x) h) (vec-dynamic x 0 (vector-length x) h)
(when (and (get-hash-table h x #f) (when (and (hashtable-ref h x #f)
(fxzero? (get-hash-table h x #f))) (fxzero? (hashtable-ref h x #f)))
(put-hash-table! h x #f))])])) (hashtable-set! h x #f))])]))
(if (print-graph) (if (print-graph)
(graph x h) (graph x h)
(dynamic x h))) (dynamic x h)))
(define (write-to-port x p) (define (write-to-port x p)
(let ([h (make-hash-table)]) (let ([h (make-hashtable)])
(hasher x h) (hasher x h)
(writer x p #t h 0)) (writer x p #t h 0))
(flush-output-port p)) (flush-output-port p))
(define (display-to-port x p) (define (display-to-port x p)
(let ([h (make-hash-table)]) (let ([h (make-hashtable)])
(hasher x h) (hasher x h)
(writer x p #f h 0)) (writer x p #f h 0))
(flush-output-port p)) (flush-output-port p))

4
src/makefile.ss
View File

@ -287,10 +287,6 @@
[print-unicode i] [print-unicode i]
[gensym-count i symbols] [gensym-count i symbols]
[gensym-prefix i symbols] [gensym-prefix i symbols]
[make-hash-table i]
[hash-table? i]
[get-hash-table i]
[put-hash-table! i]
[make-parameter i parameters] [make-parameter i parameters]
[call/cf i] [call/cf i]
[print-error i] [print-error i]