Changeset 4499


Ignore:
Timestamp:
10/22/03 17:26:35 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/j/src/org/armedbear/lisp/defclass.lisp

    r4477 r4499  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.36 2003-10-21 11:01:48 piso Exp $
     4;;; $Id: defclass.lisp,v 1.37 2003-10-22 17:26:35 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
    … …  
    1919
    2020;;; Adapted from Closette.
     21
     22;;; Closette Version 1.0 (February 10, 1991)
     23;;;
     24;;; Copyright (c) 1990, 1991 Xerox Corporation.
     25;;; All rights reserved.
     26;;;
     27;;; Use and copying of this software and preparation of derivative works
     28;;; based upon this software are permitted.  Any distribution of this
     29;;; software or derivative works must comply with all applicable United
     30;;; States export control laws.
     31;;;
     32;;; This software is made available AS IS, and Xerox Corporation makes no
     33;;; warranty about the software, its performance or its conformity to any
     34;;; specification.
     35;;;
     36;;; Closette is an implementation of a subset of CLOS with a metaobject
     37;;; protocol as described in "The Art of The Metaobject Protocol",
     38;;; MIT Press, 1991.
    2139
    2240(in-package "SYSTEM")
    … …  
    133151;;; Slot definition metaobjects
    134152
    135 ;;; N.B. Quietly retain all unknown slot options (rather than signaling an
    136 ;;; error), so that it's easy to add new ones.
    137 
    138153(defun make-direct-slot-definition (&rest properties
    139154                                          &key name
    … …  
    513528                 ,@(canonicalize-defclass-options options)))
    514529
    515 ;;;
    516530;;; Generic function metaobjects and standard-generic-function
    517 ;;;
    518531
    519532(defun method-combination-type (method-combination)
    … …  
    534547   (method-class              ; :accessor generic-function-method-class
    535548    :initarg :method-class)
    536 ;;    (discriminating-function)  ; :accessor generic-function-discriminating-function
    537549   (method-combination
    538550    :initarg :method-combination)
    … …  
    557569  (setf (slot-value gf 'methods) new-value))
    558570
    559 ;; (defun generic-function-discriminating-function (gf)
    560 ;;   (slot-value gf 'discriminating-function))
    561 ;; (defun (setf generic-function-discriminating-function) (new-value gf)
    562 ;;   (setf (slot-value gf 'discriminating-function) new-value))
    563571(defsetf generic-function-discriminating-function
    564572  %set-generic-function-discriminating-function)
    … …  
    581589  (setf (slot-value gf 'classes-to-emf-table) new-value))
    582590
    583 ;;;
    584591;;; Method metaobjects and standard-method
    585 ;;;
    586592
    587593(defclass standard-method ()
    … …  
    661667    (t
    662668     (list `',(car option) `',(cadr option)))))
    663 
    664 ;;; find-generic-function looks up a generic function by name.  It's an
    665 ;;; artifact of the fact that our generic function metaobjects can't legally
    666 ;;; be stored a symbol's function value.
    667669
    668670(defparameter generic-function-table (make-hash-table :test #'equal))
    … …  
    706708;;; finalize-generic-function
    707709
    708 ;;; N.B. Same basic idea as finalize-inheritance.  Takes care of recomputing
    709 ;;; and storing the discriminating function, and clearing the effective method
    710 ;;; function table.
    711 
    712710(defun finalize-generic-function (gf)
    713711  (setf (generic-function-discriminating-function gf)
    … …  
    716714                     #'compute-discriminating-function)
    717715                 gf))
    718   (setf (fdefinition (generic-function-name gf))
    719 ;;         (generic-function-discriminating-function gf))
    720         gf)
     716  (setf (fdefinition (generic-function-name gf)) gf)
    721717  (clrhash (classes-to-emf-table gf))
    722718  (values))
    723 
    724 ;;; make-instance-standard-generic-function creates and initializes an
    725 ;;; instance of standard-generic-function without falling into method lookup.
    726 ;;; However, it cannot be called until standard-generic-function exists.
    727719
    728720(defun make-instance-standard-generic-function (generic-function-class
    … …  
    933925      gf-keywords)))))))
    934926
    935 
    936927(defun ensure-method (gf &rest all-keys)
    937   (let* ((plist-gf (analyze-lambda-list (generic-function-lambda-list gf)))
    938          (plist-method (analyze-lambda-list (getf all-keys :lambda-list)))
    939 ;;          (gf-restp (not (null (getf plist-gf :rest-var))))
    940 ;;          (method-restp (not (null (getf plist-method :rest-var))))
    941 ;;          (gf-keysp (not (null (getf plist-gf :keywords))))
    942 ;;          (method-keysp (not (null (getf plist-method :keywords)))))
    943          (gf-restp (not (null (memq '&rest (generic-function-lambda-list gf)))))
    944          (gf-keysp (getf plist-gf :keysp))
    945          (method-restp (not (null (memq '&rest (getf all-keys :lambda-list)))))
    946          (method-keysp (getf plist-method :keysp)))
    947     (unless (= (length (getf plist-gf :required-args))
    948                (length (getf plist-method :required-args)))
     928  (let* ((gf-lambda-list (generic-function-lambda-list gf))
     929         (gf-restp (not (null (memq '&rest gf-lambda-list))))
     930         (gf-plist (analyze-lambda-list gf-lambda-list))
     931         (gf-keysp (getf gf-plist :keysp))
     932         (gf-keywords (getf gf-plist :keywords))
     933         (method-lambda-list (getf all-keys :lambda-list))
     934         (method-plist (analyze-lambda-list method-lambda-list))
     935         (method-restp (not (null (memq '&rest method-lambda-list))))
     936         (method-keysp (getf method-plist :keysp))
     937         (method-keywords (getf method-plist :keywords))
     938         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
     939    (unless (= (length (getf gf-plist :required-args))
     940               (length (getf method-plist :required-args)))
    949941      (error "the method has the wrong number of required arguments for the generic function"))
    950     (unless (= (length (getf plist-gf :optional-args))
    951                (length (getf plist-method :optional-args)))
     942    (unless (= (length (getf gf-plist :optional-args))
     943               (length (getf method-plist :optional-args)))
    952944      (error "the method has the wrong number of optional arguments for the generic function"))
    953945    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
    954 ;;       (format t "gf-restp = ~S gf-keysp = ~S~%" gf-restp gf-keysp)
    955 ;;       (format t "method-restp = ~S method-keysp = ~S~%" method-restp method-keysp)
    956 ;;       (format t "method lambda list = ~S~%" (getf all-keys :lambda-list))
    957 ;;       (format t "all-keys = ~S~%" all-keys)
    958946      (error "the method and the generic function differ in whether they accept &REST or &KEY arguments"))
    959     )
     947    (when (consp gf-keywords)
     948      (unless (or (and method-restp (not method-keysp))
     949                  method-allow-other-keys-p
     950                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
     951        (error "the method does not accept all of the keyword arguments defined for the generic function"))))
    960952  (let ((new-method
    961953         (apply
    … …  
    967959    (add-method gf new-method)
    968960    new-method))
    969 
    970 ;;; make-instance-standard-method creates and initializes an instance of
    971 ;;; standard-method without falling into method lookup.  However, it cannot
    972 ;;; be called until standard-method exists.
    973961
    974962(defun make-instance-standard-method (method-class
    … …  
    10321020        method)))
    10331021
    1034 ;;; Reader and write methods
     1022;;; Reader and writer methods
    10351023
    10361024(defun add-reader-method (class fn-name slot-name)
    … …  
    12571245                (apply #'min result))))
    12581246          (t
    1259            (error "unsupported method combination type ~S~" type))))))
     1247           (error "unsupported method combination type ~S" type))))))
    12601248
    12611249;;; compute an effective method function from a list of primary methods:
    … …  
    13211309  (new-value (class standard-class) instance slot-name)
    13221310  (setf (std-slot-value instance slot-name) new-value))
    1323 ;;; N.B. To avoid making a forward reference to a (setf xxx) generic function:
    1324 ;; (defun setf-slot-value-using-class (new-value class object slot-name)
    1325 ;;   (setf (slot-value-using-class class object slot-name) new-value))
    13261311
    13271312(defgeneric slot-exists-p-using-class (class instance slot-name))
    … …  
    14141399    (apply #'shared-initialize new added-slots initargs)))
    14151400
    1416 ;;;
    14171401;;;  Methods having to do with class metaobjects.
    1418 ;;;
    14191402
    14201403(defmethod print-object ((class standard-class) stream)
    … …  
    14521435  (std-compute-effective-slot-definition class direct-slots))
    14531436
    1454 ;;;
    14551437;;; Methods having to do with generic function metaobjects.
    1456 ;;;
    14571438
    14581439(defmethod print-object ((gf standard-generic-function) stream)
    … …  
    14661447  (finalize-generic-function gf))
    14671448
    1468 ;;;
    14691449;;; Methods having to do with method metaobjects.
    1470 ;;;
    14711450
    14721451(defmethod print-object ((method standard-method) stream)
    … …  
    14841463  (setf (method-function method) (compute-method-function method)))
    14851464
    1486 ;;;
    14871465;;; Methods having to do with generic function invocation.
    1488 ;;;
    14891466
    14901467(defgeneric compute-discriminating-function (gf))
Note: See TracChangeset for help on using the changeset viewer.