Changeset 14543 in project


Ignore:
Timestamp:
05/07/09 05:36:40 (11 years ago)
Author:
Kon Lovett
Message:

Save of prim ver.

Location:
release/4/lookup-table
Files:
2 added
1 deleted
3 edited

Legend:

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

    r14516 r14543  
    77 (doc-from-wiki)
    88 (synopsis "Simple Lookup Table")
    9  (needs check-errors miscmacros setup-helper)
     9 (needs check-errors miscmacros setup-helper srfi-9-ext)
    1010 (files
    1111  "tests"
     12  "chicken-primitive-object-inlines.scm"
     13  "chicken-primitive-alist.scm"
    1214  "lookup-table.scm"
    1315  "lookup-table.setup") )
  • release/4/lookup-table/trunk/lookup-table.scm

    r14514 r14543  
    77  (fixnum)
    88  (inline)
     9  (inline-limit 50)
    910  (local)
    1011  (no-procedure-checks) )
    1112
     13(include "chicken-primitive-object-inlines")
     14(include "chicken-primitive-alist")
     15
    1216;;;
    13 
    14 ;; Element count when hash-table faster
    15 ;; (your milage may vary)
    16 
    17 (define-constant MAGIC-LIMIT 12)
    18 
    19 ;;
    2017
    2118(module lookup-table (;export
     
    4138  dict-print )
    4239
    43 (import scheme chicken srfi-1 srfi-69 ports data-structures extras miscmacros type-checks type-errors)
    44 (require-library srfi-1 srfi-69 extras miscmacros type-checks type-errors)
     40(import
     41  scheme chicken
     42  srfi-1 srfi-69 ports data-structures extras
     43  miscmacros type-checks type-errors srfi-9-ext)
     44(require-library srfi-1 srfi-69 extras miscmacros type-checks type-errors srfi-9-ext)
    4545
    4646;;;
    4747
    48 (define (alist-find proc al #!optional def)
    49         (let loop ((al al))
    50                 (if (null? al) def
    51         (let* ((cell (car al))
    52                (val (cdr cell)))
    53             (if (proc (car cell) val) val
    54                 (loop (cdr al)) ) ) ) ) )
    55 
    5648;;; Variant Dictionary
    5749
    58 (define-record-type dict
     50(define-record-type/primitive dict
    5951        (make-dictbase data)
    6052        dict?
     
    9486(define (dictbase-delete! dict key) ((dict-delete-ref dict) (dict-data-ref dict) key))
    9587(define (dictbase-for-each dict proc) ((dict-for-each-ref dict) (dict-data-ref dict) proc))
    96 (define (dictbase-merge dict1 dict2) ((dict-merge-ref dict1) (dict-data-ref dict1) (dict-data-ref dict2)))
     88(define (dictbase-merge! dict1 dict2) ((dict-merge-ref dict1) (dict-data-ref dict1) (dict-data-ref dict2)))
    9789(define (dictbase-search dict proc def) ((dict-search-ref dict) (dict-data-ref dict) proc def))
    9890(define (dictbase-count dict) ((dict-count-ref dict) (dict-data-ref dict)))
     
    10395;; Association List
    10496
    105 (define (make-alist-data test al) (cons test al))
    106 (define (alist-dict-test data) (car data))
    107 (define (alist-dict-alist data) (cdr data))
    108 (define (alist-dict-alist-set! data al) (set-cdr! data al))
     97(define (make-alist-data test al) (%cons test al))
     98(define (alist-dict-test data) (%car data))
     99(define (alist-dict-alist data) (%cdr data))
     100(define (alist-dict-alist-set! data al) (%set-cdr! data al))
    109101
    110102(define (set-alist-dict-procs! dict)
     
    113105                alist-dict->alist
    114106                alist-dict-ref
    115                 alist-dict-set
    116                 alist-dict-delete
     107                alist-dict-set!
     108                alist-dict-delete!
    117109                alist-dict-for-each
    118                 alist-dict-merge
     110                alist-dict-merge!
    119111                alist-dict-search
    120112                alist-dict-count
     
    125117;; Hash Table
    126118
    127 (define (make-htable-data test ht) (cons test ht))
    128 (define (htable-dict-test data) (car data))
    129 (define (htable-dict-htable data) (cdr data))
    130 (define (htable-dict-htable-set! data ht) (set-cdr! data ht))
     119(define (make-htable-data test ht) (%cons test ht))
     120(define (htable-dict-test data) (%car data))
     121(define (htable-dict-htable data) (%cdr data))
     122(define (htable-dict-htable-set! data ht) (%set-cdr!/mutate data ht))
    131123
    132124(define (set-htable-dict-procs! dict)
     
    135127                htable-dict->alist
    136128                htable-dict-ref
    137                 htable-dict-set
    138                 htable-dict-delete
     129                htable-dict-set!
     130                htable-dict-delete!
    139131                htable-dict-for-each
    140                 htable-dict-merge
     132                htable-dict-merge!
    141133                htable-dict-search
    142134                htable-dict-count
     
    145137                htable-dict-exists?) )
    146138
    147 ;; Dictionary Type
    148 
    149 (define (dict-same-kind? dict1 dict2)
    150   (eq? (dict-test-ref dict1) (dict-test-ref dict2)) )
    151 
    152 (define (dict-same-test? dict1 dict2) (eq? (dictbase-test dict1) (dictbase-test dict2)))
    153 
    154 (define (dict-bestfit dict)
    155         (if (fx< MAGIC-LIMIT (dictbase-count dict))
    156       (unless (htable-dict? dict) (become-htable-dict dict))
    157       (unless (alist-dict? dict) (become-alist-dict dict)) ) )
    158 
    159 ;; Argument Checks
    160 
    161 (define-check-type dict)
    162 
    163 (define (check-value loc obj)
    164   (when (eq? (void) obj) (error-argument-type loc obj "non-undefined value")) )
    165 
    166139;;;
    167140
     
    180153
    181154(define (alist-dict-ref data key def)
    182         (alist-ref key (alist-dict-alist data) (alist-dict-test data) def) )
    183 
    184 (define (alist-dict-set data key obj)
     155        (%alist-ref key (alist-dict-alist data) (alist-dict-test data) def) )
     156
     157(define (alist-dict-set! data key obj)
    185158        (alist-dict-alist-set!
    186          data
    187    (alist-update! key obj (alist-dict-alist data) (alist-dict-test data))) )
    188 
    189 (define (alist-dict-delete data key)
     159          data
     160    (%alist-update! key obj (alist-dict-alist data) (alist-dict-test data))) )
     161
     162(define (alist-dict-delete! data key)
    190163        (alist-dict-alist-set!
    191          data
    192    (alist-delete! key (alist-dict-alist data) (alist-dict-test data))) )
     164          data
     165    (%alist-delete! key (alist-dict-alist data) (alist-dict-test data))) )
    193166
    194167(define (alist-dict-for-each data proc)
    195         (for-each (lambda (cell) (proc (car cell) (cdr cell)))
    196                           (alist-dict-alist data)) )
    197 
    198 (define (alist-dict-merge data1 data2)
     168        (%list-for-each/1
     169          (lambda (cell) (proc (%car cell) (%cdr cell)))
     170    (alist-dict-alist data)) )
     171
     172(define (alist-dict-merge! data1 data2)
    199173        (let ((test (alist-dict-test data1))
    200174              (al (alist-dict-alist data1)))
    201                 (for-each (lambda (cell)
    202                                     (set! al (alist-update! (car cell) (cdr cell) al test)))
    203                                         (alist-dict-alist data2))
     175                (%list-for-each/1
     176                  (lambda (cell) (set! al (%alist-update! (%car cell) (%cdr cell) al test)))
     177      (alist-dict-alist data2))
    204178                (alist-dict-alist-set! data1 al) ) )
    205179
    206 (define (alist-dict-search data proc def) (alist-find proc (alist-dict-alist data) def))
    207 
    208 (define (alist-dict-count data) (length (alist-dict-alist data)))
    209 
    210 (define (alist-dict-keys data) (map (lambda (x) (car x)) (alist-dict-alist data)))
    211 
    212 (define (alist-dict-values data) (map (lambda (x) (cdr x)) (alist-dict-alist data)))
     180(define (alist-dict-search data proc def) (%alist-find proc (alist-dict-alist data) def))
     181
     182(define (alist-dict-count data) (%list-length (alist-dict-alist data)))
     183
     184(define (alist-dict-keys data) (%list-map/1 (lambda (x) (%car x)) (alist-dict-alist data)))
     185
     186(define (alist-dict-values data) (%list-map/1 (lambda (x) (%cdr x)) (alist-dict-alist data)))
    213187
    214188(define (alist-dict-exists? data key)
    215         (not (eq? (void) (alist-dict-ref data key (void)))) )
     189  (not (%undefined-value? (alist-dict-ref data key (%undefined-value)))) )
    216190
    217191(define (make-alist-dict test al)
    218192  (set-alist-dict-procs! (make-dictbase (make-alist-data test al))) )
    219193
    220 (define (alist-dict? dict) (eq? alist-dict-test-ref (dictbase-test dict)))
    221 
    222 (define (become-alist-dict dict)
     194(define (alist-dict? dict) (%eq? alist-dict-test-ref (dictbase-test dict)))
     195
     196(define (become-alist-dict! dict)
    223197        (dict-data-set! dict (make-alist-data (dictbase-test dict) (dict->alist dict)))
    224198        (set-alist-dict-procs! dict) )
     
    233207        (hash-table-ref/default (htable-dict-htable data) key def) )
    234208
    235 (define (htable-dict-set data key obj)
     209(define (htable-dict-set! data key obj)
    236210        (hash-table-set! (htable-dict-htable data) key obj) )
    237211
    238 (define (htable-dict-delete data key)
     212(define (htable-dict-delete! data key)
    239213        (hash-table-delete! (htable-dict-htable data) key) )
    240214
     
    242216        (hash-table-for-each (htable-dict-htable data) proc) )
    243217
    244 (define (htable-dict-merge data1 data2)
     218(define (htable-dict-merge! data1 data2)
    245219        (htable-dict-htable-set!
    246         data1
    247          (hash-table-merge! (htable-dict-htable data1) (htable-dict-htable data2))) )
     220          data1
     221          (hash-table-merge! (htable-dict-htable data1) (htable-dict-htable data2))) )
    248222
    249223(define (htable-dict-search data proc def)
     
    266240  (set-htable-dict-procs! (make-dictbase (make-htable-data test ht))) )
    267241
    268 (define (htable-dict? dict) (eq? htable-dict-test-ref (dictbase-test dict)))
    269 
    270 (define (become-htable-dict dict)
     242(define (htable-dict? dict) (%eq? htable-dict-test-ref (dictbase-test dict)))
     243
     244(define (become-htable-dict! dict)
    271245        (let ((test (dictbase-test dict)))
    272246                (dict-data-set! dict (make-htable-data test (alist->hash-table (dict->alist dict) test))))
    273247        (set-htable-dict-procs! dict) )
    274248
     249;; Argument Checks
     250
     251(define-check-type dict)
     252
     253(define (check-value loc obj #!optional nam)
     254  (when (%undefined-value? obj)
     255    (error-argument-type loc obj "non-undefined value" nam)) )
     256
     257(define (check-assclist loc obj #!optional nam)
     258  (check-list loc obj nam)
     259  (let loop ((al obj) (tal '()))
     260    (cond ((%null? al) )
     261          ((not (%pair? (%car al)))
     262            (error-argument-type loc obj "association list" nam) )
     263          ((%memq (%cdr al) tal)
     264            (error-argument-type loc obj "proper list" nam) )
     265          (else
     266            (loop (%cdr al) (%cons (%cdr al) tal)) ) ) ) )
     267
    275268;; Errors
    276269
    277270(define-error-type dict)
    278271
    279 ;;
     272;; Print worker
    280273
    281274(define (*dict-print dict)
    282   ((rec (print-node-table dict spcr)
     275  (define (print-node-table dict spcr)
    283276    (dictbase-for-each dict
    284277      (lambda (key val)
    285         (for-each display spcr)
     278        (%list-for-each/1 display spcr)
    286279        (cond ((dict? val)
    287280                (write key) (display " :") (newline)
    288                 (print-node-table val (cons "  " spcr)))
     281                (print-node-table val (%cons "  " spcr)) )
    289282              (else
    290                 (write key) (display " : ") (pretty-print val))))))
    291     dict '()) )
     283                (write key) (display " : ") (pretty-print val)) ) ) ) )
     284    (print-node-table dict '()) )
     285
     286;; Update workers
    292287
    293288(define (*dict-update! dict key valu-func updt-func curr loc)
    294289  (let ((val (updt-func
    295               (if (not (eq? (void) curr)) curr
    296                   (let ((val (valu-func)))
    297                     (when *dict-safe-mode* (check-value loc val))
    298                     val ) ) ) ) )
     290               (if (not (%undefined-value? curr)) curr
     291                   (let ((val (valu-func)))
     292                     (when *dict-safe-mode* (check-value loc val))
     293                     val ) ) ) ) )
    299294    (dictbase-set! dict key val)
    300295    val ) )
     
    305300    (check-procedure loc valu-func)
    306301    (check-procedure loc updt-func) )
    307   (let* ((curr (dictbase-ref dict key (void)))
     302  (let* ((curr (dictbase-ref dict key (%undefined-value)))
    308303         (updt (*dict-update! dict key valu-func updt-func curr loc)))
    309     (unless (eq? (void) curr) (dict-bestfit dict))
     304    (unless (%undefined-value? curr) (dict-bestfit dict))
    310305    updt ) )
     306
     307;; Dictionary Type
     308
     309(define (dict-same-kind? dict1 dict2) (%eq? (dict-test-ref dict1) (dict-test-ref dict2)))
     310(define (dict-same-test? dict1 dict2) (%eq? (dictbase-test dict1) (dictbase-test dict2)))
     311
     312(define (dict-bestfit dict)
     313        (if (%fx< MAGIC-LIMIT (dictbase-count dict))
     314      (unless (htable-dict? dict) (become-htable-dict! dict))
     315      (unless (alist-dict? dict) (become-alist-dict! dict)) ) )
    311316
    312317;;; Globals
     
    321326    (check-cardinal-fixnum 'make-dict size "size")
    322327    (check-procedure 'make-dict test) )
    323         (if (fx< MAGIC-LIMIT size)
     328        (if (%fx< MAGIC-LIMIT size)
    324329      (make-htable-dict test (make-hash-table test))
    325330      (make-alist-dict test '())) )
     
    327332(define (alist->dict al #!optional (test eq?) (size 0))
    328333  (when *dict-safe-mode*
     334    (check-assclist 'alist->dict al "alist")
    329335    (check-cardinal-fixnum 'alist->dict size "size")
    330336    (check-procedure 'alist->dict test) )
    331         (if (or (fx< MAGIC-LIMIT size) (fx< MAGIC-LIMIT (length al)))
     337        (if (or (%fx< MAGIC-LIMIT size) (%fx< MAGIC-LIMIT (%list-length al)))
    332338      (make-htable-dict test (alist->hash-table al test))
    333339      (make-alist-dict test al)) )
     
    396402(define (dict-merge! dict . dicts)
    397403  (when *dict-safe-mode* (check-dict 'dict-merge! dict))
    398         (for-each
     404        (%list-for-each/1
    399405                (lambda (dictx)
    400406      (when *dict-safe-mode*
     
    402408        (unless (dict-same-test? dict dictx)
    403409          (error "cannot merge lookup-tables; incompatible test") ) )
    404                         (if (dict-same-kind? dict dictx) (dictbase-merge dict dictx)
     410                        (if (dict-same-kind? dict dictx) (dictbase-merge! dict dictx)
    405411          (dictbase-for-each dictx (cut dict-set! dict <> <>)) ) )
    406412                dicts)
  • release/4/lookup-table/trunk/lookup-table.setup

    r14484 r14543  
    55(verify-extension-name "lookup-table")
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "1.8.0"))
     7;; MAGIC-LIMIT - Element count when hash-table faster (YMMV)
     8
     9(setup-shared-extension-module (extension-name) (extension-version "1.8.0")
     10  #:compile-options '(-prelude "'(define-constant MAGIC-LIMIT 12)'"))
Note: See TracChangeset for help on using the changeset viewer.