Changeset 14499


Ignore:
Timestamp:
05/15/13 06:45:13 (9 years ago)
Author:
rschlatte
Message:

Move standard-generic-function definition into Lisp

Slightly tricky since we need to avoid redefining
standard-generic-function during compilation of abcl itself, hence
make-or-find-instance-funcallable-standard-class

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/StandardClass.java

    r14490 r14499  
    573573  public static final StandardClass STANDARD_METHOD =
    574574    addStandardClass(Symbol.STANDARD_METHOD, list(METHOD));
    575 
    576   public static final StandardClass STANDARD_GENERIC_FUNCTION =
    577     addFuncallableStandardClass(Symbol.STANDARD_GENERIC_FUNCTION,
    578                                 list(GENERIC_FUNCTION));
    579575
    580576  public static void initializeStandardClasses()
     
    812808    STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass();
    813809
    814     // STANDARD-GENERIC-FUNCTION
    815     STANDARD_GENERIC_FUNCTION.setCPL(STANDARD_GENERIC_FUNCTION,
    816                                      GENERIC_FUNCTION, METAOBJECT,
    817                                      FUNCALLABLE_STANDARD_OBJECT,
    818                                      STANDARD_OBJECT,
    819                                      BuiltInClass.FUNCTION,
    820                                      BuiltInClass.CLASS_T);
    821     STANDARD_GENERIC_FUNCTION.setDirectSlotDefinitions(
    822       list(new SlotDefinition(Symbol.NAME, NIL, constantlyNil),
    823            new SlotDefinition(Symbol.LAMBDA_LIST, NIL, constantlyNil),
    824            new SlotDefinition(Symbol.REQUIRED_ARGS, NIL, constantlyNil),
    825            new SlotDefinition(Symbol.OPTIONAL_ARGS, NIL, constantlyNil),
    826            new SlotDefinition(Symbol.INITIAL_METHODS, NIL, constantlyNil),
    827            new SlotDefinition(Symbol.METHODS, NIL, constantlyNil),
    828            new SlotDefinition(Symbol.METHOD_CLASS, NIL, constantlyNil),
    829            new SlotDefinition(Symbol._METHOD_COMBINATION, NIL, constantlyNil,
    830                               list(internKeyword("METHOD-COMBINATION"))),
    831            new SlotDefinition(Symbol.ARGUMENT_PRECEDENCE_ORDER, NIL,
    832                               constantlyNil),
    833            new SlotDefinition(Symbol.DECLARATIONS, NIL, constantlyNil),
    834            new SlotDefinition(Symbol._DOCUMENTATION, NIL, constantlyNil,
    835                               list(internKeyword("DOCUMENTATION")))));
    836     // There are no inherited slots.
    837     STANDARD_GENERIC_FUNCTION.finalizeClass();
    838810  }
    839811}
  • trunk/abcl/src/org/armedbear/lisp/StandardObject.java

    r14492 r14499  
    669669    public LispObject execute(LispObject arg)
    670670    {
    671       if (arg == StandardClass.STANDARD_CLASS) {
     671      if (arg == StandardClass.FUNCALLABLE_STANDARD_CLASS) {
     672        return new FuncallableStandardClass();
     673      } else if (arg == StandardClass.STANDARD_CLASS) {
    672674        return new StandardClass();
    673675      } else if (arg instanceof StandardClass) {
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r14498 r14499  
    119119  (find-class 'funcallable-standard-object))
    120120(defconstant +the-standard-method-class+ (find-class 'standard-method))
    121 (defconstant +the-standard-generic-function-class+
    122   (find-class 'standard-generic-function))
    123121(defconstant +the-T-class+ (find-class 'T))
    124122(defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition))
     
    195193    (add-subclasses 'specializer '(class))
    196194    (add-subclasses 'funcallable-standard-object 'generic-function)
    197     (add-subclasses 'generic-function 'standard-generic-function)
    198195    (add-subclasses 'method 'standard-method)
    199196    (add-subclasses 'slot-definition
     
    862859    class))
    863860
     861(defun make-or-find-instance-funcallable-standard-class
     862    (metaclass &rest initargs &key name direct-superclasses direct-slots
     863                                direct-default-initargs documentation)
     864  (declare (ignore metaclass initargs))
     865  (or (find-class name nil)
     866      (let ((class (std-allocate-instance +the-funcallable-standard-class+)))
     867        (%set-class-name name class)
     868        (unless *clos-booting* (%set-class-layout nil class))
     869        (%set-class-direct-subclasses ()  class)
     870        (%set-class-direct-methods ()  class)
     871        (%set-class-documentation class documentation)
     872        (std-after-initialization-for-classes class
     873                                              :direct-superclasses direct-superclasses
     874                                              :direct-slots direct-slots
     875                                              :direct-default-initargs direct-default-initargs)
     876        class)))
     877
    864878;(defun convert-to-direct-slot-definition (class canonicalized-slot)
    865879;  (apply #'make-instance
     
    896910  (values))
    897911
    898 ;;; Bootstrap the lower parts of the metaclass hierarchy.
    899 
    900912(defmacro define-primordial-class (name superclasses direct-slots)
    901913  "Primitive class definition tool.
     
    905917  (let ((class (gensym)))
    906918    `(let ((,class (make-instance-standard-class
     919                    nil
     920                    :name ',name
     921                    :direct-superclasses ',(mapcar #'find-class superclasses)
     922                    :direct-slots ,(canonicalize-direct-slots direct-slots))))
     923       (%set-find-class ',name ,class)
     924       ,class)))
     925
     926(defmacro define-funcallable-primordial-class (name superclasses direct-slots)
     927  "Primitive funcallable class definition tool.
     928No non-standard metaclasses, accessor methods, duplicate slots,
     929non-existent superclasses, default initargs, or other complicated stuff.
     930Handle with care.
     931Will not modify existing classes to avoid breaking std-generic-function-p."
     932  (let ((class (gensym)))
     933    `(let ((,class (make-or-find-instance-funcallable-standard-class
    907934                    nil
    908935                    :name ',name
     
    969996(defconstant +the-forward-referenced-class+
    970997  (find-class 'forward-referenced-class))
     998
     999(define-funcallable-primordial-class standard-generic-function (generic-function)
     1000  ((sys::name :initarg :name :initform nil)
     1001   (sys::lambda-list :initarg :lambda-list :initform nil)
     1002   (sys::required-args :initarg :required-args :initform nil)
     1003   (sys::optional-args :initarg :optional-args :initform nil)
     1004   (sys::initial-methods :initarg :initial-methods :initform nil)
     1005   (sys::methods :initarg :methods :initform nil)
     1006   (sys::method-class :initarg :method-class
     1007                      :initform +the-standard-method-class+)
     1008   (sys::%method-combination :initarg :method-combination
     1009                             :initform (std-find-method-combination 'standard))
     1010   (sys::argument-precedence-order :initarg :argument-precedence-order
     1011                                   :initform nil)
     1012   (sys::declarations :initarg :declarations :initform nil)
     1013   (sys::%documentation :initarg :documentation :initform nil)))
     1014(defconstant +the-standard-generic-function-class+
     1015  (find-class 'standard-generic-function))
    9711016
    9721017(defun std-generic-function-p (gf)
Note: See TracChangeset for help on using the changeset viewer.