From rschlatte at common-lisp.net Tue Apr 2 15:00:10 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 02 Apr 2013 08:00:10 -0700 Subject: [armedbear-cvs] r14454 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Apr 2 07:59:54 2013 New Revision: 14454 Log: Move standard-generic-function slot accessors from Java to Lisp - incremented fasl version since set-generic-function-initial-methods, generic-function-documentation are gone Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/documentation.lisp trunk/abcl/src/org/armedbear/lisp/known-functions.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Mar 29 16:01:36 2013 (r14453) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Tue Apr 2 07:59:54 2013 (r14454) @@ -554,9 +554,6 @@ autoload(PACKAGE_SYS, "%adjust-array", "adjust_array"); autoload(PACKAGE_SYS, "%defpackage", "PackageFunctions"); autoload(PACKAGE_SYS, "%finalize-generic-function", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "%generic-function-lambda-list", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "%generic-function-name", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "set-generic-function-declarations", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%get-output-stream-bytes", "ByteArrayOutputStream"); //AS 20090325 autoload(PACKAGE_SYS, "%get-output-stream-array", "ByteArrayOutputStream"); autoload(PACKAGE_SYS, "%make-array", "make_array"); @@ -580,12 +577,6 @@ autoload(PACKAGE_SYS, "%set-find-class", "LispClass", true); autoload(PACKAGE_SYS, "%set-class-direct-slots", "SlotClass", true); autoload(PACKAGE_SYS, "%set-function-info", "function_info"); - autoload(PACKAGE_SYS, "%set-generic-function-lambda-list", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "%set-generic-function-name", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "%set-gf-required-args", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "%set-gf-optional-args", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "gf-required-args", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "gf-optional-args", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%init-eql-specializations", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%get-arg-specialization", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives"); @@ -645,18 +636,9 @@ autoload(PACKAGE_SYS, "float-nan-p", "FloatFunctions", true); autoload(PACKAGE_SYS, "float-string", "FloatFunctions", true); autoload(PACKAGE_SYS, "function-info", "function_info"); - autoload(PACKAGE_SYS, "%generic-function-argument-precedence-order","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "generic-function-classes-to-emf-table","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "generic-function-documentation","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "generic-function-initial-methods","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "%generic-function-method-class","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "%generic-function-method-combination","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "%generic-function-methods","StandardGenericFunction", true); autoload(PACKAGE_SYS, "get-cached-emf", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "get-cached-slot-location", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "get-function-info-value", "function_info"); - autoload(PACKAGE_SYS, "gf-required-args", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "gf-optional-args", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions"); autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions"); autoload(PACKAGE_SYS, "layout-class", "Layout", true); @@ -677,13 +659,6 @@ autoload(PACKAGE_SYS, "puthash", "HashTableFunctions"); autoload(PACKAGE_SYS, "remove-zip-cache-entry", "ZipCache"); autoload(PACKAGE_SYS, "set-function-info-value", "function_info"); - autoload(PACKAGE_SYS, "set-generic-function-argument-precedence-order","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "set-generic-function-classes-to-emf-table","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "set-generic-function-documentation","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "set-generic-function-initial-methods","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "set-generic-function-method-class","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "set-generic-function-method-combination","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "set-generic-function-methods","StandardGenericFunction", true); autoload(PACKAGE_SYS, "set-slot-definition-allocation", "SlotDefinition", true); autoload(PACKAGE_SYS, "set-slot-definition-allocation-class", "SlotDefinition", true); autoload(PACKAGE_SYS, "set-slot-definition-initargs", "SlotDefinition", true); Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Fri Mar 29 16:01:36 2013 (r14453) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Tue Apr 2 07:59:54 2013 (r14454) @@ -375,7 +375,7 @@ // ### *fasl-version* // internal symbol static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(40)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(41)); // ### *fasl-external-format* // internal symbol @@ -443,7 +443,8 @@ + second.princToString() + "' but expected '" + _FASL_VERSION_.getSymbolValue().princToString() + "' in " - + Symbol.LOAD_PATHNAME.symbolValue(thread).princToString())); + + Symbol.LOAD_PATHNAME.symbolValue(thread).princToString() + + " (try recompiling the file)")); } } Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Fri Mar 29 16:01:36 2013 (r14453) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Tue Apr 2 07:59:54 2013 (r14454) @@ -113,421 +113,6 @@ return super.printObject(); } - // AMOP (p. 216) specifies the following readers as generic functions: - // generic-function-argument-precedence-order - // generic-function-declarations - // generic-function-lambda-list - // generic-function-method-class - // generic-function-method-combination - // generic-function-methods - // generic-function-name - - private static final Primitive _GENERIC_FUNCTION_NAME - = new pf__generic_function_name(); - @DocString(name="%generic-function-name") - private static final class pf__generic_function_name extends Primitive - { - pf__generic_function_name() - { - super("%generic-function-name", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME]; - } - }; - - private static final Primitive _SET_GENERIC_FUNCTION_NAME - = new pf__set_generic_function_name(); - @DocString(name="%set-generic-function-name") - private static final class pf__set_generic_function_name extends Primitive - { - pf__set_generic_function_name() - { - super ("%set-generic-function-name", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = second; - return second; - } - }; - - private static final Primitive _GENERIC_FUNCTION_LAMBDA_LIST - = new pf__generic_function_lambda_list(); - @DocString(name ="%generic-function-lambda-list") - private static final class pf__generic_function_lambda_list extends Primitive { - pf__generic_function_lambda_list() - { - super("%generic-function-lambda-list", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST]; - } - }; - - private static final Primitive _SET_GENERIC_FUNCTION_LAMBDA_LIST - = new pf__set_generic_function_lambda_list(); - @DocString(name="%set-generic-function-lambdalist") - private static final class pf__set_generic_function_lambda_list extends Primitive - { - pf__set_generic_function_lambda_list() - { - super("%set-generic-function-lambda-list", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = second; - return second; - } - }; - - private static final Primitive GF_REQUIRED_ARGS - = new pf_gf_required_args(); - @DocString(name="gf-required-args") - private static final class pf_gf_required_args extends Primitive - { - pf_gf_required_args() - { - super("gf-required-args", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS]; - } - }; - - private static final Primitive _SET_GF_REQUIRED_ARGS - = new pf__set_gf_required_args(); - @DocString(name="%set-gf-required-args") - private static final class pf__set_gf_required_args extends Primitive - { - pf__set_gf_required_args() - { - super("%set-gf-required-args", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - final StandardGenericFunction gf = checkStandardGenericFunction(first); - gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = second; - return second; - } - }; - - private static final Primitive GF_OPTIONAL_ARGS - = new pf_gf_optional_args(); - @DocString(name="gf-optional-args") - private static final class pf_gf_optional_args extends Primitive - { - pf_gf_optional_args() - { - super("gf-optional-args", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS]; - } - }; - - private static final Primitive _SET_GF_OPTIONAL_ARGS - = new pf__set_gf_optional_args(); - @DocString(name="%set-gf-optional-args") - private static final class pf__set_gf_optional_args extends Primitive - { - pf__set_gf_optional_args() - { - super("%set-gf-optional-args", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - final StandardGenericFunction gf = checkStandardGenericFunction(first); - gf.slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS] = second; - return second; - } - }; - - private static final Primitive GENERIC_FUNCTION_INITIAL_METHODS - = new pf_generic_function_initial_methods(); - @DocString(name="generic-function-initial-methods") - private static final class pf_generic_function_initial_methods extends Primitive - { - pf_generic_function_initial_methods() - { - super("generic-function-initial-methods", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS]; - } - }; - - private static final Primitive SET_GENERIC_FUNCTION_INITIAL_METHODS - = new pf_set_generic_function_initial_methods(); - @DocString(name="set-generic-function-initial-methods") - private static final class pf_set_generic_function_initial_methods extends Primitive - { - pf_set_generic_function_initial_methods() - { - super("set-generic-function-initial-methods", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = second; - return second; - } - }; - - private static final Primitive GENERIC_FUNCTION_METHODS - = new pf_generic_function_methods(); - @DocString(name="%generic-function-methods") - private static final class pf_generic_function_methods extends Primitive - { - pf_generic_function_methods() - { - super("%generic-function-methods", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS]; - } - }; - - private static final Primitive SET_GENERIC_FUNCTION_METHODS - = new pf_set_generic_function_methods(); - @DocString(name="set-generic-function-methods") - private static final class pf_set_generic_function_methods extends Primitive - { - pf_set_generic_function_methods() - { - super("set-generic-function-methods", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = second; - return second; - } - }; - - private static final Primitive GENERIC_FUNCTION_METHOD_CLASS - = new pf_generic_function_method_class(); - @DocString(name="%generic-function-method-class") - private static final class pf_generic_function_method_class extends Primitive - { - pf_generic_function_method_class() - { - super("%generic-function-method-class", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS]; - } - }; - - private static final Primitive SET_GENERIC_FUNCTION_METHOD_CLASS - = new pf_set_generic_function_method_class(); - @DocString(name="set-generic-function-method-class") - private static final class pf_set_generic_function_method_class extends Primitive - { - pf_set_generic_function_method_class() - { - super("set-generic-function-method-class", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = second; - return second; - } - }; - - private static final Primitive GENERIC_FUNCTION_METHOD_COMBINATION - = new pf_generic_function_method_combination(); - @DocString(name="%generic-function-method-combination") - private static final class pf_generic_function_method_combination extends Primitive - { - pf_generic_function_method_combination() - { - super("%generic-function-method-combination", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION]; - } - }; - - private static final Primitive SET_GENERIC_FUNCTION_METHOD_COMBINATION - = new pf_set_generic_function_method_combination(); - @DocString(name="set-generic-function-method-combination") - private static final class pf_set_generic_function_method_combination extends Primitive - { - pf_set_generic_function_method_combination() - { - super("set-generic-function-method-combination", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] - = second; - return second; - } - }; - - private static final Primitive GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER - = new pf_generic_function_argument_precedence_order(); - @DocString(name="%generic-function-argument-precedence-order") - private static final class pf_generic_function_argument_precedence_order extends Primitive - { - pf_generic_function_argument_precedence_order() - { - super("%generic-function-argument-precedence-order", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass - .SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER]; - } - }; - - private static final Primitive SET_GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER - = new pf_set_generic_function_argument_precedence_order(); - @DocString(name="set-generic-function-argument-precedence-order") - private static final class pf_set_generic_function_argument_precedence_order extends Primitive - { - pf_set_generic_function_argument_precedence_order() - { - super("set-generic-function-argument-precedence-order", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first) - .slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = second; - return second; - } - }; - - private static final Primitive GENERIC_FUNCTION_DECLARATIONS - = new pf_generic_function_declarations(); - @DocString(name="%generic-function-declarations") - private static final class pf_generic_function_declarations extends Primitive - { - pf_generic_function_declarations() - { - super("%generic-function-declarations", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg) - .slots[StandardGenericFunctionClass .SLOT_INDEX_DECLARATIONS]; - } - }; - - private static final Primitive SET_GENERIC_FUNCTION_DECLARATIONS - = new pf_set_generic_function_declarations(); - @DocString(name="set-generic-function-declarations") - private static final class pf_set_generic_function_declarations extends Primitive - { - pf_set_generic_function_declarations() - { - super("set-generic-function-declarations", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first) - .slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = second; - return second; - } - }; - - - - private static final Primitive GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE - = new pf_generic_function_classes_to_emf_table(); - @DocString(name="generic-function-classes-to-emf-table") - private static final class pf_generic_function_classes_to_emf_table extends Primitive - { - pf_generic_function_classes_to_emf_table() - { - super("generic-function-classes-to-emf-table", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg) - .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE]; - } - }; - - private static final Primitive SET_GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE - = new pf_set_generic_function_classes_to_emf_table(); - @DocString(name="set-generic-function-classes-to-emf-table") - private static final class pf_set_generic_function_classes_to_emf_table extends Primitive - { - pf_set_generic_function_classes_to_emf_table() - { - super("set-generic-function-classes-to-emf-table", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first) - .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = second; - return second; - } - }; - - private static final Primitive GENERIC_FUNCTION_DOCUMENTATION - = new pf_generic_function_documentation(); - @DocString(name="generic-function-documentation") - private static final class pf_generic_function_documentation extends Primitive - { - pf_generic_function_documentation() - { - super("generic-function-documentation", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION]; - } - }; - - private static final Primitive SET_GENERIC_FUNCTION_DOCUMENTATION - = new pf_set_generic_function_documentation(); - @DocString(name="set-generic-function-documentation") - private static final class pf_set_generic_function_documentation extends Primitive - { - pf_set_generic_function_documentation() - { - super("set-generic-function-documentation", PACKAGE_SYS, true); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] - = second; - return second; - } - }; private static final Primitive _FINALIZE_GENERIC_FUNCTION = new pf__finalize_generic_function(); Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Mar 29 16:01:36 2013 (r14453) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Apr 2 07:59:54 2013 (r14454) @@ -1555,58 +1555,52 @@ -;; MOP (p. 216) specifies the following reader generic functions: -;; generic-function-argument-precedence-order -;; generic-function-declarations -;; generic-function-lambda-list -;; generic-function-method-class -;; generic-function-method-combination -;; generic-function-methods -;; generic-function-name +;;; MOP (p. 216) specifies the following reader generic functions: +;;; generic-function-argument-precedence-order +;;; generic-function-declarations +;;; generic-function-lambda-list +;;; generic-function-method-class +;;; generic-function-method-combination +;;; generic-function-methods +;;; generic-function-name + +;;; Additionally, we define the following reader functions: +;;; generic-function-required-arguments +;;; generic-function-optional-arguments -;;; These are defined with % in package SYS, defined as functions here -;;; and redefined as generic functions once we're all set up. +;;; These are defined as functions here and redefined as generic +;;; functions via atomic-defgeneric once we're all set up. (defun generic-function-name (gf) - (%generic-function-name gf)) + (std-slot-value gf 'sys::name)) (defun generic-function-lambda-list (gf) - (%generic-function-lambda-list gf)) -(defsetf generic-function-lambda-list %set-generic-function-lambda-list) - -(defun (setf generic-function-documentation) (new-value gf) - (set-generic-function-documentation gf new-value)) - -(defun (setf generic-function-initial-methods) (new-value gf) - (set-generic-function-initial-methods gf new-value)) + (std-slot-value gf 'sys::lambda-list)) (defun generic-function-methods (gf) - (sys:%generic-function-methods gf)) -(defun (setf generic-function-methods) (new-value gf) - (set-generic-function-methods gf new-value)) + (std-slot-value gf 'sys::methods)) (defun generic-function-method-class (gf) - (sys:%generic-function-method-class gf)) -(defun (setf generic-function-method-class) (new-value gf) - (set-generic-function-method-class gf new-value)) + (std-slot-value gf 'sys::method-class)) (defun generic-function-method-combination (gf) - (sys:%generic-function-method-combination gf)) -(defun (setf generic-function-method-combination) (new-value gf) - (assert (typep new-value 'method-combination)) - (set-generic-function-method-combination gf new-value)) + (std-slot-value gf 'sys::%method-combination)) (defun generic-function-argument-precedence-order (gf) - (sys:%generic-function-argument-precedence-order gf)) -(defun (setf generic-function-argument-precedence-order) (new-value gf) - (set-generic-function-argument-precedence-order gf new-value)) + (std-slot-value gf 'sys::argument-precedence-order)) + +(defun generic-function-required-arguments (gf) + (std-slot-value gf 'sys::required-args)) + +(defun generic-function-optional-arguments (gf) + (std-slot-value gf 'sys::optional-args)) (declaim (ftype (function * t) classes-to-emf-table)) (defun classes-to-emf-table (gf) - (generic-function-classes-to-emf-table gf)) + (std-slot-value gf 'sys::classes-to-emf-table)) (defun (setf classes-to-emf-table) (new-value gf) - (set-generic-function-classes-to-emf-table gf new-value)) + (setf (std-slot-value gf 'sys::classes-to-emf-table) new-value)) (defun (setf method-lambda-list) (new-value method) (setf (std-slot-value method 'sys::lambda-list) new-value)) @@ -1640,17 +1634,20 @@ (setf documentation t) (push item options)) (:method - (push - `(push (defmethod ,function-name ,@(cdr item)) - (generic-function-initial-methods (fdefinition ',function-name))) - methods)) + ;; KLUDGE (rudi 2013-04-02): this only works with subclasses + ;; of standard-generic-function, since the initial-methods + ;; slot is not mandated by AMOP + (push + `(push (defmethod ,function-name ,@(cdr item)) + (std-slot-value (fdefinition ',function-name) 'sys::initial-methods)) + methods)) (t (push item options)))) (when declarations (push (list :declarations declarations) options)) (setf options (nreverse options) methods (nreverse methods)) - ;;; Since DEFGENERIC currently shares its argument parsing with - ;;; DEFMETHOD, we perform this check here. + ;; Since DEFGENERIC currently shares its argument parsing with + ;; DEFMETHOD, we perform this check here. (when (find '&aux lambda-list) (error 'program-error :format-control "&AUX is not allowed in a generic function lambda list: ~S" @@ -1720,19 +1717,19 @@ (defun %defgeneric (function-name &rest all-keys) (when (fboundp function-name) (let ((gf (fdefinition function-name))) - (when (typep gf 'generic-function) + (when (typep gf 'standard-generic-function) ;; Remove methods defined by previous DEFGENERIC forms, as - ;; specified by CLHS, 7.7 (Macro DEFGENERIC). - (dolist (method (generic-function-initial-methods gf)) - (if (eq (class-of gf) +the-standard-generic-function-class+) - (progn - (std-remove-method gf method) - (map-dependents gf - #'(lambda (dep) - (update-dependent gf dep - 'remove-method method)))) - (remove-method gf method))) - (setf (generic-function-initial-methods gf) '())))) + ;; specified by CLHS, 7.7 (Macro DEFGENERIC). KLUDGE: only + ;; works for subclasses of standard-generic-function. Since + ;; AMOP doesn't specify a reader for initial methods, we have to + ;; skip this step otherwise. + (dolist (method (std-slot-value gf 'sys::initial-methods)) + (std-remove-method gf method) + (map-dependents gf + #'(lambda (dep) + (update-dependent gf dep + 'remove-method method)))) + (setf (std-slot-value gf 'sys::initial-methods) '())))) (apply 'ensure-generic-function function-name all-keys)) ;;; Bootstrap version of ensure-generic-function, handling only @@ -1760,15 +1757,16 @@ (error 'simple-error :format-control "The lambda list ~S is incompatible with the existing methods of ~S." :format-arguments (list lambda-list gf))) - (setf (generic-function-lambda-list gf) lambda-list) + (setf (std-slot-value gf 'sys::lambda-list) lambda-list) (let* ((plist (analyze-lambda-list lambda-list)) (required-args (getf plist ':required-args))) - (%set-gf-required-args gf required-args) - (%set-gf-optional-args gf (getf plist :optional-args)))) - (setf (generic-function-argument-precedence-order gf) - (or argument-precedence-order (gf-required-args gf))) + (setf (std-slot-value gf 'sys::required-args) required-args) + (setf (std-slot-value gf 'sys::optional-args) + (getf plist :optional-args)))) + (setf (std-slot-value gf 'sys::argument-precedence-order) + (or argument-precedence-order (generic-function-required-arguments gf))) (when documentation-supplied-p - (setf (generic-function-documentation gf) documentation)) + (setf (std-slot-value gf 'sys::%documentation) documentation)) (finalize-standard-generic-function gf) gf) (progn @@ -1812,9 +1810,9 @@ (defun finalize-standard-generic-function (gf) (%finalize-generic-function gf) - (unless (generic-function-classes-to-emf-table gf) - (set-generic-function-classes-to-emf-table gf (make-hash-table :test #'equal))) - (clrhash (generic-function-classes-to-emf-table gf)) + (if (classes-to-emf-table gf) + (clrhash (classes-to-emf-table gf)) + (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))) (%init-eql-specializations gf (collect-eql-specializer-objects gf)) (set-funcallable-instance-function gf @@ -1823,7 +1821,7 @@ (compute-discriminating-function gf))) ;; FIXME Do we need to warn on redefinition somewhere else? (let ((*warn-on-redefinition* nil)) - (setf (fdefinition (%generic-function-name gf)) gf)) + (setf (fdefinition (generic-function-name gf)) gf)) (values)) (defun make-instance-standard-generic-function (generic-function-class @@ -1842,21 +1840,21 @@ (setf method-combination (find-method-combination gf (car method-combination) (cdr method-combination)))) - (%set-generic-function-name gf name) - (%set-generic-function-lambda-list gf lambda-list) - (set-generic-function-initial-methods gf ()) - (set-generic-function-methods gf ()) - (set-generic-function-method-class gf method-class) - (set-generic-function-method-combination gf method-combination) - (set-generic-function-declarations gf declarations) - (set-generic-function-documentation gf documentation) - (set-generic-function-classes-to-emf-table gf nil) + (setf (std-slot-value gf 'sys::name) name) + (setf (std-slot-value gf 'sys::lambda-list) lambda-list) + (setf (std-slot-value gf 'sys::initial-methods) ()) + (setf (std-slot-value gf 'sys::methods) ()) + (setf (std-slot-value gf 'sys::method-class) method-class) + (setf (std-slot-value gf 'sys::%method-combination) method-combination) + (setf (std-slot-value gf 'sys::declarations) declarations) + (setf (std-slot-value gf 'sys::%documentation) documentation) + (setf (std-slot-value gf 'sys::classes-to-emf-table) nil) (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf))) (required-args (getf plist ':required-args))) - (%set-gf-required-args gf required-args) - (%set-gf-optional-args gf (getf plist :optional-args)) - (set-generic-function-argument-precedence-order - gf (or argument-precedence-order required-args))) + (setf (std-slot-value gf 'sys::required-args) required-args) + (setf (std-slot-value gf 'sys::optional-args) (getf plist :optional-args)) + (setf (std-slot-value gf 'sys::argument-precedence-order) + (or argument-precedence-order required-args))) (finalize-standard-generic-function gf) gf)) @@ -1914,11 +1912,11 @@ real-body))))) (defun required-portion (gf args) - (let ((number-required (length (gf-required-args gf)))) + (let ((number-required (length (generic-function-required-arguments gf)))) (when (< (length args) number-required) (error 'program-error :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name gf)))) + :format-arguments (list (generic-function-name gf)))) (subseq args 0 number-required))) (defun extract-lambda-list (specialized-lambda-list) @@ -2200,14 +2198,14 @@ (std-remove-method gf old-method) (remove-method gf old-method)))) (setf (std-slot-value method 'sys::%generic-function) gf) - (push method (generic-function-methods gf)) + (push method (std-slot-value gf 'sys::methods)) (dolist (specializer (method-specializers method)) (add-direct-method specializer method)) (finalize-standard-generic-function gf) gf) (defun std-remove-method (gf method) - (setf (generic-function-methods gf) + (setf (std-slot-value gf 'sys::methods) (remove method (generic-function-methods gf))) (setf (std-slot-value method 'sys::%generic-function) nil) (dolist (specializer (method-specializers method)) @@ -2219,11 +2217,11 @@ ;; "If the specializers argument does not correspond in length to the number ;; of required arguments of the generic-function, an an error of type ERROR ;; is signaled." - (unless (= (length specializers) (length (gf-required-args gf))) + (unless (= (length specializers) (length (generic-function-required-arguments gf))) (error "The specializers argument has length ~S, but ~S has ~S required parameters." (length specializers) gf - (length (gf-required-args gf)))) + (length (generic-function-required-arguments gf)))) (let* ((canonical-specializers (canonicalize-specializers specializers)) (method (find-if #'(lambda (method) @@ -2233,13 +2231,13 @@ (method-specializers method)))) (generic-function-methods gf)))) (if (and (null method) errorp) - (error "No such method for ~S." (%generic-function-name gf)) + (error "No such method for ~S." (generic-function-name gf)) method))) (defun fast-callable-p (gf) (and (eq (method-combination-name (generic-function-method-combination gf)) 'standard) - (null (intersection (%generic-function-lambda-list gf) + (null (intersection (generic-function-lambda-list gf) '(&rest &optional &key &allow-other-keys &aux))))) (declaim (ftype (function * t) slow-method-lookup-1)) @@ -2252,125 +2250,129 @@ (defun std-compute-discriminating-function (gf) ;; In this function, we know that gf is of class - ;; standard-generic-function, so we call various - ;; sys:%generic-function-foo readers to break circularities. - (cond - ((and (= (length (sys:%generic-function-methods gf)) 1) - (eq (type-of (car (sys:%generic-function-methods gf))) 'standard-reader-method) - (eq (type-of (car (std-method-specializers (%car (sys:%generic-function-methods gf))))) 'standard-class)) - ;; we are standard and can elide slot-value(-using-class) - (let* ((method (%car (sys:%generic-function-methods gf))) - (class (car (std-method-specializers method))) - (slot-name (slot-definition-name (accessor-method-slot-definition method)))) - #'(lambda (arg) - (declare (optimize speed)) - (let* ((layout (std-instance-layout arg)) - (location (get-cached-slot-location gf layout))) - (unless location - (unless (simple-typep arg class) - ;; FIXME no applicable method - (error 'simple-type-error - :datum arg - :expected-type class)) - (setf location (slow-reader-lookup gf layout slot-name))) - (let ((value (if (consp location) - (cdr location) ; :allocation :class - (funcallable-standard-instance-access arg location)))) - (if (eq value +slot-unbound+) - ;; fix SLOT-UNBOUND.5 from ansi test suite - (nth-value 0 (slot-unbound class arg slot-name)) - value)))))) + ;; standard-generic-function, so we can access the instance's slots + ;; via std-slot-value. This breaks circularities when redefining + ;; generic function accessors. + (let ((methods (std-slot-value gf 'sys::methods))) + (cond + ((and (= (length methods) 1) + (eq (type-of (car methods)) 'standard-reader-method) + (eq (type-of (car (std-method-specializers (%car methods)))) + 'standard-class)) + (let* ((method (%car methods)) + (class (car (std-method-specializers method))) + (slot-name (slot-definition-name (accessor-method-slot-definition method)))) + #'(lambda (arg) + (declare (optimize speed)) + (let* ((layout (std-instance-layout arg)) + (location (get-cached-slot-location gf layout))) + (unless location + (unless (simple-typep arg class) + ;; FIXME no applicable method + (error 'simple-type-error + :datum arg + :expected-type class)) + (setf location (slow-reader-lookup gf layout slot-name))) + (let ((value (if (consp location) + (cdr location) ; :allocation :class + (funcallable-standard-instance-access arg location)))) + (if (eq value +slot-unbound+) + ;; fix SLOT-UNBOUND.5 from ansi test suite + (nth-value 0 (slot-unbound class arg slot-name)) + value)))))) - (t - (let* ((emf-table (classes-to-emf-table gf)) - (number-required (length (gf-required-args gf))) - (lambda-list (%generic-function-lambda-list gf)) - (exact (null (intersection lambda-list - '(&rest &optional &key - &allow-other-keys)))) - (no-aux (null (some - (lambda (method) - (find '&aux (std-slot-value method 'sys::lambda-list))) - (sys:%generic-function-methods gf))))) - (if (and exact - no-aux) - (cond - ((= number-required 1) - (cond - ((and (eq (method-combination-name (sys:%generic-function-method-combination gf)) 'standard) - (= (length (sys:%generic-function-methods gf)) 1) - (std-method-fast-function (%car (sys:%generic-function-methods gf)))) - (let* ((method (%car (sys:%generic-function-methods gf))) - (specializer (car (std-method-specializers method))) - (function (std-method-fast-function method))) - (if (typep specializer 'eql-specializer) - (let ((specializer-object (eql-specializer-object specializer))) + (t + (let* ((emf-table (classes-to-emf-table gf)) + (number-required (length (generic-function-required-arguments gf))) + (lambda-list (generic-function-lambda-list gf)) + (exact (null (intersection lambda-list + '(&rest &optional &key + &allow-other-keys)))) + (no-aux (null (some + (lambda (method) + (find '&aux (std-slot-value method 'sys::lambda-list))) + methods)))) + (if (and exact + no-aux) + (cond + ((= number-required 1) + (cond + ((and (eq (method-combination-name + (std-slot-value gf 'sys::%method-combination)) + 'standard) + (= (length methods) 1) + (std-method-fast-function (%car methods))) + (let* ((method (%car methods)) + (specializer (car (std-method-specializers method))) + (function (std-method-fast-function method))) + (if (typep specializer 'eql-specializer) + (let ((specializer-object (eql-specializer-object specializer))) + #'(lambda (arg) + (declare (optimize speed)) + (if (eql arg specializer-object) + (funcall function arg) + (no-applicable-method gf (list arg))))) #'(lambda (arg) (declare (optimize speed)) - (if (eql arg specializer-object) - (funcall function arg) - (no-applicable-method gf (list arg))))) - #'(lambda (arg) - (declare (optimize speed)) - (unless (simple-typep arg specializer) - ;; FIXME no applicable method - (error 'simple-type-error - :datum arg - :expected-type specializer)) - (funcall function arg))))) - (t - #'(lambda (arg) - (declare (optimize speed)) - (let* ((specialization - (%get-arg-specialization gf arg)) - (emfun (or (gethash1 specialization - emf-table) - (slow-method-lookup-1 - gf arg specialization)))) - (if emfun - (funcall emfun (list arg)) - (apply #'no-applicable-method gf (list arg)))))))) - ((= number-required 2) - #'(lambda (arg1 arg2) - (declare (optimize speed)) - (let* ((args (list arg1 arg2)) - (emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args))))) - ((= number-required 3) - #'(lambda (arg1 arg2 arg3) - (declare (optimize speed)) - (let* ((args (list arg1 arg2 arg3)) - (emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args))))) - (t - #'(lambda (&rest args) - (declare (optimize speed)) - (let ((len (length args))) - (unless (= len number-required) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name gf))))) - (let ((emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args)))))) - ;; (let ((non-key-args (+ number-required - ;; (length (gf-optional-args gf)))))) - #'(lambda (&rest args) - (declare (optimize speed)) - (let ((len (length args))) - (unless (>= len number-required) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name gf))))) - (let ((emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args))))))))) + (unless (simple-typep arg specializer) + ;; FIXME no applicable method + (error 'simple-type-error + :datum arg + :expected-type specializer)) + (funcall function arg))))) + (t + #'(lambda (arg) + (declare (optimize speed)) + (let* ((specialization + (%get-arg-specialization gf arg)) + (emfun (or (gethash1 specialization + emf-table) + (slow-method-lookup-1 + gf arg specialization)))) + (if emfun + (funcall emfun (list arg)) + (apply #'no-applicable-method gf (list arg)))))))) + ((= number-required 2) + #'(lambda (arg1 arg2) + (declare (optimize speed)) + (let* ((args (list arg1 arg2)) + (emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args))))) + ((= number-required 3) + #'(lambda (arg1 arg2 arg3) + (declare (optimize speed)) + (let* ((args (list arg1 arg2 arg3)) + (emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args))))) + (t + #'(lambda (&rest args) + (declare (optimize speed)) + (let ((len (length args))) + (unless (= len number-required) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (generic-function-name gf))))) + (let ((emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args)))))) + ;; (let ((non-key-args (+ number-required + ;; (length (generic-function-optional-arguments gf)))))) + #'(lambda (&rest args) + (declare (optimize speed)) + (let ((len (length args))) + (unless (>= len number-required) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (generic-function-name gf))))) + (let ((emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args)))))))))) (defun sort-methods (methods gf required-classes) (if (or (null methods) (null (%cdr methods))) @@ -2488,8 +2490,8 @@ #'compute-effective-method) gf (generic-function-method-combination gf) applicable-methods)) - (non-keyword-args (+ (length (gf-required-args gf)) - (length (gf-optional-args gf)))) + (non-keyword-args (+ (length (generic-function-required-arguments gf)) + (length (generic-function-optional-arguments gf)))) (gf-lambda-list (generic-function-lambda-list gf)) (checks-required (and (member '&key gf-lambda-list) (not (member '&allow-other-keys @@ -2639,7 +2641,7 @@ ((and (null befores) (null reverse-afters)) (let ((fast-function (std-method-fast-function (car primaries)))) (if fast-function - (ecase (length (gf-required-args gf)) + (ecase (length (generic-function-required-arguments gf)) (1 #'(lambda (args) (declare (optimize speed)) @@ -3006,7 +3008,7 @@ ;; to charpos 23 always (but (setf fdefinition) leaves the ;; outdated source position in place, which is even worse). (fset ',function-name gf) - (%set-generic-function-name gf ',function-name) + (setf (std-slot-value gf 'sys::name) ',function-name) (fmakunbound ',temp-sym) gf)))) @@ -4266,15 +4268,16 @@ &allow-other-keys) (let* ((plist (analyze-lambda-list lambda-list)) (required-args (getf plist ':required-args))) - (%set-gf-required-args instance required-args) - (%set-gf-optional-args instance (getf plist :optional-args)) - (set-generic-function-argument-precedence-order - instance (or argument-precedence-order required-args))) + (setf (std-slot-value instance 'sys::required-args) required-args) + (setf (std-slot-value instance 'sys::optional-args) + (getf plist :optional-args)) + (setf (std-slot-value instance 'sys::argument-precedence-order) + (or argument-precedence-order required-args))) (unless (typep (generic-function-method-combination instance) 'method-combination) ;; this fixes (make-instance 'standard-generic-function) -- the ;; constructor of StandardGenericFunction sets this slot to '(standard) - (setf (generic-function-method-combination instance) + (setf (std-slot-value instance 'sys::%method-combination) (find-method-combination instance (car method-combination) (cdr method-combination)))) (finalize-standard-generic-function instance)) @@ -4283,31 +4286,39 @@ ;;; AMOP pg. 216ff. (atomic-defgeneric generic-function-argument-precedence-order (generic-function) (:method ((generic-function standard-generic-function)) - (sys:%generic-function-argument-precedence-order generic-function))) + (std-slot-value generic-function 'sys::argument-precedence-order))) (atomic-defgeneric generic-function-declarations (generic-function) (:method ((generic-function standard-generic-function)) - (sys:%generic-function-declarations generic-function))) + (std-slot-value generic-function 'sys::declarations))) (atomic-defgeneric generic-function-lambda-list (generic-function) (:method ((generic-function standard-generic-function)) - (sys:%generic-function-lambda-list generic-function))) + (std-slot-value generic-function 'sys::lambda-list))) (atomic-defgeneric generic-function-method-class (generic-function) (:method ((generic-function standard-generic-function)) - (sys:%generic-function-method-class generic-function))) + (std-slot-value generic-function 'sys::method-class))) (atomic-defgeneric generic-function-method-combination (generic-function) (:method ((generic-function standard-generic-function)) - (sys:%generic-function-method-combination generic-function))) + (std-slot-value generic-function 'sys::%method-combination))) (atomic-defgeneric generic-function-methods (generic-function) (:method ((generic-function standard-generic-function)) - (sys:%generic-function-methods generic-function))) + (std-slot-value generic-function 'sys::methods))) (atomic-defgeneric generic-function-name (generic-function) (:method ((generic-function standard-generic-function)) - (sys:%generic-function-name generic-function))) + (slot-value generic-function 'sys::name))) + +(atomic-defgeneric generic-function-required-arguments (generic-function) + (:method ((generic-function standard-generic-function)) + (std-slot-value generic-function 'sys::required-args))) + +(atomic-defgeneric generic-function-optional-arguments (generic-function) + (:method ((generic-function standard-generic-function)) + (std-slot-value generic-function 'sys::optional-args))) ;;; AMOP pg. 231 (defgeneric (setf generic-function-name) (new-value gf) Modified: trunk/abcl/src/org/armedbear/lisp/documentation.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/documentation.lisp Fri Mar 29 16:01:36 2013 (r14453) +++ trunk/abcl/src/org/armedbear/lisp/documentation.lisp Tue Apr 2 07:59:54 2013 (r14454) @@ -104,19 +104,19 @@ (%set-documentation x t new-value)) (defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) - (generic-function-documentation x)) + (std-slot-value x 'sys::%documentation)) (defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't))) - (setf (generic-function-documentation x) new-value)) + (setf (std-slot-value x 'sys::%documentation) new-value)) (defmethod documentation ((x standard-generic-function) (doc-type (eql 'function))) - (generic-function-documentation x)) + (std-slot-value x 'sys::%documentation)) (defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function))) - (setf (generic-function-documentation x) new-value)) + (setf (std-slot-value x 'sys::%documentation) new-value)) (defmethod documentation ((x standard-method) (doc-type (eql 't))) (method-documentation x)) Modified: trunk/abcl/src/org/armedbear/lisp/known-functions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/known-functions.lisp Fri Mar 29 16:01:36 2013 (r14453) +++ trunk/abcl/src/org/armedbear/lisp/known-functions.lisp Tue Apr 2 07:59:54 2013 (r14454) @@ -429,7 +429,6 @@ ext:classp ext:fixnump ext:memql - sys:%generic-function-name sys::puthash precompiler::precompile1 declare @@ -444,7 +443,6 @@ sys::require-type sys::arg-count-error sys:subclassp - sys:gf-required-args sys:cache-emf sys:get-cached-emf ext:autoloadp From ehuelsmann at common-lisp.net Tue Apr 2 19:57:56 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 02 Apr 2013 12:57:56 -0700 Subject: [armedbear-cvs] r14455 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Apr 2 12:57:51 2013 New Revision: 14455 Log: Fix (DESCRIBE ) for funcallable standard objects with unbound slots. Note: this fix basically makes sure funcallable standard objects aren't dispatched to the DESCRIBE-OBJECT (T T) method. Modified: trunk/abcl/src/org/armedbear/lisp/describe.lisp Modified: trunk/abcl/src/org/armedbear/lisp/describe.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/describe.lisp Tue Apr 2 07:59:54 2013 (r14454) +++ trunk/abcl/src/org/armedbear/lisp/describe.lisp Tue Apr 2 12:57:51 2013 (r14455) @@ -110,7 +110,7 @@ (format stream " TYPE ~S~%" (pathname-type object)) (format stream " VERSION ~S~%" (pathname-version object))) -(defmethod describe-object ((object standard-object) stream) +(defun %describe-standard-object/funcallable (object stream) (let* ((class (class-of object)) (slotds (mop:class-slots class)) (max-slot-name-length 0) @@ -145,8 +145,15 @@ (dolist (slotd (nreverse class-slotds)) (describe-slot (%slot-definition-name slotd))) - (format stream "~%")))) - (values)) + (format stream "~%"))))) + +(defmethod describe-object ((object standard-object) stream) + (%describe-standard-object/funcallable object stream) + (values)) + +(defmethod describe-object ((object mop:funcallable-standard-object) stream) + (%describe-standard-object/funcallable object stream) + (values)) (defmethod describe-object ((object java:java-object) stream) (java:describe-java-object object stream)) From mevenson at common-lisp.net Wed Apr 3 08:34:14 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 03 Apr 2013 01:34:14 -0700 Subject: [armedbear-cvs] r14456 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Wed Apr 3 01:34:14 2013 New Revision: 14456 Log: Update remote JAR-PATHNAME tests to retrieve fasl version 41 artifacts. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Tue Apr 2 12:57:51 2013 (r14455) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Wed Apr 3 01:34:14 2013 (r14456) @@ -202,7 +202,7 @@ t) (defparameter *url-jar-pathname-base* - "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20130327a.jar!/") + "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20130403a.jar!/") (defmacro load-url-relative (path) `(load (format nil "~A~A" *url-jar-pathname-base* ,path))) From ehuelsmann at common-lisp.net Wed Apr 3 19:40:14 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 03 Apr 2013 12:40:14 -0700 Subject: [armedbear-cvs] r14457 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 3 12:40:11 2013 New Revision: 14457 Log: Add FASL concatenation functionality for ASDF to use in its ASDF3 system build functionality. Added: trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Apr 3 01:34:14 2013 (r14456) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Apr 3 12:40:11 2013 (r14457) @@ -369,6 +369,7 @@ "ensure-directories-exist.lisp" "error.lisp" "extensible-sequences.lisp" + "fasl-concat.lisp" "featurep.lisp" "fdefinition.lisp" "fill.lisp" Added: trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp Wed Apr 3 12:40:11 2013 (r14457) @@ -0,0 +1,85 @@ +;;; fasl-concat.lisp +;;; +;;; Copyright (C) 2013 Erik Huelsmann +;;; $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. + + +(in-package #:system) + + +(defun pathname-directory-p (pathname) + (and (null (pathname-type pathname)) + (null (pathname-name pathname)) + (null (pathname-version pathname)))) + +(defun load-concatenated-fasl (sub-fasl) + (let ((fasl-path (merge-pathnames (make-pathname :directory (list :relative + sub-fasl) + :name sub-fasl + :type "_") + *load-truename-fasl*))) + (load fasl-path))) + +(defun concatenate-fasls (inputs output) + (let* ((directory (print (ext:make-temp-directory))) + (unpacked (mapcan #'(lambda (input) + (sys:unzip (print input) + (ensure-directories-exist + (sub-directory directory + (pathname-name (print input)))))) + inputs)) + (chain-loader (make-pathname :name (pathname-name output) + :type "_" + :defaults directory))) + (with-open-file (f chain-loader + :direction :output + :if-does-not-exist :create + :if-exists :overwrite) + (write-string + ";; loader code to delegate loading of the embedded fasls below" f) + (terpri f) + (sys::dump-form `(sys:init-fasl :version ,sys:*fasl-version*) f) + (terpri f) + (dolist (input inputs) + (sys::dump-form `(load-concatenated-fasl ,(pathname-name input)) f) + (terpri f))) + (let ((paths (remove-if #'pathname-directory-p + (directory + (merge-pathnames + (make-pathname :directory '(:relative + :wild-inferiors) + :name "*" + :type "*") + directory))))) + (sys:zip output paths directory)) + (values directory unpacked chain-loader))) + +(defun sub-directory (directory name) + (merge-pathnames (make-pathname :directory (list :relative name)) + directory)) \ No newline at end of file From ehuelsmann at common-lisp.net Wed Apr 3 19:46:45 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 03 Apr 2013 12:46:45 -0700 Subject: [armedbear-cvs] r14458 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 3 12:46:42 2013 New Revision: 14458 Log: Export the SYS::CONCATENATE-FASLS symbol. Modified: trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp Modified: trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp Wed Apr 3 12:40:11 2013 (r14457) +++ trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp Wed Apr 3 12:46:42 2013 (r14458) @@ -33,6 +33,9 @@ (in-package #:system) +(export '(concatenate-fasls)) + + (defun pathname-directory-p (pathname) (and (null (pathname-type pathname)) (null (pathname-name pathname)) From ehuelsmann at common-lisp.net Wed Apr 3 21:28:45 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 03 Apr 2013 14:28:45 -0700 Subject: [armedbear-cvs] r14459 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 3 14:28:32 2013 New Revision: 14459 Log: Ensure autoloading of fasl-concat when ASDF uses it. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Wed Apr 3 12:46:42 2013 (r14458) +++ trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Wed Apr 3 14:28:32 2013 (r14459) @@ -145,12 +145,12 @@ ;; EXPORTS (IN-PACKAGE :SYSTEM) -(EXPORT (QUOTE (AVER *COMPILER-DIAGNOSTIC* COMPILE-FILE-IF-NEEDED GROVEL-JAVA-DEFINITIONS-IN-FILE COMPILER-UNSUPPORTED INTERNAL-COMPILER-ERROR COMPILER-ERROR COMPILER-WARN COMPILER-STYLE-WARN *COMPILER-ERROR-CONTEXT* COMPILER-MACROEXPAND DEFKNOWN FUNCTION-RESULT-TYPE COMPILER-SUBTYPEP MAKE-COMPILER-TYPE JAVA-LONG-TYPE-P INTEGER-CONSTANT-VALUE FIXNUM-CONSTANT-VALUE FIXNUM-TYPE-P +INTEGER-TYPE+ +FIXNUM-TYPE+ MAKE-INTEGER-TYPE %MAKE-INTEGER-TYPE INTEGER-TYPE-P INTEGER-TYPE-HIGH INTEGER-TYPE-LOW +FALSE-TYPE+ +TRUE-TYPE+ COMPILER-DEFSTRUCT DESCRIBE-COMPILER-POLICY PARSE-BODY DUMP-UNINTERNED-SYMBOL-INDEX DUMP-FORM LOOKUP-KNOWN-SYMBOL STANDARD-INSTANCE-ACCESS SLOT-DEFINITION FORWARD-REFERENCED-CLASS LOGICAL-HOST-P *INLINE-DECLARATIONS* FTYPE-RESULT-TYPE PROCLAIMED-FTYPE PROCLAIMED-TYPE CHECK-DECLARATION-TYPE PROCESS-KILL PROCESS-EXIT-CODE PROCESS-WAIT PROCESS-ALIVE-P PROCESS-ERROR PROCESS-OUTPUT PROCESS-INPUT PROCESS-P PROCESS RUN-PROGRAM SIMPLE-SEARCH EXPAND-SOURCE-TRANSFORM DEFINE-SOURCE-TRANSFORM SOURCE-TRANSFORM UNTRACED-FUNCTION))) +(EXPORT (QUOTE (CONCATENATE-FASLS AVER *COMPILER-DIAGNOSTIC* COMPILE-FILE-IF-NEEDED GROVEL-JAVA-DEFINITIONS-IN-FILE COMPILER-UNSUPPORTED INTERNAL-COMPILER-ERROR COMPILER-ERROR COMPILER-WARN COMPILER-STYLE-WARN *COMPILER-ERROR-CONTEXT* COMPILER-MACROEXPAND DEFKNOWN FUNCTION-RESULT-TYPE COMPILER-SUBTYPEP MAKE-COMPILER-TYPE JAVA-LONG-TYPE-P INTEGER-CONSTANT-VALUE FIXNUM-CONSTANT-VALUE FIXNUM-TYPE-P +INTEGER-TYPE+ +FIXNUM-TYPE+ MAKE-INTEGER-TYPE %MAKE-INTEGER-TYPE INTEGER-TYPE-P INTEGER-TYPE-HIGH INTEGER-TYPE-LOW +FALSE-TYPE+ +TRUE-TYPE+ COMPILER-DEFSTRUCT DESCRIBE-COMPILER-POLICY PARSE-BODY DUMP-UNINTERNED-SYMBOL-INDEX DUMP-FORM LOOKUP-KNOWN-SYMBOL STANDARD-INSTANCE-ACCESS SLOT-DEFINITION FORWARD-REFERENCED-CLASS LOGICAL-HOST-P *INLINE-DECLARATIONS* FTYPE-RESULT-TYPE PROCLAIMED-FTYPE PROCLAIMED-TYPE CHECK-DECLARATION-TYPE PROCESS-KILL PROCESS-EXIT-CODE PROCESS-WAIT PROCESS-ALIVE-P PROCESS-ERROR PROCESS-OUTPUT PROCESS-INPUT PROCESS-P PROCESS RUN-PROGRAM SIMPLE-SEARCH EXPAND-SOURCE-TRANSFORM DEFINE-SOURCE-TRANSFORM SOURCE-TRANSFORM UNTRACED-FUNCTION))) ;; FUNCTIONS (IN-PACKAGE :SYSTEM) -(DOLIST (FS (QUOTE ((("abcl-contrib") FIND-SYSTEM-JAR FIND-CONTRIB) (("assert") ASSERT-ERROR ASSERT-PROMPT) (("aver") %FAILED-AVER) (("backquote") BACKQUOTE-MACRO COMMA-MACRO EXPANDABLE-BACKQ-EXPRESSION-P BACKQUOTIFY COMMA BACKQUOTIFY-1 BACKQ-LIST BACKQ-LIST* BACKQ-APPEND BACKQ-NCONC BACKQ-CONS BACKQ-VECTOR %READER-ERROR) (("bit-array-ops") BIT-ARRAY-SAME-DIMENSIONS-P REQUIRE-SAME-DIMENSIONS PICK-RESULT-ARRAY) (("case") LIST-OF-LENGTH-AT-LEAST-P CASE-BODY-ERROR CASE-BODY-AUX CASE-BODY) (("check-type") CHECK-TYPE-ERROR) (("clos") COERCE-TO-CONDITION) (("coerce") COERCE-LIST-TO-VECTOR COPY-STRING COERCE-ERROR COERCE-OBJECT-TO-AND-TYPE) (("compile-file-pathname") CFP-OUTPUT-FILE-DEFAULT) (("compile-file") BASE-CLASSNAME FASL-LOADER-CLASSNAME COMPUTE-CLASSFILE-NAME SANITIZE-CLASS-NAME NEXT-CLASSFILE-NAME DUMMY VERIFY-LOAD NOTE-TOPLEVEL-FORM OUTPUT-FORM FINALIZE-FASL-OUTPUT SIMPLE-TOPLEVEL-FORM-P CONVERT-TOPLEVEL-FORM PROCESS-PROGN PRECOMPILE-TOPLEVEL-FORM PROCESS-TOPLEVEL-MACROLET PROCESS-TOPLEVEL-DEFCONSTANT PROCESS-TOPLEVEL-QUOTE PROCESS-TOPLEVEL-IMPORT PROCESS-TOPLEVEL-EXPORT PROCESS-TOPLEVEL-MOP.ENSURE-METHOD PROCESS-TOPLEVEL-DEFVAR/DEFPARAMETER PROCESS-TOPLEVEL-DEFPACKAGE/IN-PACKAGE PROCESS-TOPLEVEL-DECLARE PROCESS-TOPLEVEL-PROGN PROCESS-TOPLEVEL-DEFTYPE PROCESS-TOPLEVEL-EVAL-WHEN PROCESS-TOPLEVEL-DEFMETHOD/DEFGENERIC PROCESS-TOPLEVEL-LOCALLY PROCESS-TOPLEVEL-DEFMACRO PROCESS-TOPLEVEL-DEFUN INSTALL-TOPLEVEL-HANDLER PROCESS-TOPLEVEL-FORM POPULATE-ZIP-FASL WRITE-FASL-PROLOGUE COMPILE-FROM-STREAM COMPILE-FILE-IF-NEEDED) (("compile-system") CHECK-LISP-HOME GROVEL-JAVA-DEFINITIONS-IN-FILE GROVEL-JAVA-DEFINITIONS PACKAGES-FROM-COMBOS REMOVE-MULTI-COMBO-SYMBOLS SET-EQUAL COMBOS-TO-SYMBOL-FILESETS COMBOS-TO-FILESET-SYMBOLS WRITE-AUTOLOADER WRITE-PACKAGE-FILESETS LOAD-COMBOS GENERATE-AUTOLOADS %COMPILE-SYSTEM CREATE-SYSTEM-LOGICAL-TRANSLATIONS) (("compiler-error") COMPILER-STYLE-WARN COMPILER-WARN COMPILER-ERROR INTERNAL-COMPILER-ERROR COMPILER-UNSUPPORTED) (("compiler-macro") COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND) (("compiler-pass2") AUTOCOMPILE) (("compiler-types") MAKE-CONSTANT-TYPE CONSTANT-TYPE-P %MAKE-INTEGER-TYPE INTEGER-TYPE-P MAKE-INTEGER-TYPE FIXNUM-TYPE-P FIXNUM-CONSTANT-VALUE INTEGER-CONSTANT-VALUE JAVA-LONG-TYPE-P MAKE-UNION-TYPE MAKE-COMPILER-TYPE INTEGER-TYPE-SUBTYPEP COMPILER-SUBTYPEP FUNCTION-RESULT-TYPE SET-FUNCTION-RESULT-TYPE %DEFKNOWN) (("concatenate") CONCATENATE-TO-STRING) (("debug") INTERNAL-DEBUG DEBUG-LOOP INVOKE-DEBUGGER-REPORT-CONDITION RUN-HOOK BACKTRACE-AS-LIST) (("define-symbol-macro") %DEFINE-SYMBOL-MACRO) (("defpackage") DESIGNATED-PACKAGE-NAME STRINGIFY-NAMES CHECK-DISJOINT) (("defsetf") %DEFSETF) (("defstruct") MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION KEYWORDIFY DEFINE-KEYWORD-CONSTRUCTOR FIND-DSD GET-SLOT DEFINE-BOA-CONSTRUCTOR DEFAULT-CONSTRUCTOR-NAME DEFINE-CONSTRUCTORS NAME-INDEX DEFINE-PREDICATE MAKE-LIST-READER MAKE-VECTOR-READER MAKE-STRUCTURE-READER DEFINE-READER MAKE-LIST-WRITER MAKE-VECTOR-WRITER MAKE-STRUCTURE-WRITER DEFINE-WRITER DEFINE-ACCESS-FUNCTIONS DEFINE-COPIER DEFINE-PRINT-FUNCTION PARSE-1-OPTION PARSE-NAME-AND-OPTIONS COMPILER-DEFSTRUCT DEFSTRUCT-DEFAULT-CONSTRUCTOR) (("deftype") EXPAND-DEFTYPE) (("delete-duplicates") LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*) (("describe-compiler-policy") DESCRIBE-COMPILER-POLICY) (("describe") DESCRIBE-ARGLIST %DESCRIBE-OBJECT) (("destructuring-bind") PARSE-BODY ARG-COUNT-ERROR PARSE-DEFMACRO DEFMACRO-ERROR VERIFY-KEYWORDS LOOKUP-KEYWORD KEYWORD-SUPPLIED-P PARSE-DEFMACRO-LAMBDA-LIST PUSH-SUB-LIST-BINDING PUSH-LET-BINDING PUSH-OPTIONAL-BINDING MAKE-MACRO-EXPANDER) (("directory") PATHNAME-AS-FILE WILD-INFERIORS-P LIST-DIRECTORIES-WITH-WILDCARDS) (("do") DO-DO-BODY) (("dump-form") GET-INSTANCE-FORM DF-REGISTER-CIRCULARITY DF-CHECK-CONS DF-CHECK-VECTOR DF-CHECK-INSTANCE DF-CHECK-OBJECT DF-HANDLE-CIRCULARITY DUMP-CONS DUMP-VECTOR DUMP-INSTANCE DUMP-UNINTERNED-SYMBOL-INDEX DUMP-OBJECT DUMP-FORM) (("ed") DEFAULT-ED-FUNCTION) (("enough-namestring") EQUAL-COMPONENTS-P) (("fill") LIST-FILL VECTOR-FILL) (("find") LIST-POSITION* VECTOR-POSITION* LIST-FIND* VECTOR-FIND*) (("format") SYMBOLICATE PROPER-LIST-OF-LENGTH-P FLONUM-TO-STRING ROUND-UP SCALE-EXPONENT FLOAT-DENORMALIZED-P) (("inline") INLINE-EXPANSION SET-INLINE-EXPANSION) (("inspect") LEADER SAFE-LENGTH DISPLAY-OBJECT DISPLAY-CURRENT ISTEP) (("late-setf") MAKE-GENSYM-LIST) (("lcm") TWO-ARG-LCM) (("ldb") %LDB) (("load") LOAD-RETURNING-LAST-RESULT) (("make-sequence") SIZE-MISMATCH-ERROR) (("map1") MAP1) (("nsubstitute") NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*) (("open") UPGRADED-ELEMENT-TYPE-BITS UPGRADED-ELEMENT-TYPE) (("parse-integer") PARSE-INTEGER-ERROR) (("parse-lambda-list") PARSE-LAMBDA-LIST-LIKE-THING PARSE-LAMBDA-LIST) (("pathnames") COMPONENT-MATCH-WILD-P COMPONENT-MATCH-P DIRECTORY-MATCH-COMPONENTS DIRECTORY-MATCH-P WILD-P CASIFY TRANSLATE-COMPONENT TRANSLATE-JAR-DEVICE TRANSLATE-DIRECTORY-COMPONENTS-AUX TRANSLATE-DIRECTORY-COMPONENTS TRANSLATE-DIRECTORY LOGICAL-HOST-P CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS %SET-LOGICAL-PATHNAME-TRANSLATIONS) (("print-unreadable-object") %PRINT-UNREADABLE-OBJECT) (("print") COMPOUND-OBJECT-P OUTPUT-INTEGER OUTPUT-LIST OUTPUT-TERSE-ARRAY ARRAY-READABLY-PRINTABLE-P OUTPUT-VECTOR OUTPUT-UGLY-OBJECT CHECK-FOR-CIRCULARITY HANDLE-CIRCULARITY PRINT-LABEL PRINT-REFERENCE UNIQUELY-IDENTIFIED-BY-PRINT-P %PRINT-OBJECT %CHECK-OBJECT OUTPUT-OBJECT) (("proclaim") DECLARATION-ERROR CHECK-DECLARATION-TYPE PROCLAIM-TYPE PROCLAIMED-TYPE PROCLAIM-FTYPE-1 PROCLAIM-FTYPE PROCLAIMED-FTYPE FTYPE-RESULT-TYPE) (("query") QUERY-READLINE) (("read-circle") CIRCLE-SUBST SHARP-EQUAL SHARP-SHARP) (("read-conditional") READ-FEATURE READ-CONDITIONAL) (("remove-duplicates") LIST-REMOVE-DUPLICATES VECTOR-REMOVE-DUPLICATES) (("replace") LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR* VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*) (("run-program") RUN-PROGRAM %MAKE-PROCESS PROCESS-P MAKE-PROCESS PROCESS-ALIVE-P PROCESS-WAIT PROCESS-EXIT-CODE PROCESS-KILL %MAKE-PROCESS-BUILDER %PROCESS-BUILDER-ENVIRONMENT %PROCESS-BUILDER-ENV-PUT %PROCESS-BUILDER-ENV-CLEAR %PROCESS-BUILDER-START %MAKE-PROCESS-INPUT-STREAM %MAKE-PROCESS-OUTPUT-STREAM %MAKE-PROCESS-ERROR-STREAM %PROCESS-ALIVE-P %PROCESS-WAIT %PROCESS-EXIT-CODE %PROCESS-KILL) (("search") SIMPLE-SEARCH) (("sequences") MAKE-SEQUENCE-OF-TYPE) (("setf") GET-SETF-METHOD-INVERSE EXPAND-OR-GET-SETF-INVERSE %SET-SUBSEQ %DEFINE-SETF-MACRO %SET-CAAR %SET-CADR %SET-CDAR %SET-CDDR %SET-CAAAR %SET-CADAR %SET-CDAAR %SET-CDDAR %SET-CAADR %SET-CADDR %SET-CDADR %SET-CDDDR %SET-CAAAAR %SET-CADAAR %SET-CDAAAR %SET-CDDAAR %SET-CAADAR %SET-CADDAR %SET-CDADAR %SET-CDDDAR %SET-CAAADR %SET-CADADR %SET-CDAADR %SET-CDDADR %SET-CAADDR %SET-CADDDR %SET-CDADDR %SET-CDDDDR %SET-FIFTH %SET-SIXTH %SET-SEVENTH %SET-EIGHTH %SET-NINTH %SET-TENTH) (("sort") MERGE-SORT-VECTORS LAST-CONS-OF MERGE-LISTS MERGE-LISTS-NO-KEY SORT-LIST QUICKSORT QUICK-SORT) (("source-transform") SOURCE-TRANSFORM SET-SOURCE-TRANSFORM EXPAND-SOURCE-TRANSFORM-1 EXPAND-SOURCE-TRANSFORM) (("subst") %SUBST %SUBST-IF %SUBST-IF-NOT) (("subtypep") INITIALIZE-KNOWN-TYPES KNOWN-TYPE-P SUB-INTERVAL-P DIMENSION-SUBTYPEP SIMPLE-SUBTYPEP MAKE-CTYPE CTYPE-SUPER CTYPE-TYPE CTYPE CSUBTYPEP-ARRAY CSUBTYPEP-FUNCTION CSUBTYPEP-COMPLEX CSUBTYPEP %SUBTYPEP) (("time") PICK-OBVIOUS-YEAR LEAP-YEARS-BEFORE) (("trace") MAKE-TRACE-INFO TRACE-INFO-P LIST-TRACED-FUNCTIONS EXPAND-TRACE TRACE-1 TRACED-FUNCTION UNTRACED-FUNCTION TRACE-REDEFINED-UPDATE INDENT UNTRACE-ALL UNTRACE-1) (("tree-equal") TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST) (("typep") SIMPLE-ARRAY-P IN-INTERVAL-P MATCH-DIMENSIONS %TYPEP) (("with-hash-table-iterator") HASH-TABLE-ITERATOR-FUNCTION) (("with-package-iterator") PACKAGE-ITERATOR-FUNCTION) (("with-standard-io-syntax") %WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR FS) (CAR (CAR FS)))) +(DOLIST (FS (QUOTE ((("fasl-concat") CONCATENATE-FALSL) (("abcl-contrib") FIND-SYSTEM-JAR FIND-CONTRIB) (("assert") ASSERT-ERROR ASSERT-PROMPT) (("aver") %FAILED-AVER) (("backquote") BACKQUOTE-MACRO COMMA-MACRO EXPANDABLE-BACKQ-EXPRESSION-P BACKQUOTIFY COMMA BACKQUOTIFY-1 BACKQ-LIST BACKQ-LIST* BACKQ-APPEND BACKQ-NCONC BACKQ-CONS BACKQ-VECTOR %READER-ERROR) (("bit-array-ops") BIT-ARRAY-SAME-DIMENSIONS-P REQUIRE-SAME-DIMENSIONS PICK-RESULT-ARRAY) (("case") LIST-OF-LENGTH-AT-LEAST-P CASE-BODY-ERROR CASE-BODY-AUX CASE-BODY) (("check-type") CHECK-TYPE-ERROR) (("clos") COERCE-TO-CONDITION) (("coerce") COERCE-LIST-TO-VECTOR COPY-STRING COERCE-ERROR COERCE-OBJECT-TO-AND-TYPE) (("compile-file-pathname") CFP-OUTPUT-FILE-DEFAULT) (("compile-file") BASE-CLASSNAME FASL-LOADER-CLASSNAME COMPUTE-CLASSFILE-NAME SANITIZE-CLASS-NAME NEXT-CLASSFILE-NAME DUMMY VERIFY-LOAD NOTE-TOPLEVEL-FORM OUTPUT-FORM FINALIZE-FASL-OUTPUT SIMPLE-TOPLEVEL-FORM-P CONVERT-TOPLEVEL-FORM PROCESS-PROGN PRECOMPILE-TOPLEVEL-FORM PROCESS-TOPLEVEL-MACROLET PROCESS-TOPLEVEL-DEFCONSTANT PROCESS-TOPLEVEL-QUOTE PROCESS-TOPLEVEL-IMPORT PROCESS-TOPLEVEL-EXPORT PROCESS-TOPLEVEL-MOP.ENSURE-METHOD PROCESS-TOPLEVEL-DEFVAR/DEFPARAMETER PROCESS-TOPLEVEL-DEFPACKAGE/IN-PACKAGE PROCESS-TOPLEVEL-DECLARE PROCESS-TOPLEVEL-PROGN PROCESS-TOPLEVEL-DEFTYPE PROCESS-TOPLEVEL-EVAL-WHEN PROCESS-TOPLEVEL-DEFMETHOD/DEFGENERIC PROCESS-TOPLEVEL-LOCALLY PROCESS-TOPLEVEL-DEFMACRO PROCESS-TOPLEVEL-DEFUN INSTALL-TOPLEVEL-HANDLER PROCESS-TOPLEVEL-FORM POPULATE-ZIP-FASL WRITE-FASL-PROLOGUE COMPILE-FROM-STREAM COMPILE-FILE-IF-NEEDED) (("compile-system") CHECK-LISP-HOME GROVEL-JAVA-DEFINITIONS-IN-FILE GROVEL-JAVA-DEFINITIONS PACKAGES-FROM-COMBOS REMOVE-MULTI-COMBO-SYMBOLS SET-EQUAL COMBOS-TO-SYMBOL-FILESETS COMBOS-TO-FILESET-SYMBOLS WRITE-AUTOLOADER WRITE-PACKAGE-FILESETS LOAD-COMBOS GENERATE-AUTOLOADS %COMPILE-SYSTEM CREATE-SYSTEM-LOGICAL-TRANSLATIONS) (("compiler-error") COMPILER-STYLE-WARN COMPILER-WARN COMPILER-ERROR INTERNAL-COMPILER-ERROR COMPILER-UNSUPPORTED) (("compiler-macro") COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND) (("compiler-pass2") AUTOCOMPILE) (("compiler-types") MAKE-CONSTANT-TYPE CONSTANT-TYPE-P %MAKE-INTEGER-TYPE INTEGER-TYPE-P MAKE-INTEGER-TYPE FIXNUM-TYPE-P FIXNUM-CONSTANT-VALUE INTEGER-CONSTANT-VALUE JAVA-LONG-TYPE-P MAKE-UNION-TYPE MAKE-COMPILER-TYPE INTEGER-TYPE-SUBTYPEP COMPILER-SUBTYPEP FUNCTION-RESULT-TYPE SET-FUNCTION-RESULT-TYPE %DEFKNOWN) (("concatenate") CONCATENATE-TO-STRING) (("debug") INTERNAL-DEBUG DEBUG-LOOP INVOKE-DEBUGGER-REPORT-CONDITION RUN-HOOK BACKTRACE-AS-LIST) (("define-symbol-macro") %DEFINE-SYMBOL-MACRO) (("defpackage") DESIGNATED-PACKAGE-NAME STRINGIFY-NAMES CHECK-DISJOINT) (("defsetf") %DEFSETF) (("defstruct") MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION KEYWORDIFY DEFINE-KEYWORD-CONSTRUCTOR FIND-DSD GET-SLOT DEFINE-BOA-CONSTRUCTOR DEFAULT-CONSTRUCTOR-NAME DEFINE-CONSTRUCTORS NAME-INDEX DEFINE-PREDICATE MAKE-LIST-READER MAKE-VECTOR-READER MAKE-STRUCTURE-READER DEFINE-READER MAKE-LIST-WRITER MAKE-VECTOR-WRITER MAKE-STRUCTURE-WRITER DEFINE-WRITER DEFINE-ACCESS-FUNCTIONS DEFINE-COPIER DEFINE-PRINT-FUNCTION PARSE-1-OPTION PARSE-NAME-AND-OPTIONS COMPILER-DEFSTRUCT DEFSTRUCT-DEFAULT-CONSTRUCTOR) (("deftype") EXPAND-DEFTYPE) (("delete-duplicates") LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*) (("describe-compiler-policy") DESCRIBE-COMPILER-POLICY) (("describe") DESCRIBE-ARGLIST %DESCRIBE-OBJECT) (("destructuring-bind") PARSE-BODY ARG-COUNT-ERROR PARSE-DEFMACRO DEFMACRO-ERROR VERIFY-KEYWORDS LOOKUP-KEYWORD KEYWORD-SUPPLIED-P PARSE-DEFMACRO-LAMBDA-LIST PUSH-SUB-LIST-BINDING PUSH-LET-BINDING PUSH-OPTIONAL-BINDING MAKE-MACRO-EXPANDER) (("directory") PATHNAME-AS-FILE WILD-INFERIORS-P LIST-DIRECTORIES-WITH-WILDCARDS) (("do") DO-DO-BODY) (("dump-form") GET-INSTANCE-FORM DF-REGISTER-CIRCULARITY DF-CHECK-CONS DF-CHECK-VECTOR DF-CHECK-INSTANCE DF-CHECK-OBJECT DF-HANDLE-CIRCULARITY DUMP-CONS DUMP-VECTOR DUMP-INSTANCE DUMP-UNINTERNED-SYMBOL-INDEX DUMP-OBJECT DUMP-FORM) (("ed") DEFAULT-ED-FUNCTION) (("enough-namestring") EQUAL-COMPONENTS-P) (("fill") LIST-FILL VECTOR-FILL) (("find") LIST-POSITION* VECTOR-POSITION* LIST-FIND* VECTOR-FIND*) (("format") SYMBOLICATE PROPER-LIST-OF-LENGTH-P FLONUM-TO-STRING ROUND-UP SCALE-EXPONENT FLOAT-DENORMALIZED-P) (("inline") INLINE-EXPANSION SET-INLINE-EXPANSION) (("inspect") LEADER SAFE-LENGTH DISPLAY-OBJECT DISPLAY-CURRENT ISTEP) (("late-setf") MAKE-GENSYM-LIST) (("lcm") TWO-ARG-LCM) (("ldb") %LDB) (("load") LOAD-RETURNING-LAST-RESULT) (("make-sequence") SIZE-MISMATCH-ERROR) (("map1") MAP1) (("nsubstitute") NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*) (("open") UPGRADED-ELEMENT-TYPE-BITS UPGRADED-ELEMENT-TYPE) (("parse-integer") PARSE-INTEGER-ERROR) (("parse-lambda-list") PARSE-LAMBDA-LIST-LIKE-THING PARSE-LAMBDA-LIST) (("pathnames") COMPONENT-MATCH-WILD-P COMPONENT-MATCH-P DIRECTORY-MATCH-COMPONENTS DIRECTORY-MATCH-P WILD-P CASIFY TRANSLATE-COMPONENT TRANSLATE-JAR-DEVICE TRANSLATE-DIRECTORY-COMPONENTS-AUX TRANSLATE-DIRECTORY-COMPONENTS TRANSLATE-DIRECTORY LOGICAL-HOST-P CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS %SET-LOGICAL-PATHNAME-TRANSLATIONS) (("print-unreadable-object") %PRINT-UNREADABLE-OBJECT) (("print") COMPOUND-OBJECT-P OUTPUT-INTEGER OUTPUT-LIST OUTPUT-TERSE-ARRAY ARRAY-READABLY-PRINTABLE-P OUTPUT-VECTOR OUTPUT-UGLY-OBJECT CHECK-FOR-CIRCULARITY HANDLE-CIRCULARITY PRINT-LABEL PRINT-REFERENCE UNIQUELY-IDENTIFIED-BY-PRINT-P %PRINT-OBJECT %CHECK-OBJECT OUTPUT-OBJECT) (("proclaim") DECLARATION-ERROR CHECK-DECLARATION-TYPE PROCLAIM-TYPE PROCLAIMED-TYPE PROCLAIM-FTYPE-1 PROCLAIM-FTYPE PROCLAIMED-FTYPE FTYPE-RESULT-TYPE) (("query") QUERY-READLINE) (("read-circle") CIRCLE-SUBST SHARP-EQUAL SHARP-SHARP) (("read-conditional") READ-FEATURE READ-CONDITIONAL) (("remove-duplicates") LIST-REMOVE-DUPLICATES VECTOR-REMOVE-DUPLICATES) (("replace") LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR* VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*) (("run-program") RUN-PROGRAM %MAKE-PROCESS PROCESS-P MAKE-PROCESS PROCESS-ALIVE-P PROCESS-WAIT PROCESS-EXIT-CODE PROCESS-KILL %MAKE-PROCESS-BUILDER %PROCESS-BUILDER-ENVIRONMENT %PROCESS-BUILDER-ENV-PUT %PROCESS-BUILDER-ENV-CLEAR %PROCESS-BUILDER-START %MAKE-PROCESS-INPUT-STREAM %MAKE-PROCESS-OUTPUT-STREAM %MAKE-PROCESS-ERROR-STREAM %PROCESS-ALIVE-P %PROCESS-WAIT %PROCESS-EXIT-CODE %PROCESS-KILL) (("search") SIMPLE-SEARCH) (("sequences") MAKE-SEQUENCE-OF-TYPE) (("setf") GET-SETF-METHOD-INVERSE EXPAND-OR-GET-SETF-INVERSE %SET-SUBSEQ %DEFINE-SETF-MACRO %SET-CAAR %SET-CADR %SET-CDAR %SET-CDDR %SET-CAAAR %SET-CADAR %SET-CDAAR %SET-CDDAR %SET-CAADR %SET-CADDR %SET-CDADR %SET-CDDDR %SET-CAAAAR %SET-CADAAR %SET-CDAAAR %SET-CDDAAR %SET-CAADAR %SET-CADDAR %SET-CDADAR %SET-CDDDAR %SET-CAAADR %SET-CADADR %SET-CDAADR %SET-CDDADR %SET-CAADDR %SET-CADDDR %SET-CDADDR %SET-CDDDDR %SET-FIFTH %SET-SIXTH %SET-SEVENTH %SET-EIGHTH %SET-NINTH %SET-TENTH) (("sort") MERGE-SORT-VECTORS LAST-CONS-OF MERGE-LISTS MERGE-LISTS-NO-KEY SORT-LIST QUICKSORT QUICK-SORT) (("source-transform") SOURCE-TRANSFORM SET-SOURCE-TRANSFORM EXPAND-SOURCE-TRANSFORM-1 EXPAND-SOURCE-TRANSFORM) (("subst") %SUBST %SUBST-IF %SUBST-IF-NOT) (("subtypep") INITIALIZE-KNOWN-TYPES KNOWN-TYPE-P SUB-INTERVAL-P DIMENSION-SUBTYPEP SIMPLE-SUBTYPEP MAKE-CTYPE CTYPE-SUPER CTYPE-TYPE CTYPE CSUBTYPEP-ARRAY CSUBTYPEP-FUNCTION CSUBTYPEP-COMPLEX CSUBTYPEP %SUBTYPEP) (("time") PICK-OBVIOUS-YEAR LEAP-YEARS-BEFORE) (("trace") MAKE-TRACE-INFO TRACE-INFO-P LIST-TRACED-FUNCTIONS EXPAND-TRACE TRACE-1 TRACED-FUNCTION UNTRACED-FUNCTION TRACE-REDEFINED-UPDATE INDENT UNTRACE-ALL UNTRACE-1) (("tree-equal") TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST) (("typep") SIMPLE-ARRAY-P IN-INTERVAL-P MATCH-DIMENSIONS %TYPEP) (("with-hash-table-iterator") HASH-TABLE-ITERATOR-FUNCTION) (("with-package-iterator") PACKAGE-ITERATOR-FUNCTION) (("with-standard-io-syntax") %WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR FS) (CAR (CAR FS)))) ;; MACROS From ehuelsmann at common-lisp.net Wed Apr 3 21:34:55 2013 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 03 Apr 2013 14:34:55 -0700 Subject: [armedbear-cvs] r14460 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 3 14:34:53 2013 New Revision: 14460 Log: * Rename FASL entry point inside the fasl from "._" to "__loader__._" in case of zipped fasls. In case of "directory fasls", the loader is (still) called ".abcl". * Delete temporary directory after repackaging fasls. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Wed Apr 3 14:28:32 2013 (r14459) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Wed Apr 3 14:34:53 2013 (r14460) @@ -323,6 +323,7 @@ && truename.type.princToString().equals(COMPILE_FILE_TYPE) && Utilities.checkZipFile(truename)) { Pathname init = new Pathname(truename.getNamestring()); init.type = COMPILE_FILE_INIT_FASL_TYPE; + init.name = new SimpleString("__loader__"); LispObject t = Pathname.truename(init); if (t instanceof Pathname) { truename = (Pathname)t; Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Apr 3 14:28:32 2013 (r14459) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Apr 3 14:34:53 2013 (r14460) @@ -687,6 +687,7 @@ (push resource pathnames)))))) (setf pathnames (nreverse (remove nil pathnames))) (let ((load-file (make-pathname :defaults output-file + :name "__loader__" :type "_"))) (rename-file output-file load-file) (push load-file pathnames)) Modified: trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp Wed Apr 3 14:28:32 2013 (r14459) +++ trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp Wed Apr 3 14:34:53 2013 (r14460) @@ -44,44 +44,48 @@ (defun load-concatenated-fasl (sub-fasl) (let ((fasl-path (merge-pathnames (make-pathname :directory (list :relative sub-fasl) - :name sub-fasl + :name "__loader__" :type "_") *load-truename-fasl*))) (load fasl-path))) (defun concatenate-fasls (inputs output) - (let* ((directory (print (ext:make-temp-directory))) - (unpacked (mapcan #'(lambda (input) - (sys:unzip (print input) - (ensure-directories-exist - (sub-directory directory - (pathname-name (print input)))))) - inputs)) - (chain-loader (make-pathname :name (pathname-name output) - :type "_" - :defaults directory))) - (with-open-file (f chain-loader - :direction :output - :if-does-not-exist :create - :if-exists :overwrite) - (write-string - ";; loader code to delegate loading of the embedded fasls below" f) - (terpri f) - (sys::dump-form `(sys:init-fasl :version ,sys:*fasl-version*) f) - (terpri f) - (dolist (input inputs) - (sys::dump-form `(load-concatenated-fasl ,(pathname-name input)) f) - (terpri f))) - (let ((paths (remove-if #'pathname-directory-p - (directory - (merge-pathnames - (make-pathname :directory '(:relative - :wild-inferiors) - :name "*" - :type "*") - directory))))) - (sys:zip output paths directory)) - (values directory unpacked chain-loader))) + (let ((directory (ext:make-temp-directory)) + paths) + (unwind-protect + (let* ((unpacked (mapcan #'(lambda (input) + (sys:unzip input + (ensure-directories-exist + (sub-directory directory + (pathname-name input))))) + inputs)) + (chain-loader (make-pathname :name "__loader__" + :type "_" + :defaults directory))) + (with-open-file (f chain-loader + :direction :output + :if-does-not-exist :create + :if-exists :overwrite) + (write-string + ";; loader code to delegate loading of the embedded fasls below" f) + (terpri f) + (sys::dump-form `(sys:init-fasl :version ,sys:*fasl-version*) f) + (terpri f) + (dolist (input inputs) + (sys::dump-form `(load-concatenated-fasl ,(pathname-name input)) f) + (terpri f))) + (setf paths + (directory (merge-pathnames + (make-pathname :directory '(:relative + :wild-inferiors) + :name "*" + :type "*") + directory))) + (sys:zip output (remove-if #'pathname-directory-p paths) directory) + (values directory unpacked chain-loader)) + (dolist (path paths) + (ignore-errors (delete-file path))) + (ignore-errors (delete-file directory))))) (defun sub-directory (directory name) (merge-pathnames (make-pathname :directory (list :relative name)) From mevenson at common-lisp.net Thu Apr 4 13:57:21 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 04 Apr 2013 06:57:21 -0700 Subject: [armedbear-cvs] r14461 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Apr 4 06:57:20 2013 New Revision: 14461 Log: Update to asdf-2.33. Modified: trunk/abcl/doc/asdf/asdf.texinfo trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/doc/asdf/asdf.texinfo ============================================================================== --- trunk/abcl/doc/asdf/asdf.texinfo Wed Apr 3 14:34:53 2013 (r14460) +++ trunk/abcl/doc/asdf/asdf.texinfo Thu Apr 4 06:57:20 2013 (r14461) @@ -993,7 +993,7 @@ component-def := ( component-type simple-component-name @var{option}* ) -component-type := :system | :module | :file | :static-file | other-component-type +component-type := :module | :file | :static-file | other-component-type other-component-type := symbol-by-name (@pxref{The defsystem grammar,,Component types}) @@ -1035,10 +1035,15 @@ the current package @code{my-system-asd} can be specified as @code{:my-component-type}, or @code{my-component-type}. + at code{system} and its subclasses are @emph{not} +allowed as component types for such children components. + @subsection System class names -A system class name will be looked up in the same way as a Component -type (see above). Typically, one will not need to specify a system +A system class name will be looked up +in the same way as a Component type (see above), +except that only @code{system} and its subclasses are allowed. +Typically, one will not need to specify a system class name, unless using a non-standard system class defined in some ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON}, see below. For such class names in the ASDF package, we recommend that Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Wed Apr 3 14:34:53 2013 (r14460) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Thu Apr 4 06:57:20 2013 (r14461) @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.32: Another System Definition Facility. +;;; This is ASDF 2.33: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -71,10 +71,10 @@ (existing-version-number (and existing-version (read-from-string existing-major-minor))) (away (format nil "~A-~A" :asdf existing-version))) (when (and existing-version (< existing-version-number - (or #+abcl 2.25 #+cmu 2.018 2.27))) + (or #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27))) (rename-package :asdf away) (when *load-verbose* - (format t "; Renamed old ~A package away to ~A~%" :asdf away)))))) + (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. @@ -1014,12 +1014,15 @@ #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export ;; magic helper to define debugging functions: - #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility* + #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions #:if-let ;; basic flow control - #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists + #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists + #:remove-plist-keys #:remove-plist-key ;; plists #:emptyp ;; sequences - #:strcat #:first-char #:last-char #:split-string ;; strings + #:+non-base-chars-exist-p+ ;; characters + #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings + #:first-char #:last-char #:split-string #:string-prefix-p #:string-enclosed-p #:string-suffix-p #:find-class* ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps @@ -1092,22 +1095,22 @@ ;;; Magic debugging help. See contrib/debug.lisp (with-upgradability () - (defvar *asdf-debug-utility* + (defvar *uiop-debug-utility* '(or (ignore-errors - (symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp")) - (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname))) + (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")) + (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp")) "form that evaluates to the pathname to your favorite debugging utilities") - (defmacro asdf-debug (&rest keys) + (defmacro uiop-debug (&rest keys) `(eval-when (:compile-toplevel :load-toplevel :execute) - (load-asdf-debug-utility , at keys))) + (load-uiop-debug-utility , at keys))) - (defun load-asdf-debug-utility (&key package utility-file) + (defun load-uiop-debug-utility (&key package utility-file) (let* ((*package* (if package (find-package package) *package*)) (keyword (read-from-string (format nil ":DBG-~:@(~A~)" (package-name *package*))))) (unless (member keyword *features*) - (let* ((utility-file (or utility-file *asdf-debug-utility*)) + (let* ((utility-file (or utility-file *uiop-debug-utility*)) (file (ignore-errors (probe-file (eval utility-file))))) (if file (load file) (error "Failed to locate debug utility file: ~S" utility-file))))))) @@ -1156,7 +1159,11 @@ :for i :downfrom n :do (cond ((zerop i) (return (null l))) - ((not (consp l)) (return nil)))))) + ((not (consp l)) (return nil))))) + + (defun ensure-list (x) + (if (listp x) x (list x)))) + ;;; remove a key from a plist, i.e. for keyword argument cleanup (with-upgradability () @@ -1180,10 +1187,42 @@ (or (null x) (and (vectorp x) (zerop (length x)))))) +;;; Characters +(with-upgradability () + (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) + (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) + + ;;; Strings (with-upgradability () + (defun base-string-p (string) + (declare (ignorable string)) + (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string)))) + + (defun strings-common-element-type (strings) + (declare (ignorable strings)) + #-non-base-chars-exist-p 'character + #+non-base-chars-exist-p + (if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s))) + 'base-char 'character)) + + (defun reduce/strcat (strings &key key start end) + "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE. +NIL is interpreted as an empty string. A character is interpreted as a string of length one." + (when (or start end) (setf strings (subseq strings start end))) + (when key (setf strings (mapcar key strings))) + (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s))) + :element-type (strings-common-element-type strings)) + :with pos = 0 + :for input :in strings + :do (etypecase input + (null) + (character (setf (char output pos) input) (incf pos)) + (string (replace output input :start1 pos) (incf pos (length input)))) + :finally (return output))) + (defun strcat (&rest strings) - (apply 'concatenate 'string strings)) + (reduce/strcat strings)) (defun first-char (s) (and (stringp s) (plusp (length s)) (char s 0))) @@ -1204,12 +1243,11 @@ (loop :for start = (if (and max (>= words (1- max))) (done) - (position-if #'separatorp string :end end :from-end t)) :do - (when (null start) - (done)) - (push (subseq string (1+ start) end) list) - (incf words) - (setf end start)))))) + (position-if #'separatorp string :end end :from-end t)) + :do (when (null start) (done)) + (push (subseq string (1+ start) end) list) + (incf words) + (setf end start)))))) (defun string-prefix-p (prefix string) "Does STRING begin with PREFIX?" @@ -2427,8 +2465,14 @@ (t (translate-pathname path absolute-source destination)))) - (defvar *output-translation-function* 'identity)) ; Hook for output translations + (defvar *output-translation-function* 'identity + "Hook for output translations. +This function needs to be idempotent, so that actions can work +whether their inputs were translated or not, +which they will be if we are composing operations. e.g. if some +create-lisp-op creates a lisp file from some higher-level input, +you need to still be able to use compile-op on that lisp file.")) ;;;; ------------------------------------------------------------------------- ;;;; Portability layer around Common Lisp filesystem access @@ -2441,7 +2485,7 @@ ;; Native namestrings #:native-namestring #:parse-native-namestring ;; Probing the filesystem - #:truename* #:safe-file-write-date #:probe-file* + #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories #:collect-sub*directories ;; Resolving symlinks somewhat @@ -2456,7 +2500,7 @@ ;; Simple filesystem operations #:ensure-all-directories-exist #:rename-file-overwriting-target - #:delete-file-if-exists)) + #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree)) (in-package :uiop/filesystem) ;;; Native namestrings, as seen by the operating system calls rather than Lisp @@ -2564,10 +2608,18 @@ (probe resolve))))) (file-error () nil))))))) + (defun directory-exists-p (x) + (let ((p (probe-file* x :truename t))) + (and (directory-pathname-p p) p))) + + (defun file-exists-p (x) + (let ((p (probe-file* x :truename t))) + (and (file-pathname-p p) p))) + (defun directory* (pathname-spec &rest keys &key &allow-other-keys) (apply 'directory pathname-spec (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) - #+clozure '(:follow-links nil) + #+(or clozure digitool) '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmu scl) '(:follow-links nil :truenamep nil) #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) @@ -2602,7 +2654,11 @@ (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) (setf pattern (make-pathname-logical pattern (pathname-host dir)))) - (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) + (let* ((pat (merge-pathnames* pattern dir)) + (entries (append (ignore-errors (directory* pat)) + #+clisp + (when (equal :wild (pathname-type pattern)) + (ignore-errors (directory* (make-pathname :type nil :defaults pat))))))) (filter-logical-directory-results directory entries #'(lambda (f) @@ -2649,10 +2705,10 @@ :directory (append prefix (make-pathname-component-logical (last dir))))))))))) (defun collect-sub*directories (directory collectp recursep collector) - (when (funcall collectp directory) - (funcall collector directory)) + (when (call-function collectp directory) + (call-function collector directory)) (dolist (subdir (subdirectories directory)) - (when (funcall recursep subdir) + (when (call-function recursep subdir) (collect-sub*directories subdir collectp recursep collector))))) ;;; Resolving symlinks somewhat @@ -2790,7 +2846,8 @@ (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") (check want-relative (relative-pathname-p p) "Expected a relative pathname") (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname") - (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults)) + (transform ensure-absolute (not (absolute-pathname-p p)) + (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?"))) (check ensure-absolute (absolute-pathname-p p) "Could not make into an absolute pathname even after merging with ~S" defaults) (check ensure-subpath (absolute-pathname-p defaults) @@ -2850,8 +2907,10 @@ (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) :collect (apply 'parse-native-namestring namestring constraints))) - (defun getenv-pathname (x &rest constraints &key on-error &allow-other-keys) + (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys) + ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory (apply 'parse-native-namestring (getenvp x) + :ensure-directory (or ensure-directory want-directory) :on-error (or on-error `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) constraints)) @@ -2907,8 +2966,85 @@ #+clozure :if-exists #+clozure :rename-and-delete)) (defun delete-file-if-exists (x) - (when x (handler-case (delete-file x) (file-error () nil))))) + (when x (handler-case (delete-file x) (file-error () nil)))) + (defun delete-empty-directory (directory-pathname) + "Delete an empty directory" + #+(or abcl digitool gcl) (delete-file directory-pathname) + #+allegro (excl:delete-directory directory-pathname) + #+clisp (ext:delete-directory directory-pathname) + #+clozure (ccl::delete-empty-directory directory-pathname) + #+(or cmu scl) (multiple-value-bind (ok errno) + (unix:unix-rmdir (native-namestring directory-pathname)) + (unless ok + #+cmu (error "Error number ~A when trying to delete directory ~A" + errno directory-pathname) + #+scl (error "~@" + directory-pathname (unix:get-unix-error-msg errno)))) + #+cormanlisp (win32:delete-directory directory-pathname) + #+ecl (si:rmdir directory-pathname) + #+lispworks (lw:delete-directory directory-pathname) + #+mkcl (mkcl:rmdir directory-pathname) + #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) + `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later + `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) + #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl) + (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl + + (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) + "Delete a directory including all its recursive contents, aka rm -rf. + +To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be +a physical non-wildcard directory pathname (not namestring). + +If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens: +if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done. + +Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass +the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument +which in practice is thus compulsory, and validates by returning a non-NIL result. +If you're suicidal or extremely confident, just use :VALIDATE T." + (check-type if-does-not-exist (member :error :ignore)) + (cond + ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname) + (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname)))) + (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname" + 'delete-filesystem-tree directory-pathname)) + ((not validatep) + (error "~S was asked to delete ~S but was not provided a validation predicate" + 'delete-filesystem-tree directory-pathname)) + ((not (call-function validate directory-pathname)) + (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" + 'delete-filesystem-tree directory-pathname validate)) + ((not (directory-exists-p directory-pathname)) + (ecase if-does-not-exist + (:error + (error "~S was asked to delete ~S but the directory does not exist" + 'delete-filesystem-tree directory-pathname)) + (:ignore nil))) + #-(or allegro cmu clozure sbcl scl) + ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, + ;; except on implementations where we can prevent DIRECTORY from following symlinks; + ;; instead spawn a standard external program to do the dirty work. + (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname)))) + (t + ;; On supported implementation, call supported system functions + #+allegro (symbol-call :excl.osi :delete-directory-and-files + directory-pathname :if-does-not-exist if-does-not-exist) + #+clozure (ccl:delete-directory directory-pathname) + #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type)) + #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) + `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later + '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) + ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks, + ;; do things the hard way. + #-(or allegro clozure genera sbcl) + (let ((sub*directories + (while-collecting (c) + (collect-sub*directories directory-pathname t t #'c)))) + (dolist (d (nreverse sub*directories)) + (map () 'delete-file (directory-files d)) + (delete-empty-directory d))))))) ;;;; --------------------------------------------------------------------------- ;;;; Utilities related to streams @@ -2926,7 +3062,7 @@ #:with-output #:output-string #:with-input #:with-input-file #:call-with-input-file #:finish-outputs #:format! #:safe-format! - #:copy-stream-to-stream #:concatenate-files + #:copy-stream-to-stream #:concatenate-files #:copy-file #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line #:slurp-stream-forms #:slurp-stream-form #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form @@ -3158,6 +3294,10 @@ :direction :input :if-does-not-exist :error) (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) + (defun copy-file (input output) + ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f) + (concatenate-files (list input) output)) + (defun slurp-stream-string (input &key (element-type 'character)) "Read the contents of the INPUT stream as a string" (with-open-stream (input input) @@ -3308,7 +3448,7 @@ #+gcl2.6 (declare (ignorable external-format)) (check-type direction (member :output :io)) (loop - :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory)))) + :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory)) :for counter :from (random (ash 1 32)) :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do ;; TODO: on Unix, do something about umask @@ -3410,6 +3550,9 @@ (defvar *image-restore-hook* nil "Functions to call (in reverse order) when the image is restored") + (defvar *image-restored-p* nil + "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping") + (defvar *image-prelude* nil "a form to evaluate, or string containing forms to read and evaluate when the image is restarted, but before the entry point is called.") @@ -3602,10 +3745,17 @@ ((:lisp-interaction *lisp-interaction*) *lisp-interaction*) ((:restore-hook *image-restore-hook*) *image-restore-hook*) ((:prelude *image-prelude*) *image-prelude*) - ((:entry-point *image-entry-point*) *image-entry-point*)) + ((:entry-point *image-entry-point*) *image-entry-point*) + (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) + (when *image-restored-p* + (if if-already-restored + (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t)) + (return-from restore-image))) (with-fatal-condition-handler () + (setf *image-restored-p* :in-progress) (call-image-restore-hook) (standard-eval-thunk *image-prelude*) + (setf *image-restored-p* t) (let ((results (multiple-value-list (if *image-entry-point* (call-function *image-entry-point*) @@ -3618,14 +3768,16 @@ ;;; Dumping an image (with-upgradability () - #-(or ecl mkcl) (defun dump-image (filename &key output-name executable ((:postlude *image-postlude*) *image-postlude*) - ((:dump-hook *image-dump-hook*) *image-dump-hook*)) + ((:dump-hook *image-dump-hook*) *image-dump-hook*) + #+clozure prepend-symbols #+clozure (purify t)) (declare (ignorable filename output-name executable)) (setf *image-dumped-p* (if executable :executable t)) + (setf *image-restored-p* :in-regress) (standard-eval-thunk *image-postlude*) (call-image-dump-hook) + (setf *image-restored-p* nil) #-(or clisp clozure cmu lispworks sbcl scl) (when executable (error "Dumping an executable is not supported on this implementation! Aborting.")) @@ -3644,8 +3796,16 @@ ;; :parse-options nil ;--- requires a non-standard patch to clisp. :norc t :script nil :init-function #'restore-image))) #+clozure - (ccl:save-application filename :prepend-kernel t - :toplevel-function (when executable #'restore-image)) + (flet ((dump (prepend-kernel) + (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify + :toplevel-function (when executable #'restore-image)))) + ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system)) + (if prepend-symbols + (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path) + (require 'elf) + (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) + (dump path)) + (dump t))) #+(or cmu scl) (progn (ext:gc :full t) @@ -3669,33 +3829,36 @@ :executable t ;--- always include the runtime that goes with the core (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) - (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%" - filename (nth-value 1 (implementation-type)))) + (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" + 'dump-image filename (nth-value 1 (implementation-type)))) - - #+ecl (defun create-image (destination object-files - &key kind output-name prologue-code epilogue-code - (prelude () preludep) (entry-point () entry-point-p) build-args) + &key kind output-name prologue-code epilogue-code + (prelude () preludep) (postlude () postludep) + (entry-point () entry-point-p) build-args) + (declare (ignorable destination object-files kind output-name prologue-code epilogue-code + prelude preludep postlude postludep entry-point entry-point-p build-args)) ;; Is it meaningful to run these in the current environment? ;; only if we also track the object files that constitute the "current" image, ;; and otherwise simulate dump-image, including quitting at the end. - ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook) - (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program)) - (apply 'c::builder - kind (pathname destination) - :lisp-files object-files - :init-name (c::compute-init-name (or output-name destination) :kind kind) - :prologue-code prologue-code - :epilogue-code - `(progn - ,epilogue-code - ,@(when (eq kind :program) - `((setf *image-dumped-p* :executable) - (restore-image ;; default behavior would be (si::top-level) - ,@(when preludep `(:prelude ',prelude)) - ,@(when entry-point-p `(:entry-point ',entry-point)))))) - build-args))) + #-ecl (error "~S not implemented for your implementation (yet)" 'create-image) + #+ecl + (progn + (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program)) + (apply 'c::builder + kind (pathname destination) + :lisp-files object-files + :init-name (c::compute-init-name (or output-name destination) :kind kind) + :prologue-code prologue-code + :epilogue-code + `(progn + ,epilogue-code + ,@(when (eq kind :program) + `((setf *image-dumped-p* :executable) + (restore-image ;; default behavior would be (si::top-level) + ,@(when preludep `(:prelude ',prelude)) + ,@(when entry-point-p `(:entry-point ',entry-point)))))) + build-args)))) ;;; Some universal image restore hooks @@ -3969,7 +4132,7 @@ #+os-unix (coerce (cons (first command) command) 'vector) #+os-windows command :input interactive :output (or (and pipe :stream) interactive) :wait wait - #+os-windows :show-window #+os-windows (and pipe :hide)) + #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide)) #+clisp (flet ((run (f &rest args) (apply f `(, at args :input ,(when interactive :terminal) :wait ,wait :output @@ -3995,9 +4158,9 @@ ;; note: :external-format requires a recent SBCL #+sbcl '(:search t :external-format external-format))))) (process - #+(or allegro lispworks) (if pipe (third process*) (first process*)) + #+allegro (if pipe (third process*) (first process*)) #+ecl (third process*) - #-(or allegro lispworks ecl) (first process*)) + #-(or allegro ecl) (first process*)) (stream (when pipe #+(or allegro lispworks ecl) (first process*) @@ -4020,7 +4183,7 @@ #+clozure (nth-value 1 (ccl:external-process-status process)) #+(or cmu scl) (ext:process-exit-code process) #+ecl (nth-value 1 (ext:external-process-status process)) - #+lispworks (if pipe (system:pid-exit-status process :wait t) process) + #+lispworks (if pipe (system:pipe-exit-status process :wait t) process) #+sbcl (sb-ext:process-exit-code process)) (check-result (exit-code process) #+clisp @@ -4059,7 +4222,9 @@ (declare (ignorable interactive)) #+(or abcl xcl) (ext:run-shell-command command) #+allegro - (excl:run-shell-command command :input interactive :output interactive :wait t) + (excl:run-shell-command + command :input interactive :output interactive :wait t + #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide)) #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl) (process-result (run-program command :pipe nil :interactive interactive) nil) #+ecl (ext:system command) @@ -4067,7 +4232,7 @@ #+gcl (lisp:system command) #+(and lispworks os-windows) (system:call-system-showing-output - command :show-cmd interactive :prefix "" :output-stream nil) + command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil) #+mcl (ccl::with-cstrs ((%command command)) (_system %command)) #+mkcl (nth-value 2 (mkcl:run-program #+windows command #+windows () @@ -4109,13 +4274,15 @@ #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error #:compile-warned-warning #:compile-failed-warning #:check-lisp-compile-results #:check-lisp-compile-warnings - #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* + #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* + ;; Types + #+sbcl #:sb-grovel-unknown-constant-condition ;; Functions & Macros #:get-optimization-settings #:proclaim-optimization-settings #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions #:reify-simple-sexp #:unreify-simple-sexp - #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings + #:reify-deferred-warnings #:unreify-deferred-warnings #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check @@ -4146,15 +4313,16 @@ (defvar *previous-optimization-settings* nil) (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" + #-(or clisp clozure cmu ecl sbcl scl) + (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type)) + #+clozure (ccl:declaration-information 'optimize nil) + #+(or clisp cmu ecl sbcl scl) (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) - #-(or clisp clozure cmu ecl sbcl scl) - (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.") #.`(loop :for x :in settings - ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*)) - #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*)) + ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*)) #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity))) :for y = (or #+clisp (gethash x system::*optimize*) - #+(or clozure ecl) (symbol-value v) + #+(or ecl) (symbol-value v) #+(or cmu scl) (funcall f c::*default-cookie*) #+sbcl (cdr (assoc x sb-c::*policy*))) :when y :collect (list x y)))) @@ -4179,7 +4347,7 @@ (deftype sb-grovel-unknown-constant-condition () '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)))) - (defvar *uninteresting-compiler-conditions* + (defvar *uninteresting-conditions* (append ;;#+clozure '(ccl:compiler-warning) #+cmu '("Deleting unreachable code.") @@ -4188,38 +4356,39 @@ #+sbcl '(sb-c::simple-compiler-note "&OPTIONAL and &KEY found in the same lambda list: ~S" - sb-int:package-at-variance - sb-kernel:uninteresting-redefinition - sb-kernel:undefined-alien-style-warning - ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default. #+sb-eval sb-kernel:lexical-environment-too-complex + sb-kernel:undefined-alien-style-warning sb-grovel-unknown-constant-condition ; defined above. + ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default. + sb-int:package-at-variance + sb-kernel:uninteresting-redefinition ;; BEWARE: the below four are controversial to include here. sb-kernel:redefinition-with-defun sb-kernel:redefinition-with-defgeneric sb-kernel:redefinition-with-defmethod sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop - "Conditions that may be skipped while compiling") - + "Conditions that may be skipped while compiling or loading Lisp code.") + (defvar *uninteresting-compiler-conditions* '() + "Additional conditions that may be skipped while compiling Lisp code.") (defvar *uninteresting-loader-conditions* (append '("Overwriting already existing readtable ~S." ;; from named-readtables #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers #+clisp '(clos::simple-gf-replacing-method-warning)) - "Additional conditions that may be skipped while loading")) + "Additional conditions that may be skipped while loading Lisp code.")) ;;;; ----- Filtering conditions while building ----- (with-upgradability () (defun call-with-muffled-compiler-conditions (thunk) (call-with-muffled-conditions - thunk *uninteresting-compiler-conditions*)) + thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*))) (defmacro with-muffled-compiler-conditions ((&optional) &body body) "Run BODY where uninteresting compiler conditions are muffled" `(call-with-muffled-compiler-conditions #'(lambda () , at body))) (defun call-with-muffled-loader-conditions (thunk) (call-with-muffled-conditions - thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*))) + thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*))) (defmacro with-muffled-loader-conditions ((&optional) &body body) "Run BODY where uninteresting compiler and additional loader conditions are muffled" `(call-with-muffled-loader-conditions #'(lambda () , at body)))) @@ -4322,10 +4491,18 @@ name)) (defun reify-function-name (function-name) (let ((name (or (first function-name) ;; defun: extract the name - (first (second function-name))))) ;; defmethod: keep gf name, drop method specializers + (let ((sec (second function-name))) + (or (and (atom sec) sec) ; scoped method: drop scope + (first sec)))))) ; method: keep gf name, drop method specializers (list name))) (defun unreify-function-name (function-name) function-name) + (defun nullify-non-literals (sexp) + (typecase sexp + ((or number character simple-string symbol pathname) sexp) + (cons (cons (nullify-non-literals (car sexp)) + (nullify-non-literals (cdr sexp)))) + (t nil))) (defun reify-deferred-warning (deferred-warning) (with-accessors ((warning-type ccl::compiler-warning-warning-type) (args ccl::compiler-warning-args) @@ -4333,11 +4510,10 @@ (function-name ccl:compiler-warning-function-name)) deferred-warning (list :warning-type warning-type :function-name (reify-function-name function-name) :source-note (reify-source-note source-note) - :args (destructuring-bind (fun formals env) args - (declare (ignorable env)) - (list (unsymbolify-function-name fun) - (mapcar (constantly nil) formals) - nil))))) + :args (destructuring-bind (fun &rest more) + args + (cons (unsymbolify-function-name fun) + (nullify-non-literals more)))))) (defun unreify-deferred-warning (reified-deferred-warning) (destructuring-bind (&key warning-type function-name source-note args) reified-deferred-warning @@ -4346,8 +4522,8 @@ :function-name (unreify-function-name function-name) :source-note (unreify-source-note source-note) :warning-type warning-type - :args (destructuring-bind (fun . formals) args - (cons (symbolify-function-name fun) formals)))))) + :args (destructuring-bind (fun . more) args + (cons (symbolify-function-name fun) more)))))) #+(or cmu scl) (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit @@ -4753,11 +4929,12 @@ ;;; Links FASLs together (with-upgradability () (defun combine-fasls (inputs output) - #-(or allegro clisp clozure cmu lispworks sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (error "~A does not support ~S~%inputs ~S~%output ~S" (implementation-type) 'combine-fasls inputs output) - #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) + #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output) + #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) #+lispworks (let (fasls) (unwind-protect @@ -4766,9 +4943,8 @@ :for n :from 1 :for f = (add-pathname-suffix output (format nil "-FASL~D" n)) - :do #-lispworks-personal-edition (lispworks:copy-file i f) - #+lispworks-personal-edition (concatenate-files (list i) f) - (push f fasls)) + :do (copy-file i f) + (push f fasls)) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) (eval `(scm:defsystem :fasls-to-concatenate (:default-pathname ,(pathname-directory-pathname output)) @@ -4794,7 +4970,7 @@ #:in-user-configuration-directory #:in-system-configuration-directory #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory #:configuration-inheritance-directive-p - #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* + #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache* #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration)) @@ -5188,7 +5364,7 @@ ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "2.32") + (asdf-version "2.33") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -5205,7 +5381,7 @@ #:find-system #:system-source-file #:system-relative-pathname ;; system #:find-component ;; find-component #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action - #:component-depends-on #:component-self-dependencies #:operation-done-p + #:component-depends-on #:operation-done-p #:component-depends-on #:traverse ;; plan #:operate ;; operate #:parse-component-form ;; defsystem @@ -5219,15 +5395,17 @@ (uninterned-symbols '(#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector #:do-dep #:do-one-dep + #:component-self-dependencies #:resolve-relative-location-component #:resolve-absolute-location-component #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function (declare (ignorable redefined-functions uninterned-symbols)) - (loop :for name :in (append #-(or ecl) redefined-functions) + (loop :for name :in (append redefined-functions) :for sym = (find-symbol* name :asdf nil) :do (when sym - (fmakunbound sym))) + ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh. + #-clisp (fmakunbound sym))) (loop :with asdf = (find-package :asdf) - :for name :in (append #+(or ecl) redefined-functions uninterned-symbols) ;XXX + :for name :in uninterned-symbols :for sym = (find-symbol* name :asdf nil) :for base-pkg = (and sym (symbol-package sym)) :do (when sym @@ -5289,7 +5467,7 @@ #:static-file #:doc-file #:html-file #:file-type #:source-file-type #:source-file-explicit-type ;; backward-compatibility - #:component-in-order-to #:component-sibling-dependencies + #:component-in-order-to #:component-sideway-dependencies #:component-if-feature #:around-compile-hook #:component-description #:component-long-description #:component-version #:version-satisfies @@ -5308,7 +5486,7 @@ #:components-by-name #:components #:children #:children-by-name #:default-component-class #:author #:maintainer #:licence #:source-file #:defsystem-depends-on - #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods + #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods #:relative-pathname #:absolute-pathname #:operation-times #:around-compile #:%encoding #:properties #:component-properties #:parent)) (in-package :asdf/component) @@ -5352,7 +5530,7 @@ (version :accessor component-version :initarg :version :initform nil) (description :accessor component-description :initarg :description :initform nil) (long-description :accessor component-long-description :initarg :long-description :initform nil) - (sibling-dependencies :accessor component-sibling-dependencies :initform nil) + (sideway-dependencies :accessor component-sideway-dependencies :initform nil) (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) ;; In the ASDF object model, dependencies exist between *actions*, ;; where an action is a pair of an operation and a component. @@ -6354,8 +6532,8 @@ (:export #:action #:define-convenience-action-methods #:explain #:action-description - #:downward-operation #:upward-operation #:sibling-operation - #:component-depends-on #:component-self-dependencies + #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation + #:component-depends-on #:input-files #:output-files #:output-file #:operation-done-p #:action-status #:action-stamp #:action-done-p #:component-operation-time #:mark-operation-done #:compute-action-stamp @@ -6433,7 +6611,7 @@ ;;;; Dependencies (with-upgradability () - (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies + (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies (:documentation "Returns a list of dependencies needed by the component to perform the operation. A dependency has one of the following forms: @@ -6451,19 +6629,15 @@ Methods specialized on subclasses of existing component types should usually append the results of CALL-NEXT-METHOD to the list.")) - (defgeneric component-self-dependencies (operation component)) (define-convenience-action-methods component-depends-on (operation component)) - (define-convenience-action-methods component-self-dependencies (operation component)) + + (defmethod component-depends-on :around ((o operation) (c component)) + (do-asdf-cache `(component-depends-on ,o ,c) + (call-next-method))) (defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies + (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies - (defmethod component-self-dependencies ((o operation) (c component)) - ;; NB: result in the same format as component-depends-on - (loop* :for (o-spec . c-spec) :in (component-depends-on o c) - :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature" - :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep))) - :collect (list o-spec c)))) ;;;; upward-operation, downward-operation ;; These together handle actions that propagate along the component hierarchy. @@ -6473,7 +6647,7 @@ (with-upgradability () (defclass downward-operation (operation) ((downward-operation - :initform nil :initarg :downward-operation :reader downward-operation))) + :initform nil :initarg :downward-operation :reader downward-operation :allocation :class))) (defmethod component-depends-on ((o downward-operation) (c parent-component)) `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method))) ;; Upward operations like prepare-op propagate up the component hierarchy: @@ -6481,7 +6655,7 @@ ;; By default, an operation propagates itself, but it may propagate another one instead. (defclass upward-operation (operation) ((upward-operation - :initform nil :initarg :downward-operation :reader upward-operation))) + :initform nil :initarg :downward-operation :reader upward-operation :allocation :class))) ;; For backward-compatibility reasons, a system inherits from module and is a child-component ;; so we must guard against this case. ASDF4: remove that. (defmethod component-depends-on ((o upward-operation) (c child-component)) @@ -6490,13 +6664,22 @@ ;; Sibling operations propagate to siblings in the component hierarchy: ;; operation on a child depends-on operation on its parent. ;; By default, an operation propagates itself, but it may propagate another one instead. - (defclass sibling-operation (operation) - ((sibling-operation - :initform nil :initarg :sibling-operation :reader sibling-operation))) - (defmethod component-depends-on ((o sibling-operation) (c component)) - `((,(or (sibling-operation o) o) - ,@(loop :for dep :in (component-sibling-dependencies c) + (defclass sideway-operation (operation) + ((sideway-operation + :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class))) + (defmethod component-depends-on ((o sideway-operation) (c component)) + `((,(or (sideway-operation o) o) + ,@(loop :for dep :in (component-sideway-dependencies c) :collect (resolve-dependency-spec c dep))) + ,@(call-next-method))) + ;; Selfward operations propagate to themselves a sub-operation: + ;; they depend on some other operation being acted on the same component. + (defclass selfward-operation (operation) + ((selfward-operation + :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class))) + (defmethod component-depends-on ((o selfward-operation) (c component)) + `(,@(loop :for op :in (ensure-list (selfward-operation o)) + :collect `(,op ,c)) ,@(call-next-method)))) @@ -6546,17 +6729,16 @@ (do-asdf-cache `(input-files ,operation ,component) (call-next-method))) - (defmethod input-files ((o operation) (c parent-component)) + (defmethod input-files ((o operation) (c component)) (declare (ignorable o c)) nil) - (defmethod input-files ((o operation) (c component)) - (or (loop* :for (dep-o) :in (component-self-dependencies o c) - :append (or (output-files dep-o c) (input-files dep-o c))) - ;; no non-trivial previous operations needed? - ;; I guess we work with the original source file, then - (if-let ((pathname (component-pathname c))) - (and (file-pathname-p pathname) (list pathname)))))) + (defmethod input-files ((o selfward-operation) (c component)) + `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o)) + :append (or (output-files dep-o c) (input-files dep-o c))) + (if-let ((pathname (component-pathname c))) + (and (file-pathname-p pathname) (list pathname)))) + ,@(call-next-method)))) ;;;; Done performing @@ -6663,7 +6845,8 @@ #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op #:call-with-around-compile-hook - #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags)) + #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source + #:lisp-compilation-output-files #:flags)) (in-package :asdf/lisp-action) @@ -6687,17 +6870,23 @@ ;;; Our default operations: loading into the current lisp image (with-upgradability () - (defclass load-op (basic-load-op downward-operation sibling-operation) ()) - (defclass prepare-op (upward-operation sibling-operation) - ((sibling-operation :initform 'load-op :allocation :class))) - (defclass compile-op (basic-compile-op downward-operation) - ((downward-operation :initform 'load-op :allocation :class))) - - (defclass load-source-op (basic-load-op downward-operation) ()) - (defclass prepare-source-op (upward-operation sibling-operation) - ((sibling-operation :initform 'load-source-op :allocation :class))) + (defclass prepare-op (upward-operation sideway-operation) + ((sideway-operation :initform 'load-op))) + (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation) + ;; NB: even though compile-op depends-on on prepare-op it is not needed-in-image-p, + ;; so we need to directly depend on prepare-op for its side-effects in the current image. + ((selfward-operation :initform '(prepare-op compile-op)))) + (defclass compile-op (basic-compile-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-op) + (downward-operation :initform 'load-op))) + + (defclass prepare-source-op (upward-operation sideway-operation) + ((sideway-operation :initform 'load-source-op))) + (defclass load-source-op (basic-load-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-source-op))) - (defclass test-op (operation) ())) + (defclass test-op (selfward-operation) + ((selfward-operation :initform 'load-op)))) ;;;; prepare-op, compile-op and load-op @@ -6773,8 +6962,7 @@ (format s ":success~%")))))) (defmethod perform ((o compile-op) (c cl-source-file)) (perform-lisp-compilation o c)) - (defmethod output-files ((o compile-op) (c cl-source-file)) - (declare (ignorable o)) + (defun lisp-compilation-output-files (o c) (let* ((i (first (input-files o c))) (f (compile-file-pathname i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))) @@ -6788,9 +6976,8 @@ ,(compile-file-pathname i :fasl-p nil) ;; object file ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c)))) `(,(make-pathname :type *warnings-file-type* :defaults f)))))) - (defmethod component-depends-on ((o compile-op) (c component)) - (declare (ignorable o)) - `((prepare-op ,c) ,@(call-next-method))) + (defmethod output-files ((o compile-op) (c cl-source-file)) + (lisp-compilation-output-files o c)) (defmethod perform ((o compile-op) (c static-file)) (declare (ignorable o c)) nil) @@ -6840,13 +7027,7 @@ (perform-lisp-load-fasl o c)) (defmethod perform ((o load-op) (c static-file)) (declare (ignorable o c)) - nil) - (defmethod component-depends-on ((o load-op) (c component)) - (declare (ignorable o)) - ;; NB: even though compile-op depends-on on prepare-op, - ;; it is not needed-in-image-p, whereas prepare-op is, - ;; so better not omit prepare-op and think it will happen. - `((prepare-op ,c) (compile-op ,c) ,@(call-next-method)))) + nil)) ;;;; prepare-source-op, load-source-op @@ -6874,9 +7055,6 @@ (defmethod action-description ((o load-source-op) (c parent-component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) - (defmethod component-depends-on ((o load-source-op) (c component)) - (declare (ignorable o)) - `((prepare-source-op ,c) ,@(call-next-method))) (defun perform-lisp-load-source (o c) (call-with-around-compile-hook c #'(lambda () @@ -6902,11 +7080,7 @@ (defmethod operation-done-p ((o test-op) (c system)) "Testing a system is _never_ done." (declare (ignorable o c)) - nil) - (defmethod component-depends-on ((o test-op) (c system)) - (declare (ignorable o)) - `((load-op ,c) ,@(call-next-method)))) - + nil)) ;;;; ------------------------------------------------------------------------- ;;;; Plan @@ -7296,9 +7470,10 @@ (with-compilation-unit () ;; backward-compatibility. (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. - (defmethod perform-plan ((steps list) &key) - (loop* :for (op . component) :in steps :do - (perform-with-restarts op component))) + (defmethod perform-plan ((steps list) &key force &allow-other-keys) + (loop* :for (o . c) :in steps + :when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) + :do (perform-with-restarts o c))) (defmethod plan-operates-on-p ((plan list) (component-path list)) (find component-path (mapcar 'cdr plan) @@ -7347,7 +7522,8 @@ (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) (remove-duplicates - (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys)) + (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system + (remove-plist-key :goal-operation keys))) :from-end t))) ;;;; ------------------------------------------------------------------------- @@ -7440,7 +7616,7 @@ (defmethod operate ((operation operation) (component component) &rest keys &key &allow-other-keys) (let ((plan (apply 'traverse operation component keys))) - (perform-plan plan) + (apply 'perform-plan plan keys) (values operation plan))) (defun oos (operation component &rest args &key &allow-other-keys) @@ -7613,7 +7789,10 @@ (let ((directory (pathname-directory (car x)))) (if (listp directory) (length directory) 0)))))))) new-value) - (defsetf output-translations set-output-translations) ; works with gcl 2.6 + #-gcl2.6 + (defun* ((setf output-translations)) (new-value) (set-output-translations new-value)) + #+gcl2.6 + (defsetf output-translations set-output-translations) (defun output-translations-initialized-p () (and *output-translations* t)) @@ -8226,23 +8405,18 @@ (component-inline-methods component) nil) (defun %define-component-inline-methods (ret rest) - (dolist (name +asdf-methods+) - (let ((keyword (intern (symbol-name name) :keyword))) - (loop :for data = rest :then (cddr data) - :for key = (first data) - :for value = (second data) - :while data - :when (eq key keyword) :do - (destructuring-bind (op qual? &rest rest) value - (multiple-value-bind (qual args-and-body) - (if (symbolp qual?) - (values (list qual?) rest) - (values nil (cons qual? rest))) - (destructuring-bind ((o c) &body body) args-and-body - (pushnew - (eval `(defmethod ,name , at qual ((,o ,op) (,c (eql ,ret))) - , at body)) - (component-inline-methods ret))))))))) + (loop* :for (key value) :on rest :by #'cddr + :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=)) + :when name :do + (destructuring-bind (op &rest body) value + (loop :for arg = (pop body) + :while (atom arg) + :collect arg :into qualifiers + :finally + (destructuring-bind (o c) arg + (pushnew + (eval `(defmethod ,name , at qualifiers ((,o ,op) (,c (eql ,ret))) , at body)) + (component-inline-methods ret))))))) (defun %refresh-component-inline-methods (component rest) ;; clear methods, then add the new ones @@ -8301,7 +8475,8 @@ #:defsystem #:register-system-definition #:class-for-type #:*default-component-class* #:determine-system-directory #:parse-component-form - #:duplicate-names #:sysdef-error-component #:check-component-input)) + #:duplicate-names #:non-toplevel-system #:non-system-system + #:sysdef-error-component #:check-component-input)) (in-package :asdf/defsystem) ;;; Pathname @@ -8361,6 +8536,20 @@ (format s (compatfmt "~@") (duplicate-names-name c))))) + (define-condition non-system-system (system-definition-error) + ((name :initarg :name :reader non-system-system-name) + (class-name :initarg :class-name :reader non-system-system-class-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (non-system-system-name c) (non-system-system-class-name c) 'system)))) + + (define-condition non-toplevel-system (system-definition-error) + ((parent :initarg :parent :reader non-toplevel-system-parent) + (name :initarg :name :reader non-toplevel-system-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (non-toplevel-system-parent c) (non-toplevel-system-name c))))) + (defun sysdef-error-component (msg type name value) (sysdef-error (strcat msg (compatfmt "~&~@")) type name value)) @@ -8430,7 +8619,8 @@ (class-for-type parent type)))) (error 'duplicate-names :name name)) (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) - (let* ((args `(:name ,(coerce-name name) + (let* ((name (coerce-name name)) + (args `(:name ,name :pathname ,pathname ,@(when parent `(:parent ,parent)) ,@(remove-plist-keys @@ -8438,16 +8628,13 @@ :perform :explain :output-files :operation-done-p :weakly-depends-on :depends-on :serial) rest))) - (component (find-component parent name))) - (when weakly-depends-on - ;; ASDF4: deprecate this feature and remove it. - (appendf depends-on - (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) - (when previous-serial-component - (push previous-serial-component depends-on)) + (component (find-component parent name)) + (class (class-for-type parent type))) + (when (and parent (subtypep class 'system)) + (error 'non-toplevel-system :parent parent :name name)) (if component ; preserve identity (apply 'reinitialize-instance component args) - (setf component (apply 'make-instance (class-for-type parent type) args))) + (setf component (apply 'make-instance class args))) (component-pathname component) ; eagerly compute the absolute pathname (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous (when (and (typep component 'system) (not bspp)) @@ -8467,8 +8654,14 @@ :collect c :when serial :do (setf previous-component name))) (compute-children-by-name component)) + (when previous-serial-component + (push previous-serial-component depends-on)) + (when weakly-depends-on + ;; ASDF4: deprecate this feature and remove it. + (appendf depends-on + (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) ;; Used by POIU. ASDF4: rename to component-depends-on? - (setf (component-sibling-dependencies component) depends-on) + (setf (component-sideway-dependencies component) depends-on) (%refresh-component-inline-methods component rest) (when if-component-dep-fails (%resolve-if-component-dep-fails if-component-dep-fails component)) @@ -8501,6 +8694,8 @@ ;; We change-class AFTER we loaded the defsystem-depends-on ;; since the class might be defined as part of those. (let ((class (class-for-type nil class))) + (unless (subtypep class 'system) + (error 'non-system-system :name name :class-name (class-name class))) (unless (eq (type-of system) class) (change-class system class))) (parse-component-form @@ -8520,13 +8715,14 @@ :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) (:export - #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type - #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op - #:monolithic-op #:monolithic-bundle-op #:bundlable-file-p #:direct-dependency-files - #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op - #:program-op - #:compiled-file #:precompiled-system #:prebuilt-system - #:operation-monolithic-p + #:bundle-op #:bundle-op-build-args #:bundle-type + #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files + #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p + #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op + #:lib-op #:monolithic-lib-op + #:dll-op #:monolithic-dll-op + #:binary-op #:monolithic-binary-op + #:program-op #:compiled-file #:precompiled-system #:prebuilt-system #:user-system-p #:user-system #:trivial-system-p #+ecl #:make-build #:register-pre-built-system @@ -8542,27 +8738,37 @@ #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) - (defclass fasl-op (bundle-op) - ;; create a single fasl for the entire library - ((bundle-type :initform :fasl))) - - (defclass load-fasl-op (basic-load-op) - ;; load a single fasl for the entire library - ()) + (defclass bundle-compile-op (bundle-op basic-compile-op) + () + (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files")) - (defclass lib-op (bundle-op) - ;; On ECL: compile the system and produce linkable .a library for it. - ;; On others: just compile the system. - ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))) - - (defclass dll-op (bundle-op) - ;; Link together all the dynamic library used by this system into a single one. - ((bundle-type :initform :dll))) - - (defclass binary-op (bundle-op) - ;; On ECL: produce lib and fasl for the system. - ;; On "normal" Lisps: produce just the fasl. - ()) + ;; create a single fasl for the entire library + (defclass basic-fasl-op (bundle-compile-op) + ((bundle-type :initform :fasl))) + (defclass prepare-fasl-op (sideway-operation) + ((sideway-operation :initform 'load-fasl-op))) + (defclass fasl-op (basic-fasl-op selfward-operation) + ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op)))) + (defclass load-fasl-op (basic-load-op selfward-operation) + ((selfward-operation :initform '(prepare-op fasl-op)))) + + ;; NB: since the monolithic-op's can't be sideway-operation's, + ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's, + ;; we'd have to have the monolithic-op not inherit from the main op, + ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above. + + (defclass lib-op (bundle-compile-op) + ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) + (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it." + #-(or ecl mkcl) "just compile the system")) + + (defclass dll-op (bundle-op basic-compile-op) + ((bundle-type :initform :dll)) + (:documentation "Link together all the dynamic library used by this system into a single one.")) + + (defclass binary-op (basic-compile-op selfward-operation) + ((selfward-operation :initform '(fasl-op lib-op))) + (:documentation "produce fasl and asd files for the system")) (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies @@ -8570,29 +8776,36 @@ ((prologue-code :accessor monolithic-op-prologue-code) (epilogue-code :accessor monolithic-op-epilogue-code))) - (defclass monolithic-binary-op (binary-op monolithic-bundle-op) - ;; On ECL: produce lib and fasl for combined system and dependencies. - ;; On "normal" Lisps: produce an image file from system and dependencies. - ()) - - (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) - ;; Create a single fasl for the system and its dependencies. - ()) - - (defclass monolithic-lib-op (monolithic-bundle-op lib-op) - ;; ECL: Create a single linkable library for the system and its dependencies. - ((bundle-type :initform :lib))) - - (defclass monolithic-dll-op (monolithic-bundle-op dll-op) - ((bundle-type :initform :dll))) - - (defclass program-op (monolithic-bundle-op) - ;; All: create an executable file from the system and its dependencies - ((bundle-type :initform :program))) + (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op) + () + (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems")) + + (defclass monolithic-binary-op (monolithic-op binary-op) + ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op))) + (:documentation "produce fasl and asd files for combined system and dependencies.")) + + (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) () + (:documentation "Create a single fasl for the system and its dependencies.")) + + (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op) + ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) + (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies." + #-(or ecl mkcl) "Compile a system and its dependencies.")) + + (defclass monolithic-dll-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation) + ((bundle-type :initform :dll) + (selfward-operation :initform 'dll-op) + (sideway-operation :initform 'dll-op))) + + (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op) + #-(or mkcl ecl) (monolithic-bundle-op selfward-operation) + ((bundle-type :initform :program) + #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op)) + (:documentation "create an executable file from the system and its dependencies")) (defun bundle-pathname-type (bundle-type) (etypecase bundle-type - ((eql :no-output-file) nil) ;; should we error out instead? + ((eql :no-output-file) nil) ;; should we error out instead? ((or null string) bundle-type) ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") #+ecl @@ -8604,27 +8817,23 @@ ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) (defun bundle-output-files (o c) - (let ((bundle-type (bundle-type o))) - (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type. - (let ((name (or (component-build-pathname c) - (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) - (type (bundle-pathname-type bundle-type))) - (values (list (subpathname (component-pathname c) name :type type)) - (eq (type-of o) (component-build-operation c))))))) + (when (input-files o c) + (let ((bundle-type (bundle-type o))) + (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type. + (let ((name (or (component-build-pathname c) + (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) + (type (bundle-pathname-type bundle-type))) + (values (list (subpathname (component-pathname c) name :type type)) + (eq (type-of o) (component-build-operation c)))))))) (defmethod output-files ((o bundle-op) (c system)) (bundle-output-files o c)) #-(or ecl mkcl) - (progn - (defmethod perform ((o program-op) (c system)) - (let ((output-file (output-file o c))) - (setf *image-entry-point* (ensure-function (component-entry-point c))) - (dump-image output-file :executable t))) - - (defmethod perform ((o monolithic-binary-op) (c system)) - (let ((output-file (output-file o c))) - (dump-image output-file)))) + (defmethod perform ((o program-op) (c system)) + (let ((output-file (output-file o c))) + (setf *image-entry-point* (ensure-function (component-entry-point c))) + (dump-image output-file :executable t))) (defclass compiled-file (file-component) ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) @@ -8684,7 +8893,7 @@ (or #+ecl (or (equalp type (compile-file-type :type :object)) (equalp type (compile-file-type :type :static-library))) #+mkcl (equalp type (compile-file-type :fasl-p nil)) - #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) + #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) (defgeneric* (trivial-system-p) (component)) @@ -8705,50 +8914,17 @@ ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL ;;; (with-upgradability () - (defmethod component-depends-on ((o monolithic-lib-op) (c system)) - (declare (ignorable o)) - `((lib-op ,@(required-components c :other-systems t :component-type 'system - :goal-operation 'load-op - :keep-operation 'compile-op)))) - - (defmethod component-depends-on ((o monolithic-fasl-op) (c system)) - (declare (ignorable o)) - `((fasl-op ,@(required-components c :other-systems t :component-type 'system - :goal-operation 'load-fasl-op - :keep-operation 'fasl-op)))) - - (defmethod component-depends-on ((o program-op) (c system)) - (declare (ignorable o)) - #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c) - #-(or ecl mkcl) `((load-op ,c))) - - (defmethod component-depends-on ((o binary-op) (c system)) - (declare (ignorable o)) - `((fasl-op ,c) - (lib-op ,c))) - - (defmethod component-depends-on ((o monolithic-binary-op) (c system)) - `((,(find-operation o 'monolithic-fasl-op) ,c) - (,(find-operation o 'monolithic-lib-op) ,c))) - - (defmethod component-depends-on ((o lib-op) (c system)) - (declare (ignorable o)) - `((compile-op ,@(required-components c :other-systems nil :component-type '(not system) - :goal-operation 'load-op - :keep-operation 'compile-op)))) - - (defmethod component-depends-on ((o fasl-op) (c system)) - (declare (ignorable o)) - #+ecl `((lib-op ,c)) - #-ecl - (component-depends-on (find-operation o 'lib-op) c)) - - (defmethod component-depends-on ((o dll-op) c) - (component-depends-on (find-operation o 'lib-op) c)) - - (defmethod component-depends-on ((o bundle-op) c) - (declare (ignorable o c)) - nil) + (defmethod component-depends-on ((o bundle-compile-op) (c system)) + `(,(if (operation-monolithic-p o) + `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op + ,@(required-components c :other-systems t :component-type 'system + :goal-operation (find-operation o 'load-op) + :keep-operation 'compile-op)) + `(compile-op + ,@(required-components c :other-systems nil :component-type '(not system) + :goal-operation (find-operation o 'load-op) + :keep-operation 'compile-op))) + ,@(call-next-method))) (defmethod component-depends-on :around ((o bundle-op) (c component)) (declare (ignorable o c)) @@ -8757,14 +8933,17 @@ (call-next-method))) (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) + ;; This file selects output files from direct dependencies; + ;; your component-depends-on method better gathered the correct dependencies in the correct order. (while-collecting (collect) (map-direct-dependencies o c #'(lambda (sub-o sub-c) (loop :for f :in (funcall key sub-o sub-c) :when (funcall test f) :do (collect f)))))) - (defmethod input-files ((o bundle-op) (c system)) - (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)) + (defmethod input-files ((o bundle-compile-op) (c system)) + (unless (eq (bundle-type o) :no-output-file) + (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))) (defun select-bundle-operation (type &optional monolithic) (ecase type @@ -8811,7 +8990,7 @@ (with-upgradability () (defmethod component-depends-on ((o load-fasl-op) (c system)) (declare (ignorable o)) - `((,o ,@(loop :for dep :in (component-sibling-dependencies c) + `((,o ,@(loop :for dep :in (component-sideway-dependencies c) :collect (resolve-dependency-spec c dep))) (,(if (user-system-p c) 'fasl-op 'load-op) ,c) ,@(call-next-method))) @@ -8825,7 +9004,8 @@ nil) (defmethod perform ((o load-fasl-op) (c system)) - (perform-lisp-load-fasl o c)) + (when (input-files o c) + (perform-lisp-load-fasl o c))) (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) (mark-operation-done (find-operation o 'load-op) c))) @@ -8886,38 +9066,55 @@ :defaults (component-pathname s)))) (defmethod perform ((o binary-op) (s system)) - (let* ((dependencies (component-depends-on o s)) - (fasl (first (apply #'output-files (first dependencies)))) - (library (first (apply #'output-files (second dependencies)))) + (let* ((inputs (input-files o s)) + (fasl (first inputs)) + (library (second inputs)) (asd (first (output-files o s))) - (name (pathname-name asd)) - (name-keyword (intern (string name) (find-package :keyword)))) + (name (if (and fasl asd) (pathname-name asd) (return-from perform))) + (dependencies + (if (operation-monolithic-p o) + (remove-if-not 'builtin-system-p + (required-components s :component-type 'system + :keep-operation 'load-op)) + (while-collecting (x) ;; resolve the sideway-dependencies of s + (map-direct-dependencies + 'load-op s + #'(lambda (o c) + (when (and (typep o 'load-op) (typep c 'system)) + (x c))))))) + (depends-on (mapcar 'coerce-name dependencies))) + (when (pathname-equal asd (system-source-file s)) + (cerror "overwrite the asd file" + "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations." + (cons o s) asd)) (with-open-file (s asd :direction :output :if-exists :supersede :if-does-not-exist :create) - (format s ";;; Prebuilt ASDF definition for system ~A" name) - (format s ";;; Built for ~A ~A on a ~A/~A ~A" + (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%" + (operation-monolithic-p o) name) + (format s ";;; Built for ~A ~A on a ~A/~A ~A~%" (lisp-implementation-type) (lisp-implementation-version) (software-type) (machine-type) (software-version)) - (let ((*package* (find-package :keyword))) - (pprint `(defsystem ,name-keyword + (let ((*package* (find-package :asdf-user))) + (pprint `(defsystem ,name :class prebuilt-system + :depends-on ,depends-on :components ((:compiled-file ,(pathname-name fasl))) - :lib ,(and library (file-namestring library))) - s))))) + ,@(when library `(:lib ,(file-namestring library)))) + s) + (terpri s))))) #-(or ecl mkcl) - (defmethod perform ((o fasl-op) (c system)) + (defmethod perform ((o bundle-compile-op) (c system)) (let* ((input-files (input-files o c)) (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) (output-files (output-files o c)) (output-file (first output-files))) - (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c)) + (assert (eq (not input-files) (not output-files))) (when input-files - (assert output-files) (when non-fasl-files (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" (implementation-type) non-fasl-files)) @@ -8946,31 +9143,32 @@ #+ecl (with-upgradability () - (defmethod perform ((o bundle-op) (c system)) + (defmethod perform ((o bundle-compile-op) (c system)) (let* ((object-files (input-files o c)) (output (output-files o c)) (bundle (first output)) (kind (bundle-type o))) - (create-image - bundle (append object-files (bundle-op-lisp-files o)) - :kind kind - :entry-point (component-entry-point c) - :prologue-code - (when (typep o 'monolithic-bundle-op) - (monolithic-op-prologue-code o)) - :epilogue-code - (when (typep o 'monolithic-bundle-op) - (monolithic-op-epilogue-code o)) - :build-args (bundle-op-build-args o))))) + (when output + (create-image + bundle (append object-files (bundle-op-lisp-files o)) + :kind kind + :entry-point (component-entry-point c) + :prologue-code + (when (typep o 'monolithic-bundle-op) + (monolithic-op-prologue-code o)) + :epilogue-code + (when (typep o 'monolithic-bundle-op) + (monolithic-op-epilogue-code o)) + :build-args (bundle-op-build-args o)))))) #+mkcl (with-upgradability () (defmethod perform ((o lib-op) (s system)) - (apply #'compiler::build-static-library (first output) + (apply #'compiler::build-static-library (output-file o c) :lisp-object-files (input-files o s) (bundle-op-build-args o))) - (defmethod perform ((o fasl-op) (s system)) - (apply #'compiler::build-bundle (second output) + (defmethod perform ((o basic-fasl-op) (s system)) + (apply #'compiler::build-bundle (output-file o c) ;; second??? :lisp-object-files (input-files o s) (bundle-op-build-args o))) (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) @@ -9006,21 +9204,29 @@ ;;; Concatenate sources ;;; (with-upgradability () - (defclass concatenate-source-op (bundle-op) + (defclass basic-concatenate-source-op (bundle-op) ((bundle-type :initform "lisp"))) - (defclass load-concatenated-source-op (basic-load-op operation) - ((bundle-type :initform :no-output-file))) - (defclass compile-concatenated-source-op (basic-compile-op bundle-op) - ((bundle-type :initform :fasl))) - (defclass load-compiled-concatenated-source-op (basic-load-op operation) - ((bundle-type :initform :no-output-file))) - - (defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ()) - (defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ()) - (defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ()) - (defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ()) + (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ()) + (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ()) + (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ()) + + (defclass concatenate-source-op (basic-concatenate-source-op) ()) + (defclass load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op)))) + (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op)))) + (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform '(prepare-op compile-concatenated-source-op)))) + + (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ()) + (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op))) + (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op))) + (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform 'monolithic-compile-concatenated-source-op))) - (defmethod input-files ((operation concatenate-source-op) (s system)) + (defmethod input-files ((operation basic-concatenate-source-op) (s system)) (loop :with encoding = (or (component-encoding s) *default-encoding*) :with other-encodings = '() :with around-compile = (around-compile-hook s) @@ -9046,45 +9252,19 @@ (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" operation around-compile other-around-compile)) (return inputs))) + (defmethod output-files ((o basic-compile-concatenated-source-op) (s system)) + (lisp-compilation-output-files o s)) - (defmethod input-files ((o load-concatenated-source-op) (s system)) - (direct-dependency-files o s)) - (defmethod input-files ((o compile-concatenated-source-op) (s system)) - (direct-dependency-files o s)) - (defmethod output-files ((o compile-concatenated-source-op) (s system)) - (let ((input (first (input-files o s)))) - (list (compile-file-pathname input)))) - (defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) - (direct-dependency-files o s)) - - (defmethod perform ((o concatenate-source-op) (s system)) + (defmethod perform ((o basic-concatenate-source-op) (s system)) (let ((inputs (input-files o s)) (output (output-file o s))) (concatenate-files inputs output))) - (defmethod perform ((o load-concatenated-source-op) (s system)) + (defmethod perform ((o basic-load-concatenated-source-op) (s system)) (perform-lisp-load-source o s)) - (defmethod perform ((o compile-concatenated-source-op) (s system)) + (defmethod perform ((o basic-compile-concatenated-source-op) (s system)) (perform-lisp-compilation o s)) - (defmethod perform ((o load-compiled-concatenated-source-op) (s system)) - (perform-lisp-load-fasl o s)) - - (defmethod component-depends-on ((o concatenate-source-op) (s system)) - (declare (ignorable o s)) nil) - (defmethod component-depends-on ((o load-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s))) - (defmethod component-depends-on ((o compile-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((concatenate-source-op ,s))) - (defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((compile-concatenated-source-op ,s))) - - (defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system)) - (declare (ignorable o s)) nil) - (defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) - (defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) - (defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s)))) + (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system)) + (perform-lisp-load-fasl o s))) ;;;; ------------------------------------------------------------------------- ;;; Backward-compatible interfaces @@ -9122,7 +9302,7 @@ (defun component-load-dependencies (component) ;; Old deprecated name for the same thing. Please update your software. - (component-sibling-dependencies component)) + (component-sideway-dependencies component)) (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader. (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) @@ -9268,20 +9448,23 @@ #:search-for-system-definition #:find-component #:component-find-path #:compile-system #:load-system #:load-systems #:require-system #:test-system #:clear-system - #:operation #:upward-operation #:downward-operation #:make-operation + #:operation #:make-operation #:find-operation + #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation #:build-system #:build-op #:load-op #:prepare-op #:compile-op #:prepare-source-op #:load-source-op #:test-op #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type #:hostname #:input-files #:output-files #:output-file #:perform - #:operation-done-p #:explain #:action-description #:component-sibling-dependencies + #:operation-done-p #:explain #:action-description #:component-sideway-dependencies #:needed-in-image-p ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT. #:component-load-dependencies #:run-shell-command ; deprecated, do not use - #:bundle-op #:precompiled-system #:compiled-file #:bundle-system + #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system #+ecl #:make-build - #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op + #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op + #:lib-op #:dll-op #:binary-op #:program-op + #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op #:concatenate-source-op #:load-concatenated-source-op #:compile-concatenated-source-op @@ -9357,7 +9540,7 @@ #:missing-dependency #:missing-dependency-of-version #:circular-dependency ; errors - #:duplicate-names + #:duplicate-names #:non-toplevel-system #:non-system-system #:try-recompiling #:retry @@ -9391,6 +9574,7 @@ #:system-registered-p #:registered-systems #:already-loaded-systems #:resolve-location #:asdf-message + #:*user-cache* #:user-output-translations-pathname #:system-output-translations-pathname #:user-output-translations-directory-pathname From rschlatte at common-lisp.net Fri Apr 5 14:45:59 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 05 Apr 2013 07:45:59 -0700 Subject: [armedbear-cvs] r14462 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Fri Apr 5 07:45:58 2013 New Revision: 14462 Log: - Remove extraneous constant Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Thu Apr 4 06:57:20 2013 (r14461) +++ trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Fri Apr 5 07:45:58 2013 (r14462) @@ -42,9 +42,6 @@ { protected LispObject function; - public static int SLOT_INDEX_NAME = 1; - - protected FuncallableStandardObject() { super();