Changeset 13588


Ignore:
Timestamp:
09/08/11 21:43:31 (10 years ago)
Author:
ehuelsmann
Message:

Fix D-M-C (:ARGUMENTS ...) form and eliminate ugly +GF-ARGS-VAR+ hack.

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13587 r13588  
    999999       (if (eq ,not-exist ,value) ,init-form ,value))))
    10001000
    1001 (defconstant +gf-args-var+ (make-symbol "GF-ARGS-VAR"))
    1002 
    10031001(defun wrap-with-call-method-macro (gf args-var forms)
    10041002  `(macrolet
     
    10171015                       ;; with a binding for CALL-METHOD
    10181016                       ,(wrap-with-call-method-macro ,gf
    1019                                                      ,args-var
     1017                                                     ',args-var
    10201018                                                     (second method)))))
    10211019              (t (%method-function method)))
    1022             ,args-var
     1020            ,',args-var
    10231021            ,(unless (null next-method-list)
    10241022                     ;; by not generating an emf when there are no next methods,
     
    10281026     ,@forms))
    10291027
    1030 (defmacro with-args-lambda-list (args-lambda-list generic-function-symbol
    1031                                                   &body forms)
     1028(defmacro with-args-lambda-list (args-lambda-list
     1029                                 generic-function-symbol
     1030                                 gf-args-symbol
     1031                                 &body forms)
    10321032  (let ((gf-lambda-list (gensym))
    10331033        (nrequired (gensym))
     
    10361036    (multiple-value-bind (whole required optional rest keys aux)
    10371037        (parse-define-method-combination-arguments-lambda-list args-lambda-list)
    1038       `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list))
     1038      `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list))
    10391039              (,nrequired (length (extract-required-part ,gf-lambda-list)))
    10401040              (,noptional (length (extract-optional-part ,gf-lambda-list)))
    1041               (,rest-args (subseq ,+gf-args-var+ (+ ,nrequired ,noptional)))
    1042               ,@(when whole `((,whole ,+gf-args-var+)))
     1041              (,rest-args (subseq ,gf-args-symbol (+ ,nrequired ,noptional)))
     1042              ,@(when whole `((,whole ,gf-args-symbol)))
    10431043              ,@(loop for var in required and i upfrom 0
    10441044                  collect `(,var (when (< ,i ,nrequired)
    1045                                    (nth ,i ,+gf-args-var+))))
     1045                                   (nth ,i ,gf-args-symbol))))
    10461046              ,@(loop for (var init-form) in optional and i upfrom 0
    10471047                  collect
    10481048                  `(,var (if (< ,i ,noptional)
    1049                              (nth (+ ,nrequired ,i) ,+gf-args-var+)
     1049                             (nth (+ ,nrequired ,i) ,gf-args-symbol)
    10501050                             ,init-form)))
    10511051              ,@(when rest `((,rest ,rest-args)))
     
    11171117         ,(if (null args-lambda-list)
    11181118              `(lambda (,args-var)
    1119                  (let ((,+gf-args-var+ ,args-var))
    1120                    ,(wrap-with-call-method-macro generic-function-symbol
    1121                                                  args-var forms)))
     1119                 ,(wrap-with-call-method-macro generic-function-symbol
     1120                                               args-var forms))
    11221121              `(lambda (,args-var)
    1123                  (let ((,+gf-args-var+ ,args-var))
    1124                    ,(wrap-with-call-method-macro generic-function-symbol
    1125                                                  args-var
    1126                        `(with-args-lambda-list ,args-lambda-list
    1127                             ,generic-function-symbol
    1128                           ,@forms)))))))))
     1122                 (let* ((result
     1123                         (with-args-lambda-list ,args-lambda-list
     1124                             ,generic-function-symbol ,args-var
     1125                           ,@forms))
     1126                        (function
     1127                         `(lambda (,',args-var) ;; ugly: we're reusing it
     1128                          ;; to prevent calling gensym on every EMF invocation
     1129                          ,(wrap-with-call-method-macro ,generic-function-symbol
     1130                                                        ',args-var
     1131                                                        (list result)))))
     1132                   (funcall function ,args-var))))))))
    11291133
    11301134(defun declarationp (expr)
  • trunk/abcl/test/lisp/abcl/mop-tests.lisp

    r13582 r13588  
    472472  T)
    473473
    474 #|
    475 
    476 (progn (defvar *d-m-c-args-test* nil)
    477 (define-method-combination progn-with-lock ()
     474
     475;; Taken from SBCL: test that GF invocation arguments
     476;;   are correctly bound using the (:arguments ...) form
     477
     478(defparameter *dmc-test-4* nil)
     479
     480(defun object-lock (obj)
     481  (push "object-lock" *dmc-test-4*)
     482  obj)
     483(defun unlock (obj)
     484  (push "unlock" *dmc-test-4*)
     485  obj)
     486(defun lock (obj)
     487  (push "lock" *dmc-test-4*)
     488  obj)
     489
     490
     491(define-method-combination dmc-test-mc.4 ()
    478492  ((methods ()))
    479493  (:arguments object)
    480494  `(unwind-protect
    481     (progn (lock (object-lock ,object))
    482            ,@(mapcar #'(lambda (method)
    483                          `(call-method ,method))
    484                      methods))
    485     (unlock (object-lock ,object))))
    486 (defun object-lock (obj)
    487   (push "object-lock" *d-m-c-args-test*)
    488   obj)
    489 (defun unlock (obj)
    490   (push "unlock" *d-m-c-args-test*)
    491   obj)
    492 (defun lock (obj)
    493   (push "lock" *d-m-c-args-test*)
    494   obj)
    495 (defgeneric d-m-c-args-test (x)
     495        (progn (lock (object-lock ,object))
     496               ,@(mapcar #'(lambda (method)
     497                             `(call-method ,method))
     498                         methods))
     499     (unlock (object-lock ,object))))
     500
     501(defgeneric dmc-test.4 (x)
    496502  (:method-combination progn-with-lock))
    497 (defmethod d-m-c-args-test ((x symbol))
    498   (push "primary" *d-m-c-args-test*))
    499 (defmethod d-m-c-args-test ((x number))
    500   (error "foo")))
    501 
    502 |#
    503 
     503(defmethod dmc-test.4 ((x symbol))
     504  (push "primary" *dmc-test-4*))
     505(defmethod dmc-test.4 ((x number))
     506  (error "foo"))
     507
     508(deftest dmc-test.4a
     509    (progn
     510      (setq *dmc-test-4* nil)
     511      (values (equal (dmc-test.4 t) '("primary" "lock" "object-lock"))
     512              (equal *dmc-test-4* '("unlock" "object-lock"
     513                                    "primary" "lock" "object-lock"))))
     514  T T)
     515
     516(deftest dmc-test.4b
     517    (progn
     518      (setq *dmc-test-4* nil)
     519      (equal (dmc-test.4 1) '("unlock" "object-lock" "lock" "object-lock")))
     520  T)
    504521
    505522(defclass foo-class (standard-class))
     
    507524  t)
    508525
    509 (deftest validate-superclass.1 
    510     (mop:validate-superclass 
    511      (make-instance 'foo-class) 
     526(deftest validate-superclass.1
     527    (mop:validate-superclass
     528     (make-instance 'foo-class)
    512529     (make-instance 'standard-object))
    513530  t)
Note: See TracChangeset for help on using the changeset viewer.