From mevenson at common-lisp.net Sun Mar 4 20:55:26 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 04 Mar 2012 12:55:26 -0800 Subject: [armedbear-cvs] r13886 - in trunk/abcl: contrib/quicklisp doc/manual Message-ID: Author: mevenson Date: Sun Mar 4 12:55:25 2012 New Revision: 13886 Log: quicklisp-abcl: boot Quicklisp install from the network with URIs. Doesn't exactly work yet: need to add stuff to ABCL-ASDF around resolving ASDF:IRI classes. Added: trunk/abcl/contrib/quicklisp/ trunk/abcl/contrib/quicklisp/quicklisp-abcl.asd Modified: trunk/abcl/doc/manual/abcl.tex Added: trunk/abcl/contrib/quicklisp/quicklisp-abcl.asd ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/quicklisp/quicklisp-abcl.asd Sun Mar 4 12:55:25 2012 (r13886) @@ -0,0 +1,12 @@ +;;;; -*- Mode: LISP -*- +(require :asdf) +(require :abcl-asdf) +;; Quicklisp defines: +;;(defvar *setup-url* "http://beta.quicklisp.org/quickstart/setup.lisp") +(asdf:defsystem :quicklisp-abcl + :version "0.1.0" + :components ((:iri "http://beta.quicklisp.org/quicklisp.lisp")) + #+nil ;;; FIXME tickle the internal Quicklisp setup + :in-order-to ((asdf:compile-op (ql::install)))) + + Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Wed Feb 29 14:35:41 2012 (r13885) +++ trunk/abcl/doc/manual/abcl.tex Sun Mar 4 12:55:25 2012 (r13886) @@ -10,7 +10,7 @@ \title{Armed Bear Common Lisp User Manual} \date{Version 1.1.0-dev\\ \smallskip -Feburary 5, 2012} +March 3, 2012} \author{Mark Evenson \and Erik H\"{u}lsmann \and Rudolf Schlatte \and Alessio Stalla \and Ville Voutilainen} @@ -1023,6 +1023,9 @@ These systems name common JVM artifacts from the distributed pom.xml graph of Maven Aether: \begin{enumerate} \item \code{jna} Dynamically load 'jna.jar' version 3.0.9 from the network. + \end{enumerate} + \item \code{quicklisp-abcl} (Not working) boot a local Quicklisp + installation via the ASDF:IRI type introduced bia ABCL-ASDF. \end{enumeration} @@ -1159,14 +1162,15 @@ \section{jss} \label{section:jss} -To one used to the more universal syntax of Lisp pairs for which the -definition of read and compile time macros is quite natural, the Java -syntax available to the Java programmer may be said to suck. To -alleviate this situation, the JSS contrib introduces the -\code{SHARPSIGN-DOUBLE-QUOTE} (\code{\#"}) reader macro, which allows the -the specification of the name of invoking function as the first -element of the relevant s-expr which tends to be more congruent to -how Lisp programmers seem to be wired to think. +To one used to the more universal syntax of Lisp pairs upon which the +definition of read and compile time macros is quite +natural \footnote{See Graham's ``On Lisp'' http://lib.store.yahoo.net/lib/paulgraham/onlisp.pdf.}, the Java syntax available to +the Java programmer may be said to suck. To alleviate this situation, +the JSS contrib introduces the \code{SHARPSIGN-DOUBLE-QUOTE} +(\code{\#"}) reader macro, which allows the the specification of the +name of invoking function as the first element of the relevant s-expr +which tends to be more congruent to how Lisp programmers seem to be +wired to think. While quite useful, we don't expect that the JSS contrib will be the last experiment in wrangling Java from Common Lisp. From rschlatte at common-lisp.net Sun Mar 18 22:08:54 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 18 Mar 2012 15:08:54 -0700 Subject: [armedbear-cvs] r13887 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Mar 18 15:08:54 2012 New Revision: 13887 Log: Export more symbols from package MOP. 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 Sun Mar 4 12:55:25 2012 (r13886) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Sun Mar 18 15:08:54 2012 (r13887) @@ -60,6 +60,8 @@ class-prototype generic-function-lambda-list + generic-function-argument-precedence-order + generic-function-method-class method-function method-specializers From rschlatte at common-lisp.net Sun Mar 18 22:08:57 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 18 Mar 2012 15:08:57 -0700 Subject: [armedbear-cvs] r13888 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Mar 18 15:08:57 2012 New Revision: 13888 Log: Clobber subclasses of standard-generic-function into workingness. Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Sun Mar 18 15:08:54 2012 (r13887) +++ trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Sun Mar 18 15:08:57 2012 (r13888) @@ -186,10 +186,13 @@ { if (arg.typep(StandardClass.FUNCALLABLE_STANDARD_CLASS) != NIL) { LispObject l = Symbol.CLASS_LAYOUT.execute(arg); - if (! (l instanceof Layout)) + if (! (l instanceof Layout)) { return error(new ProgramError("Invalid standard class layout for: " + arg.princToString())); - - return new FuncallableStandardObject((Layout)l); + } + // KLUDGE (rudi 2012-03-17): make (make-instance + // 'standard-generic-function) work -- subsequent code expects + // the additional slots to be present. + return new StandardGenericFunction((Layout)l); } return type_error(arg, Symbol.FUNCALLABLE_STANDARD_CLASS); } Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Mar 18 15:08:54 2012 (r13887) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Mar 18 15:08:57 2012 (r13888) @@ -49,6 +49,26 @@ StandardClass.STANDARD_GENERIC_FUNCTION.getClassLayout().getLength()); } + public StandardGenericFunction(Layout layout) + { + super(layout); + slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS] = NIL; + numberOfRequiredArgs = 0; + slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = + StandardClass.STANDARD_METHOD; + slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] = + Symbol.STANDARD; + slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = + NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL; + } + public StandardGenericFunction(String name, Package pkg, boolean exported, Function function, LispObject lambdaList, LispObject specializers) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Mar 18 15:08:54 2012 (r13887) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Mar 18 15:08:57 2012 (r13888) @@ -3775,6 +3775,21 @@ (defmethod class-prototype ((class structure-class)) (allocate-instance class)) +(defmethod shared-initialize :after ((instance standard-generic-function) + slot-names + &key lambda-list argument-precedence-order + &allow-other-keys) + (let* ((plist (analyze-lambda-list lambda-list)) + (required-args (getf plist ':required-args))) + (%set-gf-required-args instance required-args) + (%set-gf-optional-args instance (getf plist :optional-args)) + (set-generic-function-argument-precedence-order instance + (if argument-precedence-order + (canonicalize-argument-precedence-order argument-precedence-order + required-args) + nil))) + (finalize-standard-generic-function instance)) + ;;; Readers for generic function metaobjects ;;; See AMOP pg. 216ff. (atomic-defgeneric generic-function-argument-precedence-order (generic-function) From rschlatte at common-lisp.net Sun Mar 18 22:09:00 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 18 Mar 2012 15:09:00 -0700 Subject: [armedbear-cvs] r13889 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Mar 18 15:08:59 2012 New Revision: 13889 Log: Implement proper behavior for generic-function-argument-precedence-order. ... it's specified to return a permutation of the required arguments, we used to return a list of indices. ... we now run to the end of Pascal Costanza's MOP test suite, where we get a list of missing features. Progress! Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Mar 18 15:08:57 2012 (r13888) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Mar 18 15:08:59 2012 (r13889) @@ -1383,8 +1383,11 @@ (t (list `',(car option) `',(cadr option))))) -;; From OpenMCL. -(defun canonicalize-argument-precedence-order (apo req) +;; From OpenMCL (called canonicalize-argument-precedence-order there, +;; but AMOP specifies argument-precedence-order to return a permutation +;; of the required arguments, not a list of indices, so we calculate +;; them on demand). +(defun argument-precedence-order-indices (apo req) (cond ((equal apo req) nil) ((not (eql (length apo) (length req))) (error 'program-error @@ -1448,7 +1451,7 @@ (generic-function-class +the-standard-generic-function-class+) (method-class +the-standard-method-class+) (method-combination 'standard) - (argument-precedence-order nil apo-p) + argument-precedence-order documentation &allow-other-keys) (when (autoloadp function-name) @@ -1469,12 +1472,8 @@ (required-args (getf plist ':required-args))) (%set-gf-required-args gf required-args) (%set-gf-optional-args gf (getf plist :optional-args)) - (when apo-p - (setf (generic-function-argument-precedence-order gf) - (if argument-precedence-order - (canonicalize-argument-precedence-order argument-precedence-order - required-args) - nil))) + (setf (generic-function-argument-precedence-order gf) + (or argument-precedence-order required-args)) (finalize-standard-generic-function gf)) gf) (progn @@ -1547,11 +1546,8 @@ (required-args (getf plist ':required-args))) (%set-gf-required-args gf required-args) (%set-gf-optional-args gf (getf plist :optional-args)) - (set-generic-function-argument-precedence-order gf - (if argument-precedence-order - (canonicalize-argument-precedence-order argument-precedence-order - required-args) - nil))) + (set-generic-function-argument-precedence-order + gf (or argument-precedence-order required-args))) (finalize-standard-generic-function gf) gf)) @@ -2026,12 +2022,17 @@ (if (or (null methods) (null (%cdr methods))) methods (sort methods - (if (eq (class-of gf) +the-standard-generic-function-class+) - #'(lambda (m1 m2) - (std-method-more-specific-p m1 m2 required-classes - (generic-function-argument-precedence-order gf))) - #'(lambda (m1 m2) - (method-more-specific-p gf m1 m2 required-classes)))))) + (if (eq (class-of gf) +the-standard-generic-function-class+) + (let ((method-indices + (argument-precedence-order-indices + (generic-function-argument-precedence-order gf) + (getf (analyze-lambda-list (generic-function-lambda-list gf)) + ':required-args)))) + #'(lambda (m1 m2) + (std-method-more-specific-p + m1 m2 required-classes method-indices))) + #'(lambda (m1 m2) + (method-more-specific-p gf m1 m2 required-classes)))))) (defun method-applicable-p (method args) (do* ((specializers (method-specializers method) (cdr specializers)) @@ -3478,8 +3479,12 @@ (defmethod method-more-specific-p ((gf standard-generic-function) method1 method2 required-classes) - (std-method-more-specific-p method1 method2 required-classes - (generic-function-argument-precedence-order gf))) + (let ((method-indices + (argument-precedence-order-indices + (generic-function-argument-precedence-order gf) + (getf (analyze-lambda-list (generic-function-lambda-list gf)) + ':required-args)))) + (std-method-more-specific-p method1 method2 required-classes method-indices))) ;;; XXX AMOP has COMPUTE-EFFECTIVE-METHOD (defgeneric compute-effective-method-function (gf methods)) @@ -3783,11 +3788,8 @@ (required-args (getf plist ':required-args))) (%set-gf-required-args instance required-args) (%set-gf-optional-args instance (getf plist :optional-args)) - (set-generic-function-argument-precedence-order instance - (if argument-precedence-order - (canonicalize-argument-precedence-order argument-precedence-order - required-args) - nil))) + (set-generic-function-argument-precedence-order + instance (or argument-precedence-order required-args))) (finalize-standard-generic-function instance)) ;;; Readers for generic function metaobjects From mevenson at common-lisp.net Wed Mar 21 15:25:33 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 21 Mar 2012 08:25:33 -0700 Subject: [armedbear-cvs] r13890 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Mar 21 08:25:33 2012 New Revision: 13890 Log: docstrings: correct documentation THREADS:MAILBOX-PEEK. Patch from Philipp Marek. Modified: trunk/abcl/src/org/armedbear/lisp/threads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/threads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/threads.lisp Sun Mar 18 15:08:59 2012 (r13889) +++ trunk/abcl/src/org/armedbear/lisp/threads.lisp Wed Mar 21 08:25:33 2012 (r13890) @@ -78,8 +78,7 @@ (defun mailbox-peek (mailbox) "Returns two values. The second returns non-NIL when the mailbox -is empty. The first is the next item to be read from the mailbox -if the first is NIL. +is empty. The first is the next item to be read from the mailbox. Note that due to multi-threading, the first value returned upon peek, may be different from the one returned upon next read in the From rschlatte at common-lisp.net Thu Mar 22 14:16:15 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 22 Mar 2012 07:16:15 -0700 Subject: [armedbear-cvs] r13891 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu Mar 22 07:16:13 2012 New Revision: 13891 Log: Pass arguments along to (direct|effective)-slot-definition-class Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 21 08:25:33 2012 (r13890) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Mar 22 07:16:13 2012 (r13891) @@ -443,7 +443,7 @@ slot) (defun make-direct-slot-definition (class &rest args) - (let ((slot-class (direct-slot-definition-class class))) + (let ((slot-class (apply #'direct-slot-definition-class class args))) (if (eq slot-class +the-standard-direct-slot-definition-class+) (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+))) (apply #'init-slot-definition slot :allocation-class class args) @@ -454,7 +454,7 @@ slot))))) (defun make-effective-slot-definition (class &rest args) - (let ((slot-class (effective-slot-definition-class class))) + (let ((slot-class (apply #'effective-slot-definition-class class args))) (if (eq slot-class +the-standard-effective-slot-definition-class+) (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+))) (apply #'init-slot-definition slot args) From rschlatte at common-lisp.net Thu Mar 22 14:36:44 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 22 Mar 2012 07:36:44 -0700 Subject: [armedbear-cvs] r13892 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu Mar 22 07:36:44 2012 New Revision: 13892 Log: Export mop::method-lambda-list. 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 Thu Mar 22 07:16:13 2012 (r13891) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Thu Mar 22 07:36:44 2012 (r13892) @@ -64,8 +64,11 @@ generic-function-method-class method-function - method-specializers method-generic-function + method-lambda-list + method-specializers + method-qualifiers + standard-reader-method standard-writer-method reader-method-class From rschlatte at common-lisp.net Thu Mar 22 15:34:36 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 22 Mar 2012 08:34:36 -0700 Subject: [armedbear-cvs] r13893 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu Mar 22 08:34:35 2012 New Revision: 13893 Log: Implement add-direct-subclass, remove-direct-subclass. ... down to 10 unexpected failures on the mop test suite. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Mar 22 07:36:44 2012 (r13892) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Mar 22 08:34:35 2012 (r13893) @@ -164,6 +164,14 @@ (define-class->%class-forwarder class-direct-default-initargs) (define-class->%class-forwarder (setf class-direct-default-initargs)) +(declaim (notinline add-direct-subclass remove-direct-subclass)) +(defun add-direct-subclass (superclass subclass) + (setf (class-direct-subclasses superclass) + (adjoin subclass (class-direct-subclasses superclass)))) +(defun remove-direct-subclass (superclass subclass) + (setf (class-direct-subclasses superclass) + (remove subclass (class-direct-subclasses superclass)))) + (defun fixup-standard-class-hierarchy () ;; Make the result of class-direct-subclasses for the pre-built ;; classes agree with AMOP Table 5.1 (pg. 141). This could be done in @@ -779,8 +787,12 @@ (let ((supers (or direct-superclasses (list +the-standard-object-class+)))) (setf (class-direct-superclasses class) supers) + ;; FIXME (rudi 2012-03-22: follow the AMOP spec here when classes + ;; are reinitialized: call add-direct-subclass for newly-added + ;; superclasses, call remove-direct-subclass for removed + ;; superclasses (dolist (superclass supers) - (pushnew class (class-direct-subclasses superclass)))) + (add-direct-subclass superclass class))) (let ((slots (mapcar #'(lambda (slot-properties) (apply #'make-direct-slot-definition class slot-properties)) direct-slots))) @@ -2732,6 +2744,16 @@ (push class classes))) (nreverse classes))) +(atomic-defgeneric add-direct-subclass (superclass subclass) + (:method ((superclass class) (subclass class)) + (setf (class-direct-subclasses superclass) + (adjoin subclass (class-direct-subclasses superclass))))) + +(atomic-defgeneric remove-direct-subclass (superclass subclass) + (:method ((superclass class) (subclass class)) + (setf (class-direct-subclasses superclass) + (remove subclass (class-direct-subclasses superclass))))) + ;;; AMOP pg. 182 (defun ensure-class (name &rest all-keys &key &allow-other-keys) (let ((class (find-class name nil))) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Thu Mar 22 07:36:44 2012 (r13892) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Thu Mar 22 08:34:35 2012 (r13893) @@ -58,7 +58,10 @@ class-direct-superclasses class-finalized-p class-prototype - + + add-direct-subclass + remove-direct-subclass + generic-function-lambda-list generic-function-argument-precedence-order generic-function-method-class From rschlatte at common-lisp.net Wed Mar 28 16:42:44 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 28 Mar 2012 09:42:44 -0700 Subject: [armedbear-cvs] r13894 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Mar 28 09:42:42 2012 New Revision: 13894 Log: Implemented ensure-generic-function-using-class. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Mar 22 08:34:35 2012 (r13893) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 28 09:42:42 2012 (r13894) @@ -3952,6 +3952,96 @@ (defgeneric update-dependent (metaobject dependent &rest initargs)) +;;; ensure-generic-function(-using-class), AMOP pg. 185ff. +(defgeneric ensure-generic-function-using-class (generic-function function-name + &key + argument-precedence-order + declarations documentation + generic-function-class + lambda-list method-class + method-combination + name + &allow-other-keys)) + +(defmethod ensure-generic-function-using-class ((generic-function generic-function) + function-name + &rest all-keys + &key (generic-function-class +the-standard-generic-function-class+) + lambda-list + argument-precedence-order + (method-class +the-standard-method-class+) + documentation + &allow-other-keys) + (setf all-keys (copy-list all-keys)) ; since we modify it + (remf all-keys :generic-function-class) + (unless (classp generic-function-class) + (setf generic-function-class (find-class generic-function-class))) + (unless (classp method-class) (setf method-class (find-class method-class))) + (unless (eq generic-function-class (class-of generic-function)) + (error "The class ~S is incompatible with the existing class of ~S." + generic-function-class generic-function)) + (unless (or (null (generic-function-methods generic-function)) + (lambda-lists-congruent-p lambda-list (generic-function-lambda-list generic-function))) + (error "The lambda list ~S is incompatible with the existing methods of ~S." + lambda-list generic-function)) + (unless (or (null (generic-function-methods generic-function)) + (eq method-class (generic-function-method-class generic-function))) + (error "The method class ~S is incompatible with the existing methods of ~S." + method-class generic-function)) + ;; FIXME (rudi 2012-03-26): should call reinitialize-instance here, as + ;; per AMOP. + (setf (generic-function-lambda-list generic-function) lambda-list) + (setf (generic-function-documentation generic-function) documentation) + (let* ((plist (analyze-lambda-list lambda-list)) + (required-args (getf plist ':required-args))) + (%set-gf-required-args generic-function required-args) + (%set-gf-optional-args generic-function (getf plist :optional-args)) + (setf (generic-function-argument-precedence-order generic-function) + (or argument-precedence-order required-args)) + (finalize-standard-generic-function generic-function)) + generic-function) + +(defmethod ensure-generic-function-using-class ((generic-function null) + function-name + &rest all-keys + &key (generic-function-class +the-standard-generic-function-class+) + (method-class +the-standard-method-class+) + (method-combination 'standard) + &allow-other-keys) + (setf all-keys (copy-list all-keys)) ; since we modify it + (remf all-keys :generic-function-class) + (unless (classp generic-function-class) + (setf generic-function-class (find-class generic-function-class))) + (unless (classp method-class) (setf method-class (find-class method-class))) + (when (and (null *clos-booting*) (fboundp function-name)) + (if (autoloadp function-name) + (fmakunbound function-name) + (error 'program-error + :format-control "~A already names an ordinary function, macro, or special operator." + :format-arguments (list function-name)))) + (apply (if (eq generic-function-class +the-standard-generic-function-class+) + #'make-instance-standard-generic-function + #'make-instance) + generic-function-class + :name function-name + :method-class method-class + :method-combination method-combination + all-keys)) + +(defun ensure-generic-function (function-name &rest all-keys + &key + lambda-list generic-function-class + method-class + method-combination + argument-precedence-order + documentation + &allow-other-keys) + (declare (ignore lambda-list generic-function-class method-class + method-combination argument-precedence-order documentation)) + (apply #'ensure-generic-function-using-class + (find-generic-function function-name nil) + function-name all-keys)) + ;;; SLIME compatibility functions. (defun %method-generic-function (method) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Thu Mar 22 08:34:35 2012 (r13893) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Wed Mar 28 09:42:42 2012 (r13894) @@ -50,6 +50,7 @@ ensure-class ensure-class-using-class + ensure-generic-function-using-class class-default-initargs class-direct-default-initargs From rschlatte at common-lisp.net Wed Mar 28 19:11:53 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 28 Mar 2012 12:11:53 -0700 Subject: [armedbear-cvs] r13895 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Mar 28 12:11:51 2012 New Revision: 13895 Log: Export slot-value-using-class from the MOP package. 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 Wed Mar 28 09:42:42 2012 (r13894) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Wed Mar 28 12:11:51 2012 (r13895) @@ -44,9 +44,11 @@ compute-effective-slot-definition compute-slots finalize-inheritance + validate-superclass + + slot-value-using-class slot-boundp-using-class slot-makunbound-using-class - validate-superclass ensure-class ensure-class-using-class From rschlatte at common-lisp.net Wed Mar 28 19:23:06 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 28 Mar 2012 12:23:06 -0700 Subject: [armedbear-cvs] r13896 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Mar 28 12:23:05 2012 New Revision: 13896 Log: Call (setf slot-value-using-class) from (setf slot-value). Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 28 12:11:51 2012 (r13895) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 28 12:23:05 2012 (r13896) @@ -695,10 +695,9 @@ (defun %set-slot-value (object slot-name new-value) (if (or (eq (class-of (class-of object)) +the-standard-class+) - (eq (class-of (class-of object)) +the-structure-class+)) + (eq (class-of (class-of object)) +the-structure-class+)) (setf (std-slot-value object slot-name) new-value) - (set-slot-value-using-class new-value (class-of object) - object slot-name))) + (setf (slot-value-using-class (class-of object) object slot-name) new-value))) (defsetf slot-value %set-slot-value) @@ -3012,10 +3011,6 @@ ;;; Slot access -(defun set-slot-value-using-class (new-value class instance slot-name) - (declare (ignore class)) ; FIXME - (setf (std-slot-value instance slot-name) new-value)) - (defgeneric slot-value-using-class (class instance slot-name)) (defmethod slot-value-using-class ((class standard-class) instance slot-name) From rschlatte at common-lisp.net Wed Mar 28 21:14:29 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 28 Mar 2012 14:14:29 -0700 Subject: [armedbear-cvs] r13897 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Mar 28 14:14:28 2012 New Revision: 13897 Log: Add type, documentation slots to slot-definition class. Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Wed Mar 28 12:23:05 2012 (r13896) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Wed Mar 28 14:14:28 2012 (r13897) @@ -42,6 +42,8 @@ super(StandardClass.STANDARD_SLOT_DEFINITION, StandardClass.STANDARD_SLOT_DEFINITION.getClassLayout().getLength()); slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; + slots[SlotDefinitionClass.SLOT_INDEX_TYPE] = T; + slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION] = NIL; } public SlotDefinition(StandardClass clazz) { @@ -58,6 +60,8 @@ slots[SlotDefinitionClass.SLOT_INDEX_READERS] = NIL; slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE; slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; + slots[SlotDefinitionClass.SLOT_INDEX_TYPE] = T; + slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION] = NIL; } public SlotDefinition(LispObject name, LispObject readers) @@ -474,4 +478,75 @@ return second; } }; + + private static final Primitive _SLOT_DEFINITION_TYPE + = new pf__slot_definition_type(); + @DocString(name="%slot-definition-type") + private static final class pf__slot_definition_type extends Primitive + { + pf__slot_definition_type() + { + super("%slot-definition-type", PACKAGE_SYS, true, "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_TYPE]; + } + }; + + private static final Primitive SET_SLOT_DEFINITION_TYPE + = new pf_set_slot_definition_type(); + @DocString(name="set-slot-definition-type", + args="slot-definition type") + private static final class pf_set_slot_definition_type extends Primitive + { + pf_set_slot_definition_type() + { + super("set-slot-definition-type", PACKAGE_SYS, true, + "slot-definition type"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_TYPE] = second; + return second; + } + }; + + private static final Primitive _SLOT_DEFINITION_DOCUMENTATION + = new pf__slot_definition_documentation(); + @DocString(name="%slot-definition-documentation") + private static final class pf__slot_definition_documentation extends Primitive + { + pf__slot_definition_documentation() + { + super("%slot-definition-documentation", PACKAGE_SYS, true, "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION]; + } + }; + + private static final Primitive SET_SLOT_DEFINITION_DOCUMENTATION + = new pf_set_slot_definition_documentation(); + @DocString(name="set-slot-definition-documentation", + args="slot-definition documentation") + private static final class pf_set_slot_definition_documentation extends Primitive + { + pf_set_slot_definition_documentation() + { + super("set-slot-definition-documentation", PACKAGE_SYS, true, + "slot-definition documentation"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION] = second; + return second; + } + }; + } Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java Wed Mar 28 12:23:05 2012 (r13896) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java Wed Mar 28 14:14:28 2012 (r13897) @@ -46,6 +46,8 @@ public static final int SLOT_INDEX_ALLOCATION = 6; public static final int SLOT_INDEX_ALLOCATION_CLASS = 7; public static final int SLOT_INDEX_LOCATION = 8; + public static final int SLOT_INDEX_TYPE = 9; + public static final int SLOT_INDEX_DOCUMENTATION = 10; /** * For internal use only. This constructor hardcodes the layout of the class, and can't be used @@ -63,7 +65,9 @@ pkg.intern("WRITERS"), pkg.intern("ALLOCATION"), pkg.intern("ALLOCATION-CLASS"), - pkg.intern("LOCATION") + pkg.intern("LOCATION"), + Symbol.TYPE, + Symbol.DOCUMENTATION }; setClassLayout(new Layout(this, instanceSlotNames, NIL)); //Set up slot definitions so that this class can be extended by users Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 28 12:23:05 2012 (r13896) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 28 14:14:28 2012 (r13897) @@ -302,13 +302,13 @@ (error 'program-error "duplicate slot option :TYPE for slot named ~S" name)) - (setf type (cadr olist))) ;; FIXME type is ignored + (setf type (cadr olist))) (:documentation (when documentation (error 'program-error "duplicate slot option :DOCUMENTATION for slot named ~S" name)) - (setf documentation (cadr olist))) ;; FIXME documentation is ignored + (setf documentation (cadr olist))) (:reader (maybe-note-name-defined (cadr olist)) (push-on-end (cadr olist) readers)) @@ -338,6 +338,8 @@ ,@(when initargs `(:initargs ',initargs)) ,@(when readers `(:readers ',readers)) ,@(when writers `(:writers ',writers)) + ,@(when type `(:type ',type)) + ,@(when documentation `(:documentation ',documentation)) , at other-options , at non-std-options)))) @@ -432,14 +434,30 @@ (defun (setf slot-definition-location) (value slot-definition) (set-slot-definition-location slot-definition value)) +(defun slot-definition-type (slot-definition) + (%slot-definition-type slot-definition)) + +(declaim (notinline (setf slot-definition-type))) +(defun (setf slot-definition-type) (value slot-definition) + (set-slot-definition-type slot-definition value)) + +(defun slot-definition-documentation (slot-definition) + (%slot-definition-documentation slot-definition)) + +(declaim (notinline (setf slot-definition-documentation))) +(defun (setf slot-definition-documentation) (value slot-definition) + (set-slot-definition-documentation slot-definition value)) + (defun init-slot-definition (slot &key name - (initargs ()) - (initform nil) - (initfunction nil) - (readers ()) - (writers ()) - (allocation :instance) - (allocation-class nil)) + (initargs ()) + (initform nil) + (initfunction nil) + (readers ()) + (writers ()) + (allocation :instance) + (allocation-class nil) + (type t) + (documentation nil)) (setf (slot-definition-name slot) name) (setf (slot-definition-initargs slot) initargs) (setf (slot-definition-initform slot) initform) @@ -448,6 +466,8 @@ (setf (slot-definition-writers slot) writers) (setf (slot-definition-allocation slot) allocation) (setf (slot-definition-allocation-class slot) allocation-class) + (setf (slot-definition-type slot) type) + (setf (slot-definition-documentation slot) documentation) slot) (defun make-direct-slot-definition (class &rest args) @@ -752,10 +772,10 @@ instance)) (defun make-instance-standard-class (metaclass - &rest initargs + &rest initargs &key name direct-superclasses direct-slots - direct-default-initargs - documentation) + direct-default-initargs + documentation) (declare (ignore metaclass)) (let ((class (std-allocate-instance +the-standard-class+))) (check-initargs (list #'allocate-instance #'initialize-instance) @@ -2976,6 +2996,12 @@ (defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't))) (setf (method-documentation x) new-value)) +(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't))) + (slot-definition-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-slot-definition) (doc-type (eql 't))) + (setf (slot-definition-documentation x) new-value)) + (defmethod documentation ((x package) (doc-type (eql 't))) (%documentation x doc-type)) @@ -3626,7 +3652,29 @@ (set-slot-definition-location slot-definition value) (setf (slot-value slot-definition 'sys::location) value)))) -;;; No %slot-definition-type. +(atomic-defgeneric slot-definition-type (slot-definition) + (:method ((slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (%slot-definition-type slot-definition) + (slot-value slot-definition 'cl: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)))) + +(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)))) + +(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)))) ;;; Conditions. From rschlatte at common-lisp.net Wed Mar 28 21:36:39 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 28 Mar 2012 14:36:39 -0700 Subject: [armedbear-cvs] r13898 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Mar 28 14:36:39 2012 New Revision: 13898 Log: Set type, documentation for effective slot definition objects. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 28 14:14:28 2012 (r13897) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 28 14:36:39 2012 (r13898) @@ -664,7 +664,13 @@ (defun std-compute-effective-slot-definition (class name direct-slots) (let ((initer (find-if-not #'null direct-slots - :key 'slot-definition-initfunction))) + :key 'slot-definition-initfunction)) + (documentation (find-if-not #'null direct-slots + :key 'slot-definition-documentation)) + (types (delete-duplicates + (delete t (mapcar #'slot-definition-type direct-slots)) + :test #'equal)) + ) (make-effective-slot-definition class :name name @@ -679,10 +685,14 @@ direct-slots)) :allocation (slot-definition-allocation (car direct-slots)) :allocation-class (when (slot-boundp (car direct-slots) - 'sys::allocation-class) - ;;for some classes created in Java - ;;(e.g. SimpleCondition) this slot is unbound - (slot-definition-allocation-class (car direct-slots)))))) + 'sys::allocation-class) + ;;for some classes created in Java + ;;(e.g. SimpleCondition) this slot is unbound + (slot-definition-allocation-class (car direct-slots))) + :type (cond ((null types) t) + ((= 1 (length types)) types) + (t (list* 'and types))) + :documentation documentation))) ;;; Standard instance slot access From vvoutilainen at common-lisp.net Sat Mar 31 12:50:27 2012 From: vvoutilainen at common-lisp.net (vvoutilainen at common-lisp.net) Date: Sat, 31 Mar 2012 05:50:27 -0700 Subject: [armedbear-cvs] r13899 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Mar 31 05:50:25 2012 New Revision: 13899 Log: Add :clear-env to run-program, add getenv-all Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java trunk/abcl/src/org/armedbear/lisp/run-program.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Extensions.java Wed Mar 28 14:36:39 2012 (r13898) +++ trunk/abcl/src/org/armedbear/lisp/Extensions.java Sat Mar 31 05:50:25 2012 (r13899) @@ -37,6 +37,7 @@ import java.io.File; import java.io.IOException; +import java.util.*; public final class Extensions { @@ -317,4 +318,28 @@ return NIL; } } + + // ### getenv-all variable => string + private static final Primitive GETENV_ALL = new getenv_all(); + private static class getenv_all extends Primitive + { + getenv_all() + { + super("getenv-all", PACKAGE_EXT, true, "variable", + "Returns all environment variables as an alist containing (name . value)"); + } + @Override + public LispObject execute() + { + Cons result = new Cons(NIL); + Map env = System.getenv(); + for (Map.Entry entry : env.entrySet()) { + Cons entryPair = new Cons(new SimpleString(entry.getKey()), + new SimpleString(entry.getValue())); + result = new Cons(entryPair, result); + } + return result; + } + } + } Modified: trunk/abcl/src/org/armedbear/lisp/run-program.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/run-program.lisp Wed Mar 28 14:36:39 2012 (r13898) +++ trunk/abcl/src/org/armedbear/lisp/run-program.lisp Sat Mar 31 05:50:25 2012 (r13899) @@ -40,11 +40,13 @@ ;;; This implementation uses the JVM facilities for running external ;;; processes. ;;; . -(defun run-program (program args &key environment (wait t)) +(defun run-program (program args &key environment (wait t) clear-env) ;;For documentation, see below. (let ((pb (%make-process-builder program args))) - (when environment - (let ((env-map (%process-builder-environment pb))) + (let ((env-map (%process-builder-environment pb))) + (when clear-env + (%process-builder-env-clear env-map)) + (when environment (dolist (entry environment) (%process-builder-env-put env-map (princ-to-string (car entry)) @@ -80,9 +82,12 @@ The &key arguments have the following meanings: :environment - An alist of STRINGs (name . value) describing the new - environment. The default is to copy the environment of the current - process. + An alist of STRINGs (name . value) describing new + environment values that replace existing ones. + +:clear-env + If non-NIL, the current environment is cleared before the + values supplied by :environment are inserted. :wait If non-NIL, which is the default, wait until the created process @@ -131,6 +136,9 @@ (defun %process-builder-env-put (env-map key value) (java:jcall "put" env-map key value)) +(defun %process-builder-env-clear (env-map) + (java:jcall "clear" env-map)) + (defun %process-builder-start (pb) (java:jcall "start" pb))