tests/compiler.impure-cload.lisp

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