mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-18 23:32:17 -08:00
Code Issues Projects Releases Packages Wiki Activity

Methods, generic functions and dispatch is now implemented using specializers

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2012-04-23 19:58:26 +02:00
parent ba9daa82fc
commit 66d4d462a4
5 changed files with 113 additions and 65 deletions
Download patch file Download diff file Expand all files Collapse all files

26
src/clos/boot.lsp
View file

@ -30,6 +30,9 @@
(class-default-initargs class) nil
(class-precedence-list class) nil
(class-finalized-p class) t
(eql-specializer-flag class) nil
(specializer-direct-methods class) nil
(specializer-direct-generic-functions class) nil
(find-class name) class)
(unless (eq name 'T)
(setf (slot-table class) (make-hash-table :size 2)))
@ -71,6 +74,12 @@
;; hash table for them, so that SLOT-VALUE works. Notice that we
;; make a intentional mistake: CLASS and STANDARD-CLASS share the same
;; hashtable!!
(do* ((i 0 (1+ i))
(slots eql-specializer-slots (cdr slots)))
((endp slots))
(let ((slotd (first slots)))
(setf (slot-definition-location slotd) i)
(setf (gethash (slot-definition-name slotd) hash-table) slotd)))
(do* ((i 0 (1+ i))
(slots standard-slots (cdr slots)))
((endp slots))
@ -80,6 +89,9 @@
(dolist (slotd class-slots)
(setf (slot-definition-location slotd)
(slot-definition-location (gethash (slot-definition-name slotd) hash-table))))
(dolist (slotd specializer-slots)
(setf (slot-definition-location slotd)
(slot-definition-location (gethash (slot-definition-name slotd) hash-table))))
(setf (class-slots the-class) (copy-list class-slots)
(class-size the-class) (length class-slots)
(slot-table the-class) hash-table
@ -261,8 +273,7 @@
;; shared slot
(car location))
(t
(error "Effective slot definition lacks a valid location:~%~A"
slotd)))))
(invalid-slot-definition instance slotd)))))
(defun standard-instance-set (val instance slotd)
(ensure-up-to-date-instance instance)
@ -275,9 +286,14 @@
;; shared slot
(setf (car location) val))
(t
(error "Effective slot definition lacks a valid location:~%~A"
slotd)))
val))
(invalid-slot-definition instance slotd))))
val)
(defun invalid-slot-definition (instance slotd)
(error "Effective slot definition lacks a valid location.
Class name: ~A
Slot name: ~A"
(type-of instance) (slot-definition-name slotd)))
(defmethod slot-value-using-class ((class class) self slotd)
(let ((value (standard-instance-get self slotd)))

2
src/clos/fixup.lsp
View file

@ -262,6 +262,8 @@ their lambda lists ~A and ~A are not congruent."
;;; Error messages
(defmethod no-applicable-method (gf args)
(print (generic-function-name gf))
(print (mapcar #'type-of args))
(error "No applicable method for ~S with arguments of types~{~& ~A~}"
(generic-function-name gf)
(mapcar #'type-of args)))

63
src/clos/kernel.lsp
View file

@ -63,11 +63,11 @@
(eval-when (compile eval)
(defparameter +specializer-slots+
'((flag :initform nil :accessor specializer-flag)
'((flag :initform nil :accessor eql-specializer-flag)
(direct-methods :initform nil :accessor specializer-direct-methods)
(direct-generic-functions :initform nil :accessor specializer-direct-generic-functions)))
(defparameter +eql-specializer-slots+
'((flag :initform t :accessor specializer-flag)
'((flag :initform t :accessor eql-specializer-flag)
(direct-methods :initform nil :accessor specializer-direct-methods)
(direct-generic-functions :initform nil :accessor specializer-direct-generic-functions)
(object :initarg :object :accessor eql-specializer-object))))
@ -222,7 +222,7 @@
; (record-definition 'method `(method ,name ,@qualifiers ,specializers))
(let* ((gf (ensure-generic-function name))
(specializers (mapcar #'(lambda (x)
(cond ((consp x) x)
(cond ((consp x) (intern-eql-specializer (second x)))
((typep x 'specializer) x)
((find-class x nil))
(t
@ -273,9 +273,7 @@
((not (eq common-class class))
(return t)))
do (loop for spec in specializers
unless (or (eq spec t)
(null spec)
(eq spec +the-t-class+)
unless (or (eq spec +the-t-class+)
(and (si::instancep spec)
(eq (si::instance-class spec)
+the-standard-class+)))
@ -289,7 +287,7 @@
(t
(return t))))))
(set-funcallable-instance-function gfun (gf-type gfun))))
;;; ----------------------------------------------------------------------
@ -311,11 +309,9 @@
(flet ((applicable-method-p (method args)
(loop for spec in (method-specializers method)
for arg in args
always (cond ((null spec) t)
((listp spec)
;; EQL specializer
(eql arg (second spec)))
((si::of-class-p arg spec))))))
always (if (eql-specializer-flag spec)
(eql arg (eql-specializer-object spec))
(si::of-class-p arg spec)))))
(loop for method in (generic-function-methods gf)
when (applicable-method-p method args)
collect method)))
@ -325,11 +321,10 @@
(flet ((applicable-method-p (method classes)
(loop for spec in (method-specializers method)
for class in classes
always (cond ((null spec))
((listp spec)
always (cond ((eql-specializer-flag spec)
;; EQL specializer invalidate computation
;; we return NIL
(when (si::of-class-p (second spec) class)
(when (si::of-class-p (eql-specializer-object spec) class)
(return-from std-compute-applicable-methods-using-classes
(values nil nil)))
nil)
@ -399,6 +394,18 @@
(declare (si::c-local))
;; Specialized version of subtypep which uses the fact that spec1
;; and spec2 are either classes or of the form (EQL x)
(if (eql-specializer-flag spec1)
(if (eql-specializer-flag spec2)
(eql (eql-specializer-object spec1)
(eql-specializer-object spec2))
(si::of-class-p (eql-specializer-object spec1) spec2))
(if (eql-specializer-flag spec2)
;; There is only one class with a single element, which
;; is NULL = (MEMBER NIL).
(and (null (eql-specializer-object spec2))
(eq (class-name spec1) 'null))
(si::subclassp spec1 spec2)))
#+(or)
(if (atom spec1)
(if (atom spec2)
(si::subclassp spec1 spec2)
@ -413,13 +420,11 @@
(defun compare-specializers (spec-1 spec-2 arg-class)
(declare (si::c-local))
(let* ((cpl (class-precedence-list arg-class)))
(cond ((equal spec-1 spec-2) '=)
((null spec-1) '2)
((null spec-2) '1)
(cond ((eq spec-1 spec-2) '=)
((fast-subtypep spec-1 spec-2) '1)
((fast-subtypep spec-2 spec-1) '2)
((and (listp spec-1) (eq (car spec-1) 'eql)) '1) ; is this engough?
((and (listp spec-2) (eq (car spec-2) 'eql)) '2) ; Beppe
((eql-specializer-flag spec-1) '1) ; is this engough?
((eql-specializer-flag spec-2) '2) ; Beppe
((member spec-1 (member spec-2 cpl)) '2)
((member spec-2 (member spec-1 cpl)) '1)
;; This will force an error in the caller
@ -427,15 +432,10 @@
(defun compute-g-f-spec-list (gf)
(flet ((nupdate-spec-how-list (spec-how-list specializers gf)
;; FIXME! This check should have happened before, shouldn't it???
(let ((l (length specializers)))
(if spec-how-list
(unless (= (length spec-how-list) l)
(error "The generic function ~A~%has ~D required arguments, but the new specialization provides ~D."
gf (length spec-how-list) l))
(setf spec-how-list (make-list l))))
;; update the spec-how of the gfun
;; computing the or of the previous value and the new one
(setf spec-how-list (or spec-how-list
(copy-list specializers)))
(do* ((l specializers (cdr l))
(l2 spec-how-list (cdr l2))
(spec-how)
@ -443,13 +443,12 @@
((null l))
(setq spec-how (first l) spec-how-old (first l2))
(setf (first l2)
(if (consp spec-how) ; an eql list
(if (consp spec-how-old)
(list* (second spec-how) spec-how-old)
(cdr spec-how))
(if (eql-specializer-flag spec-how)
(list* (eql-specializer-object spec-how)
(and (consp spec-how-old) spec-how-old))
(if (consp spec-how-old)
spec-how-old
(or spec-how spec-how-old)))))
spec-how))))
spec-how-list))
(let* ((spec-how-list nil)
(function nil)

50
src/clos/method.lsp
View file

@ -334,25 +334,43 @@ have disappeared."
(defun find-method (gf qualifiers specializers &optional (errorp t))
(declare (notinline method-qualifiers))
(let* ((method-list (generic-function-methods gf))
found)
(dolist (method method-list)
(when (and (equal qualifiers (method-qualifiers method))
(equal specializers (method-specializers method)))
(return-from find-method method)))
(flet ((filter-specializer (name)
(cond ((typep name 'specializer)
name)
((atom name)
(let ((class (find-class name nil)))
(unless class
(error "~A is not a valid specializer name" name))
class))
((and (eq (first name) 'EQL)
(null (cddr name)))
(cdr name))
(t
(error "~A is not a valid specializer name" name))))
(specializer= (cons-or-class specializer)
(if (consp cons-or-class)
(and (eql-specializer-flag specializer)
(eql (car cons-or-class)
(eql-specializer-object specializer)))
(eq cons-or-class specializer))))
(when (/= (length specializers)
(length (generic-function-argument-precedence-order gf)))
(error
"The specializers list~%~A~%does not match the number of required arguments in ~A"
specializers (generic-function-name gf)))
(loop with specializers = (mapcar #'filter-specializer specializers)
for method in (generic-function-methods gf)
when (and (equal qualifiers (method-qualifiers method))
(every #'specializer= specializers (method-specializers method)))
do (return-from find-method method))
;; If we did not find any matching method, then the list of
;; specializers might have the wrong size and we must signal
;; an error.
(cond ((/= (length specializers)
(length (generic-function-argument-precedence-order gf)))
(error
"The specializers list~%~A~%does not match the number of required arguments in ~A"
specializers (generic-function-name gf)))
(errorp
(error "There is no method on the generic function ~S that agrees on qualifiers ~S and specializers ~S"
(generic-function-name gf)
qualifiers specializers)))
nil))
(when errorp
(error "There is no method on the generic function ~S that agrees on qualifiers ~S and specializers ~S"
(generic-function-name gf)
qualifiers specializers)))
nil)
;;; ----------------------------------------------------------------------

37
src/clos/stdmethod.lsp
View file

@ -63,16 +63,29 @@
(lambda-list nil lambda-supplied-p)
generic-function)
(declare (ignore initargs method slot-names))
(unless spec-supplied-p
(error "Specializer list not supplied in method initialization"))
(unless lambda-supplied-p
(error "Lambda list not supplied in method initialization"))
(unless (= (first (si::process-lambda-list lambda-list 'method))
(length specializers))
(error "The list of specializers does not match the number of required arguments in the lambda list ~A"
lambda-list))
(loop for s in specializers
unless (or (typep s 'specializer)
(consp s))
do (error "Object ~A is not a valid specializer" s))
(when slot-names
(unless spec-supplied-p
(error "Specializer list not supplied in method initialization"))
(unless lambda-supplied-p
(error "Lambda list not supplied in method initialization"))
(unless (= (first (si::process-lambda-list lambda-list 'method))
(length specializers))
(error "The list of specializers does not match the number of required arguments in the lambda list ~A"
lambda-list)))
(when spec-supplied-p
(loop for s in specializers
unless (typep s 'specializer)
do (error "Object ~A is not a valid specializer" s)))
(add-method-keywords (call-next-method)))
#+threads
(defparameter *eql-specializer-lock* (mp:make-lock :name 'eql-specializer))
(defparameter *eql-specializer-hash*
(make-hash-table :size 128 :test #'eql))
(defun intern-eql-specializer (object)
(let ((table *eql-specializer-hash*))
(mp:with-lock (*eql-specializer-lock*)
(or (gethash object table nil)
(setf (gethash object table)
(make-instance 'eql-specializer :object object))))))