1(top-level-program 2 (import (except (chezpart) 3 eval 4 read) 5 (rumble) 6 (only (expander) 7 boot 8 current-command-line-arguments 9 use-compiled-file-paths 10 current-library-collection-links 11 find-library-collection-links 12 current-library-collection-paths 13 find-library-collection-paths 14 use-collection-link-paths 15 current-compiled-file-roots 16 find-compiled-file-roots 17 find-main-config 18 executable-yield-handler 19 load-on-demand-enabled 20 use-user-specific-search-paths 21 eval 22 read 23 load 24 dynamic-require 25 namespace-require 26 embedded-load 27 module-path? 28 module-declared? 29 module->language-info 30 module-path-index-join 31 identifier-binding 32 namespace-datum-introduce 33 datum->kernel-syntax 34 namespace-variable-value 35 version 36 exit 37 compile-keep-source-locations! 38 expander-place-init! 39 path-list-string->path-list) 40 (regexp) 41 (io) 42 (thread) 43 (only (linklet) 44 omit-debugging? 45 platform-independent-zo-mode? 46 linklet-performance-init! 47 linklet-performance-report! 48 current-compile-target-machine 49 compile-target-machine? 50 add-cross-compiler! 51 primitive-lookup)) 52 53 (linklet-performance-init!) 54 (unless omit-debugging? 55 (compile-keep-source-locations! #t)) 56 57 (define-syntax seq (syntax-rules () [(_ expr ...) (define dummy (let () expr ... (void)))])) 58 59 (define (run the-command-line-arguments/maybe-bytes) 60 (define the-command-line-arguments 61 (map (lambda (s) (if (bytes? s) 62 (bytes->string/locale s #\?) 63 s)) 64 the-command-line-arguments/maybe-bytes)) 65 (define (find-original-bytes s) 66 ;; In case `the-command-line-arguments/maybe-bytes` has bytes, 67 ;; try to get the original byte string for `s` 68 (let loop ([args the-command-line-arguments] 69 [args/maybe-bytes the-command-line-arguments/maybe-bytes]) 70 (cond 71 [(null? args) s] 72 [(eq? (car args) s) (car args/maybe-bytes)] 73 [else (loop (cdr args) (cdr args/maybe-bytes))]))) 74 (define (->path s) 75 (cond 76 [(path? s) s] 77 [(bytes? s) (bytes->path s)] 78 [else (string->path s)])) 79 80 (define (getenv-bytes str) 81 (environment-variables-ref (current-environment-variables) (string->utf8 str))) 82 83 (define (startup-error fmt . args) 84 (#%fprintf (#%current-error-port) "~a: " (path->string (find-system-path 'exec-file))) 85 (if (null? args) 86 (#%display fmt (#%current-error-port)) 87 (#%apply #%fprintf (#%current-error-port) fmt args)) 88 (#%newline (#%current-error-port)) 89 (exit 1)) 90 91 (define builtin-argc 11) 92 (seq 93 (unless (>= (length the-command-line-arguments) builtin-argc) 94 (startup-error (string-append 95 "expected `embedded-interactive-mode?`," 96 " `exec-file`, `run-file`, `collects`, and `etc` paths" 97 " plus `k-file`, `segment-offset`, `cs-compiled-subdir?`, `is-gui?`," 98 " `wm-is-gracket-or-x11-arg-count`, and `gracket-guid-or-x11-args`" 99 " to start"))) 100 (set-exec-file! (->path (list-ref the-command-line-arguments/maybe-bytes 1))) 101 (set-run-file! (->path (list-ref the-command-line-arguments/maybe-bytes 2)))) 102 (define embedded-interactive-mode? (string=? "true" (list-ref the-command-line-arguments 0))) 103 (define-values (init-collects-dir collects-pre-extra) 104 (let ([s (list-ref the-command-line-arguments/maybe-bytes 3)]) 105 (cond 106 [(or (equal? s "") 107 (equal? s '#vu8())) 108 (values 'disable '())] 109 [(or (string? s) (bytevector? s)) (values (->path s) '())] 110 [else (let ([s (reverse s)]) 111 (values (->path (car s)) 112 (map ->path (cdr s))))]))) 113 (define init-config-dir (->path (or (getenv-bytes "PLTCONFIGDIR") 114 (list-ref the-command-line-arguments/maybe-bytes 4)))) 115 (define k-executable-path (let ([s (list-ref the-command-line-arguments/maybe-bytes 5)]) 116 (and (not (or (equal? s "") (equal? s '#vu8()))) 117 s))) 118 (define segment-offset (#%string->number (list-ref the-command-line-arguments 6))) 119 (define cs-compiled-subdir? (string=? "true" (list-ref the-command-line-arguments 7))) 120 (define gracket? (string=? "true" (list-ref the-command-line-arguments 8))) 121 (define wm-is-gracket-or-x11-arg-count (string->number (list-ref the-command-line-arguments 9))) 122 (define gracket-guid-or-x11-args (list-ref the-command-line-arguments 10)) 123 124 (seq 125 (when (eq? 'windows (system-type)) 126 (unsafe-register-process-global (string->bytes/utf-8 "PLT_WM_IS_GRACKET") 127 (ptr-add #f wm-is-gracket-or-x11-arg-count)) 128 (unsafe-register-process-global (string->bytes/utf-8 "PLT_GRACKET_GUID") 129 (bytes-append (string->bytes/utf-8 gracket-guid-or-x11-args) #vu8(0)))) 130 (when (eq? 'macosx (system-type)) 131 (when gracket? 132 (unsafe-register-process-global (string->bytes/utf-8 "PLT_IS_FOREGROUND_APP") 133 (ptr-add #f 1)))) 134 (when (eq? 'unix (system-type)) 135 (when gracket? 136 (unsafe-register-process-global (string->bytes/utf-8 "PLT_X11_ARGUMENT_COUNT") 137 (ptr-add #f wm-is-gracket-or-x11-arg-count)) 138 (unsafe-register-process-global (string->bytes/utf-8 "PLT_X11_ARGUMENTS") 139 (ptr-add #f (#%string->number (substring gracket-guid-or-x11-args 2) 16)))))) 140 141 (define compiled-file-paths 142 (list (cond 143 [(getenv-bytes "PLT_ZO_PATH") 144 => (lambda (s) 145 (unless (and (not (equal? s #vu8())) 146 (relative-path? (->path s))) 147 (startup-error "PLT_ZO_PATH environment variable is not a valid path")) 148 (->path s))] 149 [cs-compiled-subdir? 150 (build-path "compiled" 151 (->path 152 (cond 153 [platform-independent-zo-mode? "cs"] 154 [else (symbol->string (machine-type))])))] 155 [else "compiled"]))) 156 (define user-specific-search-paths? #t) 157 (define load-on-demand? #t) 158 (define compile-target-machine (if (getenv "PLT_COMPILE_ANY") 159 #f 160 (machine-type))) 161 (define compiled-roots-path-list-string (getenv "PLTCOMPILEDROOTS")) 162 (define embedded-load-in-places '()) 163 164 (define (see saw . args) 165 (let loop ([saw saw] [args args]) 166 (if (null? args) 167 saw 168 (loop (hash-set saw (car args) #t) (cdr args))))) 169 (define (saw? saw tag) 170 (hash-ref saw tag #f)) 171 (define (saw-something? saw) 172 (positive? (hash-count saw))) 173 174 (define rx:logging-spec (pregexp "^[\\s]*(none|fatal|error|warning|info|debug)(?:@([^\\s @]+))?(.*)$")) 175 (define rx:all-whitespace (pregexp "^[\\s]*$")) 176 (define (parse-logging-spec which str where exit-on-fail?) 177 (define (fail) 178 (let ([msg (string-append 179 which " <levels> " where " must be one of the following\n" 180 " <level>s:\n" 181 " none fatal error warning info debug\n" 182 "or up to one such <level> in whitespace-separated sequence of\n" 183 " <level>@<name>\n" 184 "given: " str)]) 185 (cond 186 [exit-on-fail? 187 (startup-error msg)] 188 [else 189 (eprintf "~a\n" msg)]))) 190 (let loop ([str str] [default #f]) 191 (let ([m (regexp-match rx:logging-spec str)]) 192 (cond 193 [m 194 (let ([level (string->symbol (cadr m))] 195 [topic (caddr m)]) 196 (cond 197 [topic 198 (cons level (cons (string->symbol topic) (loop (cadddr m) default)))] 199 [default (fail)] 200 [else (loop (cadddr m) level)]))] 201 [(regexp-match? rx:all-whitespace str) 202 (if default (list default) null)] 203 [else (fail)])))) 204 205 (define (configure-runtime m) 206 ;; New-style configuration through a `configure-runtime` submodule: 207 (let ([config-m (module-path-index-join '(submod "." configure-runtime) m)]) 208 (when (module-declared? config-m #t) 209 (dynamic-require config-m #f))) 210 ;; Old-style configuration with module language info: 211 (let ([info (module->language-info m #t)]) 212 (when (and (vector? info) (= 3 (vector-length info))) 213 (let* ([info-load (lambda (info) 214 ((dynamic-require (vector-ref info 0) (vector-ref info 1)) (vector-ref info 2)))] 215 [get (info-load info)] 216 [infos (get 'configure-runtime '())]) 217 (unless (and (list? infos) 218 (andmap (lambda (info) (and (vector? info) (= 3 (vector-length info)))) 219 infos)) 220 (raise-argument-error 'runtime-configure "(listof (vector any any any))" infos)) 221 (for-each info-load infos))))) 222 223 (define need-runtime-configure? #t) 224 (define (namespace-require+ mod) 225 (let ([m (module-path-index-join mod #f)]) 226 (when need-runtime-configure? 227 (configure-runtime m) 228 (set! need-runtime-configure? #f)) 229 (namespace-require m) 230 ;; Run `main` submodule, if any: 231 (let ([main-m (module-path-index-join '(submod "." main) m)]) 232 (when (module-declared? main-m #t) 233 (dynamic-require main-m #f))))) 234 235 (define (get-repl-init-filename) 236 (call-with-continuation-prompt 237 (lambda () 238 (or (let ([p (build-path (find-system-path 'addon-dir) 239 (if gracket? 240 "gui-interactive.rkt" 241 "interactive.rkt"))]) 242 (and (file-exists? p) p)) 243 (let ([config-fn (build-path (find-main-config) "config.rktd")]) 244 (and (file-exists? config-fn) 245 (hash-ref (call-with-input-file config-fn read) 246 (if gracket? 'gui-interactive-file 'interactive-file) 247 #f))) 248 (if gracket? 'racket/gui/interactive 'racket/interactive))) 249 (default-continuation-prompt-tag) 250 (lambda args #f))) 251 252 (define init-library (if gracket? 253 '(lib "racket/gui/init") 254 '(lib "racket/init"))) 255 (define loads '()) 256 (define repl? #f) 257 (define repl-init? #t) 258 (define version? #f) 259 (define text-repl? (not gracket?)) 260 (define yield? #t) 261 (define stderr-logging-arg #f) 262 (define stdout-logging-arg #f) 263 (define syslog-logging-arg #f) 264 (define runtime-for-init? #t) 265 (define exit-value 0) 266 (define host-collects-dir #f) 267 (define host-config-dir #f) 268 (define addon-dir #f) 269 (define rev-collects-post-extra '()) 270 271 (define (no-init! saw) 272 (unless (saw? saw 'top) 273 (set! init-library #f))) 274 275 (define (next-arg what flag within-flag args) 276 (let loop ([args (cdr args)] [accum '()]) 277 (cond 278 [(null? args) 279 (startup-error "missing ~a after ~a switch" what (or within-flag flag))] 280 [(pair? (car args)) 281 (loop (cdr args) (cons (car args) accum))] 282 [else 283 (values (car args) (append (reverse accum) (cdr args)))]))) 284 285 (define (check-path-arg path what flag within-flag) 286 (when (equal? path "") 287 (startup-error "empty ~a after ~a switch" what (or within-flag flag)))) 288 289 (define (raise-bad-switch arg within-arg) 290 (startup-error "bad switch: ~a~a" 291 arg 292 (if within-arg 293 (format " within: ~a" within-arg) 294 ""))) 295 296 (define (no-front!) 297 (unsafe-register-process-global (string->bytes/utf-8 "Racket-GUI-no-front") #vu8(1))) 298 299 (define (add-namespace-require-load! mod-path arg) 300 (unless (module-path? mod-path) 301 (startup-error "bad module path: ~a derived from command-line argument: ~a" 302 (format "~v" mod-path) 303 arg)) 304 (set! loads 305 (cons (lambda () (namespace-require+ mod-path)) 306 loads))) 307 308 (include "main/help.ss") 309 310 (define-syntax string-case 311 ;; Assumes that `arg` is a variable 312 (syntax-rules () 313 [(_ arg [else body ...]) 314 (let () body ...)] 315 [(_ arg [(str ...) body ...] rest ...) 316 (if (or (string=? arg str) ...) 317 (let () body ...) 318 (string-case arg rest ...))])) 319 320 (define remaining-command-line-arguments '#()) 321 322 (seq 323 (let flags-loop ([args (list-tail the-command-line-arguments builtin-argc)] 324 [saw (hasheq)]) 325 ;; An element of `args` can become `(cons _arg _within-arg)` 326 ;; due to splitting multiple flags with a single "-" 327 (define (loop args) (flags-loop args (see saw 'something))) 328 ;; Called to handle remaining non-switch arguments: 329 (define (finish args saw) 330 (cond 331 [(and (pair? args) 332 (not (saw? saw 'non-config))) 333 (loop (cons "-u" args))] 334 [else 335 (set! remaining-command-line-arguments (vector->immutable-vector 336 (list->vector args))) 337 (cond 338 [(and (null? args) (not (saw? saw 'non-config))) 339 (set! repl? #t) 340 (when text-repl? 341 (set! version? #t))] 342 [else 343 (no-init! saw)])])) 344 ;; Dispatch on first argument: 345 (if (null? args) 346 (finish args saw) 347 (let* ([arg (car args)] 348 [within-arg (and (pair? arg) (cdr arg))] 349 [arg (if (pair? arg) (car arg) arg)]) 350 (string-case 351 arg 352 [("-l" "--lib") 353 (let-values ([(lib-name rest-args) (next-arg "library name" arg within-arg args)]) 354 (add-namespace-require-load! `(lib ,lib-name) lib-name) 355 (no-init! saw) 356 (flags-loop rest-args (see saw 'non-config 'lib)))] 357 [("-t" "--require") 358 (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) 359 (add-namespace-require-load! `(file ,file-name) file-name) 360 (no-init! saw) 361 (flags-loop rest-args (see saw 'non-config 'lib)))] 362 [("-p") 363 (let-values ([(package rest-args) (next-arg "package" arg within-arg args)]) 364 (add-namespace-require-load! `(planet ,package) package) 365 (no-init! saw) 366 (flags-loop rest-args (see saw 'non-config 'lib)))] 367 [("-u" "--require-script") 368 (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) 369 (add-namespace-require-load! `(file ,file-name) file-name) 370 (no-init! saw) 371 (check-path-arg file-name "file name" arg within-arg) 372 (set-run-file! (string->path file-name)) 373 (flags-loop (cons "--" rest-args) (see saw 'non-config 'lib)))] 374 [("-f" "--load") 375 (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) 376 (set! loads (cons (lambda () (load file-name)) 377 loads)) 378 (flags-loop rest-args (see saw 'non-config 'top)))] 379 [("-r" "--script") 380 (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) 381 (set! loads (cons (lambda () (load file-name)) 382 loads)) 383 (check-path-arg file-name "file name" arg within-arg) 384 (set-run-file! (string->path file-name)) 385 (flags-loop (cons "--" rest-args) (see saw 'non-config)))] 386 [("-e" "--eval") 387 (let-values ([(expr rest-args) (next-arg "expression" arg within-arg args)]) 388 (set! loads 389 (cons 390 (lambda () 391 (define i (open-input-string expr)) 392 (let loop () 393 (define expr (read i)) 394 (unless (eof-object? expr) 395 (call-with-values (lambda () 396 (call-with-continuation-prompt 397 (lambda () 398 (eval `(|#%top-interaction| . ,expr))) 399 (default-continuation-prompt-tag) 400 (lambda (proc) 401 ;; continue escape to set error status: 402 (abort-current-continuation (default-continuation-prompt-tag) proc)))) 403 (lambda vals 404 (for-each (lambda (v) 405 (|#%app| (current-print) v) 406 (flush-output)) 407 vals))) 408 (loop)))) 409 loads)) 410 (flags-loop rest-args (see saw 'non-config 'top)))] 411 [("-k" "-Y") 412 (let*-values ([(f rest-args) (if (equal? arg "-Y") 413 (next-arg "file" arg within-arg args) 414 (values #f (cdr args)))] 415 [(n rest-args) (next-arg "starting and ending offsets" arg within-arg (cons arg rest-args))] 416 [(m rest-args) (next-arg "first ending offset" arg within-arg (cons arg rest-args))] 417 [(p rest-args) (next-arg "second ending offset" arg within-arg (cons arg rest-args))]) 418 (let* ([add-segment-offset 419 (lambda (s what) 420 (let ([n (#%string->number s)]) 421 (unless (exact-integer? n) 422 (startup-error "bad ~a: ~a" what s)) 423 (#%number->string (+ n (if f 0 segment-offset)))))] 424 [n (add-segment-offset n "starting offset")] 425 [m (add-segment-offset m "first ending offset")] 426 [p (add-segment-offset p "second ending offset")] 427 [f (or f k-executable-path)]) 428 (set! loads 429 (cons 430 (lambda () 431 (set! embedded-load-in-places (cons (list f n m #f) embedded-load-in-places)) 432 (embedded-load n m #f #t f) 433 (embedded-load m p #f #f f)) 434 loads))) 435 (no-init! saw) 436 (flags-loop rest-args (see saw 'non-config)))] 437 [("-m" "--main") 438 (set! loads (cons (lambda () (call-main)) 439 loads)) 440 (flags-loop (cdr args) (see saw 'non-config 'top))] 441 [("-i" "--repl") 442 (set! repl? #t) 443 (set! version? #t) 444 (flags-loop (cdr args) (see saw 'non-config 'top))] 445 [("-n" "--no-lib") 446 (set! init-library #f) 447 (flags-loop (cdr args) (see saw 'non-config))] 448 [("-V" "--no-yield") 449 (set! yield? #f) 450 (set! version? #t) 451 (flags-loop (cdr args) (see saw 'non-config))] 452 [("-v" "--version") 453 (set! version? #t) 454 (flags-loop (cdr args) (see saw 'non-config))] 455 [("-c" "--no-compiled") 456 (set! compiled-file-paths '()) 457 (loop (cdr args))] 458 [("-I") 459 (let-values ([(lib-name rest-args) (next-arg "library name" arg within-arg args)]) 460 (when init-library 461 (set! init-library `(lib ,lib-name))) 462 (loop rest-args))] 463 [("-A" "--addon") 464 (let-values ([(addon-path rest-args) (next-arg "addon directory" arg within-arg args)]) 465 (set! addon-dir (find-original-bytes addon-path)) 466 (loop rest-args))] 467 [("-X" "--collects") 468 (let-values ([(collects-path rest-args) (next-arg "collects path" arg within-arg args)]) 469 (cond 470 [(equal? collects-path "") 471 (set! init-collects-dir 'disable)] 472 [else 473 (check-path-arg collects-path "collects path" arg within-arg) 474 (set! init-collects-dir (path->complete-path (->path (find-original-bytes collects-path))))]) 475 (loop rest-args))] 476 [("-S" "--search") 477 (let-values ([(collects-path rest-args) (next-arg "path" arg within-arg args)]) 478 (check-path-arg collects-path "collects path" collects-path within-arg) 479 (let ([path (path->complete-path (->path (find-original-bytes collects-path)))]) 480 (set! rev-collects-post-extra (cons path rev-collects-post-extra))) 481 (loop rest-args))] 482 [("-G" "--config") 483 (let-values ([(config-path rest-args) (next-arg "config path" arg within-arg args)]) 484 (check-path-arg config-path "config path" config-path within-arg) 485 (set! init-config-dir (path->complete-path (->path (find-original-bytes config-path)))) 486 (loop rest-args))] 487 [("-C" "--cross") 488 (set! host-config-dir init-config-dir) 489 (set! host-collects-dir init-collects-dir) 490 (set-cross-mode! 'force) 491 (loop (cdr args))] 492 [("-U" "--no-user-path") 493 (set! user-specific-search-paths? #f) 494 (loop (cdr args))] 495 [("-R" "--compiled") 496 (let-values ([(paths rest-args) (next-arg "path list" arg within-arg args)]) 497 (set! compiled-roots-path-list-string paths) 498 (loop rest-args))] 499 [("-d" "--no-delay") 500 (set! load-on-demand? #t) 501 (loop (cdr args))] 502 [("-b" "--binary") 503 (loop (cdr args))] 504 [("-q" "--no-init-file") 505 (set! repl-init? #f) 506 (loop (cdr args))] 507 [("-W" "--stderr") 508 (let-values ([(spec rest-args) (next-arg "stderr level" arg within-arg args)]) 509 (set! stderr-logging-arg (parse-logging-spec "stderr" spec (format "after ~a switch" (or within-arg arg)) #t)) 510 (loop rest-args))] 511 [("-O" "--stdout") 512 (let-values ([(spec rest-args) (next-arg "stdout level" arg within-arg args)]) 513 (set! stdout-logging-arg (parse-logging-spec "stdout" spec (format "after ~a switch" (or within-arg arg)) #t)) 514 (loop rest-args))] 515 [("-L" "--syslog") 516 (let-values ([(spec rest-args) (next-arg "syslog level" arg within-arg args)]) 517 (set! syslog-logging-arg (parse-logging-spec "syslog" spec (format "after ~a switch" (or within-arg arg)) #t)) 518 (loop rest-args))] 519 [("-N" "--name") 520 (let-values ([(name rest-args) (next-arg "name" arg within-arg args)]) 521 (check-path-arg name "name" arg within-arg) 522 (set-run-file! (string->path name)) 523 (loop rest-args))] 524 [("-E" "--exec") 525 (let-values ([(name rest-args) (next-arg "name" arg within-arg args)]) 526 (check-path-arg name "name" arg within-arg) 527 (set-exec-file! (string->path name)) 528 (loop rest-args))] 529 [("-J") 530 (cond 531 [gracket? 532 (let-values ([(wm-class rest-args) (next-arg "WM_CLASS string" arg within-arg args)]) 533 (unsafe-register-process-global (string->bytes/utf-8 "Racket-GUI-wm-class") 534 (bytes-append (string->bytes/utf-8 wm-class) #vu8(0))) 535 (loop rest-args))] 536 [else 537 (raise-bad-switch arg within-arg)])] 538 [("-K" "--back") 539 (cond 540 [gracket? 541 (no-front!) 542 (loop (cdr args))] 543 [else 544 (raise-bad-switch arg within-arg)])] 545 [("-z" "--text-repl") 546 (cond 547 [gracket? 548 (no-front!) 549 (set! text-repl? #t) 550 (loop (cdr args))] 551 [else 552 (raise-bad-switch arg within-arg)])] 553 [("-M" "--compile-any") 554 (set! compile-target-machine #f) 555 (loop (cdr args))] 556 [("--compile-machine") 557 (let-values ([(mach-str rest-args) (next-arg "target machine" arg within-arg args)]) 558 (let ([mach (string->symbol mach-str)]) 559 (unless (compile-target-machine? mach) 560 (startup-error "machine not supported as a compile target: ~a" mach)) 561 (set! compile-target-machine mach)) 562 (loop rest-args))] 563 [("--cross-compiler") 564 (let-values ([(mach rest-args) (next-arg "target machine" arg within-arg args)]) 565 (let-values ([(xpatch-dir rest-args) (next-arg "cross-compiler path" arg within-arg (cons arg rest-args))]) 566 (add-cross-compiler! (string->symbol mach) 567 (path->complete-path (->path (find-original-bytes xpatch-dir))) 568 (find-system-path 'exec-file)) 569 (loop rest-args)))] 570 [("--cross-server") 571 (let-values ([(scheme-xpatch-file rest-args) (next-arg "target machine" arg within-arg args)]) 572 (let-values ([(scheme-xpatch-file rest-args) (next-arg "compiler xpatch path" arg within-arg (cons arg rest-args))]) 573 (let-values ([(scheme-xpatch-file rest-args) (next-arg "library xpatch path" arg within-arg (cons arg rest-args))]) 574 (when (or (saw-something? saw) 575 (not (null? rest-args))) 576 (startup-error "--cross-server cannot be combined with any other arguments")) 577 (startup-error "--cross-server should have been handled earlier")))) 578 (flags-loop null (see saw 'non-config))] 579 [("-j" "--no-jit") 580 (loop (cdr args))] 581 [("-Z") 582 (let-values ([(ignored rest-args) (next-arg "argument to ignore" arg within-arg args)]) 583 (flags-loop rest-args saw))] 584 [("-h" "--help") 585 (show-help) 586 (exit)] 587 [("--") 588 (cond 589 [(or (null? (cdr args)) (not (pair? (cadr args)))) 590 (finish (cdr args) saw)] 591 [else 592 ;; Need to handle more switches from a combined flag 593 (loop (cons (cadr args) (cons (car args) (cddr args))))])] 594 [else 595 (cond 596 [(and (> (string-length arg) 1) 597 (eqv? (string-ref arg 0) #\-)) 598 (cond 599 [(and (> (string-length arg) 2) 600 (not (eqv? (string-ref arg 1) #\-))) 601 ;; Split flags 602 (loop (append (map (lambda (c) (cons (string #\- c) arg)) 603 (cdr (string->list arg))) 604 (cdr args)))] 605 [else 606 (raise-bad-switch arg within-arg)])] 607 [else 608 ;; Non-flag argument 609 (finish args saw)])]))))) 610 611 (define (call-main) 612 (let ([m (namespace-datum-introduce 'main)]) 613 (unless (identifier-binding m) 614 (namespace-variable-value 'main #f 615 (lambda () 616 (error "main: not defined or required into the top-level environment")))) 617 (call-with-values (lambda () (eval (datum->kernel-syntax 618 (cons m (vector->list remaining-command-line-arguments))))) 619 (lambda results 620 (let ([p (current-print)]) 621 (for-each (lambda (v) (|#%app| p v)) results)))))) 622 623 ;; Set up GC logging 624 (define-values (struct:gc-info make-gc-info gc-info? gc-info-ref gc-info-set!) 625 (make-struct-type 'gc-info #f 10 0 #f null 'prefab #f '(0 1 2 3 4 5 6 7 8 9))) 626 (define (K plus n) 627 (let* ([s (number->string (quotient (abs n) 1000))] 628 [len (string-length s)] 629 [len2 (+ len 630 (quotient (sub1 len) 3) 631 (if (or (< n 0) 632 (not (eq? "" plus))) 633 1 634 0) 635 1)] 636 [s2 (make-string len2)]) 637 (string-set! s2 (sub1 len2) #\K) 638 (let loop ([i len] 639 [j (sub1 len2)] 640 [digits 0]) 641 (cond 642 [(zero? i) 643 (cond 644 [(< n 0) (string-set! s2 0 #\-)] 645 [(not (eq? plus "")) (string-set! s2 0 (string-ref plus 0))]) 646 s2] 647 [(= 3 digits) 648 (let ([j (sub1 j)]) 649 (string-set! s2 j #\,) 650 (loop i j 0))] 651 [else 652 (let ([i (sub1 i)] 653 [j (sub1 j)]) 654 (string-set! s2 j (string-ref s i)) 655 (loop i j (add1 digits)))])))) 656 (define minor-gcs 0) 657 (define major-gcs 0) 658 (define auto-gcs 0) 659 (define peak-mem 0) 660 (seq 661 (set-garbage-collect-notify! 662 (let ([root-logger (current-logger)]) 663 ;; This function can be called in any Chez Scheme thread 664 (lambda (gen pre-allocated pre-allocated+overhead pre-time pre-cpu-time 665 post-allocated post-allocated+overhead proper-post-time proper-post-cpu-time 666 post-time post-cpu-time) 667 (let ([minor? (< gen (collect-maximum-generation))]) 668 (if minor? 669 (set! minor-gcs (add1 minor-gcs)) 670 (set! major-gcs (add1 major-gcs))) 671 (set! peak-mem (max peak-mem pre-allocated)) 672 (let ([debug-GC? (log-level?* root-logger 'debug 'GC)] 673 [debug-GC:major? (and (not minor?) 674 (log-level?* root-logger 'debug 'GC:major))]) 675 (when (or debug-GC? debug-GC:major?) 676 (let ([delta (- pre-allocated post-allocated)] 677 [account-str (let ([proper (if (= post-cpu-time pre-cpu-time) 678 100 679 (quotient (* 100 (- proper-post-cpu-time pre-cpu-time)) 680 (- post-cpu-time pre-cpu-time)))]) 681 (if (fx>= proper 99) 682 "" 683 (string-append "[" (number->string (fx- 100 proper)) "%]")))]) 684 (let ([msg (chez:format "GC: 0:~a~a @ ~a(~a); free ~a(~a) ~ams~a @ ~a" 685 (if minor? "min" "MAJ") gen 686 (K "" pre-allocated) (K "+" (- pre-allocated+overhead pre-allocated)) 687 (K "" delta) (K "+" (- (- pre-allocated+overhead post-allocated+overhead) 688 delta)) 689 (- post-cpu-time pre-cpu-time) 690 account-str 691 pre-cpu-time)] 692 [data (make-gc-info (if minor? 'minor 'major) pre-allocated pre-allocated+overhead 0 693 post-allocated post-allocated+overhead 694 pre-cpu-time post-cpu-time 695 pre-time post-time)] 696 [in-interrupt? #t]) 697 (when debug-GC? 698 (log-message* root-logger 'debug 'GC msg data #f in-interrupt?)) 699 (when debug-GC:major? 700 (log-message* root-logger 'debug 'GC:major msg data #f in-interrupt?))))))))))) 701 702 (define (initialize-exit-handler!) 703 (#%exit-handler 704 (let ([orig (#%exit-handler)] 705 [root-logger (current-logger)]) 706 (lambda (v) 707 (when gcs-on-exit? 708 (collect-garbage) 709 (collect-garbage)) 710 (let ([debug-GC? (log-level?* root-logger 'debug 'GC)] 711 [debug-GC:major? (log-level?* root-logger 'debug 'GC:major)]) 712 (when (or debug-GC? debug-GC:major?) 713 (let ([msg (chez:format "GC: 0:atexit peak ~a(~a); alloc ~a; major ~a; minor ~a; ~ams" 714 (K "" peak-mem) 715 (K "+" (- (maximum-memory-bytes) peak-mem)) 716 (K "" (- (+ (bytes-deallocated) (bytes-allocated)) (initial-bytes-allocated))) 717 major-gcs 718 minor-gcs 719 (let ([t (sstats-gc-cpu (statistics))]) 720 (+ (* (time-second t) 1000) 721 (quotient (time-nanosecond t) 1000000))))]) 722 (when debug-GC? 723 (log-message root-logger 'info 'GC msg #f #f)) 724 (when debug-GC:major? 725 (log-message root-logger 'info 'GC:major msg #f #f))))) 726 (linklet-performance-report!) 727 (custodian-shutdown-root-at-exit) 728 (|#%app| orig v))))) 729 730 (define stderr-logging 731 (or stderr-logging-arg 732 (let ([spec (getenv "PLTSTDERR")]) 733 (if spec 734 (parse-logging-spec "stderr" spec "in PLTSTDERR environment variable" #f) 735 '(error))))) 736 737 (define stdout-logging 738 (or stdout-logging-arg 739 (let ([spec (getenv "PLTSTDOUT")]) 740 (if spec 741 (parse-logging-spec "stdout" spec "in PLTSTDOUT environment variable" #f) 742 '())))) 743 744 (define syslog-logging 745 (or syslog-logging-arg 746 (let ([spec (getenv "PLTSYSLOG")]) 747 (if spec 748 (parse-logging-spec "syslog" spec "in PLTSYSLOG environment variable" #f) 749 '())))) 750 751 (define gcs-on-exit? (and (getenv "PLT_GCS_ON_EXIT") #t)) 752 753 (define (initialize-place!) 754 (current-command-line-arguments remaining-command-line-arguments) 755 (use-compiled-file-paths compiled-file-paths) 756 (use-user-specific-search-paths user-specific-search-paths?) 757 (load-on-demand-enabled load-on-demand?) 758 (unless (eq? compile-target-machine (machine-type)) 759 (current-compile-target-machine compile-target-machine)) 760 (boot) 761 (when (and stderr-logging 762 (not (null? stderr-logging))) 763 (apply add-stderr-log-receiver! (current-logger) stderr-logging)) 764 (when (and stdout-logging 765 (not (null? stdout-logging))) 766 (apply add-stdout-log-receiver! (current-logger) stdout-logging)) 767 (when (and syslog-logging 768 (not (null? syslog-logging))) 769 (apply add-syslog-log-receiver! (current-logger) syslog-logging)) 770 (when host-collects-dir 771 (set-host-collects-dir! host-collects-dir)) 772 (when host-config-dir 773 (set-host-config-dir! host-config-dir)) 774 (cond 775 [(eq? init-collects-dir 'disable) 776 (use-collection-link-paths #f) 777 (set-collects-dir! (build-path 'same))] 778 [else 779 (set-collects-dir! init-collects-dir)]) 780 (set-config-dir! init-config-dir) 781 (unless (eq? init-collects-dir 'disable) 782 (current-library-collection-links 783 (find-library-collection-links)) 784 (current-library-collection-paths 785 (find-library-collection-paths collects-pre-extra (reverse rev-collects-post-extra)))) 786 (let ([roots (find-compiled-file-roots)]) 787 (if compiled-roots-path-list-string 788 (current-compiled-file-roots 789 (let ([s (regexp-replace* "@[(]version[)]" 790 compiled-roots-path-list-string 791 (version))]) 792 (path-list-string->path-list s roots))) 793 (current-compiled-file-roots roots)))) 794 795 ;; Called when Racket is embedded in a larger application: 796 (define (register-embedded-entry-info! escape) 797 (let ([resume-k #f]) ;; to get back to Racket thread; expects a thunk 798 ((call/cc ;; Scheme-level `call/cc` to escape Racket's thread-engine loop 799 (lambda (init-resume-k) 800 (set! resume-k init-resume-k) 801 (set-top-level-value! 802 'embedded-racket-entry-info 803 ;; A vector of specific functions: 804 (vector 805 ;; Resume the main Racket thread to apply `proc` to `args`, 806 ;; and return a list of result values; no exception handling 807 ;; or other such protections 808 (lambda (proc args) 809 (call/cc ;; Scheme-level `call/cc` to escape engine loop 810 (lambda (entry-point-k) 811 (resume-k 812 (lambda () 813 (let-values ([vals (apply proc args)]) 814 ((call/cc 815 (lambda (latest-resume-k) 816 (set! resume-k init-resume-k) 817 (entry-point-k vals)))))))))) 818 ;; Functions that are useful to apply and that 819 ;; provide access to everything else: 820 primitive-lookup 821 eval 822 dynamic-require 823 namespace-require 824 ;; bstr as #f => use path, start, and end 825 ;; path as #f => find executable 826 ;; end as #f => use file size 827 (lambda (path start end bstr as-predefined?) 828 (embedded-load start end bstr as-predefined? path) 829 (when as-predefined? 830 (set! embedded-load-in-places (cons (list path start end bstr) embedded-load-in-places)))))) 831 (escape)))))) 832 833 (set-make-place-ports+fds! make-place-ports+fds) 834 835 (set-prepare-for-place! 836 (lambda () 837 ;; Force visit of modules to make sure that we don't end up 838 ;; with a race later by trying to visit the module in a place: 839 (call-with-system-wind 840 (lambda () 841 (for-each (lambda (lib) 842 (#%$visit-library lib '() #f)) 843 '((chezscheme) 844 (rumble) 845 (thread) 846 (io) 847 (regexp) 848 (schemify) 849 (linklet) 850 (expander))) 851 ;; Only need to visit once (although multiple time is ok) 852 (set-prepare-for-place! void))))) 853 854 (set-place-get-inherit! 855 (lambda () 856 (list (current-directory) 857 (current-library-collection-paths) 858 (current-library-collection-links) 859 (current-compiled-file-roots)))) 860 861 (set-start-place! 862 (lambda (pch mod sym in out err cust plumber inh) 863 (io-place-init! in out err cust plumber) 864 (regexp-place-init!) 865 (expander-place-init!) 866 (initialize-place!) 867 (current-directory (list-ref inh 0)) 868 (current-library-collection-paths (list-ref inh 1)) 869 (current-library-collection-links (list-ref inh 2)) 870 (current-compiled-file-roots (list-ref inh 3)) 871 (let loop ([l (reverse embedded-load-in-places)]) 872 (unless (null? l) 873 (let-values ([(path n m bstr) (apply values (car l))]) 874 (embedded-load n m bstr #t path)) 875 (loop (cdr l)))) 876 (lambda () 877 (let ([f (dynamic-require mod sym)]) 878 (f pch))))) 879 (set-destroy-place! 880 (lambda () 881 (io-place-destroy!))) 882 883 (let ([a (or addon-dir 884 (getenv-bytes "PLTADDONDIR"))]) 885 (when a 886 (set-addon-dir! (path->complete-path (->path a))))) 887 888 (when (getenv "PLT_STATS_ON_BREAK") 889 (keyboard-interrupt-handler 890 (let ([orig (keyboard-interrupt-handler)]) 891 (lambda args 892 (dump-memory-stats) 893 (apply orig args))))) 894 895 (when (getenv "PLT_MAX_COMPACT_GC") 896 (in-place-minimum-generation 254)) 897 898 (let ([s (getenv "PLT_INCREMENTAL_GC")]) 899 (when (and s 900 (>= (string-length s) 1) 901 (#%memv (string-ref s 0) '(#\0 #\n #\N))) 902 (set-incremental-collection-enabled! #f))) 903 904 (when (getenv "PLTDISABLEGC") 905 (collect-request-handler void)) 906 907 (let ([s (getenv "PLT_THREAD_QUANTUM")]) 908 ;; Setting the thread quantum is useful in probing for race conditions. The default quantum 909 ;; is 100000. If it's made too small (on the order of 100), then a thread will use up its 910 ;; quantum just checking for breaks as it is swapped in, and then it won't make any progress. 911 (when s 912 (let ([n (string->number s)]) 913 (when (and n (exact-nonnegative-integer? n)) 914 (set-schedule-quantum! n))))) 915 916 (when version? 917 (display (banner))) 918 (call/cc ; Chez Scheme's `call/cc`, used here to escape from the Racket-thread engine loop 919 (lambda (entry-point-k) 920 (call-in-main-thread 921 (lambda () 922 (initialize-exit-handler!) 923 (initialize-place!) 924 925 (when init-library 926 (namespace-require+ init-library)) 927 928 (call-with-continuation-prompt 929 (lambda () 930 (for-each (lambda (ld) (ld)) 931 (reverse loads))) 932 (default-continuation-prompt-tag) 933 ;; If any load escapes, then set the exit value and 934 ;; stop running loads (but maybe continue with the REPL) 935 (lambda (proc) 936 (set! exit-value 1) 937 ;; Let the actual default handler report an arity mismatch, etc. 938 (call-with-continuation-prompt 939 (lambda () (abort-current-continuation (default-continuation-prompt-tag) proc))))) 940 941 (when repl? 942 (set! exit-value 0) 943 (when repl-init? 944 (let ([m (get-repl-init-filename)]) 945 (when m 946 (call-with-continuation-prompt 947 (lambda () (dynamic-require m 0)) 948 (default-continuation-prompt-tag) 949 (lambda args (set! exit-value 1)))))) 950 (|#%app| (if text-repl? 951 (dynamic-require 'racket/base 'read-eval-print-loop) 952 (dynamic-require 'racket/gui/init 'graphical-read-eval-print-loop))) 953 (when text-repl? 954 (newline))) 955 956 (when yield? 957 (|#%app| (executable-yield-handler) exit-value)) 958 959 (cond 960 [embedded-interactive-mode? 961 (register-embedded-entry-info! 962 (lambda () 963 (entry-point-k exit-value)))] 964 [else 965 (exit exit-value)])))))) 966 967 (define the-command-line-arguments 968 (or (and (top-level-bound? 'bytes-command-line-arguments) 969 (top-level-value 'bytes-command-line-arguments)) 970 (command-line-arguments))) 971 972 (if (null? the-command-line-arguments) 973 ;; Assume that we're running as a boot file 974 (scheme-start (lambda args (run args))) 975 ;; Assume that we're running as a script 976 (run the-command-line-arguments))) 977