Changeset 4313


Ignore:
Timestamp:
10/11/03 18:49:44 (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/BuiltInClass.java

    r4308 r4313  
    33 *
    44 * Copyright (C) 2003 Peter Graves
    5  * $Id: BuiltInClass.java,v 1.8 2003-10-11 17:29:53 piso Exp $
     5 * $Id: BuiltInClass.java,v 1.9 2003-10-11 18:47:27 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
    … …  
    120120    public static final BuiltInClass SIMPLE_TYPE_ERROR                = addClass(Symbol.SIMPLE_TYPE_ERROR);
    121121    public static final BuiltInClass SIMPLE_WARNING                   = addClass(Symbol.SIMPLE_WARNING);
    122     public static final BuiltInClass STANDARD_CLASS                   = addClass(Symbol.STANDARD_CLASS);
     122//     public static final BuiltInClass STANDARD_CLASS                   = addClass(Symbol.STANDARD_CLASS);
    123123//     public static final BuiltInClass STANDARD_GENERIC_FUNCTION        = addClass(Symbol.STANDARD_GENERIC_FUNCTION);
    124     public static final BuiltInClass STANDARD_METHOD                  = addClass(Symbol.STANDARD_METHOD);
     124//     public static final BuiltInClass STANDARD_METHOD                  = addClass(Symbol.STANDARD_METHOD);
    125125//     public static final BuiltInClass STANDARD_OBJECT                  = addClass(Symbol.STANDARD_OBJECT);
    126126    public static final BuiltInClass STORAGE_CONDITION                = addClass(Symbol.STORAGE_CONDITION);
    … …  
    141141    public static final BuiltInClass VECTOR                           = addClass(Symbol.VECTOR);
    142142    public static final BuiltInClass WARNING                          = addClass(Symbol.WARNING);
     143
     144    public static final StandardClass STANDARD_CLASS =
     145        new StandardClass(Symbol.STANDARD_CLASS,
     146                          list1(CLASS_T));
     147    static {
     148        addClass(Symbol.STANDARD_CLASS, STANDARD_CLASS);
     149    }
    143150
    144151    public static final StandardClass STANDARD_OBJECT =
    … …  
    289296//         STANDARD_GENERIC_FUNCTION.setCPL(STANDARD_GENERIC_FUNCTION,
    290297//                                          GENERIC_FUNCTION, FUNCTION, CLASS_T);
    291         STANDARD_METHOD.setDirectSuperclass(list2(METHOD, STANDARD_OBJECT));
    292         STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, STANDARD_OBJECT,
    293                                CLASS_T);
     298//         STANDARD_METHOD.setDirectSuperclass(list2(METHOD, STANDARD_OBJECT));
     299//         STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, STANDARD_OBJECT,
     300//                                CLASS_T);
    294301//         STANDARD_OBJECT.setDirectSuperclass(CLASS_T);
    295302        STANDARD_OBJECT.setCPL(STANDARD_OBJECT, CLASS_T);

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

    r4310 r4313  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.9 2003-10-11 17:35:48 piso Exp $
     4;;; $Id: defclass.lisp,v 1.10 2003-10-11 18:49:44 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
    … …  
    564564;;;
    565565
    566 (defparameter the-defclass-standard-method
    567   '(defclass standard-method ()
    568     ((lambda-list :initarg :lambda-list)     ; :accessor method-lambda-list
    569      (qualifiers :initarg :qualifiers)       ; :accessor method-qualifiers
    570      (specializers :initarg :specializers)   ; :accessor method-specializers
    571      (body :initarg :body)                   ; :accessor method-body
    572      (environment :initarg :environment)     ; :accessor method-environment
    573      (generic-function :initform nil)        ; :accessor method-generic-function
    574      (function))))                           ; :accessor method-function
     566(defclass standard-method ()
     567  ((lambda-list :initarg :lambda-list)     ; :accessor method-lambda-list
     568   (qualifiers :initarg :qualifiers)       ; :accessor method-qualifiers
     569   (specializers :initarg :specializers)   ; :accessor method-specializers
     570   (body :initarg :body)                   ; :accessor method-body
     571   (environment :initarg :environment)     ; :accessor method-environment
     572   (generic-function :initform nil)        ; :accessor method-generic-function
     573   (function)))                            ; :accessor method-function
    575574
    576575(defvar the-class-standard-method (find-class 'standard-method))
    … …  
    649648  (let ((gf (gethash symbol generic-function-table nil)))
    650649    (if (and (null gf) errorp)
    651         (error "No generic function named ~S." symbol)
     650        (error "no generic function named ~S" symbol)
    652651        gf)))
    653652
    … …  
    664663   &allow-other-keys)
    665664  (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))
     665;;   (when (fboundp function-name)
     666;;     (error "~A already names an ordinary function, macro, or special operator"
     667;;            function-name))
    669668  (if (find-generic-function function-name nil)
    670669      (find-generic-function function-name)
    671       (let ((gf (apply (if (eq generic-function-class the-class-standard-gf)
    672                            #'make-instance-standard-generic-function
    673                            #'make-instance)
    674                        generic-function-class
    675                        :name function-name
    676                        :method-class method-class
    677                        all-keys)))
    678         (setf (find-generic-function function-name) gf)
    679         gf)))
     670      (progn
     671        (when (fboundp function-name)
     672          (error "~A already names an ordinary function, macro, or special operator"
     673                 function-name))
     674        (let ((gf (apply (if (eq generic-function-class the-class-standard-gf)
     675                             #'make-instance-standard-generic-function
     676                             #'make-instance)
     677                         generic-function-class
     678                         :name function-name
     679                         :method-class method-class
     680                         all-keys)))
     681          (setf (find-generic-function function-name) gf)
     682          gf))))
    680683
    681684;;; finalize-generic-function
    … …  
    713716    gf))
    714717
     718;;; Run-time environment hacking (Common Lisp ain't got 'em).
     719
     720(defun top-level-environment ()
     721  nil) ; Bogus top level lexical environment
     722
     723(defvar compile-methods nil)      ; by default, run everything interpreted
     724
     725(defun compile-in-lexical-environment (env lambda-expr)
     726  (declare (ignore env))
     727  (if compile-methods
     728      (compile nil lambda-expr)
     729      (eval `(function ,lambda-expr))))
     730
    715731;;; defmethod
    716732
    717 ;; (defmacro defmethod (&rest args)
    718 ;;   (multiple-value-bind (function-name qualifiers
    719 ;;                                       lambda-list specializers body)
    720 ;;     (parse-defmethod args)
    721 ;;     `(ensure-method (find-generic-function ',function-name)
    722 ;;                     :lambda-list ',lambda-list
    723 ;;                     :qualifiers ',qualifiers
    724 ;;                     :specializers ,(canonicalize-specializers specializers)
    725 ;;                     :body ',body
    726 ;;                     :environment (top-level-environment))))
     733(defmacro defmethod (&rest args)
     734  (multiple-value-bind (function-name qualifiers lambda-list specializers
     735                                      body)
     736    (parse-defmethod args)
     737    `(progn
     738      (ensure-generic-function
     739       ',function-name
     740       :lambda-list ',lambda-list)
     741      (ensure-method (find-generic-function ',function-name)
     742                     :lambda-list ',lambda-list
     743                     :qualifiers ',qualifiers
     744                     :specializers ,(canonicalize-specializers specializers)
     745                     :body ',body
     746                     :environment (top-level-environment)))))
    727747
    728748(defun canonicalize-specializers (specializers)
    … …  
    730750
    731751(defun canonicalize-specializer (specializer)
    732   `(find-class ',specializer))
     752  ;; FIXME (EQL specializers)
     753  `(if (atom ',specializer) (find-class ',specializer) (find-class 't)))
    733754
    734755(defun parse-defmethod (args)
    … …  
    901922        (remove method (generic-function-methods gf)))
    902923  (setf (method-generic-function method) nil)
     924  (format t "remove-method method-specializers = ~S~%" (method-specializers method))
    903925  (dolist (class (method-specializers method))
    904926    (setf (class-direct-methods class)
    … …  
    943965   :environment (top-level-environment))
    944966  (values))
     967
     968;;; subclassp and sub-specializer-p
     969
     970(defun subclassp (c1 c2)
     971  (not (null (find c2 (class-precedence-list c1)))))
     972
     973(defun sub-specializer-p (c1 c2 c-arg)
     974  (let ((cpl (class-precedence-list c-arg)))
     975    (not (null (find c2 (cdr (member c1 cpl)))))))
    945976
    946977;;;
    … …  
    11001131;;; Slot access
    11011132
     1133(defun setf-slot-value-using-class (new-value class instance slot-name)
     1134  (setf (std-slot-value instance slot-name) new-value))
     1135
    11021136(defgeneric slot-value-using-class (class instance slot-name))
    1103 (defmethod slot-value-using-class
    1104   ((class standard-class) instance slot-name)
     1137(defmethod slot-value-using-class ((class standard-class) instance slot-name)
    11051138  (std-slot-value instance slot-name))
    11061139
    … …  
    11101143  (setf (std-slot-value instance slot-name) new-value))
    11111144;;; N.B. To avoid making a forward reference to a (setf xxx) generic function:
    1112 (defun setf-slot-value-using-class (new-value class object slot-name)
    1113   (setf (slot-value-using-class class object slot-name) new-value))
     1145;; (defun setf-slot-value-using-class (new-value class object slot-name)
     1146;;   (setf (slot-value-using-class class object slot-name) new-value))
    11141147
    11151148(defgeneric slot-exists-p-using-class (class instance slot-name))
    … …  
    11691202                    (funcall (slot-definition-initfunction slot))))))))
    11701203  instance)
     1204
     1205;;; change-class
     1206
     1207(defgeneric change-class (instance new-class &key))
     1208(defmethod change-class
     1209  ((old-instance standard-object)
     1210   (new-class standard-class)
     1211   &rest initargs)
     1212  (let ((new-instance (allocate-instance new-class)))
     1213    (dolist (slot-name (mapcar #'slot-definition-name
     1214                               (class-slots new-class)))
     1215      (when (and (slot-exists-p old-instance slot-name)
     1216                 (slot-boundp old-instance slot-name))
     1217        (setf (slot-value new-instance slot-name)
     1218              (slot-value old-instance slot-name))))
     1219    (rotatef (std-instance-slots new-instance)
     1220             (std-instance-slots old-instance))
     1221    (rotatef (std-instance-class new-instance)
     1222             (std-instance-class old-instance))
     1223    (apply #'update-instance-for-different-class
     1224           new-instance old-instance initargs)
     1225    old-instance))
     1226
     1227(defmethod change-class
     1228  ((instance standard-object) (new-class symbol) &rest initargs)
     1229  (apply #'change-class instance (find-class new-class) initargs))
     1230
     1231(defgeneric update-instance-for-different-class (old new &key))
     1232(defmethod update-instance-for-different-class
     1233  ((old standard-object) (new standard-object) &rest initargs)
     1234  (let ((added-slots
     1235         (remove-if #'(lambda (slot-name)
     1236                       (slot-exists-p old slot-name))
     1237                    (mapcar #'slot-definition-name
     1238                            (class-slots (class-of new))))))
     1239    (apply #'shared-initialize new added-slots initargs)))
Note: See TracChangeset for help on using the changeset viewer.