mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-16 06:12:25 -08:00
Changed the boot order to create the classes before the generic functions utilities in kernel.lsp are available.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
b390d289b5
commit
b0eeaabe26
7 changed files with 353 additions and 321 deletions
|
|
@ -12,6 +12,126 @@
|
|||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Class SPECIALIZER
|
||||
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defparameter +specializer-slots+
|
||||
'((flag :initform nil :accessor eql-specializer-flag)
|
||||
(direct-methods :initform nil :accessor specializer-direct-methods)
|
||||
(direct-generic-functions :initform nil :accessor specializer-direct-generic-functions)))
|
||||
(defparameter +eql-specializer-slots+
|
||||
'((flag :initform t :accessor eql-specializer-flag)
|
||||
(direct-methods :initform nil :accessor specializer-direct-methods)
|
||||
(direct-generic-functions :initform nil :accessor specializer-direct-generic-functions)
|
||||
(object :initarg :object :accessor eql-specializer-object))))
|
||||
|
||||
#.(create-accessors +eql-specializer-slots+ 'eql-specializer)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Class METHOD-COMBINATION
|
||||
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defparameter +method-combination-slots+
|
||||
`((name :initform :name :accessor method-combination-name)
|
||||
(compiler :initform :compiler :accessor method-combination-compiler)
|
||||
(options :initform :options :accessor method-combination-options))))
|
||||
|
||||
#.(create-accessors +method-combination-slots+ 'method-combination)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Class CLASS
|
||||
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defparameter +class-slots+
|
||||
`(,@+specializer-slots+
|
||||
(name :initarg :name :initform nil :accessor class-id)
|
||||
(direct-superclasses :initarg :direct-superclasses
|
||||
:accessor class-direct-superclasses)
|
||||
(direct-subclasses :initform nil :accessor class-direct-subclasses)
|
||||
(slots :accessor class-slots)
|
||||
(precedence-list :accessor class-precedence-list)
|
||||
(direct-slots :initarg :direct-slots :accessor class-direct-slots)
|
||||
(direct-default-initargs :initarg :direct-default-initargs
|
||||
:initform nil :accessor class-direct-default-initargs)
|
||||
(default-initargs :accessor class-default-initargs)
|
||||
(finalized :initform nil :accessor class-finalized-p)
|
||||
(docstring :initarg :documentation :initform nil)
|
||||
(size :accessor class-size)
|
||||
(sealedp :initarg :sealedp :initform nil :accessor class-sealedp)
|
||||
(prototype)
|
||||
(dependents :initform nil :accessor class-dependents)
|
||||
(valid-initargs :initform nil :accessor class-valid-initargs)))
|
||||
|
||||
(defconstant +class-name-ndx+
|
||||
(position 'name +class-slots+ :key #'first))
|
||||
(defconstant +class-precedence-list-ndx+
|
||||
(position 'precedence-list +class-slots+ :key #'first)))
|
||||
|
||||
;#.(create-accessors +class-slots+ 'class)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; STANDARD-CLASS
|
||||
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defparameter +standard-class-slots+
|
||||
(append +class-slots+
|
||||
'((slot-table :accessor slot-table)
|
||||
(optimize-slot-access)
|
||||
(forward)))))
|
||||
|
||||
#.(create-accessors +standard-class-slots+ 'standard-class)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; STANDARD-GENERIC-FUNCTION
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defparameter +standard-generic-function-slots+
|
||||
'((name :initarg :name :initform nil
|
||||
:accessor generic-function-name)
|
||||
(spec-list :initform nil :accessor generic-function-spec-list)
|
||||
(method-combination
|
||||
:initarg :method-combination :initform (find-method-combination (class-prototype (find-class 'standard-generic-function)) 'standard nil)
|
||||
:accessor generic-function-method-combination)
|
||||
(lambda-list :initarg :lambda-list
|
||||
:accessor generic-function-lambda-list)
|
||||
(argument-precedence-order
|
||||
:initarg :argument-precedence-order
|
||||
:initform nil
|
||||
:accessor generic-function-argument-precedence-order)
|
||||
(method-class
|
||||
:initarg :method-class
|
||||
:initform (find-class 'standard-method))
|
||||
(docstring :initarg :documentation :initform nil)
|
||||
(methods :initform nil :accessor generic-function-methods)
|
||||
(a-p-o-function :initform nil :accessor generic-function-a-p-o-function)
|
||||
(declarations
|
||||
:initarg :declarations
|
||||
:initform nil
|
||||
:accessor generic-function-declarations)
|
||||
(dependents :initform nil :accessor generic-function-dependents))))
|
||||
|
||||
#.(create-accessors +standard-generic-function-slots+
|
||||
'standard-generic-function)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; STANDARD-METHOD
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defparameter +standard-method-slots+
|
||||
'((the-generic-function :initarg :generic-function :initform nil
|
||||
:accessor method-generic-function)
|
||||
(lambda-list :initarg :lambda-list
|
||||
:accessor method-lambda-list)
|
||||
(specializers :initarg :specializers :accessor method-specializers)
|
||||
(qualifiers :initform nil :initarg :qualifiers :accessor method-qualifiers)
|
||||
(the-function :initarg :function :accessor method-function)
|
||||
(docstring :initarg :documentation :initform nil)
|
||||
(plist :initform nil :initarg :plist :accessor method-plist)
|
||||
(keywords :initform nil :accessor method-keywords))))
|
||||
|
||||
#.(create-accessors +standard-method-slots+ 'standard-method)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
;;
|
||||
|
|
@ -163,6 +283,45 @@
|
|||
:direct-slots #.(canonical-slots +standard-method-slots+))
|
||||
)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Early accessors and class construction
|
||||
;;;
|
||||
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defmacro with-early-accessors ((&rest slot-definitions) &rest body)
|
||||
`(macrolet
|
||||
,(loop for slots in slot-definitions
|
||||
nconc (loop for (name . slotd) in (if (symbolp slots)
|
||||
(symbol-value slots)
|
||||
slots)
|
||||
for index from 0
|
||||
for accessor = (getf slotd :accessor)
|
||||
when accessor
|
||||
collect `(,accessor (object) `(si::instance-ref ,object ,,index))))
|
||||
,@body))
|
||||
(defmacro with-early-make-instance (slots (object class &rest key-value-pairs)
|
||||
&rest body)
|
||||
(when (symbolp slots)
|
||||
(setf slots (symbol-value slots)))
|
||||
`(let* ((%class ,class)
|
||||
(,object (si::allocate-raw-instance nil %class
|
||||
,(length slots))))
|
||||
(declare (type standard-object ,object))
|
||||
,@(loop for (name . slotd) in slots
|
||||
for initarg = (getf slotd :initarg)
|
||||
for initform = (getf slotd :initform)
|
||||
for initvalue = (getf key-value-pairs initarg)
|
||||
for index from 0
|
||||
do (cond ((and initarg (member initarg key-value-pairs))
|
||||
(setf initform (getf key-value-pairs initarg)))
|
||||
((getf key-value-pairs name)
|
||||
(setf initform (getf key-value-pairs name))))
|
||||
collect `(si::instance-set ,object ,index ,initform))
|
||||
(when %class
|
||||
(si::instance-sig-set ,object))
|
||||
(with-early-accessors (,slots)
|
||||
,@body))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Building the classes T, CLASS, STANDARD-OBJECT and STANDARD-CLASS.
|
||||
;;;
|
||||
|
|
|
|||
134
src/clos/cpl.lsp
Normal file
134
src/clos/cpl.lsp
Normal file
|
|
@ -0,0 +1,134 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*-
|
||||
;;;;
|
||||
;;;; Copyright (c) 1992, Giuseppe Attardi.
|
||||
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Library General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; ORDERING OF CLASSES
|
||||
;;;
|
||||
;;; We have two implementations of the algorithm described in Sect. 4.3.5
|
||||
;;; of the Common Lisp Hyperspec. The first implementation is a literal
|
||||
;;; transcription of that algorithm. The second implementation does not
|
||||
;;; create the list of pairs for describing the order, it is not recursive
|
||||
;;; and conses less
|
||||
#+(or)
|
||||
(defun compute-clos-class-precedence-list (new-class superclasses)
|
||||
(labels ((pair-list (l)
|
||||
(if (or (null l) (endp (cdr l)))
|
||||
nil
|
||||
(cons (cons (first l) (second l))
|
||||
(pair-list (rest l)))))
|
||||
(walk-supers (parent superclasses class-list precedence-alist)
|
||||
(let ((new-alist (pair-list (if parent
|
||||
(list* parent superclasses)
|
||||
superclasses))))
|
||||
(setf precedence-alist (nconc new-alist precedence-alist)
|
||||
class-list (union superclasses class-list)))
|
||||
(dolist (c superclasses)
|
||||
(multiple-value-setq (class-list precedence-alist)
|
||||
(walk-supers c (class-direct-superclasses c) class-list precedence-alist)))
|
||||
(values class-list precedence-alist))
|
||||
(cycle-error (new-class)
|
||||
(error "A cycle has been detected in the class precedence list for ~A."
|
||||
(class-name new-class)))
|
||||
(free-elements (class-list precedence-alist)
|
||||
(set-difference class-list
|
||||
(delete-duplicates (mapcar #'cdr precedence-alist))))
|
||||
(next-element (free-list cpl)
|
||||
(if (or (null cpl) (endp free-list) (endp (rest free-list)))
|
||||
(first free-list)
|
||||
(dolist (i cpl nil)
|
||||
(dolist (j (class-direct-superclasses i))
|
||||
(when (member j free-list)
|
||||
(return-from next-element j)))))))
|
||||
(if (endp (rest superclasses))
|
||||
(let ((class (first superclasses)))
|
||||
(list* new-class (class-precedence-list class)))
|
||||
(multiple-value-bind (class-list precedence-alist)
|
||||
(walk-supers nil superclasses nil nil)
|
||||
(do ((cpl (list new-class)))
|
||||
((null class-list)
|
||||
(if precedence-alist (cycle-error new-class) (nreverse cpl)))
|
||||
(let* ((candidates (free-elements class-list precedence-alist))
|
||||
(next (next-element candidates cpl)))
|
||||
(unless next
|
||||
(cycle-error new-class))
|
||||
(setf precedence-alist (delete next precedence-alist :key #'car)
|
||||
class-list (delete next class-list)
|
||||
cpl (cons next cpl))))))))
|
||||
|
||||
(defun compute-clos-class-precedence-list (new-class superclasses)
|
||||
(labels ((walk-supers (superclasses)
|
||||
;; Creates two lists, one with all the superclasses of a class to be created,
|
||||
;; and a second list with lists (c1 c2 c3 ... cn) that represent a partial
|
||||
;; ordering of the classes (c1 > c2), (c2 > c3), etc."
|
||||
(let ((class-list '())
|
||||
(precedence-lists (list superclasses)))
|
||||
(loop (unless superclasses
|
||||
(return (values class-list precedence-lists)))
|
||||
(let ((next-class (pop superclasses)))
|
||||
(unless (member next-class class-list :test 'eql)
|
||||
(let ((more-classes (class-direct-superclasses next-class)))
|
||||
(setf class-list (list* next-class class-list)
|
||||
precedence-lists (list* (list* next-class more-classes)
|
||||
precedence-lists)
|
||||
superclasses (append more-classes superclasses))))))))
|
||||
(cycle-error (class)
|
||||
(error "A cycle has been detected in the class precedence list for ~A."
|
||||
(class-name class)))
|
||||
(has-no-precedent (class precedence-lists)
|
||||
;; Check if CLASS is not preceded by any other class in the partial order.
|
||||
(dolist (partial-order precedence-lists t)
|
||||
(when (member class (rest partial-order) :test 'eql)
|
||||
(return nil))))
|
||||
(free-elements (class-list precedence-lists)
|
||||
;; Return classes that are not preceded by anyone
|
||||
(let ((output '()))
|
||||
(dolist (class class-list)
|
||||
(when (has-no-precedent class precedence-lists)
|
||||
(push class output)))
|
||||
output))
|
||||
(next-element (free-list cpl)
|
||||
;; Compute the next element that we will add to the class precedence list.
|
||||
(if (or (null cpl) (endp free-list) (endp (rest free-list)))
|
||||
(first free-list)
|
||||
(dolist (i cpl nil)
|
||||
(dolist (j (class-direct-superclasses i))
|
||||
(when (member j free-list :test 'eql)
|
||||
(return-from next-element j))))))
|
||||
(delete-class (class precedence-lists)
|
||||
(do ((l precedence-lists (rest l)))
|
||||
((null l)
|
||||
(delete nil precedence-lists))
|
||||
(let ((one-list (first l)))
|
||||
(when (eq class (first one-list))
|
||||
(setf (first l) (rest one-list)))))))
|
||||
(cond ((null superclasses)
|
||||
(list new-class))
|
||||
((endp (rest superclasses))
|
||||
(let ((class (first superclasses)))
|
||||
(list* new-class (class-precedence-list class))))
|
||||
(t
|
||||
(multiple-value-bind (class-list precedence-lists)
|
||||
(walk-supers superclasses)
|
||||
(do ((cpl (list new-class)))
|
||||
((null class-list)
|
||||
(if precedence-lists (cycle-error new-class) (nreverse cpl)))
|
||||
(let* ((candidates (free-elements class-list precedence-lists))
|
||||
(next (next-element candidates cpl)))
|
||||
(unless next
|
||||
(cycle-error new-class))
|
||||
(setf precedence-lists (delete-class next precedence-lists)
|
||||
class-list (delete next class-list)
|
||||
cpl (cons next cpl)))))))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
@ -137,123 +137,3 @@
|
|||
(defun ensure-class (name &rest initargs)
|
||||
(warn "Ignoring definition for class ~S" name)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; ORDERING OF CLASSES
|
||||
;;;
|
||||
;;; We have two implementations of the algorithm described in Sect. 4.3.5
|
||||
;;; of the Common Lisp Hyperspec. The first implementation is a literal
|
||||
;;; transcription of that algorithm. The second implementation does not
|
||||
;;; create the list of pairs for describing the order, it is not recursive
|
||||
;;; and conses less
|
||||
#+(or)
|
||||
(defun compute-clos-class-precedence-list (new-class superclasses)
|
||||
(labels ((pair-list (l)
|
||||
(if (or (null l) (endp (cdr l)))
|
||||
nil
|
||||
(cons (cons (first l) (second l))
|
||||
(pair-list (rest l)))))
|
||||
(walk-supers (parent superclasses class-list precedence-alist)
|
||||
(let ((new-alist (pair-list (if parent
|
||||
(list* parent superclasses)
|
||||
superclasses))))
|
||||
(setf precedence-alist (nconc new-alist precedence-alist)
|
||||
class-list (union superclasses class-list)))
|
||||
(dolist (c superclasses)
|
||||
(multiple-value-setq (class-list precedence-alist)
|
||||
(walk-supers c (class-direct-superclasses c) class-list precedence-alist)))
|
||||
(values class-list precedence-alist))
|
||||
(cycle-error (new-class)
|
||||
(error "A cycle has been detected in the class precedence list for ~A."
|
||||
(class-name new-class)))
|
||||
(free-elements (class-list precedence-alist)
|
||||
(set-difference class-list
|
||||
(delete-duplicates (mapcar #'cdr precedence-alist))))
|
||||
(next-element (free-list cpl)
|
||||
(if (or (null cpl) (endp free-list) (endp (rest free-list)))
|
||||
(first free-list)
|
||||
(dolist (i cpl nil)
|
||||
(dolist (j (class-direct-superclasses i))
|
||||
(when (member j free-list)
|
||||
(return-from next-element j)))))))
|
||||
(if (endp (rest superclasses))
|
||||
(let ((class (first superclasses)))
|
||||
(list* new-class (class-precedence-list class)))
|
||||
(multiple-value-bind (class-list precedence-alist)
|
||||
(walk-supers nil superclasses nil nil)
|
||||
(do ((cpl (list new-class)))
|
||||
((null class-list)
|
||||
(if precedence-alist (cycle-error new-class) (nreverse cpl)))
|
||||
(let* ((candidates (free-elements class-list precedence-alist))
|
||||
(next (next-element candidates cpl)))
|
||||
(unless next
|
||||
(cycle-error new-class))
|
||||
(setf precedence-alist (delete next precedence-alist :key #'car)
|
||||
class-list (delete next class-list)
|
||||
cpl (cons next cpl))))))))
|
||||
|
||||
(defun compute-clos-class-precedence-list (new-class superclasses)
|
||||
(labels ((walk-supers (superclasses)
|
||||
;; Creates two lists, one with all the superclasses of a class to be created,
|
||||
;; and a second list with lists (c1 c2 c3 ... cn) that represent a partial
|
||||
;; ordering of the classes (c1 > c2), (c2 > c3), etc."
|
||||
(let ((class-list '())
|
||||
(precedence-lists (list superclasses)))
|
||||
(loop (unless superclasses
|
||||
(return (values class-list precedence-lists)))
|
||||
(let ((next-class (pop superclasses)))
|
||||
(unless (member next-class class-list :test 'eql)
|
||||
(let ((more-classes (class-direct-superclasses next-class)))
|
||||
(setf class-list (list* next-class class-list)
|
||||
precedence-lists (list* (list* next-class more-classes)
|
||||
precedence-lists)
|
||||
superclasses (append more-classes superclasses))))))))
|
||||
(cycle-error (class)
|
||||
(error "A cycle has been detected in the class precedence list for ~A."
|
||||
(class-name class)))
|
||||
(has-no-precedent (class precedence-lists)
|
||||
;; Check if CLASS is not preceded by any other class in the partial order.
|
||||
(dolist (partial-order precedence-lists t)
|
||||
(when (member class (rest partial-order) :test 'eql)
|
||||
(return nil))))
|
||||
(free-elements (class-list precedence-lists)
|
||||
;; Return classes that are not preceded by anyone
|
||||
(let ((output '()))
|
||||
(dolist (class class-list)
|
||||
(when (has-no-precedent class precedence-lists)
|
||||
(push class output)))
|
||||
output))
|
||||
(next-element (free-list cpl)
|
||||
;; Compute the next element that we will add to the class precedence list.
|
||||
(if (or (null cpl) (endp free-list) (endp (rest free-list)))
|
||||
(first free-list)
|
||||
(dolist (i cpl nil)
|
||||
(dolist (j (class-direct-superclasses i))
|
||||
(when (member j free-list :test 'eql)
|
||||
(return-from next-element j))))))
|
||||
(delete-class (class precedence-lists)
|
||||
(do ((l precedence-lists (rest l)))
|
||||
((null l)
|
||||
(delete nil precedence-lists))
|
||||
(let ((one-list (first l)))
|
||||
(when (eq class (first one-list))
|
||||
(setf (first l) (rest one-list)))))))
|
||||
(cond ((null superclasses)
|
||||
(list new-class))
|
||||
((endp (rest superclasses))
|
||||
(let ((class (first superclasses)))
|
||||
(list* new-class (class-precedence-list class))))
|
||||
(t
|
||||
(multiple-value-bind (class-list precedence-lists)
|
||||
(walk-supers superclasses)
|
||||
(do ((cpl (list new-class)))
|
||||
((null class-list)
|
||||
(if precedence-lists (cycle-error new-class) (nreverse cpl)))
|
||||
(let* ((candidates (free-elements class-list precedence-lists))
|
||||
(next (next-element candidates cpl)))
|
||||
(unless next
|
||||
(cycle-error new-class))
|
||||
(setf precedence-lists (delete-class next precedence-lists)
|
||||
class-list (delete next class-list)
|
||||
cpl (cons next cpl)))))))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -10,173 +10,10 @@
|
|||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
|
||||
(defpackage "CLOS"
|
||||
(:use "CL" "EXT")
|
||||
(:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP"
|
||||
"SIMPLE-PROGRAM-ERROR"))
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
(defparameter *clos-booted* nil)
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; BOOTSTRAP FUNCTIONS TO ACCESS SLOTS
|
||||
;;;
|
||||
;;; ECL has some restictions regarding the basic classes CLASS,
|
||||
;;; STANDARD-CLASS and STANDARD-GENERIC-FUNCTION. These are that, certain
|
||||
;;; slots must have pre-defined positions which cannot change. That means
|
||||
;;; that a user can extend these classes, but they must be the first ones
|
||||
;;; in the class hierarchy, and the position of their slots must not change.
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defun create-accessors (slotds type)
|
||||
(let* ((names '())
|
||||
(forms (loop for i from 0
|
||||
for s in slotds
|
||||
for accessor = (getf (cdr s) :accessor)
|
||||
for reader = (getf (cdr s) :reader)
|
||||
when reader
|
||||
do (pushnew reader names)
|
||||
and collect `(defun ,reader (obj)
|
||||
(si::instance-ref obj ,i))
|
||||
when accessor
|
||||
do (pushnew accessor names)
|
||||
and collect `(defun ,accessor (obj)
|
||||
(si::instance-ref obj ,i))
|
||||
and collect `(defsetf ,accessor (obj) (x)
|
||||
`(si::instance-set ,obj ,,i ,x)))))
|
||||
`(progn
|
||||
#+nil
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(proclaim '(notinline ,@names)))
|
||||
,@forms)))
|
||||
(defun remove-accessors (slotds)
|
||||
(loop for i in slotds
|
||||
for j = (copy-list i)
|
||||
do (remf (cdr j) :accessor)
|
||||
collect j))
|
||||
)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Class SPECIALIZER
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defparameter +specializer-slots+
|
||||
'((flag :initform nil :accessor eql-specializer-flag)
|
||||
(direct-methods :initform nil :accessor specializer-direct-methods)
|
||||
(direct-generic-functions :initform nil :accessor specializer-direct-generic-functions)))
|
||||
(defparameter +eql-specializer-slots+
|
||||
'((flag :initform t :accessor eql-specializer-flag)
|
||||
(direct-methods :initform nil :accessor specializer-direct-methods)
|
||||
(direct-generic-functions :initform nil :accessor specializer-direct-generic-functions)
|
||||
(object :initarg :object :accessor eql-specializer-object))))
|
||||
|
||||
#.(create-accessors +eql-specializer-slots+ 'eql-specializer)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Class METHOD-COMBINATION
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defparameter +method-combination-slots+
|
||||
`((name :initform :name :accessor method-combination-name)
|
||||
(compiler :initform :compiler :accessor method-combination-compiler)
|
||||
(options :initform :options :accessor method-combination-options))))
|
||||
|
||||
#.(create-accessors +method-combination-slots+ 'method-combination)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Class CLASS
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defparameter +class-slots+
|
||||
`(,@+specializer-slots+
|
||||
(name :initarg :name :initform nil :accessor class-id)
|
||||
(direct-superclasses :initarg :direct-superclasses
|
||||
:accessor class-direct-superclasses)
|
||||
(direct-subclasses :initform nil :accessor class-direct-subclasses)
|
||||
(slots :accessor class-slots)
|
||||
(precedence-list :accessor class-precedence-list)
|
||||
(direct-slots :initarg :direct-slots :accessor class-direct-slots)
|
||||
(direct-default-initargs :initarg :direct-default-initargs
|
||||
:initform nil :accessor class-direct-default-initargs)
|
||||
(default-initargs :accessor class-default-initargs)
|
||||
(finalized :initform nil :accessor class-finalized-p)
|
||||
(docstring :initarg :documentation :initform nil)
|
||||
(size :accessor class-size)
|
||||
(sealedp :initarg :sealedp :initform nil :accessor class-sealedp)
|
||||
(prototype)
|
||||
(dependents :initform nil :accessor class-dependents)
|
||||
(valid-initargs :initform nil :accessor class-valid-initargs)))
|
||||
|
||||
(defconstant +class-name-ndx+
|
||||
(position 'name +class-slots+ :key #'first))
|
||||
(defconstant +class-precedence-list-ndx+
|
||||
(position 'precedence-list +class-slots+ :key #'first)))
|
||||
|
||||
;#.(create-accessors +class-slots+ 'class)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; STANDARD-CLASS
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defparameter +standard-class-slots+
|
||||
(append +class-slots+
|
||||
'((slot-table :accessor slot-table)
|
||||
(optimize-slot-access)
|
||||
(forward)))))
|
||||
|
||||
#.(create-accessors +standard-class-slots+ 'standard-class)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; STANDARD-GENERIC-FUNCTION
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defparameter +standard-generic-function-slots+
|
||||
'((name :initarg :name :initform nil
|
||||
:accessor generic-function-name)
|
||||
(spec-list :initform nil :accessor generic-function-spec-list)
|
||||
(method-combination
|
||||
:initarg :method-combination :initform (find-method-combination (class-prototype (find-class 'standard-generic-function)) 'standard nil)
|
||||
:accessor generic-function-method-combination)
|
||||
(lambda-list :initarg :lambda-list
|
||||
:accessor generic-function-lambda-list)
|
||||
(argument-precedence-order
|
||||
:initarg :argument-precedence-order
|
||||
:initform nil
|
||||
:accessor generic-function-argument-precedence-order)
|
||||
(method-class
|
||||
:initarg :method-class
|
||||
:initform (find-class 'standard-method))
|
||||
(docstring :initarg :documentation :initform nil)
|
||||
(methods :initform nil :accessor generic-function-methods)
|
||||
(a-p-o-function :initform nil :accessor generic-function-a-p-o-function)
|
||||
(declarations
|
||||
:initarg :declarations
|
||||
:initform nil
|
||||
:accessor generic-function-declarations)
|
||||
(dependents :initform nil :accessor generic-function-dependents))))
|
||||
|
||||
#.(create-accessors +standard-generic-function-slots+
|
||||
'standard-generic-function)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; STANDARD-METHOD
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defparameter +standard-method-slots+
|
||||
'((the-generic-function :initarg :generic-function :initform nil
|
||||
:accessor method-generic-function)
|
||||
(lambda-list :initarg :lambda-list
|
||||
:accessor method-lambda-list)
|
||||
(specializers :initarg :specializers :accessor method-specializers)
|
||||
(qualifiers :initform nil :initarg :qualifiers :accessor method-qualifiers)
|
||||
(the-function :initarg :function :accessor method-function)
|
||||
(docstring :initarg :documentation :initform nil)
|
||||
(plist :initform nil :initarg :plist :accessor method-plist)
|
||||
(keywords :initform nil :accessor method-keywords))))
|
||||
|
||||
#.(create-accessors +standard-method-slots+ 'standard-method)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;;
|
||||
;;; FIND-CLASS naming classes.
|
||||
|
|
@ -251,41 +88,6 @@
|
|||
;;; ----------------------------------------------------------------------
|
||||
;;; early versions
|
||||
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defmacro with-early-accessors ((&rest slot-definitions) &rest body)
|
||||
`(macrolet
|
||||
,(loop for slots in slot-definitions
|
||||
nconc (loop for (name . slotd) in (if (symbolp slots)
|
||||
(symbol-value slots)
|
||||
slots)
|
||||
for index from 0
|
||||
for accessor = (getf slotd :accessor)
|
||||
when accessor
|
||||
collect `(,accessor (object) `(si::instance-ref ,object ,,index))))
|
||||
,@body))
|
||||
(defmacro with-early-make-instance (slots (object class &rest key-value-pairs)
|
||||
&rest body)
|
||||
(when (symbolp slots)
|
||||
(setf slots (symbol-value slots)))
|
||||
`(let* ((%class ,class)
|
||||
(,object (si::allocate-raw-instance nil %class
|
||||
,(length slots))))
|
||||
(declare (type standard-object ,object))
|
||||
,@(loop for (name . slotd) in slots
|
||||
for initarg = (getf slotd :initarg)
|
||||
for initform = (getf slotd :initform)
|
||||
for initvalue = (getf key-value-pairs initarg)
|
||||
for index from 0
|
||||
do (cond ((and initarg (member initarg key-value-pairs))
|
||||
(setf initform (getf key-value-pairs initarg)))
|
||||
((getf key-value-pairs name)
|
||||
(setf initform (getf key-value-pairs name))))
|
||||
collect `(si::instance-set ,object ,index ,initform))
|
||||
(when %class
|
||||
(si::instance-sig-set ,object))
|
||||
(with-early-accessors (,slots)
|
||||
,@body))))
|
||||
|
||||
;;; early version used during bootstrap
|
||||
(defun ensure-generic-function (name &key (lambda-list (si::unbound) l-l-p))
|
||||
(if (and (fboundp name) (si::instancep (fdefinition name)))
|
||||
|
|
|
|||
|
|
@ -1,13 +1,15 @@
|
|||
;;; @configure_input@
|
||||
|
||||
(defvar +clos-module-files+
|
||||
'("src:clos;kernel.lsp"
|
||||
'("src:clos;package.lsp"
|
||||
"src:clos;slot.lsp"
|
||||
"src:clos;cpl.lsp"
|
||||
"src:clos;boot.lsp"
|
||||
"src:clos;kernel.lsp"
|
||||
"src:clos;macros.lsp"
|
||||
"src:clos;method.lsp"
|
||||
"src:clos;slot.lsp"
|
||||
"src:clos;combin.lsp"
|
||||
"src:clos;defclass.lsp"
|
||||
"src:clos;boot.lsp"
|
||||
"src:clos;slotvalue.lsp"
|
||||
"src:clos;standard.lsp"
|
||||
"src:clos;builtin.lsp"
|
||||
|
|
|
|||
17
src/clos/package.lsp
Normal file
17
src/clos/package.lsp
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*-
|
||||
;;;;
|
||||
;;;; Copyright (c) 1992, Giuseppe Attardi.
|
||||
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Library General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
|
||||
(defpackage "CLOS"
|
||||
(:use "CL" "EXT")
|
||||
(:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP"
|
||||
"SIMPLE-PROGRAM-ERROR"))
|
||||
|
||||
|
|
@ -156,4 +156,42 @@
|
|||
name)))
|
||||
(push slotd collect))))
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; BOOTSTRAP FUNCTIONS TO ACCESS SLOTS
|
||||
;;;
|
||||
;;; ECL has some restictions regarding the basic classes CLASS,
|
||||
;;; STANDARD-CLASS and STANDARD-GENERIC-FUNCTION. These are that, certain
|
||||
;;; slots must have pre-defined positions which cannot change. That means
|
||||
;;; that a user can extend these classes, but they must be the first ones
|
||||
;;; in the class hierarchy, and the position of their slots must not change.
|
||||
|
||||
(eval-when (compile eval)
|
||||
(defun create-accessors (slotds type)
|
||||
(let* ((names '())
|
||||
(forms (loop for i from 0
|
||||
for s in slotds
|
||||
for accessor = (getf (cdr s) :accessor)
|
||||
for reader = (getf (cdr s) :reader)
|
||||
when reader
|
||||
do (pushnew reader names)
|
||||
and collect `(defun ,reader (obj)
|
||||
(si::instance-ref obj ,i))
|
||||
when accessor
|
||||
do (pushnew accessor names)
|
||||
and collect `(defun ,accessor (obj)
|
||||
(si::instance-ref obj ,i))
|
||||
and collect `(defsetf ,accessor (obj) (x)
|
||||
`(si::instance-set ,obj ,,i ,x)))))
|
||||
`(progn
|
||||
#+nil
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(proclaim '(notinline ,@names)))
|
||||
,@forms)))
|
||||
(defun remove-accessors (slotds)
|
||||
(loop for i in slotds
|
||||
for j = (copy-list i)
|
||||
do (remf (cdr j) :accessor)
|
||||
collect j))
|
||||
)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue