suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

code cleanup etc

Browse Source 
svn: r5401
This commit is contained in:
Eli Barzilay 2007-01-18 19:36:43 +00:00
parent 33f9bc68db
commit b35c1ab25f
1 changed files with 374 additions and 475 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

413
collects/syntax/moddep.ss
View File

@ -1,85 +1,70 @@
(module moddep mzscheme (module moddep mzscheme
(require (lib "etc.ss") (require (lib "port.ss")
(lib "port.ss")
(lib "list.ss") (lib "list.ss")
(lib "string.ss")
(lib "contract.ss") (lib "contract.ss")
(lib "kw.ss")
(lib "resolver.ss" "planet")) (lib "resolver.ss" "planet"))
(provide moddep-current-open-input-file) (provide moddep-current-open-input-file)
(define moddep-current-open-input-file (define moddep-current-open-input-file
(make-parameter open-input-file)) (make-parameter open-input-file))
(provide with-module-reading-parameterization) (provide with-module-reading-parameterization)
(define (with-module-reading-parameterization thunk) (define (with-module-reading-parameterization thunk)
(parameterize ((read-case-sensitive #t) (parameterize ([read-case-sensitive #t]
(read-square-bracket-as-paren #t) [read-square-bracket-as-paren #t]
(read-curly-brace-as-paren #t) [read-curly-brace-as-paren #t]
(read-accept-box #t) [read-accept-box #t]
(read-accept-compiled #t) [read-accept-compiled #t]
(read-accept-bar-quote #t) [read-accept-bar-quote #t]
(read-accept-graph #t) [read-accept-graph #t]
(read-decimal-as-inexact #t) [read-decimal-as-inexact #t]
(read-accept-dot #t) [read-accept-dot #t]
(read-accept-quasiquote #t) [read-accept-quasiquote #t]
(read-accept-reader #t) [read-accept-reader #t]
(current-readtable #f)) [current-readtable #f])
(thunk))) (thunk)))
(define (raise-wrong-module-name filename expected-name name) (define (raise-wrong-module-name filename expected-name name)
(raise (error 'load-handler
(make-exn:fail "expected a `module' declaration for `~a' in ~s, found: ~a"
(format expected-name filename name))
"load-handler: expected a `module' declaration for `~a' in ~s, found: ~a"
expected-name filename name)
(current-continuation-marks))))
(define (check-module-form exp expected-module filename) (define (check-module-form exp expected-module filename)
(cond (cond [(or (eof-object? exp) (eof-object? (syntax-e exp)))
[(or (eof-object? exp)
(eof-object? (syntax-e exp)))
(and filename (and filename
(raise (error 'load-handler
(make-exn:fail "expected a `module' declaration for `~a' in ~s, but found end-of-file"
(format expected-module filename))]
"load-handler: expected a `module' declaration for `~a' in ~s, but found end-of-file"
expected-module filename)
(current-continuation-marks))))]
[(compiled-module-expression? (syntax-e exp)) [(compiled-module-expression? (syntax-e exp))
(if (eq? (module-compiled-name (syntax-e exp)) (if (eq? (module-compiled-name (syntax-e exp)) expected-module)
expected-module)
;; It's fine: ;; It's fine:
exp exp
;; Wrong name: ;; Wrong name:
(and filename (and filename (raise-wrong-module-name
(raise-wrong-module-name filename expected-module filename expected-module
(module-compiled-name (syntax-e exp)))))] (module-compiled-name (syntax-e exp)))))]
[(and (syntax? exp) [(and (syntax? exp)
(syntax-case exp () (syntax-case exp ()
[(mod nm . _) [(mod nm . _)
(and (eq? (syntax-e (syntax mod)) 'module) (and (eq? (syntax-e #'mod) 'module) (identifier? #'nm))]
(identifier? (syntax nm)))]
[_else #f])) [_else #f]))
;; It's ok; need to install a specific `module' binding: ;; It's ok; need to install a specific `module' binding:
(with-syntax ([(mod nm . _) exp]) (with-syntax ([(mod nm . _) exp])
(unless (eq? (syntax-e (syntax nm)) expected-module) (unless (eq? (syntax-e #'nm) expected-module)
(raise-wrong-module-name filename expected-module (syntax-e (syntax nm)))) (raise-wrong-module-name filename expected-module
(syntax-e #'nm)))
(datum->syntax-object exp (datum->syntax-object exp
(cons (syntax module) (cons #'module (cdr (syntax-e exp)))
(cdr (syntax-e exp)))
exp exp
exp))] exp))]
[else [else
(and filename (and filename
(raise (error 'load-handler
(make-exn:fail "expected a `module' declaration for `~a' in ~s, but found something else"
(format expected-module filename))]))
"load-handler: expected a `module' declaration for `~a' in ~s, but found something else"
expected-module filename)
(current-continuation-marks))))]))
(define re:suffix #rx#"\\..*$")
(define (resolve s) (define (resolve s)
(if (complete-path? s) (if (complete-path? s)
@ -88,44 +73,41 @@
(if d (path->complete-path s d) s)))) (if d (path->complete-path s d) s))))
(define (date>=? a bm) (define (date>=? a bm)
(and a (and a (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(file-or-directory-modify-seconds a))]) (file-or-directory-modify-seconds a))])
(or (and (not bm) am) (and am bm (>= am bm)))))) (or (and (not bm) am) (and am bm (>= am bm))))))
(define (read-one path src?) (define (read-one path src?)
(let ([p ((moddep-current-open-input-file) path)]) (let ([p ((moddep-current-open-input-file) path)])
(when src? (when src? (port-count-lines! p) (strip-shell-command-start p))
(port-count-lines! p)
(strip-shell-command-start p))
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(let ([v (with-module-reading-parameterization (let ([v (with-module-reading-parameterization
(lambda () (lambda () (read-syntax path p)))])
(read-syntax path p)))])
(when (eof-object? v) (when (eof-object? v)
(error 'read-one "empty file; expected a module declaration in: ~a" path)) (error 'read-one
"empty file; expected a module declaration in: ~a" path))
(let* ([name (let-values ([(base name dir?) (split-path path)]) (let* ([name (let-values ([(base name dir?) (split-path path)])
(string->symbol (bytes->string/utf-8 (string->symbol
(bytes->string/utf-8
(path->bytes (path-replace-suffix name #"")) (path->bytes (path-replace-suffix name #""))
#\?)))] #\?)))]
[v (check-module-form v name path)]) [v (check-module-form v name path)])
(unless (eof-object? (read p)) (unless (eof-object? (read p))
(error (error 'read-one
'read-one
"file has more than one expression; expected a module declaration only in: ~a" "file has more than one expression; expected a module declaration only in: ~a"
path)) path))
(if (and (syntax? v) (if (and (syntax? v) (compiled-expression? (syntax-e v)))
(compiled-expression? (syntax-e v)))
(syntax-e v) (syntax-e v)
v)))) v))))
(lambda () (close-input-port p))))) (lambda () (close-input-port p)))))
(define-struct (exn:get-module-code exn) (path)) (define-struct (exn:get-module-code exn) (path))
(define get-module-code (define/kw (get-module-code path
(opt-lambda (path [sub-path "compiled"] [compiler compile] [extension-handler #f]) #:optional
[sub-path "compiled"] [compiler compile] [extension-handler #f])
(unless (path-string? path) (unless (path-string? path)
(raise-type-error 'get-module-code "path or string (sans nul)" path)) (raise-type-error 'get-module-code "path or string (sans nul)" path))
(let*-values ([(path) (resolve path)] (let*-values ([(path) (resolve path)]
@ -133,19 +115,11 @@
[(base) (if (eq? base 'relative) 'same base)] [(base) (if (eq? base 'relative) 'same base)]
[(mode) (use-compiled-file-paths)]) [(mode) (use-compiled-file-paths)])
(let* ([get-so (lambda (file) (let* ([get-so (lambda (file)
(build-path base (build-path
sub-path base sub-path "native"
"native"
(system-library-subpath) (system-library-subpath)
(path-replace-suffix (path-replace-suffix file (system-type 'so-suffix))))]
file [zo (build-path base sub-path (path-replace-suffix file #".zo"))]
(case (system-type)
[(windows) #".dll"]
[(macosx) #".dylib"]
[else #".so"]))))]
[zo (build-path base
sub-path
(path-replace-suffix file #".zo"))]
[so (get-so file)] [so (get-so file)]
[_loader-so (get-so (string->path "_loader.ss"))] [_loader-so (get-so (string->path "_loader.ss"))]
[path-d (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) [path-d (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
@ -158,14 +132,11 @@
(t)))]) (t)))])
(cond (cond
;; Use .zo, if it's new enough ;; Use .zo, if it's new enough
[(date>=? zo path-d) [(date>=? zo path-d) (read-one zo #f)]
(read-one zo #f)]
;; Otherwise, use source if it exists ;; Otherwise, use source if it exists
[path-d [path-d (with-dir (lambda () (compiler (read-one path #t))))]
(with-dir (lambda () (compiler (read-one path #t))))]
;; No source --- maybe there's an .so? ;; No source --- maybe there's an .so?
[(and (not path-d) [(and (not path-d) (date>=? so path-d))
(date>=? so path-d))
(if extension-handler (if extension-handler
(extension-handler so #f) (extension-handler so #f)
(raise (make-exn:get-module-code (raise (make-exn:get-module-code
@ -176,7 +147,8 @@
[(and (not path-d) [(and (not path-d)
(date>=? _loader-so path-d) (date>=? _loader-so path-d)
(let ([getter (load-extension _loader-so)]) (let ([getter (load-extension _loader-so)])
(let-values ([(loader modname) (getter (string->symbol (let-values ([(loader modname)
(getter (string->symbol
(bytes->string/latin-1 (bytes->string/latin-1
(path->bytes (path->bytes
(path-replace-suffix file #"")))))]) (path-replace-suffix file #"")))))])
@ -190,81 +162,64 @@
(current-continuation-marks) (current-continuation-marks)
loader))))] loader))))]
;; Report a not-there error ;; Report a not-there error
[else [else (raise (make-exn:get-module-code
(raise (make-exn:get-module-code
(format "get-module-code: no such file: ~e" path) (format "get-module-code: no such file: ~e" path)
(current-continuation-marks) (current-continuation-marks)
#f))]))))) #f))]))))
(define re:dir #rx#"(.+?)/+(.*)")
(define (force-relto relto dir?) (define (force-relto relto dir?)
(cond (cond [(path-string? relto)
[(path-string? relto)
(if dir? (if dir?
(let-values ([(base n d?) (split-path relto)]) (let-values ([(base n d?) (split-path relto)])
(if (eq? base 'relative) (if (eq? base 'relative)
(or (current-load-relative-directory) (or (current-load-relative-directory) (current-directory))
(current-directory))
base)) base))
relto)] relto)]
[(pair? relto) relto] [(pair? relto) relto]
[(not dir?) [(not dir?)
(error 'resolve-module-path-index "can't resolve \"self\" with non-path relative-to: ~e" relto)] (error 'resolve-module-path-index
"can't resolve \"self\" with non-path relative-to: ~e" relto)]
[(procedure? relto) (relto)] [(procedure? relto) (relto)]
[else [else (current-directory)]))
(current-directory)]))
(define resolve-module-path (define (explode-relpath-string p)
;; relto should be a complete path, #f, or procedure that returns a complete path (map (lambda (p)
(lambda (s relto) (cond [(assoc p '((#"." . same) (#".." . up))) => cdr]
(let ([get-dir (lambda () (force-relto relto #t))]) [else (bytes->path p)]))
(cond (regexp-split #rx#"/+" (string->bytes/utf-8 p))))
[(string? s)
(define (resolve-module-path s relto)
;; relto should be a complete path, #f, or procedure that returns a
;; complete path
(define (get-dir) (force-relto relto #t))
(cond [(string? s)
;; Parse Unix-style relative path string ;; Parse Unix-style relative path string
(let loop ([path (get-dir)][s (if (path? s) (apply build-path (get-dir) (explode-relpath-string s))]
(path->bytes s) [(and (or (not (pair? s)) (not (list? s))) (not (path? s)))
(string->bytes/utf-8 s))])
(let ([prefix (regexp-match re:dir s)])
(if prefix
(loop (build-path path
(let ([p (cadr prefix)])
(cond
[(bytes=? p #".") 'same]
[(bytes=? p #"..") 'up]
[else (bytes->path p)])))
(caddr prefix))
(build-path path (bytes->path s)))))]
[(and (or (not (pair? s))
(not (list? s)))
(not (path? s)))
#f] #f]
[(or (path? s) [(or (path? s) (eq? (car s) 'file))
(eq? (car s) 'file)) (let ([p (if (path? s) s (cadr s))])
(let ([p (if (path? s) (path->complete-path
s p (let ([d (get-dir)])
(cadr s))])
(path->complete-path p (let ([d (get-dir)])
(if (path-string? d) (if (path-string? d)
d d
(or (current-load-relative-directory) (or (current-load-relative-directory)
(current-directory))))))] (current-directory))))))]
[(eq? (car s) 'lib) [(eq? (car s) 'lib)
(let ([cols (let ([len (length s)]) (let* ([cols (let ([len (length s)])
(if (= len 2) (if (= len 2) (list "mzlib") (cddr s)))]
(list "mzlib") [p (apply collection-path cols)])
(cddr s)))]) (build-path p (cadr s)))]
(let ([p (apply collection-path cols)])
(build-path p (cadr s))))]
[(eq? (car s) 'planet) [(eq? (car s) 'planet)
(let ((module-id (let ([module-id
(cond (and (path? relto)
[(path? relto) (string->symbol
(string->symbol (string-append "," (path->string (path->complete-path relto))))] (string-append
[else #f]))) "," (path->string (path->complete-path relto)))))])
(let-values ([(path pkg) (get-planet-module-path/pkg s module-id #f)]) (let-values ([(path pkg)
(get-planet-module-path/pkg s module-id #f)])
path))] path))]
[else #f])))) [else #f]))
(define (resolve-module-path-index mpi relto) (define (resolve-module-path-index mpi relto)
;; relto must be a complete path ;; relto must be a complete path
@ -274,8 +229,7 @@
(force-relto relto #f)))) (force-relto relto #f))))
(define (resolve-possible-module-path-index base relto) (define (resolve-possible-module-path-index base relto)
(cond (cond [(module-path-index? base)
[(module-path-index? base)
(resolve-module-path-index base relto)] (resolve-module-path-index base relto)]
[(symbol? base) [(symbol? base)
(let ([s (symbol->string base)]) (let ([s (symbol->string base)])
@ -283,31 +237,26 @@
(char=? #\, (string-ref s 0))) (char=? #\, (string-ref s 0)))
(substring s 1 (string-length s)) (substring s 1 (string-length s))
relto))] relto))]
[relto (if (procedure? relto) [relto (if (procedure? relto) (relto) relto)]
(relto)
relto)]
[else #f])) [else #f]))
(define re:path-only #rx#"^(.*)/[^/]*$") (define (collapse-module-path s relto-mp)
;; relto-mp should be a relative path, '(lib relative-path collection),
;; or '(file path) or a thunk that produces one of those
(define collapse-module-path
;; relto-mp should be a relative path, '(lib relative-path collection), or '(file path)
;; or a thunk that produces one of those
(lambda (s relto-mp)
;; Used for 'lib paths, so it's always Unix-style ;; Used for 'lib paths, so it's always Unix-style
(define (attach-to-relative-path-string elements relto) (define (attach-to-relative-path-string elements relto)
(let ([elem-str (substring (let ([elem-str
(substring
(apply string-append (apply string-append
(map (lambda (i) (map (lambda (i)
(string-append (string-append
"/" "/"
(cond (cond [(bytes? i) (bytes->string/locale i)]
[(bytes? i) (bytes->string/locale i)]
[(path? i) (path->string i)] [(path? i) (path->string i)]
[(eq? i 'up) ".."] [(eq? i 'up) ".."]
[else i]))) [else i])))
(filter (lambda (x) (filter (lambda (x) (not (eq? x 'same)))
(not (eq? x 'same)))
elements))) elements)))
1)]) 1)])
(if (or (regexp-match #rx"^[.]/+[^/]*" relto) (if (or (regexp-match #rx"^[.]/+[^/]*" relto)
@ -322,125 +271,88 @@
(define (attach-to-relative-path relto) (define (attach-to-relative-path relto)
(apply build-path (apply build-path
(let-values ([(base n d?) (split-path relto)]) (let-values ([(base n d?) (split-path relto)])
(if (eq? base 'relative) (if (eq? base 'relative) 'same base))
'same (map (lambda (i) (if (bytes? i) (bytes->path i) i))
base))
(map (lambda (i)
(cond
[(bytes? i) (bytes->path i)]
[else i]))
elements))) elements)))
(when (procedure? relto-mp) (when (procedure? relto-mp) (set! relto-mp (relto-mp)))
(set! relto-mp (relto-mp)))
(cond (cond
[(or (path? relto-mp) [(or (path? relto-mp) (and (string? relto-mp) (ormap path? elements)))
(and (string? relto-mp)
(ormap path? elements)))
(apply build-path (apply build-path
(let-values ([(base name dir?) (split-path relto-mp)]) (let-values ([(base name dir?) (split-path relto-mp)])
(if (eq? base 'relative) (if (eq? base 'relative) 'same base))
'same
base))
(map (lambda (x) (if (bytes? x) (bytes->path x) x)) (map (lambda (x) (if (bytes? x) (bytes->path x) x))
elements))] elements))]
[(string? relto-mp) [(string? relto-mp)
(bytes->string/locale (bytes->string/locale
(apply (apply
bytes-append bytes-append
(let ([m (regexp-match re:path-only (string->bytes/locale relto-mp))]) (cond [(regexp-match #rx#"^(.*)/[^/]*$"
(if m (string->bytes/locale relto-mp))
(cadr m) => cadr]
#".")) [else #"."])
(map (lambda (e) (map (lambda (e)
(cond (cond [(eq? e 'same) #"/."]
[(eq? e 'same) #"/."]
[(eq? e 'up) #"/.."] [(eq? e 'up) #"/.."]
[else (bytes-append #"/" (if (path? e) [else (bytes-append
(path->bytes e) #"/" (if (path? e) (path->bytes e) e))]))
e))]))
elements)))] elements)))]
[(eq? (car relto-mp) 'file) [(eq? (car relto-mp) 'file)
(let ([path ((if (ormap path? elements) (let ([path ((if (ormap path? elements) values path->string)
values
path->string)
(attach-to-relative-path (cadr relto-mp)))]) (attach-to-relative-path (cadr relto-mp)))])
(if (path? path) (if (path? path) path `(file ,path)))]
path
`(file ,path)))]
[(eq? (car relto-mp) 'lib) [(eq? (car relto-mp) 'lib)
(let ([path (attach-to-relative-path-string elements (let ([path (attach-to-relative-path-string
(cadr relto-mp))]) elements (cadr relto-mp))])
`(lib ,path ,(caddr relto-mp)))] `(lib ,path ,(caddr relto-mp)))]
[(eq? (car relto-mp) 'planet) [(eq? (car relto-mp) 'planet)
(let ([pathstr (attach-to-relative-path-string elements (let ([pathstr (attach-to-relative-path-string
(cadr relto-mp))]) elements (cadr relto-mp))])
`(planet ,pathstr ,(caddr relto-mp)))] `(planet ,pathstr ,(caddr relto-mp)))]
[else (error 'combine-relative-elements "don't know how to deal with: ~s" relto-mp)])) [else (error 'combine-relative-elements
"don't know how to deal with: ~s" relto-mp)]))
(cond (cond [(string? s)
[(string? s)
;; Parse Unix-style relative path string ;; Parse Unix-style relative path string
(let loop ([elements null][s (string->bytes/utf-8 s)]) (combine-relative-elements (explode-relpath-string s))]
(let ([prefix (regexp-match re:dir s)]) [(and (or (not (pair? s)) (not (list? s))) (not (path? s)))
(if prefix
(loop (cons (let ([p (cadr prefix)])
(cond
[(bytes=? p #".") 'same]
[(bytes=? p #"..") 'up]
[else (bytes->path p)]))
elements)
(caddr prefix))
(combine-relative-elements
(reverse (cons s elements))))))]
[(and (or (not (pair? s))
(not (list? s)))
(not (path? s)))
#f] #f]
[(or (path? s) [(or (path? s) (eq? (car s) 'file))
(eq? (car s) 'file)) (let ([p (if (path? s) s (cadr s))])
(let ([p (if (path? s)
s
(cadr s))])
(if (absolute-path? p) (if (absolute-path? p)
s s
(let loop ([p p] [elements null]) (let loop ([p p] [elements null])
(let-values ([(base name dir?) (split-path p)]) (let-values ([(base name dir?) (split-path p)])
(cond (cond [(eq? base 'relative)
[(eq? base 'relative) (combine-relative-elements (cons name elements))]
(combine-relative-elements
(cons name elements))]
[else (loop base (cons name elements))])))))] [else (loop base (cons name elements))])))))]
[(eq? (car s) 'lib) [(eq? (car s) 'lib)
(let ([cols (let ([len (length s)]) (let ([cols (let ([len (length s)])
(if (= len 2) (if (= len 2) (list "mzlib") (cddr s)))])
(list "mzlib")
(cddr s)))])
`(lib ,(attach-to-relative-path-string `(lib ,(attach-to-relative-path-string
(append (cdr cols) (append (cdr cols) (list (cadr s)))
(list (cadr s)))
".") ".")
,(car cols)))] ,(car cols)))]
[(eq? (car s) 'planet) [(eq? (car s) 'planet)
(let ((cols (cdddr s))) (let ([cols (cdddr s)])
`(planet `(planet
,(attach-to-relative-path-string ,(attach-to-relative-path-string
(append cols (append cols (list (cadr s)))
(list (cadr s)))
".") ".")
,(caddr s)))] ,(caddr s)))]
[else #f]))) [else #f]))
(define (collapse-module-path-index mpi relto-mp) (define (collapse-module-path-index mpi relto-mp)
(let-values ([(path base) (module-path-index-split mpi)]) (let-values ([(path base) (module-path-index-split mpi)])
(if path (if path
(collapse-module-path path (collapse-module-path
path
(cond (cond
[(symbol? base) [(symbol? base)
(let ([s (symbol->string base)]) (let ([s (symbol->string base)])
(if (and ((string-length s) . > . 0) (if (and ((string-length s) . > . 0)
(char=? #\, (string-ref s 0))) (char=? #\, (string-ref s 0)))
`(file ,(substring s 1 (string-length s))) `(file ,(substring s 1))
relto-mp))] relto-mp))]
[(module-path-index? base) [(module-path-index? base)
(collapse-module-path-index base relto-mp)] (collapse-module-path-index base relto-mp)]
@ -449,15 +361,15 @@
(define (show-import-tree module-path) (define (show-import-tree module-path)
(let loop ([path (resolve-module-path module-path #f)][indent ""][fs ""]) (let loop ([path (resolve-module-path module-path #f)][indent ""][fs ""])
(printf "~a~a~a~n" indent path fs) (printf "~a~a~a\n" indent path fs)
(let ([code (get-module-code path)]) (let ([code (get-module-code path)])
(let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)] (let-values ([(imports fs-imports ft-imports)
[(mk-loop) (lambda (fs) (module-compiled-imports code)])
(lambda (i) (define ((mk-loop fs) i)
(unless (symbol? i) (unless (symbol? i)
(loop (resolve-module-path-index i path) (loop (resolve-module-path-index i path)
(format " ~a" indent) (format " ~a" indent)
fs))))]) fs)))
(for-each (mk-loop "") imports) (for-each (mk-loop "") imports)
(for-each (mk-loop " [for-syntax]") fs-imports) (for-each (mk-loop " [for-syntax]") fs-imports)
(for-each (mk-loop " [for-template]") ft-imports))))) (for-each (mk-loop " [for-template]") ft-imports)))))
@ -468,10 +380,8 @@
(not (regexp-match #rx"/$" v)))) (not (regexp-match #rx"/$" v))))
(define (module-path-v? v) (define (module-path-v? v)
(cond (cond [(path? v) #t]
[(path? v) #t] [(string? v) (module-path-v-string? v)]
[(string? v)
(module-path-v-string? v)]
[(pair? v) [(pair? v)
(case (car v) (case (car v)
[(file) (and (pair? (cdr v)) [(file) (and (pair? (cdr v))
@ -485,57 +395,46 @@
[else #f])) [else #f]))
(define rel-to-path-string/thunk/#f (define rel-to-path-string/thunk/#f
(or/c path-string? (or/c path-string? (-> path-string?) false/c))
(-> path-string?)
false/c))
(define simple-rel-to-module-path-v/c (define simple-rel-to-module-path-v/c
(or/c (or/c
(list/c (symbols 'lib) module-path-v-string? module-path-v-string?) (list/c (symbols 'lib) module-path-v-string? module-path-v-string?)
(list/c (symbols 'file) (and/c string? path-string?)) (list/c (symbols 'file) (and/c string? path-string?))
;; not quite specific enough of a contract -- it should also spell out what's ;; not quite specific enough of a contract -- it should also spell out
;; allowed in the package spec ;; what's allowed in the package spec
(cons/c (symbols 'planet) (cons/c string? (cons/c (listof any/c) (listof string?)))) (cons/c (symbols 'planet)
(cons/c string? (cons/c (listof any/c) (listof string?))))
path-string?)) path-string?))
(define rel-to-module-path-v/c (define rel-to-module-path-v/c
(or/c simple-rel-to-module-path-v/c (or/c simple-rel-to-module-path-v/c (-> simple-rel-to-module-path-v/c)))
(-> simple-rel-to-module-path-v/c)))
(provide/contract (provide/contract
[check-module-form (syntax? symbol? (or/c string? path? false/c) [check-module-form (syntax? symbol? (or/c string? path? false/c) . -> . any)]
. -> . any)]
[get-module-code ([path-string?] [get-module-code ([path-string?]
[(and/c path-string? [(and/c path-string? relative-path?)
relative-path?)
(any/c . -> . any) (any/c . -> . any)
(or/c false/c (or/c false/c (path? boolean? . -> . any))]
(path? boolean? . -> . any))]
. opt-> . . opt-> .
any)]) any)])
(provide (provide exn:get-module-code
exn:get-module-code
exn:get-module-code? exn:get-module-code?
exn:get-module-code-path exn:get-module-code-path
make-exn:get-module-code) make-exn:get-module-code)
(provide/contract (provide/contract
[resolve-module-path (module-path-v? [resolve-module-path (module-path-v? rel-to-path-string/thunk/#f
rel-to-path-string/thunk/#f
. -> . path?)] . -> . path?)]
[resolve-module-path-index ((or/c symbol? [resolve-module-path-index ((or/c symbol? module-path-index?)
module-path-index?)
rel-to-path-string/thunk/#f rel-to-path-string/thunk/#f
. -> . path?)] . -> . path?)]
[collapse-module-path (module-path-v? [collapse-module-path (module-path-v? rel-to-module-path-v/c
rel-to-module-path-v/c . -> . simple-rel-to-module-path-v/c)]
. -> . [collapse-module-path-index ((or/c symbol? module-path-index?)
simple-rel-to-module-path-v/c)]
[collapse-module-path-index ((or/c symbol?
module-path-index?)
rel-to-module-path-v/c rel-to-module-path-v/c
. -> . simple-rel-to-module-path-v/c)]) . -> . simple-rel-to-module-path-v/c)])