;;;; This file is for testing debugging functionality, using
;;;; test machinery which might have side effects (e.g.
;;;; executing DEFUN).

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

;;; The debugger doesn't have any native knowledge of the interpreter
(when (eq sb-ext:*evaluator-mode* :interpret)
  (sb-ext:exit :code 104))


;;;; Check that we get debug arglists right.

(defun zoop (zeep &key beep)
  (declare (ignore zeep beep) (special blurp))
  blurp)
(assert (equal (sb-kernel:%fun-lambda-list #'zoop) '(zeep &key beep)))

;;; Check some predefined functions too.
;;;
;;; (We don't know exactly what the arguments are, e.g. the first
;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
;;; whatever. But we do know the general structure that a correct
;;; answer should have, so we can safely do a lot of checks.)
(with-test (:name :predefined-functions-1)
  (destructuring-bind (object-sym andoptional-sym stream-sym)
      (sb-kernel:%fun-lambda-list #'print)
    (assert (symbolp object-sym))
    (assert (eql andoptional-sym '&optional))
    (assert (symbolp stream-sym))))

(with-test (:name :predefined-functions-2)
  (destructuring-bind (dest-sym control-sym andrest-sym format-args-sym)
      (sb-kernel:%fun-lambda-list #'format)
    (assert (symbolp dest-sym))
    (assert (symbolp control-sym))
    (assert (eql andrest-sym '&rest))
    (assert (symbolp format-args-sym))))

;;;; test TRACE

(defmacro with-traced-function ((name &rest options) &body body)
  `(with-output-to-string (*trace-output*)
     (unwind-protect
          (progn
            (trace ,name ,@options)
            ,@body)
       (ignore-errors (untrace ,name)))))

(defun trace-this (&optional arg)
  (declare (ignore arg))
  'ok)

(defun trace-fact (n)
  (if (zerop n)
      1
      (* n (trace-fact (1- n)))))

(with-test (:name (trace :simple))
  (let ((output (with-traced-function (trace-this)
                  (assert (eq 'ok (trace-this))))))
    (assert (search "TRACE-THIS" output))
    (assert (search "returned OK" output))))

(with-test (:name (trace :print-readably))
  (let ((output (with-traced-function (trace-this)
                  (let ((*print-readably* t))
                    (assert (eq 'ok (trace-this (sb-int:make-unprintable-object "foo"))))))))
    (assert (search "TRACE-THIS" output))
    (assert (search "foo" output))
    (assert (search "returned OK" output))))

;;; The following should not work:
;;;  (DEFUN G () (M))
;;;  (DEFMACRO M (&REST r) (format t "M invoked: ~S~%" r))
;;;  (ENCAPSULATE 'M 'foo (lambda (f &rest r) (format t "encapsulation: ~S ~S~%" f r)))
;;;  (G)
;;; If (ENCAPSULATE) were permitted, M's guard trampoline would be replaced by the
;;; encapsulation which is not meaningful. Most uses of the macro M will NOT invoke
;;; the encapsulation since we don't store macro functions in the symbol-function location.
;;; Only a consumer of M being accidentally compiled first and resolving M to an
;;; fdefinition would see the encapulation. That should just be an error.
(with-test (:name :no-macro-encapsulation)
  (assert-error (sb-int:encapsulate 'cond 'tryme
                                    (lambda (f &rest stuff)
                                      (declare (ignore f stuff))))))

;;; bug 379
(with-test (:name (trace :encapsulate nil)
            :fails-on (or (and :ppc (not :linux)) :sparc :arm64)
            :broken-on (or :hppa :freebsd))
  (let ((output (with-traced-function (trace-this :encapsulate nil)
                  (assert (eq 'ok (trace-this))))))
    (assert (search "TRACE-THIS" output))
    (assert (search "returned OK" output))))

(with-test (:name (trace :encapsulate nil :recursive)
            :fails-on (or (and :ppc (not :linux)) :sparc :arm64)
            :broken-on (or :hppa :freebsd))
  (let ((output (with-traced-function (trace-fact :encapsulate nil)
                  (assert (= 120 (trace-fact 5))))))
    (assert (search "TRACE-FACT" output))
    (assert (search "returned 1" output))
    (assert (search "returned 120" output))))

(defun trace-and-fmakunbound-this (x)
  x)

(with-test (:name (trace fmakunbound :bug-667657))
  (trace trace-and-fmakunbound-this)
  (fmakunbound 'trace-and-fmakunbound-this)
  ;; FIXME: this generates a pointless warning that we can't untrace a formerly
  ;; traced function. Function redefinition knows to untrace/re-trace because of
  ;; the setf-fdefn hook. fmakunbound can do something similar - drop the trace.
  (untrace)
  (assert (not (trace))))

(with-test (:name (trace :report nil :smoke))
  (let ((output (with-traced-function (trace-this :report nil)
                  (assert (eq 'ok (trace-this))))))
    (assert (sequence:emptyp output))))

(with-test (:name (trace :report nil :print))
  (let ((output (with-traced-function
                    (trace-fact :report nil :print (sb-debug:arg 0))
                  (assert (eq '2 (trace-fact 2))))))
    (assert (string= output (format nil "2~@
                                         1~@
                                         0~%")))))

(with-test (:name :bug-414)
  (handler-bind ((warning #'error))
    (with-scratch-file (output "fasl")
      (load (compile-file "bug-414.lisp" :output-file output
                                         :verbose nil :print nil)))
    (with-output-to-string (s)
      (disassemble 'bug-414 :stream s))))

;; A known function can be stored as a code constant in lieu of the
;; usual mode of storing an #<fdefn> and looking up the function from it.
;; One such usage occurs with TAIL-CALL-VARIABLE (e.g. via APPLY).
;; Show that declaring the function locally notinline uses the #<fdefn>
;; by first compiling a call that would have elided the #<fdefn>
;; and then TRACE.
;; XXX: what purpose has the JUNK argument?
(defun test-compile-then-load (filename junk)
  (declare (notinline compile-file load))
  (with-scratch-file (output "fasl")
    (apply 'load (apply 'compile-file filename :output-file output junk)
           junk)))
(compile 'test-compile-then-load)
(with-test (:name :traceable-known-fun)
  (let ((s (make-string-output-stream)))
    (trace compile-file load)
    (let ((*trace-output* s))
      (test-compile-then-load "bug-414.lisp" nil))
    (untrace)
    (assert (>= (count #\Newline (get-output-stream-string s)) 4))))

(with-test (:name :bug-310175 :fails-on (not :stack-allocatable-lists))
  ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
  ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS.  Therefore,
  ;; use two-arg-LIST, which should get through to VOP LIST, and thus
  ;; stack-allocate on a predictable set of machines.
  (let ((dx-arg (list t t)))
    (declare (dynamic-extent dx-arg))
    (flet ((dx-arg-backtrace (x)
             (declare (optimize (debug 2)))
             (prog1 (sb-debug:list-backtrace :count 10)
               (assert (sb-debug::stack-allocated-p x)))))
      (declare (notinline dx-arg-backtrace))
      (assert (member-if (lambda (frame)
                           (and (consp frame)
                                (consp (car frame))
                                (equal '(flet dx-arg-backtrace :in) (butlast (car frame)))
                                (notany #'sb-debug::stack-allocated-p (cdr frame))))
                         (dx-arg-backtrace dx-arg))))))

(with-test (:name :bug-795245)
  (assert
   (eq :ok
       (catch 'done
         (handler-bind
             ((error (lambda (e)
                       (declare (ignore e))
                       (handler-case
                           (sb-debug:print-backtrace :count 100
                                                     :stream (make-broadcast-stream))
                         (error ()
                           (throw 'done :error))
                         (:no-error ()
                           (throw 'done :ok))))))
           (apply '/= nil 1 2 nil))))))

;;;; test infinite error protection

(defmacro nest-errors (n-levels error-form)
  (if (< 0 n-levels)
      `(handler-bind ((error (lambda (condition)
                               (declare (ignore condition))
                               ,error-form)))
        (nest-errors ,(1- n-levels) ,error-form))
      error-form))

(defun erroring-debugger-hook (condition old-debugger-hook)
  (let ((*debugger-hook* old-debugger-hook))
    (format t "recursive condition: ~A~%" condition) (force-output)
    (error "recursive condition: ~A" condition)))

(defun test-infinite-error-protection ()
  ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
  ;; to halt, it produces so much garbage that's hard to suppress that
  ;; it is tested only once
  (write-line "--HARMLESS BUT ALARMING BACKTRACE COMING UP--")
  (let ((*debugger-hook* #'erroring-debugger-hook))
    (loop repeat 1 do
          (let ((error-counter 0)
                (*terminal-io* (make-broadcast-stream)))
            (assert
             (not (eq
                   :normal-exit
                   (catch 'sb-impl::toplevel-catcher
                     (nest-errors 20 (error "infinite error ~s"
                                            (incf error-counter)))
                     :normal-exit)))))))
  (write-line "--END OF H-B-A-B--"))

;;; *debugger-hook* is now cleared after trying to enter the debugger
;;; *once in ERROR-ERROR, breaking these tests.
(with-test (:name :infinite-error-protection
            :skipped-on :sbcl)
  (enable-debugger)
  (test-infinite-error-protection))

(with-test (:name (:infinite-error-protection :thread)
            :skipped-on (or :sbcl (not :sb-thread)))
  (enable-debugger)
  (let ((thread (sb-thread:make-thread #'test-infinite-error-protection)))
    (loop while (sb-thread:thread-alive-p thread))))

;; unconditional, in case either previous left it enabled
(disable-debugger)

;;;; test some limitations of MAKE-LISP-OBJ

;;; Older GENCGC systems had a bug in the pointer validation used by
;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
;;; validate.
(with-test (:name (:make-lisp-obj :simple-funs))
  (sb-sys:without-gcing
    (assert (eq #'identity
                (sb-kernel:make-lisp-obj
                 (sb-kernel:get-lisp-obj-address
                  #'identity))))))

;;; Older CHENEYGC systems didn't perform any real pointer validity
;;; checks beyond "is this pointer to somewhere in heap space".
(with-test (:name (:make-lisp-obj :pointer-validation))
  ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
  ;; address, but we also need the GC to not pitch a fit if it sees an
  ;; object with said bogus address.  Thus, construct our known-bogus
  ;; object within an area of unboxed storage (a vector) in static
  ;; space.  We'll make it a simple object, (CONS 0 0), which has an
  ;; in-memory representation of two consecutive zero words.  We
  ;; allocate a three-word vector so that we can guarantee a
  ;; double-word aligned double-word of zeros no matter what happens
  ;; with the vector-data-offset (currently double-word aligned).
  (let* ((memory (sb-int:make-static-vector 3 :element-type `(unsigned-byte ,sb-vm:n-word-bits)
                                            :initial-element 0))
         (vector-data-address (sb-sys:sap-int (sb-kernel::vector-sap memory)))
         (object-base-address (logandc2 (+ vector-data-address sb-vm:lowtag-mask) sb-vm:lowtag-mask))
         (object-tagged-address (+ object-base-address sb-vm:list-pointer-lowtag)))
    (multiple-value-bind (object valid-p)
        (sb-kernel:make-lisp-obj object-tagged-address nil)
      (declare (ignore object))
      (assert (not valid-p)))))

(defun test-debugger (control form &rest targets)
  (let ((out (make-string-output-stream))
        (oops t))
    (unwind-protect
         (progn
           (with-simple-restart (debugger-test-done! "Debugger Test Done!")
             (let* ((*debug-io* (make-two-way-stream
                                 (make-string-input-stream control)
                                 (make-broadcast-stream out #+nil *standard-output*)))
                    ;; Initial announcement goes to *ERROR-OUTPUT*
                    (*error-output* *debug-io*)
                    (*invoke-debugger-hook* nil))
               (handler-bind ((error #'invoke-debugger))
                 (eval form))))
           (setf oops nil))
      (when oops
        (error "Uncontrolled unwind from debugger test.")))
    ;; For sanity's sake this is outside the *debug-io* rebinding -- otherwise
    ;; it could swallow our asserts!
    (with-input-from-string (s (get-output-stream-string out))
      (loop for line = (read-line s nil)
            while line
            do (assert targets nil "Line = ~a" line)
               #+nil
               (format *error-output* "Got: ~A~%" line)
               (let ((match (pop targets)))
                 (if (eq '* match)
                     ;; Whatever, till the next line matches.
                     (let ((text (pop targets)))
                       #+nil
                       (format *error-output* "Looking for: ~A~%" text)
                       (unless (search text line)
                         (push text targets)
                         (push match targets)))
                     (unless (search match line)
                       (format *error-output* "~&Wanted: ~S~%   Got: ~S~%" match line)
                       (setf oops t))))))
    ;; Check that we saw everything we wanted
    (when targets
      (error "Missed: ~S" targets))
    (assert (not oops))))

(with-test (:name (:debugger :source 1))
  (test-debugger
   "d
    source 0
    debugger-test-done!"
   `(progn
      (defun this-will-break (x)
               (declare (optimize debug))
               (let* ((y (- x x))
                      (z (/ x y)))
                 (+ x z)))
      (this-will-break 1))
   '*
   "debugger invoked"
   '*
   "DIVISION-BY-ZERO"
   "Operation was (/ 1 0)"
   '*
   "INTEGER-/-INTEGER"
   "(THIS-WILL-BREAK 1)"
   "1]"
   "(/ X Y)"
   "1]"))

(with-test (:name (:debugger :source 2))
  (test-debugger
   "d
    source 0
    debugger-test-done!"
   `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
      (let ((f #'(lambda (x cont)
                   (print x (make-broadcast-stream))
                   (if (zerop x)
                       (error "~%foo")
                       (funcall cont (1- x) cont)))))
        (funcall f 10 f)))
   '*
   "debugger"
   '*
   "foo"
   '*
   "source: (ERROR \"~%foo\")"
   '*
   "(LAMBDA (X CONT)"
   '*
   "(FUNCALL CONT (1- X) CONT)"
   "1]"))

(with-test (:name (:debugger :bogus-debug-fun :source))
  (test-debugger
   "d
    debugger-test-done!"
   `(let ()
      (#.(gensym)))
   '*
   "undefined function"
   '*
   "1]"))

(with-test (:name (disassemble :high-debug-eval))
  (eval `(defun this-will-be-disassembled (x)
           (declare (optimize debug))
           (+ x x)))
  (let* ((oopses (make-string-output-stream))
         (disassembly
           (let ((*error-output* oopses))
             (with-output-to-string (*standard-output*)
               (disassemble 'this-will-be-disassembled)))))
    (with-input-from-string (s disassembly)
      (assert (search "; disassembly for THIS-WILL-BE-DISASSEMBLED"
                      (read-line s))))
    (let ((problems (get-output-stream-string oopses)))
      (unless (zerop (length problems))
        (error problems)))))

(defun this-too-will-be-disasssembled (x)
  (declare (optimize debug))
  (+ x x))

(with-test (:name (disassemble :high-debug-load))
  (let* ((oopses (make-string-output-stream))
         (disassembly
           (let ((*error-output* oopses))
             (with-output-to-string (*standard-output*)
               (disassemble 'this-too-will-be-disasssembled)))))
    (with-input-from-string (s disassembly)
      (assert (equal "; disassembly for THIS-TOO-WILL-BE-DISASSSEMBLED"
                     (read-line s))))
    (let ((problems (get-output-stream-string oopses)))
      (unless (zerop (length problems))
        (error problems)))))

(with-test (:name (:xep-arglist-clean-up :bug-1192929))
  (assert
   (block nil
     (handler-bind ((error (lambda (e)
                             (declare (ignore e))
                             (return (< (length (car (sb-debug:list-backtrace :count 1)))
                                        10)))))
       (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))

;;; bug-1261646

(defun print-backtrace-to-string/debug-print-variable-alist (x)
  (values
   (with-output-to-string (stream)
     (let ((*debug-print-variable-alist* '((*print-length* . 5)
                                           (*print-level* . 3))))
       (sb-debug:print-backtrace :stream stream :count 5)))
   x)) ; Force use of X to prevent flushing

(with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
                   *print-length* :bug-1261646))
  (let* ((printed (print-backtrace-to-string/debug-print-variable-alist (make-array 200)))
         (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
         (position (+ (search call printed) (length call))))
    (assert (eql position (search "#(0 0 0 0 0 ...)" printed :start2 position)))))

(with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
                   *print-level* :bug-1261646))
  (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
                   '(((((1)))))))
         (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
         (position (+ (search call printed) (length call))))
    (assert (eql position (search "((#))" printed :start2 position)))))


(defvar *x* nil)
(defun foo (a) a)

(with-test (:name :trace-debug-arg)
  (trace foo :print-after (setf *x* (sb-debug:arg 0)))
  (foo 1)
  (assert (eql *x* 1))

  (trace foo :print (setf *x* (sb-debug:arg 0)))
  (foo 2)
  (assert (eql *x* 2))

  (trace foo :condition (eql (setf *x* (sb-debug:arg 0)) 0))
  (foo 3)
  (assert (eql *x* 3))

  (trace foo :condition-after (setf *x* (sb-debug:arg 0)))
  (foo 4)
  (assert (eql *x* 4))

  (trace foo :break (and (setf *x* (sb-debug:arg 0)) nil))
  (foo 5)
  (assert (eql *x* 5))

  (trace foo :break-all (and (setf *x* (sb-debug:arg 0)) nil))
  (foo 6)
  (assert (eql *x* 6))
  (trace foo :break-after (and (setf *x* (sb-debug:arg 0)) nil))
  (foo 7))

(defun frobbleize (arg) (declare (ignore arg)) (sb-debug:list-backtrace) 'win)
(defmethod low-debug-method ((self t))
  (declare (optimize (debug 0)))
  (frobbleize 'me) ; make this not a tail call, so it remains on stack
  5)
(with-test (:name :clean-fast-method-frame-lossage)
  (low-debug-method 42)) ; no need to assert. it either crashes or doesn't

(defun return-65535 ()
  65535)

(with-test (:name :indirect-closure-values)
  (let ((count 0))
    (block nil
      (handler-bind ((error (lambda (c)
                              (declare (ignore c))
                              (sb-debug::map-backtrace
                               (lambda (frame)
                                 (let ((sb-debug::*current-frame* frame)
                                       (name (sb-debug::frame-call frame)))
                                   (when (or (eq name 'test)
                                             (and (consp name)
                                                  (or (eql (search '(labels f1) name) 0)
                                                      (eql (search '(labels f2) name) 0))))
                                     (incf count)
                                     (assert (eql (var 'a) 2))))))
                              (return))))
        (funcall
         (compile nil
                  `(sb-int:named-lambda test ()
                     (declare (optimize debug))
                     (let ((a 1))
                       (labels
                           ((f1 ()
                              (incf a)
                              (signal 'error))
                            (f2 ()
                              (f1)))
                         (f2))))))))
    (assert (= count 3))))

(with-test (:name :indirect-closure-values.2)
  (let ((count 0))
    (block nil
      (handler-bind ((error (lambda (c)
                              (declare (ignore c))
                              (sb-debug::map-backtrace
                               (lambda (frame)
                                 (let ((sb-debug::*current-frame* frame)
                                       (name (sb-debug::frame-call frame)))
                                   (when (or (eq name 'test)
                                             (and (consp name)
                                                  (or (eql (search '(labels f1) name) 0)
                                                      (eql (search '(labels f2) name) 0))))
                                     (incf count)
                                     (assert (eql (var 'a) 65535))))))
                              (return))))
        (funcall
         (compile nil
                  `(sb-int:named-lambda test ()
                     (declare (optimize debug))
                     (let ((a (return-65535)))
                       (declare ((unsigned-byte 16) a))
                       (labels
                           ((f1 ()
                              (incf a)
                              (signal 'error))
                            (f2 ()
                              (f1)))
                         (f2))))))))
    (assert (= count 3))))

(with-test (:name :non-tail-self-call-bad-variables)
  (let ((count 0))
    (block nil
      (handler-bind ((error (lambda (c)
                              (declare (ignore c))
                              (sb-debug::map-backtrace
                               (lambda (frame)
                                 (let ((sb-debug::*current-frame* frame))
                                   (multiple-value-bind (name args)
                                       (sb-debug::frame-call frame)
                                     (when (eq name 'test)
                                       (assert (or (null args)
                                                   (equal args '(nil))))
                                       (incf count))))))
                              (return))))
        (funcall
         (compile nil `(sb-int:named-lambda test (&optional x)
                         (declare (optimize sb-c::recognize-self-calls))
                         (signal 'error :format-control "~a" :format-arguments (list x))
                         (test 1)
                         1)))))
    (assert (= count 1))))

(with-test (:name :local-tail-call-variables)
  (let ((count 0))
    (block nil
      (handler-bind ((error (lambda (c)
                              (declare (ignore c))
                              (sb-debug::map-backtrace
                               (lambda (frame)
                                 (let ((sb-debug::*current-frame* frame))
                                   (multiple-value-bind (name args)
                                       (sb-debug::frame-call frame)
                                     (when (eq name 'test)
                                       (assert (equal args '(error)))
                                       (incf count))))))
                              (return))))
        (funcall
         (compile nil `(sb-int:named-lambda test (x)
                         (signal x)
                         ;; If :local-tail-call fails, this will fail
                         ;; too, because there's no jump between
                         ;; SIGNAL and the call to TAIL and it will
                         ;; show (flet tail) in the backtrace.
                         (flet ((tail ()))
                           (declare (notinline tail))
                           (tail))))
         'error)))
    (assert (= count 1))))

(with-test (:name :variables-surrounding-inlined-code)
  (let ((count 0))
    (block nil
      (handler-bind ((error (lambda (c)
                              (declare (ignore c))
                              (sb-debug::map-backtrace
                               (lambda (frame)
                                 (let ((sb-debug::*current-frame* frame))
                                   (multiple-value-bind (name)
                                       (sb-debug::frame-call frame)
                                     (when (eq name 'test)
                                       (assert (equal (sb-debug:var 'l) '(1 2 3)))
                                       (incf count))))))
                              (return))))
        (funcall
         (compile nil `(sb-int:named-lambda test (a i)
                         (declare (optimize (debug 3)))
                         (let ((l (list 1 2 3)))
                           (aref a i)
                           l)))
         #(1) 2)))
    (assert (= count 1))))

(with-test (:name :variables-surrounding-inlined-code.2)
  (let ((count 0))
    (block nil
      (handler-bind ((error (lambda (c)
                              (declare (ignore c))
                              (sb-debug::map-backtrace
                               (lambda (frame)
                                 (let ((sb-debug::*current-frame* frame))
                                   (multiple-value-bind (name)
                                       (sb-debug::frame-call frame)
                                     (when (eq name 'test)
                                       (assert (equal (sb-debug:var 'l) '(1 2 3)))
                                       (incf count))))))
                              (return))))
        (funcall
         (compile nil `(sb-int:named-lambda test (c)
                         (declare (optimize (debug 3)))
                         (let ((l (list 1 2 3)))
                           (map 'list #'signal c)
                           l)))
         '(error))))
    (assert (= count 1))))

(with-test (:name :properly-tagged-p-internal
            :fails-on (not (or :x86 :x86-64)))
  ;; Pick a code component that has a ton of restarts.
  (let* ((code (sb-kernel:fun-code-header #'sb-impl::update-package-with-variance))
         (n (sb-kernel:code-n-entries code)))
    (sb-sys:with-pinned-objects (code)
      (let* ((base (logandc2 (sb-kernel:get-lisp-obj-address code)
                             sb-vm:lowtag-mask))
             (limit (+ base (sb-vm::primitive-object-size code))))
        (flet ((properly-tagged-p (ptr)
                 (eql (alien-funcall (extern-alien "properly_tagged_p_internal"
                                                   (function int unsigned unsigned))
                                     ptr base)
                      1)))
          ;; Test that there are exactly n-entries properly tagged interior pointers.
          (assert (= (loop for ptr from (+ base (* 2 sb-vm:n-word-bytes))
                           below limit count (properly-tagged-p ptr))
                     n))
          ;; Verify that the binary search algorithm for simple-fun-index works.
          (let ((count 0))
            (loop for ptr from base below limit
                  do
               (let ((index (alien-funcall
                             (extern-alien "simple_fun_index"
                                           (function int unsigned unsigned))
                             base ptr)))
                 (unless (eql index -1)
                   (let ((tagged-fun (logior ptr sb-vm:fun-pointer-lowtag)))
                     (assert (properly-tagged-p tagged-fun))
                     (incf count)
                     #+nil
                     (format t "~x -> ~d (~a)~%"
                             ptr index (sb-kernel:make-lisp-obj tagged-fun))))))
            (assert (= count n))))))))

(with-test (:name :repeatable-fasl)
  (with-scratch-file (output1 "fasl")
    (compile-file "bug-414.lisp" ; compile this file, why not
                  ::output-file output1 :verbose nil :print nil)
    (with-scratch-file (output2 "fasl")
      (compile-file "bug-414.lisp" ; compile this file, why not
                    ::output-file output2 :verbose nil :print nil)
      (with-open-file (fasl1 output1 :element-type '(unsigned-byte 8))
        (with-open-file (fasl2 output2 :element-type '(unsigned-byte 8))
          (assert (= (file-length fasl1) (file-length fasl2)))
          (loop repeat (file-length fasl1)
                do (assert (= (read-byte fasl1) (read-byte fasl2)))))))))
