Changeset 29774 in project for release/4/list-bindings


Ignore:
Timestamp:
09/22/13 14:37:26 (7 years ago)
Author:
juergen
Message:

helper module removed, bind reimplemented

Location:
release/4/list-bindings
Files:
4 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/list-bindings/tags/1.5.1/list-bindings.scm

    r29769 r29774  
    3838]|#
    3939
    40 (module list-binding-helpers
    41   (export list-binding-helpers pattern? tree-ref pindex pmap pflatten quote-last)
    42   (import scheme (only chicken error))
    43 
    44 ;;; (list-ref* lst . ks)
    45 ;;; --------------------
    46 ;;; references elements of possibly deeply nested lists
    47 ;;; (for comparison purpose only)
    48 (define (list-ref* lst . ks)
    49   (cond
    50     ((null? ks) lst)
    51     ((null? (cdr ks)) (list-ref lst (car ks)))
    52     (else (apply list-ref* (list-ref lst (car ks)) (cdr ks)))))
    53 
    54 ;;; (tree-ref k ...) or (tree-ref k ... '(l))
    55 ;;; -----------------    ----------------------
    56 ;;; (the latter for handling the rest parameter in nested pseudolists)
    57 ;;; references elements of possibly deeply nested pseudolists.
    58 (define (tree-ref lst . ks) ; ok
    59   (cond
    60     ((null? ks) lst)
    61     ((null? (cdr ks)) ; flat pseudolist
    62      (let ((ks (car ks)))
    63        (if (pair? lst)
    64          (if (integer? ks)
    65            (if (zero? ks)
    66              (car lst)
    67              (tree-ref (cdr lst) (- ks 1)))
    68            ;; pair
    69            (if (zero? (car ks))
    70              lst
    71              (tree-ref (cdr lst) (list (- (car ks) 1)))))
    72          (if (and (pair? ks) (zero? (car ks)))
    73            lst
    74            (error 'tree-ref "match error")))))
    75     (else
    76      (apply tree-ref (tree-ref lst (car ks)) (cdr ks)))))
    77 
    78 ;;; (quote-last lst)
    79 ;;; ----------------
    80 ;;; quotes the last item of an index list in case it is itself a list.
    81 ;;; For example, (0 1 2) is untouched, but (0 1 (2)) is transformed to
    82 ;;; (0 1 '(2))
    83 (define (quote-last lst)
    84   (let loop ((lst lst) (result '()))
    85     (if (null? (cdr lst))
    86       (reverse (cons (if (list? (car lst)) `',(car lst) (car lst)) result))
    87       (loop (cdr lst) (cons (car lst) result)))))
    88 
    89 ;;; (pattern? xpr)
    90 ;;; --------------
    91 ;;; checks, if xpr is a pattern, i.e. a nested lambda-list
    92 (define (pattern? xpr)
    93   (or (symbol? xpr)
    94       (null? xpr)
    95       (and (pair? xpr)
    96            (not (null? (car xpr)))
    97            (pattern? (car xpr))
    98            (pattern? (cdr xpr)))))
    99 
    100 ;;; (pmap fn pat)
    101 ;;; -------------
    102 ;;; maps the pattern variables, i.e. the symbols, of a pattern with
    103 ;;; function fn to a nested list with the same structure as pat
    104 (define (pmap fn pat)
    105   (cond
    106     ((null? pat) '())
    107     ((symbol? pat) (fn pat))
    108     ((pair? pat)
    109      (cons (pmap fn (car pat)) (pmap fn (cdr pat))))))
    110 
    111 ;;; (pflatten pat)
    112 ;;; --------------
    113 ;;; maps a pattern, pat, to a flat list of symbols
    114 (define (pflatten pat)
    115   (cond
    116     ((null? pat) '())
    117     ((symbol? pat) (list pat))
    118     (else
    119       (append (pflatten (car pat))
    120               (pflatten (cdr pat))))))
    121 
    122 ;;; (pindex pat)
    123 ;;; ------------
    124 ;;; indexes the pattern variables of a pattern, pat, so that tree-ref
    125 ;;; can destructure a nested pseudolist by means of the generated
    126 ;;; indices.
    127 ;;; The index of each non-null leaf item is packaged in a singleton
    128 ;;; list. For example, (pindex '(a (b c)) produces the list ((0) (1 0)
    129 ;;; (1 1)) while (pindex '(a (b . c)) produces ((0) (1 0) (1 (1)))
    130 (define (pindex pat)
    131   (let recur ((k 0) (pat pat))
    132     (cond
    133       ((null? pat) '())
    134       ((symbol? pat) (list (list (list k))))
    135       ((symbol? (car pat))
    136        (cons (list k) (recur (+ k 1) (cdr pat))))
    137       ((pair? (car pat))
    138        (append (map (lambda (x) (cons k x)) (recur 0 (car pat)))
    139                (recur (+ k 1) (cdr pat)))))))
    140 
    141 (define (list-binding-helpers)
    142   '(pattern? pindex pmap pflatten tree-ref))
    143 
    144 ) ; list-binding-helpers
    145 
    14640(module list-bindings
    14741  (export list-bindings bind-define bind-set! bind bindable? bind-case
    14842          bind/cc bind-let bind-let* define-syntax-rule define-macro
    149           let-macro letrec-macro tree-ref)
     43          let-macro letrec-macro)
    15044  (import scheme
    15145          (only chicken condition-case error)
    152           (only extras format)
    153           (only list-binding-helpers tree-ref))
    154   (import-for-syntax (only list-binding-helpers pattern? pindex
    155                            tree-ref pmap pflatten quote-last))
     46          (only extras format))
    15647
    15748#|[
    15849Binding macros
    15950==============
    160 
    161 The old version of bind
    162 ;;; (bind pat tpl . body)
    163 ;;; --------------------------
    164 ;;; Common Lisp's destructuring bind
    165 ;;; binds pattern variables of pat to corresponding subexpression of
    166 ;;; tpl and evalueates body in this context
    167 ;;; (This is the old version)
    168 (define-syntax bind
    169   (ir-macro-transformer
    170     (lambda (form inject compare?)
    171       (if (< (length form) 4)
    172         (error 'bind "macro-code doesn't match pattern "
    173                '(_ pat lst xpr . xprs))
    174         (let ((pat (cadr form))
    175               (xpr (caddr form))
    176               (body (cdddr form)))
    177           (letrec (
    178             (pmap (lambda (pl)
    179                     (cond
    180                       ((pair? pl)
    181                        (cons (if (symbol? (car pl)) (car pl) (gensym)) (pmap (cdr pl))))
    182                       ((null? pl) pl)
    183                       ((symbol? pl) pl)
    184                       )))
    185             (listify (lambda (pl)
    186                        (cond
    187                          ((pair? pl)
    188                           (cons (car pl) (listify (cdr pl))))
    189                          ((null? pl) pl)
    190                          ((symbol? pl) (list pl)))))
    191             (flat? (lambda (pl)
    192                      (or (symbol? pl)
    193                          (null? pl)
    194                          (and (symbol? (car pl)) (flat? (cdr pl))))))
    195             (nested-lambda-list? (lambda (xpr)
    196                                    (or (symbol? xpr)
    197                                        (null? xpr)
    198                                        (and (pair? xpr)
    199                                             (nested-lambda-list? (car xpr))
    200                                             (nested-lambda-list? (cdr xpr))))))
    201             )
    202             (if (not (nested-lambda-list? pat))
    203               (error 'bind "not a nested lambda-list" pat)
    204               (if (flat? pat)
    205                 (cond
    206                   ((pair? pat)
    207                    `(apply (lambda ,pat ,@body) ,xpr))
    208                   ((null? pat)
    209                    `(apply (lambda ,pat ,@body) ,xpr))
    210                   ((symbol? pat)
    211                    `((lambda (,pat) ,@body) ,xpr)))
    212                 (let ((new-pat (pmap pat)))
    213                   (let ((lst `(bind ,new-pat ,xpr
    214                                 (list ,@(listify new-pat)))))
    215                      `(bind ,(car pat) (car ,lst)
    216                        (bind ,(listify (cdr pat)) (cdr ,lst)
    217                          ,@body))))))))))))
    21851]|#
    21952
     
    22457(define-syntax bindable?
    22558  (syntax-rules ()
    226     ((_ ())
    227      (lambda (tpl) (null? tpl)))
    22859    ((_ (a . b))
    22960     (lambda (tpl)
     
    23162            ((bindable? a) (car tpl))
    23263            ((bindable? b) (cdr tpl)))))
     64    ((_ ())
     65     (lambda (tpl) (null? tpl)))
    23366    ((_ a) (lambda (tpl) #t))))
    23467
    235 
    23668#|[
    237 Note that in the three following macros the pattern argument is
    238 processed at compile time while the template argument is processed at
    239 runtime.
    240 Note also, that the terminal position argument of tree-ref in the
    241 template must be quoted, in case it is a singleton list. This is done by
    242 quote-last
     69The following is a Scheme version of Common Lisp's destructuring bind.
     70Note, that the call to bindable? is strictly speaking not necessary, but
     71it provides a meaningful error message. It causes to traverse pair
     72patterns twice. But that is unimportant because it happens at compile
     73time.
    24374]|#
    24475
    24576;;; (bind pat tpl . body)
    24677;;; --------------------------
    247 ;;; Common Lisp's destructuring bind
    24878;;; binds pattern variables of pat to corresponding subexpression of
    24979;;; tpl and evalueates body in this context
    25080(define-syntax bind
    251   (ir-macro-transformer
    252     (lambda (form inject compare?)
    253       (let ((pat (cadr form))
    254             (tpl (caddr form))
    255             (xpr (cadddr form))
    256             (xprs (cddddr form)))
    257         `(if ((bindable? ,pat) ,tpl)
    258           (let
    259              ,(map (lambda (ks)
    260                      `(,(apply tree-ref pat ks)
    261                         (tree-ref ,tpl ,@(quote-last ks))))
    262                    (pindex pat))
    263              ,xpr ,@xprs)
    264           (error 'bind
    265                  (format #f "template ~s doesn't match pattern ~s"
    266                          ,tpl ',pat)))))))
     81  (syntax-rules ()
     82    ((_(a . b) tpl xpr . xprs)
     83     (if ((bindable? (a . b)) tpl)
     84       (bind a (car tpl) (bind b (cdr tpl) xpr . xprs))
     85       (error 'bind (format #f "template ~s doesn't match pattern ~s"
     86                            tpl '(a . b)))))
     87    ((_ () tpl xpr . xprs)
     88     (if (null? tpl)
     89       (let () xpr . xprs)
     90       (error 'bind "not null" tpl)))
     91    ((_ a tpl xpr . xprs)
     92     (let ((a tpl)) xpr . xprs))))
     93;(define-syntax bind
     94;  (ir-macro-transformer
     95;    (lambda (form inject compare?)
     96;      (let ((pat (cadr form))
     97;            (tpl (caddr form))
     98;            (xpr (cadddr form))
     99;            (xprs (cddddr form)))
     100;        `(if ((bindable? ,pat) ,tpl)
     101;          (let
     102;             ,(map (lambda (ks)
     103;                     `(,(apply tree-ref pat ks)
     104;                        (tree-ref ,tpl ,@(quote-last ks))))
     105;                   (pindex pat))
     106;             ,xpr ,@xprs)
     107;          (error 'bind
     108;                 (format #f "template ~s doesn't match pattern ~s"
     109;                         ,tpl ',pat)))))))
    267110;(define-syntax bind
    268111;  (er-macro-transformer
     
    308151
    309152#|[
    310 old versions:
    311 ;;; (bind-define pat tpl)
    312 ;;; ---------------------
    313 ;;; defines pattern variables of the pattern pat by setting them to
    314 ;;; corresponding subexpressions of the template tpl
    315 (define-syntax bind-define
    316   (ir-macro-transformer
    317     (lambda (form inject compare)
    318       (let ((pat (cadr form)) (tpl (caddr form)))
    319         (let ((aux (pmap (lambda (x) (gensym)) pat)))
    320           `(if ((bindable? ,pat) ,tpl)
    321              (bind ,aux ,tpl
    322                (begin
    323                  ,@(map (lambda (ks)
    324                           `(define
    325                              ,(apply tree-ref pat ks)
    326                              (tree-ref ,(cons 'list aux) ,@(quote-last ks))))
    327                         (pindex pat))))
    328              (error 'bind-define (format #f "template ~s doesn't match pattern ~s"
    329                                          ,tpl ',pat))))))))
    330 
    331 ;;; (bind-set! pat tpl)
    332 ;;; ---------------------
    333 ;;; sets pattern variables of the pattern pat to corresponding
    334 ;;; subexpressions of the template tpl
    335 (define-syntax bind-set!
    336   (ir-macro-transformer
    337     (lambda (form inject compare)
    338       (let ((pat (cadr form)) (tpl (caddr form)))
    339         `(if ((bindable? ,pat) ,tpl)
    340            (begin
    341              ,@(map (lambda (ks)
    342                       `(set!
    343                          ,(apply tree-ref pat ks)
    344                          (tree-ref ,tpl ,@(quote-last ks))))
    345                     (pindex pat)))
    346            (error 'bind-set! (format #f "template ~s doesn't match pattern ~s" ,tpl ',pat)))))))
    347 
    348 These versions would perfectly work, if tpl is simply a list, but not if
    349 it is a list wrapped by a let storing common state. But the latter is
    350 the most often used case of bind-define. The same applies to the
    351 following version:
     153The next two macros provide simultaneous setting and defining of pattern
     154variables to subexpressions of a template. The following first try would
     155perfectly work, if tpl is simply a list, but not if it is a list wrapped
     156by a let storing common state. But the latter is the most often used
     157case of bind-define.
    352158
    353159(define-syntax bind-define
     
    371177We could have used implicit-renaming macros as well, but then the
    372178gensyms would be automatically renamed again, which isn't necessary.
     179Note, that there is some code duplication in the two macros below, which
     180could have been avoided by defining two helpers, pmap and pflatten, in a
     181separate helper module which must be imported for syntax. I've done this
     182in a former version.
    373183]|#
    374184
     
    381191    (lambda (form rename compare?)
    382192      (let ((pat (cadr form)) (tpl (caddr form)))
    383         (let ((aux (pmap gensym pat))
     193        (let ((aux (let recur ((pat pat))
     194                     (cond
     195                       ((null? pat) '())
     196                       ((symbol? pat) (gensym))
     197                       ((pair? pat)
     198                        (cons (recur (car pat)) (recur (cdr pat)))))))
    384199              ; rename would potentially clash with the %x below
    385200              (%bind (rename 'bind))
     
    389204          `(,%let ((,%x ,tpl))
    390205             (,%bind ,aux ,%x
    391                ,@(map (lambda (p a) `(,%set! ,p ,a))
    392                       (pflatten pat) (pflatten aux)))))))))
     206               ,@(let recur ((pat pat) (aux aux))
     207                   (cond
     208                     ((null? pat) '())
     209                     ((symbol? pat) `((set! ,pat ,aux)))
     210                     ((pair? pat)
     211                      (append (recur (car pat) (car aux))
     212                              (recur (cdr pat) (cdr aux)))))))))))))
    393213;(define-syntax bind-set!
    394214;  (ir-macro-transformer
     
    409229    (lambda (form rename compare?)
    410230      (let ((pat (cadr form)) (tpl (caddr form)))
    411         (let ((aux (pmap gensym pat))
     231        (let ((aux (let recur ((pat pat))
     232                     (cond
     233                       ((null? pat) '())
     234                       ((symbol? pat) (gensym))
     235                       ((pair? pat)
     236                        (cons (recur (car pat)) (recur (cdr pat)))))))
    412237              (%bind-set! (rename 'bind-set!))
    413238              (%define (rename 'define))
     
    415240          `(,%begin
    416241             (,%bind-set! ,aux ,tpl)
    417              ,@(map (lambda (p a) `(,%define ,p ,a))
    418                     (pflatten pat) (pflatten aux))))))))
     242             ,@(let recur ((pat pat) (aux aux))
     243                 (cond
     244                   ((null? pat) '())
     245                   ((symbol? pat) `((set! ,pat ,aux)))
     246                   ((pair? pat)
     247                    (append (recur (car pat) (car aux))
     248                            (recur (cdr pat) (cdr aux))))))))))))
    419249;(define-syntax bind-define
    420250;  (ir-macro-transformer
     
    704534(define (list-bindings)
    705535  '(bind-define bind-set! bind bind-let* bind-let bind-case bindable? bind/cc
    706     define-macro let-macro letrec-macro define-syntax-rule tree-ref
    707     pflatten))
     536    define-macro let-macro letrec-macro define-syntax-rule))
    708537
    709538) ; module list-bindings
  • release/4/list-bindings/tags/1.5.1/list-bindings.setup

    r29769 r29774  
    33(compile -O3 -s -d1 list-bindings.scm -J)
    44(compile -O3 -d0 -s list-bindings.import.scm)
    5 (compile -O3 -d0 -s list-binding-helpers.import.scm)
    65
    76(install-extension
    87 'list-bindings
    9  '("list-bindings.so" "list-bindings.import.so"
    10    "list-binding-helpers.import.so")
    11  '((version "1.5")))
     8 '("list-bindings.so" "list-bindings.import.so")
     9 '((version "1.5.1")))
    1210
  • release/4/list-bindings/trunk/list-bindings.scm

    r29769 r29774  
    3838]|#
    3939
    40 (module list-binding-helpers
    41   (export list-binding-helpers pattern? tree-ref pindex pmap pflatten quote-last)
    42   (import scheme (only chicken error))
    43 
    44 ;;; (list-ref* lst . ks)
    45 ;;; --------------------
    46 ;;; references elements of possibly deeply nested lists
    47 ;;; (for comparison purpose only)
    48 (define (list-ref* lst . ks)
    49   (cond
    50     ((null? ks) lst)
    51     ((null? (cdr ks)) (list-ref lst (car ks)))
    52     (else (apply list-ref* (list-ref lst (car ks)) (cdr ks)))))
    53 
    54 ;;; (tree-ref k ...) or (tree-ref k ... '(l))
    55 ;;; -----------------    ----------------------
    56 ;;; (the latter for handling the rest parameter in nested pseudolists)
    57 ;;; references elements of possibly deeply nested pseudolists.
    58 (define (tree-ref lst . ks) ; ok
    59   (cond
    60     ((null? ks) lst)
    61     ((null? (cdr ks)) ; flat pseudolist
    62      (let ((ks (car ks)))
    63        (if (pair? lst)
    64          (if (integer? ks)
    65            (if (zero? ks)
    66              (car lst)
    67              (tree-ref (cdr lst) (- ks 1)))
    68            ;; pair
    69            (if (zero? (car ks))
    70              lst
    71              (tree-ref (cdr lst) (list (- (car ks) 1)))))
    72          (if (and (pair? ks) (zero? (car ks)))
    73            lst
    74            (error 'tree-ref "match error")))))
    75     (else
    76      (apply tree-ref (tree-ref lst (car ks)) (cdr ks)))))
    77 
    78 ;;; (quote-last lst)
    79 ;;; ----------------
    80 ;;; quotes the last item of an index list in case it is itself a list.
    81 ;;; For example, (0 1 2) is untouched, but (0 1 (2)) is transformed to
    82 ;;; (0 1 '(2))
    83 (define (quote-last lst)
    84   (let loop ((lst lst) (result '()))
    85     (if (null? (cdr lst))
    86       (reverse (cons (if (list? (car lst)) `',(car lst) (car lst)) result))
    87       (loop (cdr lst) (cons (car lst) result)))))
    88 
    89 ;;; (pattern? xpr)
    90 ;;; --------------
    91 ;;; checks, if xpr is a pattern, i.e. a nested lambda-list
    92 (define (pattern? xpr)
    93   (or (symbol? xpr)
    94       (null? xpr)
    95       (and (pair? xpr)
    96            (not (null? (car xpr)))
    97            (pattern? (car xpr))
    98            (pattern? (cdr xpr)))))
    99 
    100 ;;; (pmap fn pat)
    101 ;;; -------------
    102 ;;; maps the pattern variables, i.e. the symbols, of a pattern with
    103 ;;; function fn to a nested list with the same structure as pat
    104 (define (pmap fn pat)
    105   (cond
    106     ((null? pat) '())
    107     ((symbol? pat) (fn pat))
    108     ((pair? pat)
    109      (cons (pmap fn (car pat)) (pmap fn (cdr pat))))))
    110 
    111 ;;; (pflatten pat)
    112 ;;; --------------
    113 ;;; maps a pattern, pat, to a flat list of symbols
    114 (define (pflatten pat)
    115   (cond
    116     ((null? pat) '())
    117     ((symbol? pat) (list pat))
    118     (else
    119       (append (pflatten (car pat))
    120               (pflatten (cdr pat))))))
    121 
    122 ;;; (pindex pat)
    123 ;;; ------------
    124 ;;; indexes the pattern variables of a pattern, pat, so that tree-ref
    125 ;;; can destructure a nested pseudolist by means of the generated
    126 ;;; indices.
    127 ;;; The index of each non-null leaf item is packaged in a singleton
    128 ;;; list. For example, (pindex '(a (b c)) produces the list ((0) (1 0)
    129 ;;; (1 1)) while (pindex '(a (b . c)) produces ((0) (1 0) (1 (1)))
    130 (define (pindex pat)
    131   (let recur ((k 0) (pat pat))
    132     (cond
    133       ((null? pat) '())
    134       ((symbol? pat) (list (list (list k))))
    135       ((symbol? (car pat))
    136        (cons (list k) (recur (+ k 1) (cdr pat))))
    137       ((pair? (car pat))
    138        (append (map (lambda (x) (cons k x)) (recur 0 (car pat)))
    139                (recur (+ k 1) (cdr pat)))))))
    140 
    141 (define (list-binding-helpers)
    142   '(pattern? pindex pmap pflatten tree-ref))
    143 
    144 ) ; list-binding-helpers
    145 
    14640(module list-bindings
    14741  (export list-bindings bind-define bind-set! bind bindable? bind-case
    14842          bind/cc bind-let bind-let* define-syntax-rule define-macro
    149           let-macro letrec-macro tree-ref)
     43          let-macro letrec-macro)
    15044  (import scheme
    15145          (only chicken condition-case error)
    152           (only extras format)
    153           (only list-binding-helpers tree-ref))
    154   (import-for-syntax (only list-binding-helpers pattern? pindex
    155                            tree-ref pmap pflatten quote-last))
     46          (only extras format))
    15647
    15748#|[
    15849Binding macros
    15950==============
    160 
    161 The old version of bind
    162 ;;; (bind pat tpl . body)
    163 ;;; --------------------------
    164 ;;; Common Lisp's destructuring bind
    165 ;;; binds pattern variables of pat to corresponding subexpression of
    166 ;;; tpl and evalueates body in this context
    167 ;;; (This is the old version)
    168 (define-syntax bind
    169   (ir-macro-transformer
    170     (lambda (form inject compare?)
    171       (if (< (length form) 4)
    172         (error 'bind "macro-code doesn't match pattern "
    173                '(_ pat lst xpr . xprs))
    174         (let ((pat (cadr form))
    175               (xpr (caddr form))
    176               (body (cdddr form)))
    177           (letrec (
    178             (pmap (lambda (pl)
    179                     (cond
    180                       ((pair? pl)
    181                        (cons (if (symbol? (car pl)) (car pl) (gensym)) (pmap (cdr pl))))
    182                       ((null? pl) pl)
    183                       ((symbol? pl) pl)
    184                       )))
    185             (listify (lambda (pl)
    186                        (cond
    187                          ((pair? pl)
    188                           (cons (car pl) (listify (cdr pl))))
    189                          ((null? pl) pl)
    190                          ((symbol? pl) (list pl)))))
    191             (flat? (lambda (pl)
    192                      (or (symbol? pl)
    193                          (null? pl)
    194                          (and (symbol? (car pl)) (flat? (cdr pl))))))
    195             (nested-lambda-list? (lambda (xpr)
    196                                    (or (symbol? xpr)
    197                                        (null? xpr)
    198                                        (and (pair? xpr)
    199                                             (nested-lambda-list? (car xpr))
    200                                             (nested-lambda-list? (cdr xpr))))))
    201             )
    202             (if (not (nested-lambda-list? pat))
    203               (error 'bind "not a nested lambda-list" pat)
    204               (if (flat? pat)
    205                 (cond
    206                   ((pair? pat)
    207                    `(apply (lambda ,pat ,@body) ,xpr))
    208                   ((null? pat)
    209                    `(apply (lambda ,pat ,@body) ,xpr))
    210                   ((symbol? pat)
    211                    `((lambda (,pat) ,@body) ,xpr)))
    212                 (let ((new-pat (pmap pat)))
    213                   (let ((lst `(bind ,new-pat ,xpr
    214                                 (list ,@(listify new-pat)))))
    215                      `(bind ,(car pat) (car ,lst)
    216                        (bind ,(listify (cdr pat)) (cdr ,lst)
    217                          ,@body))))))))))))
    21851]|#
    21952
     
    22457(define-syntax bindable?
    22558  (syntax-rules ()
    226     ((_ ())
    227      (lambda (tpl) (null? tpl)))
    22859    ((_ (a . b))
    22960     (lambda (tpl)
     
    23162            ((bindable? a) (car tpl))
    23263            ((bindable? b) (cdr tpl)))))
     64    ((_ ())
     65     (lambda (tpl) (null? tpl)))
    23366    ((_ a) (lambda (tpl) #t))))
    23467
    235 
    23668#|[
    237 Note that in the three following macros the pattern argument is
    238 processed at compile time while the template argument is processed at
    239 runtime.
    240 Note also, that the terminal position argument of tree-ref in the
    241 template must be quoted, in case it is a singleton list. This is done by
    242 quote-last
     69The following is a Scheme version of Common Lisp's destructuring bind.
     70Note, that the call to bindable? is strictly speaking not necessary, but
     71it provides a meaningful error message. It causes to traverse pair
     72patterns twice. But that is unimportant because it happens at compile
     73time.
    24374]|#
    24475
    24576;;; (bind pat tpl . body)
    24677;;; --------------------------
    247 ;;; Common Lisp's destructuring bind
    24878;;; binds pattern variables of pat to corresponding subexpression of
    24979;;; tpl and evalueates body in this context
    25080(define-syntax bind
    251   (ir-macro-transformer
    252     (lambda (form inject compare?)
    253       (let ((pat (cadr form))
    254             (tpl (caddr form))
    255             (xpr (cadddr form))
    256             (xprs (cddddr form)))
    257         `(if ((bindable? ,pat) ,tpl)
    258           (let
    259              ,(map (lambda (ks)
    260                      `(,(apply tree-ref pat ks)
    261                         (tree-ref ,tpl ,@(quote-last ks))))
    262                    (pindex pat))
    263              ,xpr ,@xprs)
    264           (error 'bind
    265                  (format #f "template ~s doesn't match pattern ~s"
    266                          ,tpl ',pat)))))))
     81  (syntax-rules ()
     82    ((_(a . b) tpl xpr . xprs)
     83     (if ((bindable? (a . b)) tpl)
     84       (bind a (car tpl) (bind b (cdr tpl) xpr . xprs))
     85       (error 'bind (format #f "template ~s doesn't match pattern ~s"
     86                            tpl '(a . b)))))
     87    ((_ () tpl xpr . xprs)
     88     (if (null? tpl)
     89       (let () xpr . xprs)
     90       (error 'bind "not null" tpl)))
     91    ((_ a tpl xpr . xprs)
     92     (let ((a tpl)) xpr . xprs))))
     93;(define-syntax bind
     94;  (ir-macro-transformer
     95;    (lambda (form inject compare?)
     96;      (let ((pat (cadr form))
     97;            (tpl (caddr form))
     98;            (xpr (cadddr form))
     99;            (xprs (cddddr form)))
     100;        `(if ((bindable? ,pat) ,tpl)
     101;          (let
     102;             ,(map (lambda (ks)
     103;                     `(,(apply tree-ref pat ks)
     104;                        (tree-ref ,tpl ,@(quote-last ks))))
     105;                   (pindex pat))
     106;             ,xpr ,@xprs)
     107;          (error 'bind
     108;                 (format #f "template ~s doesn't match pattern ~s"
     109;                         ,tpl ',pat)))))))
    267110;(define-syntax bind
    268111;  (er-macro-transformer
     
    308151
    309152#|[
    310 old versions:
    311 ;;; (bind-define pat tpl)
    312 ;;; ---------------------
    313 ;;; defines pattern variables of the pattern pat by setting them to
    314 ;;; corresponding subexpressions of the template tpl
    315 (define-syntax bind-define
    316   (ir-macro-transformer
    317     (lambda (form inject compare)
    318       (let ((pat (cadr form)) (tpl (caddr form)))
    319         (let ((aux (pmap (lambda (x) (gensym)) pat)))
    320           `(if ((bindable? ,pat) ,tpl)
    321              (bind ,aux ,tpl
    322                (begin
    323                  ,@(map (lambda (ks)
    324                           `(define
    325                              ,(apply tree-ref pat ks)
    326                              (tree-ref ,(cons 'list aux) ,@(quote-last ks))))
    327                         (pindex pat))))
    328              (error 'bind-define (format #f "template ~s doesn't match pattern ~s"
    329                                          ,tpl ',pat))))))))
    330 
    331 ;;; (bind-set! pat tpl)
    332 ;;; ---------------------
    333 ;;; sets pattern variables of the pattern pat to corresponding
    334 ;;; subexpressions of the template tpl
    335 (define-syntax bind-set!
    336   (ir-macro-transformer
    337     (lambda (form inject compare)
    338       (let ((pat (cadr form)) (tpl (caddr form)))
    339         `(if ((bindable? ,pat) ,tpl)
    340            (begin
    341              ,@(map (lambda (ks)
    342                       `(set!
    343                          ,(apply tree-ref pat ks)
    344                          (tree-ref ,tpl ,@(quote-last ks))))
    345                     (pindex pat)))
    346            (error 'bind-set! (format #f "template ~s doesn't match pattern ~s" ,tpl ',pat)))))))
    347 
    348 These versions would perfectly work, if tpl is simply a list, but not if
    349 it is a list wrapped by a let storing common state. But the latter is
    350 the most often used case of bind-define. The same applies to the
    351 following version:
     153The next two macros provide simultaneous setting and defining of pattern
     154variables to subexpressions of a template. The following first try would
     155perfectly work, if tpl is simply a list, but not if it is a list wrapped
     156by a let storing common state. But the latter is the most often used
     157case of bind-define.
    352158
    353159(define-syntax bind-define
     
    371177We could have used implicit-renaming macros as well, but then the
    372178gensyms would be automatically renamed again, which isn't necessary.
     179Note, that there is some code duplication in the two macros below, which
     180could have been avoided by defining two helpers, pmap and pflatten, in a
     181separate helper module which must be imported for syntax. I've done this
     182in a former version.
    373183]|#
    374184
     
    381191    (lambda (form rename compare?)
    382192      (let ((pat (cadr form)) (tpl (caddr form)))
    383         (let ((aux (pmap gensym pat))
     193        (let ((aux (let recur ((pat pat))
     194                     (cond
     195                       ((null? pat) '())
     196                       ((symbol? pat) (gensym))
     197                       ((pair? pat)
     198                        (cons (recur (car pat)) (recur (cdr pat)))))))
    384199              ; rename would potentially clash with the %x below
    385200              (%bind (rename 'bind))
     
    389204          `(,%let ((,%x ,tpl))
    390205             (,%bind ,aux ,%x
    391                ,@(map (lambda (p a) `(,%set! ,p ,a))
    392                       (pflatten pat) (pflatten aux)))))))))
     206               ,@(let recur ((pat pat) (aux aux))
     207                   (cond
     208                     ((null? pat) '())
     209                     ((symbol? pat) `((set! ,pat ,aux)))
     210                     ((pair? pat)
     211                      (append (recur (car pat) (car aux))
     212                              (recur (cdr pat) (cdr aux)))))))))))))
    393213;(define-syntax bind-set!
    394214;  (ir-macro-transformer
     
    409229    (lambda (form rename compare?)
    410230      (let ((pat (cadr form)) (tpl (caddr form)))
    411         (let ((aux (pmap gensym pat))
     231        (let ((aux (let recur ((pat pat))
     232                     (cond
     233                       ((null? pat) '())
     234                       ((symbol? pat) (gensym))
     235                       ((pair? pat)
     236                        (cons (recur (car pat)) (recur (cdr pat)))))))
    412237              (%bind-set! (rename 'bind-set!))
    413238              (%define (rename 'define))
     
    415240          `(,%begin
    416241             (,%bind-set! ,aux ,tpl)
    417              ,@(map (lambda (p a) `(,%define ,p ,a))
    418                     (pflatten pat) (pflatten aux))))))))
     242             ,@(let recur ((pat pat) (aux aux))
     243                 (cond
     244                   ((null? pat) '())
     245                   ((symbol? pat) `((set! ,pat ,aux)))
     246                   ((pair? pat)
     247                    (append (recur (car pat) (car aux))
     248                            (recur (cdr pat) (cdr aux))))))))))))
    419249;(define-syntax bind-define
    420250;  (ir-macro-transformer
     
    704534(define (list-bindings)
    705535  '(bind-define bind-set! bind bind-let* bind-let bind-case bindable? bind/cc
    706     define-macro let-macro letrec-macro define-syntax-rule tree-ref
    707     pflatten))
     536    define-macro let-macro letrec-macro define-syntax-rule))
    708537
    709538) ; module list-bindings
  • release/4/list-bindings/trunk/list-bindings.setup

    r29769 r29774  
    33(compile -O3 -s -d1 list-bindings.scm -J)
    44(compile -O3 -d0 -s list-bindings.import.scm)
    5 (compile -O3 -d0 -s list-binding-helpers.import.scm)
    65
    76(install-extension
    87 'list-bindings
    9  '("list-bindings.so" "list-bindings.import.so"
    10    "list-binding-helpers.import.so")
    11  '((version "1.5")))
     8 '("list-bindings.so" "list-bindings.import.so")
     9 '((version "1.5.1")))
    1210
Note: See TracChangeset for help on using the changeset viewer.