X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=7b00490d74307bf0f376009ab743f4c618af6f59;hb=62f25b3b18b66ae67d555ca8a05026dbf03d89e1;hp=4b587fcd66f78d0762598b62b1cfbf0ba9a3b20d;hpb=5a31671c1093aa155a7832277ebd46766eb7c6e4;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 4b587fc..7b00490 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -52,28 +52,38 @@ :initial-element +slot-unbound+)))) instance)) -(defmacro allocate-funcallable-instance-slots (wrapper &optional - slots-init-p slots-init) +(defmacro allocate-standard-funcallable-instance-slots + (wrapper &optional slots-init-p slots-init) `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper))) - ,(if slots-init-p - `(if ,slots-init-p - (make-array no-of-slots :initial-contents ,slots-init) - (make-array no-of-slots :initial-element +slot-unbound+)) - `(make-array no-of-slots :initial-element +slot-unbound+)))) - -(defun allocate-funcallable-instance (wrapper &optional - (slots-init nil slots-init-p)) - (let ((fin (%make-pcl-funcallable-instance nil nil - (get-instance-hash-code)))) + ,(if slots-init-p + `(if ,slots-init-p + (make-array no-of-slots :initial-contents ,slots-init) + (make-array no-of-slots :initial-element +slot-unbound+)) + `(make-array no-of-slots :initial-element +slot-unbound+)))) + +(define-condition unset-funcallable-instance-function + (reference-condition simple-error) + () + (:default-initargs + :references (list '(:amop :generic-function allocate-instance) + '(:amop :function set-funcallable-instance-function)))) + +(defun allocate-standard-funcallable-instance + (wrapper &optional (slots-init nil slots-init-p)) + (let ((fin (%make-standard-funcallable-instance + nil nil (get-instance-hash-code)))) (set-funcallable-instance-function fin #'(lambda (&rest args) (declare (ignore args)) - (error "The function of the funcallable-instance ~S has not been set." - fin))) + (error 'unset-funcallable-instance-function + :format-control "~@" + :format-arguments (list fin)))) (setf (fsc-instance-wrapper fin) wrapper - (fsc-instance-slots fin) (allocate-funcallable-instance-slots - wrapper slots-init-p slots-init)) + (fsc-instance-slots fin) + (allocate-standard-funcallable-instance-slots + wrapper slots-init-p slots-init)) fin)) (defun allocate-structure-instance (wrapper &optional @@ -197,7 +207,7 @@ ())) (setq proto (if (eq meta 'funcallable-standard-class) - (allocate-funcallable-instance wrapper) + (allocate-standard-funcallable-instance wrapper) (allocate-standard-instance wrapper))) (setq direct-slots @@ -266,6 +276,7 @@ (set-slot 'name name) (set-slot 'finalized-p t) (set-slot 'source source) + (set-slot 'safe-p nil) (set-slot '%type (if (eq class (find-class t)) t ;; FIXME: Could this just be CLASS instead @@ -359,6 +370,7 @@ (set-val 'writers (get-val :writers)) (set-val 'allocation :instance) (set-val '%type (or (get-val :type) t)) + (set-val '%type-check-function (get-val 'type-check-function)) (set-val '%documentation (or (get-val :documentation) "")) (set-val '%class class) (when effective-p @@ -415,8 +427,7 @@ (list class-name) (list class-name) "automatically generated boundp method"))) - (let ((gf (ensure-generic-function accessor-name - :lambda-list arglist))) + (let ((gf (ensure-generic-function accessor-name :lambda-list arglist))) (if (find specls (early-gf-methods gf) :key #'early-method-specializers :test 'equal) @@ -430,7 +441,9 @@ (funcall make-method-function class-name slot-name) doc - slot-name)))))) + :slot-name slot-name + :object-class class-name + :method-class-function (constantly (find-class accessor-class)))))))) (defun !bootstrap-accessor-definitions1 (class-name slot-name @@ -503,16 +516,12 @@ (cons name cpl) wrapper prototype)))))) -(defmacro wrapper-of-macro (x) - `(layout-of ,x)) - -(defun class-of (x) - (wrapper-class* (wrapper-of-macro x))) - -;;; FIXME: We probably don't need both WRAPPER-OF and WRAPPER-OF-MACRO. #-sb-fluid (declaim (inline wrapper-of)) (defun wrapper-of (x) - (wrapper-of-macro x)) + (layout-of x)) + +(defun class-of (x) + (wrapper-class* (wrapper-of x))) (defun eval-form (form) (lambda () (eval form))) @@ -577,6 +586,7 @@ (pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*) (pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*) +;;; FIXME: only needed during bootstrap (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name :lambda-list '(object))) (mlist (if (eq *boot-state* 'complete) @@ -585,8 +595,8 @@ (unless mlist (unless (eq class *the-class-t*) (let* ((default-method-function #'constantly-nil) - (default-method-initargs (list :function - default-method-function)) + (default-method-initargs (list :function default-method-function + 'plist '(:constant-value nil))) (default-method (make-a-method 'standard-method () @@ -594,57 +604,59 @@ (list *the-class-t*) default-method-initargs "class predicate default method"))) - (setf (method-function-get default-method-function :constant-value) - nil) (add-method gf default-method))) (let* ((class-method-function #'constantly-t) - (class-method-initargs (list :function - class-method-function)) + (class-method-initargs (list :function class-method-function + 'plist '(:constant-value t))) (class-method (make-a-method 'standard-method () (list 'object) (list class) class-method-initargs "class predicate class method"))) - (setf (method-function-get class-method-function :constant-value) t) (add-method gf class-method))) gf)) ;;; Set the inherits from CPL, and register the layout. This actually ;;; installs the class in the Lisp type system. (defun update-lisp-class-layout (class layout) - (let ((lclass (layout-classoid layout))) - (unless (eq (classoid-layout lclass) layout) + (let ((classoid (layout-classoid layout)) + (olayout (class-wrapper class))) + (unless (eq (classoid-layout classoid) layout) (setf (layout-inherits layout) - (order-layout-inherits - (map 'simple-vector #'class-wrapper - (reverse (rest (class-precedence-list class)))))) + (order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest (class-precedence-list class)))))) (register-layout layout :invalidate t) - ;; Subclasses of formerly forward-referenced-class may be - ;; unknown to CL:FIND-CLASS and also anonymous. This - ;; functionality moved here from (SETF FIND-CLASS). + ;; FIXME: I don't think this should be necessary, but without it + ;; we are unable to compile (TYPEP foo ') in the + ;; same file as the class is defined. If we had environments, + ;; then I think the classsoid whould only be associated with the + ;; name in that environment... Alternatively, fix the compiler + ;; so that TYPEP foo ' is slow but compileable. (let ((name (class-name class))) - (setf (find-classoid name) lclass - (classoid-name lclass) name))))) - -(defun set-class-type-translation (class name) - (let ((classoid (find-classoid name nil))) - (etypecase classoid - (null) - (built-in-classoid - (let ((translation (built-in-classoid-translation classoid))) - (cond - (translation - (aver (ctype-p translation)) - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) translation))) - (t - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid)))))) - (classoid - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid)))))) + (when (and name (symbolp name) (eq name (classoid-name classoid))) + (setf (find-classoid name) classoid)))))) + +(defun set-class-type-translation (class classoid) + (when (not (typep classoid 'classoid)) + (setq classoid (find-classoid classoid nil))) + (etypecase classoid + (null) + (built-in-classoid + (let ((translation (built-in-classoid-translation classoid))) + (cond + (translation + (aver (ctype-p translation)) + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) translation))) + (t + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) classoid)))))) + (classoid + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) classoid))))) (clrhash *find-class*) (!bootstrap-meta-braid)