diff --git a/collects/compiler/embed-unit.rkt b/collects/compiler/embed-unit.rkt index c6785fe74c..f93f3328fc 100644 --- a/collects/compiler/embed-unit.rkt +++ b/collects/compiler/embed-unit.rkt @@ -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)))]))))))) diff --git a/collects/file/resource.rkt b/collects/file/resource.rkt index 9a58731e07..bd047ac995 100644 --- a/collects/file/resource.rkt +++ b/collects/file/resource.rkt @@ -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)) diff --git a/collects/planet/private/planet-shared.rkt b/collects/planet/private/planet-shared.rkt index 4d52048cad..1b0e5adde6 100644 --- a/collects/planet/private/planet-shared.rkt +++ b/collects/planet/private/planet-shared.rkt @@ -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))) diff --git a/collects/scheme/exists/lang.rkt b/collects/scheme/exists/lang.rkt index ae8b29e518..ccd247deb4 100644 --- a/collects/scheme/exists/lang.rkt +++ b/collects/scheme/exists/lang.rkt @@ -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? diff --git a/collects/setup/parallel-do.rkt b/collects/setup/parallel-do.rkt index f3bf99ba48..fa1bc790d8 100644 --- a/collects/setup/parallel-do.rkt +++ b/collects/setup/parallel-do.rkt @@ -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)] diff --git a/collects/syntax/private/template-runtime.rkt b/collects/syntax/private/template-runtime.rkt index e300642dc1..89a1b95e6c 100644 --- a/collects/syntax/private/template-runtime.rkt +++ b/collects/syntax/private/template-runtime.rkt @@ -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")]))) diff --git a/collects/syntax/template.rkt b/collects/syntax/template.rkt index 2cb5eae99b..eb8d2798c2 100644 --- a/collects/syntax/template.rkt +++ b/collects/syntax/template.rkt @@ -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]) diff --git a/collects/tests/racket/mzlib-tests.rktl b/collects/tests/racket/mzlib-tests.rktl index df5492c9bc..b0a35143e2 100644 --- a/collects/tests/racket/mzlib-tests.rktl +++ b/collects/tests/racket/mzlib-tests.rktl @@ -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) diff --git a/collects/tests/racket/syntaxlibs.rktl b/collects/tests/racket/syntaxlibs.rktl new file mode 100644 index 0000000000..132e7c3262 --- /dev/null +++ b/collects/tests/racket/syntaxlibs.rktl @@ -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)