Changeset 15950 in project


Ignore:
Timestamp:
09/18/09 22:29:05 (10 years ago)
Author:
Kon Lovett
Message:

Save - this has a prob when test run - alist->hash-table is unbound!

Location:
release/4/lookup-table/trunk
Files:
1 added
1 deleted
7 edited

Legend:

Unmodified
Added
Removed
  • release/4/lookup-table/trunk/chicken-primitive-object-inlines.scm

    r14543 r15950  
    712712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
    713713
    714 (define-inline (%any/1 pred? ls)
     714(define-inline (%list-any/1 pred? ls)
    715715  (let loop ((ls ls))
    716716    (and (not (%null? ls))
     
    718718             (loop (%cdr ls)) ) ) ) )
    719719
     720(define-inline (%list-every/1 pred? ls)
     721  (let loop ((ls ls) (last #t))
     722    (if (%null? ls) last
     723        (let ((this (pred? (%car ls))))
     724          (and this
     725               (loop (%cdr ls) this)) ) ) ) )
     726
    720727(define-inline (%list-length ls0)
    721728  (let loop ((ls ls0) (n 0))
    722729    (if (%null? ls) n
    723730        (loop (%cdr ls) (%fxadd1 n)) ) ) )
     731
     732(define-inline (%list-find pred? ls)
     733  (let loop ((ls ls))
     734    (and (not (%null? ls))
     735         (or (let ((elm (%car ls))) (and (pred? elm) elm))
     736             (loop (%cdr ls)) ) ) ) )
     737
     738(define-inline (%alist-ref key al #!optional (test eqv?) def)
     739  (let loop ((al al))
     740    (cond ((%null? al) def )
     741          ((test key (%caar al)) (%cdar al) )
     742          (else (loop (%cdr al)) ) ) ) )
     743
     744(define-inline (%alist-update! key val al0 #!optional (test eqv?))
     745  (let loop ((al al0))
     746    (cond ((%null? al) (%cons (%cons key val) al0) )
     747          ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
     748          (else (loop (%cdr al)) ) ) ) )
     749
     750(define-inline (%alist-delete! key al0 #!optional (test equal?))
     751  (let loop ((al al0) (prv #f))
     752    (cond ((%null? al) al0)
     753          ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
     754          (else (loop (%cdr al) al) ) ) ) )
    724755
    725756;; Structure (wordblock)
  • release/4/lookup-table/trunk/lookup-table-body.scm

    r15948 r15950  
    11;;;; lookup-table-body.scm
    22;;;; Kon Lovett, Sep '09
     3
     4(import (only srfi-1 reverse! fold list-copy find alist-delete!)
     5        (only srfi-69 hash-table->alist hash-table-ref/default hash-table-set!
     6                      hash-table-delete! hash-table-for-each hash-table-merge!
     7                      hash-table-walk hash-table-size hash-table-keys hash-table-values
     8                      hash-table-exists? alist->hash-table make-hash-table)
     9        (only ports with-output-to-port)
     10        (only data-structures identity alist-ref alist-update!)
     11        (only extras pretty-print)
     12        (only miscmacros let/cc)
     13        type-checks
     14        type-errors)
     15
     16(require-library srfi-1 srfi-69 extras miscmacros type-checks type-errors)
    317
    418;;;
     
    1024;;;
    1125
    12 ;;; Variant Dictionary
    13 
    14 (define-record-type/primitive dict
    15         (make-dictbase data)
    16         dict?
    17         (data dict-data-ref dict-data-set!)
    18         (test dict-test-ref dict-test-set!)
    19         (to-alist dict->alist-ref dict->alist-set!)
    20         (ref dict-ref-ref dict-ref-set!)
    21         (set dict-set-ref dict-set-set!)
    22         (delete dict-delete-ref dict-delete-set!)
    23         (for-each dict-for-each-ref dict-for-each-set!)
    24         (merge dict-merge-ref dict-merge-set!)
    25         (search dict-search-ref dict-search-set!)
    26         (count dict-count-ref dict-count-set!)
    27         (keys dict-keys-ref dict-keys-set!)
    28         (values dict-values-ref dict-values-set!)
    29         (exists dict-exists-ref dict-exists-set!) )
     26(cond-expand
     27
     28  (unsafe
     29    (import srfi-9-ext)
     30    (require-library srfi-9-ext)
     31
     32    (include "chicken-primitive-object-inlines")
     33
     34    (define-record-type/primitive dict
     35      (make-dictbase data)
     36      dict?
     37      (data dict-data-ref dict-data-set!)
     38      (test dict-test-ref dict-test-set!)
     39      (to-alist dict->alist-ref dict->alist-set!)
     40      (ref dict-ref-ref dict-ref-set!)
     41      (set dict-set-ref dict-set-set!)
     42      (delete dict-delete-ref dict-delete-set!)
     43      (for-each dict-for-each-ref dict-for-each-set!)
     44      (merge dict-merge-ref dict-merge-set!)
     45      (search dict-search-ref dict-search-set!)
     46      (count dict-count-ref dict-count-set!)
     47      (keys dict-keys-ref dict-keys-set!)
     48      (values dict-values-ref dict-values-set!)
     49      (exists dict-exists-ref dict-exists-set!) ) )
     50
     51  (else
     52    (define (%undefined-value? obj) (eq? (void) obj))
     53    (define (%undefined-value) (void))
     54    (define %list-map/1 map)
     55    (define %list-for-each/1 for-each)
     56    (define %list-length length)
     57    (define %list-find find)
     58    (define %fx< fx<)
     59    (define %memq memq)
     60    (define %pair? pair?)
     61    (define %null? null?)
     62    (define %eq? eq?)
     63    (define %alist-delete! alist-delete!)
     64    (define %alist-update! alist-update!)
     65    (define %alist-ref alist-ref)
     66    (define %list-copy list-copy)
     67    (define %set-cdr! set-cdr!)
     68    (define %cons cons)
     69    (define %cdr cdr)
     70    (define %car car)
     71
     72    (define-record-type dict
     73      (make-dictbase data)
     74      dict?
     75      (data dict-data-ref dict-data-set!)
     76      (test dict-test-ref dict-test-set!)
     77      (to-alist dict->alist-ref dict->alist-set!)
     78      (ref dict-ref-ref dict-ref-set!)
     79      (set dict-set-ref dict-set-set!)
     80      (delete dict-delete-ref dict-delete-set!)
     81      (for-each dict-for-each-ref dict-for-each-set!)
     82      (merge dict-merge-ref dict-merge-set!)
     83      (search dict-search-ref dict-search-set!)
     84      (count dict-count-ref dict-count-set!)
     85      (keys dict-keys-ref dict-keys-set!)
     86      (values dict-values-ref dict-values-set!)
     87      (exists dict-exists-ref dict-exists-set!) ) ) )
     88
     89;;;
    3090
    3191(define (set-dict-procs! dict tst to ref set del for mrg sch cnt keys vals exsts)
     
    61121;; Association List
    62122
     123(define (alist-search al proc #!optional def)
     124  (let ((cell (%list-find (lambda (cell) (proc (%car cell) (%cdr cell))) al)))
     125    (if cell (%cdr cell)
     126        def ) ) )
     127
    63128(define (make-alist-data test al) (%cons test al))
    64129(define (alist-dict-test data) (%car data))
     
    86151(define (htable-dict-test data) (%car data))
    87152(define (htable-dict-htable data) (%cdr data))
    88 (define (htable-dict-htable-set! data ht) (%set-cdr!/mutate data ht))
     153(define (htable-dict-htable-set! data ht) (%set-cdr! data ht))
    89154
    90155(define (set-htable-dict-procs! dict)
     
    110175
    111176(define (alist-dict->alist data)
    112   (cond-expand (unsafe (alist-dict-alist data)) (else (list-copy (alist-dict-alist data)))) )
     177  (cond-expand (unsafe (alist-dict-alist data)) (else (%list-copy (alist-dict-alist data)))) )
    113178
    114179(define (alist-dict-ref data key def)
     
    138203                (alist-dict-alist-set! data1 al) ) )
    139204
    140 (define (alist-dict-search data proc def) (%alist-find proc (alist-dict-alist data) def))
     205(define (alist-dict-search data proc def) (alist-search (alist-dict-alist data) proc def))
    141206
    142207(define (alist-dict-count data) (%list-length (alist-dict-alist data)))
     
    326391          (if (eq? def val) def
    327392              (begin
    328                 (dictbase-set! dict key obj)
     393                (dictbase-set! dict key val)
    329394                (dict-bestfit dict)
    330395                val ) ) ) ) ) )
  • release/4/lookup-table/trunk/lookup-table-synch.scm

    r15948 r15950  
    3535  (lambda (frm rnm cmp)
    3636    (let ((_define (rnm 'define))
    37           (_let* (rnm 'let*))
     37          (_let (rnm 'let))
    3838          (_and (rnm 'and))
    3939          (_or (rnm 'or))
     
    6161      (let* ((prcnam (cadr frm))
    6262             (newnam (string->symbol (string-append (symbol->string prcnam) "/synch"))) )
    63         `(,_define (,newnam ds . args) (,_let/synch ((o os)) (,_apply ,prcnam o args))) ) ) ) )
     63        `(,_define (,newnam os . args) (,_let/synch ((o os)) (,_apply ,prcnam o args))) ) ) ) )
    6464
    6565(synch-wrap-make make-dict)
  • release/4/lookup-table/trunk/lookup-table-unsafe-synch.scm

    r15948 r15950  
    3535  (lambda (frm rnm cmp)
    3636    (let ((_define (rnm 'define))
    37           (_let* (rnm 'let*))
     37          (_let (rnm 'let))
    3838          (_and (rnm 'and))
    3939          (_or (rnm 'or))
     
    6161      (let* ((prcnam (cadr frm))
    6262             (newnam (string->symbol (string-append (symbol->string prcnam) "/%synch"))) )
    63         `(,_define (,newnam ds . args) (,_%let/synch ((o os)) (,_apply ,prcnam o args))) ) ) ) )
     63        `(,_define (,newnam os . args) (,_%let/synch ((o os)) (,_apply ,prcnam o args))) ) ) ) )
    6464
    6565(synch-wrap-make make-dict)
  • release/4/lookup-table/trunk/lookup-table-unsafe.scm

    r15948 r15950  
    11;;;; lookup-table-unsafe.scm
    22;;;; Kon Lovett, ep '09
    3 
    4 (include "chicken-primitive-object-inlines")
    5 (include "chicken-primitive-alist")
    63
    74;;;
     
    3027  dict-print )
    3128
    32   (import scheme chicken
    33           srfi-1 srfi-69 ports data-structures extras
    34           miscmacros type-checks type-errors srfi-9-ext)
     29 (import scheme chicken)
    3530
    36   (require-library srfi-1 srfi-69 extras miscmacros type-checks type-errors srfi-9-ext)
    37 
    38   (include "lookup-table-body")
     31 (include "lookup-table-body")
    3932
    4033) ;module lookup-table-unsafe
  • release/4/lookup-table/trunk/lookup-table.scm

    r15948 r15950  
    11;;;; lookup-table.scm
    22;;;; Kon Lovett, Sep '09
    3 
    4 (include "chicken-primitive-object-inlines")
    5 (include "chicken-primitive-alist")
    63
    74;;;
     
    3027  dict-print )
    3128
    32   (import
    33     scheme chicken
    34     srfi-1 srfi-69 ports data-structures extras
    35     miscmacros type-checks type-errors srfi-9-ext)
     29 (import scheme chicken)
    3630
    37   (require-library srfi-1 srfi-69 extras miscmacros type-checks type-errors srfi-9-ext)
    38 
    39   (include "lookup-table-body")
     31 (include "lookup-table-body")
    4032
    4133) ;module lookup-table
  • release/4/lookup-table/trunk/tests/run.scm

    r15809 r15950  
    1 (system "csi -n -s safe.scm")
    2 (system "csi -n -s unsafe.scm")
     1(system "csc safe.scm") (system "./safe")
     2
     3(system "csc unsafe.scm") (system "./unsafe")
Note: See TracChangeset for help on using the changeset viewer.