6fe2861877
... for the purpose of "populate 'compiled' directories" --- but only if the user has write permission for the package directory. This change may or may not be a good idea. The idea is that installed packages generally should be treated in the same way as the main "collects" tree (e.g., avoiding debugging instrumentation), but if you happen to be developing a package, then you want it treated like things that are not in the main "collects" tree. So, how do you pick? Maybe opening a file in the package is a good way to pick.
145 lines
5.8 KiB
Racket
145 lines
5.8 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/draw
|
|
racket/list
|
|
racket/set
|
|
compiler/cm
|
|
setup/dirs
|
|
planet/config
|
|
pkg/lib
|
|
(prefix-in *** '#%foreign) ;; just to make sure it is here
|
|
)
|
|
|
|
(provide set-basic-parameters/no-gui
|
|
set-module-language-parameters
|
|
(struct-out prefab-module-settings)
|
|
transform-module
|
|
get-init-dir)
|
|
|
|
;; get-init-dir : (or/c path? #f) -> path?
|
|
;; returns the initial directory for a program
|
|
;; that is saved in 'path/f' (with #f indicating
|
|
;; an unsaved file)
|
|
(define (get-init-dir path/f)
|
|
(cond
|
|
[path/f
|
|
(let-values ([(base name dir?) (split-path path/f)])
|
|
base)]
|
|
[else
|
|
(find-system-path 'home-dir)]))
|
|
|
|
(struct prefab-module-settings
|
|
(command-line-args
|
|
collection-paths
|
|
compilation-on?
|
|
full-trace?
|
|
annotations)
|
|
#:prefab)
|
|
|
|
(define orig-namespace (current-namespace))
|
|
|
|
(define (set-basic-parameters/no-gui)
|
|
(let ([cust (current-custodian)])
|
|
(define (drracket-plain-exit-handler arg)
|
|
(custodian-shutdown-all cust))
|
|
(exit-handler drracket-plain-exit-handler))
|
|
(current-thread-group (make-thread-group))
|
|
(current-command-line-arguments #())
|
|
(current-pseudo-random-generator (make-pseudo-random-generator))
|
|
(current-evt-pseudo-random-generator (make-pseudo-random-generator))
|
|
(read-curly-brace-as-paren #t)
|
|
(read-square-bracket-as-paren #t)
|
|
(error-print-width 250)
|
|
(current-ps-setup (make-object ps-setup%))
|
|
(current-namespace (make-base-empty-namespace))
|
|
;; is this wise?
|
|
#;(namespace-attach-module orig-namespace ''#%foreign))
|
|
|
|
|
|
(define (set-module-language-parameters settings
|
|
module-language-parallel-lock-client
|
|
currently-open-files
|
|
#:use-use-current-security-guard? [use-current-security-guard? #f])
|
|
(current-command-line-arguments (prefab-module-settings-command-line-args settings))
|
|
(let* ([default (current-library-collection-paths)]
|
|
[cpaths (append-map (λ (x) (if (symbol? x) default (list x)))
|
|
(prefab-module-settings-collection-paths settings))])
|
|
(when (null? cpaths)
|
|
(eprintf "WARNING: your collection paths are empty!\n"))
|
|
(current-library-collection-paths cpaths))
|
|
|
|
(compile-context-preservation-enabled (prefab-module-settings-full-trace? settings))
|
|
|
|
(when (prefab-module-settings-compilation-on? settings)
|
|
(define open-pkgs
|
|
(for/fold ([s (set)]) ([path (in-list currently-open-files)])
|
|
(define pkg (path->pkg path))
|
|
(if (and pkg
|
|
(memq 'write
|
|
(file-or-directory-permissions (pkg-directory pkg))))
|
|
(set-add s pkg)
|
|
s)))
|
|
(for ([pkg (in-set open-pkgs)])
|
|
(log-info "DrRacket: enabling bytecode-file compilation for package ~s" pkg))
|
|
(define skip-path?
|
|
(let* ([cd (find-collects-dir)]
|
|
[no-dirs (if cd
|
|
(list (CACHE-DIR) cd)
|
|
(list (CACHE-DIR)))])
|
|
(λ (p) (or (file-stamp-in-paths p no-dirs)
|
|
(let ([pkg (path->pkg p)])
|
|
(and pkg
|
|
(not (set-member? open-pkgs pkg))
|
|
(file-stamp-in-paths p (list (pkg-directory pkg)))))))))
|
|
(define extra-compiled-file-path
|
|
(case (prefab-module-settings-annotations settings)
|
|
[(none) (build-path "compiled" "drracket")]
|
|
[(debug) (build-path "compiled" "drracket" "errortrace")]
|
|
[else #f]))
|
|
(when extra-compiled-file-path
|
|
;; Add extra compiled-file path:
|
|
(use-compiled-file-paths
|
|
(cons extra-compiled-file-path
|
|
(use-compiled-file-paths)))
|
|
;; If we ever skip a file, then don't use the extra compiled-file
|
|
;; path for the skipped file's dependencies (because modules
|
|
;; compiled against the non-DrRacket-generated bytecode might not
|
|
;; work with any DrRacket-generated bytecode that is sitting around):
|
|
(current-load/use-compiled
|
|
(let ([orig (current-load/use-compiled)])
|
|
(lambda (path mod-name)
|
|
(if (and (member extra-compiled-file-path (use-compiled-file-paths))
|
|
(skip-path? path))
|
|
(parameterize ([use-compiled-file-paths
|
|
(remove extra-compiled-file-path
|
|
(use-compiled-file-paths))])
|
|
(orig path mod-name))
|
|
(orig path mod-name))))))
|
|
;; Install the compilation manager:
|
|
(parallel-lock-client module-language-parallel-lock-client)
|
|
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler
|
|
#t
|
|
#:security-guard (and use-current-security-guard?
|
|
(current-security-guard))))
|
|
(manager-skip-file-handler skip-path?)))
|
|
|
|
(define (transform-module filename stx raise-hopeless-syntax-error)
|
|
(define-values (mod name lang body)
|
|
(syntax-case stx ()
|
|
[(module name lang . body)
|
|
(eq? 'module (syntax-e #'module))
|
|
(values #'module #'name #'lang #'body)]
|
|
[_ (raise-hopeless-syntax-error
|
|
(string-append "only a module expression is allowed, either\n"
|
|
" #lang <language-name>\n or\n"
|
|
" (module <name> <language> ...)\n")
|
|
stx)]))
|
|
(define name* (syntax-e name))
|
|
(unless (symbol? name*)
|
|
(raise-hopeless-syntax-error "bad syntax in name position of module"
|
|
stx name))
|
|
(let* (;; rewrite the module to use the racket/base version of `module'
|
|
[mod (datum->syntax #'here 'module mod)]
|
|
[expr (datum->syntax stx `(,mod ,name ,lang . ,body) stx stx)])
|
|
(values name lang expr)))
|