generalize this-expression-source-directory
svn: r9176 original commit: f31bf12543ffed4d9d2c2c0b9941d65db2576025
This commit is contained in:
Matthew Flatt
commit
7f2d6a8484
|
|
@ -262,39 +262,47 @@
|
||||||
|
|
||||||
(define-syntax (this-expression-source-directory stx)
|
(define-syntax (this-expression-source-directory stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_)
|
[(_ sub)
|
||||||
(let ([source-path
|
(let ([stx (syntax sub)])
|
||||||
(let* ([source (syntax-source stx)]
|
(let ([source-path
|
||||||
[source (and (path? source) source)]
|
(let* ([source (syntax-source stx)]
|
||||||
[local (or (current-load-relative-directory) (current-directory))]
|
[source (and (path? source) source)]
|
||||||
[dir (path->main-collects-relative
|
[local (or (current-load-relative-directory) (current-directory))]
|
||||||
(or (and source (file-exists? source)
|
[dir (path->main-collects-relative
|
||||||
(let-values ([(base file dir?)
|
(or (and source (file-exists? source)
|
||||||
(split-path source)])
|
(let-values ([(base file dir?)
|
||||||
(and (path? base)
|
(split-path source)])
|
||||||
(path->complete-path base local))))
|
(and (path? base)
|
||||||
local))])
|
(path->complete-path base local))))
|
||||||
(if (and (pair? dir) (eq? 'collects (car dir)))
|
local))])
|
||||||
(with-syntax ([d dir])
|
(if (and (pair? dir) (eq? 'collects (car dir)))
|
||||||
(syntax/loc stx (main-collects-relative->path 'd)))
|
(with-syntax ([d dir])
|
||||||
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
|
(syntax/loc stx (main-collects-relative->path 'd)))
|
||||||
(syntax/loc stx (bytes->path d)))))])
|
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
|
||||||
(let ([mpi (syntax-source-module stx)])
|
(syntax/loc stx (bytes->path d)))))])
|
||||||
(if mpi
|
(let ([mpi (syntax-source-module stx)])
|
||||||
(quasisyntax/loc stx
|
(if mpi
|
||||||
(or (extract-module-directory (quote-syntax #,stx))
|
(quasisyntax/loc stx
|
||||||
#,source-path))
|
(or (extract-module-directory (quote-syntax #,(datum->syntax-object
|
||||||
source-path)))]))
|
stx
|
||||||
|
'context
|
||||||
|
stx
|
||||||
|
stx)))
|
||||||
|
#,source-path))
|
||||||
|
source-path))))]
|
||||||
|
[(_) #`(this-expression-source-directory #,stx)]))
|
||||||
|
|
||||||
(define-syntax (this-expression-file-name stx)
|
(define-syntax (this-expression-file-name stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_)
|
[(_ sub)
|
||||||
(let* ([f (syntax-source stx)]
|
(let ([stx #'sub])
|
||||||
[f (and f (path? f) (file-exists? f)
|
(let* ([f (syntax-source stx)]
|
||||||
(let-values ([(base file dir?) (split-path f)]) file))])
|
[f (and f (path? f) (file-exists? f)
|
||||||
(if f
|
(let-values ([(base file dir?) (split-path f)]) file))])
|
||||||
(with-syntax ([f (path->bytes f)]) #'(bytes->path f))
|
(if f
|
||||||
#'#f))]))
|
(with-syntax ([f (path->bytes f)]) #'(bytes->path f))
|
||||||
|
#'#f)))]
|
||||||
|
[(_) #`(this-expression-file-name #,stx)]))
|
||||||
|
|
||||||
;; This is a macro-generating macro that wants to expand
|
;; This is a macro-generating macro that wants to expand
|
||||||
;; expressions used in the generated macro. So it's weird,
|
;; expressions used in the generated macro. So it's weird,
|
||||||
|
|
|
||||||
|
|
@ -1,192 +1,4 @@
|
||||||
;; (documentation (name match))
|
#lang scheme/base
|
||||||
;; <pre>Pattern Matching Syntactic Extensions for Scheme
|
|
||||||
;;
|
|
||||||
;; Special thanks go out to:
|
|
||||||
;; Robert Bruce Findler for support and bug detection.
|
|
||||||
;; Doug Orleans for pointing out that pairs should be reused while
|
|
||||||
;; matching lists.
|
|
||||||
;;
|
|
||||||
;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
|
|
||||||
;; which in turn was adapted from code written by Bruce F. Duba, 1991.
|
|
||||||
;;
|
|
||||||
;; This macro package extends Scheme with several new expression forms.
|
|
||||||
;; Following is a brief summary of the new forms. See the associated
|
|
||||||
;; LaTeX documentation for a full description of their functionality.
|
|
||||||
;;
|
|
||||||
;;
|
|
||||||
;; match expressions:
|
|
||||||
;;
|
|
||||||
;; exp ::= ...
|
|
||||||
;; | (match exp clause ...)
|
|
||||||
;; | (match-lambda clause ...)
|
|
||||||
;; | (match-lambda* clause ...)
|
|
||||||
;; | (match-let ((pat exp) ...) body ...)
|
|
||||||
;; | (match-let var ((pat exp) ...) body ...)
|
|
||||||
;; | (match-let* ((pat exp) ...) body ...)
|
|
||||||
;; | (match-letrec ((pat exp) ...) body ...)
|
|
||||||
;; | (match-define pat exp)
|
|
||||||
;;
|
|
||||||
;; clause ::= (pat body) | (pat (=> identifier) exp)
|
|
||||||
;;
|
|
||||||
;; patterns: matches:
|
|
||||||
;;
|
|
||||||
;; pat ::=
|
|
||||||
;; identifier this binds an identifier if it
|
|
||||||
;; doesn't conflict with
|
|
||||||
;; ..k, var, $, =, and,
|
|
||||||
;; or, not, ?, set!, or get!
|
|
||||||
;; | _ anything
|
|
||||||
;; | () the empty list
|
|
||||||
;; | #t #t
|
|
||||||
;; | #f #f
|
|
||||||
;; | string a string
|
|
||||||
;; | number a number
|
|
||||||
;; | character a character
|
|
||||||
;; | 'sexp an s-expression
|
|
||||||
;; | 'symbol a symbol (special case of s-expr)
|
|
||||||
;; | (lvp_1 ... lvp_n) list of n elements
|
|
||||||
;; | (pat ... pat_n . pat_{n+1}) list of n or more
|
|
||||||
;; | #(lvp_1 ... lvp_n) vector of n elements
|
|
||||||
;; | #&pat box
|
|
||||||
;; | ($ struct-name pat_1 ... pat_n) a structure
|
|
||||||
;; | (= field pat) a field of a structure (field is
|
|
||||||
;; an accessor)
|
|
||||||
;; Actually field can be any function
|
|
||||||
;; which can be
|
|
||||||
;; applied to the data being matched.
|
|
||||||
;; Ex: (match 5 ((= add1 b) b)) => 6
|
|
||||||
;;
|
|
||||||
;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
|
|
||||||
;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
|
|
||||||
;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
|
|
||||||
;; | (? predicate pat_1 ... pat_n) if predicate true and all of
|
|
||||||
;; pat_1 thru pat_n match
|
|
||||||
;; | (set! identifier) anything, and binds setter
|
|
||||||
;; | (get! identifier) anything, and binds getter
|
|
||||||
;; | `qp a quasi-pattern
|
|
||||||
;;
|
|
||||||
;; lvp ::= pat ooo greedily matches n or more of pat,
|
|
||||||
;; each element must match pat
|
|
||||||
;; | pat matches pat
|
|
||||||
;;
|
|
||||||
;; ooo ::= ... zero or more
|
|
||||||
;; | ___ zero or more
|
|
||||||
;; | ..k k or more
|
|
||||||
;; | __k k or more
|
|
||||||
;;
|
|
||||||
;; quasi-patterns: matches:
|
|
||||||
;;
|
|
||||||
;; qp ::= () the empty list
|
|
||||||
;; | #t #t
|
|
||||||
;; | #f #f
|
|
||||||
;; | string a string
|
|
||||||
;; | number a number
|
|
||||||
;; | character a character
|
|
||||||
;; | identifier a symbol
|
|
||||||
;; | (qp_1 ... qp_n) list of n elements
|
|
||||||
;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more
|
|
||||||
;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element
|
|
||||||
;; of remainder must match qp_n+1
|
|
||||||
;; | #(qp_1 ... qp_n) vector of n elements
|
|
||||||
;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element
|
|
||||||
;; of remainder must match qp_n+1
|
|
||||||
;; | #&qp box
|
|
||||||
;; | ,pat a pattern
|
|
||||||
;; | ,@(lvp . . . lvp-n)
|
|
||||||
;; | ,@(pat . . . pat_n . pat_{n+1})
|
|
||||||
;; | ,@`qp qp must evaluate to a list as
|
|
||||||
;; so that this rule resembles the
|
|
||||||
;; above two rules
|
|
||||||
;;
|
|
||||||
;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
|
|
||||||
;; and, or, not, set!, get!, list-no-order, hash-table, ..., ___)
|
|
||||||
;; cannot be used as pattern variables.</pre>
|
|
||||||
;;
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
|
|
||||||
(module match mzscheme
|
|
||||||
(provide
|
|
||||||
match
|
|
||||||
match-lambda
|
|
||||||
match-lambda*
|
|
||||||
match-let
|
|
||||||
match-let*
|
|
||||||
match-letrec
|
|
||||||
match-define
|
|
||||||
match-equality-test
|
|
||||||
exn:misc:match?
|
|
||||||
exn:misc:match-value
|
|
||||||
define-match-expander)
|
|
||||||
|
|
||||||
;; FIXME: match-helper and match-error should each be split
|
|
||||||
;; into a compile-time part and a run-time part.
|
|
||||||
|
|
||||||
(require-for-syntax "private/match/convert-pat.ss"
|
|
||||||
"private/match/match-helper.ss")
|
|
||||||
|
|
||||||
(require-for-template mzscheme)
|
|
||||||
|
|
||||||
(require (prefix plt: "private/match/match-internal-func.ss")
|
|
||||||
"private/match/match-expander.ss"
|
|
||||||
"private/match/match-helper.ss"
|
|
||||||
"private/match/match-error.ss"
|
|
||||||
"private/match/test-no-order.ss")
|
|
||||||
|
|
||||||
(define-syntax match-definer
|
|
||||||
(syntax-rules ()
|
|
||||||
[(match-definer name clauses ...)
|
|
||||||
(define-syntax (name stx)
|
|
||||||
(md-help syntax stx
|
|
||||||
(syntax-case stx ()
|
|
||||||
clauses ...)))]))
|
|
||||||
|
|
||||||
(match-definer match-lambda
|
|
||||||
[(k clause ...)
|
|
||||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
|
|
||||||
#'(plt:match-lambda new-clauses ...))])
|
|
||||||
|
|
||||||
(match-definer match-lambda*
|
|
||||||
[(k clause ...)
|
|
||||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
|
|
||||||
#'(plt:match-lambda* new-clauses ...))])
|
|
||||||
|
|
||||||
(match-definer match-let
|
|
||||||
[(k name (clauses ...) body ...)
|
|
||||||
(identifier? (syntax name))
|
|
||||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
|
||||||
#'(plt:match-let name (new-clauses ...) body ...))]
|
|
||||||
[(k (clauses ...) body ...)
|
|
||||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
|
||||||
#'(plt:match-let (new-clauses ...) body ...))])
|
|
||||||
|
|
||||||
(match-definer match-let*
|
|
||||||
[(k (clauses ...) body ...)
|
|
||||||
(with-syntax
|
|
||||||
([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
|
||||||
#'(plt:match-let* (new-clauses ...) body ...))])
|
|
||||||
|
|
||||||
(match-definer match
|
|
||||||
[(_ exp clause ...)
|
|
||||||
(with-syntax
|
|
||||||
([(new-clauses ...) (handle-clauses #'(clause ...))])
|
|
||||||
#'(plt:match exp new-clauses ...))])
|
|
||||||
|
|
||||||
|
|
||||||
(match-definer match-letrec
|
|
||||||
[(k (clauses ...) body ...)
|
|
||||||
(with-syntax
|
|
||||||
([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
|
||||||
#'(plt:match-letrec (new-clauses ...) body ...))])
|
|
||||||
|
|
||||||
|
|
||||||
(match-definer match-define
|
|
||||||
[(k pat exp)
|
|
||||||
(with-syntax ([new-pat (convert-pat #'pat)])
|
|
||||||
#'(plt:match-define new-pat exp))])
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
|
(require scheme/match/legacy-match)
|
||||||
|
(provide (all-from-out scheme/match/legacy-match))
|
||||||
|
|
@ -1,157 +1,4 @@
|
||||||
;; (documentation (name plt-match))
|
#lang scheme/base
|
||||||
;; <pre>Pattern Matching Syntactic Extensions for Scheme
|
|
||||||
;;
|
|
||||||
;; All bugs or questions concerning this software should be directed to
|
|
||||||
;; Bruce Hauman <bhauman@cs.wcu.edu>. The latest version of this software
|
|
||||||
;; can be obtained from http://sol.cs.wcu.edu/~bhauman/scheme/pattern.php.
|
|
||||||
;;
|
|
||||||
;; Special thanks go out to:
|
|
||||||
;; Robert Bruce Findler for support and bug detection.
|
|
||||||
;; Doug Orleans for pointing out that pairs should be reused while
|
|
||||||
;; matching lists.
|
|
||||||
;;
|
|
||||||
;;
|
|
||||||
;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
|
|
||||||
;; which in turn was adapted from code written by Bruce F. Duba, 1991.
|
|
||||||
;;
|
|
||||||
;; This software is in the public domain. Feel free to copy,
|
|
||||||
;; distribute, and modify this software as desired. No warranties
|
|
||||||
;; nor guarantees of any kind apply. Please return any improvements
|
|
||||||
;; or bug fixes to bhauman@cs.wcu.edu so that they may be included
|
|
||||||
;; in future releases.
|
|
||||||
;;
|
|
||||||
;; This macro package extends Scheme with several new expression forms.
|
|
||||||
;; Following is a brief summary of the new forms. See the associated
|
|
||||||
;; LaTeX documentation for a full description of their functionality.
|
|
||||||
;;
|
|
||||||
;;
|
|
||||||
;; match expressions:
|
|
||||||
;;
|
|
||||||
;; exp ::= ...
|
|
||||||
;; | (match exp clause ...)
|
|
||||||
;; | (match-lambda clause ...)
|
|
||||||
;; | (match-lambda* clause ...)
|
|
||||||
;; | (match-let ((pat exp) ...) body ...)
|
|
||||||
;; | (match-let var ((pat exp) ...) body ...)
|
|
||||||
;; | (match-let* ((pat exp) ...) body ...)
|
|
||||||
;; | (match-letrec ((pat exp) ...) body ...)
|
|
||||||
;; | (match-define pat exp)
|
|
||||||
;;
|
|
||||||
;; clause ::= (pat body) | (pat (=> identifier) exp)
|
|
||||||
;;
|
|
||||||
;; patterns: matches:
|
|
||||||
;;
|
|
||||||
;; pat ::=
|
|
||||||
;; identifier this binds an identifier if it
|
|
||||||
;; doesn't conflict with ..k, __k or _
|
|
||||||
;; | _ anything
|
|
||||||
;; | #t #t
|
|
||||||
;; | #f #f
|
|
||||||
;; | string a string
|
|
||||||
;; | number a number
|
|
||||||
;; | character a character
|
|
||||||
;; | 'sexp an s-expression
|
|
||||||
;; | 'symbol a symbol (special case of s-expr)
|
|
||||||
;; | (var id) allows one to use ..k or _ as
|
|
||||||
;; identifiers
|
|
||||||
;; | (list lvp_1 ... lvp_n) list of n elements
|
|
||||||
;; | (list-rest lvp_1 ... lvp_n pat) an improper list of n elements
|
|
||||||
;; plus a last element which represents
|
|
||||||
;; the last cdr of the list
|
|
||||||
;; | (vector lvp_1 ... lvp_n) vector of n elements
|
|
||||||
;; | (box pat) box
|
|
||||||
;; | (struct struct-name (pat_1 ... pat_n)) a structure
|
|
||||||
;; | (regexp exp) if regular expression exp matches
|
|
||||||
;; | (regexp exp pat) if result of regexp-match matches pat
|
|
||||||
;; | (pregexp exp) if pregexp.ss regular expression exp matches
|
|
||||||
;; | (pregexp exp pat) if result of pregexp-match matches pat
|
|
||||||
;; | (list-no-order pat ...) matches a list with no regard for
|
|
||||||
;; the order of the
|
|
||||||
;; items in the list
|
|
||||||
;; | (list-no-order pat ... pat_n ooo) pat_n matches the remaining
|
|
||||||
;; unmatched items
|
|
||||||
;; | (hash-table (pat_k pat_v) ...) matches the elements of a hash table
|
|
||||||
;; | (hash-table (pat_k pat_v) ... (pat_kn pat_vn) ooo)
|
|
||||||
;; pat_kn must match the remaining
|
|
||||||
;; unmatched key elements
|
|
||||||
;; pat_vn must match the remaining
|
|
||||||
;; unmatched value elements
|
|
||||||
;; | (app field pat) a field of a structure (field is
|
|
||||||
;; an accessor)
|
|
||||||
;; Actually field can be any function
|
|
||||||
;; which can be
|
|
||||||
;; applied to the data being matched.
|
|
||||||
;; Ex: (match 5 ((= add1 b) b)) => 6
|
|
||||||
;;
|
|
||||||
;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
|
|
||||||
;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
|
|
||||||
;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
|
|
||||||
;; | (? predicate pat_1 ... pat_n) if predicate true and all of
|
|
||||||
;; pat_1 thru pat_n match
|
|
||||||
;; | (set! identifier) anything, and binds setter
|
|
||||||
;; | (get! identifier) anything, and binds getter
|
|
||||||
;; | `qp a quasi-pattern
|
|
||||||
;;
|
|
||||||
;; lvp ::= pat ooo greedily matches n or more of pat,
|
|
||||||
;; each element must match pat
|
|
||||||
;; | pat matches pat
|
|
||||||
;;
|
|
||||||
;; ooo ::= ... zero or more
|
|
||||||
;; | ___ zero or more
|
|
||||||
;; | ..k k or more
|
|
||||||
;; | __k k or more
|
|
||||||
;;
|
|
||||||
;; quasi-patterns: matches:
|
|
||||||
;;
|
|
||||||
;; qp ::= () the empty list
|
|
||||||
;; | #t #t
|
|
||||||
;; | #f #f
|
|
||||||
;; | string a string
|
|
||||||
;; | number a number
|
|
||||||
;; | character a character
|
|
||||||
;; | identifier a symbol
|
|
||||||
;; | (qp_1 ... qp_n) list of n elements
|
|
||||||
;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more
|
|
||||||
;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element
|
|
||||||
;; of remainder must match qp_n+1
|
|
||||||
;; | #(qp_1 ... qp_n) vector of n elements
|
|
||||||
;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element
|
|
||||||
;; of remainder must match qp_n+1
|
|
||||||
;; | #&qp box
|
|
||||||
;; | ,pat a pattern
|
|
||||||
;; | ,@(list lvp . . . lvp-n)
|
|
||||||
;; | ,@(list-rest lvp-1 . . . lvp-n pat)
|
|
||||||
;; | ,@`qp qp must evaluate to a list as
|
|
||||||
;; so that this rule resembles the
|
|
||||||
;; above two rules
|
|
||||||
;;
|
|
||||||
;;
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;;
|
|
||||||
|
|
||||||
(module plt-match mzscheme
|
|
||||||
(provide
|
|
||||||
match
|
|
||||||
match-lambda
|
|
||||||
match-lambda*
|
|
||||||
match-let
|
|
||||||
match-let*
|
|
||||||
match-letrec
|
|
||||||
match-define
|
|
||||||
pregexp-match-with-error
|
|
||||||
exn:misc:match?
|
|
||||||
exn:misc:match-value
|
|
||||||
match-equality-test
|
|
||||||
define-match-expander)
|
|
||||||
|
|
||||||
(require "private/match/match-internal-func.ss"
|
|
||||||
"private/match/match-expander.ss"
|
|
||||||
"private/match/match-helper.ss"
|
|
||||||
"private/match/match-error.ss"
|
|
||||||
"private/match/test-no-order.ss")
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(require scheme/match/match)
|
||||||
|
(provide (all-from-out scheme/match/match))
|
||||||
Loading…
Reference in New Issue
Block a user