Changeset 30177 in project


Ignore:
Timestamp:
12/10/13 18:20:52 (6 years ago)
Author:
juergen
Message:

bindings 2.4, generic functions rewritten, records removed from tests

Location:
release/4/bindings
Files:
5 edited
4 copied

Legend:

Unmodified
Added
Removed
  • release/4/bindings/tags/2.4/bindings.meta

    r29779 r30177  
    44 (category lang-exts)
    55 (license "BSD")
    6  (test-depends tuples lolevel simple-tests)
     6 (test-depends tuples simple-tests)
    77 (author "Juergen Lorenz")
    88 (files "bindings.setup" "bindings.release-info" "bindings.meta" "bindings.scm" "tests/run.scm"))
  • release/4/bindings/tags/2.4/bindings.scm

    r30172 r30177  
    7373sort of overkill.
    7474
    75 Internally, we'll use three generic functions instead, generic-car,
    76 generic-cdr and generic-null? which are able to handle not only lists,
     75Internally, we'll use three generic functions instead, gcar,
     76gcdr and gnull? which are able to handle not only lists,
    7777but vectors and strings as well. So our binding macros work on
    7878arbitrary mixtures of (pseudo-) lists, strings and vectors as given.
     
    9999(module bindings
    100100(export bindings
    101         (bind generic-car generic-cdr generic-null? generic-pair?)
     101        (bind gcar gcdr gnull? gpair?)
    102102        bindable?  bind-case bind-let bind-let* bind-letrec
    103103        bindrec bind-lambda bind-lambda* bind* bind-set!
    104104        bind-define bind-case-lambda bind-case-lambda*
     105        ;gcar gcar-table gnull? gnull?-table gcdr gcdr-table ;;;
     106        ;search-and-call assp;;;
    105107        ;; the generics updater must be exported for bind to be extensible
    106108        generic-null-car-cdr!)
     
    109111        (only data-structures ->string list-of?)
    110112        (only chicken
    111               condition-case case-lambda
     113              condition-case case-lambda define-values
    112114              print error gensym
    113115              current-exception-handler
     
    166168    ((_(a . b) seq xpr . xprs)
    167169     (let ((seq1 seq))
    168        (if (generic-pair? seq1)
    169          (bind a (generic-car seq1)
    170            (bind b (generic-cdr seq1) xpr . xprs))
     170       (if (gpair? seq1)
     171         (bind a (gcar seq1)
     172           (bind b (gcdr seq1) xpr . xprs))
    171173         (signal (make-property-condition 'bind-exn
    172174                                          'message "no match"
     
    174176                                          'arguments (list '(a . b) seq1)
    175177                                          )))))
    176 ;       (condition-case
    177 ;         (bind a (generic-car seq1)
    178 ;           (bind b (generic-cdr seq1) xpr . xprs))
    179 ;         ((exn)
    180 ;          (signal (make-property-condition 'bind-exn
    181 ;                                           'message "no match"
    182 ;                                           'location '(bind)
    183 ;                                           'arguments (list '(a . b) seq1)
    184 ;                                           ))))))
    185178    ((_ () seq xpr . xprs)
    186179     (let ((seq1 seq))
    187        (if (generic-null? seq1)
     180       (if (gnull? seq1)
    188181         (let () xpr . xprs)
    189182         (signal (make-property-condition 'bind-exn
     
    588581#|[
    589582Now to the generic functions.
    590 In generic-null-car-cdr! we store an associative list of vectors which
    591 store versions of null?, car and cdr for lists, pseudolists, vectors and
    592 strings, indexed over type predicates. This list can be updated by
    593 clients to allow other sequence types. In the tests we've done it for
    594 tuples and records.
    595 The generic-functions generic-null?, generic-car and generic-cdr are
    596 defined by searching this table. They need not be exported.
    597 ]|#
    598 
    599 ;;; (generic-null-car-cdr type-predicate type-null? type-car type-cdr)
    600 ;;; ------------------------------------------------------------------
    601 ;;; updates the table with tree functions in this order and index it
    602 ;;; with the type predicate.
    603 (define generic-null-car-cdr!
    604   (let (
    605     (table
    606       (list
    607         (cons list?
    608               (vector null? car cdr))
    609         (cons pair?
    610               (vector (lambda (x) #f) car cdr))
    611         (cons vector?
    612               (vector
    613                 (lambda (seq) (zero? (vector-length seq)))
    614                 (lambda (seq) (vector-ref seq 0))
    615                 (lambda (seq) ;(subvector seq 1))))
    616                               ;subvector is still buggy
    617                   (let ((len (vector-length seq)))
    618                     (if (zero? (vector-length seq))
    619                       (error 'subvector "out of range")
    620                       (let* ((new-len (- len 1))
    621                              (result (make-vector new-len #f)))
    622                         (do ((k 0 (+ k 1)))
    623                           ((= k new-len) result)
    624                           (vector-set! result k
    625                                        (vector-ref seq (+ k 1))))))))))
    626         (cons string?
    627               (vector
    628                 (lambda (seq) (zero? (string-length seq)))
    629                 (lambda (seq) (string-ref seq 0))
    630                 (lambda (seq) (substring seq 1))))
    631         ))
    632     )
    633     (lambda args
    634       (cond
    635         ;; add to table
    636         ((and ((list-of? procedure?) args)
    637               (= (length args) 4))
    638          (set! table
    639                (cons (cons (car args)
    640                            (apply vector (cdr args)))
    641                      table)))
    642         ;; search table
    643         ((= (length args) 1)
    644          (let loop ((tbl table))
    645            (cond
    646              ((null? tbl)
    647               (error 'generic-null-car-cdr!
    648                      (string-append
    649                        "not in type list "
    650                        (->string (map car table)))
    651                      (car args)))
    652              (((caar tbl) (car args))
    653               (cdar tbl))
    654              (else
    655                (loop (cdr tbl))))))
    656         (else
    657           (error 'generic-null-car-cdr!
    658                  "wrong arguments"))))))
    659 
    660 (define (generic-null? seq)
    661   (condition-case
    662     ((vector-ref (generic-null-car-cdr! seq) 0) seq)
    663     ((exn) #f)))
    664 (define (generic-car seq)
    665   (condition-case
    666     ((vector-ref (generic-null-car-cdr! seq) 1) seq)
    667     ((exn) (error 'generic-car "bad argument type" seq))))
    668 (define (generic-cdr seq)
    669   (condition-case
    670     ((vector-ref (generic-null-car-cdr! seq) 2) seq)
    671     ((exn) (error 'generic-cdr "bad argument type" seq))))
    672 (define (generic-pair? x)
     583We start with a helper, which does the search, a variant of assoc, which
     584might be of interest in other contexts as well.
     585]|#
     586
     587(define (assp ok? tbl)
     588  (let loop ((tbl tbl))
     589    (cond
     590      ((null? tbl) #f)
     591      ((ok? (caar tbl)) (car tbl))
     592      (else (loop (cdr tbl))))))
     593
     594#|[
     595The following two macros help to avoid repetition of code.
     596]|#
     597
     598(define-syntax search-and-call
     599  (syntax-rules ()
     600    ((_ tbl)
     601     (lambda (lst)
     602       (let ((pair (assp (lambda (x) (x lst))
     603                         tbl))) ; choose method
     604         (if pair
     605           ((cdr pair) lst) ; apply it
     606           (error 'search-and-call "type error" lst)))))))
     607
     608(define-syntax add-to-table
     609  (syntax-rules ()
     610    ((_ tbl)
     611     (lambda (pair)
     612       (set! tbl (append tbl (list pair)))))))
     613
     614#|[
     615
     616Generic functions are in fact closures, which search a table for a
     617matching operation and apply that operation in case of a match.
     618To be able to add new operations to that table, we must get a handle on
     619it. In other words, there must be other routines which operate on the
     620same table. define-values will come to the rescue ...
     621]|#
     622
     623(define-values (gnull? gnull?-table gnull?-table!)
     624  (let ((table
     625          (list
     626            (cons list? null?)
     627            (cons pair? (lambda (seq) #f))
     628            (cons vector?  (lambda (seq) (zero? (vector-length seq))))
     629            (cons string? (lambda (seq) (zero? (string-length seq))))
     630            )))
     631    (values
     632      (search-and-call table)
     633      (lambda () table) ; for debugging purposes
     634      (add-to-table table))))
     635
     636(define-values (gcar gcar-table gcar-table!)
     637  (let ((table
     638          (list
     639            (cons list? car)
     640            (cons pair? car)
     641            (cons vector?  (lambda (seq) (vector-ref seq 0)))
     642            (cons string? (lambda (seq) (string-ref seq 0)))
     643            )))
     644    (values
     645      (search-and-call table)
     646      (lambda () table) ; for debugging purposes
     647      (add-to-table table))))
     648      ;  (set! table (append table (list pair)))))))
     649
     650(define-values (gcdr gcdr-table gcdr-table!)
     651  (let ((table
     652          (list
     653            (cons list? cdr)
     654            (cons pair? cdr)
     655            (cons vector?
     656                  (lambda (seq)
     657                    ; (subvector seq 1))) ; buggy implemetation
     658                    (let ((len (vector-length seq)))
     659                      (if (zero? (vector-length seq))
     660                        (error 'subvector "out of range")
     661                        (let* ((new-len (- len 1))
     662                               (result (make-vector new-len #f)))
     663                          (do ((k 0 (+ k 1)))
     664                            ((= k new-len) result)
     665                            (vector-set! result k
     666                                         (vector-ref seq (+ k 1)))))))))
     667            (cons string? (lambda (seq) (substring seq 1)))
     668            )))
     669    (values
     670      (search-and-call table)
     671      (lambda () table) ; for debugging purposes
     672      (add-to-table table))))
     673
     674(define (gpair? x)
    673675  (let ((result (gensym 'result)))
    674676    (if (memq result
    675677              (list
    676                 (condition-case (generic-car x)
     678                (condition-case (gcar x)
    677679                  ((exn) result))
    678                 (condition-case (generic-cdr x)
     680                (condition-case (gcdr x)
    679681                  ((exn) result))))
    680682      #f
    681683      #t)))
     684
     685#|[
     686All of the generic functions above need not be exported. We will only
     687export the following routine, which updates the three tables in one go.
     688This way it's impossible to forget updating one of the three tables.
     689]|#
     690
     691;;; (generic-null-car-cdr! type? type-null? type-car type-cdr)
     692;;; ----------------------------------------------------------
     693;;; updates the tables with tree functions in this order and index it
     694;;; with the type predicate type?.
     695(define (generic-null-car-cdr! type? type-null? type-car type-cdr)
     696  (gnull?-table! (cons type? type-null?))
     697  (gcar-table! (cons type? type-car))
     698  (gcdr-table! (cons type? type-cdr)))
    682699
    683700(define bindings
     
    686703      (bind
    687704        "a variant of Common Lisp's destructuring-bind macro"
    688         (bind pat seq (where . fenders) .. xpr . xprs)
    689 "Destructures the sequence expression seq according to the pattern pat, checking the optional fenders, binds pattern variables of pat to corresponding subexpressions of seq and executes xpr . xprs in this context")
     705        (bind pat seq (where . fenders) .. xpr . xprs))
    690706      (bind-set!
    691707        "sets multiple variables by destructuring its sequence argument"
    692         (bind-set! pat seq)
    693     "destructures seq according to pat and sets pattern variables with values corresponding to subexpressions of seq")
     708        (bind-set! pat seq))
    694709      (bind-define
    695710        "defines multiple variables by destructuring its sequence argument"
    696         (bind-define pat seq)
    697     "destructures seq according to pat and defines pattern variables with values corresponding to subexpressions of seq")
     711        (bind-define pat seq))
    698712      (bindable?
    699713        "returns a unary predicate, which checks if its sequence argument matches the pattern argument of bindable? and passes all optional fenders"
    700         (bindable? pat . fenders) ..)
     714        (bindable? pat . fenders))
    701715      (bind-case
    702716        "a variant of matchable's match macro."
    703         (bind-case seq (pat (where . fenders) .. xpr . xprs) ....)
    704 "Checks if seq matches patterns pat checking fenders in sequence, binds the pattern variables of the first matching pattern to corresponding subexpressions of seq and executes corresponding body in this context")
     717        (bind-case seq (pat (where . fenders) .. xpr . xprs) ....))
    705718      (bind-lambda
    706719        "combination of lambda and bind, one pattern argument"
     
    711724      (bind-case-lambda
    712725        "combination of lambda and bind-case with one pattern argument"
    713         (bind-case-lambda clause ....)
    714 "where each clause is either of the form (pat xpr . xprs) or (pat (where . fenders) xpr . xprs) where fenders can be used to reject an otherwise matching pattern")
     726        (bind-case-lambda (pat (where . fenders) .. xpr . xprs) ....))
    715727      (bind-case-lambda*
    716728        "combination of lambda and bind-case with multiple pattern arguments"
    717         (bind-case-lambda* clause ....)
    718 "where each clause is either of the form (pat xpr . xprs) or (pat (where . fenders) xpr . xprs) where fenders can be used to reject an otherwise matching pattern")
     729        (bind-case-lambda* (pat (where . fenders) .. xpr . xprs) ....))
    719730      (bind*
    720731        "named version of bind"
    721         (bind* loop pat seq xpr . xprs)
    722 "where loop evaluates to a one-parameter procedure to be used in xpr . xprs")
     732        (bind* loop pat seq xpr . xprs))
    723733      (bind-let
    724734        "nested version of let, named and unnamed"
    725         (bind-let loop .. ((pat seq) ...) xpr . xprs)
    726 "binds pattern variables of pat ... to matching positions of seq ...  in parallel and executes xpr . xprs in this context. If loop is provided, it evaluates to a one-parameter procedure available in the body xpr . xprs")
     735        (bind-let loop .. ((pat seq) ...) xpr . xprs))
    727736      (bind-let*
    728         "sequential version of let"
    729         (bind-let ((pat seq) ...) xpr . xprs)
    730 "binds pattern variables of pat ... to matching positions of seq ...  sequentially and executes xpr . xprs in this context")
     737        "nested version of let*"
     738        (bind-let ((pat seq) ...) xpr . xprs))
    731739      (bind-letrec
    732740        "recursive version of bind-let"
    733         (bind-letrec ((pat seq) ...) xpr . xprs)
    734 "binds pattern variables of pat ... to matching positions of seq ...  recursively and executes xpr . xprs in this context")
     741        (bind-letrec ((pat seq) ...) xpr . xprs))
    735742      (bindrec
    736743        "recursive version of bind"
    737         (bindrec pat seq . body)
    738 "like bind, but seq can contain references to pattern variables in pat")
     744        (bindrec pat seq . body))
    739745      (generic-null-car-cdr!
    740746        "command updating the table of the following generic functions"
    741         (generic-null-car-cdr! type-predicate null-proc car-proc cdr-proc))))
     747        (generic-null-car-cdr! type? type-null? type-car type-cdr))))
    742748      )
    743749      (case-lambda
     
    750756
    751757) ; module bindings
     758
  • release/4/bindings/tags/2.4/bindings.setup

    r30172 r30177  
    77 'bindings
    88 '("bindings.so" "bindings.import.so")
    9  '((version "2.3.4")))
     9 '((version "2.4")))
    1010
  • release/4/bindings/tags/2.4/tests/run.scm

    r30172 r30177  
    33;;;; ju (at) jugilo (dot) de
    44
    5 (require-library bindings lolevel tuples simple-tests)
     5(require-library bindings tuples simple-tests)
    66
    77(import bindings
    88        (only tuples tuple tuple? tuple-empty? tuple-left tuple-butleft)
    9         (only lolevel record-instance? record->vector)
    109        (only chicken error)
    1110        simple-tests)
     
    298297  (define-test (sequences?)
    299298    (check
    300       (generic-null-car-cdr! record-instance?
    301                              (lambda (seq)
    302                                (= 1 (vector-length (record->vector seq))))
    303                              (lambda (seq)
    304                                (vector-ref (record->vector seq) 1))
    305                              (lambda (seq)
    306                                (let* ((vec (record->vector seq))
    307                                       (len (vector-length vec)))
    308                                  (if (< len 2)
    309                                    (error 'subrecord "range error")
    310                                    (let* ((new-len (- len 2))
    311                                           (result (make-vector new-len #f)))
    312                                      (do ((k 0 (+ k 1)))
    313                                        ((= k new-len) result)
    314                                        (vector-set! result k
    315                                                     (vector-ref vec (+ k 2)))))))))
    316299      (generic-null-car-cdr! tuple? tuple-empty? tuple-left tuple-butleft)
    317300      (define-record point x y)
    318       (equal? (bind (x y) (make-point 1 2) (list x y)) '(1 2))
    319       (equal? (bind (x (y z)) (vector 1 (make-point 2 3)) (list x y z))
    320               '(1 2 3))
    321       (equal? (bind (x . y) (make-point 1 2) (list x y)) '(1 #(2)))
    322301      (equal? (bind (x y z) (tuple 1 2 3) (list x y z)) '(1 2 3))
    323302      (equal? (bind (x (y z)) (vector 0 (tuple 1 2)) (list x y z)) '(0 1 2))
     303      (equal? (bind (x (y (z))) (vector 0 (tuple 1 "2")) (list x y z))
     304              '(0 1 #\2))
    324305      ))
    325306  (sequences?)
  • release/4/bindings/trunk/bindings.meta

    r29779 r30177  
    44 (category lang-exts)
    55 (license "BSD")
    6  (test-depends tuples lolevel simple-tests)
     6 (test-depends tuples simple-tests)
    77 (author "Juergen Lorenz")
    88 (files "bindings.setup" "bindings.release-info" "bindings.meta" "bindings.scm" "tests/run.scm"))
  • release/4/bindings/trunk/bindings.scm

    r30172 r30177  
    7373sort of overkill.
    7474
    75 Internally, we'll use three generic functions instead, generic-car,
    76 generic-cdr and generic-null? which are able to handle not only lists,
     75Internally, we'll use three generic functions instead, gcar,
     76gcdr and gnull? which are able to handle not only lists,
    7777but vectors and strings as well. So our binding macros work on
    7878arbitrary mixtures of (pseudo-) lists, strings and vectors as given.
     
    9999(module bindings
    100100(export bindings
    101         (bind generic-car generic-cdr generic-null? generic-pair?)
     101        (bind gcar gcdr gnull? gpair?)
    102102        bindable?  bind-case bind-let bind-let* bind-letrec
    103103        bindrec bind-lambda bind-lambda* bind* bind-set!
    104104        bind-define bind-case-lambda bind-case-lambda*
     105        ;gcar gcar-table gnull? gnull?-table gcdr gcdr-table ;;;
     106        ;search-and-call assp;;;
    105107        ;; the generics updater must be exported for bind to be extensible
    106108        generic-null-car-cdr!)
     
    109111        (only data-structures ->string list-of?)
    110112        (only chicken
    111               condition-case case-lambda
     113              condition-case case-lambda define-values
    112114              print error gensym
    113115              current-exception-handler
     
    166168    ((_(a . b) seq xpr . xprs)
    167169     (let ((seq1 seq))
    168        (if (generic-pair? seq1)
    169          (bind a (generic-car seq1)
    170            (bind b (generic-cdr seq1) xpr . xprs))
     170       (if (gpair? seq1)
     171         (bind a (gcar seq1)
     172           (bind b (gcdr seq1) xpr . xprs))
    171173         (signal (make-property-condition 'bind-exn
    172174                                          'message "no match"
     
    174176                                          'arguments (list '(a . b) seq1)
    175177                                          )))))
    176 ;       (condition-case
    177 ;         (bind a (generic-car seq1)
    178 ;           (bind b (generic-cdr seq1) xpr . xprs))
    179 ;         ((exn)
    180 ;          (signal (make-property-condition 'bind-exn
    181 ;                                           'message "no match"
    182 ;                                           'location '(bind)
    183 ;                                           'arguments (list '(a . b) seq1)
    184 ;                                           ))))))
    185178    ((_ () seq xpr . xprs)
    186179     (let ((seq1 seq))
    187        (if (generic-null? seq1)
     180       (if (gnull? seq1)
    188181         (let () xpr . xprs)
    189182         (signal (make-property-condition 'bind-exn
     
    588581#|[
    589582Now to the generic functions.
    590 In generic-null-car-cdr! we store an associative list of vectors which
    591 store versions of null?, car and cdr for lists, pseudolists, vectors and
    592 strings, indexed over type predicates. This list can be updated by
    593 clients to allow other sequence types. In the tests we've done it for
    594 tuples and records.
    595 The generic-functions generic-null?, generic-car and generic-cdr are
    596 defined by searching this table. They need not be exported.
    597 ]|#
    598 
    599 ;;; (generic-null-car-cdr type-predicate type-null? type-car type-cdr)
    600 ;;; ------------------------------------------------------------------
    601 ;;; updates the table with tree functions in this order and index it
    602 ;;; with the type predicate.
    603 (define generic-null-car-cdr!
    604   (let (
    605     (table
    606       (list
    607         (cons list?
    608               (vector null? car cdr))
    609         (cons pair?
    610               (vector (lambda (x) #f) car cdr))
    611         (cons vector?
    612               (vector
    613                 (lambda (seq) (zero? (vector-length seq)))
    614                 (lambda (seq) (vector-ref seq 0))
    615                 (lambda (seq) ;(subvector seq 1))))
    616                               ;subvector is still buggy
    617                   (let ((len (vector-length seq)))
    618                     (if (zero? (vector-length seq))
    619                       (error 'subvector "out of range")
    620                       (let* ((new-len (- len 1))
    621                              (result (make-vector new-len #f)))
    622                         (do ((k 0 (+ k 1)))
    623                           ((= k new-len) result)
    624                           (vector-set! result k
    625                                        (vector-ref seq (+ k 1))))))))))
    626         (cons string?
    627               (vector
    628                 (lambda (seq) (zero? (string-length seq)))
    629                 (lambda (seq) (string-ref seq 0))
    630                 (lambda (seq) (substring seq 1))))
    631         ))
    632     )
    633     (lambda args
    634       (cond
    635         ;; add to table
    636         ((and ((list-of? procedure?) args)
    637               (= (length args) 4))
    638          (set! table
    639                (cons (cons (car args)
    640                            (apply vector (cdr args)))
    641                      table)))
    642         ;; search table
    643         ((= (length args) 1)
    644          (let loop ((tbl table))
    645            (cond
    646              ((null? tbl)
    647               (error 'generic-null-car-cdr!
    648                      (string-append
    649                        "not in type list "
    650                        (->string (map car table)))
    651                      (car args)))
    652              (((caar tbl) (car args))
    653               (cdar tbl))
    654              (else
    655                (loop (cdr tbl))))))
    656         (else
    657           (error 'generic-null-car-cdr!
    658                  "wrong arguments"))))))
    659 
    660 (define (generic-null? seq)
    661   (condition-case
    662     ((vector-ref (generic-null-car-cdr! seq) 0) seq)
    663     ((exn) #f)))
    664 (define (generic-car seq)
    665   (condition-case
    666     ((vector-ref (generic-null-car-cdr! seq) 1) seq)
    667     ((exn) (error 'generic-car "bad argument type" seq))))
    668 (define (generic-cdr seq)
    669   (condition-case
    670     ((vector-ref (generic-null-car-cdr! seq) 2) seq)
    671     ((exn) (error 'generic-cdr "bad argument type" seq))))
    672 (define (generic-pair? x)
     583We start with a helper, which does the search, a variant of assoc, which
     584might be of interest in other contexts as well.
     585]|#
     586
     587(define (assp ok? tbl)
     588  (let loop ((tbl tbl))
     589    (cond
     590      ((null? tbl) #f)
     591      ((ok? (caar tbl)) (car tbl))
     592      (else (loop (cdr tbl))))))
     593
     594#|[
     595The following two macros help to avoid repetition of code.
     596]|#
     597
     598(define-syntax search-and-call
     599  (syntax-rules ()
     600    ((_ tbl)
     601     (lambda (lst)
     602       (let ((pair (assp (lambda (x) (x lst))
     603                         tbl))) ; choose method
     604         (if pair
     605           ((cdr pair) lst) ; apply it
     606           (error 'search-and-call "type error" lst)))))))
     607
     608(define-syntax add-to-table
     609  (syntax-rules ()
     610    ((_ tbl)
     611     (lambda (pair)
     612       (set! tbl (append tbl (list pair)))))))
     613
     614#|[
     615
     616Generic functions are in fact closures, which search a table for a
     617matching operation and apply that operation in case of a match.
     618To be able to add new operations to that table, we must get a handle on
     619it. In other words, there must be other routines which operate on the
     620same table. define-values will come to the rescue ...
     621]|#
     622
     623(define-values (gnull? gnull?-table gnull?-table!)
     624  (let ((table
     625          (list
     626            (cons list? null?)
     627            (cons pair? (lambda (seq) #f))
     628            (cons vector?  (lambda (seq) (zero? (vector-length seq))))
     629            (cons string? (lambda (seq) (zero? (string-length seq))))
     630            )))
     631    (values
     632      (search-and-call table)
     633      (lambda () table) ; for debugging purposes
     634      (add-to-table table))))
     635
     636(define-values (gcar gcar-table gcar-table!)
     637  (let ((table
     638          (list
     639            (cons list? car)
     640            (cons pair? car)
     641            (cons vector?  (lambda (seq) (vector-ref seq 0)))
     642            (cons string? (lambda (seq) (string-ref seq 0)))
     643            )))
     644    (values
     645      (search-and-call table)
     646      (lambda () table) ; for debugging purposes
     647      (add-to-table table))))
     648      ;  (set! table (append table (list pair)))))))
     649
     650(define-values (gcdr gcdr-table gcdr-table!)
     651  (let ((table
     652          (list
     653            (cons list? cdr)
     654            (cons pair? cdr)
     655            (cons vector?
     656                  (lambda (seq)
     657                    ; (subvector seq 1))) ; buggy implemetation
     658                    (let ((len (vector-length seq)))
     659                      (if (zero? (vector-length seq))
     660                        (error 'subvector "out of range")
     661                        (let* ((new-len (- len 1))
     662                               (result (make-vector new-len #f)))
     663                          (do ((k 0 (+ k 1)))
     664                            ((= k new-len) result)
     665                            (vector-set! result k
     666                                         (vector-ref seq (+ k 1)))))))))
     667            (cons string? (lambda (seq) (substring seq 1)))
     668            )))
     669    (values
     670      (search-and-call table)
     671      (lambda () table) ; for debugging purposes
     672      (add-to-table table))))
     673
     674(define (gpair? x)
    673675  (let ((result (gensym 'result)))
    674676    (if (memq result
    675677              (list
    676                 (condition-case (generic-car x)
     678                (condition-case (gcar x)
    677679                  ((exn) result))
    678                 (condition-case (generic-cdr x)
     680                (condition-case (gcdr x)
    679681                  ((exn) result))))
    680682      #f
    681683      #t)))
     684
     685#|[
     686All of the generic functions above need not be exported. We will only
     687export the following routine, which updates the three tables in one go.
     688This way it's impossible to forget updating one of the three tables.
     689]|#
     690
     691;;; (generic-null-car-cdr! type? type-null? type-car type-cdr)
     692;;; ----------------------------------------------------------
     693;;; updates the tables with tree functions in this order and index it
     694;;; with the type predicate type?.
     695(define (generic-null-car-cdr! type? type-null? type-car type-cdr)
     696  (gnull?-table! (cons type? type-null?))
     697  (gcar-table! (cons type? type-car))
     698  (gcdr-table! (cons type? type-cdr)))
    682699
    683700(define bindings
     
    686703      (bind
    687704        "a variant of Common Lisp's destructuring-bind macro"
    688         (bind pat seq (where . fenders) .. xpr . xprs)
    689 "Destructures the sequence expression seq according to the pattern pat, checking the optional fenders, binds pattern variables of pat to corresponding subexpressions of seq and executes xpr . xprs in this context")
     705        (bind pat seq (where . fenders) .. xpr . xprs))
    690706      (bind-set!
    691707        "sets multiple variables by destructuring its sequence argument"
    692         (bind-set! pat seq)
    693     "destructures seq according to pat and sets pattern variables with values corresponding to subexpressions of seq")
     708        (bind-set! pat seq))
    694709      (bind-define
    695710        "defines multiple variables by destructuring its sequence argument"
    696         (bind-define pat seq)
    697     "destructures seq according to pat and defines pattern variables with values corresponding to subexpressions of seq")
     711        (bind-define pat seq))
    698712      (bindable?
    699713        "returns a unary predicate, which checks if its sequence argument matches the pattern argument of bindable? and passes all optional fenders"
    700         (bindable? pat . fenders) ..)
     714        (bindable? pat . fenders))
    701715      (bind-case
    702716        "a variant of matchable's match macro."
    703         (bind-case seq (pat (where . fenders) .. xpr . xprs) ....)
    704 "Checks if seq matches patterns pat checking fenders in sequence, binds the pattern variables of the first matching pattern to corresponding subexpressions of seq and executes corresponding body in this context")
     717        (bind-case seq (pat (where . fenders) .. xpr . xprs) ....))
    705718      (bind-lambda
    706719        "combination of lambda and bind, one pattern argument"
     
    711724      (bind-case-lambda
    712725        "combination of lambda and bind-case with one pattern argument"
    713         (bind-case-lambda clause ....)
    714 "where each clause is either of the form (pat xpr . xprs) or (pat (where . fenders) xpr . xprs) where fenders can be used to reject an otherwise matching pattern")
     726        (bind-case-lambda (pat (where . fenders) .. xpr . xprs) ....))
    715727      (bind-case-lambda*
    716728        "combination of lambda and bind-case with multiple pattern arguments"
    717         (bind-case-lambda* clause ....)
    718 "where each clause is either of the form (pat xpr . xprs) or (pat (where . fenders) xpr . xprs) where fenders can be used to reject an otherwise matching pattern")
     729        (bind-case-lambda* (pat (where . fenders) .. xpr . xprs) ....))
    719730      (bind*
    720731        "named version of bind"
    721         (bind* loop pat seq xpr . xprs)
    722 "where loop evaluates to a one-parameter procedure to be used in xpr . xprs")
     732        (bind* loop pat seq xpr . xprs))
    723733      (bind-let
    724734        "nested version of let, named and unnamed"
    725         (bind-let loop .. ((pat seq) ...) xpr . xprs)
    726 "binds pattern variables of pat ... to matching positions of seq ...  in parallel and executes xpr . xprs in this context. If loop is provided, it evaluates to a one-parameter procedure available in the body xpr . xprs")
     735        (bind-let loop .. ((pat seq) ...) xpr . xprs))
    727736      (bind-let*
    728         "sequential version of let"
    729         (bind-let ((pat seq) ...) xpr . xprs)
    730 "binds pattern variables of pat ... to matching positions of seq ...  sequentially and executes xpr . xprs in this context")
     737        "nested version of let*"
     738        (bind-let ((pat seq) ...) xpr . xprs))
    731739      (bind-letrec
    732740        "recursive version of bind-let"
    733         (bind-letrec ((pat seq) ...) xpr . xprs)
    734 "binds pattern variables of pat ... to matching positions of seq ...  recursively and executes xpr . xprs in this context")
     741        (bind-letrec ((pat seq) ...) xpr . xprs))
    735742      (bindrec
    736743        "recursive version of bind"
    737         (bindrec pat seq . body)
    738 "like bind, but seq can contain references to pattern variables in pat")
     744        (bindrec pat seq . body))
    739745      (generic-null-car-cdr!
    740746        "command updating the table of the following generic functions"
    741         (generic-null-car-cdr! type-predicate null-proc car-proc cdr-proc))))
     747        (generic-null-car-cdr! type? type-null? type-car type-cdr))))
    742748      )
    743749      (case-lambda
     
    750756
    751757) ; module bindings
     758
  • release/4/bindings/trunk/bindings.setup

    r30172 r30177  
    77 'bindings
    88 '("bindings.so" "bindings.import.so")
    9  '((version "2.3.4")))
     9 '((version "2.4")))
    1010
  • release/4/bindings/trunk/tests/run.scm

    r30172 r30177  
    33;;;; ju (at) jugilo (dot) de
    44
    5 (require-library bindings lolevel tuples simple-tests)
     5(require-library bindings tuples simple-tests)
    66
    77(import bindings
    88        (only tuples tuple tuple? tuple-empty? tuple-left tuple-butleft)
    9         (only lolevel record-instance? record->vector)
    109        (only chicken error)
    1110        simple-tests)
     
    298297  (define-test (sequences?)
    299298    (check
    300       (generic-null-car-cdr! record-instance?
    301                              (lambda (seq)
    302                                (= 1 (vector-length (record->vector seq))))
    303                              (lambda (seq)
    304                                (vector-ref (record->vector seq) 1))
    305                              (lambda (seq)
    306                                (let* ((vec (record->vector seq))
    307                                       (len (vector-length vec)))
    308                                  (if (< len 2)
    309                                    (error 'subrecord "range error")
    310                                    (let* ((new-len (- len 2))
    311                                           (result (make-vector new-len #f)))
    312                                      (do ((k 0 (+ k 1)))
    313                                        ((= k new-len) result)
    314                                        (vector-set! result k
    315                                                     (vector-ref vec (+ k 2)))))))))
    316299      (generic-null-car-cdr! tuple? tuple-empty? tuple-left tuple-butleft)
    317300      (define-record point x y)
    318       (equal? (bind (x y) (make-point 1 2) (list x y)) '(1 2))
    319       (equal? (bind (x (y z)) (vector 1 (make-point 2 3)) (list x y z))
    320               '(1 2 3))
    321       (equal? (bind (x . y) (make-point 1 2) (list x y)) '(1 #(2)))
    322301      (equal? (bind (x y z) (tuple 1 2 3) (list x y z)) '(1 2 3))
    323302      (equal? (bind (x (y z)) (vector 0 (tuple 1 2)) (list x y z)) '(0 1 2))
     303      (equal? (bind (x (y (z))) (vector 0 (tuple 1 "2")) (list x y z))
     304              '(0 1 #\2))
    324305      ))
    325306  (sequences?)
Note: See TracChangeset for help on using the changeset viewer.