;;;; -*- lisp -*-

;;;; 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)

;;;; recognize self-calls
(declaim (optimize speed))

;;; This is a fopcompilable form that caused FOP stack underflow
;;; because the PROGN and SETQ each failed to push a NIL onto the stack.
;;; >>> DO NOT ADD A (WITH-TEST) TO THIS. <<< It must stay fopcompilable.
(let ((a (progn)) ; lp# 1427050
      (b (setq))
      (b (+ 1 2)))
  (defvar *aaa* a)
  (defvar *bbb* b))


;;;; These three forms should be equivalent.

;;; This used to be a bug in the handling of null-lexenv vs toplevel
;;; policy: LOCALLY and MACROLET hid the toplevel policy from view.

(locally
    (defun foo (n)
      (frob 'foo)
      (if (<= n 0)
          n
          (foo (1- n)))))

(progn
  (defun bar (n)
    (frob 'bar)
    (if (<= n 0)
        n
        (bar (1- n)))))

(macrolet ()
  (defun quux (n)
    (frob 'quux)
    (if (<= n 0)
        n
        (quux (1- n)))))

(defun frob (x)
  (setf (fdefinition x) (constantly 13)))

(defun test ()
  (list (foo 1) (bar 1) (quux 1)))

(assert (equal (test) '(0 0 0)))
(assert (equal (test) '(13 13 13))) ; sanity check

;;; Bug in 1.0.2 and 1.0.3, where the XEP was compiled with the wrong
;;; policy. (Test-case derived from code posted by alexander.ekart in
;;; comp.lang.lisp).

(locally
    (declare (optimize (safety 0)))
  (defun bubblesort (x y)
    (declare (type (simple-array fixnum (*)) x)
             (type fixnum y)
             (optimize (speed 3) (safety 3) (space 0) (debug 0)))
    (aref x y)))

(assert-error (bubblesort (make-array 10) 9))

(define-symbol-macro %trash% what)
(locally
  ;; just in case we get so smart that INFO becomes foldable
  (declare (notinline sb-int:info))
  (assert (eq (sb-int:info :variable :kind '%trash%) :macro))
  (assert (eq (sb-int:info :variable :macro-expansion '%trash%) 'what))
  (assert (sb-int:info :source-location :symbol-macro '%trash%)))
(let ()
  (declare (notinline sb-int:info))
  (defconstant %trash% 9) ; this is non-toplevel
  (multiple-value-bind (val foundp)
      (sb-int:info :variable :macro-expansion '%trash%)
    (assert (and (not val) (not foundp)))))

;;; COMPILE-FILE-LINE and COMPILE-FILE-POSITION

(macrolet ((line () `(multiple-value-call 'cons (compile-file-line))))
  (defun more-foo (x)
    (if x
        (format nil "Great! ~D" (line)) ; <-- this is line 97
        (format nil "Yikes ~D" (line)))))

(declaim (inline thing))
(defun thing ()
  (format nil "failed to frob a knob at line #~D"
          (compile-file-line))) ; <-- this is line 103

(defmacro more-randomness ()
  '(progn
    (let ()
      (thing))))

(macrolet ()
  (progn
    (defun bork (x)
      (flet ()
        (if x
            (locally (declare (notinline thing))
              (more-randomness))
            (progn (more-randomness))))))) ; <-- this is line 117

(defun compile-file-pos-sharp-dot (x)
  (list #.(format nil "Foo line ~D" (compile-file-line)) ; line #120
        x))

(defun compile-file-pos-eval-in-macro ()
  (macrolet ((macro (x)
               (format nil "hi ~A at ~D" x
                       (compile-file-line)))) ; line #126
    (macro "there")))

(with-test (:name :compile-file-line)
  (assert (string= (more-foo t) "Great! (97 . 32)"))
  (assert (string= (more-foo nil) "Yikes (98 . 31)"))
  (assert (string= (bork t) "failed to frob a knob at line #103"))
  (assert (string= (bork nil) "failed to frob a knob at line #117"))
  (assert (string= (car (compile-file-pos-sharp-dot nil))
                    "Foo line 120"))
  (assert (string= (compile-file-pos-eval-in-macro)
                    "hi there at 126")))

(eval-when (:compile-toplevel)
  (let ((stream (sb-c::source-info-stream sb-c::*source-info*)))
    (assert (pathname stream))))
