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

unstable:

Browse Source 
added struct and syntax libraries

svn: r16621
This commit is contained in:
Ryan Culpepper 2009-11-08 19:20:53 +00:00
parent 7cce5c98a3
commit 7483b7ed20
14 changed files with 348 additions and 272 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/redex/private/term.ss
View File

@ -2,7 +2,7 @@
(require (for-syntax scheme/base
"term-fn.ss"
syntax/private/util/misc)
unstable/syntax)
"matcher.ss")
(provide term term-let term-let/error-name term-let-fn term-define-fn hole in-hole)

2
collects/syntax/private/stxparse/parse.ss
View File

@ -4,7 +4,7 @@
syntax/stx
syntax/id-table
syntax/keyword
syntax/private/util/misc
unstable/syntax
"rep-data.ss"
"rep.ss"
"codegen-data.ss"

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

@ -7,7 +7,7 @@
syntax/id-table
syntax/stx
syntax/keyword
syntax/private/util/misc
unstable/syntax
"../util.ss"
"rep-data.ss"
"codegen-data.ss")

2
collects/syntax/private/stxparse/runtime-prose.ss
View File

@ -8,7 +8,7 @@
(for-syntax syntax/stx)
(for-syntax scheme/private/sc)
(for-syntax "rep-data.ss")
(for-syntax "../util/error.ss")
(for-syntax "../util.ss")
"runtime.ss")
(provide syntax-patterns-fail
current-failure-handler

12
collects/syntax/private/util.ss
View File

@ -1,9 +1,5 @@
#lang scheme/base
(require "util/error.ss"
"util/expand.ss"
"util/misc.ss"
"util/struct.ss")
(provide (all-from-out "util/error.ss")
(all-from-out "util/expand.ss")
(all-from-out "util/misc.ss")
(all-from-out "util/struct.ss"))
(require unstable/syntax
unstable/struct)
(provide (all-from-out unstable/syntax)
(all-from-out unstable/struct))

16
collects/syntax/private/util/error.ss
View File

@ -1,16 +0,0 @@
#lang scheme/base
(provide wrong-syntax
current-syntax-context)
(define current-syntax-context (make-parameter #f))
(define (wrong-syntax stx #:extra [extras null] format-string . args)
(unless (or (eq? stx #f) (syntax? stx))
(raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args)))
(let* ([ctx (current-syntax-context)]
[blame (and (syntax? ctx) (syntax-property ctx 'report-errors-as))])
(raise-syntax-error (if (symbol? blame) blame #f)
(apply format format-string args)
ctx
stx
extras)))

241
collects/syntax/private/util/misc.ss
View File

@ -1,241 +0,0 @@
#lang scheme/base
(require syntax/kerncase
syntax/stx
(for-syntax scheme/base
scheme/private/sc))
(provide unwrap-syntax
define-pattern-variable
with-temporaries
generate-temporary
generate-n-temporaries
current-caught-disappeared-uses
with-catching-disappeared-uses
with-disappeared-uses
syntax-local-value/catch
record-disappeared-uses
format-symbol
in-stx-list
in-stx-list/unwrap
#|
parse-kw-options
extract-kw-option
chunk-kw-seq/no-dups
chunk-kw-seq/no-dups/eol
chunk-kw-seq
reject-duplicate-chunks
check-id
check-nat/f
check-string
check-idlist
|#)
;; Unwrapping syntax
;; unwrap-syntax : any #:stop-at (any -> boolean) -> any
(define (unwrap-syntax stx #:stop-at [stop-at (lambda (x) #f)])
(let loop ([x stx])
(cond [(stop-at x) x]
[(syntax? x) (loop (syntax-e x))]
[(pair? x) (cons (loop (car x)) (loop (cdr x)))]
[(vector? x) (apply vector-immutable (loop (vector->list x)))]
[(box? x) (box-immutable (loop (unbox x)))]
[(prefab-struct-key x)
=> (lambda (key)
(apply make-prefab-struct key
(loop (cdr (vector->list (struct->vector x))))))]
[else x])))
;; Defining pattern variables
(define-syntax-rule (define-pattern-variable name expr)
(begin (define var expr)
(define-syntax name (make-syntax-mapping '0 (quote-syntax var)))))
;; Statics and disappeared uses
(define current-caught-disappeared-uses (make-parameter #f))
(define-syntax-rule (with-catching-disappeared-uses . body)
(parameterize ((current-caught-disappeared-uses null))
(let ([result (let () . body)])
(values result (current-caught-disappeared-uses)))))
(define-syntax-rule (with-disappeared-uses stx-expr)
(let-values ([(stx disappeared-uses)
(with-catching-disappeared-uses stx-expr)])
(syntax-property stx
'disappeared-use
(append (or (syntax-property stx 'disappeared-use) null)
disappeared-uses))))
(define (syntax-local-value/catch id pred)
(let ([value (syntax-local-value id (lambda () #f))])
(and (pred value)
(begin (record-disappeared-uses (list id))
value))))
(define (record-disappeared-uses ids)
(let ([uses (current-caught-disappeared-uses)])
(when uses
(current-caught-disappeared-uses (append ids uses)))))
;; Generating temporaries
;; with-temporaries
(define-syntax-rule (with-temporaries (temp-name ...) . body)
(with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))])
. body))
;; generate-temporary : any -> identifier
(define (generate-temporary [stx 'g])
(car (generate-temporaries (list stx))))
;; generate-n-temporaries : exact-nonnegative-integer -> (listof identifier)
(define (generate-n-temporaries n)
(generate-temporaries
(for/list ([i (in-range n)])
(string->symbol (format "g~sx" i)))))
;; 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))))
;; Syntax list sequence
(define (in-stx-list x)
(let ([l (stx->list x)])
(unless l
(raise-type-error 'in-stx-list "syntax list" x))
(in-list l)))
(define (in-stx-list/unwrap x)
(let ([l (stx->list x)])
(unless l
(raise-type-error 'in-stx-list "syntax list" x))
(in-list (map syntax-e l))))
;; Parsing keyword arguments
;; parse-kw-options : ...
(define (parse-kw-options stx table extractions #:context [ctx #f])
(let ([chunks (chunk-kw-seq/no-dups/eol stx table #:context ctx)])
(for/list ([ex extractions])
(extract-kw-option chunks ex))))
;; extract-kw-option : ...
(define (extract-kw-option chunks ex)
(let ([entry (assq (car ex) chunks)])
(if entry
(cddr entry)
(cdr ex))))
;; chunk-kw-seq/no-dups/eol : ...
(define (chunk-kw-seq/no-dups/eol stx kws #:context [ctx #f] #:only [only #f])
(let-values ([(chunks rest) (chunk-kw-seq/no-dups stx kws #:context ctx #:only only)])
(unless (stx-null? rest)
(raise-syntax-error #f "unexpected terms after keyword arguments" ctx stx))
chunks))
;; chunk-kw-seq/no-dups : syntax
;; alist[keyword => (listof (stx -> any))]
;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx)
(define (chunk-kw-seq/no-dups stx kws #:context [ctx #f] #:only [only #f])
(let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)])
(reject-duplicate-chunks chunks #:context ctx #:only only)
(values chunks rest)))
;; chunk-kw-seq : stx
;; alist[keyword => (listof (stx -> any))
;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx)
(define (chunk-kw-seq stx kws #:context [ctx #f])
(define (loop stx rchunks)
(syntax-case stx ()
[(kw . more)
(and (keyword? (syntax-e #'kw)) (assq (syntax-e #'kw) kws))
(let* ([kw-value (syntax-e #'kw)]
[arity (cdr (assq kw-value kws))]
[args+rest (stx-split #'more arity)])
(if args+rest
(loop (cdr args+rest)
(cons (list* kw-value #'kw (car args+rest)) rchunks))
(raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))]
[(kw . more)
(keyword? (syntax-e #'kw))
(raise-syntax-error #f
(format "unexpected keyword, expected one of ~s" (map car kws))
ctx
#'kw)]
[_
(values (reverse rchunks) stx)]))
(loop stx null))
;; reject-duplicate-chunks : (listof (cons kw (cons stx(kw) (listof any)))) -> void
(define (reject-duplicate-chunks chunks
#:context [ctx #f]
#:only [only #f])
(define kws (make-hasheq))
(define (loop chunks)
(when (pair? chunks)
(let ([kw (caar chunks)])
(when (or (not only) (memq kw only))
(when (hash-ref kws kw #f)
(raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx))
(hash-set! kws kw #t)))
(loop (cdr chunks))))
(loop chunks))
;; alist-select : (listof (cons A B)) A -> (listof B)
(define (alist-select alist key)
(cond [(pair? alist)
(if (eq? (caar alist) key)
(cons (cdar alist) (alist-select (cdr alist) key))
(alist-select (cdr alist) key))]
[else null]))
;; stx-split : stx nat -> (cons (listof stx) stx)
(define (stx-split stx procs)
(define (loop stx procs acc)
(cond [(null? procs)
(cons (reverse acc) stx)]
[(stx-pair? stx)
(loop (stx-cdr stx) (cdr procs) (cons ((car procs) (stx-car stx)) acc))]
[else #f]))
(loop stx procs null))
;; check-id : stx -> identifier
(define (check-id stx)
(unless (identifier? stx)
(raise-syntax-error 'pattern "expected identifier" stx))
stx)
;; check-string : stx -> stx
(define (check-string stx)
(unless (string? (syntax-e stx))
(raise-syntax-error #f "expected string" stx))
stx)
;; nat/f : any -> boolean
(define (nat/f x)
(or (not x) (exact-nonnegative-integer? x)))
;; check-nat/f : stx -> stx
(define (check-nat/f stx)
(let ([d (syntax-e stx)])
(unless (nat/f d)
(raise-syntax-error #f "expected exact nonnegative integer or #f" stx))
stx))
;; check-idlist : stx -> (listof identifier)
(define (check-idlist stx)
(unless (and (stx-list? stx) (andmap identifier? (stx->list stx)))
(raise-syntax-error #f "expected list of identifiers" stx))
(stx->list stx))

2
collects/typed-scheme/rep/rep-utils.ss
View File

@ -10,7 +10,7 @@
scheme/contract
(for-syntax
scheme/list
(only-in syntax/private/util/misc generate-temporary)
(only-in unstable/syntax generate-temporary)
scheme/match
(except-in syntax/parse id identifier keyword)
scheme/base

2
collects/typed-scheme/utils/stxclass-util.ss
View File

@ -3,7 +3,7 @@
(require (except-in syntax/parse id keyword)
(for-syntax syntax/parse
scheme/base
(only-in syntax/private/util/misc generate-temporary)))
(only-in unstable/syntax generate-temporary)))
(provide (except-out (all-defined-out) id keyword)
(rename-out [id id*] [keyword keyword*]))

28
collects/unstable/scribblings/struct.scrbl Normal file
View File

@ -0,0 +1,28 @@
#lang scribble/manual
@(require scribble/eval
(for-label unstable/struct
scheme/contract
scheme/base))
@title[#:tag "struct"]{Structs}
@(define the-eval (make-base-eval))
@(the-eval '(require unstable/struct))
@defmodule[unstable/struct]
@defform[(make struct-id expr ...)]{
Creates an instance of @scheme[struct-id], which must be bound as a
struct name. The number of @scheme[expr]s is statically checked
against the number of fields associated with @scheme[struct-id]. If
they are different, or if the number of fields is not known, an error
is raised at compile time.
@examples[#:eval the-eval
(define-struct triple (a b c))
(make triple 3 4 5)
(make triple 2 4)
]
}

194
collects/unstable/scribblings/syntax.scrbl Normal file
View File

@ -0,0 +1,194 @@
#lang scribble/manual
@(require scribble/struct
scribble/decode
scribble/eval
(for-label scheme/base
scheme/contract
unstable/syntax))
@(define the-eval (make-base-eval))
@(the-eval '(require unstable/syntax))
@(the-eval '(require (for-syntax scheme/base unstable/syntax)))
@title[#:tag "syntax"]{Syntax}
@defmodule[unstable/syntax]
@defparam[current-syntax-context stx (or/c syntax? false/c)]{
The current contextual syntax object, defaulting to @scheme[#f]. It
determines the special form name that prefixes syntax errors created
by @scheme[wrong-syntax].
@;{
If it is a syntax object with a @scheme['report-error-as] syntax
property whose value is a symbol, then that symbol is used as the
special form name. Otherwise, the same rules apply as in
@scheme[raise-syntax-error].
}
}
@defproc[(wrong-syntax [stx syntax?] [format-string string?] [v any/c] ...)
any]{
Raises a syntax error using the result of
@scheme[(current-syntax-context)] as the ``major'' syntax object and
the provided @scheme[stx] as the specific syntax object. (The latter,
@scheme[stx], is usually the one highlighted by DrScheme.) The error
message is constructed using the format string and arguments, and it
is prefixed with the special form name as described under
@scheme[current-syntax-context].
@examples[#:eval the-eval
(wrong-syntax #'here "expected ~s" 'there)
(parameterize ((current-syntax-context #'(look over here)))
(wrong-syntax #'here "expected ~s" 'there))
]
A macro using @scheme[wrong-syntax] might set the syntax context at the very
beginning of its transformation as follows:
@SCHEMEBLOCK[
(define-syntax (my-macro stx)
(parameterize ((current-syntax-context stx))
(syntax-case stx ()
___)))
]
Then any calls to @scheme[wrong-syntax] during the macro's
transformation will refer to @scheme[my-macro] (more precisely, the name that
referred to @scheme[my-macro] where the macro was used, which may be
different due to renaming, prefixing, etc).
@;{
A macro that expands into a helper macro can insert its own name into
syntax errors raised by the helper macro by installing a
@scheme['report-error-as] syntax property on the helper macro
expression.
@examples[#:eval the-eval
(define-syntax (public-macro stx)
(syntax-case stx ()
[(public-macro stuff)
(syntax-property #'(private-macro stuff)
'report-error-as
(syntax-e #'public-macro))]))
(define-syntax (private-macro stx)
(parameterize ((current-syntax-context stx))
(syntax-case stx ()
[(private-macro arg)
(wrong-syntax #'arg "just no good")])))
(public-macro 5)
]
}
}
@;{----}
@defform[(define-pattern-variable id expr)]{
Evaluates @scheme[expr] and binds it to @scheme[id] as a pattern
variable, so @scheme[id] can be used in subsequent @scheme[syntax]
patterns.
@examples[#:eval the-eval
(define-pattern-variable name #'Alice)
#'(hello name)
]
}
@;{----}
@defform[(with-temporaries (temp-id ...) . body)]{
Evaluates @scheme[body] with each @scheme[temp-id] bound as a pattern
variable to a freshly generated identifier.
@examples[#:eval the-eval
(with-temporaries (x) #'(lambda (x) x))
]
}
@defproc[(generate-temporary [name-base any/c 'g]) identifier?]{
Generates one fresh identifier. Singular form of
@scheme[generate-temporaries]. If @scheme[name-base] is supplied, it
is used as the basis for the identifier's name.
}
@defproc[(generate-n-temporaries [n exact-nonnegative-integer?])
(listof identifier?)]{
Generates a list of @scheme[n] fresh identifiers.
}
@;{----}
@defparam[current-caught-disappeared-uses ids
(or/c (listof identifier?) false/c)]{
Parameter for tracking disappeared uses. Tracking is ``enabled'' when
the parameter has a non-false value. This is done automatically by
forms like @scheme[with-disappeared-uses].
}
@defform[(with-disappeared-uses stx-expr)
#:contracts ([stx-expr syntax?])]{
Evaluates the @scheme[stx-expr], catching identifiers looked up using
@scheme[syntax-local-value/catch]. Adds the caught identifiers to the
@scheme['disappeared-uses] syntax property of the resulting syntax
object.
}
@defform[(with-catching-disappeared-uses body-expr)]{
Evaluates the @scheme[body-expr], catching identifiers looked up using
@scheme[syntax-local-value/catch]. Returns two values: the result of
@scheme[body-expr] and the list of caught identifiers.
}
@defproc[(syntax-local-value/catch [id identifier?] [predicate (-> any/c boolean?)])
any/c]{
Looks up @scheme[id] in the syntactic environment (as
@scheme[syntax-local-value]). If the lookup succeeds and returns a
value satisfying the predicate, the value is returned and @scheme[id]
is recorded (``caught'') as a disappeared use. If the lookup fails or
if the value does not satisfy the predicate, @scheme[#f] is returned
and the identifier is not recorded as a disappeared use.
If not used within the extent of a @scheme[with-disappeared-uses] form
or similar, has no effect.
}
@defproc[(record-disappeared-uses [ids (listof identifier?)])
void?]{
Add @scheme[ids] to the current disappeared uses.
If not used within the extent of a @scheme[with-disappeared-uses] form
or similar, has no effect.
}
@;{----}
@defproc[(format-symbol [fmt string?] [v any/c] ...)
symbol?]{
Like @scheme[format], but produces a symbol.
@examples[#:eval the-eval
(format-symbol "make-~s" 'triple)
]
}

2
collects/unstable/scribblings/unstable.scrbl
View File

@ -78,6 +78,8 @@ Keep documentation and tests up to date.
@include-section["net.scrbl"]
@include-section["path.scrbl"]
@include-section["string.scrbl"]
@include-section["struct.scrbl"]
@include-section["syntax.scrbl"]
@;{--------}

2
collects/syntax/private/util/struct.ss → collects/unstable/struct.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
;; owner: ryanc
(require (for-syntax scheme/base
scheme/struct-info))
(provide make)
;; (make struct-name field-expr ...)

113
collects/unstable/syntax.ss Normal file
View File

@ -0,0 +1,113 @@
#lang scheme/base
;; owner: ryanc
(require syntax/kerncase
syntax/stx
(for-syntax scheme/base
scheme/private/sc))
(provide unwrap-syntax
define-pattern-variable
with-temporaries
generate-temporary
generate-n-temporaries
current-caught-disappeared-uses
with-catching-disappeared-uses
with-disappeared-uses
syntax-local-value/catch
record-disappeared-uses
format-symbol
current-syntax-context
wrong-syntax)
;; Unwrapping syntax
;; unwrap-syntax : any #:stop-at (any -> boolean) -> any
(define (unwrap-syntax stx #:stop-at [stop-at (lambda (x) #f)])
(let loop ([x stx])
(cond [(stop-at x) x]
[(syntax? x) (loop (syntax-e x))]
[(pair? x) (cons (loop (car x)) (loop (cdr x)))]
[(vector? x) (apply vector-immutable (loop (vector->list x)))]
[(box? x) (box-immutable (loop (unbox x)))]
[(prefab-struct-key x)
=> (lambda (key)
(apply make-prefab-struct key
(loop (cdr (vector->list (struct->vector x))))))]
[else x])))
;; Defining pattern variables
(define-syntax-rule (define-pattern-variable name expr)
(begin (define var expr)
(define-syntax name (make-syntax-mapping '0 (quote-syntax var)))))
;; Statics and disappeared uses
(define current-caught-disappeared-uses (make-parameter #f))
(define-syntax-rule (with-catching-disappeared-uses . body)
(parameterize ((current-caught-disappeared-uses null))
(let ([result (let () . body)])
(values result (current-caught-disappeared-uses)))))
(define-syntax-rule (with-disappeared-uses stx-expr)
(let-values ([(stx disappeared-uses)
(with-catching-disappeared-uses stx-expr)])
(syntax-property stx
'disappeared-use
(append (or (syntax-property stx 'disappeared-use) null)
disappeared-uses))))
(define (syntax-local-value/catch id pred)
(let ([value (syntax-local-value id (lambda () #f))])
(and (pred value)
(begin (record-disappeared-uses (list id))
value))))
(define (record-disappeared-uses ids)
(let ([uses (current-caught-disappeared-uses)])
(when uses
(current-caught-disappeared-uses (append ids uses)))))
;; Generating temporaries
;; with-temporaries
(define-syntax-rule (with-temporaries (temp-name ...) . body)
(with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))])
. body))
;; generate-temporary : any -> identifier
(define (generate-temporary [stx 'g])
(car (generate-temporaries (list stx))))
;; generate-n-temporaries : exact-nonnegative-integer -> (listof identifier)
(define (generate-n-temporaries n)
(generate-temporaries
(for/list ([i (in-range n)])
(string->symbol (format "g~sx" i)))))
;; 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))))
;; Error reporting
(define current-syntax-context (make-parameter #f))
(define (wrong-syntax stx #:extra [extras null] format-string . args)
(unless (or (eq? stx #f) (syntax? stx))
(raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args)))
(let* ([ctx (current-syntax-context)]
[blame (and (syntax? ctx) (syntax-property ctx 'report-error-as))])
(raise-syntax-error (if (symbol? blame) blame #f)
(apply format format-string args)
ctx
stx
extras)))