(in-package "SB!C")
\f
-;;;; COMPILE and UNCOMPILE
+;;;; CL:COMPILE
(defun get-lambda-to-compile (definition)
(if (consp definition)
(when old (substitute-leaf fun old)))
name)))
-(defun compile (name &optional (definition (fdefinition name)))
- #!+sb-doc
- "Compiles the function whose name is Name. If Definition is supplied,
- it should be a lambda expression that is compiled and then placed in the
- function cell of Name. If Name is Nil, the compiled code object is
- returned."
+;;; Handle the nontrivial case of CL:COMPILE.
+(defun actually-compile (name definition)
(with-compilation-values
(sb!xc:with-compilation-unit ()
- (let* ((*info-environment* (or *backend-info-environment*
- *info-environment*))
+ (let* (;; FIXME: Do we need this rebinding here? It's a literal
+ ;; translation of the old CMU CL rebinding to
+ ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
+ ;; and it's not obvious whether the rebinding to itself is
+ ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
+ (*info-environment* *info-environment*)
(*lexenv* (make-null-lexenv))
(form `#',(get-lambda-to-compile definition))
(*source-info* (make-lisp-source-info form))
#'(lambda ()
(compiler-mumble
"~2&fatal error, aborting compilation~%")
- (return-from compile (values nil t nil))))
+ (return-from actually-compile (values nil t nil))))
(*current-path* nil)
(*last-source-context* nil)
(*last-original-source* nil)
(dolist (component *all-components*)
(compile-component component))))
- (let* ((res1 (core-call-top-level-lambda lambda *compile-object*))
- (result (or name res1)))
- (fix-core-source-info *source-info* *compile-object* res1)
- (when name
- (setf (fdefinition name) res1))
- result))))))
+ (let ((compiled-fun (core-call-top-level-lambda lambda
+ *compile-object*)))
+ (fix-core-source-info *source-info* *compile-object* compiled-fun)
+ compiled-fun))))))
+
+(defun compile (name &optional (definition (fdefinition name)))
+ #!+sb-doc
+ "Coerce DEFINITION (by default, the function whose name is NAME)
+ to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
+ where if NAME is NIL, THING is the result of compilation, and
+ otherwise THING is NAME. When NAME is not NIL, the compiled function
+ is also set into (FDEFINITION NAME)."
+ ;;(format t "~&/in COMPILE NAME=~S DEFINITION=~S" name definition) ; REMOVEME
+ (multiple-value-bind (compiled-definition warnings-p failure-p)
+ (if (compiled-function-p definition)
+ (values definition nil nil)
+ (actually-compile name definition))
+ ;;(format t "~&/COMPILED-DEFINITION=~S~%" compiled-definition) ; REMOVEME
+ (cond (name
+ (unless failure-p
+ (setf (fdefinition name) compiled-definition))
+ (values name warnings-p failure-p))
+ (t
+ (values compiled-definition warnings-p failure-p)))))
(define-condition condition-foo3 (condition-foo2) ())
(define-condition condition-foo4 (condition-foo3) ())
-(format t "~&/before DEFUN TEST-INLINE-TYPE-TESTS~%")
-
-(fmakunbound 'test-inline-type-tests)
-(defun test-inline-type-tests ()
- ;; structure type tests
- (assert (typep (make-structure-foo3) 'structure-foo2))
- (assert (not (typep (make-structure-foo1) 'structure-foo4)))
- (assert (null (ignore-errors
- (setf (structure-foo2-x (make-structure-foo1)) 11))))
-
- ;; structure-class tests
- (assert (typep (make-instance 'structure-class-foo3)
- 'structure-class-foo2))
- (assert (not (typep (make-instance 'structure-class-foo1)
- 'structure-class-foo4)))
- (assert (null (ignore-errors
- (setf (slot-value (make-instance 'structure-class-foo1) 'x)
- 11))))
-
- ;; standard-class tests
- (assert (typep (make-instance 'standard-class-foo3)
- 'standard-class-foo2))
- (assert (not (typep (make-instance 'standard-class-foo1)
- 'standard-class-foo4)))
- (assert (null (ignore-errors
- (setf (slot-value (make-instance 'standard-class-foo1) 'x)
- 11))))
-
- ;; condition tests
- (assert (typep (make-condition 'condition-foo3)
- 'condition-foo2))
- (assert (not (typep (make-condition 'condition-foo1)
- 'condition-foo4)))
- (assert (null (ignore-errors
- (setf (slot-value (make-condition 'condition-foo1) 'x)
- 11))))
- (assert (subtypep 'error 't))
- (assert (subtypep 'simple-condition 'condition))
- (assert (subtypep 'simple-error 'simple-condition))
- (assert (subtypep 'simple-error 'error))
- (assert (not (subtypep 'condition 'simple-condition)))
- (assert (not (subtypep 'error 'simple-error)))
- (assert (eq (car (sb-kernel:class-direct-superclasses (find-class
- 'simple-condition)))
- (find-class 'condition)))
-
- (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
- 'simple-condition)))
- (sb-pcl:find-class 'condition)))
- (assert (null (set-difference
- (sb-pcl:class-direct-subclasses (sb-pcl:find-class
- 'simple-condition))
- (mapcar #'sb-pcl:find-class '(simple-type-error simple-error
- sb-int:simple-style-warning)))))
-
- ;; precedence lists
- (assert (equal (sb-pcl:class-precedence-list
- (sb-pcl:find-class 'simple-condition))
- (mapcar #'sb-pcl:find-class '(simple-condition condition
- sb-kernel:instance t))))
-
- ;; stream classes
- (assert (null (sb-kernel:class-direct-superclasses (find-class
- 'fundamental-stream))))
- (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
- 'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(standard-object stream))))
- (assert (null (set-difference
- (sb-pcl:class-direct-subclasses (sb-pcl:find-class
- 'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
- fundamental-character-stream
- fundamental-output-stream
- fundamental-input-stream)))))
- (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
- 'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(fundamental-stream
- standard-object
- sb-pcl::std-object
- sb-pcl::slot-object
- stream
- sb-kernel:instance
- t))))
- (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
- 'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(fundamental-stream
- standard-object
- sb-pcl::std-object
- sb-pcl::slot-object stream
- sb-kernel:instance t))))
- (assert (subtypep (find-class 'stream) (find-class t)))
- (assert (subtypep (find-class 'fundamental-stream) 'stream))
- (assert (not (subtypep 'stream 'fundamental-stream))))
-
-(format t "~&/done with DEFUN TEST-INLINE-TYPE-TESTS~%")
-
-;;; inline-type tests:
-;;; Test the interpreted version.
-(test-inline-type-tests)
-(format t "~&/done with interpreted (TEST-INLINE-TYPE-TESTS)~%")
-;;; Test the compiled version.
-#| ; FIXME: fails 'cause FUNCALL of COMPILEd function broken ca. 0.pre7.15
-(compile nil #'test-inline-type-tests)
-(test-inline-type-tests)
-|#
+;;; inline type tests
+(format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
+(defparameter *tests-of-inline-type-tests*
+ '(progn
+
+ ;; structure type tests
+ (assert (typep (make-structure-foo3) 'structure-foo2))
+ (assert (not (typep (make-structure-foo1) 'structure-foo4)))
+ (assert (null (ignore-errors
+ (setf (structure-foo2-x (make-structure-foo1)) 11))))
+
+ ;; structure-class tests
+ (assert (typep (make-instance 'structure-class-foo3)
+ 'structure-class-foo2))
+ (assert (not (typep (make-instance 'structure-class-foo1)
+ 'structure-class-foo4)))
+ (assert (null (ignore-errors
+ (setf (slot-value (make-instance 'structure-class-foo1)
+ 'x)
+ 11))))
+
+ ;; standard-class tests
+ (assert (typep (make-instance 'standard-class-foo3)
+ 'standard-class-foo2))
+ (assert (not (typep (make-instance 'standard-class-foo1)
+ 'standard-class-foo4)))
+ (assert (null (ignore-errors
+ (setf (slot-value (make-instance 'standard-class-foo1) 'x)
+ 11))))
+
+ ;; condition tests
+ (assert (typep (make-condition 'condition-foo3)
+ 'condition-foo2))
+ (assert (not (typep (make-condition 'condition-foo1)
+ 'condition-foo4)))
+ (assert (null (ignore-errors
+ (setf (slot-value (make-condition 'condition-foo1) 'x)
+ 11))))
+ (assert (subtypep 'error 't))
+ (assert (subtypep 'simple-condition 'condition))
+ (assert (subtypep 'simple-error 'simple-condition))
+ (assert (subtypep 'simple-error 'error))
+ (assert (not (subtypep 'condition 'simple-condition)))
+ (assert (not (subtypep 'error 'simple-error)))
+ (assert (eq (car (sb-kernel:class-direct-superclasses
+ (find-class 'simple-condition)))
+ (find-class 'condition)))
+
+ (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
+ 'simple-condition)))
+ (sb-pcl:find-class 'condition)))
+ (assert (null (set-difference
+ (sb-pcl:class-direct-subclasses (sb-pcl:find-class
+ 'simple-condition))
+ (mapcar #'sb-pcl:find-class
+ '(simple-type-error simple-error
+ sb-int:simple-style-warning)))))
+
+ ;; precedence lists
+ (assert (equal (sb-pcl:class-precedence-list
+ (sb-pcl:find-class 'simple-condition))
+ (mapcar #'sb-pcl:find-class '(simple-condition
+ condition
+ sb-kernel:instance
+ t))))
+
+ ;; stream classes
+ (assert (null (sb-kernel:class-direct-superclasses
+ (find-class 'fundamental-stream))))
+ (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
+ 'fundamental-stream))
+ (mapcar #'sb-pcl:find-class '(standard-object stream))))
+ (assert (null (set-difference
+ (sb-pcl:class-direct-subclasses (sb-pcl:find-class
+ 'fundamental-stream))
+ (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
+ fundamental-character-stream
+ fundamental-output-stream
+ fundamental-input-stream)))))
+ (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
+ 'fundamental-stream))
+ (mapcar #'sb-pcl:find-class '(fundamental-stream
+ standard-object
+ sb-pcl::std-object
+ sb-pcl::slot-object
+ stream
+ sb-kernel:instance
+ t))))
+ (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
+ 'fundamental-stream))
+ (mapcar #'sb-pcl:find-class '(fundamental-stream
+ standard-object
+ sb-pcl::std-object
+ sb-pcl::slot-object stream
+ sb-kernel:instance t))))
+ (assert (subtypep (find-class 'stream) (find-class t)))
+ (assert (subtypep (find-class 'fundamental-stream) 'stream))
+ (assert (not (subtypep 'stream 'fundamental-stream)))))
+;;; Test under the interpreter.
+(eval *tests-of-inline-type-tests*)
+(format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
+;;; Test under the compiler.
+(defun tests-of-inline-type-tests ()
+ #.*tests-of-inline-type-tests*)
+(tests-of-inline-type-tests)
+(format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
;;; success
(quit :unix-status 104)
projects / sbcl.git / commitdiff