mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-17 06:42:18 -08:00
Reorganize the code so that SLOT-VALUE is available at boot time.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
3fc09351ea
commit
88db3f8dbf
7 changed files with 509 additions and 416 deletions
|
|
@ -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)
|
||||
|
|
|
|||
293
src/clos/hierarchy.lsp
Normal file
293
src/clos/hierarchy.lsp
Normal file
|
|
@ -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#)
|
||||
)))
|
||||
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
202
src/clos/std-slot-value.lsp
Normal file
202
src/clos/std-slot-value.lsp
Normal file
|
|
@ -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)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue