tests/compiler.impure-cload.lisp

   1 (eval-when (:compile-toplevel :load-toplevel :execute)
   2   (load "assertoid.lisp")
   3   (use-package "ASSERTOID"))
   4
   5 ;;; bug 254: compiler falure
   6 (defpackage :bug254 (:use :cl))
   7 (in-package :bug254)
   8 (declaim (optimize (safety 3) (debug 2) (speed 2) (space 1)))
   9 (defstruct foo
  10   (uhw2 nil :type (or package null)))
  11 (macrolet ((defprojection (variant &key lexpr eexpr)
  12              (let ()
  13                `(defmethod uu ((foo foo))
  14                   (let ((uhw2 (foo.uhw2 bar)))
  15                     (let ()
  16                       (u-flunt uhw2
  17                                (baz (funcall ,lexpr south east 1)))))))))
  18   (defprojection h
  19       :lexpr (lambda (south east sched)
  20                (flet ((bd (x) (bref x sched)))
  21                  (let ((avecname (gafp)))
  22                    (declare (type (vector t) avecname))
  23                    (multiple-value-prog1
  24                        (progn
  25                          (setf (avec.count avecname) (length rest))
  26                          (setf (aref avecname 0) (bd (h south)))
  27                          (setf (aref avecname 1) (bd (h east)))
  28                          (stub avecname))
  29                      (paip avecname)))))
  30       :eexpr (lambda (south east))))
  31 (delete-package :bug254)
  32
  33 ;;; bug 255
  34 (defpackage :bug255 (:use :cl))
  35 (in-package :bug255)
  36 (declaim (optimize (safety 3) (debug 2) (speed 2) (space 1)))
  37 (defvar *1*)
  38 (defvar *2*)
  39 (defstruct v a b)
  40 (defstruct w)
  41 (defstruct yam (v nil :type (or v null)))
  42 (defstruct un u)
  43 (defstruct (bod (:include un)) bo)
  44 (defstruct (bad (:include bod)) ba)
  45 (declaim (ftype (function ((or w bad) (or w bad)) (values)) %ufm))
  46 (defun %ufm (base bound) (froj base bound *1*) (values))
  47 (declaim (ftype (function ((vector t)) (or w bad)) %pu))
  48 (defun %pu (pds) *2*)
  49 (defun uu (yam)
  50   (let ((v (yam-v az)))
  51     (%ufm v
  52           (flet ((project (x) (frob x 0)))
  53             (let ((avecname *1*))
  54               (multiple-value-prog1
  55                   (progn (%pu avecname))
  56                 (frob)))))))
  57 (delete-package :bug255)
  58
  59 ;;; bug 148
  60 (defpackage :bug148 (:use :cl))
  61 (in-package :bug148)
  62
  63 (defvar *thing*)
  64 (defvar *zoom*)
  65 (defstruct foo bar bletch)
  66 (defun %zeep ()
  67   (labels ((kidify1 (kid)
  68              )
  69            (kid-frob (kid)
  70              (if *thing*
  71                  (setf sweptm
  72                        (m+ (frobnicate kid)
  73                            sweptm))
  74                  (kidify1 kid))))
  75     (declare (inline kid-frob))
  76     (map nil
  77          #'kid-frob
  78          (the simple-vector (foo-bar perd)))))
  79
  80 (declaim (optimize (safety 3) (speed 2) (space 1)))
  81 (defvar *foo*)
  82 (defvar *bar*)
  83 (defun u-b-sra (x r ad0 &optional ad1 &rest ad-list)
  84   (labels ((c.frob (c0)
  85              (let ()
  86                (when *foo*
  87                  (vector-push-extend c0 *bar*))))
  88            (ad.frob (ad)
  89              (if *foo*
  90                  (map nil #'ad.frob (the (vector t) *bar*))
  91                  (dolist (b *bar*)
  92                    (c.frob b)))))
  93     (declare (inline c.frob ad.frob))   ; 'til DYNAMIC-EXTENT
  94     (ad.frob ad0)))
  95
  96 (defun bug148-3 (ad0)
  97   (declare (special *foo* *bar*))
  98   (declare (optimize (safety 3) (speed 2) (space 1)))
  99   (labels ((c.frob ())
 100            (ad.frob (ad)
 101              (if *foo*
 102                  (mapc #'ad.frob *bar*)
 103                  (dolist (b *bar*)
 104                    (c.frob)))))
 105     (declare (inline c.frob ad.frob))
 106     (ad.frob ad0)))
 107
 108 (defun bug148-4 (ad0)
 109   (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
 110   (labels ((c.frob (x)
 111              (* 7 x))
 112            (ad.frob (ad)
 113              (loop for b in ad
 114                    collect (c.frob b))))
 115     (declare (inline c.frob ad.frob))
 116     (list (the list ad0)
 117           (funcall (if (listp ad0) #'ad.frob #'print) ad0)
 118           (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0)))))
 119
 120 (assert (equal (eval '(bug148-4 '(1 2 3)))
 121                '((1 2 3) (7 14 21) (21 14 7))))
 122
 123 (delete-package :bug148)
 124
 125 ;;; bug 258
 126 (defpackage :bug258 (:use :cl))
 127 (in-package :bug258)
 128
 129 (defun u-b-sra (ad0)
 130   (declare (special *foo* *bar*))
 131   (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
 132   (labels ((c.frob (x)
 133              (1- x))
 134            (ad.frob (ad)
 135              (mapcar #'c.frob ad)))
 136     (declare (inline c.frob ad.frob))
 137     (list (the list ad0)
 138           (funcall (if (listp ad0) #'ad.frob #'print) ad0)
 139           (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0)))))
 140
 141 (assert (equal (u-b-sra '(4 9 7))
 142                '((4 9 7) (3 8 6) (6 8 3))))
 143
 144 (delete-package :bug258)
 145
 146 (in-package :cl-user)
 147
 148 ;;;
 149 (defun bug233a (x)
 150   (declare (optimize (speed 2) (safety 3)))
 151   (let ((y 0d0))
 152     (values
 153      (the double-float x)
 154      (setq y (+ x 1d0))
 155      (setq x 3d0)
 156      (funcall (eval ''list) y (+ y 2d0) (* y 3d0)))))
 157 (assert (raises-error? (bug233a 4) type-error))
 158
 159 \f
 160 (sb-ext:quit :unix-status 104)