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

syntax/parse: eliminate old minimatch struct syntaxes

Browse Source
This commit is contained in:
Ryan Culpepper 2012-03-21 07:27:10 -06:00
parent 6c369f2563
commit df265ddc67
3 changed files with 30 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/syntax/parse/private/minimatch.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require unstable/struct
(for-syntax racket/base racket/struct-info unstable/struct))
(provide match make ?)
(provide match ?)
(define-syntax (match stx)
(syntax-case stx ()
@ -25,7 +25,7 @@
;; (match-p id Pattern SuccessExpr FailureExpr)
(define-syntax (match-p stx)
(syntax-case stx (quote cons list vector make struct ?)
(syntax-case stx (quote cons list vector STRUCT ?)
[(match-p x wildcard success failure)
(and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_))
#'success]
@ -51,9 +51,7 @@
[(match-p x var success failure)
(identifier? #'var)
#'(let ([var x]) success)]
[(match-p x (make S p ...) success failure)
#'(match-p x (struct S (p ...)) success failure)]
[(match-p x (struct S (p ...)) success failure)
[(match-p x (STRUCT S (p ...)) success failure)
(identifier? #'S)
(let ()
(define (not-a-struct)
@ -79,7 +77,7 @@
[(match-p x (S p ...) success failure)
(identifier? #'S)
(if (struct-info? (syntax-local-value #'S (lambda () #f)))
#'(match-p x (struct S (p ...)) success failure)
#'(match-p x (STRUCT S (p ...)) success failure)
(raise-syntax-error #f "bad minimatch form" stx #'S))]
[(match-p x s success failure)
(prefab-struct-key (syntax-e #'s))
@ -99,11 +97,8 @@
[(match-p* ((x1 p1) . rest) success failure)
(match-p x1 p1 (match-p* rest success failure) failure)]))
#;
(define-syntax struct
(lambda (stx)
(raise-syntax-error #f "illegal use of keyword" stx)))
(define-syntax ?
(lambda (stx)
(raise-syntax-error #f "illegal use of minimatch form '?'" stx)))
(define-syntax STRUCT #f) ;; internal keyword

9
collects/syntax/parse/private/rep-data.rkt
View File

@ -5,6 +5,7 @@
syntax/private/id-table
racket/syntax
syntax/parse/private/residual-ct ;; keep abs. path
unstable/struct
"minimatch.rkt"
"kws.rkt"
"rep-attrs.rkt"
@ -126,23 +127,23 @@ expressions are duplicated, and may be evaluated in different scopes.
;; So blame-declare? only applies to stxclass declares
(let ([val (declenv-lookup env id #:use-conventions? #f)])
(match val
[(struct den:lit (_i _e _ip _lp))
[(den:lit _i _e _ip _lp)
(wrong-syntax id "identifier previously declared as literal")]
[(struct den:magic-class (name _c _a _r))
[(den:magic-class name _c _a _r)
(if (and blame-declare? stxclass-name)
(wrong-syntax name
"identifier previously declared with syntax class ~a"
stxclass-name)
(wrong-syntax (if blame-declare? name id)
"identifier previously declared"))]
[(struct den:class (name _c _a))
[(den:class name _c _a)
(if (and blame-declare? stxclass-name)
(wrong-syntax name
"identifier previously declared with syntax class ~a"
stxclass-name)
(wrong-syntax (if blame-declare? name id)
"identifier previously declared"))]
[(struct den:parser (_p _a _sp _c _dc?))
[(den:parser _p _a _sp _c _dc?)
(wrong-syntax id "(internal error) late unbound check")]
['#f (void)])))

38
collects/syntax/parse/private/rep.rkt
View File

@ -258,11 +258,11 @@
;; FIXME: replace with txlift mechanism
(define (create-aux-def entry)
(match entry
[(struct den:lit (_i _e _ip _lp))
[(den:lit _i _e _ip _lp)
(values entry null)]
[(struct den:magic-class (name class argu role))
[(den:magic-class name class argu role)
(values entry null)]
[(struct den:class (name class argu))
[(den:class name class argu)
;; FIXME: integrable syntax classes?
(cond [(identifier? name)
(let* ([pos-count (length (arguments-pargs argu))]
@ -283,9 +283,9 @@
(values (make den:delayed #'parser class)
(list #`(define-values (parser)
(curried-stxclass-parser #,class #,argu)))))])]
[(struct den:parser (_p _a _sp _c _dc?))
[(den:parser _p _a _sp _c _dc?)
(values entry null)]
[(struct den:delayed (_p _c))
[(den:delayed _p _c)
(values entry null)]))
(define (append-lits+litsets lits litsets)
@ -361,18 +361,18 @@
(create-action:and
(for/list ([side (in-list sides)])
(match side
[(make clause:fail condition message)
[(clause:fail condition message)
(create-action:post
(create-action:fail condition message))]
[(make clause:with wpat expr defs)
[(clause:with wpat expr defs)
(let ([ap (create-action:post
(create-action:parse wpat expr))])
(if (pair? defs)
(create-action:and (list (create-action:do defs) ap))
ap))]
[(make clause:attr attr expr)
[(clause:attr attr expr)
(create-action:bind (list side))]
[(make clause:do stmts)
[(clause:do stmts)
(create-action:do stmts)]))))
(define dummy-pattern
(and (pair? sides)
@ -607,18 +607,18 @@
(define (parse-pat:id id decls allow-head?)
(define entry (declenv-lookup decls id))
(match entry
[(struct den:lit (internal literal input-phase lit-phase))
[(den:lit internal literal input-phase lit-phase)
(create-pat:literal literal input-phase lit-phase)]
[(struct den:magic-class (name class argu role))
[(den:magic-class name class argu role)
(let* ([pos-count (length (arguments-pargs argu))]
[kws (arguments-kws argu)]
[sc (get-stxclass/check-arity class class pos-count kws)])
(parse-pat:var* id allow-head? id sc argu "." role #f))]
[(struct den:class (_n _c _a))
[(den:class _n _c _a)
(error 'parse-pat:id
"(internal error) decls had leftover stxclass entry: ~s"
entry)]
[(struct den:parser (parser attrs splicing? commit? delimit-cut?))
[(den:parser parser attrs splicing? commit? delimit-cut?)
(check-no-delimit-cut-in-not id delimit-cut?)
(cond [splicing?
(unless allow-head?
@ -626,7 +626,7 @@
(parse-pat:id/h id parser no-arguments attrs commit? "." #f)]
[else
(parse-pat:id/s id parser no-arguments attrs commit? "." #f)])]
[(struct den:delayed (parser class))
[(den:delayed parser class)
(let ([sc (get-stxclass class)])
(parse-pat:var* id allow-head? id sc no-arguments "." #f parser))]
['#f
@ -994,15 +994,15 @@
(define (check-list-pattern pattern stx)
(match pattern
[(make pat:datum _base '())
[(pat:datum _base '())
#t]
[(make pat:head _base _head tail)
[(pat:head _base _head tail)
(check-list-pattern tail stx)]
[(make pat:action _base _action tail)
[(pat:action _base _action tail)
(check-list-pattern tail stx)]
[(make pat:dots _base _head tail)
[(pat:dots _base _head tail)
(check-list-pattern tail stx)]
[(make pat:pair _base _head tail)
[(pat:pair _base _head tail)
(check-list-pattern tail stx)]
[_
(wrong-syntax stx "expected proper list pattern")]))