Changeset 29277 in project


Ignore:
Timestamp:
06/28/13 20:46:17 (8 years ago)
Author:
juergen
Message:

records added in generics, bind/cc added for completeness

Location:
release/4/bindings/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/bindings/trunk/bindings.meta

    r28089 r29277  
    44 (category lang-exts)
    55 (license "BSD")
     6 (test-depends tuples simple-tests)
    67 (author "Juergen Lorenz")
    78 (files "bindings.setup" "bindings.release-info" "bindings.meta" "bindings.scm" "tests/run.scm"))
  • release/4/bindings/trunk/bindings.scm

    r28089 r29277  
    3232; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3333;
    34 ; Last update: Jan 12, 2013
     34; Last update: Jun 28, 2013
    3535;
    3636;Binding pattern variables to subsequences
     
    7474;sort of overkill.
    7575;
    76 ;We'll use three generic functions instead, generic-car, generic-cdr and
    77 ;generic-null? which are able to handle not only lists, but vectors and
    78 ;strings as well. So our binding macros work on arbitrary mixtures of
    79 ;(pseudo-) lists, strings and vectors as given. But since they operate
    80 ;by searching a local table, we can add other type-operator-pairs to
    81 ;these tables, thus enhancing the binding operators to other sequence
    82 ;types, say tuples, lazy-lists or what have you, without touching the
    83 ;macros itself!
     76;Internally, we'll use three generic functions instead, generic-car,
     77;generic-cdr and generic-null? which are able to handle not only lists,
     78;but vectors and strings as well. So our binding macros work on
     79;arbitrary mixtures of (pseudo-) lists, strings and vectors as given.
     80;But since they operate by searching a local table, we can add other
     81;type-operator-pairs to these tables, thus enhancing the binding
     82;operators to other sequence types, say tuples, lazy-lists or what have
     83;you, without touching the macros itself! To be more precise, we need to
     84;export only one function, generic-null-car-cdr!, which maintains the
     85;table for the other three generics, and which can be used by clients to
     86;add other relevant operator triples.
    8487;
    8588;I've added one additional twist. The bodies of bind and some other
     
    9396;times" or "one or many times" respectively.
    9497;
     98
     99(require-library lolevel)
     100
    95101(module bindings
    96     (bindings bind
    97               bind? bind-case ;bind-matches?
     102    (bindings (bind generic-car generic-cdr generic-null?)
     103              bind? bind-case bind/cc ;bind-matches?
    98104              bind-let bind-let* bind-letrec
    99105              bindrec bind-lambda bind-lambda* bind* bind-set!
    100106              bind-define bind-case-lambda bind-case-lambda*
    101               ;; the generics must be exported for bind to be extensible
    102               generic-car generic-cdr generic-null?
     107              ;; the generics updater must be exported for bind to be extensible
    103108              generic-null-car-cdr!)
    104109
    105110(import scheme
    106111        (only data-structures list-of?)
    107         (only extras sprintf)
     112        (only extras format)
     113        (only lolevel record-instance? record->vector)
     114              ;extend-procedure procedure-data)
    108115        (only chicken condition-case case-lambda
    109116              print error gensym fx- fx+ fx=))
     
    175182                       ((lambda ,vars ,@body) ,@vars)
    176183                      (error 'bind
    177                               (sprintf
     184                              (format #f
    178185                               "expression ~a doesn't match pattern ~a where ~a~%"
    179186                               ,seq ',pat ',fender))))))))
     
    591598       ...))))
    592599
     600;;; (bind/cc k xpr . xprs)
     601;;; ----------------------
     602(define-syntax bind/cc
     603  (syntax-rules ()
     604    ((_ k xpr . xprs)
     605     (call-with-current-continuation
     606       (lambda (k) xpr . xprs)))))
     607
    593608;Now to the generic functions
    594609;
     
    610625    (table
    611626      (list
    612         (cons pair? (vector (lambda (seq) #f) car cdr))
    613         (cons list? (vector null? car cdr))
    614         (cons vector?
     627        (cons ;(extend-procedure list? 'list?)
     628              list?
     629              (vector null? car cdr))
     630        (cons ;(extend-procedure pair? 'pair?)
     631              pair?
     632              (vector (lambda () #f) car cdr))
     633        (cons ;(extend-procedure vector? 'vector?)
     634              vector?
    615635              (vector
    616636                (lambda (seq) (zero? (vector-length seq)))
    617637                (lambda (seq) (vector-ref seq 0))
    618638                (lambda (seq) (vector-tail seq 1))))
    619         (cons string?
     639        (cons ;(extend-procedure string? 'string?)
     640              string?
    620641              (vector
    621642                (lambda (seq) (zero? (string-length seq)))
    622643                (lambda (seq) (string-ref seq 0))
    623                 (lambda (seq) (substring seq 1))))))
     644                (lambda (seq) (substring seq 1))))
     645        (cons ;(extend-procedure record-instance? 'record-instance?)
     646              record-instance?
     647              (vector
     648                (lambda (seq) (= 1 (vector-length (record->vector seq))))
     649                (lambda (seq) (vector-ref (record->vector seq) 1))
     650                (lambda (seq)
     651                  (vector-tail (record->vector seq) 2))))))
     652                  ;(let ((lst (vector->list (record->vector seq))))
     653                  ;  (cons (car lst) (cddr lst))))))))
    624654    )
    625655    (lambda args
     
    635665        ((= (length args) 1)
    636666         (let loop ((tbl table))
    637           (cond
    638             ((null? tbl)
    639              (error 'generic-null-car-cdr!
    640                     "not in type list"
    641                     (map car table)))
    642             (((caar tbl) (car args))
    643              (cdar tbl))
    644             (else
    645               (loop (cdr tbl))))))
     667           (cond
     668             ((null? tbl)
     669              (error 'generic-null-car-cdr!
     670                     (format #f
     671                             "not in type list ~s: ~s"
     672                             ;(map procedure-data (map car table))
     673                             (map car table)
     674                             (car args))))
     675             (((caar tbl) (car args))
     676              (cdar tbl))
     677             (else
     678               (loop (cdr tbl))))))
    646679        (else
    647680          (error 'generic-null-car-cdr!
     
    727760        "recursive version of bind"
    728761        (bindrec pat seq . body)
     762      (bind/cc
     763        "package call/cc in a binding construct"
     764        (bind/cc k xpr . xprs)
     765        "captures current continuation as a unary escape procedure and
     766        evalute xpr . xprs in this context, possibly calling k")
    729767"like bind, but seq can contain references to pattern variables in pat")
    730768      (generic-null-car-cdr!
    731769        "command updating the table of the following generic functions"
    732         (generic-null-car-cdr! type-predicate null-proc car-proc cdr-proc))
    733       (generic-null?
    734         "null? for seqquence types"
    735         (generic-null? seq))
    736       (generic-car
    737         "car for seqquence types"
    738         (generic-car seq))
    739       (generic-cdr
    740         "cdr for seqquence types"
    741         (generic-cdr seq))
    742       )))
    743     (case-lambda
    744       (() (map car alist))
    745       ((sym)
    746        (let ((pair (assq sym alist)))
    747          (if pair
    748            (cdr pair)
    749            (print "Choose one of " (map car alist))))))))
     770        (generic-null-car-cdr! type-predicate null-proc car-proc cdr-proc))))
     771      )
     772      (case-lambda
     773        (() (map car alist))
     774        ((sym)
     775         (let ((pair (assq sym alist)))
     776           (if pair
     777             (cdr pair)
     778             (print "Choose one of " (map car alist))))))))
    750779
    751780) ; module bindings
  • release/4/bindings/trunk/bindings.setup

    r28089 r29277  
    77 'bindings
    88 '("bindings.so" "bindings.import.so")
    9  '((version "2.0")))
     9 '((version "2.1")))
    1010
  • release/4/bindings/trunk/tests/run.scm

    r28089 r29277  
    66;;;;       Sep 01, 2011
    77;;;;       Jan 08, 2013
    8 
    9 (require-library bindings)
    10 
    11 (import bindings)
    12 
    13 ;;; (run xpr0 xpr1 ...)
    14 ;;; -------------------
    15 (define (run . xprs)
    16   (let loop ((xprs xprs))
    17     (if (null? xprs)
    18       (print "All tests passed!")
    19       (if (car xprs)
    20         (loop (cdr xprs))
    21         (error 'run "#### Some test failed! ####")))))
    22 
    23 (run
     8;;;;       Jun 28, 2013
     9
     10(require-library bindings tuples simple-tests)
     11
     12(import bindings tuples simple-tests)
     13
     14(run-tests
    2415  (equal?
    2516    (let ((stack #f) (push! #f) (pop! #f))
     
    270261     '(1 #(20 30 40) 2 3) '(4 5 6))
    271262    '(1 20 #(30 40) (2 3) 4 (5 6)))
     263  "BINDING RECORDS"
     264  (define-record point x y)
     265  (equal? (bind (x y) (make-point 1 2) (list x y)) '(1 2))
     266  (equal? (bind (x (y z)) (vector 1 (make-point 2 3)) (list x y z))
     267          '(1 2 3))
     268  (equal? (bind (x . y) (make-point 1 2) (list x y)) '(1 #(2)))
     269  "ADDING NEW TYPES TO GENERICS"
     270  (generic-null-car-cdr! tuple? tuple-empty? tuple-left tuple-butleft)
     271  (equal? (bind (x y z) (tuple 1 2 3) (list x y z)) '(1 2 3))
     272  (equal? (bind (x (y z)) (vector 0 (tuple 1 2)) (list x y z)) '(0 1 2))
     273
    272274  )
    273275
    274 ;(use tuples)
    275 ;(generic-null-car-cdr! tuple? empty? tuple-left (lambda (tup)
    276 ;                                                  (tuple-copy tup 1)))
    277 ;(generic-cdr (cons tuple? (lambda (tup) (tuple-copy tup 1))))
    278 ;(define tup (tuple 0 1 2 3))
    279 ;(print (bind (x . y) tup (list x y)))
    280 ;(print (bind (x (y . z)) (vector 1 tup) (list x y z)))
     276;(xpr:val
     277;  (bind (x . y) (tuple 1 2 3) (list x y))
     278;  (bind (x (y . z)) (vector 0 (tuple 1 2 3)) (list x y z)))
     279;
     280;(require-library lazy-lists)
     281;(import %lazy-lists)
     282;(generic-null-car-cdr! List-finite? Null? Car (o Realize Cdr))
     283;
     284;(xpr:val
     285;  (bind (x . y) (List 1 2 3) (list x y))
     286;  (bind (x (y . z)) (vector 0 (List 1 2 3)) (list x y z))
     287;  )
     288
Note: See TracChangeset for help on using the changeset viewer.