mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-26 06:22:33 -08:00
Merge branch 'method-combinations' into 'develop'
various cleanups See merge request embeddable-common-lisp/ecl!284
This commit is contained in:
Marius Gerbershagen
commit
f0d3dc4b6d
11 changed files with 395 additions and 323 deletions
|
|
@ -2885,16 +2885,15 @@ si_process_lambda(cl_object lambda)
|
|||
* VALUES(5) = allow-other-keys ; flag &allow-other-keys
|
||||
* VALUES(6) = (N aux1 init1 ... ) ; auxiliary variables
|
||||
*
|
||||
* 1°) The prefix "N" is an integer value denoting the number of
|
||||
* variables which are declared within this section of the lambda
|
||||
* list.
|
||||
* 1) The prefix "N" is an integer value denoting the number of variables
|
||||
* which are declared within this section of the lambda list.
|
||||
*
|
||||
* 2°) The INIT* arguments are lisp forms which are evaluated when
|
||||
* no value is provided.
|
||||
* 2) The INIT* arguments are lisp forms which are evaluated when no value is
|
||||
* provided.
|
||||
*
|
||||
* 3°) The FLAG* arguments is the name of a variable which holds a
|
||||
* boolean value in case an optional or keyword argument was
|
||||
* provided. If it is NIL, no such variable exists.
|
||||
* 3) The FLAG* arguments is the name of a variable which holds a boolean
|
||||
* value in case an optional or keyword argument was provided. If it is NIL,
|
||||
* no such variable exists.
|
||||
*/
|
||||
|
||||
cl_object
|
||||
|
|
@ -3088,15 +3087,16 @@ si_process_lambda_list(cl_object org_lambda_list, cl_object context)
|
|||
|
||||
OUTPUT:
|
||||
if ((nreq+nopt+(!Null(rest))+nkey) >= ECL_CALL_ARGUMENTS_LIMIT)
|
||||
FEprogram_error("LAMBDA: Argument list is too long, ~S.", 1,
|
||||
org_lambda_list);
|
||||
@(return CONS(ecl_make_fixnum(nreq), lists[0])
|
||||
FEprogram_error("LAMBDA: Argument list is too long, ~S.", 1, org_lambda_list);
|
||||
|
||||
@(return
|
||||
CONS(ecl_make_fixnum(nreq), lists[0])
|
||||
CONS(ecl_make_fixnum(nopt), lists[1])
|
||||
rest
|
||||
key_flag
|
||||
CONS(ecl_make_fixnum(nkey), lists[2])
|
||||
allow_other_keys
|
||||
lists[3]);
|
||||
CONS(ecl_make_fixnum(naux), lists[3]))
|
||||
|
||||
ILLEGAL_LAMBDA:
|
||||
FEprogram_error("LAMBDA: Illegal lambda list ~S.", 1, org_lambda_list);
|
||||
|
|
@ -3195,7 +3195,7 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) {
|
|||
}
|
||||
ECL_RPLACD(aux, names);
|
||||
}
|
||||
|
||||
auxs = ECL_CONS_CDR(auxs);
|
||||
while (!Null(auxs)) { /* Local bindings */
|
||||
cl_object var = pop(&auxs);
|
||||
cl_object value = pop(&auxs);
|
||||
|
|
|
|||
|
|
@ -167,294 +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)))))
|
||||
|
||||
(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
|
||||
(group-names '())
|
||||
(group-checks '())
|
||||
(group-after '())
|
||||
(generic-function '.generic-function.)
|
||||
(method-arguments '())
|
||||
decls documentation arguments-lambda-list)
|
||||
form
|
||||
(unless (symbolp name) (syntax-error))
|
||||
(let ((x (first body)))
|
||||
(when (and (consp x) (eql (first x) :ARGUMENTS))
|
||||
(setf body (rest body)
|
||||
arguments-lambda-list (rest x))))
|
||||
(let ((x (first body)))
|
||||
(when (and (consp x) (eql (first x) :GENERIC-FUNCTION))
|
||||
(setf body (rest body))
|
||||
(unless (symbolp (setf generic-function (second x)))
|
||||
(syntax-error))))
|
||||
(multiple-value-setq (decls body documentation)
|
||||
(si::find-declarations body t))
|
||||
(dolist (group method-groups)
|
||||
(destructuring-bind (group-name predicate &key description
|
||||
(order :most-specific-first) (required nil))
|
||||
group
|
||||
(if (symbolp group-name)
|
||||
(push group-name group-names)
|
||||
(syntax-error))
|
||||
(let ((condition
|
||||
(cond ((eql predicate '*) 'T)
|
||||
((and predicate (symbolp predicate))
|
||||
`(,predicate .METHOD-QUALIFIERS.))
|
||||
((and (listp predicate)
|
||||
(let* ((q (last predicate 0))
|
||||
(p (copy-list (butlast predicate 0))))
|
||||
(when (every #'symbolp p)
|
||||
(if (eql q '*)
|
||||
`(every #'equal ',p .METHOD-QUALIFIERS.)
|
||||
`(equal ',p .METHOD-QUALIFIERS.))))))
|
||||
(t (syntax-error)))))
|
||||
(push `(,condition (push .METHOD. ,group-name)) group-checks))
|
||||
(when required
|
||||
(push `(unless ,group-name
|
||||
(error "Method combination: ~S. No methods ~
|
||||
in required group ~S." ',name ,group-name))
|
||||
group-after))
|
||||
(case order
|
||||
(:most-specific-first
|
||||
(push `(setf ,group-name (nreverse ,group-name)) group-after))
|
||||
(:most-specific-last)
|
||||
(otherwise
|
||||
(let ((order-var (gensym)))
|
||||
(setf group-names (append group-names (list (list order-var order)))
|
||||
group-after (list* `(when (eq ,order-var :most-specific-first)
|
||||
(setf ,group-name (nreverse ,group-name)))
|
||||
group-after)))))))
|
||||
`(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-lambda-list generic-function
|
||||
`(let (,@group-names)
|
||||
(dolist (.method. .methods-list.)
|
||||
(let ((.method-qualifiers. (method-qualifiers .method.)))
|
||||
(cond ,@(nreverse group-checks)
|
||||
(t (invalid-method-error .method.
|
||||
"Method qualifiers ~S are not allowed in the method-~
|
||||
combination ~S." .method-qualifiers. ',name)))))
|
||||
,@group-after
|
||||
,@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
|
||||
|
|
@ -496,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))
|
||||
|
||||
|
|
|
|||
317
src/clos/defcombin.lsp
Normal file
317
src/clos/defcombin.lsp
Normal file
|
|
@ -0,0 +1,317 @@
|
|||
;;;; -*- 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 (rest 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)
|
||||
decls documentation)
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -353,8 +353,9 @@
|
|||
(when (and key-flag (not allow-other-keys))
|
||||
(push `(si::check-keyword ,rest ',all-keys) extra-stmts))
|
||||
;; 7. construct body
|
||||
(pop aux-vars)
|
||||
(loop while aux-vars
|
||||
do (push (list (pop aux-vars) (pop aux-vars)) let-vars))
|
||||
do (push (list (pop aux-vars) (pop aux-vars)) let-vars))
|
||||
(values (nreverse (delete-if-not #'first let-vars))
|
||||
`(,@(and apply-var `((declare (ignorable ,apply-var))))
|
||||
,@(multiple-value-bind (decl body)
|
||||
|
|
|
|||
|
|
@ -303,7 +303,7 @@
|
|||
(extract-lambda-type-checks function-name requireds optionals
|
||||
keywords ts other-decls)
|
||||
(let* ((declarations other-decls)
|
||||
(let-vars (loop for spec on (nconc new-auxs aux-vars)
|
||||
(let-vars (loop for spec on (nconc new-auxs (rest aux-vars))
|
||||
by #'cddr
|
||||
for name = (first spec)
|
||||
for init = (second spec)
|
||||
|
|
|
|||
|
|
@ -613,9 +613,9 @@ keyword argument, the compiler-macro declines to provide an expansion.
|
|||
parse-forms-pass2))
|
||||
;; 5. &aux vars: these are simply set to their initforms after
|
||||
;; parsing of keywords has finished
|
||||
(loop for a on auxs
|
||||
do (push (first auxs) bindings-for-body)
|
||||
(push `(setf ,(first auxs) ,(second auxs)) aux-setf-forms))
|
||||
(loop for a on (rest auxs) by #'cddr
|
||||
do (push (first a) bindings-for-body)
|
||||
(push `(setf ,(first a) ,(second a)) aux-setf-forms))
|
||||
;; 6. Finally, we are ready to create the compiler-macro definition
|
||||
`(define-compiler-macro ,name ,(nreverse new-lambda-list)
|
||||
(let* ,(nreverse bindings-for-body)
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@
|
|||
,@(mapcar #'(lambda (form)
|
||||
`(let ((,n-res (cons ,form nil)))
|
||||
(cond (,n-tail
|
||||
(setf (cdr ,n-tail) ,n-res)
|
||||
(rplacd ,n-tail ,n-res)
|
||||
(setq ,n-tail ,n-res))
|
||||
(t
|
||||
(setq ,n-tail ,n-res ,n-value ,n-res)))))
|
||||
|
|
@ -95,7 +95,7 @@ Example:
|
|||
(let (macros binds)
|
||||
(dolist (spec collections)
|
||||
(cond ((atom spec)
|
||||
(setf spec (list spec)))
|
||||
(setq spec (list spec)))
|
||||
((not (<= 1 (length spec) 3))
|
||||
(error "Malformed collection specifier: ~S." spec)))
|
||||
(let ((n-value (gensym))
|
||||
|
|
@ -150,7 +150,7 @@ Example:
|
|||
`(progn ,@body)
|
||||
(let ((spec (first specs)))
|
||||
(cond ((atom spec)
|
||||
(setf spec (list spec spec)))
|
||||
(setq spec (list spec spec)))
|
||||
((/= (length spec) 2)
|
||||
(error "Malformed Once-Only binding spec: ~S." spec)))
|
||||
(let ((name (first spec))
|
||||
|
|
|
|||
|
|
@ -155,7 +155,7 @@
|
|||
(dm-v v `(if (eq ,temp 'missing-keyword) ,init ,temp))
|
||||
(when sv (dm-v sv `(not (eq ,temp 'missing-keyword))))
|
||||
(push k all-keywords)))
|
||||
(do ((l auxs (cddr l))) ((endp l))
|
||||
(do ((l (rest auxs) (cddr l))) ((endp l))
|
||||
(let* ((v (first l))
|
||||
(init (second l)))
|
||||
(dm-v v init)))
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
:default-component-class asdf:cl-source-file.lsp
|
||||
:components
|
||||
((:file "ansi")
|
||||
(:file "clos")
|
||||
(:file "mixed")
|
||||
(:file "compiler")
|
||||
(:file "executable-cli")
|
||||
|
|
|
|||
52
src/tests/normal-tests/clos.lsp
Normal file
52
src/tests/normal-tests/clos.lsp
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
|
||||
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
||||
|
||||
;;;; Author: Daniel Kochmański
|
||||
;;;; Created: 2023-01-19
|
||||
;;;; Contains: CLOS tests
|
||||
|
||||
(in-package #:cl-test)
|
||||
|
||||
(suite 'clos)
|
||||
|
||||
|
||||
;;; Method combination long form
|
||||
|
||||
;;; Check whether different types of wildcard patterns are correctly handled.
|
||||
;;; Most notably the symbol * in a pattern matches any method qualifier on
|
||||
;;; that position.
|
||||
(ext:with-clean-symbols (combin gf)
|
||||
(test clos.0001.combin/wildcard
|
||||
(define-method-combination combin ()
|
||||
((p1 (:wild :no))
|
||||
(p2 (:wild * *))
|
||||
(p3 (:wild . *))
|
||||
(pr *))
|
||||
`(list ,(length p1)
|
||||
,(length p2)
|
||||
,(length p3)
|
||||
,(length pr)))
|
||||
(defgeneric gf ()
|
||||
(:method-combination combin))
|
||||
(finishes (defmethod gf :wild :no ())) ; p1
|
||||
(finishes (defmethod gf :wild :x :y ())) ; p2
|
||||
(finishes (defmethod gf :wild ())) ; p3
|
||||
(finishes (defmethod gf :wild :foobar ())) ; p3
|
||||
(finishes (defmethod gf :wild :no :a :b ())) ; p3
|
||||
(finishes (defmethod gf :xxx :yyy 34 23 ())) ; p4
|
||||
(is-equal '(1 1 3 1) (gf))))
|
||||
|
||||
;;; This test checks whether define-method-combination handles arguments
|
||||
;;; :GENERIC-FUNCTION and :ARGUMENTS &WHOLE ARGS.
|
||||
(ext:with-clean-symbols (combin f1 f2)
|
||||
(test clos.0002.combin/arguments
|
||||
(define-method-combination combin ()
|
||||
((method-list *))
|
||||
(:arguments &whole args)
|
||||
(:generic-function gf)
|
||||
`(list ,gf ,args))
|
||||
(defgeneric f1 (a &key key-1)
|
||||
(:method-combination combin)
|
||||
(:method (a &key key-1 key-2)
|
||||
(declare (ignore a key-1 key-2))))
|
||||
(is-equal (list #'f1 1 :key-1 2) (f1 1 :key-1 2))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue