stxclass cleanup, improved error messages

svn: r12149

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
+syntax browser pane and then clicking one of ``Hide module'', ``Hide
-macro", or "Show macro". The new rule appears in the policy display,
+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
+@;@example[(bound-identifier=? (let ([x 1]) #'x) #'x)]
-(or in the macro stepper, through the Syntax menu). This partitioning
+
-applies only to identifiers. When the user selects an identifier, all
+@subsection{Secondary partitioning}
-terms in the same equivalence class as the selected term are
+
-highlighted in yellow.
+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',
+@subsection{Interpreting syntax}
-      'identifier-transformer-binding', and
-      'identifier-template-binding' in the Help Desk.
 
-  - Source
+The binding information of a syntax object may not be the same as
-
+the binding structure of the program it represents. The binding
-      Displays source location information about the syntax object.
+structure of a program is only determined after macro expansion is
-
-  - 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
 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.

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))]))])))

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) 
+          string<? 
+          #:key symbol->string
+          #: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))]))
+

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])
+  (cond [(rhs:union? rhs)
-    #`(lambda (x arg ...)
+         (with-syntax ([(arg ...) args])
-        (define (fail-rhs x expected reason frontier)
+           #`(lambda (x arg ...)
-          (make-failed x expected reason))
+               (define (fail-rhs x expected reason frontier)
-        #,(parse:pks (list #'x)
+                 (make-failed x expected reason))
-                     (list (empty-frontier #'x))
+               #,(parse:pks (list #'x)
-                     (rhs->pks rhs relsattrs #'x)
+                            (list (empty-frontier #'x))
-                     #'fail-rhs))))
+                            (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) 
-          string<? 
-          #:key symbol->string
-          #: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)
+                            #:pattern (expectation-of-constants
-                                                        (for/list ([d datumpkss])
+                                       (pair? pairpks)
-                                                                  (datumpks-datum d))
+                                       (for/list ([d datumpkss])
-                                                        (for/list ([l literalpkss])
+                                         (datumpks-datum d))
-                                                                  (literalpks-literal l)))
+                                       (for/list ([l literalpkss])
+                                         (literalpks-literal l)))
                             #:fc (car fcs))]))))]
     #;
     [(struct pk ((cons (struct pat:splice (orig-stx attrs depth head tail))

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)
+;; RHSBase is stx (listof SAttr) boolean string/#f
-(define-struct rhs (orig-stx attrs)
+(define-struct rhs (orig-stx attrs transparent? description)
   #:transparent)
 
-;; A RHS is 
+;; A RHS is one of
 ;;   (make-rhs:union <RHSBase> (listof RHS))
-(define-struct (rhs:union rhs) (transparent? description patterns)
+;;   (make-rhs:basic <RHSBase> stx)
+(define-struct (rhs:union rhs) (patterns)
+  #:transparent)
+(define-struct (rhs:basic rhs) (parser)
   #:transparent)
 
 ;; An RHSPattern is
-;;   (make-rhs:pattern <RHSBase> Pattern Env Env (listof SideClause))
+;;   (make-rhs:pattern stx (listof SAttr) Pattern Env Env (listof SideClause))
-(define-struct (rhs:pattern rhs) (pattern decls remap wheres)
+(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 lits0 (assq '#:literals chunks))
-  (define desc (assq '#:description chunks))
+  (define desc0 (assq '#:description chunks))
-  (define trans (assq '#:transparent chunks))
+  (define trans0 (assq '#:transparent chunks))
-  (define literals (if lits (caddr lits) null))
+  (define literals (if lits0 (caddr lits0) null))
-  (define (gather-patterns stx)
+  (define description (and desc0 (caddr desc0)))
-    (syntax-case stx (pattern)
+  (define transparent? (and trans0 #t))
-      [((pattern . _) . rest)
+
-       (cons (parse-rhs-pattern (stx-car stx) allow-unbound? splice? literals)
+  (define (parse-rhs*-basic rest)
-             (gather-patterns #'rest))]
+    (syntax-case rest (basic-syntax-class)
-      [()
+      [((basic-syntax-class ([attr depth] ...) parser-expr))
-       null]))
+       (make rhs:basic stx 
-  (define patterns (gather-patterns rest))
+             (for/list ([attr-stx (syntax->list #'([attr depth] ...))])
-  (when (null? patterns)
+               (syntax-case attr-stx ()
-        (raise-syntax-error #f "syntax class has no variants" ctx))
+                 [(attr depth)
-  (let ([sattrs (intersect-attrss (map rhs-attrs patterns) ctx)])
+                  (begin (unless (and (identifier? #'attr) 
-    (make rhs:union stx sattrs 
+                                      (exact-nonnegative-integer? (syntax-e #'depth)))
-          (and desc (caddr desc)) 
+                           (raise-syntax-error #f "bad attribute declaration" stx attr-stx))
-          (and trans #t)
+                         (make-attr (syntax-e #'attr) (syntax-e #'depth) null))]))
-          patterns)))
+             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)

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-class (name arg ...)
-            (define-syntax name
+       (basic-syntax-class
-              (make sc 'name
+        ([attr-name attr-depth] ...)
-                    '(arg ...)
+        (let ([name parser-expr]) name)))]))
-                    (list (make-attr 'attr-name 'attr-depth null) ...)
-                    ((syntax-local-certifier) #'parser)
-                    #f)))]))
 
 (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)))
+         (let ([fail (syntax-patterns-fail x)])
-           #,(parse:clauses #'clauses #'x #'syntax-patterns-fail)))]))
+           (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)))
+         (let ([fail (syntax-patterns-fail x)])
-           #,(parse:clauses #'clauses #'x #'syntax-patterns-fail)))]))
+           (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)
+    (raise (make-exn:fail:syntax 
-                                 (current-continuation-marks)
+            (if msg
-                                 (list stx))))
+                (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)
+  (cond #;
-         (err (format "missing ~s" expected)
+        [(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 <pattern>"
          (syntax-case x ()
            [(one)
@@ -184,20 +189,22 @@
            [(first . more)
             (err "unexpected terms starting here" #'first)]
            [_
-            (err "expected end of list" x)])]
+            (err "unexpected term" x)])]
-        [expected
+        [(and expected (expectation->string expected))
-         (err (format "~a~a"
+         =>
-                      expected
+         (lambda (msg)
-                      (cond [(zero? n) ""]
+           (err (format "expected ~a~a"
-                            [(= n +inf.0) " after matching main pattern"]
+                        msg
-                            [else (format " after ~s ~a"
+                        (cond [(zero? n) ""]
-                                          n
+                              [(= n +inf.0) " after matching main pattern"]
-                                          (if (= 1 n) "form" "forms"))]))
+                              [else (format " after ~s ~a"
-              stx)]
+                                            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

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)

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"
+         macro-debugger/stxclass/stxclass
-         "lib.ss"
+         (for-syntax scheme/base macro-debugger/stxclass/stxclass))
-         (for-syntax scheme/base "sc.ss" "lib.ss"))
 
 ;; Testing stuff
 
@@ -30,17 +29,17 @@
   (pattern (a b c)))
 
 (define-syntax-class two-or-three/flat
-  (union (pattern (a b))
+  (pattern (a b))
-         (pattern (a b c))))
+  (pattern (a b c)))
 
 (define-syntax-class two-or-three/tag
-  (union (pattern a:two)
+  (pattern a:two)
-         (pattern a:three)))
+  (pattern a:three))
 
 (define-syntax-class two-to-four/untagged
-  (union two
+  (pattern :two)
-         three
+  (pattern :three)
-         (pattern (a b c d))))
+  (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])
-   (pattern ([#:else answer])
+           #:with tests (list #'#t)
-            #:with tests (list #'#t)
+           #:with answers (list #'answer))
-            #:with answers (list #'answer))
+  (pattern ([test answer] . more:cond-clauses)
-   (pattern ([test answer] . more:cond-clauses)
+           #:with tests (cons #'test #'more.tests)
-            #:with tests (cons #'test #'more.tests)
+           #:with answers (cons #'answer #'more.answers))
-            #:with answers (cons #'answer #'more.answers))
+  (pattern ([test #:=> answer] . more:cond-clauses)
-   (pattern ([test #:=> answer] . more:cond-clauses)
+           #:with tests (cons #'test #'more.tests)
-            #:with tests (cons #'test #'more.tests)
+           #:with answers (cons #'answer #'more.answers))
-            #:with answers (cons #'answer #'more.answers))
+  (pattern ()
-   (pattern ()
+           #:with tests null
-            #:with tests null
+           #:with answers null))
-            #:with answers null)))
-
 
 (define-syntax-class zork
   (pattern f:frob))