1#lang racket/base 2(require '#%paramz 3 racket/private/place-local 4 "../eval/collection.rkt" 5 "../syntax/api.rkt" 6 "../syntax/error.rkt" 7 "../syntax/srcloc.rkt" 8 "../syntax/taint.rkt" 9 "../namespace/namespace.rkt" 10 "../eval/parameter.rkt" 11 "../eval/main.rkt" 12 "../eval/dynamic-require.rkt" 13 "../namespace/api.rkt" 14 "../common/module-path.rkt" 15 "../eval/module-read.rkt" 16 "../expand/missing-module.rkt" 17 "../read/api.rkt" 18 "../read/primitive-parameter.rkt" 19 "load-handler.rkt" 20 "../common/performance.rkt") 21 22(provide boot 23 seal 24 orig-paramz 25 26 boot-primitives) 27 28(define-values (dll-suffix) 29 (system-type 'so-suffix)) 30 31(define default-load/use-compiled 32 (let* ([resolve (lambda (s) 33 (if (complete-path? s) 34 s 35 (let ([d (current-load-relative-directory)]) 36 (if d (path->complete-path s d) s))))] 37 [date-of-1 (lambda (a) 38 (let ([v (file-or-directory-modify-seconds a #f (lambda () #f))]) 39 (and v (cons a v))))] 40 [date-of (lambda (a modes roots) 41 (ormap (lambda (root-dir) 42 (ormap 43 (lambda (compiled-dir) 44 (let ([a (a root-dir compiled-dir)]) 45 (date-of-1 a))) 46 modes)) 47 roots))] 48 [date>=? 49 (lambda (modes roots a bm) 50 (and a 51 (let ([am (date-of a modes roots)]) 52 (or (and (not bm) am) 53 (and am bm (>= (cdr am) (cdr bm)) am)))))] 54 [with-dir* (lambda (base t) 55 (parameterize ([current-load-relative-directory 56 (if (path? base) 57 base 58 (current-directory))]) 59 (t)))]) 60 (lambda (path expect-module) 61 (unless (path-string? path) 62 (raise-argument-error 'load/use-compiled "path-string?" path)) 63 (unless (or (not expect-module) 64 (symbol? expect-module) 65 (and (list? expect-module) 66 ((length expect-module) . > . 1) 67 (or (symbol? (car expect-module)) 68 (not (car expect-module))) 69 (andmap symbol? (cdr expect-module)))) 70 (raise-argument-error 'load/use-compiled "(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))" path)) 71 (define name (and expect-module (current-module-declare-name))) 72 (define ns-hts (and name (registry-table-ref (namespace-module-registry (current-namespace))))) 73 (define use-path/src (and ns-hts (hash-ref (cdr ns-hts) name #f))) 74 (if use-path/src 75 ;; Use previous decision of .zo vs. source: 76 (parameterize ([current-module-declare-source (cadr use-path/src)]) 77 (with-dir* (caddr use-path/src) 78 (lambda () ((current-load) (car use-path/src) expect-module)))) 79 ;; Check .zo vs. src dates, etc.: 80 (let*-values ([(orig-path) (resolve path)] 81 [(base orig-file dir?) (split-path path)] 82 [(file alt-file) (if expect-module 83 (let* ([b (path->bytes orig-file)] 84 [len (bytes-length b)]) 85 (cond 86 [(and (len . >= . 4) 87 (bytes=? #".rkt" (subbytes b (- len 4)))) 88 ;; .rkt => try .rkt then .ss 89 (values orig-file 90 (bytes->path (bytes-append (subbytes b 0 (- len 4)) #".ss")))] 91 [else 92 ;; No search path 93 (values orig-file #f)])) 94 (values orig-file #f))] 95 [(path) (if (eq? file orig-file) 96 orig-path 97 (build-path base file))] 98 [(alt-path) (and alt-file 99 (if (eq? alt-file orig-file) 100 orig-path 101 (build-path base alt-file)))] 102 [(base) (if (eq? base 'relative) 'same base)] 103 [(modes) (use-compiled-file-paths)] 104 [(roots) (current-compiled-file-roots)] 105 [(reroot) (lambda (p d) 106 (cond 107 [(eq? d 'same) p] 108 [(relative-path? d) (build-path p d)] 109 [else (reroot-path p d)]))]) 110 (let* ([main-path-d (date-of-1 path)] 111 [alt-path-d (and alt-path 112 (not main-path-d) 113 (date-of-1 alt-path))] 114 [path-d (or main-path-d alt-path-d)] 115 [get-so (lambda (file rep-sfx?) 116 (and (eq? 'racket (system-type 'vm)) 117 (lambda (root-dir compiled-dir) 118 (build-path (reroot base root-dir) 119 compiled-dir 120 "native" 121 (system-library-subpath) 122 (if rep-sfx? 123 (path-add-extension 124 file 125 dll-suffix) 126 file)))))] 127 [zo (lambda (root-dir compiled-dir) 128 (build-path (reroot base root-dir) 129 compiled-dir 130 (path-add-extension file #".zo")))] 131 [alt-zo (lambda (root-dir compiled-dir) 132 (build-path (reroot base root-dir) 133 compiled-dir 134 (path-add-extension alt-file #".zo")))] 135 [so (get-so file #t)] 136 [alt-so (get-so alt-file #t)] 137 [try-main? (or main-path-d (not alt-path-d))] 138 [try-alt? (and alt-file (or alt-path-d (not main-path-d)))] 139 [with-dir (lambda (t) (with-dir* base t))]) 140 (cond 141 [(and so 142 try-main? 143 (date>=? modes roots so path-d)) 144 => (lambda (so-d) 145 (parameterize ([current-module-declare-source #f]) 146 (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] 147 [(and alt-so 148 try-alt? 149 (date>=? modes roots alt-so alt-path-d)) 150 => (lambda (so-d) 151 (parameterize ([current-module-declare-source alt-path]) 152 (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] 153 [(and try-main? 154 (date>=? modes roots zo path-d)) 155 => (lambda (zo-d) 156 (register-zo-path name ns-hts (car zo-d) #f base) 157 (parameterize ([current-module-declare-source #f]) 158 (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] 159 [(and try-alt? 160 (date>=? modes roots alt-zo path-d)) 161 => (lambda (zo-d) 162 (register-zo-path name ns-hts (car zo-d) alt-path base) 163 (parameterize ([current-module-declare-source alt-path]) 164 (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] 165 [(or (not (pair? expect-module)) 166 (car expect-module) 167 (is-compiled-file? (if try-main? path alt-path))) 168 (let ([p (if try-main? path alt-path)]) 169 ;; "quiet" failure when asking for a submodule: 170 (unless (and (pair? expect-module) 171 (not (file-exists? p))) 172 (parameterize ([current-module-declare-source (and expect-module 173 (not try-main?) 174 p)]) 175 (with-dir (lambda () ((current-load) p expect-module))))))]))))))) 176 177(define (register-zo-path name ns-hts path src-path base) 178 (when ns-hts 179 (hash-set! (cdr ns-hts) name (list path src-path base)))) 180 181(define (is-compiled-file? p) 182 (and (file-exists? p) 183 (call-with-input-file* p linklet-directory-start))) 184 185(define (default-reader-guard path) 186 path) 187 188;; weak map from namespace to pair of module-name hts 189(define-place-local -module-hash-table-table 190 (make-weak-hasheq)) 191 192(define (registry-table-ref reg) 193 (define e (hash-ref -module-hash-table-table 194 reg 195 #f)) 196 (and e (ephemeron-value e))) 197 198(define (registry-table-set! reg v) 199 (hash-set! -module-hash-table-table 200 reg 201 (make-ephemeron reg v))) 202 203;; Weak map from a module registries to a cache that maps module 204;; references to resolved-module information. The idea behind mapping 205;; from a registry is that changes made to the collection mapping 206;; (e.g., by installing a package) reliably take effect when changing 207;; namespaces, so using the same namespace may not see the change. 208;; Also, we only cache on successful loads, so changing the mapping 209;; for that namespace probably doesn't make sense, anyway, for 210;; anything that was successfully loaded. 211(define-place-local path-caches (make-weak-hasheq)) 212 213(define (path-cache-get p reg) 214 (define cache (hash-ref path-caches reg #hash())) 215 (hash-ref cache p #f)) 216 217(define (path-cache-set! p reg v) 218 (define current-cache (hash-ref path-caches reg #hash())) 219 ;; Limit cache memory use by flushing the whole thing when it 220 ;; reaches a maximum size: 221 (define cache (if (= (hash-count current-cache) 1024) 222 #hash() 223 current-cache)) 224 (hash-set! path-caches reg (hash-set cache p v))) 225 226(define -loading-filename (gensym)) 227(define -loading-prompt-tag (make-continuation-prompt-tag 'module-loading)) 228(define-place-local -prev-relto #f) 229(define-place-local -prev-relto-dir #f) 230 231(define (split-relative-string s coll-mode?) 232 (let ([l (let loop ([s s]) 233 (let ([len (string-length s)]) 234 (let iloop ([i 0]) 235 (cond 236 [(= i len) (list s)] 237 [(char=? #\/ (string-ref s i)) 238 (cons (substring s 0 i) 239 (loop (substring s (add1 i))))] 240 [else (iloop (add1 i))]))))]) 241 (if coll-mode? 242 l 243 (let loop ([l l]) 244 (if (null? (cdr l)) 245 (values null (car l)) 246 (let-values ([(c f) (loop (cdr l))]) 247 (values (cons (car l) c) f))))))) 248 249(define (format-source-location stx) 250 (srcloc->string (srcloc (syntax-source stx) 251 (syntax-line stx) 252 (syntax-column stx) 253 (syntax-position stx) 254 (syntax-span stx)))) 255 256(define-place-local orig-paramz #f) 257(define-place-local planet-resolver #f) 258 259(define (prep-planet-resolver!) 260 (unless planet-resolver 261 (with-continuation-mark 262 parameterization-key 263 orig-paramz 264 (set! planet-resolver (dynamic-require '(lib "planet/resolver.rkt") 'planet-module-name-resolver))))) 265 266(define standard-module-name-resolver 267 (case-lambda 268 [(s from-namespace) 269 (unless (resolved-module-path? s) 270 (raise-argument-error 'standard-module-name-resolver 271 "resolved-module-path?" 272 s)) 273 (unless (or (not from-namespace) (namespace? from-namespace)) 274 (raise-argument-error 'standard-module-name-resolver 275 "(or/c #f namespace?)" 276 from-namespace)) 277 (when planet-resolver 278 ;; Let planet resolver register, too: 279 (planet-resolver s)) 280 ;; Register s as loaded: 281 (let ([hts (or (registry-table-ref (namespace-module-registry (current-namespace))) 282 (let ([hts (cons (make-hasheq) (make-hasheq))]) 283 (registry-table-set! (namespace-module-registry (current-namespace)) 284 hts) 285 hts))]) 286 (hash-set! (car hts) s 'declared) 287 ;; If attach from another namespace, copy over source-file path, if any: 288 (when from-namespace 289 (let ([root-name (if (pair? (resolved-module-path-name s)) 290 (make-resolved-module-path (car (resolved-module-path-name s))) 291 s)] 292 [from-hts (registry-table-ref (namespace-module-registry from-namespace))]) 293 (when from-hts 294 (let ([use-path/src (hash-ref (cdr from-hts) root-name #f)]) 295 (when use-path/src 296 (hash-set! (cdr hts) root-name use-path/src)))))))] 297 [(s relto stx) ; for backward-compatibility 298 (log-message (current-logger) 'error 299 "default module name resolver called with three arguments (deprecated)" 300 #f) 301 (standard-module-name-resolver s relto stx #t)] 302 [(s relto stx load?) 303 ;; If stx is not #f, raise syntax error for ill-formed paths 304 (unless (module-path? s) 305 (if (syntax? stx) 306 (raise-syntax-error #f 307 "bad module path" 308 stx) 309 (raise-argument-error 'standard-module-name-resolver 310 "module-path?" 311 s))) 312 (unless (or (not relto) (resolved-module-path? relto)) 313 (raise-argument-error 'standard-module-name-resolver 314 "(or/c #f resolved-module-path?)" 315 relto)) 316 (unless (or (not stx) (syntax? stx)) 317 (raise-argument-error 'standard-module-name-resolver 318 "(or/c #f syntax?)" 319 stx)) 320 (define (flatten-sub-path base orig-l) 321 (let loop ([a null] [l orig-l]) 322 (cond 323 [(null? l) (if (null? a) 324 base 325 (cons base (reverse a)))] 326 [(equal? (car l) "..") 327 (if (null? a) 328 (error 329 'standard-module-name-resolver 330 "too many \"..\"s in submodule path: ~.s" 331 (list* 'submod 332 (if (equal? base ".") 333 base 334 (if (path? base) 335 base 336 (list (if (symbol? base) 'quote 'file) base))) 337 orig-l)) 338 (loop (cdr a) (cdr l)))] 339 [else (loop (cons (car l) a) (cdr l))]))) 340 (cond 341 [(and (pair? s) (eq? (car s) 'quote)) 342 (make-resolved-module-path (cadr s))] 343 [(and (pair? s) (eq? (car s) 'submod) 344 (pair? (cadr s)) (eq? (caadr s) 'quote)) 345 (make-resolved-module-path (flatten-sub-path (cadadr s) (cddr s)))] 346 [(and (pair? s) (eq? (car s) 'submod) 347 (or (equal? (cadr s) ".") 348 (equal? (cadr s) "..")) 349 (and relto 350 (let ([p (resolved-module-path-name relto)]) 351 (or (symbol? p) 352 (and (pair? p) (symbol? (car p))))))) 353 (define rp (resolved-module-path-name relto)) 354 (make-resolved-module-path (flatten-sub-path (if (pair? rp) (car rp) rp) 355 (let ([r (if (equal? (cadr s) "..") 356 (cdr s) 357 (cddr s))]) 358 (if (pair? rp) 359 (append (cdr rp) r) 360 r))))] 361 [(and (pair? s) (eq? (car s) 'planet)) 362 (prep-planet-resolver!) 363 (planet-resolver s relto stx load? #f orig-paramz)] 364 [(and (pair? s) 365 (eq? (car s) 'submod) 366 (pair? (cadr s)) 367 (eq? (caadr s) 'planet)) 368 (prep-planet-resolver!) 369 (planet-resolver (cadr s) relto stx load? (cddr s) orig-paramz)] 370 [else 371 (let ([get-dir (lambda () 372 (or (and relto 373 (if (eq? relto -prev-relto) 374 -prev-relto-dir 375 (let ([p (resolved-module-path-name relto)]) 376 (let ([p (if (pair? p) (car p) p)]) 377 (and (path? p) 378 (let-values ([(base n d?) (split-path p)]) 379 (set! -prev-relto relto) 380 (set! -prev-relto-dir base) 381 base)))))) 382 (current-load-relative-directory) 383 (current-directory)))] 384 [get-reg (lambda () 385 (namespace-module-registry (current-namespace)))] 386 [show-collection-err (lambda (msg) 387 (let ([msg (string-append 388 (or (and stx 389 (error-print-source-location) 390 (format-source-location stx)) 391 "standard-module-name-resolver") 392 ": " 393 (regexp-replace #rx"\n" 394 msg 395 (format "\n for module path: ~s\n" 396 s)))]) 397 (raise 398 (if stx 399 (exn:fail:syntax:missing-module 400 msg 401 (current-continuation-marks) 402 (list (syntax-taint stx)) 403 s) 404 (exn:fail:filesystem:missing-module 405 msg 406 (current-continuation-marks) 407 s)))))] 408 [invent-collection-dir (lambda (f-file col col-path fail) 409 (lambda (msg) 410 ;; No such module => make a module-name symbol that 411 ;; certainly isn't declared 412 (string->uninterned-symbol 413 (path->string 414 (build-path (apply build-path col col-path) f-file)))))] 415 [ss->rkt (lambda (s) 416 (let ([len (string-length s)]) 417 (if (and (len . >= . 3) 418 ;; ".ss" 419 (equal? #\. (string-ref s (- len 3))) 420 (equal? #\s (string-ref s (- len 2))) 421 (equal? #\s (string-ref s (- len 1)))) 422 (string-append (substring s 0 (- len 3)) ".rkt") 423 s)))] 424 [path-ss->rkt (lambda (p) 425 (let-values ([(base name dir?) (split-path p)]) 426 (if (regexp-match #rx"[.]ss$" (path->bytes name)) 427 (path-replace-extension p #".rkt") 428 p)))] 429 [s (if (and (pair? s) (eq? 'submod (car s))) 430 (let ([v (cadr s)]) 431 (if (or (equal? v ".") 432 (equal? v "..")) 433 (if relto 434 ;; must have a path inside, or we wouldn't get here 435 (let ([p (resolved-module-path-name relto)]) 436 (if (pair? p) 437 (car p) 438 p)) 439 (error 'standard-module-name-resolver 440 "no base path for relative submodule path: ~.s" 441 s)) 442 v)) 443 s)] 444 [subm-path (if (and (pair? s) (eq? 'submod (car s))) 445 (let ([p (if (and (or (equal? (cadr s) ".") 446 (equal? (cadr s) "..")) 447 relto) 448 (let ([p (resolved-module-path-name relto)] 449 [r (if (equal? (cadr s) "..") 450 (cdr s) 451 (cddr s))]) 452 (if (pair? p) 453 (flatten-sub-path (car p) (append (cdr p) r)) 454 (flatten-sub-path p r))) 455 (flatten-sub-path "." 456 (if (equal? (cadr s) "..") 457 (cdr s) 458 (cddr s))))]) 459 ;; flattening may erase the submodule path: 460 (if (pair? p) 461 (cdr p) 462 #f)) 463 #f)]) 464 (let ([s-parsed 465 ;; Non-string, non-vector result represents an error, but 466 ;; a symbol result is a special kind of error for the purposes 467 ;; of dealing with a submodule path when there's no such 468 ;; collection 469 (cond 470 [(symbol? s) 471 (or (path-cache-get s (get-reg)) 472 (let-values ([(cols file) (split-relative-string (symbol->string s) #f)]) 473 (let* ([f-file (if (null? cols) 474 "main.rkt" 475 (string-append file ".rkt"))] 476 [col (if (null? cols) file (car cols))] 477 [col-path (if (null? cols) null (cdr cols))]) 478 (find-col-file (if (not subm-path) 479 show-collection-err 480 ;; Invent a fictional collection directory, if necessary, 481 ;; so that we don't raise an exception: 482 (invent-collection-dir f-file col col-path 483 show-collection-err)) 484 col 485 col-path 486 f-file 487 #t))))] 488 [(string? s) 489 (let* ([dir (get-dir)]) 490 (or (path-cache-get (cons s dir) #f) 491 (let-values ([(cols file) (split-relative-string s #f)]) 492 (if (null? cols) 493 (build-path dir (ss->rkt file)) 494 (apply build-path 495 dir 496 (append 497 (map (lambda (s) 498 (cond 499 [(string=? s ".") 'same] 500 [(string=? s "..") 'up] 501 [else s])) 502 cols) 503 (list (ss->rkt file))))))))] 504 [(path? s) 505 ;; Use filesystem-sensitive `simplify-path' here: 506 (path-ss->rkt (simplify-path (if (complete-path? s) 507 s 508 (path->complete-path s (get-dir)))))] 509 [(eq? (car s) 'lib) 510 (or (path-cache-get s (get-reg)) 511 (let*-values ([(cols file) (split-relative-string (cadr s) #f)] 512 [(old-style?) (if (null? (cddr s)) 513 (and (null? cols) 514 (regexp-match? #rx"[.]" file)) 515 #t)]) 516 (let* ([f-file (if old-style? 517 (ss->rkt file) 518 (if (null? cols) 519 "main.rkt" 520 (if (regexp-match? #rx"[.]" file) 521 (ss->rkt file) 522 (string-append file ".rkt"))))]) 523 (let-values ([(cols) 524 (if old-style? 525 (append (if (null? (cddr s)) 526 '("mzlib") 527 (apply append 528 (map (lambda (p) 529 (split-relative-string p #t)) 530 (cddr s)))) 531 cols) 532 (if (null? cols) 533 (list file) 534 cols))]) 535 (find-col-file show-collection-err 536 (car cols) 537 (cdr cols) 538 f-file 539 #t)))))] 540 [(eq? (car s) 'file) 541 ;; Use filesystem-sensitive `simplify-path' here: 542 (path-ss->rkt 543 (simplify-path (path->complete-path (expand-user-path (cadr s)) (get-dir))))])]) 544 (cond 545 [(symbol? s-parsed) 546 ;; Return a genenerated symnol 547 (make-resolved-module-path 548 (cons s-parsed subm-path))] 549 [(not (or (path? s-parsed) 550 (vector? s-parsed))) 551 (if stx 552 (raise-syntax-error 553 'require 554 (format "bad module path~a" (if s-parsed 555 (car s-parsed) 556 "")) 557 stx) 558 (raise-argument-error 559 'standard-module-name-resolver 560 "module-path?" 561 s))] 562 [else 563 ;; At this point, s-parsed is a complete path (or a cached vector) 564 (define filename (if (vector? s-parsed) 565 (vector-ref s-parsed 0) 566 (simplify-path (cleanse-path s-parsed) #f))) 567 (define normal-filename (if (vector? s-parsed) 568 (vector-ref s-parsed 1) 569 (normal-case-path filename))) 570 (define-values (base name dir?) (if (vector? s-parsed) 571 (values 'ignored (vector-ref s-parsed 2) 'ignored) 572 (split-path filename))) 573 (define no-sfx (if (vector? s-parsed) 574 (vector-ref s-parsed 3) 575 (path-replace-extension name #""))) 576 (define root-modname (if (vector? s-parsed) 577 (vector-ref s-parsed 4) 578 (make-resolved-module-path filename))) 579 (define hts (or (registry-table-ref (get-reg)) 580 (let ([hts (cons (make-hasheq) (make-hasheq))]) 581 (registry-table-set! (get-reg) 582 hts) 583 hts))) 584 (define modname (if subm-path 585 (make-resolved-module-path 586 (cons (resolved-module-path-name root-modname) 587 subm-path)) 588 root-modname)) 589 ;; Loaded already? 590 (when load? 591 (let ([got (hash-ref (car hts) modname #f)]) 592 (unless got 593 ;; Currently loading? 594 (let ([loading 595 (let ([tag (if (continuation-prompt-available? -loading-prompt-tag) 596 -loading-prompt-tag 597 (default-continuation-prompt-tag))]) 598 (continuation-mark-set-first 599 #f 600 -loading-filename 601 null 602 tag))] 603 [nsr (get-reg)]) 604 (for-each 605 (lambda (s) 606 (when (and (equal? (cdr s) normal-filename) 607 (eq? (car s) nsr)) 608 (error 609 'standard-module-name-resolver 610 "cycle in loading\n at path: ~a\n paths:~a" 611 filename 612 (apply string-append 613 (let loop ([l (reverse loading)]) 614 (if (null? l) 615 '() 616 (list* "\n " (path->string (cdar l)) (loop (cdr l))))))))) 617 loading) 618 ((if (continuation-prompt-available? -loading-prompt-tag) 619 (lambda (f) (f)) 620 (lambda (f) (call-with-continuation-prompt f -loading-prompt-tag))) 621 (lambda () 622 (with-continuation-mark 623 -loading-filename (cons (cons nsr normal-filename) 624 loading) 625 (parameterize ([current-module-declare-name root-modname] 626 [current-module-path-for-load 627 ;; If `s' is an absolute module path, then 628 ;; keep it as-is, the better to let a tool 629 ;; recommend how to get an unavailable module; 630 ;; also, propagate the source location. 631 ((if stx 632 (lambda (p) (datum->syntax #f p stx)) 633 values) 634 (cond 635 [(symbol? s) s] 636 [(and (pair? s) (eq? (car s) 'lib)) s] 637 [else (if (resolved-module-path? root-modname) 638 (let ([src (resolved-module-path-name root-modname)]) 639 (if (symbol? src) 640 (list 'quote src) 641 src)) 642 root-modname)]))]) 643 ((current-load/use-compiled) 644 filename 645 (let ([sym (string->symbol (path->string no-sfx))]) 646 (if subm-path 647 (if (hash-ref (car hts) root-modname #f) 648 ;; Root is already loaded, so only use .zo 649 (cons #f subm-path) 650 ;; Root isn't loaded, so it's ok to load form source: 651 (cons sym subm-path)) 652 sym))))))))))) 653 ;; If a `lib' path, cache pathname manipulations 654 (when (and (not (vector? s-parsed)) 655 load? 656 (or (string? s) 657 (symbol? s) 658 (and (pair? s) 659 (eq? (car s) 'lib)))) 660 (path-cache-set! (if (string? s) 661 (cons s (get-dir)) 662 s) 663 (if (string? s) 664 #f 665 (get-reg)) 666 (vector filename 667 normal-filename 668 name 669 no-sfx 670 root-modname))) 671 ;; Result is the module name: 672 modname])))])])) 673 674(define default-eval-handler 675 (lambda (s) 676 (eval s 677 (current-namespace) 678 (let ([c (current-compile)]) 679 (lambda (e ns) 680 ;; `ns` is `(current-namespace)`, but possibly 681 ;; phase-shifted 682 (if (eq? ns (current-namespace)) 683 (c e #t) 684 (parameterize ([current-namespace ns]) 685 (c e #t)))))))) 686 687(define default-compile-handler 688 ;; Constrained to two arguments: 689 (lambda (s immediate-eval?) (compile s 690 (current-namespace) 691 (not immediate-eval?)))) 692 693(define (default-read-interaction src in) 694 (unless (input-port? in) 695 (raise-argument-error 'default-read-interaction "input-port?" in)) 696 (parameterize ([read-accept-reader #t] 697 [read-accept-lang #f]) 698 (read-syntax src in))) 699 700(define (boot) 701 (set! -module-hash-table-table (make-weak-hasheq)) 702 (set! path-caches (make-weak-hasheq)) 703 (seal) 704 (current-module-name-resolver standard-module-name-resolver) 705 (current-load/use-compiled default-load/use-compiled) 706 (current-reader-guard default-reader-guard) 707 (current-eval default-eval-handler) 708 (current-compile default-compile-handler) 709 (current-load default-load-handler) 710 (current-read-interaction default-read-interaction)) 711 712(define (seal) 713 (set! orig-paramz 714 (reparameterize 715 (continuation-mark-set-first #f parameterization-key)))) 716 717(define (get-original-parameterization) 718 orig-paramz) 719 720;; ---------------------------------------- 721;; For historical uses of '#%boot 722 723(define boot-primitives 724 (hash 'boot boot 725 'seal seal 726 ;; Historically, exported a `orig-paramz` after place 727 ;; initialization, but we now need an indirection 728 'get-original-parameterization get-original-parameterization)) 729