Changeset 11139


Ignore:
Timestamp:
Oct 17, 2008, 5:35:56 PM (11 years ago)
Author:
gz
Message:

Propagate r8668 to trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/method-combination.lisp

    r11135 r11139  
    166166
    167167
    168 ; Need to special case (compute-effective-method #'compute-effective-method ...)
     168;;; Need to special case (compute-effective-method #'compute-effective-method ...)
    169169(defmethod compute-effective-method ((generic-function standard-generic-function)
    170170                                     (method-combination standard-method-combination)
     
    232232                           `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m nil)) primaries)))))
    233233               (make-effective-method
     234                generic-function
    234235                (if arounds
    235236                  `(call-method ,(car arounds)
     
    283284                                     methods)
    284285  (or (get-combined-method methods generic-function)
    285       (destructuring-bind (args-var . expander)
     286      (destructuring-bind ((args-var . gf-name) . expander)
    286287                          (method-combination-expander method-combination)
    287288        (let* ((user-form (funcall expander
     
    292293                (if (functionp user-form)
    293294                  user-form
    294                   (make-effective-method user-form args-var))))
     295                  (make-effective-method generic-function user-form args-var gf-name))))
    295296          (put-combined-method methods effective-method generic-function)))))
    296297
     
    347348         (logbitp $lfbits-nextmeth-bit lfbits))))
    348349
    349 (defun make-effective-method (form &optional (args-sym (make-symbol "ARGS")))
     350(defun make-effective-method (gf form  &optional (args-sym (make-symbol "ARGS")) (gf-name (make-symbol "GF")))
    350351  (setq args-sym (require-type args-sym 'symbol))
    351352  (let (m mf)
     
    361362       nil
    362363       `(lambda (&rest ,args-sym)
    363           (declare (dynamic-extent ,args-sym))
    364           (with-call-method-context ,args-sym
    365             ,form))
     364         (declare (dynamic-extent ,args-sym))
     365         (let* ((,gf-name ,gf))
     366           (declare (ignorable ,gf-name))
     367           (with-call-method-context ,args-sym
     368             ,form)))
    366369       nil))))
    367370
     
    437440      (maphash temp *effective-method-gfs*))))
    438441
     442;;; Support el-bizarro arglist partitioning for the long form of
     443;;; DEFINE-METHOD-COMBINATION.
     444(defun nth-required-gf-arg (gf argvals i)
     445  (declare (fixnum i))
     446  (let* ((bits (lfun-bits gf))
     447         (numreq (ldb $lfbits-numreq bits)))
     448    (declare (fixnum bits numreq))
     449    (if (< i numreq)
     450      (nth i argvals))))
     451
     452(defun nth-opt-gf-arg-present-p (gf argvals i)
     453  (declare (fixnum i))
     454  (let* ((bits (lfun-bits gf))
     455         (numreq (ldb $lfbits-numreq bits))
     456         (numopt (ldb $lfbits-numopt bits)))
     457    (declare (fixnum bits numreq numopt))
     458    (and (< i numopt)
     459         (< (the fixum (+ i numreq)) (length argvals)))))
     460
     461;;; This assumes that we've checked for argument presence.
     462(defun nth-opt-gf-arg (gf argvals i)
     463  (declare (fixnum i))
     464  (let* ((bits (lfun-bits gf))
     465         (numreq (ldb $lfbits-numreq bits)))
     466    (declare (fixnum bits numreq ))
     467    (nth (the fixum (+ i numreq)) argvals)))
     468
     469(defun gf-arguments-tail (gf argvals)
     470  (let* ((bits (lfun-bits gf))
     471         (numreq (ldb $lfbits-numreq bits))
     472         (numopt (ldb $lfbits-numopt bits)))
     473    (declare (fixnum bits numreq numopt))
     474    (nthcdr (the fixnum (+ numreq numopt)) argvals)))
     475
     476(defun gf-key-present-p (gf argvals key)
     477  (let* ((tail (gf-arguments-tail gf argvals))
     478         (missing (cons nil nil)))
     479    (declare (dynamic-extent missing))
     480    (not (eq missing (getf tail key missing)))))
     481
     482;; Again, this should only be called if GF-KEY-PRESENT-P returns true.
     483(defun gf-key-value (gf argvals key)
     484  (let* ((tail (gf-arguments-tail gf argvals)))
     485    (getf tail key))) 
     486 
     487
     488(defun lfmc-bindings (gf-form args-form lambda-list)
     489  (let* ((req-idx 0)
     490         (opt-idx 0)
     491         (state :required))
     492    (collect ((names)
     493              (vals))
     494      (dolist (arg lambda-list)
     495        (case arg
     496          ((&whole &optional &rest &key &allow-other-keys &aux)
     497           (setq state arg))
     498          (t
     499           (case state
     500             (:required
     501              (names arg)
     502              (vals (list 'quote `(nth-required-gf-arg ,gf-form ,args-form ,req-idx)))
     503              (incf req-idx))
     504             (&whole
     505              (names arg)
     506              (vals `,args-form)
     507              (setq state :required))
     508             (&optional
     509              (let* ((var arg)
     510                     (val nil)
     511                     (spvar nil))
     512                (when (listp arg)
     513                  (setq var (pop arg)
     514                        val (pop arg)
     515                        spvar (car arg)))
     516                (names var)
     517                (vals (list 'quote
     518                            `(if (nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx)
     519                              (nth-opt-gf-arg ,gf-form ,args-form ,opt-idx)
     520                              ,val)))
     521                (when spvar
     522                  (names spvar)
     523                  (vals (list 'quote
     524                         `(nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx))))
     525                (incf opt-idx)))
     526             (&rest
     527              (names arg)
     528              (vals (list 'quote
     529                          `(gf-arguments-tail ,gf-form ,args-form))))
     530             (&key
     531              (let* ((var arg)
     532                     (keyword nil)
     533                     (val nil)
     534                     (spvar nil))
     535                (if (atom arg)
     536                  (setq keyword (make-symbol (symbol-name arg)))
     537                  (progn
     538                    (setq var (car arg))
     539                    (if (atom var)
     540                      (setq keyword (make-symbol (symbol-name var)))
     541                      (setq keyword (car var) var (cadr var)))
     542                    (setq val (cadr arg) spvar (caddr arg))))
     543                (names var)
     544                (vals (list 'quote `(if (gf-key-present-p ,gf-form ,args-form ',keyword)
     545                                     (gf-key-value ,gf-form ,args-form ',keyword)
     546                                     ,val)))
     547                (when spvar
     548                  (names spvar)
     549                  (vals (list 'quote `(gf-key-present-p ,gf-form ,args-form ',keyword))))))
     550             (&allow-other-keys)
     551             (&aux
     552              (cond ((atom arg)
     553                     (names arg)
     554                     (vals nil))
     555                    (t
     556                     (names (car arg))
     557                     (vals (list 'quote (cadr arg))))))))))
     558      (values (names) (vals)))))
    439559;;
    440560;; Long form
     
    468588               (args-sym (make-symbol "ARGS"))
    469589               (options-sym (make-symbol "OPTIONS"))
     590               (arg-vars ())
     591               (arg-vals ())
    470592               (code `(lambda (,generic-fn-symbol ,methods-sym ,options-sym)
    471593                        ,@(unless gf-symbol-specified?
    472594                            `((declare (ignore-if-unused ,generic-fn-symbol))))
    473                         (let* (,@(let* ((n -1)
    474                                         (temp #'(lambda (sym)
    475                                                   `(,sym '(nth ,(incf n) ,args-sym)))))
    476                                    (declare (dynamic-extent temp))
    477                                    (mapcar temp arguments)))
     595                        (let* (,@(progn
     596                                  (multiple-value-setq (arg-vars arg-vals)
     597                                    (lfmc-bindings generic-fn-symbol
     598                                                   args-sym
     599                                                   arguments))
     600                                  (mapcar #'list arg-vars arg-vals)))
     601                          (declare (ignorable ,@arg-vars))
    478602                          ,@decls
    479603                          (destructuring-bind ,lambda-list ,options-sym
     
    487611                              ,@body))))))
    488612          `(%long-form-define-method-combination
    489             ',name (cons ',args-sym #',code) ',doc))))))
     613            ',name (cons (cons ',args-sym ',generic-fn-symbol) #',code) ',doc))))))
    490614
    491615(defun %long-form-define-method-combination (name args-var.expander documentation)
Note: See TracChangeset for help on using the changeset viewer.