diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index de328e60f8..63916291aa 100644 --- a/collects/mred/private/snipfile.rkt +++ b/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 + (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)] + [(bytescomplete-path filename))]) (if expected-module - (with-module-reading-parameterization - (lambda () - (let* ([first (read-syntax src in-port)] - [module-ized-exp (check-module-form first expected-module filename)] - [second (read in-port)]) - (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)))) + (jump-to-submodule + in-port + expected-module + (lambda (check-second?) + (with-module-reading-parameterization + (lambda () + (let* ([first (read-syntax src in-port)] + [module-ized-exp (check-module-form first expected-module filename)] + [second (if check-second? + (read in-port) + eof)]) + (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) diff --git a/collects/tests/gracket/load-handler.rkt b/collects/tests/gracket/load-handler.rkt new file mode 100644 index 0000000000..2f50e74362 --- /dev/null +++ b/collects/tests/gracket/load-handler.rkt @@ -0,0 +1,5 @@ +#lang racket +(require racket/gui/init + tests/racket/load-handler) + +(try-load-handler-now) diff --git a/collects/tests/racket/load-handler.rkt b/collects/tests/racket/load-handler.rkt new file mode 100644 index 0000000000..4b22d87f8a --- /dev/null +++ b/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)) diff --git a/src/racket/src/portfun.c b/src/racket/src/portfun.c index 5dfb050dba..d6f6f6a869 100644 --- a/src/racket/src/portfun.c +++ b/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; } } diff --git a/src/racket/src/print.c b/src/racket/src/print.c index b65bdda9a7..7d9c6416b1 100644 --- a/src/racket/src/print.c +++ b/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)); diff --git a/src/racket/src/startup.inc b/src/racket/src/startup.inc index e90268b810..d382f041e9 100644 --- a/src/racket/src/startup.inc +++ b/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)"