Changeset 4472


Ignore:
Timestamp:
10/20/03 17:23:11 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4471 r4472  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.31 2003-10-20 15:33:11 piso Exp $
     4;;; $Id: defclass.lisp,v 1.32 2003-10-20 17:23:11 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    438438
    439439(defun std-allocate-instance (class)
    440 ;;   (format t "std-allocate-instance class = ~S~%" class)
    441 ;;   (format t "class-slots = ~S~%" (class-slots class))
    442440  (allocate-std-instance
    443441   class
     
    451449                                               &allow-other-keys)
    452450  (declare (ignore metaclass))
    453 ;;   (format t "name = ~S~%" name)
    454 ;;   (format t "direct-superclasses = ~S~%" direct-superclasses)
    455 ;;   (format t "direct-slots = ~S~%" direct-slots)
    456451  (let ((class (std-allocate-instance (find-class 'standard-class))))
    457452    (setf (class-name class) name)
     
    463458    class))
    464459
    465 ;; FIXME
    466460(defun std-after-initialization-for-classes (class
    467461                                             &key direct-superclasses direct-slots
     
    523517;;;
    524518
     519(defun method-combination-type (method-combination)
     520  (if (atom method-combination)
     521      method-combination
     522      (car method-combination)))
     523
     524(defun method-combination-options (method-combination)
     525  (if (atom method-combination)
     526      nil
     527      (cdr method-combination)))
     528
    525529(defclass standard-generic-function (generic-function)
    526530  ((name :initarg :name)      ; :accessor generic-function-name
     
    531535    :initarg :method-class)
    532536;;    (discriminating-function)  ; :accessor generic-function-discriminating-function
    533    (method-combination-type
     537   (method-combination
    534538    :initarg :method-combination)
    535539   (classes-to-emf-table      ; :accessor classes-to-emf-table
     
    565569  (setf (slot-value gf 'method-class) new-value))
    566570
    567 (defun generic-function-method-combination-type (gf)
    568   (slot-value gf 'method-combination-type))
    569 (defun (setf generic-function-method-combination-type) (new-value gf)
    570   (setf (slot-value gf 'method-combination-type) new-value))
     571(defun generic-function-method-combination (gf)
     572  (slot-value gf 'method-combination))
     573(defun (setf generic-function-method-combination) (new-value gf)
     574  (setf (slot-value gf 'method-combination) new-value))
    571575
    572576;;; Internal accessor for effective method function table
     
    650654  (case (car option)
    651655    (:generic-function-class
    652      (list ':generic-function-class
    653            `(find-class ',(cadr option))))
     656     (list ':generic-function-class `(find-class ',(cadr option))))
    654657    (:method-class
    655      (list ':method-class
    656            `(find-class ',(cadr option))))
    657     (t (list `',(car option) `',(cadr option)))))
     658     (list ':method-class `(find-class ',(cadr option))))
     659    (:method-combination
     660     (list `',(car option) `',(cdr option)))
     661    (t
     662     (list `',(car option) `',(cadr option)))))
    658663
    659664;;; find-generic-function looks up a generic function by name.  It's an
     
    727732  (declare (ignore generic-function-class))
    728733  (let ((gf (std-allocate-instance the-class-standard-gf)))
    729 ;;     (format t "gf = ~S~%" gf)
    730734    (setf (generic-function-name gf) name)
    731735    (setf (generic-function-lambda-list gf) lambda-list)
    732736    (setf (generic-function-methods gf) ())
    733737    (setf (generic-function-method-class gf) method-class)
    734     (setf (generic-function-method-combination-type gf) method-combination)
     738    (setf (generic-function-method-combination gf) method-combination)
    735739    (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
    736740    (finalize-generic-function gf)
     
    888892
    889893(defun ensure-method (gf &rest all-keys)
    890 ;;   (format t "ENSURE-METHOD ~S all-keys = ~S~%" (generic-function-name gf) all-keys)
    891 ;;   (format t "ENSURE-METHOD gf type = ~S~%" (generic-function-method-combination gf))
    892 ;;   (format t "ENSURE-METHOD qualifiers = ~S~%" (getf all-keys :qualifiers))
    893 ;;   (let ((gf-method-combination-type (generic-function-method-combination gf))
    894 ;;         (qualifiers (getf all-keys :qualifiers)))
    895 ;;     (if (eq gf-method-combination-type 'standard)
    896 ;;         (unless (or (null qualifiers)
    897 ;;                     (and (= (length qualifiers) 1)
    898 ;;                          (memq (car qualifiers) '(:before :after :around))))
    899 ;;           (error "method combination type mismatch"))
    900 ;;         (unless (memq gf-method-combination-type qualifiers)
    901 ;;           (error "method combination type mismatch"))))
    902894  (let ((new-method
    903895         (apply
     
    977969
    978970(defun add-reader-method (class fn-name slot-name)
    979 ;;   (format t "add-reader-method ~S~%" fn-name)
    980971  (ensure-method
    981972   (ensure-generic-function fn-name :lambda-list '(object))
     
    10891080
    10901081(defun std-compute-effective-method-function (gf methods)
    1091 ;;   (let ((primaries (remove-if-not #'primary-method-p methods))
    1092 ;;         (around (find-if #'around-method-p methods)))
    1093   (let ((type (generic-function-method-combination-type gf))
    1094         (primaries ())
    1095         (arounds ())
    1096         around)
     1082  (let* ((mc (generic-function-method-combination gf))
     1083         (type (method-combination-type mc))
     1084         (options (method-combination-options mc))
     1085         (order (car options))
     1086         (primaries ())
     1087         (arounds ())
     1088         around)
    10971089    (dolist (m methods)
    1098 ;;       (cond ((around-method-p m)
    1099 ;;              (push m arounds))
    1100 ;;             ((primary-method-p m)
    1101 ;;              (push m primaries))))
    11021090      (let ((qualifiers (method-qualifiers m)))
    11031091        (cond ((null qualifiers)
     
    11141102              (t
    11151103               (invalid generic-function combin m)))))
    1116     (setq primaries (nreverse primaries))
     1104    (unless (eq order :most-specific-last)
     1105      (setq primaries (nreverse primaries)))
    11171106    (setq arounds (nreverse arounds))
    11181107    (setq around (car arounds))
     
    11281117          #'(lambda (args)
    11291118             (funcall (method-function around) args next-emfun)))
    1130         (case (generic-function-method-combination-type gf)
     1119        (case type
    11311120          (STANDARD
    11321121           (let ((next-emfun (compute-primary-emfun (cdr primaries)))
     
    11561145                  (unless result (return)))
    11571146                result)))
     1147          (OR
     1148           #'(lambda (args)
     1149              (let ((result nil))
     1150                (dolist (primary primaries)
     1151                  (setf result
     1152                        (or result
     1153                            (funcall (method-function primary) args nil)))
     1154                  (when result (return)))
     1155                result)))
     1156          (+
     1157           #'(lambda (args)
     1158              (let ((result 0)
     1159                (dolist (primary primaries)
     1160                  (incf result (funcall (method-function primary) args nil)))
     1161                result))))
     1162          (MAX
     1163           #'(lambda (args)
     1164              (let ((result ()))
     1165                (dolist (primary primaries)
     1166                  (push (funcall (method-function primary) args nil) result))
     1167                (apply #'max result))))
     1168          (MIN
     1169           #'(lambda (args)
     1170              (let ((result ()))
     1171                (dolist (primary primaries)
     1172                  (push (funcall (method-function primary) args nil) result))
     1173                (apply #'min result))))
    11581174          (t
    1159            (error "unsupported method combination type ~S~"
    1160                   (generic-function-method-combination-type gf)))))))
     1175           (error "unsupported method combination type ~S~" type))))))
    11611176
    11621177;;; compute an effective method function from a list of primary methods:
     
    12421257
    12431258;;; Instance creation and initialization
    1244 
    1245 ;; (defgeneric allocate-instance (class))
    1246 ;; (defmethod allocate-instance ((class standard-class))
    1247 ;;   (std-allocate-instance class))
    12481259
    12491260(defgeneric make-instance (class &key))
Note: See TracChangeset for help on using the changeset viewer.