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

Diff of /gcl/lsp/gcl_make_defpackage.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    ;;; Thu Aug 12 14:22:09 1993 by Mark Kantrowitz <mkant@cs.cmu.edu>
2    ;;; make-defpackage.lisp -- 1961 bytes
3    
4    ;;; ****************************************************************
5    ;;; Make a Defpackage Form From Package State **********************
6    ;;; ****************************************************************
7    
8    (defun make-defpackage-form (package-name)
9      "Given a package, returns a defpackage form that could recreate the
10       current state of the package, more or less."
11      (let ((package (find-package package-name)))
12        (let* ((name (package-name package))
13               (nicknames (package-nicknames package))
14               (package-use-list (package-use-list package))
15               (use-list (mapcar #'package-name package-use-list))
16               (externs nil)
17               (shadowed-symbols (package-shadowing-symbols package))
18               (imports nil)
19               (shadow-imports nil)
20               (pure-shadow nil)
21               (pure-import nil))
22          (do-external-symbols (sym package) (push (symbol-name sym) externs))
23          (do-symbols (sym package)
24            (unless (or (eq package (symbol-package sym))
25                        (find (symbol-package sym) package-use-list))
26              (push sym imports)))
27          (setq shadow-imports (intersection shadowed-symbols imports))
28          (setq pure-shadow (set-difference shadowed-symbols shadow-imports))
29          (setq pure-import (set-difference imports shadow-imports))
30          `(defpackage ,name
31               ,@(when nicknames `((:nicknames ,@nicknames)))
32               ,@(when use-list `((:use ,@use-list)))
33               ,@(when externs `((:export ,@externs)))
34               ;; skip :intern
35               ,@(when pure-shadow
36                   `((:shadow ,@(mapcar #'symbol-name pure-shadow))))
37               ,@(when shadow-imports
38                   (mapcar #'(lambda (symbol)
39                               `((:shadowing-import-from
40                                  ,(package-name (symbol-package symbol))
41                                  ,(symbol-name symbol))))
42                           shadow-imports))
43               ,@(when pure-import
44                   (mapcar #'(lambda (symbol)
45                               `((:import-from
46                                  ,(package-name (symbol-package symbol))
47                                  ,(symbol-name symbol))))
48                           pure-import))))))
49    
50    ;;; *EOF*

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