From 85fc035f75d75bbf0456a0ff191e98e0ca31b879 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 9 Jun 2013 20:51:27 -0400 Subject: [PATCH] Cosmetic restructuring of syntax/modcode. This work is preparation for exporting more functionality from this module. Renamed variables for clarity and to eliminate shadowing. Turned lets into defines. --- collects/syntax/modcode.rkt | 430 ++++++++++++++++++------------------ 1 file changed, 218 insertions(+), 212 deletions(-) diff --git a/collects/syntax/modcode.rkt b/collects/syntax/modcode.rkt index 58ea911e11..42dae22af2 100644 --- a/collects/syntax/modcode.rkt +++ b/collects/syntax/modcode.rkt @@ -1,226 +1,232 @@ #lang racket/base - (require racket/contract/base - racket/list - "modread.rkt") +(require racket/contract/base + racket/list + "modread.rkt") - (provide moddep-current-open-input-file - exn:get-module-code - exn:get-module-code? - exn:get-module-code-path - make-exn:get-module-code) +(provide moddep-current-open-input-file + exn:get-module-code + exn:get-module-code? + exn:get-module-code-path + make-exn:get-module-code) - (provide/contract - [get-module-code (->* (path?) - (#:roots - (listof (or/c path? 'same)) - #:submodule-path - (listof symbol?) - #:sub-path - (and/c path-string? relative-path?) - (and/c path-string? relative-path?) - #:compile (-> any/c any) - (-> any/c any) - #:extension-handler (or/c false/c (path? boolean? . -> . any)) - (or/c false/c (path? boolean? . -> . any)) - #:choose - (path? path? path? . -> . (or/c (symbols 'src 'zo 'so) false/c)) - #:notify (any/c . -> . any) - #:source-reader (any/c input-port? . -> . (or/c syntax? eof-object?)) - #:rkt-try-ss? boolean?) - any)]) +(provide/contract + [get-module-code (->* (path?) + (#:roots + (listof (or/c path? 'same)) + #:submodule-path + (listof symbol?) + #:sub-path + (and/c path-string? relative-path?) + (and/c path-string? relative-path?) + #:compile (-> any/c any) + (-> any/c any) + #:extension-handler (or/c false/c (path? boolean? . -> . any)) + (or/c false/c (path? boolean? . -> . any)) + #:choose + (path? path? path? . -> . (or/c (symbols 'src 'zo 'so) false/c)) + #:notify (any/c . -> . any) + #:source-reader (any/c input-port? . -> . (or/c syntax? eof-object?)) + #:rkt-try-ss? boolean?) + any)]) - (define moddep-current-open-input-file - (make-parameter open-input-file)) +(define moddep-current-open-input-file + (make-parameter open-input-file)) - (define (resolve s) - (if (complete-path? s) +(define (resolve s) + (if (complete-path? s) s (let ([d (current-load-relative-directory)]) (if d (path->complete-path s d) s)))) - (define (date>=? a bm) - (and a (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) - (file-or-directory-modify-seconds a))]) - (or (and (not bm) am) (and am bm (>= am bm)))))) +(define (date>=? a bm) + (and a + (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) + (file-or-directory-modify-seconds a))]) + (and am (if bm (>= am bm) #t))))) - (define (read-one orig-path path src? read-src-syntax) - (let ([p ((moddep-current-open-input-file) path)]) - (when src? (port-count-lines! p)) - (dynamic-wind - void - (lambda () - (let ([v (with-module-reading-parameterization - (lambda () - ;; In case we're reading a .zo, we need to set - ;; the load-relative directory for unmarshaling - ;; path literals. - (parameterize ([current-load-relative-directory - (let-values ([(base name dir?) (split-path orig-path)]) - (if (path? base) - base - (current-directory)))]) - (read-src-syntax path p))))]) - (when (eof-object? v) - (error 'read-one - "empty file; expected a module declaration in: ~a" path)) - (let* ([name (let-values ([(base name dir?) (split-path orig-path)]) - (string->symbol - (bytes->string/utf-8 - (path->bytes (path-replace-suffix name #"")) - #\?)))] - [v (check-module-form v name path)]) - (unless (eof-object? (read p)) - (error 'read-one - "file has more than one expression; expected a module declaration only in: ~a" - path)) - (if (and (syntax? v) (compiled-expression? (syntax-e v))) - (syntax-e v) - v)))) - (lambda () (close-input-port p))))) +(define (read-one orig-path path src? read-src-syntax) + (define p ((moddep-current-open-input-file) path)) + (when src? (port-count-lines! p)) + (define (reader) + (define-values (base name dir?) (split-path orig-path)) + (define unchecked-v + (with-module-reading-parameterization + (lambda () + ;; In case we're reading a .zo, we need to set + ;; the load-relative directory for unmarshaling + ;; path literals. + (parameterize ([current-load-relative-directory + (if (path? base) base (current-directory))]) + (read-src-syntax path p))))) + (when (eof-object? unchecked-v) + (error 'read-one "empty file; expected a module declaration in: ~a" path)) + (define sym + (string->symbol + (bytes->string/utf-8 (path->bytes (path-replace-suffix name #"")) #\?))) + (define checked-v (check-module-form unchecked-v sym path)) + (unless (eof-object? (read p)) + (error 'read-one + "file has more than one expression; expected a module declaration only in: ~a" + path)) + (if (and (syntax? checked-v) (compiled-expression? (syntax-e checked-v))) + (syntax-e checked-v) + checked-v)) + (define (closer) (close-input-port p)) + (dynamic-wind void reader closer)) - (define-struct (exn:get-module-code exn:fail) (path)) +(define-struct (exn:get-module-code exn:fail) (path)) - (define (get-module-code path - #:roots [roots (current-compiled-file-roots)] - #:submodule-path [submodule-path '()] - #:sub-path [sub-path0 "compiled"] - #:compile [compile0 compile] - #:extension-handler [ext-handler0 #f] - [sub-path sub-path0] [compiler compile0] [extension-handler ext-handler0] - #:choose [choose (lambda (src zo so) #f)] - #:notify [notify void] - #:source-reader [read-src-syntax read-syntax] - #:rkt-try-ss? [rkt-try-ss? #t]) - (let*-values ([(orig-path) (resolve path)] - [(base orig-file dir?) (split-path path)] - [(main-file alt-file) - (if rkt-try-ss? - (let* ([b (path->bytes orig-file)] - [len (bytes-length b)]) - (cond - [(and (len . >= . 4) - (bytes=? #".rkt" (subbytes b (- len 4)))) - ;; .rkt => try .rkt then .ss - (values orig-file - (bytes->path (bytes-append (subbytes b 0 (- len 4)) #".ss")))] - [else - ;; No search path - (values orig-file #f)])) - (values orig-file #f))] - [(main-path) (if (eq? main-file orig-file) - orig-path - (build-path base main-file))] - [(alt-path) (and alt-file - (if (eq? alt-file orig-file) - orig-path - (build-path base alt-file)))] - [(base) (if (eq? base 'relative) 'same base)]) - (define (build-found-path base . args) - (cond - [(or (equal? roots '(same)) (null? roots)) - (apply build-path base args)] - [else - (let ([reroot-path* (lambda (base root) - (cond - [(eq? root 'same) base] - [(relative-path? root) (build-path base root)] - [else (reroot-path base root)]))]) - (or (for/or ([root (in-list (if (null? (cdr roots)) null roots))]) - (define p (apply build-path (reroot-path* base root) args)) - (and (file-exists? p) p)) - (apply build-path (reroot-path* base (car roots)) args)))])) - (let* ([main-path-d (file-or-directory-modify-seconds orig-path #f (lambda () #f))] - [alt-path-d (and alt-path - (not main-path-d) - (file-or-directory-modify-seconds alt-path #f (lambda () #f)))] - [path-d (or main-path-d alt-path-d)] - [file (if alt-path-d alt-file main-file)] - [path (if alt-path-d alt-path main-path)] - [try-alt? (and alt-file (not alt-path-d) (not main-path-d))] - [get-so (lambda (file) - (build-found-path - base sub-path "native" - (system-library-subpath) - (path-add-suffix file (system-type 'so-suffix))))] - [zo (build-found-path base sub-path (path-add-suffix file #".zo"))] - [alt-zo (and try-alt? - (build-found-path base sub-path (path-add-suffix alt-file #".zo")))] - [so (get-so file)] - [alt-so (and try-alt? (get-so alt-file))] - [with-dir (lambda (t) - (parameterize ([current-load-relative-directory - (if (path? base) - base - (current-directory))]) - (t)))] - [prefer (choose path zo so)]) - (define (extract-submodule m [sm-path submodule-path]) +(define (reroot-path* base root) + (cond + [(eq? root 'same) base] + [(relative-path? root) (build-path base root)] + [else (reroot-path base root)])) + +(define (get-module-code + path0 + #:roots [roots (current-compiled-file-roots)] + #:submodule-path [submodule-path '()] + #:sub-path [sub-path/kw "compiled"] + [sub-path sub-path/kw] + #:compile [compile/kw compile] + [compiler compile/kw] + #:extension-handler [ext-handler/kw #f] + [ext-handler ext-handler/kw] + #:choose [choose (lambda (src zo so) #f)] + #:notify [notify void] + #:source-reader [read-src-syntax read-syntax] + #:rkt-try-ss? [rkt-try-ss? #t]) + (define resolved-path (resolve path0)) + (define-values (path0-rel path0-file path0-dir?) (split-path path0)) + (define-values (main-src-file alt-src-file) + (if rkt-try-ss? + (let* ([b (path->bytes path0-file)] + [len (bytes-length b)]) (cond - [(null? sm-path) m] - [else - (extract-submodule - (or (for/or ([c (in-list (append (module-compiled-submodules m #t) - (module-compiled-submodules m #f)))]) - (and (eq? (last (module-compiled-name c)) (car sm-path)) - c)) - (raise - (make-exn:get-module-code - (format "get-module-code: cannot find submodule: ~e" sm-path) + [(and (len . >= . 4) (bytes=? #".rkt" (subbytes b (- len 4)))) + ;; .rkt => try .rkt then .ss + (values path0-file + (bytes->path (bytes-append (subbytes b 0 (- len 4)) + #".ss")))] + [else + ;; No search path + (values path0-file #f)])) + (values path0-file #f))) + (define main-src-path + (if (eq? main-src-file path0-file) + resolved-path + (build-path path0-rel main-src-file))) + (define alt-src-path + (and alt-src-file + (if (eq? alt-src-file path0-file) + resolved-path + (build-path path0-rel alt-src-file)))) + (define path0-base (if (eq? path0-rel 'relative) 'same path0-rel)) + (define (build-found-path base . args) + (cond + [(or (equal? roots '(same)) (null? roots)) + (apply build-path base args)] + [else + (or (for/or ([root (in-list (if (null? (cdr roots)) null roots))]) + (define p (apply build-path (reroot-path* base root) args)) + (and (file-exists? p) p)) + (apply build-path (reroot-path* base (car roots)) args))])) + (define main-src-date + (file-or-directory-modify-seconds main-src-path #f (lambda () #f))) + (define alt-src-date + (and alt-src-path + (not main-src-date) + (file-or-directory-modify-seconds alt-src-path #f (lambda () #f)))) + (define src-date (or main-src-date alt-src-date)) + (define src-file (if alt-src-date alt-src-file main-src-file)) + (define src-path (if alt-src-date alt-src-path main-src-path)) + (define try-alt? (and alt-src-file (not alt-src-date) (not main-src-date))) + (define (get-so file) + (build-found-path path0-base + sub-path + "native" + (system-library-subpath) + (path-add-suffix file (system-type 'so-suffix)))) + (define zo + (build-found-path path0-base sub-path (path-add-suffix src-file #".zo"))) + (define alt-zo + (and try-alt? + (build-found-path path0-base + sub-path + (path-add-suffix alt-src-file #".zo")))) + (define so (get-so src-file)) + (define alt-so (and try-alt? (get-so alt-src-file))) + (define (with-dir t) + (parameterize ([current-load-relative-directory + (if (path? path0-base) path0-base (current-directory))]) + (t))) + (define prefer (choose src-path zo so)) + (define (extract-submodule m [sm-path submodule-path]) + (cond + [(null? sm-path) m] + [else + (extract-submodule + (or (for/or ([c (in-list (append (module-compiled-submodules m #t) + (module-compiled-submodules m #f)))]) + (and (eq? (last (module-compiled-name c)) (car sm-path)) + c)) + (raise + (make-exn:get-module-code + (format "get-module-code: cannot find submodule: ~e" sm-path) + (current-continuation-marks) + #f))) + (cdr sm-path))])) + (cond + ;; Use .zo, if it's new enough + [(or (eq? prefer 'zo) + (and (not prefer) + (pair? roots) + (or (date>=? zo src-date) + (and try-alt? + (date>=? alt-zo src-date))))) + (let ([zo (if (date>=? zo src-date) + zo + (if (and try-alt? (date>=? alt-zo src-date)) + alt-zo + zo))]) + (notify zo) + (extract-submodule (read-one src-path zo #f read-syntax)))] + ;; Maybe there's an .so? Use it only if we don't prefer source + ;; and only if there's no submodule path. + [(and (null? submodule-path) + (or (eq? prefer 'so) + (and (not prefer) + (pair? roots) + (or (date>=? so src-date) + (and try-alt? + (date>=? alt-so src-date)))))) + (let ([so (if (date>=? so src-date) + so + (if (and try-alt? (date>=? alt-so src-date)) + alt-so + so))]) + (if ext-handler + (begin + (notify so) + (ext-handler so #f)) + (raise (make-exn:get-module-code + (format "get-module-code: cannot use extension file; ~e" so) + (current-continuation-marks) + so))))] + ;; Use source if it exists + [(or (eq? prefer 'src) src-date) + (notify src-path) + (define (compile-one) + (with-dir + (lambda () + (compiler (read-one resolved-path src-path #t read-src-syntax))))) + (if (null? submodule-path) + ;; allow any result: + (compile-one) + ;; expect a compiled-module result: + (extract-submodule (compile-one)))] + ;; Report a not-there error + [else (raise (make-exn:get-module-code + (format "get-module-code: no such file: ~e" resolved-path) (current-continuation-marks) - #f))) - (cdr sm-path))])) - (cond - ;; Use .zo, if it's new enough - [(or (eq? prefer 'zo) - (and (not prefer) - (pair? roots) - (or (date>=? zo path-d) - (and try-alt? - (date>=? alt-zo path-d))))) - (let ([zo (if (date>=? zo path-d) - zo - (if (and try-alt? - (date>=? alt-zo path-d)) - alt-zo - zo))]) - (notify zo) - (extract-submodule (read-one path zo #f read-syntax)))] - ;; Maybe there's an .so? Use it only if we don't prefer source - ;; and only if there's no submodule path. - [(and (null? submodule-path) - (or (eq? prefer 'so) - (and (not prefer) - (pair? roots) - (or (date>=? so path-d) - (and try-alt? - (date>=? alt-so path-d)))))) - (let ([so (if (date>=? so path-d) - so - (if (and try-alt? - (date>=? alt-so path-d)) - alt-so - so))]) - (if extension-handler - (begin - (notify so) - (extension-handler so #f)) - (raise (make-exn:get-module-code - (format "get-module-code: cannot use extension file; ~e" so) - (current-continuation-marks) - so))))] - ;; Use source if it exists - [(or (eq? prefer 'src) - path-d) - (notify path) - (define (compile-one) - (with-dir (lambda () (compiler (read-one orig-path path #t read-src-syntax))))) - (if (null? submodule-path) - ;; allow any result: - (compile-one) - ;; expect a compiled-module result: - (extract-submodule (compile-one)))] - ;; Report a not-there error - [else (raise (make-exn:get-module-code - (format "get-module-code: no such file: ~e" orig-path) - (current-continuation-marks) - #f))])))) + #f))]))