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

unstable/syntax: added format-id

Browse Source 
svn: r16629
This commit is contained in:
Ryan Culpepper 2009-11-09 02:33:43 +00:00
parent 99a70b38d8
commit daba183b08
9 changed files with 94 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/macro-debugger/model/yacc-interrupted.ss
View File

@ -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)))]))

4
collects/macro-debugger/util/class-iop.ss
View File

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

58
collects/macro-debugger/util/notify.ss
View File

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

6
collects/syntax/private/id-table.ss
View File

@ -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

10
collects/syntax/private/stxparse/rep-patterns.ss
View File

@ -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)])))]))

5
collects/syntax/private/stxparse/rep.ss
View File

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

5
collects/syntax/private/stxparse/sc.ss
View File

@ -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"

33
collects/unstable/scribblings/syntax.scrbl
View File

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

14
collects/unstable/syntax.ss
View File

@ -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