diff options
Diffstat (limited to 'scheme/plt/geiser')
| -rw-r--r-- | scheme/plt/geiser/enter.ss | 103 | ||||
| -rw-r--r-- | scheme/plt/geiser/main.ss | 9 | ||||
| -rw-r--r-- | scheme/plt/geiser/modules.ss | 21 | ||||
| -rw-r--r-- | scheme/plt/geiser/user.ss | 57 |
4 files changed, 172 insertions, 18 deletions
diff --git a/scheme/plt/geiser/enter.ss b/scheme/plt/geiser/enter.ss new file mode 100644 index 0000000..b81ba48 --- /dev/null +++ b/scheme/plt/geiser/enter.ss @@ -0,0 +1,103 @@ +;;; enter.ss -- custom module loaders + +;; Copyright (C) 2010 Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Wed Mar 31, 2010 21:53 + +#lang scheme/base + +(require syntax/modcode + (for-syntax scheme/base)) + +(provide get-namespace enter-module module-loader module-loaded?) + +(define-struct mod (name timestamp depends)) + +(define loaded (make-hash)) + +(define (module-loaded? path) + (with-handlers ((exn? (lambda (_) #f))) + (let ((rp (module-path-index-resolve (module-path-index-join path #f)))) + (hash-has-key? loaded (resolved-module-path-name rp))))) + +(define (enter-module mod) + (dynamic-require mod #f) + (check-latest mod)) + +(define (module-loader orig) + (enter-load/use-compiled orig #f)) + +(define (notify re? path) + (when re? + (fprintf (current-error-port) " [re-loading ~a]\n" path))) + +(define inhibit-eval (make-parameter #f)) + +(define (get-namespace mod) + (parameterize ([inhibit-eval #t]) + (module->namespace mod))) + +(define ((enter-load/use-compiled orig re?) path name) + (when (inhibit-eval) + (raise (make-exn:fail "namespace not found" + (current-continuation-marks)))) + (if name + ;; Module load: + (let ([code (get-module-code path "compiled" compile + (lambda (ext loader?) + (load-extension ext) + #f) + #:notify (lambda (chosen) + (notify re? chosen)))] + [path (normal-case-path + (simplify-path + (path->complete-path path + (or (current-load-relative-directory) + (current-directory)))))]) + ;; Record module timestamp and dependencies: + (let ([mod (make-mod name + (get-timestamp path) + (if code + (apply append + (map cdr (module-compiled-imports code))) + null))]) + (hash-set! loaded path mod)) + ;; Evaluate the module: + (eval code)) + ;; Not a module: + (begin + (notify re? path) + (orig path name)))) + +(define (get-timestamp path) + (file-or-directory-modify-seconds path #f (lambda () -inf.0))) + +(define (check-latest mod) + (let ([mpi (module-path-index-join mod #f)] + [done (make-hash)]) + (let loop ([mpi mpi]) + (let* ([rpath (module-path-index-resolve mpi)] + [path (resolved-module-path-name rpath)]) + (when (path? path) + (let ([path (normal-case-path path)]) + (unless (hash-ref done path #f) + (hash-set! done path #t) + (let ([mod (hash-ref loaded path #f)]) + (when mod + (for-each loop (mod-depends mod)) + (let ([ts (get-timestamp path)]) + (when (ts . > . (mod-timestamp mod)) + (let ([orig (current-load/use-compiled)]) + (parameterize ([current-load/use-compiled + (enter-load/use-compiled orig #f)] + [current-module-declare-name rpath]) + ((enter-load/use-compiled orig #t) + path + (mod-name mod))))))))))))))) + +;;; enter.ss ends here diff --git a/scheme/plt/geiser/main.ss b/scheme/plt/geiser/main.ss index d342b15..f157ac6 100644 --- a/scheme/plt/geiser/main.ss +++ b/scheme/plt/geiser/main.ss @@ -13,8 +13,7 @@ #lang scheme/base -(provide geiser:init - geiser:eval +(provide geiser:eval geiser:compile geiser:load-file geiser:compile-file @@ -47,8 +46,4 @@ (define geiser:module-exports module-exports) (define geiser:macroexpand macroexpand) -(define (geiser:init) - (compile-enforce-module-constants #f) - (current-prompt-read (compose (make-repl-reader (current-prompt-read)) - current-namespace))) - +;;; main.ss ends here diff --git a/scheme/plt/geiser/modules.ss b/scheme/plt/geiser/modules.ss index 9842174..829cf77 100644 --- a/scheme/plt/geiser/modules.ss +++ b/scheme/plt/geiser/modules.ss @@ -20,7 +20,7 @@ module-list module-exports) -(require srfi/13 scheme/enter syntax/modresolve syntax/modcode) +(require srfi/13 syntax/modresolve syntax/modcode geiser/enter) (define (ensure-module-spec spec) (cond ((symbol? spec) spec) @@ -28,22 +28,22 @@ (else `(file ,spec)))) (define (module-spec->namespace spec (lang #f)) - (let ((spec (ensure-module-spec spec))) - (if spec - (with-handlers ((exn? - (lambda (_) - (with-handlers - ((exn? (const (current-namespace)))) + (let ((spec (ensure-module-spec spec)) + (try-lang (lambda (_) + (with-handlers ((exn? (const (current-namespace)))) + (and lang + (begin (load-module lang #f (current-namespace)) - (module->namespace lang))))) - (module->namespace spec)) + (module->namespace lang))))))) + (or (and spec + (with-handlers ((exn? try-lang)) (get-namespace spec))) (current-namespace)))) (define nowhere (open-output-nowhere)) (define (load-module spec (port #f) (ns #f)) (parameterize ((current-error-port (or port nowhere))) - (eval #`(enter! #,(ensure-module-spec spec))) + (enter-module (ensure-module-spec spec)) (when (namespace? ns) (current-namespace ns)))) @@ -79,7 +79,6 @@ ((symbol? path) (symbol->string path)) (else ""))) - (define (skippable-dir? path) (call-with-values (lambda () (split-path path)) (lambda (_ basename __) diff --git a/scheme/plt/geiser/user.ss b/scheme/plt/geiser/user.ss new file mode 100644 index 0000000..48b7dd5 --- /dev/null +++ b/scheme/plt/geiser/user.ss @@ -0,0 +1,57 @@ +;;; user.ss -- global bindings visible to geiser users + +;; Copyright (C) 2010 Jose Antonio Ortega Ruiz + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +;; Start date: Wed Mar 31, 2010 22:24 + +#lang scheme/base + +(provide enter!) + +(require geiser/enter geiser/eval (for-syntax scheme/base)) + +(define-syntax (enter! stx) + (syntax-case stx () + [(enter! mod) + (if (or (not (syntax-e #'mod)) + (module-path? (syntax->datum #'mod))) + #'(do-enter! 'mod) + (raise-syntax-error + #f + "not a valid module path, and not #f" + stx + #'mod))] + [_ (raise-syntax-error + #f + "bad syntax; should be `(enter! <module-path-or-#f>)'" + stx)])) + +(define orig-namespace (current-namespace)) + +(define (do-enter! mod) + (if mod + (begin + (enter-module mod) + (let ([ns (module->namespace mod)]) + (current-namespace ns) + (namespace-require 'geiser/user))) + (current-namespace orig-namespace))) + + +(define orig-loader (current-load/use-compiled)) + +(define (init) + (compile-enforce-module-constants #f) + (current-load/use-compiled (module-loader orig-loader)) + (current-prompt-read (compose (make-repl-reader (current-prompt-read)) + current-namespace))) + +(init) + +;;; user.ss ends here + |