67 lines
2.2 KiB
Scheme
67 lines
2.2 KiB
Scheme
|
|
;;----------------------------------------------------------------------
|
|
;; syntax/loc
|
|
|
|
(module stxloc '#%kernel
|
|
(#%require "qq-and-or.ss" "stxcase.ss" "define-et-al.ss"
|
|
(for-syntax '#%kernel "stxcase.ss" "sc.ss"))
|
|
|
|
;; Regular syntax-case
|
|
(-define-syntax syntax-case*
|
|
(lambda (stx)
|
|
(syntax-case** #f #t stx () free-identifier=?
|
|
[(_ stxe kl id=? clause ...)
|
|
(syntax (syntax-case** _ #f stxe kl id=? clause ...))])))
|
|
|
|
;; Regular syntax-case
|
|
(-define-syntax syntax-case
|
|
(lambda (stx)
|
|
(syntax-case** #f #t stx () free-identifier=?
|
|
[(_ stxe kl clause ...)
|
|
(syntax (syntax-case** _ #f stxe kl free-identifier=? clause ...))])))
|
|
|
|
(-define (relocate loc stx)
|
|
(if (or (syntax-source loc)
|
|
(syntax-position loc))
|
|
(datum->syntax stx
|
|
(syntax-e stx)
|
|
loc
|
|
#f
|
|
stx)
|
|
stx))
|
|
|
|
;; Like syntax, but also takes a syntax object
|
|
;; that supplies a source location for the
|
|
;; resulting syntax object.
|
|
(-define-syntax syntax/loc
|
|
(lambda (stx)
|
|
(syntax-case** #f #t stx () free-identifier=?
|
|
[(_ loc pattern)
|
|
(if (if (symbol? (syntax-e #'pattern))
|
|
(syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f)))
|
|
#f)
|
|
(syntax (syntax pattern))
|
|
(syntax (relocate loc (syntax pattern))))])))
|
|
|
|
(-define-syntax quote-syntax/prune
|
|
(lambda (stx)
|
|
(syntax-case** #f #t stx () free-identifier=?
|
|
[(_ id)
|
|
(if (symbol? (syntax-e #'id))
|
|
(datum->syntax #'here
|
|
(list (quote-syntax quote-syntax)
|
|
(identifier-prune-lexical-context (syntax id)
|
|
(list
|
|
(syntax-e (syntax id))
|
|
'#%top)))
|
|
stx
|
|
#f
|
|
stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier"
|
|
stx
|
|
#'id))])))
|
|
|
|
(#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case ... _))
|