From aab5226dfe937861c54729744e8add15d931f758 Mon Sep 17 00:00:00 2001 From: jao Date: Mon, 20 Jul 2020 04:41:00 +0100 Subject: geiser -> src --- geiser/completion.scm | 27 ----- geiser/doc.scm | 258 ---------------------------------------------- geiser/emacs.scm | 58 ----------- geiser/evaluation.scm | 144 -------------------------- geiser/modules.scm | 104 ------------------- geiser/utils.scm | 52 ---------- geiser/xref.scm | 84 --------------- src/geiser/completion.scm | 27 +++++ src/geiser/doc.scm | 258 ++++++++++++++++++++++++++++++++++++++++++++++ src/geiser/emacs.scm | 58 +++++++++++ src/geiser/evaluation.scm | 144 ++++++++++++++++++++++++++ src/geiser/modules.scm | 104 +++++++++++++++++++ src/geiser/utils.scm | 52 ++++++++++ src/geiser/xref.scm | 84 +++++++++++++++ 14 files changed, 727 insertions(+), 727 deletions(-) delete mode 100644 geiser/completion.scm delete mode 100644 geiser/doc.scm delete mode 100644 geiser/emacs.scm delete mode 100644 geiser/evaluation.scm delete mode 100644 geiser/modules.scm delete mode 100644 geiser/utils.scm delete mode 100644 geiser/xref.scm create mode 100644 src/geiser/completion.scm create mode 100644 src/geiser/doc.scm create mode 100644 src/geiser/emacs.scm create mode 100644 src/geiser/evaluation.scm create mode 100644 src/geiser/modules.scm create mode 100644 src/geiser/utils.scm create mode 100644 src/geiser/xref.scm diff --git a/geiser/completion.scm b/geiser/completion.scm deleted file mode 100644 index d69859b..0000000 --- a/geiser/completion.scm +++ /dev/null @@ -1,27 +0,0 @@ -;;; completion.scm -- completing known symbols and module names - -;; Copyright (C) 2009, 2012 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 . - -;; Start date: Mon Mar 02, 2009 02:22 - -(define-module (geiser completion) - #:export (completions module-completions) - #:use-module (geiser utils) - #:use-module (geiser modules) - #:use-module (ice-9 session) - #:use-module (ice-9 regex)) - -(define (completions prefix) - (let ((prefix (string-append "^" (regexp-quote prefix)))) - (sort! (map symbol->string (apropos-internal prefix)) string. - -;; Start date: Sun Feb 08, 2009 18:44 - -(define-module (geiser doc) - #:export (autodoc - symbol-documentation - module-exports - object-signature) - #:use-module (geiser utils) - #:use-module (geiser modules) - #:use-module (system vm program) - #:use-module (system vm debug) - #:use-module (ice-9 session) - #:use-module (ice-9 documentation) - #:use-module (ice-9 regex) - #:use-module (ice-9 format) - #:use-module (oop goops) - #:use-module (srfi srfi-1)) - -(define (autodoc ids) - (if (not (list? ids)) - '() - (map (lambda (id) (or (autodoc* id) (list id))) ids))) - -(define* (autodoc* id) - (let ((args (obj-args (symbol->object id)))) - (and args - `(,@(signature id args) - ("module" . ,(symbol-module id)))))) - -(define (object-signature name obj) - (let ((args (obj-args obj))) - (and args (signature name args)))) - -(define (value-str obj) - (format #f "~:@y" obj)) - -(define* (signature id args-list #:optional (detail #t)) - (define (arglst args kind) - (let ((args (assq-ref args kind))) - (cond ((or (not args) (null? args)) '()) - ((list? args) args) - (else (list args))))) - (define (mkargs as) - `(("required" ,@(arglst as 'required)) - ("optional" ,@(arglst as 'optional) - ,@(if (assq-ref as 'rest) (list "...") '())) - ("key" ,@(arglst as 'keyword)))) - (let* ((args-list (map mkargs (if (list? args-list) args-list '()))) - (value (and (and detail (null? args-list)) - (value-str (symbol->object id))))) - `(,id ("args" ,@args-list) ,@(if value `(("value" . ,value)) '())))) - -(define default-macro-args '(((required ...)))) - -(define geiser-args-key (gensym "geiser-args-key-")) - -(define (obj-args obj) - (cond ((not obj) #f) - ((or (procedure? obj) (program? obj)) - (cond ((procedure-property obj geiser-args-key)) - ((arguments obj) => - (lambda (args) - (set-procedure-property! obj geiser-args-key args) - args)) - (else #f))) - ((and (macro? obj) (macro-transformer obj)) => macro-args) - ((macro? obj) default-macro-args) - (else 'variable))) - -(define (program-arities prog) - (let ((addrs (program-address-range prog))) - (when (pair? addrs) (find-program-arities (car addrs))))) - -(define (arguments proc) - (define (p-args prog) - (let ((as (map arity-arguments-alist (or (program-arities prog) '())))) - (and (not (null? as)) as))) - (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y))))) - (cond ((is-a? proc ) (generic-args proc)) - ((doc->args proc) => list) - ((procedure-property proc 'arglist) => (clist arglist->args)) - ((procedure-source proc) => (clist source->args)) - ((and (program? proc) (p-args proc))) - ((procedure-property proc 'arity) => (clist arity->args)) - (else #f))) - -(define (source->args src) - (let ((formals (cadr src))) - (cond ((list? formals) `((required . ,formals))) - ((pair? formals) - `((required . ,(car formals)) (rest . ,(cdr formals)))) - (else #f)))) - -(define (macro-args tf) - (define* (collect args #:optional (req '())) - (cond ((null? args) (arglist->args `(,(reverse req) #f #f r #f))) - ((symbol? args) (arglist->args `(,(reverse req) #f #f r ,args))) - ((and (pair? args) (symbol? (car args))) - (collect (cdr args) (cons (car args) req))) - (else #f))) - (let* ((pats (procedure-property tf 'patterns)) - (args (and pats (filter-map collect pats)))) - (or (and args (not (null? args)) args) default-macro-args))) - -(define (arity->args art) - (define (gen-arg-names count) - (map (lambda (x) '_) (iota (max count 0)))) - (let ((req (car art)) - (opt (cadr art)) - (rest (caddr art))) - `(,@(if (> req 0) - (list (cons 'required (gen-arg-names req))) - '()) - ,@(if (> opt 0) - (list (cons 'optional (gen-arg-names opt))) - '()) - ,@(if rest (list (cons 'rest 'rest)) '())))) - -(define (arglist->args arglist) - `((required . ,(car arglist)) - (optional . ,(cadr arglist)) - (keyword . ,(caddr arglist)) - (rest . ,(car (cddddr arglist))))) - -(define (doc->args proc) - ;; Guile 2.0.9+ uses the (texinfo ...) modules to produce - ;; `guile-procedures.txt', and the output has a single hyphen, whereas - ;; `makeinfo' produces two hyphens. - (define proc-rx "--? Scheme Procedure: ([^[\n]+)\n") - (define proc-rx2 "--? Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)") - (let ((doc (object-documentation proc))) - (and doc - (let ((match (or (string-match proc-rx doc) - (string-match proc-rx2 doc)))) - (and match - (parse-signature-string (match:substring match 1))))))) - -(define (parse-signature-string str) - (define opt-arg-rx "\\[([^] ]+)\\]?") - (define opt-arg-rx2 "([^ ])+\\]+") - (let ((tokens (string-tokenize str))) - (if (< (length tokens) 2) - '() - (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f)) - (cond ((null? tokens) - `((required ,@(map string->symbol (reverse! req))) - (optional ,@(map string->symbol (reverse! opt))) - ,@(if rest - (list (cons 'rest (string->symbol rest))) - '()))) - ((string=? "." (car tokens)) - (if (not (null? (cdr tokens))) - (loop (cddr tokens) req opt (cadr tokens)) - (loop '() req opt "rest"))) - ((or (string-match opt-arg-rx (car tokens)) - (string-match opt-arg-rx2 (car tokens))) - => (lambda (m) - (loop (cdr tokens) - req - (cons (match:substring m 1) opt) - rest))) - (else (loop (cdr tokens) - (cons (car tokens) req) - opt - rest))))))) - -(define (generic-args gen) - (define (src> src1 src2) - (> (length (cadr src1)) (length (cadr src2)))) - (define (src m) - (catch #t - (lambda () (method-source m)) - (lambda (k . a) #f))) - (let* ((methods (generic-function-methods gen)) - (srcs (filter identity (map src methods)))) - (cond ((and (null? srcs) - (not (null? methods)) - (method-procedure (car methods))) => arguments) - ((not (null? srcs)) (list (source->args (car (sort! srcs src>))))) - (else '(((rest . rest))))))) - -(define (symbol-documentation sym) - (let ((obj (symbol->object sym))) - (if obj - `(("signature" . ,(or (obj-signature sym obj #f) sym)) - ("docstring" . ,(docstring sym obj)))))) - -(define (docstring sym obj) - (define (valuable?) - (not (or (macro? obj) (procedure? obj) (program? obj)))) - (with-output-to-string - (lambda () - (let* ((type (cond ((macro? obj) "A macro") - ((procedure? obj) "A procedure") - ((program? obj) "A compiled program") - (else "An object"))) - (modname (symbol-module sym)) - (doc (object-documentation obj))) - (display type) - (if modname - (begin - (display " in module ") - (display modname) - (display "."))) - (newline) - (if doc (begin (newline) (display doc))) - (if (valuable?) (begin (newline) - (display "Value:") - (newline) - (display " ") - (display (value-str obj)))))))) - -(define* (obj-signature sym obj #:optional (detail #t)) - (let ((args (obj-args obj))) - (and args (signature sym args detail)))) - -(define (module-exports mod-name) - (define elt-sort (make-symbol-sort car)) - (let* ((mod (catch #t - (lambda () (resolve-interface mod-name)) - (lambda args (resolve-module mod-name)))) - (elts (hash-fold classify-module-object - (list '() '() '()) - (module-obarray mod))) - (elts (map elt-sort elts)) - (subs (map (lambda (m) (list (module-name m))) - (submodules (resolve-module mod-name #f))))) - (list (cons "modules" subs) - (cons "procs" (car elts)) - (cons "syntax" (cadr elts)) - (cons "vars" (caddr elts))))) - -(define (classify-module-object name var elts) - (let ((obj (and (variable-bound? var) - (variable-ref var)))) - (cond ((or (not obj) (module? obj)) elts) - ((or (procedure? obj) (program? obj)) - (list (cons (list name `("signature" . ,(obj-signature name obj))) - (car elts)) - (cadr elts) - (caddr elts))) - ((macro? obj) - (list (car elts) - (cons (list name `("signature" . ,(obj-signature name obj))) - (cadr elts)) - (caddr elts))) - (else (list (car elts) - (cadr elts) - (cons (list name) (caddr elts))))))) diff --git a/geiser/emacs.scm b/geiser/emacs.scm deleted file mode 100644 index 6f2fc29..0000000 --- a/geiser/emacs.scm +++ /dev/null @@ -1,58 +0,0 @@ -;;; emacs.scm -- procedures for emacs interaction: entry point - -;; Copyright (C) 2009, 2010, 2011 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 . - -;; Start date: Sun Feb 08, 2009 18:39 - -(define-module (geiser emacs) - #:use-module (ice-9 match) - #:use-module (system repl command) - #:use-module (system repl error-handling) - #:use-module (system repl server) - #:use-module (geiser evaluation) - #:use-module ((geiser modules) #:renamer (symbol-prefix-proc 'ge:)) - #:use-module ((geiser completion) #:renamer (symbol-prefix-proc 'ge:)) - #:use-module ((geiser xref) #:renamer (symbol-prefix-proc 'ge:)) - #:use-module ((geiser doc) #:renamer (symbol-prefix-proc 'ge:))) - -(define this-module (resolve-module '(geiser emacs))) - -(define-meta-command ((geiser-no-values geiser) repl) - "geiser-no-values -No-op command used internally by Geiser." - (values)) - -(define-meta-command ((geiser-newline geiser) repl) - "geiser-newline -Meta-command used by Geiser to emit a new line." - (newline)) - -(define-meta-command ((geiser-eval geiser) repl (mod form args) . rest) - "geiser-eval module form args () -Meta-command used by Geiser to evaluate and compile code." - (if (null? args) - (call-with-error-handling - (lambda () (ge:compile form mod))) - (let ((proc (eval form this-module))) - (ge:eval `(,proc ,@args) mod)))) - -(define-meta-command ((geiser-load-file geiser) repl file) - "geiser-load-file file -Meta-command used by Geiser to load and compile files." - (call-with-error-handling - (lambda () (ge:compile-file file)))) - - -(define-meta-command ((geiser-start-server geiser) repl) - "geiser-start-server -Meta-command used by Geiser to start a REPL server." - (let* ((sock (make-tcp-server-socket #:port 0)) - (port (sockaddr:port (getsockname sock)))) - (spawn-server sock) - (write (list 'port port)) - (newline))) diff --git a/geiser/evaluation.scm b/geiser/evaluation.scm deleted file mode 100644 index bdbcdd8..0000000 --- a/geiser/evaluation.scm +++ /dev/null @@ -1,144 +0,0 @@ -;;; evaluation.scm -- evaluation, compilation and macro-expansion - -;; Copyright (C) 2009, 2010, 2011, 2013, 2015 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 . - -;; Start date: Mon Mar 02, 2009 02:46 - -(cond-expand - (guile-2.2 - (define-module (geiser evaluation) - #:export (ge:compile - ge:eval - ge:macroexpand - ge:compile-file - ge:load-file - ge:set-warnings - ge:add-to-load-path) - #:use-module (geiser modules) - #:use-module (srfi srfi-1) - #:use-module (language tree-il) - #:use-module (system base compile) - #:use-module (system base message) - #:use-module (system base pmatch) - #:use-module (system vm program) - #:use-module (ice-9 pretty-print) - #:use-module (system vm loader))) - (else - (define-module (geiser evaluation) - #:export (ge:compile - ge:eval - ge:macroexpand - ge:compile-file - ge:load-file - ge:set-warnings - ge:add-to-load-path) - #:use-module (geiser modules) - #:use-module (srfi srfi-1) - #:use-module (language tree-il) - #:use-module (system base compile) - #:use-module (system base message) - #:use-module (system base pmatch) - #:use-module (system vm program) - #:use-module (ice-9 pretty-print)))) - - -(define compile-opts '()) -(define compile-file-opts '()) - -(define default-warnings '(arity-mismatch unbound-variable format)) -(define verbose-warnings `(unused-variable ,@default-warnings)) - -(define (ge:set-warnings wl) - (let* ((warns (cond ((list? wl) wl) - ((symbol? wl) (case wl - ((none nil null) '()) - ((medium default) default-warnings) - ((high verbose) verbose-warnings) - (else '()))) - (else '()))) - (fwarns (if (memq 'unused-variable warns) - (cons 'unused-toplevel warns) - warns))) - (set! compile-opts (list #:warnings warns)) - (set! compile-file-opts (list #:warnings fwarns)))) - -(ge:set-warnings 'none) - -(define (call-with-result thunk) - (letrec* ((result #f) - (output - (with-output-to-string - (lambda () - (with-fluids ((*current-warning-port* (current-output-port)) - (*current-warning-prefix* "")) - (with-error-to-port (current-output-port) - (lambda () (set! result - (map object->string (thunk)))))))))) - (write `((result ,@result) (output . ,output))) - (newline))) - -(define (ge:compile form module) - (compile* form module compile-opts)) - -(define (compile* form module-name opts) - (let* ((module (or (find-module module-name) (current-module))) - (ev (lambda () - (call-with-values - (lambda () - (let* ((to (cond-expand (guile-2.2 'bytecode) - (else 'objcode))) - (cf (cond-expand (guile-2.2 load-thunk-from-memory) - (else make-program))) - (o (compile form - #:to to - #:env module - #:opts opts)) - (thunk (cf o))) - (start-stack 'geiser-evaluation-stack - (eval `(,thunk) module)))) - (lambda vs vs))))) - (call-with-result ev))) - -(define (ge:eval form module-name) - (let* ((module (or (find-module module-name) (current-module))) - (ev (lambda () - (call-with-values - (lambda () (eval form module)) - (lambda vs vs))))) - (call-with-result ev))) - -(define (ge:compile-file path) - (call-with-result - (lambda () - (let ((cr (compile-file path - #:canonicalization 'absolute - #:opts compile-file-opts))) - (and cr - (list (object->string (save-module-excursion - (lambda () (load-compiled cr)))))))))) - -(define ge:load-file ge:compile-file) - -(define (ge:macroexpand form . all) - (let ((all (and (not (null? all)) (car all)))) - (with-output-to-string - (lambda () - (pretty-print (tree-il->scheme (macroexpand form))))))) - -(define (add-to-list lst dir) - (and (not (member dir lst)))) - -(define (ge:add-to-load-path dir) - (and (file-is-directory? dir) - (let ((in-lp (member dir %load-path)) - (in-clp (member dir %load-compiled-path))) - (when (not in-lp) - (set! %load-path (cons dir %load-path))) - (when (not in-clp) - (set! %load-compiled-path (cons dir %load-compiled-path))) - (or in-lp in-clp)))) diff --git a/geiser/modules.scm b/geiser/modules.scm deleted file mode 100644 index 32b0f1f..0000000 --- a/geiser/modules.scm +++ /dev/null @@ -1,104 +0,0 @@ -;;; modules.scm -- module metadata - -;; Copyright (C) 2009, 2010, 2011, 2018 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 . - -;; Start date: Mon Mar 02, 2009 02:00 - -(define-module (geiser modules) - #:export (symbol-module - program-module - module-name? - module-path - find-module - all-modules - submodules - module-location) - #:use-module (geiser utils) - #:use-module (system vm program) - #:use-module (system vm debug) - #:use-module (ice-9 regex) - #:use-module (ice-9 session) - #:use-module (srfi srfi-1)) - -;; Return hash table mapping filename to list of modules defined in that -;; file. H/t andy wingo. -(define (fill-file->module-mapping! ret) - (define (record-module m) - (let ((f (module-filename m))) - (hash-set! ret f (cons m (hash-ref ret f '()))))) - (define (visit-module m) - (record-module m) - (hash-for-each (lambda (k v) (visit-module v)) - (module-submodules m))) - (visit-module (resolve-module '() #f)) - ret) - -(define file->modules (fill-file->module-mapping! (make-hash-table))) - -(define (program-file p) - (let ((src (program-source p 0))) - (and (pair? src) (cadr src)))) - -(define (program-module p) - (let* ((f (program-file p)) - (mods (or (hash-ref file->modules f) - (hash-ref (fill-file->module-mapping! file->modules) f)))) - (and (pair? mods) (not (null? mods)) (car mods)))) - -(define (module-name? module-name) - (and (list? module-name) - (not (null? module-name)) - (every symbol? module-name))) - -(define (symbol-module sym . all) - (and sym - (catch 'module-name - (lambda () - (apropos-fold (lambda (module name var init) - (if (eq? name sym) - (throw 'module-name (module-name module)) - init)) - #f - (regexp-quote (symbol->string sym)) - (if (or (null? all) (not (car all))) - (apropos-fold-accessible (current-module)) - apropos-fold-all))) - (lambda (key . args) - (and (eq? key 'module-name) (car args)))))) - -(define (module-location name) - (make-location (module-path name) #f)) - -(define (find-module mod-name) - (and (module-name? mod-name) - (resolve-module mod-name #f #:ensure #f))) - -(define (module-path module-name) - (and (module-name? module-name) - (or ((@@ (ice-9 session) module-filename) module-name) - (module-filename (resolve-module module-name #f))))) - -(define (submodules mod) - (hash-map->list (lambda (k v) v) (module-submodules mod))) - -(define (root-modules) - (submodules (resolve-module '() #f))) - -(define (all-modules) - (define (maybe-name m) - (and (module-kind m) (format #f "~A" (module-name m)))) - (let* ((guile (resolve-module '(guile))) - (roots (remove (lambda (m) (eq? m guile)) (root-modules))) - (children (append-map all-child-modules roots))) - (cons "(guile)" (filter-map maybe-name children)))) - -(define* (all-child-modules mod #:optional (seen '())) - (let ((cs (filter (lambda (m) (not (member m seen))) (submodules mod)))) - (fold (lambda (m all) (append (all-child-modules m all) all)) - (list mod) - cs))) diff --git a/geiser/utils.scm b/geiser/utils.scm deleted file mode 100644 index 92ed7ae..0000000 --- a/geiser/utils.scm +++ /dev/null @@ -1,52 +0,0 @@ -;;; utils.scm -- utility functions - -;; Copyright (C) 2009, 2010, 2011 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 . - -;; Start date: Mon Mar 02, 2009 01:48 - -(define-module (geiser utils) - #:export (make-location - symbol->object - pair->list - sort-symbols! - make-symbol-sort - gensym?) - #:use-module (ice-9 regex)) - -(define (symbol->object sym) - (and (symbol? sym) - (module-defined? (current-module) sym) - (module-ref (current-module) sym))) - -(define (pair->list pair) - (let loop ((d pair) (s '())) - (cond ((null? d) (reverse! s)) - ((symbol? d) (reverse! (cons d s))) - (else (loop (cdr d) (cons (car d) s)))))) - -(define (make-location file line) - (list (cons "file" (if (string? file) file '())) - (cons "line" (if (number? line) (+ 1 line) '())))) - -(define (sort-symbols! syms) - (let ((cmp (lambda (l r) - (stringstring l) (symbol->string r))))) - (sort! syms cmp))) - -(define (make-symbol-sort sel) - (let ((cmp (lambda (a b) - (stringstring (sel a)) - (symbol->string (sel b)))))) - (lambda (syms) - (sort! syms cmp)))) - -(define (gensym? sym) - (and (symbol? sym) (gensym-name? (format #f "~A" sym)))) - -(define (gensym-name? name) - (and (string-match "^#[{]" name) #t)) diff --git a/geiser/xref.scm b/geiser/xref.scm deleted file mode 100644 index 549cc94..0000000 --- a/geiser/xref.scm +++ /dev/null @@ -1,84 +0,0 @@ -;;; xref.scm -- cross-referencing utilities - -;; Copyright (C) 2009, 2010, 2020 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 . - -;; Start date: Mon Mar 02, 2009 02:37 - -(define-module (geiser xref) - #:export (symbol-location - generic-methods - callers - callees - find-file) - #:use-module (geiser utils) - #:use-module (geiser modules) - #:use-module (geiser doc) - #:use-module (oop goops) - #:use-module (system xref) - #:use-module (system vm program)) - -(define (symbol-location sym) - (let ((obj (symbol->object sym))) - (cond ((program? obj) (program-location obj)) - ((symbol-module sym) => module-location) - (else '())))) - -(define (generic-methods sym) - (let* ((gen (symbol->object sym)) - (methods (if (is-a? gen ) - (generic-function-methods gen) - '()))) - (filter (lambda (x) (not (null? x))) - (map (lambda (m) - (make-xref (method-procedure m) sym (symbol-module sym))) - methods)))) - -(define (make-xref proc name module) - (and proc - `(("location" . ,(or (program-location proc) (symbol-location name))) - ("signature" . ,(object-signature name proc)) - ("module" . ,(or module '()))))) - -(define (program-location p) - (cond ((not (program? p)) #f) - ((program-source p 0) => - (lambda (s) (make-location (program-path p) (source:line s)))) - ((program-path p) => (lambda (s) (make-location s #f))) - (else #f))) - -(define (program-path p) - (let* ((mod (program-module p)) - (name (and (module? mod) (module-name mod)))) - (and name (module-path name)))) - -(define (procedure-xref proc . mod-name) - (let* ((proc-name (or (procedure-name proc) ')) - (mod-name (if (null? mod-name) - (symbol-module proc-name) - (car mod-name)))) - (make-xref proc proc-name mod-name))) - -(define (callers sym) - (let ((mod (symbol-module sym #t))) - (and mod - (apply append (map (lambda (procs) - (map (lambda (proc) - (procedure-xref proc (car procs))) - (cdr procs))) - (procedure-callers (cons mod sym))))))) - -(define (callees sym) - (let ((obj (symbol->object sym))) - (and obj - (map procedure-xref (procedure-callees obj))))) - -(define (find-file path) - (let loop ((dirs %load-path)) - (if (null? dirs) #f - (let ((candidate (string-append (car dirs) "/" path))) - (if (file-exists? candidate) candidate (loop (cdr dirs))))))) diff --git a/src/geiser/completion.scm b/src/geiser/completion.scm new file mode 100644 index 0000000..d69859b --- /dev/null +++ b/src/geiser/completion.scm @@ -0,0 +1,27 @@ +;;; completion.scm -- completing known symbols and module names + +;; Copyright (C) 2009, 2012 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 . + +;; Start date: Mon Mar 02, 2009 02:22 + +(define-module (geiser completion) + #:export (completions module-completions) + #:use-module (geiser utils) + #:use-module (geiser modules) + #:use-module (ice-9 session) + #:use-module (ice-9 regex)) + +(define (completions prefix) + (let ((prefix (string-append "^" (regexp-quote prefix)))) + (sort! (map symbol->string (apropos-internal prefix)) string. + +;; Start date: Sun Feb 08, 2009 18:44 + +(define-module (geiser doc) + #:export (autodoc + symbol-documentation + module-exports + object-signature) + #:use-module (geiser utils) + #:use-module (geiser modules) + #:use-module (system vm program) + #:use-module (system vm debug) + #:use-module (ice-9 session) + #:use-module (ice-9 documentation) + #:use-module (ice-9 regex) + #:use-module (ice-9 format) + #:use-module (oop goops) + #:use-module (srfi srfi-1)) + +(define (autodoc ids) + (if (not (list? ids)) + '() + (map (lambda (id) (or (autodoc* id) (list id))) ids))) + +(define* (autodoc* id) + (let ((args (obj-args (symbol->object id)))) + (and args + `(,@(signature id args) + ("module" . ,(symbol-module id)))))) + +(define (object-signature name obj) + (let ((args (obj-args obj))) + (and args (signature name args)))) + +(define (value-str obj) + (format #f "~:@y" obj)) + +(define* (signature id args-list #:optional (detail #t)) + (define (arglst args kind) + (let ((args (assq-ref args kind))) + (cond ((or (not args) (null? args)) '()) + ((list? args) args) + (else (list args))))) + (define (mkargs as) + `(("required" ,@(arglst as 'required)) + ("optional" ,@(arglst as 'optional) + ,@(if (assq-ref as 'rest) (list "...") '())) + ("key" ,@(arglst as 'keyword)))) + (let* ((args-list (map mkargs (if (list? args-list) args-list '()))) + (value (and (and detail (null? args-list)) + (value-str (symbol->object id))))) + `(,id ("args" ,@args-list) ,@(if value `(("value" . ,value)) '())))) + +(define default-macro-args '(((required ...)))) + +(define geiser-args-key (gensym "geiser-args-key-")) + +(define (obj-args obj) + (cond ((not obj) #f) + ((or (procedure? obj) (program? obj)) + (cond ((procedure-property obj geiser-args-key)) + ((arguments obj) => + (lambda (args) + (set-procedure-property! obj geiser-args-key args) + args)) + (else #f))) + ((and (macro? obj) (macro-transformer obj)) => macro-args) + ((macro? obj) default-macro-args) + (else 'variable))) + +(define (program-arities prog) + (let ((addrs (program-address-range prog))) + (when (pair? addrs) (find-program-arities (car addrs))))) + +(define (arguments proc) + (define (p-args prog) + (let ((as (map arity-arguments-alist (or (program-arities prog) '())))) + (and (not (null? as)) as))) + (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y))))) + (cond ((is-a? proc ) (generic-args proc)) + ((doc->args proc) => list) + ((procedure-property proc 'arglist) => (clist arglist->args)) + ((procedure-source proc) => (clist source->args)) + ((and (program? proc) (p-args proc))) + ((procedure-property proc 'arity) => (clist arity->args)) + (else #f))) + +(define (source->args src) + (let ((formals (cadr src))) + (cond ((list? formals) `((required . ,formals))) + ((pair? formals) + `((required . ,(car formals)) (rest . ,(cdr formals)))) + (else #f)))) + +(define (macro-args tf) + (define* (collect args #:optional (req '())) + (cond ((null? args) (arglist->args `(,(reverse req) #f #f r #f))) + ((symbol? args) (arglist->args `(,(reverse req) #f #f r ,args))) + ((and (pair? args) (symbol? (car args))) + (collect (cdr args) (cons (car args) req))) + (else #f))) + (let* ((pats (procedure-property tf 'patterns)) + (args (and pats (filter-map collect pats)))) + (or (and args (not (null? args)) args) default-macro-args))) + +(define (arity->args art) + (define (gen-arg-names count) + (map (lambda (x) '_) (iota (max count 0)))) + (let ((req (car art)) + (opt (cadr art)) + (rest (caddr art))) + `(,@(if (> req 0) + (list (cons 'required (gen-arg-names req))) + '()) + ,@(if (> opt 0) + (list (cons 'optional (gen-arg-names opt))) + '()) + ,@(if rest (list (cons 'rest 'rest)) '())))) + +(define (arglist->args arglist) + `((required . ,(car arglist)) + (optional . ,(cadr arglist)) + (keyword . ,(caddr arglist)) + (rest . ,(car (cddddr arglist))))) + +(define (doc->args proc) + ;; Guile 2.0.9+ uses the (texinfo ...) modules to produce + ;; `guile-procedures.txt', and the output has a single hyphen, whereas + ;; `makeinfo' produces two hyphens. + (define proc-rx "--? Scheme Procedure: ([^[\n]+)\n") + (define proc-rx2 "--? Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)") + (let ((doc (object-documentation proc))) + (and doc + (let ((match (or (string-match proc-rx doc) + (string-match proc-rx2 doc)))) + (and match + (parse-signature-string (match:substring match 1))))))) + +(define (parse-signature-string str) + (define opt-arg-rx "\\[([^] ]+)\\]?") + (define opt-arg-rx2 "([^ ])+\\]+") + (let ((tokens (string-tokenize str))) + (if (< (length tokens) 2) + '() + (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f)) + (cond ((null? tokens) + `((required ,@(map string->symbol (reverse! req))) + (optional ,@(map string->symbol (reverse! opt))) + ,@(if rest + (list (cons 'rest (string->symbol rest))) + '()))) + ((string=? "." (car tokens)) + (if (not (null? (cdr tokens))) + (loop (cddr tokens) req opt (cadr tokens)) + (loop '() req opt "rest"))) + ((or (string-match opt-arg-rx (car tokens)) + (string-match opt-arg-rx2 (car tokens))) + => (lambda (m) + (loop (cdr tokens) + req + (cons (match:substring m 1) opt) + rest))) + (else (loop (cdr tokens) + (cons (car tokens) req) + opt + rest))))))) + +(define (generic-args gen) + (define (src> src1 src2) + (> (length (cadr src1)) (length (cadr src2)))) + (define (src m) + (catch #t + (lambda () (method-source m)) + (lambda (k . a) #f))) + (let* ((methods (generic-function-methods gen)) + (srcs (filter identity (map src methods)))) + (cond ((and (null? srcs) + (not (null? methods)) + (method-procedure (car methods))) => arguments) + ((not (null? srcs)) (list (source->args (car (sort! srcs src>))))) + (else '(((rest . rest))))))) + +(define (symbol-documentation sym) + (let ((obj (symbol->object sym))) + (if obj + `(("signature" . ,(or (obj-signature sym obj #f) sym)) + ("docstring" . ,(docstring sym obj)))))) + +(define (docstring sym obj) + (define (valuable?) + (not (or (macro? obj) (procedure? obj) (program? obj)))) + (with-output-to-string + (lambda () + (let* ((type (cond ((macro? obj) "A macro") + ((procedure? obj) "A procedure") + ((program? obj) "A compiled program") + (else "An object"))) + (modname (symbol-module sym)) + (doc (object-documentation obj))) + (display type) + (if modname + (begin + (display " in module ") + (display modname) + (display "."))) + (newline) + (if doc (begin (newline) (display doc))) + (if (valuable?) (begin (newline) + (display "Value:") + (newline) + (display " ") + (display (value-str obj)))))))) + +(define* (obj-signature sym obj #:optional (detail #t)) + (let ((args (obj-args obj))) + (and args (signature sym args detail)))) + +(define (module-exports mod-name) + (define elt-sort (make-symbol-sort car)) + (let* ((mod (catch #t + (lambda () (resolve-interface mod-name)) + (lambda args (resolve-module mod-name)))) + (elts (hash-fold classify-module-object + (list '() '() '()) + (module-obarray mod))) + (elts (map elt-sort elts)) + (subs (map (lambda (m) (list (module-name m))) + (submodules (resolve-module mod-name #f))))) + (list (cons "modules" subs) + (cons "procs" (car elts)) + (cons "syntax" (cadr elts)) + (cons "vars" (caddr elts))))) + +(define (classify-module-object name var elts) + (let ((obj (and (variable-bound? var) + (variable-ref var)))) + (cond ((or (not obj) (module? obj)) elts) + ((or (procedure? obj) (program? obj)) + (list (cons (list name `("signature" . ,(obj-signature name obj))) + (car elts)) + (cadr elts) + (caddr elts))) + ((macro? obj) + (list (car elts) + (cons (list name `("signature" . ,(obj-signature name obj))) + (cadr elts)) + (caddr elts))) + (else (list (car elts) + (cadr elts) + (cons (list name) (caddr elts))))))) diff --git a/src/geiser/emacs.scm b/src/geiser/emacs.scm new file mode 100644 index 0000000..6f2fc29 --- /dev/null +++ b/src/geiser/emacs.scm @@ -0,0 +1,58 @@ +;;; emacs.scm -- procedures for emacs interaction: entry point + +;; Copyright (C) 2009, 2010, 2011 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 . + +;; Start date: Sun Feb 08, 2009 18:39 + +(define-module (geiser emacs) + #:use-module (ice-9 match) + #:use-module (system repl command) + #:use-module (system repl error-handling) + #:use-module (system repl server) + #:use-module (geiser evaluation) + #:use-module ((geiser modules) #:renamer (symbol-prefix-proc 'ge:)) + #:use-module ((geiser completion) #:renamer (symbol-prefix-proc 'ge:)) + #:use-module ((geiser xref) #:renamer (symbol-prefix-proc 'ge:)) + #:use-module ((geiser doc) #:renamer (symbol-prefix-proc 'ge:))) + +(define this-module (resolve-module '(geiser emacs))) + +(define-meta-command ((geiser-no-values geiser) repl) + "geiser-no-values +No-op command used internally by Geiser." + (values)) + +(define-meta-command ((geiser-newline geiser) repl) + "geiser-newline +Meta-command used by Geiser to emit a new line." + (newline)) + +(define-meta-command ((geiser-eval geiser) repl (mod form args) . rest) + "geiser-eval module form args () +Meta-command used by Geiser to evaluate and compile code." + (if (null? args) + (call-with-error-handling + (lambda () (ge:compile form mod))) + (let ((proc (eval form this-module))) + (ge:eval `(,proc ,@args) mod)))) + +(define-meta-command ((geiser-load-file geiser) repl file) + "geiser-load-file file +Meta-command used by Geiser to load and compile files." + (call-with-error-handling + (lambda () (ge:compile-file file)))) + + +(define-meta-command ((geiser-start-server geiser) repl) + "geiser-start-server +Meta-command used by Geiser to start a REPL server." + (let* ((sock (make-tcp-server-socket #:port 0)) + (port (sockaddr:port (getsockname sock)))) + (spawn-server sock) + (write (list 'port port)) + (newline))) diff --git a/src/geiser/evaluation.scm b/src/geiser/evaluation.scm new file mode 100644 index 0000000..bdbcdd8 --- /dev/null +++ b/src/geiser/evaluation.scm @@ -0,0 +1,144 @@ +;;; evaluation.scm -- evaluation, compilation and macro-expansion + +;; Copyright (C) 2009, 2010, 2011, 2013, 2015 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 . + +;; Start date: Mon Mar 02, 2009 02:46 + +(cond-expand + (guile-2.2 + (define-module (geiser evaluation) + #:export (ge:compile + ge:eval + ge:macroexpand + ge:compile-file + ge:load-file + ge:set-warnings + ge:add-to-load-path) + #:use-module (geiser modules) + #:use-module (srfi srfi-1) + #:use-module (language tree-il) + #:use-module (system base compile) + #:use-module (system base message) + #:use-module (system base pmatch) + #:use-module (system vm program) + #:use-module (ice-9 pretty-print) + #:use-module (system vm loader))) + (else + (define-module (geiser evaluation) + #:export (ge:compile + ge:eval + ge:macroexpand + ge:compile-file + ge:load-file + ge:set-warnings + ge:add-to-load-path) + #:use-module (geiser modules) + #:use-module (srfi srfi-1) + #:use-module (language tree-il) + #:use-module (system base compile) + #:use-module (system base message) + #:use-module (system base pmatch) + #:use-module (system vm program) + #:use-module (ice-9 pretty-print)))) + + +(define compile-opts '()) +(define compile-file-opts '()) + +(define default-warnings '(arity-mismatch unbound-variable format)) +(define verbose-warnings `(unused-variable ,@default-warnings)) + +(define (ge:set-warnings wl) + (let* ((warns (cond ((list? wl) wl) + ((symbol? wl) (case wl + ((none nil null) '()) + ((medium default) default-warnings) + ((high verbose) verbose-warnings) + (else '()))) + (else '()))) + (fwarns (if (memq 'unused-variable warns) + (cons 'unused-toplevel warns) + warns))) + (set! compile-opts (list #:warnings warns)) + (set! compile-file-opts (list #:warnings fwarns)))) + +(ge:set-warnings 'none) + +(define (call-with-result thunk) + (letrec* ((result #f) + (output + (with-output-to-string + (lambda () + (with-fluids ((*current-warning-port* (current-output-port)) + (*current-warning-prefix* "")) + (with-error-to-port (current-output-port) + (lambda () (set! result + (map object->string (thunk)))))))))) + (write `((result ,@result) (output . ,output))) + (newline))) + +(define (ge:compile form module) + (compile* form module compile-opts)) + +(define (compile* form module-name opts) + (let* ((module (or (find-module module-name) (current-module))) + (ev (lambda () + (call-with-values + (lambda () + (let* ((to (cond-expand (guile-2.2 'bytecode) + (else 'objcode))) + (cf (cond-expand (guile-2.2 load-thunk-from-memory) + (else make-program))) + (o (compile form + #:to to + #:env module + #:opts opts)) + (thunk (cf o))) + (start-stack 'geiser-evaluation-stack + (eval `(,thunk) module)))) + (lambda vs vs))))) + (call-with-result ev))) + +(define (ge:eval form module-name) + (let* ((module (or (find-module module-name) (current-module))) + (ev (lambda () + (call-with-values + (lambda () (eval form module)) + (lambda vs vs))))) + (call-with-result ev))) + +(define (ge:compile-file path) + (call-with-result + (lambda () + (let ((cr (compile-file path + #:canonicalization 'absolute + #:opts compile-file-opts))) + (and cr + (list (object->string (save-module-excursion + (lambda () (load-compiled cr)))))))))) + +(define ge:load-file ge:compile-file) + +(define (ge:macroexpand form . all) + (let ((all (and (not (null? all)) (car all)))) + (with-output-to-string + (lambda () + (pretty-print (tree-il->scheme (macroexpand form))))))) + +(define (add-to-list lst dir) + (and (not (member dir lst)))) + +(define (ge:add-to-load-path dir) + (and (file-is-directory? dir) + (let ((in-lp (member dir %load-path)) + (in-clp (member dir %load-compiled-path))) + (when (not in-lp) + (set! %load-path (cons dir %load-path))) + (when (not in-clp) + (set! %load-compiled-path (cons dir %load-compiled-path))) + (or in-lp in-clp)))) diff --git a/src/geiser/modules.scm b/src/geiser/modules.scm new file mode 100644 index 0000000..32b0f1f --- /dev/null +++ b/src/geiser/modules.scm @@ -0,0 +1,104 @@ +;;; modules.scm -- module metadata + +;; Copyright (C) 2009, 2010, 2011, 2018 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 . + +;; Start date: Mon Mar 02, 2009 02:00 + +(define-module (geiser modules) + #:export (symbol-module + program-module + module-name? + module-path + find-module + all-modules + submodules + module-location) + #:use-module (geiser utils) + #:use-module (system vm program) + #:use-module (system vm debug) + #:use-module (ice-9 regex) + #:use-module (ice-9 session) + #:use-module (srfi srfi-1)) + +;; Return hash table mapping filename to list of modules defined in that +;; file. H/t andy wingo. +(define (fill-file->module-mapping! ret) + (define (record-module m) + (let ((f (module-filename m))) + (hash-set! ret f (cons m (hash-ref ret f '()))))) + (define (visit-module m) + (record-module m) + (hash-for-each (lambda (k v) (visit-module v)) + (module-submodules m))) + (visit-module (resolve-module '() #f)) + ret) + +(define file->modules (fill-file->module-mapping! (make-hash-table))) + +(define (program-file p) + (let ((src (program-source p 0))) + (and (pair? src) (cadr src)))) + +(define (program-module p) + (let* ((f (program-file p)) + (mods (or (hash-ref file->modules f) + (hash-ref (fill-file->module-mapping! file->modules) f)))) + (and (pair? mods) (not (null? mods)) (car mods)))) + +(define (module-name? module-name) + (and (list? module-name) + (not (null? module-name)) + (every symbol? module-name))) + +(define (symbol-module sym . all) + (and sym + (catch 'module-name + (lambda () + (apropos-fold (lambda (module name var init) + (if (eq? name sym) + (throw 'module-name (module-name module)) + init)) + #f + (regexp-quote (symbol->string sym)) + (if (or (null? all) (not (car all))) + (apropos-fold-accessible (current-module)) + apropos-fold-all))) + (lambda (key . args) + (and (eq? key 'module-name) (car args)))))) + +(define (module-location name) + (make-location (module-path name) #f)) + +(define (find-module mod-name) + (and (module-name? mod-name) + (resolve-module mod-name #f #:ensure #f))) + +(define (module-path module-name) + (and (module-name? module-name) + (or ((@@ (ice-9 session) module-filename) module-name) + (module-filename (resolve-module module-name #f))))) + +(define (submodules mod) + (hash-map->list (lambda (k v) v) (module-submodules mod))) + +(define (root-modules) + (submodules (resolve-module '() #f))) + +(define (all-modules) + (define (maybe-name m) + (and (module-kind m) (format #f "~A" (module-name m)))) + (let* ((guile (resolve-module '(guile))) + (roots (remove (lambda (m) (eq? m guile)) (root-modules))) + (children (append-map all-child-modules roots))) + (cons "(guile)" (filter-map maybe-name children)))) + +(define* (all-child-modules mod #:optional (seen '())) + (let ((cs (filter (lambda (m) (not (member m seen))) (submodules mod)))) + (fold (lambda (m all) (append (all-child-modules m all) all)) + (list mod) + cs))) diff --git a/src/geiser/utils.scm b/src/geiser/utils.scm new file mode 100644 index 0000000..92ed7ae --- /dev/null +++ b/src/geiser/utils.scm @@ -0,0 +1,52 @@ +;;; utils.scm -- utility functions + +;; Copyright (C) 2009, 2010, 2011 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 . + +;; Start date: Mon Mar 02, 2009 01:48 + +(define-module (geiser utils) + #:export (make-location + symbol->object + pair->list + sort-symbols! + make-symbol-sort + gensym?) + #:use-module (ice-9 regex)) + +(define (symbol->object sym) + (and (symbol? sym) + (module-defined? (current-module) sym) + (module-ref (current-module) sym))) + +(define (pair->list pair) + (let loop ((d pair) (s '())) + (cond ((null? d) (reverse! s)) + ((symbol? d) (reverse! (cons d s))) + (else (loop (cdr d) (cons (car d) s)))))) + +(define (make-location file line) + (list (cons "file" (if (string? file) file '())) + (cons "line" (if (number? line) (+ 1 line) '())))) + +(define (sort-symbols! syms) + (let ((cmp (lambda (l r) + (stringstring l) (symbol->string r))))) + (sort! syms cmp))) + +(define (make-symbol-sort sel) + (let ((cmp (lambda (a b) + (stringstring (sel a)) + (symbol->string (sel b)))))) + (lambda (syms) + (sort! syms cmp)))) + +(define (gensym? sym) + (and (symbol? sym) (gensym-name? (format #f "~A" sym)))) + +(define (gensym-name? name) + (and (string-match "^#[{]" name) #t)) diff --git a/src/geiser/xref.scm b/src/geiser/xref.scm new file mode 100644 index 0000000..549cc94 --- /dev/null +++ b/src/geiser/xref.scm @@ -0,0 +1,84 @@ +;;; xref.scm -- cross-referencing utilities + +;; Copyright (C) 2009, 2010, 2020 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 . + +;; Start date: Mon Mar 02, 2009 02:37 + +(define-module (geiser xref) + #:export (symbol-location + generic-methods + callers + callees + find-file) + #:use-module (geiser utils) + #:use-module (geiser modules) + #:use-module (geiser doc) + #:use-module (oop goops) + #:use-module (system xref) + #:use-module (system vm program)) + +(define (symbol-location sym) + (let ((obj (symbol->object sym))) + (cond ((program? obj) (program-location obj)) + ((symbol-module sym) => module-location) + (else '())))) + +(define (generic-methods sym) + (let* ((gen (symbol->object sym)) + (methods (if (is-a? gen ) + (generic-function-methods gen) + '()))) + (filter (lambda (x) (not (null? x))) + (map (lambda (m) + (make-xref (method-procedure m) sym (symbol-module sym))) + methods)))) + +(define (make-xref proc name module) + (and proc + `(("location" . ,(or (program-location proc) (symbol-location name))) + ("signature" . ,(object-signature name proc)) + ("module" . ,(or module '()))))) + +(define (program-location p) + (cond ((not (program? p)) #f) + ((program-source p 0) => + (lambda (s) (make-location (program-path p) (source:line s)))) + ((program-path p) => (lambda (s) (make-location s #f))) + (else #f))) + +(define (program-path p) + (let* ((mod (program-module p)) + (name (and (module? mod) (module-name mod)))) + (and name (module-path name)))) + +(define (procedure-xref proc . mod-name) + (let* ((proc-name (or (procedure-name proc) ')) + (mod-name (if (null? mod-name) + (symbol-module proc-name) + (car mod-name)))) + (make-xref proc proc-name mod-name))) + +(define (callers sym) + (let ((mod (symbol-module sym #t))) + (and mod + (apply append (map (lambda (procs) + (map (lambda (proc) + (procedure-xref proc (car procs))) + (cdr procs))) + (procedure-callers (cons mod sym))))))) + +(define (callees sym) + (let ((obj (symbol->object sym))) + (and obj + (map procedure-xref (procedure-callees obj))))) + +(define (find-file path) + (let loop ((dirs %load-path)) + (if (null? dirs) #f + (let ((candidate (string-append (car dirs) "/" path))) + (if (file-exists? candidate) candidate (loop (cdr dirs))))))) -- cgit v1.2.3