122 lines
3.7 KiB
Scheme
122 lines
3.7 KiB
Scheme
|
;;; These are some macros to support using regexp matching.
|
||
|
|
|
||
|
|
(define-structure let-match-package
|
||
|
|
(export (let-match :syntax)
|
||
|
|
(if-match :syntax)
|
||
|
|
(match-cond :syntax))
|
||
|
|
(for-syntax (open scheme
|
||
|
|
signals)) ; For ERROR
|
||
|
|
|
||
|
|
(open scsh scheme)
|
||
|
|
(access signals) ; for ERROR
|
||
|
|
|
||
|
|
(begin
|
||
|
|
|
||
|
|
;;; (let-match m mvars body ...)
|
||
|
|
;;; Bind the vars in MVARS to the match & submatch strings of match data M,
|
||
|
|
;;; and eval the body forms. #F is allowed in the MVARS list, as a don't-care
|
||
|
|
;;; parameter.
|
||
|
|
;;;
|
||
|
|
;;; (if-match m mvars conseq alt)
|
||
|
|
;;; The same as LET-MATCH -- eval the CONSEQ form in the scope of the
|
||
|
|
;;; bound MVARS. However, if the match data M evaluates to false, instead
|
||
|
|
;;; of blowing up, we execute the ALT form instead.
|
||
|
|
|
||
|
|
(define-syntax let-match
|
||
|
|
(lambda (exp r c)
|
||
|
|
(if (< (length exp) 3)
|
||
|
|
(error "No match-vars list in LET-MATCH" exp))
|
||
|
|
(let ((m (cadr exp)) ; The match expression
|
||
|
|
(mvars (caddr exp)) ; The match vars
|
||
|
|
(body (cdddr exp)) ; The expression's body forms
|
||
|
|
|
||
|
|
(%begin (r 'begin))
|
||
|
|
(%match:substring (r 'match:substring))
|
||
|
|
(%let* (r 'let*)))
|
||
|
|
|
||
|
|
(cond ((null? mvars) `(,%begin ,@body))
|
||
|
|
|
||
|
|
((pair? mvars)
|
||
|
|
(let* ((msv (or (car mvars) (r 'match-val))) ; "match-struct var"
|
||
|
|
(sm-bindings (let recur ((i 0) (vars (cdr mvars)))
|
||
|
|
(if (pair? vars)
|
||
|
|
(let ((var (car vars))
|
||
|
|
(bindings (recur (+ i 1) (cdr vars))))
|
||
|
|
(if var
|
||
|
|
(cons `(,var (,%match:substring ,msv ,i))
|
||
|
|
bindings)
|
||
|
|
bindings))
|
||
|
|
'()))))
|
||
|
|
`(,%let* ((,msv ,m) ,@sm-bindings) ,@body)))
|
||
|
|
|
||
|
|
|
||
|
|
(else (error "Illegal match-vars list in LET-MATCH" mvars exp))))))
|
||
|
|
|
||
|
|
(define-syntax if-match
|
||
|
|
(syntax-rules ()
|
||
|
|
((if-match match-exp mvars on-match no-match)
|
||
|
|
(cond (match-exp => (lambda (m) (let-match m mvars on-match)))
|
||
|
|
(else no-match)))))
|
||
|
|
|
||
|
|
;;; (MATCH-COND (<match-exp> <match-vars> <body> ...)
|
||
|
|
;;; (TEST <exp> <body> ...)
|
||
|
|
;;; (TEST <exp> => <proc>)
|
||
|
|
;;; (ELSE <body> ...))
|
||
|
|
;;;
|
||
|
|
;;; The first clause is as-in IF-MATCH; the next three clauses are as-in COND.
|
||
|
|
;;;
|
||
|
|
;;; It would be slicker if we could *add* extra clauses to the syntax
|
||
|
|
;;; of COND, but Scheme macros aren't extensible this way.
|
||
|
|
|
||
|
|
;;; Two defs. The other expander produces prettier output -- one COND
|
||
|
|
;;; rather than a mess of nested IF's.
|
||
|
|
;(define-syntax match-cond
|
||
|
|
; (syntax-rules (else test =>)
|
||
|
|
; ((match-cond (else body ...) clause2 ...) (begin body ...))
|
||
|
|
;
|
||
|
|
; ((match-cond) (cond))
|
||
|
|
;
|
||
|
|
; ((match-cond (test exp => proc) clause2 ...)
|
||
|
|
; (let ((v exp)) (if v (proc v) (match-cond clause2 ...))))
|
||
|
|
;
|
||
|
|
; ((match-cond (test exp body ...) clause2 ...)
|
||
|
|
; (if exp (begin body ...) (match-cond clause2 ...)))
|
||
|
|
;
|
||
|
|
; ((match-cond (test exp) clause2 ...)
|
||
|
|
; (or exp (match-cond clause2 ...)))
|
||
|
|
;
|
||
|
|
; ((match-cond (match-exp mvars body ...) clause2 ...)
|
||
|
|
; (if-match match-exp mvars (begin body ...)
|
||
|
|
; (match-cond clause2 ...)))))
|
||
|
|
|
||
|
|
(define-syntax match-cond
|
||
|
|
(syntax-rules ()
|
||
|
|
((match-cond clause ...) (match-cond-aux () clause ...))))
|
||
|
|
|
||
|
|
(define-syntax match-cond-aux
|
||
|
|
(syntax-rules (test else)
|
||
|
|
|
||
|
|
;; No more clauses.
|
||
|
|
((match-cond-aux (cond-clause ...))
|
||
|
|
(cond cond-clause ...))
|
||
|
|
|
||
|
|
;; (TEST . <cond-clause>)
|
||
|
|
((match-cond-aux (cond-clause ...)
|
||
|
|
(test . another-cond-clause) clause2 ...)
|
||
|
|
(match-cond-aux (cond-clause ... another-cond-clause)
|
||
|
|
clause2 ...))
|
||
|
|
|
||
|
|
;; (ELSE <body> ...)
|
||
|
|
((match-cond-aux (cond-clause ...)
|
||
|
|
(else body ...) clause2 ...)
|
||
|
|
(match-cond-aux (cond-clause ... (else body ...))))
|
||
|
|
|
||
|
|
;; (<match-exp> <mvars> <body> ...)
|
||
|
|
((match-cond-aux (cond-clause ...)
|
||
|
|
(match-exp mvars body ...) clause2 ...)
|
||
|
|
(match-cond-aux (cond-clause ... (match-exp => (lambda (m)
|
||
|
|
(let-match m mvars
|
||
|
|
body ...))))
|
||
|
|
clause2 ...))))
|
||
|
|
))
|