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

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

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

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

@ -1,14 +1,12 @@
(library (ikarus hash-tables)
(export hash-table? make-hash-table get-hash-table put-hash-table!
make-hashtable hashtable-ref hashtable-set!)
(export make-hashtable hashtable-ref hashtable-set! hashtable?)
(import
(ikarus system $pairs)
(ikarus system $vectors)
(ikarus system $tcbuckets)
(ikarus system $fx)
(except (ikarus) hash-table? make-hash-table get-hash-table
make-hashtable put-hash-table! hashtable-ref hashtable-set!))
(except (ikarus) make-hashtable hashtable-ref hashtable-set! hashtable?))
(define-record hasht (vec count tc))
@ -178,27 +176,24 @@
(init-vec (make-vector n) 0 n)))
;;; 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 ([tc (cons x x)])
(make-hasht (make-base-vec 32) 0 tc))))
(define get-hash-table
(define hashtable-ref
(lambda (h x v)
(if (hasht? h)
(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)
(if (hasht? h)
(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)
(export pretty-print)
(import (except (ikarus) pretty-print))
(import
(rnrs hashtables)
(except (ikarus) pretty-print))
(define (map1ltr f ls)
;;; ltr so that gensym counts get assigned properly
(cond
@ -454,56 +456,56 @@
(cond
[(pair? x)
(cond
[(get-hash-table h x #f) =>
[(hashtable-ref h x #f) =>
(lambda (n)
(set! rv #t)
(put-hash-table! h x (fxadd1 n)))]
(hashtable-set! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(hashtable-set! h x 0)
(graph (car x))
(graph (cdr x))])]
[(vector? x)
(cond
[(get-hash-table h x #f) =>
[(hashtable-ref h x #f) =>
(lambda (n)
(set! rv #t)
(put-hash-table! h x (fxadd1 n)))]
(hashtable-set! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(hashtable-set! h x 0)
(vec-graph x 0 (vector-length x))])]
[(gensym? x)
(cond
[(get-hash-table h x #f) =>
[(hashtable-ref h x #f) =>
(lambda (n)
(set! rv #t)
(put-hash-table! h x (fxadd1 n)))])]))
(hashtable-set! h x (fxadd1 n)))])]))
(define (dynamic x)
(cond
[(pair? x)
(cond
[(get-hash-table h x #f) =>
[(hashtable-ref h x #f) =>
(lambda (n)
(set! rv #t)
(put-hash-table! h x (fxadd1 n)))]
(hashtable-set! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(hashtable-set! h x 0)
(dynamic (car x))
(dynamic (cdr x))
(when (and (get-hash-table h x #f)
(fxzero? (get-hash-table h x #f)))
(put-hash-table! h x #f))])]
(when (and (hashtable-ref h x #f)
(fxzero? (hashtable-ref h x #f)))
(hashtable-set! h x #f))])]
[(vector? x)
(cond
[(get-hash-table h x #f) =>
[(hashtable-ref h x #f) =>
(lambda (n)
(set! rv #t)
(put-hash-table! h x (fxadd1 n)))]
(hashtable-set! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(hashtable-set! h x 0)
(vec-dynamic x 0 (vector-length x))
(when (and (get-hash-table h x #f)
(fxzero? (get-hash-table h x #f)))
(put-hash-table! h x #f))])]))
(when (and (hashtable-ref h x #f)
(fxzero? (hashtable-ref h x #f)))
(hashtable-set! h x #f))])]))
(if (print-graph)
(graph x)
(dynamic x))
@ -518,7 +520,7 @@
(cond
[(pair? x)
(cond
[(get-hash-table h x #f) =>
[(hashtable-ref h x #f) =>
(lambda (n)
(cond
[(setbox? n)
@ -526,7 +528,7 @@
[(and (fixnum? n) (fx> n 0))
(let ([box (make-setbox counter #f)])
(set! counter (add1 counter))
(put-hash-table! h x box)
(hashtable-set! h x box)
(let* ([a (f (car x))]
[d (f (cdr x))])
(set-setbox-data! box (cons a d))
@ -547,7 +549,7 @@
(cons a d)))])]
[(vector? x)
(cond
[(get-hash-table h x #f) =>
[(hashtable-ref h x #f) =>
(lambda (n)
(cond
[(setbox? n)
@ -555,7 +557,7 @@
[(and (fixnum? n) (fx> n 0))
(let ([box (make-setbox counter #f)])
(set! counter (add1 counter))
(put-hash-table! h x box)
(hashtable-set! h x box)
(set-setbox-data! box
(list->vector
(map1ltr f (vector->list x))))
@ -567,7 +569,7 @@
[else x])))
(define (unshare x)
(let ([h (make-hash-table)])
(let ([h (make-hashtable)])
(if (hasher x h)
(rewrite-shared x h)
x)))

59
src/ikarus.writer.ss
View File

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

4
src/makefile.ss
View File

@ -287,10 +287,6 @@
[print-unicode i]
[gensym-count 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]
[call/cf i]
[print-error i]