tests/compiler.impure-cload.lisp

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