Ignore:
Timestamp:
02/14/04 00:20:26 (17 years ago)
Author:
piso
Message:

DEFMETHOD: support declarations.

File:
1 edited

Legend:

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

    r5807 r5814  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.84 2004-02-13 16:26:14 piso Exp $
     4;;; $Id: clos.lisp,v 1.85 2004-02-14 00:20:26 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    732732   (qualifiers :initarg :qualifiers)       ; :accessor method-qualifiers
    733733   (specializers :initarg :specializers)   ; :accessor method-specializers
     734   (declarations :initarg :declarations)   ; :accessir method-declarations
    734735   (body :initarg :body)                   ; :accessor method-body
    735736   (environment :initarg :environment)     ; :accessor method-environment
     
    754755(defun (setf method-specializers) (new-value method)
    755756  (setf (slot-value method 'specializers) new-value))
     757
     758(defun method-declarations (method) (slot-value method 'declarations))
     759(defun (setf method-declarations) (new-value method)
     760  (setf (slot-value method 'declarations) new-value))
    756761
    757762(defun method-body (method) (slot-value method 'body))
     
    953958(defmacro defmethod (&rest args)
    954959  (multiple-value-bind
    955     (function-name qualifiers lambda-list specializers documentation body)
     960    (function-name qualifiers lambda-list specializers documentation declarations body)
    956961    (parse-defmethod args)
    957962    `(progn
     
    965970                      :specializers ',specializers
    966971                      :documentation ,documentation
     972                      :declarations ',declarations
    967973                      :body ',body
    968974                      :environment (top-level-environment)))))
     
    10071013    (multiple-value-bind (real-body declarations documentation)
    10081014      (parse-body body)
    1009       (values function-name
    1010               qualifiers
    1011               (extract-lambda-list specialized-lambda-list)
    1012               specializers
    1013               documentation
    1014               (list* 'block
    1015                      (if (consp function-name)
    1016                          (cadr function-name)
    1017                          function-name)
    1018                      real-body)))))
     1015        (values function-name
     1016                qualifiers
     1017                (extract-lambda-list specialized-lambda-list)
     1018                specializers
     1019                documentation
     1020                declarations
     1021                (list* 'block
     1022                         (if (consp function-name)
     1023                             (cadr function-name)
     1024                             function-name)
     1025                         real-body)))))
    10191026
    10201027(defun required-portion (gf args)
     
    11851192                                      &key
    11861193                                      lambda-list qualifiers specializers
    1187                                       documentation body environment)
     1194                                      documentation declarations body
     1195                                      environment)
    11881196  (declare (ignore method-class))
    11891197  (let ((method (std-allocate-instance the-class-standard-method)))
     
    11921200    (setf (method-specializers method) specializers)
    11931201    (setf (method-documentation method) documentation)
     1202    (setf (method-declarations method) declarations)
    11941203    (setf (method-body method) (precompile-form body nil))
    11951204    (setf (method-environment method) environment)
     
    14641473
    14651474(defun std-compute-method-function (method)
    1466   (let ((form (method-body method))
     1475  (let ((body (method-body method))
     1476        (declarations (method-declarations method))
    14671477        (lambda-list (method-lambda-list method))
    14681478        (*call-next-method-p* nil)
    14691479        (*next-method-p-p* nil))
    1470     (walk-form form)
     1480    (walk-form body)
    14711481    (setf lambda-list (kludge-arglist lambda-list))
    14721482    (compile-in-lexical-environment
     
    14811491                   (next-method-p ()
    14821492                                  (not (null next-emfun))))
    1483               (apply #'(lambda ,lambda-list ,form) args)))
     1493              (apply #'(lambda ,lambda-list ,@declarations ,body) args)))
    14841494         `(lambda (args next-emfun)
    1485             (apply #'(lambda ,lambda-list ,form) args))))))
     1495            (apply #'(lambda ,lambda-list ,@declarations ,body) args))))))
    14861496
    14871497;;; N.B. The function kludge-arglist is used to pave over the differences
Note: See TracChangeset for help on using the changeset viewer.