77 lines
2.7 KiB
Scheme
77 lines
2.7 KiB
Scheme
(module match-error mzscheme
|
|
(provide (all-defined))
|
|
|
|
(require (lib "pregexp.ss"))
|
|
|
|
(define-struct (exn:misc:match exn:fail) (value))
|
|
|
|
(define match:error
|
|
(case-lambda
|
|
((val)
|
|
(raise
|
|
(make-exn:misc:match
|
|
(string->immutable-string (format "match: no matching clause for ~e" val))
|
|
(current-continuation-marks)
|
|
val)))
|
|
((val expr)
|
|
(raise
|
|
(make-exn:misc:match
|
|
(string->immutable-string (format "match: no matching clause for ~e: ~s" val expr))
|
|
(current-continuation-marks)
|
|
val)))))
|
|
|
|
;;! (function match:syntax-err
|
|
;; (form (match:syntax-err object message . detail) -> void)
|
|
;; (contract (any string . any) -> void)
|
|
;; (example (match:syntax-err (syntax here) "Bad error" (vector))
|
|
;; -> void)
|
|
;; (contract object -> (normally a syntax object that
|
|
;; that helps determine the source location
|
|
;; of the error)))
|
|
;; This function is used to report malformed match expressions.
|
|
|
|
(define match:syntax-err (lambda (obj msg . detail)
|
|
(apply
|
|
raise-syntax-error
|
|
'match
|
|
msg
|
|
obj
|
|
detail)))
|
|
|
|
|
|
|
|
;;!(function unreachable
|
|
;; (form (unreachable plist match-expr) -> void)
|
|
;; (contract (list syntax-object) -> void)
|
|
;; (contract plist -> (is a list of unreached pattern clauses))
|
|
;; (contract match-expr -> (is the origional match expr
|
|
;; the clauses came from)))
|
|
;; This function takes a list of unreached clauses and the original
|
|
;; match expression and prints a warning for each of the unreached
|
|
;; match clauses to the current error port
|
|
(define unreachable
|
|
(lambda (plist match-expr)
|
|
(map
|
|
(lambda (x)
|
|
(if (not (cdr x))
|
|
(fprintf
|
|
(current-error-port)
|
|
"Warning: unreachable match clause ~e in ~e~n"
|
|
(syntax-object->datum (car x))
|
|
(syntax-object->datum match-expr))))
|
|
plist)))
|
|
|
|
;; this makes pregexp errors a little more friendly
|
|
(define (pregexp-match-with-error regex str)
|
|
(if (or (string? regex)
|
|
(and (pair? regex)
|
|
(equal? ':sub (car regex))))
|
|
(pregexp-match regex str)
|
|
(error 'match:pregex
|
|
(string-append
|
|
"this pattern expects either a S-regexp or a U-regexp,"
|
|
" given " (format "~s" regex) "; "
|
|
"other argument was " (format "~s" str)))))
|
|
|
|
|
|
) |