Changeset 38020 in project


Ignore:
Timestamp:
12/14/19 13:01:58 (10 months ago)
Author:
juergen
Message:

bindings 2.1 bug fix in bind

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

Legend:

Unmodified
Added
Removed
  • release/5/bindings/tags/2.1/bindings.egg

    r38015 r38020  
    44 (test-dependencies simple-tests checks)
    55 (author "Juergen Lorenz")
    6  (version "2.0")
     6 (version "2.1")
    77 (components (extension bindings)))
  • release/5/bindings/tags/2.1/bindings.scm

    r38015 r38020  
    5959        )
    6060
    61 (import-for-syntax (only (chicken keyword) keyword?))
     61(import-for-syntax (only (chicken keyword) keyword?)
     62                   (only (chicken format) format))
    6263
    6364(define (split-along pat lst) ; internal
     
    105106      )))
    106107
    107 ;;; (bind-pvars pat)
    108 ;;; ----------------
    109 ;;; returns the list of pattern variables of the pattern
    110 ;;; or error in case of duplicates
    111 (define (bind-pvars pat)
    112   (let ((result '()))
    113     (let loop ((pat pat))
    114       (cond
    115         ((pair? pat)
    116          (loop (car pat))
    117          (loop (cdr pat)))
    118         ((and (symbol? pat)
    119               (not (eq? pat '_)))
    120          (if (memq pat result)
    121              (error 'bind-pvars
    122                     (format #f "duplicates: ~s already in ~s~%"
    123                             pat result))
    124              (set! result (cons pat result))))
    125         (else (void))))
    126     (reverse result)))
     108;;; (bind-pvars pat xpr . xprs)
     109;;; ---------------------------
     110;;; wraps the body xpr . xprs into a let which binds the variables of
     111;;; pat to #f checking for duplicates on its way
     112(define-syntax bind-pvars
     113  (er-macro-transformer
     114    (lambda (form rename compare?)
     115      (let ((pat (cadr form))
     116            (xpr (caddr form))
     117            (xprs (cdddr form))
     118            (%_ (rename '_))
     119            (%let (rename 'let))
     120            )
     121        (let ((result '()))
     122           (let loop ((pat pat))
     123             (cond
     124                ((pair? pat)
     125                 (loop (car pat))
     126                 (loop (cdr pat)))
     127                ((and (symbol? pat)
     128                      (not (compare? pat %_)))
     129                 (if (memq pat result)
     130                      (error (format #f "duplicates: ~s already in ~s~%"
     131                                     pat result))
     132                      (set! result (cons pat result))))
     133                (else (if #f #f)))
     134            `(,%let ,(map (lambda (r) `(,r #f))
     135                         (reverse result))
     136              ,xpr ,@xprs)))))))
     137
    127138
    128139;#|[
    129140;bind-set! is the macro, which does all the dirty work. It destructures
    130141;the pattern and the template in parallel, checks if literals match and
    131 ;if length' are equal, checks for duplicate pattern variables, and
    132 ;handles the wildcard, which matches everything but binds nothing.
    133 ;Because of the wildcard, _, the macro will be unhygienic, hence must
    134 ;be implemented procedurally. This has the additional advantage, that
    135 ;some the branching code can be evaluated at compile time.
    136 
     142;if length' are equal, and handles the wildcard, which matches
     143;everything but binds nothing.  Because of the wildcard, _, the macro
     144;will be unhygienic on purpose, hence must be implemented procedurally.
     145;This has the additional advantage, that some the branching code can be
     146;evaluated at compile time.
    137147;]|#
    138148
     
    170180            )
    171181        `(,%let ((,%pat ',pat) (,%seq ,seq))
    172            (,%bind-pvars ,%pat) ;check for duplicates
     182           ;(,%bind-pvars ,pat #t) ;check for duplicates
    173183           ,(cond
    174184              ((pair? pat)
     
    280290  (syntax-rules ()
    281291    ((_ pat seq xpr . xprs)
    282      (begin
     292     ;(begin
     293     (bind-pvars pat
    283294       (bind-set! pat seq) xpr . xprs))))
    284295
     
    541552      "internal database")
    542553    (bind-pvars
    543       procedure:
    544       (bind-pvars pat)
    545       "checks if a pattern contains duplicate pattern variables,"
    546       "if so calls error, otherwise returns the list of pvars.")
     554      macro:
     555      (bind-pvars pat xpr ....)
     556      "wraps xpr .... into a let, binding pattern variables of pat to #f"
     557      "checking for duplicates on its way")
    547558    (bind
    548559      macro:
  • release/5/bindings/tags/2.1/tests/run.scm

    r38015 r38020  
    1010        )
    1111
     12(pe '(bind-pvars (a (b c)) #t))
     13(pe '(bind-pvars (a _ (b _ c)) #t))
     14(pe '(bind-pvars (#f a (b 3 c)) #t))
     15;(pe '(bind-pvars (a (b b)) #t))
     16
    1217(define-test (helpers?)
    1318  ;; reset internal database
    1419  (bind-seq->list)
    1520
    16   (equal? (bind-pvars '(a (b c)))
    17           '(a b c))
    18   (equal? (bind-pvars '(a _ (b _ c)))
    19           '(a b c))
    20   (equal? (bind-pvars '(#f a (b 3 c)))
    21           '(a b c))
    22   (not (condition-case (bind-pvars '(a (b b)))
    23          ((exn) #f)))
    2421  (equal? (bind-seq->list "x") (cons identity identity))
    2522  (bind-seq->list string? string->list list->string)
  • release/5/bindings/trunk/bindings.egg

    r38015 r38020  
    44 (test-dependencies simple-tests checks)
    55 (author "Juergen Lorenz")
    6  (version "2.0")
     6 (version "2.1")
    77 (components (extension bindings)))
  • release/5/bindings/trunk/bindings.scm

    r38015 r38020  
    5959        )
    6060
    61 (import-for-syntax (only (chicken keyword) keyword?))
     61(import-for-syntax (only (chicken keyword) keyword?)
     62                   (only (chicken format) format))
    6263
    6364(define (split-along pat lst) ; internal
     
    105106      )))
    106107
    107 ;;; (bind-pvars pat)
    108 ;;; ----------------
    109 ;;; returns the list of pattern variables of the pattern
    110 ;;; or error in case of duplicates
    111 (define (bind-pvars pat)
    112   (let ((result '()))
    113     (let loop ((pat pat))
    114       (cond
    115         ((pair? pat)
    116          (loop (car pat))
    117          (loop (cdr pat)))
    118         ((and (symbol? pat)
    119               (not (eq? pat '_)))
    120          (if (memq pat result)
    121              (error 'bind-pvars
    122                     (format #f "duplicates: ~s already in ~s~%"
    123                             pat result))
    124              (set! result (cons pat result))))
    125         (else (void))))
    126     (reverse result)))
     108;;; (bind-pvars pat xpr . xprs)
     109;;; ---------------------------
     110;;; wraps the body xpr . xprs into a let which binds the variables of
     111;;; pat to #f checking for duplicates on its way
     112(define-syntax bind-pvars
     113  (er-macro-transformer
     114    (lambda (form rename compare?)
     115      (let ((pat (cadr form))
     116            (xpr (caddr form))
     117            (xprs (cdddr form))
     118            (%_ (rename '_))
     119            (%let (rename 'let))
     120            )
     121        (let ((result '()))
     122           (let loop ((pat pat))
     123             (cond
     124                ((pair? pat)
     125                 (loop (car pat))
     126                 (loop (cdr pat)))
     127                ((and (symbol? pat)
     128                      (not (compare? pat %_)))
     129                 (if (memq pat result)
     130                      (error (format #f "duplicates: ~s already in ~s~%"
     131                                     pat result))
     132                      (set! result (cons pat result))))
     133                (else (if #f #f)))
     134            `(,%let ,(map (lambda (r) `(,r #f))
     135                         (reverse result))
     136              ,xpr ,@xprs)))))))
     137
    127138
    128139;#|[
    129140;bind-set! is the macro, which does all the dirty work. It destructures
    130141;the pattern and the template in parallel, checks if literals match and
    131 ;if length' are equal, checks for duplicate pattern variables, and
    132 ;handles the wildcard, which matches everything but binds nothing.
    133 ;Because of the wildcard, _, the macro will be unhygienic, hence must
    134 ;be implemented procedurally. This has the additional advantage, that
    135 ;some the branching code can be evaluated at compile time.
    136 
     142;if length' are equal, and handles the wildcard, which matches
     143;everything but binds nothing.  Because of the wildcard, _, the macro
     144;will be unhygienic on purpose, hence must be implemented procedurally.
     145;This has the additional advantage, that some the branching code can be
     146;evaluated at compile time.
    137147;]|#
    138148
     
    170180            )
    171181        `(,%let ((,%pat ',pat) (,%seq ,seq))
    172            (,%bind-pvars ,%pat) ;check for duplicates
     182           ;(,%bind-pvars ,pat #t) ;check for duplicates
    173183           ,(cond
    174184              ((pair? pat)
     
    280290  (syntax-rules ()
    281291    ((_ pat seq xpr . xprs)
    282      (begin
     292     ;(begin
     293     (bind-pvars pat
    283294       (bind-set! pat seq) xpr . xprs))))
    284295
     
    541552      "internal database")
    542553    (bind-pvars
    543       procedure:
    544       (bind-pvars pat)
    545       "checks if a pattern contains duplicate pattern variables,"
    546       "if so calls error, otherwise returns the list of pvars.")
     554      macro:
     555      (bind-pvars pat xpr ....)
     556      "wraps xpr .... into a let, binding pattern variables of pat to #f"
     557      "checking for duplicates on its way")
    547558    (bind
    548559      macro:
  • release/5/bindings/trunk/tests/run.scm

    r38015 r38020  
    1010        )
    1111
     12(pe '(bind-pvars (a (b c)) #t))
     13(pe '(bind-pvars (a _ (b _ c)) #t))
     14(pe '(bind-pvars (#f a (b 3 c)) #t))
     15;(pe '(bind-pvars (a (b b)) #t))
     16
    1217(define-test (helpers?)
    1318  ;; reset internal database
    1419  (bind-seq->list)
    1520
    16   (equal? (bind-pvars '(a (b c)))
    17           '(a b c))
    18   (equal? (bind-pvars '(a _ (b _ c)))
    19           '(a b c))
    20   (equal? (bind-pvars '(#f a (b 3 c)))
    21           '(a b c))
    22   (not (condition-case (bind-pvars '(a (b b)))
    23          ((exn) #f)))
    2421  (equal? (bind-seq->list "x") (cons identity identity))
    2522  (bind-seq->list string? string->list list->string)
Note: See TracChangeset for help on using the changeset viewer.