diff options
| author | jao <jao@gnu.org> | 2020-07-20 04:41:00 +0100 | 
|---|---|---|
| committer | jao <jao@gnu.org> | 2020-07-20 04:41:00 +0100 | 
| commit | aab5226dfe937861c54729744e8add15d931f758 (patch) | |
| tree | 7397e3edaffb23d5efb6aad1762681834faabfa3 /geiser | |
| parent | 20043b13bb9756079d73c68ffd3942cecedb2b9e (diff) | |
| download | geiser-guile-aab5226dfe937861c54729744e8add15d931f758.tar.gz geiser-guile-aab5226dfe937861c54729744e8add15d931f758.tar.bz2 | |
geiser -> src
Diffstat (limited to 'geiser')
| -rw-r--r-- | geiser/completion.scm | 27 | ||||
| -rw-r--r-- | geiser/doc.scm | 258 | ||||
| -rw-r--r-- | geiser/emacs.scm | 58 | ||||
| -rw-r--r-- | geiser/evaluation.scm | 144 | ||||
| -rw-r--r-- | geiser/modules.scm | 104 | ||||
| -rw-r--r-- | geiser/utils.scm | 52 | ||||
| -rw-r--r-- | geiser/xref.scm | 84 | 
7 files changed, 0 insertions, 727 deletions
| 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 <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. - -;; 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<?))) - -(define (module-completions prefix) -  (let* ((prefix (string-append "^" (regexp-quote prefix))) -         (matcher (lambda (s) (string-match prefix s))) -         (names (filter matcher (all-modules)))) -    (sort! names string<?))) diff --git a/geiser/doc.scm b/geiser/doc.scm deleted file mode 100644 index 9f28f7f..0000000 --- a/geiser/doc.scm +++ /dev/null @@ -1,258 +0,0 @@ -;;; doc.scm -- procedures providing documentation on scheme objects - -;; Copyright (C) 2009, 2010, 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 <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. - -;; 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>) (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 <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. - -;; 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 <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. - -;; 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 <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. - -;; 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 <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. - -;; 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) -               (string<? (symbol->string l) (symbol->string r))))) -    (sort! syms cmp))) - -(define (make-symbol-sort sel) -  (let ((cmp (lambda (a b) -               (string<? (symbol->string (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 <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. - -;; 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>) -                      (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) '<anonymous>)) -         (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))))))) | 
