mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-26 06:22:33 -08:00
* Created a new class, FUNCALLABLE-STANDARD-CLASS.
* Create a new class STD-CLASS that sits between CLASS and the two children STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. * Generic functions are now of type FUNCALLABLE-STANDARD-OBJECT. Based on a patch by A. Gavrilov.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
35fd642cd6
commit
ce91c03f9d
6 changed files with 79 additions and 142 deletions
|
|
@ -41,7 +41,11 @@
|
|||
;; itself as metaclass. MAKE-EMPTY-CLASS takes care of that.
|
||||
;;
|
||||
(let* ((standard-class (make-empty-standard-class 'STANDARD-CLASS nil))
|
||||
(std-class (make-empty-standard-class 'STD-CLASS standard-class))
|
||||
(standard-object (make-empty-standard-class 'STANDARD-OBJECT standard-class))
|
||||
(funcallable-standard-class
|
||||
(make-empty-standard-class 'FUNCALLABLE-STANDARD-CLASS
|
||||
standard-class))
|
||||
(the-class (make-empty-standard-class 'CLASS standard-class))
|
||||
(the-t (make-empty-standard-class 'T the-class))
|
||||
;; It does not matter that we pass NIL instead of a class object,
|
||||
|
|
@ -52,7 +56,7 @@
|
|||
collect (canonical-slot-to-direct-slot nil s)))
|
||||
(hash-table (make-hash-table :size 24)))
|
||||
|
||||
;; 2) STANDARD-CLASS and CLASS are the only classes with slots. Create a
|
||||
;; 2) STANDARD-CLASS and CLASS and others are classes with slots. Create a
|
||||
;; hash table for them, so that SLOT-VALUE works. Notice that we
|
||||
;; make a intentional mistake: CLASS and STANDARD-CLASS share the same
|
||||
;; hashtable!!
|
||||
|
|
@ -68,11 +72,22 @@
|
|||
(setf (class-slots the-class) (copy-list class-slots)
|
||||
(class-size the-class) (length class-slots)
|
||||
(slot-table the-class) hash-table
|
||||
(class-direct-slots the-class) class-slots
|
||||
(class-slots standard-class) standard-slots
|
||||
(class-direct-slots the-class) class-slots)
|
||||
(setf (class-slots standard-class) standard-slots
|
||||
(class-size standard-class) (length standard-slots)
|
||||
(slot-table standard-class) hash-table
|
||||
(class-direct-slots standard-class) (set-difference standard-slots class-slots))
|
||||
(class-direct-slots standard-class)
|
||||
(set-difference standard-slots class-slots))
|
||||
(setf (class-slots funcallable-standard-class) standard-slots
|
||||
(class-size funcallable-standard-class) (length standard-slots)
|
||||
(slot-table funcallable-standard-class) hash-table
|
||||
(class-direct-slots funcallable-standard-class)
|
||||
(class-direct-slots standard-class))
|
||||
(setf (class-slots std-class) standard-slots
|
||||
(class-size std-class) (length standard-slots)
|
||||
(slot-table std-class) hash-table
|
||||
(class-direct-slots std-class)
|
||||
(class-direct-slots standard-class))
|
||||
|
||||
;; 3) Fix the class hierarchy
|
||||
(setf (class-direct-superclasses the-t) nil
|
||||
|
|
@ -81,16 +96,22 @@
|
|||
(class-direct-subclasses standard-object) (list the-class)
|
||||
(class-direct-superclasses the-class) (list standard-object)
|
||||
(class-direct-subclasses the-class) (list standard-class)
|
||||
(class-direct-superclasses standard-class) (list the-class))
|
||||
(class-direct-superclasses std-class) (list the-class)
|
||||
(class-direct-superclasses standard-class) (list std-class)
|
||||
(class-direct-superclasses funcallable-standard-class) (list std-class))
|
||||
|
||||
(si::instance-sig-set the-class)
|
||||
(si::instance-sig-set std-class)
|
||||
(si::instance-sig-set standard-class)
|
||||
(si::instance-sig-set standard-object)
|
||||
(si::instance-sig-set funcallable-standard-class)
|
||||
(si::instance-sig-set the-t)
|
||||
|
||||
;; 4) Fix the class precedence list
|
||||
(let ((cpl (list standard-class the-class standard-object the-t)))
|
||||
(setf (class-precedence-list standard-class) cpl
|
||||
(let ((cpl (list std-class the-class standard-object the-t)))
|
||||
(setf (class-precedence-list std-class) cpl
|
||||
(class-precedence-list standard-class) (list* standard-class cpl)
|
||||
(class-precedence-list funcallable-standard-class) (list* funcallable-standard-class cpl)
|
||||
(class-precedence-list the-class) (cdr cpl)
|
||||
(class-precedence-list standard-object) (cddr cpl)
|
||||
(class-precedence-list the-t) (cdddr cpl)))
|
||||
|
|
@ -99,6 +120,8 @@
|
|||
)
|
||||
|
||||
(defconstant +the-standard-class+ (find-class 'standard-class nil))
|
||||
(defconstant +the-funcallable-standard-class+
|
||||
(find-class 'funcallable-standard-class nil))
|
||||
|
||||
(defmethod class-prototype ((class class))
|
||||
(unless (slot-boundp class 'prototype)
|
||||
|
|
@ -114,8 +137,8 @@
|
|||
|
||||
(defun find-slot-definition (class slot-name)
|
||||
(declare (si::c-local))
|
||||
(if nil #+nil ; TODO: fix
|
||||
(eq (si:instance-class class) +the-standard-class+)
|
||||
(if (or (eq (si:instance-class class) +the-standard-class+)
|
||||
(eq (si:instance-class class) +the-funcallable-standard-class+))
|
||||
(gethash slot-name (slot-table class) nil)
|
||||
(find slot-name (class-slots class) :key #'slot-definition-name)))
|
||||
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@
|
|||
#'shared-initialize (list new-data added-slots))))
|
||||
(apply #'shared-initialize new-data added-slots initargs)))
|
||||
|
||||
(defmethod change-class ((instance standard-object) (new-class standard-class)
|
||||
(defmethod change-class ((instance standard-object) (new-class std-class)
|
||||
&rest initargs)
|
||||
(let* ((old-instance (si::copy-instance instance))
|
||||
(new-size (class-size new-class))
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@
|
|||
x))))
|
||||
(map-into direct-slots #'identity new-direct-slots)
|
||||
(map-into effective-slots #'identity new-effective-slots)
|
||||
(when (typep class 'standard-class)
|
||||
(when (typep class 'std-class)
|
||||
(std-create-slots-table class)))
|
||||
(mapc #'convert-one-class (class-direct-subclasses class)))
|
||||
|
||||
|
|
@ -65,12 +65,12 @@
|
|||
(make-instances-obsolete (find-class 't))
|
||||
(convert-one-class (find-class 't)))
|
||||
|
||||
(defmethod reader-method-class ((class standard-class)
|
||||
(defmethod reader-method-class ((class std-class)
|
||||
(direct-slot direct-slot-definition)
|
||||
&rest initargs)
|
||||
(find-class 'standard-reader-method))
|
||||
|
||||
(defmethod writer-method-class ((class standard-class)
|
||||
(defmethod writer-method-class ((class std-class)
|
||||
(direct-slot direct-slot-definition)
|
||||
&rest initargs)
|
||||
(find-class 'standard-writer-method))
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@
|
|||
(si::inspect-indent)
|
||||
(format t "It has no class slots.~%")))))
|
||||
|
||||
(defmethod select-clos-N ((instance standard-class))
|
||||
(defun select-clos-N-inner-class (instance)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(local-slotds (slot-value class 'CLOS::SLOTS)))
|
||||
(if local-slotds
|
||||
|
|
@ -83,30 +83,11 @@
|
|||
(si::inspect-indent)
|
||||
(format t "It has no (local) slots.~%")))))
|
||||
|
||||
(defmethod select-clos-N ((instance std-class))
|
||||
(select-clos-N-inner-class instance))
|
||||
|
||||
(defmethod select-clos-N ((instance t))
|
||||
(let* ((class (si:instance-class instance))
|
||||
(local-slotds (slot-value class 'CLOS::SLOTS)))
|
||||
(if local-slotds
|
||||
(progn
|
||||
(si::inspect-indent)
|
||||
(format t "The (local) slots are:~%")
|
||||
(incf si::*inspect-level*)
|
||||
(dolist (slotd local-slotds)
|
||||
(si::inspect-indent-1)
|
||||
(format t "name : ~S" (clos::slot-definition-name slotd))
|
||||
(if (slot-boundp instance (clos::slot-definition-name slotd))
|
||||
(si::inspect-recursively "value:"
|
||||
(slot-value instance (clos::slot-definition-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
)
|
||||
(si::inspect-print "value: Unbound"
|
||||
nil
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
)))
|
||||
(decf si::*inspect-level*))
|
||||
(progn
|
||||
(si::inspect-indent)
|
||||
(format t "It has no (local) slots.~%")))))
|
||||
(select-clos-N-inner-class instance))
|
||||
|
||||
(defmethod select-clos-L ((instance standard-object))
|
||||
(let* ((class (si:instance-class instance))
|
||||
|
|
@ -130,7 +111,7 @@
|
|||
(format t "It has no class slots.~%")))
|
||||
(terpri)))
|
||||
|
||||
(defmethod select-clos-L ((instance standard-class))
|
||||
(defun select-clos-L-inner-class (instance)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(local-slotds (slot-value class 'CLOS::SLOTS)))
|
||||
(terpri)
|
||||
|
|
@ -143,18 +124,11 @@
|
|||
(format t "It has no (local) slots.~%")))
|
||||
(terpri)))
|
||||
|
||||
(defmethod select-clos-L ((instance std-class))
|
||||
(select-clos-L-inner-class instance))
|
||||
|
||||
(defmethod select-clos-L ((instance t))
|
||||
(let* ((class (si:instance-class instance))
|
||||
(local-slotds (slot-value class 'CLOS::SLOTS)))
|
||||
(terpri)
|
||||
(if local-slotds
|
||||
(progn
|
||||
(format t "The names of the (local) slots are:~%")
|
||||
(dolist (slotd local-slotds)
|
||||
(format t " ~S~%" (clos::slot-definition-name slotd))))
|
||||
(progn
|
||||
(format t "It has no (local) slots.~%")))
|
||||
(terpri)))
|
||||
(select-clos-L-inner-class instance))
|
||||
|
||||
(defmethod select-clos-J ((instance standard-object))
|
||||
(let* ((class (si:instance-class instance))
|
||||
|
|
@ -185,7 +159,7 @@
|
|||
(terpri)
|
||||
(terpri)))))
|
||||
|
||||
(defmethod select-clos-J ((instance standard-class))
|
||||
(defun select-clos-J-inner-class (instance)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(local-slotds (slot-value class 'CLOS::SLOTS))
|
||||
(slotd (car (member (prog1
|
||||
|
|
@ -215,35 +189,11 @@
|
|||
(terpri)
|
||||
(terpri)))))
|
||||
|
||||
(defmethod select-clos-J ((instance std-class))
|
||||
(select-clos-J-inner-class instance))
|
||||
|
||||
(defmethod select-clos-J ((instance t))
|
||||
(let* ((class (si:instance-class instance))
|
||||
(local-slotds (slot-value class 'CLOS::SLOTS))
|
||||
(slotd (car (member (prog1
|
||||
(read-preserving-whitespace *query-io*)
|
||||
(si::inspect-read-line))
|
||||
local-slotds
|
||||
:key #'clos::slot-definition-name
|
||||
:test #'eq))))
|
||||
(if slotd
|
||||
(progn
|
||||
(incf si::*inspect-level*)
|
||||
(si::inspect-indent-1)
|
||||
(format t "name : ~S" (clos::slot-definition-name slotd))
|
||||
(if (slot-boundp instance (clos::slot-definition-name slotd))
|
||||
(si::inspect-recursively "value:"
|
||||
(slot-value instance (clos::slot-definition-name slotd))
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
)
|
||||
(si::inspect-print "value: Unbound"
|
||||
nil
|
||||
; (slot-value instance (clos::slot-definition-name slotd))
|
||||
))
|
||||
(decf si::*inspect-level*))
|
||||
(progn
|
||||
(terpri)
|
||||
(format t "~S is not a slot of the instance." (slot-definition-name slotd))
|
||||
(terpri)
|
||||
(terpri)))))
|
||||
(select-clos-J-inner-class instance))
|
||||
|
||||
(defun select-clos-? ()
|
||||
(declare (si::c-local))
|
||||
|
|
@ -262,8 +212,9 @@ q (or Q): quits the inspection.~%~
|
|||
))
|
||||
|
||||
(defmethod inspect-obj ((instance standard-object))
|
||||
(unless (eq (si:instance-class (si:instance-class instance))
|
||||
(find-class 'STANDARD-CLASS))
|
||||
(unless (let ((metaclass (si:instance-class (si:instance-class instance))))
|
||||
(or (eq metaclass (find-class 'STANDARD-CLASS))
|
||||
(eq metaclass (find-class 'FUNCALLABLE-STANDARD-CLASS))))
|
||||
(terpri)
|
||||
(format t "No applicable method CLOS::INSPECT-OBJ for an instance~%")
|
||||
(format t "of class ~S" (si:instance-class instance))
|
||||
|
|
@ -320,7 +271,7 @@ q (or Q): quits the inspection.~%~
|
|||
(si::inspect-indent)))
|
||||
(incf si::*inspect-level*))
|
||||
|
||||
(defmethod inspect-obj ((instance standard-class))
|
||||
(defun inspect-obj-inner-class (instance)
|
||||
(decf si::*inspect-level*)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(local-slotds (slot-value class 'CLOS::SLOTS)))
|
||||
|
|
@ -371,56 +322,11 @@ q (or Q): quits the inspection.~%~
|
|||
(si::inspect-indent)))
|
||||
(incf si::*inspect-level*))
|
||||
|
||||
(defmethod inspect-obj ((instance std-class))
|
||||
(inspect-obj-inner-class instance))
|
||||
|
||||
(defmethod inspect-obj ((instance t))
|
||||
(decf si::*inspect-level*)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(local-slotds (slot-value class 'CLOS::SLOTS)))
|
||||
(declare (type class))
|
||||
(loop
|
||||
(format t "~S - clos object:" instance)
|
||||
(incf si::*inspect-level*)
|
||||
(si::inspect-indent)
|
||||
(format t "- it is an instance of class named ~S,"
|
||||
(class-name class))
|
||||
(si::inspect-indent)
|
||||
(format t "- it has ~A local slots: " (length local-slotds))
|
||||
(force-output)
|
||||
(case (do ((char (read-char *query-io*) (read-char *query-io*)))
|
||||
((and (char/= char #\Space) (char/= #\Tab)) char))
|
||||
((#\Newline #\Return)
|
||||
(select-clos-N instance)
|
||||
(return nil))
|
||||
((#\n #\N)
|
||||
(si::inspect-read-line)
|
||||
(select-clos-N instance)
|
||||
(return nil))
|
||||
((#\s #\S)
|
||||
(si::inspect-read-line)
|
||||
(return nil))
|
||||
((#\p #\P)
|
||||
(si::inspect-read-line)
|
||||
(si::select-P instance))
|
||||
((#\a #\A)
|
||||
(si::inspect-read-line)
|
||||
(throw 'SI::ABORT-INSPECT nil))
|
||||
((#\e #\E)
|
||||
(si::select-E))
|
||||
((#\q #\Q)
|
||||
(si::inspect-read-line)
|
||||
(throw 'SI::QUIT-INSPECT nil))
|
||||
((#\l #\L)
|
||||
(si::inspect-read-line)
|
||||
(select-clos-L instance))
|
||||
((#\j #\J)
|
||||
(select-clos-J instance))
|
||||
((#\?)
|
||||
(si::inspect-read-line)
|
||||
(select-clos-?))
|
||||
(t
|
||||
(si::inspect-read-line)))
|
||||
(decf si::*inspect-level*)
|
||||
(si::inspect-indent)))
|
||||
(incf si::*inspect-level*))
|
||||
(inspect-obj-inner-class instance))
|
||||
|
||||
;;; -------------------------------------------------------------------------
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -167,7 +167,7 @@
|
|||
|
||||
class)
|
||||
|
||||
(defmethod shared-initialize :after ((class standard-class) slot-names &rest initargs &key
|
||||
(defmethod shared-initialize :after ((class std-class) slot-names &rest initargs &key
|
||||
(optimize-slot-access (list *optimize-slot-access*))
|
||||
sealedp)
|
||||
(setf (slot-value class 'optimize-slot-access) (first optimize-slot-access)
|
||||
|
|
@ -186,6 +186,7 @@
|
|||
(list (find-class (typecase class
|
||||
(STANDARD-CLASS 'STANDARD-OBJECT)
|
||||
(STRUCTURE-CLASS 'STRUCTURE-OBJECT)
|
||||
(FUNCALLABLE-STANDARD-CLASS 'FUNCALLABLE-STANDARD-OBJECT)
|
||||
(otherwise (error "No :DIRECT-SUPERCLASS ~
|
||||
argument was supplied for metaclass ~S." (class-of class))))))))
|
||||
;; FIXME!!! Here should come the invocation of VALIDATE-SUPERCLASS!
|
||||
|
|
@ -203,10 +204,12 @@ argument was supplied for metaclass ~S." (class-of class))))))))
|
|||
|
||||
(defun find-slot-definition (class slot-name)
|
||||
(declare (si::c-local))
|
||||
(if nil #+nil ; TODO: fix
|
||||
(eq (si:instance-class class) +the-standard-class+)
|
||||
(gethash slot-name (slot-table class) nil)
|
||||
(find slot-name (class-slots class) :key #'slot-definition-name)))
|
||||
(let (table)
|
||||
(if (and (or (eq (si:instance-class class) +the-standard-class+)
|
||||
(eq (si:instance-class class) +the-funcallable-standard-class+))
|
||||
(not (eq (setf table (slot-table class)) 'SI::UNBOUND)))
|
||||
(gethash slot-name table nil)
|
||||
(find slot-name (class-slots class) :key #'slot-definition-name))))
|
||||
|
||||
(defmethod finalize-inheritance ((class class))
|
||||
;; FINALIZE-INHERITANCE computes the guts of what defines a class: the
|
||||
|
|
@ -301,7 +304,7 @@ because it contains a reference to the undefined class~% ~A"
|
|||
(setf (gethash (slot-definition-name slotd) table) slotd))
|
||||
(setf (slot-table class) table)))
|
||||
|
||||
(defmethod finalize-inheritance ((class standard-class))
|
||||
(defmethod finalize-inheritance ((class std-class))
|
||||
(call-next-method)
|
||||
(std-create-slots-table class)
|
||||
(std-class-generate-accessors class))
|
||||
|
|
@ -496,7 +499,7 @@ because it contains a reference to the undefined class~% ~A"
|
|||
(return)))))))))
|
||||
slots))
|
||||
|
||||
(defmethod compute-slots :around ((class standard-class))
|
||||
(defmethod compute-slots :around ((class std-class))
|
||||
(std-class-compute-slots class (call-next-method)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
@ -586,8 +589,6 @@ because it contains a reference to the undefined class~% ~A"
|
|||
;; the instance.
|
||||
;;
|
||||
(dolist (slotd (class-direct-slots standard-class))
|
||||
#+(or)
|
||||
(print (slot-definition-name slotd))
|
||||
(multiple-value-bind (reader writer)
|
||||
(let ((name (slot-definition-name slotd))
|
||||
(allocation (slot-definition-allocation slotd))
|
||||
|
|
@ -723,7 +724,7 @@ because it contains a reference to the undefined class~% ~A"
|
|||
;;; ----------------------------------------------------------------------
|
||||
;;; Methods
|
||||
|
||||
(defmethod describe-object ((obj standard-class) (stream t))
|
||||
(defmethod describe-object ((obj std-class) (stream t))
|
||||
(let ((slotds (class-slots (si:instance-class obj))))
|
||||
(format t "~%~A is an instance of class ~A"
|
||||
obj (class-name (si:instance-class obj)))
|
||||
|
|
|
|||
|
|
@ -11,15 +11,22 @@
|
|||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Funcallable object
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(defclass funcallable-standard-object (standard-object function) ())
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Generic Functions
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(defclass generic-function (standard-object function) ())
|
||||
(defclass generic-function (standard-object function) ()
|
||||
(:metaclass 'funcallable-standard-class))
|
||||
|
||||
(defclass standard-generic-function (generic-function)
|
||||
#.+standard-generic-function-slots+)
|
||||
#.+standard-generic-function-slots+
|
||||
(:metaclass 'funcallable-standard-class))
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; Method
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue