/[gcl]/gcl/lsp/gcl_module.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_module.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
1    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
2    
3    ;; This file is part of GNU Common Lisp, herein referred to as GCL
4    ;;
5    ;; GCL is free software; you can redistribute it and/or modify it under
6    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7    ;; the Free Software Foundation; either version 2, or (at your option)
8    ;; any later version.
9    ;;
10    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
11    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
13    ;; License for more details.
14    ;;
15    ;; You should have received a copy of the GNU Library General Public License
16    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
17    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
18    
19    
20    ;;;;    module.lsp
21    ;;;;
22    ;;;;                            module routines
23    
24    
25    (in-package 'lisp)
26    
27    (export '(*modules* provide require))
28    (export 'documentation)
29    (export '(variable function structure type setf))
30    
31    (in-package 'system)
32    
33    
34    (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
35    
36    
37    (defvar *modules* nil)
38    
39    
40    (defun provide (module-name)
41      (setq *modules*
42            (adjoin (string module-name)
43                    *modules*
44                    :test #'string=)))
45    
46    
47    (defun require (module-name
48                    &optional (pathname (string-downcase (string module-name))))
49      (let ((*default-pathname-defaults* #""))
50        (unless (member (string module-name)
51                        *modules*
52                        :test #'string=)
53                (if (atom pathname)
54                    (load pathname)
55                    (do ((p pathname (cdr p)))
56                        ((endp p))
57                      (load (car p)))))))
58              
59    
60    (defun documentation (symbol doc-type)
61      (case doc-type
62        (variable (get symbol 'variable-documentation))
63        (function (get symbol 'function-documentation))
64        (structure (get symbol 'structure-documentation))
65        (type (get symbol 'type-documentation))
66        (setf (get symbol 'setf-documentation))
67        (t
68         (if (packagep symbol)
69             (get (find-symbol (package-name symbol) :keyword) 'package-documentation)
70           (error "~S is an illegal documentation type." doc-type)))))
71    
72    
73    (defun find-documentation (body)
74      (if (or (endp body) (endp (cdr body)))
75          nil
76          (let ((form (macroexpand (car body))))
77            (if (stringp form)
78                form
79                (if (and (consp form)
80                         (eq (car form) 'declare))
81                    (find-documentation (cdr body))
82                    nil)))))
83    
84    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26