Changeset 34875 in project


Ignore:
Timestamp:
11/07/17 11:08:31 (23 months ago)
Author:
juergen
Message:

bindings 7.1 with procedural bind-case to improve error message

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

Legend:

Unmodified
Added
Removed
  • release/4/bindings/tags/7.1/bindings.scm

    r33785 r34875  
    332332;;; corresponding body xpr ....
    333333(define-syntax bind-case
    334   (syntax-rules ()
    335     ((_ seq)
    336      (raise (seq-exception 'bind-case "no match for" seq)))
    337     ((_ seq (pat (where . fenders) xpr . xprs))
    338      (condition-case (bind pat seq (where . fenders) xpr . xprs)
    339        ((exn sequence) (bind-case seq))))
    340     ((_ seq (pat xpr . xprs))
    341      (bind-case seq (pat (where) xpr . xprs)))
    342     ((_ seq clause . clauses)
    343      (condition-case (bind-case seq clause)
    344        ((exn sequence) (bind-case seq . clauses))))
    345     ))
     334  (ir-macro-transformer
     335    (lambda (form inject compare?)
     336  (let ((seq (cadr form))
     337        (rules (cddr form))
     338        (insert-where-clause
     339          (lambda (rule)
     340            (if (and (pair? (cadr rule))
     341                     (compare? (caadr rule) 'where))
     342              rule
     343              `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
     344    (let ((rules (map insert-where-clause rules))
     345          (rule->bind
     346            (lambda (rule)
     347              `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
     348      (let loop ((binds (map rule->bind rules)) (pats '()))
     349        (if (null? binds)
     350           `(raise (seq-exception 'bind-case "no match"
     351                                  ,seq
     352                                  ',(reverse pats)))
     353           `(condition-case ,(car binds)
     354              ((exn)
     355               ,(loop (cdr binds)
     356                      (cons (list (cadar binds) (car (cdddar binds)))
     357                            pats)))))))))))
     358; the procedural version above improves the error message
     359;(define-syntax bind-case
     360;  (syntax-rules ()
     361;    ((_ seq)
     362;     (raise (seq-exception 'bind-case "no match for" seq)))
     363;    ((_ seq (pat (where . fenders) xpr . xprs))
     364;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
     365;       ((exn sequence) (bind-case seq))))
     366;    ((_ seq (pat xpr . xprs))
     367;     (bind-case seq (pat (where) xpr . xprs)))
     368;    ((_ seq clause . clauses)
     369;     (condition-case (bind-case seq clause)
     370;       ((exn sequence) (bind-case seq . clauses))))
     371;    ))
    346372
    347373#|[
  • release/4/bindings/tags/7.1/bindings.setup

    r33859 r34875  
    77 'bindings
    88 '("bindings.so" "bindings.import.so")
    9  '((version "7.0.4")))
     9 '((version "7.1")))
  • release/4/bindings/trunk/bindings.scm

    r33785 r34875  
    332332;;; corresponding body xpr ....
    333333(define-syntax bind-case
    334   (syntax-rules ()
    335     ((_ seq)
    336      (raise (seq-exception 'bind-case "no match for" seq)))
    337     ((_ seq (pat (where . fenders) xpr . xprs))
    338      (condition-case (bind pat seq (where . fenders) xpr . xprs)
    339        ((exn sequence) (bind-case seq))))
    340     ((_ seq (pat xpr . xprs))
    341      (bind-case seq (pat (where) xpr . xprs)))
    342     ((_ seq clause . clauses)
    343      (condition-case (bind-case seq clause)
    344        ((exn sequence) (bind-case seq . clauses))))
    345     ))
     334  (ir-macro-transformer
     335    (lambda (form inject compare?)
     336  (let ((seq (cadr form))
     337        (rules (cddr form))
     338        (insert-where-clause
     339          (lambda (rule)
     340            (if (and (pair? (cadr rule))
     341                     (compare? (caadr rule) 'where))
     342              rule
     343              `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
     344    (let ((rules (map insert-where-clause rules))
     345          (rule->bind
     346            (lambda (rule)
     347              `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
     348      (let loop ((binds (map rule->bind rules)) (pats '()))
     349        (if (null? binds)
     350           `(raise (seq-exception 'bind-case "no match"
     351                                  ,seq
     352                                  ',(reverse pats)))
     353           `(condition-case ,(car binds)
     354              ((exn)
     355               ,(loop (cdr binds)
     356                      (cons (list (cadar binds) (car (cdddar binds)))
     357                            pats)))))))))))
     358; the procedural version above improves the error message
     359;(define-syntax bind-case
     360;  (syntax-rules ()
     361;    ((_ seq)
     362;     (raise (seq-exception 'bind-case "no match for" seq)))
     363;    ((_ seq (pat (where . fenders) xpr . xprs))
     364;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
     365;       ((exn sequence) (bind-case seq))))
     366;    ((_ seq (pat xpr . xprs))
     367;     (bind-case seq (pat (where) xpr . xprs)))
     368;    ((_ seq clause . clauses)
     369;     (condition-case (bind-case seq clause)
     370;       ((exn sequence) (bind-case seq . clauses))))
     371;    ))
    346372
    347373#|[
  • release/4/bindings/trunk/bindings.setup

    r33859 r34875  
    77 'bindings
    88 '("bindings.so" "bindings.import.so")
    9  '((version "7.0.4")))
     9 '((version "7.1")))
Note: See TracChangeset for help on using the changeset viewer.