Changeset 4309


Ignore:
Timestamp:
10/11/03 17:31:00 (19 years ago)
Author:
piso
Message:

Work in progress.

Location:
trunk/j/src/org/armedbear/lisp
Files:
2 edited

Legend:

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

    r4301 r4309  
    33 *
    44 * Copyright (C) 2003 Peter Graves
    5  * $Id: StandardObject.java,v 1.3 2003-10-11 00:17:18 piso Exp $
     5 * $Id: StandardObject.java,v 1.4 2003-10-11 17:28:52 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    2525{
    2626    // Slots.
    27     private LispObject cls;
     27    private LispClass cls;
    2828    private LispObject slots; // A simple vector.
    2929
     
    3232    }
    3333
    34     private StandardObject(LispObject cls, LispObject slots)
     34    private StandardObject(LispClass cls, LispObject slots)
    3535    {
    3636        this.cls = cls;
     
    4545    public LispClass classOf()
    4646    {
    47         return BuiltInClass.STANDARD_OBJECT;
     47        return cls;
    4848    }
    4949
     
    5353            return T;
    5454        if (type == BuiltInClass.STANDARD_OBJECT)
     55            return T;
     56        if (type == cls)
    5557            return T;
    5658        return super.typep(type);
     
    7476    {
    7577        public LispObject execute(LispObject first, LispObject second)
     78            throws ConditionThrowable
    7679        {
    7780            if (first == BuiltInClass.STANDARD_CLASS)
    7881                return new StandardClass();
    79             return new StandardObject(first, second);
     82            if (first instanceof LispClass)
     83                return new StandardObject((LispClass)first, second);
     84            throw new ConditionThrowable(new TypeError(first, "class"));
    8085        }
    8186    };
  • trunk/j/src/org/armedbear/lisp/defclass.lisp

    r4305 r4309  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.7 2003-10-11 14:58:59 piso Exp $
     4;;; $Id: defclass.lisp,v 1.8 2003-10-11 17:31:00 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    352352                        :key #'slot-definition-name)))
    353353        (if (null slot)
    354             (error "The slot ~S is missing from the class ~S."
     354            (error "the slot ~S is missing from the class ~S"
    355355                   slot-name class)
    356356            (let ((pos (position slot
     
    358358                                                (class-slots class)))))
    359359              (if (null pos)
    360                   (error "The slot ~S is not an instance~@
    361                   slot in the class ~S."
     360                  (error "the slot ~S is not an instance slot in the class ~S"
    362361                         slot-name class)
    363362                  pos))))))
     
    427426
    428427(defun std-allocate-instance (class)
     428;;   (format t "std-allocate-instance class = ~S~%" class)
     429;;   (format t "class-slots = ~S~%" (class-slots class))
    429430  (allocate-std-instance
    430431   class
     
    500501;;;
    501502
    502 (defparameter the-defclass-standard-generic-function
    503   '(defclass standard-generic-function ()
    504     ((name :initarg :name)      ; :accessor generic-function-name
    505      (lambda-list               ; :accessor generic-function-lambda-list
    506       :initarg :lambda-list)
    507      (methods :initform ())     ; :accessor generic-function-methods
    508      (method-class              ; :accessor generic-function-method-class
    509       :initarg :method-class)
    510      (discriminating-function)  ; :accessor generic-function-
    511      ;    -discriminating-function
    512      (classes-to-emf-table      ; :accessor classes-to-emf-table
    513       :initform (make-hash-table :test #'equal)))))
     503;; (defparameter the-defclass-standard-generic-function
     504;;   '(defclass standard-generic-function ()
     505;;     ((name :initarg :name)      ; :accessor generic-function-name
     506;;      (lambda-list               ; :accessor generic-function-lambda-list
     507;;       :initarg :lambda-list)
     508;;      (methods :initform ())     ; :accessor generic-function-methods
     509;;      (method-class              ; :accessor generic-function-method-class
     510;;       :initarg :method-class)
     511;;      (discriminating-function)  ; :accessor generic-function-
     512;;      ;    -discriminating-function
     513;;      (classes-to-emf-table      ; :accessor classes-to-emf-table
     514;;       :initform (make-hash-table :test #'equal)))))
     515
     516(defclass standard-generic-function ()
     517  ((name :initarg :name)      ; :accessor generic-function-name
     518   (lambda-list               ; :accessor generic-function-lambda-list
     519    :initarg :lambda-list)
     520   (methods :initform ())     ; :accessor generic-function-methods
     521   (method-class              ; :accessor generic-function-method-class
     522    :initarg :method-class)
     523   (discriminating-function)  ; :accessor generic-function-
     524   ;    -discriminating-function
     525   (classes-to-emf-table      ; :accessor classes-to-emf-table
     526    :initform (make-hash-table :test #'equal))))
    514527
    515528(defvar the-class-standard-gf (find-class 'standard-generic-function))
     
    594607;;; defgeneric
    595608
    596 ;; (defmacro defgeneric (function-name lambda-list &rest options)
    597 ;;   `(ensure-generic-function
    598 ;;     ',function-name
    599 ;;     :lambda-list ',lambda-list
    600 ;;     ,@(canonicalize-defgeneric-options options)))
     609(defmacro defgeneric (function-name lambda-list
     610                                    &rest options-and-method-descriptions)
     611  (let ((options ())
     612        (methods ()))
     613    (dolist (item options-and-method-descriptions)
     614      (case (car item)
     615        (declare) ; FIXME
     616        (:method
     617         (push `(defmethod ,function-name ,@(cdr item)) methods))
     618        (t
     619         (push item options))))
     620    (setf options (nreverse options)
     621          methods (nreverse methods))
     622    `(prog1
     623       (ensure-generic-function
     624        ',function-name
     625        :lambda-list ',lambda-list
     626        ,@(canonicalize-defgeneric-options options))
     627       ,@methods)))
    601628
    602629(defun canonicalize-defgeneric-options (options)
     
    637664   &allow-other-keys)
    638665  (format t "ensure-generic-function function-name = ~S~%" function-name)
     666  (when (fboundp function-name)
     667    (error "~A already names an ordinary function, macro, or special operator"
     668           function-name))
    639669  (if (find-generic-function function-name nil)
    640670      (find-generic-function function-name)
     
    670700;;; However, it cannot be called until standard-generic-function exists.
    671701
    672 (defun make-instance-standard-generic-function
    673   (generic-function-class &key name lambda-list method-class)
     702(defun make-instance-standard-generic-function (generic-function-class
     703                                                &key name lambda-list method-class)
    674704  (declare (ignore generic-function-class))
    675705  (let ((gf (std-allocate-instance the-class-standard-gf)))
     706    (format t "gf = ~S~%" gf)
    676707    (setf (generic-function-name gf) name)
    677708    (setf (generic-function-lambda-list gf) lambda-list)
     
    912943   :environment (top-level-environment))
    913944  (values))
     945
     946;;;
     947;;; Generic function invocation
     948;;;
     949
     950;;; apply-generic-function
     951
     952(defun apply-generic-function (gf args)
     953  (apply (generic-function-discriminating-function gf) args))
     954
     955;;; compute-discriminating-function
     956
     957(defun std-compute-discriminating-function (gf)
     958  #'(lambda (&rest args)
     959     (let* ((classes (mapcar #'class-of
     960                             (required-portion gf args)))
     961            (emfun (gethash classes (classes-to-emf-table gf) nil)))
     962       (if emfun
     963           (funcall emfun args)
     964           (slow-method-lookup gf args classes)))))
     965
     966(defun slow-method-lookup (gf args classes)
     967  (let* ((applicable-methods
     968          (compute-applicable-methods-using-classes gf classes))
     969         (emfun
     970          (funcall
     971           (if (eq (class-of gf) the-class-standard-gf)
     972               #'std-compute-effective-method-function
     973               #'compute-effective-method-function)
     974           gf applicable-methods)))
     975    (setf (gethash classes (classes-to-emf-table gf)) emfun)
     976    (funcall emfun args)))
     977
     978;;; compute-applicable-methods-using-classes
     979
     980(defun compute-applicable-methods-using-classes
     981  (gf required-classes)
     982  (sort
     983   (copy-list
     984    (remove-if-not #'(lambda (method)
     985                      (every #'subclassp
     986                             required-classes
     987                             (method-specializers method)))
     988                   (generic-function-methods gf)))
     989   #'(lambda (m1 m2)
     990      (funcall
     991       (if (eq (class-of gf) the-class-standard-gf)
     992           #'std-method-more-specific-p
     993           #'method-more-specific-p)
     994       gf m1 m2 required-classes))))
     995
     996;;; method-more-specific-p
     997
     998(defun std-method-more-specific-p (gf method1 method2 required-classes)
     999  (declare (ignore gf))
     1000  (mapc #'(lambda (spec1 spec2 arg-class)
     1001           (unless (eq spec1 spec2)
     1002             (return-from std-method-more-specific-p
     1003                          (sub-specializer-p spec1 spec2 arg-class))))
     1004        (method-specializers method1)
     1005        (method-specializers method2)
     1006        required-classes)
     1007  nil)
     1008
     1009;;; apply-methods and compute-effective-method-function
     1010
     1011(defun apply-methods (gf args methods)
     1012  (funcall (compute-effective-method-function gf methods)
     1013           args))
     1014
     1015(defun primary-method-p (method)
     1016  (null (method-qualifiers method)))
     1017(defun before-method-p (method)
     1018  (equal '(:before) (method-qualifiers method)))
     1019(defun after-method-p (method)
     1020  (equal '(:after) (method-qualifiers method)))
     1021(defun around-method-p (method)
     1022  (equal '(:around) (method-qualifiers method)))
     1023
     1024(defun std-compute-effective-method-function (gf methods)
     1025  (let ((primaries (remove-if-not #'primary-method-p methods))
     1026        (around (find-if #'around-method-p methods)))
     1027    (when (null primaries)
     1028      (error "No primary methods for the~@
     1029      generic function ~S." gf))
     1030    (if around
     1031        (let ((next-emfun
     1032               (funcall
     1033                (if (eq (class-of gf) the-class-standard-gf)
     1034                    #'std-compute-effective-method-function
     1035                    #'compute-effective-method-function)
     1036                gf (remove around methods))))
     1037          #'(lambda (args)
     1038             (funcall (method-function around) args next-emfun)))
     1039        (let ((next-emfun (compute-primary-emfun (cdr primaries)))
     1040              (befores (remove-if-not #'before-method-p methods))
     1041              (reverse-afters
     1042               (reverse (remove-if-not #'after-method-p methods))))
     1043          #'(lambda (args)
     1044             (dolist (before befores)
     1045               (funcall (method-function before) args nil))
     1046             (multiple-value-prog1
     1047              (funcall (method-function (car primaries)) args next-emfun)
     1048              (dolist (after reverse-afters)
     1049                (funcall (method-function after) args nil))))))))
     1050
     1051;;; compute an effective method function from a list of primary methods:
     1052
     1053(defun compute-primary-emfun (methods)
     1054  (if (null methods)
     1055      nil
     1056      (let ((next-emfun (compute-primary-emfun (cdr methods))))
     1057        #'(lambda (args)
     1058           (funcall (method-function (car methods)) args next-emfun)))))
     1059
     1060;;; apply-method and compute-method-function
     1061
     1062(defun apply-method (method args next-methods)
     1063  (funcall (method-function method)
     1064           args
     1065           (if (null next-methods)
     1066               nil
     1067               (compute-effective-method-function
     1068                (method-generic-function method) next-methods))))
     1069
     1070(defun std-compute-method-function (method)
     1071  (let ((form (method-body method))
     1072        (lambda-list (method-lambda-list method)))
     1073    (compile-in-lexical-environment (method-environment method)
     1074                                    `(lambda (args next-emfun)
     1075                                       (flet ((call-next-method (&rest cnm-args)
     1076                                                                (if (null next-emfun)
     1077                                                                    (error "No next method for the~@
     1078                                                                    generic function ~S."
     1079                                                                           (method-generic-function ',method))
     1080                                                                    (funcall next-emfun (or cnm-args args))))
     1081                                              (next-method-p ()
     1082                                                             (not (null next-emfun))))
     1083                                         (apply #'(lambda ,(kludge-arglist lambda-list)
     1084                                                   ,form)
     1085                                                args))))))
     1086
     1087;;; N.B. The function kludge-arglist is used to pave over the differences
     1088;;; between argument keyword compatibility for regular functions versus
     1089;;; generic functions.
     1090
     1091(defun kludge-arglist (lambda-list)
     1092  (if (and (member '&key lambda-list)
     1093           (not (member '&allow-other-keys lambda-list)))
     1094      (append lambda-list '(&allow-other-keys))
     1095      (if (and (not (member '&rest lambda-list))
     1096               (not (member '&key lambda-list)))
     1097          (append lambda-list '(&key &allow-other-keys))
     1098          lambda-list)))
Note: See TracChangeset for help on using the changeset viewer.