Ignore:
Timestamp:
11/27/08 15:40:05 (13 years ago)
Author:
felix winkelmann
Message:

applied changes (untested)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/lazy-gensyms/lolevel.scm

    r10788 r12612  
    323323  (let copy ([x x])
    324324    (cond [(not (##core#inline "C_blockp" x)) x]
    325           [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
     325          [(symbol? x) (##sys#intern-symbol (##sys#symbol-name x))]
    326326          [else
    327327            (let* ([n (##sys#size x)]
     
    432432
    433433(define object-size
    434     (lambda (x)
    435       (let ([tab (##sys#make-vector evict-table-size '())])
    436         (let evict ([x x])
    437           (cond [(not (##core#inline "C_blockp" x)) 0]
    438                 [(##sys#hash-table-ref tab x) 0]
    439                 [else
    440                 (let* ([n (##sys#size x)]
    441                         [bytes
    442                         (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    443                               (##core#inline "C_bytes" 1) ) ] )
    444                    (##sys#hash-table-set! tab x #t)
    445                    (unless (##core#inline "C_byteblockp" x)
    446                      (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
    447                                 1
    448                                 0)
    449                              (fx+ i 1) ] )
    450                         ((fx>= i n))
    451                        (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
    452                    bytes) ] ) ) ) ) )
     434  (lambda (x)
     435    (let ([tab (##sys#make-vector evict-table-size '())])
     436      (let evict ([x x])
     437        (cond [(not (##core#inline "C_blockp" x)) 0]
     438              [(##sys#hash-table-ref tab x) 0]
     439              [else
     440              (let* ([n (##sys#size x)]
     441                      [bytes
     442                      (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
     443                            (##core#inline "C_bytes" 1) ) ] )
     444                 (##sys#hash-table-set! tab x #t)
     445                 (unless (##core#inline "C_byteblockp" x)
     446                   (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
     447                              1
     448                              0)
     449                           (fx+ i 1) ] )
     450                      ((fx>= i n))
     451                     (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
     452                 bytes) ] ) ) ) ) )
    453453
    454454(define object-unevict
    455     (lambda (x #!optional (full #f))
    456       (define (err x)
    457         (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
    458       (let ([tab (##sys#make-vector evict-table-size '())])
    459         (let copy ([x x])
    460           (cond [(not (##core#inline "C_blockp" x)) x]
    461                 [(not (##core#inline "C_permanentp" x)) x]
    462                 [(##sys#hash-table-ref tab x)]
    463                 [(##core#inline "C_byteblockp" x)
    464                 (if full
    465                      (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
    466                        (##sys#hash-table-set! tab x y)
    467                        y)
    468                      x) ]
    469                 [(symbol? x)
    470                  (let ([y (##sys#intern-symbol (##sys#slot x 1))])
    471                    (##sys#hash-table-set! tab x y)
    472                    y) ]
    473                 [else
    474                 (let* ([words (##sys#size x)]
    475                         [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
    476                    (##sys#hash-table-set! tab x y)
    477                    (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    478                        ((fx>= i words))
    479                      (##sys#setslot y i (copy (##sys#slot y i))) )
    480                    y) ] ) ) ) ) )
     455  (lambda (x #!optional (full #f))
     456    (define (err x)
     457      (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
     458    (let ([tab (##sys#make-vector evict-table-size '())])
     459      (let copy ([x x])
     460        (cond [(not (##core#inline "C_blockp" x)) x]
     461              [(not (##core#inline "C_permanentp" x)) x]
     462              [(##sys#hash-table-ref tab x)]
     463              [(##core#inline "C_byteblockp" x)
     464              (if full
     465                   (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
     466                     (##sys#hash-table-set! tab x y)
     467                     y)
     468                   x) ]
     469              [(symbol? x)
     470               (let ([y (##sys#intern-symbol (##sys#symbol-name x))])
     471                 (##sys#hash-table-set! tab x y)
     472                 y) ]
     473              [else
     474              (let* ([words (##sys#size x)]
     475                      [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     476                 (##sys#hash-table-set! tab x y)
     477                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     478                     ((fx>= i words))
     479                   (##sys#setslot y i (copy (##sys#slot y i))) )
     480                 y) ] ) ) ) ) )
    481481
    482482
Note: See TracChangeset for help on using the changeset viewer.