suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

stxclass cleanup, improved error messages

Browse Source 
svn: r12149
This commit is contained in:
Ryan Culpepper 2008-10-27 22:56:52 +00:00
parent 0c44c5ce40
commit 05df5e36e0
8 changed files with 350 additions and 250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
collects/macro-debugger/macro-debugger.scrbl
View File

@ -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.

31
collects/macro-debugger/stxclass/private/kws.ss
View File

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

154
collects/macro-debugger/stxclass/private/messages.ss Normal file
View File

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

73
collects/macro-debugger/stxclass/private/parse.ss
View File

@ -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,12 +51,11 @@
(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)
(cond [(rhs:union? rhs)
(with-syntax ([(arg ...) args])
#`(lambda (x arg ...)
(define (fail-rhs x expected reason frontier)
@ -59,15 +63,17 @@
#,(parse:pks (list #'x)
(list (empty-frontier #'x))
(rhs->pks rhs relsattrs #'x)
#'fail-rhs))))
#'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,7 +282,8 @@
[datum-test datum-rhs] ...
[else
#,(fail failid (car vars)
#:pattern (report-constants (pair? pairpks)
#:pattern (expectation-of-constants
(pair? pairpks)
(for/list ([d datumpkss])
(datumpks-datum d))
(for/list ([l literalpkss])

55
collects/macro-debugger/stxclass/private/rep.ss
View File

@ -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 <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))
(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,10 +234,29 @@
(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 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)
@ -244,12 +267,18 @@
(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)])
(let ([sattrs (intersect-attrss (map rhs:pattern-attrs patterns) ctx)])
(make rhs:union stx sattrs
(and desc (caddr desc))
(and trans #t)
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)
(syntax-case stx (pattern)

53
collects/macro-debugger/stxclass/private/sc.ss
View File

@ -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)
(let ([fail (syntax-patterns-fail x)])
(parameterize ((current-expression (or (current-expression) x)))
#,(parse:clauses #'clauses #'x #'syntax-patterns-fail)))]))
#,(parse:clauses #'clauses #'x #'fail))))]))
(define-syntax (syntax-parse stx)
(syntax-case stx ()
[(syntax-parse expr . clauses)
#`(let ([x expr])
(let ([fail (syntax-patterns-fail x)])
(parameterize ((current-expression (or (current-expression) x)))
#,(parse:clauses #'clauses #'x #'syntax-patterns-fail)))]))
#,(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
(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 <pattern>"
(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
(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)]
stx))]
[reason
(format "~a" reason)]
(err (format "~a" reason) stx)]
[else
(err "failed" stx)]))
(err #f stx0)]))
(define (frontier->syntax f)
(match f

16
collects/macro-debugger/stxclass/private/util.ss
View File

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

29
collects/tests/macro-debugger/tests/stxclass.ss
View File

@ -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,7 +252,6 @@
#:declare e (expr/c #'number?)))
(define-syntax-class cond-clauses
(union
(pattern ([#:else answer])
#:with tests (list #'#t)
#:with answers (list #'answer))
@ -265,8 +263,7 @@
#:with answers (cons #'answer #'more.answers))
(pattern ()
#:with tests null
#:with answers null)))
#:with answers null))
(define-syntax-class zork
(pattern f:frob))