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

fix mistakes uncovered by optimizer warnings

Browse Source
This commit is contained in:
Matthew Flatt 2011-04-30 18:59:46 -06:00
parent 045fd7a77c
commit 1b14c6a38e
9 changed files with 57 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/compiler/embed-unit.rkt
View File

@ -468,8 +468,8 @@
;; Record module as copied
(set-box! codes
(cons (make-mod filename module-path #f
#f #f #f #f
null null
#f #f #f
null null null
actual-filename)
(unbox codes))))
;; Build up relative module resolutions, relative to this one,
@ -513,7 +513,7 @@
(set-box! codes
(cons (make-mod filename module-path code
name #f #f
null null
null null null
actual-filename)
(unbox codes)))])))))))

4
collects/file/resource.rkt
View File

@ -142,7 +142,7 @@
(and (box? value)
(let ([value (unbox value)])
(or (string? value) (bytes? value) (exact-integer? value)))))
(raise-type-error 'get-resource "box of string, byte string, or exact integer"))
(raise-type-error 'get-resource "#f or box of string, byte string, or exact integer" value))
(unless (or (not file)
(path-string? file))
(raise-type-error 'get-resource "path string or #f" file))
@ -221,7 +221,7 @@
(unless (string? entry)
(raise-type-error 'write-resource "string" entry))
(unless (or (string? value) (bytes? value) (exact-integer? value))
(raise-type-error 'write-resource "string, byte string, or exact integer"))
(raise-type-error 'write-resource "string, byte string, or exact integer" value))
(unless (or (not file)
(path-string? file))
(raise-type-error 'write-resource "path string or #f" file))

4
collects/planet/private/planet-shared.rkt
View File

@ -442,12 +442,12 @@ Various common pieces of code that both the client and server need to access
(define (copy-n-chars n ip op)
(let ((cport (make-cutoff-port ip
n
(lambda ()
(lambda (m)
(raise
(make-exn:fail:read:eof
(format "Not enough chars on input (expected ~a, got ~a)"
n
(- n 0))
m)
(current-continuation-marks)
ip))))))
(copy-port cport op)))

37
collects/scheme/exists/lang.rkt
View File

@ -7,7 +7,11 @@
(define runtime-predicates
(let ([fn (build-path (collection-path "scheme")
"compiled"
"main_rkt.zo")])
"main_rkt.zo")]
[ns (make-base-namespace)])
(namespace-attach-module (current-namespace) 'scheme ns)
(parameterize ([current-namespace ns])
(namespace-require 'scheme))
(let-values ([(vars stx)
(module-compiled-exports
(parameterize ([read-accept-compiled #t])
@ -16,7 +20,10 @@
(filter (λ (sym)
(let ([str (symbol->string sym)])
(and (regexp-match #rx"[?]$" str)
(not (regexp-match #rx"[=<>][?]$" str)))))
(not (regexp-match #rx"[=<>][?]$" str))
(procedure-arity-includes?
(namespace-variable-value sym #t #f ns)
1))))
(map car (cdr (assoc 0 vars))))
string<=?
#:key symbol->string))))
@ -24,7 +31,6 @@
(define-for-syntax predicates
'(absolute-path?
arity-at-least?
bitwise-bit-set?
blame-original?
blame-swapped?
blame?
@ -39,7 +45,6 @@
channel?
chaperone-contract-property?
chaperone-contract?
chaperone-of?
chaperone?
char-alphabetic?
char-blank?
@ -64,12 +69,9 @@
continuation-prompt-available?
continuation-prompt-tag?
continuation?
contract-first-order-passes?
contract-property?
contract-stronger?
contract?
custodian-box?
custodian-memory-accounting-available?
custodian?
custom-print-quotable?
custom-write?
@ -80,9 +82,6 @@
empty?
eof-object?
ephemeron?
eq?
equal?
eqv?
even?
evt?
exact-integer?
@ -126,44 +125,35 @@
hash-eq?
hash-equal?
hash-eqv?
hash-has-key?
hash-placeholder?
hash-weak?
hash?
identifier?
immutable?
impersonator-of?
impersonator-property-accessor-procedure?
impersonator-property?
impersonator?
implementation?
inexact-real?
inexact?
input-port?
inspector?
integer?
interface-extension?
interface?
internal-definition-context?
is-a?
keyword?
link-exists?
list?
log-level?
log-receiver?
logger?
member-name-key?
method-in-interface?
module-path-index?
module-path?
module-provide-protected?
mpair?
namespace-anchor?
namespace?
negative?
null?
number?
object-method-arity-includes?
object?
odd?
output-port?
@ -176,7 +166,6 @@
placeholder?
port-closed?
port-provides-progress-evts?
port-try-file-lock?
port-writes-atomic?
port-writes-special?
port?
@ -185,9 +174,7 @@
pretty-print-style-table?
primitive-closure?
primitive?
procedure-arity-includes?
procedure-arity?
procedure-closure-contents-eq?
procedure-struct-type?
procedure?
promise-forced?
@ -197,8 +184,6 @@
rational?
readtable?
real?
regexp-match-exact?
regexp-match?
regexp?
relative-path?
rename-transformer?
@ -220,16 +205,12 @@
struct-type-property?
struct-type?
struct?
subclass?
subprocess?
symbol-interned?
symbol-unreadable?
symbol?
syntax-local-transforming-module-provides?
syntax-original?
syntax-transforming?
syntax?
system-big-endian?
tcp-accept-ready?
tcp-listener?
tcp-port?

2
collects/setup/parallel-do.rkt
View File

@ -341,7 +341,7 @@
(send/resp (list 'DONE result)))
(define (send/errorp message)
(send/resp (list 'ERROR message)))
(with-handlers ([exn:fail? (lambda (x) (send/errorp (exn-message x)) (loop))])
(with-handlers ([exn:fail? (lambda (x) (send/errorp (exn-message x)) (loop (add1 i)))])
(parameterize ([current-output-port out-str-port]
[current-error-port err-str-port])
(syntax-parameterize ([send/msg (make-rename-transformer #'send/msgp)]

10
collects/syntax/private/template-runtime.rkt
View File

@ -81,7 +81,11 @@
[(prefab? tmap)
(d->s (car data)
stx
(loop (prefab-fields tmap)
(cdr data)
(struct->list (syntax-e stx))))]
(apply
make-prefab-struct
(prefab-struct-key (syntax-e stx))
(loop (prefab-fields tmap)
(cdr data)
(struct->list (syntax-e stx))
pcons)))]
[else (error "template-map-apply fallthrough")])))

3
collects/syntax/template.rkt
View File

@ -74,8 +74,7 @@
(and k
(let ([as (loop (struct->list (syntax-e tmpl)) in-ellipses?)])
(and (or as (not const-leaf?))
(make-prefab k as))
#f)))])))
(make-prefab k as)))))])))
(define (template-map-collect tmap template s->d leaf->d pvar->d)
(let loop ([tmap tmap][template template])

1
collects/tests/racket/mzlib-tests.rktl
View File

@ -31,5 +31,6 @@
(load-in-sandbox "kw.rktl")
(load-in-sandbox "macrolib.rktl")
(load-in-sandbox "resource.rktl")
(load-in-sandbox "syntaxlibs.rktl")
(report-errs)

31
collects/tests/racket/syntaxlibs.rktl Normal file
View File

@ -0,0 +1,31 @@
(load-relative "loadtest.rktl")
(Section 'syntax/....)
(require (for-syntax syntax/template))
(let ()
(define-syntax (a-template-test stx)
(syntax-case stx ()
[(_ tmpl)
(let ([v (transform-template #'tmpl
#:save (lambda (stx) stx)
#:restore-stx (lambda (v stx datum)
(datum->syntax stx datum stx stx stx)))])
v)]))
(test '(1 #s(x "a" 1/2 8 9)
(2 3)
(#s(y 8) #s(y 9))
#(3 4 8 9)
. 6)
syntax->datum
(with-syntax ([(w ...) #'(8 9)])
(a-template-test (1 #s(x "a" 1/2 w ...)
(2 3)
(#s(y w) ...)
#(3 4 w ...)
. 6)))))
(report-errs)