From rschlatte at common-lisp.net Mon Jul 2 16:33:37 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 02 Jul 2012 09:33:37 -0700 Subject: [armedbear-cvs] r13990 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jul 2 09:33:36 2012 New Revision: 13990 Log: Implement make-method-lambda 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 Sat Jun 30 12:11:12 2012 (r13989) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jul 2 09:33:36 2012 (r13990) @@ -800,15 +800,9 @@ (eq (slot-definition-allocation slot) :instance)) (defun std-allocate-instance (class) - ;; AMOP says ALLOCATE-INSTANCE checks if the class is finalized - ;; and if not, tries to finalize it. - (unless (class-finalized-p class) - (std-finalize-inheritance class)) (sys::%std-allocate-instance class)) (defun allocate-funcallable-instance (class) - (unless (class-finalized-p class) - (std-finalize-inheritance class)) (let ((instance (sys::%allocate-funcallable-instance class))) (set-funcallable-instance-function instance @@ -817,6 +811,11 @@ (error 'program-error "Called a funcallable-instance with unset function."))) instance)) +(declaim (notinline class-prototype)) +(defun class-prototype (class) + (unless (class-finalized-p class) (error "Class ~A not finalized" (class-name class))) + (std-allocate-instance class)) + (defun make-instance-standard-class (metaclass &rest initargs &key name direct-superclasses direct-slots @@ -1388,6 +1387,10 @@ (defun method-generic-function (method) (std-method-generic-function method)) +(declaim (notinline method-function)) +(defun method-function (method) + (std-method-function method)) + (declaim (notinline method-specializers)) (defun method-specializers (method) (std-method-specializers method)) @@ -2602,6 +2605,12 @@ (t nil)))))) +(declaim (notinline make-method-lambda)) +(defun make-method-lambda (generic-function method lambda-expression env) + (declare (ignore generic-function method env)) + (values (compute-method-function lambda-expression) nil)) + + ;; From CLHS section 7.6.5: ;; "When a generic function or any of its methods mentions &key in a lambda ;; list, the specific set of keyword arguments accepted by the generic function @@ -2618,13 +2627,17 @@ `(,@(subseq lambda-list 0 key-end) &allow-other-keys , at aux-part)) lambda-list)) -(defmacro defmethod (&rest args) +(defmacro defmethod (&rest args &environment env) (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body) (parse-defmethod args) (let* ((specializers-form '()) (lambda-expression `(lambda ,lambda-list , at declarations ,body)) - (method-function (compute-method-function lambda-expression)) + (gf (or (find-generic-function function-name nil) + (ensure-generic-function function-name :lambda-list lambda-list))) + (method-function + (make-method-lambda gf (class-prototype (generic-function-method-class gf)) + lambda-expression env)) (fast-function (compute-method-fast-function lambda-expression)) ) (dolist (specializer specializers) @@ -3338,8 +3351,7 @@ ;;; Instance creation and initialization -;;; AMOP pg. 168ff. Checking whether the class is finalized is done -;;; inside std-allocate-instance and allocate-funcallable-instance. +;;; AMOP pg. 168ff. (defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)) (defmethod allocate-instance ((class standard-class) &rest initargs) @@ -3360,6 +3372,11 @@ (declare (ignore initargs)) (error "Cannot allocate instances of a built-in class: ~S" class)) +(defmethod allocate-instance :before ((class class) &rest initargs) + (declare (ignore initargs)) + (unless (class-finalized-p class) + (finalize-inheritance class))) + ;; "The set of valid initialization arguments for a class is the set of valid ;; initialization arguments that either fill slots or supply arguments to ;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS." @@ -3782,6 +3799,15 @@ (defmethod compute-applicable-methods ((gf standard-generic-function) args) (%compute-applicable-methods gf args)) +;;; AMOP pg. 207 +(atomic-defgeneric make-method-lambda (generic-function method lambda-expression environment) + (:method ((generic-function standard-generic-function) + (method standard-method) + lambda-expression environment) + (declare (ignore environment)) + (values (compute-method-function lambda-expression) nil))) + + ;;; Slot definition accessors (defmacro slot-definition-dispatch (slot-definition std-form generic-form) @@ -4083,20 +4109,20 @@ (setf *gf-reinitialize-instance* (symbol-function 'reinitialize-instance)) (setf *clos-booting* nil) -(defgeneric class-prototype (class)) +(atomic-defgeneric class-prototype (class) + (:method ((class standard-class)) + (allocate-instance class)) + (:method ((class funcallable-standard-class)) + (allocate-instance class)) + (:method ((class structure-class)) + (allocate-instance class)) + (:method :before (class) + (unless (class-finalized-p class) + (error "~@<~S is not finalized.~:@>" class)))) -(defmethod class-prototype :before (class) - (unless (class-finalized-p class) - (error "~@<~S is not finalized.~:@>" class))) -(defmethod class-prototype ((class standard-class)) - (allocate-instance class)) -(defmethod class-prototype ((class funcallable-standard-class)) - (allocate-instance class)) -(defmethod class-prototype ((class structure-class)) - (allocate-instance class)) (defmethod shared-initialize :before ((instance generic-function) slot-names Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Jun 30 12:11:12 2012 (r13989) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Jul 2 09:33:36 2012 (r13990) @@ -60,6 +60,7 @@ compute-applicable-methods compute-applicable-methods-using-classes compute-effective-method + make-method-lambda compute-slots finalize-inheritance validate-superclass From rschlatte at common-lisp.net Wed Jul 4 14:13:00 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 04 Jul 2012 07:13:00 -0700 Subject: [armedbear-cvs] r13991 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jul 4 07:12:57 2012 New Revision: 13991 Log: Call compute-applicable-methods 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 Mon Jul 2 09:33:36 2012 (r13990) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jul 4 07:12:57 2012 (r13991) @@ -2199,7 +2199,7 @@ (unless (subclassp (class-of (car args)) specializer) (return nil)))))) -(defun %compute-applicable-methods (gf args) +(defun std-compute-applicable-methods (gf args) (let ((required-classes (mapcar #'class-of (required-portion gf args))) (methods '())) (dolist (method (generic-function-methods gf)) @@ -2207,6 +2207,10 @@ (push method methods))) (sort-methods methods gf required-classes))) +(declaim (notinline compute-applicable-methods)) +(defun compute-applicable-methods (gf args) + (std-compute-applicable-methods gf args)) + ;;; METHOD-APPLICABLE-USING-CLASSES-P ;;; ;;; If the first return value is T, METHOD is definitely applicable to @@ -2272,7 +2276,10 @@ (funcall emfun args))) (defun slow-method-lookup (gf args) - (let ((applicable-methods (%compute-applicable-methods gf args))) + (let ((applicable-methods + (if (eq (class-of gf) +the-standard-generic-function-class+) + (std-compute-applicable-methods gf args) + (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 @@ -2303,7 +2310,10 @@ (apply #'no-applicable-method gf args)))) (defun slow-method-lookup-1 (gf arg arg-specialization) - (let ((applicable-methods (%compute-applicable-methods gf (list arg)))) + (let ((applicable-methods + (if (eq (class-of gf) +the-standard-generic-function-class+) + (std-compute-applicable-methods gf (list arg)) + (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 @@ -3150,9 +3160,9 @@ ;;; Applicable methods -(defgeneric compute-applicable-methods (gf args) +(atomic-defgeneric compute-applicable-methods (gf args) (:method ((gf standard-generic-function) args) - (%compute-applicable-methods gf args))) + (std-compute-applicable-methods gf args))) (defgeneric compute-applicable-methods-using-classes (gf classes) (:method ((gf standard-generic-function) classes) @@ -3387,12 +3397,14 @@ initargs) (let* ((methods (nconc - (compute-applicable-methods #'shared-initialize - (list* instance - shared-initialize-param - initargs)) + (std-compute-applicable-methods #'shared-initialize + (list* instance + shared-initialize-param + initargs)) (mapcan #'(lambda (gf) - (compute-applicable-methods gf args)) + (if (eq (class-of gf) +the-standard-generic-function-class+) + (std-compute-applicable-methods gf args) + (compute-applicable-methods gf args))) gf-list))) (method-keyword-args (reduce #'merge-initargs-sets @@ -3797,7 +3809,7 @@ (defgeneric compute-applicable-methods (gf args)) (defmethod compute-applicable-methods ((gf standard-generic-function) args) - (%compute-applicable-methods gf args)) + (std-compute-applicable-methods gf args)) ;;; AMOP pg. 207 (atomic-defgeneric make-method-lambda (generic-function method lambda-expression environment) From rschlatte at common-lisp.net Wed Jul 4 21:14:01 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 04 Jul 2012 14:14:01 -0700 Subject: [armedbear-cvs] r13992 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jul 4 14:13:59 2012 New Revision: 13992 Log: Call compute-applicable-methods-using-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 Wed Jul 4 07:12:57 2012 (r13991) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jul 4 14:13:59 2012 (r13992) @@ -1621,7 +1621,8 @@ :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+) + (setf gf (apply (if (eq generic-function-class + +the-standard-generic-function-class+) #'make-instance-standard-generic-function #'make-instance) generic-function-class @@ -2222,18 +2223,18 @@ ;;; (defun method-applicable-using-classes-p (method classes) (do* ((specializers (method-specializers method) (cdr specializers)) - (classes classes (cdr classes)) - (knownp t)) + (classes classes (cdr classes)) + (knownp t)) ((null specializers) - (if knownp (values t t) (values nil nil))) + (if knownp (values t t) (values nil nil))) (let ((specializer (car specializers))) (if (typep specializer 'eql-specializer) - (if (eql (class-of (eql-specializer-object specializer)) - (car classes)) - (setf knownp nil) - (return (values nil t))) - (unless (subclassp (car classes) specializer) - (return (values nil t))))))) + (if (eql (class-of (eql-specializer-object specializer)) + (car classes)) + (setf knownp nil) + (return (values nil t))) + (unless (subclassp (car classes) specializer) + (return (values nil t))))))) (defun check-applicable-method-keyword-args (gf args keyword-args @@ -2279,21 +2280,21 @@ (let ((applicable-methods (if (eq (class-of gf) +the-standard-generic-function-class+) (std-compute-applicable-methods gf args) - (compute-applicable-methods gf args)))) + (or (compute-applicable-methods-using-classes gf (mapcar #'class-of args)) + (compute-applicable-methods gf args))))) (if applicable-methods - (let* ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) + (let* ((emfun (funcall (if (eq (class-of gf) + +the-standard-generic-function-class+) #'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)))) + (non-keyword-args (+ (length (gf-required-args gf)) + (length (gf-optional-args gf)))) (gf-lambda-list (generic-function-lambda-list gf)) (checks-required (and (member '&key gf-lambda-list) (not (member '&allow-other-keys - gf-lambda-list))) - ) + gf-lambda-list)))) (applicable-keywords (when checks-required ;; Don't do applicable keyword checks when this is @@ -2313,9 +2314,11 @@ (let ((applicable-methods (if (eq (class-of gf) +the-standard-generic-function-class+) (std-compute-applicable-methods gf (list arg)) - (compute-applicable-methods gf (list arg))))) + (or (compute-applicable-methods-using-classes gf (list (class-of arg))) + (compute-applicable-methods gf (list arg)))))) (if applicable-methods - (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) + (let ((emfun (funcall (if (eq (class-of gf) + +the-standard-generic-function-class+) #'std-compute-effective-method #'compute-effective-method) gf (generic-function-method-combination gf) @@ -3402,7 +3405,8 @@ shared-initialize-param initargs)) (mapcan #'(lambda (gf) - (if (eq (class-of gf) +the-standard-generic-function-class+) + (if (eq (class-of gf) + +the-standard-generic-function-class+) (std-compute-applicable-methods gf args) (compute-applicable-methods gf args))) gf-list))) From rschlatte at common-lisp.net Thu Jul 5 14:38:32 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 05 Jul 2012 07:38:32 -0700 Subject: [armedbear-cvs] r13993 - trunk/abcl/tools Message-ID: Author: rschlatte Date: Thu Jul 5 07:38:30 2012 New Revision: 13993 Log: add micro-benchmarks Added: trunk/abcl/tools/clos-benchmarks.lisp Added: trunk/abcl/tools/clos-benchmarks.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/clos-benchmarks.lisp Thu Jul 5 07:38:30 2012 (r13993) @@ -0,0 +1,44 @@ +;;; Some simple micro-benchmarks for CLOS. +;;; +;;; From: Kiczales and Rodriguez Jr., "Efficient Method Dispatch in PCL" + +(defun fun (x) 0) + +(defclass c1 () + ((x :initform 0 + :accessor accessor1 + :accessor accessor2 + :accessor accessor3))) + +(defclass c2 (c1) + ()) + +(defclass c3 (c1) + ()) + +(defmethod g1 ((f c1)) 0) + +(defmethod g2 ((f c1)) 0) +(defmethod g2 ((b c2)) 0) + +(defvar *outer-times* 3) +(defvar *inner-times* 100000) + +(defmacro test (&body body) + `(let ((i1 (make-instance 'c1)) + (i2 (make-instance 'c2)) + (i3 (make-instance 'c3))) + (dotimes (i *outer-times*) + (time (dotimes (j *inner-times*) + , at body))))) + +(defun fun-test () (test (fun i1))) +(defun accessor1-test () (test (accessor1 i1))) +(defun accessor2-test () (test (accessor2 i2) + (accessor2 i2))) +(defun accessor3-test () (test (accessor3 i1) + (accessor3 i2) + (accessor3 i3))) +(defun g1-test () (test (g1 i1))) +(defun g2-test () (test (g2 i2) + (g2 i2))) From rschlatte at common-lisp.net Thu Jul 5 15:25:55 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 05 Jul 2012 08:25:55 -0700 Subject: [armedbear-cvs] r13994 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu Jul 5 08:25:53 2012 New Revision: 13994 Log: Fix mailbox-send Patch by Uchida Yasuo (armedbear-devel Jul 5, 2012) Modified: trunk/abcl/src/org/armedbear/lisp/threads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/threads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/threads.lisp Thu Jul 5 07:38:30 2012 (r13993) +++ trunk/abcl/src/org/armedbear/lisp/threads.lisp Thu Jul 5 08:25:53 2012 (r13994) @@ -56,7 +56,7 @@ "Sends an item into the mailbox, notifying 1 waiter to wake up for retrieval of that object." (threads:synchronized-on mailbox - (push (mailbox-queue mailbox) item) + (push item (mailbox-queue mailbox)) (threads:object-notify mailbox))) (defun mailbox-empty-p (mailbox) From vvoutilainen at common-lisp.net Thu Jul 5 19:07:01 2012 From: vvoutilainen at common-lisp.net (vvoutilainen at common-lisp.net) Date: Thu, 05 Jul 2012 12:07:01 -0700 Subject: [armedbear-cvs] r13995 - public_html Message-ID: Author: vvoutilainen Date: Thu Jul 5 12:06:57 2012 New Revision: 13995 Log: JSR-223, not JSR-233. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml Thu Jul 5 08:25:53 2012 (r13994) +++ public_html/index.shtml Thu Jul 5 12:06:57 2012 (r13995) @@ -83,7 +83,7 @@ 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 + language for the J editor, it now supports JSR-223 (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. From rschlatte at common-lisp.net Sun Jul 8 10:57:24 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 08 Jul 2012 03:57:24 -0700 Subject: [armedbear-cvs] r13996 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jul 8 03:57:21 2012 New Revision: 13996 Log: Small cleanup of atomic-defgeneric 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 Jul 5 12:06:57 2012 (r13995) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jul 8 03:57:21 2012 (r13996) @@ -2798,16 +2798,17 @@ Note: the user should really use the (:method ..) method description way of defining methods; there's not much use in atomically defining -generic functions without providing sensible behaviour..." +generic functions without providing sensible behaviour." (let ((temp-sym (gensym))) `(progn (defgeneric ,temp-sym , at rest) (let ((gf (symbol-function ',temp-sym))) - (setf ,(if (and (consp function-name) - (eq (car function-name) 'setf)) - `(get ',(second function-name) 'setf-function) - `(symbol-function ',function-name)) gf) + ;; FIXME (rudi 2012-07-08): fset gets the source location info + ;; to charpos 23 always (but (setf fdefinition) leaves the + ;; outdated source position in place, which is even worse). + (fset ',function-name gf) (%set-generic-function-name gf ',function-name) + (fmakunbound ',temp-sym) gf)))) (defmacro redefine-class-forwarder (name slot &optional body-alist) From rschlatte at common-lisp.net Sun Jul 8 15:30:34 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 08 Jul 2012 08:30:34 -0700 Subject: [armedbear-cvs] r13997 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jul 8 08:30:33 2012 New Revision: 13997 Log: Fix fast-function optimization when only standard method function is given. - This was the last error / missing feature exposed by the MOP test suite. 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 Jul 8 03:57:21 2012 (r13996) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jul 8 08:30:33 2012 (r13997) @@ -2099,11 +2099,11 @@ ((= number-required 1) (cond ((and (eq (method-combination-name (sys:%generic-function-method-combination gf)) 'standard) - (= (length (sys:%generic-function-methods gf)) 1)) + (= (length (sys:%generic-function-methods gf)) 1) + (std-method-fast-function (%car (sys:%generic-function-methods gf)))) (let* ((method (%car (sys:%generic-function-methods gf))) (specializer (car (std-method-specializers method))) - (function (or (std-method-fast-function method) - (std-method-function method)))) + (function (std-method-fast-function method))) (if (typep specializer 'eql-specializer) (let ((specializer-object (eql-specializer-object specializer))) #'(lambda (arg) From rschlatte at common-lisp.net Mon Jul 9 09:47:39 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 09 Jul 2012 02:47:39 -0700 Subject: [armedbear-cvs] r13998 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jul 9 02:47:36 2012 New Revision: 13998 Log: Structure classes are finalized by definition, make them say so - fixes a bunch of ansi tests, we're now back to our expected number of failures Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureClass.java Sun Jul 8 08:30:33 2012 (r13997) +++ trunk/abcl/src/org/armedbear/lisp/StructureClass.java Mon Jul 9 02:47:36 2012 (r13998) @@ -120,6 +120,7 @@ c.setCPL(c, BuiltInClass.STRUCTURE_OBJECT, BuiltInClass.CLASS_T); c.setDirectSlotDefinitions(directSlots); c.setSlotDefinitions(slots); + c.setFinalized(true); addClass(symbol, c); return c; } From rschlatte at common-lisp.net Tue Jul 10 20:46:37 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 10 Jul 2012 13:46:37 -0700 Subject: [armedbear-cvs] r13999 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Jul 10 13:46:34 2012 New Revision: 13999 Log: Introduce a "continue" restart for delete-package - Fixes ansi test DELETE-PACKAGE.6 Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java trunk/abcl/src/org/armedbear/lisp/package.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Mon Jul 9 02:47:36 2012 (r13998) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Tue Jul 10 13:46:34 2012 (r13999) @@ -381,7 +381,7 @@ autoload("cos", "MathFunctions"); autoload("cosh", "MathFunctions"); autoload("delete-file", "delete_file"); - autoload("delete-package", "PackageFunctions"); + autoload("%delete-package", "PackageFunctions"); autoload("echo-stream-input-stream", "EchoStream"); autoload("echo-stream-output-stream", "EchoStream"); autoload("exp", "MathFunctions"); Modified: trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Mon Jul 9 02:47:36 2012 (r13998) +++ trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Tue Jul 10 13:46:34 2012 (r13999) @@ -204,9 +204,9 @@ } }; - // ### delete-package - private static final Primitive DELETE_PACKAGE = - new Primitive("delete-package", "package") + // ### %delete-package + private static final Primitive _DELETE_PACKAGE = + new Primitive("%delete-package", PACKAGE_SYS, false) { @Override public LispObject execute(LispObject arg) Modified: trunk/abcl/src/org/armedbear/lisp/package.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/package.lisp Mon Jul 9 02:47:36 2012 (r13998) +++ trunk/abcl/src/org/armedbear/lisp/package.lisp Tue Jul 10 13:46:34 2012 (r13999) @@ -93,3 +93,6 @@ :report "Skip symbol")))) T) +(defun delete-package (package) + (with-simple-restart (continue "Ignore missing package.") + (sys::%delete-package package))) From rschlatte at common-lisp.net Wed Jul 11 10:50:42 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 11 Jul 2012 03:50:42 -0700 Subject: [armedbear-cvs] r14000 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jul 11 03:50:41 2012 New Revision: 14000 Log: Remove to-be-deleted package from packages which use it - fixes ansi test DELETE-PACKAGE.5 Modified: trunk/abcl/src/org/armedbear/lisp/Package.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Tue Jul 10 13:46:34 2012 (r13999) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Wed Jul 11 03:50:41 2012 (r14000) @@ -170,6 +170,12 @@ } } + if (usedByList != null) { + while (!usedByList.isEmpty()) { + usedByList.get(0).unusePackage(this); + } + } + Packages.deletePackage(this); makeSymbolsUninterned(internalSymbols); From rschlatte at common-lisp.net Wed Jul 11 11:04:16 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 11 Jul 2012 04:04:16 -0700 Subject: [armedbear-cvs] r14001 - trunk/abcl Message-ID: Author: rschlatte Date: Wed Jul 11 04:04:16 2012 New Revision: 14001 Log: Set java tab-width to 2 - this will cause Java code to slowly converge towards our preferred indentation style Added: trunk/abcl/.dir-locals.el Added: trunk/abcl/.dir-locals.el ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/.dir-locals.el Wed Jul 11 04:04:16 2012 (r14001) @@ -0,0 +1,6 @@ +;;; Directory Local Variables +;;; See Info node `(emacs) Directory Variables' for more information. + +((java-mode + (c-basic-offset . 2))) + From mevenson at common-lisp.net Thu Jul 12 09:25:41 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 12 Jul 2012 02:25:41 -0700 Subject: [armedbear-cvs] r14002 - in trunk/abcl/src/org/armedbear/lisp: . scripting Message-ID: Author: mevenson Date: Thu Jul 12 02:25:37 2012 New Revision: 14002 Log: dmiles: SYS:*COMPILE-FILE-CLASS-EXTENSION* contains PATHNAME TYPE of compiled JVM artifacts. The default "cls" of compiled JVM artifacts was chosen to easily differentiate bewtween JVM artifacts not produced by ABCL and those which are the JVM bytecode of the ABCL Java 5.0 compiler. During the bootstrapping and subsequent debugging of the current compiler, this distinction has proven more useful than giving ABCL produced artifacts the default "class" CL:PATHNAME TYPE. This change facilitates the bootstrapping of [running ABCL on the MSFT .NET CLR underway by dmiles][abcl-ikvm] [abcl-ikvm]: http://code.google.com/r/logicmoo-abcl-ikvm dmiles: Implementation of ticket #34. dmiles: It makes no change at first but makes implmentation satisfactory to my initial request. Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Wed Jul 11 04:04:16 2012 (r14001) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Thu Jul 12 02:25:37 2012 (r14002) @@ -111,7 +111,7 @@ } public byte[] getFunctionClassBytes(String name) { - Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); + Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + "." + Lisp._COMPILE_FILE_CLASS_EXTENSION_.symbolValue().getStringValue()); return readFunctionBytes(pathname); } Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Jul 11 04:04:16 2012 (r14001) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Thu Jul 12 02:25:37 2012 (r14002) @@ -2482,10 +2482,12 @@ internSpecial("*AUTOLOADING-CACHE*", PACKAGE_SYS, NIL); // ### *compile-file-type* - public static final String COMPILE_FILE_TYPE = "abcl"; public static final Symbol _COMPILE_FILE_TYPE_ = - internConstant("*COMPILE-FILE-TYPE*", PACKAGE_SYS, - new SimpleString(COMPILE_FILE_TYPE)); + exportSpecial("*COMPILE-FILE-TYPE*", PACKAGE_SYS, new SimpleString("abcl")); + + // ### *compile-file-class-extension* + public static final Symbol _COMPILE_FILE_CLASS_EXTENSION_ = + exportSpecial("*COMPILE-FILE-CLASS-EXTENSION*", PACKAGE_SYS, new SimpleString("cls")); // ### *compile-file-zip* public static final Symbol _COMPILE_FILE_ZIP_ = Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Wed Jul 11 04:04:16 2012 (r14001) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Thu Jul 12 02:25:37 2012 (r14002) @@ -73,6 +73,7 @@ return t; } } + final String COMPILE_FILE_TYPE = Lisp._COMPILE_FILE_TYPE_.symbolValue().getStringValue(); if (name.type == NIL && (name.name != NIL || name.name != null)) { Pathname lispPathname = new Pathname(name); @@ -80,7 +81,7 @@ lispPathname.invalidateNamestring(); LispObject lisp = Pathname.truename(lispPathname, false); Pathname abclPathname = new Pathname(name); - abclPathname.type = new SimpleString("abcl"); + abclPathname.type = new SimpleString(COMPILE_FILE_TYPE); abclPathname.invalidateNamestring(); LispObject abcl = Pathname.truename(abclPathname, false); if (lisp instanceof Pathname && abcl instanceof Pathname) { @@ -262,12 +263,13 @@ } URL url = null; truename = findLoadableFile(mergedPathname); + final String COMPILE_FILE_TYPE = Lisp._COMPILE_FILE_TYPE_.symbolValue().getStringValue(); if (truename == null || truename.equals(NIL) || bootPath.equals(NIL)) { // Make an attempt to use the boot classpath String path = pathname.asEntryPath(); - url = Lisp.class.getResource(path); + url = Lisp.class.getResource(path); if (url == null || url.toString().endsWith("/")) { - url = Lisp.class.getResource(path.replace('-', '_') + ".abcl"); + url = Lisp.class.getResource(path.replace('-', '_') + "." + COMPILE_FILE_TYPE); if (url == null) { url = Lisp.class.getResource(path + ".lisp"); } @@ -476,7 +478,7 @@ if (!truename.equals(NIL)) { truePathname = new Pathname(((Pathname)truename).getNamestring()); String type = truePathname.type.getStringValue(); - if (type.equals(COMPILE_FILE_TYPE) + if (type.equals(Lisp._COMPILE_FILE_TYPE_.symbolValue(thread).getStringValue()) || type.equals(COMPILE_FILE_INIT_FASL_TYPE.toString())) { Pathname truenameFasl = new Pathname(truePathname); thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, truenameFasl); Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Jul 11 04:04:16 2012 (r14001) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Thu Jul 12 02:25:37 2012 (r14002) @@ -53,7 +53,7 @@ (let ((name (sanitize-class-name (%format nil "~A_~D" (pathname-name output-file-pathname) n)))) - (namestring (merge-pathnames (make-pathname :name name :type "cls") + (namestring (merge-pathnames (make-pathname :name name :type *compile-file-class-extension*) output-file-pathname)))) (defun sanitize-class-name (name) @@ -616,7 +616,7 @@ (pathnames nil) (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) - :type "cls") + :type *compile-file-class-extension*) output-file)))) (when (probe-file fasl-loader) (push fasl-loader pathnames)) Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Jul 11 04:04:16 2012 (r14001) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Thu Jul 12 02:25:37 2012 (r14002) @@ -86,7 +86,7 @@ (unless output-path (setf output-path *default-pathname-defaults*)) (flet ((do-compile (file) - (let ((out (make-pathname :type "abcl" + (let ((out (make-pathname :type *compile-file-type* :defaults (merge-pathnames file output-path)))) (compile-file-if-needed file :output-file out)))) @@ -273,8 +273,10 @@ "write-sequence.lisp"))) t)) -(defun compile-system (&key quit (zip t) output-path) - (let ((status -1)) +(defun compile-system (&key quit (zip t) (cls-ext *compile-file-class-extension*) (abcl-ext *compile-file-type*) output-path) + (let ((status -1) + (*compile-file-class-extension* cls-ext) + (*compile-file-type* abcl-ext)) (check-lisp-home) (time (with-compilation-unit () Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Wed Jul 11 04:04:16 2012 (r14001) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Thu Jul 12 02:25:37 2012 (r14002) @@ -136,7 +136,8 @@ } public static boolean isCompiled(String filespec) { - if (filespec.endsWith(".abcl")) { + final String compiledExt = "." + Lisp._COMPILE_FILE_TYPE_.symbolValue().getStringValue(); + if (filespec.endsWith(compiledExt)) { return true; } File source; @@ -144,10 +145,10 @@ if (filespec.endsWith(".lisp")) { source = new File(filespec); compiled = new File(filespec.substring(0, filespec.length() - 5) - + ".abcl"); + + compiledExt); } else { source = new File(filespec + ".lisp"); - compiled = new File(filespec + ".abcl"); + compiled = new File(filespec + compiledExt); } if (!source.exists()) { throw new IllegalArgumentException("The source file " + filespec + " cannot be found"); From rschlatte at common-lisp.net Fri Jul 13 14:07:28 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 13 Jul 2012 07:07:28 -0700 Subject: [armedbear-cvs] r14003 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Fri Jul 13 07:07:27 2012 New Revision: 14003 Log: Eliminate once-only-used 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 Thu Jul 12 02:25:37 2012 (r14002) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 07:07:27 2012 (r14003) @@ -870,9 +870,6 @@ (maybe-finalize-class-subtree class) (values)) -(defun canonical-slot-name (canonical-slot) - (getf canonical-slot :name)) - (defvar *extensible-built-in-classes* (list (find-class 'sequence) (find-class 'java:java-object))) @@ -2879,11 +2876,13 @@ ;;; Class definition (defun check-duplicate-slots (slots) - (dolist (s1 slots) - (let ((name1 (canonical-slot-name s1))) - (dolist (s2 (cdr (memq s1 slots))) - (when (eq name1 (canonical-slot-name s2)) - (error 'program-error "Duplicate slot ~S" name1)))))) + (flet ((canonical-slot-name (canonical-slot) + (getf canonical-slot :name))) + (dolist (s1 slots) + (let ((name1 (canonical-slot-name s1))) + (dolist (s2 (cdr (memq s1 slots))) + (when (eq name1 (canonical-slot-name s2)) + (error 'program-error "Duplicate slot ~S" name1))))))) (defun check-duplicate-default-initargs (initargs) (let ((names ())) From rschlatte at common-lisp.net Fri Jul 13 14:07:32 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 13 Jul 2012 07:07:32 -0700 Subject: [armedbear-cvs] r14004 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Fri Jul 13 07:07:31 2012 New Revision: 14004 Log: Move definition of eql-specializer metaclass into Lisp side Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jul 13 07:07:27 2012 (r14003) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jul 13 07:07:31 2012 (r14004) @@ -199,16 +199,18 @@ { LispObject layout = getInstanceSlotValue(symLayout); if (layout == UNBOUND_VALUE) - return null; + return null; if (! (layout instanceof Layout)) { - (new Error()).printStackTrace(); - LispThread.currentThread().printBacktrace(); - return (Layout)Lisp.error(Symbol.TYPE_ERROR, - new SimpleString("The value " + layout.princToString() - + " is not of expected type " + Symbol.LAYOUT.princToString() - + " in class " + this.princToString() + ".")); - } + (new Error()).printStackTrace(); + LispThread.currentThread().printBacktrace(); + System.out.println("Class: " + this.princToString()); + return (Layout)Lisp.error(Symbol.TYPE_ERROR, + new SimpleString("The value " + layout.princToString() + + " is not of expected type " + + Symbol.LAYOUT.princToString() + + " in class " + this.princToString() + ".")); + } return (layout == UNBOUND_VALUE) ? null : (Layout)layout; } @@ -448,8 +450,6 @@ addStandardClass(Symbol.METAOBJECT, list(STANDARD_OBJECT)); public static final StandardClass SPECIALIZER = addStandardClass(Symbol.SPECIALIZER, list(METAOBJECT)); - public static final StandardClass EQL_SPECIALIZER = - addStandardClass(Symbol.EQL_SPECIALIZER, list(SPECIALIZER)); public static final StandardClass SLOT_DEFINITION = addStandardClass(Symbol.SLOT_DEFINITION, list(METAOBJECT)); @@ -731,11 +731,6 @@ list(new SlotDefinition(Symbol.CAUSE, list(Symbol.JAVA_EXCEPTION_CAUSE)))); METAOBJECT.setCPL(METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); SPECIALIZER.setCPL(SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); - EQL_SPECIALIZER.setCPL(EQL_SPECIALIZER, SPECIALIZER, METAOBJECT, - STANDARD_OBJECT, BuiltInClass.CLASS_T); - EQL_SPECIALIZER.setDirectSlotDefinitions( - list(new SlotDefinition(Symbol.OBJECT, NIL, constantlyNil), - new SlotDefinition(symDirectMethods, NIL, constantlyNil))); METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); @@ -912,7 +907,6 @@ SPECIALIZER.finalizeClass(); CLASS.finalizeClass(); BUILT_IN_CLASS.finalizeClass(); - EQL_SPECIALIZER.finalizeClass(); METHOD_COMBINATION.finalizeClass(); SHORT_METHOD_COMBINATION.finalizeClass(); LONG_METHOD_COMBINATION.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 07:07:27 2012 (r14003) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 07:07:31 2012 (r14004) @@ -214,7 +214,6 @@ (add-subclasses 'direct-slot-definition 'standard-direct-slot-definition) (add-subclasses 'effective-slot-definition 'standard-effective-slot-definition) - (add-subclasses 'specializer '(eql-specializer class)) (add-subclasses 'class '(built-in-class forward-referenced-class standard-class funcallable-standard-class)))) @@ -483,26 +482,36 @@ (setf (slot-definition-documentation slot) documentation) slot) +(declaim (notinline direct-slot-definition-class)) +(defun direct-slot-definition-class (class &rest args) + (declare (ignore class args)) + +the-standard-direct-slot-definition-class+) + (defun make-direct-slot-definition (class &rest args) (let ((slot-class (apply #'direct-slot-definition-class class args))) (if (eq slot-class +the-standard-direct-slot-definition-class+) - (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+))) - (apply #'init-slot-definition slot :allocation-class class args) - slot) - (progn - (let ((slot (apply #'make-instance slot-class :allocation-class class - args))) - slot))))) + (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+))) + (apply #'init-slot-definition slot :allocation-class class args) + slot) + (progn + (let ((slot (apply #'make-instance slot-class :allocation-class class + args))) + slot))))) + +(declaim (notinline effective-slot-definition-class)) +(defun effective-slot-definition-class (class &rest args) + (declare (ignore class args)) + +the-standard-effective-slot-definition-class+) (defun make-effective-slot-definition (class &rest args) (let ((slot-class (apply #'effective-slot-definition-class class args))) (if (eq slot-class +the-standard-effective-slot-definition-class+) - (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+))) - (apply #'init-slot-definition slot args) - slot) - (progn - (let ((slot (apply #'make-instance slot-class args))) - slot))))) + (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+))) + (apply #'init-slot-definition slot args) + slot) + (progn + (let ((slot (apply #'make-instance slot-class args))) + slot))))) ;;; finalize-inheritance @@ -529,8 +538,8 @@ #'compute-class-precedence-list) class)) (setf (class-slots class) - (funcall (if (eq (class-of class) +the-standard-class+) - #'std-compute-slots + (funcall (if (eq (class-of class) +the-standard-class+) + #'std-compute-slots #'compute-slots) class)) (let ((old-layout (class-layout class)) (length 0) @@ -688,8 +697,7 @@ :key 'slot-definition-documentation)) (types (delete-duplicates (delete t (mapcar #'slot-definition-type direct-slots)) - :test #'equal)) - ) + :test #'equal))) (make-effective-slot-definition class :name name @@ -711,7 +719,9 @@ :type (cond ((null types) t) ((= 1 (length types)) types) (t (list* 'and types))) - :documentation (documentation documentation-slot t)))) + :documentation (if documentation-slot + (documentation documentation-slot t) + nil)))) ;;; Standard instance slot access @@ -816,6 +826,12 @@ (unless (class-finalized-p class) (error "Class ~A not finalized" (class-name class))) (std-allocate-instance class)) +(defun maybe-finalize-class-subtree (class) + (when (every #'class-finalized-p (class-direct-superclasses class)) + (finalize-inheritance class) + (dolist (subclass (class-direct-subclasses class)) + (maybe-finalize-class-subtree subclass)))) + (defun make-instance-standard-class (metaclass &rest initargs &key name direct-superclasses direct-slots @@ -823,12 +839,15 @@ documentation) (declare (ignore metaclass)) (let ((class (std-allocate-instance +the-standard-class+))) - (check-initargs (list #'allocate-instance #'initialize-instance) - (list* class initargs) - class t initargs - *make-instance-initargs-cache* 'make-instance) + (unless *clos-booting* + (check-initargs (list #'allocate-instance #'initialize-instance) + (list* class initargs) + class t initargs + *make-instance-initargs-cache* 'make-instance)) (%set-class-name name class) - (%set-class-layout nil class) + ;; KLUDGE: necessary in define-primordial-class, otherwise + ;; StandardClass.getClassLayout() throws an error + (unless *clos-booting* (%set-class-layout nil class)) (%set-class-direct-subclasses () class) (%set-class-direct-methods () class) (%set-class-documentation class documentation) @@ -870,6 +889,26 @@ (maybe-finalize-class-subtree class) (values)) +;;; Bootstrap the lower parts of the metaclass hierarchy. + +(defmacro define-primordial-class (name superclasses direct-slots) + "Primitive class definition tool. +No non-standard metaclasses, accessor methods, duplicate slots, +non-existent superclasses, default initargs, or other complicated stuff. +Handle with care." + (let ((class (gensym))) + `(let ((,class (make-instance-standard-class + nil + :name ',name + :direct-superclasses ',(mapcar #'find-class superclasses) + :direct-slots ,(canonicalize-direct-slots direct-slots)))) + (%set-find-class ',name ,class) + ,class))) + +(define-primordial-class eql-specializer (specializer) + ((object :initform nil) + (direct-methods :initform nil))) + (defvar *extensible-built-in-classes* (list (find-class 'sequence) (find-class 'java:java-object))) @@ -1343,13 +1382,13 @@ ;; we will be called during generic function invocation ;; setup, so have to rely on plain functions here. (let ((instance (std-allocate-instance (find-class 'eql-specializer)))) - (setf (std-slot-value instance 'sys::object) object) + (setf (std-slot-value instance 'object) object) (setf (std-slot-value instance 'direct-methods) nil) instance)))) (defun eql-specializer-object (eql-specializer) (check-type eql-specializer eql-specializer) - (std-slot-value eql-specializer 'sys::object)) + (std-slot-value eql-specializer 'object)) ;;; Initial versions of some method metaobject readers. Defined on ;;; AMOP pg. 218ff, will be redefined when generic functions are set up. @@ -2998,12 +3037,6 @@ all-keys) class) -(defun maybe-finalize-class-subtree (class) - (when (every #'class-finalized-p (class-direct-superclasses class)) - (finalize-inheritance class) - (dolist (subclass (class-direct-subclasses class)) - (maybe-finalize-class-subtree subclass)))) - (defmacro defclass (&whole form name direct-superclasses direct-slots &rest options) (unless (>= (length form) 3) (error 'program-error "Wrong number of arguments for DEFCLASS.")) From rschlatte at common-lisp.net Fri Jul 13 14:15:59 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 13 Jul 2012 07:15:59 -0700 Subject: [armedbear-cvs] r14005 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Fri Jul 13 07:15:58 2012 New Revision: 14005 Log: Repair class hierarchy (fixes previous commit) 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 Jul 13 07:07:31 2012 (r14004) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 07:15:58 2012 (r14005) @@ -197,6 +197,7 @@ (add-subclasses 'metaobject '(generic-function method method-combination slot-definition specializer)) + (add-subclasses 'specializer '(class)) (add-subclasses 'method-combination '(long-method-combination short-method-combination)) (add-subclasses 'funcallable-standard-object 'generic-function) From rschlatte at common-lisp.net Fri Jul 13 16:16:59 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 13 Jul 2012 09:16:59 -0700 Subject: [armedbear-cvs] r14006 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Fri Jul 13 09:16:58 2012 New Revision: 14006 Log: Move method-combination metaclass definitions into Lisp - method-combination - long-method-combination - short-method-combination Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jul 13 07:15:58 2012 (r14005) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jul 13 09:16:58 2012 (r14006) @@ -491,15 +491,6 @@ addClass(Symbol.GENERIC_FUNCTION, GENERIC_FUNCTION); } - public static final StandardClass METHOD_COMBINATION = - addStandardClass(Symbol.METHOD_COMBINATION, list(METAOBJECT)); - - public static final StandardClass SHORT_METHOD_COMBINATION = - addStandardClass(Symbol.SHORT_METHOD_COMBINATION, list(METHOD_COMBINATION)); - - public static final StandardClass LONG_METHOD_COMBINATION = - addStandardClass(Symbol.LONG_METHOD_COMBINATION, list(METHOD_COMBINATION)); - public static final StandardClass CLASS = addStandardClass(Symbol.CLASS, list(SPECIALIZER)); @@ -761,47 +752,6 @@ STANDARD_ACCESSOR_METHOD, STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); - METHOD_COMBINATION.setCPL(METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT, - BuiltInClass.CLASS_T); - METHOD_COMBINATION.setDirectSlotDefinitions( - list(new SlotDefinition(Symbol.NAME, - list(Symbol.METHOD_COMBINATION_NAME), - constantlyNil), - new SlotDefinition(Symbol._DOCUMENTATION, - list(Symbol.METHOD_COMBINATION_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); - SHORT_METHOD_COMBINATION.setDirectSlotDefinitions( - list(new SlotDefinition(Symbol.OPERATOR, - list(Symbol.SHORT_METHOD_COMBINATION_OPERATOR)), - new SlotDefinition(Symbol.IDENTITY_WITH_ONE_ARGUMENT, - list(Symbol.SHORT_METHOD_COMBINATION_IDENTITY_WITH_ONE_ARGUMENT)))); - LONG_METHOD_COMBINATION.setCPL(LONG_METHOD_COMBINATION, - METHOD_COMBINATION, METAOBJECT, - STANDARD_OBJECT, BuiltInClass.CLASS_T); - LONG_METHOD_COMBINATION.setDirectSlotDefinitions( - list(new SlotDefinition(Symbol.LAMBDA_LIST, - list(Symbol.LONG_METHOD_COMBINATION_LAMBDA_LIST)), - new SlotDefinition(Symbol.METHOD_GROUP_SPECS, - list(Symbol.LONG_METHOD_COMBINATION_METHOD_GROUP_SPECS)), - new SlotDefinition(Symbol.ARGS_LAMBDA_LIST, - list(Symbol.LONG_METHOD_COMBINATION_ARGS_LAMBDA_LIST)), - new SlotDefinition(Symbol.GENERIC_FUNCTION_SYMBOL, - list(Symbol.LONG_METHOD_COMBINATION_GENERIC_FUNCTION_SYMBOL)), - new SlotDefinition(Symbol.FUNCTION, - list(Symbol.LONG_METHOD_COMBINATION_FUNCTION)), - new SlotDefinition(Symbol.ARGUMENTS, - list(Symbol.LONG_METHOD_COMBINATION_ARGUMENTS)), - new SlotDefinition(Symbol.DECLARATIONS, - list(Symbol.LONG_METHOD_COMBINATION_DECLARATIONS)), - new SlotDefinition(Symbol.FORMS, - list(Symbol.LONG_METHOD_COMBINATION_FORMS)))); - PACKAGE_ERROR.setCPL(PACKAGE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); PACKAGE_ERROR.setDirectSlotDefinitions( @@ -907,9 +857,6 @@ SPECIALIZER.finalizeClass(); CLASS.finalizeClass(); BUILT_IN_CLASS.finalizeClass(); - METHOD_COMBINATION.finalizeClass(); - SHORT_METHOD_COMBINATION.finalizeClass(); - LONG_METHOD_COMBINATION.finalizeClass(); PACKAGE_ERROR.finalizeClass(); PARSE_ERROR.finalizeClass(); PRINT_NOT_READABLE.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Fri Jul 13 07:15:58 2012 (r14005) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Fri Jul 13 09:16:58 2012 (r14006) @@ -66,7 +66,7 @@ pkg.intern("METHOD-CLASS"), pkg.intern("%METHOD-COMBINATION"), pkg.intern("ARGUMENT-PRECEDENCE-ORDER"), - Symbol.DECLARATIONS, + pkg.intern("DECLARATIONS"), pkg.intern("CLASSES-TO-EMF-TABLE"), Symbol._DOCUMENTATION }; Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jul 13 07:15:58 2012 (r14005) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jul 13 09:16:58 2012 (r14006) @@ -2977,10 +2977,6 @@ PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-CLASS"); public static final Symbol GENERIC_FUNCTION_METHODS = PACKAGE_MOP.addExternalSymbol("GENERIC-FUNCTION-METHODS"); - public static final Symbol SHORT_METHOD_COMBINATION = - PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION"); - public static final Symbol LONG_METHOD_COMBINATION = - PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION"); public static final Symbol METAOBJECT = PACKAGE_MOP.addExternalSymbol("METAOBJECT"); public static final Symbol SPECIALIZER = @@ -3006,44 +3002,6 @@ PACKAGE_MOP.addInternalSymbol("METHOD-COMBINATION-NAME"); public static final Symbol METHOD_COMBINATION_DOCUMENTATION = PACKAGE_MOP.addInternalSymbol("METHOD-COMBINATION-DOCUMENTATION"); - public static final Symbol SHORT_METHOD_COMBINATION_OPERATOR = - PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION-OPERATOR"); - public static final Symbol SHORT_METHOD_COMBINATION_IDENTITY_WITH_ONE_ARGUMENT = - PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT"); - public static final Symbol LONG_METHOD_COMBINATION_LAMBDA_LIST = - PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-LAMBDA-LIST"); - public static final Symbol LONG_METHOD_COMBINATION_METHOD_GROUP_SPECS = - PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-METHOD-GROUP-SPECS"); - public static final Symbol LONG_METHOD_COMBINATION_ARGS_LAMBDA_LIST = - PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-ARGS-LAMBDA-LIST"); - public static final Symbol LONG_METHOD_COMBINATION_GENERIC_FUNCTION_SYMBOL = - PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-GENERIC-FUNCTION-SYMBOL"); - public static final Symbol LONG_METHOD_COMBINATION_FUNCTION = - PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-FUNCTION"); - public static final Symbol LONG_METHOD_COMBINATION_ARGUMENTS = - PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-ARGUMENTS"); - public static final Symbol LONG_METHOD_COMBINATION_DECLARATIONS = - PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-DECLARATIONS"); - public static final Symbol LONG_METHOD_COMBINATION_FORMS = - PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-FORMS"); - // slot names of (long-|short-)method-combination classes - public static final Symbol OPERATOR = - PACKAGE_MOP.addInternalSymbol("OPERATOR"); - public static final Symbol IDENTITY_WITH_ONE_ARGUMENT = - PACKAGE_MOP.addInternalSymbol("IDENTITY-WITH-ONE-ARGUMENT"); - public static final Symbol METHOD_GROUP_SPECS = - PACKAGE_MOP.addInternalSymbol("METHOD-GROUP-SPECS"); - public static final Symbol ARGS_LAMBDA_LIST = - PACKAGE_MOP.addInternalSymbol("ARGS-LAMBDA-LIST"); - public static final Symbol GENERIC_FUNCTION_SYMBOL = - PACKAGE_MOP.addInternalSymbol("GENERIC-FUNCTION-SYMBOL"); - public static final Symbol ARGUMENTS = - PACKAGE_MOP.addInternalSymbol("ARGUMENTS"); - public static final Symbol DECLARATIONS = - PACKAGE_MOP.addInternalSymbol("DECLARATIONS"); - public static final Symbol FORMS = - PACKAGE_MOP.addInternalSymbol("FORMS"); - // Java interface. public static final Symbol JAVA_EXCEPTION = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 07:15:58 2012 (r14005) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 09:16:58 2012 (r14006) @@ -195,11 +195,8 @@ (add-subclasses 'function 'funcallable-standard-object) (add-subclasses 'standard-object '(funcallable-standard-object metaobject)) (add-subclasses 'metaobject - '(generic-function method method-combination - slot-definition specializer)) + '(generic-function method slot-definition specializer)) (add-subclasses 'specializer '(class)) - (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) @@ -910,6 +907,25 @@ ((object :initform nil) (direct-methods :initform nil))) +(define-primordial-class method-combination (metaobject) + ((sys::name :initform nil) + (sys::%documentation :initarg :documentation :initform nil) + (options :initarg :options :initform nil))) + +(define-primordial-class short-method-combination (method-combination) + (operator + identity-with-one-argument)) + +(define-primordial-class long-method-combination (method-combination) + (sys::lambda-list + method-group-specs + args-lambda-list + generic-function-symbol + function + arguments + declarations + forms)) + (defvar *extensible-built-in-classes* (list (find-class 'sequence) (find-class 'java:java-object))) From rschlatte at common-lisp.net Fri Jul 13 16:44:21 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 13 Jul 2012 09:44:21 -0700 Subject: [armedbear-cvs] r14007 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Fri Jul 13 09:44:19 2012 New Revision: 14007 Log: Move definition of subclasses of standard-method metaclass to Lisp - standard-accessor-method - standard-reader-method - standard-writer-method - standard-method itself is used Java-side by StandardGenericFunction, so cannot be moved at this time. Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jul 13 09:16:58 2012 (r14006) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jul 13 09:44:19 2012 (r14007) @@ -616,15 +616,6 @@ public static final StandardClass STANDARD_METHOD = addStandardClass(Symbol.STANDARD_METHOD, list(METHOD)); - public static final StandardClass STANDARD_ACCESSOR_METHOD = - addStandardClass(Symbol.STANDARD_ACCESSOR_METHOD, list(STANDARD_METHOD)); - - public static final StandardClass STANDARD_READER_METHOD = - addStandardClass(Symbol.STANDARD_READER_METHOD, list(STANDARD_ACCESSOR_METHOD)); - - public static final StandardClass STANDARD_WRITER_METHOD = - addStandardClass(Symbol.STANDARD_WRITER_METHOD, list(STANDARD_ACCESSOR_METHOD)); - public static final StandardClass STANDARD_GENERIC_FUNCTION = new StandardGenericFunctionClass(); static @@ -738,20 +729,6 @@ new SlotDefinition(Symbol.FAST_FUNCTION, NIL, constantlyNil), new SlotDefinition(Symbol._DOCUMENTATION, NIL, constantlyNil, list(internKeyword("DOCUMENTATION"))))); - STANDARD_ACCESSOR_METHOD.setCPL(STANDARD_ACCESSOR_METHOD, STANDARD_METHOD, - METHOD, METAOBJECT, STANDARD_OBJECT, - BuiltInClass.CLASS_T); - STANDARD_ACCESSOR_METHOD.setDirectSlotDefinitions( - list(new SlotDefinition(Symbol._SLOT_DEFINITION, NIL, constantlyNil, - list(internKeyword("SLOT-DEFINITION"))))); - STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD, - STANDARD_ACCESSOR_METHOD, STANDARD_METHOD, - METHOD, METAOBJECT, STANDARD_OBJECT, - BuiltInClass.CLASS_T); - STANDARD_WRITER_METHOD.setCPL(STANDARD_WRITER_METHOD, - STANDARD_ACCESSOR_METHOD, STANDARD_METHOD, - METHOD, METAOBJECT, STANDARD_OBJECT, - BuiltInClass.CLASS_T); PACKAGE_ERROR.setCPL(PACKAGE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); PACKAGE_ERROR.setDirectSlotDefinitions( @@ -851,9 +828,6 @@ METAOBJECT.finalizeClass(); METHOD.finalizeClass(); STANDARD_METHOD.finalizeClass(); - STANDARD_ACCESSOR_METHOD.finalizeClass(); - STANDARD_READER_METHOD.finalizeClass(); - STANDARD_WRITER_METHOD.finalizeClass(); SPECIALIZER.finalizeClass(); CLASS.finalizeClass(); BUILT_IN_CLASS.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jul 13 09:16:58 2012 (r14006) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jul 13 09:44:19 2012 (r14007) @@ -3150,8 +3150,6 @@ PACKAGE_SYS.addInternalSymbol("PROXY-PRELOADED-FUNCTION"); public static final Symbol QUALIFIERS = PACKAGE_SYS.addInternalSymbol("QUALIFIERS"); - public static final Symbol _SLOT_DEFINITION = - PACKAGE_SYS.addInternalSymbol("%SLOT-DEFINITION"); public static final Symbol _SOURCE = PACKAGE_SYS.addInternalSymbol("%SOURCE"); public static final Symbol SOCKET_STREAM = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 09:16:58 2012 (r14006) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 09:44:19 2012 (r14007) @@ -118,10 +118,6 @@ (defconstant +the-standard-method-class+ (find-class 'standard-method)) (defconstant +the-forward-referenced-class+ (find-class 'forward-referenced-class)) -(defconstant +the-standard-reader-method-class+ - (find-class 'standard-reader-method)) -(defconstant +the-standard-writer-method-class+ - (find-class 'standard-writer-method)) (defconstant +the-standard-generic-function-class+ (find-class 'standard-generic-function)) (defconstant +the-T-class+ (find-class 'T)) @@ -200,9 +196,6 @@ (add-subclasses 'funcallable-standard-object 'generic-function) (add-subclasses 'generic-function 'standard-generic-function) (add-subclasses 'method 'standard-method) - (add-subclasses 'standard-method 'standard-accessor-method) - (add-subclasses 'standard-accessor-method - '(standard-reader-method standard-writer-method)) (add-subclasses 'slot-definition '(direct-slot-definition effective-slot-definition standard-slot-definition)) @@ -926,6 +919,20 @@ declarations forms)) +(define-primordial-class standard-accessor-method (standard-method) + ((sys::%slot-definition :initarg :slot-definition :initform nil))) + +(define-primordial-class standard-reader-method (standard-accessor-method) + ()) +(defconstant +the-standard-reader-method-class+ + (find-class 'standard-reader-method)) + +(define-primordial-class standard-writer-method (standard-accessor-method) + ()) +(defconstant +the-standard-writer-method-class+ + (find-class 'standard-writer-method)) + + (defvar *extensible-built-in-classes* (list (find-class 'sequence) (find-class 'java:java-object))) From rschlatte at common-lisp.net Sun Jul 15 10:38:08 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 15 Jul 2012 03:38:08 -0700 Subject: [armedbear-cvs] r14008 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jul 15 03:38:05 2012 New Revision: 14008 Log: Eliminate Java-side definition of generic functions ... which was used only once in the entire codebase Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.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 Fri Jul 13 09:44:19 2012 (r14007) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Jul 15 03:38:05 2012 (r14008) @@ -70,57 +70,6 @@ slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL; } - public StandardGenericFunction(String name, Package pkg, boolean exported, - Function function, LispObject lambdaList, - LispObject specializers) - { - this(); - Symbol symbol; - if (exported) - symbol = pkg.internAndExport(name.toUpperCase()); - else - symbol = pkg.intern(name.toUpperCase()); - symbol.setSymbolFunction(this); - this.function = function; - slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = symbol; - slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = - lambdaList; - slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = - lambdaList; - slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS] = - NIL; - numberOfRequiredArgs = lambdaList.length(); - slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = - NIL; - StandardObject method - = (StandardObject)StandardClass.STANDARD_METHOD.allocateInstance(); - method.setInstanceSlotValue(Symbol._GENERIC_FUNCTION, this); - method.setInstanceSlotValue(Symbol.LAMBDA_LIST, lambdaList); - method.setInstanceSlotValue(Symbol.KEYWORDS, NIL); - method.setInstanceSlotValue(Symbol.OTHER_KEYWORDS_P, NIL); - method.setInstanceSlotValue(Symbol.SPECIALIZERS, specializers); - method.setInstanceSlotValue(Symbol.QUALIFIERS, NIL); - // Setting the function slot to nil is a transcription of what the - // constructor for StandardMethod instances did (that Java class was - // removed for the implementation of subclassable standard-method). - // (rudi 2012-01-27) - method.setInstanceSlotValue(Symbol._FUNCTION, NIL); - method.setInstanceSlotValue(Symbol.FAST_FUNCTION, function); - method.setInstanceSlotValue(Symbol._DOCUMENTATION, NIL); - slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = - list(method); - slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = - StandardClass.STANDARD_METHOD; - slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] = - 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; - slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = - NIL; - slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL; - } - void finalizeInternal() { cache = null; @@ -803,14 +752,6 @@ } }; - private static final StandardGenericFunction GENERIC_FUNCTION_NAME = - new StandardGenericFunction("generic-function-name", - PACKAGE_MOP, - true, - _GENERIC_FUNCTION_NAME, - list(Symbol.GENERIC_FUNCTION), - list(StandardClass.STANDARD_GENERIC_FUNCTION)); - private static class CacheEntry { final LispObject[] array; Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 13 09:44:19 2012 (r14007) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jul 15 03:38:05 2012 (r14008) @@ -1473,6 +1473,9 @@ ;;; These are defined with % in package SYS, defined as functions here ;;; and redefined as generic functions once we're all set up. +(defun generic-function-name (gf) + (%generic-function-name gf)) + (defun generic-function-lambda-list (gf) (%generic-function-lambda-list gf)) (defsetf generic-function-lambda-list %set-generic-function-lambda-list) From rschlatte at common-lisp.net Mon Jul 16 13:30:39 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 16 Jul 2012 06:30:39 -0700 Subject: [armedbear-cvs] r14009 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jul 16 06:30:26 2012 New Revision: 14009 Log: Don't redefine 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 Sun Jul 15 03:38:05 2012 (r14008) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jul 16 06:30:26 2012 (r14009) @@ -888,11 +888,12 @@ non-existent superclasses, default initargs, or other complicated stuff. Handle with care." (let ((class (gensym))) - `(let ((,class (make-instance-standard-class - nil - :name ',name - :direct-superclasses ',(mapcar #'find-class superclasses) - :direct-slots ,(canonicalize-direct-slots direct-slots)))) + `(let ((,class (or (find-class ',name nil) + (make-instance-standard-class + nil + :name ',name + :direct-superclasses ',(mapcar #'find-class superclasses) + :direct-slots ,(canonicalize-direct-slots direct-slots))))) (%set-find-class ',name ,class) ,class))) From rschlatte at common-lisp.net Mon Jul 16 14:04:08 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 16 Jul 2012 07:04:08 -0700 Subject: [armedbear-cvs] r14010 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jul 16 07:04:07 2012 New Revision: 14010 Log: Revert previous commit. - hacking clos is hard, let's go shopping! 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 Mon Jul 16 06:30:26 2012 (r14009) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jul 16 07:04:07 2012 (r14010) @@ -888,12 +888,11 @@ non-existent superclasses, default initargs, or other complicated stuff. Handle with care." (let ((class (gensym))) - `(let ((,class (or (find-class ',name nil) - (make-instance-standard-class - nil - :name ',name - :direct-superclasses ',(mapcar #'find-class superclasses) - :direct-slots ,(canonicalize-direct-slots direct-slots))))) + `(let ((,class (make-instance-standard-class + nil + :name ',name + :direct-superclasses ',(mapcar #'find-class superclasses) + :direct-slots ,(canonicalize-direct-slots direct-slots)))) (%set-find-class ',name ,class) ,class))) From rschlatte at common-lisp.net Tue Jul 17 07:59:28 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 17 Jul 2012 00:59:28 -0700 Subject: [armedbear-cvs] r14011 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Jul 17 00:59:27 2012 New Revision: 14011 Log: Robustify print-object of uninitialized class objects - avoid recursive errors when invoking debugger because of validate-superclass failures - Reproducible on the REPL via (class-prototype (find-class 'standard-class)) Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print-object.lisp Mon Jul 16 07:04:07 2012 (r14010) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Tue Jul 17 00:59:27 2012 (r14011) @@ -50,7 +50,9 @@ (defmethod print-object ((class class) stream) (print-unreadable-object (class stream :identity t) - (format stream "~S ~S" (class-name (class-of class)) (class-name class))) + ;; Avoid recursive errors for uninitialized class objects, e.g. when + ;; validate-superclass fails + (format stream "~S ~S" (class-name (class-of class)) (ignore-errors (class-name class)))) class) (defmethod print-object ((gf generic-function) stream) From rschlatte at common-lisp.net Thu Jul 19 19:41:42 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 19 Jul 2012 12:41:42 -0700 Subject: [armedbear-cvs] r14012 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu Jul 19 12:41:41 2012 New Revision: 14012 Log: Enable usage of method combinations with options - e.g., (defgeneric foo (x) (:method-combination and :most-specific-last)) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/print-object.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jul 17 00:59:27 2012 (r14011) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Jul 19 12:41:41 2012 (r14012) @@ -901,23 +901,23 @@ (direct-methods :initform nil))) (define-primordial-class method-combination (metaobject) - ((sys::name :initform nil) + ((sys::name :initarg :name :initform nil) (sys::%documentation :initarg :documentation :initform nil) (options :initarg :options :initform nil))) (define-primordial-class short-method-combination (method-combination) - (operator - identity-with-one-argument)) + ((operator :initarg :operator) + (identity-with-one-argument :initarg :identity-with-one-argument))) (define-primordial-class long-method-combination (method-combination) - (sys::lambda-list - method-group-specs - args-lambda-list - generic-function-symbol - function - arguments - declarations - forms)) + ((sys::lambda-list :initarg :lambda-list) + (method-group-specs :initarg :method-group-specs) + (args-lambda-list :initarg :args-lambda-list) + (generic-function-symbol :initarg :generic-function-symbol) + (function :initarg :function) + (arguments :initarg :arguments) + (declarations :initarg :declarations) + (forms :initarg :forms))) (define-primordial-class standard-accessor-method (standard-method) ((sys::%slot-definition :initarg :slot-definition :initform nil))) @@ -1033,7 +1033,6 @@ (operator (getf (cddr whole) :operator name))) `(progn - ;; Class short-method-combination is defined in StandardClass.java. (let ((instance (std-allocate-instance (find-class 'short-method-combination)))) (setf (std-slot-value instance 'sys::name) ',name) Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print-object.lisp Tue Jul 17 00:59:27 2012 (r14011) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Thu Jul 19 12:41:41 2012 (r14012) @@ -79,7 +79,7 @@ (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))) + (ignore-errors (mop::method-combination-name method-combination)))) method-combination) (defmethod print-object ((restart restart) stream) From mevenson at common-lisp.net Fri Jul 20 12:54:35 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 20 Jul 2012 05:54:35 -0700 Subject: [armedbear-cvs] r14013 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jul 20 05:54:34 2012 New Revision: 14013 Log: Commit asdf-2.23 to trunk. 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 Thu Jul 19 12:41:41 2012 (r14012) +++ trunk/abcl/doc/asdf/asdf.texinfo Fri Jul 20 05:54:34 2012 (r14013) @@ -2879,14 +2879,22 @@ if no value is specified in any transitive parent. The argument must be a either @code{nil}, a fbound symbol, -a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk) ...)}) +a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk ...) ...)}) a function object (e.g. using @code{#.#'} but that's discouraged because it prevents the introspection done by e.g. asdf-dependency-grovel), or a string that when read yields a symbol or a lambda-expression. @code{nil} means the normal compile-file function will be called. A non-nil value designates a function of one argument -that will be called with a thunk for calling -the compile-file function with proper arguments. +that will be called with a function that +calls the @code{*compile-op-compile-file-function*} (usually @code{compile-file*}) +with proper arguments; +the around-compile hook may supply additional arguments +to pass to that @code{*compile-op-compile-file-function*}. +One notable argument that is heeded by @code{compile-file*} is + at code{:compile-check}, a function called when the compilation was otherwise a success, +with the same arguments as @code{compile-file}, +to determine whether +(NB: The ability to pass such extra flags is only available starting with asdf 2.22.1.) Note that by using a string, you may reference a function, symbol and/or package Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Thu Jul 19 12:41:41 2012 (r14012) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Fri Jul 20 05:54:34 2012 (r14013) @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.22: Another System Definition Facility. +;;; This is ASDF 2.23: 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.22") + (asdf-version "2.23") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -371,7 +371,8 @@ #:coerce-name #:directory-pathname-p #:ensure-directory-pathname #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root - #:getenv + #:getenv #:getenv-pathname #:getenv-pathname + #:getenv-absolute-directory #:getenv-absolute-directories #:probe-file* #:find-symbol* #:strcat #:make-pathname-component-logical #:make-pathname-logical @@ -2464,11 +2465,11 @@ (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) (call-with-around-compile-hook - c #'(lambda () + c #'(lambda (&rest flags) (apply *compile-op-compile-file-function* source-file :output-file output-file :external-format (component-external-format c) - (compile-op-flags operation)))) + (append flags (compile-op-flags operation))))) (unless output (error 'compile-error :component c :operation operation)) (when failure-p @@ -3290,37 +3291,44 @@ #+mcl (current-user-homedir-pathname) #-mcl (user-homedir-pathname)))) -(defun* ensure-absolute-pathname* (x fmt &rest args) - (and (plusp (length x)) - (or (absolute-pathname-p x) - (cerror "ignore relative pathname" - "Invalid relative pathname ~A~@[ ~?~]" x fmt args)) - x)) -(defun* split-absolute-pathnames (x fmt &rest args) +(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args) + (when (plusp (length x)) + (let ((p (if want-directory (ensure-directory-pathname x) (pathname x)))) + (when want-absolute + (unless (absolute-pathname-p p) + (cerror "ignore relative pathname" + "Invalid relative pathname ~A~@[ ~?~]" x fmt args) + (return-from ensure-pathname* nil))) + p))) +(defun* split-pathnames* (x want-absolute want-directory fmt &rest args) (loop :for dir :in (split-string x :separator (string (inter-directory-separator))) - :do (apply 'ensure-absolute-pathname* dir fmt args) - :collect dir)) -(defun getenv-absolute-pathname (x &aux (s (getenv x))) - (ensure-absolute-pathname* s "from (getenv ~S)" x)) -(defun getenv-absolute-pathnames (x &aux (s (getenv x))) + :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args))) +(defun getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x))) + (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x)) +(defun getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x))) (and (plusp (length s)) - (split-absolute-pathnames s "from (getenv ~S) = ~S" x s))) + (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s))) +(defun getenv-absolute-directory (x) + (getenv-pathname x :want-absolute t :want-directory t)) +(defun getenv-absolute-directories (x) + (getenv-pathnames x :want-absolute t :want-directory t)) + (defun* user-configuration-directories () (let ((dirs `(,@(when (os-unix-p) (cons - (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/") - (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS") + (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/") + (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS") :collect (subpathname* dir "common-lisp/")))) ,@(when (os-windows-p) `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv-absolute-pathname "LOCALAPPDATA")) + (getenv-absolute-directory "LOCALAPPDATA")) "common-lisp/config/") ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) - (getenv-absolute-pathname "APPDATA")) + (getenv-absolute-directory "APPDATA")) "common-lisp/config/"))) ,(subpathname (user-homedir) ".config/common-lisp/")))) (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) @@ -3333,8 +3341,8 @@ (aif ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) - (getenv-absolute-pathname "ALLUSERSAPPDATA") - (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")) + (getenv-absolute-directory "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")) "common-lisp/config/") (list it))))) @@ -3458,12 +3466,12 @@ (defvar *user-cache* (flet ((try (x &rest sub) (and x `(,x , at sub)))) (or - (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation) + (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation) (when (os-windows-p) (try (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv-absolute-pathname "LOCALAPPDATA") + (getenv-absolute-directory "LOCALAPPDATA") #+lispworks (sys:get-folder-path :appdata) - (getenv-absolute-pathname "APPDATA")) + (getenv-absolute-directory "APPDATA")) "common-lisp" "cache" :implementation)) '(:home ".cache" "common-lisp" :implementation)))) @@ -3687,8 +3695,8 @@ `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. - #+sbcl ,(let ((h (getenv "SBCL_HOME"))) - (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ()))) + #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t))) + (when h `((,(truenamize h) ,*wild-inferiors*) ()))) ;; The below two are not needed: no precompiled ASDF system there #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) @@ -3882,12 +3890,13 @@ (when (and x (probe-file* x)) (delete-file x))) -(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) - (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys)) +(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys) + (let* ((keywords (remove-keyword :compile-check keys)) + (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords)) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) - (apply 'compile-file input-file :output-file tmp-file keys) + (apply 'compile-file input-file :output-file tmp-file keywords) (cond (failure-p (setf status *compile-file-failure-behaviour*)) @@ -3895,15 +3904,19 @@ (setf status *compile-file-warnings-behaviour*)) (t (setf status :success))) - (ecase status - ((:success :warn :ignore) + (cond + ((and (ecase status + ((:success :warn :ignore) t) + ((:error nil))) + (or (not compile-check) + (apply compile-check input-file :output-file tmp-file keywords))) (delete-file-if-exists output-file) (when output-truename (rename-file output-truename output-file) (setf output-truename output-file))) - (:error + (t ;; error or failed check (delete-file-if-exists output-truename) - (setf output-truename nil))) + (setf output-truename nil failure-p t))) (values output-truename warnings-p failure-p)))) #+abcl @@ -4179,7 +4192,7 @@ (defun* wrapping-source-registry () `(:source-registry - #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME"))) + #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t))) :inherit-configuration #+cmu (:tree #p"modules:") #+scl (:tree #p"file://modules/"))) @@ -4189,18 +4202,18 @@ (:directory ,(default-directory)) ,@(loop :for dir :in `(,@(when (os-unix-p) - `(,(or (getenv-absolute-pathname "XDG_DATA_HOME") + `(,(or (getenv-absolute-directory "XDG_DATA_HOME") (subpathname (user-homedir) ".local/share/")) - ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS") + ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") '("/usr/local/share" "/usr/share")))) ,@(when (os-windows-p) `(,(or #+lispworks (sys:get-folder-path :local-appdata) - (getenv-absolute-pathname "LOCALAPPDATA")) + (getenv-absolute-directory "LOCALAPPDATA")) ,(or #+lispworks (sys:get-folder-path :appdata) - (getenv-absolute-pathname "APPDATA")) + (getenv-absolute-directory "APPDATA")) ,(or #+lispworks (sys:get-folder-path :common-appdata) - (getenv-absolute-pathname "ALLUSERSAPPDATA") - (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))))) + (getenv-absolute-directory "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))) :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) :inherit-configuration)) From rschlatte at common-lisp.net Sat Jul 21 14:02:35 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 21 Jul 2012 07:02:35 -0700 Subject: [armedbear-cvs] r14014 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jul 21 07:02:32 2012 New Revision: 14014 Log: fixes for (documentation x 'type) and (documentation x 'structure) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jul 20 05:54:34 2012 (r14013) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jul 21 07:02:32 2012 (r14014) @@ -3176,16 +3176,16 @@ (%set-class-documentation x new-value)) (defmethod documentation ((x structure-class) (doc-type (eql 't))) - (%documentation x doc-type)) + (%documentation x t)) (defmethod documentation ((x structure-class) (doc-type (eql 'type))) - (%documentation x doc-type)) + (%documentation x t)) (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't))) - (%set-documentation x doc-type new-value)) + (%set-documentation x t new-value)) (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type))) - (%set-documentation x doc-type new-value)) + (%set-documentation x t new-value)) (defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) (generic-function-documentation x)) @@ -3218,7 +3218,26 @@ (%set-documentation x doc-type new-value)) (defmethod documentation ((x symbol) (doc-type (eql 'function))) - (%documentation x doc-type)) + (%documentation x 'function)) + +(defmethod documentation ((x symbol) (doc-type (eql 'type))) + (let ((class (find-class x nil))) + (if class + (documentation class t) + (%documentation x 'type)))) + +(defmethod documentation ((x symbol) (doc-type (eql 'structure))) + (%documentation x 'structure)) + +(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) + (let ((class (find-class x nil))) + (if class + (setf (documentation class t) new-value) + (%set-documentation x 'type new-value)))) + +(defmethod (setf documentation) (new-value (x symbol) + (doc-type (eql 'structure))) + (%set-documentation x 'structure new-value)) ;;; Applicable methods Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Fri Jul 20 05:54:34 2012 (r14013) +++ trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Sat Jul 21 07:02:32 2012 (r14014) @@ -125,6 +125,7 @@ (defvar *dd-direct-slots*) (defvar *dd-slots*) (defvar *dd-inherited-accessors*) +(defvar *dd-documentation*) (defun keywordify (symbol) (intern (symbol-name symbol) +keyword-package+)) @@ -514,7 +515,8 @@ print-object direct-slots slots - inherited-accessors) + inherited-accessors + documentation) (setf (get name 'structure-definition) (make-defstruct-description :name name :conc-name conc-name @@ -531,8 +533,12 @@ :direct-slots direct-slots :slots slots :inherited-accessors inherited-accessors)) + (%set-documentation name 'structure documentation) (when (or (null type) named) - (make-structure-class name direct-slots slots (car include))) + (let ((structure-class + (make-structure-class name direct-slots slots (car include)))) + (%set-documentation name 'type documentation) + (%set-documentation structure-class t documentation))) (when default-constructor (proclaim `(ftype (function * t) ,default-constructor)))) @@ -552,7 +558,8 @@ (*dd-print-object* nil) (*dd-direct-slots* ()) (*dd-slots* ()) - (*dd-inherited-accessors* ())) + (*dd-inherited-accessors* ()) + (*dd-documentation* nil)) (parse-name-and-options (if (atom name-and-options) (list name-and-options) name-and-options)) @@ -564,7 +571,7 @@ (return))) (setf *dd-default-constructor* (default-constructor-name))) (when (stringp (car slots)) - (%set-documentation *dd-name* 'structure (pop slots))) + (setf *dd-documentation* (pop slots))) (dolist (slot slots) (let* ((name (if (atom slot) slot (car slot))) (reader (if *dd-conc-name* @@ -656,7 +663,8 @@ ,@(if *dd-print-object* `(:print-object ',*dd-print-object*)) :direct-slots ',*dd-direct-slots* :slots ',*dd-slots* - :inherited-accessors ',*dd-inherited-accessors*)) + :inherited-accessors ',*dd-inherited-accessors* + :documentation ',*dd-documentation*)) ,@(define-constructors) ,@(define-predicate) ,@(define-access-functions) From mevenson at common-lisp.net Mon Jul 23 11:58:36 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 23 Jul 2012 04:58:36 -0700 Subject: [armedbear-cvs] r14015 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Jul 23 04:58:34 2012 New Revision: 14015 Log: dmiles: classloaders to search their parent/system classloaders first. Robustifies strategies for loading in non-JVM environments (iKVM/GCJ) when using the "class" PATHNAME TYPE for bytecode artifacts. Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Sat Jul 21 07:02:32 2012 (r14014) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Mon Jul 23 04:58:34 2012 (r14015) @@ -59,9 +59,16 @@ * which - in ABCL - is pretty deep, most of the time. */ if (name.startsWith(baseName + "_")) { - String internalName = "org/armedbear/lisp/" + name; + String internalName = name.replace(".", "/"); + if (!internalName.contains("/")) internalName = "org/armedbear/lisp/" + internalName; Class c = this.findLoadedClass(internalName); + if (c == null && checkPreCompiledClassLoader) { + c = findPrecompiledClassOrNull(name); + // Oh, we have to return here so we don't become the owning class loader? + if (c != null) + return c; + } if (c == null) { c = findClass(name); } @@ -80,8 +87,13 @@ @Override protected Class findClass(String name) throws ClassNotFoundException { try { + if (checkPreCompiledClassLoader) { + Class c = findPrecompiledClassOrNull(name); + if (c != null) + return c; + } byte[] b = getFunctionClassBytes(name); - return defineClass(name, b, 0, b.length); + return defineLispClass(name, b, 0, b.length); } catch(Throwable e) { //TODO handle this better, readFunctionBytes uses Debug.assert() but should return null e.printStackTrace(); if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } @@ -110,27 +122,16 @@ return null; } - public byte[] getFunctionClassBytes(String name) { - Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + "." + Lisp._COMPILE_FILE_CLASS_EXTENSION_.symbolValue().getStringValue()); - return readFunctionBytes(pathname); - } - - public byte[] getFunctionClassBytes(Class functionClass) { - return getFunctionClassBytes(functionClass.getName()); - } - - public byte[] getFunctionClassBytes(Function f) { - byte[] b = getFunctionClassBytes(f.getClass()); - f.setClassBytes(b); - return b; - } - public LispObject loadFunction(int fnNumber) { //Function name is fnIndex + 1 String name = baseName + "_" + (fnNumber + 1); try { - Function f = (Function) loadClass(name).newInstance(); - f.setClassBytes(getFunctionClassBytes(name)); + Class clz = loadClass(name); + Function f = (Function) clz.newInstance(); + if (clz.getClassLoader() instanceof JavaClassLoader) { + // Don't do this for system classes (though probably dont need this for other classes) + f.setClassBytes(getFunctionClassBytes(name)); + } return f; } catch(Throwable e) { if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java Sat Jul 21 07:02:32 2012 (r14014) +++ trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java Mon Jul 23 04:58:34 2012 (r14015) @@ -38,6 +38,9 @@ import java.util.Collections; import java.util.HashSet; import java.util.Set; +import java.io.DataInputStream; +import java.io.IOException; +import java.io.InputStream; import java.net.URL; import java.net.URLClassLoader; @@ -45,6 +48,71 @@ private static JavaClassLoader persistentInstance; + public static boolean checkPreCompiledClassLoader = true; + + public Class loadClass(String name) throws ClassNotFoundException { + if (checkPreCompiledClassLoader) { + Class c = findPrecompiledClassOrNull(name); + if (c != null) { + return c; + } + } + return loadClass(name, false); + } + + /** + * Returns a class loaded by the system or bootstrap class loader; + * or return null if not found. + * + * On AOT systems like GCJ and IKVM this means a class implemented in ASM or CLR + * + * like findLoadedClass it does not throw an exception if a class is not found + */ + public Class findPrecompiledClassOrNull(String name) { + ClassLoader ourCL = JavaClassLoader.class.getClassLoader(); + while (ourCL != null) { + try { + return Class.forName(name, true, ourCL); + } catch (ClassNotFoundException cnf) { + } + ourCL = ourCL.getParent(); + } + try { + return findSystemClass(name); + } catch (ClassNotFoundException e) { + return null; + } + } + + public byte[] getFunctionClassBytes(String name) { + Pathname pathname + = new Pathname(name.substring("org/armedbear/lisp/".length()) + + "." + Lisp._COMPILE_FILE_CLASS_EXTENSION_.symbolValue().getStringValue()); + return readFunctionBytes(pathname); + } + + public byte[] getFunctionClassBytes(Class functionClass) { + String className = functionClass.getName(); + try { + String ext = Lisp._COMPILE_FILE_CLASS_EXTENSION_.symbolValue().getStringValue(); + InputStream is = getResourceAsStream(className.replace('.', '/') + "." + ext); + if (is != null) { + byte[] imgDataBa = new byte[(int) is.available()]; + DataInputStream dataIs = new DataInputStream(is); + dataIs.readFully(imgDataBa); + return imgDataBa; + } + } catch (IOException e) { + } + return getFunctionClassBytes(className); + } + + final public byte[] getFunctionClassBytes(Function f) { + byte[] b = getFunctionClassBytes(f.getClass()); + f.setClassBytes(b); + return b; + } + private static Set packages = Collections.synchronizedSet(new HashSet()); public JavaClassLoader() @@ -53,11 +121,11 @@ } public JavaClassLoader(ClassLoader parent) { - super(new URL[] {}, parent); + super(new URL[] {}, parent); } public JavaClassLoader(URL[] classpath, ClassLoader parent) { - super(classpath, parent); + super(classpath, parent); } public static JavaClassLoader getPersistentInstance() @@ -69,7 +137,7 @@ { if (persistentInstance == null) persistentInstance = new JavaClassLoader(); - definePackage(packageName); + definePackage(packageName); return persistentInstance; } @@ -89,30 +157,36 @@ byte[] classbytes) { try { - long length = classbytes.length; + long length = classbytes.length; if (length < Integer.MAX_VALUE) { Class c = - defineClass(className, classbytes, 0, (int) length); + defineLispClass(className, classbytes, 0, (int) length); if (c != null) { resolveClass(c); return c; } } } - catch (LinkageError e) { + catch (LinkageError e) { throw e; - } + } catch (Throwable t) { Debug.trace(t); } return null; } + protected final Class defineLispClass(String name, byte[] b, int off, int len) + throws ClassFormatError { + ///if (checkPreCompiledClassLoader) Debug.trace("DEFINE JAVA CLASS " + name + " " + len); + return defineClass(name, b, off, len); + } + public Class loadClassFromByteArray(String className, byte[] bytes, int offset, int length) { try { - Class c = defineClass(className, bytes, offset, length); + Class c = defineLispClass(className, bytes, offset, length); if (c != null) { resolveClass(c); return c; @@ -130,15 +204,15 @@ @Override public void addURL(URL url) { - super.addURL(url); + super.addURL(url); } public static final Symbol CLASSLOADER = PACKAGE_JAVA.intern("*CLASSLOADER*"); private static final Primitive GET_DEFAULT_CLASSLOADER = new pf_get_default_classloader(); private static final class pf_get_default_classloader extends Primitive { - - private final LispObject defaultClassLoader = new JavaObject(new JavaClassLoader()); + + private final LispObject defaultClassLoader = new JavaObject(new JavaClassLoader()); pf_get_default_classloader() { super("get-default-classloader", PACKAGE_JAVA, true, ""); @@ -146,7 +220,7 @@ @Override public LispObject execute() { - return defaultClassLoader; + return defaultClassLoader; } }; @@ -161,12 +235,12 @@ @Override public LispObject execute() { - return new JavaObject(new JavaClassLoader(getCurrentClassLoader())); + return new JavaObject(new JavaClassLoader(getCurrentClassLoader())); } @Override public LispObject execute(LispObject parent) { - return new JavaObject(new JavaClassLoader((ClassLoader) parent.javaInstance(ClassLoader.class))); + return new JavaObject(new JavaClassLoader((ClassLoader) parent.javaInstance(ClassLoader.class))); } }; @@ -181,19 +255,19 @@ @Override public LispObject execute() { - return execute(new JavaObject(getCurrentClassLoader())); + return execute(new JavaObject(getCurrentClassLoader())); } @Override public LispObject execute(LispObject classloader) { - LispObject list = NIL; - Object o = classloader.javaInstance(); - while(o instanceof ClassLoader) { - ClassLoader cl = (ClassLoader) o; - list = list.push(dumpClassPath(cl)); - o = cl.getParent(); - } - return list.nreverse(); + LispObject list = NIL; + Object o = classloader.javaInstance(); + while(o instanceof ClassLoader) { + ClassLoader cl = (ClassLoader) o; + list = list.push(dumpClassPath(cl)); + o = cl.getParent(); + } + return list.nreverse(); } }; @@ -221,26 +295,26 @@ @Override public LispObject execute(LispObject jarOrJars) { - return execute(jarOrJars, new JavaObject(getCurrentClassLoader())); + return execute(jarOrJars, new JavaObject(getCurrentClassLoader())); } @Override public LispObject execute(LispObject jarOrJars, LispObject classloader) { - Object o = classloader.javaInstance(); - if(o instanceof JavaClassLoader) { - JavaClassLoader jcl = (JavaClassLoader) o; - if(jarOrJars instanceof Cons) { - while(jarOrJars != NIL) { - addURL(jcl, jarOrJars.car()); - jarOrJars = jarOrJars.cdr(); - } - } else { - addURL(jcl, jarOrJars); - } - return T; - } else { - return error(new TypeError(o + " must be an instance of " + JavaClassLoader.class.getName())); - } + Object o = classloader.javaInstance(); + if(o instanceof JavaClassLoader) { + JavaClassLoader jcl = (JavaClassLoader) o; + if(jarOrJars instanceof Cons) { + while(jarOrJars != NIL) { + addURL(jcl, jarOrJars.car()); + jarOrJars = jarOrJars.cdr(); + } + } else { + addURL(jcl, jarOrJars); + } + return T; + } else { + return error(new TypeError(o + " must be an instance of " + JavaClassLoader.class.getName())); + } } }; @@ -256,24 +330,24 @@ public static LispObject dumpClassPath(ClassLoader o) { - if(o instanceof URLClassLoader) { - LispObject list = NIL; - for(URL u : ((URLClassLoader) o).getURLs()) { - list = list.push(new Pathname(u)); - } - return new Cons(new JavaObject(o), list.nreverse()); - } else { - return new JavaObject(o); - } + if(o instanceof URLClassLoader) { + LispObject list = NIL; + for(URL u : ((URLClassLoader) o).getURLs()) { + list = list.push(new Pathname(u)); + } + return new Cons(new JavaObject(o), list.nreverse()); + } else { + return new JavaObject(o); + } } public static ClassLoader getCurrentClassLoader() { - LispObject classLoader = CLASSLOADER.symbolValueNoThrow(); - if(classLoader != null) { - return (ClassLoader) classLoader.javaInstance(ClassLoader.class); - } else { - return Lisp.class.getClassLoader(); - } + LispObject classLoader = CLASSLOADER.symbolValueNoThrow(); + if(classLoader != null) { + return (ClassLoader) classLoader.javaInstance(ClassLoader.class); + } else { + return Lisp.class.getClassLoader(); + } } Modified: trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Sat Jul 21 07:02:32 2012 (r14014) +++ trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Mon Jul 23 04:58:34 2012 (r14015) @@ -78,6 +78,13 @@ return c; } } + + if (checkPreCompiledClassLoader) { + Class c = findPrecompiledClassOrNull(name); + if (c != null) { + return c; + } + } // Fall through to our super's default handling return super.loadClass(name, resolve); @@ -86,8 +93,13 @@ @Override protected Class findClass(String name) throws ClassNotFoundException { try { + if (checkPreCompiledClassLoader) { + Class c = findPrecompiledClassOrNull(name); + if (c != null) + return c; + } byte[] b = getFunctionClassBytes(name); - return defineClass(name, b, 0, b.length); + return defineLispClass(name, b, 0, b.length); } catch(Throwable e) { //TODO handle this better, readFunctionBytes uses Debug.assert() but should return null e.printStackTrace(); if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } @@ -96,23 +108,17 @@ } public byte[] getFunctionClassBytes(String name) { - return (byte[])hashtable.get(name).javaInstance(); - } - - public byte[] getFunctionClassBytes(Class functionClass) { - return getFunctionClassBytes(functionClass.getName()); - } - - public byte[] getFunctionClassBytes(Function f) { - byte[] b = getFunctionClassBytes(f.getClass()); - f.setClassBytes(b); - return b; + if (hashtable.containsKey(name)) { + return (byte[])hashtable.get(name).javaInstance(); + } + return super.getFunctionClassBytes(name); } public LispObject loadFunction(String name) { try { - Function f = (Function) loadClass(name).newInstance(); - f.setClassBytes(getFunctionClassBytes(name)); + Class clz = loadClass(name); + Function f = (Function) clz.newInstance(); + getFunctionClassBytes(f); //as a side effect it sets them return f; } catch(Throwable e) { if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } @@ -135,29 +141,28 @@ private static final Primitive PUT_MEMORY_FUNCTION = new pf_put_memory_function(); private static final class pf_put_memory_function extends Primitive { - pf_put_memory_function() { + pf_put_memory_function() { super("put-memory-function", PACKAGE_SYS, false, "loader class-name class-bytes"); } @Override public LispObject execute(LispObject loader, LispObject className, LispObject classBytes) { MemoryClassLoader l = (MemoryClassLoader) loader.javaInstance(MemoryClassLoader.class); - return (LispObject)l.hashtable.put(className.getStringValue(), (JavaObject)classBytes); + return (LispObject)l.hashtable.put(className.getStringValue(), (JavaObject)classBytes); } }; private static final Primitive GET_MEMORY_FUNCTION = new pf_get_memory_function(); private static final class pf_get_memory_function extends Primitive { - pf_get_memory_function() { + pf_get_memory_function() { super("get-memory-function", PACKAGE_SYS, false, "loader class-name"); } @Override public LispObject execute(LispObject loader, LispObject name) { MemoryClassLoader l = (MemoryClassLoader) loader.javaInstance(MemoryClassLoader.class); - return l.loadFunction(name.getStringValue()); + return l.loadFunction(name.getStringValue()); } }; +} - -} \ No newline at end of file From rschlatte at common-lisp.net Wed Jul 25 13:33:32 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 25 Jul 2012 06:33:32 -0700 Subject: [armedbear-cvs] r14016 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jul 25 06:33:29 2012 New Revision: 14016 Log: slightly more helpful error message 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 Mon Jul 23 04:58:34 2012 (r14015) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jul 25 06:33:29 2012 (r14016) @@ -4416,8 +4416,8 @@ (setf generic-function-class (find-class generic-function-class))) (unless (classp method-class) (setf method-class (find-class method-class))) (unless (eq generic-function-class (class-of generic-function)) - (error "The class ~S is incompatible with the existing class of ~S." - generic-function-class generic-function)) + (error "The class ~S is incompatible with the existing class (~S) of ~S." + generic-function-class (class-of generic-function) generic-function)) (unless (or (null (generic-function-methods generic-function)) (lambda-lists-congruent-p lambda-list (generic-function-lambda-list generic-function))) (error "The lambda list ~S is incompatible with the existing methods of ~S." From ehuelsmann at common-lisp.net Sat Jul 28 20:44:40 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 28 Jul 2012 13:44:40 -0700 Subject: [armedbear-cvs] r14017 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 28 13:44:37 2012 New Revision: 14017 Log: Fix #191: Compiling SHARPSIGN SHARPSIGN form causes stack overflow. We weren't correctly detecting recursive structures when traversing the to-be-compiled tree of sexps. Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Wed Jul 25 06:33:29 2012 (r14016) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Jul 28 13:44:37 2012 (r14017) @@ -577,21 +577,28 @@ (eq name (block-name block))) (return block)))) -(defun %find-enclosed-blocks (form) +(defun %find-enclosed-blocks (form traversed-blocks) "Helper function for `find-enclosed-blocks`, implementing the actual -algorithm specified there." +algorithm specified there. +`traversed-blocks' prevents traversal of recursive structures." (cond ((node-p form) (list form)) ((atom form) nil) (t ;; We can't use MAPCAN or DOLIST here: they'll choke on dotted lists (do* ((tail form (cdr tail)) + (current-block (if (consp tail) + (car tail) tail) + (if (consp tail) + (car tail) tail)) blocks) ((null tail) blocks) - (setf blocks - (nconc (%find-enclosed-blocks (if (consp tail) - (car tail) tail)) - blocks)) + (unless (gethash current-block traversed-blocks) + (setf (gethash current-block traversed-blocks) t) + (setf blocks + (nconc (%find-enclosed-blocks current-block + traversed-blocks) + blocks))) (when (not (listp tail)) (return blocks)))))) @@ -609,7 +616,7 @@ (null (node-children first-enclosing-block))) (return-from find-enclosed-blocks)))) - (%find-enclosed-blocks form)) + (%find-enclosed-blocks form (make-hash-table :test 'eq))) (defun some-nested-block (predicate blocks) From ehuelsmann at common-lisp.net Sun Jul 29 11:32:14 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jul 2012 04:32:14 -0700 Subject: [armedbear-cvs] r14018 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 29 04:32:09 2012 New Revision: 14018 Log: Fix #206 while moving the definition of the condition classes to lisp. Deleted: trunk/abcl/src/org/armedbear/lisp/CompilerError.java trunk/abcl/src/org/armedbear/lisp/CompilerUnsupportedFeatureError.java trunk/abcl/src/org/armedbear/lisp/InternalCompilerError.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp trunk/abcl/src/org/armedbear/lisp/make_condition.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sat Jul 28 13:44:37 2012 (r14017) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sun Jul 29 04:32:09 2012 (r14018) @@ -597,16 +597,6 @@ public static final StandardClass UNDEFINED_FUNCTION = addStandardClass(Symbol.UNDEFINED_FUNCTION, list(CELL_ERROR)); - public static final StandardClass COMPILER_ERROR = - addStandardClass(Symbol.COMPILER_ERROR, list(CONDITION)); - - public static final StandardClass INTERNAL_COMPILER_ERROR = - addStandardClass(Symbol.INTERNAL_COMPILER_ERROR, list(CONDITION)); - - public static final StandardClass COMPILER_UNSUPPORTED_FEATURE_ERROR = - addStandardClass(Symbol.COMPILER_UNSUPPORTED_FEATURE_ERROR, - list(CONDITION)); - public static final StandardClass JAVA_EXCEPTION = addStandardClass(Symbol.JAVA_EXCEPTION, list(ERROR)); @@ -649,13 +639,6 @@ list(new SlotDefinition(Symbol.NAME, list(Symbol.CELL_ERROR_NAME)))); CLASS.setCPL(CLASS, SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); - COMPILER_ERROR.setCPL(COMPILER_ERROR, CONDITION, STANDARD_OBJECT, - BuiltInClass.CLASS_T); - INTERNAL_COMPILER_ERROR.setCPL(INTERNAL_COMPILER_ERROR, CONDITION, STANDARD_OBJECT, - BuiltInClass.CLASS_T); - COMPILER_UNSUPPORTED_FEATURE_ERROR.setCPL(COMPILER_UNSUPPORTED_FEATURE_ERROR, - CONDITION, STANDARD_OBJECT, - BuiltInClass.CLASS_T); CONDITION.setCPL(CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); CONDITION.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.FORMAT_CONTROL, @@ -811,9 +794,6 @@ GENERIC_FUNCTION.finalizeClass(); ARITHMETIC_ERROR.finalizeClass(); CELL_ERROR.finalizeClass(); - COMPILER_ERROR.finalizeClass(); - INTERNAL_COMPILER_ERROR.finalizeClass(); - COMPILER_UNSUPPORTED_FEATURE_ERROR.finalizeClass(); CONDITION.finalizeClass(); CONTROL_ERROR.finalizeClass(); DIVISION_BY_ZERO.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Jul 28 13:44:37 2012 (r14017) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sun Jul 29 04:32:09 2012 (r14018) @@ -2925,12 +2925,6 @@ PACKAGE_EXT.addExternalSymbol("MEMQL"); public static final Symbol NIL_VECTOR = PACKAGE_EXT.addExternalSymbol("NIL-VECTOR"); - public static final Symbol COMPILER_ERROR = - PACKAGE_EXT.addExternalSymbol("COMPILER-ERROR"); - public static final Symbol INTERNAL_COMPILER_ERROR = - PACKAGE_EXT.addExternalSymbol("INTERNAL-COMPILER-ERROR"); - public static final Symbol COMPILER_UNSUPPORTED_FEATURE_ERROR = - PACKAGE_EXT.addExternalSymbol("COMPILER-UNSUPPORTED-FEATURE-ERROR"); public static final Symbol MAILBOX = PACKAGE_EXT.addExternalSymbol("MAILBOX"); public static final Symbol MUTEX = Modified: trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp Sat Jul 28 13:44:37 2012 (r14017) +++ trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp Sun Jul 29 04:32:09 2012 (r14018) @@ -40,6 +40,10 @@ (defvar *compiler-error-context* nil) +(define-condition compiler-error (error)) +(define-condition internal-compiler-error (compiler-error)) +(define-condition compiler-unsupported-feature-error (compiler-error)) + (defun compiler-style-warn (format-control &rest format-arguments) (warn 'style-warning :format-control format-control Modified: trunk/abcl/src/org/armedbear/lisp/make_condition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/make_condition.java Sat Jul 28 13:44:37 2012 (r14017) +++ trunk/abcl/src/org/armedbear/lisp/make_condition.java Sun Jul 29 04:32:09 2012 (r14018) @@ -119,13 +119,6 @@ if (symbol == Symbol.WARNING) return new Warning(initArgs); - if (symbol == Symbol.COMPILER_ERROR) - return new CompilerError(initArgs); - if (symbol == Symbol.INTERNAL_COMPILER_ERROR) - return new InternalCompilerError(initArgs); - if (symbol == Symbol.COMPILER_UNSUPPORTED_FEATURE_ERROR) - return new CompilerUnsupportedFeatureError(initArgs); - return NIL; } From ehuelsmann at common-lisp.net Sun Jul 29 15:24:20 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jul 2012 08:24:20 -0700 Subject: [armedbear-cvs] r14019 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 29 08:24:16 2012 New Revision: 14019 Log: Fix #224: autoloading clobbered by unknown special variable state. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Sun Jul 29 04:32:09 2012 (r14018) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sun Jul 29 08:24:16 2012 (r14019) @@ -215,14 +215,19 @@ } } - public static final LispObject loadSystemFile(String filename, boolean auto) - + public static LispObject loadSystemFile(String filename, boolean auto) { LispThread thread = LispThread.currentThread(); if (auto) { final SpecialBindingsMark mark = thread.markSpecialBindings(); + // Due to autoloading, we're not sure about the loader state. + // Make sure that all reader relevant variables have known state. thread.bindSpecial(Symbol.CURRENT_READTABLE, STANDARD_READTABLE.symbolValue(thread)); + thread.bindSpecial(Symbol.READ_BASE, Fixnum.constants[10]); + thread.bindSpecial(Symbol.READ_SUPPRESS, NIL); + thread.bindSpecial(Symbol.READ_EVAL, T); + thread.bindSpecial(Symbol.READ_DEFAULT_FLOAT_FORMAT, Symbol.SINGLE_FLOAT); thread.bindSpecial(Symbol._PACKAGE_, PACKAGE_CL_USER); try { return loadSystemFile(filename, From ehuelsmann at common-lisp.net Sun Jul 29 15:41:32 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jul 2012 08:41:32 -0700 Subject: [armedbear-cvs] r14020 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 29 08:41:31 2012 New Revision: 14020 Log: Document what I've explained to Mark this morning. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Jul 29 08:24:16 2012 (r14019) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Jul 29 08:41:31 2012 (r14020) @@ -104,6 +104,13 @@ (diag "Internal compiler error detected: Fasl contains ~ zero-length jvm classfile corresponding to ~A." classfile) (return-from verify-load nil))) + ;; ### FIXME + ;; The section below can't work, because we have + ;; circular references between classes of outer- and innerscoped + ;; functions. We need the class loader to resolve these circular + ;; references for us. Our FASL class loader does exactly that, + ;; so we need a class loader here which knows how to find + ;; all the .cls files related to the current scope being loaded. #+nil (when (or force (> *safety* *speed*)) (diag "Testing compiled bytecode by loading classfile into JVM.") From ehuelsmann at common-lisp.net Sun Jul 29 15:45:16 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jul 2012 08:45:16 -0700 Subject: [armedbear-cvs] r14021 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 29 08:45:14 2012 New Revision: 14021 Log: Commit comment that's been sitting in my working copy (only for me to see) too long. 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 Jul 29 08:41:31 2012 (r14020) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jul 29 08:45:14 2012 (r14021) @@ -2166,6 +2166,8 @@ (let* ((method (%car (sys:%generic-function-methods gf))) (specializer (car (std-method-specializers method))) (function (std-method-fast-function method))) + ;;### The above doesn't work: STD-METHOD-FUNCTION + ;; is a function of 2 args: ARGS and NEXT-EMFUN and being called with one below... (if (typep specializer 'eql-specializer) (let ((specializer-object (eql-specializer-object specializer))) #'(lambda (arg) From ehuelsmann at common-lisp.net Sun Jul 29 19:14:11 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jul 2012 12:14:11 -0700 Subject: [armedbear-cvs] r14022 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 29 12:14:08 2012 New Revision: 14022 Log: Delete unused import. Modified: trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java Modified: trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java Sun Jul 29 08:45:14 2012 (r14021) +++ trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java Sun Jul 29 12:14:08 2012 (r14022) @@ -34,7 +34,6 @@ package org.armedbear.lisp; -import java.util.Collection; import java.util.List; import java.util.ArrayList; import static org.armedbear.lisp.Lisp.*; From ehuelsmann at common-lisp.net Sun Jul 29 20:04:53 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jul 2012 13:04:53 -0700 Subject: [armedbear-cvs] r14023 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 29 13:04:53 2012 New Revision: 14023 Log: Remove Function Preloading facility not in use for quite some time. Deleted: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Primitives.java Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Sun Jul 29 12:14:08 2012 (r14022) +++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Sun Jul 29 13:04:53 2012 (r14023) @@ -224,10 +224,6 @@ namestring = ((Pathname)arg).getNamestring(); else if (arg instanceof AbstractString) namestring = arg.getStringValue(); - if (namestring != null) { - // Debug.trace("autoloading preloaded ... " + namestring); - return AutoloadedFunctionProxy.loadPreloadedFunction(namestring); - } if(arg instanceof JavaObject) { try { return loadClassBytes((byte[]) arg.javaInstance(byte[].class)); Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Sun Jul 29 12:14:08 2012 (r14022) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sun Jul 29 13:04:53 2012 (r14023) @@ -600,9 +600,6 @@ final SpecialBindingsMark mark = thread.markSpecialBindings(); LispObject result = NIL; try { - thread.bindSpecial(AUTOLOADING_CACHE, - AutoloadedFunctionProxy.makePreloadingContext()); - // Same bindings are established in Lisp.readObjectFromString() thread.bindSpecial(Symbol.READ_BASE, LispInteger.getInstance(10)); thread.bindSpecial(Symbol.READ_EVAL, Symbol.T); Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun Jul 29 12:14:08 2012 (r14022) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun Jul 29 13:04:53 2012 (r14023) @@ -1736,8 +1736,7 @@ if (arg instanceof Symbol) { LispObject oldDefinition = arg.getSymbolFunction(); if (oldDefinition != null - && !(oldDefinition instanceof Autoload) - && !(oldDefinition instanceof AutoloadedFunctionProxy)) { + && !(oldDefinition instanceof Autoload)) { LispObject oldSource = Extensions.SOURCE_PATHNAME.execute(arg); LispObject currentSource = _SOURCE_.symbolValue(thread); From ehuelsmann at common-lisp.net Sun Jul 29 20:08:55 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jul 2012 13:08:55 -0700 Subject: [armedbear-cvs] r14024 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 29 13:08:54 2012 New Revision: 14024 Log: Fix #60 (Implement USE_FAST_CALLS properly) by deleting the USE_FAST_CALLS infrastructure in LispThread: The suggested alternative has existed in the compiler for a looooong time already. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java Sun Jul 29 13:04:53 2012 (r14023) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Sun Jul 29 13:08:54 2012 (r14024) @@ -45,7 +45,7 @@ public final class LispThread extends LispObject { - static boolean use_fast_calls = false; +// static boolean use_fast_calls = false; // use a concurrent hashmap: we may want to add threads // while at the same time iterating the hash @@ -625,9 +625,6 @@ @Override public LispObject execute(LispObject function) { - if (use_fast_calls) - return function.execute(); - pushStackFrame(new LispStackFrame(function)); try { return function.execute(); @@ -639,11 +636,7 @@ @Override public LispObject execute(LispObject function, LispObject arg) - { - if (use_fast_calls) - return function.execute(arg); - pushStackFrame(new LispStackFrame(function, arg)); try { return function.execute(arg); @@ -656,11 +649,7 @@ @Override public LispObject execute(LispObject function, LispObject first, LispObject second) - { - if (use_fast_calls) - return function.execute(first, second); - pushStackFrame(new LispStackFrame(function, first, second)); try { return function.execute(first, second); @@ -673,11 +662,7 @@ @Override public LispObject execute(LispObject function, LispObject first, LispObject second, LispObject third) - { - if (use_fast_calls) - return function.execute(first, second, third); - pushStackFrame(new LispStackFrame(function, first, second, third)); try { return function.execute(first, second, third); @@ -691,11 +676,7 @@ public LispObject execute(LispObject function, LispObject first, LispObject second, LispObject third, LispObject fourth) - { - if (use_fast_calls) - return function.execute(first, second, third, fourth); - pushStackFrame(new LispStackFrame(function, first, second, third, fourth)); try { return function.execute(first, second, third, fourth); @@ -709,11 +690,7 @@ public LispObject execute(LispObject function, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) - { - if (use_fast_calls) - return function.execute(first, second, third, fourth, fifth); - pushStackFrame(new LispStackFrame(function, first, second, third, fourth, fifth)); try { return function.execute(first, second, third, fourth, fifth); @@ -728,11 +705,7 @@ LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) - { - if (use_fast_calls) - return function.execute(first, second, third, fourth, fifth, sixth); - pushStackFrame(new LispStackFrame(function, first, second, third, fourth, fifth, sixth)); try { @@ -748,12 +721,7 @@ LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh) - { - if (use_fast_calls) - return function.execute(first, second, third, fourth, fifth, sixth, - seventh); - pushStackFrame(new LispStackFrame(function, first, second, third, fourth, fifth, sixth, seventh)); try { @@ -770,12 +738,7 @@ LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh, LispObject eighth) - { - if (use_fast_calls) - return function.execute(first, second, third, fourth, fifth, sixth, - seventh, eighth); - pushStackFrame(new LispStackFrame(function, first, second, third, fourth, fifth, sixth, seventh, eighth)); try { @@ -788,11 +751,7 @@ } public LispObject execute(LispObject function, LispObject[] args) - { - if (use_fast_calls) - return function.execute(args); - pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(args); @@ -1203,18 +1162,6 @@ }; - @DocString(name="use-fast-calls") - private static final Primitive USE_FAST_CALLS = - new Primitive("use-fast-calls", PACKAGE_SYS, true) - { - @Override - public LispObject execute(LispObject arg) - { - use_fast_calls = (arg != NIL); - return use_fast_calls ? T : NIL; - } - }; - @DocString(name="synchronized-on", args="form &body body") private static final SpecialOperator SYNCHRONIZED_ON = new SpecialOperator("synchronized-on", PACKAGE_THREADS, true, From ehuelsmann at common-lisp.net Sun Jul 29 20:11:30 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jul 2012 13:11:30 -0700 Subject: [armedbear-cvs] r14025 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 29 13:11:29 2012 New Revision: 14025 Log: Re #60: Line missed in last commit. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java Sun Jul 29 13:08:54 2012 (r14024) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Sun Jul 29 13:11:29 2012 (r14025) @@ -45,8 +45,6 @@ public final class LispThread extends LispObject { -// static boolean use_fast_calls = false; - // use a concurrent hashmap: we may want to add threads // while at the same time iterating the hash final static ConcurrentHashMap map = From ehuelsmann at common-lisp.net Tue Jul 31 12:23:26 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 31 Jul 2012 05:23:26 -0700 Subject: [armedbear-cvs] r14026 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 31 05:23:25 2012 New Revision: 14026 Log: Add a few missing autoloaders. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Jul 29 13:11:29 2012 (r14025) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Tue Jul 31 05:23:25 2012 (r14026) @@ -544,6 +544,7 @@ autoload(PACKAGE_SYS, "%finalize-generic-function", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%generic-function-lambda-list", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%generic-function-name", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "set-generic-function-declarations", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%get-output-stream-bytes", "ByteArrayOutputStream"); //AS 20090325 autoload(PACKAGE_SYS, "%get-output-stream-array", "ByteArrayOutputStream"); autoload(PACKAGE_SYS, "%make-array", "make_array"); @@ -568,6 +569,11 @@ autoload(PACKAGE_SYS, "%set-generic-function-lambda-list", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%set-generic-function-name", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%set-gf-required-args", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%set-gf-optional-args", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "gf-required-args", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "gf-optional-args", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%init-eql-specializations", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%get-arg-specialization", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives"); autoload(PACKAGE_SYS, "%simple-bit-vector-bit-and", "SimpleBitVector"); autoload(PACKAGE_SYS, "%simple-bit-vector-bit-andc1", "SimpleBitVector"); From ehuelsmann at common-lisp.net Tue Jul 31 12:24:31 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 31 Jul 2012 05:24:31 -0700 Subject: [armedbear-cvs] r14027 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 31 05:24:30 2012 New Revision: 14027 Log: Add infrastructure to record toplevel names of functions and macros. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Tue Jul 31 05:23:25 2012 (r14026) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Tue Jul 31 05:24:30 2012 (r14027) @@ -40,6 +40,10 @@ (defvar *output-file-pathname*) +(defvar *toplevel-functions*) +(defvar *toplevel-macros*) + + (defun base-classname (&optional (output-file-pathname *output-file-pathname*)) (sanitize-class-name (pathname-name output-file-pathname))) @@ -403,6 +407,7 @@ (defun process-toplevel-defmethod/defgeneric (form stream compile-time-too) (note-toplevel-form form) (note-name-defined (second form)) + (push (second form) *toplevel-functions*) (let ((*compile-print* nil)) (process-toplevel-form (macroexpand-1 form *compile-file-environment*) stream compile-time-too)) @@ -428,6 +433,7 @@ (note-toplevel-form form) (let ((name (second form))) (eval form) + (push name *toplevel-macros*) (let* ((expr (function-lambda-expression (macro-function name))) (saved-class-number *class-number*) (classfile (next-classfile-name))) @@ -527,6 +533,7 @@ ',(inline-expansion name)))))) (push name jvm::*functions-defined-in-current-file*) (note-name-defined name) + (push name *toplevel-functions*) ;; If NAME is not fbound, provide a dummy definition so that ;; getSymbolFunctionOrDie() will succeed when we try to verify that ;; functions defined later in the same file can be loaded correctly. @@ -693,6 +700,7 @@ output-file ((:verbose *compile-verbose*) *compile-verbose*) ((:print *compile-print*) *compile-print*) + (extract-toplevel-funcs-and-macros nil) external-format) (declare (ignore external-format)) ; FIXME (unless (or (and (probe-file input-file) (not (file-directory-p input-file))) @@ -712,6 +720,10 @@ output-file)) (temp-file2 (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp2")) output-file)) + (functions-file (merge-pathnames (make-pathname :type "funcs") output-file)) + (macros-file (merge-pathnames (make-pathname :type "macs") output-file)) + *toplevel-functions* + *toplevel-macros* (warnings-p nil) (failure-p nil)) (with-open-file (in input-file :direction :input) @@ -766,6 +778,34 @@ (finalize-fasl-output) (dolist (name *fbound-names*) (fmakunbound name))))))) + (when extract-toplevel-funcs-and-macros + (setf *toplevel-functions* + (remove-if-not (lambda (func-name) + (if (symbolp func-name) + (symbol-package func-name) + T)) + (remove-duplicates *toplevel-functions*))) + (when *toplevel-functions* + (with-open-file (f-out functions-file + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + + (let ((*package* (find-package :keyword))) + (write *toplevel-functions* :stream f-out)))) + (setf *toplevel-macros* + (remove-if-not (lambda (mac-name) + (if (symbolp mac-name) + (symbol-package mac-name) + T)) + (remove-duplicates *toplevel-macros*))) + (when *toplevel-macros* + (with-open-file (m-out macros-file + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (let ((*package* (find-package :keyword))) + (write *toplevel-macros* :stream m-out))))) (with-open-file (in temp-file :direction :input) (with-open-file (out temp-file2 :direction :output :if-does-not-exist :create @@ -835,7 +875,7 @@ (file-write-date output-file)))) (if (or (null target-write-time) (<= target-write-time source-write-time)) - (apply 'compile-file input-file allargs) + (apply #'compile-file input-file allargs) output-file))))) (provide 'compile-file) From ehuelsmann at common-lisp.net Tue Jul 31 12:26:36 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 31 Jul 2012 05:26:36 -0700 Subject: [armedbear-cvs] r14028 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 31 05:26:35 2012 New Revision: 14028 Log: When creating a generic function on top of an autoloader, don't resolve the autoloader: that's probably what we are already doing (but the function doesn't get replaced until autoloading has succeeded). 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 Jul 31 05:24:30 2012 (r14027) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jul 31 05:26:35 2012 (r14028) @@ -1653,8 +1653,6 @@ argument-precedence-order documentation &allow-other-keys) - (when (autoloadp function-name) - (resolve function-name)) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :generic-function-class) (let ((gf (find-generic-function function-name nil))) @@ -1677,7 +1675,14 @@ gf) (progn (when (and (null *clos-booting*) - (fboundp function-name)) + (and (fboundp function-name) + ;; since we're overwriting an autoloader, + ;; we're probably meant to redefine it, + ;; so throwing an error here might be a bad idea. + ;; also, resolving the symbol isn't + ;; a good option either: we've seen that lead to + ;; recursive loading of the same file + (not (autoloadp function-name)))) (error 'program-error :format-control "~A already names an ordinary function, macro, or special operator." :format-arguments (list function-name))) From ehuelsmann at common-lisp.net Tue Jul 31 12:31:15 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 31 Jul 2012 05:31:15 -0700 Subject: [armedbear-cvs] r14029 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 31 05:31:14 2012 New Revision: 14029 Log: More output during "boot" phase when property abcl.autoload.verbose is set. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Tue Jul 31 05:26:35 2012 (r14028) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Tue Jul 31 05:31:14 2012 (r14029) @@ -705,7 +705,8 @@ { final LispThread thread = LispThread.currentThread(); return loadSystemFile(arg.getStringValue(), - Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL, + Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL + || System.getProperty("abcl.autoload.verbose") != null, Symbol.LOAD_PRINT.symbolValue(thread) != NIL, false); } From ehuelsmann at common-lisp.net Tue Jul 31 13:07:18 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 31 Jul 2012 06:07:18 -0700 Subject: [armedbear-cvs] r14030 - trunk/abcl Message-ID: Author: ehuelsmann Date: Tue Jul 31 06:07:15 2012 New Revision: 14030 Log: More output while initializing the system. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Tue Jul 31 05:31:14 2012 (r14029) +++ trunk/abcl/build.xml Tue Jul 31 06:07:15 2012 (r14030) @@ -251,6 +251,7 @@ inputstring="(handler-case (compile-system :zip nil :quit t :output-path "${abcl.lisp.output}/") (t (x) (progn (format t "~A: ~A~%" (type-of x) x) (exit :status -1))))" classname="org.armedbear.lisp.Main"> + From ehuelsmann at common-lisp.net Tue Jul 31 18:04:53 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 31 Jul 2012 11:04:53 -0700 Subject: [armedbear-cvs] r14031 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 31 11:04:52 2012 New Revision: 14031 Log: The precompiler has significant performance benefit in interpreted code. Load as early as possible and don't leave to the autoloader to do it. Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/boot.lisp Tue Jul 31 06:07:15 2012 (r14030) +++ trunk/abcl/src/org/armedbear/lisp/boot.lisp Tue Jul 31 11:04:52 2012 (r14031) @@ -178,6 +178,9 @@ (load-system-file "signal") (load-system-file "list") (load-system-file "require") +;; precompiler has a large performance benefit on interpreted code +;; load as early as possible +(load-system-file "precompiler") (load-system-file "extensible-sequences-base") (load-system-file "sequences") (load-system-file "error") From ehuelsmann at common-lisp.net Tue Jul 31 18:07:00 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 31 Jul 2012 11:07:00 -0700 Subject: [armedbear-cvs] r14032 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 31 11:06:59 2012 New Revision: 14032 Log: Follow up to r14023: removal of function preloading facility. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Tue Jul 31 11:04:52 2012 (r14031) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Tue Jul 31 11:06:59 2012 (r14032) @@ -688,13 +688,6 @@ autoload(PACKAGE_SYS, "unzip", "unzip", true); autoload(PACKAGE_SYS, "zip", "zip", true); - autoload(PACKAGE_SYS, "proxy-preloaded-function", - "AutoloadedFunctionProxy", false); - autoload(PACKAGE_SYS, "make-function-preloading-context", - "AutoloadedFunctionProxy", false); - autoload(PACKAGE_SYS, "function-preload", - "AutoloadedFunctionProxy", false); - autoload(Symbol.COPY_LIST, "copy_list"); autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false); From ehuelsmann at common-lisp.net Tue Jul 31 18:10:04 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 31 Jul 2012 11:10:04 -0700 Subject: [armedbear-cvs] r14033 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 31 11:10:03 2012 New Revision: 14033 Log: Make MACROEXPAND-1 auto-load strictly what it needs (macro functions) instead of auto-loading all function types. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Jul 31 11:06:59 2012 (r14032) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Jul 31 11:10:03 2012 (r14033) @@ -223,8 +223,11 @@ if (car instanceof Symbol) { LispObject obj = env.lookupFunction(car); - if (obj instanceof Autoload) + if (obj instanceof AutoloadMacro) { + // Don't autoload function objects here: + // we want that to happen upon the first use. + // in case of macro functions, this *is* the first use. Autoload autoload = (Autoload) obj; autoload.load(); obj = car.getSymbolFunction(); @@ -1808,6 +1811,15 @@ } else if (obj instanceof Cons && obj.car() == Symbol.LAMBDA) return new Closure(obj, new Environment()); + if (obj instanceof Cons && obj.car() == Symbol.NAMED_LAMBDA) { + LispObject name = obj.cadr(); + if (name instanceof Symbol || isValidSetfFunctionName(name)) { + return new Closure(name, + new Cons(Symbol.LAMBDA, obj.cddr()), + new Environment()); + } + return type_error(name, FUNCTION_NAME); + } error(new UndefinedFunction(obj)); // Not reached. return null; From ehuelsmann at common-lisp.net Tue Jul 31 18:17:02 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 31 Jul 2012 11:17:02 -0700 Subject: [armedbear-cvs] r14034 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 31 11:17:01 2012 New Revision: 14034 Log: Follow up to r14027: generate the output files while building our system. Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Tue Jul 31 11:10:03 2012 (r14033) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Tue Jul 31 11:17:01 2012 (r14034) @@ -89,7 +89,9 @@ (let ((out (make-pathname :type *compile-file-type* :defaults (merge-pathnames file output-path)))) - (compile-file-if-needed file :output-file out)))) + (compile-file-if-needed file + :output-file out + :extract-toplevel-funcs-and-macros t)))) (load (do-compile "defstruct.lisp")) (load (do-compile "coerce.lisp")) (load (do-compile "open.lisp"))