From 14089e0ac6128d2f001c0e5e23f323dd1e77dd91 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 29 Feb 2012 02:37:06 -0700 Subject: [PATCH] syntax/parse: clean up integrable stxclass code --- collects/syntax/parse/private/lib.rkt | 53 +++++++++++-------- collects/syntax/parse/private/parse.rkt | 6 +-- .../syntax/parse/private/rep-patterns.rkt | 8 +-- collects/syntax/parse/private/rep.rkt | 8 +-- collects/syntax/parse/private/residual.rkt | 16 ++---- 5 files changed, 44 insertions(+), 47 deletions(-) diff --git a/collects/syntax/parse/private/lib.rkt b/collects/syntax/parse/private/lib.rkt index c2b776c894..f330be95d8 100644 --- a/collects/syntax/parse/private/lib.rkt +++ b/collects/syntax/parse/private/lib.rkt @@ -1,7 +1,6 @@ #lang racket/base (require "sc.rkt" "keywords.rkt" - syntax/parse/private/residual ;; keep abs. (for-syntax racket/base)) (provide identifier @@ -22,41 +21,49 @@ expr static) + +(define (expr-stx? x) + (not (keyword-stx? x))) + +(define ((stxof pred?) x) (and (syntax? x) (pred? (syntax-e x)))) +(define keyword-stx? (stxof keyword?)) +(define boolean-stx? (stxof boolean?)) +(define string-stx? (stxof string?)) +(define char-stx? (stxof char?)) +(define number-stx? (stxof number?)) +(define integer-stx? (stxof integer?)) +(define exact-integer-stx? (stxof exact-integer?)) +(define exact-nonnegative-integer-stx? (stxof exact-nonnegative-integer?)) +(define exact-positive-integer-stx? (stxof exact-positive-integer?)) + ;; == Integrable syntax classes == (define-integrable-syntax-class identifier (quote "identifier") identifier?) (define-integrable-syntax-class expr (quote "expression") expr-stx?) (define-integrable-syntax-class keyword (quote "keyword") keyword-stx?) - -;; == Normal syntax classes == - -(define-syntax-rule (define-pred-stxclass name pred) - (define-syntax-class name #:attributes () #:opaque #:commit - (pattern (~and x (~fail #:unless (pred (syntax-e #'x))))))) - -;;(define-pred-stxclass identifier symbol?) -;;(define-pred-stxclass keyword keyword?) -(define-pred-stxclass boolean boolean?) -(define-pred-stxclass character char?) - -(define-syntax-class str #:attributes () #:opaque #:commit - #:description "string" - (pattern (~and x (~fail #:unless (string? (syntax-e #'x)))))) - -(define-pred-stxclass number number?) -(define-pred-stxclass integer integer?) -(define-pred-stxclass exact-integer exact-integer?) -(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?) -(define-pred-stxclass exact-positive-integer exact-positive-integer?) +(define-integrable-syntax-class boolean (quote "boolean") boolean-stx?) +(define-integrable-syntax-class character (quote "character") char-stx?) +(define-integrable-syntax-class str (quote "string") string-stx?) +(define-integrable-syntax-class number (quote "number") number-stx?) +(define-integrable-syntax-class integer (quote "integer") integer-stx?) +(define-integrable-syntax-class exact-integer (quote "exact-integer") exact-integer-stx?) +(define-integrable-syntax-class exact-nonnegative-integer + (quote "exact-nonnegative-integer") + exact-nonnegative-integer-stx?) +(define-integrable-syntax-class exact-positive-integer + (quote "exact-positive-integer") + exact-positive-integer-stx?) ;; Aliases (define-syntax id (make-rename-transformer #'identifier)) (define-syntax nat (make-rename-transformer #'exact-nonnegative-integer)) (define-syntax char (make-rename-transformer #'character)) +;; == Normal syntax classes == + (define notfound (box 'notfound)) -(define-syntax-class (static pred name) +(define-syntax-class (static pred [name #f]) #:attributes (value) #:description name #:commit diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index 85e5e5f494..d75b3fc206 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -563,13 +563,13 @@ Conventions: [#s(pat:post attrs pattern) #`(let ([pr (ps-add-post pr)]) (parse:S x cx pattern pr es k))] - [#s(pat:integrated _attrs name argu predicate description) + [#s(pat:integrated _attrs name predicate description) (with-syntax ([(name-attr ...) (if (identifier? #'name) #'([#s(attr name 0 #t) x*]) #'())]) #'(let ([x* (datum->syntax cx x cx)]) - (if (app-argu predicate x* argu) + (if (predicate x*) (let-attributes (name-attr ...) k) (let ([es (cons (expect:thing 'description #t) es)]) (fail (failure pr es))))))])])) @@ -818,7 +818,7 @@ Conventions: (else (fail result))))] ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr [(parse:dots x cx (#s(ehpat (attr0) - #s(pat:integrated _attrs _name _argu pred? desc) + #s(pat:integrated _attrs _name pred? desc) #f)) #s(pat:datum () ()) pr es k) #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc)]) diff --git a/collects/syntax/parse/private/rep-patterns.rkt b/collects/syntax/parse/private/rep-patterns.rkt index 8b37f6cd3e..1cff8382b6 100644 --- a/collects/syntax/parse/private/rep-patterns.rkt +++ b/collects/syntax/parse/private/rep-patterns.rkt @@ -40,7 +40,7 @@ A SinglePattern is one of (pat:commit Base SinglePattern) (pat:reflect Base stx Arguments (listof SAttr) id (listof IAttr)) (pat:post Base SinglePattern) - (pat:integrated Base id/#f Arguments id string) + (pat:integrated Base id/#f id string) A ListPattern is a subtype of SinglePattern; one of (pat:datum Base '()) @@ -69,7 +69,7 @@ A ListPattern is a subtype of SinglePattern; one of (define-struct pat:commit (attrs pattern) #:prefab) (define-struct pat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab) (define-struct pat:post (attrs pattern) #:prefab) -(define-struct pat:integrated (attrs name argu predicate description) #:prefab) +(define-struct pat:integrated (attrs name predicate description) #:prefab) #| A ActionPattern is one of @@ -306,9 +306,9 @@ A SideClause is one of (define (create-pat:post pattern) (make pat:post (pattern-attrs pattern) pattern)) -(define (create-pat:integrated name argu predicate description) +(define (create-pat:integrated name predicate description) (let ([attrs (if name (list (make attr name 0 #t)) null)]) - (make pat:integrated attrs name argu predicate description))) + (make pat:integrated attrs name predicate description))) ;; ---- diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt index f8e37d9000..7b9dfea3ba 100644 --- a/collects/syntax/parse/private/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -704,8 +704,8 @@ (define (parse-pat:var* stx allow-head? name sc argu [pfx "."]) (check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc)) (cond [(stxclass/s? sc) - (if (and (stxclass-integrate sc) (null? (arguments-kws argu))) - (parse-pat:id/s/integrate name (stxclass-integrate sc) argu) + (if (and (stxclass-integrate sc) (equal? argu no-arguments)) + (parse-pat:id/s/integrate name (stxclass-integrate sc)) (parse-pat:id/s name (stxclass-parser sc) argu @@ -727,9 +727,9 @@ (define bind (name->bind name)) (create-pat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit?)) -(define (parse-pat:id/s/integrate name integrate argu) +(define (parse-pat:id/s/integrate name integrate) (define bind (name->bind name)) - (create-pat:integrated bind argu + (create-pat:integrated bind (integrate-predicate integrate) (integrate-description integrate))) diff --git a/collects/syntax/parse/private/residual.rkt b/collects/syntax/parse/private/residual.rkt index 60b7272060..a51bbfe136 100644 --- a/collects/syntax/parse/private/residual.rkt +++ b/collects/syntax/parse/private/residual.rkt @@ -193,21 +193,11 @@ ["runtime-report.rkt" (syntax-patterns-fail)]) -;; == predicates and parsers - -(provide keyword-stx? - expr-stx? - predicate-ellipsis-parser) - -(define (keyword-stx? x) - (and (syntax? x) (keyword? (syntax-e x)))) - -(define (expr-stx? x) - (not (keyword-stx? x))) - -;; Specialized ellipsis parser +;; == specialized ellipsis parser ;; returns (values 'ok attr-values) or (values 'fail failure) +(provide predicate-ellipsis-parser) + (define (predicate-ellipsis-parser x cx pr es pred? desc) (let ([elems (stx->list x)]) (if (and elems (andmap pred? elems))