[armedbear-cvs] r13588 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Thu Sep 8 21:43:33 UTC 2011
Author: ehuelsmann
Date: Thu Sep 8 14:43:31 2011
New Revision: 13588
Log:
Fix D-M-C (:ARGUMENTS ...) form and eliminate ugly +GF-ARGS-VAR+ hack.
Modified:
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/test/lisp/abcl/mop-tests.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Sep 8 11:45:19 2011 (r13587)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Sep 8 14:43:31 2011 (r13588)
@@ -998,8 +998,6 @@
`(let ((,value (getf ,plist ,key ,not-exist)))
(if (eq ,not-exist ,value) ,init-form ,value))))
-(defconstant +gf-args-var+ (make-symbol "GF-ARGS-VAR"))
-
(defun wrap-with-call-method-macro (gf args-var forms)
`(macrolet
((call-method (method &optional next-method-list)
@@ -1016,10 +1014,10 @@
;; the null lexical environment augmented
;; with a binding for CALL-METHOD
,(wrap-with-call-method-macro ,gf
- ,args-var
+ ',args-var
(second method)))))
(t (%method-function method)))
- ,args-var
+ ,',args-var
,(unless (null next-method-list)
;; by not generating an emf when there are no next methods,
;; we ensure next-method-p returns NIL
@@ -1027,26 +1025,28 @@
,gf (process-next-method-list next-method-list))))))
, at forms))
-(defmacro with-args-lambda-list (args-lambda-list generic-function-symbol
- &body forms)
+(defmacro with-args-lambda-list (args-lambda-list
+ generic-function-symbol
+ gf-args-symbol
+ &body forms)
(let ((gf-lambda-list (gensym))
(nrequired (gensym))
(noptional (gensym))
(rest-args (gensym)))
(multiple-value-bind (whole required optional rest keys aux)
(parse-define-method-combination-arguments-lambda-list args-lambda-list)
- `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list))
+ `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list))
(,nrequired (length (extract-required-part ,gf-lambda-list)))
(,noptional (length (extract-optional-part ,gf-lambda-list)))
- (,rest-args (subseq ,+gf-args-var+ (+ ,nrequired ,noptional)))
- ,@(when whole `((,whole ,+gf-args-var+)))
+ (,rest-args (subseq ,gf-args-symbol (+ ,nrequired ,noptional)))
+ ,@(when whole `((,whole ,gf-args-symbol)))
,@(loop for var in required and i upfrom 0
collect `(,var (when (< ,i ,nrequired)
- (nth ,i ,+gf-args-var+))))
+ (nth ,i ,gf-args-symbol))))
,@(loop for (var init-form) in optional and i upfrom 0
collect
`(,var (if (< ,i ,noptional)
- (nth (+ ,nrequired ,i) ,+gf-args-var+)
+ (nth (+ ,nrequired ,i) ,gf-args-symbol)
,init-form)))
,@(when rest `((,rest ,rest-args)))
,@(loop for ((key var) init-form) in keys and i upfrom 0
@@ -1116,16 +1116,20 @@
,methods
,(if (null args-lambda-list)
`(lambda (,args-var)
- (let ((,+gf-args-var+ ,args-var))
- ,(wrap-with-call-method-macro generic-function-symbol
- args-var forms)))
+ ,(wrap-with-call-method-macro generic-function-symbol
+ args-var forms))
`(lambda (,args-var)
- (let ((,+gf-args-var+ ,args-var))
- ,(wrap-with-call-method-macro generic-function-symbol
- args-var
- `(with-args-lambda-list ,args-lambda-list
- ,generic-function-symbol
- , at forms)))))))))
+ (let* ((result
+ (with-args-lambda-list ,args-lambda-list
+ ,generic-function-symbol ,args-var
+ , at forms))
+ (function
+ `(lambda (,',args-var) ;; ugly: we're reusing it
+ ;; to prevent calling gensym on every EMF invocation
+ ,(wrap-with-call-method-macro ,generic-function-symbol
+ ',args-var
+ (list result)))))
+ (funcall function ,args-var))))))))
(defun declarationp (expr)
(and (consp expr) (eq (car expr) 'DECLARE)))
Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/mop-tests.lisp Thu Sep 8 11:45:19 2011 (r13587)
+++ trunk/abcl/test/lisp/abcl/mop-tests.lisp Thu Sep 8 14:43:31 2011 (r13588)
@@ -471,44 +471,61 @@
(typep error 'error))
T)
-#|
-(progn (defvar *d-m-c-args-test* nil)
-(define-method-combination progn-with-lock ()
- ((methods ()))
- (:arguments object)
- `(unwind-protect
- (progn (lock (object-lock ,object))
- ,@(mapcar #'(lambda (method)
- `(call-method ,method))
- methods))
- (unlock (object-lock ,object))))
+;; Taken from SBCL: test that GF invocation arguments
+;; are correctly bound using the (:arguments ...) form
+
+(defparameter *dmc-test-4* nil)
+
(defun object-lock (obj)
- (push "object-lock" *d-m-c-args-test*)
+ (push "object-lock" *dmc-test-4*)
obj)
(defun unlock (obj)
- (push "unlock" *d-m-c-args-test*)
+ (push "unlock" *dmc-test-4*)
obj)
(defun lock (obj)
- (push "lock" *d-m-c-args-test*)
+ (push "lock" *dmc-test-4*)
obj)
-(defgeneric d-m-c-args-test (x)
- (:method-combination progn-with-lock))
-(defmethod d-m-c-args-test ((x symbol))
- (push "primary" *d-m-c-args-test*))
-(defmethod d-m-c-args-test ((x number))
- (error "foo")))
-|#
+(define-method-combination dmc-test-mc.4 ()
+ ((methods ()))
+ (:arguments object)
+ `(unwind-protect
+ (progn (lock (object-lock ,object))
+ ,@(mapcar #'(lambda (method)
+ `(call-method ,method))
+ methods))
+ (unlock (object-lock ,object))))
+
+(defgeneric dmc-test.4 (x)
+ (:method-combination progn-with-lock))
+(defmethod dmc-test.4 ((x symbol))
+ (push "primary" *dmc-test-4*))
+(defmethod dmc-test.4 ((x number))
+ (error "foo"))
+
+(deftest dmc-test.4a
+ (progn
+ (setq *dmc-test-4* nil)
+ (values (equal (dmc-test.4 t) '("primary" "lock" "object-lock"))
+ (equal *dmc-test-4* '("unlock" "object-lock"
+ "primary" "lock" "object-lock"))))
+ T T)
+
+(deftest dmc-test.4b
+ (progn
+ (setq *dmc-test-4* nil)
+ (equal (dmc-test.4 1) '("unlock" "object-lock" "lock" "object-lock")))
+ T)
(defclass foo-class (standard-class))
(defmethod mop:validate-superclass ((class foo-class) (superclass standard-object))
t)
-(deftest validate-superclass.1
- (mop:validate-superclass
- (make-instance 'foo-class)
+(deftest validate-superclass.1
+ (mop:validate-superclass
+ (make-instance 'foo-class)
(make-instance 'standard-object))
t)
More information about the armedbear-cvs
mailing list