tests/fwdref-layout.impure.lisp

   1
   2 ;;; Regression tests for bugs cited in
   3 ;;; https://groups.google.com/g/sbcl-devel/c/4XTJ9hEUngM/m/B5-iQxdTAAAJ
   4
   5 ;;; 1. loading an externalized literal prior to seeing a %DEFSTRUCT
   6 ;;;    and %TARGET-DEFSTRUCT for the type.
   7 ;;     Presence of raw slots is irrelevant.
   8 (with-test (:name :literal-before-defstruct)
   9   (with-scratch-file (srcname "lisp")
  10     (with-scratch-file (fasl "fasl")
  11       (with-open-file (src srcname :direction :output)
  12         (print '(in-package "STRUCT") src)
  13         (print '(eval-when (:compile-toplevel :load-toplevel)
  14                  (defstruct charstruc (c #\a :type character)))
  15                src)
  16         (print '(eval-when (:compile-toplevel)
  17                  (defmethod make-load-form ((x charstruc) &optional e)
  18                    (make-load-form-saving-slots x :environment e)))
  19                src)
  20         ;; Write as a string because #S() won't work until CHARSTRUC is compiled
  21         (write-string "(defparameter *s* #s(charstruc :c #\\z))" src))
  22       (make-package "STRUCT" :use '("CL"))
  23       (compile-file srcname :output-file fasl :verbose nil)
  24       (delete-package "STRUCT")
  25       (make-package "STRUCT" :use '("CL"))
  26       (load fasl))))
  27
  28 ;;; 2. referencing a layout and then defining the structure
  29 ;;;    could fail if there are raw slots.
  30 (with-test (:name :no-spurious-redef-warning)
  31   (with-scratch-file (srcname "lisp")
  32     (with-scratch-file (fasl "fasl")
  33       (with-open-file (src srcname :direction :output)
  34         (let ((defstruct
  35                   `(defstruct (big (:predicate nil))
  36                      (first t)
  37                      ,@(loop for i below sb-vm:n-word-bits
  38                              collect `(,(sb-int:symbolicate "RAW" i)
  39                                         0 :type cl:double-float))
  40                      ,@(loop for i below 5
  41                              collect `(,(sb-int:symbolicate "MORE" i) nil)))))
  42           (print '(in-package "STRUCT") src)
  43           (print `(eval-when (:compile-toplevel) ,defstruct) src) ; for compiling a type-check
  44           (print `(defun bigp (x) (typep x 'big)) src)
  45           (print defstruct src)))
  46       ;; Reusing the same package as from test #1
  47       ;; (make-package "STRUCT" :use '("CL"))
  48       (compile-file srcname :output-file fasl :verbose nil)
  49       (delete-package "STRUCT")
  50       (make-package "STRUCT" :use '("CL"))
  51       (load fasl))))