From daba183b087e841b4ad7d4e96b8383e784392b4b Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 9 Nov 2009 02:33:43 +0000 Subject: [PATCH] unstable/syntax: added format-id svn: r16629 --- .../macro-debugger/model/yacc-interrupted.ss | 35 +++++------ collects/macro-debugger/util/class-iop.ss | 4 +- collects/macro-debugger/util/notify.ss | 58 ++++++++----------- collects/syntax/private/id-table.ss | 6 +- .../syntax/private/stxparse/rep-patterns.ss | 10 ++-- collects/syntax/private/stxparse/rep.ss | 5 +- collects/syntax/private/stxparse/sc.ss | 5 +- collects/unstable/scribblings/syntax.scrbl | 33 ++++++++++- collects/unstable/syntax.ss | 14 ++++- 9 files changed, 94 insertions(+), 76 deletions(-) diff --git a/collects/macro-debugger/model/yacc-interrupted.ss b/collects/macro-debugger/model/yacc-interrupted.ss index f83832b321..7d7c491f31 100644 --- a/collects/macro-debugger/model/yacc-interrupted.ss +++ b/collects/macro-debugger/model/yacc-interrupted.ss @@ -1,7 +1,8 @@ #lang scheme/base -(require (for-syntax scheme/base) - (for-syntax mzlib/etc) +(require (for-syntax scheme/base + mzlib/etc + unstable/syntax) "yacc-ext.ss") (provide ! ? !! define-production-splitter @@ -50,26 +51,18 @@ (raise-syntax-error 'split "bad grammar option or alternate" #'other)]) (values options (reverse alts))))) -(define-for-syntax (symbol+ . args) - (define (norm x) - (cond [(identifier? x) (norm (syntax-e x))] - [(string? x) x] - [(number? x) (number->string x)] - [(symbol? x) (symbol->string x)])) - (string->symbol (apply string-append (map norm args)))) - (define-for-syntax (I symbol) (syntax-local-introduce (syntax-local-get-shadower (datum->syntax #f symbol)))) (define-for-syntax ($name n) - (I (symbol+ '$ n))) + (I (format-symbol "$~a" n))) -(define-for-syntax (interrupted-name s) - (I (symbol+ s '/Interrupted))) +(define-for-syntax (interrupted-name id) + (I (format-symbol "~a/Interrupted" (syntax-e id)))) -(define-for-syntax (skipped-name s) - (I (symbol+ s '/Skipped))) +(define-for-syntax (skipped-name id) + (I (format-symbol "~a/Skipped" (syntax-e id)))) (define-for-syntax (elaborate-skipped-tail head tail position args mk-action) (define-values (new-tail new-arguments) @@ -149,7 +142,7 @@ [((? NT) . parts-rest) (cons ;; NT is interrupted - (elaborate-skipped-tail (I (symbol+ #'NT '/Interrupted)) + (elaborate-skipped-tail (interrupted-name #'NT) #'parts-rest (add1 position) (cons ($name position) args) @@ -163,7 +156,7 @@ (define-for-syntax (generate-action-name nt pos) (syntax-local-get-shadower - (datum->syntax #f (symbol+ 'action-for- nt '/ pos)))) + (format-id #f "action-for-~a/~a" (syntax-e nt) pos))) (define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos) (define pattern (car alt)) @@ -265,8 +258,8 @@ interrupted-alternates] [skip-spec (assq '#:skipped options)] [args-spec (assq '#:args options)] - [name/Skipped (I (symbol+ #'name '/Skipped))] - [name/Interrupted (I (symbol+ #'name '/Interrupted))] + [name/Skipped (skipped-name #'name)] + [name/Interrupted (interrupted-name #'name)] [%action ((syntax-local-certifier) #'%action)]) #`(begin (definitions #,@action-definitions) @@ -284,11 +277,11 @@ #'(begin)] [(skipped-token-values name . more) (identifier? #'name) - (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) + (with-syntax ([name/Skipped (skipped-name #'name)]) #'(begin (productions (name/Skipped [() #f])) (skipped-token-values . more)))] [(skipped-token-values (name value) . more) - (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) + (with-syntax ([name/Skipped (skipped-name #'name)]) #'(begin (productions (name/Skipped [() value])) (skipped-token-values . more)))])) diff --git a/collects/macro-debugger/util/class-iop.ss b/collects/macro-debugger/util/class-iop.ss index 549b6f2688..ae89b2fa39 100644 --- a/collects/macro-debugger/util/class-iop.ss +++ b/collects/macro-debugger/util/class-iop.ss @@ -2,6 +2,7 @@ (require scheme/class (for-syntax scheme/base syntax/parse + unstable/syntax "class-ct.ss")) (provide define-interface define-interface/dynamic @@ -130,8 +131,7 @@ [(method ...) (static-interface-members si)] [(name.method ...) (map (lambda (m) - (datum->syntax #'name - (string->symbol (format "~a.~a" (syntax-e #'name) m)))) + (format-id #'name "~a.~a" (syntax-e #'name) m)) (static-interface-members si))]) #`(begin (define name-internal (check-object<:interface define: expr iface)) diff --git a/collects/macro-debugger/util/notify.ss b/collects/macro-debugger/util/notify.ss index 991bce1263..2eb7d9c57c 100644 --- a/collects/macro-debugger/util/notify.ss +++ b/collects/macro-debugger/util/notify.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require (for-syntax scheme/base) +(require (for-syntax scheme/base unstable/syntax) scheme/list scheme/class macro-debugger/util/class-iop @@ -18,30 +18,27 @@ check-box/notify-box choice/notify-box) -(define-for-syntax (join . args) - (define (->string x) - (cond [(string? x) x] - [(symbol? x) (symbol->string x)] - [(identifier? x) (symbol->string (syntax-e x))] - [else (error '->string)])) - (string->symbol (apply string-append (map ->string args)))) - (define-syntax override/return-false (syntax-rules () [(override/return-false m ...) (begin (define/override (m) #f) ...)])) +(define-for-syntax (mk-init name) + (format-id name "init-~a" (syntax-e name))) +(define-for-syntax (mk-get name) + (format-id name "get-~a" (syntax-e name))) +(define-for-syntax (mk-set name) + (format-id name "set-~a" (syntax-e name))) +(define-for-syntax (mk-listen name) + (format-id name "listen-~a" (syntax-e name))) + (define-syntax (field/notify stx) (syntax-case stx () [(field/notify name value) - (with-syntax ([init-name - (datum->syntax #'name (join "init-" #'name))] - [get-name - (datum->syntax #'name (join "get-" #'name))] - [set-name - (datum->syntax #'name (join "set-" #'name))] - [listen-name - (datum->syntax #'name (join "listen-" #'name))]) + (with-syntax ([init-name (mk-init #'name)] + [get-name (mk-get #'name)] + [set-name (mk-set #'name)] + [listen-name (mk-listen #'name)]) #'(begin (field [name (init-name)]) (define/public (init-name) value) (define/public-final (get-name) @@ -54,14 +51,10 @@ (define-syntax (notify-methods stx) (syntax-case stx () [(notify-methods name) - (with-syntax ([init-name - (datum->syntax #'name (join "init-" #'name))] - [get-name - (datum->syntax #'name (join "get-" #'name))] - [set-name - (datum->syntax #'name (join "set-" #'name))] - [listen-name - (datum->syntax #'name (join "listen-" #'name))]) + (with-syntax ([init-name (mk-init #'name)] + [get-name (mk-get #'name)] + [set-name (mk-set #'name)] + [listen-name (mk-listen #'name)]) #'(begin (field [name (init-name)]) (define/public (init-name) (new notify-box% (value #f))) @@ -75,15 +68,13 @@ (define-syntax (connect-to-pref stx) (syntax-case stx () [(connect-to-pref name pref) - (with-syntax ([init-name - (datum->syntax #'name (join "init-" #'name))]) + (with-syntax ([init-name (mk-init #'name)]) #'(define/override (init-name) (notify-box/pref pref)))])) (define-syntax (connect-to-pref/readonly stx) (syntax-case stx () [(connect-to-pref/readonly name pref) - (with-syntax ([init-name - (datum->syntax #'name (join "init-" #'name))]) + (with-syntax ([init-name (mk-init #'name)]) #'(define/override (init-name) (notify-box/pref/readonly pref)))])) (define-syntax (define/listen stx) @@ -91,12 +82,9 @@ [(define/listen name value) (unless (identifier? #'name) (raise-syntax-error 'define/listen "expected identifier" #'name)) - (with-syntax ([get-name - (datum->syntax #'name (join "get-" #'name))] - [set-name - (datum->syntax #'name (join "set-" #'name))] - [listen-name - (datum->syntax #'name (join "listen-" #'name))]) + (with-syntax ([get-name (mk-get #'name)] + [set-name (mk-set #'name)] + [listen-name (mk-listen #'name)]) #'(begin (define name value) (define listeners null) diff --git a/collects/syntax/private/id-table.ss b/collects/syntax/private/id-table.ss index d2b5acec45..8241924e91 100644 --- a/collects/syntax/private/id-table.ss +++ b/collects/syntax/private/id-table.ss @@ -1,5 +1,6 @@ #lang scheme/base -(require (for-syntax scheme/base) +(require (for-syntax scheme/base + unstable/syntax) scheme/dict) (provide id-table-position?) @@ -41,9 +42,6 @@ name) arity)) -(define-for-syntax (format-id stx fmt . args) - (datum->syntax stx (string->symbol (apply format fmt args)))) - (define-syntax (make-code stx) (syntax-case stx () [(_ idtbl diff --git a/collects/syntax/private/stxparse/rep-patterns.ss b/collects/syntax/private/stxparse/rep-patterns.ss index ef36742e12..da3be9f1f8 100644 --- a/collects/syntax/private/stxparse/rep-patterns.ss +++ b/collects/syntax/private/stxparse/rep-patterns.ss @@ -1,9 +1,9 @@ #lang scheme/base (require "rep-attrs.ss" - "../util.ss" + unstable/struct (for-syntax scheme/base syntax/stx - "../util.ss")) + unstable/syntax)) (provide (all-defined-out)) #| @@ -157,10 +157,8 @@ A Kind is one of (with-syntax ([([pred accessor] ...) (for/list ([s (stx->list #'(struct ...))]) - (list (datum->syntax - s (format-symbol "~a?" (syntax-e s))) - (datum->syntax - s (format-symbol "~a-attrs" (syntax-e s)))))]) + (list (format-id s "~a?" (syntax-e s)) + (format-id s "~a-attrs" (syntax-e s))))]) #'(lambda (x) (cond [(pred x) (accessor x)] ... [else (raise-type-error 'pattern-attrs "pattern" x)])))])) diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index 3f9cb56893..f9c0095635 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -9,7 +9,6 @@ syntax/keyword unstable/syntax unstable/struct - "../util.ss" "rep-data.ss" "codegen-data.ss") @@ -499,7 +498,7 @@ (define (name->prefix id) (cond [(wildcard? id) #f] [(epsilon? id) id] - [else (datum->syntax id (format-symbol "~a." (syntax-e id)))])) + [else (format-id id "~a." (syntax-e id))])) (define (name->bind id) (cond [(wildcard? id) #f] @@ -521,7 +520,7 @@ ;; prefix-attr-name : id symbol -> id (define (prefix-attr-name prefix name) - (datum->syntax prefix (format-symbol "~a~a" (syntax-e prefix) name))) + (format-id prefix "~a~a" (syntax-e prefix) name)) ;; ---- diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss index 98f7266228..3eb360e79a 100644 --- a/collects/syntax/private/stxparse/sc.ss +++ b/collects/syntax/private/stxparse/sc.ss @@ -1,9 +1,10 @@ #lang scheme/base (require (for-syntax scheme/base scheme/private/sc + unstable/syntax + unstable/struct "rep-data.ss" - "rep.ss" - "../util.ss") + "rep.ss") syntax/stx "parse.ss" "runtime.ss" diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl index bde7cea404..150a9f3564 100644 --- a/collects/unstable/scribblings/syntax.scrbl +++ b/collects/unstable/scribblings/syntax.scrbl @@ -190,5 +190,36 @@ Like @scheme[format], but produces a symbol. @examples[#:eval the-eval (format-symbol "make-~s" 'triple) ] - +} + +@defproc[(format-id [lctx (or/c syntax? #f)] + [#:source src (or/c syntax? #f) #f] + [#:props props (or/c syntax? #f) #f] + [#:cert cert (or/c syntax? #f) #f] + [fmt string?] [v any/c] ...) + identifier?]{ + +Like @scheme[format-symbol], but converts the symbol into an +identifier using @scheme[lctx] for the lexical context, @scheme[src] +for the source location, @scheme[props] for the properties, and +@scheme[cert] for the inactive certificates. (See +@scheme[datum->syntax].) + +@examples[#:eval the-eval +(define-syntax (make-pred stx) + (syntax-case stx () + [(make-pred name) + (format-id #'name "~a?" (syntax-e #'name))])) +(make-pred pair) +(make-pred none-such) +(define-syntax (better-make-pred stx) + (syntax-case stx () + [(better-make-pred name) + (format-id #'name #:source #'name + "~a?" (syntax-e #'name))])) +(better-make-pred none-such) +] + +(Scribble doesn't show it, but the DrScheme pinpoints the location of +the second error but not of the first.) } diff --git a/collects/unstable/syntax.ss b/collects/unstable/syntax.ss index 0e3477556c..b5599f651d 100644 --- a/collects/unstable/syntax.ss +++ b/collects/unstable/syntax.ss @@ -21,6 +21,7 @@ record-disappeared-uses format-symbol + format-id current-syntax-context wrong-syntax) @@ -95,8 +96,17 @@ ;; Symbol Formatting (define (format-symbol fmt . args) - (let ([args (for/list ([arg args]) (if (syntax? arg) (syntax->datum arg) arg))]) - (string->symbol (apply format fmt args)))) + (string->symbol (apply format fmt args))) + +(define (format-id lctx + #:source [src #f] + #:props [props #f] + #:cert [cert #f] + fmt . args) + (let* ([str (apply format fmt args)] + [sym (string->symbol str)]) + (datum->syntax lctx sym src props cert))) + ;; Error reporting