From c082f130cb5e151be72ac8a4003a960bd9c47d04 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 16 May 2017 18:21:22 -0400 Subject: [PATCH] support string, bytes (bindings from racket) as stxclass refs add compile-time table as alternative to stxclass binding --- .../syntax/scribblings/parse/lib.scrbl | 16 +++++++++++++++- pkgs/racket-test/tests/stxparse/test.rkt | 9 +++++++++ racket/collects/syntax/parse/private/lib.rkt | 13 ++++++++++++- .../collects/syntax/parse/private/rep-data.rkt | 6 ++++++ .../syntax/parse/private/residual-ct.rkt | 6 ++++++ 5 files changed, 48 insertions(+), 2 deletions(-) diff --git a/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl index 213fe61e7b..c489bca67c 100644 --- a/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl @@ -31,7 +31,6 @@ actually a valid expression. @deftogether[( @defstxclass[identifier] @defstxclass[boolean] -@defstxclass[str] @defstxclass[char] @defstxclass[keyword] @defstxclass[number] @@ -43,8 +42,23 @@ actually a valid expression. Match syntax satisfying the corresponding predicates. } +@deftogether[[ +@defidform[#:kind "syntax class" #:link-target? #f + string] +@defidform[#:kind "syntax class" #:link-target? #f + bytes] +]]{ + +As special cases, Racket's @racket[string] and @racket[bytes] bindings +are also interpreted as syntax classes that recognize literal strings +and bytes, respectively. + +@history[#:added "6.9.0.4"] +} + @defstxclass[id]{ Alias for @racket[identifier]. } @defstxclass[nat]{ Alias for @racket[exact-nonnegative-integer]. } +@defstxclass[str]{ Alias for @racket[string]. } @defstxclass[(static [predicate (-> any/c any/c)] [description (or/c string? #f)])]{ diff --git a/pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-test/tests/stxparse/test.rkt index 831a7dc7f4..0f89965f02 100644 --- a/pkgs/racket-test/tests/stxparse/test.rkt +++ b/pkgs/racket-test/tests/stxparse/test.rkt @@ -505,6 +505,15 @@ ;; == Lib tests +;; test string, bytes act as stxclasses + +(test-case "string, bytes act as stxclasses" + (check-equal? (syntax->datum + (syntax-parse #'(#"a" #"b" "c" "d") + [(b:bytes ... s:string ...) + #'((b ...) (s ...))])) + '((#"a" #"b") ("c" "d")))) + ;; static (tcerr "static: correct error" diff --git a/racket/collects/syntax/parse/private/lib.rkt b/racket/collects/syntax/parse/private/lib.rkt index f330be95d8..f1374b60cf 100644 --- a/racket/collects/syntax/parse/private/lib.rkt +++ b/racket/collects/syntax/parse/private/lib.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "sc.rkt" "keywords.rkt" + (for-syntax syntax/parse/private/residual-ct) (for-syntax racket/base)) (provide identifier @@ -29,6 +30,7 @@ (define keyword-stx? (stxof keyword?)) (define boolean-stx? (stxof boolean?)) (define string-stx? (stxof string?)) +(define bytes-stx? (stxof bytes?)) (define char-stx? (stxof char?)) (define number-stx? (stxof number?)) (define integer-stx? (stxof integer?)) @@ -36,6 +38,7 @@ (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?) @@ -43,7 +46,6 @@ (define-integrable-syntax-class keyword (quote "keyword") keyword-stx?) (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?) @@ -54,10 +56,19 @@ (quote "exact-positive-integer") exact-positive-integer-stx?) +(define-integrable-syntax-class -string (quote "string") string-stx?) +(define-integrable-syntax-class -bytes (quote "bytes") bytes-stx?) +(begin-for-syntax + (set-box! alt-stxclass-mapping + (list (cons #'string (syntax-local-value #'-string)) + (cons #'bytes (syntax-local-value #'-bytes))))) + ;; Aliases (define-syntax id (make-rename-transformer #'identifier)) (define-syntax nat (make-rename-transformer #'exact-nonnegative-integer)) (define-syntax char (make-rename-transformer #'character)) +(define-syntax str (make-rename-transformer #'-string)) + ;; == Normal syntax classes == diff --git a/racket/collects/syntax/parse/private/rep-data.rkt b/racket/collects/syntax/parse/private/rep-data.rkt index 702b279793..3bed4c7f20 100644 --- a/racket/collects/syntax/parse/private/rep-data.rkt +++ b/racket/collects/syntax/parse/private/rep-data.rkt @@ -240,11 +240,17 @@ expressions are duplicated, and may be evaluated in different scopes. ;; otherwise, just a var (define stxclass-colon-notation? (make-parameter #t)) +;; get-stxclass : Identifier -> Stxclass +;; Stxclasses are primarily bound by env / syntax-local-value, but a few +;; are attached to existing bindings via alt-stxclass-mapping. + (define (get-stxclass id) (define config (stxclass-lookup-config)) (if (eq? config 'no) (make-dummy-stxclass id) (cond [(syntax-local-value/record id stxclass?) => values] + [(assoc id (unbox alt-stxclass-mapping) free-identifier=?) + => cdr] [(eq? config 'try) (make-dummy-stxclass id)] [else (wrong-syntax id "not defined as syntax class")]))) diff --git a/racket/collects/syntax/parse/private/residual-ct.rkt b/racket/collects/syntax/parse/private/residual-ct.rkt index bdd896322f..9d9924b353 100644 --- a/racket/collects/syntax/parse/private/residual-ct.rkt +++ b/racket/collects/syntax/parse/private/residual-ct.rkt @@ -11,6 +11,7 @@ (struct-out den:lit) (struct-out den:datum-lit) (struct-out den:delayed) + alt-stxclass-mapping log-syntax-parse-error log-syntax-parse-warning log-syntax-parse-info @@ -39,6 +40,11 @@ inline ;; Id/#f, reference to a predicate ) #:prefab) +;; alt-stxclass-mapping : (boxof (listof (pair Identifier Stxclass))) +;; Maps existing bindings (can't use syntax-local-value mechanism) to stxclasses. +;; Uses alist to avoid residual dependence on syntax/id-table. +(define alt-stxclass-mapping (box null)) + ;; A scopts is #s(scopts Nat Bool Bool String/#f) ;; These are passed on to var patterns. (define-struct scopts