Back to index

plt-scheme  4.2.1
startup.inc
Go to the documentation of this file.
00001   EVAL_ONE_STR(
00002 "(module #%min-stx '#%kernel"
00003 "(#%require '#%paramz"
00004 "(for-syntax '#%kernel))"
00005 "(#%provide unless when"
00006 " and or"
00007 " cond"
00008 " let let* letrec"
00009 " parameterize"
00010 " define)"
00011 "(define-values-for-syntax(here-stx)"
00012 "(quote-syntax here))"
00013 "(define-syntaxes(unless)"
00014 "(lambda(stx)"
00015 "(let-values(((s)(syntax->list stx)))"
00016 "(datum->syntax here-stx"
00017 "(list 'if(cadr s)"
00018 "(void)"
00019 "(cons 'begin(cddr s)))))))"
00020 "(define-syntaxes(when)"
00021 "(lambda(stx)"
00022 "(let-values(((s)(syntax->list stx)))"
00023 "(datum->syntax here-stx"
00024 "(list 'if(cadr s)"
00025 "(cons 'begin(cddr s))"
00026 "(void))))))"
00027 "(define-syntaxes(and)"
00028 "(lambda(stx)"
00029 "(let-values(((s)(cdr(syntax->list stx))))"
00030 "(if(null? s)"
00031 "(quote-syntax #t)"
00032 "(if(null?(cdr s))"
00033 "(car s)"
00034 "(datum->syntax here-stx"
00035 "(list 'if(car s)(cons 'and(cdr s)) #f)))))))"
00036 "(define-syntaxes(or)"
00037 "(lambda(stx)"
00038 "(let-values(((s)(cdr(syntax->list stx))))"
00039 "(if(null? s)"
00040 "(quote-syntax #f)"
00041 "(if(null?(cdr s))"
00042 "(car s)"
00043 "(datum->syntax here-stx"
00044 "(list 'let-values(list(list(list 'x)"
00045 "(car s)))"
00046 "(list 'if 'x 'x(cons 'or(cdr s))))))))))"
00047 "(define-syntaxes(let)"
00048 "(lambda(stx)"
00049 "(let-values(((s)(cdr(syntax->list stx))))"
00050 "(datum->syntax "
00051 " here-stx"
00052 "(if(symbol?(syntax-e(car s)))"
00053 "(let-values(((clauses)"
00054 "(map(lambda(c)"
00055 "(syntax->list c))"
00056 "(syntax->list(cadr s)))))"
00057 "(list 'letrec-values(list(list(list(car s))"
00058 "(list* 'lambda"
00059 "(map car clauses)"
00060 "(cddr s))))"
00061 "(cons(car s)(map cadr clauses))))"
00062 "(list* 'let-values(map(lambda(c)"
00063 "(let-values(((c)(syntax->list c)))"
00064 "(cons(list(car c))"
00065 "(cdr c))))"
00066 "(syntax->list(car s)))"
00067 "(cdr s)))))))"
00068 "(define-syntaxes(letrec)"
00069 "(lambda(stx)"
00070 "(let-values(((s)(cdr(syntax->list stx))))"
00071 "(datum->syntax "
00072 " here-stx"
00073 "(list* 'letrec-values(map(lambda(c)"
00074 "(let-values(((c)(syntax->list c)))"
00075 "(cons(list(car c))"
00076 "(cdr c))))"
00077 "(syntax->list(car s)))"
00078 "(cdr s))))))"
00079 "(define-syntaxes(let*)"
00080 "(lambda(stx)"
00081 "(let-values(((s)(cdr(syntax->list stx))))"
00082 "(let-values(((fst)(syntax->list(car s))))"
00083 "(datum->syntax "
00084 " here-stx"
00085 "(if(null? fst)"
00086 "(list* 'let-values()(cdr s))"
00087 "(list 'let(list(car fst))"
00088 "(list* 'let*(cdr fst)(cdr s)))))))))"
00089 "(define-syntaxes(parameterize)"
00090 "(lambda(stx)"
00091 "(let-values(((s)(cdr(syntax->list stx))))"
00092 "(let-values(((bindings)(apply append"
00093 "(map syntax->list(syntax->list(car s))))))"
00094 "(datum->syntax "
00095 " here-stx"
00096 "(list 'with-continuation-mark"
00097 " 'parameterization-key"
00098 "(list* 'extend-parameterization"
00099 " '(continuation-mark-set-first #f parameterization-key)"
00100 " bindings)"
00101 "(list* 'let-values()"
00102 "(cdr s))))))))"
00103 "(define-syntaxes(cond)"
00104 "(lambda(stx)"
00105 "(let-values(((s)(cdr(syntax->list stx))))"
00106 "(if(null? s)"
00107 "(quote-syntax(void))"
00108 "(datum->syntax "
00109 " here-stx"
00110 "(let-values(((a)(syntax->list(car s))))"
00111 "(if(eq? '=>(syntax-e(cadr a)))"
00112 "(list 'let-values(list(list '(v)(car a)))"
00113 "(list* 'cond"
00114 "(list 'v(list(caddr a) 'v))"
00115 "(cdr s)))"
00116 "(list 'if(if(eq?(syntax-e(car a)) 'else)"
00117 " #t"
00118 "(car a))"
00119 "(list* 'let-values '()(cdr a))"
00120 "(cons 'cond(cdr s))))))))))"
00121 "(define-syntaxes(define)"
00122 "(lambda(stx)"
00123 "(let-values(((s)(cdr(syntax->list stx))))"
00124 "(datum->syntax "
00125 " here-stx"
00126 "(if(symbol?(syntax-e(car s)))"
00127 "(list 'define-values(list(car s))(cadr s))"
00128 "(let-values(((a)(syntax-e(car s))))"
00129 "(list 'define-values(list(car a))"
00130 "(list* 'lambda(cdr a)"
00131 "(cdr s))))))))))"
00132 );
00133   EVAL_ONE_STR(
00134 "(module #%utils '#%kernel"
00135 "(#%require '#%min-stx)"
00136 "(#%provide path-string?"
00137 " normal-case-path"
00138 " path-replace-suffix"
00139 " path-add-suffix"
00140 " -find-col"
00141 " collection-path"
00142 " find-library-collection-paths"
00143 " path-list-string->path-list"
00144 " find-executable-path"
00145 " load/use-compiled"
00146 " embedded-load)"
00147 "(define-values(path-string?)"
00148 "(lambda(s)"
00149 "(or(path? s) "
00150 "(and(string? s)"
00151 "(or(relative-path? s)"
00152 "(absolute-path? s))))))"
00153 "(define-values(bsbs)(string #\\u5C #\\u5C))"
00154 "(define-values(normal-case-path)"
00155 "(lambda(s)"
00156 "(unless(or(path-for-some-system? s)"
00157 "(path-string? s))"
00158 " (raise-type-error 'normal-path-case \"path (for any system) or valid-path string\" s))"
00159 "(cond"
00160 "((if(path-for-some-system? s)"
00161 "(eq?(path-convention-type s) 'windows)"
00162 "(eq?(system-type) 'windows))"
00163 "(let((str(if(string? s) s(bytes->string/locale(path->bytes s)))))"
00164 " (if (regexp-match? #rx\"^[\\u5C][\\u5C][?][\\u5C]\" str)"
00165 "(if(string? s)"
00166 "(string->path s)"
00167 " s)"
00168 "(let((s(string-locale-downcase str)))"
00169 "(bytes->path "
00170 "(string->bytes/locale"
00171 " (regexp-replace* #rx\"/\" "
00172 " (if (regexp-match? #rx\"[/\\u5C][. ]+[/\\u5C]*$\" s)"
00173 " s"
00174 " (regexp-replace* #rx\"\\u5B .\\u5D+([/\\u5C]*)$\" s \"\\u005C1\"))"
00175 " bsbs))"
00176 " 'windows)))))"
00177 "((string? s)(string->path s))"
00178 "(else s))))"
00179 "(define-values(-check-relpath)"
00180 "(lambda(who s)"
00181 "(unless(path-string? s)"
00182 " (raise-type-error who \"path or valid-path string\" s))"
00183 "(unless(relative-path? s)"
00184 "(raise(make-exn:fail:contract"
00185 "(string->immutable-string"
00186 " (format \"~a: invalid relative path: ~s\" who s))"
00187 "(current-continuation-marks))))))"
00188 "(define-values(-check-collection)"
00189 "(lambda(who collection collection-path)"
00190 "(-check-relpath who collection) "
00191 "(for-each(lambda(p)(-check-relpath who p)) collection-path)))"
00192 "(define-values(collection-path)"
00193 "(lambda(collection . collection-path) "
00194 "(-check-collection 'collection-path collection collection-path)"
00195 "(-find-col 'collection-path(lambda(s)"
00196 "(raise"
00197 "(make-exn:fail:filesystem s(current-continuation-marks))))"
00198 " collection collection-path)))"
00199 "(define-values(-find-col)"
00200 "(lambda(who fail collection collection-path)"
00201 "(let((all-paths(current-library-collection-paths)))"
00202 "(let cloop((paths all-paths))"
00203 "(if(null? paths)"
00204 "(fail"
00205 " (format \"~a: collection not found: ~s in any of: ~s\" "
00206 " who(if(null? collection-path)"
00207 " collection"
00208 "(apply build-path collection collection-path))"
00209 " all-paths))"
00210 "(let((dir(build-path(car paths) collection)))"
00211 "(if(directory-exists? dir)"
00212 "(let((cpath(apply build-path dir collection-path)))"
00213 "(if(directory-exists? cpath)"
00214 " cpath"
00215 "(cloop(cdr paths))))"
00216 "(cloop(cdr paths)))))))))"
00217 "(define-values(check-suffix-call)"
00218 "(lambda(s sfx who)"
00219 "(unless(or(path-for-some-system? s)"
00220 "(path-string? s))"
00221 " (raise-type-error who \"path (for any system) or valid-path string\" 0 s sfx))"
00222 "(unless(or(string? sfx)(bytes? sfx))"
00223 " (raise-type-error who \"string or byte string\" 1 s sfx))"
00224 "(let-values(((base name dir?)(split-path s)))"
00225 "(when(not base)"
00226 " (raise-mismatch-error who \"cannot add a suffix to a root path: \" s))"
00227 "(values base name))))"
00228 "(define-values(path-replace-suffix)"
00229 "(lambda(s sfx)"
00230 "(let-values(((base name)(check-suffix-call s sfx 'path-replace-suffix)))"
00231 "(let((new-name(bytes->path-element"
00232 " (regexp-replace #rx#\"(?:[.][^.]*|)$\""
00233 "(path-element->bytes name)"
00234 "(if(string? sfx)"
00235 "(string->bytes/locale sfx(char->integer #\\?))"
00236 " sfx))"
00237 "(if(path-for-some-system? s)"
00238 "(path-convention-type s)"
00239 "(system-path-convention-type)))))"
00240 "(if(path? base)"
00241 "(build-path base new-name)"
00242 " new-name)))))"
00243 "(define-values(path-add-suffix)"
00244 "(lambda(s sfx)"
00245 "(let-values(((base name)(check-suffix-call s sfx 'path-add-suffix)))"
00246 "(let((new-name(bytes->path-element"
00247 "(bytes-append"
00248 " (regexp-replace* #rx#\"[.]\""
00249 "(path-element->bytes name)"
00250 " \"_\")"
00251 "(if(string? sfx)"
00252 "(string->bytes/locale sfx(char->integer #\\?))"
00253 " sfx))"
00254 "(if(path-for-some-system? s)"
00255 "(path-convention-type s)"
00256 "(system-path-convention-type)))))"
00257 "(if(path? base)"
00258 "(build-path base new-name)"
00259 " new-name)))))"
00260 "(define-values(load/use-compiled)"
00261 "(lambda(f)((current-load/use-compiled) f #f)))"
00262 "(define-values(find-library-collection-paths)"
00263 "(case-lambda"
00264 "(()(find-library-collection-paths null null))"
00265 "((extra-collects-dirs)(find-library-collection-paths extra-collects-dirs null))"
00266 "((extra-collects-dirs post-collects-dirs)"
00267 "(let((user-too?(use-user-specific-search-paths))"
00268 "(cons-if(lambda(f r)(if f(cons f r) r))))"
00269 "(path-list-string->path-list"
00270 "(if user-too?"
00271 " (or (getenv \"PLTCOLLECTS\") \"\")"
00272 " \"\")"
00273 "(cons-if"
00274 "(and user-too?"
00275 "(build-path(find-system-path 'addon-dir)"
00276 "(version)"
00277 " \"collects\"))"
00278 "(let loop((l(append"
00279 " extra-collects-dirs"
00280 "(list(find-system-path 'collects-dir))"
00281 " post-collects-dirs)))"
00282 "(if(null? l)"
00283 " null"
00284 "(let*((collects-path(car l))"
00285 "(v"
00286 "(cond"
00287 "((complete-path? collects-path) collects-path)"
00288 "((absolute-path? collects-path)"
00289 "(path->complete-path collects-path"
00290 "(find-executable-path(find-system-path 'exec-file) #f #t)))"
00291 "(else"
00292 "(find-executable-path(find-system-path 'exec-file) collects-path #t)))))"
00293 "(if v"
00294 "(cons(simplify-path(path->complete-path v(current-directory)))"
00295 "(loop(cdr l)))"
00296 "(loop(cdr l))))))))))))"
00297 "(define-values(path-list-string->path-list)"
00298 "(let((r(byte-regexp(string->bytes/utf-8"
00299 "(let((sep(if(eq?(system-type) 'windows)"
00300 " \";\"\n"
00301 " \":\")))"
00302 " (format \"([^~a]*)~a(.*)\" sep sep)))))"
00303 "(cons-path(lambda(default s l) "
00304 " (if (bytes=? s #\"\")"
00305 "(append default l)"
00306 "(cons(bytes->path s) l)))))"
00307 "(lambda(s default)"
00308 "(unless(or(bytes? s)"
00309 "(string? s))"
00310 " (raise-type-error 'path-list-string->path-list \"byte string or string\" s))"
00311 "(unless(and(list? default)"
00312 "(andmap path? default))"
00313 " (raise-type-error 'path-list-string->path-list \"list of paths\" default))"
00314 "(let loop((s(if(string? s)"
00315 "(string->bytes/utf-8 s)"
00316 " s)))"
00317 "(let((m(regexp-match r s)))"
00318 "(if m"
00319 "(cons-path default(cadr m)(loop(caddr m)))"
00320 "(cons-path default s null)))))))"
00321 "(define-values(find-executable-path)"
00322 "(case-lambda "
00323 "((program libpath reverse?)"
00324 "(unless(path-string? program) "
00325 " (raise-type-error 'find-executable-path \"path or string (sans nul)\" program))"
00326 "(unless(or(not libpath)(and(path-string? libpath) "
00327 "(relative-path? libpath)))"
00328 " (raise-type-error 'find-executable-path \"#f or relative path or string\" libpath))"
00329 "(letrec((found-exec"
00330 "(lambda(exec-name)"
00331 "(if libpath"
00332 "(let-values(((base name isdir?)(split-path exec-name)))"
00333 "(let((next"
00334 "(lambda()"
00335 "(let((resolved(resolve-path exec-name)))"
00336 "(cond"
00337 "((equal? resolved exec-name) #f)"
00338 "((relative-path? resolved)"
00339 "(found-exec(build-path base resolved)))"
00340 "(else(found-exec resolved)))))))"
00341 "(or(and reverse?(next))"
00342 "(if(path? base)"
00343 "(let((lib(build-path base libpath)))"
00344 "(and(or(directory-exists? lib) "
00345 "(file-exists? lib))"
00346 " lib))"
00347 " #f)"
00348 "(and(not reverse?)(next)))))"
00349 " exec-name))))"
00350 "(if(and(relative-path? program)"
00351 "(let-values(((base name dir?)(split-path program)))"
00352 "(eq? base 'relative)))"
00353 " (let ((paths-str (getenv \"PATH\"))"
00354 "(win-add(lambda(s)(if(eq?(system-type) 'windows) "
00355 " (cons (bytes->path #\".\") s) "
00356 " s))))"
00357 "(let loop((paths(if paths-str "
00358 "(win-add(path-list-string->path-list paths-str null))"
00359 " null)))"
00360 "(if(null? paths)"
00361 " #f"
00362 "(let*((base(path->complete-path(car paths)))"
00363 "(name(build-path base program)))"
00364 "(if(file-exists? name)"
00365 "(found-exec name)"
00366 "(loop(cdr paths)))))))"
00367 "(let((p(path->complete-path program)))"
00368 "(and(file-exists? p)(found-exec p))))))"
00369 "((program libpath)(find-executable-path program libpath #f))"
00370 "((program)(find-executable-path program #f #f))))"
00371 "(define(embedded-load start end str)"
00372 "(let*((s(if str"
00373 " str"
00374 "(let*((sp(find-system-path 'exec-file)) "
00375 "(exe(find-executable-path sp #f))"
00376 "(start(or(string->number start) 0))"
00377 "(end(or(string->number end) 0)))"
00378 "(with-input-from-file exe "
00379 "(lambda()"
00380 "(file-position(current-input-port) start)"
00381 "(read-bytes(max 0(- end start))))))))"
00382 "(p(open-input-bytes s)))"
00383 "(let loop()"
00384 "(let((e(parameterize((read-accept-compiled #t))"
00385 "(read p))))"
00386 "(unless(eof-object? e)"
00387 "(eval e)"
00388 "(loop)))))))"
00389 );
00390   EVAL_ONE_STR(
00391 "(module #%builtin '#%kernel"
00392 "(#%require '#%expobs"
00393 "(only '#%foreign) "
00394 " '#%paramz"
00395 " '#%network"
00396 " '#%utils"
00397 "(only '#%place)))"
00398 );
00399   EVAL_ONE_STR(
00400 "(module #%boot '#%kernel"
00401 "(#%require '#%min-stx '#%utils)"
00402 "(#%provide boot)"
00403 "(define-values(dll-suffix)"
00404 "(system-type 'so-suffix))"
00405 "(define-values(default-load/use-compiled)"
00406 "(let*((resolve(lambda(s)"
00407 "(if(complete-path? s)"
00408 " s"
00409 "(let((d(current-load-relative-directory)))"
00410 "(if d(path->complete-path s d) s)))))"
00411 "(date-of(lambda(a modes)"
00412 "(ormap"
00413 "(lambda(compiled-dir)"
00414 "(let((a(a compiled-dir)))"
00415 "(let((v(file-or-directory-modify-seconds a #f(lambda() #f))))"
00416 "(and v(cons a v)))))"
00417 " modes)))"
00418 "(date>=?"
00419 "(lambda(modes a bm)"
00420 "(and a"
00421 "(let((am(date-of a modes)))"
00422 "(or(and(not bm) am) "
00423 "(and am bm(>=(cdr am)(cdr bm)) am)))))))"
00424 "(lambda(path expect-module)"
00425 "(unless(path-string? path)"
00426 " (raise-type-error 'load/use-compiled \"path or valid-path string\" path))"
00427 "(let*-values(((path)(resolve path))"
00428 "((base file dir?)(split-path path))"
00429 "((base)(if(eq? base 'relative) 'same base))"
00430 "((modes)(use-compiled-file-paths)))"
00431 "(let*((get-so(lambda(file rep-sfx?)"
00432 "(lambda(compiled-dir)"
00433 "(build-path base"
00434 " compiled-dir"
00435 " \"native\""
00436 "(system-library-subpath)"
00437 "(if rep-sfx?"
00438 "(path-add-suffix"
00439 " file"
00440 " dll-suffix)"
00441 " file)))))"
00442 "(zo(lambda(compiled-dir)"
00443 "(build-path base"
00444 " compiled-dir"
00445 " (path-add-suffix file #\".zo\"))))"
00446 "(so(get-so file #t))"
00447 "(path-d(date-of(lambda(dir) path) modes))"
00448 "(with-dir(lambda(t) "
00449 "(parameterize((current-load-relative-directory "
00450 "(if(path? base) "
00451 " base "
00452 "(current-directory))))"
00453 "(t)))))"
00454 "(cond"
00455 "((date>=? modes so path-d)"
00456 " =>(lambda(so-d)"
00457 "(with-dir(lambda()((current-load-extension)(car so-d) expect-module)))))"
00458 "((date>=? modes zo path-d)"
00459 " =>(lambda(zo-d)"
00460 "(with-dir(lambda()((current-load)(car zo-d) expect-module)))))"
00461 "(else"
00462 "(with-dir(lambda()((current-load) path expect-module))))))))))"
00463 "(define-values(default-reader-guard)"
00464 "(lambda(path) path))"
00465 "(define-values(-module-hash-table-table)(make-weak-hasheq)) "
00466 "(define-values(-path-cache)(make-weak-hash)) "
00467 "(define-values(-loading-filename)(gensym))"
00468 "(define-values(-loading-prompt-tag)(make-continuation-prompt-tag 'module-loading))"
00469 "(define-values(-prev-relto) #f)"
00470 "(define-values(-prev-relto-dir) #f)"
00471 "(define(split-relative-string s coll-mode?)"
00472 "(let((l(let loop((s s))"
00473 "(cond"
00474 " ((regexp-match #rx\"^(.*?)/(.*)$\" s)"
00475 " =>(lambda(m)"
00476 "(cons(cadr m)"
00477 "(loop(caddr m)))))"
00478 "(else(list s))))))"
00479 "(if coll-mode?"
00480 " l"
00481 "(let loop((l l))"
00482 "(if(null?(cdr l))"
00483 "(values null(car l))"
00484 "(let-values(((c f)(loop(cdr l))))"
00485 "(values(cons(car l) c) f)))))))"
00486 "(define-values(make-standard-module-name-resolver)"
00487 "(lambda(orig-namespace)"
00488 "(define-values(planet-resolver) #f)"
00489 "(define-values(standard-module-name-resolver)"
00490 "(case-lambda "
00491 "((s) "
00492 "(unless(resolved-module-path? s)"
00493 "(raise-type-error 'standard-module-name-resolver"
00494 " \"resolved-module-path\""
00495 " s))"
00496 "(when planet-resolver"
00497 "(planet-resolver s))"
00498 "(let((ht(or(hash-ref -module-hash-table-table"
00499 "(namespace-module-registry(current-namespace))"
00500 " #f)"
00501 "(let((ht(make-hasheq)))"
00502 "(hash-set! -module-hash-table-table"
00503 "(namespace-module-registry(current-namespace))"
00504 " ht)"
00505 " ht))))"
00506 "(hash-set! ht s 'attach)))"
00507 "((s relto stx)(standard-module-name-resolver s relto stx #t))"
00508 "((s relto stx load?)"
00509 "(unless(or(path? s)"
00510 "(module-path? s))"
00511 "(if stx"
00512 "(raise-syntax-error #f"
00513 " \"bad module path\""
00514 " stx)"
00515 "(raise-type-error 'standard-module-name-resolver"
00516 " \"module-path or path\""
00517 " s)))"
00518 "(cond"
00519 "((and(pair? s)(eq?(car s) 'quote))"
00520 "(make-resolved-module-path(cadr s)))"
00521 "((and(pair? s)(eq?(car s) 'planet))"
00522 "(unless planet-resolver"
00523 "(parameterize((current-namespace orig-namespace))"
00524 " (set! planet-resolver (dynamic-require '(lib \"planet/resolver.ss\") 'planet-module-name-resolver))))"
00525 "(planet-resolver s relto stx load?))"
00526 "(else"
00527 "(let((get-dir(lambda()"
00528 "(or(and relto"
00529 "(if(eq? relto -prev-relto)"
00530 " -prev-relto-dir"
00531 "(let((p(resolved-module-path-name relto)))"
00532 "(and(path? p)"
00533 "(let-values(((base n d?)(split-path p)))"
00534 "(set! -prev-relto relto)"
00535 "(set! -prev-relto-dir base)"
00536 " base)))))"
00537 "(current-load-relative-directory)"
00538 "(current-directory))))"
00539 "(show-collection-err(lambda(s)"
00540 "(if stx"
00541 "(raise-syntax-error"
00542 " #f"
00543 " s"
00544 " stx)"
00545 "(error s)))))"
00546 "(let((s-parsed"
00547 "(cond"
00548 "((symbol? s)"
00549 "(or(hash-ref -path-cache"
00550 "(cons s(current-library-collection-paths))"
00551 " #f)"
00552 "(let-values(((cols file)(split-relative-string(symbol->string s) #f)))"
00553 "(let((p(-find-col 'standard-module-name-resolver"
00554 " show-collection-err"
00555 "(if(null? cols) file(car cols))"
00556 "(if(null? cols) null(cdr cols)))))"
00557 "(build-path p(if(null? cols)"
00558 " \"main.ss\""
00559 " (string-append file \".ss\")))))))"
00560 "((string? s)"
00561 "(let*((dir(get-dir)))"
00562 "(or(hash-ref -path-cache(cons s dir) #f)"
00563 "(let-values(((cols file)(split-relative-string s #f)))"
00564 "(apply build-path "
00565 " dir"
00566 "(append"
00567 "(map(lambda(s)"
00568 "(cond"
00569 " ((string=? s \".\") 'same)"
00570 " ((string=? s \"..\") 'up)"
00571 "(else s)))"
00572 " cols)"
00573 "(list file)))))))"
00574 "((path? s) "
00575 "(if(absolute-path? s)"
00576 " s"
00577 " (list \" (a path must be absolute)\")))"
00578 "((eq?(car s) 'lib)"
00579 "(or(hash-ref -path-cache"
00580 "(cons s(current-library-collection-paths))"
00581 " #f)"
00582 "(let*-values(((cols file)(split-relative-string(cadr s) #f))"
00583 "((old-style?)(if(null?(cddr s))"
00584 "(and(null? cols)"
00585 " (regexp-match? #rx\"[.]\" file))"
00586 " #t)))"
00587 "(let((p(let-values(((cols)"
00588 "(if old-style?"
00589 "(append(if(null?(cddr s))"
00590 " '(\"mzlib\")"
00591 "(apply append"
00592 "(map(lambda(p)"
00593 "(split-relative-string p #t))"
00594 "(cddr s))))"
00595 " cols)"
00596 "(if(null? cols)"
00597 "(list file)"
00598 " cols))))"
00599 "(-find-col 'standard-module-name-resolver"
00600 " show-collection-err"
00601 "(car cols)"
00602 "(cdr cols)))))"
00603 "(build-path p(if old-style?"
00604 " file"
00605 "(if(null? cols)"
00606 " \"main.ss\""
00607 " (if (regexp-match? #rx\"[.]\" file)"
00608 " file"
00609 " (string-append file \".ss\")))))))))"
00610 "((eq?(car s) 'file)"
00611 "(path->complete-path(expand-user-path(cadr s))(get-dir))))))"
00612 "(unless(or(path? s-parsed) "
00613 "(vector? s-parsed))"
00614 "(if stx"
00615 "(raise-syntax-error"
00616 " 'require"
00617 " (format \"bad module path~a\" (if s-parsed"
00618 "(car s-parsed)"
00619 " \"\"))"
00620 " stx)"
00621 "(raise-type-error "
00622 " 'standard-module-name-resolver"
00623 " (format \"module path~a\" (if s-parsed"
00624 "(car s-parsed)"
00625 " \"\"))"
00626 " s)))"
00627 "(let*((filename(if(vector? s-parsed)"
00628 "(vector-ref s-parsed 0)"
00629 "(simplify-path(cleanse-path s-parsed) #f)))"
00630 "(normal-filename(if(vector? s-parsed)"
00631 "(vector-ref s-parsed 1)"
00632 "(normal-case-path filename))))"
00633 "(let-values(((base name dir?)(if(vector? s-parsed)"
00634 "(values 'ignored(vector-ref s-parsed 2) 'ignored)"
00635 "(split-path filename))))"
00636 "(let*((no-sfx(if(vector? s-parsed)"
00637 "(vector-ref s-parsed 3)"
00638 " (path-replace-suffix name #\"\"))))"
00639 "(let((modname(if(vector? s-parsed)"
00640 "(vector-ref s-parsed 4)"
00641 "(make-resolved-module-path filename)))"
00642 "(ht(or(hash-ref -module-hash-table-table"
00643 "(namespace-module-registry(current-namespace))"
00644 " #f)"
00645 "(let((ht(make-hasheq)))"
00646 "(hash-set! -module-hash-table-table"
00647 "(namespace-module-registry(current-namespace))"
00648 " ht)"
00649 " ht))))"
00650 "(when load?"
00651 "(let((got(hash-ref ht modname #f)))"
00652 "(unless got"
00653 "(let((l(let((tag(if(continuation-prompt-available? -loading-prompt-tag)"
00654 " -loading-prompt-tag"
00655 "(default-continuation-prompt-tag))))"
00656 "(continuation-mark-set->list"
00657 "(current-continuation-marks tag)"
00658 " -loading-filename"
00659 " tag)))"
00660 "(nsr(namespace-module-registry(current-namespace))))"
00661 "(for-each"
00662 "(lambda(s)"
00663 "(when(and(equal?(cdr s) normal-filename)"
00664 "(eq?(car s) nsr))"
00665 "(error"
00666 " 'standard-module-name-resolver"
00667 " \"cycle in loading at ~e: ~e\""
00668 " filename"
00669 "(map cdr(reverse(cons s l))))))"
00670 " l))"
00671 "((if(continuation-prompt-available? -loading-prompt-tag)"
00672 "(lambda(f)(f))"
00673 "(lambda(f)(call-with-continuation-prompt f -loading-prompt-tag)))"
00674 "(lambda()"
00675 "(with-continuation-mark -loading-filename(cons "
00676 "(namespace-module-registry(current-namespace))"
00677 " normal-filename)"
00678 "(parameterize((current-module-declare-name modname))"
00679 "((current-load/use-compiled) "
00680 " filename "
00681 "(string->symbol(path->string no-sfx)))))))"
00682 "(hash-set! ht modname #t))))"
00683 "(when(and(not(vector? s-parsed))"
00684 "(or(string? s)"
00685 "(symbol? s)"
00686 "(and(pair? s)"
00687 "(eq?(car s) 'lib))))"
00688 "(hash-set! -path-cache"
00689 "(if(string? s)"
00690 "(cons s(get-dir))"
00691 "(cons s(current-library-collection-paths)))"
00692 "(vector filename"
00693 " normal-filename"
00694 " name"
00695 " no-sfx"
00696 " modname)))"
00697 " modname)))))))))))"
00698 " standard-module-name-resolver))"
00699 "(define-values(boot)"
00700 "(lambda()"
00701 "(current-module-name-resolver(make-standard-module-name-resolver(current-namespace)))"
00702 "(current-load/use-compiled default-load/use-compiled)"
00703 "(current-reader-guard default-reader-guard))))"
00704 );