From 88db3f8dbf90e9b31bdf2b503bae79372e807ec0 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 7 Oct 2012 12:02:45 +0200 Subject: [PATCH] Reorganize the code so that SLOT-VALUE is available at boot time. --- src/clos/boot.lsp | 287 +---------------------------------- src/clos/hierarchy.lsp | 293 ++++++++++++++++++++++++++++++++++++ src/clos/load.lsp.in | 2 +- src/clos/method.lsp | 19 --- src/clos/slotvalue.lsp | 111 +------------- src/clos/standard.lsp | 11 +- src/clos/std-slot-value.lsp | 202 +++++++++++++++++++++++++ 7 files changed, 509 insertions(+), 416 deletions(-) create mode 100644 src/clos/hierarchy.lsp create mode 100644 src/clos/std-slot-value.lsp diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 50bc5b0a7..c699a1202 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -12,292 +12,17 @@ (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)))) - -;;; ---------------------------------------------------------------------- -;;; 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)))) - -;;; ---------------------------------------------------------------------- -;;; 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 :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))) - -;;; ---------------------------------------------------------------------- -;;; STANDARD-CLASS - -(eval-when (:compile-toplevel :execute) - (defparameter +standard-class-slots+ - (append +class-slots+ - '((slot-table :accessor slot-table) - (optimize-slot-access) - (forward))))) - -;;; ---------------------------------------------------------------------- -;;; STANDARD-GENERIC-FUNCTION - -(eval-when (:compile-toplevel :execute) - (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)))) - -;;; ---------------------------------------------------------------------- -;;; STANDARD-METHOD - -(eval-when (:compile-toplevel :execute) - (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))) - - (defparameter +standard-accessor-method-slots+ - (append +standard-method-slots+ - '((slot-definition :initarg :slot-definition - :initform nil - ;; FIXME! Should be a :reader - :accessor accessor-method-slot-definition))))) - -;;; ---------------------------------------------------------------------- -(eval-when (:compile-toplevel :execute) - ;; - ;; All changes to this are connected to the changes in - ;; the code of cl_class_of() in src/instance.d - ;; - (defconstant +builtin-classes-list+ - '(;(t object) - (sequence) - (list sequence) - (cons list) - (array) - (vector array sequence) - (string vector) - #+unicode - (base-string string vector) - (bit-vector vector) - (stream) - (ext:ansi-stream stream) - (file-stream ext:ansi-stream) - (echo-stream ext:ansi-stream) - (string-stream ext:ansi-stream) - (two-way-stream ext:ansi-stream) - (synonym-stream ext:ansi-stream) - (broadcast-stream ext:ansi-stream) - (concatenated-stream ext:ansi-stream) - (ext:sequence-stream ext:ansi-stream) - (character) - (number) - (real number) - (rational real) - (integer rational) - (ratio rational) - (float real) - (complex number) - (symbol) - (null symbol list) - (keyword symbol) - (package) - (function) - (pathname) - (logical-pathname pathname) - (hash-table) - (random-state) - (readtable) - (si::code-block) - (si::foreign-data) - (si::frame) - (si::weak-pointer) - #+threads (mp::process) - #+threads (mp::lock) - #+threads (mp::rwlock) - #+threads (mp::condition-variable) - #+threads (mp::semaphore) - #+threads (mp::barrier) - #+threads (mp::mailbox) - #+sse2 (ext::sse-pack)))) - -(defconstant +builtin-classes-pre-array+ (make-array (1+ #.(length +builtin-classes-list+)))) - -;;; FROM AMOP: -;;; -;;; Metaobject Class Direct Superclasses -;;; standard-object (t) -;;; funcallable-standard-object (standard-object function) -;;; * metaobject (standard-object) -;;; * generic-function (metaobject funcallable-standard-object) -;;; standard-generic-function (generic-function) -;;; * method (metaobject) -;;; standard-method (method) -;;; * standard-accessor-method (standard-method) -;;; standard-reader-method (standard-accessor-method) -;;; standard-writer-method (standard-accessor-method) -;;; * method-combination (metaobject) -;;; * slot-definition (metaobject) -;;; * direct-slot-definition (slot-definition) -;;; * effective-slot-definition (slot-definition) -;;; * standard-slot-definition (slot-definition) -;;; standard-direct-slot-definition (standard-slot-definition direct-slot-definition) -;;; standard-effective-slot-definition (standard-slot-definition effective-slot-definition) -;;; * specializer (metaobject) -;;; eql-specializer (specializer) -;;; * class (specializer) -;;; built-in-class (class) -;;; forward-referenced-class (class) -;;; standard-class (class) -;;; funcallable-standard-class (class) -;;; -(eval-when (eval) - (defconstant +class-hierarchy+ - `((standard-class - :metaclass nil) ; Special-cased below - (t - :index 0) - (standard-object - :direct-superclasses (t)) - (metaobject - :direct-superclasses (standard-object)) - (method-combination - :direct-superclasses (metaobject) - :direct-slots #.+method-combination-slots+) - (specializer - :direct-superclasses (metaobject) - :direct-slots #.+specializer-slots+) - (eql-specializer - :direct-superclasses (specializer) - :direct-slots #.+eql-specializer-slots+) - (class - :direct-superclasses (specializer) - :direct-slots #.+class-slots+) - (forward-referenced-class - :direct-superclasses (class) - :direct-slots #.+class-slots+) - (built-in-class - :direct-superclasses (class) - :direct-slots #1=#.+standard-class-slots+) - (std-class - :direct-superclasses (class) - :direct-slots #1#) - (standard-class - :direct-superclasses (std-class) - :direct-slots #1# - :metaclass standard-class) - (funcallable-standard-class - :direct-superclasses (std-class) - :direct-slots #1#) - ,@(loop for (name . rest) in +builtin-classes-list+ - for index from 1 - collect (list name :metaclass 'built-in-class - :index index - :direct-superclasses (or rest '(t)))) - (funcallable-standard-object - :direct-superclasses (standard-object function)) - (generic-function - :metaclass funcallable-standard-class - :direct-superclasses (metaobject funcallable-standard-object)) - (standard-generic-function - :direct-superclasses (generic-function) - :direct-slots #.+standard-generic-function-slots+ - :metaclass funcallable-standard-class) - (method - :direct-superclasses (metaobject)) - (standard-method - :direct-superclasses (method) - :direct-slots #.+standard-method-slots+) - (standard-accessor-method - :direct-superclasses (standard-method) - :direct-slots #2=#.+standard-accessor-method-slots+) - (standard-reader-method - :direct-superclasses (standard-accessor-method) - :direct-slots #2#) - (standard-writer-method - :direct-superclasses (standard-accessor-method) - :direct-slots #2#) - ))) +(defconstant +builtin-classes-pre-array+ + (make-array (1+ #.(length +builtin-classes-list+)))) ;;; ---------------------------------------------------------------------- ;;; Early accessors and class construction ;;; - +;;; +;;; The following macro is also used at bootstap for instantiating +;;; a class based only on the s-form description. +;;; (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) diff --git a/src/clos/hierarchy.lsp b/src/clos/hierarchy.lsp new file mode 100644 index 000000000..53a44985c --- /dev/null +++ b/src/clos/hierarchy.lsp @@ -0,0 +1,293 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- +;;;; +;;;; Copyright (c) 1992, Giuseppe Attardi.o +;;;; 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. + +;;; +;;; COMMON LISP CLASSES HIERARCHY +;;; +;;; The following set of constants describe the slots, the names of +;;; the classes and their relation, including both standard Commmon Lisp +;;; and the MetaObject Protocol. This information is only loaded when +;;; bootstrapping and compiling ECL. +;;; + +(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)))) + +(eval-when (:compile-toplevel :execute) + (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)))) + +;;; ---------------------------------------------------------------------- +;;; 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)))) + +;;; ---------------------------------------------------------------------- +;;; 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 :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))) + +;;; ---------------------------------------------------------------------- +;;; STANDARD-CLASS + +(eval-when (:compile-toplevel :execute) + (defparameter +standard-class-slots+ + (append +class-slots+ + '((slot-table :accessor slot-table) + (optimize-slot-access) + (forward))))) + +;;; ---------------------------------------------------------------------- +;;; STANDARD-GENERIC-FUNCTION + +(eval-when (:compile-toplevel :execute) + (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)))) + +;;; ---------------------------------------------------------------------- +;;; STANDARD-METHOD + +(eval-when (:compile-toplevel :execute) + (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))) + + (defparameter +standard-accessor-method-slots+ + (append +standard-method-slots+ + '((slot-definition :initarg :slot-definition + :initform nil + ;; FIXME! Should be a :reader + :accessor accessor-method-slot-definition))))) + +;;; ---------------------------------------------------------------------- +(eval-when (:compile-toplevel :execute) + ;; + ;; All changes to this are connected to the changes in + ;; the code of cl_class_of() in src/instance.d + ;; + (defconstant +builtin-classes-list+ + '(;(t object) + (sequence) + (list sequence) + (cons list) + (array) + (vector array sequence) + (string vector) + #+unicode + (base-string string vector) + (bit-vector vector) + (stream) + (ext:ansi-stream stream) + (file-stream ext:ansi-stream) + (echo-stream ext:ansi-stream) + (string-stream ext:ansi-stream) + (two-way-stream ext:ansi-stream) + (synonym-stream ext:ansi-stream) + (broadcast-stream ext:ansi-stream) + (concatenated-stream ext:ansi-stream) + (ext:sequence-stream ext:ansi-stream) + (character) + (number) + (real number) + (rational real) + (integer rational) + (ratio rational) + (float real) + (complex number) + (symbol) + (null symbol list) + (keyword symbol) + (package) + (function) + (pathname) + (logical-pathname pathname) + (hash-table) + (random-state) + (readtable) + (si::code-block) + (si::foreign-data) + (si::frame) + (si::weak-pointer) + #+threads (mp::process) + #+threads (mp::lock) + #+threads (mp::rwlock) + #+threads (mp::condition-variable) + #+threads (mp::semaphore) + #+threads (mp::barrier) + #+threads (mp::mailbox) + #+sse2 (ext::sse-pack)))) + +;;; FROM AMOP: +;;; +;;; Metaobject Class Direct Superclasses +;;; standard-object (t) +;;; funcallable-standard-object (standard-object function) +;;; * metaobject (standard-object) +;;; * generic-function (metaobject funcallable-standard-object) +;;; standard-generic-function (generic-function) +;;; * method (metaobject) +;;; standard-method (method) +;;; * standard-accessor-method (standard-method) +;;; standard-reader-method (standard-accessor-method) +;;; standard-writer-method (standard-accessor-method) +;;; * method-combination (metaobject) +;;; * slot-definition (metaobject) +;;; * direct-slot-definition (slot-definition) +;;; * effective-slot-definition (slot-definition) +;;; * standard-slot-definition (slot-definition) +;;; standard-direct-slot-definition (standard-slot-definition direct-slot-definition) +;;; standard-effective-slot-definition (standard-slot-definition effective-slot-definition) +;;; * specializer (metaobject) +;;; eql-specializer (specializer) +;;; * class (specializer) +;;; built-in-class (class) +;;; forward-referenced-class (class) +;;; standard-class (class) +;;; funcallable-standard-class (class) +;;; +(eval-when (eval) + (defconstant +class-hierarchy+ + `((standard-class + :metaclass nil) ; Special-cased below + (t + :index 0) + (standard-object + :direct-superclasses (t)) + (metaobject + :direct-superclasses (standard-object)) + (method-combination + :direct-superclasses (metaobject) + :direct-slots #.+method-combination-slots+) + (specializer + :direct-superclasses (metaobject) + :direct-slots #.+specializer-slots+) + (eql-specializer + :direct-superclasses (specializer) + :direct-slots #.+eql-specializer-slots+) + (class + :direct-superclasses (specializer) + :direct-slots #.+class-slots+) + (forward-referenced-class + :direct-superclasses (class) + :direct-slots #.+class-slots+) + (built-in-class + :direct-superclasses (class) + :direct-slots #1=#.+standard-class-slots+) + (std-class + :direct-superclasses (class) + :direct-slots #1#) + (standard-class + :direct-superclasses (std-class) + :direct-slots #1# + :metaclass standard-class) + (funcallable-standard-class + :direct-superclasses (std-class) + :direct-slots #1#) + ,@(loop for (name . rest) in +builtin-classes-list+ + for index from 1 + collect (list name :metaclass 'built-in-class + :index index + :direct-superclasses (or rest '(t)))) + (funcallable-standard-object + :direct-superclasses (standard-object function)) + (generic-function + :metaclass funcallable-standard-class + :direct-superclasses (metaobject funcallable-standard-object)) + (standard-generic-function + :direct-superclasses (generic-function) + :direct-slots #.+standard-generic-function-slots+ + :metaclass funcallable-standard-class) + (method + :direct-superclasses (metaobject)) + (standard-method + :direct-superclasses (method) + :direct-slots #.+standard-method-slots+) + (standard-accessor-method + :direct-superclasses (standard-method) + :direct-slots #2=#.+standard-accessor-method-slots+) + (standard-reader-method + :direct-superclasses (standard-accessor-method) + :direct-slots #2#) + (standard-writer-method + :direct-superclasses (standard-accessor-method) + :direct-slots #2#) + ))) + diff --git a/src/clos/load.lsp.in b/src/clos/load.lsp.in index 651287ed2..2cbc30627 100644 --- a/src/clos/load.lsp.in +++ b/src/clos/load.lsp.in @@ -4,9 +4,9 @@ '("src:clos;package.lsp" "src:clos;slot.lsp" "src:clos;cpl.lsp" + "src:clos;std-slot-value.lsp" "src:clos;boot.lsp" "src:clos;kernel.lsp" - "src:clos;macros.lsp" "src:clos;method.lsp" "src:clos;combin.lsp" "src:clos;defclass.lsp" diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 4c9da4aa2..9d1cb3d27 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -421,25 +421,6 @@ have disappeared." qualifiers specializers))) nil) - -;;; ---------------------------------------------------------------------- -;;; with-slots - -(defmacro with-slots (slot-entries instance-form &body body) - (let* ((temp (gensym)) - (accessors - (do ((scan slot-entries (cdr scan)) - (res)) - ((null scan) (nreverse res)) - (if (symbolp (first scan)) - (push `(,(first scan) (slot-value ,temp ',(first scan))) res) - (push `(,(caar scan) - (slot-value ,temp ',(cadar scan))) res))))) - `(let ((,temp ,instance-form)) - (symbol-macrolet ,accessors ,@body)))) - -;(with-slots (x (y2 y)) inst (setq x y2)) - ;;; ---------------------------------------------------------------------- ;;; with-accessors diff --git a/src/clos/slotvalue.lsp b/src/clos/slotvalue.lsp index 9511fb6f1..293476de8 100644 --- a/src/clos/slotvalue.lsp +++ b/src/clos/slotvalue.lsp @@ -17,65 +17,6 @@ (setf (slot-value class 'prototype) (allocate-instance class))) (slot-value class 'prototype)) -;;; ---------------------------------------------------------------------- -;;; SLOTS READING AND WRITING -;;; -;;; -;;; 1) Functional interface -;;; - -(defun find-slot-definition (class slot-name) - (declare (si::c-local)) - (if (or (eq (si:instance-class class) +the-standard-class+) - (eq (si:instance-class class) +the-funcallable-standard-class+)) - (gethash slot-name (slot-table class) nil) - (find slot-name (class-slots class) :key #'slot-definition-name))) - -(defun slot-value (self slot-name) - (let* ((class (class-of self))) - (if (or (eq (si:instance-class class) +the-standard-class+) - (eq (si:instance-class class) +the-funcallable-standard-class+)) - (with-early-accessors (+standard-class-slots+) - (let ((slotd (gethash slot-name (slot-table class) nil))) - (if slotd - (let ((value (standard-instance-get self slotd))) - (if (sl:sl-boundp value) - value - (values (slot-unbound class self (slot-definition-name slotd))))) - (slot-missing class self slot-name 'SLOT-VALUE)))) - (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) - (if slotd - (slot-value-using-class class self slotd) - (values (slot-missing class self slot-name 'SLOT-VALUE))))))) - -(defun slot-boundp (self slot-name) - (let* ((class (class-of self))) - (if (or (eq (si:instance-class class) +the-standard-class+) - (eq (si:instance-class class) +the-funcallable-standard-class+)) - (with-early-accessors (+standard-class-slots+) - (let ((slotd (gethash slot-name (slot-table class) nil))) - (if slotd - (si::sl-boundp (standard-instance-get self slotd)) - (values (slot-missing class self slot-name 'SLOT-BOUNDP))))) - (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) - (if slotd - (slot-boundp-using-class class self slotd) - (values (slot-missing class self slot-name 'SLOT-BOUNDP))))))) - -(defun (setf slot-value) (value self slot-name) - (let* ((class (class-of self))) - (if (or (eq (si:instance-class class) +the-standard-class+) - (eq (si:instance-class class) +the-funcallable-standard-class+)) - (with-early-accessors (+standard-class-slots+) - (let ((slotd (gethash slot-name (slot-table class) nil))) - (if slotd - (standard-instance-set value self slotd) - (slot-missing class self slot-name 'SETF value)))) - (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) - (if slotd - (setf (slot-value-using-class class self slotd) value) - (slot-missing class self slot-name 'SETF value)))))) - (defun slot-makunbound (self slot-name) (let* ((class (class-of self)) (slotd (find-slot-definition class slot-name))) @@ -84,62 +25,16 @@ (slot-missing class self slot-name 'SLOT-MAKUNBOUND)) self)) -(defun slot-exists-p (self slot-name) - (and (find-slot-definition (class-of self) slot-name) - t)) - -;;; -;;; 2) Overloadable methods on which the previous functions are based -;;; - -(defun standard-instance-get (instance slotd) - (with-early-accessors (+standard-class-slots+) - (ensure-up-to-date-instance instance) - (let* ((class (si:instance-class instance)) - (location (slot-definition-location slotd))) - (cond ((ext:fixnump location) - ;; local slot - (si:instance-ref instance (truly-the fixnum location))) - ((consp location) - ;; shared slot - (car location)) - (t - (invalid-slot-definition instance slotd)))))) - -(defun standard-instance-set (val instance slotd) - (with-early-accessors (+standard-class-slots+) - (ensure-up-to-date-instance instance) - (let* ((class (si:instance-class instance)) - (location (slot-definition-location slotd))) - (cond ((ext:fixnump location) - ;; local slot - (si:instance-set instance (truly-the fixnum location) val)) - ((consp location) - ;; shared slot - (setf (car location) val)) - (t - (invalid-slot-definition instance slotd)))) - val)) - -(defun invalid-slot-definition (instance slotd) - (error "Effective slot definition lacks a valid location. -Class name: ~A -Slot name: ~A" - (type-of instance) (slot-definition-name slotd))) - (defmethod slot-value-using-class ((class class) self slotd) - (let ((value (standard-instance-get self slotd))) - (if (si:sl-boundp value) - value - (values (slot-unbound class self (slot-definition-name slotd)))))) + (slot-value self (slot-definition-name slotd))) (defmethod slot-boundp-using-class ((class class) self slotd) (declare (ignore class)) - (si::sl-boundp (standard-instance-get self slotd))) + (slot-boundp self (slot-definition-name slotd))) (defmethod (setf slot-value-using-class) (val (class class) self slotd) (declare (ignore class)) - (standard-instance-set val self slotd)) + (setf (slot-value self (slot-definition-name slotd)) val)) (defmethod slot-makunbound-using-class ((class class) instance slotd) (declare (ignore class)) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 6d290c702..841a0bd6e 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -355,13 +355,6 @@ because it contains a reference to the undefined class~% ~A" (finalize-unless-forward subclass)) ) -(defun std-create-slots-table (class) - (let* ((all-slots (class-slots class)) - (table (make-hash-table :size (max 32 (length all-slots))))) - (dolist (slotd (class-slots class)) - (setf (gethash (slot-definition-name slotd) table) slotd)) - (setf (slot-table class) table))) - (defmethod finalize-inheritance ((class std-class)) (call-next-method) (std-create-slots-table class) @@ -370,6 +363,10 @@ because it contains a reference to the undefined class~% ~A" (defmethod compute-class-precedence-list ((class class)) (compute-clos-class-precedence-list class (class-direct-superclasses class))) +(eval-when (:compile-toplevel :execute) + (defmacro mapappend (fun &rest args) + `(reduce #'append (mapcar ,fun ,@args)))) + (defmethod compute-slots ((class class)) ;; INV: for some classes ECL expects that the order of the inherited slots is ;; preserved. The following code ensures that, if C1 is after C2 in the diff --git a/src/clos/std-slot-value.lsp b/src/clos/std-slot-value.lsp new file mode 100644 index 000000000..f1b9551d2 --- /dev/null +++ b/src/clos/std-slot-value.lsp @@ -0,0 +1,202 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*- +;;;; +;;;; Copyright (c) 1992, Giuseppe Attardi.o +;;;; 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") + +(eval-when (:compile-toplevel :execute) + (load "src:clos;hierarchy.lsp")) + +;;; ---------------------------------------------------------------------- +;;; SLOTS READING AND WRITING +;;; +;;; Functional and macro interface for accessing the slots of an instance. +;;; This interface is defined with specialization for classes that ECL +;;; knows of such as standard classes and funcallable standard class. +;;; This is needed to avoid circularity in compute-applicable-methods, +;;; which needs the slot values and thus cannot go through a dispatch +;;; itself. +;;; +;;; Note that using SLOT-VALUE or specialized versions of it is not +;;; wrong because the MOP enforces various restrictions on portable +;;; code: +;;; 1) Accessors must behave as SLOT-VALUE +;;; 2) In particular, any method defined by the user must be +;;; specialized on at least one non-specified class. This means +;;; that the user cannot change the behavoir of SLOT-VALUE for +;;; standard classes. +;;; +;;; First of all we define WITH-SLOTS because it is going to be useful +;;; for enforcing the use of SLOT-VALUE and not of accessors +;;; throughout the bootstrap code. +;;; +(defmacro with-slots (slot-entries instance-form &body body) + (let* ((temp (gensym)) + (accessors + (do ((scan slot-entries (cdr scan)) + (res)) + ((null scan) (nreverse res)) + (if (symbolp (first scan)) + (push `(,(first scan) (slot-value ,temp ',(first scan))) res) + (push `(,(caar scan) + (slot-value ,temp ',(cadar scan))) res))))) + `(let ((,temp ,instance-form)) + (symbol-macrolet ,accessors ,@body)))) + +;;; +;;; The following macro is a convenience that can be used to directly +;;; access the slots of a class based on their s-form description. It +;;; is used internally by ECL during bootstrap. Unlike WITH-SLOTS, +;;; the macros directly access the slots by index. +;;; +(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))) + +;;; +;;; ECL classes store slots in a hash table for faster access. The +;;; following functions create the cache and allow us to locate the +;;; slots rapidly. +;;; +(defun std-create-slots-table (class) + (with-slots ((all-slots slots) (slot-table slot-table)) + class + (let* ((table (make-hash-table :size (max 32 (length all-slots))))) + (dolist (slotd all-slots) + (setf (gethash (slot-definition-name slotd) table) slotd)) + (setf slot-table table)))) + +(defun find-slot-definition (class slot-name) + (if (or (eq (si:instance-class class) +the-standard-class+) + (eq (si:instance-class class) +the-funcallable-standard-class+)) + (gethash slot-name (slot-table class) nil) + (find slot-name (class-slots class) :key #'slot-definition-name))) + +;;; +;;; INSTANCE UPDATE PREVIOUS +;;; +(eval-when (:compile-toplevel :execute) + (defmacro ensure-up-to-date-instance (instance) + ;; The up-to-date status of a class is determined by + ;; instance.sig. This slot of the C structure contains a list of + ;; slot definitions that was used to create the instance. When the + ;; class is updated, the list is newly created. Structures are also + ;; "instances" but keep ECL_UNBOUND instead of the list. + `(let* ((i ,instance) + (s (si::instance-sig i))) + (declare (:read-only i s)) + (when (si:sl-boundp s) + (unless (eq s (class-slots (si::instance-class i))) + (update-instance i)))))) + +;;; +;;; STANDARD-CLASS INTERFACE +;;; +;;; Specific functions for slot reading, writing, boundness checking, etc. +;;; + +(defun standard-instance-get (instance slotd) + (with-early-accessors (+standard-class-slots+) + (ensure-up-to-date-instance instance) + (let* ((class (si:instance-class instance)) + (location (slot-definition-location slotd))) + (cond ((ext:fixnump location) + ;; local slot + (si:instance-ref instance (truly-the fixnum location))) + ((consp location) + ;; shared slot + (car location)) + (t + (invalid-slot-definition instance slotd)))))) + +(defun standard-instance-set (val instance slotd) + (with-early-accessors (+standard-class-slots+) + (ensure-up-to-date-instance instance) + (let* ((class (si:instance-class instance)) + (location (slot-definition-location slotd))) + (cond ((ext:fixnump location) + ;; local slot + (si:instance-set instance (truly-the fixnum location) val)) + ((consp location) + ;; shared slot + (setf (car location) val)) + (t + (invalid-slot-definition instance slotd)))) + val)) + +(defun slot-value (self slot-name) + (let* ((class (class-of self))) + (if (or (eq (si:instance-class class) +the-standard-class+) + (eq (si:instance-class class) +the-funcallable-standard-class+)) + (with-early-accessors (+standard-class-slots+) + (let ((slotd (gethash slot-name (slot-table class) nil))) + (if slotd + (let ((value (standard-instance-get self slotd))) + (if (si:sl-boundp value) + value + (values (slot-unbound class self (slot-definition-name slotd))))) + (slot-missing class self slot-name 'SLOT-VALUE)))) + (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) + (if slotd + (slot-value-using-class class self slotd) + (values (slot-missing class self slot-name 'SLOT-VALUE))))))) + +(defun slot-exists-p (self slot-name) + (and (find-slot-definition (class-of self) slot-name) + t)) + +(defun slot-boundp (self slot-name) + (let* ((class (class-of self))) + (if (or (eq (si:instance-class class) +the-standard-class+) + (eq (si:instance-class class) +the-funcallable-standard-class+)) + (with-early-accessors (+standard-class-slots+) + (let ((slotd (gethash slot-name (slot-table class) nil))) + (if slotd + (si::sl-boundp (standard-instance-get self slotd)) + (values (slot-missing class self slot-name 'SLOT-BOUNDP))))) + (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) + (if slotd + (slot-boundp-using-class class self slotd) + (values (slot-missing class self slot-name 'SLOT-BOUNDP))))))) + +(defun (setf slot-value) (value self slot-name) + (let* ((class (class-of self))) + (if (or (eq (si:instance-class class) +the-standard-class+) + (eq (si:instance-class class) +the-funcallable-standard-class+)) + (with-early-accessors (+standard-class-slots+) + (let ((slotd (gethash slot-name (slot-table class) nil))) + (if slotd + (standard-instance-set value self slotd) + (slot-missing class self slot-name 'SETF value)))) + (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) + (if slotd + (setf (slot-value-using-class class self slotd) value) + (slot-missing class self slot-name 'SETF value)))))) + +;;; +;;; 2) Overloadable methods on which the previous functions are based +;;; + +(defun invalid-slot-definition (instance slotd) + (declare (si::c-local)) + (error "Effective slot definition lacks a valid location. +Class name: ~A +Slot name: ~A" + (type-of instance) (slot-definition-name slotd)))