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.
parent ca67b27f
......@@ -43,7 +43,7 @@ public class Autoload extends Function
protected final String fileName;
protected final String className;
private final Symbol symbol;
protected final Symbol symbol;
protected Autoload(Symbol symbol)
{
......@@ -262,7 +262,7 @@ public class Autoload extends Function
{
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 @@ public class Autoload extends Function
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 @@ public class Autoload extends Function
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);
}
}
/*
* 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);
}
}
......@@ -2769,6 +2769,7 @@ public final class Lisp
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");
......
......@@ -3574,7 +3574,7 @@ public final class Primitives {
};
// ### 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);
......
......@@ -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)
......
......@@ -1780,7 +1780,10 @@ compare the method combination name to the symbol 'standard.")
;; 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 @@ or T when any keyword is acceptable due to presence of
(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."
......
......@@ -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 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(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 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(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 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(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 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(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 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(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 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(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 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
: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 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment