Ignore:
Timestamp:
11/07/17 10:54:09 (4 years ago)
Author:
juergen
Message:

basic-macros 1.2 with procedural bind-case to improve error message

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/basic-macros/trunk/basic-macros.scm

    r34857 r34873  
    489489;;; pattern to corresponding subexpressions of seq and executes
    490490;;; corresponding body xpr . xprs
    491 (define-syntax bind-case
    492   (syntax-rules ()
    493     ((_ seq)
    494      (error 'bind-case "no match, possibly caused by fenders, for" seq))
    495     ((_ seq (pat (where . fenders) xpr . xprs))
    496      (condition-case (bind pat seq (where . fenders) xpr . xprs)
    497        ((exn) (bind-case seq))))
    498     ((_ seq (pat xpr . xprs))
    499      (bind-case seq (pat (where) xpr . xprs)))
    500     ((_ seq clause . clauses)
    501      (condition-case (bind-case seq clause)
    502        ((exn) (bind-case seq . clauses))))
    503     ))
     491(define-ir-macro-transformer (bind-case form inject compare?)
     492  (let ((seq (cadr form))
     493        (rules (cddr form))
     494        (insert-where-clause
     495          (lambda (rule)
     496            (if (and (pair? (cadr rule))
     497                     (compare? (caadr rule) 'where))
     498              rule
     499              `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
     500    (let ((rules (map insert-where-clause rules))
     501          (rule->bind
     502            (lambda (rule)
     503              `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
     504      (let loop ((binds (map rule->bind rules)) (pats '()))
     505        (if (null? binds)
     506           `(error 'bind-case "no match"
     507                   ,seq
     508                   ',(reverse pats))
     509           `(condition-case ,(car binds)
     510              ((exn)
     511               ,(loop (cdr binds)
     512                      (cons (list (cadar binds) (car (cdddar binds)))
     513                            pats)))))))))
     514; the procedural version above improves the error message
     515;(define-syntax bind-case
     516;  (syntax-rules ()
     517;    ((_ seq)
     518;     (error 'bind-case "no match, possibly caused by fenders, for" seq))
     519;    ((_ seq (pat (where . fenders) xpr . xprs))
     520;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
     521;       ((exn) (bind-case seq))))
     522;    ((_ seq (pat xpr . xprs))
     523;     (bind-case seq (pat (where) xpr . xprs)))
     524;    ((_ seq clause . clauses)
     525;     (condition-case (bind-case seq clause)
     526;       ((exn) (bind-case seq . clauses))))
     527;    ))
    504528
    505529;;; (once-only (x ....) xpr ....)
     
    689713
    690714) ; module basic-macros
    691 
Note: See TracChangeset for help on using the changeset viewer.