Changeset 10004 in project


Ignore:
Timestamp:
03/21/08 02:20:59 (11 years ago)
Author:
kon
Message:

Added 'hash-table-clear!' to srfi-69. Removed dep on srfi-69 by lolevel. Fixed srfi-69 ref of ##compiler#file-requirements. Added ##sys#hash-table->alist.

Location:
chicken/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/batch-driver.scm

    r8361 r10004  
    490490                    [proc (user-pass-2)] )
    491491               (when (debugging 'M "; requirements:")
    492                  (pretty-print (hash-table->alist file-requirements)))
     492                 (pretty-print (##sys#hash-table->alist file-requirements)))
    493493               (when proc
    494494                 (when verbose (printf "Secondary user pass...~%"))
  • chicken/trunk/compiler.scm

    r10003 r10004  
    10311031        (let* ([u (cadr spec)]
    10321032               [un (string->c-identifier (stringify u))] )
    1033           (hash-table-set! file-requirements 'unit u)
     1033          (##sys#hash-table-set! file-requirements 'unit u)
    10341034          (when (and unit-name (not (string=? unit-name un)))
    10351035            (compiler-warning 'usage "unit was already given a name (new name is ignored)") )
  • chicken/trunk/eval.scm

    r10003 r10004  
    544544                        (p (##sys#slot bucket 0) (##sys#slot bucket 1) ) )
    545545                      (##sys#slot ht i) ) ) ) )
     546
     547(define (##sys#hash-table->alist ht)
     548  (let ([len (##core#inline "C_block_size" ht)] )
     549    (let loop ([i 0] [lst '()])
     550      (if (fx>= i len)
     551          lst
     552          (let loop2 ([bucket (##sys#slot vec i)]
     553                      [lst lst])
     554            (if (null? bucket)
     555                (loop (fx+ i 1) lst)
     556                (loop2 (##sys#slot bucket 1)
     557                       (let ([x (##sys#slot bucket 0)])
     558                         (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
    546559
    547560(define ##sys#hash-table-location
  • chicken/trunk/lolevel.scm

    r10003 r10004  
    2828(declare
    2929  (unit lolevel)
    30   (uses srfi-69)
    3130  (usual-integrations)
    3231  (disable-warning var redef)
     
    5453    (no-procedure-checks-for-usual-bindings)
    5554    (bound-to-procedure
    56      ##sys#symbol-hash-toplevel-binding? ##sys#make-locative ##sys#become! make-hash-table
    57      hash-table-ref/default ##sys#make-string make-vector hash-table-set! hash-table-set!
     55     ##sys#hash-table-ref ##sys#hash-table-set!
     56     ##sys#make-locative ##sys#become!
     57     ##sys#make-string
    5858     make-property-condition make-composite-condition signal ##sys#set-pointer-address! ##sys#make-vector
    5959     ##sys#make-pointer make-string make-byte-vector ##sys#not-a-proper-list-error ##sys#check-pointer
     
    461461;;; Copy arbitrary object:
    462462
    463 (define object-copy
    464   (let ([make-vector make-vector])
    465     (lambda (x)
    466       (let copy ([x x])
    467         (cond [(not (##core#inline "C_blockp" x)) x]
    468               [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
    469               [else
    470                (let* ([n (##sys#size x)]
    471                       [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
    472                       [y (##core#inline "C_copy_block" x (make-vector words))] )
    473                  (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
    474                    (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    475                        ((fx>= i n))
    476                      (##sys#setslot y i (copy (##sys#slot y i))) ) )
    477                  y) ] ) ) ) ) )
     463(define (object-copy x)
     464  (let copy ([x x])
     465    (cond [(not (##core#inline "C_blockp" x)) x]
     466          [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
     467          [else
     468            (let* ([n (##sys#size x)]
     469                   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
     470                   [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     471              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
     472                (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     473                    ((fx>= i n))
     474                  (##sys#setslot y i (copy (##sys#slot y i))) ) )
     475              y) ] ) ) )
    478476
    479477
    480478;;; Evict objects into static memory:
     479
     480(define-constant evict-table-size 301)
    481481
    482482(define (object-evicted? x) (##core#inline "C_permanentp" x))
     
    488488                 (car allocator)
    489489                 (foreign-lambda c-pointer "C_malloc" int) ) ]
    490             [tab (make-hash-table eq?)] )
     490            [tab (##sys#make-vector evict-table-size '())] )
    491491        (let evict ([x x])
    492492          (cond [(not (##core#inline "C_blockp" x)) x]
    493                 [(hash-table-ref/default tab x #f)]
     493                [(##sys#hash-table-ref tab x)]
    494494                [else
    495495                 (let* ([n (##sys#size x)]
     
    497497                        [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
    498498                   (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
    499                    (hash-table-set! tab x y)
     499                   (##sys#hash-table-set! tab x y)
    500500                   (unless (##core#inline "C_byteblockp" x)
    501501                     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
     
    538538                  #f) ]
    539539             [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
    540              [tab (make-hash-table eq?)]
     540             [tab (##sys#make-vector evict-table-size '())]
    541541             [x2
    542542              (let evict ([x x])
    543543                (cond [(not (##core#inline "C_blockp" x)) x]
    544                       [(hash-table-ref/default tab x #f)]
     544                      [(##sys#hash-table-ref tab x)]
    545545                      [else
    546546                       (let* ([n (##sys#size x)]
     
    561561                           (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
    562562                           (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
    563                            (hash-table-set! tab x y)
     563                           (##sys#hash-table-set! tab x y)
    564564                           (unless (##core#inline "C_byteblockp" x)
    565565                             (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
     
    574574(define object-size
    575575    (lambda (x)
    576       (let ([tab (make-hash-table eq?)])
     576      (let ([tab (##sys#make-vector evict-table-size '())])
    577577        (let evict ([x x])
    578578          (cond [(not (##core#inline "C_blockp" x)) 0]
    579                 [(hash-table-ref/default tab x #f) 0]
     579                [(##sys#hash-table-ref tab x) 0]
    580580                [else
    581581                 (let* ([n (##sys#size x)]
     
    583583                         (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    584584                              (##core#inline "C_bytes" 1) ) ] )
    585                    (hash-table-set! tab x #t)
     585                   (##sys#hash-table-set! tab x #t)
    586586                   (unless (##core#inline "C_byteblockp" x)
    587587                     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
     
    597597      (define (err x)
    598598        (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
    599       (let ([tab (make-hash-table eq?)])
     599      (let ([tab (##sys#make-vector evict-table-size '())])
    600600        (let copy ([x x])
    601601          (cond [(not (##core#inline "C_blockp" x)) x]
    602602                [(not (##core#inline "C_permanentp" x)) x]
    603                 [(hash-table-ref/default tab x #f)]
     603                [(##sys#hash-table-ref tab x)]
    604604                [(##core#inline "C_byteblockp" x)
    605605                 (if full
    606606                     (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
    607                        (hash-table-set! tab x y)
     607                       (##sys#hash-table-set! tab x y)
    608608                       y)
    609609                     x) ]
    610610                [(symbol? x)
    611611                 (let ([y (##sys#intern-symbol (##sys#slot x 1))])
    612                    (hash-table-set! tab x y)
     612                   (##sys#hash-table-set! tab x y)
    613613                   y) ]
    614614                [else
    615615                 (let* ([words (##sys#size x)]
    616                         [y (##core#inline "C_copy_block" x (make-vector words))] )
    617                    (hash-table-set! tab x y)
     616                        [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     617                   (##sys#hash-table-set! tab x y)
    618618                   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    619619                       ((fx>= i words))
     
    648648  (let* ((n (##sys#size old))
    649649         (words (##core#inline "C_words" n))
    650          (y (##core#inline "C_copy_block" old (make-vector words))) )
     650         (y (##core#inline "C_copy_block" old (##sys#make-vector words))) )
    651651    (##sys#become! (list (cons old (proc y))))
    652652    y) )
  • chicken/trunk/tests/hash-table-tests.scm

    r10003 r10004  
    145145      [(fx= i stress-size)]
    146146    (assert (fx= i (hash-table-ref ht i))) ) )
     147
     148;; Clear Test
     149
     150
     151(print "HT - Clear!")
     152(hash-table-clear! ht)
     153(assert (= (hash-table-size ht) 0))
     154(assert (null? (hash-table-keys ht)))
     155
Note: See TracChangeset for help on using the changeset viewer.