Commit 72da63ab authored by Pascal Costanza's avatar Pascal Costanza
Browse files

Added a utility function required-args.

darcs-hash:a6d51c1d634b093f9403635cb3ec6230bba703b1
parent 40f5f703
......@@ -117,6 +117,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:accessor-method-slot-definition
#:add-dependent
......
(in-package :closer-mop)
;; This is a useful utility function.
(defun required-args (lambda-list &optional (collector #'identity))
(loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (funcall collector arg)))
;; We need a new standard-class for various things.
(cl:defclass standard-class (cl:standard-class)
......@@ -150,9 +157,7 @@
(defun ensure-method (gf lambda-expression
&key (qualifiers ())
(lambda-list (cadr lambda-expression))
(specializers (loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (find-class 't))))
(specializers (required-args lambda-list (constantly (find-class 't)))))
(funcall (compile nil `(lambda ()
(defmethod ,(generic-function-name gf) ,@qualifiers
,(loop for specializer in specializers
......
......@@ -110,6 +110,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:accessor-method-slot-definition
#:add-dependent
......
(in-package :closer-mop)
;; This is a useful utility function.
(defun required-args (lambda-list &optional (collector #'identity))
(loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (funcall collector arg)))
(defun ensure-method (gf lambda-expression
&key (qualifiers ())
(lambda-list (cadr lambda-expression))
(specializers (loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (find-class 't))))
(specializers (required-args lambda-list (constantly 't))))
(funcall (compile nil `(lambda ()
(defmethod ,(generic-function-name gf) ,@qualifiers
,(loop for specializer in specializers
......
......@@ -120,6 +120,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#-lispworks4.3 #:accessor-method-slot-definition
#:add-dependent
......
(in-package :closer-mop)
;; This is a useful utility function.
(defun required-args (lambda-list &optional (collector #'identity))
(loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (funcall collector arg)))
;; We need a new standard-generic-function for various things.
(cl:defclass standard-generic-function (cl:standard-generic-function)
......@@ -407,9 +414,7 @@
&key (method-class (generic-function-method-class gf))
(qualifiers ())
(lambda-list (cadr lambda-expression))
(specializers (loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (find-class 't))))
(specializers (required-args lambda-list (constantly (find-class 't)))))
(multiple-value-bind
(method-lambda method-args)
(make-method-lambda
......
......@@ -115,6 +115,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:accessor-method-slot-definition
#:add-dependent
......
(in-package :closer-mop)
;; This is a useful utility function.
(defun required-args (lambda-list &optional (collector #'identity))
(loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (funcall collector arg)))
#-openmcl
(progn
;; We need a new standard-class for various things.
......@@ -107,9 +114,7 @@
(defun ensure-method (gf lambda-expression
&key (qualifiers ())
(lambda-list (cadr lambda-expression))
(specializers (loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (find-class 't))))
(specializers (required-args lambda-list (constantly (find-class 't)))))
(eval `(defmethod ,(generic-function-name gf) ,@qualifiers
,(loop for specializer in specializers
for (arg . rest) on lambda-list
......
......@@ -115,6 +115,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:accessor-method-slot-definition
#:add-dependent
......
(in-package :closer-mop)
;; This is a useful utility function.
(defun required-args (lambda-list &optional (collector #'identity))
(loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (funcall collector arg)))
;; The following is commented out. SBCL now supports compatible standard-class and
;; funcallable-standard-class metaclasses, but this requires that we don't mess with
;; the class hierarchy anymore. So we will try the trick we have already used
......@@ -151,9 +158,7 @@
&key (method-class (generic-function-method-class gf))
(qualifiers ())
(lambda-list (cadr lambda-expression))
(specializers (loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect (find-class 't))))
(specializers (required-args lambda-list (constantly (find-class 't)))))
(multiple-value-bind
(method-lambda method-args)
(make-method-lambda
......@@ -181,9 +186,7 @@
(defun ensure-method (gf lambda-expression
&key (qualifiers ())
(lambda-list (cadr lambda-expression))
(specializers (loop for arg in lambda-list
until (member arg lambda-list-keywords)
collect 't)))
(specializers (required-args lambda-list (constantly 't))))
(funcall (compile nil `(lambda ()
(defmethod ,(generic-function-name gf) ,@qualifiers
,(loop for specializer in specializers
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment