fix mistakes uncovered by optimizer warnings

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 
+                                                            #f #f #f
-                                                            null null
+                                                            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)))])))))))
     

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

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

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?

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

collects/syntax/private/template-runtime.rkt

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

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))
+                     (make-prefab k as)))))])))
-                #f)))])))
 
 (define (template-map-collect tmap template s->d leaf->d pvar->d)
   (let loop ([tmap tmap][template template])

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)

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)