unstable/syntax: added format-id

svn: r16629

collects/macro-debugger/model/yacc-interrupted.ss

@@ -1,7 +1,8 @@
 
 #lang scheme/base
-(require (for-syntax scheme/base)
+(require (for-syntax scheme/base
-         (for-syntax mzlib/etc)
+                     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)
+(define-for-syntax (interrupted-name id)
-  (I (symbol+ s '/Interrupted)))
+  (I (format-symbol "~a/Interrupted" (syntax-e id))))
 
-(define-for-syntax (skipped-name s)
+(define-for-syntax (skipped-name id)
-  (I (symbol+ s '/Skipped)))
+  (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/Skipped (skipped-name #'name)]
-                     [name/Interrupted (I (symbol+ #'name '/Interrupted))]
+                     [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)))]))
 

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
+                             (format-id #'name "~a.~a" (syntax-e #'name) m))
-                                            (string->symbol (format "~a.~a" (syntax-e #'name) m))))
                            (static-interface-members si))])
          #`(begin (define name-internal
                     (check-object<:interface define: expr iface))

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
+     (with-syntax ([init-name (mk-init #'name)]
-                    (datum->syntax #'name (join "init-" #'name))]
+                   [get-name (mk-get #'name)]
-                   [get-name
+                   [set-name (mk-set #'name)]
-                    (datum->syntax #'name (join "get-" #'name))]
+                   [listen-name (mk-listen #'name)])
-                   [set-name
-                    (datum->syntax #'name (join "set-" #'name))]
-                   [listen-name
-                    (datum->syntax #'name (join "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
+     (with-syntax ([init-name (mk-init #'name)]
-                    (datum->syntax #'name (join "init-" #'name))]
+                   [get-name (mk-get #'name)]
-                   [get-name
+                   [set-name (mk-set #'name)]
-                    (datum->syntax #'name (join "get-" #'name))]
+                   [listen-name (mk-listen #'name)])
-                   [set-name
-                    (datum->syntax #'name (join "set-" #'name))]
-                   [listen-name
-                    (datum->syntax #'name (join "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
+     (with-syntax ([init-name (mk-init #'name)])
-                    (datum->syntax #'name (join "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
+     (with-syntax ([init-name (mk-init #'name)])
-                    (datum->syntax #'name (join "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
+     (with-syntax ([get-name (mk-get #'name)]
-                    (datum->syntax #'name (join "get-" #'name))]
+                   [set-name (mk-set #'name)]
-                   [set-name
+                   [listen-name (mk-listen #'name)])
-                    (datum->syntax #'name (join "set-" #'name))]
-                   [listen-name
-                    (datum->syntax #'name (join "listen-" #'name))])
        #'(begin
            (define name value)
            (define listeners null)

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

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
+                 (list (format-id s "~a?" (syntax-e s))
-                        s (format-symbol "~a?" (syntax-e s)))
+                       (format-id s "~a-attrs" (syntax-e s))))])
-                       (datum->syntax
-                        s (format-symbol "~a-attrs" (syntax-e s)))))])
            #'(lambda (x)
                (cond [(pred x) (accessor x)] ...
                      [else (raise-type-error 'pattern-attrs "pattern" x)])))]))

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

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"
+                     "rep.ss")
-                     "../util.ss")
          syntax/stx
          "parse.ss"
          "runtime.ss"

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.)
 }

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