Changeset 4499
- Timestamp:
- 10/22/03 17:26:35 (19 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/defclass.lisp
r4477 r4499 2 2 ;;; 3 3 ;;; Copyright (C) 2003 Peter Graves 4 ;;; $Id: defclass.lisp,v 1.3 6 2003-10-21 11:01:48piso Exp $4 ;;; $Id: defclass.lisp,v 1.37 2003-10-22 17:26:35 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 19 19 20 20 ;;; 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. 21 39 22 40 (in-package "SYSTEM") … … 133 151 ;;; Slot definition metaobjects 134 152 135 ;;; N.B. Quietly retain all unknown slot options (rather than signaling an136 ;;; error), so that it's easy to add new ones.137 138 153 (defun make-direct-slot-definition (&rest properties 139 154 &key name … … 513 528 ,@(canonicalize-defclass-options options))) 514 529 515 ;;;516 530 ;;; Generic function metaobjects and standard-generic-function 517 ;;;518 531 519 532 (defun method-combination-type (method-combination) … … 534 547 (method-class ; :accessor generic-function-method-class 535 548 :initarg :method-class) 536 ;; (discriminating-function) ; :accessor generic-function-discriminating-function537 549 (method-combination 538 550 :initarg :method-combination) … … 557 569 (setf (slot-value gf 'methods) new-value)) 558 570 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))563 571 (defsetf generic-function-discriminating-function 564 572 %set-generic-function-discriminating-function) … … 581 589 (setf (slot-value gf 'classes-to-emf-table) new-value)) 582 590 583 ;;;584 591 ;;; Method metaobjects and standard-method 585 ;;;586 592 587 593 (defclass standard-method () … … 661 667 (t 662 668 (list `',(car option) `',(cadr option))))) 663 664 ;;; find-generic-function looks up a generic function by name. It's an665 ;;; artifact of the fact that our generic function metaobjects can't legally666 ;;; be stored a symbol's function value.667 669 668 670 (defparameter generic-function-table (make-hash-table :test #'equal)) … … 706 708 ;;; finalize-generic-function 707 709 708 ;;; N.B. Same basic idea as finalize-inheritance. Takes care of recomputing709 ;;; and storing the discriminating function, and clearing the effective method710 ;;; function table.711 712 710 (defun finalize-generic-function (gf) 713 711 (setf (generic-function-discriminating-function gf) … … 716 714 #'compute-discriminating-function) 717 715 gf)) 718 (setf (fdefinition (generic-function-name gf)) 719 ;; (generic-function-discriminating-function gf)) 720 gf) 716 (setf (fdefinition (generic-function-name gf)) gf) 721 717 (clrhash (classes-to-emf-table gf)) 722 718 (values)) 723 724 ;;; make-instance-standard-generic-function creates and initializes an725 ;;; instance of standard-generic-function without falling into method lookup.726 ;;; However, it cannot be called until standard-generic-function exists.727 719 728 720 (defun make-instance-standard-generic-function (generic-function-class … … 933 925 gf-keywords))))))) 934 926 935 936 927 (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))) 949 941 (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))) 952 944 (error "the method has the wrong number of optional arguments for the generic function")) 953 945 (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)958 946 (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")))) 960 952 (let ((new-method 961 953 (apply … … 967 959 (add-method gf new-method) 968 960 new-method)) 969 970 ;;; make-instance-standard-method creates and initializes an instance of971 ;;; standard-method without falling into method lookup. However, it cannot972 ;;; be called until standard-method exists.973 961 974 962 (defun make-instance-standard-method (method-class … … 1032 1020 method))) 1033 1021 1034 ;;; Reader and write methods1022 ;;; Reader and writer methods 1035 1023 1036 1024 (defun add-reader-method (class fn-name slot-name) … … 1257 1245 (apply #'min result)))) 1258 1246 (t 1259 (error "unsupported method combination type ~S ~" type))))))1247 (error "unsupported method combination type ~S" type)))))) 1260 1248 1261 1249 ;;; compute an effective method function from a list of primary methods: … … 1321 1309 (new-value (class standard-class) instance slot-name) 1322 1310 (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))1326 1311 1327 1312 (defgeneric slot-exists-p-using-class (class instance slot-name)) … … 1414 1399 (apply #'shared-initialize new added-slots initargs))) 1415 1400 1416 ;;;1417 1401 ;;; Methods having to do with class metaobjects. 1418 ;;;1419 1402 1420 1403 (defmethod print-object ((class standard-class) stream) … … 1452 1435 (std-compute-effective-slot-definition class direct-slots)) 1453 1436 1454 ;;;1455 1437 ;;; Methods having to do with generic function metaobjects. 1456 ;;;1457 1438 1458 1439 (defmethod print-object ((gf standard-generic-function) stream) … … 1466 1447 (finalize-generic-function gf)) 1467 1448 1468 ;;;1469 1449 ;;; Methods having to do with method metaobjects. 1470 ;;;1471 1450 1472 1451 (defmethod print-object ((method standard-method) stream) … … 1484 1463 (setf (method-function method) (compute-method-function method))) 1485 1464 1486 ;;;1487 1465 ;;; Methods having to do with generic function invocation. 1488 ;;;1489 1466 1490 1467 (defgeneric compute-discriminating-function (gf))
Note: See TracChangeset
for help on using the changeset viewer.