;;;; miscellaneous compiler tests with side-effects (e.g. DEFUN
;;;; changing FDEFINITIONs and globaldb stuff)

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;; 
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(cl:in-package :cl-user)

(declaim (optimize (debug 3) (speed 2) (space 1)))

;;; Until version 0.6.9 or so, SBCL's version of Python couldn't do
;;; this correctly, due to the bug patched by Rob MacLachlan on the
;;; cmucl-imp list 2000-06-21, and applied to SBCL by Martin Atzmueller.
;;; (The effectiveness of the test also depends on the implicit
;;; function typing of Python (where DEFUN is like DECLAIM FTYPE),
;;; which violates the ANSI spec, and should be fixed. Once that
;;; unrelated bug is fixed, this code will no longer test the type
;;; inference behavior it's intended to test.)
(defun emptyvalues (&rest rest) (declare (ignore rest)) (values))
(defstruct foo x y)
(defun bar ()
  (let ((res (emptyvalues)))
    (unless (typep res 'foo)
      'expected-value)))
(assert (eq (bar) 'expected-value))

(declaim (ftype (function (real) (values integer single-float)) valuesify))
(defun valuesify (x)
  (values (round x)
	  (coerce x 'single-float)))
(defun exercise-valuesify (x)
  (multiple-value-bind (i f) (valuesify x)
    (declare (type integer i))
    (declare (type single-float f))
    (+ i f)))
(assert (= (exercise-valuesify 1.25) 2.25))

;;; Don Geddis reported this test case 25 December 1999 on a CMU CL
;;; mailing list: dumping circular lists caused the compiler to enter
;;; an infinite loop. Douglas Crosher reported a patch 27 Dec 1999.
;;; The patch was tested on SBCL by Martin Atzmueller 2 Nov 2000, and
;;; merged in sbcl-0.6.8.11.
(defun q-dg1999-1 () (dolist (x '#1=("A" "B" . #1#)) x))
(defun q-dg1999-2 () (dolist (x '#1=("C" "D" . #1#)) x))
(defun q-dg1999-3 () (dolist (x '#1=("E" "F" . #1#)) x))
(defun q-dg1999-4 () (dolist (x '#1=("C" "D" . #1#)) x))
(defun useful-dg1999 (keys)
  (declare (type list keys))
  (loop
      for c in '#1=("Red" "Blue" . #1#)
      for key in keys ))

;;; An early version (sbcl-0.6.11.33) of code to check FTYPEs from DEFUN
;;; against DECLAIMed FTYPEs blew up when an FTYPE was DECLAIMed
;;; to be pure FUNCTION, because the internal representation of
;;; FUNCTION itself (as opposed to subtypes of FUNCTION, such as
;;; (FUNCTION () T)) is a BUILT-IN-CLASS object, not a FUN-TYPE
;;; object.
(declaim (ftype function i-am-just-a-function))
(defun i-am-just-a-function (x y) (+ x y 1))

;;; Stig E SandPHI (where PHI is some phi-like character not
;;; representable in ASCII) reported in cclan-Bugs-431263 that SBCL
;;; couldn't compile this. sbcl-0.6.12.26 died in CIRCULAR-LIST-P with
;;; "The value \"EST\" is not of type LIST." Dan Barlow fixed it.
(defvar +time-zones+
  '((5 "EDT" . "EST") (6 "CDT" . "CST") (7 "MDT" .
"MST") (8 "PDT" . "PST")
    (0 "GMT" . "GDT") (-2 "MET" . "MET DST"))
  "*The string representations of the time zones.")

;;; The old CMU CL Python compiler assumed that it was safe to infer
;;; function types (including return types) from function definitions
;;; and then use them to optimize code later. This is of course bad
;;; when functions are redefined. The problem was fixed in
;;; sbcl-0.6.12.57.
(defun foo (x)
  (if (plusp x)
      1.0
      0))
(defun bar (x)
  (typecase (foo x)
    (fixnum :fixnum)
    (real :real)
    (string :string)
    (t :t)))
(assert (eql (bar 11) :real))
(assert (eql (bar -11) :fixnum))
(setf (symbol-function 'foo) #'identity)
(assert (eql (bar 11) :fixnum))
(assert (eql (bar -11.0) :real))
(assert (eql (bar "this is a test") :string))
(assert (eql (bar (make-hash-table)) :t))

;;; bug reported by Brian Spilsbury sbcl-devel 2001-09-30, fixed by
;;; Alexey Dejneka patch sbcl-devel 2001-10-02
(defun pixarray-element-size (pixarray)
  (let ((eltype (array-element-type pixarray)))
    (cond ((eq eltype 'bit) 1)
          ((and (listp eltype)
                (eq (first eltype) 'unsigned-byte))
           (second eltype))
          (t
           (error "Invalid pixarray: ~S." pixarray)))))
(assert (eql 1 (pixarray-element-size #*110)))

(sb-ext:quit :unix-status 104) ; success