[armedbear-cvs] r14369 - trunk/abcl/src/org/armedbear/lisp
mevenson at common-lisp.net
mevenson at common-lisp.net
Wed Feb 13 19:01:25 UTC 2013
Author: mevenson
Date: Wed Feb 13 11:01:20 2013
New Revision: 14369
Log:
Implementation of autoloader for SETF generalized references.
Fixes #296. Fixes #266. Fixes #228.
For forms which set the symbol properties of SETF-EXPANDER or
SETF-FUNCTION to function definitions, places stub of type
AutoloadGeneralizedReference to be resolved when first invoked.
Added:
trunk/abcl/src/org/armedbear/lisp/AutoloadGeneralizedReference.java
Modified:
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/Lisp.java
trunk/abcl/src/org/armedbear/lisp/Primitives.java
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java Tue Feb 12 01:56:45 2013 (r14368)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Wed Feb 13 11:01:20 2013 (r14369)
@@ -43,7 +43,7 @@
protected final String fileName;
protected final String className;
- private final Symbol symbol;
+ protected final Symbol symbol;
protected Autoload(Symbol symbol)
{
@@ -262,7 +262,7 @@
{
StringBuilder sb = new StringBuilder();
sb.append(symbol.princToString());
- sb.append(" \"");
+ sb.append(" stub to be autoloaded from \"");
if (className != null) {
int index = className.lastIndexOf('.');
if (index >= 0)
@@ -272,12 +272,13 @@
sb.append(".class");
} else
sb.append(getFileName());
+ sb.append("\"");
return unreadableString(sb.toString());
}
public static final Primitive AUTOLOAD = new pf_autoload();
@DocString(name="autoload",
- args="symbol-or-symbols filename",
+ args="symbol-or-symbols &optional filename",
doc="Setup the autoload for SYMBOL-OR-SYMBOLS optionally corresponding to FILENAME.")
private static final class pf_autoload extends Primitive {
pf_autoload() {
@@ -731,5 +732,9 @@
autoload(PACKAGE_JAVA, "%jget-property-value", "JavaBeans", false);
autoload(PACKAGE_JAVA, "%jset-property-value", "JavaBeans", false);
+
+ autoload(PACKAGE_EXT, "autoload-setf-expander", "AutoloadGeneralizedReference", true);
+ autoload(PACKAGE_EXT, "autoload-setf-function", "AutoloadGeneralizedReference", true);
+ autoload(PACKAGE_EXT, "autoload-ref-p", "AutoloadGeneralizedReference", true);
}
}
Added: trunk/abcl/src/org/armedbear/lisp/AutoloadGeneralizedReference.java
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/abcl/src/org/armedbear/lisp/AutoloadGeneralizedReference.java Wed Feb 13 11:01:20 2013 (r14369)
@@ -0,0 +1,234 @@
+/*
+ * AutoloadGeneralizedReference.java
+ *
+ * Copyright (C) 2014 Mark Evenson
+ * $Id$
+ *
+ * This program 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 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program 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, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *
+ * As a special exception, the copyright holders of this library give you
+ * permission to link this library with independent modules to produce an
+ * executable, regardless of the license terms of these independent
+ * modules, and to copy and distribute the resulting executable under
+ * terms of your choice, provided that you also meet, for each linked
+ * independent module, the terms and conditions of the license of that
+ * module. An independent module is a module which is not derived from
+ * or based on this library. If you modify this library, you may extend
+ * this exception to your version of the library, but you are not
+ * obligated to do so. If you do not wish to do so, delete this
+ * exception statement from your version.
+ */
+
+package org.armedbear.lisp;
+
+import static org.armedbear.lisp.Lisp.*;
+
+public final class AutoloadGeneralizedReference extends Autoload
+{
+ Symbol indicator;
+ private AutoloadGeneralizedReference(Symbol symbol, Symbol indicator, String filename) {
+ super(symbol, filename, null);
+ this.indicator = indicator;
+ }
+
+ @Override
+ public void load()
+ {
+ Load.loadSystemFile(getFileName(), true);
+ }
+
+ static final Symbol SETF_EXPANDER = PACKAGE_SYS.intern("SETF-EXPANDER");
+ public static final Primitive AUTOLOAD_SETF_EXPANDER = new pf_autoload_setf_expander();
+ @DocString(
+ name="autoload-setf-expander",
+ args="symbol-or-symbols filename",
+ doc="Setup the autoload for SYMBOL-OR-SYMBOLS on the setf-expander from FILENAME."
+ )
+ private static final class pf_autoload_setf_expander extends Primitive {
+ pf_autoload_setf_expander() {
+ super("autoload-setf-expander", PACKAGE_EXT, true);
+ }
+ @Override
+ public LispObject execute(LispObject first, LispObject second) {
+ final String filename = second.getStringValue();
+ return installAutoloadGeneralizedReference(first, SETF_EXPANDER, filename);
+ }
+ };
+
+ static final Symbol SETF_FUNCTION = PACKAGE_SYS.intern("SETF-FUNCTION");
+ public static final Primitive AUTOLOAD_SETF_FUNCTION = new pf_autoload_setf_function();
+ @DocString(
+ name="autoload-setf-function",
+ args="symbol-or-symbols filename",
+ doc="Setup the autoload for SYMBOL-OR-SYMBOLS on the setf-function from FILENAME."
+ )
+ private static final class pf_autoload_setf_function extends Primitive {
+ pf_autoload_setf_function() {
+ super("autoload-setf-function", PACKAGE_EXT, true);
+ }
+ @Override
+ public LispObject execute(LispObject first, LispObject second) {
+ final String filename = second.getStringValue();
+ return installAutoloadGeneralizedReference(first, SETF_FUNCTION, filename);
+ }
+ };
+
+ public static final Primitive AUTOLOAD_REF_P = new pf_autoload_ref_p();
+ @DocString(
+ name="autoload-ref-p",
+ args="symbol",
+ doc="Boolean predicate for whether SYMBOL has generalized reference functions which need to be resolved."
+ )
+ private static final class pf_autoload_ref_p extends Primitive {
+ pf_autoload_ref_p() {
+ super("autoload-ref-p", PACKAGE_EXT, true, "symbol");
+ }
+ @Override
+ public LispObject execute(LispObject arg) {
+ LispObject list = checkSymbol(arg).getPropertyList();
+ while (list != NIL) {
+ if (list.car() instanceof AutoloadGeneralizedReference) {
+ return T;
+ }
+
+ list = list.cdr();
+ }
+ return NIL;
+ }
+ };
+
+
+ private static final LispObject installAutoloadGeneralizedReference(LispObject first,
+ Symbol indicator,
+ String filename)
+ {
+ if (first instanceof Symbol) {
+ Symbol symbol = checkSymbol(first);
+ install(symbol, indicator, filename);
+ return T;
+ }
+ if (first instanceof Cons) {
+ for (LispObject list = first; list != NIL; list = list.cdr()) {
+ Symbol symbol = checkSymbol(list.car());
+ install(symbol, indicator, filename);
+ }
+ return T;
+ }
+ return error(new TypeError(first));
+ }
+
+ private static LispObject install(Symbol symbol, Symbol indicator, String filename) {
+ if (get(symbol, indicator) == NIL) {
+ return Primitives.PUT.execute(symbol, indicator,
+ new AutoloadGeneralizedReference(symbol, indicator, filename));
+ } else {
+ return NIL;
+ }
+
+ }
+ @Override
+ public LispObject execute()
+ {
+ load();
+ return get(symbol, indicator, null).execute();
+ }
+
+ @Override
+ public LispObject execute(LispObject arg)
+ {
+ load();
+ return get(symbol, indicator, null).execute(arg);
+ }
+
+ @Override
+ public LispObject execute(LispObject first, LispObject second)
+
+ {
+ load();
+ return get(symbol, indicator, null).execute(first, second);
+ }
+
+ @Override
+ public LispObject execute(LispObject first, LispObject second,
+ LispObject third)
+
+ {
+ load();
+ return get(symbol, indicator, null).execute(first, second, third);
+ }
+
+ @Override
+ public LispObject execute(LispObject first, LispObject second,
+ LispObject third, LispObject fourth)
+
+ {
+ load();
+ return get(symbol, indicator, null).execute(first, second, third, fourth);
+ }
+
+ @Override
+ public LispObject execute(LispObject first, LispObject second,
+ LispObject third, LispObject fourth,
+ LispObject fifth)
+
+ {
+ load();
+ return get(symbol, indicator, null).execute(first, second, third, fourth, fifth);
+ }
+
+ @Override
+ public LispObject execute(LispObject first, LispObject second,
+ LispObject third, LispObject fourth,
+ LispObject fifth, LispObject sixth)
+
+ {
+ load();
+ return get(symbol, indicator, null).execute(first, second, third, fourth, fifth, sixth);
+ }
+
+ @Override
+ public LispObject execute(LispObject first, LispObject second,
+ LispObject third, LispObject fourth,
+ LispObject fifth, LispObject sixth,
+ LispObject seventh)
+
+ {
+ load();
+ return symbol.execute(first, second, third, fourth, fifth, sixth,
+ seventh);
+ }
+
+ @Override
+ public LispObject execute(LispObject first, LispObject second,
+ LispObject third, LispObject fourth,
+ LispObject fifth, LispObject sixth,
+ LispObject seventh, LispObject eighth)
+
+ {
+ load();
+ return get(symbol, indicator, null).execute(first, second, third, fourth, fifth, sixth,
+ seventh, eighth);
+ }
+
+ @Override
+ public LispObject execute(LispObject[] args)
+ {
+ load();
+ return get(symbol, indicator, null).execute(args);
+ }
+
+
+
+}
Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Feb 12 01:56:45 2013 (r14368)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Feb 13 11:01:20 2013 (r14369)
@@ -2769,6 +2769,7 @@
loadClass("org.armedbear.lisp.CompiledClosure");
loadClass("org.armedbear.lisp.Autoload");
loadClass("org.armedbear.lisp.AutoloadMacro");
+ loadClass("org.armedbear.lisp.AutoloadGeneralizedReference");
loadClass("org.armedbear.lisp.cxr");
loadClass("org.armedbear.lisp.Do");
loadClass("org.armedbear.lisp.dolist");
Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Feb 12 01:56:45 2013 (r14368)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Wed Feb 13 11:01:20 2013 (r14369)
@@ -3574,7 +3574,7 @@
};
// ### put symbol indicator value => value
- private static final Primitive PUT = new pf_put();
+ public static final Primitive PUT = new pf_put();
private static final class pf_put extends Primitive {
pf_put() {
super("put", PACKAGE_SYS, true);
Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Tue Feb 12 01:56:45 2013 (r14368)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Wed Feb 13 11:01:20 2013 (r14369)
@@ -49,9 +49,9 @@
(in-package :cl-user)
-#+abcl
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (documentation 'car 'function)) ;; workaround (SETF DOCUMENTATION) autoloader bug
+;; #+abcl
+;; (eval-when (:load-toplevel :compile-toplevel :execute)
+;; (documentation 'car 'function)) ;; workaround (SETF DOCUMENTATION) autoloader bug
#+cmu
(eval-when (:load-toplevel :compile-toplevel :execute)
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Feb 12 01:56:45 2013 (r14368)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Feb 13 11:01:20 2013 (r14369)
@@ -1780,7 +1780,10 @@
;; also, resolving the symbol isn't
;; a good option either: we've seen that lead to
;; recursive loading of the same file
- (not (autoloadp function-name))))
+ (and (not (autoloadp function-name))
+ (and (consp function-name)
+ (eq 'setf (first function-name))
+ (not (autoload-ref-p (second function-name)))))))
(error 'program-error
:format-control "~A already names an ordinary function, macro, or special operator."
:format-arguments (list function-name)))
@@ -4478,7 +4481,10 @@
(unless (classp generic-function-class)
(setf generic-function-class (find-class generic-function-class)))
(when (and (null *clos-booting*) (fboundp function-name))
- (if (autoloadp function-name)
+ (if (or (autoloadp function-name)
+ (and (consp function-name)
+ (eq 'setf (first function-name))
+ (autoload-ref-p (second function-name))))
(fmakunbound function-name)
(error 'program-error
:format-control "~A already names an ordinary function, macro, or special operator."
Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Tue Feb 12 01:56:45 2013 (r14368)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Feb 13 11:01:20 2013 (r14369)
@@ -46,6 +46,8 @@
(defvar *toplevel-functions*)
(defvar *toplevel-macros*)
(defvar *toplevel-exports*)
+(defvar *toplevel-setf-expanders*)
+(defvar *toplevel-setf-functions*)
(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
@@ -423,6 +425,10 @@
(note-toplevel-form form)
(note-name-defined (second form))
(push (second form) *toplevel-functions*)
+ (when (and (consp (second form))
+ (eq 'setf (first (second form))))
+ (push (second (second form))
+ *toplevel-setf-functions*))
(let ((*compile-print* nil))
(process-toplevel-form (macroexpand-1 form *compile-file-environment*)
stream compile-time-too))
@@ -550,6 +556,9 @@
(push name jvm::*functions-defined-in-current-file*)
(note-name-defined name)
(push name *toplevel-functions*)
+ (when (and (consp name)
+ (eq 'setf (first name)))
+ (push (second name) *toplevel-setf-functions*))
;; If NAME is not fbound, provide a dummy definition so that
;; getSymbolFunctionOrDie() will succeed when we try to verify that
;; functions defined later in the same file can be loaded correctly.
@@ -605,6 +614,11 @@
(return-from process-toplevel-form))
(when (and (symbolp operator)
(macro-function operator *compile-file-environment*))
+ (when (eq operator 'define-setf-expander) ;; ??? what if the symbol is package qualified?
+ (push (second form) *toplevel-setf-expanders*))
+ (when (and (eq operator 'defsetf) ;; ??? what if the symbol is package qualified?
+ (consp (third form))) ;; long form of DEFSETF
+ (push (second form) *toplevel-setf-expanders*))
(note-toplevel-form form)
;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in
;; case the form being expanded expands into something that needs
@@ -613,7 +627,6 @@
(process-toplevel-form (macroexpand-1 form *compile-file-environment*)
stream compile-time-too))
(return-from process-toplevel-form))
-
(cond
((and (symbolp operator)
(not (special-operator-p operator))
@@ -717,7 +730,8 @@
(defun compile-from-stream (in output-file temp-file temp-file2
extract-toplevel-funcs-and-macros
- functions-file macros-file exports-file)
+ functions-file macros-file exports-file
+ setf-functions-file setf-expanders-file)
(let* ((*compile-file-pathname* (make-pathname :defaults (pathname in)
:version nil))
(*compile-file-truename* (make-pathname :defaults (truename in)
@@ -777,7 +791,8 @@
(if (symbolp func-name)
(symbol-package func-name)
T))
- (remove-duplicates *toplevel-functions*)))
+ (remove-duplicates
+ *toplevel-functions*)))
(when *toplevel-functions*
(with-open-file (f-out functions-file
:direction :output
@@ -811,7 +826,33 @@
:if-does-not-exist :create
:if-exists :supersede)
(let ((*package* (find-package :keyword)))
- (write *toplevel-exports* :stream e-out)))))
+ (write *toplevel-exports* :stream e-out))))
+ (setf *toplevel-setf-functions*
+ (remove-if-not (lambda (sym)
+ (if (symbolp sym)
+ (symbol-package sym)
+ T))
+ (remove-duplicates *toplevel-setf-functions*)))
+ (when *toplevel-setf-functions*
+ (with-open-file (e-out setf-functions-file
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (let ((*package* (find-package :keyword)))
+ (write *toplevel-setf-functions* :stream e-out))))
+ (setf *toplevel-setf-expanders*
+ (remove-if-not (lambda (sym)
+ (if (symbolp sym)
+ (symbol-package sym)
+ T))
+ (remove-duplicates *toplevel-setf-expanders*)))
+ (when *toplevel-setf-expanders*
+ (with-open-file (e-out setf-expanders-file
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (let ((*package* (find-package :keyword)))
+ (write *toplevel-setf-expanders* :stream e-out)))))
(with-open-file (in temp-file :direction :input :external-format *fasl-external-format*)
(with-open-file (out temp-file2 :direction :output
:if-does-not-exist :create
@@ -900,14 +941,19 @@
(functions-file (pathname-with-type output-file "funcs"))
(macros-file (pathname-with-type output-file "macs"))
(exports-file (pathname-with-type output-file "exps"))
+ (setf-functions-file (pathname-with-type output-file "setf-functions"))
+ (setf-expanders-file (pathname-with-type output-file "setf-expanders"))
*toplevel-functions*
*toplevel-macros*
- *toplevel-exports*)
+ *toplevel-exports*
+ *toplevel-setf-functions*
+ *toplevel-setf-expanders*)
(with-open-file (in input-file :direction :input :external-format external-format)
(multiple-value-bind (output-file-truename warnings-p failure-p)
(compile-from-stream in output-file temp-file temp-file2
extract-toplevel-funcs-and-macros
- functions-file macros-file exports-file)
+ functions-file macros-file exports-file
+ setf-functions-file setf-expanders-file)
(values (truename output-file) warnings-p failure-p))))))
(defun compile-file-if-needed (input-file &rest allargs &key force-compile
Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Tue Feb 12 01:56:45 2013 (r14368)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Feb 13 11:01:20 2013 (r14369)
@@ -148,12 +148,11 @@
(remove-if (lambda (x)
(null (cdr x)))
(mapcar (lambda (x)
- (cons (car x)
+ (cons (car x)
(remove-if-not (lambda (x)
- ;;; ### TODO: Support SETF functions
- (and (symbolp x)
- (eq (symbol-package x)
- filter-package)))
+ (and (symbolp x)
+ (eq (symbol-package x)
+ filter-package)))
(cdr x))))
filesets-symbols))))
(write-autoloader stream package type filtered-filesets)))
@@ -174,34 +173,40 @@
(push (list base-name function-name) all-functions))))))))
(defun generate-autoloads (symbol-files-pathspec)
- (flet ((filter-combos (combos)
- (remove-multi-combo-symbols
- (remove-if (lambda (x)
- ;; exclude the symbols from the files
- ;; below: putting autoloaders on some of
- ;; the symbols conflicts with the bootstrapping
- ;; Primitives which have been defined Java-side
- (member x '( ;; function definitions to be excluded
- "fdefinition" "early-defuns"
- "require" "signal" "restart"
-
- ;; extensible sequences override
- ;; lots of default functions;
- ;; java-collections implements
- ;; extensible sequences
- "extensible-sequences-base"
- "extensible-sequences" "java-collections"
-
- ;; macro definitions to be excluded
- "macros" ;; "backquote"
- "precompiler")
- :test #'string=))
- combos
- :key #'first)))
- (symbols-pathspec (filespec)
- (merge-pathnames filespec symbol-files-pathspec)))
+ (labels ((filter-combos (combos)
+ (remove-multi-combo-symbols
+ (remove-if (lambda (x)
+ ;; exclude the symbols from the files
+ ;; below: putting autoloaders on some of
+ ;; the symbols conflicts with the bootstrapping
+ ;; Primitives which have been defined Java-side
+ (member x '( ;; function definitions to be excluded
+ "fdefinition" "early-defuns"
+ "require" "signal" "restart"
+
+ ;; extensible sequences override
+ ;; lots of default functions;
+ ;; java-collections implements
+ ;; extensible sequences
+ "extensible-sequences-base"
+ "extensible-sequences" "java-collections"
+
+ ;; macro definitions to be excluded
+ "macros" ;; "backquote"
+ "precompiler")
+ :test #'string=))
+ combos
+ :key #'first)))
+ (filter-setf-combos (combos)
+ (filter-combos
+ (remove-multi-combo-symbols
+ (remove-if (lambda (x) (member x '("clos") :test #'string=)) combos :key #'first))))
+ (symbols-pathspec (filespec)
+ (merge-pathnames filespec symbol-files-pathspec)))
(let ((funcs (filter-combos (load-combos (symbols-pathspec "*.funcs"))))
(macs (filter-combos (load-combos (symbols-pathspec "*.macs"))))
+ (setf-functions (filter-setf-combos (load-combos (symbols-pathspec "*.setf-functions"))))
+ (setf-expanders (filter-setf-combos (load-combos (symbols-pathspec "*.setf-expanders"))))
(exps (filter-combos (load-combos (symbols-pathspec "*.exps")))))
(with-open-file (f (symbols-pathspec "autoloads-gen.lisp")
:direction :output :if-does-not-exist :create
@@ -243,8 +248,19 @@
(write-line ";; MACROS" f)
(terpri f)
(write-package-filesets f package 'ext:autoload-macro
- (combos-to-fileset-symbols macs)))))))
+ (combos-to-fileset-symbols macs))
+ (terpri f)
+
+ (write-line ";; SETF-FUNCTIONS" f)
+ (terpri f)
+ (write-package-filesets f package 'ext:autoload-setf-function
+ (combos-to-fileset-symbols setf-functions))
+ (terpri f)
+ (write-line ";; SETF-EXPANDERS" f)
+ (terpri f)
+ (write-package-filesets f package 'ext:autoload-setf-expander
+ (combos-to-fileset-symbols setf-expanders)))))))
;;
;; --- End of autoloads.lisp
More information about the armedbear-cvs
mailing list