71 |
(defmacro parse-gspec (spec |
(defmacro parse-gspec (spec |
72 |
(non-setf-var . non-setf-case) |
(non-setf-var . non-setf-case) |
73 |
(setf-var . setf-case)) |
(setf-var . setf-case)) |
74 |
(declare (indentation 1 1)) |
; (declare (indentation 1 1)) |
75 |
#+setf (declare (ignore setf-var setf-case)) |
#+setf (declare (ignore setf-var setf-case)) |
76 |
(once-only (spec) |
(once-only (spec) |
77 |
`(cond (#-setf (symbolp ,spec) #+setf t |
`(cond (#-setf (symbolp ,spec) #+setf t |
370 |
type)))) |
type)))) |
371 |
|
|
372 |
;;; not used... |
;;; not used... |
373 |
#+nil |
;#+nil |
374 |
(defun *typep (object type) |
(defun *typep (object type) |
375 |
(setq type (*normalize-type type)) |
(setq type (*normalize-type type)) |
376 |
(cond ((member (car type) '(eql wrapper-eq class-eq class)) |
(cond ((member (car type) '(eql wrapper-eq class-eq class)) |
434 |
;; better. Note that for most ports, providing this definition |
;; better. Note that for most ports, providing this definition |
435 |
;; should just speed up class definition. It shouldn't have an |
;; should just speed up class definition. It shouldn't have an |
436 |
;; effect on performance of most user code. |
;; effect on performance of most user code. |
437 |
(eval `(deftype ,name () '(satisfies ,predicate)))) |
(progn ;(break "foo ~a ~a~%" name predicate) |
438 |
|
(eval `(deftype ,name () '(satisfies ,predicate))))) |
439 |
|
|
440 |
(defun make-type-predicate-name (name &optional kind) |
(defun make-type-predicate-name (name &optional kind) |
441 |
(if (symbol-package name) |
(if (symbol-package name) |
625 |
(defclass kernel:funcallable-instance (function) () |
(defclass kernel:funcallable-instance (function) () |
626 |
(:metaclass built-in-class))) |
(:metaclass built-in-class))) |
627 |
|
|
628 |
|
;(defclass function (t) () |
629 |
|
; (:metaclass built-in-class)) |
630 |
|
|
631 |
|
;(defclass stream (si::instance) () |
632 |
|
; (:metaclass built-in-class)) |
633 |
|
|
634 |
|
|
635 |
(defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) () |
(defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) () |
636 |
(:metaclass slot-class)) |
(:metaclass slot-class)) |
637 |
|
|
638 |
(defclass structure-object (slot-object) () |
;(defclass si::instance (slot-object) ()) |
639 |
|
|
640 |
|
;(defclass si::funcallable-instance (slot-object) ()) |
641 |
|
|
642 |
|
(defclass structure-object (slot-object ;si::instance |
643 |
|
) () |
644 |
(:metaclass structure-class)) |
(:metaclass structure-class)) |
645 |
|
|
646 |
(defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object |
(defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object |
651 |
|
|
652 |
(defclass metaobject (standard-object) ()) |
(defclass metaobject (standard-object) ()) |
653 |
|
|
654 |
(defclass specializer (metaobject) |
(defclass funcallable-standard-object (standard-object) |
655 |
|
; si::funcallable-instance) |
656 |
|
() |
657 |
|
(:metaclass funcallable-standard-class)) |
658 |
|
|
659 |
|
(defclass specializer (metaobject); si::instance) |
660 |
((type |
((type |
661 |
:initform nil |
:initform nil |
662 |
:reader specializer-type))) |
:reader specializer-type))) |
684 |
;;; have the class CLASS in its class precedence list. |
;;; have the class CLASS in its class precedence list. |
685 |
;;; |
;;; |
686 |
(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin |
(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin |
687 |
specializer) |
specializer );si::instance) |
688 |
((name |
((name |
689 |
:initform nil |
:initform nil |
690 |
:initarg :name |
:initarg :name |
789 |
;;; |
;;; |
790 |
;;; Slot definitions. |
;;; Slot definitions. |
791 |
;;; |
;;; |
792 |
(defclass slot-definition (metaobject) |
(defclass slot-definition (metaobject );si::instance) |
793 |
((name |
((name |
794 |
:initform nil |
:initform nil |
795 |
:initarg :name |
:initarg :name |
877 |
effective-slot-definition) |
effective-slot-definition) |
878 |
()) |
()) |
879 |
|
|
880 |
(defclass method (metaobject) ()) |
(defclass method (metaobject );si::instance) |
881 |
|
()) |
882 |
|
|
883 |
(defclass standard-method (definition-source-mixin plist-mixin method) |
(defclass standard-method (definition-source-mixin plist-mixin method) |
884 |
((generic-function |
((generic-function |
927 |
definition-source-mixin |
definition-source-mixin |
928 |
documentation-mixin |
documentation-mixin |
929 |
metaobject |
metaobject |
930 |
#+cmu17 kernel:funcallable-instance) |
funcallable-standard-object) |
931 |
() |
() |
932 |
(:metaclass funcallable-standard-class)) |
(:metaclass funcallable-standard-class)) |
933 |
|
|
959 |
(:default-initargs :method-class *the-class-standard-method* |
(:default-initargs :method-class *the-class-standard-method* |
960 |
:method-combination *standard-method-combination*)) |
:method-combination *standard-method-combination*)) |
961 |
|
|
962 |
(defclass method-combination (metaobject) ()) |
(defclass method-combination (metaobject); si::instance) |
963 |
|
()) |
964 |
|
|
965 |
(defclass standard-method-combination |
(defclass standard-method-combination |
966 |
(definition-source-mixin method-combination) |
(definition-source-mixin method-combination) |
1001 |
(method-combination method-combination-p) |
(method-combination method-combination-p) |
1002 |
(long-method-combination long-method-combination-p))) |
(long-method-combination long-method-combination-p))) |
1003 |
|
|
1004 |
|
|
1005 |
|
(defun early-find-class-symbol (x &optional errorp environment) |
1006 |
|
(declare (ignore errorp environment)) |
1007 |
|
(when (or (member x *early-class-definitions* :key 'cadr) |
1008 |
|
(gethash x *find-class*)) |
1009 |
|
x)) |
1010 |
|
|
1011 |
|
(defun mk-early-cpl (sym) |
1012 |
|
(let ((l (nth 4 (car (member sym *early-class-definitions* :key 'cadr))))) |
1013 |
|
(append l (reduce (lambda (&rest r) (when r (apply 'union r))) (mapcar 'mk-early-cpl l))))) |
1014 |
|
|
1015 |
|
(defun early-class-precedence-list-symbol (x &aux tem) |
1016 |
|
(cond ((mk-early-cpl x)) |
1017 |
|
((setq tem (gethash x *find-class*)) |
1018 |
|
(early-class-precedence-list (car tem))))) |
1019 |
|
|
1020 |
|
(setf (symbol-function 'si::find-class) (symbol-function 'early-find-class-symbol)) |
1021 |
|
(setf (symbol-function 'si::class-precedence-list) (symbol-function 'early-class-precedence-list-symbol)) |