From 05df5e36e0897fefd1b7049de225153a83195de3 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 27 Oct 2008 22:56:52 +0000 Subject: [PATCH] stxclass cleanup, improved error messages svn: r12149 --- collects/macro-debugger/macro-debugger.scrbl | 103 ++++-------- .../macro-debugger/stxclass/private/kws.ss | 31 +--- .../stxclass/private/messages.ss | 154 ++++++++++++++++++ .../macro-debugger/stxclass/private/parse.ss | 95 +++-------- .../macro-debugger/stxclass/private/rep.ss | 79 ++++++--- .../macro-debugger/stxclass/private/sc.ss | 71 ++++---- .../macro-debugger/stxclass/private/util.ss | 16 ++ .../tests/macro-debugger/tests/stxclass.ss | 51 +++--- 8 files changed, 350 insertions(+), 250 deletions(-) create mode 100644 collects/macro-debugger/stxclass/private/messages.ss diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl index bb2928a227..07df4fee74 100644 --- a/collects/macro-debugger/macro-debugger.scrbl +++ b/collects/macro-debugger/macro-debugger.scrbl @@ -173,7 +173,7 @@ process, and it gives the user controls to step forward or backwards as well as to jump to the beginning or end of the expansion process. If the macro stepper is showing multiple expansions, then it also -provides "Previous term" and "Next term" buttons to go up and down in +provides ``Previous term'' and ``Next term'' buttons to go up and down in the list of expansions. Horizontal lines delimit the current expansion from the others. @@ -186,8 +186,8 @@ shows the expansion of their subterms. The bottom panel of the macro stepper controls the macro hiding policy. The user changes the policy by selecting an identifier in the -syntax browser pane and then clicking one of "Hide module", "Hide -macro", or "Show macro". The new rule appears in the policy display, +syntax browser pane and then clicking one of ``Hide module'', ``Hide +macro'', or ``Show macro''. The new rule appears in the policy display, and the user may later remove it using the "Delete" button. The stepper also offers coarser-grained options that can hide @@ -200,7 +200,9 @@ begin forms are not spliced into module or block bodies, etc. @section{Using the syntax browser} -@subsection{Selection (bold)} +@subsection{Selection} + +The selection is indicated by bold text. The user can click on any part of a subterm to select it. To select a parenthesized subterm, click on either of the parentheses. The @@ -213,7 +215,9 @@ object in the properties panel on the right, when that panel is shown. The selected syntax also determines the highlighting done by the secondary partitioning (see below). -@subsection{Primary partition (foreground color)} +@subsection{Primary partition} + +The primary partition is indicated by foreground color. The primary partitioning always assigns two syntax subterms the same color if they have the same marks. In the absence of unhygienic @@ -225,13 +229,18 @@ Syntax colored in black always corresponds to unmarked syntax. Such syntax may be original, or it may be produced by the expansion of a nonhygienic macro. -@subsection{Secondary partitioning (highlight)} +Note: even terms that have the same marks might not be +@scheme[bound-identifier=?] to each other, because they might occur in +different environments. -The user may select a *secondary partitioning* from a drop-down box -(or in the macro stepper, through the Syntax menu). This partitioning -applies only to identifiers. When the user selects an identifier, all -terms in the same equivalence class as the selected term are -highlighted in yellow. +@;@example[(bound-identifier=? (let ([x 1]) #'x) #'x)] + +@subsection{Secondary partitioning} + +The user may select a secondary partitioning through the Syntax +menu. This partitioning applies only to identifiers. When the user +selects an identifier, all terms in the same equivalence class as the +selected term are highlighted in yellow. The available secondary partitionings are: @itemize{ @@ -259,67 +268,25 @@ The available secondary partitionings are: @subsection{Properties} When the properties pane is shown, it displays properties of the -selected syntax object. The properties pane has three tabbed pages: +selected syntax object. The properties pane has two tabbed pages: - - Binding +@itemize{ +@item{@bold{Term}: If the selection is an identifier, shows the binding information - associated with the syntax object. + associated with the syntax object. For more information, see + @scheme[identifier-binding], etc. +} +@item{@bold{Syntax Object}: - *Note: See the warning in the section below. + Displays source location information and other properties (see + @scheme[syntax-property]) carried by the syntax object. +} +} - For more information, look up 'identifier-binding', - 'identifier-transformer-binding', and - 'identifier-template-binding' in the Help Desk. +@subsection{Interpreting syntax} - - Source - - Displays source location information about the syntax object. - - - Properties - - Displays properties (see 'syntax-property') of the selection - when it has properties it knows the keys for. - -@subsection{Warnings about interpreting syntax} - -The binding information of a *syntax object* may not be the same as -the binding structure of the *program* it represents. The binding -structure of a *program* is only determined after macro expansion is +The binding information of a syntax object may not be the same as +the binding structure of the program it represents. The binding +structure of a program is only determined after macro expansion is complete. - -For example, in @schemeblock[(browse-syntax #'(lambda (foo) foo))] -the syntax browser will report that the inner 'foo' is unbound, even -though in the *program* that this syntax represents, the inner 'foo' -is bound to the outer 'foo'. - -@subsection{Notes and Limitations} - -The syntax browser does not have a way of extending the set of -available secondary partitions. - -The syntax browser does not have a way of extending the set of known -properties. - -The syntax browser does not preserve the distinction between -parentheses and square brackets. - - -@section{Notes for DrScheme language implementors} - -The macro stepper works "out of the box" only with certain languages -out of all the languages available from the DrScheme languages -menu. For example, the macro stepper is disabled for the teaching -languages. - -An implementor of a new DrScheme language can designate their language -"macro-steppable" by overriding the 'enable-macro-stepper?' method of -their implementation of 'drscheme:language:language<%>'. The default -implementation in the mixin provided by -'drscheme:language:get-default-mixin' returns false; override this -method to return true if the macro stepper button should be shown for -this language. - -Note: There is currently no way to customize the behavior of the macro -stepper for different languages. When enabled, the macro stepper sees -exactly those terms that pass through the 'current-eval' handler. diff --git a/collects/macro-debugger/stxclass/private/kws.ss b/collects/macro-debugger/stxclass/private/kws.ss index 571c2076d5..f81393efae 100644 --- a/collects/macro-debugger/stxclass/private/kws.ss +++ b/collects/macro-debugger/stxclass/private/kws.ss @@ -4,7 +4,6 @@ (provide pattern ...* - try with-enclosing-fail enclosing-fail @@ -57,6 +56,7 @@ (raise-syntax-error #f "keyword used out of context" stx)))) (define-keyword pattern) +(define-keyword basic-syntax-class) (define-keyword ...*) (define-keyword ...**) @@ -99,32 +99,3 @@ (make-rename-transformer (quote-syntax failvar)))) expr)) -(define-syntax try - (syntax-rules () - [(try failvar (expr0)) - expr0] - [(try failvar (expr0 . exprs)) - (let ([failvar - (lambda (x1 p1 r1 f1) - (let ([failvar - (lambda (x2 p2 r2 f2) - (choose-error failvar x1 x2 p1 p2 r1 r2 f1 f2))]) - (try failvar exprs)))]) - expr0)])) - -(define (choose-error k x1 x2 p1 p2 r1 r2 frontier1 frontier2) - (define (go1) (k x1 p1 r1 frontier1)) - (define (go2) (k x2 p2 r2 frontier2)) - (let loop ([f1 frontier1] [f2 frontier2]) - (cond [(and (null? f1) (null? f2)) - ;; FIXME: merge - (let ([p (and p1 p2 (format "~a; or ~a" p1 p2))]) - (k x1 p #f frontier1))] - [(and (pair? f1) (null? f2)) (go1)] - [(and (null? f1) (pair? f2)) (go2)] - [(and (pair? f1) (pair? f2)) - (let ([c1 (cadr f1)] - [c2 (cadr f2)]) - (cond [(> c1 c2) (go1)] - [(< c1 c2) (go2)] - [else (loop (cddr f1) (cddr f2))]))]))) diff --git a/collects/macro-debugger/stxclass/private/messages.ss b/collects/macro-debugger/stxclass/private/messages.ss new file mode 100644 index 0000000000..be32cfa81c --- /dev/null +++ b/collects/macro-debugger/stxclass/private/messages.ss @@ -0,0 +1,154 @@ +#lang scheme/base +(require (for-syntax scheme/base "rep.ss") + scheme/match) +(provide (for-syntax expectation-of-stxclass + expectation-of-constants) + try + empty-expectation? + expectation->string) + +(define-struct scdyn (name desc) + #:transparent) + +(define-struct expc (stxclasses pairs? data literals) + #:transparent) + +(begin-for-syntax + (define certify (syntax-local-certifier)) + (define (expectation-of-stxclass stxclass) + (if stxclass + (with-syntax ([name (sc-name stxclass)] + [desc (sc-description stxclass)]) + (certify #'(make-expc (list (make-scdyn 'name 'desc)) #f null null))) + #'#f)) + + (define (expectation-of-constants pairs? data literals) + (with-syntax ([(datum ...) data] + [(literal ...) literals] + [pairs? pairs?]) + (certify + #'(make-expc null 'pairs? (list 'datum ...) (list (quote-syntax literal) ...)))))) + + +(define-syntax try + (syntax-rules () + [(try failvar (expr0)) + expr0] + [(try failvar (expr0 . exprs)) + (let ([failvar + (lambda (x1 p1 r1 f1) + (let ([failvar + (lambda (x2 p2 r2 f2) + (choose-error failvar x1 x2 p1 p2 r1 r2 f1 f2))]) + (try failvar exprs)))]) + expr0)])) + +(define (choose-error k x1 x2 p1 p2 r1 r2 frontier1 frontier2) + (define (go1) (k x1 p1 r1 frontier1)) + (define (go2) (k x2 p2 r2 frontier2)) + (let loop ([f1 frontier1] [f2 frontier2]) + (cond [(and (null? f1) (null? f2)) + (let ([p (merge-expectations p1 p2)]) + (k x1 p #f frontier1))] + [(and (pair? f1) (null? f2)) (go1)] + [(and (null? f1) (pair? f2)) (go2)] + [(and (pair? f1) (pair? f2)) + (let ([c1 (cadr f1)] + [c2 (cadr f2)]) + (cond [(> c1 c2) (go1)] + [(< c1 c2) (go2)] + [else (loop (cddr f1) (cddr f2))]))]))) + +(define (merge-expectations e1 e2) + (make-expc (union (expc-stxclasses e1) (expc-stxclasses e2)) + (or (expc-pairs? e1) (expc-pairs? e2)) + (union (expc-data e1) (expc-data e2)) + (union (expc-literals e1) (expc-literals e2)))) + +(define union append) + +(define (empty-expectation? e) + (match e + [(struct expc (scs pairs? data literals)) + (and (null? scs) + (not pairs?) + (null? literals) + (and (pair? data) (null? (cdr data))) + (equal? (car data) '()))])) + +(define (expectation->string e) + (match e + [(struct expc (_ #t _ _)) + #f] + [(struct expc (stxclasses pairs? data literals)) + (let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))] + [s2 (and (pair? data) (string-of-data data))] + [s3 (and (pair? literals) (string-of-literals literals))] + [s4 (and pairs? string-of-pairs?)]) + (join-sep (filter string? (list s1 s2 s3 s4)) + ";" + "or"))])) + +(define (string-of-stxclasses stxclasses) + (comma-list (map string-of-stxclass stxclasses))) + +(define (string-of-stxclass stxclass) + (and stxclass + (format "~a" + (or (scdyn-desc stxclass) + (scdyn-name stxclass))))) + +(define (string-of-literals literals0) + (define literals + (sort (map syntax-e literals0) + stringstring + #:cache-keys? #t)) + (case (length literals) + [(1) (format "the literal identifier ~s" (car literals))] + [else (format "one of the following literal identifiers: ~a" + (comma-list (map ->string literals)))])) + +(define (string-of-data data) + (case (length data) + [(1) (format "the literal ~s" (car data))] + [else (format "one of the following literals: ~a" + (comma-list (map ->string data)))])) + +(define (->string x) (format "~s" x)) + +(define string-of-pairs? + "structured syntax") + +(define (comma-list items) + (join-sep items "," "or")) + +(define (join-sep items sep0 ult0) + (define sep (string-append sep0 " ")) + (define ult (string-append ult0 " ")) + (define (loop items) + (cond [(null? items) + null] + [(null? (cdr items)) + (list sep ult (car items))] + [else + (list* sep (car items) (loop (cdr items)))])) + (case (length items) + [(2) (format "~a ~a~a" (car items) ult (cadr items))] + [else (let ([strings (list* (car items) (loop (cdr items)))]) + (apply string-append strings))])) + +;; (define (comma-list items0) +;; (define items (for/list ([item items0]) (format "~s" item))) +;; (define (loop items) +;; (cond [(null? items) +;; null] +;; [(null? (cdr items)) +;; (list ", or " (car items))] +;; [else +;; (list* ", " (car items) (loop (cdr items)))])) +;; (case (length items) +;; [(2) (format "~a or ~a" (car items) (cadr items))] +;; [else (let ([strings (list* (car items) (loop (cdr items)))]) +;; (apply string-append strings))])) + diff --git a/collects/macro-debugger/stxclass/private/parse.ss b/collects/macro-debugger/stxclass/private/parse.ss index 16bb4d1f14..dd307096ad 100644 --- a/collects/macro-debugger/stxclass/private/parse.ss +++ b/collects/macro-debugger/stxclass/private/parse.ss @@ -3,7 +3,8 @@ (require (for-template scheme/base syntax/stx scheme/stxparam - "kws.ss") + "kws.ss" + "messages.ss") scheme/match scheme/contract scheme/private/sc @@ -22,7 +23,11 @@ ;; - 'fail' stxparameterized to (non-escaping!) failure procedure (define-struct pk (ps k) #:transparent) -;; A FrontierContext (FC) is ({nat id}*) +;; A FrontierContext (FC) is ({FrontierIndex stx}*) +;; A FrontierIndex is one of +;; - nat +;; - `(+ ,nat expr ...) + (define (empty-frontier x) (list 0 x)) (define (done-frontier x) @@ -46,28 +51,29 @@ (define (frontier->expr fc) #`(list #,@(reverse (or fc null)))) -;; A FrontierContext (FC) is (listof (cons id nat)) - ;; parse:rhs : RHS (listof SAttr) (listof identifier) -> stx ;; Takes a list of the relevant attrs; order is significant! ;; Returns either fail or a list having length same as 'relsattrs' (define (parse:rhs rhs relsattrs args) - (with-syntax ([(arg ...) args]) - #`(lambda (x arg ...) - (define (fail-rhs x expected reason frontier) - (make-failed x expected reason)) - #,(parse:pks (list #'x) - (list (empty-frontier #'x)) - (rhs->pks rhs relsattrs #'x) - #'fail-rhs)))) + (cond [(rhs:union? rhs) + (with-syntax ([(arg ...) args]) + #`(lambda (x arg ...) + (define (fail-rhs x expected reason frontier) + (make-failed x expected reason)) + #,(parse:pks (list #'x) + (list (empty-frontier #'x)) + (rhs->pks rhs relsattrs #'x) + #'fail-rhs)))] + [(rhs:basic? rhs) + (rhs:basic-parser rhs)])) ;; fail : id id #:pattern datum #:reason datum #:fc FC -> stx -(define (fail k x #:pattern [p #f] #:reason [reason #f] #:fc [fc #f]) +(define (fail k x #:pattern [p #'#f] #:reason [reason #f] #:fc [fc #f]) (with-syntax ([k k] [x x] [p p] [reason reason] [fc-expr (frontier->expr fc)]) #`(let ([failcontext fc-expr]) #;(printf "failing at ~s\n" failcontext) - (k x 'p 'reason failcontext)))) + (k x p 'reason failcontext)))) ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs->pks rhs relsattrs main-var) @@ -206,54 +212,6 @@ #`(let-syntax ([failvar (make-rename-transformer (quote-syntax #,failid))]) (try failvar (expr ...))))))])) -(define (report-stxclass stxclass) - (and stxclass - (format "expected ~a" - (or (sc-description stxclass) - (sc-name stxclass))))) - -(define (report-constants pairs? data literals) - (cond [pairs? #f] - [(null? data) - (format "expected ~a" (report-choices-literals literals))] - [(null? literals) - (format "expected ~a" (report-choices-data data))] - [else - (format "expected ~a; or ~a" - (report-choices-data data) - (report-choices-literals literals))])) - -(define (report-choices-literals literals0) - (define literals - (sort (map syntax-e literals0) - stringstring - #:cache-keys? #t)) - (case (length literals) - [(1) (format "the literal identifier ~s" (car literals))] - [else (format "one of the following literal identifiers: ~a" - (comma-list literals))])) - -(define (report-choices-data data) - (case (length data) - [(1) (format "the datum ~s" (car data))] - [else (format "one of the following literals: ~a" - (comma-list data))])) - -(define (comma-list items0) - (define items (for/list ([item items0]) (format "~s" item))) - (define (loop items) - (cond [(null? items) - null] - [(null? (cdr items)) - (list ", or " (car items))] - [else - (list* ", " (car items) (loop (cdr items)))])) - (case (length items) - [(2) (format "~a or ~a" (car items) (cadr items))] - [else (let ([strings (list* (car items) (loop (cdr items)))]) - (apply string-append strings))])) - ;; parse:extpk : (listof identifier) (listof FC) ExtPK identifier -> stx ;; Pre: vars is not empty @@ -270,7 +228,7 @@ (if (ok? r) #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'r) failid) #,(fail failid (car vars) - #:pattern (report-stxclass stxclass) + #:pattern (expectation-of-stxclass stxclass) #:fc (car fcs)))))] [(struct cpks (pairpks datumpkss literalpkss)) (with-syntax ([var0 (car vars)] @@ -324,11 +282,12 @@ [datum-test datum-rhs] ... [else #,(fail failid (car vars) - #:pattern (report-constants (pair? pairpks) - (for/list ([d datumpkss]) - (datumpks-datum d)) - (for/list ([l literalpkss]) - (literalpks-literal l))) + #:pattern (expectation-of-constants + (pair? pairpks) + (for/list ([d datumpkss]) + (datumpks-datum d)) + (for/list ([l literalpkss]) + (literalpks-literal l))) #:fc (car fcs))]))))] #; [(struct pk ((cons (struct pat:splice (orig-stx attrs depth head tail)) diff --git a/collects/macro-debugger/stxclass/private/rep.ss b/collects/macro-debugger/stxclass/private/rep.ss index ae23d0146a..f8ebe38114 100644 --- a/collects/macro-debugger/stxclass/private/rep.ss +++ b/collects/macro-debugger/stxclass/private/rep.ss @@ -10,6 +10,7 @@ (struct-out attr) (struct-out rhs) (struct-out rhs:union) + (struct-out rhs:basic) (struct-out rhs:pattern) (struct-out pattern) (struct-out pat:id) @@ -44,18 +45,21 @@ (define-struct attr (name depth inner) #:transparent) -;; RHSBase is stx (listof SAttr) -(define-struct rhs (orig-stx attrs) +;; RHSBase is stx (listof SAttr) boolean string/#f +(define-struct rhs (orig-stx attrs transparent? description) #:transparent) -;; A RHS is +;; A RHS is one of ;; (make-rhs:union (listof RHS)) -(define-struct (rhs:union rhs) (transparent? description patterns) +;; (make-rhs:basic stx) +(define-struct (rhs:union rhs) (patterns) + #:transparent) +(define-struct (rhs:basic rhs) (parser) #:transparent) ;; An RHSPattern is -;; (make-rhs:pattern Pattern Env Env (listof SideClause)) -(define-struct (rhs:pattern rhs) (pattern decls remap wheres) +;; (make-rhs:pattern stx (listof SAttr) Pattern Env Env (listof SideClause)) +(define-struct rhs:pattern (stx attrs pattern decls remap wheres) #:transparent) ;; A Pattern is one of @@ -230,25 +234,50 @@ (define (parse-rhs* stx allow-unbound? splice? ctx) (define-values (chunks rest) (chunk-kw-seq stx rhs-directive-table #:context ctx)) - (define lits (assq '#:literals chunks)) - (define desc (assq '#:description chunks)) - (define trans (assq '#:transparent chunks)) - (define literals (if lits (caddr lits) null)) - (define (gather-patterns stx) - (syntax-case stx (pattern) - [((pattern . _) . rest) - (cons (parse-rhs-pattern (stx-car stx) allow-unbound? splice? literals) - (gather-patterns #'rest))] - [() - null])) - (define patterns (gather-patterns rest)) - (when (null? patterns) - (raise-syntax-error #f "syntax class has no variants" ctx)) - (let ([sattrs (intersect-attrss (map rhs-attrs patterns) ctx)]) - (make rhs:union stx sattrs - (and desc (caddr desc)) - (and trans #t) - patterns))) + (define lits0 (assq '#:literals chunks)) + (define desc0 (assq '#:description chunks)) + (define trans0 (assq '#:transparent chunks)) + (define literals (if lits0 (caddr lits0) null)) + (define description (and desc0 (caddr desc0))) + (define transparent? (and trans0 #t)) + + (define (parse-rhs*-basic rest) + (syntax-case rest (basic-syntax-class) + [((basic-syntax-class ([attr depth] ...) parser-expr)) + (make rhs:basic stx + (for/list ([attr-stx (syntax->list #'([attr depth] ...))]) + (syntax-case attr-stx () + [(attr depth) + (begin (unless (and (identifier? #'attr) + (exact-nonnegative-integer? (syntax-e #'depth))) + (raise-syntax-error #f "bad attribute declaration" stx attr-stx)) + (make-attr (syntax-e #'attr) (syntax-e #'depth) null))])) + description + transparent? + #'parser-expr)])) + + (define (parse-rhs*-patterns rest) + (define (gather-patterns stx) + (syntax-case stx (pattern) + [((pattern . _) . rest) + (cons (parse-rhs-pattern (stx-car stx) allow-unbound? splice? literals) + (gather-patterns #'rest))] + [() + null])) + (define patterns (gather-patterns rest)) + (when (null? patterns) + (raise-syntax-error #f "syntax class has no variants" ctx)) + (let ([sattrs (intersect-attrss (map rhs:pattern-attrs patterns) ctx)]) + (make rhs:union stx sattrs + description + transparent? + patterns))) + + (syntax-case rest (pattern basic-syntax-class) + [((basic-syntax-class . _)) + (parse-rhs*-basic rest)] + [_ + (parse-rhs*-patterns rest)])) ;; parse-rhs-pattern : stx boolean boolean (listof identifier) -> RHS (define (parse-rhs-pattern stx allow-unbound? splice? literals) diff --git a/collects/macro-debugger/stxclass/private/sc.ss b/collects/macro-debugger/stxclass/private/sc.ss index 0bbd4fd7eb..dc13171f49 100644 --- a/collects/macro-debugger/stxclass/private/sc.ss +++ b/collects/macro-debugger/stxclass/private/sc.ss @@ -8,7 +8,8 @@ "util.ss") scheme/match syntax/stx - "kws.ss") + "kws.ss" + "messages.ss") (provide define-syntax-class define-basic-syntax-class define-basic-syntax-class* @@ -40,12 +41,13 @@ '(arg ...) (rhs-attrs the-rhs) ((syntax-local-certifier) #'parser) - (rhs:union-description the-rhs)))) + (rhs-description the-rhs)))) (define parser (rhs->parser name rhss (arg ...) #,stx)))] [(define-syntax-class name . rhss) (syntax/loc stx (define-syntax-class (name) . rhss))])) + #; (define-syntax (define-syntax-splice-class stx) (syntax-case stx () @@ -87,13 +89,10 @@ [(define-basic-syntax-class* (name arg ...) ([attr-name attr-depth] ...) parser-expr) - (begin (define parser (let ([name parser-expr]) name)) - (define-syntax name - (make sc 'name - '(arg ...) - (list (make-attr 'attr-name 'attr-depth null) ...) - ((syntax-local-certifier) #'parser) - #f)))])) + (define-syntax-class (name arg ...) + (basic-syntax-class + ([attr-name attr-depth] ...) + (let ([name parser-expr]) name)))])) (define-syntax (rhs->parser stx) (syntax-case stx () @@ -141,15 +140,17 @@ (syntax-case stx () [(syntax-parser . clauses) #`(lambda (x) - (parameterize ((current-expression (or (current-expression) x))) - #,(parse:clauses #'clauses #'x #'syntax-patterns-fail)))])) + (let ([fail (syntax-patterns-fail x)]) + (parameterize ((current-expression (or (current-expression) x))) + #,(parse:clauses #'clauses #'x #'fail))))])) (define-syntax (syntax-parse stx) (syntax-case stx () [(syntax-parse expr . clauses) #`(let ([x expr]) - (parameterize ((current-expression (or (current-expression) x))) - #,(parse:clauses #'clauses #'x #'syntax-patterns-fail)))])) + (let ([fail (syntax-patterns-fail x)]) + (parameterize ((current-expression (or (current-expression) x))) + #,(parse:clauses #'clauses #'x #'fail))))])) (define-syntax with-patterns (syntax-rules () @@ -158,14 +159,18 @@ [(with-patterns ([p x] . more) . b) (syntax-parse x [p (with-patterns more . b)])])) -(define (syntax-patterns-fail x expected reason frontier) +(define ((syntax-patterns-fail stx0) x expected reason frontier) (define (err msg stx) - (raise (make-exn:fail:syntax (string->immutable-string msg) - (current-continuation-marks) - (list stx)))) + (raise (make-exn:fail:syntax + (if msg + (string->immutable-string (string-append "bad syntax: " msg)) + (string->immutable-string "bad syntax")) + (current-continuation-marks) + (list stx)))) (define-values (stx n) (frontier->syntax frontier)) - (cond [(stx-null? x) - (err (format "missing ~s" expected) + (cond #; + [(and (stx-null? x) expected) + (err (format "missing ~s" (expectation->string expected)) (datum->syntax stx x (list (syntax-source stx) #f @@ -176,7 +181,7 @@ (syntax-span stx) -1)) 1)))] - [(equal? expected '()) + [(empty-expectation? expected) ;; FIXME: "extra term(s) after " (syntax-case x () [(one) @@ -184,20 +189,22 @@ [(first . more) (err "unexpected terms starting here" #'first)] [_ - (err "expected end of list" x)])] - [expected - (err (format "~a~a" - expected - (cond [(zero? n) ""] - [(= n +inf.0) " after matching main pattern"] - [else (format " after ~s ~a" - n - (if (= 1 n) "form" "forms"))])) - stx)] + (err "unexpected term" x)])] + [(and expected (expectation->string expected)) + => + (lambda (msg) + (err (format "expected ~a~a" + msg + (cond [(zero? n) ""] + [(= n +inf.0) " after matching main pattern"] + [else (format " after ~s ~a" + n + (if (= 1 n) "form" "forms"))])) + stx))] [reason - (format "~a" reason)] + (err (format "~a" reason) stx)] [else - (err "failed" stx)])) + (err #f stx0)])) (define (frontier->syntax f) (match f diff --git a/collects/macro-debugger/stxclass/private/util.ss b/collects/macro-debugger/stxclass/private/util.ss index 5850779082..af88bb003c 100644 --- a/collects/macro-debugger/stxclass/private/util.ss +++ b/collects/macro-debugger/stxclass/private/util.ss @@ -8,6 +8,10 @@ (provide make + with-temporaries + generate-temporary + generate-n-temporaries + chunk-kw-seq/no-dups chunk-kw-seq reject-duplicate-chunks @@ -48,6 +52,18 @@ (with-syntax ([constructor constructor]) #'(constructor expr ...)))])) +(define-syntax-rule (with-temporaries (temp-name ...) . body) + (with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))]) + . body)) + +(define (generate-temporary [stx 'g]) + (car (generate-temporaries (list stx)))) + +(define (generate-n-temporaries n) + (generate-temporaries + (for/list ([i (in-range n)]) + (string->symbol (format "g~sx" i))))) + (define (chunk-kw-seq/no-dups stx kws #:context [ctx #f]) (let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)]) (reject-duplicate-chunks chunks) diff --git a/collects/tests/macro-debugger/tests/stxclass.ss b/collects/tests/macro-debugger/tests/stxclass.ss index 6742b98d80..c52c58fd61 100644 --- a/collects/tests/macro-debugger/tests/stxclass.ss +++ b/collects/tests/macro-debugger/tests/stxclass.ss @@ -2,9 +2,8 @@ (require (planet "test.ss" ("schematics" "schemeunit.plt" 2 9)) (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2 9)) - "sc.ss" - "lib.ss" - (for-syntax scheme/base "sc.ss" "lib.ss")) + macro-debugger/stxclass/stxclass + (for-syntax scheme/base macro-debugger/stxclass/stxclass)) ;; Testing stuff @@ -30,17 +29,17 @@ (pattern (a b c))) (define-syntax-class two-or-three/flat - (union (pattern (a b)) - (pattern (a b c)))) + (pattern (a b)) + (pattern (a b c))) (define-syntax-class two-or-three/tag - (union (pattern a:two) - (pattern a:three))) + (pattern a:two) + (pattern a:three)) (define-syntax-class two-to-four/untagged - (union two - three - (pattern (a b c d)))) + (pattern :two) + (pattern :three) + (pattern (a b c d))) (define-syntax-class xs (pattern (x ...))) @@ -226,18 +225,18 @@ (loop ns -inf.0)) (define-syntax madd1 - (syntax-patterns + (syntax-parser [(_ e:expr/num) #'(+ 1 e)])) (define-syntax mapp-to-1 - (syntax-patterns + (syntax-parser [(_ e) #:declare e expr/num->num #'(e 1)])) (define-syntax bad-mapp-to-1 - (syntax-patterns + (syntax-parser [(_ e:expr/num->num) #'(e 'whoa)])) @@ -253,20 +252,18 @@ #:declare e (expr/c #'number?))) (define-syntax-class cond-clauses - (union - (pattern ([#:else answer]) - #:with tests (list #'#t) - #:with answers (list #'answer)) - (pattern ([test answer] . more:cond-clauses) - #:with tests (cons #'test #'more.tests) - #:with answers (cons #'answer #'more.answers)) - (pattern ([test #:=> answer] . more:cond-clauses) - #:with tests (cons #'test #'more.tests) - #:with answers (cons #'answer #'more.answers)) - (pattern () - #:with tests null - #:with answers null))) - + (pattern ([#:else answer]) + #:with tests (list #'#t) + #:with answers (list #'answer)) + (pattern ([test answer] . more:cond-clauses) + #:with tests (cons #'test #'more.tests) + #:with answers (cons #'answer #'more.answers)) + (pattern ([test #:=> answer] . more:cond-clauses) + #:with tests (cons #'test #'more.tests) + #:with answers (cons #'answer #'more.answers)) + (pattern () + #:with tests null + #:with answers null)) (define-syntax-class zork (pattern f:frob))