Changeset 13780 in project for chicken


Ignore:
Timestamp:
03/16/09 03:32:12 (11 years ago)
Author:
Kon Lovett
Message:

Fix for intemperate use of ##sys#hash-table. Reported by Jim Ursetto.

Location:
chicken/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/lolevel.scm

    r13611 r13780  
    2828(declare
    2929  (unit lolevel)
     30  (uses srfi-69)
    3031  (usual-integrations)
    3132  (disable-warning var redef)
     
    5960     ##sys#error ##sys#signal-hook
    6061     ##sys#error-not-a-proper-list
    61      ##sys#hash-table-ref ##sys#hash-table-set!
     62     make-hash-table hash-table-ref/default hash-table-set!
    6263     ##sys#make-pointer ##sys#make-tagged-pointer ##sys#make-locative ##sys#locative?
    6364     ##sys#become!
     
    513514  (let ([allocator
    514515         (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ]
    515         [tab (##sys#make-vector evict-table-size '())] )
     516        [tab (make-hash-table eq?)] )
    516517    (##sys#check-closure allocator 'object-evict)
    517518    (let evict ([x x])
    518519      (cond [(not (##core#inline "C_blockp" x)) x ]
    519             [(##sys#hash-table-ref tab x) ]
     520            [(hash-table-ref/default tab x #f) ]
    520521            [else
    521522             (let* ([n (##sys#size x)]
     
    523524                    [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
    524525               (when (symbol? x) (##sys#setislot y 0 (void)))
    525                (##sys#hash-table-set! tab x y)
     526               (hash-table-set! tab x y)
    526527               (unless (##core#inline "C_byteblockp" x)
    527528                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
     
    538539                       limit)) ]
    539540         [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
    540          [tab (##sys#make-vector evict-table-size '())]
     541         [tab (make-hash-table eq?)]
    541542         [x2
    542543          (let evict ([x x])
    543544            (cond [(not (##core#inline "C_blockp" x)) x ]
    544                   [(##sys#hash-table-ref tab x) ]
     545                  [(hash-table-ref/default tab x #f) ]
    545546                  [else
    546547                   (let* ([n (##sys#size x)]
     
    561562                     (when (symbol? x) (##sys#setislot y 0 (void)))
    562563                     (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
    563                      (##sys#hash-table-set! tab x y)
     564                     (hash-table-set! tab x y)
    564565                     (unless (##core#inline "C_byteblockp" x)
    565566                       (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
     
    588589
    589590(define (object-size x)
    590   (let ([tab (##sys#make-vector evict-table-size '())])
     591  (let ([tab (make-hash-table eq?)])
    591592    (let evict ([x x])
    592593      (cond [(not (##core#inline "C_blockp" x)) 0 ]
    593             [(##sys#hash-table-ref tab x) 0 ]
     594            [(hash-table-ref/default tab x #f) 0 ]
    594595            [else
    595596             (let* ([n (##sys#size x)]
     
    597598                     (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    598599                          (##core#inline "C_bytes" 1) ) ] )
    599                (##sys#hash-table-set! tab x #t)
     600               (hash-table-set! tab x #t)
    600601               (unless (##core#inline "C_byteblockp" x)
    601602                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
     
    605606
    606607(define (object-unevict x #!optional full)
    607   (let ([tab (##sys#make-vector evict-table-size '())])
     608  (let ([tab (make-hash-table eq?)])
    608609    (let copy ([x x])
    609610    (cond [(not (##core#inline "C_blockp" x)) x ]
    610611          [(not (##core#inline "C_permanentp" x)) x ]
    611           [(##sys#hash-table-ref tab x) ]
     612          [(hash-table-ref/default tab x #f) ]
    612613          [(##core#inline "C_byteblockp" x)
    613614           (if full
    614615               (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
    615                  (##sys#hash-table-set! tab x y)
     616                 (hash-table-set! tab x y)
    616617                 y)
    617618               x) ]
    618619          [(symbol? x)
    619620           (let ([y (##sys#intern-symbol (##sys#slot x 1))])
    620              (##sys#hash-table-set! tab x y)
     621             (hash-table-set! tab x y)
    621622             y) ]
    622623          [else
    623624           (let* ([words (##sys#size x)]
    624625                  [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
    625              (##sys#hash-table-set! tab x y)
     626             (hash-table-set! tab x y)
    626627             (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    627628                 ((fx>= i words))
  • chicken/trunk/tests/lolevel-tests.scm

    r13148 r13780  
    206206(assert (equal? '#(test a b) (record->vector some-record)))
    207207
     208; object-evict
    208209; object-evicted?
    209 
    210 ; object-evict
     210; object-size
     211; object-release
     212
     213(define tstvec (vector #f))
     214(let ((sz (object-size tstvec)))
     215  (assert (and (integer? sz) (positive? sz))) )
     216(define ev-tstvec (object-evict tstvec))
     217(assert (not (eq? tstvec ev-tstvec)))
     218(assert (object-evicted? ev-tstvec))
     219(object-release ev-tstvec)
    211220
    212221; object-evict-to-location
    213 
    214 ; object-release
    215 
    216 ; object-size
    217222
    218223; object-unevict
Note: See TracChangeset for help on using the changeset viewer.