Commit 2d2a36ab authored by rschlatte@1c010e3e-69d0-11dd-93a8-456734b0d56f's avatar rschlatte@1c010e3e-69d0-11dd-93a8-456734b0d56f
Browse files

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
parent f5f20547
......@@ -573,10 +573,6 @@ public class StandardClass extends SlotClass
public static final StandardClass STANDARD_METHOD =
addStandardClass(Symbol.STANDARD_METHOD, list(METHOD));
public static final StandardClass STANDARD_GENERIC_FUNCTION =
addFuncallableStandardClass(Symbol.STANDARD_GENERIC_FUNCTION,
list(GENERIC_FUNCTION));
public static void initializeStandardClasses()
{
// We need to call setDirectSuperclass() here for classes that have a
......@@ -811,29 +807,5 @@ public class StandardClass extends SlotClass
BuiltInClass.CLASS_T);
STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass();
// STANDARD-GENERIC-FUNCTION
STANDARD_GENERIC_FUNCTION.setCPL(STANDARD_GENERIC_FUNCTION,
GENERIC_FUNCTION, METAOBJECT,
FUNCALLABLE_STANDARD_OBJECT,
STANDARD_OBJECT,
BuiltInClass.FUNCTION,
BuiltInClass.CLASS_T);
STANDARD_GENERIC_FUNCTION.setDirectSlotDefinitions(
list(new SlotDefinition(Symbol.NAME, NIL, constantlyNil),
new SlotDefinition(Symbol.LAMBDA_LIST, NIL, constantlyNil),
new SlotDefinition(Symbol.REQUIRED_ARGS, NIL, constantlyNil),
new SlotDefinition(Symbol.OPTIONAL_ARGS, NIL, constantlyNil),
new SlotDefinition(Symbol.INITIAL_METHODS, NIL, constantlyNil),
new SlotDefinition(Symbol.METHODS, NIL, constantlyNil),
new SlotDefinition(Symbol.METHOD_CLASS, NIL, constantlyNil),
new SlotDefinition(Symbol._METHOD_COMBINATION, NIL, constantlyNil,
list(internKeyword("METHOD-COMBINATION"))),
new SlotDefinition(Symbol.ARGUMENT_PRECEDENCE_ORDER, NIL,
constantlyNil),
new SlotDefinition(Symbol.DECLARATIONS, NIL, constantlyNil),
new SlotDefinition(Symbol._DOCUMENTATION, NIL, constantlyNil,
list(internKeyword("DOCUMENTATION")))));
// There are no inherited slots.
STANDARD_GENERIC_FUNCTION.finalizeClass();
}
}
......@@ -668,7 +668,9 @@ public class StandardObject extends LispObject
@Override
public LispObject execute(LispObject arg)
{
if (arg == StandardClass.STANDARD_CLASS) {
if (arg == StandardClass.FUNCALLABLE_STANDARD_CLASS) {
return new FuncallableStandardClass();
} else if (arg == StandardClass.STANDARD_CLASS) {
return new StandardClass();
} else if (arg instanceof StandardClass) {
StandardClass cls = (StandardClass)arg;
......
......@@ -118,8 +118,6 @@
(defconstant +the-funcallable-standard-object-class+
(find-class 'funcallable-standard-object))
(defconstant +the-standard-method-class+ (find-class 'standard-method))
(defconstant +the-standard-generic-function-class+
(find-class 'standard-generic-function))
(defconstant +the-T-class+ (find-class 'T))
(defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition))
(defconstant +the-standard-direct-slot-definition-class+ (find-class 'standard-direct-slot-definition))
......@@ -194,7 +192,6 @@
'(generic-function method slot-definition specializer))
(add-subclasses 'specializer '(class))
(add-subclasses 'funcallable-standard-object 'generic-function)
(add-subclasses 'generic-function 'standard-generic-function)
(add-subclasses 'method 'standard-method)
(add-subclasses 'slot-definition
'(direct-slot-definition effective-slot-definition
......@@ -861,6 +858,23 @@
:direct-default-initargs direct-default-initargs)
class))
(defun make-or-find-instance-funcallable-standard-class
(metaclass &rest initargs &key name direct-superclasses direct-slots
direct-default-initargs documentation)
(declare (ignore metaclass initargs))
(or (find-class name nil)
(let ((class (std-allocate-instance +the-funcallable-standard-class+)))
(%set-class-name name class)
(unless *clos-booting* (%set-class-layout nil class))
(%set-class-direct-subclasses () class)
(%set-class-direct-methods () class)
(%set-class-documentation class documentation)
(std-after-initialization-for-classes class
:direct-superclasses direct-superclasses
:direct-slots direct-slots
:direct-default-initargs direct-default-initargs)
class)))
;(defun convert-to-direct-slot-definition (class canonicalized-slot)
; (apply #'make-instance
; (apply #'direct-slot-definition-class
......@@ -895,8 +909,6 @@
(maybe-finalize-class-subtree class)
(values))
;;; Bootstrap the lower parts of the metaclass hierarchy.
(defmacro define-primordial-class (name superclasses direct-slots)
"Primitive class definition tool.
No non-standard metaclasses, accessor methods, duplicate slots,
......@@ -911,6 +923,21 @@ Handle with care."
(%set-find-class ',name ,class)
,class)))
(defmacro define-funcallable-primordial-class (name superclasses direct-slots)
"Primitive funcallable class definition tool.
No non-standard metaclasses, accessor methods, duplicate slots,
non-existent superclasses, default initargs, or other complicated stuff.
Handle with care.
Will not modify existing classes to avoid breaking std-generic-function-p."
(let ((class (gensym)))
`(let ((,class (make-or-find-instance-funcallable-standard-class
nil
:name ',name
:direct-superclasses ',(mapcar #'find-class superclasses)
:direct-slots ,(canonicalize-direct-slots direct-slots))))
(%set-find-class ',name ,class)
,class)))
(define-primordial-class eql-specializer (specializer)
((object :initform nil)
(direct-methods :initform nil)))
......@@ -969,6 +996,24 @@ Handle with care."
(defconstant +the-forward-referenced-class+
(find-class 'forward-referenced-class))
(define-funcallable-primordial-class standard-generic-function (generic-function)
((sys::name :initarg :name :initform nil)
(sys::lambda-list :initarg :lambda-list :initform nil)
(sys::required-args :initarg :required-args :initform nil)
(sys::optional-args :initarg :optional-args :initform nil)
(sys::initial-methods :initarg :initial-methods :initform nil)
(sys::methods :initarg :methods :initform nil)
(sys::method-class :initarg :method-class
:initform +the-standard-method-class+)
(sys::%method-combination :initarg :method-combination
:initform (std-find-method-combination 'standard))
(sys::argument-precedence-order :initarg :argument-precedence-order
:initform nil)
(sys::declarations :initarg :declarations :initform nil)
(sys::%documentation :initarg :documentation :initform nil)))
(defconstant +the-standard-generic-function-class+
(find-class 'standard-generic-function))
(defun std-generic-function-p (gf)
(eq (class-of gf) +the-standard-generic-function-class+))
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment