Changeset 14378

Timestamp:

02/13/13 19:54:49 (11 years ago)

Author:

Mark Evenson

Message:

Backport r14369 | mevenson | 2013-02-13 20:01:20 +0100 (Wed, 13 Feb 2013) | 7 lines

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.

Does NOT include changes to asdf.

Location:

branches/1.1.x/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (5 diffs)
• AutoloadGeneralizedReference.java (copied) (copied from trunk/abcl/src/org/armedbear/lisp/AutoloadGeneralizedReference.java)
• Lisp.java (modified) (1 diff)
• Primitives.java (modified) (1 diff)
• clos.lisp (modified) (2 diffs)
• compile-file.lisp (modified) (9 diffs)
• compile-system.lisp (modified) (3 diffs)

branches/1.1.x/src/org/armedbear/lisp/Autoload.java

@@ -44 +44 @@
     protected final String className;
 
-    private final Symbol symbol;
+    protected final Symbol symbol;
 
     protected Autoload(Symbol symbol)
@@ -263 +263 @@
         StringBuilder sb = new StringBuilder();
         sb.append(symbol.princToString());
-        sb.append(" \"");
+        sb.append(" stub to be autoloaded from \"");
         if (className != null) {
             int index = className.lastIndexOf('.');
@@ -273 +273 @@
         } else
             sb.append(getFileName());
+        sb.append("\"");
         return unreadableString(sb.toString());
     }
@@ -278 +279 @@
     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 {
@@ -732 +733 @@
         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);
     }
 }

branches/1.1.x/src/org/armedbear/lisp/Lisp.java

@@ -2770 +2770 @@
     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");

branches/1.1.x/src/org/armedbear/lisp/Primitives.java

@@ -3575 +3575 @@
 
     // ### 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() {

branches/1.1.x/src/org/armedbear/lisp/clos.lisp

@@ -1781 +1781 @@
                           ;; 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."
@@ -4479 +4482 @@
     (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

branches/1.1.x/src/org/armedbear/lisp/compile-file.lisp

@@ -47 +47 @@
 (defvar *toplevel-macros*)
 (defvar *toplevel-exports*)
+(defvar *toplevel-setf-expanders*)
+(defvar *toplevel-setf-functions*)
 
 
@@ -424 +426 @@
   (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*)
@@ -551 +557 @@
     (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
@@ -606 +615 @@
       (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
@@ -614 +628 @@
                                  stream compile-time-too))
         (return-from process-toplevel-form))
-
       (cond
         ((and (symbolp operator)
@@ -718 +731 @@
 (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))
@@ -778 +792 @@
                                      (symbol-package func-name)
                                      T))
-                               (remove-duplicates *toplevel-functions*)))
+                               (remove-duplicates
+                            *toplevel-functions*)))
           (when *toplevel-functions*
             (with-open-file (f-out functions-file
@@ -812 +827 @@
                                    :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
@@ -901 +942 @@
            (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))))))
 

branches/1.1.x/src/org/armedbear/lisp/compile-system.lisp

@@ -149 +149 @@
                       (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))))
@@ -175 +174 @@
 
 (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")
@@ -244 +249 @@
           (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)))))))
 
 ;;