source: trunk/abcl/src/org/armedbear/lisp/defpackage.lisp

Last change on this file was 14914, checked in by Mark Evenson, 5 years ago

Dramatically improve source recording on SYS::SOURCE plist for a symbol (Alan Ruttenberg)

The interface to recording information on the SYS:%SOURCE plist for a
symbol is now deprecated and will be removed with abcl-1.7.

Implementation


Source information for ABCL is now recorded on the SYS::SOURCE
property. The appropiate information for type is recorded by the
SYS::RECORD-SOURCE-INFORMATION-BY-TYPE function:

record-source-information-by-type (name type &optional source-pathname source-position)

TYPE is either a symbol or list.

Source information for functions, methods, and generic functions are
represented as lists of the following form:

(:generic-function function-name)
(:function function-name)
(:method method-name qualifiers specializers)

Where FUNCTION-NAME or METHOD-NAME can be a either be of the form
'symbol or '(setf symbol).

Source information for all other forms have a symbol for TYPE which is
one of the following:

:class, :variable, :condition, :constant, :compiler-macro, :macro
:package, :structure, :type, :setf-expander, :source-transform

These values follow SBCL'S implemenation in SLIME
c.f. <https://github.com/slime/slime/blob/bad2acf672c33b913aabc1a7facb9c3c16a4afe9/swank/sbcl.lisp#L748>

Modifications are in two places, one at the definitions, calling
record-source-information-by-type and then again in the file-compiler,
which writes forms like

(put 'source name (cons (list type pathname position) (get 'source name)))

In theory this can lead to redundancy if a fasl is loaded again and
again. I'm not sure how to fix this yet. Forms in the loader get
called early in build when many of the sequence functions aren't
present. Will probably just filter when presenting in slime.

<> :closes <http://abcl.org/trac/ticket/421> .
<> :merges <https://github.com/armedbear/abcl/pull/5> .

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 7.0 KB
Line 
1;;; defpackage.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: defpackage.lisp 14914 2016-11-24 10:31:17Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "SYSTEM")
33
34;;; Adapted from CMUCL.
35
36(defun designated-package-name (designator)
37  (cond ((packagep designator)
38         (package-name designator))
39        (t
40         (string designator))))
41
42(defun stringify-names (names)
43  (mapcar #'string names))
44
45(defun check-disjoint (&rest args)
46  (let ((rest-args args))
47    (dolist (arg1 args)
48      (let ((key1 (car arg1))
49            (set1 (cdr arg1)))
50        (setq rest-args (cdr rest-args))
51        (dolist (arg2 rest-args)
52          (let* ((key2 (car arg2))
53                 (set2 (cdr arg2))
54                 (common (remove-duplicates (intersection set1 set2 :test #'string=))))
55            (when common
56              (error 'program-error
57                     :format-control
58                     "Parameters ~S and ~S must be disjoint, but have common elements: ~S"
59                     :format-arguments
60                     (list key1 key2 common)))))))))
61
62(defun ensure-available-symbols (symbols)
63   symbols)
64
65(defmacro defpackage (package &rest options)
66  (let ((nicknames nil)
67        (size nil)
68        (shadows nil)
69        (shadowing-imports nil)
70        (use nil)
71        (use-p nil)
72        (imports nil)
73        (interns nil)
74        (exports nil)
75        (local-nicknames nil)
76        (doc nil))
77    (dolist (option options)
78      (unless (consp option)
79        (error 'program-error "bad DEFPACKAGE option: ~S" option))
80      (case (car option)
81        (:nicknames
82         (setq nicknames (stringify-names (cdr option))))
83        (:size
84         (cond (size
85                (error 'program-error "can't specify :SIZE twice"))
86               ((and (consp (cdr option))
87                     (typep (second option) 'unsigned-byte))
88                (setq size (second option)))
89               (t
90                (error 'program-error
91                       "bad :SIZE, must be a positive integer: ~S"
92                       (second option)))))
93        (:shadow
94         (let ((new (stringify-names (cdr option))))
95           (setq shadows (append shadows new))))
96        (:shadowing-import-from
97         (let ((package-name (designated-package-name (cadr option)))
98               (symbol-names (stringify-names (cddr option))))
99           (let ((assoc (assoc package-name shadowing-imports
100                               :test #'string=)))
101             (if assoc
102                 (setf (cdr assoc) (append (cdr assoc) symbol-names))
103                 (setq shadowing-imports
104                       (acons package-name symbol-names shadowing-imports))))))
105        (:use
106         (let ((new (mapcar #'designated-package-name (cdr option))))
107           (setq use (delete-duplicates (nconc use new) :test #'string=))
108           (setq use-p t)))
109        (:import-from
110         (let ((package-name (designated-package-name (cadr option)))
111               (symbol-names (stringify-names (cddr option))))
112           (let ((assoc (assoc package-name imports
113                               :test #'string=)))
114             (if assoc
115                 (setf (cdr assoc) (append (cdr assoc) symbol-names))
116                 (setq imports (acons package-name symbol-names imports))))))
117        (:intern
118         (let ((new (stringify-names (cdr option))))
119           (setq interns (append interns new))))
120        (:export
121         (let ((new (stringify-names (cdr option))))
122           (setq exports (append exports new))))
123        (:documentation
124         (when doc
125           (error 'program-error "can't specify :DOCUMENTATION twice"))
126         (setq doc (coerce (cadr option) 'simple-string)))
127        (:local-nicknames
128         (dolist (nickdecl (cdr option))
129           (unless (= (length nickdecl) 2)
130             (error 'program-error "Malformed local nickname declaration ~A"
131                    nickdecl))
132           (let ((local-nickname (string (first nickdecl)))
133                 (package-name (designated-package-name (second nickdecl))))
134             (when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD")
135                           :test #'string=)
136               (cerror "Continue anyway"
137                       (format nil "Trying to define a local nickname for package ~A"
138                               local-nickname)))
139             (when (member local-nickname (list* package nicknames)
140                           :test #'string=)
141               (cerror "Continue anyway"
142                       "Trying to override the name or a nickname (~A) ~
143                        with a local nickname for another package ~A"
144                       local-nickname package-name))
145             (push (list local-nickname package-name) local-nicknames))))
146        (t
147         (error 'program-error "bad DEFPACKAGE option: ~S" option))))
148    (check-disjoint `(:intern ,@interns) `(:export  ,@exports))
149    (check-disjoint `(:intern ,@interns)
150                    `(:import-from
151                      ,@(apply #'append (mapcar #'rest imports)))
152                    `(:shadow ,@shadows)
153                    `(:shadowing-import-from
154                      ,@(apply #'append (mapcar #'rest shadowing-imports))))
155    `(prog1
156       (%defpackage ,(string package) ',nicknames ',size
157        ',shadows (ensure-available-symbols ',shadowing-imports)
158        ',(if use-p use nil)
159        (ensure-available-symbols ',imports) ',interns ',exports
160        ',local-nicknames ',doc)
161       ,(when (and (symbolp package) (not (keywordp package)))
162    `(record-source-information-for-type ',package :package))
163       (record-source-information-for-type ,(intern (string package) :keyword) :package)
164       )))
Note: See TracBrowser for help on using the repository browser.