From rschlatte at common-lisp.net Sun Jun 3 22:19:19 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 03 Jun 2012 15:19:19 -0700 Subject: [armedbear-cvs] r13955 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 3 15:19:18 2012 New Revision: 13955 Log: Make slot-value-using-class &c dispatch on slot definition object - Keeping the old methods dispatching on slot name around for existing users, but slot-value &c now use the new code paths. - The new behavior is following the AMOP spec (although chapters 1-4 and the Closette implementation of AMOP show method dispatch on slot names instead). - Minor incompatible change: standard-instance-access now does not complain about unbound slots, returning +slot-unbound+ instead. We handle unbound slots Lisp-side now both for :allocation :instance and :allocation :class in one code path. - Removes 5 failures from the AMOP test suite. Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java Tue May 29 12:21:00 2012 (r13954) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sun Jun 3 15:19:18 2012 (r13955) @@ -450,13 +450,10 @@ list(Symbol.INTEGER, Fixnum.ZERO, Fixnum.getInstance(instance.slots.length))); } - if (value == UNBOUND_VALUE) - { - LispObject slotName = instance.layout.getSlotNames()[index]; - value = Symbol.SLOT_UNBOUND.execute(instance.getLispClass(), - instance, slotName); - LispThread.currentThread()._values = null; - } + // We let UNBOUND_VALUE escape here, since invoking + // standard-instance-access on an unbound slot has undefined + // consequences (AMOP pg. 239), and we use this behavior to + // implement slot-boundp-using-class. return value; } }; Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue May 29 12:21:00 2012 (r13954) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 3 15:19:18 2012 (r13955) @@ -99,7 +99,14 @@ ;; ### Note that the "declares all API functions as regular functions" ;; isn't true when I write the above, but it's definitely the target. ;; -;; +;; A note about AMOP: the first chapters (and the sample Closette +;; implementation) of the book sometimes deviate from the specification. +;; For example, in the examples slot-value-using-class has the slot name +;; as third argument where in the specification it is the effective slot +;; definition. When in doubt, we aim to follow the specification, the +;; MOP test suite at http://common-lisp.net/project/closer/features.html +;; and the behavior of other CL implementations in preference to +;; chapters 1-4 and appendix D. (export '(class-precedence-list class-slots slot-definition-name)) @@ -256,6 +263,9 @@ (defsetf std-instance-layout %set-std-instance-layout) (defsetf standard-instance-access %set-standard-instance-access) +(defun funcallable-standard-instance-access (instance location) + (standard-instance-access instance location)) +(defsetf funcallable-standard-instance-access %set-standard-instance-access) (defun (setf find-class) (new-value symbol &optional errorp environment) (declare (ignore errorp environment)) @@ -528,9 +538,9 @@ (unless (slot-definition-location slot) (let ((allocation-class (slot-definition-allocation-class slot))) (setf (slot-definition-location slot) - (if (eq allocation-class class) - (cons (slot-definition-name slot) +slot-unbound+) - (slot-location allocation-class (slot-definition-name slot)))))) + (if (eq allocation-class class) + (cons (slot-definition-name slot) +slot-unbound+) + (slot-location allocation-class (slot-definition-name slot)))))) (push (slot-definition-location slot) shared-slots)))) (when old-layout ;; Redefined class: initialize added shared slots. @@ -717,25 +727,38 @@ (and layout (layout-slot-location layout slot-name)))) (defun slot-value (object slot-name) - (if (or (eq (class-of (class-of object)) +the-standard-class+) - (eq (class-of (class-of object)) +the-structure-class+)) - (std-slot-value object slot-name) - (slot-value-using-class (class-of object) object slot-name))) + (let* ((class (class-of object)) + (metaclass (class-of class))) + (if (or (eq metaclass +the-standard-class+) + (eq metaclass +the-structure-class+) + (eq metaclass +the-funcallable-standard-class+)) + (std-slot-value object slot-name) + (slot-value-using-class class object + (find-slot-definition class slot-name))))) (defsetf std-slot-value set-std-slot-value) (defun %set-slot-value (object slot-name new-value) - (if (or (eq (class-of (class-of object)) +the-standard-class+) - (eq (class-of (class-of object)) +the-structure-class+)) - (setf (std-slot-value object slot-name) new-value) - (setf (slot-value-using-class (class-of object) object slot-name) new-value))) + (let* ((class (class-of object)) + (metaclass (class-of class))) + (if (or (eq metaclass +the-standard-class+) + (eq metaclass +the-structure-class+) + (eq metaclass +the-funcallable-standard-class+)) + (setf (std-slot-value object slot-name) new-value) + (setf (slot-value-using-class class object + (find-slot-definition class slot-name)) + new-value)))) (defsetf slot-value %set-slot-value) (defun slot-boundp (object slot-name) - (if (eq (class-of (class-of object)) +the-standard-class+) - (std-slot-boundp object slot-name) - (slot-boundp-using-class (class-of object) object slot-name))) + (let* ((class (class-of object)) + (metaclass (class-of class))) + (if (or (eq metaclass +the-standard-class+) + (eq metaclass +the-funcallable-standard-class+)) + (std-slot-boundp object slot-name) + (slot-boundp-using-class class object + (find-slot-definition class slot-name))))) (defun std-slot-makunbound (instance slot-name) (let ((location (instance-slot-location instance slot-name))) @@ -748,9 +771,13 @@ instance) (defun slot-makunbound (object slot-name) - (if (eq (class-of (class-of object)) +the-standard-class+) - (std-slot-makunbound object slot-name) - (slot-makunbound-using-class (class-of object) object slot-name))) + (let* ((class (class-of object)) + (metaclass (class-of class))) + (if (or (eq metaclass +the-standard-class+) + (eq metaclass +the-funcallable-standard-class+)) + (std-slot-makunbound object slot-name) + (slot-makunbound-using-class class object + (find-slot-definition class slot-name))))) (defun std-slot-exists-p (instance slot-name) (not (null (find slot-name (class-slots (class-of instance)) @@ -1975,10 +2002,12 @@ :datum arg :expected-type class)) (setf location (slow-reader-lookup gf layout slot-name))) - (if (consp location) - ;; Shared slot. - (cdr location) - (standard-instance-access arg location)))))) + (let ((value (if (consp location) + (cdr location) ; :allocation :class + (funcallable-standard-instance-access arg location)))) + (if (eq value +slot-unbound+) + (slot-unbound class arg slot-name) + value)))))) (t (let* ((emf-table (classes-to-emf-table gf)) @@ -3058,37 +3087,97 @@ ;;; Slot access +;;; +;;; See AMOP pg. 156ff. for an overview. +;;; +;;; AMOP specifies these generic functions to dispatch on slot objects +;;; (with the exception of slot-exists-p-using-class), although its +;;; sample implementation Closette dispatches on slot names. We let +;;; slot-value and friends call their gf counterparts with the effective +;;; slot definition, but leave the definitions dispatching on slot name +;;; in place for user convenience. + +;;; AMOP pg. 235 +(defgeneric slot-value-using-class (class instance slot)) + +(defmethod slot-value-using-class ((class standard-class) instance (slot symbol)) + (std-slot-value instance slot)) +(defmethod slot-value-using-class ((class standard-class) instance + (slot standard-effective-slot-definition)) + (let* ((location (slot-definition-location slot)) + (value (if (consp location) + (cdr location) ; :allocation :class + (standard-instance-access instance location)))) + (if (eq value +slot-unbound+) + (slot-unbound class instance (slot-definition-name slot)) + value))) -(defgeneric slot-value-using-class (class instance slot-name)) - -(defmethod slot-value-using-class ((class standard-class) instance slot-name) - (std-slot-value instance slot-name)) (defmethod slot-value-using-class ((class funcallable-standard-class) - instance slot-name) - (std-slot-value instance slot-name)) -(defmethod slot-value-using-class ((class structure-class) instance slot-name) - (std-slot-value instance slot-name)) + instance (slot symbol)) + (std-slot-value instance slot)) +(defmethod slot-value-using-class ((class funcallable-standard-class) instance + (slot standard-effective-slot-definition)) + (let* ((location (slot-definition-location slot)) + (value (if (consp location) + (cdr location) ; :allocation :class + (funcallable-standard-instance-access instance location)))) + (if (eq value +slot-unbound+) + (slot-unbound class instance (slot-definition-name slot)) + value))) + +(defmethod slot-value-using-class ((class structure-class) instance + (slot symbol)) + (std-slot-value instance slot)) +(defmethod slot-value-using-class ((class structure-class) instance + (slot standard-effective-slot-definition)) + (std-slot-value instance (slot-definition-name slot))) -(defgeneric (setf slot-value-using-class) (new-value class instance slot-name)) +;;; AMOP pg. 231 +(defgeneric (setf slot-value-using-class) (new-value class instance slot)) (defmethod (setf slot-value-using-class) (new-value (class standard-class) instance - slot-name) - (setf (std-slot-value instance slot-name) new-value)) + (slot symbol)) + (setf (std-slot-value instance slot) new-value)) +(defmethod (setf slot-value-using-class) (new-value + (class standard-class) + instance + (slot standard-effective-slot-definition)) + (let ((location (slot-definition-location slot))) + (if (consp location) ; :allocation :class + (setf (cdr location) new-value) + (setf (standard-instance-access instance location) new-value)))) (defmethod (setf slot-value-using-class) (new-value (class funcallable-standard-class) instance - slot-name) - (setf (std-slot-value instance slot-name) new-value)) + (slot symbol)) + (setf (std-slot-value instance slot) new-value)) +(defmethod (setf slot-value-using-class) (new-value + (class funcallable-standard-class) + instance + (slot standard-effective-slot-definition)) + (let ((location (slot-definition-location slot))) + (if (consp location) ; :allocation :class + (setf (cdr location) new-value) + (setf (funcallable-standard-instance-access instance location) + new-value)))) (defmethod (setf slot-value-using-class) (new-value (class structure-class) instance - slot-name) - (setf (std-slot-value instance slot-name) new-value)) + (slot symbol)) + (setf (std-slot-value instance slot) new-value)) +(defmethod (setf slot-value-using-class) (new-value + (class structure-class) + instance + (slot standard-effective-slot-definition)) + (setf (std-slot-value instance (slot-definition-name slot)) new-value)) +;;; slot-exists-p-using-class is not specified by AMOP, and obviously +;;; cannot be specialized on the slot type. Hence, its implementation +;;; differs from slot-(boundp|makunbound|value)-using-class (defgeneric slot-exists-p-using-class (class instance slot-name)) (defmethod slot-exists-p-using-class (class instance slot-name) @@ -3105,29 +3194,63 @@ (return-from slot-exists-p-using-class t))) nil) -(defgeneric slot-boundp-using-class (class instance slot-name)) -(defmethod slot-boundp-using-class ((class standard-class) instance slot-name) - (std-slot-boundp instance slot-name)) -(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance slot-name) - (std-slot-boundp instance slot-name)) -(defmethod slot-boundp-using-class ((class structure-class) instance slot-name) + +(defgeneric slot-boundp-using-class (class instance slot)) +(defmethod slot-boundp-using-class ((class standard-class) instance (slot symbol)) + (std-slot-boundp instance slot)) +(defmethod slot-boundp-using-class ((class standard-class) instance + (slot standard-effective-slot-definition)) + (let ((location (slot-definition-location slot))) + (if (consp location) + (eq (cdr location) +slot-unbound+) ; :allocation :class + (eq (standard-instance-access instance location) +slot-unbound+)))) + +(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance + (slot symbol)) + (std-slot-boundp instance slot)) +(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance + (slot standard-effective-slot-definition)) + (let ((location (slot-definition-location slot))) + (if (consp location) + (eq (cdr location) +slot-unbound+) ; :allocation :class + (eq (funcallable-standard-instance-access instance location) + +slot-unbound+)))) + +(defmethod slot-boundp-using-class ((class structure-class) instance slot) "Structure slots can't be unbound, so this method always returns T." - (declare (ignore class instance slot-name)) + (declare (ignore class instance slot)) t) -(defgeneric slot-makunbound-using-class (class instance slot-name)) +(defgeneric slot-makunbound-using-class (class instance slot)) +(defmethod slot-makunbound-using-class ((class standard-class) + instance + (slot symbol)) + (std-slot-makunbound instance slot)) (defmethod slot-makunbound-using-class ((class standard-class) instance - slot-name) - (std-slot-makunbound instance slot-name)) + (slot standard-effective-slot-definition)) + (let ((location (slot-definition-location slot))) + (if (consp location) + (setf (cdr location) +slot-unbound+) + (setf (standard-instance-access instance location) +slot-unbound+)))) + (defmethod slot-makunbound-using-class ((class funcallable-standard-class) instance - slot-name) - (std-slot-makunbound instance slot-name)) + (slot symbol)) + (std-slot-makunbound instance slot)) +(defmethod slot-makunbound-using-class ((class funcallable-standard-class) + instance + (slot symbol)) + (let ((location (slot-definition-location slot))) + (if (consp location) + (setf (cdr location) +slot-unbound+) + (setf (funcallable-standard-instance-access instance location) + +slot-unbound+)))) + (defmethod slot-makunbound-using-class ((class structure-class) instance - slot-name) - (declare (ignore class instance slot-name)) + slot) + (declare (ignore class instance slot)) (error "Structure slots can't be unbound")) (defgeneric slot-missing (class instance slot-name operation &optional new-value)) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Tue May 29 12:21:00 2012 (r13954) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Sun Jun 3 15:19:18 2012 (r13955) @@ -99,6 +99,7 @@ slot-definition-writers slot-definition-location standard-instance-access + funcallable-standard-instance-access intern-eql-specializer eql-specializer-object From rschlatte at common-lisp.net Sun Jun 10 21:34:16 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 10 Jun 2012 14:34:16 -0700 Subject: [armedbear-cvs] r13956 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 10 14:34:15 2012 New Revision: 13956 Log: Properly canonicalize class-direct-default-initargs - AMOP pg. 149: "A canonicalized default initarg is a list of three elements" -- namely, the initarg name, form, and closure. Make it so. Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotClass.java Sun Jun 3 15:19:18 2012 (r13955) +++ trunk/abcl/src/org/armedbear/lisp/SlotClass.java Sun Jun 10 14:34:15 2012 (r13956) @@ -122,6 +122,9 @@ LispObject computeDefaultInitargs() { + // KLUDGE (rudi 2012-06-02): duplicate initargs are not removed + // here, but this does not hurt us since no Lisp class we define + // Java-side has non-nil direct default initargs. LispObject result = NIL; LispObject cpl = getCPL(); while (cpl != NIL) { Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sun Jun 3 15:19:18 2012 (r13955) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sun Jun 10 14:34:15 2012 (r13956) @@ -681,10 +681,9 @@ new SlotDefinition(Symbol.FORMAT_ARGUMENTS, list(Symbol.SIMPLE_CONDITION_FORMAT_ARGUMENTS), NIL))); - CONDITION.setDirectDefaultInitargs(list(Keyword.FORMAT_ARGUMENTS, - // FIXME - new Closure(list(Symbol.LAMBDA, NIL, NIL), - new Environment()))); + CONDITION.setDirectDefaultInitargs(list(list(Keyword.FORMAT_ARGUMENTS, + NIL, + constantlyNil))); CONTROL_ERROR.setCPL(CONTROL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); DIVISION_BY_ZERO.setCPL(DIVISION_BY_ZERO, ARITHMETIC_ERROR, ERROR, Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 3 15:19:18 2012 (r13955) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 10 14:34:15 2012 (r13956) @@ -369,12 +369,10 @@ (:default-initargs (list ':direct-default-initargs - `(list ,@(mapappend - #'(lambda (x) x) - (mapplist - #'(lambda (key value) - `(',key ,(make-initfunction value))) - (cdr option)))))) + `(list ,@(mapplist + #'(lambda (key value) + `(list ',key ',value ,(make-initfunction value))) + (cdr option))))) ((:documentation :report) (list (car option) `',(cadr option))) (t (list `(quote ,(car option)) `(quote ,(cdr option)))))) @@ -505,10 +503,12 @@ ;;; finalize-inheritance (defun std-compute-class-default-initargs (class) - (mapcan #'(lambda (c) - (copy-list - (class-direct-default-initargs c))) - (class-precedence-list class))) + (delete-duplicates + (mapcan #'(lambda (c) + (copy-list + (class-direct-default-initargs c))) + (class-precedence-list class)) + :key #'car :from-end t)) (defun std-finalize-inheritance (class) ;; In case the class is already finalized, return @@ -3380,13 +3380,13 @@ (defun augment-initargs-with-defaults (class initargs) (let ((default-initargs '())) - (do* ((list (class-default-initargs class) (cddr list)) - (key (car list) (car list)) - (fn (cadr list) (cadr list))) - ((null list)) - (when (eq (getf initargs key 'not-found) 'not-found) - (setf default-initargs (append default-initargs (list key (funcall fn)))))) - (append initargs default-initargs))) + (dolist (initarg (class-default-initargs class)) + (let ((key (first initarg)) + (fn (third initarg))) + (when (eq (getf initargs key +slot-unbound+) +slot-unbound+) + (push key default-initargs) + (push (funcall fn) default-initargs)))) + (append initargs (nreverse default-initargs)))) (defmethod make-instance ((class standard-class) &rest initargs) (setf initargs (augment-initargs-with-defaults class initargs)) From rschlatte at common-lisp.net Mon Jun 11 10:44:14 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 11 Jun 2012 03:44:14 -0700 Subject: [armedbear-cvs] r13957 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jun 11 03:44:13 2012 New Revision: 13957 Log: Properly initialize documentation for effective slot definitions Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 10 14:34:15 2012 (r13956) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jun 11 03:44:13 2012 (r13957) @@ -676,8 +676,8 @@ (defun std-compute-effective-slot-definition (class name direct-slots) (let ((initer (find-if-not #'null direct-slots :key 'slot-definition-initfunction)) - (documentation (find-if-not #'null direct-slots - :key 'slot-definition-documentation)) + (documentation-slot (find-if-not #'null direct-slots + :key 'slot-definition-documentation)) (types (delete-duplicates (delete t (mapcar #'slot-definition-type direct-slots)) :test #'equal)) @@ -703,7 +703,7 @@ :type (cond ((null types) t) ((= 1 (length types)) types) (t (list* 'and types))) - :documentation documentation))) + :documentation (documentation documentation-slot t)))) ;;; Standard instance slot access From rschlatte at common-lisp.net Mon Jun 11 11:47:09 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 11 Jun 2012 04:47:09 -0700 Subject: [armedbear-cvs] r13958 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jun 11 04:47:06 2012 New Revision: 13958 Log: Implement compute-default-initargs Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jun 11 03:44:13 2012 (r13957) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jun 11 04:47:06 2012 (r13958) @@ -502,7 +502,11 @@ ;;; finalize-inheritance -(defun std-compute-class-default-initargs (class) +(declaim (notinline compute-default-initargs)) +(defun compute-default-initargs (class) + (std-compute-default-initargs class)) + +(defun std-compute-default-initargs (class) (delete-duplicates (mapcan #'(lambda (c) (copy-list @@ -555,7 +559,7 @@ (setf (class-layout class) (make-layout class (nreverse instance-slots) (nreverse shared-slots)))) (setf (class-default-initargs class) - (std-compute-class-default-initargs class)) + (compute-default-initargs class)) (setf (class-finalized-p class) t)) (declaim (notinline finalize-inheritance)) @@ -3629,6 +3633,15 @@ (:method ((class funcallable-standard-class)) (std-finalize-inheritance class))) +;;; Default initargs + +;;; AMOP pg. 174 +(atomic-defgeneric compute-default-initargs (class) + (:method ((class standard-class)) + (std-compute-default-initargs class)) + (:method ((class funcallable-standard-class)) + (std-compute-default-initargs class))) + ;;; Class precedence lists (defgeneric compute-class-precedence-list (class)) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jun 11 03:44:13 2012 (r13957) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jun 11 04:47:06 2012 (r13958) @@ -55,6 +55,7 @@ compute-effective-slot-definition compute-class-precedence-list + compute-default-initargs compute-effective-slot-definition compute-slots finalize-inheritance From rschlatte at common-lisp.net Mon Jun 11 12:26:38 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 11 Jun 2012 05:26:38 -0700 Subject: [armedbear-cvs] r13959 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jun 11 05:26:37 2012 New Revision: 13959 Log: Implement compute-effective-method - possibly not quite compliant: we return only one value instead of the specified two. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jun 11 04:47:06 2012 (r13958) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jun 11 05:26:37 2012 (r13959) @@ -1130,8 +1130,9 @@ ,(unless (null next-method-list) ;; by not generating an emf when there are no next methods, ;; we ensure next-method-p returns NIL - (compute-effective-method-function - ,gf (process-next-method-list next-method-list)))))) + (compute-effective-method + ,gf (generic-function-method-combination ,gf) + (process-next-method-list next-method-list)))))) , at forms)) (defmacro with-args-lambda-list (args-lambda-list @@ -2207,9 +2208,10 @@ (let ((applicable-methods (%compute-applicable-methods gf args))) (if applicable-methods (let* ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) - #'std-compute-effective-method-function - #'compute-effective-method-function) - gf applicable-methods)) + #'std-compute-effective-method + #'compute-effective-method) + gf (generic-function-method-combination gf) + applicable-methods)) (non-keyword-args (+ (length (gf-required-args gf)) (length (gf-optional-args gf)))) @@ -2237,9 +2239,10 @@ (let ((applicable-methods (%compute-applicable-methods gf (list arg)))) (if applicable-methods (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) - #'std-compute-effective-method-function - #'compute-effective-method-function) - gf applicable-methods))) + #'std-compute-effective-method + #'compute-effective-method) + gf (generic-function-method-combination gf) + applicable-methods))) (when emfun (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun)) emfun)))) @@ -2304,9 +2307,8 @@ next-method-form))) next-method-list)) -(defun std-compute-effective-method-function (gf methods) - (let* ((mc (generic-function-method-combination gf)) - (mc-name (if (atom mc) mc (%car mc))) +(defun std-compute-effective-method (gf mc methods) + (let* ((mc-name (if (atom mc) mc (%car mc))) (options (if (atom mc) '() (%cdr mc))) (order (car options)) (primaries '()) @@ -2342,9 +2344,10 @@ (let ((next-emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) - #'std-compute-effective-method-function - #'compute-effective-method-function) - gf (remove around methods)))) + #'std-compute-effective-method + #'compute-effective-method) + gf (generic-function-method-combination gf) + (remove around methods)))) (setf emf-form (generate-emf-lambda (std-method-function around) next-emfun)))) ((eq mc-name 'standard) @@ -3687,10 +3690,10 @@ ':required-args)))) (std-method-more-specific-p method1 method2 required-classes method-indices))) -;;; XXX AMOP has COMPUTE-EFFECTIVE-METHOD -(defgeneric compute-effective-method-function (gf methods)) -(defmethod compute-effective-method-function ((gf standard-generic-function) methods) - (std-compute-effective-method-function gf methods)) +;;; AMOP pg. 176 +(defgeneric compute-effective-method (gf method-combination methods)) +(defmethod compute-effective-method ((gf standard-generic-function) method-combination methods) + (std-compute-effective-method gf method-combination methods)) (defgeneric compute-applicable-methods (gf args)) (defmethod compute-applicable-methods ((gf standard-generic-function) args) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jun 11 04:47:06 2012 (r13958) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jun 11 05:26:37 2012 (r13959) @@ -57,6 +57,7 @@ compute-class-precedence-list compute-default-initargs compute-effective-slot-definition + compute-effective-method compute-slots finalize-inheritance validate-superclass From rschlatte at common-lisp.net Mon Jun 11 12:52:07 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 11 Jun 2012 05:52:07 -0700 Subject: [armedbear-cvs] r13960 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jun 11 05:52:04 2012 New Revision: 13960 Log: Export slot definition accessors from the MOP package - also move all exports into mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jun 11 05:26:37 2012 (r13959) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jun 11 05:52:04 2012 (r13960) @@ -108,8 +108,6 @@ ;; and the behavior of other CL implementations in preference to ;; chapters 1-4 and appendix D. -(export '(class-precedence-list class-slots - slot-definition-name)) (defconstant +the-standard-class+ (find-class 'standard-class)) (defconstant +the-funcallable-standard-class+ (find-class 'funcallable-standard-class)) @@ -3089,9 +3087,6 @@ (values (sort-methods methods gf classes) t)))) -(export '(compute-applicable-methods - compute-applicable-methods-using-classes)) - ;;; Slot access ;;; Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jun 11 05:26:37 2012 (r13959) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jun 11 05:52:04 2012 (r13960) @@ -57,6 +57,8 @@ compute-class-precedence-list compute-default-initargs compute-effective-slot-definition + compute-applicable-methods + compute-applicable-methods-using-classes compute-effective-method compute-slots finalize-inheritance @@ -77,6 +79,8 @@ class-direct-superclasses class-finalized-p class-prototype + class-precedence-list + class-slots add-direct-subclass remove-direct-subclass @@ -97,9 +101,13 @@ writer-method-class slot-definition + slot-definition-initargs + slot-definition-location + slot-definition-name slot-definition-readers + slot-definition-type slot-definition-writers - slot-definition-location + standard-instance-access funcallable-standard-instance-access From rschlatte at common-lisp.net Mon Jun 11 13:11:17 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 11 Jun 2012 06:11:17 -0700 Subject: [armedbear-cvs] r13961 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jun 11 06:11:15 2012 New Revision: 13961 Log: Export the rest of the standard metaobject readers - also some feeble reorganization of the export list in mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jun 11 05:52:04 2012 (r13960) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jun 11 06:11:15 2012 (r13961) @@ -46,8 +46,7 @@ funcallable-standard-object funcallable-standard-class forward-referenced-class - direct-slot-definition-class - effective-slot-definition-class + slot-definition standard-method standard-accessor-method standard-reader-method @@ -78,29 +77,32 @@ class-direct-subclasses class-direct-superclasses class-finalized-p - class-prototype class-precedence-list + class-prototype class-slots add-direct-subclass remove-direct-subclass - generic-function-lambda-list generic-function-argument-precedence-order + generic-function-declarations + generic-function-lambda-list generic-function-method-class + generic-function-method-combination + generic-function-name method-function method-generic-function method-lambda-list method-specializers method-qualifiers + accessor-method-slot-definition - standard-reader-method - standard-writer-method reader-method-class writer-method-class - slot-definition + direct-slot-definition-class + effective-slot-definition-class slot-definition-initargs slot-definition-location slot-definition-name From mevenson at common-lisp.net Tue Jun 12 11:46:12 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 12 Jun 2012 04:46:12 -0700 Subject: [armedbear-cvs] r13962 - trunk/abcl/contrib/jfli Message-ID: Author: mevenson Date: Tue Jun 12 04:46:11 2012 New Revision: 13962 Log: jfli: fix jref for byte array problem, clean up code. Patch by Alex Mizrahi, more fully described in [his email to ][1]. [1]: http://article.gmane.org/gmane.lisp.armedbear.devel/2360 1. make-immediate-object is deprecated now, so we use java:+null+ and friends 2. boxing extension by A. Vodonosov is described in comment 3. ensure-java-class was renamed to %ensure-java-class to avoid collision with java:ensure-java-class which does completely different thing. (I thought about shadowing it, but I think renaming makes it clearer.) 4. support for both int and long in overloads (or however they are called in Java) 5. new-class functionality was commented out because abcl-side interface have changed. (together with its helper jrc) Modified: trunk/abcl/contrib/jfli/jfli.lisp Modified: trunk/abcl/contrib/jfli/jfli.lisp ============================================================================== --- trunk/abcl/contrib/jfli/jfli.lisp Mon Jun 11 06:11:15 2012 (r13961) +++ trunk/abcl/contrib/jfli/jfli.lisp Tue Jun 12 04:46:11 2012 (r13962) @@ -7,8 +7,9 @@ ; You must not remove this notice, or any other, from this software. ; Ported to ABCL by asimon at math.bme.hu. -; Minor ABCL fixes by A. Vodonosov (avodonosov at yandex.ru). -; Ripped out CLOS mirror support +; Minor ABCL fixes by: +; A. Vodonosov (avodonosov at yandex.ru). +; Alex Mizrahi (alex.mizrahi at gmail.com) (defpackage :jfli (:use :common-lisp :java) @@ -25,6 +26,7 @@ :find-java-class :new :make-new + :make-typed-ref :jeq ;array support @@ -44,29 +46,60 @@ :new-proxy :unregister-proxy + ;conversions + :box-boolean + :box-byte + :box-char + :box-double + :box-float + :box-integer + :box-long + :box-short + :box-string + :unbox-boolean + :unbox-byte + :unbox-char + :unbox-double + :unbox-float + :unbox-integer + :unbox-long + :unbox-short + :unbox-string + +; :ensure-package +; :member-symbol +; :class-symbol +; :constructor-symbol + + :*null* + :new-class + :super )) (in-package :jfli) -#+ignore -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +null+ (make-immediate-object nil :ref)) - (defconstant +false+ (make-immediate-object nil :boolean)) - (defconstant +true+ (make-immediate-object t :boolean))) (eval-when (:compile-toplevel :load-toplevel :execute) - (defun string-append (&rest strings) - (apply #'concatenate 'string (mapcar #'(lambda (s) (if (symbolp s) (symbol-name s) s)) strings))) - (defun intern-and-unexport (string package) - (multiple-value-bind (symbol status) - (find-symbol string package) - (when (and *compile-file-pathname* (eq status :external)) (unexport symbol package)) - (intern string package)))) +(defun string-append (&rest strings) + (apply #'concatenate 'string (mapcar #'(lambda (s) (if (symbolp s) (symbol-name s) s)) strings))) + + +(defun intern-and-unexport (string package) + (multiple-value-bind (symbol status) + (find-symbol string package) + (when (and *compile-file-pathname* (eq status :external)) (unexport symbol package)) + (intern string package))) +) (defun is-assignable-from (class-1 class-2) (jcall (jmethod "java.lang.Class" "isAssignableFrom" "java.lang.Class") class-2 class-1)) ;;not a typo +#+abcl_not_used +(defun new-object-array (len element-type initial-element) + (jnew-array-from-array element-type (make-array (list len) :initial-element initial-element))) + + (defun java-ref-p (x) (java-object-p x)) @@ -89,9 +122,6 @@ (defun convert-to-java-string (s) (jnew (jconstructor "java.lang.String" "java.lang.String") s)) -(defun convert-from-java-string (s) - (values s)) - (define-symbol-macro boolean.type (jfield "java.lang.Boolean" "TYPE")) (define-symbol-macro byte.type (jfield "java.lang.Byte" "TYPE")) (define-symbol-macro character.type (jfield "java.lang.Character" "TYPE")) @@ -100,10 +130,24 @@ (define-symbol-macro long.type (jfield "java.lang.Long" "TYPE")) (define-symbol-macro float.type (jfield "java.lang.Float" "TYPE")) (define-symbol-macro double.type (jfield "java.lang.Double" "TYPE")) -(define-symbol-macro string.type (jclass "java.lang.String")) -(define-symbol-macro object.type (jclass "java.lang.Object")) (define-symbol-macro void.type (jfield "java.lang.Void" "TYPE")) +#| +(defconstant boolean.type (jfield "java.lang.Boolean" "TYPE")) +(defconstant byte.type (jfield "java.lang.Byte" "TYPE")) +(defconstant character.type (jfield "java.lang.Character" "TYPE")) +(defconstant short.type (jfield "java.lang.Short" "TYPE")) +(defconstant integer.type (jfield "java.lang.Integer" "TYPE")) +(defconstant long.type (jfield "java.lang.Long" "TYPE")) +(defconstant float.type (jfield "java.lang.Float" "TYPE")) +(defconstant double.type (jfield "java.lang.Double" "TYPE")) +|# + +(defconstant *null* java:+null+) + +(defun identity-or-nil (obj) + (unless (equal obj *null*) obj)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-when (:compile-toplevel :load-toplevel :execute) @@ -138,16 +182,30 @@ (eval-when (:compile-toplevel) (intern-and-unexport "OBJECT." "java.lang")) +;create object. to bootstrap the hierarchy +(defclass |java.lang|::object. () + ((ref :reader ref :initarg :ref) + (lisp-allocated :reader lisp-allocated-p :initarg :lisp-allocated :initform nil)) + (:documentation "the superclass of all Java typed reference classes")) + (defun get-ref (x) "any function taking an object can be passed a raw java-ref ptr or a typed reference instance. Will also convert strings for use as objects" +;; avodonosov: +;; typecase instead of etypecase +;; to allow not only jfli-wrapped objects +;; as a parameters of NEW-CLASS, but also native +;; Lisp objects too (in case of ABCL they are java +;; instances anyway). +;; For example that may be org.armedbear.lisp.Function. (typecase x (java-ref x) + (|java.lang|::object. (ref x)) (string (convert-to-java-string x)) (null nil) ((or number character) x) ;; avodonosov: otherwise clause - (otherwise x))) + (otherwise x))) (defun is-same-object (obj1 obj2) (equal obj1 obj2)) @@ -240,18 +298,17 @@ (:short short.type) (:double double.type) (:byte byte.type) - (:object object.type) (:void void.type) (otherwise (get-java-class-ref class-sym-or-string)))) (string (get-java-class-ref (canonic-class-symbol class-sym-or-string))))) -;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;; typed reference support ;;;;;;;;;;;;;;;;;;;;;;;; #| -In an effort to reduce the volume of stuff generated when wrapping entire libraries, -the wrappers just generate minimal stubs, which, if and when invoked at runtime, -complete the work of building thunking closures, so very little code is generated for -things never called (Java libraries have huge numbers of symbols). -Not sure if this approach matters, but that's how it works +The library maintains a hierarchy of typed reference classes that parallel the +class hierarchy on the Java side +new returns a typed reference, but other functions that return objects +return raw references (for efficiency) +make-typed-ref can create fully-typed wrappers when desired |# (defun get-superclass-names (full-class-name) @@ -275,6 +332,67 @@ (lambda (x y) (is-assignable-from x y))))) (mapcar #'jclass-name result)))) +#| +(defun get-superclass-names (full-class-name) + (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name))) + (super (class.getsuperclass class)) + (interfaces (class.getinterfaces class)) + (supers ())) + (do-jarray (i interfaces) + (push (class.getname i) supers)) + ;hmmm - where should the base class go in the precedence list? + ;is it more important than the interfaces? this says no + (if super + (push (class.getname super) supers) + (push "java.lang.Object" supers)) + (nreverse supers))) +|# + +(defun %ensure-java-class (full-class-name) + "walks the superclass hierarchy and makes sure all the classes are fully defined +(they may be undefined or just forward-referenced-class) +caches this has been done on the class-symbol's plist" + (let* ((class-sym (class-symbol full-class-name)) + (class (find-class class-sym nil))) + (if (or (eql class-sym '|java.lang|::object.) + (get class-sym :ensured)) + class + (let ((supers (get-superclass-names full-class-name))) + (dolist (super supers) + (%ensure-java-class super)) + (unless (and class (subtypep class 'standard-object)) + (setf class + #+abcl + (sys::ensure-class class-sym :direct-superclasses (mapcar #'(lambda (c) (find-class (class-symbol c))) supers)))) + (setf (get class-sym :ensured) t) + class)))) + + +(defun ensure-java-hierarchy (class-sym) + "Works off class-sym for efficient use in new +This will only work on class-syms created by def-java-class, +as it depends upon symbol-value being the canonic class symbol" + (unless (get class-sym :ensured) + (%ensure-java-class (java-class-name class-sym)))) + +(defun make-typed-ref (java-ref) + "Given a raw java-ref, determines the full type of the object +and returns an instance of a typed reference wrapper" + (when java-ref + (let ((class (jobject-class java-ref))) + (if (jclass-array-p class) + (error "typed refs not supported for arrays (yet)") + (make-instance (%ensure-java-class (jclass-name class)) :ref java-ref))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| +In an effort to reduce the volume of stuff generated when wrapping entire libraries, +the wrappers just generate minimal stubs, which, if and when invoked at runtime, +complete the work of building thunking closures, so very little code is generated for +things never called (Java libraries have huge numbers of symbols). +Not sure if this approach matters, but that's how it works +|# (defmacro def-java-class (full-class-name) "Given the package-qualified, case-correct name of a java class, will generate @@ -284,8 +402,9 @@ (let* ((class-sym (unexported-class-symbol full-class-name)) (defs (list* + #+nil `(format t "!!!!!!!!!!~a~%" ,full-class-name) `(ensure-package ,pacakge) - ;;build a path from the simple class symbol to the canonic + ;build a path from the simple class symbol to the canonic `(defconstant ,class-sym ',(canonic-class-symbol full-class-name)) `(export ',class-sym (symbol-package ',class-sym)) `(def-java-constructors ,full-class-name) @@ -300,7 +419,10 @@ (lambda (p) `(ensure-package ,(package-name p))) (remove (symbol-package class-sym) (remove-duplicates (mapcar #'symbol-package supers)))) - super-exports)))))) + super-exports + (list + `(defclass ,(class-symbol full-class-name) + ,supers ())))))))) `(locally , at defs)))) (defun jarfile.new (fn) @@ -403,22 +525,24 @@ (let* ((ctor-list (get-ctor-list full-class-name))) (when ctor-list (setf (fdefinition (constructor-symbol full-class-name)) - (make-ctor-thunk ctor-list))))) + (make-ctor-thunk ctor-list (class-symbol full-class-name)))))) -(defun make-ctor-thunk (ctors) +(defun make-ctor-thunk (ctors class-sym) (if (rest ctors) ;overloaded - (make-overloaded-ctor-thunk ctors) - (make-non-overloaded-ctor-thunk (first ctors)))) + (make-overloaded-ctor-thunk ctors class-sym) + (make-non-overloaded-ctor-thunk (first ctors) class-sym))) -(defun make-non-overloaded-ctor-thunk (ctor) +(defun make-non-overloaded-ctor-thunk (ctor class-sym) (let ((arg-boxers (get-arg-boxers (jconstructor-params ctor)))) (lambda (&rest args) - (let* ((arglist (build-arglist args arg-boxers)) - (object (apply #'jnew ctor arglist))) - (unbox-object object))))) + (let ((arglist (build-arglist args arg-boxers))) + (ensure-java-hierarchy class-sym) + (make-instance class-sym + :ref (apply #'jnew ctor arglist) + :lisp-allocated t))))) -(defun make-overloaded-ctor-thunk (ctors) - (let ((thunks (make-ctor-thunks-by-args-length ctors))) +(defun make-overloaded-ctor-thunk (ctors class-sym) + (let ((thunks (make-ctor-thunks-by-args-length ctors class-sym))) (lambda (&rest args) (let ((fn (cdr (assoc (length args) thunks)))) (if fn @@ -426,7 +550,7 @@ args) (error "invalid arity")))))) -(defun make-ctor-thunks-by-args-length (ctors) +(defun make-ctor-thunks-by-args-length (ctors class-sym) "returns an alist of thunks keyed by number of args" (let ((ctors-by-args-length (make-hash-table)) (thunks-by-args-length nil)) @@ -436,17 +560,17 @@ (maphash #'(lambda (args-len ctors) (push (cons args-len (if (rest ctors);truly overloaded - (make-type-overloaded-ctor-thunk ctors) + (make-type-overloaded-ctor-thunk ctors class-sym) ;only one ctor with this number of args - (make-non-overloaded-ctor-thunk (first ctors)))) + (make-non-overloaded-ctor-thunk (first ctors) class-sym))) thunks-by-args-length)) ctors-by-args-length) thunks-by-args-length)) -(defun make-type-overloaded-ctor-thunk (ctors) +(defun make-type-overloaded-ctor-thunk (ctors class-sym) "these methods have the same number of args and must be distinguished by type" (let ((thunks (mapcar #'(lambda (ctor) - (list (make-non-overloaded-ctor-thunk ctor) + (list (make-non-overloaded-ctor-thunk ctor class-sym) (jarray-to-list (jconstructor-params ctor)))) ctors))) (lambda (&rest args) @@ -584,18 +708,24 @@ (progn (setf (fdefinition field-sym) (lambda () - (funcall unboxer (jfield-raw class field-name)))) + (funcall unboxer (jfield-raw class field-name) #+nil (field.get field nil)))) (setf (fdefinition `(setf ,field-sym)) (lambda (arg) - (jfield field-name nil (get-ref (funcall boxer arg))) + (jfield field-name nil + (get-ref (if (and boxer (not (boxed? arg))) + (funcall boxer arg) + arg))) arg))) (progn (setf (fdefinition field-sym) (lambda (obj) - (funcall unboxer (jfield-raw class field-name (get-ref obj))))) + (funcall unboxer (jfield-raw class field-name (get-ref obj)) #+nil(field.get field (get-ref obj))))) (setf (fdefinition `(setf ,field-sym)) (lambda (arg obj) - (jfield field-name (get-ref obj) (get-ref (funcall boxer arg))) + (jfield field-name (get-ref obj) + (get-ref (if (and boxer (not (boxed? arg))) + (funcall boxer arg) + arg))) arg)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -627,13 +757,13 @@ (mapcar #'class-name-for-doc (jarray-to-list (jmethod-params m))))))) (defmacro def-java-methods (full-class-name) - (let ((class-methods (get-class-methods full-class-name)) + (let ((methods-by-name (get-methods-by-name full-class-name)) (defs nil)) (maphash (lambda (name methods) (let ((method-sym (unexported-member-symbol full-class-name name))) (push `(defun ,method-sym (&rest args) ,(build-method-doc-string name methods) - (apply #'install-method-and-call ,full-class-name ,name args)) + (apply #'install-methods-and-call ,full-class-name ,name args)) defs) (push `(export ',method-sym (symbol-package ',method-sym)) defs) @@ -641,7 +771,7 @@ (flet ((add-setter-if (prefix) (when (eql 0 (search prefix name)) (let ((setname (string-append "set" (subseq name (length prefix))))) - (when (gethash setname class-methods) + (when (gethash setname methods-by-name) (push `(defun (setf ,method-sym) (val &rest args) (progn (apply #',(member-symbol full-class-name setname) @@ -650,15 +780,15 @@ defs)))))) (add-setter-if "get") (add-setter-if "is")))) - class-methods) + methods-by-name) `(locally ,@(nreverse defs)))) -(defun install-method-and-call (full-class-name name &rest args) +(defun install-methods-and-call (full-class-name method &rest args) "initially all the member function symbols for a class are bound to this function, when first called it will replace them with the appropriate direct thunks, then call the requested method - subsequent calls via those symbols will be direct" - (install-method full-class-name name) - (apply (member-symbol full-class-name name) args)) + (install-methods full-class-name) + (apply (member-symbol full-class-name method) args)) (defun decode-array-name (tn) (let ((prim (assoc tn @@ -689,7 +819,8 @@ (defun jmethod-made-accessible (method) "Return a method made accessible" (jcall (jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean") - method +true+) + method + java:+true+) method) (defun jclass-relevant-methods (class) @@ -698,22 +829,24 @@ (map 'list #'jmethod-made-accessible (remove-if-not #'jmember-protected-p (jclass-methods class :declared t))))) -(defun get-class-methods (full-class-name) +(defun get-methods-by-name (full-class-name) "returns an #'equal hashtable of lists of java.lang.Method refs keyed by name" (let* ((class-sym (canonic-class-symbol full-class-name)) (class (get-java-class-ref class-sym)) (methods (jclass-relevant-methods class)) - (class-methods (make-hash-table :test #'equal))) + (methods-by-name (make-hash-table :test #'equal))) (loop for method in methods do - (push method (gethash (jmethod-name method) class-methods))) - class-methods)) + (push method (gethash (jmethod-name method) methods-by-name))) + methods-by-name)) -(defun install-method (full-class-name name) - (let* ((class-methods (get-class-methods full-class-name)) - (methods (gethash name class-methods))) - (setf (fdefinition (member-symbol full-class-name name)) - (make-method-thunk methods)))) +(defun install-methods (full-class-name) + (let ((methods-by-name (get-methods-by-name full-class-name))) + (maphash + (lambda (name methods) + (setf (fdefinition (member-symbol full-class-name name)) + (make-method-thunk methods))) + methods-by-name))) (defun make-method-thunk (methods) (if (rest methods) ;overloaded @@ -726,9 +859,11 @@ (is-static (jmember-static-p method)) (caller (if is-static #'jstatic-raw #'jcall-raw))) (lambda (&rest args) - (let ((object (if is-static nil (get-ref (first args)))) - (arglist (build-arglist (if is-static args (rest args)) arg-boxers))) - (funcall unboxer-fn (apply caller method object arglist)))))) + (let ((arglist (build-arglist (if is-static args (rest args)) arg-boxers))) + (funcall unboxer-fn + (apply caller method + (if is-static nil (get-ref (first args))) + arglist)))))) (defun make-overloaded-thunk (methods) (let ((thunks (make-thunks-by-args-length methods))) @@ -781,8 +916,11 @@ (defun jref (array &rest subscripts) (apply #'jarray-ref-raw array subscripts)) + (defun (setf jref) (val array &rest subscripts) - (apply #'jarray-set array (get-ref val) subscripts)) + (apply #'jarray-set array val subscripts)) + + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro def-refs (&rest types) @@ -794,10 +932,11 @@ `(defun ,ref-sym (array &rest subscripts) ,(format nil "like aref, for Java arrays of ~A, settable" (symbol-name type)) (assert (every #'integerp subscripts)) - (unbox-object (apply #'jarray-ref array subscripts))) + (apply #'jarray-ref array subscripts)) + `(defun (setf ,ref-sym) (val array &rest subscripts) (assert (every #'integerp subscripts)) - (apply #'jarray-set array val subscripts) + (apply #'jarray-set array ,(if (eql type 'boolean) '(box-boolean val) 'val) subscripts) )))) types)))) @@ -844,16 +983,15 @@ (defmethod make-new-array ((type (eql :long)) &rest dimensions) (apply #'make-new-array long.type dimensions)) -(defmethod make-new-array ((type (eql :object)) &rest dimensions) - (apply #'make-new-array object.type dimensions)) - ;;;;;;;;;;;;;;;;;;;;;;;;;; arg/param helpers ;;;;;;;;;;;;;;;;;;;;;; (defun get-arg-boxers (param-types) "returns a list with one entry per param, either nil or a function that boxes the arg" - (loop for param-type across param-types collect - (get-boxer-fn (jclass-name param-type)))) + (loop for param-type across param-types + collecting (get-boxer-fn (jclass-name param-type)))) + + (defun build-arglist (args arg-boxers) (when args @@ -883,10 +1021,21 @@ ;;;;;;;;;;;;;;;;;;;;;;;; argument conversion and boxing ;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun box-string (s) + "Given a string or symbol, returns reference to a Java string" + (convert-to-java-string s)) + +(defun unbox-string (ref &optional delete-local) + "Given a reference to a Java string, returns a Lisp string" + (declare (ignore delete-local)) + (convert-from-java-string (get-ref ref))) + + + (defun get-boxer-fn (class-name) (if (string= class-name "boolean") #'box-boolean - #'identity)) + nil)) (defun get-boxer-fn-sym (class-name) (if (string= class-name "boolean") @@ -901,50 +1050,41 @@ (cond ((null x) nil) ((boxed? x) (jobject-class (get-ref x))) - ((integerp x) integer.type) + ((typep x '(integer -2147483648 +2147483647)) integer.type) + ((typep x '(integer -9223372036854775808 +9223372036854775807)) long.type) ((numberp x) double.type) + ; ((characterp x) character.type) ;;;FIXME!! ((eq x t) boolean.type) - ((stringp x) string.type) - ((symbolp x) string.type) - (t object.type) + ((or (stringp x) (symbolp x)) + (get-java-class-ref '|java.lang|::|String|)) (t (error "can't infer box type")))) + (defun get-unboxer-fn (class-name) - (cond ((string= class-name "void") #'unbox-void) - ((is-name-of-primitive class-name) #'unbox-primitive) - ((string= class-name "java.lang.String") #'unbox-string) - ((string= class-name "java.lang.Boolean") #'unbox-boolean) - (t #'unbox-object))) + (if (string= class-name "void") + #'unbox-void + (if (or (is-name-of-primitive class-name) (string= class-name "java.lang.String")) + #'jobject-lisp-value + #'identity-or-nil))) (defun get-unboxer-fn-sym (class-name) - (cond ((string= class-name "void") 'unbox-void) - ((is-name-of-primitive class-name) 'unbox-primitive) - ((string= class-name "java.lang.String") 'unbox-string) - ((string= class-name "java.lang.Boolean") 'unbox-boolean) - (t 'unbox-object))) + (if (string= class-name "void") + 'unbox-void + (if (or (is-name-of-primitive class-name) (string= class-name "java.lang.String")) + 'jobject-lisp-value + 'identity-or-nil))) + (defun unbox-void (x &optional delete-local) (declare (ignore x delete-local)) nil) -(defun unbox-primitive (x) - (unless (equal x +null+) - (jobject-lisp-value x))) - -(defun unbox-string (x) - (unless (equal x +null+) - (jobject-lisp-value x))) - -(defun unbox-boolean (x) - (unless (equal x +null+) - (jobject-lisp-value x))) - -(defun unbox-object (x) - (unless (equal x +null+) - (jcoerce x (jclass-of x)))) +(defun box-void (x) + (declare (ignore x)) + nil) (defun box-boolean (x) - (if x +true+ +false+)) + (if x java:+true+ java:+false+)) ;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1025,6 +1165,26 @@ arg-defs (jarray-to-list params)))) `(java::%jnew-proxy ,@(process-idefs interface-defs))))) + +#+nil +(defun jrc (class-name super-name interfaces constructors methods fields &optional filename) + "A friendlier version of jnew-runtime-class." + #+nil (format t "~s~%~s~%~s~%~s~%~s~%~s~%" class-name super-name interfaces constructors methods fields filename) + (if (java:jruntime-class-exists-p class-name) + (progn + (warn "Java class ~a already exists. Redefining methods." class-name) + (loop for + (argument-types function super-invocation-args) in constructors + do + (java:jredefine-method class-name nil argument-types function)) + (loop for + (method-name return-type argument-types function &rest modifiers) + in methods + do + (java:jredefine-method class-name method-name argument-types function))) + (java:jnew-runtime-class class-name super-name interfaces constructors methods fields filename))) + + (defun get-modifiers (member) (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)) @@ -1046,10 +1206,164 @@ mods) collect mod))) + +(defun get-java-object (x) + (typecase x + (|java.lang|::object. (ref x)) + (t x))) + (defun find-java-class-name-in-macro (c) (etypecase c (symbol (jclass-name (find-java-class (symbol-value c)))) (string c))) +#+nil +(defmacro new-class (class-name super-and-interface-names constructor-defs method-defs field-defs) + "class-name -> string + super-and-interface-names -> class-name | (class-name interface-name*) + constructor-defs -> (constructor-def*) + constructor-def -> (ctr-arg-defs body) + /the first form in body may be (super arg-name+); this will call the constructor of the superclass + with the listed arguments/ + ctr-arg-def -> (arg-name arg-type) + method-def -> (method-name return-type access-modifiers arg-defs* body) + /access-modifiers may be nil (to get the modifiers from the superclass), a keyword, or + a list of keywords/ + method-name -> string +arg-def -> arg-name | (arg-name arg-type) +arg-type -> \"package.qualified.ClassName\" | classname. | :primitive +class-name -> \"package.qualified.ClassName\" | classname. +interface-name -> \"package.qualified.InterfaceName\" | interfacename. + +Creates, registers and returns a Java object that implements the supplied interfaces" + (let ((this (intern "THIS" *package*)) + (defined-method-names)) + (labels ((process-ctr-def (ctr-def ctrs) + (destructuring-bind ((&rest arg-defs) &body body) + ctr-def + (let ((ctr-param-names + (mapcar + #'(lambda (arg-def) (find-java-class-name-in-macro (cadr arg-def))) + arg-defs)) + ;(ctr-param-names (mapcar #'cadr arg-defs)) + (gargs (gensym)) + (head (car body)) + (sia)) + (when (and (consp head) (eq (car head) 'super)) + (setq sia (mapcar + #'(lambda (arg-name) + (1+ (position arg-name arg-defs :key #'car))) + (cdr head)) + body (cdr body))) + `(,ctr-param-names + (lambda (&rest ,gargs) + (let ,(arg-lets (append arg-defs (list this)) + (append + ctr-param-names + (list class-name)) + gargs + 0) + , at body)) + ,sia)))) + (process-method-def (method-def methods) + (destructuring-bind (method-name return-type modifiers (&rest arg-defs) &body body) + method-def + (push method-name defined-method-names) + (let* ((method (matching-method method-name arg-defs methods)) + (method-params + (if method + (jarray-to-list (jmethod-params method)) + (mapcar #'(lambda (arg-def) (find-java-class-in-macro (cadr arg-def))) arg-defs))) + (method-param-names + #+nil + (if method + (mapcar #'jclass-name (jarray-to-list method-params)) + (mapcar #'cadr arg-defs)) + (mapcar #'jclass-name method-params)) + (return-type-name + (jclass-name + (if method (jmethod-return-type method) (find-java-class-in-macro return-type)))) + (modifiers + #+nil + (if method (get-modifier-list method) '("public")) + (cond ((and (null modifiers) method) (get-modifier-list method)) + ((symbolp modifiers) (list (string-downcase (symbol-name modifiers)))) + ((consp modifiers) (mapcar #'(lambda (m) (string-downcase (symbol-name m))) modifiers)) + (t (error (format t "Need to provide modifiers for method ~A" method-name))))) + (gargs (gensym))) + `(,method-name ,return-type-name ,method-param-names + (lambda (&rest ,gargs) + ;;(,(get-boxer-fn-sym return-type-name) + (get-java-object ;;check! + (let ,(arg-lets (append arg-defs (list this)) + (append + method-param-names + #+nil (map 'list #'(lambda (p) (jclass-name p)) method-params) + (list class-name)) + gargs + 0) + , at body)) + ) + , at modifiers)))) + (arg-lets (arg-defs params gargs idx) + (when arg-defs + (let ((arg (first arg-defs)) + (param (first params))) + (cons `(,(if (atom arg) arg (first arg)) + (,(get-unboxer-fn-sym param) + (nth ,idx ,gargs))) + (arg-lets (rest arg-defs) (rest params) gargs (1+ idx)))))) + (matching-method (method-name arg-defs methods) + (let (match) + (loop for method across methods + when (method-matches method-name arg-defs method) + do + (if match + (error (format nil "more than one method matches ~A" method-name)) + (setf match method))) + match)) + (method-matches (method-name arg-defs method) + (when (string-equal method-name (jmethod-name method)) + (let ((params (jmethod-params method))) + (when (= (length arg-defs) (length params)) + (is-congruent arg-defs params))))) + (is-congruent (arg-defs params) + (every (lambda (arg param) + (or (atom arg) ;no type spec matches anything + (jeq (find-java-class-in-macro (second arg)) param))) + arg-defs (jarray-to-list params)))) + (unless (consp super-and-interface-names) + (setq super-and-interface-names (list super-and-interface-names))) + (let* ((super-name (find-java-class-name-in-macro (car super-and-interface-names))) + (interfaces (mapcar #'find-java-class-name-in-macro (cdr super-and-interface-names))) + (super (jclass super-name)) + (super-ctrs (jclass-constructors super)) + (ctrs-ret (loop for ctr-def in constructor-defs collecting + (process-ctr-def ctr-def super-ctrs))) + (super-methods (jclass-methods super)) + (iface-methods + (apply #'concatenate 'vector + (mapcar #'(lambda (ifn) + (jclass-methods (jclass ifn))) + interfaces))) + (methods-ret (loop for method-def in method-defs collecting + (process-method-def + method-def + (concatenate 'vector super-methods iface-methods))))) + ;;check to make sure every function is defined + (loop for method across iface-methods + for mname = (jmethod-name method) + unless (member mname defined-method-names :test #'string-equal) + do + (warn (format nil "class doesn't define:~%~A" mname))) + `(progn + (jrc ,class-name ,super-name ,interfaces + ',ctrs-ret + ',methods-ret + (loop for (fn type . mods) in ',field-defs + collecting `(,fn ,(find-java-class-name-in-macro type) + ,@(mapcar #'(lambda (mod) (string-downcase (symbol-name mod))) mods))) + #+nil ,(namestring (merge-pathnames class-name "/tmp/"))) + (eval '(def-java-class ,class-name))))))) From mevenson at common-lisp.net Wed Jun 13 11:39:20 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 13 Jun 2012 04:39:20 -0700 Subject: [armedbear-cvs] r13963 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jun 13 04:39:16 2012 New Revision: 13963 Log: asdf: Upgrade to asdf-2.22. 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 Tue Jun 12 04:46:11 2012 (r13962) +++ trunk/abcl/doc/asdf/asdf.texinfo Wed Jun 13 04:39:16 2012 (r13963) @@ -2924,12 +2924,19 @@ @section Controlling source file character encoding -Starting with ASDF 2.21, components accept a @code{:encoding} option. +Starting with ASDF 2.21, components accept a @code{:encoding} option +so authors may specify which character encoding should be used +to read and evaluate their source code. +When left unspecified, the encoding is inherited +from the parent module or system; +if no encoding is specified at any point, +the default @code{:autodetect} is assumed. By default, only @code{:default}, @code{:utf-8} and @code{:autodetect} are accepted. - at code{:autodetect} is the default, and calls + at code{:autodetect}, the default, calls @code{*encoding-detection-hook*} which by default always returns @code{*default-encoding*} which itself defaults to @code{:default}. + In other words, there now are plenty of extension hooks, but by default ASDF follows the backwards compatible behavior of using whichever @code{:default} encoding your implementation uses, @@ -2948,7 +2955,7 @@ only if you're using a recent ASDF on an implementation that supports unicode. We recommend that you avoid using unprotected @code{:encoding} specifications -until after ASDF 2.21 becomes widespread, hopefully by the end of 2012. +until after ASDF 2.21 or later becomes widespread, hopefully by the end of 2012. While it offers plenty of hooks for extension, and one such extension is being developed (see below), @@ -3156,7 +3163,7 @@ @code{xcvb-driver:run-program/} from the @code{xcvb-driver} system that is distributed with XCVB: @url{http://common-lisp.net/project/xcvb}. -It's only alternative that supports +It's the only alternative that supports as many implementations and operating systems as ASDF does, and provides well-defined behavior outside Unix (i.e. on Windows). (The only unsupported exception is Genera, since on it @@ -3226,6 +3233,11 @@ to see if the new API is present. @emph{All} versions of ASDF should have the @code{:asdf} feature. +Additionally, all versions of asdf 2 +define a function @code{(asdf:asdf-version)} you may use to query the version; +and the source code of recent versions of asdf 2 features the version number +prominently on the second line of its source code. + If you are experiencing problems or limitations of any sort with ASDF 1, we recommend that you should upgrade to ASDF 2, or whatever is the latest release. @@ -3453,7 +3465,7 @@ your previous A-B-L configuration. See @code{enable-asdf-binary-locations-compatibility} in @pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. -But thou shall not load ABL on top of ASDF 2. +But thou shalt not load ABL on top of ASDF 2. @end itemize @@ -3469,7 +3481,8 @@ must now be specified with @code{#p} syntax where the namestring might have previously sufficed; moreover when evaluation is desired @code{#.} must be used, -where it wasn't necessary in the toplevel @code{:pathname} argument. +where it wasn't necessary in the toplevel @code{:pathname} argument +(but necessary in other @code{:pathname} arguments). @item There is a slight performance bug, notably on SBCL, @@ -3485,7 +3498,7 @@ or shallow @code{:tree} entries. Or you can fix your implementation to not be quite that slow when recursing through directories. - at emph{Update}: performance bug fixed the hard way in 2.010. + at emph{Update}: This performance bug fixed the hard way in 2.010. @item On Windows, only LispWorks supports proper default configuration pathnames @@ -3542,6 +3555,7 @@ @item If ASDF isn't loaded yet, then @code{(require "asdf")} should load the version of ASDF that is bundled with your system. +If possible so should @code{(require "ASDF")}. You may have it load some other version configured by the user, if you allow such configuration. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Tue Jun 12 04:46:11 2012 (r13962) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Wed Jun 13 04:39:16 2012 (r13963) @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.21: Another System Definition Facility. +;;; This is ASDF 2.22: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -116,7 +116,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.21") + (asdf-version "2.22") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -1343,7 +1343,7 @@ :initarg :if-component-dep-fails :accessor module-if-component-dep-fails) (default-component-class - :initform *default-component-class* + :initform nil :initarg :default-component-class :accessor module-default-component-class))) @@ -2788,6 +2788,11 @@ directory-pathname (default-directory)))) +(defun* find-class* (x &optional (errorp t) environment) + (etypecase x + ((or standard-class built-in-class) x) + (symbol (find-class x errorp environment)))) + (defun* class-for-type (parent type) (or (loop :for symbol :in (list type @@ -2799,8 +2804,10 @@ class (find-class 'component))) :return class) (and (eq type :file) - (or (and parent (module-default-component-class parent)) - (find-class *default-component-class*))) + (find-class* + (or (loop :for module = parent :then (component-parent module) :while module + :thereis (module-default-component-class module)) + *default-component-class*) nil)) (sysdef-error "don't recognize component type ~A" type))) (defun* maybe-add-tree (tree op1 op2 c) @@ -2886,7 +2893,7 @@ (type name &rest rest &key ;; the following list of keywords is reproduced below in the ;; remove-keys form. important to keep them in sync - components pathname default-component-class + components pathname perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to do-first @@ -2913,7 +2920,7 @@ :pathname pathname :parent parent (remove-keys - '(components pathname default-component-class + '(components pathname perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to) rest))) @@ -2927,10 +2934,6 @@ (setf ret (apply 'make-instance (class-for-type parent type) args))) (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) - (setf (module-default-component-class ret) - (or default-component-class - (and (typep parent 'module) - (module-default-component-class parent)))) (let ((*serial-depends-on* nil)) (setf (module-components ret) (loop @@ -3687,7 +3690,7 @@ #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ()))) ;; The below two are not needed: no precompiled ASDF system there - ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) + #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ;; All-import, here is where we want user stuff to be: :inherit-configuration @@ -4011,21 +4014,24 @@ entries)) (defun* directory-files (directory &optional (pattern *wild-file*)) - (setf directory (pathname directory)) - (when (wild-pathname-p directory) - (error "Invalid wild in ~S" directory)) - (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) - (error "Invalid file pattern ~S" pattern)) - (when (typep directory 'logical-pathname) - (setf pattern (make-pathname-logical pattern (pathname-host directory)))) - (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory))))) - (filter-logical-directory-results - directory entries - #'(lambda (f) - (make-pathname :defaults directory - :name (pathname-name f) - :type (make-pathname-component-logical (pathname-type f)) - :version (make-pathname-component-logical (pathname-version f))))))) + (let ((dir (pathname directory))) + (when (typep dir 'logical-pathname) + ;; Because of the filtering we do below, + ;; logical pathnames have restrictions on wild patterns. + ;; Not that the results are very portable when you use these patterns on physical pathnames. + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (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))))) + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical (pathname-name f)) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f)))))))) (defun* directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -4399,7 +4405,7 @@ (let ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil))) (when system - (operate *require-asdf-operator* system :verbose nil) + (operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems)) t)))) #+(or abcl clisp clozure cmu ecl sbcl) From rschlatte at common-lisp.net Thu Jun 14 12:46:27 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 14 Jun 2012 05:46:27 -0700 Subject: [armedbear-cvs] r13964 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu Jun 14 05:46:25 2012 New Revision: 13964 Log: make (setf class-name) call reinitialize-instance Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jun 13 04:39:16 2012 (r13963) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Jun 14 05:46:25 2012 (r13964) @@ -2722,42 +2722,50 @@ (%set-generic-function-name gf ',function-name) gf)))) -(defmacro redefine-class-forwarder (name slot) +(defmacro redefine-class-forwarder (name slot &optional body-alist) "Define a generic function on a temporary symbol as an accessor for the slot `slot'. Then, when definition is complete (including allocation of methods), swap the definition in place. -Without this approach, we can't depend the old forwarders to be -in place, while we still need them to " - (let* (($name (if (consp name) (cadr name) name)) - (%name (intern (concatenate 'string - "%" - (if (consp name) - (symbol-name 'set-) "") - (symbol-name $name)) - (find-package "SYS")))) - `(atomic-defgeneric ,name (;; splice a new-value parameter for setters - ,@(when (consp name) (list 'new-value)) - class) - ,@(mapcar (if (consp name) - #'(lambda (class-name) - `(:method (new-value (class ,class-name)) - (,%name new-value class))) - #'(lambda (class-name) - `(:method ((class ,class-name)) - (,%name class)))) - '(built-in-class forward-referenced-class structure-class)) - ,@(mapcar #'(lambda (class-name) - `(:method (,@(when (consp name) (list 'new-value)) - (class ,class-name)) - ,(if (consp name) - `(setf (slot-value class ',slot) new-value) - `(slot-value class ',slot)))) - '(standard-class funcallable-standard-class))))) +`body-alist' can be used to override the default method bodies for given +metaclasses. In substitute method bodies, `class' names the class +instance and, for setters, `new-value' the new value." + (let* ((setterp (consp name)) + (%name + (intern (concatenate 'string + "%" + (if setterp (symbol-name 'set-) "") + (symbol-name (if setterp (cadr name) name))) + (find-package "SYS"))) + (bodies + (append body-alist + (if setterp + `((built-in-class . (,%name new-value class)) + (forward-referenced-class . (,%name new-value class)) + (structure-class . (,%name new-value class)) + (standard-class . (setf (slot-value class ',slot) + new-value)) + (funcallable-standard-class . (setf (slot-value class ',slot) + new-value))) + `((built-in-class . (,%name class)) + (forward-referenced-class . (,%name class)) + (structure-class . (,%name class)) + (standard-class . (slot-value class ',slot)) + (funcallable-standard-class . (slot-value class ',slot))))))) + `(atomic-defgeneric ,name (,@(when setterp (list 'new-value)) class) + ,@(mapcar #'(lambda (class-name) + `(:method (,@(when setterp (list 'new-value)) + (class ,class-name)) + ,(cdr (assoc class-name bodies)))) + '(built-in-class forward-referenced-class structure-class + standard-class funcallable-standard-class))))) (redefine-class-forwarder class-name name) -(redefine-class-forwarder (setf class-name) name) +;;; AMOP pg. 230 +(redefine-class-forwarder (setf class-name) name + ((standard-class . (reinitialize-instance class :name new-value)) + (funcallable-standard-class . (reinitialize-instance class :name new-value)))) (redefine-class-forwarder class-slots slots) (redefine-class-forwarder (setf class-slots) slots) (redefine-class-forwarder class-direct-slots direct-slots) From rschlatte at common-lisp.net Thu Jun 14 16:16:58 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 14 Jun 2012 09:16:58 -0700 Subject: [armedbear-cvs] r13965 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu Jun 14 09:16:57 2012 New Revision: 13965 Log: Implement (setf generic-function-name) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Jun 14 05:46:25 2012 (r13964) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Jun 14 09:16:57 2012 (r13965) @@ -4052,6 +4052,11 @@ (:method ((generic-function standard-generic-function)) (sys:%generic-function-name generic-function))) +;;; AMOP pg. 231 +(defgeneric (setf generic-function-name) (new-value gf) + (:method (new-value (gf generic-function)) + (reinitialize-instance gf :name new-value))) + ;;; Readers for Method Metaobjects ;;; AMOP pg. 218ff. From mevenson at common-lisp.net Fri Jun 15 14:41:33 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 15 Jun 2012 07:41:33 -0700 Subject: [armedbear-cvs] r13966 - trunk/abcl/examples/misc Message-ID: Author: mevenson Date: Fri Jun 15 07:41:32 2012 New Revision: 13966 Log: examples/misc/dotabclrc: More contemporary examples. Example for how to possibly dynamically load and install Quicklisp (q.v.) from an HTTP connection. Example of the nest of CL:REQUIRE statements needed to bring up the Maven Aether connector contained in ABCL-ASDF. Modified: trunk/abcl/examples/misc/dotabclrc Modified: trunk/abcl/examples/misc/dotabclrc ============================================================================== --- trunk/abcl/examples/misc/dotabclrc Thu Jun 14 09:16:57 2012 (r13965) +++ trunk/abcl/examples/misc/dotabclrc Fri Jun 15 07:41:32 2012 (r13966) @@ -1,11 +1,20 @@ ;;; -*- Mode: Lisp -*- -;;; See also: -;;; .clinit.cl (Allegro) -;;; .cmucl-init.lisp (CMUCL) -;;; .sbclrc (SBCL) -;;; .clisprc.lisp (CLISP) -;;; .lispworks (LispWorks) +;;; Possible codas for inclusion in the Armed Bear startup file #p"~/.abclrc" + +#-quicklisp +(let ((quicklisp-local #P"~/quicklisp/setup.lisp") + (quicklisp-remote #p"http://beta.quicklisp.org/quiclisp.lisp")) + (unless (probe-file quicklisp-local) + (unless (probe-file quicklisp-remote) ;;; XXX possibly search for a proxy? + (load quicklisp-remote))) + (when (probe-file quicklisp-local) + (load quicklisp-local))) + +(require :asdf) +(require :abcl-contrib) +(require :abcl-asdf) +(setf abcl-asdf::*maven-http-proxy* "http://localhost:3128/") ;;; Customize the procedure used by CL:DISASSEMBLE (setf *disassembler* From mevenson at common-lisp.net Fri Jun 15 20:41:57 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 15 Jun 2012 13:41:57 -0700 Subject: [armedbear-cvs] r13967 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jun 15 13:41:56 2012 New Revision: 13967 Log: JAVA:JINPUT-STREAM returns the underlying java.io.InputStream for any PATHNAME resolved by CL:TRUENAME. SYS:ENSURE-INPUT-STREAM is the primitive wrapping the execution of Pathname.getInputStream(). My name is , and I support this API. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Fri Jun 15 07:41:32 2012 (r13966) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Fri Jun 15 13:41:56 2012 (r13967) @@ -1064,7 +1064,7 @@ return (Symbol)// Not reached. type_error(obj, Symbol.SYMBOL); } - + public static final LispObject checkList(LispObject obj) { Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java Fri Jun 15 07:41:32 2012 (r13966) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Fri Jun 15 13:41:56 2012 (r13967) @@ -2282,6 +2282,22 @@ return result; } + public static final Primitive GET_INPUT_STREAM = new pf_get_input_stream(); + @DocString(name="get-input-stream", + args="pathname", + doc="Returns a java.io.InputStream for resource denoted by PATHNAME.") + private static final class pf_get_input_stream extends Primitive { + pf_get_input_stream() { + super("ensure-input-stream", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject pathname) { + Pathname p = (Pathname) coerceToPathname(pathname); + return new JavaObject(p.getInputStream()); + } + }; + + public InputStream getInputStream() { InputStream result = null; if (isJar()) { Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jun 15 07:41:32 2012 (r13966) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jun 15 13:41:56 2012 (r13967) @@ -3064,6 +3064,8 @@ PACKAGE_JAVA.addExternalSymbol("JCLASS-NAME"); public static final Symbol JCLASS_OF = PACKAGE_JAVA.addExternalSymbol("JCLASS-OF"); + public static final Symbol JINPUT_STREAM = + PACKAGE_JAVA.addExternalSymbol("JINPUT-STREAM"); public static final Symbol JMETHOD_RETURN_TYPE = PACKAGE_JAVA.addExternalSymbol("JMETHOD-RETURN-TYPE"); public static final Symbol JRESOLVE_METHOD = @@ -3084,6 +3086,8 @@ PACKAGE_SYS.addExternalSymbol("FLOAT-UNDERFLOW-MODE"); public static final Symbol FLOAT_OVERFLOW_MODE = PACKAGE_SYS.addExternalSymbol("FLOAT-OVERFLOW-MODE"); + public static final Symbol ENSURE_INPUT_STREAM = + PACKAGE_SYS.addExternalSymbol("ENSURE-INPUT-STREAM"); public static final Symbol CLASS_BYTES = PACKAGE_SYS.addExternalSymbol("CLASS-BYTES"); public static final Symbol _CLASS_SLOTS = Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp Fri Jun 15 07:41:32 2012 (r13966) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Fri Jun 15 13:41:56 2012 (r13967) @@ -513,4 +513,9 @@ (declare (ignore initargs)) (error "make-instance not supported for ~S" class)) +(defun jinput-stream (pathname) + "Returns a java.io.InputStream for resource denoted by PATHNAME." + (sys:ensure-input-stream pathname)) + (provide "JAVA") + From rschlatte at common-lisp.net Sat Jun 16 10:45:29 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 16 Jun 2012 03:45:29 -0700 Subject: [armedbear-cvs] r13968 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jun 16 03:45:26 2012 New Revision: 13968 Log: Ensure add-method calls remove-method - also move some error checks out of the fast path + into standard path for non-standard metaclasses Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jun 15 13:41:56 2012 (r13967) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jun 16 03:45:26 2012 (r13968) @@ -1922,16 +1922,15 @@ (remove method (class-direct-methods specializer))))) (defun std-add-method (gf method) - (when (and (method-generic-function method) - (not (eql gf (method-generic-function method)))) - (error 'simple-error - :format-control "~S is already a method of ~S, cannot add to ~S." - :format-arguments (list method (method-generic-function method) gf))) - ;; Remove existing method with same qualifiers and specializers (if any). + ;; calls sites need to make sure that method is either a method of the + ;; given gf or does not have a gf. (let ((old-method (%find-method gf (std-method-qualifiers method) (method-specializers method) nil))) (when old-method - (std-remove-method gf old-method))) + (if (and (eq (class-of gf) +the-standard-generic-function-class+) + (eq (class-of old-method) +the-standard-method-class+)) + (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)) (dolist (specializer (method-specializers method)) @@ -3950,17 +3949,26 @@ (find-method (find-generic-function generic-function errorp) qualifiers specializers errorp)) +;;; AMOP pg. 167 (defgeneric add-method (generic-function method)) +(defmethod add-method :before ((generic-function generic-function) + (method method)) + (when (and (method-generic-function method) + (not (eql generic-function (method-generic-function method)))) + (error 'simple-error + :format-control "~S is already a method of ~S, cannot add to ~S." + :format-arguments (list method (method-generic-function method) + generic-function))) + (check-method-lambda-list (generic-function-name generic-function) + (method-lambda-list method) + (generic-function-lambda-list generic-function))) + (defmethod add-method ((generic-function standard-generic-function) - (method method)) - (let ((method-lambda-list (method-lambda-list method)) - (gf-lambda-list (generic-function-lambda-list generic-function))) - (check-method-lambda-list (%generic-function-name generic-function) - method-lambda-list gf-lambda-list)) + (method standard-method)) (std-add-method generic-function method)) -(defmethod add-method :after ((generic-function standard-generic-function) +(defmethod add-method :after ((generic-function generic-function) (method method)) (map-dependents generic-function #'(lambda (dep) (update-dependent generic-function dep @@ -3969,10 +3977,10 @@ (defgeneric remove-method (generic-function method)) (defmethod remove-method ((generic-function standard-generic-function) - (method method)) + (method standard-method)) (std-remove-method generic-function method)) -(defmethod remove-method :after ((generic-function standard-generic-function) +(defmethod remove-method :after ((generic-function generic-function) (method method)) (map-dependents generic-function #'(lambda (dep) (update-dependent generic-function dep From mevenson at common-lisp.net Sat Jun 16 22:02:35 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 16 Jun 2012 15:02:35 -0700 Subject: [armedbear-cvs] r13969 - trunk/abcl/examples/misc Message-ID: Author: mevenson Date: Sat Jun 16 15:02:34 2012 New Revision: 13969 Log: examples: fix obvious errors. Modified: trunk/abcl/examples/misc/dotabclrc Modified: trunk/abcl/examples/misc/dotabclrc ============================================================================== --- trunk/abcl/examples/misc/dotabclrc Sat Jun 16 03:45:26 2012 (r13968) +++ trunk/abcl/examples/misc/dotabclrc Sat Jun 16 15:02:34 2012 (r13969) @@ -4,9 +4,9 @@ #-quicklisp (let ((quicklisp-local #P"~/quicklisp/setup.lisp") - (quicklisp-remote #p"http://beta.quicklisp.org/quiclisp.lisp")) + (quicklisp-remote #p"http://beta.quicklisp.org/quicklisp.lisp")) (unless (probe-file quicklisp-local) - (unless (probe-file quicklisp-remote) ;;; XXX possibly search for a proxy? + (when (probe-file quicklisp-remote) ;;; XXX possibly search for a proxy? (load quicklisp-remote))) (when (probe-file quicklisp-local) (load quicklisp-local))) From rschlatte at common-lisp.net Sun Jun 17 10:54:12 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 17 Jun 2012 03:54:12 -0700 Subject: [armedbear-cvs] r13970 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 17 03:54:11 2012 New Revision: 13970 Log: implement generic-function-declarations Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Jun 16 15:02:34 2012 (r13969) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Jun 17 03:54:11 2012 (r13970) @@ -65,6 +65,7 @@ Symbol.STANDARD; slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL; } @@ -114,6 +115,7 @@ Symbol.STANDARD; slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL; @@ -484,6 +486,43 @@ } }; + 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") Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Sat Jun 16 15:02:34 2012 (r13969) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Sun Jun 17 03:54:11 2012 (r13970) @@ -46,8 +46,9 @@ public static final int SLOT_INDEX_METHOD_CLASS = 6; public static final int SLOT_INDEX_METHOD_COMBINATION = 7; public static final int SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER = 8; - public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE = 9; - public static final int SLOT_INDEX_DOCUMENTATION = 10; + public static final int SLOT_INDEX_DECLARATIONS = 9; + public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE = 10; + public static final int SLOT_INDEX_DOCUMENTATION = 11; public StandardGenericFunctionClass() { @@ -65,6 +66,7 @@ pkg.intern("METHOD-CLASS"), pkg.intern("%METHOD-COMBINATION"), pkg.intern("ARGUMENT-PRECEDENCE-ORDER"), + Symbol.DECLARATIONS, pkg.intern("CLASSES-TO-EMF-TABLE"), Symbol._DOCUMENTATION }; Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jun 16 15:02:34 2012 (r13969) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 03:54:11 2012 (r13970) @@ -1412,10 +1412,17 @@ &rest options-and-method-descriptions) (let ((options ()) (methods ()) + (declarations ()) (documentation nil)) (dolist (item options-and-method-descriptions) (case (car item) - (declare) ; FIXME + (declare + (when declarations + (error 'program-error + :format-control "Two declare forms in definition of generic function ~S." + :format-arguments (list function-name))) + (setf declarations t) + (push (list :declarations (cdr item)) options)) (:documentation (when documentation (error 'program-error @@ -1608,6 +1615,7 @@ method-class method-combination argument-precedence-order + declarations documentation) ;; to avoid circularities, we do not call generic functions in here. (declare (ignore generic-function-class)) @@ -1618,6 +1626,7 @@ (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) (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf))) @@ -4030,15 +4039,14 @@ (finalize-standard-generic-function instance)) ;;; Readers for generic function metaobjects -;;; See AMOP pg. 216ff. +;;; 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))) (atomic-defgeneric generic-function-declarations (generic-function) (:method ((generic-function standard-generic-function)) - ;; TODO: add slot to StandardGenericFunctionClass.java, use it - nil)) + (sys:%generic-function-declarations generic-function))) (atomic-defgeneric generic-function-lambda-list (generic-function) (:method ((generic-function standard-generic-function)) @@ -4254,10 +4262,12 @@ method-class method-combination argument-precedence-order + declarations documentation &allow-other-keys) (declare (ignore lambda-list generic-function-class method-class - method-combination argument-precedence-order documentation)) + method-combination argument-precedence-order declarations + documentation)) (apply #'ensure-generic-function-using-class (find-generic-function function-name nil) function-name all-keys)) From rschlatte at common-lisp.net Sun Jun 17 11:26:44 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 17 Jun 2012 04:26:44 -0700 Subject: [armedbear-cvs] r13971 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 17 04:26:43 2012 New Revision: 13971 Log: fix ansi tests SLOT-UNBOUND.5, SLOT-UNBOUND.6 Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 03:54:11 2012 (r13970) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 04:26:43 2012 (r13971) @@ -2017,7 +2017,8 @@ (cdr location) ; :allocation :class (funcallable-standard-instance-access arg location)))) (if (eq value +slot-unbound+) - (slot-unbound class arg slot-name) + ;; fix SLOT-UNBOUND.5 from ansi test suite + (nth-value 0 (slot-unbound class arg slot-name)) value)))))) (t @@ -3127,7 +3128,8 @@ (cdr location) ; :allocation :class (standard-instance-access instance location)))) (if (eq value +slot-unbound+) - (slot-unbound class instance (slot-definition-name slot)) + ;; fix SLOT-UNBOUND.5 from ansi test suite + (nth-value 0 (slot-unbound class instance (slot-definition-name slot))) value))) (defmethod slot-value-using-class ((class funcallable-standard-class) @@ -3140,7 +3142,8 @@ (cdr location) ; :allocation :class (funcallable-standard-instance-access instance location)))) (if (eq value +slot-unbound+) - (slot-unbound class instance (slot-definition-name slot)) + ;; fix SLOT-UNBOUND.5 from ansi test suite + (nth-value 0 (slot-unbound class instance (slot-definition-name slot))) value))) (defmethod slot-value-using-class ((class structure-class) instance From rschlatte at common-lisp.net Sun Jun 17 12:01:53 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 17 Jun 2012 05:01:53 -0700 Subject: [armedbear-cvs] r13972 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 17 05:01:52 2012 New Revision: 13972 Log: Allow multiple declare forms in defgeneric - fixes ansi test defgeneric.26 Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 04:26:43 2012 (r13971) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 05:01:52 2012 (r13972) @@ -1417,12 +1417,7 @@ (dolist (item options-and-method-descriptions) (case (car item) (declare - (when declarations - (error 'program-error - :format-control "Two declare forms in definition of generic function ~S." - :format-arguments (list function-name))) - (setf declarations t) - (push (list :declarations (cdr item)) options)) + (setf declarations (append declarations (cdr item)))) (:documentation (when documentation (error 'program-error @@ -1437,6 +1432,7 @@ 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 From rschlatte at common-lisp.net Sun Jun 17 12:46:30 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 17 Jun 2012 05:46:30 -0700 Subject: [armedbear-cvs] r13973 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 17 05:46:30 2012 New Revision: 13973 Log: Fix check for duplicate initargs - fixes ansi test defclass.error.2, defclass.error.16 Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 05:01:52 2012 (r13972) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 05:46:30 2012 (r13973) @@ -2803,10 +2803,8 @@ (defun check-duplicate-default-initargs (initargs) (let ((names ())) - (do* ((initargs initargs (cddr initargs)) - (name (car initargs) (car initargs))) - ((null initargs)) - (push name names)) + (dolist (initarg initargs) + (push (car initarg) names)) (do* ((names names (cdr names)) (name (car names) (car names))) ((null names)) From rschlatte at common-lisp.net Sun Jun 17 12:55:20 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 17 Jun 2012 05:55:20 -0700 Subject: [armedbear-cvs] r13974 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 17 05:55:18 2012 New Revision: 13974 Log: Fix return value of (setf class-name) - fixes ansi test setf-class-name.2 Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 05:46:30 2012 (r13973) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 05:55:18 2012 (r13974) @@ -2769,8 +2769,8 @@ (redefine-class-forwarder class-name name) ;;; AMOP pg. 230 (redefine-class-forwarder (setf class-name) name - ((standard-class . (reinitialize-instance class :name new-value)) - (funcallable-standard-class . (reinitialize-instance class :name new-value)))) + ((standard-class . (progn (reinitialize-instance class :name new-value) new-value)) + (funcallable-standard-class . (progn (reinitialize-instance class :name new-value) new-value)))) (redefine-class-forwarder class-slots slots) (redefine-class-forwarder (setf class-slots) slots) (redefine-class-forwarder class-direct-slots direct-slots) From rschlatte at common-lisp.net Sun Jun 17 16:35:00 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 17 Jun 2012 09:35:00 -0700 Subject: [armedbear-cvs] r13975 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 17 09:34:58 2012 New Revision: 13975 Log: Ensure argument-precedence-order matches lambda-list in defgeneric - fixes ansi tests defgeneric.error.4, defgeneric.error.8 - also fix newly-introduced error ensure-generic-function.9 Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 05:55:18 2012 (r13974) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 09:34:58 2012 (r13975) @@ -1522,8 +1522,7 @@ (apply 'ensure-generic-function function-name all-keys)) ;;; Bootstrap version of ensure-generic-function, handling only -;;; standard-generic-function. This function will be replaced in -;;; mop.lisp. +;;; standard-generic-function. This function is replaced later. (declaim (notinline ensure-generic-function)) (defun ensure-generic-function (function-name &rest all-keys @@ -1615,6 +1614,7 @@ documentation) ;; to avoid circularities, we do not call generic functions in here. (declare (ignore generic-function-class)) + (check-argument-precedence-order lambda-list argument-precedence-order) (let ((gf (std-allocate-instance +the-standard-generic-function-class+))) (%set-generic-function-name gf name) (%set-generic-function-lambda-list gf lambda-list) @@ -1844,6 +1844,17 @@ all of the keyword arguments defined for the ~ generic function." method-lambda-list name))))) +(defun check-argument-precedence-order (lambda-list argument-precedence-order) + (when argument-precedence-order + (if lambda-list + ;; raising the required program-errors is a side-effect of + ;; calculating the given permutation of apo vs req + (argument-precedence-order-indices + argument-precedence-order + (getf (analyze-lambda-list lambda-list) :required-args)) + ;; AMOP pg. 198 + (error 'program-error "argument precedence order specified without lambda list")))) + (defvar *gf-initialize-instance* nil "Cached value of the INITIALIZE-INSTANCE generic function. Initialized with the true value near the end of the file.") @@ -3676,10 +3687,6 @@ (defmethod compute-effective-slot-definition ((class funcallable-standard-class) name direct-slots) (std-compute-effective-slot-definition class name direct-slots)) -;;; Methods having to do with generic function metaobjects. - -(defmethod initialize-instance :after ((gf standard-generic-function) &key) - (finalize-standard-generic-function gf)) ;;; Methods having to do with generic function invocation. @@ -4023,6 +4030,12 @@ (defmethod class-prototype ((class structure-class)) (allocate-instance class)) +(defmethod shared-initialize :before ((instance generic-function) + slot-names + &key lambda-list argument-precedence-order + &allow-other-keys) + (check-argument-precedence-order lambda-list argument-precedence-order)) + (defmethod shared-initialize :after ((instance standard-generic-function) slot-names &key lambda-list argument-precedence-order @@ -4193,9 +4206,7 @@ &rest all-keys &key (generic-function-class +the-standard-generic-function-class+) lambda-list - argument-precedence-order (method-class +the-standard-method-class+) - documentation &allow-other-keys) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :generic-function-class) @@ -4213,17 +4224,8 @@ (eq method-class (generic-function-method-class generic-function))) (error "The method class ~S is incompatible with the existing methods of ~S." method-class generic-function)) - ;; FIXME (rudi 2012-03-26): should call reinitialize-instance here, as - ;; per AMOP. - (setf (generic-function-lambda-list generic-function) lambda-list) - (setf (generic-function-documentation generic-function) documentation) - (let* ((plist (analyze-lambda-list lambda-list)) - (required-args (getf plist ':required-args))) - (%set-gf-required-args generic-function required-args) - (%set-gf-optional-args generic-function (getf plist :optional-args)) - (setf (generic-function-argument-precedence-order generic-function) - (or argument-precedence-order required-args)) - (finalize-standard-generic-function generic-function)) + (apply #'reinitialize-instance generic-function + :method-class method-class all-keys) generic-function) (defmethod ensure-generic-function-using-class ((generic-function null) From rschlatte at common-lisp.net Sun Jun 17 17:05:21 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 17 Jun 2012 10:05:21 -0700 Subject: [armedbear-cvs] r13976 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 17 10:05:19 2012 New Revision: 13976 Log: Correct default superclass for funcallable-standard-classes Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 09:34:58 2012 (r13975) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 10:05:19 2012 (r13976) @@ -113,6 +113,8 @@ (find-class 'funcallable-standard-class)) (defconstant +the-structure-class+ (find-class 'structure-class)) (defconstant +the-standard-object-class+ (find-class 'standard-object)) +(defconstant +the-funcallable-standard-object-class+ + (find-class 'funcallable-standard-object)) (defconstant +the-standard-method-class+ (find-class 'standard-method)) (defconstant +the-forward-referenced-class+ (find-class 'forward-referenced-class)) @@ -843,8 +845,12 @@ &key direct-superclasses direct-slots direct-default-initargs &allow-other-keys) - (let ((supers (or direct-superclasses - (list +the-standard-object-class+)))) + (let ((supers (cond (direct-superclasses) + ((subtypep (class-of class) + +the-funcallable-standard-class+) + (list +the-funcallable-standard-object-class+)) + ((subtypep (class-of class) +the-standard-class+) + (list +the-standard-object-class+))))) (setf (class-direct-superclasses class) supers) ;; FIXME (rudi 2012-03-22: follow the AMOP spec here when classes ;; are reinitialized: call add-direct-subclass for newly-added From rschlatte at common-lisp.net Sun Jun 17 18:20:32 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 17 Jun 2012 11:20:32 -0700 Subject: [armedbear-cvs] r13977 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 17 11:20:32 2012 New Revision: 13977 Log: Properly call remove-direct-method on class redefinition Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 10:05:19 2012 (r13976) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 11:20:32 2012 (r13977) @@ -852,10 +852,6 @@ ((subtypep (class-of class) +the-standard-class+) (list +the-standard-object-class+))))) (setf (class-direct-superclasses class) supers) - ;; FIXME (rudi 2012-03-22: follow the AMOP spec here when classes - ;; are reinitialized: call add-direct-subclass for newly-added - ;; superclasses, call remove-direct-subclass for removed - ;; superclasses (dolist (superclass supers) (add-direct-subclass superclass class))) (let ((slots (mapcar #'(lambda (slot-properties) @@ -3622,16 +3618,42 @@ &rest args) (apply #'std-after-initialization-for-classes class args)) -(defmethod reinitialize-instance :after ((class standard-class) &rest all-keys) - (remhash class *make-instance-initargs-cache*) - (remhash class *reinitialize-instance-initargs-cache*) - (%make-instances-obsolete class) - (setf (class-finalized-p class) nil) +(defmethod reinitialize-instance :before ((class standard-class) + &key direct-superclasses + &rest all-keys) (check-initargs (list #'allocate-instance #'initialize-instance) (list* class all-keys) class t all-keys nil 'reinitialize-instance) + (dolist (superclass (set-difference (class-direct-superclasses class) + direct-superclasses)) + (remove-direct-subclass superclass class)) + (dolist (superclass (set-difference direct-superclasses + (class-direct-superclasses class))) + (add-direct-subclass superclass class))) + +(defmethod reinitialize-instance :before ((class funcallable-standard-class) + &key direct-superclasses + &rest all-keys) + (check-initargs (list #'allocate-instance + #'initialize-instance) + (list* class all-keys) + class t all-keys + nil 'reinitialize-instance) + (dolist (superclass (set-difference (class-direct-superclasses class) + direct-superclasses)) + (remove-direct-subclass superclass class)) + (dolist (superclass (set-difference direct-superclasses + (class-direct-superclasses class))) + (add-direct-subclass superclass class))) + +(defmethod reinitialize-instance :after ((class standard-class) &rest all-keys) + (remhash class *make-instance-initargs-cache*) + (remhash class *reinitialize-instance-initargs-cache*) + (%make-instances-obsolete class) + (setf (class-finalized-p class) nil) + ;; KLUDGE (rudi 2012-06-17) this calls add-direct-subclass again (apply #'std-after-initialization-for-classes class all-keys) (map-dependents class #'(lambda (dep) (update-dependent class dep all-keys)))) @@ -3641,11 +3663,7 @@ (remhash class *reinitialize-instance-initargs-cache*) (%make-instances-obsolete class) (setf (class-finalized-p class) nil) - (check-initargs (list #'allocate-instance - #'initialize-instance) - (list* class all-keys) - class t all-keys - nil 'reinitialize-instance) + ;; KLUDGE (rudi 2012-06-17) this calls add-direct-subclass again (apply #'std-after-initialization-for-classes class all-keys) (map-dependents class #'(lambda (dep) (update-dependent class dep all-keys)))) From rschlatte at common-lisp.net Mon Jun 18 16:32:50 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 18 Jun 2012 09:32:50 -0700 Subject: [armedbear-cvs] r13978 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jun 18 09:32:48 2012 New Revision: 13978 Log: Don't defer compute-discriminating-function Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 17 11:20:32 2012 (r13977) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jun 18 09:32:48 2012 (r13978) @@ -1574,15 +1574,6 @@ all-keys)) gf)))) -(defun initial-discriminating-function (gf args) - (set-funcallable-instance-function - gf - (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) - #'std-compute-discriminating-function - #'compute-discriminating-function) - gf)) - (apply gf args)) - (defun collect-eql-specializer-objects (generic-function) (let ((result nil)) (dolist (method (generic-function-methods generic-function)) @@ -1600,8 +1591,10 @@ (clrhash (generic-function-classes-to-emf-table gf)) (%init-eql-specializations gf (collect-eql-specializer-objects gf)) (set-funcallable-instance-function - gf #'(lambda (&rest args) - (initial-discriminating-function gf args))) + gf + (if (eq (class-of gf) +the-standard-generic-function-class+) + (std-compute-discriminating-function gf) + (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)) From rschlatte at common-lisp.net Tue Jun 19 13:52:25 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 19 Jun 2012 06:52:25 -0700 Subject: [armedbear-cvs] r13979 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Jun 19 06:52:22 2012 New Revision: 13979 Log: export mop:compute-discriminating-function - amusingly, this fixes 6 failures in the mop-feature-tests suite. Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jun 18 09:32:48 2012 (r13978) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Tue Jun 19 06:52:22 2012 (r13979) @@ -56,6 +56,7 @@ compute-class-precedence-list compute-default-initargs compute-effective-slot-definition + compute-discriminating-function compute-applicable-methods compute-applicable-methods-using-classes compute-effective-method From rschlatte at common-lisp.net Tue Jun 19 15:01:37 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 19 Jun 2012 08:01:37 -0700 Subject: [armedbear-cvs] r13980 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Jun 19 08:01:37 2012 New Revision: 13980 Log: Pass multiply-specified slot option as a list to direct-slot-definition-class. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jun 19 06:52:22 2012 (r13979) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jun 19 08:01:37 2012 (r13980) @@ -331,8 +331,7 @@ (push-on-end (cadr olist) readers) (push-on-end `(setf ,(cadr olist)) writers)) (t - (push-on-end `(quote ,(car olist)) non-std-options) - (push-on-end `(quote ,(cadr olist)) non-std-options)))) + (push-on-end (cadr olist) (getf non-std-options (car olist)))))) `(list :name ',name ,@(when initfunction @@ -352,7 +351,10 @@ ,@(when type `(:type ',type)) ,@(when documentation `(:documentation ',documentation)) , at other-options - , at non-std-options)))) + ,@(mapcar #'(lambda (opt) (if (or (atom opt) (/= 1 (length opt))) + `',opt + `',(car opt))) + non-std-options))))) (defun maybe-note-name-defined (name) (when (fboundp 'note-name-defined) From astalla at common-lisp.net Fri Jun 22 19:58:07 2012 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Fri, 22 Jun 2012 12:58:07 -0700 Subject: [armedbear-cvs] r13981 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jun 22 12:58:02 2012 New Revision: 13981 Log: runtime-class: basic support for calling superclass methods (only with the same signature and only defined in the direct superclass) Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Jun 19 08:01:37 2012 (r13980) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Fri Jun 22 12:58:02 2012 (r13981) @@ -82,15 +82,48 @@ (rest (subseq name 1))) (format nil "~A~A~A" prefix initial rest))) +;;This is missing from compiler-pass2.lisp. Probably this and similar functions should reside +;;in a dedicated file, independent from both runtime-class and compiler-pass2. +(defun emit-invokespecial (class-name method-name arg-types return-type) + (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) + (index (pool-add-method-ref *pool* class-name + method-name (cons return-type arg-types))) + (instruction (apply #'%emit 'invokespecial (u2 index)))) + (declare (type (signed-byte 8) stack-effect)) + (setf (instruction-stack instruction) (1- stack-effect)))) + +(defun java::canonicalize-java-type (type) + (cond + ((stringp type) (make-jvm-class-name type)) + ((keywordp type) type) + (t (error "Unrecognized Java type: ~A" type)))) + +(defun java::emit-unbox-and-return (return-type) + (cond + ((eq return-type :void) + (emit 'pop) + (emit 'return)) + ((eq return-type :int) + (emit-invokevirtual +lisp-object+ "intValue" nil :int) + (emit 'ireturn)) + ((eq return-type :boolean) + (emit-invokevirtual +lisp-object+ "getBooleanValue" nil :boolean) + (emit 'ireturn)) + ((jvm-class-name-p return-type) + (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+) + (emit-checkcast return-type) + (emit 'areturn)) + (t + (error "Unsupported return type: ~A" return-type)))) + (defun java::runtime-class-add-methods (class-file methods) (let (method-implementation-fields) (dolist (m methods) - (destructuring-bind (name return-type argument-types function &key (modifiers '(:public)) annotations) m - (let* ((argument-types (mapcar #'make-jvm-class-name argument-types)) + (destructuring-bind (name return-type argument-types function + &key (modifiers '(:public)) annotations override) m + (let* ((argument-types (mapcar #'java::canonicalize-java-type argument-types)) (argc (length argument-types)) - (return-type (if (keywordp return-type) - return-type - (make-jvm-class-name return-type))) + (return-type (java::canonicalize-java-type return-type)) (jmethod (make-jvm-method name return-type argument-types :flags modifiers)) (field-name (string (gensym name)))) (class-add-method class-file jmethod) @@ -135,22 +168,40 @@ (aload (+ argc 2 i)))) (error "execute(LispObject[]) is currently not supported")) (emit-call-execute (1+ (length argument-types))) - (cond - ((eq return-type :void) - (emit 'pop) - (emit 'return)) - ((eq return-type :int) - (emit-invokevirtual +lisp-object+ "intValue" nil :int) - (emit 'ireturn)) - ((eq return-type :boolean) - (emit-invokevirtual +lisp-object+ "getBooleanValue" nil :boolean) - (emit 'ireturn)) - ((jvm-class-name-p return-type) - (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+) - (emit-checkcast return-type) - (emit 'areturn)) - (t - (error "Unsupported return type: ~A" return-type))))))) + (java::emit-unbox-and-return return-type)) + (cond + ((eq override t) + (let ((super-method + (make-jvm-method (format nil "super$~A" name) + return-type argument-types :flags modifiers))) + (class-add-method class-file super-method) + (with-code-to-method (class-file super-method) + (dotimes (i (1+ (length argument-types))) + (allocate-register nil)) + (aload 0) + (loop + :for arg-type :in argument-types + :for i :from 1 + :do (progn + (cond + ((keywordp arg-type) + (error "Unsupported arg-type: ~A" arg-type)) + ((eq arg-type :int) :todo) + (t (aload i))))) + (emit-invokespecial (class-file-superclass class-file) name + argument-types return-type) + ;(emit 'pop) + (cond + ((eq return-type :void) + (emit 'return)) + ((eq return-type :int) + (emit 'ireturn)) + ((eq return-type :boolean) + (emit 'ireturn)) + ((jvm-class-name-p return-type) + (emit 'areturn)) + (t + (error "Unsupported return type: ~A" return-type)))))))))) method-implementation-fields)) (defun java::runtime-class-add-fields (class-file fields) From ehuelsmann at common-lisp.net Sat Jun 23 21:48:29 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 23 Jun 2012 14:48:29 -0700 Subject: [armedbear-cvs] r13982 - public_html Message-ID: Author: ehuelsmann Date: Sat Jun 23 14:48:28 2012 New Revision: 13982 Log: Try out some reorganized thoughts. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml Fri Jun 22 12:58:02 2012 (r13981) +++ public_html/index.shtml Sat Jun 23 14:48:28 2012 (r13982) @@ -30,29 +30,12 @@ - -
-

Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM

-
- - - @@ -93,6 +76,20 @@
Project description
-

- ABCL is a full implementation of the Common Lisp - language featuring both an interpreter and a compiler, - running in the JVM. Originally started to be a scripting - language for the J editor, it now supports JSR-233 (Java - scripting API): it can be a scripting engine in any Java - application. Additionally, it can be used to implement (parts of) - the application using Java to Lisp integration APIs. -

-
Downloads
+ABCL — Common Lisp on the JVM + + +

+ Armed Bear Common Lisp (ABCL) is a full implementation of the Common Lisp + language featuring both an interpreter and a compiler, + running in the JVM. Originally started to be a scripting + language for the J editor, it now supports JSR-233 (Java + scripting API): it can be a scripting engine in any Java + application. Additionally, it can be used to implement (parts of) + the application using Java to Lisp integration APIs. +

+ + Users (development with ABCL) @@ -128,24 +125,6 @@ -Licensing - - - - -

-ABCL is covered by the -GNU General Public License with Classpath exception, -meaning that you can use ABCL in your application without the -requirement to open the sources to your application. -

- - - - - System requirements (Users) System requirements (Developers) @@ -172,6 +151,25 @@ + + +Licensing + + + + +

+ABCL is covered by the +GNU General Public License with Classpath exception, +meaning that you can use ABCL in your application without the +requirement to open the sources to your application. +

+ + + +
From rschlatte at common-lisp.net Sun Jun 24 11:04:26 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 24 Jun 2012 04:04:26 -0700 Subject: [armedbear-cvs] r13983 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 24 04:04:25 2012 New Revision: 13983 Log: Implement find-method-combination - Store method combination as an object of type 'method-combination. - We use singleton objects if there are no options supplied to the method combination (the majority of cases), otherwise we cons up a fresh method-combination object with the same name that holds the options. Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp trunk/abcl/src/org/armedbear/lisp/print-object.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sat Jun 23 14:48:28 2012 (r13982) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sun Jun 24 04:04:25 2012 (r13983) @@ -774,7 +774,10 @@ constantlyNil), new SlotDefinition(Symbol._DOCUMENTATION, list(Symbol.METHOD_COMBINATION_DOCUMENTATION), - constantlyNil, list(internKeyword("DOCUMENTATION"))))); + constantlyNil, list(internKeyword("DOCUMENTATION"))), + new SlotDefinition(PACKAGE_MOP.intern("OPTIONS"), + NIL, constantlyNil, + list(internKeyword("OPTIONS"))))); SHORT_METHOD_COMBINATION.setCPL(SHORT_METHOD_COMBINATION, METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Jun 23 14:48:28 2012 (r13982) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Jun 24 04:04:25 2012 (r13983) @@ -62,7 +62,7 @@ slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = StandardClass.STANDARD_METHOD; slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] = - Symbol.STANDARD; + Symbol.STANDARD; // fixed up by shared-initialize :after in clos.lisp slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = NIL; @@ -112,7 +112,7 @@ slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = StandardClass.STANDARD_METHOD; slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] = - Symbol.STANDARD; + Symbol.STANDARD; // fixed up by shared-initialize :after in clos.lisp slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = NIL; Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jun 23 14:48:28 2012 (r13982) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 24 04:04:25 2012 (r13983) @@ -184,8 +184,8 @@ (defun fixup-standard-class-hierarchy () ;; Make the result of class-direct-subclasses for the pre-built ;; classes agree with AMOP Table 5.1 (pg. 141). This could be done in - ;; StandardClass.java where these classes are defined, but here it's - ;; less painful + ;; StandardClass.java where these classes are defined, but it's less + ;; painful to do it Lisp-side. (flet ((add-subclasses (class subclasses) (when (atom subclasses) (setf subclasses (list subclasses))) (setf (class-direct-subclasses (find-class class)) @@ -197,6 +197,8 @@ (add-subclasses 'metaobject '(generic-function method method-combination slot-definition specializer)) + (add-subclasses 'method-combination + '(long-method-combination short-method-combination)) (add-subclasses 'funcallable-standard-object 'generic-function) (add-subclasses 'generic-function 'standard-generic-function) (add-subclasses 'method 'standard-method) @@ -911,6 +913,7 @@ (setf (std-slot-value instance 'arguments) arguments) (setf (std-slot-value instance 'declarations) declarations) (setf (std-slot-value instance 'forms) forms) + (setf (std-slot-value instance 'options) nil) instance)) (defun method-combination-name (method-combination) @@ -979,6 +982,7 @@ (setf (std-slot-value instance 'operator) ',operator) (setf (std-slot-value instance 'identity-with-one-argument) ',identity-with-one-arg) + (setf (std-slot-value instance 'options) nil) (setf (get ',name 'method-combination-object) instance) ',name)))) @@ -1001,10 +1005,6 @@ ;;; ;;; long form of define-method-combination (from Sacla and XCL) ;;; -(defun define-method-combination-type (name &rest initargs) - (setf (get name 'method-combination-object) - (apply '%make-long-method-combination initargs))) - (defun method-group-p (selecter qualifiers) ;; selecter::= qualifier-pattern | predicate (etypecase selecter @@ -1284,12 +1284,61 @@ :method-group-specs ,method-group-specs ,@(long-form-method-combination-args args))) (lambda-expression (apply #'method-combination-type-lambda initargs))) - (apply #'define-method-combination-type name - `(, at initargs -;; :function ,(compile nil lambda-expression) - :function ,(coerce-to-function lambda-expression))) + (setf (get name 'method-combination-object) + (apply '%make-long-method-combination + :function (coerce-to-function lambda-expression) initargs)) name)) +(defun std-find-method-combination (gf name options) + (declare (ignore gf)) + (when (and (eql name 'standard) options) + ;; CLHS DEFGENERIC + (error "The standard method combination does not accept any arguments.")) + (let ((mc (get name 'method-combination-object))) + (cond + ((null mc) (error "Method combination ~S not found" name)) + ((null options) mc) + ((typep mc 'short-method-combination) + (make-instance + 'short-method-combination + :name name + :documentation (method-combination-documentation mc) + :operator (short-method-combination-operator mc) + :identity-with-one-argument + (short-method-combination-identity-with-one-argument mc) + :options options)) + ((typep mc 'long-method-combination) + (make-instance + 'long-method-combination + :name name + :documentation (method-combination-documentation mc) + :lambda-list (long-method-combination-lambda-list mc) + :method-group-specs (long-method-combination-method-group-specs mc) + :args-lambda-list (long-method-combination-args-lambda-list mc) + :generic-function-symbol (long-method-combination-generic-function-symbol mc) + :function (long-method-combination-function mc) + :arguments (long-method-combination-arguments mc) + :declarations (long-method-combination-declarations mc) + :forms (long-method-combination-forms mc) + :options options))))) + +(declaim (notinline find-method-combination)) +(defun find-method-combination (gf name options) + (std-find-method-combination gf name options)) + +(defconstant +the-standard-method-combination+ + (let ((instance (std-allocate-instance (find-class 'method-combination)))) + (setf (std-slot-value instance 'sys::name) 'standard) + (setf (std-slot-value instance 'sys:%documentation) + "The standard method combination.") + (setf (std-slot-value instance 'options) nil) + instance) + "The standard method combination. +Do not use this object for identity since it changes between +compile-time and run-time. To detect the standard method combination, +compare the method combination name to the symbol 'standard.") +(setf (get 'standard 'method-combination-object) +the-standard-method-combination+) + (defparameter *eql-specializer-table* (make-hash-table :test 'eql)) (defun intern-eql-specializer (object) @@ -1384,6 +1433,7 @@ (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)) (defun generic-function-argument-precedence-order (gf) @@ -1534,7 +1584,7 @@ lambda-list (generic-function-class +the-standard-generic-function-class+) (method-class +the-standard-method-class+) - (method-combination 'standard) + (method-combination +the-standard-method-combination+ mc-p) argument-precedence-order documentation &allow-other-keys) @@ -1566,6 +1616,8 @@ (error 'program-error :format-control "~A already names an ordinary function, macro, or special operator." :format-arguments (list function-name))) + (when mc-p + (error "Preliminary ensure-method does not support :method-combination argument.")) (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+) #'make-instance-standard-generic-function #'make-instance) @@ -1982,7 +2034,8 @@ method))) (defun fast-callable-p (gf) - (and (eq (generic-function-method-combination gf) 'standard) + (and (eq (method-combination-name (generic-function-method-combination gf)) + 'standard) (null (intersection (%generic-function-lambda-list gf) '(&rest &optional &key &allow-other-keys &aux))))) @@ -2041,7 +2094,7 @@ (cond ((= number-required 1) (cond - ((and (eq (sys:%generic-function-method-combination gf) 'standard) + ((and (eq (method-combination-name (sys:%generic-function-method-combination gf)) 'standard) (= (length (sys:%generic-function-methods gf)) 1)) (let* ((method (%car (sys:%generic-function-methods gf))) (specializer (car (std-method-specializers method))) @@ -2318,23 +2371,24 @@ next-method-form))) next-method-list)) -(defun std-compute-effective-method (gf mc methods) - (let* ((mc-name (if (atom mc) mc (%car mc))) - (options (if (atom mc) '() (%cdr mc))) +(defun std-compute-effective-method (gf method-combination methods) + (assert (typep method-combination 'method-combination)) + (let* ((mc-name (method-combination-name method-combination)) + (options (slot-value method-combination 'options)) (order (car options)) (primaries '()) (arounds '()) around emf-form (long-method-combination-p - (typep (get mc-name 'method-combination-object) 'long-method-combination))) + (typep method-combination 'long-method-combination))) (unless long-method-combination-p (dolist (m methods) (let ((qualifiers (method-qualifiers m))) (cond ((null qualifiers) (if (eq mc-name 'standard) (push m primaries) - (error "Method combination type mismatch."))) + (error "Method combination type mismatch: missing qualifier for method combination ~S." method-combination))) ((cdr qualifiers) (error "Invalid method qualifiers.")) ((eq (car qualifiers) :around) @@ -2357,10 +2411,9 @@ (if (eq (class-of gf) +the-standard-generic-function-class+) #'std-compute-effective-method #'compute-effective-method) - gf (generic-function-method-combination gf) - (remove around methods)))) + gf method-combination (remove around methods)))) (setf emf-form - (generate-emf-lambda (std-method-function around) next-emfun)))) + (generate-emf-lambda (method-function around) next-emfun)))) ((eq mc-name 'standard) (let* ((next-emfun (compute-primary-emfun (cdr primaries))) (befores (remove-if-not #'before-method-p methods)) @@ -2383,41 +2436,36 @@ (generate-emf-lambda (std-method-function (car primaries)) next-emfun)))) (t - (let ((method-function (std-method-function (car primaries)))) + (let ((method-function (method-function (car primaries)))) #'(lambda (args) (declare (optimize speed)) (dolist (before befores) - (funcall (std-method-function before) args nil)) + (funcall (method-function before) args nil)) (multiple-value-prog1 (funcall method-function args next-emfun) (dolist (after reverse-afters) - (funcall (std-method-function after) args nil)))))))))) + (funcall (method-function after) args nil)))))))))) (long-method-combination-p - (let* ((mc-obj (get mc-name 'method-combination-object)) - (function (long-method-combination-function mc-obj)) - (arguments (rest (slot-value gf 'method-combination)))) - (assert (typep mc-obj 'long-method-combination)) + (let ((function (long-method-combination-function method-combination)) + (arguments (slot-value method-combination 'options))) (assert function) (setf emf-form (if arguments (apply function gf methods arguments) (funcall function gf methods))))) (t - (let ((mc-obj (get mc-name 'method-combination-object))) - (unless (typep mc-obj 'short-method-combination) - (error "Unsupported method combination type ~A." - mc-name)) - (let* ((operator (short-method-combination-operator mc-obj)) - (ioa (short-method-combination-identity-with-one-argument mc-obj))) - (setf emf-form - (if (and (null (cdr primaries)) - (not (null ioa))) - (generate-emf-lambda (std-method-function (car primaries)) nil) - `(lambda (args) - (,operator ,@(mapcar - (lambda (primary) - `(funcall ,(std-method-function primary) args nil)) - primaries))))))))) + (unless (typep method-combination 'short-method-combination) + (error "Unsupported method combination type ~A." mc-name)) + (let ((operator (short-method-combination-operator method-combination)) + (ioa (short-method-combination-identity-with-one-argument method-combination))) + (setf emf-form + (if (and ioa (null (cdr primaries))) + (generate-emf-lambda (method-function (car primaries)) nil) + `(lambda (args) + (,operator ,@(mapcar + (lambda (primary) + `(funcall ,(method-function primary) args nil)) + primaries)))))))) (assert (not (null emf-form))) (or #+nil (ignore-errors (autocompile emf-form)) (coerce-to-function emf-form)))) @@ -4065,6 +4113,11 @@ (%set-gf-optional-args instance (getf plist :optional-args)) (set-generic-function-argument-precedence-order instance (or argument-precedence-order required-args))) + (when (eq (generic-function-method-combination instance) 'standard) + ;; fix up "naked" (make-instance 'standard-generic-function) -- gfs + ;; created via defgeneric have that slot initalized properly + (set-generic-function-method-combination instance + +the-standard-method-combination+)) (finalize-standard-generic-function instance)) ;;; Readers for generic function metaobjects @@ -4129,6 +4182,14 @@ (:method ((method standard-accessor-method)) (std-accessor-method-slot-definition method))) + +;;; find-method-combination + +;;; AMOP pg. 191 +(atomic-defgeneric find-method-combination (gf name options) + (:method (gf (name symbol) options) + (std-find-method-combination gf name options))) + ;;; specializer-direct-method and friends. ;;; AMOP pg. 237 @@ -4226,6 +4287,7 @@ &key (generic-function-class +the-standard-generic-function-class+) lambda-list (method-class +the-standard-method-class+) + (method-combination +the-standard-method-combination+) &allow-other-keys) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :generic-function-class) @@ -4243,8 +4305,15 @@ (eq method-class (generic-function-method-class generic-function))) (error "The method class ~S is incompatible with the existing methods of ~S." method-class generic-function)) + (unless (typep method-combination 'method-combination) + (setf method-combination + (find-method-combination generic-function + (car method-combination) + (cdr method-combination)))) (apply #'reinitialize-instance generic-function - :method-class method-class all-keys) + :method-combination method-combination + :method-class method-class + all-keys) generic-function) (defmethod ensure-generic-function-using-class ((generic-function null) @@ -4252,13 +4321,18 @@ &rest all-keys &key (generic-function-class +the-standard-generic-function-class+) (method-class +the-standard-method-class+) - (method-combination 'standard) + (method-combination +the-standard-method-combination+) &allow-other-keys) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :generic-function-class) (unless (classp generic-function-class) (setf generic-function-class (find-class generic-function-class))) (unless (classp method-class) (setf method-class (find-class method-class))) + (unless (typep method-combination 'method-combination) + (setf method-combination + (find-method-combination (class-prototype generic-function-class) + (car method-combination) + (cdr method-combination)))) (when (and (null *clos-booting*) (fboundp function-name)) (if (autoloadp function-name) (fmakunbound function-name) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Jun 23 14:48:28 2012 (r13982) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Sun Jun 24 04:04:25 2012 (r13983) @@ -121,6 +121,8 @@ add-direct-method remove-direct-method + find-method-combination + extract-lambda-list extract-specializer-names Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print-object.lisp Sat Jun 23 14:48:28 2012 (r13982) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Sun Jun 24 04:04:25 2012 (r13983) @@ -74,6 +74,12 @@ (mop:method-specializers method)))) method) +(defmethod print-object ((method-combination method-combination) stream) + (print-unreadable-object (method-combination stream :identity t) + (format stream "~A ~S" (class-name (class-of method-combination)) + (mop::method-combination-name method-combination))) + method-combination) + (defmethod print-object ((restart restart) stream) (if *print-escape* (print-unreadable-object (restart stream :type t :identity t) From rschlatte at common-lisp.net Sun Jun 24 14:57:27 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 24 Jun 2012 07:57:27 -0700 Subject: [armedbear-cvs] r13984 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jun 24 07:57:25 2012 New Revision: 13984 Log: Don't short-circuit slot readers for subclasses of standard-class Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 24 04:04:25 2012 (r13983) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 24 07:57:25 2012 (r13984) @@ -2051,11 +2051,11 @@ ;; 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. - ;; (rudi 2012-01-27): maybe we need to discriminate between - ;; standard-methods and methods as well. (cond ((and (= (length (sys:%generic-function-methods gf)) 1) - (typep (car (sys:%generic-function-methods gf)) 'standard-reader-method)) + (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)))) @@ -2736,7 +2736,8 @@ (autocompile method-function)) :fast-function ,(if (autoloadp 'compile) fast-function - (autocompile fast-function)))) + (autocompile fast-function)) + :slot-definition ,slot-definition)) (method-class (if (eq class +the-standard-class+) +the-standard-writer-method-class+ (apply #'writer-method-class class slot-definition From mevenson at common-lisp.net Wed Jun 27 18:55:54 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 27 Jun 2012 11:55:54 -0700 Subject: [armedbear-cvs] r13985 - trunk/abcl Message-ID: Author: mevenson Date: Wed Jun 27 11:55:53 2012 New Revision: 13985 Log: build: 'abcl.snapshot' will introspect other possible DVCs for more version information. Use case: I use Mercurial to snapshot the SVN trunk in order to manage patch submission. I'd like to create a snapshot target that allows me to more effciently package things with the appropiate metainformation from my patche queues. Only tested on Solaris oi-151a3. TODO: generalize to other people's flavors of build enviroment (git, darcs, etc.) FIXME: Work through MSFT Windows kinks. Added: trunk/abcl/build-snapshot.xml Modified: trunk/abcl/build.xml Added: trunk/abcl/build-snapshot.xml ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/build-snapshot.xml Wed Jun 27 11:55:53 2012 (r13985) @@ -0,0 +1,65 @@ + + + + + + + + + +abcl.version: ${abcl.version} +abcl.version.hg: ${abcl.version.hg} +abcl.src.version: ${abcl.src.version} + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Sun Jun 24 07:57:25 2012 (r13984) +++ trunk/abcl/build.xml Wed Jun 27 11:55:53 2012 (r13985) @@ -960,11 +960,19 @@ - + + From mevenson at common-lisp.net Wed Jun 27 18:58:00 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 27 Jun 2012 11:58:00 -0700 Subject: [armedbear-cvs] r13986 - trunk/abcl Message-ID: Author: mevenson Date: Wed Jun 27 11:58:00 2012 New Revision: 13986 Log: build: prefer ORCL jdk-1.7.0_4 or better. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Wed Jun 27 11:55:53 2012 (r13985) +++ trunk/abcl/build.xml Wed Jun 27 11:58:00 2012 (r13986) @@ -147,8 +147,8 @@ - - + + From mevenson at common-lisp.net Fri Jun 29 18:14:08 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 29 Jun 2012 11:14:08 -0700 Subject: [armedbear-cvs] r13987 - trunk/abcl Message-ID: Author: mevenson Date: Fri Jun 29 11:14:07 2012 New Revision: 13987 Log: build: Fix typos in match for ORCL JDK version. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Wed Jun 27 11:58:00 2012 (r13986) +++ trunk/abcl/build.xml Fri Jun 29 11:14:07 2012 (r13987) @@ -147,8 +147,8 @@ - - + + From mevenson at common-lisp.net Fri Jun 29 18:17:13 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 29 Jun 2012 11:17:13 -0700 Subject: [armedbear-cvs] r13988 - trunk/abcl Message-ID: Author: mevenson Date: Fri Jun 29 11:17:13 2012 New Revision: 13988 Log: build: generalized corrected version of JDK version match. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Fri Jun 29 11:14:07 2012 (r13987) +++ trunk/abcl/build.xml Fri Jun 29 11:17:13 2012 (r13988) @@ -144,11 +144,14 @@ java.version: ${java.version} - + - - - + + + From ehuelsmann at common-lisp.net Sat Jun 30 19:11:15 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 30 Jun 2012 12:11:15 -0700 Subject: [armedbear-cvs] r13989 - public_html Message-ID: Author: ehuelsmann Date: Sat Jun 30 12:11:12 2012 New Revision: 13989 Log: Add tag back in index.shtml. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml Fri Jun 29 11:17:13 2012 (r13988) +++ public_html/index.shtml Sat Jun 30 12:11:12 2012 (r13989) @@ -30,7 +30,7 @@ - +