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

R6RS repairs (PRs 9361 and 9371)

Browse Source 
svn: r9844
This commit is contained in:
Matthew Flatt 2008-05-15 13:23:16 +00:00
parent c8df8f0793
commit 41ad955597
9 changed files with 169 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/r6rs/private/base-for-syntax.ss
View File

@ -4,9 +4,36 @@
;; for-syntax exports of `rnrs/base-6' are exported
;; from here in phase 0
(require r6rs/private/identifier-syntax)
(require r6rs/private/identifier-syntax
(for-syntax scheme/base
"check-pattern.ss"))
(provide syntax-rules
(provide (rename-out [r6rs:syntax-rules syntax-rules])
identifier-syntax
...
_)
(define-syntax (r6rs:syntax-rules stx)
(syntax-case stx ()
[(_ (lit ...) [pat tmpl] ...)
(let ([lits (syntax->list #'(lit ...))])
(for-each
(lambda (lit)
(unless (identifier? lit)
(raise-syntax-error #f
"literal is not an identifier"
stx
lit))
(when (or (free-identifier=? lit (quote-syntax ...))
(free-identifier=? lit #'_))
(raise-syntax-error #f
"not allowed as a literal"
stx
lit)))
lits)
(for-each (check-pat-ellipses stx) (syntax->list #'(pat ...)))
(syntax-case stx ()
[(_ . rest)
(syntax/loc stx (syntax-rules . rest))]))]
[(_ . rest)
(syntax/loc stx (syntax-rules . rest))]))

25
collects/r6rs/private/check-pattern.ss Normal file
View File

@ -0,0 +1,25 @@
#lang scheme/base
(require (for-template (only-in scheme/base ...)))
(provide check-pat-ellipses)
(define ((check-pat-ellipses orig-stx) stx)
(let loop ([stx stx][car-ok? #f])
(cond
[(syntax? stx) (loop (syntax-e stx) car-ok?)]
[(pair? stx)
(if (and (not car-ok?)
(identifier? (car stx))
(free-identifier=? (car stx) (quote-syntax ...)))
(raise-syntax-error #f
"ellipsis without preceding form"
orig-stx
(car stx))
(begin (loop (car stx) #f)
(loop (cdr stx) #t)))]
[(vector? stx)
(for-each (lambda (stx) (loop stx #f)) (vector->list stx))]
[else (void)])))

28
collects/r6rs/private/conds.ss
View File

@ -107,6 +107,8 @@
(exn:fail:r6rs-message c)]
[(exn:fail:contract:r6rs? c)
(exn:fail:contract:r6rs-message c)]
[(exn:fail:syntax:r6rs? c)
(exn:fail:syntax:r6rs-message c)]
[else (exn-message c)]))
(make-has-continuation-marks (exn-continuation-marks c)))
(if (and (exn:fail? c)
@ -138,15 +140,23 @@
(list (make-lexical-violation))
null)
(if (exn:fail:syntax? c)
(let ([forms (exn:fail:syntax-exprs c)])
(list (make-syntax-violation
(if (pair? forms)
(car forms)
#f)
(if (and (pair? forms)
(pair? (cdr forms)))
(cadr forms)
#f))))
(if (exn:fail:syntax:r6rs? c)
(append
(list (make-syntax-violation
(exn:fail:syntax:r6rs-form c)
(exn:fail:syntax:r6rs-subform c)))
(if (exn:fail:syntax:r6rs-who c)
(list (make-who-condition (exn:fail:syntax:r6rs-who c)))
null))
(let ([forms (exn:fail:syntax-exprs c)])
(list (make-syntax-violation
(if (pair? forms)
(car forms)
#f)
(if (and (pair? forms)
(pair? (cdr forms)))
(cadr forms)
#f)))))
null)
(if (exn:fail:contract:variable? c)
(list (make-undefined-violation))

2
collects/r6rs/private/exns.ss
View File

@ -3,10 +3,12 @@
(provide (struct-out exn:fail:r6rs)
(struct-out exn:fail:contract:r6rs)
(struct-out exn:fail:contract:non-continuable)
(struct-out exn:fail:syntax:r6rs)
(struct-out exn:fail:filesystem:exists-not))
(define-struct (exn:fail:r6rs exn:fail) (message who irritants))
(define-struct (exn:fail:contract:r6rs exn:fail:contract) (message who irritants))
(define-struct (exn:fail:contract:non-continuable exn:fail:contract) ())
(define-struct (exn:fail:syntax:r6rs exn:fail:syntax) (message who form subform))
(define-struct (exn:fail:filesystem:exists-not exn:fail:filesystem) (filename))

5
collects/rnrs/base-6.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require (for-syntax r6rs/private/base-for-syntax
(require (for-syntax (rename-in r6rs/private/base-for-syntax
[syntax-rules r6rs:syntax-rules])
scheme/base)
r6rs/private/qq-gen
r6rs/private/exns
@ -167,7 +168,7 @@
[r6rs:letrec-syntax letrec-syntax])
;; 11.19
(for-syntax syntax-rules
(for-syntax (rename-out [r6rs:syntax-rules syntax-rules])
identifier-syntax
...
_)

41
collects/rnrs/syntax-case-6.ss
View File

@ -3,7 +3,9 @@
(require (for-syntax scheme/base)
r6rs/private/qq-gen
scheme/stxparam
scheme/mpair)
scheme/mpair
r6rs/private/exns
(for-syntax r6rs/private/check-pattern))
(provide make-variable-transformer
(rename-out [r6rs:syntax-case syntax-case]
@ -18,7 +20,40 @@
[r6rs:with-syntax with-syntax]
[r6rs:quasisyntax quasisyntax])
unsyntax unsyntax-splicing
(rename-out [raise-syntax-error syntax-violation]))
syntax-violation)
(define syntax-violation
(let ([go (lambda (who message form subforms)
(let ([exn (with-handlers ([exn:fail:syntax? (lambda (x) x)])
(apply raise-syntax-error
(if (string? who)
(string->symbol who)
who)
message
(convert-mpairs form)
(map convert-mpairs subforms)))])
(raise
(make-exn:fail:syntax:r6rs
(exn-message exn)
(exn-continuation-marks exn)
(exn:fail:syntax-exprs exn)
message
(or who
(cond
[(identifier? form) (syntax-e form)]
[(and (pair? form) (identifier? (car form)))
(syntax-e (car form))]
[(and (syntax? form) (pair? (syntax-e form))
(identifier? (car (syntax-e form))))
(syntax-e (car (syntax-e form)))]
[else #f]))
form
(and (pair? subforms) (car subforms))))))])
(case-lambda
[(who message form subform)
(go who message form (list subform))]
[(who message form)
(go who message form null)])))
(define (r6rs:free-identifier=? a b)
(free-identifier=? a b))
@ -158,11 +193,13 @@
(syntax-case clause ()
[(pat val)
(with-syntax ([pat-ids (extract-pattern-ids #'pat lits)])
((check-pat-ellipses stx) #'pat)
#`(pat (syntax-parameterize ([pattern-vars
(add-pattern-vars #'pat-ids)])
val)))]
[(pat fender val)
(with-syntax ([pat-ids (extract-pattern-ids #'pat lits)])
((check-pat-ellipses stx) #'pat)
#`(pat (syntax-parameterize ([pattern-vars
(add-pattern-vars #'pat-ids)])
fender)

10
collects/scribblings/reference/runtime.scrbl
View File

@ -173,10 +173,14 @@ follows, in the order that they are set within @scheme[results]:
@item{@scheme[7]: The number of syntax objects read from compiled code
since start-up.}
@item{@scheme[8]: The number of hash-table searches performed.}
@item{@scheme[8]: The number of hash-table searches performed. When
this counter reaches the maximum value of a @tech{fixnum}, it
overflows to the most negative @tech{fixnum}.}
@item{@scheme[9]: The number of additional hash slots searched to complete
hash searches (using double hashing).}
@item{@scheme[9]: The number of additional hash slots searched to
complete hash searches (using double hashing). When this counter
reaches the maximum value of a @tech{fixnum}, it overflows to the
most negative @tech{fixnum}.}
@item{@scheme[10]: The number of bytes allocated for machine code
that is not reported by @scheme[current-memory-use].}

19
collects/scribblings/reference/startup.scrbl
View File

@ -151,12 +151,19 @@ flags:
binary that also embeds Scheme code.}
@item{@FlagFirst{m} or @DFlagFirst{main} : Evaluates a call to
@scheme[main] in the top-level environment. All of the
command-line arguments that are not processed as options
(i.e., the arguments put into
@scheme[current-command-line-arguments]) are passed as arguments to
@scheme[main]. The results of the call are printed via
@scheme[current-print].}
@schemeidfont{main} as bound in the top-level environment. All
of the command-line arguments that are not processed as
options (i.e., the arguments put into
@scheme[current-command-line-arguments]) are passed as
arguments to @schemeidfont{main}. The results of the call are
printed via @scheme[current-print].
The call to @schemeidfont{main} is constructed as an
expression @scheme[((unsyntax @schemeidfont{main}) _arg-str
...)] where the lexical context of the expression gives
@schemeidfont{#%app} and @schemeidfont{#%datum} bindings as
@scheme[#%plain-app] and @scheme[#%datum], but the lexical
context of @schemeidfont{main} is the top-level environment.}
}}

32
collects/tests/r6rs/syntax-case.ss
View File

@ -286,6 +286,38 @@
(test/exn (syntax-violation 'form "bad" 7 #'8) &syntax)
(test/exn (syntax-violation 'form "bad" #'7 8) &syntax)
(test/exn (syntax-violation 'form "bad" 7 8) &syntax)
(test/exn (syntax-violation "form" "bad" 7) &syntax)
(test/exn (syntax-violation "form" "bad" 7 8) &syntax)
(test (condition-message
(guard (v [#t v])
(syntax-violation 'apple "bad" 'worm)))
"bad")
(test (condition-who
(guard (v [#t v])
(syntax-violation 'apple "bad" 'worm)))
'apple)
(test (condition-who
(guard (v [#t v])
(syntax-violation "apple" "bad" 'worm)))
"apple")
(test (condition-who
(guard (v [#t v])
(syntax-violation #f "bad" #'worm)))
'worm)
(test (syntax-violation-form
(guard (v [#t v])
(syntax-violation 'apple "bad" '(worm))))
'(worm))
(test (syntax-violation-subform
(guard (v [#t v])
(syntax-violation 'apple "bad" '(worm))))
#f)
(test (syntax-violation-subform
(guard (v [#t v])
(syntax-violation 'apple "bad" '(worm) '(another))))
'(another))
;;
))