diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 577ec56b3..31f3bfebd 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -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. ;;; diff --git a/src/clos/cpl.lsp b/src/clos/cpl.lsp new file mode 100644 index 000000000..d59cc45da --- /dev/null +++ b/src/clos/cpl.lsp @@ -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))))))))) + +;;; ---------------------------------------------------------------------- diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index b085a78c2..bd2d5002d 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -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))))))))) - -;;; ---------------------------------------------------------------------- diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 86da65c5f..bb078952d 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -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))) diff --git a/src/clos/load.lsp.in b/src/clos/load.lsp.in index 64a3982c2..651287ed2 100644 --- a/src/clos/load.lsp.in +++ b/src/clos/load.lsp.in @@ -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" diff --git a/src/clos/package.lsp b/src/clos/package.lsp new file mode 100644 index 000000000..59a612c56 --- /dev/null +++ b/src/clos/package.lsp @@ -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")) + diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index b485e1f76..146126b84 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.lsp @@ -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)) +) + ;;; ----------------------------------------------------------------------