source: trunk/abcl/src/org/armedbear/lisp/late-setf.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.


Source information for ABCL is now recorded on the SYS::SOURCE
property. The appropiate information for type is recorded by the

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. <>

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 <> .
<> :merges <> .

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 4.5 KB
1;;; late-setf.lisp
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: late-setf.lisp 14914 2016-11-24 10:31:17Z mevenson $
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.
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; GNU General Public License for more details.
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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
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.
32;;; From CMUCL/SBCL.
34(in-package #:system)
36(defmacro define-setf-expander (access-fn lambda-list &body body)
37  (require-type access-fn 'symbol)
38  (let ((whole (gensym "WHOLE-"))
39  (environment (gensym "ENV-")))
40    (multiple-value-bind (body local-decs doc)
41       (parse-defmacro lambda-list whole body access-fn
42           'define-setf-expander
43           :environment environment)
44      `(progn
45   (record-source-information-for-type ',access-fn :setf-expander)
46   (eval-when (:compile-toplevel :load-toplevel :execute)
47     ,@(when doc
48         `((%set-documentation ',access-fn 'setf ,doc)))
49     (setf (get ',access-fn 'setf-expander)
50     #'(lambda (,whole ,environment)
51         ,@local-decs
52         (block ,access-fn ,body)))
53     ',access-fn)))))
55(define-setf-expander values (&rest places &environment env)
56  (let ((setters ())
57        (getters ())
58        (all-dummies ())
59        (all-vals ())
60        (newvals ()))
61    (dolist (place places)
62      (multiple-value-bind (dummies vals newval setter getter)
63        (get-setf-expansion place env)
64        (setf all-dummies (append all-dummies dummies (cdr newval))
65              all-vals (append all-vals vals
66                               (mapcar (constantly nil) (cdr newval)))
67              newvals (append newvals (list (car newval))))
68        (push setter setters)
69        (push getter getters)))
70    (values all-dummies all-vals newvals
71            `(values ,@(reverse setters)) `(values ,@(reverse getters)))))
73(defun make-gensym-list (n)
74  (let ((list ()))
75    (dotimes (i n list)
76      (push (gensym) list))))
78(define-setf-expander getf (place prop &optional default &environment env)
79  (multiple-value-bind (temps values stores set get)
80    (get-setf-expansion place env)
81    (let ((newval (gensym))
82          (ptemp (gensym))
83          (def-temp (if default (gensym))))
84      (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
85              `(,@values ,prop ,@(if default `(,default)))
86              `(,newval)
87              `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
88                 ,set
89                 ,newval)
90              `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
92(define-setf-expander apply (functionoid &rest args)
93  (let ((function (second functionoid))
94        (new-var (gensym))
95        (vars (make-gensym-list (length args))))
96    (values vars args (list new-var)
97            `(apply #'(setf ,function) ,new-var ,@vars)
98            `(apply #',function ,@vars))))
100(define-setf-expander the (type place &environment env)
101  (multiple-value-bind (temps subforms store-vars setter getter)
102    (get-setf-expansion place env)
103    (values temps subforms store-vars
104            `(multiple-value-bind ,store-vars
105               (the ,type (values ,@store-vars))
106               ,setter)
107            `(the ,type ,getter))))
109(defun (setf macro-function) (new-function symbol &optional environment)
110  (declare (ignore environment))
111  (let ((macro (make-macro symbol (or (precompile nil new-function)
112                                      new-function))))
113    (fset symbol macro)
114    macro))
Note: See TracBrowser for help on using the repository browser.