From rschlatte at common-lisp.net Wed May 2 11:57:00 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 02 May 2012 04:57:00 -0700 Subject: [armedbear-cvs] r13923 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed May 2 04:56:59 2012 New Revision: 13923 Log: Implement validate-superclass Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/java.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Apr 30 00:47:19 2012 (r13922) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed May 2 04:56:59 2012 (r13923) @@ -104,6 +104,8 @@ (export '(class-precedence-list class-slots slot-definition-name)) (defconstant +the-standard-class+ (find-class 'standard-class)) +(defconstant +the-funcallable-standard-class+ + (find-class 'funcallable-standard-class)) (defconstant +the-structure-class+ (find-class 'structure-class)) (defconstant +the-standard-object-class+ (find-class 'standard-object)) (defconstant +the-standard-method-class+ (find-class 'standard-method)) Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp Mon Apr 30 00:47:19 2012 (r13922) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Wed May 2 04:56:59 2012 (r13923) @@ -439,6 +439,14 @@ :initform (error "class is required") :reader java-class-jclass))) +;;; FIXME (rudi 2012-05-02): consider replacing the metaclass of class +;;; java-object to be java-class here instead of allowing this subclass +;;; relationship. On the other hand, abcl ran for the longest time +;;; without an implementation of validate-superclass, so this doesn't +;;; introduce new sources for bugs. +(defmethod mop:validate-superclass ((class java-class) (superclass built-in-class)) + t) + ;;init java.lang.Object class (defconstant +java-lang-object-class+ (%register-java-class +java-lang-object+ Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Apr 30 00:47:19 2012 (r13922) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Wed May 2 04:56:59 2012 (r13923) @@ -13,20 +13,29 @@ ;;; 2. Tighten the type checks so that only instances of ;;; FUNCALLABLE-STANDARD-CLASS are callable. +;;; AMOP pg. 240ff. (defgeneric validate-superclass (class superclass) (:documentation "This generic function is called to determine whether the class superclass is suitable for use as a superclass of class.")) -;;; TODO Hook VALIDATE-SUPERCLASS into during class metaobject -;;; initialization and reinitialization. (AMOP p.240-1) (defmethod validate-superclass ((class class) (superclass class)) - (or (eql (class-name superclass) t) - (eql (class-name class) (class-name superclass)) - (or (and (eql (class-name class) 'standard-class) - (eql (class-name superclass) 'funcallable-standard-class)) - (and (eql (class-name class) 'funcallable-standard-class) - (eql (class-name superclass) 'standard-class))))) + (or (eql superclass +the-T-class+) + (eql (class-of class) (class-of superclass)) + (or (and (eql (class-of class) +the-standard-class+) + (eql (class-of superclass) +the-funcallable-standard-class+)) + (and (eql (class-of class) +the-funcallable-standard-class+) + (eql (class-of superclass) +the-standard-class+))))) + +(defmethod shared-initialize :before ((instance class) + slot-names + &key direct-superclasses + &allow-other-keys) + (declare (ignore slot-names)) + (dolist (superclass direct-superclasses) + (assert (validate-superclass instance superclass) (instance superclass) + "Class ~S is not compatible with superclass ~S" + instance superclass))) (export '(;; classes funcallable-standard-object From mevenson at common-lisp.net Fri May 4 09:14:25 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 04 May 2012 02:14:25 -0700 Subject: [armedbear-cvs] r13924 - in trunk/abcl: . test/lisp/ansi Message-ID: Author: mevenson Date: Fri May 4 02:14:24 2012 New Revision: 13924 Log: ansi-tests: DO-TESTS-MATCHING will run all case-insensitive matching tests. An ASDF load of ANSI-INTERPRETED now loads the interpreted tests into memory via an :around specialization. Changes in ABCL.TEST.ANSI (aka ANSI-TESTS): DO-TESTS-MATCHING implemented (cribbed from ABCL-TEST-LISP). Refactored DEFPACKAGE forms out of ABCL-ANSI-TESTS code, creating abcl-ansi.lisp to hold all other forms. Import symbols from REGRESSION-TEST where it makes sense (list could probably be larger; why not just use the package?) Added: trunk/abcl/test/lisp/ansi/abcl-ansi.lisp trunk/abcl/test/lisp/ansi/packages.lisp - copied, changed from r13923, trunk/abcl/test/lisp/ansi/package.lisp Deleted: trunk/abcl/test/lisp/ansi/package.lisp Modified: trunk/abcl/abcl.asd Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd Wed May 2 04:56:59 2012 (r13923) +++ trunk/abcl/abcl.asd Fri May 4 02:14:24 2012 (r13924) @@ -66,37 +66,44 @@ "Invoke tests with (asdf:oos 'asdf:test-op :abcl-test-lisp)." (funcall (intern (symbol-name 'run) :abcl.test.lisp))) -;;; Test ABCL with the interpreted ANSI tests -(defsystem :ansi-interpreted :version "1.1" - :components - ((:module ansi-tests :pathname "test/lisp/ansi/" :components - ((:file "package") - (:file "parse-ansi-errors" :depends-on ("package")))))) +(defsystem :ansi-interpreted + :version "1.2" + :description "Test ABCL with the interpreted ANSI tests" :components + ((:module ansi-tests :pathname "test/lisp/ansi/" :components + ((:file "packages") + (:file "abcl-ansi" :depends-on ("packages")) + (:file "parse-ansi-errors" :depends-on ("abcl-ansi")))))) (defmethod perform :before ((o test-op) (c (eql (find-system :ansi-interpreted)))) (load-system :ansi-interpreted)) + +(defmethod perform :after ((o load-op) (c (eql (find-system :ansi-interpreted)))) + (funcall (intern (symbol-name 'load-tests) :abcl.test.ansi))) + (defmethod perform ((o test-op) (c (eql (find-system :ansi-interpreted)))) (funcall (intern (symbol-name 'run) :abcl.test.ansi) :compile-tests nil)) -;;; Test ABCL with the compiled ANSI tests -(defsystem :ansi-compiled :version "1.1" - :components + +(defsystem :ansi-compiled :version "1.2" + :description "Test ABCL with the compiled ANSI tests." :components ((:module ansi-tests :pathname "test/lisp/ansi/" :components - ((:file "package") - (:file "parse-ansi-errors" :depends-on ("package")))))) + ((:file "packages") + (:file "abcl-ansi" :depends-on ("packages")) + (:file "parse-ansi-errors" :depends-on ("abcl-ansi")))))) + (defmethod perform :before ((o test-op) (c (eql (find-system :ansi-compiled)))) (load-system :ansi-compiled)) (defmethod perform ((o test-op) (c (eql (find-system :ansi-compiled)))) (funcall (intern (symbol-name 'run) :abcl.test.ansi) :compile-tests t)) -;;; Test ABCL with CL-BENCH -(defsystem :cl-bench :components - ((:module cl-bench-package :pathname "../cl-bench/" - :components ((:file "defpackage"))) - (:module cl-bench-wrapper :pathname "test/lisp/cl-bench/" - :depends-on (cl-bench-package) :components - ((:file "wrapper"))))) +(defsystem :cl-bench + :description "Test ABCL with CL-BENCH." + :components ((:module cl-bench-package :pathname "../cl-bench/" + :components ((:file "defpackage"))) + (:module cl-bench-wrapper :pathname "test/lisp/cl-bench/" + :depends-on (cl-bench-package) :components + ((:file "wrapper"))))) (defmethod perform :before ((o test-op) (c (eql (find-system :cl-bench)))) (load-system :cl-bench)) (defmethod perform ((o test-op) (c (eql (find-system :cl-bench)))) Added: trunk/abcl/test/lisp/ansi/abcl-ansi.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/test/lisp/ansi/abcl-ansi.lisp Fri May 4 02:14:24 2012 (r13924) @@ -0,0 +1,92 @@ +(in-package :abcl.test.ansi) + +(defparameter *ansi-tests-master-source-location* + "") + +(defparameter *ansi-tests-directory* + (if (find :asdf2 *features*) + (asdf:system-relative-pathname :ansi-compiled "../ansi-tests/") + (merge-pathnames #p"../ansi-tests/" + (asdf:component-pathname + (asdf:find-system :ansi-compiled))))) + +(defun run (&key (compile-tests nil)) + "Run the ANSI-TESTS suite, to be found in *ANSI-TESTS-DIRECTORY*. +Possibly running the compiled version of the tests if COMPILE-TESTS is non-NIL." + (verify-ansi-tests) + (let* ((ansi-tests-directory + *ansi-tests-directory*) + (boot-file + (if compile-tests "compileit.lsp" "doit.lsp")) + (message + (format nil "Invocation of '~A' in ~A" + boot-file ansi-tests-directory))) + (progv + '(*default-pathname-defaults*) + `(,(merge-pathnames *ansi-tests-directory* + *default-pathname-defaults*)) + (format t "---> ~A begins.~%" message) + (format t "Invoking ABCL hosted on ~A ~A.~%" + (software-type) (software-version)) + (time (load boot-file)) + (format t "<--- ~A ends.~%" message)))) + +(defun verify-ansi-tests () + (unless + (probe-file *ansi-tests-directory*) + (error 'file-error + "Failed to find the GCL ANSI tests in '~A'. Please +locally obtain ~A, and set the value of *ANSI-TESTS-DIRECTORY* to that +location." + *ansi-tests-directory* + *ansi-tests-master-source-location*))) + +(defvar *ansi-tests-loaded-p* nil) +(defun load-tests () + "Load the ANSI tests but do not execute them." + (verify-ansi-tests) + (let ((*default-pathname-defaults* *ansi-tests-directory*) + (package *package*)) + (setf *package* (find-package :cl-user)) + (load "gclload1.lsp") + (load "gclload2.lsp") + (setf *package* package)) + (setf *ansi-tests-loaded-p* t)) + +(defun clean-tests () + "Do what 'make clean' would do from the GCL ANSI tests," + ;; so we don't have to hunt for 'make' in the PATH on win32. + (verify-ansi-tests) + + (mapcar #'delete-file + (append (directory (format nil "~A/*.cls" *ansi-tests-directory*)) + (directory (format nil "~A/*.abcl" *ansi-tests-directory*)) + (directory (format nil "~A/scratch/*" *ansi-tests-directory*)) + (mapcar (lambda(x) + (format nil "~A/~A" *ansi-tests-directory* x)) + '("scratch/" + "scratch.txt" "foo.txt" "foo.lsp" + "foo.dat" + "tmp.txt" "tmp.dat" "tmp2.dat" + "temp.dat" "out.class" + "file-that-was-renamed.txt" + "compile-file-test-lp.lsp" + "compile-file-test-lp.out" + "ldtest.lsp"))))) + +;;; XXX move this into test-utilities.lisp? +(defvar *last-run-matching* "bit-vector") + +(defun do-tests-matching (&optional (match *last-run-matching*)) + "Run all tests in suite whose symbol contains MATCH in a case-insensitive manner." + (setf *last-run-matching* match) + (let* ((matching (string-upcase match)) + (count 0)) + (mapcar (lambda (entry) + (if (search matching (symbol-name (rt::name entry))) + (setf (rt::pend entry) t + count (1+ count)) + (setf (rt::pend entry) nil))) + (rest rt::*entries*)) + (format t "Performing ~A tests matching '~A'.~%" count matching) + (rt::do-entries t))) Copied and modified: trunk/abcl/test/lisp/ansi/packages.lisp (from r13923, trunk/abcl/test/lisp/ansi/package.lisp) ============================================================================== --- trunk/abcl/test/lisp/ansi/package.lisp Wed May 2 04:56:59 2012 (r13923, copy source) +++ trunk/abcl/test/lisp/ansi/packages.lisp Fri May 4 02:14:24 2012 (r13924) @@ -2,87 +2,14 @@ (:use :cl :cl-user) (:nicknames #:ansi-tests #:abcl-ansi-tests #:gcl-ansi) (:export #:run - #:verify-ansi-tests + #:verify-ansi-tests #:load-tests #:clean-tests #:full-report - #:report #:parse)) + #:report #:parse) + (:import-from #:rt #:do-test #:do-test #:do-tests)) -(in-package :abcl.test.ansi) -(defparameter *ansi-tests-master-source-location* - "") - -(defparameter *ansi-tests-directory* - (if (find :asdf2 *features*) - (asdf:system-relative-pathname :ansi-compiled "../ansi-tests/") - (merge-pathnames #p"../ansi-tests/" - (asdf:component-pathname - (asdf:find-system :ansi-compiled))))) - -(defun run (&key (compile-tests nil)) - "Run the ANSI-TESTS suite, to be found in *ANSI-TESTS-DIRECTORY*. -Possibly running the compiled version of the tests if COMPILE-TESTS is non-NIL." - (verify-ansi-tests) - (let* ((ansi-tests-directory - *ansi-tests-directory*) - (boot-file - (if compile-tests "compileit.lsp" "doit.lsp")) - (message - (format nil "Invocation of '~A' in ~A" - boot-file ansi-tests-directory))) - (progv - '(*default-pathname-defaults*) - `(,(merge-pathnames *ansi-tests-directory* - *default-pathname-defaults*)) - (format t "---> ~A begins.~%" message) - (format t "Invoking ABCL hosted on ~A ~A.~%" - (software-type) (software-version)) - (time (load boot-file)) - (format t "<--- ~A ends.~%" message)))) - -(defun verify-ansi-tests () - (unless - (probe-file *ansi-tests-directory*) - (error 'file-error - "Failed to find the GCL ANSI tests in '~A'. Please -locally obtain ~A, and set the value of *ANSI-TESTS-DIRECTORY* to that -location." - *ansi-tests-directory* - *ansi-tests-master-source-location*))) - -(defvar *ansi-tests-loaded-p* nil) -(defun load-tests () - "Load the ANSI tests but do not execute them." - (verify-ansi-tests) - (let ((*default-pathname-defaults* *ansi-tests-directory*) - (package *package*)) - (setf *package* (find-package :cl-user)) - (load "gclload1.lsp") - (load "gclload2.lsp") - (setf *package* package)) - (setf *ansi-tests-loaded-p* t)) - -(defun clean-tests () - "Do what 'make clean' would do from the GCL ANSI tests," - ;; so we don't have to hunt for 'make' in the PATH on win32. - (verify-ansi-tests) - - (mapcar #'delete-file - (append (directory (format nil "~A/*.cls" *ansi-tests-directory*)) - (directory (format nil "~A/*.abcl" *ansi-tests-directory*)) - (directory (format nil "~A/scratch/*" *ansi-tests-directory*)) - (mapcar (lambda(x) - (format nil "~A/~A" *ansi-tests-directory* x)) - '("scratch/" - "scratch.txt" "foo.txt" "foo.lsp" - "foo.dat" - "tmp.txt" "tmp.dat" "tmp2.dat" - "temp.dat" "out.class" - "file-that-was-renamed.txt" - "compile-file-test-lp.lsp" - "compile-file-test-lp.out" - "ldtest.lsp"))))) From mevenson at common-lisp.net Fri May 4 13:48:58 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 04 May 2012 06:48:58 -0700 Subject: [armedbear-cvs] r13925 - in trunk/abcl: . test/lisp/ansi Message-ID: Author: mevenson Date: Fri May 4 06:48:56 2012 New Revision: 13925 Log: ansi-tests: Fix ANSI-RT load definition. A bit of a circular dance here to be able to use the ANSI-TESTS via ASDF. In order to define functions like ABCL.TEST.ANSI:DO-TESTS-MATCHING we need to have loaded the REGRESSION-TEST package included with the ANSI-TESTS, so we can no longer use the value of the ABCL.TEST.ANSI:*ANSI-TESTS-DIRECTORY*. We now do this via a relative pathname of the form '../ansi-tests/' to the location of 'abcl.asd' file, whereas our api previously suggested that one could set the contents of ABCL.TEST.ANSI:*ANSI-TESTS-DIRECTORY* to an arbitrary pathname. This fixes the location of the ANSI-TESTS on the filesystem to be a sibling directory named 'ansi-tests' to the truename of the directory containing 'abcl.asd'. I tried to add some sort of :before method to either the ASDF:LOAD-OP or the ASDF:COMPILE-OP for the ANSI-RT definition, but assuming that the source named in an system definition exists locally seems too baked into ASDF2 to be cleanly intercepted. Modified: trunk/abcl/abcl.asd trunk/abcl/test/lisp/ansi/abcl-ansi.lisp trunk/abcl/test/lisp/ansi/packages.lisp Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd Fri May 4 02:14:24 2012 (r13924) +++ trunk/abcl/abcl.asd Fri May 4 06:48:56 2012 (r13925) @@ -66,15 +66,42 @@ "Invoke tests with (asdf:oos 'asdf:test-op :abcl-test-lisp)." (funcall (intern (symbol-name 'run) :abcl.test.lisp))) +;;;; +;;;; ASDF definitions and the ANSI-TEST +;;;; + +;;; We refer to the ANSI-TESTS source tree, which isn't shipped as +;;; part of ABCL, but may be obtained at +;;; . + +;;; We currently require that the ANSI-TESTS to be in a sibling +;;; directory named "ansi-tests" which should be manually synced with +;;; the contents of the SVN repository listed above. + +;;; The ASDF definition for ABCL.TEST.ANSI defines VERIFY-ANSI-TESTS +;;; which provides a more useful diagnostic, but I can't seem to find +;;; a way to hook this into the ASDF:LOAD-OP phase +(defsystem :ansi-rt + :description "Enapsulation of the REGRESSION-TEST framework use by ~ +the ANSI test suite, so that we may build on its 'API'. + +Requires that the contents of ~ +be in a directory named '../ansi-test/'." + :pathname "../ansi-tests/" ;;; NB works when loaded from ASDF but not with a naked EVAL + :default-component-class cl-source-file.lsp + :components ((:file "rt-package") + (:file "rt" :depends-on (rt-package)))) + (defsystem :ansi-interpreted :version "1.2" - :description "Test ABCL with the interpreted ANSI tests" :components + :description "Test ABCL with the interpreted ANSI tests." + :depends-on (ansi-rt) :components ((:module ansi-tests :pathname "test/lisp/ansi/" :components ((:file "packages") (:file "abcl-ansi" :depends-on ("packages")) (:file "parse-ansi-errors" :depends-on ("abcl-ansi")))))) (defmethod perform :before ((o test-op) (c (eql (find-system :ansi-interpreted)))) - (load-system :ansi-interpreted)) + (load-system :ansi-interpreted)) (defmethod perform :after ((o load-op) (c (eql (find-system :ansi-interpreted)))) (funcall (intern (symbol-name 'load-tests) :abcl.test.ansi))) @@ -83,9 +110,10 @@ (funcall (intern (symbol-name 'run) :abcl.test.ansi) :compile-tests nil)) - (defsystem :ansi-compiled :version "1.2" - :description "Test ABCL with the compiled ANSI tests." :components + :description "Test ABCL with the compiled ANSI tests." + :depends-on (ansi-rt) + :components ((:module ansi-tests :pathname "test/lisp/ansi/" :components ((:file "packages") (:file "abcl-ansi" :depends-on ("packages")) Modified: trunk/abcl/test/lisp/ansi/abcl-ansi.lisp ============================================================================== --- trunk/abcl/test/lisp/ansi/abcl-ansi.lisp Fri May 4 02:14:24 2012 (r13924) +++ trunk/abcl/test/lisp/ansi/abcl-ansi.lisp Fri May 4 06:48:56 2012 (r13925) @@ -36,8 +36,7 @@ (probe-file *ansi-tests-directory*) (error 'file-error "Failed to find the GCL ANSI tests in '~A'. Please -locally obtain ~A, and set the value of *ANSI-TESTS-DIRECTORY* to that -location." +locally obtain ~A, and place it in a sibling directory to the ABCL source named '../ansi-tests/'" *ansi-tests-directory* *ansi-tests-master-source-location*))) Modified: trunk/abcl/test/lisp/ansi/packages.lisp ============================================================================== --- trunk/abcl/test/lisp/ansi/packages.lisp Fri May 4 02:14:24 2012 (r13924) +++ trunk/abcl/test/lisp/ansi/packages.lisp Fri May 4 06:48:56 2012 (r13925) @@ -7,7 +7,14 @@ #:clean-tests #:full-report #:report #:parse) - (:import-from #:rt #:do-test #:do-test #:do-tests)) + ;; This should be REGRESSION-TEST included with the ANSI-TESTS, but + ;; it is possible that the user may have included a slightly + ;; different version from say Quicklisp. + (:import-from #:rt + #:pend #:name + #:*entries* + #:do-test #:do-tests + #:do-entries)) From mevenson at common-lisp.net Fri May 4 13:52:34 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 04 May 2012 06:52:34 -0700 Subject: [armedbear-cvs] r13926 - trunk/abcl/test/lisp/ansi Message-ID: Author: mevenson Date: Fri May 4 06:52:33 2012 New Revision: 13926 Log: ansi-tests: Export DO-TESTS-MATCHING. Modified: trunk/abcl/test/lisp/ansi/packages.lisp Modified: trunk/abcl/test/lisp/ansi/packages.lisp ============================================================================== --- trunk/abcl/test/lisp/ansi/packages.lisp Fri May 4 06:48:56 2012 (r13925) +++ trunk/abcl/test/lisp/ansi/packages.lisp Fri May 4 06:52:33 2012 (r13926) @@ -3,10 +3,11 @@ (:nicknames #:ansi-tests #:abcl-ansi-tests #:gcl-ansi) (:export #:run #:verify-ansi-tests - #:load-tests - #:clean-tests + #:do-tests-matching + #:load-tests + #:clean-tests #:full-report - #:report #:parse) + #:report #:parse) ;; This should be REGRESSION-TEST included with the ANSI-TESTS, but ;; it is possible that the user may have included a slightly ;; different version from say Quicklisp. @@ -15,9 +16,3 @@ #:*entries* #:do-test #:do-tests #:do-entries)) - - - - - - From mevenson at common-lisp.net Sat May 5 07:02:06 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 05 May 2012 00:02:06 -0700 Subject: [armedbear-cvs] r13927 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat May 5 00:02:01 2012 New Revision: 13927 Log: Provide text of last signalled error when *CURRENT-ERROR-DEPTH* is exceeded. Modified: trunk/abcl/src/org/armedbear/lisp/signal.lisp Modified: trunk/abcl/src/org/armedbear/lisp/signal.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/signal.lisp Fri May 4 06:52:33 2012 (r13926) +++ trunk/abcl/src/org/armedbear/lisp/signal.lisp Sat May 5 00:02:01 2012 (r13927) @@ -67,8 +67,8 @@ (let ((*current-error-depth* (1+ *current-error-depth*))) (cond ((> *current-error-depth* *maximum-error-depth*) (%format *debug-io* - "~%Maximum error depth exceeded (~D nested errors).~%" - *current-error-depth*) + "~%Maximum error depth exceeded (~D nested errors) with '~A'.~%" + *current-error-depth* condition) (if (fboundp 'internal-debug) (internal-debug) (quit))) From rschlatte at common-lisp.net Sat May 5 14:05:31 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 05 May 2012 07:05:31 -0700 Subject: [armedbear-cvs] r13928 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat May 5 07:05:28 2012 New Revision: 13928 Log: Better error reporting involving partially-initialized class metaobjects 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 Sat May 5 00:02:01 2012 (r13927) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Sat May 5 07:05:28 2012 (r13928) @@ -52,7 +52,13 @@ (print-unreadable-object (class stream :identity t) (format stream "~S ~S" (class-name (class-of class)) - (class-name class))) + ;; Handle partially-initialized class metaobjects + ;; gracefully; useful for error reporting. + (cond ((not (slot-exists-p class 'name)) + "(a class object without name slot)") + ((not (slot-boundp class 'name)) + "(a class object with unset name)") + (t (class-name class))))) class) (defmethod print-object ((gf generic-function) stream) From rschlatte at common-lisp.net Sat May 5 14:12:14 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 05 May 2012 07:12:14 -0700 Subject: [armedbear-cvs] r13929 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat May 5 07:12:13 2012 New Revision: 13929 Log: Re-enable class forward definitions. ... add an additional clause to validate-superclass, allowing forward referenced classes as superclasses in all cases. Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat May 5 07:05:28 2012 (r13928) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat May 5 07:12:13 2012 (r13929) @@ -27,6 +27,11 @@ (and (eql (class-of class) +the-funcallable-standard-class+) (eql (class-of superclass) +the-standard-class+))))) +;;; This is against the letter of the MOP, but very much in its spirit. +(defmethod validate-superclass ((class class) + (superclass forward-referenced-class)) + t) + (defmethod shared-initialize :before ((instance class) slot-names &key direct-superclasses From rschlatte at common-lisp.net Sat May 5 19:48:17 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 05 May 2012 12:48:17 -0700 Subject: [armedbear-cvs] r13930 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat May 5 12:48:16 2012 New Revision: 13930 Log: Revert previous print-object change. ... better to find the root causes and fix them. 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 Sat May 5 07:12:13 2012 (r13929) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Sat May 5 12:48:16 2012 (r13930) @@ -50,15 +50,7 @@ (defmethod print-object ((class class) stream) (print-unreadable-object (class stream :identity t) - (format stream "~S ~S" - (class-name (class-of class)) - ;; Handle partially-initialized class metaobjects - ;; gracefully; useful for error reporting. - (cond ((not (slot-exists-p class 'name)) - "(a class object without name slot)") - ((not (slot-boundp class 'name)) - "(a class object with unset name)") - (t (class-name class))))) + (format stream "~S ~S" (class-name (class-of class)) (class-name class))) class) (defmethod print-object ((gf generic-function) stream) From mevenson at common-lisp.net Sun May 6 13:37:35 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 06 May 2012 06:37:35 -0700 Subject: [armedbear-cvs] r13931 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun May 6 06:37:33 2012 New Revision: 13931 Log: Fixes #196: STABLE-SORT is only stable for lists. Somewhat kludgily fix the macrology submitted by Jorge Tavares to pass all the newly failing ANSI tests introduced. The macrology of MERGE-VECTORS-BODY and MERGE-SORT-BODY required that the sequences were of type SIMPLE-VECTOR. But somehow, MERGE-SORT-BODY was not working when asked to stable sort sequences of type BIT-VECTOR or STRING, both of which are subtypes of VECTOR but not SIMPLE-VECTOR. Modified: trunk/abcl/src/org/armedbear/lisp/sort.lisp Modified: trunk/abcl/src/org/armedbear/lisp/sort.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/sort.lisp Sat May 5 12:48:16 2012 (r13930) +++ trunk/abcl/src/org/armedbear/lisp/sort.lisp Sun May 6 06:37:33 2012 (r13931) @@ -52,6 +52,10 @@ ;;; - the merge-vectors algorithm is inspired from the CCL base code ;;; +;;; http://trac.common-lisp.net/armedbear/ticket/196 +;;; TODO Restore the optimization for SIMPLE-VECTOR types by +;;; conditionally using aref/svref instead of always using AREF + (defmacro merge-vectors-body (type ref a start-a end-a b start-b end-b aux start-aux predicate &optional key) (let ((i-a (gensym)) (i-b (gensym)) @@ -95,7 +99,8 @@ (loop (if (funcall ,predicate ,k-b ,k-a) (progn - (setf (svref ,aux ,i-aux) ,v-b +;; (setf (svref ,aux ,i-aux) ,v-b ;; FIXME Ticket #196 + (setf (aref ,aux ,i-aux) ,v-b ,i-aux (+ ,i-aux 1) ,i-b (+ ,i-b 1)) (when (= ,i-b ,end-b) (return)) @@ -104,7 +109,8 @@ `(,k-b (funcall ,key ,v-b)) `(,k-b ,v-b)))) (progn - (setf (svref ,aux ,i-aux) ,v-a +;; (setf (svref ,aux ,i-aux) ,v-a ;; FIXME Ticket #196 + (setf (aref ,aux ,i-aux) ,v-a ,i-aux (+ ,i-aux 1) ,i-a (+ ,i-a 1)) (when (= ,i-a ,end-a) @@ -118,7 +124,8 @@ `(,k-a (funcall ,key ,v-a)) `(,k-a ,v-a)))))))) (loop - (setf (svref ,aux ,i-aux) ,v-a +;; (setf (svref ,aux ,i-aux) ,v-a ;; FIXME Ticket #196 + (setf (aref ,aux ,i-aux) ,v-a ,i-a (+ ,i-a 1)) (when (= ,i-a ,end-a) (return)) (setf ,v-a (,ref ,a ,i-a) @@ -156,7 +163,8 @@ `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence ,mid ,end ,aux ,start ,predicate))))) (let ((,maux (make-array ,mend))) - (declare (type simple-vector ,maux)) +;; (declare (type simple-vector ,maux)) + (declare (type vector ,maux)) (,merge-sort-call ,msequence ,mstart ,mend ,mpredicate ,mkey ,maux nil)))))) (defun merge-sort-vectors (sequence predicate key) From mevenson at common-lisp.net Sun May 6 14:41:08 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 06 May 2012 07:41:08 -0700 Subject: [armedbear-cvs] r13932 - trunk/abcl Message-ID: Author: mevenson Date: Sun May 6 07:41:07 2012 New Revision: 13932 Log: abcl.properties.in: note the specificity of options with Oracle HotSpot JVM. Modified: trunk/abcl/abcl.properties.in Modified: trunk/abcl/abcl.properties.in ============================================================================== --- trunk/abcl/abcl.properties.in Sun May 6 06:37:33 2012 (r13931) +++ trunk/abcl/abcl.properties.in Sun May 6 07:41:07 2012 (r13932) @@ -13,8 +13,12 @@ #abcl.compile.lisp.skip=true # java.options sets the Java options in the abcl wrapper scripts +# +# See +# http://www.oracle.com/technetwork/java/javase/tech/vmoptions-jsp-140102.html +# for options for the Oracle HotSpot JVM -# Examples: +# HotSpot Examples: # Java7 on 64bit optimizations #java.options=-d64 -Xmx16g -XX:+CMSClassUnloadingEnabled -XX:MaxPermSize=2g @@ -22,8 +26,8 @@ # Set the JVM to use a maximum of 1GB of RAM (only works for 64bit JVMs) #java.options=-d64 -Xmx1g -# Use a default garbage collector on another -#java.options=-d64 -Xmx4g -XX:+PrintGCDetails -XX:+UnlockExperimentalVMOptions -XX:+UseG1GC -XX:MaxGCPauseMillis=100 +# Use the G1 garbage collector stablized with jdk1.7.0_04 +#java.options=-d64 -Xmx4g -XX:+PrintGCDetails -XX:+UseG1GC # Use a separate concurrent GC thread (java-1.6_14 or later) #java.options=-d64 -Xmx8g -XX:+UseConcMarkSweepGC From mevenson at common-lisp.net Mon May 14 08:15:50 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 14 May 2012 01:15:50 -0700 Subject: [armedbear-cvs] r13933 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Mon May 14 01:15:49 2012 New Revision: 13933 Log: doc: include the package qualification of referenced symbols. Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Sun May 6 07:41:07 2012 (r13932) +++ trunk/abcl/doc/manual/abcl.tex Mon May 14 01:15:49 2012 (r13933) @@ -10,7 +10,7 @@ \title{Armed Bear Common Lisp User Manual} \date{Version 1.1.0-dev\\ \smallskip -March 3, 2012} +May 14, 2012} \author{Mark Evenson \and Erik H\"{u}lsmann \and Rudolf Schlatte \and Alessio Stalla \and Ville Voutilainen} @@ -820,13 +820,13 @@ \label{EXTENSIONS:JAR-PATHNAME} \index{JAR-PATHNAME} -Both \code{URL-PATHNAME} and \code{JAR-PATHNAME} may be used anywhere +Both \code{EXT:URL-PATHNAME} and \code{EXT:JAR-PATHNAME} may be used anywhere a \code{CL:PATHNAME} is accepted with the following caveats: \begin{itemize} -\item A stream obtained via OPEN on a URL-PATHNAME cannot be the - target of write operations. +\item A stream obtained via \code{CL:OPEN} on a \code{CL:URL-PATHNAME} + cannot be the target of write operations. \index{URI} \item No canonicalization is performed on the underlying \textsc{URI} @@ -846,7 +846,7 @@ \end{itemize} -The implementation of \code{URL-PATHNAME} allows the \textsc{ABCL} +The implementation of \code{EXT:URL-PATHNAME} allows the \textsc{ABCL} user to dynamically load code from the network. For example, Quicklisp (\cite{quicklisp}) may be completely installed from the REPL as the single form: From mevenson at common-lisp.net Mon May 14 08:15:52 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 14 May 2012 01:15:52 -0700 Subject: [armedbear-cvs] r13934 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Mon May 14 01:15:51 2012 New Revision: 13934 Log: abcl-test-lisp: update test jar loaded via http to fasl version 39. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Mon May 14 01:15:49 2012 (r13933) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Mon May 14 01:15:51 2012 (r13934) @@ -42,6 +42,8 @@ (print form s))))) (defun jar-file-init () + "Create the jar archives used for testing. +Returns the two values of the pathnames of the created archives." (let* ((temp-file (java:jcall "getAbsolutePath" (java:jstatic "createTempFile" "java.io.File" "jar" "tmp"))) (temp-dir (make-pathname :directory (append @@ -102,7 +104,8 @@ (ensure-directories-exist *tmp-directory-whitespace*) (setf *tmp-jar-path-whitespace* (merge-pathnames "baz.jar" *tmp-directory-whitespace*)) - (cl-fad-copy-file *tmp-jar-path* *tmp-jar-path-whitespace*)))) + (cl-fad-copy-file *tmp-jar-path* *tmp-jar-path-whitespace*))) + (values *tmp-jar-path* *tmp-jar-path-whitespace*)) (defun clean-jar-tests () (when (probe-file *tmp-directory*) @@ -199,7 +202,7 @@ t) (defparameter *url-jar-pathname-base* - "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20110610a.jar!/") + "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20120514a.jar!/") (defmacro load-url-relative (path) `(load (format nil "~A~A" *url-jar-pathname-base* ,path))) From mevenson at common-lisp.net Mon May 14 08:15:54 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 14 May 2012 01:15:54 -0700 Subject: [armedbear-cvs] r13935 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Mon May 14 01:15:53 2012 New Revision: 13935 Log: abcl-test-lisp: rename DO-MATCHING to DO-TESTS-MATCHING. Use the same name as defined in ANSI-TESTS. Modified: trunk/abcl/test/lisp/abcl/package.lisp Modified: trunk/abcl/test/lisp/abcl/package.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/package.lisp Mon May 14 01:15:51 2012 (r13934) +++ trunk/abcl/test/lisp/abcl/package.lisp Mon May 14 01:15:53 2012 (r13935) @@ -3,12 +3,14 @@ (:nicknames "ABCL-TEST-LISP" "ABCL-TEST") (:export #:run - #:do-matching #:run-matching #:do-test #:do-tests + #:do-tests-matching ;; previously in file-system-tests.lisp #:pathnames-equal-p #:run-shell-command #:copy-file #:make-symbolic-link #:touch #:make-temporary-directory #:delete-directory-and-files + ;;; Deprecated + #:do-matching #:run-matching )) (in-package #:abcl.test.lisp) @@ -27,7 +29,7 @@ ;;; XXX move this into test-utilities.lisp? (defvar *last-run-matching* "url-pathname") -(defun do-matching (&optional (match *last-run-matching*)) +(defun do-tests-matching (&optional (match *last-run-matching*)) "Run all tests in suite whose symbol contains MATCH in a case-insensitive manner." (setf *last-run-matching* match) (let* ((matching (string-upcase match)) @@ -42,7 +44,8 @@ (abcl-rt::do-entries t))) ;;; Deprecated -(setf (symbol-function 'run-matching) #'do-matching) +(setf (symbol-function 'run-matching) #'do-tests-matching) +(setf (symbol-function 'do-matching) #'do-tests-matching) From mevenson at common-lisp.net Wed May 16 09:13:12 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 16 May 2012 02:13:12 -0700 Subject: [armedbear-cvs] r13936 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Wed May 16 02:13:11 2012 New Revision: 13936 Log: abcl-test-lisp: add test for ticket #199. Fix test for tciekt #205. Modified: trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Mon May 14 01:15:53 2012 (r13935) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Wed May 16 02:13:11 2012 (r13936) @@ -104,10 +104,26 @@ (string= result docstring)) t) - - +;;; http://trac.common-lisp.net/armedbear/ticket/205 (deftest bugs.with-constant-signature.1 - (with-constant-signature ((substring "substring")) - (substring "some string" 2)) + (progn + (require :abcl-contrib) + (require :jss) + (jss:with-constant-signature ((substring "substring")) + (substring "some string" 2))) t) + +;;; http://trac.common-lisp.net/armedbear/ticket/199 +(deftest bugs.clos.aux.1 + ;;; XXX possible collision with previously defined names + (progn + (defclass room () + ((decorators :reader room-decorators))) + (defgeneric decorators (room)) + (defmethod decorators ((room room) + &aux (d (decorators room))) + d) + (decorators (make-instance 'room))) + t) + From mevenson at common-lisp.net Wed May 16 12:10:07 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 16 May 2012 05:10:07 -0700 Subject: [armedbear-cvs] r13937 - in trunk/abcl: contrib/jss test/lisp/abcl Message-ID: Author: mevenson Date: Wed May 16 05:10:06 2012 New Revision: 13937 Log: jss: fix ticket #205 JSS:WITH-CONSTANT-SIGNATURE. Add more docstrings to JSS. JAVA-CLASS-METHOD-NAMES is now a synonym for JSS. Modified: trunk/abcl/contrib/jss/compat.lisp trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/jss.asd trunk/abcl/contrib/jss/packages.lisp trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/contrib/jss/compat.lisp ============================================================================== --- trunk/abcl/contrib/jss/compat.lisp Wed May 16 02:13:11 2012 (r13936) +++ trunk/abcl/contrib/jss/compat.lisp Wed May 16 05:10:06 2012 (r13937) @@ -4,6 +4,7 @@ "Whether backwards compatibility with JSS's use of CL-USER has been enabled.") (defun ensure-compatibility () + "Ensure backwards compatibility with JSS's use of CL-USER." (require 'abcl-asdf) (loop :for symbol :in '("add-directory-jars-to-class-path" "need-to-add-directory-jar?") Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Wed May 16 02:13:11 2012 (r13936) +++ trunk/abcl/contrib/jss/invoke.lisp Wed May 16 05:10:06 2012 (r13937) @@ -1,7 +1,7 @@ ;; invoke.lisp v2.0 ;; ;; Copyright (C) 2005 Alan Ruttenberg -;; Copyright (C) 2011 Mark Evenson +;; Copyright (C) 2011-2 Mark Evenson ;; ;; Since most of this code is derivative of the Jscheme System, it is ;; licensed under the same terms, namely: @@ -122,11 +122,15 @@ (in-package :jss) (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *do-auto-imports* t)) + (defvar *do-auto-imports* t + "Whether to automatically introspect all Java classes on the classpath when JSS is loaded.")) (defvar *imports-resolved-classes* (make-hash-table :test 'equal)) (defun find-java-class (name) + "Returns the java.lang.Class representation of NAME. + +NAME can either string or a symbol according to the usual JSS conventions." (jclass (maybe-resolve-class-against-imports name))) (defmacro invoke-add-imports (&rest imports) @@ -176,42 +180,20 @@ (apply #'jstatic method object-as-class args) (apply #'jcall method object args)))))) -;;; Method name as String --> String | Symbol --> jmethod -(defvar *methods-cache* (make-hash-table :test #'equal)) - -(defun get-jmethod (method object) - (when (gethash method *methods-cache*) - (gethash - (if (symbolp object) (lookup-class-name object) (jobject-class object)) - (gethash method *methods-cache*)))) - -(defun set-jmethod (method object jmethod) - (unless (gethash method *methods-cache*) - (setf (gethash method *methods-cache*) (make-hash-table :test #'equal))) - (setf - (gethash - (if (symbolp object) (lookup-class-name object) (jobject-class object)) - (gethash method *methods-cache*)) - jmethod)) - (defconstant +set-accessible+ (jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean")) -;;; TODO optimize me! (defun invoke-find-method (method object args) - (let ((jmethod (get-jmethod method object))) - (unless jmethod - (setf jmethod - (if (symbolp object) + (let ((result + (if (symbolp object) ;;; static method - (apply #'jmethod (lookup-class-name object) - method (mapcar #'jobject-class args)) + (apply #'jmethod (lookup-class-name object) + method (mapcar #'jobject-class args)) ;;; instance method - (apply #'jresolve-method - method object args))) - (jcall +set-accessible+ jmethod +true+) - (set-jmethod method object jmethod)) - jmethod)) + (apply #'jresolve-method + method object args)))) + (jcall +set-accessible+ result +true+) + result)) ;; This is the reader macro for java methods. it translates the method ;; into a lambda form that calls invoke. Which is nice because you @@ -232,6 +214,16 @@ (set-dispatch-macro-character #\# #\" 'read-invoke)) (defmacro with-constant-signature (fname-jname-pairs &body body) + "Expand all references to FNAME-JNAME-PAIRS in BODY into static function calls promising that the same function bound in the FNAME-JNAME-PAIRS will be invoked with the same argument signature. + +FNAME-JNAME-PAIRS is a list of (symbol function &optional raw) +elements where symbol will be the symbol bound to the method named by +the string function. If the optional parameter raw is non-nil, the +result will be the raw JVM object, uncoerced by the usual conventions. + +Use this macro if you are making a lot of calls and +want to avoid the overhead of the dynamic dispatch." + (if (null fname-jname-pairs) `(progn , at body) (destructuring-bind ((fname jname &optional raw) &rest ignore) fname-jname-pairs @@ -259,7 +251,6 @@ (jclass "java.lang.String")) (jclass "java.util.regex.Pattern") ".*?([^.]*)$"))) - (last-name (let ((matcher (#0"matcher" last-name-pattern name))) (#"matches" matcher) @@ -308,6 +299,7 @@ )))) (defun jar-import (file) + "Import all the Java classes contained in the pathname FILE into the JSS dynamic lookup cache." (when (probe-file file) (loop for (name . full-class-name) in (get-all-jar-classnames file) do @@ -315,6 +307,9 @@ :test 'equal)))) (defun new (class-name &rest args) + "Invoke the Java constructor for CLASS-NAME with ARGS. + +CLASS-NAME may either be a symbol or a string according to the usual JSS conventions." (invoke-restargs 'new class-name args)) (defvar *running-in-osgi* (ignore-errors (jclass "org.osgi.framework.BundleActivator"))) @@ -404,6 +399,7 @@ (do-auto-imports))) (defun japropos (string) +"Output the names of all Java class names loaded in the current process which match STRING.." (setq string (string string)) (let ((matches nil)) (maphash (lambda(key value) @@ -425,12 +421,21 @@ (remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getMethods" (find-java-class class))) :test 'equal) (ignore-errors (remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getConstructors" (find-java-class class))) :test 'equal)))) -(defun jcmn (class &optional full) - (if full +(defun java-class-method-names (class &optional stream) + "Return a list of the public methods encapsulated by the JVM CLASS. + +If STREAM non-nil, output a verbose description to the named output stream. + +CLASS may either be a string naming a fully qualified JVM class in dot +notation, or a symbol resolved against all class entries in the +current classpath." + (if stream (dolist (method (jclass-method-names class t)) - (format t "~a~%" method)) + (format stream "~a~%" method)) (jclass-method-names class))) +(setf (symbol-function 'jcmn) 'java-class-method-names) + (defun path-to-class (classname) (let ((full (lookup-class-name classname))) (#"toString" @@ -503,6 +508,7 @@ )) (defun classfiles-import (directory) + "Load all Java classes recursively contained under DIRECTORY in the current process." (setq directory (truename directory)) (loop for full-class-name in (all-classes-below-directory directory) for name = (#"replaceAll" full-class-name "^.*\\." "") @@ -525,6 +531,7 @@ :collecting (jcall "get" list i))) (defun jarray-to-list (jarray) + "Convert the Java array named by JARRARY into a Lisp list." (declare (optimize (speed 3) (safety 0))) (jlist-to-list (jstatic "asList" "java.util.Arrays" jarray))) @@ -545,6 +552,7 @@ ;; Contribution of Luke Hope. (Thanks!) (defun iterable-to-list (iterable) + "Return the items contained the java.lang.Iterable ITERABLE as a list." (declare (optimize (speed 3) (safety 0))) (let ((it (#"iterator" iterable))) (with-constant-signature ((hasmore "hasMoreElements") Modified: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- trunk/abcl/contrib/jss/jss.asd Wed May 16 02:13:11 2012 (r13936) +++ trunk/abcl/contrib/jss/jss.asd Wed May 16 05:10:06 2012 (r13937) @@ -3,7 +3,7 @@ (defsystem :jss :author "Alan Ruttenberg, Mark Evenson" - :version "3.0.2" + :version "3.0.3" :components ((:module base :pathname "" :serial t Modified: trunk/abcl/contrib/jss/packages.lisp ============================================================================== --- trunk/abcl/contrib/jss/packages.lisp Wed May 16 02:13:11 2012 (r13936) +++ trunk/abcl/contrib/jss/packages.lisp Wed May 16 05:10:06 2012 (r13937) @@ -11,7 +11,7 @@ #:invoke-add-imports #:find-java-class - #:jcmn + #:jcmn #:java-class-method-names #:japropos #:new Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Wed May 16 02:13:11 2012 (r13936) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Wed May 16 05:10:06 2012 (r13937) @@ -110,8 +110,8 @@ (require :abcl-contrib) (require :jss) (jss:with-constant-signature ((substring "substring")) - (substring "some string" 2))) - t) + (substring "01234" 2))) + "234") ;;; http://trac.common-lisp.net/armedbear/ticket/199 From mevenson at common-lisp.net Thu May 17 15:22:23 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 17 May 2012 08:22:23 -0700 Subject: [armedbear-cvs] r13938 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Thu May 17 08:22:21 2012 New Revision: 13938 Log: Additional test for &aux problems. See ticket #199. Modified: trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Wed May 16 05:10:06 2012 (r13937) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Thu May 17 08:22:21 2012 (r13938) @@ -126,4 +126,10 @@ d) (decorators (make-instance 'room))) t) + +(deftest bugs.aux.1 + ((lambda (a &aux (b (+ a 1))) + b) + 2) + 3) From mevenson at common-lisp.net Tue May 22 13:39:16 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 22 May 2012 06:39:16 -0700 Subject: [armedbear-cvs] r13939 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Tue May 22 06:39:13 2012 New Revision: 13939 Log: Fixes ticket #199: CL-METHOD failure for &AUX arguments. DEFGENERIC specified with &AUX arguments now signals an error. Removed badly conceived BUGS.AUX.1 test which blew up the stack due to recursively referencing itself in the &AUX init form. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu May 17 08:22:21 2012 (r13938) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue May 22 06:39:13 2012 (r13939) @@ -1403,6 +1403,12 @@ (push item options)))) (setf options (nreverse options) methods (nreverse methods)) + ;;; Since DEFGENERIC currently shares its argument parsing with + ;;; DEFMETHOD, we perform this check here. + (when (find '&aux lambda-list) + (error 'program-error + :format-control "&AUX is not allowed in a generic function lambda list: ~S" + :format-arguments (list lambda-list))) `(prog1 (%defgeneric ',function-name @@ -1981,8 +1987,13 @@ (lambda-list (%generic-function-lambda-list gf)) (exact (null (intersection lambda-list '(&rest &optional &key - &allow-other-keys &aux))))) - (if exact + &allow-other-keys)))) + (no-aux (null (some + (lambda (method) + (find '&aux (std-slot-value method 'sys::lambda-list))) + (sys:%generic-function-methods gf))))) + (if (and exact + no-aux) (cond ((= number-required 1) (cond Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Thu May 17 08:22:21 2012 (r13938) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Tue May 22 06:39:13 2012 (r13939) @@ -115,19 +115,7 @@ ;;; http://trac.common-lisp.net/armedbear/ticket/199 -(deftest bugs.clos.aux.1 - ;;; XXX possible collision with previously defined names - (progn - (defclass room () - ((decorators :reader room-decorators))) - (defgeneric decorators (room)) - (defmethod decorators ((room room) - &aux (d (decorators room))) - d) - (decorators (make-instance 'room))) - t) - -(deftest bugs.aux.1 +(deftest bugs.clos.aux.1 ((lambda (a &aux (b (+ a 1))) b) 2) From mevenson at common-lisp.net Wed May 23 13:01:05 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 23 May 2012 06:01:05 -0700 Subject: [armedbear-cvs] r13940 - in trunk/abcl: contrib/jss test/lisp/abcl Message-ID: Author: mevenson Date: Wed May 23 06:01:04 2012 New Revision: 13940 Log: Move JSS specific test under contrib. Invocations of the ABCL test suite as used for bisection with '--noinit --batch' fail to find abcl-contrib properly, so move the one contrib specific test for now. Added: trunk/abcl/contrib/jss/tests.lisp Modified: trunk/abcl/test/lisp/abcl/bugs.lisp Added: trunk/abcl/contrib/jss/tests.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jss/tests.lisp Wed May 23 06:01:04 2012 (r13940) @@ -0,0 +1,15 @@ +(require :abcl) +(require :abcl-test-lisp) +(require :abcl-contrib) +(require :jss) + +(in-package :abcl-test-lisp) + +;;; http://trac.common-lisp.net/armedbear/ticket/205 +(deftest jss.with-constant-signature.1 + (progn + (jss:with-constant-signature ((substring "substring")) + (substring "01234" 2))) + "234") + + Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Tue May 22 06:39:13 2012 (r13939) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Wed May 23 06:01:04 2012 (r13940) @@ -104,16 +104,6 @@ (string= result docstring)) t) -;;; http://trac.common-lisp.net/armedbear/ticket/205 -(deftest bugs.with-constant-signature.1 - (progn - (require :abcl-contrib) - (require :jss) - (jss:with-constant-signature ((substring "substring")) - (substring "01234" 2))) - "234") - - ;;; http://trac.common-lisp.net/armedbear/ticket/199 (deftest bugs.clos.aux.1 ((lambda (a &aux (b (+ a 1))) From mevenson at common-lisp.net Wed May 23 13:01:07 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 23 May 2012 06:01:07 -0700 Subject: [armedbear-cvs] r13941 - trunk/abcl/tools Message-ID: Author: mevenson Date: Wed May 23 06:01:06 2012 New Revision: 13941 Log: tools: Expand documentation for the bisect wrapper tool. Modified: trunk/abcl/tools/check.lisp Modified: trunk/abcl/tools/check.lisp ============================================================================== --- trunk/abcl/tools/check.lisp Wed May 23 06:01:04 2012 (r13940) +++ trunk/abcl/tools/check.lisp Wed May 23 06:01:06 2012 (r13941) @@ -6,11 +6,30 @@ (defun generate-bisect-wrapper () "Create 'check.sh', a script suitable for use with hg bisect. - To use, adjust the contents of the *TESTS* +To use, first clone hg clone https://evenson.not.org at code.google.com/p/abcl-dynamic-install/ ./abcl -&& cd abcl -&& hg bisect --reset && hg bisect --good && hg --command sh ./check.sh + cd abcl + +Then copy 'check.lisp' to this directory, as well as the bisect +wrapper script 'check.sh'. Adjust 'check.lisp' to raise an error if +the problem exists in a given changeset. + +Then reset the hg bisection data via: + + hg bisect --reset + +Mark the last known good and earliest known bad changeset via + + hg bisect --good + hg bisect --bad + +Then issue + + hg bisect --command sh ./check.sh + +which will churn through the revisions until it finds the earliest +known version in which the 'check.lisp' raises the error. " (let ((check.sh #p"check.sh")) (unless (probe-file check.sh) From mevenson at common-lisp.net Thu May 24 09:50:35 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 24 May 2012 02:50:35 -0700 Subject: [armedbear-cvs] r13942 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 24 02:50:34 2012 New Revision: 13942 Log: Implement EXT:MAKE-TEMP-DIRECTORY. Docstrings for MAKE-TEMP-DIRECTORY and MAKE-TEMP-PATHNAME Adjust the signature of the GENSYM primitive to allow its use in Java code. As far as I am concerned, all primitives should be public, as they constitute the API of the Java part of the implementation. Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java trunk/abcl/src/org/armedbear/lisp/Primitives.java Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Extensions.java Wed May 23 06:01:06 2012 (r13941) +++ trunk/abcl/src/org/armedbear/lisp/Extensions.java Thu May 24 02:50:34 2012 (r13942) @@ -257,8 +257,9 @@ } } - // ### make-temp-file => pathname - private static final Primitive MAKE_TEMP_FILE = new make_temp_file(); + public static final Primitive MAKE_TEMP_FILE = new make_temp_file(); + @DocString(name="make_temp_file", + doc="Create and return the pathname of a previously non-existent file.") private static class make_temp_file extends Primitive { make_temp_file() { super("make-temp-file", PACKAGE_EXT, true, ""); @@ -279,6 +280,32 @@ return NIL; } } + + public static final Primitive MAKE_TEMP_DIRECTORY = new make_temp_directory(); + @DocString(name="make_temp_directory", + doc="Create and return the pathname of a previously non-existent directory.") + private static class make_temp_directory extends Primitive { + make_temp_directory() { + super("make-temp-directory", PACKAGE_EXT, true, ""); + } + @Override + public LispObject execute() + { + try { + String tmpdir = System.getProperty("java.io.tmpdir"); + String name = Primitives.GENSYM.execute().getStringValue(); + File dir = new File(tmpdir, name); + File file = new File(dir, "xx"); + + if (file.mkdirs()) { + return new Pathname(dir + "/"); + } + } catch (Throwable t) { + Debug.trace(t); + } + return NIL; + } + } // ### interrupt-lisp private static final Primitive INTERRUPT_LISP = new interrupt_lisp(); Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Wed May 23 06:01:06 2012 (r13941) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Thu May 24 02:50:34 2012 (r13942) @@ -3071,7 +3071,7 @@ }; // ### gensym - private static final Primitive GENSYM = new pf_gensym(); + public static final Primitive GENSYM = new pf_gensym(); private static final class pf_gensym extends Primitive { pf_gensym() { super(Symbol.GENSYM, "&optional x"); From mevenson at common-lisp.net Thu May 24 11:11:42 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 24 May 2012 04:11:42 -0700 Subject: [armedbear-cvs] r13943 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 24 04:11:41 2012 New Revision: 13943 Log: Fix EXT:MAKE-TEMP-DIRECTORY not to create extra subdirectory 'xx'. Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Extensions.java Thu May 24 02:50:34 2012 (r13942) +++ trunk/abcl/src/org/armedbear/lisp/Extensions.java Thu May 24 04:11:41 2012 (r13943) @@ -295,9 +295,8 @@ String tmpdir = System.getProperty("java.io.tmpdir"); String name = Primitives.GENSYM.execute().getStringValue(); File dir = new File(tmpdir, name); - File file = new File(dir, "xx"); - if (file.mkdirs()) { + if (dir.mkdirs()) { return new Pathname(dir + "/"); } } catch (Throwable t) { From mevenson at common-lisp.net Thu May 24 11:11:43 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 24 May 2012 04:11:43 -0700 Subject: [armedbear-cvs] r13944 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 24 04:11:43 2012 New Revision: 13944 Log: Add docstring for SYS:UNZIP. Modified: trunk/abcl/src/org/armedbear/lisp/unzip.java Modified: trunk/abcl/src/org/armedbear/lisp/unzip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/unzip.java Thu May 24 04:11:41 2012 (r13943) +++ trunk/abcl/src/org/armedbear/lisp/unzip.java Thu May 24 04:11:43 2012 (r13944) @@ -42,12 +42,15 @@ import java.util.zip.ZipEntry; import java.util.zip.ZipFile; -// ### unzip pathname directory => unzipped_pathnames + at DocString(name="unzip", + args="pathname &optional directory => unzipped_pathnames", + doc="Unpack zip archive at PATHNAME returning a list of extracted pathnames.\nIf the optional DIRECTORY is specified, root the abstraction in that directory, otherwise use the current value of *DEFAULT-PATHNAME-DEFAULTS.") public final class unzip extends Primitive { public unzip() { - super("unzip", PACKAGE_SYS, true, "pathname &optional directory => unzipped_pathnames"); + super("unzip", PACKAGE_SYS, true, + "pathname &optional directory => unzipped_pathnames"); } @Override From mevenson at common-lisp.net Thu May 24 11:11:45 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 24 May 2012 04:11:45 -0700 Subject: [armedbear-cvs] r13945 - trunk/abcl/tools Message-ID: Author: mevenson Date: Thu May 24 04:11:44 2012 New Revision: 13945 Log: Start collecting routines for massaging fasl for analysis tools. Added: trunk/abcl/tools/fasl.lisp Added: trunk/abcl/tools/fasl.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/fasl.lisp Thu May 24 04:11:44 2012 (r13945) @@ -0,0 +1,17 @@ +(in-package :cl-user) + +(defun unpack (fasl-path &key (dir (make-temp-directory))) + "Unpack compressed fasl at FASL-PATH into 'org/armedbear/lisp' under DIR renaming *.cls to *.class." + (let ((pkg-dir (merge-pathnames "org/armedbear/lisp/" dir))) + (ensure-directories-exist dir) + (sys:unzip fasl-path dir) + (ensure-directories-exist pkg-dir) + (loop :for fasl :in (directory (merge-pathnames "*.cls" dir)) + :doing (rename-file + fasl + (make-pathname :defaults fasl + :directory (pathname-directory pkg-dir) + :type "class"))) + dir)) + + \ No newline at end of file From mevenson at common-lisp.net Thu May 24 11:26:06 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 24 May 2012 04:26:06 -0700 Subject: [armedbear-cvs] r13946 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 24 04:26:06 2012 New Revision: 13946 Log: Use java.io.File routine to guarantee uniquely non-existing pathname for EXT:MAKE-TEMP-DIRECTORY. Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Extensions.java Thu May 24 04:11:44 2012 (r13945) +++ trunk/abcl/src/org/armedbear/lisp/Extensions.java Thu May 24 04:26:06 2012 (r13946) @@ -292,13 +292,11 @@ public LispObject execute() { try { - String tmpdir = System.getProperty("java.io.tmpdir"); - String name = Primitives.GENSYM.execute().getStringValue(); - File dir = new File(tmpdir, name); - - if (dir.mkdirs()) { - return new Pathname(dir + "/"); - } + File dir = File.createTempFile("abcl", null); + dir.delete(); + if (dir.mkdirs()) { + return new Pathname(dir + "/"); + } } catch (Throwable t) { Debug.trace(t); } From rschlatte at common-lisp.net Thu May 24 17:50:30 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 24 May 2012 10:50:30 -0700 Subject: [armedbear-cvs] r13947 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu May 24 10:50:29 2012 New Revision: 13947 Log: change slot names to avoid symbols from CL - The mop-feature-tests suite tells us that using symbols from the CL package is not allowed. This means slots named DOCUMENTATION, TYPE, FUNCTION, GENERIC-FUNCTION, METHOD-COMBINATION, SLOT-DEFINITION need to be renamed. - Decreases missing standard features (as reported by mop-feature-tests) from 52 to 41. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.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/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Thu May 24 04:26:06 2012 (r13946) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Thu May 24 10:50:29 2012 (r13947) @@ -5561,7 +5561,7 @@ if (arg instanceof LispClass) return ((LispClass)arg).getDocumentation(); else - return ((StandardObject)arg).getInstanceSlotValue(Symbol.DOCUMENTATION); + return ((StandardObject)arg).getInstanceSlotValue(Symbol._DOCUMENTATION); } }; @@ -5579,7 +5579,7 @@ if (first instanceof LispClass) ((LispClass)first).setDocumentation(second); else - ((StandardObject)first).setInstanceSlotValue(Symbol.DOCUMENTATION, second); + ((StandardObject)first).setInstanceSlotValue(Symbol._DOCUMENTATION, second); return second; } }; Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Thu May 24 04:26:06 2012 (r13946) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Thu May 24 10:50:29 2012 (r13947) @@ -104,6 +104,19 @@ slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE; } + public SlotDefinition(LispObject name, LispObject readers, + Function initFunction, LispObject initargs) + { + this(); + Debug.assertTrue(name instanceof Symbol); + slots[SlotDefinitionClass.SLOT_INDEX_NAME] = name; + slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = initFunction; + slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = NIL; + slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = initargs; + slots[SlotDefinitionClass.SLOT_INDEX_READERS] = readers; + slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE; + } + public static StandardObject checkSlotDefinition(LispObject obj) { if (obj instanceof StandardObject) return (StandardObject)obj; return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION); @@ -278,7 +291,7 @@ } }; - private static final Primitive SET_SLOT_DEFINITION_INITARGS + static final Primitive SET_SLOT_DEFINITION_INITARGS = new pf_set_slot_definition_initargs(); @DocString(name="set-slot-definition-initargs", args="slot-definition initargs") Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java Thu May 24 04:26:06 2012 (r13946) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java Thu May 24 10:50:29 2012 (r13947) @@ -66,8 +66,8 @@ pkg.intern("ALLOCATION"), pkg.intern("ALLOCATION-CLASS"), pkg.intern("LOCATION"), - Symbol.TYPE, - Symbol.DOCUMENTATION + Symbol._TYPE, + Symbol._DOCUMENTATION }; setClassLayout(new Layout(this, instanceSlotNames, NIL)); //Set up slot definitions so that this class can be extended by users @@ -78,11 +78,16 @@ // The Java class SlotDefinition sets the location slot to NIL // in its constructor; here we make Lisp-side subclasses of // standard-*-slot-definition do the same. - LispObject locationSlot = slotDefinitions.nthcdr(8).car(); + LispObject locationSlot = slotDefinitions.nthcdr(SLOT_INDEX_LOCATION).car(); SlotDefinition.SET_SLOT_DEFINITION_INITFORM.execute(locationSlot, NIL); SlotDefinition.SET_SLOT_DEFINITION_INITFUNCTION.execute(locationSlot, StandardClass.constantlyNil); setDirectSlotDefinitions(slotDefinitions); setSlotDefinitions(slotDefinitions); + // Fix initargs of TYPE, DOCUMENTATION slots. + LispObject typeSlot = slotDefinitions.nthcdr(SLOT_INDEX_TYPE).car(); + SlotDefinition.SET_SLOT_DEFINITION_INITARGS.execute(typeSlot, list(internKeyword("TYPE"))); + LispObject documentationSlot = slotDefinitions.nthcdr(SLOT_INDEX_DOCUMENTATION).car(); + SlotDefinition.SET_SLOT_DEFINITION_INITARGS.execute(documentationSlot, list(internKeyword("DOCUMENTATION"))); setFinalized(true); } Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Thu May 24 04:26:06 2012 (r13946) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Thu May 24 10:50:29 2012 (r13947) @@ -83,7 +83,7 @@ symDirectDefaultInitargs, symDefaultInitargs, symFinalizedP, - Symbol.DOCUMENTATION), + Symbol._DOCUMENTATION), NIL) { @Override @@ -106,7 +106,7 @@ symDirectDefaultInitargs, symDefaultInitargs, symFinalizedP, - Symbol.DOCUMENTATION), + Symbol._DOCUMENTATION), NIL) { @Override @@ -292,13 +292,13 @@ @Override public LispObject getDocumentation() { - return getInstanceSlotValue(Symbol.DOCUMENTATION); + return getInstanceSlotValue(Symbol._DOCUMENTATION); } @Override public void setDocumentation(LispObject doc) { - setInstanceSlotValue(Symbol.DOCUMENTATION, doc); + setInstanceSlotValue(Symbol._DOCUMENTATION, doc); } @Override @@ -412,7 +412,9 @@ helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", constantlyNil), helperMakeSlotDefinition("DEFAULT-INITARGS", constantlyNil), helperMakeSlotDefinition("FINALIZED-P", constantlyNil), - helperMakeSlotDefinition("DOCUMENTATION", constantlyNil)); + new SlotDefinition(Symbol._DOCUMENTATION, + list(PACKAGE_MOP.intern("CLASS-DOCUMENTATION")), + constantlyNil, list(internKeyword("DOCUMENTATION")))); } @@ -739,20 +741,24 @@ STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_METHOD.setDirectSlotDefinitions( - list(new SlotDefinition(Symbol.GENERIC_FUNCTION, NIL, constantlyNil), + list(new SlotDefinition(Symbol._GENERIC_FUNCTION, NIL, constantlyNil, + list(internKeyword("GENERIC-FUNCTION"))), new SlotDefinition(Symbol.LAMBDA_LIST, NIL, constantlyNil), new SlotDefinition(Symbol.KEYWORDS, NIL, constantlyNil), new SlotDefinition(Symbol.OTHER_KEYWORDS_P, NIL, constantlyNil), new SlotDefinition(Symbol.SPECIALIZERS, NIL, constantlyNil), new SlotDefinition(Symbol.QUALIFIERS, NIL, constantlyNil), - new SlotDefinition(Symbol.FUNCTION, NIL, constantlyNil), + new SlotDefinition(Symbol._FUNCTION, NIL, constantlyNil, + list(internKeyword("FUNCTION"))), new SlotDefinition(Symbol.FAST_FUNCTION, NIL, constantlyNil), - new SlotDefinition(Symbol.DOCUMENTATION, 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))); + 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, @@ -767,9 +773,9 @@ list(new SlotDefinition(Symbol.NAME, list(Symbol.METHOD_COMBINATION_NAME), constantlyNil), - new SlotDefinition(Symbol.DOCUMENTATION, + new SlotDefinition(Symbol._DOCUMENTATION, list(Symbol.METHOD_COMBINATION_DOCUMENTATION), - constantlyNil))); + constantlyNil, list(internKeyword("DOCUMENTATION"))))); SHORT_METHOD_COMBINATION.setCPL(SHORT_METHOD_COMBINATION, METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Thu May 24 04:26:06 2012 (r13946) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Thu May 24 10:50:29 2012 (r13947) @@ -93,7 +93,7 @@ NIL; StandardObject method = (StandardObject)StandardClass.STANDARD_METHOD.allocateInstance(); - method.setInstanceSlotValue(Symbol.GENERIC_FUNCTION, this); + method.setInstanceSlotValue(Symbol._GENERIC_FUNCTION, this); method.setInstanceSlotValue(Symbol.LAMBDA_LIST, lambdaList); method.setInstanceSlotValue(Symbol.KEYWORDS, NIL); method.setInstanceSlotValue(Symbol.OTHER_KEYWORDS_P, NIL); @@ -103,9 +103,9 @@ // 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._FUNCTION, NIL); method.setInstanceSlotValue(Symbol.FAST_FUNCTION, function); - method.setInstanceSlotValue(Symbol.DOCUMENTATION, NIL); + method.setInstanceSlotValue(Symbol._DOCUMENTATION, NIL); slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = list(method); slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Thu May 24 04:26:06 2012 (r13946) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Thu May 24 10:50:29 2012 (r13947) @@ -63,10 +63,10 @@ pkg.intern("INITIAL-METHODS"), pkg.intern("METHODS"), pkg.intern("METHOD-CLASS"), - pkg.intern("METHOD-COMBINATION"), + pkg.intern("%METHOD-COMBINATION"), pkg.intern("ARGUMENT-PRECEDENCE-ORDER"), pkg.intern("CLASSES-TO-EMF-TABLE"), - Symbol.DOCUMENTATION + Symbol._DOCUMENTATION }; setClassLayout(new Layout(this, instanceSlotNames, NIL)); setFinalized(true); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Thu May 24 04:26:06 2012 (r13946) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Thu May 24 10:50:29 2012 (r13947) @@ -3162,8 +3162,12 @@ public static final Symbol FORMAT_CONTROL = PACKAGE_SYS.addInternalSymbol("FORMAT-CONTROL"); public static final Symbol FSET = PACKAGE_SYS.addInternalSymbol("FSET"); + public static final Symbol _FUNCTION = + PACKAGE_SYS.addInternalSymbol("%FUNCTION"); public static final Symbol FUNCTION_PRELOAD = PACKAGE_SYS.addInternalSymbol("FUNCTION-PRELOAD"); + public static final Symbol _GENERIC_FUNCTION = + PACKAGE_SYS.addInternalSymbol("%GENERIC-FUNCTION"); public static final Symbol INSTANCE = PACKAGE_SYS.addInternalSymbol("INSTANCE"); public static final Symbol KEYWORDS = @@ -3184,6 +3188,8 @@ 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 = @@ -3198,6 +3204,8 @@ PACKAGE_SYS.addInternalSymbol("SYSTEM-STREAM"); public static final Symbol STACK_FRAME = PACKAGE_SYS.addInternalSymbol("STACK-FRAME"); + public static final Symbol _TYPE = + PACKAGE_SYS.addInternalSymbol("%TYPE"); public static final Symbol LISP_STACK_FRAME = PACKAGE_SYS.addInternalSymbol("LISP-STACK-FRAME"); public static final Symbol JAVA_STACK_FRAME = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu May 24 04:26:06 2012 (r13946) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu May 24 10:50:29 2012 (r13947) @@ -211,7 +211,6 @@ funcallable-standard-class)))) (fixup-standard-class-hierarchy) - (defun no-applicable-method (generic-function &rest args) (error "There is no applicable method for the generic function ~S when called with arguments ~S." generic-function @@ -869,7 +868,7 @@ arguments declarations forms) (let ((instance (std-allocate-instance (find-class 'long-method-combination)))) (setf (std-slot-value instance 'sys::name) name) - (setf (std-slot-value instance 'documentation) documentation) + (setf (std-slot-value instance 'sys:%documentation) documentation) (setf (std-slot-value instance 'sys::lambda-list) lambda-list) (setf (std-slot-value instance 'method-group-specs) method-group-specs) (setf (std-slot-value instance 'args-lambda-list) args-lambda-list) @@ -887,7 +886,7 @@ (defun method-combination-documentation (method-combination) (check-type method-combination method-combination) - (std-slot-value method-combination 'documentation)) + (std-slot-value method-combination 'sys:%documentation)) (defun short-method-combination-operator (method-combination) (check-type method-combination short-method-combination) @@ -943,7 +942,7 @@ (let ((instance (std-allocate-instance (find-class 'short-method-combination)))) (setf (std-slot-value instance 'sys::name) ',name) - (setf (std-slot-value instance 'documentation) ',documentation) + (setf (std-slot-value instance 'sys:%documentation) ',documentation) (setf (std-slot-value instance 'operator) ',operator) (setf (std-slot-value instance 'identity-with-one-argument) ',identity-with-one-arg) @@ -1277,10 +1276,10 @@ ;;; AMOP pg. 218ff, will be redefined when generic functions are set up. (defun std-method-function (method) - (std-slot-value method 'cl:function)) + (std-slot-value method 'sys::%function)) (defun std-method-generic-function (method) - (std-slot-value method 'cl:generic-function)) + (std-slot-value method 'sys::%generic-function)) (defun std-method-specializers (method) (std-slot-value method 'sys::specializers)) @@ -1289,7 +1288,7 @@ (std-slot-value method 'sys::qualifiers)) (defun std-accessor-method-slot-definition (accessor-method) - (std-slot-value accessor-method 'sys:slot-definition)) + (std-slot-value accessor-method 'sys::%slot-definition)) ;;; Additional method readers (defun std-method-fast-function (method) @@ -1372,10 +1371,10 @@ (setf (std-slot-value method 'sys::qualifiers) new-value)) (defun method-documentation (method) - (std-slot-value method 'documentation)) + (std-slot-value method 'sys:%documentation)) (defun (setf method-documentation) (new-value method) - (setf (std-slot-value method 'documentation) new-value)) + (setf (std-slot-value method 'sys:%documentation) new-value)) ;;; defgeneric @@ -1869,8 +1868,8 @@ (setf (std-slot-value method 'sys::specializers) (canonicalize-specializers specializers)) (setf (method-documentation method) documentation) - (setf (std-slot-value method 'generic-function) nil) ; set by add-method - (setf (std-slot-value method 'function) function) + (setf (std-slot-value method 'sys::%generic-function) nil) ; set by add-method + (setf (std-slot-value method 'sys::%function) function) (setf (std-slot-value method 'sys::fast-function) fast-function) (setf (std-slot-value method 'sys::keywords) (getf analyzed-args :keywords)) (setf (std-slot-value method 'sys::other-keywords-p) @@ -1903,7 +1902,7 @@ (method-specializers method) nil))) (when old-method (std-remove-method gf old-method))) - (setf (std-slot-value method 'generic-function) gf) + (setf (std-slot-value method 'sys::%generic-function) gf) (push method (generic-function-methods gf)) (dolist (specializer (method-specializers method)) (add-direct-method specializer method)) @@ -1913,7 +1912,7 @@ (defun std-remove-method (gf method) (setf (generic-function-methods gf) (remove method (generic-function-methods gf))) - (setf (std-slot-value method 'generic-function) nil) + (setf (std-slot-value method 'sys::%generic-function) nil) (dolist (specializer (method-specializers method)) (remove-direct-method specializer method)) (finalize-standard-generic-function gf) @@ -2566,10 +2565,10 @@ (setf (std-slot-value method 'sys::specializers) (canonicalize-specializers specializers)) (setf (method-documentation method) documentation) - (setf (std-slot-value method 'generic-function) nil) - (setf (std-slot-value method 'function) function) + (setf (std-slot-value method 'sys::%generic-function) nil) + (setf (std-slot-value method 'sys::%function) function) (setf (std-slot-value method 'sys::fast-function) fast-function) - (setf (std-slot-value method 'sys:slot-definition) slot-definition) + (setf (std-slot-value method 'sys::%slot-definition) slot-definition) (setf (std-slot-value method 'sys::keywords) nil) (setf (std-slot-value method 'sys::other-keywords-p) nil) method)) @@ -3679,25 +3678,25 @@ (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-type slot-definition) - (slot-value slot-definition 'cl:type)))) + (slot-value slot-definition 'sys::%type)))) (atomic-defgeneric (setf slot-definition-type) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-type slot-definition value) - (setf (slot-value slot-definition 'cl:type) value)))) + (setf (slot-value slot-definition 'sys::%type) value)))) (atomic-defgeneric slot-definition-documentation (slot-definition) (:method ((slot-definition slot-definition)) (slot-definition-dispatch slot-definition (%slot-definition-documentation slot-definition) - (slot-value slot-definition 'cl:documentation)))) + (slot-value slot-definition 'sys:%documentation)))) (atomic-defgeneric (setf slot-definition-documentation) (value slot-definition) (:method (value (slot-definition slot-definition)) (slot-definition-dispatch slot-definition (set-slot-definition-documentation slot-definition value) - (setf (slot-value slot-definition 'cl:documentation) value)))) + (setf (slot-value slot-definition 'sys:%documentation) value)))) ;;; Conditions. From ehuelsmann at common-lisp.net Sun May 27 19:57:45 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 27 May 2012 12:57:45 -0700 Subject: [armedbear-cvs] r13948 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 27 12:57:44 2012 New Revision: 13948 Log: Fix file handle leak identified by Alex Mizrahi. 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 Thu May 24 10:50:29 2012 (r13947) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun May 27 12:57:44 2012 (r13948) @@ -97,12 +97,13 @@ (unless classfile (diag "Nil classfile argument passed to verify-load.") (return-from verify-load nil)) - (when - (= 0 (file-length (open classfile :direction :input))) - ;;; TODO hook into a real ABCL compiler condition hierarchy - (diag "Internal compiler error detected: Fasl contains ~ + (with-open-file (cf classfile :direction :input) + (when + (= 0 (file-length cf)) +;;; TODO hook into a real ABCL compiler condition hierarchy + (diag "Internal compiler error detected: Fasl contains ~ zero-length jvm classfile corresponding to ~A." classfile) - (return-from verify-load nil)) + (return-from verify-load nil))) #+nil (when (or force (> *safety* *speed*)) (diag "Testing compiled bytecode by loading classfile into JVM.") From mevenson at common-lisp.net Tue May 29 07:10:03 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 29 May 2012 00:10:03 -0700 Subject: [armedbear-cvs] r13949 - in trunk/abcl/contrib/jfli: . examples examples/swing examples/swt Message-ID: Author: mevenson Date: Tue May 29 00:10:01 2012 New Revision: 13949 Log: abcl-contrib: Add jfli. The Java Foreign Linker Interface (JFLI) provides an abstraction to manipulate Java classes from Armed Bear Common Lisp that has been ported to other Lisp implementations. Incorporated into ABCL from . Added: trunk/abcl/contrib/jfli/ trunk/abcl/contrib/jfli/README trunk/abcl/contrib/jfli/examples/ trunk/abcl/contrib/jfli/examples/swing/ trunk/abcl/contrib/jfli/examples/swing/README trunk/abcl/contrib/jfli/examples/swt/ trunk/abcl/contrib/jfli/examples/swt/README trunk/abcl/contrib/jfli/examples/swt/file.gif (contents, props changed) trunk/abcl/contrib/jfli/examples/swt/folder.gif (contents, props changed) trunk/abcl/contrib/jfli/jfli.asd Added: trunk/abcl/contrib/jfli/README ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jfli/README Tue May 29 00:10:01 2012 (r13949) @@ -0,0 +1,36 @@ +JFLI +==== + +The Java Foreign Linker Interface (JFLI) provides an abstraction to +manipulate Java classes from Armed Bear Common Lisp that has been +ported to other Lisp implementations. + +Incorporated into ABCL from . + + +README +------ + +jfli (http://jfli.sf.net) is a library that provides access to Java +from Lisp. jfli-abcl is jfli modified to work with ABCL +(http://armedbear-j.sf.net); it provides the same interface to Java, +but, since ABCL lives on the JVM, it doesn't need jni. + +jfli-abcl has an experimental NEW-CLASS macro that writes and loads a +Java class at runtime, and defines the usual jfli-like Lisp interface +to it. See the documentation of NEW-CLASS and the examples for the +syntax. If you want to use it, make sure that (1) asm.jar +(http://asm.objectweb.org) is in your classpath, and (2) the runtime +generated Java classes are in the Java package of the same name as the +Lisp package in which they're defined, like this: + +(in-package "FOO") +(new-class "FOO.MyClass" ...) + +Caveats: jfli-abcl inherits all the bugs from jfli; see the archives +of the jfli-users mailing list for a partial list. It probably also +adds some of its own. I'm particularly interested in the latter type. + +Please send (ABCL-specific) bug reports, suggestions, examples, +and whatever else you can think of, to asimon at math.bme.hu. + Added: trunk/abcl/contrib/jfli/examples/swing/README ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jfli/examples/swing/README Tue May 29 00:10:01 2012 (r13949) @@ -0,0 +1,10 @@ +This is a swing/jdbc example. + +To try it, (compile and) load table-gen.lisp and table.lisp +(you need to modify it a bit first if you're not using PostgreSQL), in +this order, then do + +(table:create-and-show-gui "select * from ") + +The cells are editable, so don't try it on an important db table. + Added: trunk/abcl/contrib/jfli/examples/swt/README ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jfli/examples/swt/README Tue May 29 00:10:01 2012 (r13949) @@ -0,0 +1,27 @@ +This example is a Lisp version of Explorer v9 from +http://www-106.ibm.com/developerworks/opensource/library/os-ecgui3/ +The gifs are from +ftp://www6.software.ibm.com/software/developer/library/os-ecgui3/examples.zip + +To use it, (optionally compile) and load swt9jfli-gen.lisp first, and +then swt9jfli.lisp. Start it with (swt0:main). + +But make sure first that besides asm.jar (http:/asm.objectweb.org), +the various swt-related jars are in your classpath. I start abcl like +this: + +/usr/java/jdk1.5.0/bin/java -cp /home/simon/java/j2/j/src/\ +:/usr/share/java/pg74.215.jdbc3.jar\ +:/home/simon/java/asm-1.5.1/lib/asm-1.5.1.jar\ +:/opt/home/simon/java/eclipse/plugins/org.eclipse.core.boot_2.1.3/boot.jar\ +:/opt/home/simon/java/eclipse/plugins/org.eclipse.core.runtime_2.1.1/runtime.jar\ +:/opt/home/simon/java/eclipse/plugins/org.eclipse.jface_2.1.3/jface.jar\ +:/opt/home/simon/java/eclipse/plugins/org.eclipse.jface.text_2.1.0/jfacetext.jar\ +:/opt/home/simon/java/eclipse/plugins/org.eclipse.swt.gtk_2.1.3/ws/gtk/swt.jar\ +:/opt/home/simon/java/eclipse/plugins/org.eclipse.swt.gtk_2.1.3/ws/gtk/swt-pi.jar\ + -Djava.library.path=/opt/home/simon/java/eclipse/plugins/org.eclipse.swt.gtk_2.1.3/os/linux/x86/\ +:/home/simon/java/jogl/\ + org.armedbear.lisp.Main "$@" + +If everything goes well, a window like +http://www.math.bme.hu/~asimon/lisp/swt.png should appear. Added: trunk/abcl/contrib/jfli/examples/swt/file.gif ============================================================================== Binary file. No diff available. Added: trunk/abcl/contrib/jfli/examples/swt/folder.gif ============================================================================== Binary file. No diff available. Added: trunk/abcl/contrib/jfli/jfli.asd ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jfli/jfli.asd Tue May 29 00:10:01 2012 (r13949) @@ -0,0 +1,5 @@ +(defpackage :jfli-system (:use :cl :asdf)) +(in-package :jfli-system) + +(defsystem jfli + :components ((:file "jfli"))) From mevenson at common-lisp.net Tue May 29 09:24:39 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 29 May 2012 02:24:39 -0700 Subject: [armedbear-cvs] r13950 - trunk/abcl/contrib/jfli Message-ID: Author: mevenson Date: Tue May 29 02:24:37 2012 New Revision: 13950 Log: jfli.lisp: https://github.com/mrohne/jfli/blob/master/jfli.lisp. Commit to initial JFLI implementation. Untested except for loading via: (cl:require :abcl-contrib) (cl:require :jfli) Added: trunk/abcl/contrib/jfli/jfli.lisp Added: trunk/abcl/contrib/jfli/jfli.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jfli/jfli.lisp Tue May 29 02:24:37 2012 (r13950) @@ -0,0 +1,1055 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Common Public License 1.0 (http://opensource.org/licenses/cpl.php) +; which can be found in the file CPL.TXT at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +; Ported to ABCL by asimon at math.bme.hu. +; Minor ABCL fixes by A. Vodonosov (avodonosov at yandex.ru). +; Ripped out CLOS mirror support + +(defpackage :jfli + (:use :common-lisp :java) + (:export + + :enable-java-proxies + + ;wrapper generation + :def-java-class + :get-jar-classnames + :dump-wrapper-defs-to-file + + ;object creation etc + :find-java-class + :new + :make-new + :jeq + + ;array support + :make-new-array + :jlength + :jref + :jref-boolean + :jref-byte + :jref-char + :jref-double + :jref-float + :jref-int + :jref-short + :jref-long + + ;proxy support + :new-proxy + :unregister-proxy + + )) + +(in-package :jfli) + +#+ignore +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +null+ (make-immediate-object nil :ref)) + (defconstant +false+ (make-immediate-object nil :boolean)) + (defconstant +true+ (make-immediate-object t :boolean))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun string-append (&rest strings) + (apply #'concatenate 'string (mapcar #'(lambda (s) (if (symbolp s) (symbol-name s) s)) strings))) + (defun intern-and-unexport (string package) + (multiple-value-bind (symbol status) + (find-symbol string package) + (when (and *compile-file-pathname* (eq status :external)) (unexport symbol package)) + (intern string package)))) + +(defun is-assignable-from (class-1 class-2) + (jcall (jmethod "java.lang.Class" "isAssignableFrom" "java.lang.Class") + class-2 class-1)) ;;not a typo + +(defun java-ref-p (x) + (java-object-p x)) + +(deftype java-ref () + '(satisfies java-ref-p)) + +(defun split-package-and-class (name) + (let ((p (position #\. name :from-end t))) + (unless p (error "must supply package-qualified classname")) + (values (subseq name 0 p) + (subseq name (1+ p))))) + +(defun is-name-of-primitive (s) + (member s '("boolean" "byte" "char" "short" "int" "long" "float" "double" "void") + :test #'string-equal)) + +(defun is-primitive-class (class) + (is-name-of-primitive (jclass-name class))) + +(defun convert-to-java-string (s) + (jnew (jconstructor "java.lang.String" "java.lang.String") s)) + +(defun convert-from-java-string (s) + (values s)) + +(define-symbol-macro boolean.type (jfield "java.lang.Boolean" "TYPE")) +(define-symbol-macro byte.type (jfield "java.lang.Byte" "TYPE")) +(define-symbol-macro character.type (jfield "java.lang.Character" "TYPE")) +(define-symbol-macro short.type (jfield "java.lang.Short" "TYPE")) +(define-symbol-macro integer.type (jfield "java.lang.Integer" "TYPE")) +(define-symbol-macro long.type (jfield "java.lang.Long" "TYPE")) +(define-symbol-macro float.type (jfield "java.lang.Float" "TYPE")) +(define-symbol-macro double.type (jfield "java.lang.Double" "TYPE")) +(define-symbol-macro string.type (jclass "java.lang.String")) +(define-symbol-macro object.type (jclass "java.lang.Object")) +(define-symbol-macro void.type (jfield "java.lang.Void" "TYPE")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ensure-package (name) + "find the package or create it if it doesn't exist" + (or (find-package name) + (make-package name :use '()))) + (intern "Object" (ensure-package "java.lang")) + (intern "String" (ensure-package "java.lang"))) + +(defun enumeration.hasmoreelements (enum) + (jcall (jmethod "java.util.Enumeration" "hasMoreElements") enum)) + +(defun enumeration.nextelement (enum) + (jcall (jmethod "java.util.Enumeration" "nextElement") enum)) + +(defmacro doenum ((e enum) &body body) + "jni-based, so not safe and not exported, but used by the implementation" + (let ((genum (gensym))) + `(let ((,genum ,enum)) + (do () + ((not (enumeration.hasmoreelements ,genum))) + (let ((,e (enumeration.nextelement ,genum))) + , at body))))) + +;probably insufficiently general, works as used here +(defmacro get-or-init (place init-form) + `(or ,place + (setf ,place ,init-form))) + + +(eval-when (:compile-toplevel) + (intern-and-unexport "OBJECT." "java.lang")) + +(defun get-ref (x) + "any function taking an object can be passed a raw java-ref ptr or a typed reference instance. +Will also convert strings for use as objects" + (typecase x + (java-ref x) + (string (convert-to-java-string x)) + (null nil) + ((or number character) x) + ;; avodonosov: otherwise clause + (otherwise x))) + +(defun is-same-object (obj1 obj2) + (equal obj1 obj2)) + +(defun jeq (obj1 obj2) + "are these 2 java objects the same object? Note that is not the same as Object.equals()" + (is-same-object (get-ref obj1) (get-ref obj2))) + + +;;;;;;;;;;;;;;;;;;;;;;;; names and symbols ;;;;;;;;;;;;;;;;;;;;;;; +#| +The library does a lot with names and symbols, needing at various times to: + - find stuff in Java - full names w/case required + - create hopefully non-conflicting packages and member names + +When you (def-java-class "java.lang.String") you get a bunch of symbols/names: +a package named '|java.lang| +a class-symbol '|java.lang|:STRING. (note the dot and case), + which can usually be used where a typename is required + it also serves as the name of the Lisp typed reference class for string + its symbol-value is the canonic-class-symbol (see below) +a canonic-class-symbol '|java.lang|::|String| + can be used to reconstitute the full class name + +I've started trying to flesh out the notion of a Java class designator, which can either be +the full class name as a string, the class-symbol, or one of :boolean, :int etc +|# + +(defun canonic-class-symbol (full-class-name) + "(\"java.lang.Object\") -> '|java.lang|:|Object|" + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern class (ensure-package package)))) + +(defun class-symbol (full-class-name) + "(\"java.lang.Object\") -> '|java.lang|:object." + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern (string-upcase (string-append class ".")) (ensure-package package)))) + +(defun unexported-class-symbol (full-class-name) + "(\"java.lang.Object\") -> '|java.lang|::object." + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern-and-unexport (string-upcase (string-append class ".")) (ensure-package package)))) + +(defun java-class-name (class-sym) + "inverse of class-symbol, only valid on class-syms created by def-java-class" + (let ((canonic-class-symbol (symbol-value class-sym))) + (string-append (package-name (symbol-package canonic-class-symbol)) + "." + canonic-class-symbol))) + +(defun member-symbol (full-class-name member-name) + "members are defined case-insensitively in case-sensitive packages, +prefixed by 'classname.' - +(member-symbol \"java.lang.Object\" \"toString\") -> '|java.lang|::OBJECT.TOSTRING" + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern (string-upcase (string-append class "." member-name)) (ensure-package package)))) + +(defun unexported-member-symbol (full-class-name member-name) + "members are defined case-insensitively in case-sensitive packages, +prefixed by 'classname.' - +(member-symbol \"java.lang.Object\" \"toString\") -> '|java.lang|::OBJECT.TOSTRING" + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern-and-unexport (string-upcase (string-append class "." member-name)) (ensure-package package)))) + +(defun constructor-symbol (full-class-name) + (member-symbol full-class-name "new")) + +(defun unexported-constructor-symbol (full-class-name) + (unexported-member-symbol full-class-name "new")) + +(defun get-java-class-ref (canonic-class-symbol) + "class-ref is cached on the plist of the canonic class symbol" + (get-or-init (get canonic-class-symbol :class-ref) + (let ((class-name (string-append (package-name + (symbol-package canonic-class-symbol)) + "." + canonic-class-symbol))) + (jclass class-name) + ))) + +(defun find-java-class (class-sym-or-string) + "Given a Java class designator, returns the Java Class object." + (ctypecase class-sym-or-string + (symbol (case class-sym-or-string + (:int integer.type) + (:char character.type) + (:long long.type) + (:float float.type) + (:boolean boolean.type) + (:short short.type) + (:double double.type) + (:byte byte.type) + (:object object.type) + (:void void.type) + (otherwise (get-java-class-ref class-sym-or-string)))) + (string (get-java-class-ref (canonic-class-symbol class-sym-or-string))))) + +;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| +In an effort to reduce the volume of stuff generated when wrapping entire libraries, +the wrappers just generate minimal stubs, which, if and when invoked at runtime, +complete the work of building thunking closures, so very little code is generated for +things never called (Java libraries have huge numbers of symbols). +Not sure if this approach matters, but that's how it works +|# + +(defun get-superclass-names (full-class-name) + (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name))) + (super (jclass-superclass class)) + (interfaces (jclass-interfaces class)) + (supers ())) + (loop for i across interfaces + do (push i supers)) + ;hmmm - where should the base class go in the precedence list? + ;is it more important than the interfaces? this says no + (if super + (push super supers) + (push (jclass "java.lang.Object") supers)) + (setf supers (nreverse supers)) + ;now we need to fix up order so more derived classes are first + ;but don't have a total ordering, so merge one at a time + (let (result) + (dolist (s supers) + (setf result (merge 'list result (list s) + (lambda (x y) + (is-assignable-from x y))))) + (mapcar #'jclass-name result)))) + +(defmacro def-java-class (full-class-name) + "Given the package-qualified, case-correct name of a java class, will generate +wrapper functions for its contructors, fields and methods." + (multiple-value-bind (pacakge class) (split-package-and-class full-class-name) + (declare (ignore class)) + (let* ((class-sym (unexported-class-symbol full-class-name)) + (defs + (list* + `(ensure-package ,pacakge) + ;;build a path from the simple class symbol to the canonic + `(defconstant ,class-sym ',(canonic-class-symbol full-class-name)) + `(export ',class-sym (symbol-package ',class-sym)) + `(def-java-constructors ,full-class-name) + `(def-java-methods ,full-class-name) + `(def-java-fields ,full-class-name) + (unless (string= full-class-name "java.lang.Object") + (let* ((supers (mapcar #'unexported-class-symbol (get-superclass-names full-class-name))) + (super-exports + (mapcar #'(lambda (class-sym) `(export ',class-sym (symbol-package ',class-sym))) + supers))) + (append (mapcar + (lambda (p) `(ensure-package ,(package-name p))) + (remove (symbol-package class-sym) + (remove-duplicates (mapcar #'symbol-package supers)))) + super-exports)))))) + `(locally , at defs)))) + +(defun jarfile.new (fn) + (jnew (jconstructor "java.util.jar.JarFile" "java.lang.String") fn)) + +(defun jarfile.entries (jar) + (jcall (jmethod "java.util.jar.JarFile" "entries") jar)) + +(defun zipentry.isdirectory (e) + (jcall (jmethod "java.util.zip.ZipEntry" "isDirectory") e)) + +(defun zipentry.getname (e) + (jcall (jmethod "java.util.zip.ZipEntry" "getName") e)) + +(defun get-jar-classnames (jar-file-name &rest packages) + "returns a list of strings, packages should be of the form \"java/lang\" + for recursive lookup and \"java/util/\" for non-recursive" + (let* ((jar (jarfile.new jar-file-name)) + (entries (jarfile.entries jar)) + (names ())) + (doenum (e entries) + (unless (zipentry.isdirectory e) + (let ((ename (zipentry.getname e))) + (flet ((matches (package) + (and (eql 0 (search package ename)) + (or (not (eql #\/ (schar package (1- (length package))))) ;recursive + (not (find #\/ ename :start (length package))))))) ;non-subdirectory + (when (and (eql (search ".class" ename) + (- (length ename) 6)) ;classname + ;don't grab anonymous inner classes + (not (and (find #\$ ename) + (digit-char-p (schar ename (1+ (position #\$ ename)))))) + (some #'matches packages)) + (push (nsubstitute #\. #\/ (subseq ename 0 (- (length ename) 6))) + names)))))) + names)) + +(defun dump-wrapper-defs-to-file (filename classnames) + "given a list of classnames (say from get-jar-classnames), writes +calls to def-java-class to a file" + (with-open-file (s filename :direction :output :if-exists :supersede) + (dolist (name (sort classnames #'string-lessp)) + (format s "(def-java-class ~S)~%" name)))) + +;;;;;;;;;;;;;;;;;;;;;;;;; constructors and new ;;;;;;;;;;;;;;;;;;;;;;;;;; +#| + +Every non-interface class with a public ctor will get; + a constructor, classname.new + a method defined on make-new, ultimately calling classname.new, + specialized on (the value of) it's class-symbol (e.g. canonic sym) + +Note that if the ctor is overloaded, there is just one function (taking a rest arg), +which handles overload resolution + +The new macro expands into a call to make-new +|# + +(defgeneric make-new (class-sym &rest args) + (:documentation "Allows for definition of before/after methods on ctors. +The new macro expands into call to this")) + +(defun build-ctor-doc-string (name ctors) + (with-output-to-string (s) + (dolist (c ctors) + (format s "~A(~{~#[~;~A~:;~A,~]~})~%" + name + (mapcar #'class-name-for-doc (jarray-to-list (jconstructor-params c))))))) + +(defmacro def-java-constructors (full-class-name) +"creates and exports a ctor func classname.new, defines a method of +make-new specialized on the class-symbol" + (let ((ctor-list (get-ctor-list full-class-name))) + (when ctor-list + (let ((ctor-sym (unexported-constructor-symbol full-class-name)) + (class-sym (class-symbol full-class-name))) + `(locally + (defun ,ctor-sym (&rest args) + ,(build-ctor-doc-string full-class-name ctor-list) + (apply #'install-constructors-and-call ,full-class-name args)) + (export ',ctor-sym (symbol-package ',ctor-sym)) + (defmethod make-new ((class-sym (eql ,class-sym)) &rest args) + (apply (function ,ctor-sym) args))))))) + +(defun get-ctor-list (full-class-name) + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (ctor-array (jclass-constructors class)) + (ctor-list (jarray-to-list ctor-array))) + ctor-list)) + +(defun install-constructors-and-call (full-class-name &rest args) + "initially the constructor symbol for a class is bound to this function, +when first called it will replace itself with the appropriate direct thunk, +then call the requested ctor - subsequent calls will be direct" + (install-constructors full-class-name) + (apply (constructor-symbol full-class-name) args)) + +(defun install-constructors (full-class-name) + (let* ((ctor-list (get-ctor-list full-class-name))) + (when ctor-list + (setf (fdefinition (constructor-symbol full-class-name)) + (make-ctor-thunk ctor-list))))) + +(defun make-ctor-thunk (ctors) + (if (rest ctors) ;overloaded + (make-overloaded-ctor-thunk ctors) + (make-non-overloaded-ctor-thunk (first ctors)))) + +(defun make-non-overloaded-ctor-thunk (ctor) + (let ((arg-boxers (get-arg-boxers (jconstructor-params ctor)))) + (lambda (&rest args) + (let* ((arglist (build-arglist args arg-boxers)) + (object (apply #'jnew ctor arglist))) + (unbox-object object))))) + +(defun make-overloaded-ctor-thunk (ctors) + (let ((thunks (make-ctor-thunks-by-args-length ctors))) + (lambda (&rest args) + (let ((fn (cdr (assoc (length args) thunks)))) + (if fn + (apply fn + args) + (error "invalid arity")))))) + +(defun make-ctor-thunks-by-args-length (ctors) + "returns an alist of thunks keyed by number of args" + (let ((ctors-by-args-length (make-hash-table)) + (thunks-by-args-length nil)) + (dolist (ctor ctors) + (let ((params-len (length (jconstructor-params ctor)))) + (push ctor (gethash params-len ctors-by-args-length)))) + (maphash #'(lambda (args-len ctors) + (push (cons args-len + (if (rest ctors);truly overloaded + (make-type-overloaded-ctor-thunk ctors) + ;only one ctor with this number of args + (make-non-overloaded-ctor-thunk (first ctors)))) + thunks-by-args-length)) + ctors-by-args-length) + thunks-by-args-length)) + +(defun make-type-overloaded-ctor-thunk (ctors) + "these methods have the same number of args and must be distinguished by type" + (let ((thunks (mapcar #'(lambda (ctor) + (list (make-non-overloaded-ctor-thunk ctor) + (jarray-to-list (jconstructor-params ctor)))) + ctors))) + (lambda (&rest args) + (block fn + (let ((arg-types (get-types-of-args args))) + (dolist (thunk-info thunks) + (destructuring-bind (thunk param-types) thunk-info + (when (is-congruent-type-list param-types arg-types) + (return-from fn (apply thunk args))))) + (error "No matching constructor")))))) + +(defmacro new (class-spec &rest args) +"new class-spec args +class-spec -> class-name | (class-name this-name) +class-name -> \"package.qualified.ClassName\" | classname. +args -> [actual-arg]* [init-arg-spec]* +init-arg-spec -> init-arg | (init-arg) +init-arg -> :settable-field-or-method [params]* value ;note keyword + | + .method-name [args]* ;note dot + +Creates a new instance of class-name, using make-new generic function, +then initializes it by setting fields or accessors and/or calling member functions +If this-name is supplied it will be bound to the newly-allocated object and available +to the init-args" + (labels ((mem-sym? (x) + (or (keywordp x) + (and (symbolp x) (eql 0 (position #\. (symbol-name x)))))) + (mem-form? (x) + (and (listp x) (mem-sym? (first x)))) + (mem-init? (x) + (or (mem-sym? x) (mem-form? x))) + (init-forms (x) + (if x + (if (mem-form? (first x)) + (cons (first x) (init-forms (rest x))) + (let ((more (member-if #'mem-init? (rest x)))) + (cons (ldiff x more) (init-forms more))))))) + (let* ((inits (member-if #'mem-init? args)) + (real-args (ldiff args inits)) + (class-atom (if (atom class-spec) + class-spec + (first class-spec))) + (class-sym (if (symbolp class-atom) + ;(find-symbol (string-append (symbol-name class-atom) ".")) + class-atom + (multiple-value-bind (package class) (split-package-and-class class-atom) + (find-symbol (string-append (string-upcase class) ".") package)))) + (class-name (subseq (symbol-name class-sym) 0 (1- (length (symbol-name class-sym))))) + (gthis (gensym))) + (flet ((expand-init (x) + (if (keywordp (first x)) ;setf field or property + `(setf (,(find-symbol (string-append class-name "." (symbol-name (first x)))) + ,gthis ,@(butlast (rest x))) + ,@(last (rest x))) + ;.memfunc + `(,(find-symbol (string-append class-name (symbol-name (first x)))) + ,gthis + ,@(rest x))))) + `(let* ((,gthis (make-new ,class-sym , at real-args)) + ,@(when (listp class-spec) + `((,(second class-spec) ,gthis)))) + ,@(mapcar #'expand-init (init-forms inits)) + ,gthis))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Fields ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| +all public fields will get a getter function classname.fieldname and a setter - (setf classname.fieldname) +instance fields take an first arg which is the instance +static fields also get a symbol-macro *classname.fieldname* +|# + +(defmacro def-java-fields (full-class-name) +"fields will get a getter function classname.fieldname and a setter - (setf classname.fieldname) +instance fields take an first arg which is the instance +static fields also get a symbol-macro *classname.fieldname*" + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (fields (jarray-to-list (jclass-fields class))) + (defs nil)) + (dolist (field fields) + (let* ((field-name (jfield-name field)) + (field-sym (unexported-member-symbol full-class-name field-name)) + (is-static (jmember-static-p field))) + (if is-static + (let ((macsym (intern-and-unexport (string-append "*" (symbol-name field-sym) "*") + (symbol-package field-sym)))) + (push `(defun ,field-sym () + (install-static-field-and-get ,full-class-name ,field-name)) + defs) + (push `(defun (setf ,field-sym) (val) + (install-static-field-and-set ,full-class-name ,field-name val)) + defs) + (push `(export ',field-sym (symbol-package ',field-sym)) defs) + (push `(define-symbol-macro ,macsym (,field-sym)) defs) + (push `(export ',macsym (symbol-package ',macsym)) defs)) + (progn + (push `(defun ,field-sym (obj) + (install-field-and-get ,full-class-name ,field-name obj)) + defs) + (push `(defun (setf ,field-sym) (val obj) + (install-field-and-set ,full-class-name ,field-name val obj)) + defs) + (push `(export ',field-sym (symbol-package ',field-sym)) defs))))) + `(locally ,@(nreverse defs)))) + +(defun install-field-and-get (full-class-name field-name obj) + (install-field full-class-name field-name) + (funcall (member-symbol full-class-name field-name) obj)) + +(defun install-field-and-set (full-class-name field-name val obj) + (install-field full-class-name field-name) + (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name))) val obj)) + +(defun install-static-field-and-get (full-class-name field-name) + (install-field full-class-name field-name) + (funcall (member-symbol full-class-name field-name))) + +(defun install-static-field-and-set (full-class-name field-name val) + (install-field full-class-name field-name) + (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name))) val)) + + +(defun install-field (full-class-name field-name) + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (field (jclass-field class field-name)) + (field-sym (member-symbol full-class-name field-name)) + (is-static (jmember-static-p field)) + (field-type-name (jclass-name (jfield-type field))) + (boxer (get-boxer-fn field-type-name)) + (unboxer (get-unboxer-fn field-type-name))) + (if is-static + (progn + (setf (fdefinition field-sym) + (lambda () + (funcall unboxer (jfield-raw class field-name)))) + (setf (fdefinition `(setf ,field-sym)) + (lambda (arg) + (jfield field-name nil (get-ref (funcall boxer arg))) + arg))) + (progn + (setf (fdefinition field-sym) + (lambda (obj) + (funcall unboxer (jfield-raw class field-name (get-ref obj))))) + (setf (fdefinition `(setf ,field-sym)) + (lambda (arg obj) + (jfield field-name (get-ref obj) (get-ref (funcall boxer arg))) + arg)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| +defines wrappers for all public methods of the class +As with ctors, if a method is overloaded a single wrapper is created that handles +overload resolution. +The wrappers have the name classname.methodname +If a method follows the JavaBeans property protocol (i.e. it is called getSomething or isSomething +and there is a corresponding setSomething, then a (setf classname.methodname) will be defined +that calls the latter +|# + +(defun class-name-for-doc (class) + (let ((name (jclass-name class))) + (if (jclass-array-p class) + (decode-array-name name) + name))) + +(defun build-method-doc-string (name methods) + (with-output-to-string (s) + (dolist (m methods) + (format s "~A~A ~A(~{~#[~;~A~:;~A,~]~})~%" + (if (jmember-static-p m) + "static " + "") + (jclass-name (jmethod-return-type m)) + name + (mapcar #'class-name-for-doc (jarray-to-list (jmethod-params m))))))) + +(defmacro def-java-methods (full-class-name) + (let ((class-methods (get-class-methods full-class-name)) + (defs nil)) + (maphash (lambda (name methods) + (let ((method-sym (unexported-member-symbol full-class-name name))) + (push `(defun ,method-sym (&rest args) + ,(build-method-doc-string name methods) + (apply #'install-method-and-call ,full-class-name ,name args)) + defs) + (push `(export ',method-sym (symbol-package ',method-sym)) + defs) + ;build setters when finding beans property protocol + (flet ((add-setter-if (prefix) + (when (eql 0 (search prefix name)) + (let ((setname (string-append "set" (subseq name (length prefix))))) + (when (gethash setname class-methods) + (push `(defun (setf ,method-sym) (val &rest args) + (progn + (apply #',(member-symbol full-class-name setname) + (append args (list val))) + val)) + defs)))))) + (add-setter-if "get") + (add-setter-if "is")))) + class-methods) + `(locally ,@(nreverse defs)))) + +(defun install-method-and-call (full-class-name name &rest args) + "initially all the member function symbols for a class are bound to this function, +when first called it will replace them with the appropriate direct thunks, +then call the requested method - subsequent calls via those symbols will be direct" + (install-method full-class-name name) + (apply (member-symbol full-class-name name) args)) + +(defun decode-array-name (tn) + (let ((prim (assoc tn + '(("Z" . "boolean") + ("B" . "byte") + ("C" . "char") + ("S" . "short") + ("I" . "int") + ("J" . "long") + ("F" . "float") + ("D" . "double") + ("V" . "void")) + :test #'string-equal))) + (if prim + (rest prim) + (let ((array-depth (count #\[ tn))) + (if (= 0 array-depth) + (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ; + (with-output-to-string (s) + (write-string (decode-array-name (subseq tn array-depth)) s) + (dotimes (x array-depth) + (write-string "[]" s)))))))) + +(defun jarray-to-list (array) + (coerce array 'list)) + + +(defun jmethod-made-accessible (method) + "Return a method made accessible" + (jcall (jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean") + method +true+) + method) + +(defun jclass-relevant-methods (class) + "Return all public methods, and all protected declared methods" + (append (jarray-to-list (jclass-methods class)) + (map 'list #'jmethod-made-accessible + (remove-if-not #'jmember-protected-p (jclass-methods class :declared t))))) + +(defun get-class-methods (full-class-name) + "returns an #'equal hashtable of lists of java.lang.Method refs keyed by name" + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (methods (jclass-relevant-methods class)) + (class-methods (make-hash-table :test #'equal))) + (loop for method in methods + do + (push method (gethash (jmethod-name method) class-methods))) + class-methods)) + +(defun install-method (full-class-name name) + (let* ((class-methods (get-class-methods full-class-name)) + (methods (gethash name class-methods))) + (setf (fdefinition (member-symbol full-class-name name)) + (make-method-thunk methods)))) + +(defun make-method-thunk (methods) + (if (rest methods) ;overloaded + (make-overloaded-thunk methods) + (make-non-overloaded-thunk (first methods)))) + +(defun make-non-overloaded-thunk (method) + (let* ((unboxer-fn (get-unboxer-fn (jclass-name (jmethod-return-type method)))) + (arg-boxers (get-arg-boxers (jmethod-params method))) + (is-static (jmember-static-p method)) + (caller (if is-static #'jstatic-raw #'jcall-raw))) + (lambda (&rest args) + (let ((object (if is-static nil (get-ref (first args)))) + (arglist (build-arglist (if is-static args (rest args)) arg-boxers))) + (funcall unboxer-fn (apply caller method object arglist)))))) + +(defun make-overloaded-thunk (methods) + (let ((thunks (make-thunks-by-args-length methods))) + (lambda (&rest args) + (let ((fn (cdr (assoc (length args) thunks)))) + (if fn + (apply fn + args) + (error "invalid arity")))))) + +(defun make-thunks-by-args-length (methods) + "returns an alist of thunks keyed by number of args" + (let ((methods-by-args-length (make-hash-table)) + (thunks-by-args-length nil)) + (dolist (method methods) + (let ((is-static (jmember-static-p method)) + (params-len (length (jmethod-params method)))) + (push method (gethash (if is-static params-len (1+ params-len)) + methods-by-args-length)))) + (maphash #'(lambda (args-len methods) + (push (cons args-len + (if (rest methods);truly overloaded + (make-type-overloaded-thunk methods) + ;only one method with this number of args + (make-non-overloaded-thunk (first methods)))) + thunks-by-args-length)) + methods-by-args-length) + thunks-by-args-length)) + +(defun make-type-overloaded-thunk (methods) + "these methods have the same number of args and must be distinguished by type" + (let ((thunks (mapcar #'(lambda (method) + (list (make-non-overloaded-thunk method) + (jmember-static-p method) + (jarray-to-list (jmethod-params method)))) + methods))) + (lambda (&rest args) + (block fn + (let ((arg-types (get-types-of-args args))) + (dolist (thunk-info thunks) + (destructuring-bind (thunk is-static param-types) thunk-info + (when (is-congruent-type-list param-types (if is-static arg-types (rest arg-types))) + (return-from fn (apply thunk args))))) + (error "No matching method")))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; array support ;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun jref (array &rest subscripts) + (apply #'jarray-ref-raw array subscripts)) + +(defun (setf jref) (val array &rest subscripts) + (apply #'jarray-set array (get-ref val) subscripts)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro def-refs (&rest types) + `(locally + ,@(mapcan + (lambda (type) + (let ((ref-sym (intern (string-upcase (string-append "jref-" (symbol-name type)))))) + (list + `(defun ,ref-sym (array &rest subscripts) + ,(format nil "like aref, for Java arrays of ~A, settable" (symbol-name type)) + (assert (every #'integerp subscripts)) + (unbox-object (apply #'jarray-ref array subscripts))) + `(defun (setf ,ref-sym) (val array &rest subscripts) + (assert (every #'integerp subscripts)) + (apply #'jarray-set array val subscripts) + )))) + types)))) + +;arrays of primitives have their own accessors +(def-refs boolean byte char double float int short long) + +(defun jlength (array) + "like length, for Java arrays" + (jarray-length array)) ;(get-ref array)? + +(defgeneric make-new-array (type &rest dimensions) + (:documentation "generic function, with methods for all Java class designators") + (:method (type &rest dims) + (assert (every #'integerp dims)) + (apply #'jnew-array type dims))) + +(defmethod make-new-array ((type symbol) &rest dimensions) + (apply #'make-new-array (get-java-class-ref type) dimensions)) + +(defmethod make-new-array ((type string) &rest dimensions) + (apply #'make-new-array (find-java-class type) dimensions)) + +(defmethod make-new-array ((type (eql :char)) &rest dimensions) + (apply #'make-new-array character.type dimensions)) + +(defmethod make-new-array ((type (eql :int)) &rest dimensions) + (apply #'make-new-array integer.type dimensions)) + +(defmethod make-new-array ((type (eql :boolean)) &rest dimensions) + (apply #'make-new-array boolean.type dimensions)) + +(defmethod make-new-array ((type (eql :double)) &rest dimensions) + (apply #'make-new-array double.type dimensions)) + +(defmethod make-new-array ((type (eql :byte)) &rest dimensions) + (apply #'make-new-array byte.type dimensions)) + +(defmethod make-new-array ((type (eql :float)) &rest dimensions) + (apply #'make-new-array float.type dimensions)) + +(defmethod make-new-array ((type (eql :short)) &rest dimensions) + (apply #'make-new-array short.type dimensions)) + +(defmethod make-new-array ((type (eql :long)) &rest dimensions) + (apply #'make-new-array long.type dimensions)) + +(defmethod make-new-array ((type (eql :object)) &rest dimensions) + (apply #'make-new-array object.type dimensions)) + +;;;;;;;;;;;;;;;;;;;;;;;;;; arg/param helpers ;;;;;;;;;;;;;;;;;;;;;; + + +(defun get-arg-boxers (param-types) + "returns a list with one entry per param, either nil or a function that boxes the arg" + (loop for param-type across param-types collect + (get-boxer-fn (jclass-name param-type)))) + +(defun build-arglist (args arg-boxers) + (when args + (loop for arg in args + for boxer in arg-boxers + collecting + (get-ref (if (and boxer (not (boxed? arg))) + (funcall boxer arg) + arg))))) + + +(defun get-types-of-args (args) + (let (ret) + (dolist (arg args) + (push (infer-box-type arg) + ret)) + (nreverse ret))) + +(defun is-congruent-type-list (param-types arg-types) + (every #'(lambda (arg-type param-type) + (if arg-type + (is-assignable-from arg-type param-type) + ;nil was passed - must be boolean or non-primitive target type + (or (not (is-primitive-class param-type)) + (jclass-superclass-p boolean.type param-type)))) + arg-types param-types)) + + +;;;;;;;;;;;;;;;;;;;;;;;; argument conversion and boxing ;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun get-boxer-fn (class-name) + (if (string= class-name "boolean") + #'box-boolean + #'identity)) + +(defun get-boxer-fn-sym (class-name) + (if (string= class-name "boolean") + 'box-boolean + 'identity)) + +(defun boxed? (x) + (or (java-ref-p x) + (typep x '|java.lang|::object.))) + +(defun infer-box-type (x) + (cond + ((null x) nil) + ((boxed? x) (jobject-class (get-ref x))) + ((integerp x) integer.type) + ((numberp x) double.type) + ((eq x t) boolean.type) + ((stringp x) string.type) + ((symbolp x) string.type) + (t object.type) + (t (error "can't infer box type")))) + +(defun get-unboxer-fn (class-name) + (cond ((string= class-name "void") #'unbox-void) + ((is-name-of-primitive class-name) #'unbox-primitive) + ((string= class-name "java.lang.String") #'unbox-string) + ((string= class-name "java.lang.Boolean") #'unbox-boolean) + (t #'unbox-object))) + +(defun get-unboxer-fn-sym (class-name) + (cond ((string= class-name "void") 'unbox-void) + ((is-name-of-primitive class-name) 'unbox-primitive) + ((string= class-name "java.lang.String") 'unbox-string) + ((string= class-name "java.lang.Boolean") 'unbox-boolean) + (t 'unbox-object))) + +(defun unbox-void (x &optional delete-local) + (declare (ignore x delete-local)) + nil) + +(defun unbox-primitive (x) + (unless (equal x +null+) + (jobject-lisp-value x))) + +(defun unbox-string (x) + (unless (equal x +null+) + (jobject-lisp-value x))) + +(defun unbox-boolean (x) + (unless (equal x +null+) + (jobject-lisp-value x))) + +(defun unbox-object (x) + (unless (equal x +null+) + (jcoerce x (jclass-of x)))) + +(defun box-boolean (x) + (if x +true+ +false+)) + +;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun enable-java-proxies () + t) + +(defun find-java-class-in-macro (name) + (find-java-class + (if (symbolp name) + (symbol-value name) + name))) + +(defmacro new-proxy (&rest interface-defs) + "interface-def -> (interface-name method-defs+) +interface-name -> \"package.qualified.ClassName\" | classname. (must name a Java interface type) +method-def -> (method-name arg-defs* body) +arg-def -> arg-name | (arg-name arg-type) +arg-type -> \"package.qualified.ClassName\" | classname. | :primitive +method-name -> symbol | string (matched case-insensitively) + +Creates, registers and returns a Java object that implements the supplied interfaces" + (let (defined-method-names) + (labels ((process-idefs (idefs) + (when (rest idefs) + (error "Sorry, only one interface def at a time")) + (process-idef (first idefs))) + (process-idef (idef) + (destructuring-bind (interface-name &rest method-defs) idef + (let* ((methods (jclass-methods (find-java-class-in-macro interface-name))) + (ret `((find-java-class ,interface-name) + ,@(loop for method-def in method-defs appending (process-method-def method-def methods))))) + ;;check to make sure every function is defined + (loop for method across methods + for mname = (jmethod-name method) + unless (member mname defined-method-names :test #'string-equal) + do + (warn (format nil "proxy doesn't define:~%~A" mname))) + ret))) + (process-method-def (method-def methods) + (destructuring-bind (method-name (&rest arg-defs) &body body) method-def + (push method-name defined-method-names) + (let ((method (matching-method method-name arg-defs methods)) + (gargs (gensym))) + `(,(jmethod-name method) + (lambda (&rest ,gargs) + (,(get-boxer-fn-sym (jclass-name (jmethod-return-type method))) + (let ,(arg-lets arg-defs + (jarray-to-list (jmethod-params method)) + gargs + 0) + , at body))))))) + (arg-lets (arg-defs params gargs idx) + (when arg-defs + (let ((arg (first arg-defs)) + (param (first params))) + (cons `(,(if (atom arg) arg (first arg)) + (,(get-unboxer-fn-sym (jclass-name param)) + (nth ,idx ,gargs))) + (arg-lets (rest arg-defs) (rest params) gargs (1+ idx)))))) + (matching-method (method-name arg-defs methods) + (let (match) + (loop for method across methods + when (method-matches method-name arg-defs method) + do + (if match + (error (format nil "more than one method matches ~A" method-name)) + (setf match method))) + (or match (error (format nil "no method matches ~A" method-name))))) + (method-matches (method-name arg-defs method) + (when (string-equal method-name (jmethod-name method)) + (let ((params (jmethod-params method))) + (when (= (length arg-defs) (length params)) + (is-congruent arg-defs params))))) + (is-congruent (arg-defs params) + (every (lambda (arg param) + (or (atom arg) ;no type spec matches anything + (jeq (find-java-class-in-macro (second arg)) param))) + arg-defs (jarray-to-list params)))) + `(java::%jnew-proxy ,@(process-idefs interface-defs))))) + +(defun get-modifiers (member) + (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)) + +(defun get-modifier-list (member) + (let ((mods (get-modifiers member))) + (loop for (mod . mod-call) in + '(("public" . "isPublic") + ("protected" . "isProtected") + ("private" . "isPrivate") + ("static" . "isStatic") + ;("abstract" . "isAbstract") + ("final" . "isFinal") + ("transient" . "isTransient") + ("volatile" . "isVolatile") + ("synchronized" . "isSynchronized")) + when + (jstatic (jmethod "java.lang.reflect.Modifier" mod-call "int") + "java.lang.reflect.Modifier" + mods) + collect mod))) + +(defun find-java-class-name-in-macro (c) + (etypecase c + (symbol (jclass-name (find-java-class (symbol-value c)))) + (string c))) + + + From mevenson at common-lisp.net Tue May 29 09:34:02 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 29 May 2012 02:34:02 -0700 Subject: [armedbear-cvs] r13951 - in trunk/abcl/contrib/jfli: . test Message-ID: Author: mevenson Date: Tue May 29 02:34:01 2012 New Revision: 13951 Log: jfli: start collecting tests. Need Anton's functions. Added: trunk/abcl/contrib/jfli/test/ trunk/abcl/contrib/jfli/test/yanking.lisp Modified: trunk/abcl/contrib/jfli/jfli.asd Modified: trunk/abcl/contrib/jfli/jfli.asd ============================================================================== --- trunk/abcl/contrib/jfli/jfli.asd Tue May 29 02:24:37 2012 (r13950) +++ trunk/abcl/contrib/jfli/jfli.asd Tue May 29 02:34:01 2012 (r13951) @@ -1,5 +1,6 @@ -(defpackage :jfli-system (:use :cl :asdf)) -(in-package :jfli-system) - -(defsystem jfli - :components ((:file "jfli"))) +(require :asdf) +(asdf:defsystem jfli + :version "0.1.0" + :components ((:file "jfli") + (:module test :components + ((:file "yanking"))))) Added: trunk/abcl/contrib/jfli/test/yanking.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jfli/test/yanking.lisp Tue May 29 02:34:01 2012 (r13951) @@ -0,0 +1,386 @@ +(defpackage :my (:use :cl)) +(in-package :my) + +;; runtime-class.lisp is a part of ABCL, but it is excluded from ABCL build, +;; because it requires asm.jar to be present in classpath during the build. +;; +;; The functionality it provides is necessary for dynamic creation of +;; new java classes from Lisp (in particular for the +;; NEW-CLASS macro of jfli ABCL port) +(load (concatenate 'string abclidea:*lisp-dir* "org/armedbear/lisp/runtime-class.lisp")) + +;; Load jfli +(load (concatenate 'string abclidea:*lisp-dir* "jfli-abcl/jfli-abcl.lisp")) + +(use-package :jfli) + +;; "Import" java classes we use. +;; +;; You may produce DEF-JAVA-CLASS forms for all the IDEA API classes automatically: +;; +;; (jfli:dump-wrapper-defs-to-file (concatenate 'string abclidea:*lisp-dir* "idea-api.lisp") +;; (jfli:get-jar-classnames "path/to/idea/openapi.jar" +;; "com/intellij")) +;; +;; +;; In result they will be stored in idea-api.lisp file. +;; +;; But we do it manually, because there are not so many classes we use. + +(def-java-class "com.intellij.openapi.ui.Messages") +(use-package "com.intellij.openapi.ui") + +(def-java-class "com.intellij.openapi.application.ModalityState") +(def-java-class "com.intellij.openapi.application.Application") +(def-java-class "com.intellij.openapi.application.ApplicationManager") +(use-package "com.intellij.openapi.application") + +(def-java-class "com.intellij.openapi.actionSystem.AnAction") +(def-java-class "com.intellij.openapi.actionSystem.AnActionEvent") +(def-java-class "com.intellij.openapi.actionSystem.ActionManager") +(def-java-class "com.intellij.openapi.actionSystem.DefaultActionGroup") +(def-java-class "com.intellij.openapi.actionSystem.CustomShortcutSet") +(def-java-class "com.intellij.openapi.actionSystem.Shortcut") +(def-java-class "com.intellij.openapi.actionSystem.KeyboardShortcut") +(def-java-class "com.intellij.openapi.actionSystem.CustomShortcutSet") +(use-package "com.intellij.openapi.actionSystem") + +(def-java-class "com.intellij.openapi.ide.CopyPasteManager") +(use-package "com.intellij.openapi.ide") + +(def-java-class "com.intellij.openapi.keymap.KeymapManager") +(def-java-class "com.intellij.openapi.keymap.Keymap") +(use-package "com.intellij.openapi.keymap") + +(def-java-class "com.intellij.openapi.project.ProjectManager") +(use-package "com.intellij.openapi.project") + +(def-java-class "com.intellij.openapi.editor.Editor") +(def-java-class "com.intellij.openapi.editor.Document") +(def-java-class "com.intellij.openapi.editor.SelectionModel") +(use-package "com.intellij.openapi.editor") + +(def-java-class "com.intellij.openapi.fileEditor.FileEditorManager") +(def-java-class "com.intellij.openapi.fileEditor.FileEditor") +(def-java-class "com.intellij.openapi.fileEditor.TextEditor") +(use-package "com.intellij.openapi.fileEditor") + +(def-java-class "com.intellij.openapi.command.CommandProcessor") +(def-java-class "com.intellij.openapi.command.CommandAdapter") +(def-java-class "com.intellij.openapi.command.CommandEvent") +(use-package "com.intellij.openapi.command") + +(def-java-class "com.intellij.openapi.wm.WindowManager") +(def-java-class "com.intellij.openapi.wm.StatusBar") +(use-package "com.intellij.openapi.wm") + +(def-java-class "java.lang.Runnable") +(def-java-class "java.lang.Thread") +(def-java-class "java.lang.Object") +(def-java-class "java.lang.Class") +(def-java-class "java.lang.String") +(use-package "java.lang") + +(def-java-class "java.awt.datatransfer.Transferable") +(def-java-class "java.awt.datatransfer.DataFlavor") +(use-package "java.awt.datatransfer") + +(def-java-class "javax.swing.KeyStroke") +(use-package "javax.swing") + +(define-condition action-is-not-applicable () + ((why :initarg :why :reader why)) + (:report (lambda (condition stream) + (format stream "Action is not applicable: ~A" (why condition))))) + +(defun cur-prj () + (let ((all-prjs (projectmanager.getopenprojects (projectmanager.getinstance)))) + (when (> (jlength all-prjs) 0) + (jref all-prjs 0)))) + +(defun cur-prj-safe () + (or (cur-prj) (error 'action-is-not-applicable :why "no current project"))) + +(defun cur-editor (prj) + (fileeditormanager.getselectedtexteditor (fileeditormanager.getinstance prj))) + +(defun cur-editor-safe (prj) + (or (cur-editor prj) + (error 'action-is-not-applicable + :why "no text editor is selected"))) + +;; region object +(defun make-region (start end) + (cons start end)) + +(defun region-start (region) + (car region)) + +(defun region-end (region) + (cdr region)) + +(defun get-sel-region() + "Selection in the currently active editor" + (let* ((cur-prj (cur-prj-safe)) + (cur-editor (cur-editor-safe cur-prj)) + (sel-model (editor.getselectionmodel cur-editor))) + (make-region + (selectionmodel.getselectionstart sel-model) + (selectionmodel.getselectionend sel-model)))) + +(defun replace-region (replacement-text region) + "Replace text in the curently active editor" + (let* ((cur-prj (cur-prj-safe)) + (cur-editor (cur-editor-safe cur-prj)) + (cur-doc (editor.getdocument cur-editor))) + (document.replacestring cur-doc + (region-start region) + (region-end region) + replacement-text))) + +(defvar *yank-index* 0 + "Index of clipboard item that will be pasted by the next yank or + yank-pop operation \(similar to kill-ring-yank-pointer in Emacs\).") + +(defvar *yank-region* nil + "Region of text that was inserted by previous yank or yank-pop command, +and that must be replaced by next yank-pop.") + +(defvar *yank-undo-id* 0 + "Yank following by a sequence of yank-pop must be considered as a +single action by undo mechanism. This variable is unique identifier +of such an compound action.") + +(defun get-yank-text (&optional (index 0)) + (let ((all-contents (copypastemanager.getallcontents (copypastemanager.getinstance))) + content) + (when (zerop (jlength all-contents)) + (RETURN-FROM get-yank-tex nil)) + (setf content (jref all-contents (mod index (jlength all-contents)))) + (transferable.gettransferdata content (dataflavor.stringflavor)))) + +(defun get-yank-text-safe (&optional (index 0)) + (or (get-yank-text index) + (error 'action-is-not-applicable :why "clipboard is empty"))) + +(defun next-yank-region (cur-selection-region replacement-text) + (make-region (region-start cur-selection-region) + (+ (region-start cur-selection-region) + (length (java:jobject-lisp-value replacement-text))))) +(defun yank() + (let ((sel-region (get-sel-region)) + (yank-text (get-yank-text-safe))) + (replace-region yank-text + sel-region) + (setf *yank-region* (next-yank-region sel-region + yank-text)) + (setf *yank-index* 1))) + +(defun make-runnable (fun) + (java:jinterface-implementation + "java.lang.Runnable" + "run" + ;; wrap FUN into lambda to allow it to be + ;; not only function objects, but also symbols + ;; (java:jinterface-implementation supports + ;; only function objects) + (lambda () (funcall fun)))) + +(defmacro runnable (&body body) + `(make-runnable (lambda () , at body))) + +(defun run-write-action (fun) + (let ((app (applicationmanager.getapplication)) + (runnable (make-runnable fun))) + (application.runwriteaction app runnable))) + +(defun exec-cmd (fun name group-id) + (commandprocessor.executecommand (commandprocessor.getinstance) + (cur-prj) + (make-runnable fun) + name + group-id)) + +;; set status bar text +(defun set-status (status-text) + (statusbar.setinfo (windowmanager.getstatusbar + (windowmanager.getinstance) + (cur-prj)) + status-text)) + +(new-class + "MY.MyAction" ;; class name + anaction. ;; super class + + ;; constructors + ( + (((text "java.lang.String") (func "java.lang.Object")) + (super text) + (setf (myaction.func this) func)) + ) + + ;; methods + ( + ("actionPerformed" :void :public (action-event) + ;; It's usefull to setup a restart before + ;; calling FUNC. + ;; + ;; It helps when slime is connected to + ;; the IDEA and error happens + ;; during action execution. + ;; + ;; Slime debugger hooks the error, + ;; but as actions are invoked from + ;; idea UI event dispatching thread, + ;; no slime restarts are set + ;; and our restart is the only + ;; way to leave SLIME debugger. + (restart-case + (handler-case + (funcall (myaction.func this) action-event) + (action-is-not-applicable () + ;; NOTE: it is not guaranteed + ;; that execution will be passed to this + ;; handler, even if your code signals + ;; ACTION-IS-NOT-APPLICABLE. + ;; + ;; It's so because ABCL impements + ;; non local exits using java exceptions + ;; (org.armedbear.lisp.Go); if somewhere + ;; in the call stack below our HANDLER-CASE + ;; and above the SIGNAL there is a + ;; + ;; catch (Throwable) + ;; + ;; then ABCL's Go exception will be catched. + ;; + ;; catch (Throwable) is in partiular + ;; used by IDEA methods that accept Runnable + ;; (like CommandProcessor.executeCommand, + ;; Application.runWriteAction) + ;; + ;; But even despite that, HANDLER-CASE + ;; is useful, because ACTION-IS-NOT-APPLICABLE + ;; is not trapped by Slime debugger. + )) + (continue () + :report "Return from IDEA action" + nil))) + ) + + ;; fields + ( + ("func" "java.lang.Object" :public)) + ) + +(setf act-yank (myaction.new "yank" nil)) +(setf (myaction.func act-yank) + #'(lambda (action-event) + (declare (ignore action-event)) + (incf *yank-undo-id*) + (exec-cmd (lambda () + (run-write-action 'yank)) + "yank" + (format nil "yank-~A" *yank-undo-id*)))) + +(setf edit-menu (actionmanager.getaction (actionmanager.getinstance) "EditMenu")) + +(actionmanager.registeraction (actionmanager.getinstance) "yank" act-yank) +(defaultactiongroup.add edit-menu act-yank) + +;;(actionmanager.unregisteraction (actionmanager.getinstance) "yank") +;;(defaultactiongroup.remove edit-menu act-yank) + +;; assign keyboard shortcut Ctrl-Y to our action +;; (by default Ctrl-Y is used for delete-line operation in IDEA; +;; override this by unregistering Ctrl-Y from delete-line) +(defun action-shortcut (anaction) + "The first element of AnAction.getShorcuts()" + (jref (customshortcutset.getshortcuts (anaction.getshortcutset anaction)) 0)) + +(defun remove-shortcut (keystroke-str) + "Unregister all the shortcuts specified by KEYSTROKE-STR +for all the actions in the active keymap. +Example \(REMOVE-SHORTCUT \"control Y\"\)" + (let* ((keymap (keymapmanager.getactivekeymap (keymapmanager.getinstance))) + (keystroke (keystroke.getkeystroke keystroke-str)) + (act-ids (keymap.getactionids keymap keystroke))) + (dotimes (i (jlength act-ids)) + (let ((shortcuts (keymap.getshortcuts keymap (jref act-ids i)))) + (dotimes (j (jlength shortcuts)) + (let ((shortcut (jref shortcuts j))) + (when (class.isinstance (class.forname "com.intellij.openapi.actionSystem.KeyboardShortcut") + shortcut) + (when (jeq (keyboardshortcut.getfirstkeystroke shortcut) + keystroke) + (keymap.removeshortcut keymap (jref act-ids i) shortcut))))))))) + +;; this is to display shortcut correctly in the menu +(anaction.setshortcutset act-yank + (customshortcutset.new (keystroke.getkeystroke "control Y"))) + +;; this is to make it actually fired when user presses the key combination +(remove-shortcut "control Y") +(keymap.addshortcut (keymapmanager.getactivekeymap (keymapmanager.getinstance)) + "yank" + (action-shortcut act-yank)) + +;; yank-pop is allowed only if previous command was yank or yank-pop. +;; Add a command listentener that clears *yank-region* when any +;; other command is executed, and thus makes yank-pop impossible. +(new-class + "MY.MyCommandListener" ;; class name + commandadapter. ;; super class + + ;; constructors + () + + ;; methods + ( + ("commandFinished" :void :public (command-event) + (unless (member (java:jobject-lisp-value (commandevent.getcommandname + command-event)) + '("yank" "yank-pop") + :test #'string=) + (setf *yank-region* nil))) + ) + + ;; fields + () + ) + +(setf my-cmd-listener (mycommandlistener.new)) +(commandprocessor.addcommandlistener (commandprocessor.getinstance) + my-cmd-listener) + +;; (actionmanager.unregisteraction (actionmanager.getinstance) "yank-pop") +;; (defaultactiongroup.remove edit-menu act-yank-pop) + +(defun yank-pop () + (let ((yank-text (get-yank-text *yank-index*))) + (replace-region yank-text *yank-region*) + (setf *yank-region* (make-region (region-start *yank-region*) + (+ (region-start *yank-region*) + (string.length yank-text))))) + (incf *yank-index*)) + +(setf act-yank-pop (myaction.new "yank-pop" nil)) +(setf (myaction.func act-yank-pop) + #'(lambda (action-event) + (if *yank-region* + (exec-cmd (lambda () + (run-write-action 'yank-pop)) + "yank-pop" + (format nil "yank-~A" *yank-undo-id*)) + (set-status "Previous command was not a yank")))) + +(actionmanager.registeraction (actionmanager.getinstance) "yank-pop" act-yank-pop) +(defaultactiongroup.add edit-menu act-yank-pop) + +(anaction.setshortcutset act-yank-pop + (customshortcutset.new (keystroke.getkeystroke "alt Y"))) + +(keymap.addshortcut (keymapmanager.getactivekeymap (keymapmanager.getinstance)) + "yank-pop" + (action-shortcut act-yank-pop)) + From mevenson at common-lisp.net Tue May 29 19:05:59 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 29 May 2012 12:05:59 -0700 Subject: [armedbear-cvs] r13952 - trunk/abcl/contrib/mvn Message-ID: Author: mevenson Date: Tue May 29 12:05:58 2012 New Revision: 13952 Log: jna: Add ASDF :defsystem-depends-on: clause to try to triage load failures. Modified: trunk/abcl/contrib/mvn/jna.asd Modified: trunk/abcl/contrib/mvn/jna.asd ============================================================================== --- trunk/abcl/contrib/mvn/jna.asd Tue May 29 02:34:01 2012 (r13951) +++ trunk/abcl/contrib/mvn/jna.asd Tue May 29 12:05:58 2012 (r13952) @@ -5,5 +5,5 @@ (require :asdf) (asdf:defsystem :jna :version "3.0.9" -;; :defsystem-depends-on (abcl-asdf) ;;; XXX not working in the bowels of ASDF + :defsystem-depends-on (abcl-asdf) ;;; XXX not working in the bowels of ASDF :components ((:mvn "com.sun.jna/jna/3.0.9"))) From mevenson at common-lisp.net Tue May 29 19:06:05 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 29 May 2012 12:06:05 -0700 Subject: [armedbear-cvs] r13953 - trunk/abcl/examples/misc Message-ID: Author: mevenson Date: Tue May 29 12:06:04 2012 New Revision: 13953 Log: Customize the disassembler used locally to analyze JVM bytecode. Modified: trunk/abcl/examples/misc/dotabclrc Modified: trunk/abcl/examples/misc/dotabclrc ============================================================================== --- trunk/abcl/examples/misc/dotabclrc Tue May 29 12:05:58 2012 (r13952) +++ trunk/abcl/examples/misc/dotabclrc Tue May 29 12:06:04 2012 (r13953) @@ -7,6 +7,22 @@ ;;; .clisprc.lisp (CLISP) ;;; .lispworks (LispWorks) +;;; Customize the procedure used by CL:DISASSEMBLE +(progn + (setf *disassembler* + (let ((strategies (list + (lambda (p) + (let ((class (make-pathname :name (pathname-name p))) + (path (directory-namestring p))) + (format nil "javap -c -l -verbose -classpath ~A ~A" path class)) + "/Users/evenson/bin/jad -a -p" + (lambda (p) + (format nil "java -jar ~ +/Users/evenson/work/classfileanalyzer/classfileanalyzer.jar ~A" + p)))))) + (first strategies)))) + + (defparameter *ansi-tests-directory* #-(or windows mswindows win32) #p"/home/peter/xcl/x/ansi-tests/" From mevenson at common-lisp.net Tue May 29 19:21:01 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 29 May 2012 12:21:01 -0700 Subject: [armedbear-cvs] r13954 - trunk/abcl/examples/misc Message-ID: Author: mevenson Date: Tue May 29 12:21:00 2012 New Revision: 13954 Log: bugfix: typo in last commit. Pay attention to indentation! Trust in Emacs. Modified: trunk/abcl/examples/misc/dotabclrc Modified: trunk/abcl/examples/misc/dotabclrc ============================================================================== --- trunk/abcl/examples/misc/dotabclrc Tue May 29 12:06:04 2012 (r13953) +++ trunk/abcl/examples/misc/dotabclrc Tue May 29 12:21:00 2012 (r13954) @@ -8,20 +8,17 @@ ;;; .lispworks (LispWorks) ;;; Customize the procedure used by CL:DISASSEMBLE -(progn - (setf *disassembler* - (let ((strategies (list - (lambda (p) - (let ((class (make-pathname :name (pathname-name p))) - (path (directory-namestring p))) - (format nil "javap -c -l -verbose -classpath ~A ~A" path class)) - "/Users/evenson/bin/jad -a -p" - (lambda (p) - (format nil "java -jar ~ +(setf *disassembler* + (let ((strategies (list (lambda (p) + (let ((class (make-pathname :name (pathname-name p))) + (path (directory-namestring p))) + (format nil "javap -c -l -verbose -classpath ~A ~A" path class))) + "/Users/evenson/bin/jad -a -p" + (lambda (p) + (format nil "java -jar ~ /Users/evenson/work/classfileanalyzer/classfileanalyzer.jar ~A" - p)))))) - (first strategies)))) - + p))))) + (first strategies))) (defparameter *ansi-tests-directory* #-(or windows mswindows win32)