diff options
| -rw-r--r-- | geiser-chez.el | 10 | ||||
| -rw-r--r-- | src/geiser/geiser.ss | 78 |
2 files changed, 61 insertions, 27 deletions
diff --git a/geiser-chez.el b/geiser-chez.el index b0a668c..1e847ef 100644 --- a/geiser-chez.el +++ b/geiser-chez.el @@ -136,7 +136,9 @@ Return its local name." (if (listp (cadr args)) (format "(geiser:ge:eval '%s '%s)" (car args) (cadr args)) (format "(geiser:eval '%s '%s)" (car args) (cadr args)))) - ((load-file compile-file) (format "(geiser:load-file %s)" (car args))) + ((load-file compile-file) + (let ((lib (geiser-chez--current-library))) + (format "(geiser:load-file %s '%s)" (car args) (or lib "#f")))) ((no-values) "(geiser:no-values)") (t (list (format "geiser:%s" proc) (mapconcat 'identity args " "))))) @@ -193,9 +195,9 @@ Return its local name." (col (or (cdr (assoc "column" loc)) (cdr (assoc "char" loc)))) (name (cdr (assoc "name" loc)))) (unless (string-prefix-p geiser-chez-scheme-dir file) - (insert "\n" file (format ":%s" line)) - (when col (insert (format ":%s" col))) - (when name (insert (format " (%s)" name))))))) + (insert "\n" file (format ":%s:" line)) + (when col (insert (format "%s:" col))) + (when name (insert (format " (%s)" name))))))) (geiser-edit--buttonize-files) t)) diff --git a/src/geiser/geiser.ss b/src/geiser/geiser.ss index 0644b4d..0af9807 100644 --- a/src/geiser/geiser.ss +++ b/src/geiser/geiser.ss @@ -60,7 +60,7 @@ res)))) (define (call-with-result thunk) - (let ((output-string (open-output-string))) + (let ((output (open-output-string))) (write (call/cc (lambda (k) @@ -70,19 +70,19 @@ (let ((loc (or (condition-location e) '())) (desc (as-string (display-condition e)))) (k `((result "") - (output . ,(get-output-string output-string)) + (output . ,(get-output-string output)) (error (key . condition) (msg . ,(cons desc loc))))))) (lambda () (call-with-values (lambda () - (parameterize ((current-output-port output-string)) (thunk))) + (parameterize ((current-output-port output)) (thunk))) (lambda result `((result ,(write-to-string (if (null? (cdr result)) (car result) result))) - (output . ,(get-output-string output-string)))))))))) + (output . ,(get-output-string output)))))))))) (newline) - (close-output-port output-string))) + (close-output-port output))) (define (last-index-of str-list char idx last-idx) (if (null? str-list) @@ -102,18 +102,13 @@ (let ((idx (last-index-of (string->list filename) #\/ 0 -1))) (if (= idx -1) filename (substring filename 0 idx)))) - (define (geiser:load-file filename) - (let ((output-filename (obj-file-name filename))) - (call-with-result - (lambda () - (parameterize ([current-directory (file-directory filename)]) - (with-output-to-string - (lambda () (maybe-compile-file filename output-filename))) - (load output-filename)))))) - - (define (geiser:add-to-load-path path) - (let ((p (cons path path))) - (library-directories (cons p (remove p (library-directories)))))) + (define (library-source-filename id) + (let ((obj (library-object-filename id))) + (let loop ((exts (if obj (map car (library-extensions)) '()))) + (cond ((null? exts) #f) + ((file-exists? (with-extension obj (car exts))) + (with-extension obj (car exts))) + (else (loop (cdr exts))))))) (define string-prefix? (lambda (x y) @@ -148,6 +143,25 @@ ((memq s (library-exports (car l))) (car l)) (else (symbol-lib s (cdr l))))))) + (define (add-reverse-deps! deps lib) + (for-each (lambda (dep) + (let ((rdeps (hashtable-ref deps dep '()))) + (when (not (member lib rdeps)) + (hashtable-set! deps dep (cons lib rdeps))))) + (library-requirements lib))) + + (define (add-reverse-deps*! deps libs) + (when (not (null? libs)) + (add-reverse-deps*! deps (cdr libs)) + (add-reverse-deps! deps (car libs)))) + + (define reverse-lib-deps + (let ((deps (make-hashtable equal-hash equal?))) + (add-reverse-deps*! deps (library-list)) + deps)) + + (define (reverse-deps lib) (hashtable-ref reverse-lib-deps lib '())) + (define not-found (gensym)) (define (try-eval sym) @@ -157,6 +171,28 @@ (let ((env (transitive-env))) (lambda () (if env (eval sym env) (eval sym)))))))) + (define (compile-and-load lib) + (let ((scm (if (string? lib) lib (library-source-filename lib)))) + (when scm + (let ((obj (obj-file-name scm))) + (parameterize ([current-directory (file-directory scm)]) + (with-output-to-string (lambda () (maybe-compile-file scm obj))) + (load obj))) + (for-each compile-and-load (reverse-deps lib))))) + + (define (geiser:load-file filename lib) + (let ((output-filename (obj-file-name filename))) + (call-with-result + (lambda () + (compile-and-load filename) + (when lib + (for-each compile-and-load (reverse-deps lib)) + (add-reverse-deps! reverse-lib-deps lib)))))) + + (define (geiser:add-to-load-path path) + (let ((p (cons path path))) + (library-directories (cons p (remove p (library-directories)))))) + (define (geiser:eval lib form) (call-with-result (lambda () @@ -269,12 +305,8 @@ (or (and (not (eq? not-found b)) (code-location b)) '()))) (define (geiser:module-location id) - (let ((obj (library-object-filename id))) - (let loop ((exts (if obj (map car (library-extensions)) '()))) - (cond ((null? exts) '()) - ((file-exists? (with-extension obj (car exts))) - `(("file" . ,(with-extension obj (car exts))))) - (else (loop (cdr exts))))))) + (let ((f (library-source-filename id))) + (if f `(("file" . ,f)) '()))) (define (docstr lib id) (format "A ~a defined in library ~a" |