Changeset 15809 in project


Ignore:
Timestamp:
09/09/09 06:40:08 (10 years ago)
Author:
Kon Lovett
Message:

Split into safe & unsafe.

Location:
release/4/lookup-table/trunk
Files:
2 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/lookup-table/trunk/lookup-table.meta

    r14543 r15809  
    1212  "chicken-primitive-object-inlines.scm"
    1313  "chicken-primitive-alist.scm"
     14  "lookup-table-body.scm"
    1415  "lookup-table.scm"
     16  "lookup-table-unsafe.scm"
    1517  "lookup-table.setup") )
  • release/4/lookup-table/trunk/lookup-table.scm

    r15713 r15809  
    11;;;; lookup-table.scm
    2 ;;;; Kon Lovett, Apr '09
    3 
    4 (declare
    5   (usual-integrations)
    6   (disable-interrupts)
    7   (fixnum)
    8   (inline)
    9   (inline-limit 50)
    10   (local)
    11   (no-procedure-checks) )
     2;;;; Kon Lovett, Sep '09
    123
    134(include "chicken-primitive-object-inlines")
     
    4233    srfi-1 srfi-69 ports data-structures extras
    4334    miscmacros type-checks type-errors srfi-9-ext)
     35
    4436  (require-library srfi-1 srfi-69 extras miscmacros type-checks type-errors srfi-9-ext)
    4537
    46 ;;;
    47 
    48 ;;; Variant Dictionary
    49 
    50 (define-record-type/primitive dict
    51         (make-dictbase data)
    52         dict?
    53         (data dict-data-ref dict-data-set!)
    54         (test dict-test-ref dict-test-set!)
    55         (to-alist dict->alist-ref dict->alist-set!)
    56         (ref dict-ref-ref dict-ref-set!)
    57         (set dict-set-ref dict-set-set!)
    58         (delete dict-delete-ref dict-delete-set!)
    59         (for-each dict-for-each-ref dict-for-each-set!)
    60         (merge dict-merge-ref dict-merge-set!)
    61         (search dict-search-ref dict-search-set!)
    62         (count dict-count-ref dict-count-set!)
    63         (keys dict-keys-ref dict-keys-set!)
    64         (values dict-values-ref dict-values-set!)
    65         (exists dict-exists-ref dict-exists-set!) )
    66 
    67 (define (set-dict-procs! dict tst to ref set del for mrg sch cnt keys vals exsts)
    68         (dict-test-set! dict tst)
    69         (dict->alist-set! dict to)
    70         (dict-ref-set! dict ref)
    71         (dict-set-set! dict set)
    72         (dict-delete-set! dict del)
    73         (dict-for-each-set! dict for)
    74         (dict-merge-set! dict mrg)
    75         (dict-search-set! dict sch)
    76         (dict-count-set! dict cnt)
    77         (dict-keys-set! dict keys)
    78         (dict-values-set! dict vals)
    79         (dict-exists-set! dict exsts)
    80         dict )
    81 
    82 ; Representation independent primitive calls
    83 
    84 (define (dictbase-test dict) ((dict-test-ref dict) (dict-data-ref dict)))
    85 (define (dictbase->alist dict) ((dict->alist-ref dict) (dict-data-ref dict)))
    86 (define (dictbase-ref dict key def) ((dict-ref-ref dict) (dict-data-ref dict) key def))
    87 (define (dictbase-set! dict key val) ((dict-set-ref dict) (dict-data-ref dict) key val))
    88 (define (dictbase-delete! dict key) ((dict-delete-ref dict) (dict-data-ref dict) key))
    89 (define (dictbase-for-each dict proc) ((dict-for-each-ref dict) (dict-data-ref dict) proc))
    90 (define (dictbase-merge! dict1 dict2) ((dict-merge-ref dict1) (dict-data-ref dict1) (dict-data-ref dict2)))
    91 (define (dictbase-search dict proc def) ((dict-search-ref dict) (dict-data-ref dict) proc def))
    92 (define (dictbase-count dict) ((dict-count-ref dict) (dict-data-ref dict)))
    93 (define (dictbase-keys dict) ((dict-keys-ref dict) (dict-data-ref dict)))
    94 (define (dictbase-values dict) ((dict-values-ref dict) (dict-data-ref dict)))
    95 (define (dictbase-exists? dict key) ((dict-exists-ref dict) (dict-data-ref dict) key))
    96 
    97 ;; Association List
    98 
    99 (define (make-alist-data test al) (%cons test al))
    100 (define (alist-dict-test data) (%car data))
    101 (define (alist-dict-alist data) (%cdr data))
    102 (define (alist-dict-alist-set! data al) (%set-cdr! data al))
    103 
    104 (define (set-alist-dict-procs! dict)
    105         (set-dict-procs! dict
    106                 alist-dict-test-ref
    107                 alist-dict->alist
    108                 alist-dict-ref
    109                 alist-dict-set!
    110                 alist-dict-delete!
    111                 alist-dict-for-each
    112                 alist-dict-merge!
    113                 alist-dict-search
    114                 alist-dict-count
    115                 alist-dict-keys
    116                 alist-dict-values
    117                 alist-dict-exists?) )
    118 
    119 ;; Hash Table
    120 
    121 (define (make-htable-data test ht) (%cons test ht))
    122 (define (htable-dict-test data) (%car data))
    123 (define (htable-dict-htable data) (%cdr data))
    124 (define (htable-dict-htable-set! data ht) (%set-cdr!/mutate data ht))
    125 
    126 (define (set-htable-dict-procs! dict)
    127         (set-dict-procs! dict
    128                 htable-dict-test-ref
    129                 htable-dict->alist
    130                 htable-dict-ref
    131                 htable-dict-set!
    132                 htable-dict-delete!
    133                 htable-dict-for-each
    134                 htable-dict-merge!
    135                 htable-dict-search
    136                 htable-dict-count
    137                 htable-dict-keys
    138                 htable-dict-values
    139                 htable-dict-exists?) )
    140 
    141 ;;;
    142 
    143 ;; Argument validation & literal object return.
    144 
    145 (define *dict-safe-mode* #f)
    146 
    147 ;;; Alist Dictionary
    148 
    149 (define (alist-dict-test-ref data) (alist-dict-test data))
    150 
    151 (define (alist-dict->alist data)
    152   (let ((dat (alist-dict-alist data)))
    153     (if *dict-safe-mode* (list-copy dat)
    154         dat ) ) )
    155 
    156 (define (alist-dict-ref data key def)
    157         (%alist-ref key (alist-dict-alist data) (alist-dict-test data) def) )
    158 
    159 (define (alist-dict-set! data key obj)
    160         (alist-dict-alist-set!
    161           data
    162     (%alist-update! key obj (alist-dict-alist data) (alist-dict-test data))) )
    163 
    164 (define (alist-dict-delete! data key)
    165         (alist-dict-alist-set!
    166           data
    167     (%alist-delete! key (alist-dict-alist data) (alist-dict-test data))) )
    168 
    169 (define (alist-dict-for-each data proc)
    170         (%list-for-each/1
    171           (lambda (cell) (proc (%car cell) (%cdr cell)))
    172     (alist-dict-alist data)) )
    173 
    174 (define (alist-dict-merge! data1 data2)
    175         (let ((test (alist-dict-test data1))
    176               (al (alist-dict-alist data1)))
    177                 (%list-for-each/1
    178                   (lambda (cell) (set! al (%alist-update! (%car cell) (%cdr cell) al test)))
    179       (alist-dict-alist data2))
    180                 (alist-dict-alist-set! data1 al) ) )
    181 
    182 (define (alist-dict-search data proc def) (%alist-find proc (alist-dict-alist data) def))
    183 
    184 (define (alist-dict-count data) (%list-length (alist-dict-alist data)))
    185 
    186 (define (alist-dict-keys data) (%list-map/1 (lambda (x) (%car x)) (alist-dict-alist data)))
    187 
    188 (define (alist-dict-values data) (%list-map/1 (lambda (x) (%cdr x)) (alist-dict-alist data)))
    189 
    190 (define (alist-dict-exists? data key)
    191   (not (%undefined-value? (alist-dict-ref data key (%undefined-value)))) )
    192 
    193 (define (make-alist-dict test al)
    194   (set-alist-dict-procs! (make-dictbase (make-alist-data test al))) )
    195 
    196 (define (alist-dict? dict) (%eq? alist-dict-test-ref (dictbase-test dict)))
    197 
    198 (define (become-alist-dict! dict)
    199         (dict-data-set! dict (make-alist-data (dictbase-test dict) (dictbase->alist dict)))
    200         (set-alist-dict-procs! dict) )
    201 
    202 ;;; Hash-table Dictionary
    203 
    204 (define (htable-dict-test-ref data) (htable-dict-test data))
    205 
    206 (define (htable-dict->alist data) (hash-table->alist (htable-dict-htable data)))
    207 
    208 (define (htable-dict-ref data key def)
    209         (hash-table-ref/default (htable-dict-htable data) key def) )
    210 
    211 (define (htable-dict-set! data key obj)
    212         (hash-table-set! (htable-dict-htable data) key obj) )
    213 
    214 (define (htable-dict-delete! data key)
    215         (hash-table-delete! (htable-dict-htable data) key) )
    216 
    217 (define (htable-dict-for-each data proc)
    218         (hash-table-for-each (htable-dict-htable data) proc) )
    219 
    220 (define (htable-dict-merge! data1 data2)
    221         (htable-dict-htable-set!
    222           data1
    223           (hash-table-merge! (htable-dict-htable data1) (htable-dict-htable data2))) )
    224 
    225 (define (htable-dict-search data proc def)
    226         (let ((ht (htable-dict-htable data))
    227                                 (ret #f))
    228                 (let ((res (let/cc return
    229                  (hash-table-walk ht
    230                    (lambda (key val) (when (proc key val) (set! ret #t) (return val)))))))
    231                         (if ret res def) ) ) )
    232 
    233 (define (htable-dict-count data) (hash-table-size (htable-dict-htable data)))
    234 
    235 (define (htable-dict-keys data) (hash-table-keys (htable-dict-htable data)))
    236 
    237 (define (htable-dict-values data) (hash-table-values (htable-dict-htable data)))
    238 
    239 (define (htable-dict-exists? data key) (hash-table-exists? (htable-dict-htable data) key))
    240 
    241 (define (make-htable-dict test ht)
    242   (set-htable-dict-procs! (make-dictbase (make-htable-data test ht))) )
    243 
    244 (define (htable-dict? dict) (%eq? htable-dict-test-ref (dictbase-test dict)))
    245 
    246 (define (become-htable-dict! dict)
    247         (let ((test (dictbase-test dict)))
    248                 (dict-data-set! dict (make-htable-data test (alist->hash-table (dictbase->alist dict) test))))
    249         (set-htable-dict-procs! dict) )
    250 
    251 ;; Argument Checks
    252 
    253 (define-check-type dict)
    254 
    255 (define (check-value loc obj #!optional nam)
    256   (when (%undefined-value? obj)
    257     (error-argument-type loc obj "non-undefined value" nam)) )
    258 
    259 (define (check-alist loc obj #!optional nam)
    260   (check-list loc obj nam)
    261   (let loop ((al obj) (tal '()))
    262     (cond ((%null? al) )
    263           ((not (%pair? (%car al)))
    264             (error-argument-type loc obj "association list" nam) )
    265           ((%memq (%cdr al) tal)
    266             (error-argument-type loc obj "proper list" nam) )
    267           (else
    268             (loop (%cdr al) (%cons (%cdr al) tal)) ) ) ) )
    269 
    270 ;; Errors
    271 
    272 (define-error-type dict)
    273 
    274 ;; Print worker
    275 
    276 (define (*dict-print dict)
    277   (define (print-node-table dict spcr)
    278     (dictbase-for-each dict
    279       (lambda (key val)
    280         (%list-for-each/1 display spcr)
    281         (cond ((dict? val)
    282                 (write key) (display " :") (newline)
    283                 (print-node-table val (%cons "  " spcr)) )
    284               (else
    285                 (write key) (display " : ") (pretty-print val)) ) ) ) )
    286     (print-node-table dict '()) )
    287 
    288 ;; Update workers
    289 
    290 (define (*dict-update! dict key valu-func updt-func curr loc)
    291   (let ((val (updt-func
    292                (if (not (%undefined-value? curr)) curr
    293                    (let ((val (valu-func)))
    294                      (when *dict-safe-mode* (check-value loc val))
    295                      val ) ) ) ) )
    296     (dictbase-set! dict key val)
    297     val ) )
    298 
    299 (define (+dict-update! dict key valu-func updt-func loc)
    300   (when *dict-safe-mode*
    301     (check-dict loc dict)
    302     (check-procedure loc valu-func)
    303     (check-procedure loc updt-func) )
    304   (let* ((curr (dictbase-ref dict key (%undefined-value)))
    305          (updt (*dict-update! dict key valu-func updt-func curr loc)))
    306     (unless (%undefined-value? curr) (dict-bestfit dict))
    307     updt ) )
    308 
    309 ;; Dictionary Type
    310 
    311 (define (dict-same-kind? dict1 dict2) (%eq? (dict-test-ref dict1) (dict-test-ref dict2)))
    312 (define (dict-same-test? dict1 dict2) (%eq? (dictbase-test dict1) (dictbase-test dict2)))
    313 
    314 (define (dict-bestfit dict)
    315         (if (%fx< MAGIC-LIMIT (dictbase-count dict))
    316       (unless (htable-dict? dict) (become-htable-dict! dict))
    317       (unless (alist-dict? dict) (become-alist-dict! dict)) ) )
    318 
    319 ;;; Globals
    320 
    321 (define-parameter dict-safe-mode *dict-safe-mode*
    322   (lambda (x)
    323     (set! *dict-safe-mode* x)
    324     x))
    325 
    326 (define (make-dict #!optional (test eq?) (size 0))
    327   (when *dict-safe-mode*
    328     (check-cardinal-fixnum 'make-dict size "size")
    329     (check-procedure 'make-dict test) )
    330         (if (%fx< MAGIC-LIMIT size)
    331       (make-htable-dict test (make-hash-table test))
    332       (make-alist-dict test '())) )
    333 
    334 (define (alist->dict al #!optional (test eq?) (size 0))
    335   (when *dict-safe-mode*
    336     (check-alist 'alist->dict al "alist")
    337     (check-cardinal-fixnum 'alist->dict size "size")
    338     (check-procedure 'alist->dict test) )
    339         (if (or (%fx< MAGIC-LIMIT size) (%fx< MAGIC-LIMIT (%list-length al)))
    340       (make-htable-dict test (alist->hash-table al test))
    341       (make-alist-dict test al)) )
    342 
    343 (define (dict->alist dict)
    344   (when *dict-safe-mode* (check-dict 'dict->alist dict))
    345         (dictbase->alist dict) )
    346 
    347 (define (dict-equivalence-function dict)
    348   (when *dict-safe-mode* (check-dict 'dict-equivalence-function dict))
    349         (dictbase-test dict) )
    350 
    351 (define (dict-count dict)
    352   (when *dict-safe-mode* (check-dict 'dict-count dict))
    353         (dictbase-count dict) )
    354 
    355 (define (dict-keys dict)
    356   (when *dict-safe-mode* (check-dict 'dict-keys dict))
    357         (dictbase-keys dict) )
    358 
    359 (define (dict-values dict)
    360   (when *dict-safe-mode* (check-dict 'dict-values dict))
    361         (dictbase-values dict) )
    362 
    363 (define (dict-ref dict key #!optional def)
    364   (when *dict-safe-mode* (check-dict 'dict-ref dict))
    365         (dictbase-ref dict key def) )
    366 
    367 (define (dict-set! dict key obj)
    368   (when *dict-safe-mode*
    369     (check-value 'dict-set! obj)
    370     (check-dict 'dict-set! dict) )
    371         (dictbase-set! dict key obj)
    372         (dict-bestfit dict) )
    373 
    374 (define (dict-exists? dict key)
    375   (when *dict-safe-mode* (check-dict 'dict-exists? dict))
    376   (dictbase-exists? dict key) )
    377 
    378 (define (dict-update! dict key valu-func #!optional (updt-func identity))
    379         (+dict-update! dict key valu-func updt-func 'dict-update!) )
    380 
    381 (define (dict-update-list! dict key . vals)
    382   (+dict-update! dict key (lambda () '()) (cut fold cons <> (reverse! vals)) 'dict-update-list!) )
    383 
    384 (define (dict-update-dict! dict key)
    385   (+dict-update! dict key (cut make-dict) identity 'dict-update-dict!) )
    386 
    387 (define (dict-delete! dict key)
    388   (when *dict-safe-mode* (check-dict 'dict-delete! dict))
    389         (dictbase-delete! dict key)
    390         (dict-bestfit dict) )
    391 
    392 (define (dict-for-each dict proc)
    393   (when *dict-safe-mode*
    394     (check-dict 'dict-for-each dict)
    395     (check-procedure 'dict-for-each proc) )
    396         (dictbase-for-each dict proc) )
    397 
    398 (define (dict-search dict proc #!optional def)
    399   (when *dict-safe-mode*
    400     (check-dict 'dict-search dict)
    401     (check-procedure 'dict-search proc) )
    402         (dictbase-search dict proc def) )
    403 
    404 (define (dict-merge! dict . dicts)
    405   (when *dict-safe-mode* (check-dict 'dict-merge! dict))
    406         (%list-for-each/1
    407                 (lambda (dictx)
    408       (when *dict-safe-mode*
    409         (check-dict 'dict-merge! dictx)
    410         (unless (dict-same-test? dict dictx)
    411           (error "cannot merge lookup-tables; incompatible test") ) )
    412                         (if (dict-same-kind? dict dictx) (dictbase-merge! dict dictx)
    413           (dictbase-for-each dictx (cut dict-set! dict <> <>)) ) )
    414                 dicts)
    415         (dict-bestfit dict) )
    416 
    417 (define (dict-print dict #!optional port)
    418   (if (not port) (*dict-print dict)
    419       (with-output-to-port port (lambda () (*dict-print dict)) ) ) )
     38(include "lookup-table-body")
    42039
    42140) ;module lookup-table
  • release/4/lookup-table/trunk/lookup-table.setup

    r14543 r15809  
    66
    77;; MAGIC-LIMIT - Element count when hash-table faster (YMMV)
     8(define opts
     9  '(-prelude "'(define-constant MAGIC-LIMIT 12)'"
     10    -fixnum-arithmetic
     11    -disable-interrupts
     12    -inline-limit 50))
    813
    9 (setup-shared-extension-module (extension-name) (extension-version "1.8.0")
    10   #:compile-options '(-prelude "'(define-constant MAGIC-LIMIT 12)'"))
     14(setup-shared-extension-module 'lookup-table (extension-version "1.10.0")
     15  #:compile-options (append opts '(-optimize-level 3 -debug-level 1)))
     16
     17(setup-shared-extension-module 'lookup-table-unsafe (extension-version "1.10.0")
     18  #:compile-options (append opts '(-optimize-level 4 -debug-level 0)))
  • release/4/lookup-table/trunk/tests/run.scm

    r14544 r15809  
    1 ;;;; lookup-table-test.scm
    2 
    3 (use srfi-1 test lookup-table)
    4 
    5 ;;;
    6 
    7 ;;
    8 
    9 (define (dict-alist-test al tst)
    10   (let ((foodat (alist-ref 'foo al))
    11         (bazdat (alist-ref 'baz al))
    12         (allen (length al)))
    13 
    14     (let ((tbl1 (alist->dict (list-copy al) tst)))
    15  
    16       (test-assert (dict? tbl1))
    17       (test tst (dict-equivalence-function tbl1))
    18  
    19       (test-assert (tst foodat (dict-ref tbl1 'foo)))
    20       (test-assert (begin (dict-delete! tbl1 'foo) #t))
    21       (test-assert (not (dict-ref tbl1 'foo)))
    22  
    23       (test '() (dict-update! tbl1 'foo (lambda () '())))
    24       (test '(1) (dict-update! tbl1 'foo void (lambda (x) (append x '(1)))))
    25  
    26       (test '() (dict-update-list! tbl1 'list))
    27       (test '(1 2) (dict-update-list! tbl1 'list 1 2))
    28  
    29       (let ((tbl2 (dict-update-dict! tbl1 'dict)))
    30         (test-assert (dict? (dict-ref tbl1 'dict)))
    31         (test tbl2 (dict-ref tbl1 'dict))
    32         (test tbl2 (dict-update-dict! tbl1 'dict)) ) )
    33  
    34     (let ((tbl (alist->dict (list-copy al) tst)))
    35       (test-assert (begin (dict-merge! tbl (alist->dict '((off . rab) (baz . pob)) tst)) #t))
    36       (test (+ allen 1) (dict-count tbl))
    37       (test foodat (dict-ref tbl 'foo))
    38       (test 'pob (dict-ref tbl 'baz))
    39       (test 'rab (dict-ref tbl 'off)) ) )
    40 )
    41 
    42 ;;
    43 
    44 (define (dict-ht-test)
    45   (let ((tbl1 (make-dict equal? 2)))
    46 
    47     (do ([i 0 (add1 i)])
    48         ([> i 54])
    49       (if (odd? i)
    50           (dict-set! tbl1 i (->string i))
    51           (dict-set! tbl1 (->string i) i)))
    52 
    53     (test 20 (dict-ref tbl1 "20"))
    54     (test-assert (begin (dict-delete! tbl1 "20") #t))
    55     (test-assert (not (dict-ref tbl1 "20")))
    56 
    57     (test-assert (begin (dict-merge! tbl1 (alist->dict '((foo . bar) (baz . bop)) equal?)) #t))
    58 
    59     (test 'bop (dict-ref tbl1 'baz))
    60 
    61     (test 'bar (dict-search tbl1 (lambda (key val) (eq? key 'foo))))
    62 
    63     (dict-print tbl1)
    64     #;(with-output-to-string (lambda () (dict-print tbl1))) )
    65 )
    66 
    67 ;;;
    68 
    69 (dict-safe-mode #t)
    70 (newline) (print "** Alist Test (Safe eq?) **") (newline)
    71 (dict-alist-test '((foo . bar) (baz . bop)) eq?)
    72 (newline) (print "** Alist Test (Safe equal?) **") (newline)
    73 (dict-alist-test '((foo . bar) (baz . bop) (2 . 3)) equal?)
    74 (newline) (print "** HT Test (Safe) **") (newline)
    75 (dict-ht-test)
    76 
    77 (dict-safe-mode #f)
    78 (newline) (print "** Alist Test (Unsafe eq?) **") (newline)
    79 (dict-alist-test '((foo . bar) (baz . bop)) eq?)
    80 (newline) (print "** Alist Test (Unsafe equal?) **") (newline)
    81 (dict-alist-test '((foo . bar) (baz . bop) (2 . 3)) equal?)
    82 (newline) (print "** HT Test (Unsafe) **") (newline)
    83 (dict-ht-test)
     1(system "csi -n -s safe.scm")
     2(system "csi -n -s unsafe.scm")
Note: See TracChangeset for help on using the changeset viewer.