Changeset 5232


Ignore:
Timestamp:
12/20/03 18:12:01 (17 years ago)
Author:
piso
Message:

STD-COMPUTE-METHOD-FUNCTION: call WALK-FORM and omit CALL-NEXT-METHOD and NEXT-METHOD-P if possible.

File:
1 edited

Legend:

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

    r5229 r5232  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.51 2003-12-20 16:26:27 piso Exp $
     4;;; $Id: clos.lisp,v 1.52 2003-12-20 18:12:01 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    10631063    (setf (method-environment method) environment)
    10641064    (setf (method-generic-function method) nil)
    1065     (setf (method-function method)
    1066           (std-compute-method-function method))
     1065    (setf (method-function method) (std-compute-method-function method))
    10671066    method))
    10681067
     
    11711170          (setf (gethash classes (classes-to-emf-table gf)) emfun)
    11721171          (funcall emfun args))
    1173         (error "no applicable methods for generic function ~S with arguments ~S of classes ~S" gf args classes))))
     1172        (error "No applicable methods for generic function ~S with arguments ~S of classes ~S."
     1173               gf args classes))))
    11741174
    11751175(defun compute-applicable-methods-using-classes (gf required-classes)
     
    13511351                (method-generic-function method) next-methods))))
    13521352
     1353(defvar *call-next-method-p*)
     1354(defvar *next-method-p-p*)
     1355
     1356(defun walk-form (form)
     1357  (cond ((atom form)
     1358         (cond ((eq form 'call-next-method)
     1359                (setf *call-next-method-p* t))
     1360               ((eq form 'next-method-p)
     1361                (setf *next-method-p-p* t))))
     1362        (t
     1363         (walk-form (car form))
     1364         (walk-form (cdr form)))))
     1365
    13531366(defun std-compute-method-function (method)
    13541367  (let ((form (method-body method))
    1355         (lambda-list (method-lambda-list method)))
     1368        (lambda-list (method-lambda-list method))
     1369        (*call-next-method-p* nil)
     1370        (*next-method-p-p* nil))
     1371    (walk-form form)
    13561372    (compile-in-lexical-environment
    13571373     (method-environment method)
    1358      `(lambda (args next-emfun)
    1359         (flet ((call-next-method (&rest cnm-args)
    1360                                  (if (null next-emfun)
    1361                                      (error "no next method for generic function ~S"
    1362                                             (method-generic-function ',method))
    1363                                      (funcall next-emfun (or cnm-args args))))
    1364                (next-method-p ()
    1365                               (not (null next-emfun))))
    1366           (apply #'(lambda ,(kludge-arglist lambda-list)
    1367                     ,form)
    1368                  args))))))
     1374     (if (or *call-next-method-p* *next-method-p-p*)
     1375         `(lambda (args next-emfun)
     1376            (flet ((call-next-method (&rest cnm-args)
     1377                                     (if (null next-emfun)
     1378                                         (error "No next method for generic function ~S."
     1379                                                (method-generic-function ',method))
     1380                                         (funcall next-emfun (or cnm-args args))))
     1381                   (next-method-p ()
     1382                                  (not (null next-emfun))))
     1383              (apply #'(lambda ,(kludge-arglist lambda-list)
     1384                        ,form)
     1385                     args)))
     1386         `(lambda (args next-emfun)
     1387            (apply #'(lambda ,(kludge-arglist lambda-list)
     1388                      ,form)
     1389                   args))))))
    13691390
    13701391;;; N.B. The function kludge-arglist is used to pave over the differences
Note: See TracChangeset for help on using the changeset viewer.