From 1f80c5048e78d0251c18634b8bf7d3f8ea4733b0 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Mon, 2 Mar 2009 03:13:59 +0100 Subject: Breakdown of schemeland into neat submodules. --- scheme/guile/geiser/completion.scm | 56 +++++++ scheme/guile/geiser/doc.scm | 183 +++++++++++++++++++++ scheme/guile/geiser/emacs.scm | 128 ++------------- scheme/guile/geiser/evaluation.scm | 144 ++++++++++++++++ scheme/guile/geiser/introspection.scm | 298 ---------------------------------- scheme/guile/geiser/modules.scm | 102 ++++++++++++ scheme/guile/geiser/utils.scm | 53 ++++++ scheme/guile/geiser/xref.scm | 37 +++++ 8 files changed, 587 insertions(+), 414 deletions(-) create mode 100644 scheme/guile/geiser/completion.scm create mode 100644 scheme/guile/geiser/doc.scm create mode 100644 scheme/guile/geiser/evaluation.scm delete mode 100644 scheme/guile/geiser/introspection.scm create mode 100644 scheme/guile/geiser/modules.scm create mode 100644 scheme/guile/geiser/utils.scm create mode 100644 scheme/guile/geiser/xref.scm (limited to 'scheme/guile') diff --git a/scheme/guile/geiser/completion.scm b/scheme/guile/geiser/completion.scm new file mode 100644 index 0000000..4906368 --- /dev/null +++ b/scheme/guile/geiser/completion.scm @@ -0,0 +1,56 @@ +;; completion.scm -- completing known symbols and module names + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Mon Mar 02, 2009 02:22 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Comentary: + +;; Completion interface with emacs. + +;;; Code: + +(define-module (geiser completion) + #:export (completions) + #:use-module (geiser utils) + #:use-module (ice-9 session) + #:use-module (ice-9 regex)) + +(define (completions prefix . context) + (let ((context (and (not (null? context)) (car context))) + (prefix (string-append "^" (regexp-quote prefix)))) + (append (filter (lambda (s) (string-match prefix s)) + (map symbol->string (local-bindings context))) + (sort! (map symbol->string (apropos-internal prefix)) string (length f) 2) (cddr f) '())) + (let loop ((form form) (bindings '())) + (cond ((not (pair? form)) bindings) + ((list? (car form)) + (loop (cdr form) (append (local-bindings (car form)) bindings))) + ((and (list? form) (< (length form) 2)) bindings) + ((memq (car form) '(define define* lambda)) + (loop (body form) (append (pair->list (cadr form)) bindings))) + ((and (memq (car form) '(let let* letrec letrec*)) + (list? (cadr form))) + (loop (body form) (append (map car (cadr form)) bindings))) + ((and (eq? 'let (car form)) (symbol? (cadr form))) + (loop (cons 'let (body form)) (cons (cadr form) bindings))) + (else (loop (cdr form) bindings))))) + +;;; completions.scm ends here diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm new file mode 100644 index 0000000..21ede9e --- /dev/null +++ b/scheme/guile/geiser/doc.scm @@ -0,0 +1,183 @@ +;; doc.scm -- name says it all + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sun Feb 08, 2009 18:44 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Comentary: + +;; Procedures providing documentation on scheme objects. + +;;; Code: + +(define-module (geiser doc) + #:export (autodoc + symbol-documentation) + #:use-module (geiser utils) + #:use-module (geiser modules) + #:use-module (system vm program) + #:use-module (ice-9 session) + #:use-module (ice-9 documentation) + #:use-module (oop goops) + #:use-module (srfi srfi-1)) + +(define (autodoc form) + (cond ((null? form) #f) + ((symbol? form) (describe-application (list form))) + ((and (pair? form) (not (list? form))) (autodoc (pair->list form))) + ((list? form) + (let ((lst (last form))) + (cond ((symbol? lst) (or (describe-application (list lst)) + (describe-application form))) + ((pair? lst) + (or (autodoc (pair->list lst)) + (autodoc (map (lambda (s) (if (pair? s) (gensym) s)) form)))) + (else (describe-application form))))) + (else #f))) + +(define (describe-application form) + (let* ((fun (car form)) + (args (obj-args (symbol->object fun)))) + (and args + (list (cons 'signature (signature fun args)) + (cons 'position (find-position args form)) + (cons 'module (symbol-module fun)))))) + +(define (arglst args kind) + (let ((args (assq-ref args kind))) + (cond ((or (not args) (null? args)) '()) + ((list? args) args) + (else (list args))))) + +(define (signature fun args) + (let ((req (arglst args 'required)) + (opt (arglst args 'optional)) + (key (arglst args 'keyword)) + (rest (assq-ref args 'rest))) + (let ((sgn `(,fun ,@req + ,@(if (not (null? opt)) (cons #:opt opt) '()) + ,@(if (not (null? key)) (cons #:key key) '())))) + (if rest `(,@sgn #:rest ,rest) sgn)))) + +(define (find-position args form) + (let* ((lf (length form)) + (lf-1 (- lf 1))) + (if (= 1 lf) 0 + (let ((req (length (arglst args 'required))) + (opt (length (arglst args 'optional))) + (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k))) + (arglst args 'keyword))) + (rest (assq-ref args 'rest))) + (cond ((<= lf (+ 1 req)) lf-1) + ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1)) + ((or (memq (last form) keys) + (memq (car (take-right form 2)) keys)) => + (lambda (sl) + (+ 2 req + (if (> opt 0) (+ 1 opt) 0) + (- (length keys) (length sl))))) + (else (+ 1 req + (if (> opt 0) (+ 1 opt) 0) + (if (null? keys) 0 (+ 1 (length keys))) + (if rest 2 0)))))))) + +(define (obj-args obj) + (cond ((not obj) #f) + ((or (procedure? obj) (program? obj)) (arguments obj)) + ((macro? obj) (or (obj-args (macro-transformer obj)) + '((required ...)))) + (else #f))) + +(define (arguments proc) + (cond + ((is-a? proc ) (generic-args proc)) + ((procedure-property proc 'arglist) => arglist->args) + ((procedure-source proc) => source->args) + ((program? proc) ((@ (system vm program) program-arguments) proc)) + ((procedure-property proc 'arity) => 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 (arity->args art) + (let ((req (car art)) + (opt (cadr art)) + (rest (caddr art))) + `(,@(if (> req 0) (list (cons 'required (gen-arg-names 1 req))) '()) + ,@(if (> opt 0) (list (cons 'optional (gen-arg-names (+ 1 req) opt))) '()) + ,@(if rest (list (cons 'rest 'rest)) '())))) + +(define (gen-arg-names fst count) + (map (lambda (n) (string->symbol (format "arg-~A" (+ fst n)))) + (iota (max count 1)))) + +(define (arglist->args arglist) + `((required . ,(car arglist)) + (optional . ,(cadr arglist)) + (keyword . ,(caddr arglist)) + (rest . ,(car (cddddr arglist))))) + +(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) (null? methods)) '((rest . rest))) + ((and (null? srcs) + (not (null? methods)) + (method-procedure (car methods))) + => arguments) + ((not (null? srcs)) (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) sym)) + (docstring . ,(docstring sym obj)))))) + +(define (docstring sym 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))) + (newline) + (if doc (display doc)))))) + +(define (obj-signature sym obj) + (let ((args (obj-args obj))) + (and args (signature sym args)))) + +;;; doc.scm ends here diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm index f2f3d45..0c99216 100644 --- a/scheme/guile/geiser/emacs.scm +++ b/scheme/guile/geiser/emacs.scm @@ -25,128 +25,24 @@ ;;; Code: (define-module (geiser emacs) - #:export (ge:eval - ge:compile - ge:macroexpand - ge:compile-file - ge:load-file) - #:re-export (ge:autodoc + #:re-export (ge:eval + ge:compile + ge:macroexpand + ge:compile-file + ge:load-file + ge:autodoc ge:completions ge:symbol-location + ge:generic-methods ge:symbol-documentation ge:all-modules ge:module-children ge:module-location) - #:use-module (srfi srfi-1) - #:use-module (system base compile) - #:use-module (system vm program) - #:use-module (ice-9 debugger utils) - #:use-module (ice-9 pretty-print) - #:use-module ((geiser introspection) :renamer (symbol-prefix-proc 'ge:))) + #: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 (make-result result output) - (list (cons 'result result) (cons 'output output))) - -(define (make-error key args stack) - (list (cons 'error (apply parse-error (cons key args))) - (cons 'stack (parse-stack stack)))) - -(define (parse-stack stack) - (if stack - (map (lambda (n) (parse-frame (stack-ref stack n))) - (iota (stack-length stack))) - '())) - -(define (parse-frame frame) - (list (cons 'frame (frame-number frame)) - (cons 'procedure (or (and (frame-procedure? frame) - (procedure-name (frame-procedure frame))) - '())) - (cons 'source (or (frame->source-position frame) '())) - (cons 'description (with-output-to-string - (lambda () - (if (frame-procedure? frame) - (write-frame-short/application frame) - (write-frame-short/expression frame))))))) - -(define (frame->source-position frame) - (let ((source (if (frame-procedure? frame) - (or (frame-source frame) - (let ((proc (frame-procedure frame))) - (and proc - (procedure? proc) - (procedure-source proc)))) - (frame-source frame)))) - (and source - (cond ((string? (source-property source 'filename)) - (list (source-property source 'filename) - (+ 1 (source-property source 'line)) - (source-property source 'column))) - ((and (pair? source) (list? (cadr source))) - (list (caadr source) - (+ 1 (caddr source)) - (cdddr source))) - (else #f))))) - -(define (parse-error key . args) - (let* ((len (length args)) - (subr (and (> len 0) (first args))) - (msg (and (> len 1) (second args))) - (margs (and (> len 2) (third args))) - (rest (and (> len 3) (fourth args)))) - (list (cons 'key key) - (cons 'subr (or subr '())) - (cons 'msg (if msg (apply format (cons #f (cons msg margs))) '())) - (cons 'rest (or rest '()))))) - -(define (evaluate form module-name evaluator) - (let ((module (or (and (list? module-name) - (resolve-module module-name)) - (current-module))) - (result #f) - (captured-stack #f) - (error #f)) - (let ((output - (with-output-to-string - (lambda () - (set! result - (catch #t - (lambda () - (start-stack 'id (evaluator form module))) - (lambda (key . args) - (set! error (make-error key args captured-stack))) - (lambda (key . args) - (set! captured-stack (make-stack #t 2 2))))))))) - (write (or error (make-result result output))) - (newline)))) - -(define (eval-compile form module) - (save-module-excursion - (lambda () - (set-current-module module) - (compile form)))) - -(define (ge:eval form module-name) - (evaluate form module-name eval)) - -(define (ge:compile form module-name) - (evaluate form module-name eval-compile)) - -(define (ge:compile-file path) - "Compile and load file, given its full @var{path}." - (evaluate `(and (compile-file ,path) - (load-compiled ,(compiled-file-name path))) - #f - eval)) - -(define (ge:load-file path) - "Load file, given its full @var{path}." - (evaluate `(load ,path) #f eval)) - -(define (ge:macroexpand form . all) - (let ((all (and (not (null? all)) (car all)))) - (with-output-to-string - (lambda () - (pretty-print ((if all macroexpand macroexpand-1) form)))))) ;;; emacs.scm ends here diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm new file mode 100644 index 0000000..1f3afc0 --- /dev/null +++ b/scheme/guile/geiser/evaluation.scm @@ -0,0 +1,144 @@ +;; evaluation.scm -- evaluation, compilation and macro-expansion + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Mon Mar 02, 2009 02:46 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Comentary: + +;; Core evaluation engine. + +;;; Code: + +(define-module (geiser evaluation) + #:export (ge:eval + ge:compile + ge:macroexpand + ge:compile-file + ge:load-file) + #:use-module (srfi srfi-1) + #:use-module (system base compile) + #:use-module (system vm program) + #:use-module (ice-9 debugger utils) + #:use-module (ice-9 pretty-print)) + +(define (make-result result output) + (list (cons 'result result) (cons 'output output))) + +(define (make-error key args stack) + (list (cons 'error (apply parse-error (cons key args))) + (cons 'stack (parse-stack stack)))) + +(define (parse-stack stack) + (if stack + (map (lambda (n) (parse-frame (stack-ref stack n))) + (iota (stack-length stack))) + '())) + +(define (parse-frame frame) + (list (cons 'frame (frame-number frame)) + (cons 'procedure (or (and (frame-procedure? frame) + (procedure-name (frame-procedure frame))) + '())) + (cons 'source (or (frame->source-position frame) '())) + (cons 'description (with-output-to-string + (lambda () + (if (frame-procedure? frame) + (write-frame-short/application frame) + (write-frame-short/expression frame))))))) + +(define (frame->source-position frame) + (let ((source (if (frame-procedure? frame) + (or (frame-source frame) + (let ((proc (frame-procedure frame))) + (and proc + (procedure? proc) + (procedure-source proc)))) + (frame-source frame)))) + (and source + (cond ((string? (source-property source 'filename)) + (list (source-property source 'filename) + (+ 1 (source-property source 'line)) + (source-property source 'column))) + ((and (pair? source) (list? (cadr source))) + (list (caadr source) + (+ 1 (caddr source)) + (cdddr source))) + (else #f))))) + +(define (parse-error key . args) + (let* ((len (length args)) + (subr (and (> len 0) (first args))) + (msg (and (> len 1) (second args))) + (margs (and (> len 2) (third args))) + (rest (and (> len 3) (fourth args)))) + (list (cons 'key key) + (cons 'subr (or subr '())) + (cons 'msg (if msg (apply format (cons #f (cons msg margs))) '())) + (cons 'rest (or rest '()))))) + +(define (evaluate form module-name evaluator) + (let ((module (or (and (list? module-name) + (resolve-module module-name)) + (current-module))) + (result #f) + (captured-stack #f) + (error #f)) + (let ((output + (with-output-to-string + (lambda () + (set! result + (catch #t + (lambda () + (start-stack 'id (evaluator form module))) + (lambda (key . args) + (set! error (make-error key args captured-stack))) + (lambda (key . args) + (set! captured-stack (make-stack #t 2 2))))))))) + (write (or error (make-result result output))) + (newline)))) + +(define (eval-compile form module) + (save-module-excursion + (lambda () + (set-current-module module) + (compile form)))) + +(define (ge:eval form module-name) + (evaluate form module-name eval)) + +(define (ge:compile form module-name) + (evaluate form module-name eval-compile)) + +(define (ge:compile-file path) + "Compile and load file, given its full @var{path}." + (evaluate `(and (compile-file ,path) + (load-compiled ,(compiled-file-name path))) + #f + eval)) + +(define (ge:load-file path) + "Load file, given its full @var{path}." + (evaluate `(load ,path) #f eval)) + +(define (ge:macroexpand form . all) + (let ((all (and (not (null? all)) (car all)))) + (with-output-to-string + (lambda () + (pretty-print ((if all macroexpand macroexpand-1) form)))))) + +;;; evaluation.scm ends here diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm deleted file mode 100644 index 900a5fa..0000000 --- a/scheme/guile/geiser/introspection.scm +++ /dev/null @@ -1,298 +0,0 @@ -;; introspection.scm -- name says it all - -;; Copyright (C) 2009 Jose Antonio Ortega Ruiz - -;; Author: Jose Antonio Ortega Ruiz -;; Start date: Sun Feb 08, 2009 18:44 - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Comentary: - -;; Procedures introspecting on scheme objects and their properties. - -;;; Code: - -(define-module (geiser introspection) - #:export (autodoc - completions - symbol-location - symbol-documentation - all-modules - module-children - module-location) - #:use-module (system vm program) - #:use-module (ice-9 regex) - #:use-module (ice-9 session) - #:use-module (ice-9 documentation) - #:use-module (oop goops) - #:use-module (srfi srfi-1)) - -(define (autodoc form) - (cond ((null? form) #f) - ((symbol? form) (describe-application (list form))) - ((and (pair? form) (not (list? form))) (autodoc (pair->list form))) - ((list? form) - (let ((lst (last form))) - (cond ((symbol? lst) (or (describe-application (list lst)) - (describe-application form))) - ((pair? lst) - (or (autodoc (pair->list lst)) - (autodoc (map (lambda (s) (if (pair? s) (gensym) s)) form)))) - (else (describe-application form))))) - (else #f))) - -(define (describe-application form) - (let* ((fun (car form)) - (args (obj-args (symbol->obj fun)))) - (and args - (list (cons 'signature (signature fun args)) - (cons 'position (find-position args form)) - (cons 'module (symbol-module fun)))))) - -(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 (arglst args kind) - (let ((args (assq-ref args kind))) - (cond ((or (not args) (null? args)) '()) - ((list? args) args) - (else (list args))))) - -(define (signature fun args) - (let ((req (arglst args 'required)) - (opt (arglst args 'optional)) - (key (arglst args 'keyword)) - (rest (assq-ref args 'rest))) - (let ((sgn `(,fun ,@req - ,@(if (not (null? opt)) (cons #:opt opt) '()) - ,@(if (not (null? key)) (cons #:key key) '())))) - (if rest `(,@sgn #:rest ,rest) sgn)))) - -(define (find-position args form) - (let* ((lf (length form)) - (lf-1 (- lf 1))) - (if (= 1 lf) 0 - (let ((req (length (arglst args 'required))) - (opt (length (arglst args 'optional))) - (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k))) - (arglst args 'keyword))) - (rest (assq-ref args 'rest))) - (cond ((<= lf (+ 1 req)) lf-1) - ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1)) - ((or (memq (last form) keys) - (memq (car (take-right form 2)) keys)) => - (lambda (sl) - (+ 2 req - (if (> opt 0) (+ 1 opt) 0) - (- (length keys) (length sl))))) - (else (+ 1 req - (if (> opt 0) (+ 1 opt) 0) - (if (null? keys) 0 (+ 1 (length keys))) - (if rest 2 0)))))))) - -(define (symbol-module sym) - (and sym - (call/cc - (lambda (k) - (apropos-fold (lambda (module name var init) - (if (eq? name sym) (k (module-name module)) init)) - #f - (regexp-quote (symbol->string sym)) - (apropos-fold-accessible (current-module))))))) - -(define (symbol->obj sym) - (and (symbol? sym) - (module-defined? (current-module) sym) - (module-ref (current-module) sym))) - -(define (obj-args obj) - (cond ((not obj) #f) - ((or (procedure? obj) (program? obj)) (arguments obj)) - ((macro? obj) (or (obj-args (macro-transformer obj)) - '((required ...)))) - (else #f))) - -(define (arguments proc) - (cond - ((is-a? proc ) (generic-args proc)) - ((procedure-property proc 'arglist) => arglist->args) - ((procedure-source proc) => source->args) - ((program? proc) ((@ (system vm program) program-arguments) proc)) - ((procedure-property proc 'arity) => 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 (arity->args art) - (let ((req (car art)) - (opt (cadr art)) - (rest (caddr art))) - `(,@(if (> req 0) (list (cons 'required (gen-arg-names 1 req))) '()) - ,@(if (> opt 0) (list (cons 'optional (gen-arg-names (+ 1 req) opt))) '()) - ,@(if rest (list (cons 'rest 'rest)) '())))) - -(define (gen-arg-names fst count) - (map (lambda (n) (string->symbol (format "arg-~A" (+ fst n)))) - (iota (max count 1)))) - -(define (arglist->args arglist) - `((required . ,(car arglist)) - (optional . ,(cadr arglist)) - (keyword . ,(caddr arglist)) - (rest . ,(car (cddddr arglist))))) - -(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) (null? methods)) '((rest . rest))) - ((and (null? srcs) - (not (null? methods)) - (method-procedure (car methods))) - => arguments) - ((not (null? srcs)) (source->args (car (sort! srcs src>)))) - (else '((rest . rest)))))) - -(define (completions prefix . context) - (let ((context (and (not (null? context)) (car context))) - (prefix (string-append "^" (regexp-quote prefix)))) - (append (filter (lambda (s) (string-match prefix s)) - (map symbol->string (local-bindings context))) - (sort! (map symbol->string (apropos-internal prefix)) string (length f) 2) (cddr f) '())) - (let loop ((form form) (bindings '())) - (cond ((not (pair? form)) bindings) - ((list? (car form)) - (loop (cdr form) (append (local-bindings (car form)) bindings))) - ((and (list? form) (< (length form) 2)) bindings) - ((memq (car form) '(define define* lambda)) - (loop (body form) (append (pair->list (cadr form)) bindings))) - ((and (memq (car form) '(let let* letrec letrec*)) - (list? (cadr form))) - (loop (body form) (append (map car (cadr form)) bindings))) - ((and (eq? 'let (car form)) (symbol? (cadr form))) - (loop (cons 'let (body form)) (cons (cadr form) bindings))) - (else (loop (cdr form) bindings))))) - -(define (module-location name) - (make-location (module-filename name) #f)) - -(define (symbol-location sym) - (cond ((symbol-module sym) => module-location) - (else '()))) - -(define (make-location file line) - (list (cons 'file (if (string? file) file '())) - (cons 'line (if (number? line) (+ 1 line) '())))) - -(define module-filename (@@ (ice-9 session) module-filename)) - -(define (docstring sym 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))) - (newline) - (if doc (display doc)))))) - -(define (obj-signature sym obj) - (let ((args (obj-args obj))) - (and args (signature sym args)))) - -(define (symbol-documentation sym) - (let ((obj (symbol->obj sym))) - (if obj - `((signature . ,(or (obj-signature sym obj) sym)) - (docstring . ,(docstring sym obj)))))) - -(define (all-modules) - (let ((roots ((@@ (ice-9 session) root-modules)))) - (sort! (map (lambda (m) - (format "~A" (module-name m))) - (fold (lambda (m all) - (append (all-child-modules m) all)) - roots - roots)) - stringstring l) (symbol->string r))))) - (sort! syms cmp))) - -(define (maybe-module-interface mod-name) - (catch #t - (lambda () (resolve-interface mod-name)) - (lambda args (resolve-module mod-name)))) - -(define (classify-module-object name var elts) - (let ((obj (and (variable-bound? var) - (variable-ref var)))) - (cond ((not obj) elts) - ((and (module? obj) (eq? (module-kind obj) 'directory)) - (list (cons name (car elts)) - (cadr elts) - (caddr elts))) - ((or (procedure? obj) (program? obj) (macro? obj)) - (list (car elts) - (cons name (cadr elts)) - (caddr elts))) - (else (list (car elts) - (cadr elts) - (cons name (caddr elts))))))) - -;;; introspection.scm ends here diff --git a/scheme/guile/geiser/modules.scm b/scheme/guile/geiser/modules.scm new file mode 100644 index 0000000..13a1cdd --- /dev/null +++ b/scheme/guile/geiser/modules.scm @@ -0,0 +1,102 @@ +;; modules.scm -- module metadata + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Mon Mar 02, 2009 02:00 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Comentary: + +;; Utilities for accessing metadata about modules. + +;;; Code: + +(define-module (geiser modules) + #:export (symbol-module + module-filename + all-modules + module-children + module-location) + #:use-module (geiser utils) + #:use-module (ice-9 regex) + #:use-module (ice-9 session) + #:use-module (srfi srfi-1)) + +(define (symbol-module sym) + (and sym + (call/cc + (lambda (k) + (apropos-fold (lambda (module name var init) + (if (eq? name sym) (k (module-name module)) init)) + #f + (regexp-quote (symbol->string sym)) + (apropos-fold-accessible (current-module))))))) + +(define (module-location name) + (make-location (module-filename name) #f)) + +(define module-filename (@@ (ice-9 session) module-filename)) + +(define (all-modules) + (let ((roots ((@@ (ice-9 session) root-modules)))) + (sort! (map (lambda (m) + (format "~A" (module-name m))) + (fold (lambda (m all) + (append (all-child-modules m) all)) + roots + roots)) + string +;; Start date: Mon Mar 02, 2009 01:48 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Comentary: + +;; Some utilities used by other modules. + +;;; Code: + +(define-module (geiser utils) + #:export (make-location + symbol->object + pair->list + sort-symbols!)) + +(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))) + +;;; utils.scm ends here diff --git a/scheme/guile/geiser/xref.scm b/scheme/guile/geiser/xref.scm new file mode 100644 index 0000000..2cd4d80 --- /dev/null +++ b/scheme/guile/geiser/xref.scm @@ -0,0 +1,37 @@ +;; xref.scm -- cross-referencing utilities + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Mon Mar 02, 2009 02:37 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Comentary: + +;; Procedures to locate symbols and their xrefs. + +;;; Code: + +(define-module (geiser xref) + #:export (symbol-location + generic-methods) + #:use-module (geiser utils) + #:use-module (geiser modules)) + +(define (symbol-location sym) + (cond ((symbol-module sym) => module-location) + (else '()))) + +;;; xref.scm ends here -- cgit v1.2.3