(sb-ext:code-deletion-note (e)
(error e)))
+;;; unknown values return convention getting disproportionate
+;;; amounts of values.
+(declaim (notinline one-value two-values))
+(defun one-value (x)
+ (not x))
+(defun two-values (x y)
+ (values y x))
+(defun wants-many-values (x y)
+ (multiple-value-bind (a b c d e f)
+ (one-value y)
+ (assert (and (eql (not y) a)
+ (not (or b c d e f)))))
+ (multiple-value-bind (a b c d e f)
+ (two-values y x)
+ (assert (and (eql a x) (eql b y)
+ (not (or c d e f)))))
+ (multiple-value-bind (a b c d e f g h i)
+ (one-value y)
+ (assert (and (eql (not y) a)
+ (not (or b c d e f g h i)))))
+ (multiple-value-bind (a b c d e f g h i)
+ (two-values y x)
+ (assert (and (eql a x) (eql b y)
+ (not (or c d e f g h i)))))
+ (multiple-value-bind (a b c d e f g h i j k l m n o p q r s)
+ (one-value y)
+ (assert (and (eql (not y) a)
+ (not (or b c d e f g h i j k l m n o p q r s)))))
+ (multiple-value-bind (a b c d e f g h i j k l m n o p q r s)
+ (two-values y x)
+ (assert (and (eql a x) (eql b y)
+ (not (or c d e f g h i j k l m n o p q r s))))))
+(wants-many-values 1 42)
+
+;;; constant coalescing
+
+(defun count-code-constants (x f)
+ (let ((code (sb-kernel:fun-code-header f))
+ (n 0))
+ (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
+ do (when (equal x (sb-kernel:code-header-ref code i))
+ (incf n)))
+ n))
+
+(defvar *lambda*)
+
+(defun compile2 (lambda)
+ (let* ((lisp "compiler-impure-tmp.lisp")
+ (fasl (compile-file-pathname lisp)))
+ (unwind-protect
+ (progn
+ (with-open-file (f lisp :direction :output)
+ (prin1 `(setf *lambda* ,lambda) f))
+ (multiple-value-bind (fasl warn fail) (compile-file lisp)
+ (declare (ignore warn))
+ (when fail
+ (error "File-compiling ~S failed." lambda))
+ (let ((*lambda* nil))
+ (load fasl)
+ (values *lambda* (compile nil lambda)))))
+ (ignore-errors (delete-file lisp))
+ (ignore-errors (delete-file fasl)))))
+
+;; named and unnamed
+(defconstant +born-to-coalesce+ '.born-to-coalesce.)
+(multiple-value-bind (file-fun core-fun)
+ (compile2 '(lambda ()
+ (let ((x (cons +born-to-coalesce+ nil))
+ (y (cons '.born-to-coalesce. nil)))
+ (list x y))))
+ (assert (= 1 (count-code-constants '.born-to-coalesce. file-fun)))
+ (assert (= 1 (count-code-constants '.born-to-coalesce. core-fun))))
+
+;; some things must retain identity under COMPILE, but we want to coalesce them under COMPILE-FILE
+(defun assert-coalescing (constant)
+ (let ((value (copy-seq (symbol-value constant))))
+ (multiple-value-bind (file-fun core-fun)
+ (compile2 `(lambda ()
+ (let ((x (cons ,constant nil))
+ (y (cons ',value nil)))
+ (list x y))))
+ (assert (= 1 (count-code-constants value file-fun)))
+ (assert (= 2 (count-code-constants value core-fun)))
+ (let* ((l (funcall file-fun))
+ (a (car (first l)))
+ (b (car (second l))))
+ (assert (and (equal value a)
+ (equal a b)
+ (eq a b))))
+ (let* ((l (funcall core-fun))
+ (a (car (first l)))
+ (b (car (second l))))
+ (assert (and (equal value a)
+ (equal a b)
+ (not (eq a b))))))))
+
+(defconstant +born-to-coalesce2+ "maybe coalesce me!")
+(assert-coalescing '+born-to-coalesce2+)
+
+(defconstant +born-to-coalesce3+ #*01101001011101110100011)
+(assert-coalescing '+born-to-coalesce3+)
+
+(defconstant +born-to-coalesce4+ '(foo bar "zot" 123 (nested "quux") #*0101110010))
+(assert-coalescing '+born-to-coalesce4+)
+
+(defclass some-constant-thing () ())
+
+;;; correct handling of nested things loaded via SYMBOL-VALUE
+(defvar *sneaky-nested-thing* (list (make-instance 'some-constant-thing)))
+(defconstant +sneaky-nested-thing+ *sneaky-nested-thing*)
+(multiple-value-bind (file-fun core-fun) (compile2 '(lambda () +sneaky-nested-thing+))
+ (assert (equal *sneaky-nested-thing* (funcall file-fun)))
+ (assert (equal *sneaky-nested-thing* (funcall core-fun))))
+
+;;; catch constant modifications thru undefined variables
+(defun sneak-set-dont-set-me (x)
+ (ignore-errors (setq dont-set-me x)))
+(defconstant dont-set-me 42)
+(assert (not (sneak-set-dont-set-me 13)))
+(assert (= 42 dont-set-me))
+(defun sneak-set-dont-set-me2 (x)
+ (ignore-errors (setq dont-set-me2 x)))
+(defconstant dont-set-me2 (make-instance 'some-constant-thing))
+(assert (not (sneak-set-dont-set-me2 13)))
+(assert (typep dont-set-me2 'some-constant-thing))
+
+;;; check that non-trivial constants are EQ across different files: this is
+;;; not something ANSI either guarantees or requires, but we want to do it
+;;; anyways.
+(defconstant +share-me-1+ 123.456d0)
+(defconstant +share-me-2+ "a string to share")
+(defconstant +share-me-3+ (vector 1 2 3))
+(defconstant +share-me-4+ (* 2 most-positive-fixnum))
+(multiple-value-bind (f1 c1) (compile2 '(lambda () (values +share-me-1+
+ +share-me-2+
+ +share-me-3+
+ +share-me-4+
+ pi)))
+ (multiple-value-bind (f2 c2) (compile2 '(lambda () (values +share-me-1+
+ +share-me-2+
+ +share-me-3+
+ +share-me-4+
+ pi)))
+ (flet ((test (fa fb)
+ (mapc (lambda (a b)
+ (assert (eq a b)))
+ (multiple-value-list (funcall fa))
+ (multiple-value-list (funcall fb)))))
+ (test f1 c1)
+ (test f1 f2)
+ (test f1 c2))))
+
;;; success
projects / sbcl.git / blobdiff