mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 07:12:26 -08:00
clos: move define-method-combination to a separate file
This commit is contained in:
Daniel Kochmański
parent
dea75e6bb5
commit
2ba8228366
3 changed files with 318 additions and 306 deletions
|
|
@ -167,299 +167,7 @@
|
|||
(nconc (rest around) main)))
|
||||
(if (or before after)
|
||||
(standard-main-effective-method before primary after)
|
||||
(combine-method-functions (first primary) (rest primary))))
|
||||
)))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; DEFINE-METHOD-COMBINATION
|
||||
;;
|
||||
;; METHOD-COMBINATION objects are just a list
|
||||
;; (name arg*)
|
||||
;; where NAME is the name of the method combination type defined with
|
||||
;; DEFINE-METHOD-COMBINATION, and ARG* is zero or more arguments.
|
||||
;;
|
||||
;; For each method combination type there is an associated function,
|
||||
;; and the list of all known method combination types is kept in
|
||||
;; *METHOD-COMBINATIONS* in the form of property list:
|
||||
;; (mc-type-name1 function1 mc-type-name2 function2 ....)
|
||||
;;
|
||||
;; FUNCTIONn is the function associated to a method combination. It
|
||||
;; is of type (FUNCTION (generic-function method-list) FUNCTION),
|
||||
;; and it outputs an anonymous function which is the effective method.
|
||||
;;
|
||||
|
||||
#+threads
|
||||
(defparameter *method-combinations-lock* (mp:make-lock :name 'find-method-combination))
|
||||
(defparameter *method-combinations* (make-hash-table :size 32 :test 'eq))
|
||||
|
||||
(defun search-method-combination (name)
|
||||
(mp:with-lock (*method-combinations-lock*)
|
||||
(or (gethash name *method-combinations*)
|
||||
(error "~A does not name a method combination" name))))
|
||||
|
||||
(defun install-method-combination (name function)
|
||||
(mp:with-lock (*method-combinations-lock*)
|
||||
(setf (gethash name *method-combinations*) function))
|
||||
name)
|
||||
|
||||
(defun make-method-combination (name compiler options)
|
||||
(with-early-make-instance +method-combination-slots+
|
||||
(o (find-class 'method-combination)
|
||||
:name name
|
||||
:compiler compiler
|
||||
:options options)
|
||||
o))
|
||||
|
||||
(defun find-method-combination (gf method-combination-type-name method-combination-options)
|
||||
(declare (ignore gf))
|
||||
(make-method-combination method-combination-type-name
|
||||
(search-method-combination method-combination-type-name)
|
||||
method-combination-options
|
||||
))
|
||||
|
||||
(defun define-simple-method-combination (name &key documentation
|
||||
identity-with-one-argument
|
||||
(operator name))
|
||||
`(define-method-combination ,name (&optional (order :MOST-SPECIFIC-FIRST))
|
||||
((around (:AROUND))
|
||||
(principal (,name) :REQUIRED t))
|
||||
,documentation
|
||||
(let ((main-effective-method
|
||||
`(,',operator ,@(mapcar #'(lambda (x) `(CALL-METHOD ,x NIL))
|
||||
(if (eql order :MOST-SPECIFIC-LAST)
|
||||
(reverse principal)
|
||||
principal)))))
|
||||
(cond (around
|
||||
`(call-method ,(first around)
|
||||
(,@(rest around) (make-method ,main-effective-method))))
|
||||
(,(if identity-with-one-argument
|
||||
'(rest principal)
|
||||
t)
|
||||
main-effective-method)
|
||||
(t (second main-effective-method))))))
|
||||
|
||||
(defun method-combination-arguments-reshuffling (mc-whole-arg mc-lambda-list gf-lambda-list body)
|
||||
;; Implement the reshuffling of arguments to the generic function
|
||||
;; into arguments for a method-combination arguments lambda list
|
||||
;; required for the long form of DEFINE-METHOD-COMBINATION. The
|
||||
;; generic function arguments are stored in the variable
|
||||
;; .COMBINED-METHOD-ARGS. of type STACK-FRAME. To extract the
|
||||
;; arguments we apply to this stack frame a function whose
|
||||
;; lambda-list is built below by reshaping the method-combination
|
||||
;; lambda-list to fit the form of the generic-function lambda-list.
|
||||
(let ((lambda-list '())
|
||||
(let-statements '())
|
||||
(ignored-vars '())
|
||||
n-gf-requireds n-gf-optionals)
|
||||
(multiple-value-bind (mc-requireds mc-optionals mc-rest mc-key-flag mc-keywords
|
||||
mc-allow-other-keys mc-aux-vars)
|
||||
(si::process-lambda-list mc-lambda-list 'function)
|
||||
(declare (ignore mc-allow-other-keys))
|
||||
(multiple-value-bind (gf-requireds gf-optionals)
|
||||
(si::process-lambda-list gf-lambda-list 'function)
|
||||
(setf n-gf-requireds (first gf-requireds)
|
||||
n-gf-optionals (first gf-optionals))
|
||||
(when mc-whole-arg
|
||||
(push `(,mc-whole-arg (apply #'list .combined-method-args.))
|
||||
let-statements))
|
||||
(loop for r in (rest mc-requireds) by #'cdr
|
||||
for i from 0
|
||||
if (< i n-gf-requireds)
|
||||
do (push r lambda-list)
|
||||
else ; excess required args of the method-combination
|
||||
; are set to nil
|
||||
do (push `(,r nil) let-statements))
|
||||
;; excess required args of the generic-function are ignored
|
||||
(loop repeat (- n-gf-requireds (first mc-requireds))
|
||||
for v = (gensym)
|
||||
do (push v lambda-list)
|
||||
(push v ignored-vars))
|
||||
(push '&optional lambda-list)
|
||||
(loop for o on (rest mc-optionals) by #'cdddr
|
||||
for i from 0
|
||||
if (< i n-gf-optionals)
|
||||
do (push (if (third o)
|
||||
`(,(first o) ,(second o) ,(third o))
|
||||
`(,(first o) ,(second o)))
|
||||
lambda-list)
|
||||
else ; excess optional args of the method-combination
|
||||
; are set to their init forms
|
||||
do (push `(,(first o) ,(second o)) let-statements)
|
||||
(when (third o)
|
||||
(push `(,(third o) nil) let-statements)))
|
||||
;; excess args of the generic-function are ignored
|
||||
(loop repeat (- n-gf-optionals (first mc-optionals))
|
||||
for v = (gensym)
|
||||
do (push v lambda-list)
|
||||
(push v ignored-vars))
|
||||
(unless mc-rest
|
||||
(setf mc-rest (gensym))
|
||||
(push mc-rest ignored-vars))
|
||||
;; rest, keyword and aux args are treated as usual
|
||||
(push '&rest lambda-list)
|
||||
(push mc-rest lambda-list)
|
||||
(when mc-key-flag
|
||||
(push '&key lambda-list)
|
||||
(loop for k on (rest mc-keywords) by #'cddddr
|
||||
do (push (if (fourth k)
|
||||
`((,(first k) ,(second k)) ,(third k) ,(fourth k))
|
||||
`((,(first k) ,(second k)) ,(third k)))
|
||||
lambda-list))
|
||||
(push '&allow-other-keys lambda-list))
|
||||
(when mc-aux-vars
|
||||
(push '&aux lambda-list)
|
||||
(loop for a on mc-aux-vars by #'cddr
|
||||
do (push `(,(first a) ,(second a)) lambda-list)))
|
||||
`(apply #'(lambda ,(nreverse lambda-list)
|
||||
(declare (ignore ,@ignored-vars))
|
||||
(let ,(nreverse let-statements)
|
||||
,body))
|
||||
.combined-method-args.)))))
|
||||
|
||||
(defun process-define-method-combination-arguments-lambda-list
|
||||
(lambda-list generic-function body)
|
||||
(declare (si::c-local))
|
||||
(when (null lambda-list)
|
||||
(return-from process-define-method-combination-arguments-lambda-list body))
|
||||
(let ((whole (when (eq (first lambda-list) '&whole)
|
||||
(prog1 (second lambda-list)
|
||||
(setf lambda-list (cddr lambda-list))))))
|
||||
(multiple-value-bind (requireds optionals rest key-flag keywords
|
||||
allow-other-keys aux-vars)
|
||||
(si::process-lambda-list lambda-list 'function)
|
||||
(declare (ignore allow-other-keys key-flag))
|
||||
;; This is a little complicated. We are constructing a form
|
||||
;; which when evaluated constructs another form that finally
|
||||
;; implements the desired destructuring of arguments supplied to
|
||||
;; the generic function.
|
||||
;;
|
||||
;; First evaluate the body form containing the grouping of the
|
||||
;; methods and the user-supplied method-combination body in a
|
||||
;; context in which all free variables are bound to fresh
|
||||
;; symbols (we use the name of the free variable itself). This
|
||||
;; part happens when the method combination is defined.
|
||||
`(let ((result (let ,(mapcar #'(lambda (v) `(,v ',v))
|
||||
(append (when whole (list whole))
|
||||
(rest requireds)
|
||||
(loop for o on (rest optionals) by #'cdddr
|
||||
collect (first o)
|
||||
when (third o) collect (third o))
|
||||
(when rest (list rest))
|
||||
(loop for k on (rest keywords) by #'cddddr
|
||||
collect (second k)
|
||||
when (fourth k) collect (fourth k))
|
||||
(loop for a on (rest aux-vars) by #'cddr
|
||||
collect (first a))))
|
||||
,body)))
|
||||
;; Second, construct a form which implements the required
|
||||
;; complex reshuffling of arguments. This part happens after
|
||||
;; a generic function using the method combination is
|
||||
;; defined.
|
||||
(method-combination-arguments-reshuffling
|
||||
',whole
|
||||
',lambda-list
|
||||
(generic-function-lambda-list ,generic-function)
|
||||
result)))))
|
||||
|
||||
(defmacro with-method-groups ((&rest method-groups) &body body)
|
||||
(let (group-names matchers cleanup)
|
||||
(flet ((parse-qualifier-pattern (pattern)
|
||||
(cond ((eq pattern '*) 't)
|
||||
((eq pattern nil) '(null .method-qualifiers.))
|
||||
((symbolp pattern) `(,pattern .method-qualifiers.))
|
||||
((listp pattern)
|
||||
`(do ((pattern ',pattern (cdr pattern))
|
||||
(qualifiers .method-qualifiers. (cdr qualifiers)))
|
||||
((or (eq pattern '*)
|
||||
(and (null pattern)
|
||||
(null qualifiers)))
|
||||
t)
|
||||
(unless (and pattern qualifiers
|
||||
(or (eq (car pattern) '*)
|
||||
(eq (car pattern) (car qualifiers))))
|
||||
(return nil))))
|
||||
(t
|
||||
(error "Invalid method group pattern ~s." pattern)))))
|
||||
(dolist (group method-groups)
|
||||
(destructuring-bind (name pattern &key description
|
||||
(order :most-specific-first)
|
||||
(required nil))
|
||||
group
|
||||
(declare (ignore description))
|
||||
(push name group-names)
|
||||
(push `(,(parse-qualifier-pattern pattern) (push .method. ,name))
|
||||
matchers)
|
||||
(when required
|
||||
(push `(unless ,name
|
||||
(error "No methods in required group ~S." ',name))
|
||||
cleanup))
|
||||
(case order
|
||||
(:most-specific-first
|
||||
(push `(setf ,name (nreverse ,name)) cleanup))
|
||||
(:most-specific-last)
|
||||
(otherwise
|
||||
(push `(when (eq ,order :most-specific-first)
|
||||
(setf ,name (nreverse ,name)))
|
||||
cleanup))))))
|
||||
`(let ,group-names
|
||||
(dolist (.method. .methods-list.)
|
||||
(let ((.method-qualifiers. (method-qualifiers .method.)))
|
||||
(declare (ignorable .method-qualifiers.))
|
||||
(cond ,@(nreverse matchers)
|
||||
,@(unless (member t matchers :key #'car)
|
||||
`((t (invalid-method-error
|
||||
.method.
|
||||
"Method qualifiers ~s are not allowed." .method-qualifiers.)))))))
|
||||
,@cleanup
|
||||
,@body)))
|
||||
|
||||
(defun define-complex-method-combination (form)
|
||||
(declare (si::c-local))
|
||||
(flet ((syntax-error ()
|
||||
(error "~S is not a valid DEFINE-METHOD-COMBINATION form." form)))
|
||||
(destructuring-bind (name lambda-list method-groups &rest body
|
||||
&aux (generic-function '.generic-function.)
|
||||
(arguments nil))
|
||||
form
|
||||
(let ((x (first body)))
|
||||
(when (and (consp x) (eql (first x) :ARGUMENTS))
|
||||
(setf body (rest body))
|
||||
(setf arguments (rest x))))
|
||||
(let ((x (first body)))
|
||||
(when (and (consp x) (eql (first x) :GENERIC-FUNCTION))
|
||||
(setf body (rest body))
|
||||
(setf generic-function (second x))))
|
||||
(unless (and (symbolp name) (symbolp generic-function))
|
||||
(error "~S is not a valid DEFINE-METHOD-COMBINATION form." form))
|
||||
(multiple-value-setq (decls body documentation)
|
||||
(si::find-declarations body t))
|
||||
`(progn
|
||||
,@(si::expand-set-documentation name 'method-combination documentation)
|
||||
(install-method-combination ',name
|
||||
(lambda (,generic-function .methods-list. ,@lambda-list)
|
||||
(declare (ignorable ,generic-function))
|
||||
,@decls
|
||||
(block ,name
|
||||
(effective-method-function
|
||||
,(process-define-method-combination-arguments-lambda-list
|
||||
arguments generic-function
|
||||
`(with-method-groups ,method-groups ,@body))
|
||||
t))))))))
|
||||
|
||||
(defmacro define-method-combination (name &body body)
|
||||
(if (and body (listp (first body)))
|
||||
(define-complex-method-combination (list* name body))
|
||||
(apply #'define-simple-method-combination name body)))
|
||||
|
||||
(defun method-combination-error (format-control &rest args)
|
||||
;; FIXME! We should emit a more detailed error!
|
||||
(error "Method-combination error:~%~S"
|
||||
(apply #'format nil format-control args)))
|
||||
|
||||
(defun invalid-method-error (method format-control &rest args)
|
||||
(error "Invalid method error for ~A~%~S"
|
||||
method
|
||||
(apply #'format nil format-control args)))
|
||||
(combine-method-functions (first primary) (rest primary)))) )))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; COMPUTE-EFFECTIVE-METHOD
|
||||
|
|
@ -501,16 +209,3 @@
|
|||
(defun compute-effective-method (gf method-combination applicable-methods)
|
||||
`(funcall ,(std-compute-effective-method gf method-combination applicable-methods)
|
||||
.combined-method-args. *next-methods*))
|
||||
|
||||
(install-method-combination 'standard 'standard-compute-effective-method)
|
||||
(progn
|
||||
(define-method-combination progn :identity-with-one-argument t)
|
||||
(define-method-combination and :identity-with-one-argument t)
|
||||
(define-method-combination max :identity-with-one-argument t)
|
||||
(define-method-combination + :identity-with-one-argument t)
|
||||
(define-method-combination nconc :identity-with-one-argument t)
|
||||
(define-method-combination append :identity-with-one-argument nil)
|
||||
(define-method-combination list :identity-with-one-argument nil)
|
||||
(define-method-combination min :identity-with-one-argument t)
|
||||
(define-method-combination or :identity-with-one-argument t))
|
||||
|
||||
|
|
|
|||
316
src/clos/defcombin.lsp
Normal file
316
src/clos/defcombin.lsp
Normal file
|
|
@ -0,0 +1,316 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: CLOS -*-
|
||||
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
||||
|
||||
;;;;
|
||||
;;;; Copyright (c) 1992, Giuseppe Attardi
|
||||
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll
|
||||
;;;; Copyright (c) 2023, Daniel Kochmański
|
||||
;;;; Copyright (c) 2023, Marius Gerbershagen
|
||||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
;;;;
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; DEFINE-METHOD-COMBINATION
|
||||
;;
|
||||
;; METHOD-COMBINATION objects are just a list
|
||||
;; (name arg*)
|
||||
;; where NAME is the name of the method combination type defined with
|
||||
;; DEFINE-METHOD-COMBINATION, and ARG* is zero or more arguments.
|
||||
;;
|
||||
;; For each method combination type there is an associated function,
|
||||
;; and the list of all known method combination types is kept in
|
||||
;; *METHOD-COMBINATIONS* in the form of property list:
|
||||
;; (mc-type-name1 function1 mc-type-name2 function2 ....)
|
||||
;;
|
||||
;; FUNCTIONn is the function associated to a method combination. It
|
||||
;; is of type (FUNCTION (generic-function method-list) FUNCTION),
|
||||
;; and it outputs an anonymous function which is the effective method.
|
||||
;;
|
||||
|
||||
#+threads
|
||||
(defparameter *method-combinations-lock* (mp:make-lock :name 'find-method-combination))
|
||||
(defparameter *method-combinations* (make-hash-table :size 32 :test 'eq))
|
||||
|
||||
(defun search-method-combination (name)
|
||||
(mp:with-lock (*method-combinations-lock*)
|
||||
(or (gethash name *method-combinations*)
|
||||
(error "~A does not name a method combination" name))))
|
||||
|
||||
(defun install-method-combination (name function)
|
||||
(mp:with-lock (*method-combinations-lock*)
|
||||
(setf (gethash name *method-combinations*) function))
|
||||
name)
|
||||
|
||||
(defun make-method-combination (name compiler options)
|
||||
(with-early-make-instance +method-combination-slots+
|
||||
(o (find-class 'method-combination)
|
||||
:name name
|
||||
:compiler compiler
|
||||
:options options)
|
||||
o))
|
||||
|
||||
(defun find-method-combination (gf method-combination-type-name method-combination-options)
|
||||
(declare (ignore gf))
|
||||
(make-method-combination method-combination-type-name
|
||||
(search-method-combination method-combination-type-name)
|
||||
method-combination-options
|
||||
))
|
||||
|
||||
(defun define-simple-method-combination (name &key documentation
|
||||
identity-with-one-argument
|
||||
(operator name))
|
||||
`(define-method-combination ,name (&optional (order :MOST-SPECIFIC-FIRST))
|
||||
((around (:AROUND))
|
||||
(principal (,name) :REQUIRED t))
|
||||
,documentation
|
||||
(let ((main-effective-method
|
||||
`(,',operator ,@(mapcar #'(lambda (x) `(CALL-METHOD ,x NIL))
|
||||
(if (eql order :MOST-SPECIFIC-LAST)
|
||||
(reverse principal)
|
||||
principal)))))
|
||||
(cond (around
|
||||
`(call-method ,(first around)
|
||||
(,@(rest around) (make-method ,main-effective-method))))
|
||||
(,(if identity-with-one-argument
|
||||
'(rest principal)
|
||||
t)
|
||||
main-effective-method)
|
||||
(t (second main-effective-method))))))
|
||||
|
||||
(defun method-combination-arguments-reshuffling (mc-whole-arg mc-lambda-list gf-lambda-list body)
|
||||
;; Implement the reshuffling of arguments to the generic function
|
||||
;; into arguments for a method-combination arguments lambda list
|
||||
;; required for the long form of DEFINE-METHOD-COMBINATION. The
|
||||
;; generic function arguments are stored in the variable
|
||||
;; .COMBINED-METHOD-ARGS. of type STACK-FRAME. To extract the
|
||||
;; arguments we apply to this stack frame a function whose
|
||||
;; lambda-list is built below by reshaping the method-combination
|
||||
;; lambda-list to fit the form of the generic-function lambda-list.
|
||||
(let ((lambda-list '())
|
||||
(let-statements '())
|
||||
(ignored-vars '())
|
||||
n-gf-requireds n-gf-optionals)
|
||||
(multiple-value-bind (mc-requireds mc-optionals mc-rest mc-key-flag mc-keywords
|
||||
mc-allow-other-keys mc-aux-vars)
|
||||
(si::process-lambda-list mc-lambda-list 'function)
|
||||
(declare (ignore mc-allow-other-keys))
|
||||
(multiple-value-bind (gf-requireds gf-optionals)
|
||||
(si::process-lambda-list gf-lambda-list 'function)
|
||||
(setf n-gf-requireds (first gf-requireds)
|
||||
n-gf-optionals (first gf-optionals))
|
||||
(when mc-whole-arg
|
||||
(push `(,mc-whole-arg (apply #'list .combined-method-args.))
|
||||
let-statements))
|
||||
(loop for r in (rest mc-requireds) by #'cdr
|
||||
for i from 0
|
||||
if (< i n-gf-requireds)
|
||||
do (push r lambda-list)
|
||||
else ; excess required args of the method-combination
|
||||
; are set to nil
|
||||
do (push `(,r nil) let-statements))
|
||||
;; excess required args of the generic-function are ignored
|
||||
(loop repeat (- n-gf-requireds (first mc-requireds))
|
||||
for v = (gensym)
|
||||
do (push v lambda-list)
|
||||
(push v ignored-vars))
|
||||
(push '&optional lambda-list)
|
||||
(loop for o on (rest mc-optionals) by #'cdddr
|
||||
for i from 0
|
||||
if (< i n-gf-optionals)
|
||||
do (push (if (third o)
|
||||
`(,(first o) ,(second o) ,(third o))
|
||||
`(,(first o) ,(second o)))
|
||||
lambda-list)
|
||||
else ; excess optional args of the method-combination
|
||||
; are set to their init forms
|
||||
do (push `(,(first o) ,(second o)) let-statements)
|
||||
(when (third o)
|
||||
(push `(,(third o) nil) let-statements)))
|
||||
;; excess args of the generic-function are ignored
|
||||
(loop repeat (- n-gf-optionals (first mc-optionals))
|
||||
for v = (gensym)
|
||||
do (push v lambda-list)
|
||||
(push v ignored-vars))
|
||||
(unless mc-rest
|
||||
(setf mc-rest (gensym))
|
||||
(push mc-rest ignored-vars))
|
||||
;; rest, keyword and aux args are treated as usual
|
||||
(push '&rest lambda-list)
|
||||
(push mc-rest lambda-list)
|
||||
(when mc-key-flag
|
||||
(push '&key lambda-list)
|
||||
(loop for k on (rest mc-keywords) by #'cddddr
|
||||
do (push (if (fourth k)
|
||||
`((,(first k) ,(second k)) ,(third k) ,(fourth k))
|
||||
`((,(first k) ,(second k)) ,(third k)))
|
||||
lambda-list))
|
||||
(push '&allow-other-keys lambda-list))
|
||||
(when mc-aux-vars
|
||||
(push '&aux lambda-list)
|
||||
(loop for a on mc-aux-vars by #'cddr
|
||||
do (push `(,(first a) ,(second a)) lambda-list)))
|
||||
`(apply #'(lambda ,(nreverse lambda-list)
|
||||
(declare (ignore ,@ignored-vars))
|
||||
(let ,(nreverse let-statements)
|
||||
,body))
|
||||
.combined-method-args.)))))
|
||||
|
||||
(defun process-define-method-combination-arguments-lambda-list
|
||||
(lambda-list generic-function body)
|
||||
(declare (si::c-local))
|
||||
(when (null lambda-list)
|
||||
(return-from process-define-method-combination-arguments-lambda-list body))
|
||||
(let ((whole (when (eq (first lambda-list) '&whole)
|
||||
(prog1 (second lambda-list)
|
||||
(setf lambda-list (cddr lambda-list))))))
|
||||
(multiple-value-bind (requireds optionals rest key-flag keywords
|
||||
allow-other-keys aux-vars)
|
||||
(si::process-lambda-list lambda-list 'function)
|
||||
(declare (ignore allow-other-keys key-flag))
|
||||
;; This is a little complicated. We are constructing a form
|
||||
;; which when evaluated constructs another form that finally
|
||||
;; implements the desired destructuring of arguments supplied to
|
||||
;; the generic function.
|
||||
;;
|
||||
;; First evaluate the body form containing the grouping of the
|
||||
;; methods and the user-supplied method-combination body in a
|
||||
;; context in which all free variables are bound to fresh
|
||||
;; symbols (we use the name of the free variable itself). This
|
||||
;; part happens when the method combination is defined.
|
||||
`(let ((result (let ,(mapcar #'(lambda (v) `(,v ',v))
|
||||
(append (when whole (list whole))
|
||||
(rest requireds)
|
||||
(loop for o on (rest optionals) by #'cdddr
|
||||
collect (first o)
|
||||
when (third o) collect (third o))
|
||||
(when rest (list rest))
|
||||
(loop for k on (rest keywords) by #'cddddr
|
||||
collect (second k)
|
||||
when (fourth k) collect (fourth k))
|
||||
(loop for a on (rest aux-vars) by #'cddr
|
||||
collect (first a))))
|
||||
,body)))
|
||||
;; Second, construct a form which implements the required
|
||||
;; complex reshuffling of arguments. This part happens after
|
||||
;; a generic function using the method combination is
|
||||
;; defined.
|
||||
(method-combination-arguments-reshuffling
|
||||
',whole
|
||||
',lambda-list
|
||||
(generic-function-lambda-list ,generic-function)
|
||||
result)))))
|
||||
|
||||
(defmacro with-method-groups ((&rest method-groups) &body body)
|
||||
(let (group-names matchers cleanup)
|
||||
(flet ((parse-qualifier-pattern (pattern)
|
||||
(cond ((eq pattern '*) 't)
|
||||
((eq pattern nil) '(null .method-qualifiers.))
|
||||
((symbolp pattern) `(,pattern .method-qualifiers.))
|
||||
((listp pattern)
|
||||
`(do ((pattern ',pattern (cdr pattern))
|
||||
(qualifiers .method-qualifiers. (cdr qualifiers)))
|
||||
((or (eq pattern '*)
|
||||
(and (null pattern)
|
||||
(null qualifiers)))
|
||||
t)
|
||||
(unless (and pattern qualifiers
|
||||
(or (eq (car pattern) '*)
|
||||
(eq (car pattern) (car qualifiers))))
|
||||
(return nil))))
|
||||
(t
|
||||
(error "Invalid method group pattern ~s." pattern)))))
|
||||
(dolist (group method-groups)
|
||||
(destructuring-bind (name pattern &key description
|
||||
(order :most-specific-first)
|
||||
(required nil))
|
||||
group
|
||||
(declare (ignore description))
|
||||
(push name group-names)
|
||||
(push `(,(parse-qualifier-pattern pattern) (push .method. ,name))
|
||||
matchers)
|
||||
(when required
|
||||
(push `(unless ,name
|
||||
(error "No methods in required group ~S." ',name))
|
||||
cleanup))
|
||||
(case order
|
||||
(:most-specific-first
|
||||
(push `(setf ,name (nreverse ,name)) cleanup))
|
||||
(:most-specific-last)
|
||||
(otherwise
|
||||
(push `(when (eq ,order :most-specific-first)
|
||||
(setf ,name (nreverse ,name)))
|
||||
cleanup))))))
|
||||
`(let ,group-names
|
||||
(dolist (.method. .methods-list.)
|
||||
(let ((.method-qualifiers. (method-qualifiers .method.)))
|
||||
(declare (ignorable .method-qualifiers.))
|
||||
(cond ,@(nreverse matchers)
|
||||
,@(unless (member t matchers :key #'car)
|
||||
`((t (invalid-method-error
|
||||
.method.
|
||||
"Method qualifiers ~s are not allowed." .method-qualifiers.)))))))
|
||||
,@cleanup
|
||||
,@body)))
|
||||
|
||||
(defun define-complex-method-combination (form)
|
||||
(declare (si::c-local))
|
||||
(flet ((syntax-error ()
|
||||
(error "~S is not a valid DEFINE-METHOD-COMBINATION form." form)))
|
||||
(destructuring-bind (name lambda-list method-groups &rest body
|
||||
&aux (generic-function '.generic-function.)
|
||||
(arguments nil))
|
||||
form
|
||||
(let ((x (first body)))
|
||||
(when (and (consp x) (eql (first x) :ARGUMENTS))
|
||||
(setf body (rest body))
|
||||
(setf arguments (rest x))))
|
||||
(let ((x (first body)))
|
||||
(when (and (consp x) (eql (first x) :GENERIC-FUNCTION))
|
||||
(setf body (rest body))
|
||||
(setf generic-function (second x))))
|
||||
(unless (and (symbolp name) (symbolp generic-function))
|
||||
(error "~S is not a valid DEFINE-METHOD-COMBINATION form." form))
|
||||
(multiple-value-setq (decls body documentation)
|
||||
(si::find-declarations body t))
|
||||
`(progn
|
||||
,@(si::expand-set-documentation name 'method-combination documentation)
|
||||
(install-method-combination ',name
|
||||
(lambda (,generic-function .methods-list. ,@lambda-list)
|
||||
(declare (ignorable ,generic-function))
|
||||
,@decls
|
||||
(block ,name
|
||||
(effective-method-function
|
||||
,(process-define-method-combination-arguments-lambda-list
|
||||
arguments generic-function
|
||||
`(with-method-groups ,method-groups ,@body))
|
||||
t))))))))
|
||||
|
||||
(defmacro define-method-combination (name &body body)
|
||||
(if (and body (listp (first body)))
|
||||
(define-complex-method-combination (list* name body))
|
||||
(apply #'define-simple-method-combination name body)))
|
||||
|
||||
(defun method-combination-error (format-control &rest args)
|
||||
;; FIXME! We should emit a more detailed error!
|
||||
(error "Method-combination error:~%~S"
|
||||
(apply #'format nil format-control args)))
|
||||
|
||||
(defun invalid-method-error (method format-control &rest args)
|
||||
(error "Invalid method error for ~A~%~S"
|
||||
method
|
||||
(apply #'format nil format-control args)))
|
||||
|
||||
(install-method-combination 'standard 'standard-compute-effective-method)
|
||||
(progn
|
||||
(define-method-combination progn :identity-with-one-argument t)
|
||||
(define-method-combination and :identity-with-one-argument t)
|
||||
(define-method-combination max :identity-with-one-argument t)
|
||||
(define-method-combination + :identity-with-one-argument t)
|
||||
(define-method-combination nconc :identity-with-one-argument t)
|
||||
(define-method-combination append :identity-with-one-argument nil)
|
||||
(define-method-combination list :identity-with-one-argument nil)
|
||||
(define-method-combination min :identity-with-one-argument t)
|
||||
(define-method-combination or :identity-with-one-argument t))
|
||||
|
|
@ -13,6 +13,7 @@
|
|||
"src:clos;kernel.lsp"
|
||||
"src:clos;method.lsp"
|
||||
"src:clos;combin.lsp"
|
||||
"src:clos;defcombin.lsp"
|
||||
"src:clos;std-accessors.lsp"
|
||||
"src:clos;defclass.lsp"
|
||||
"src:clos;slotvalue.lsp"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue