Commit b337d8b1 authored by Pascal Costanza's avatar Pascal Costanza
Browse files

Added support for Scieneer Common Lisp.

Ignore-this: d8c7f662bb705caccb34aad316d58d05

darcs-hash:89505302b3fb43207ecd0db837584796ebd7a260
parent 5e4d4e06
......@@ -34,6 +34,7 @@ OTHER DEALINGS IN THE SOFTWARE.
#+lispworks "lispworks"
#+(or clozure-common-lisp openmcl mcl) "mcl"
#+(or cmu sbcl) "pcl"
#+scl "scl"
:components ((:file "closer-mop-packages")
(:file "closer-mop"
:depends-on ("closer-mop-packages"))))
......@@ -43,4 +44,5 @@ OTHER DEALINGS IN THE SOFTWARE.
#+ecl "ecl"
#+lispworks "lispworks"
#+(or clozure-common-lisp openmcl mcl) "mcl"
#+(or cmu sbcl) "pcl"))))
#+(or cmu sbcl) "pcl"
#+scl "scl"))))
......@@ -326,3 +326,45 @@
:sbcl 1.0.32
#| all features implemented |#
:scl 1.3.9
((:add-direct-method fixed)
(:add-method-calls-add-direct-method fixed)
(:class-default-initargs)
(:class-direct-default-initargs)
(:compute-effective-method)
(:compute-effective-method-is-generic)
(:defmethod-calls-make-method-lambda)
(:dependent-protocol-for-classes fixed)
(:dependent-protocol-for-generic-functions fixed)
(:discriminating-functions-can-be-funcalled)
(:eql-specializer)
(:extensible-allocation)
(:funcallable-standard-instance-access)
(:function-invocation-calls-compute-applicable-methods)
(:function-invocation-calls-compute-effective-method)
(:make-method-lambda)
(:method-lambdas-are-processed)
(:multiple-slot-options-passed-as-list-to-direct-slot-definition-class)
(:reinitialize-instance-calls-compute-discriminating-function)
(:remove-direct-method fixed)
(:remove-method-calls-remove-direct-method fixed)
(:setf-class-name-calls-reinitialize-instance)
(:setf-generic-function-name-calls-reinitialize-instance)
(:specializer)
(:standard-class-and-funcallable-standard-class-are-compatible)
(:standard-instance-access)
(:subclasses-of-built-in-class-do-not-inherit-exported-slots)
(:subclasses-of-class-do-not-inherit-exported-slots)
(:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots)
(:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots)
(:subclasses-of-method-combination-do-not-inherit-exported-slots)
(:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots)
(:subclasses-of-standard-class-do-not-inherit-exported-slots)
(:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots)
(:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots)
(:subclasses-of-standard-generic-function-do-not-inherit-exported-slots)
(:subclasses-of-standard-method-do-not-inherit-exported-slots)
(:subclasses-of-standard-reader-method-do-not-inherit-exported-slots)
(:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots)
(:subclasses-of-standard-writer-method-do-not-inherit-exported-slots))
......@@ -82,7 +82,6 @@ LispWorks, 5.1.2 Personal & Professional Edition
- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed.
- Subclasses of BUILT-IN-CLASS (fixed), CLASS (fixed), DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS (fixed), FUNCALLABLE-STANDARD-CLASS (fixed), SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS (fixed), STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed, except where indicated otherwise.
MCL 5.1
In MCL, generic functions work completely differently than specified. The specific incompatibilities are not listed and are not fixed.
......@@ -110,6 +109,24 @@ SBCL 1.0.31
All features implemented.
SCL 1.3.9
- The functions ADD-DIRECT-METHOD and REMOVE-DIRECT-METHOD don't exist, and thus are also not called. Partially fixed.
- CLASS-DEFAULT-INITARGS and CLASS-DIRECT-DEFAULT-INITARGS don't exist. Not fixed.
- COMPUTE-EFFECTIVE-METHOD doesn't exist and isn't called. Not fixed.
- MAKE-METHOD-LAMBDA doesn't exist and isn't used. Not fixed.
- The dependent protocols for classes and generic functions are not implemented. Fixed.
- Discriminating functions cannot be funcalled, and it's unclear whether your own discriminating functions may be closures or not. COMPUTE-DISCRIMINATING-FUNCTION exists, but requires an extra 'cache' parameter, whose purpose is not specified. Not fixed.
- EQL-SPECIALIZER is not a class, but only a type. Not fixed, but the implemented behavior should be sufficient for most cases.
- Allocations other than :CLASS and :INSTANCE are not supported. Not fixed.
- STANDARD-INSTANCE-ACCESS and FUNCALLABLE-STANDARD-INSTANCE-ACCESS don't exist. Not fixed.
- COMPUTE-APPLICABLE-METHODS is not invoked when generic functions are called. Not fixed.
- Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround.
- Reinitialization of a generic function doesn't trigger recomputing its discriminating function. Not fixed.
- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) are not implemented by way of calling REINITIALIZE-INSTANCE. Not fixed.
- The class SPECIALIZER doesn't exist. Not fixed.
- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible.
- Subclasses of BUILT-IN-CLASS, CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION, STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed.
Summary:
......
(in-package :cl-user)
(defpackage #:closer-mop
(:use #:common-lisp)
(:nicknames #:c2mop)
(:shadow #:defmethod)
(:import-from
#:clos
#:direct-slot-definition
#:effective-slot-definition
#:eql-specializer
#:forward-referenced-class
#:funcallable-standard-class
#:funcallable-standard-object
#:metaobject
#:slot-definition
#-scl #:specializer
#:standard-accessor-method
#:standard-direct-slot-definition
#:standard-effective-slot-definition
#:standard-reader-method
#:standard-slot-definition
#:standard-writer-method
#:accessor-method-slot-definition
#-scl #:add-dependent
#-scl #:add-direct-method
#:add-direct-subclass
#-scl #:class-default-initargs
#-scl #:class-direct-default-initargs
#:class-direct-slots
#:class-direct-subclasses
#:class-direct-superclasses
#:class-finalized-p
#:class-precedence-list
#:class-prototype
#:class-slots
#:compute-applicable-methods-using-classes
#:compute-class-precedence-list
#:compute-default-initargs
#:compute-discriminating-function
#-scl #:compute-effective-method
#:compute-effective-slot-definition
#:compute-slots
#:direct-slot-definition-class
#:effective-slot-definition-class
#:ensure-class
#:ensure-class-using-class
#:ensure-generic-function-using-class
#:eql-specializer-object
#:extract-lambda-list
#:extract-specializer-names
#:finalize-inheritance
#:find-method-combination
#-scl #:funcallable-standard-instance-access
#:generic-function-argument-precedence-order
#:generic-function-declarations
#:generic-function-lambda-list
#:generic-function-method-class
#:generic-function-method-combination
#:generic-function-methods
#:generic-function-name
#:intern-eql-specializer
#-scl #:make-method-lambda
#-scl #:map-dependents
#:method-function
#:method-generic-function
#:method-lambda-list
#:method-specializers
#:reader-method-class
#-scl #:remove-dependent
#-scl #:remove-direct-method
#:remove-direct-subclass
#:set-funcallable-instance-function
#:slot-boundp-using-class
#:slot-definition-allocation
#:slot-definition-initargs
#:slot-definition-initform
#:slot-definition-initfunction
#:slot-definition-location
#:slot-definition-name
#:slot-definition-readers
#:slot-definition-writers
#:slot-definition-type
#:slot-makunbound-using-class
#:slot-value-using-class
#:specializer-direct-generic-functions
#:specializer-direct-methods
#:standard-instance-access
#-scl #:update-dependent
#:validate-superclass
#:writer-method-class)
(:export
#:built-in-class
#:class
#:direct-slot-definition
#:effective-slot-definition
#:eql-specializer
#:forward-referenced-class
#:funcallable-standard-class
#:funcallable-standard-object
#:generic-function
#:metaobject
#:method
#:method-combination
#:slot-definition
#-scl #:specializer
#:standard-accessor-method
#:standard-class
#:standard-generic-function
#:standard-direct-slot-definition
#:standard-effective-slot-definition
#:standard-method
#:standard-object
#:standard-reader-method
#:standard-slot-definition
#:standard-writer-method
#:defclass
#:defgeneric
#:define-method-combination
#:defmethod
#:classp
#:ensure-finalized
#:ensure-method
#:fix-slot-initargs
#:required-args
#:subclassp
#:accessor-method-slot-definition
#:add-dependent
#:add-direct-method
#:add-direct-subclass
#:class-default-initargs
#:class-direct-default-initargs
#:class-direct-slots
#:class-direct-subclasses
#:class-direct-superclasses
#:class-finalized-p
#:class-precedence-list
#:class-prototype
#:class-slots
#:compute-applicable-methods-using-classes
#:compute-class-precedence-list
#:compute-default-initargs
#:compute-discriminating-function
#-scl #:compute-effective-method
#-scl #:compute-effective-method-function
#:compute-effective-slot-definition
#:compute-slots
#:direct-slot-definition-class
#:effective-slot-definition-class
#:ensure-class
#:ensure-class-using-class
#:ensure-generic-function
#:ensure-generic-function-using-class
#:eql-specializer-object
#:extract-lambda-list
#:extract-specializer-names
#:finalize-inheritance
#:find-method-combination
#-scl #:funcallable-standard-instance-access
#:generic-function-argument-precedence-order
#:generic-function-declarations
#:generic-function-lambda-list
#:generic-function-method-class
#:generic-function-method-combination
#:generic-function-methods
#:generic-function-name
#:intern-eql-specializer
#-scl #:make-method-lambda
#:map-dependents
#:method-function
#:method-generic-function
#:method-lambda-list
#:method-specializers
#:reader-method-class
#:remove-dependent
#:remove-direct-method
#:remove-direct-subclass
#:set-funcallable-instance-function
#:slot-boundp-using-class
#:slot-definition-allocation
#:slot-definition-initargs
#:slot-definition-initform
#:slot-definition-initfunction
#:slot-definition-location
#:slot-definition-name
#:slot-definition-readers
#:slot-definition-writers
#:slot-definition-type
#:slot-makunbound-using-class
#:slot-value-using-class
#:specializer-direct-generic-functions
#:specializer-direct-methods
#-scl #:standard-instance-access
#:subtypep
#:typep
#:update-dependent
#:validate-superclass
#:writer-method-class
#:warn-on-defmethod-without-generic-function))
(in-package :closer-mop)
(define-modify-macro nconcf (&rest lists) nconc)
(defun required-args (lambda-list &optional (collector #'identity))
(loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (funcall collector arg)))
(defun ensure-finalized (class &optional (errorp t))
(if (typep class 'class)
(unless (class-finalized-p class)
(finalize-inheritance class))
(when errorp (error "~S is not a class." class)))
class)
(defun subclassp (class superclass)
(flet ((get-class (class) (etypecase class
(class class)
(symbol (find-class class)))))
(loop with class = (get-class class)
with superclass = (get-class superclass)
for superclasses = (list class)
then (set-difference
(union (class-direct-superclasses current-class) superclasses)
seen)
for current-class = (first superclasses)
while current-class
if (eq current-class superclass) return t
else collect current-class into seen
finally (return nil))))
(declaim (inline classp))
(defun classp (thing)
(typep thing 'class))
(cl:defgeneric add-direct-method (specializer method)
(:method ((specializer standard-object) (method method))))
(cl:defgeneric remove-direct-method (specializer method)
(:method ((specializer standard-object) (method method))))
(defvar *dependents* (make-hash-table :test #'eq))
(cl:defgeneric add-dependent (metaobject dependent)
(:method ((metaobject standard-class) dependent)
(pushnew dependent (gethash metaobject *dependents*)))
(:method ((metaobject funcallable-standard-class) dependent)
(pushnew dependent (gethash metaobject *dependents*)))
(:method ((metaobject standard-generic-function) dependent)
(pushnew dependent (gethash metaobject *dependents*))))
(cl:defgeneric remove-dependent (metaobject dependent)
(:method ((metaobject standard-class) dependent)
(setf (gethash metaobject *dependents*)
(delete metaobject (gethash metaobject *dependents*))))
(:method ((metaobject funcallable-standard-class) dependent)
(setf (gethash metaobject *dependents*)
(delete metaobject (gethash metaobject *dependents*))))
(:method ((metaobject standard-generic-function) dependent)
(setf (gethash metaobject *dependents*)
(delete metaobject (gethash metaobject *dependents*)))))
(cl:defgeneric map-dependents (metaobject function)
(:method ((metaobject standard-class) function)
(mapc function (gethash metaobject *dependents*)))
(:method ((metaobject funcallable-standard-class) function)
(mapc function (gethash metaobject *dependents*)))
(:method ((metaobject standard-generic-function) function)
(mapc function (gethash metaobject *dependents*))))
(cl:defgeneric update-dependent (metaobject dependent &rest initargs))
(cl:defmethod reinitialize-instance :after ((metaobject metaobject) &rest initargs)
(declare (dynamic-extent initargs))
(map-dependents
metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))
(cl:defmethod add-method :after
((gf standard-generic-function) method)
(loop for specializer in (method-specializers method)
do (add-direct-method specializer method))
(map-dependents
gf (lambda (dep) (update-dependent gf dep 'add-method method))))
(cl:defmethod remove-method :after
((gf standard-generic-function) method)
(loop for specializer in (method-specializers method)
do (remove-direct-method specializer method))
(map-dependents
gf (lambda (dep) (update-dependent gf dep 'remove-method method))))
(define-condition defmethod-without-generic-function (style-warning)
((name :initarg :name :reader dwg-name))
(:report (lambda (c s) (format s "No generic function present when encountering a defmethod for ~S. Assuming it will be an instance of standard-generic-function." (dwg-name c)))))
(define-symbol-macro warn-on-defmethod-without-generic-function t)
(defmacro defmethod (&whole form name &body body &environment env)
(declare (ignore body))
(let ((generic-function (when (fboundp name) (fdefinition name))))
(when (macroexpand 'warn-on-defmethod-without-generic-function env)
(unless generic-function
(warn 'defmethod-without-generic-function :name name)))
`(cl:defmethod ,@(cdr form))))
(defun ensure-method (gf lambda-expression
&key (qualifiers ())
(lambda-list (cadr lambda-expression))
(specializers (required-args lambda-list (constantly 't))))
(funcall (compile nil `(lambda ()
(defmethod ,(generic-function-name gf) ,@qualifiers
,(loop for specializer in specializers
for (arg . rest) on lambda-list
collect `(,arg ,specializer) into args
finally (return (nconc args rest)))
,@(cddr lambda-expression))))))
;; The following can be used in direct-slot-definition-class to get the correct initargs
;; for a slot. Use it like this:
;;
;; (defmethod direct-slot-definition-class
;; ((class my-standard-class) &rest initargs)
;; (declare (dynamic-extent initargs))
;; (destructuring-bind
;; (&key key-of-interest &allow-other-keys)
;; (fix-slot-initargs initargs)
;; ...))
(defvar *standard-slot-keys*
'(:name :documentation
:initargs :initform :initfunction
:readers :writers))
(defun fix-slot-initargs (initargs)
(let* ((counts (loop with counts
for (key nil) on initargs by #'cddr
do (incf (getf counts key 0))
finally (return counts)))
(keys-to-fix (loop for (key value) on counts by #'cddr
if (> value 1) collect key)))
(if keys-to-fix
(let ((multiple-standard-keys
(intersection keys-to-fix *standard-slot-keys*)))
(if multiple-standard-keys
(error "Too many occurences of ~S in slot initargs ~S."
multiple-standard-keys initargs)
(loop with fixed-keys
for (key value) on initargs by #'cddr
if (member key keys-to-fix)
do (nconcf (getf fixed-keys key) (list value))
else nconc (list key value) into fixed-initargs
finally (return (nconc fixed-initargs fixed-keys)))))
initargs)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))
......@@ -5,3 +5,4 @@ CMU Common Lisp 20a
LispWorks 5.1.1 Personal Edition
LispWorks 5.1.2 Professional Edition
SBCL 1.0.32
Scieneer 1.3.9
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment