more load[/use-compiled] handler fixes for submodules

Closes PR 12630

collects/mred/private/snipfile.rkt

@@ -176,6 +176,71 @@
 		      (update-str-to-snip empty-string))
 		  port)))))))
 
+  (define (jump-to-submodule in-port expected-module k)
+    (let ([header (bytes-append #"^#~"
+                                (bytes (string-length (version)))
+                                (regexp-quote (string->bytes/utf-8 (version)))
+                                #"D")])
+      (cond
+       [(regexp-match-peek header in-port)
+        ;; The input has a submodule table:
+        (define encoded-expected
+          (apply bytes-append
+                 (for/list ([n (in-list (if (pair? expected-module)
+                                            (cdr expected-module)
+                                            '()))])
+                   (define s (string->bytes/utf-8 (symbol->string n)))
+                   (define l (bytes-length s))
+                   (bytes-append (if (l . < . 255)
+                                     (bytes l)
+                                     (bytes 255 
+                                            (bitwise-and l 255)
+                                            (bitwise-and (arithmetic-shift l -8) 255)
+                                            (bitwise-and (arithmetic-shift l -16) 255)
+                                            (bitwise-and (arithmetic-shift l -24) 255)))
+                                 s))))
+        (define (skip-bytes amt)
+          (if (file-stream-port? in-port)
+              (file-position in-port (+ (file-position in-port) amt))
+              (read-bytes amt in-port)))
+        (define len (+ 2 1 (string-length (version)) 1 4)) ; 4 for table count
+        (skip-bytes len)
+        (let loop ([pos len])
+          ;; Each node in the table's btree is <name-len> <name> <start> <len> <left> <right>
+          (define (read-num)
+            (integer-bytes->integer (read-bytes 4 in-port) #f #f))
+          (define len (read-num))
+          (define new-pos (+ pos 4))
+          (define name (read-bytes len in-port))
+          (define code-start (read-num))
+          (define code-len (read-num))
+          (define left (read-num))
+          (define right (read-num))
+          (define after-pos (+ new-pos len 16))
+          (cond
+           [(bytes=? encoded-expected name)
+            (skip-bytes (- code-start after-pos))
+            (k #f)]
+           [(bytes<? encoded-expected name)
+            (if (zero? left)
+                (void)
+                (begin
+                  (skip-bytes (- left after-pos))
+                  (loop left)))]
+           [else
+            (if (zero? right)
+                (void)
+                (begin
+                  (skip-bytes (- right after-pos))
+                  (loop right)))]))]
+       [(or (not (pair? expected-module))
+            (car expected-module))
+        ;; No table; ok to load source or full bytecode:
+        (k #t)]
+       [else
+        ;; don't load the file from source or reload useless bytecode:
+        (void)])))
+
   (define (text-editor-load-handler filename expected-module)
     (unless (path? filename)
       (raise-type-error 'text-editor-load-handler "path" filename))
@@ -187,18 +252,24 @@
                            [read-on-demand-source (and (load-on-demand-enabled)
                                                        (path->complete-path filename))])
 	      (if expected-module
-		  (with-module-reading-parameterization 
+                  (jump-to-submodule
-		   (lambda ()
+                   in-port
-		     (let* ([first (read-syntax src in-port)]
+                   expected-module
-			    [module-ized-exp (check-module-form first expected-module filename)]
+                   (lambda (check-second?)
-			    [second (read in-port)])
+                      (with-module-reading-parameterization 
-		       (unless (eof-object? second)
+                       (lambda ()
-			 (raise-syntax-error
+                         (let* ([first (read-syntax src in-port)]
-			  'text-editor-load-handler
+                                [module-ized-exp (check-module-form first expected-module filename)]
-			  (format "expected only a `module' declaration for `~s', but found an extra expression"
+                                [second (if check-second?
-				  expected-module)
+                                            (read in-port)
-			  second))
+                                            eof)])
-		       (eval module-ized-exp))))
+                           (unless (eof-object? second)
+                             (raise-syntax-error
+                              'text-editor-load-handler
+                              (format "expected only a `module' declaration for `~s', but found an extra expression"
+                                      expected-module)
+                              second))
+                           (eval module-ized-exp))))))
 		  (let loop ([last-time-values (list (void))])
 		    (let ([exp (read-syntax src in-port)])
 		      (if (eof-object? exp)

collects/tests/gracket/load-handler.rkt

@@ -0,0 +1,5 @@
+#lang racket
+(require racket/gui/init
+         tests/racket/load-handler)
+
+(try-load-handler-now)

collects/tests/racket/load-handler.rkt

@@ -0,0 +1,92 @@
+#lang racket/base
+(require racket/file
+         mzlib/compile)
+
+(provide try-load-handler-now)
+
+(module+ main
+  (try-load-handler-now))
+
+(define (try-load-handler-now)
+  ;; Check a load handler's treatment of the "expected module" argument.
+
+  (define tmp-dir (build-path (find-system-path 'temp-dir) "lhm"))
+  (define tmp-file-name "m.rkt")
+  (define tmp-file (build-path tmp-dir tmp-file-name))
+
+  (make-directory* tmp-dir)
+
+  (with-output-to-file tmp-file
+    #:exists 'truncate/replace
+    (lambda ()
+      (write '(module m racket/base
+                (define m 'm) ; errors on redeclaration
+                (provide m)
+                (module* alpha racket/base
+                  (define a 'a)
+                  (provide a))
+                (module* beta racket/base
+                  (define b 'b)
+                  (provide b))))))
+
+  (when (directory-exists? (build-path tmp-dir "compiled"))
+    (delete-directory/files (build-path tmp-dir "compiled")))
+
+  (define (do-test a b where)
+    (unless (equal? a b)
+      (error 'failed
+             "~a expected: ~e got: ~e"
+             where a b)))
+
+  (define-syntax-rule (test a b)
+    (do-test a b 'b))
+
+  (parameterize ([current-namespace (make-base-namespace)])
+    (test 'm (dynamic-require tmp-file 'm))
+    ;; From source, all modules get declared:
+    (test #t (module-declared? tmp-file #f))
+    (test #t (module-declared? `(submod ,tmp-file alpha) #f))
+    (test #t (module-declared? `(submod ,tmp-file beta) #f))
+    (test #f (module-declared? `(submod ,tmp-file other) #f))
+    (test #f (module-declared? `(submod ,tmp-file other) #t))
+    ;; Requires should succeed:
+    (test 'a (dynamic-require `(submod ,tmp-file alpha) 'a))
+    (test 'b (dynamic-require `(submod ,tmp-file beta) 'b)))
+
+  (parameterize ([current-namespace (make-base-namespace)])
+    (void (compile-file tmp-file)))
+
+  (parameterize ([current-namespace (make-base-namespace)])
+    (test 'm (dynamic-require tmp-file 'm))
+    ;; From bytecode, modules get declared only on demand:
+    (test #t (module-declared? tmp-file #f))
+    (test #f (module-declared? `(submod ,tmp-file alpha) #f))
+    (test #f (module-declared? `(submod ,tmp-file beta) #f))
+    (test #f (module-declared? `(submod ,tmp-file other) #f))
+    (test #f (module-declared? `(submod ,tmp-file other) #t))
+    ;; Requires should succeed:
+    (test 'a (dynamic-require `(submod ,tmp-file alpha) 'a))
+    (test #t (module-declared? `(submod ,tmp-file alpha) #f))
+    (test #f (module-declared? `(submod ,tmp-file beta) #f))
+    (test 'b (dynamic-require `(submod ,tmp-file beta) 'b))
+    (test #t (module-declared? `(submod ,tmp-file beta) #f)))
+
+  (parameterize ([current-namespace (make-base-namespace)])
+    ;; eval compiled code directly:
+    (parameterize ([current-module-declare-name (make-resolved-module-path (build-path tmp-dir tmp-file-name))]
+                   [read-accept-compiled #t])
+      (with-input-from-file (build-path tmp-dir "compiled" (path-add-suffix tmp-file-name #".zo"))
+        (lambda () (eval (read)))))
+    ;; It's as if we read from source:
+    (test 'm (dynamic-require tmp-file 'm))
+    ;; From source, all modules get declared:
+    (test #t (module-declared? tmp-file #f))
+    (test #t (module-declared? `(submod ,tmp-file alpha) #f))
+    (test #t (module-declared? `(submod ,tmp-file beta) #f))
+    (test #f (module-declared? `(submod ,tmp-file other) #f))
+    (test #f (module-declared? `(submod ,tmp-file other) #t))
+    ;; Requires should succeed:
+    (test 'a (dynamic-require `(submod ,tmp-file alpha) 'a))
+    (test 'b (dynamic-require `(submod ,tmp-file beta) 'b)))
+
+  (delete-directory/files tmp-dir))

src/racket/src/portfun.c

@@ -4285,7 +4285,7 @@ static Scheme_Object *do_load_handler(void *data)
       while (pos) {
         name_size = get_number(port, pos);
         s = get_bytes(port, pos + 4, name_size);
-        if ((name_size == namelen) && !strncmp(find_name, s,name_size)) {
+        if ((name_size == namelen) && !strncmp(find_name, s, name_size)) {
           /* found it */
           offset = get_number(port, pos + 4 + name_size);
           break;
@@ -4294,7 +4294,10 @@ static Scheme_Object *do_load_handler(void *data)
         rellen = namelen;
         for (i = 0; (i < rellen) && (i < name_size); i++) {
           if (find_name[i] != s[i]) {
-            rellen = 0;
+            if (((unsigned char *)find_name)[i] < ((unsigned char *)s)[i])
+              rellen = 0;
+            else
+              rellen = name_size + 1;
             break;
           }
         }

src/racket/src/print.c

@@ -1851,7 +1851,7 @@ static intptr_t compute_module_subtrees(Module_And_Offset *a, intptr_t *subtrees
   intptr_t len;
 
   len = SCHEME_BYTE_STRLEN_VAL(o);
-  offset += 8 + len + 20;
+  offset += 4 + len + 16;
 
   if (midpt > start)
     offset = compute_module_subtrees(a, subtrees, start, midpt - start, offset);
@@ -3112,7 +3112,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
       /* orig_a is in declaration order, a in sorted (for btree) order */
 
       subtrees = MALLOC_N_ATOMIC(intptr_t, count);
-      (void)compute_module_subtrees(a, subtrees, 0, count, 0);
+      (void)compute_module_subtrees(a, subtrees, 0, count, init_offset);
 
       print_this_string(pp, "#~", 0, 2);
       print_one_byte(pp, strlen(MZSCHEME_VERSION));

src/racket/src/startup.inc

@@ -660,6 +660,10 @@
 "(or(and(not bm) am) "
 "(and am bm(>=(cdr am)(cdr bm)) am)))))))"
 "(lambda(path expect-module)"
+"(with-continuation-mark"
+" parameterization-key"
+" orig-paramz"
+" (printf \"~s ~s\\n\" path expect-module))"
 "(unless(path-string? path)"
 " (raise-type-error 'load/use-compiled \"path or valid-path string\" path))"
 "(unless(or(not expect-module)"