Changeset 8668


Ignore:
Timestamp:
Mar 6, 2008, 3:40:11 PM (12 years ago)
Author:
gb
Message:

Try to address ticket:254 on the working-0711 branch, hopefully
without breaking anything in the process.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/method-combination.lisp

    r2325 r8668  
    165165
    166166
    167 ; Need to special case (compute-effective-method #'compute-effective-method ...)
     167;;; Need to special case (compute-effective-method
     168;;; #'compute-effective-method ...)
    168169(defmethod compute-effective-method ((generic-function standard-generic-function)
    169170                                     (method-combination standard-method-combination)
     
    231232                           `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m nil)) primaries)))))
    232233               (make-effective-method
     234                generic-function
    233235                (if arounds
    234236                  `(call-method ,(car arounds)
     
    282284                                     methods)
    283285  (or (get-combined-method methods generic-function)
    284       (destructuring-bind (args-var . expander)
     286      (destructuring-bind ((args-var . gf-name) . expander)
    285287                          (method-combination-expander method-combination)
    286288        (let* ((user-form (funcall expander
     
    288290                                   methods
    289291                                   (method-combination-options method-combination)))
     292               
    290293               (effective-method
    291294                (if (functionp user-form)
    292295                  user-form
    293                   (make-effective-method user-form args-var))))
     296                  (make-effective-method generic-function  user-form args-var gf-name))))
    294297          (put-combined-method methods effective-method generic-function)))))
    295298
     
    346349         (logbitp $lfbits-nextmeth-bit lfbits))))
    347350
    348 (defun make-effective-method (form &optional (args-sym (make-symbol "ARGS")))
     351(defun make-effective-method (gf form  &optional (args-sym (make-symbol "ARGS")) (gf-name (make-symbol "GF")))
    349352  (setq args-sym (require-type args-sym 'symbol))
    350353  (let (m mf)
     
    360363       nil
    361364       `(lambda (&rest ,args-sym)
    362           (declare (dynamic-extent ,args-sym))
    363           (with-call-method-context ,args-sym
    364             ,form))
     365         (declare (dynamic-extent ,args-sym))
     366         (let* ((,gf-name ,gf))
     367           (declare (ignorable ,gf-name))
     368           (with-call-method-context ,args-sym
     369             ,form)))
    365370       nil))))
    366371
     
    436441      (maphash temp *effective-method-gfs*))))
    437442
     443;;; Support el-bizarro arglist partitioning for the long form of
     444;;; DEFINE-METHOD-COMBINATION.
     445(defun nth-required-gf-arg (gf argvals i)
     446  (declare (fixnum i))
     447  (let* ((bits (lfun-bits gf))
     448         (numreq (ldb $lfbits-numreq bits)))
     449    (declare (fixnum bits numreq))
     450    (if (< i numreq)
     451      (nth i argvals))))
     452
     453(defun nth-opt-gf-arg-present-p (gf argvals i)
     454  (declare (fixnum i))
     455  (let* ((bits (lfun-bits gf))
     456         (numreq (ldb $lfbits-numreq bits))
     457         (numopt (ldb $lfbits-numopt bits)))
     458    (declare (fixnum bits numreq numopt))
     459    (and (< i numopt)
     460         (< (the fixum (+ i numreq)) (length argvals)))))
     461
     462;;; This assumes that we've checked for argument presence.
     463(defun nth-opt-gf-arg (gf argvals i)
     464  (declare (fixnum i))
     465  (let* ((bits (lfun-bits gf))
     466         (numreq (ldb $lfbits-numreq bits)))
     467    (declare (fixnum bits numreq ))
     468    (nth (the fixum (+ i numreq)) argvals)))
     469
     470(defun gf-arguments-tail (gf argvals)
     471  (let* ((bits (lfun-bits gf))
     472         (numreq (ldb $lfbits-numreq bits))
     473         (numopt (ldb $lfbits-numopt bits)))
     474    (declare (fixnum bits numreq numopt))
     475    (nthcdr (the fixnum (+ numreq numopt)) argvals)))
     476
     477(defun gf-key-present-p (gf argvals key)
     478  (let* ((tail (gf-arguments-tail gf argvals))
     479         (missing (cons nil nil)))
     480    (declare (dynamic-extent missing))
     481    (not (eq missing (getf tail key missing)))))
     482
     483;; Again, this should only be called if GF-KEY-PRESENT-P returns true.
     484(defun gf-key-value (gf argvals key)
     485  (let* ((tail (gf-arguments-tail gf argvals)))
     486    (getf tail key))) 
     487 
     488
     489(defun lfmc-bindings (gf-form args-form lambda-list)
     490  (let* ((req-idx 0)
     491         (opt-idx 0)
     492         (state :required))
     493    (collect ((names)
     494              (vals))
     495      (dolist (arg lambda-list)
     496        (case arg
     497          ((&whole &optional &rest &key &allow-other-keys &aux)
     498           (setq state arg))
     499          (t
     500           (case state
     501             (:required
     502              (names arg)
     503              (vals (list 'quote `(nth-required-gf-arg ,gf-form ,args-form ,req-idx)))
     504              (incf req-idx))
     505             (&whole
     506              (names arg)
     507              (vals `,args-form)
     508              (setq state :required))
     509             (&optional
     510              (let* ((var arg)
     511                     (val nil)
     512                     (spvar nil))
     513                (when (listp arg)
     514                  (setq var (pop arg)
     515                        val (pop arg)
     516                        spvar (car arg)))
     517                (names var)
     518                (vals (list 'quote
     519                            `(if (nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx)
     520                              (nth-opt-gf-arg ,gf-form ,args-form ,opt-idx)
     521                              ,val)))
     522                (when spvar
     523                  (names spvar)
     524                  (vals (list 'quote
     525                         `(nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx))))
     526                (incf opt-idx)))
     527             (&rest
     528              (names arg)
     529              (vals (list 'quote
     530                          `(gf-arguments-tail ,gf-form ,args-form))))
     531             (&key
     532              (let* ((var arg)
     533                     (keyword nil)
     534                     (val nil)
     535                     (spvar nil))
     536                (if (atom arg)
     537                  (setq keyword (make-symbol (symbol-name arg)))
     538                  (progn
     539                    (setq var (car arg))
     540                    (if (atom var)
     541                      (setq keyword (make-symbol (symbol-name var)))
     542                      (setq keyword (car var) var (cadr var)))
     543                    (setq val (cadr arg) spvar (caddr arg))))
     544                (names var)
     545                (vals (list 'quote `(if (gf-key-present-p ,gf-form ,args-form ',keyword)
     546                                     (gf-key-value ,gf-form ,args-form ',keyword)
     547                                     ,val)))
     548                (when spvar
     549                  (names spvar)
     550                  (vals (list 'quote `(gf-key-present-p ,gf-form ,args-form ',keyword))))))
     551             (&allow-other-keys)
     552             (&aux
     553              (cond ((atom arg)
     554                     (names arg)
     555                     (vals nil))
     556                    (t
     557                     (names (car arg))
     558                     (vals (list 'quote (cadr arg))))))))))
     559      (values (names) (vals)))))
    438560;;
    439561;; Long form
     
    467589               (args-sym (make-symbol "ARGS"))
    468590               (options-sym (make-symbol "OPTIONS"))
     591               (arg-vars ())
     592               (arg-vals ())
    469593               (code `(lambda (,generic-fn-symbol ,methods-sym ,options-sym)
    470594                        ,@(unless gf-symbol-specified?
    471595                            `((declare (ignore-if-unused ,generic-fn-symbol))))
    472                         (let* (,@(let* ((n -1)
    473                                         (temp #'(lambda (sym)
    474                                                   `(,sym '(nth ,(incf n) ,args-sym)))))
    475                                    (declare (dynamic-extent temp))
    476                                    (mapcar temp arguments)))
     596                        (let* (,@(progn
     597                                  (multiple-value-setq (arg-vars arg-vals)
     598                                    (lfmc-bindings generic-fn-symbol
     599                                                   args-sym
     600                                                   arguments))
     601                                  (mapcar #'list arg-vars arg-vals)))
     602                          (declare (ignorable ,@arg-vars))
    477603                          ,@decls
    478604                          (destructuring-bind ,lambda-list ,options-sym
     
    486612                              ,@body))))))
    487613          `(%long-form-define-method-combination
    488             ',name (cons ',args-sym #',code) ',doc))))))
     614            ',name (cons (cons ',args-sym ',generic-fn-symbol) #',code) ',doc))))))
    489615
    490616(defun %long-form-define-method-combination (name args-var.expander documentation)
Note: See TracChangeset for help on using the changeset viewer.