SBCL to wager that this (undefined in ANSI) operation would be safe.
3:
+ a:
ANSI specifies that a type mismatch in a structure slot
initialization value should not cause a warning.
WORKAROUND:
Such code should compile without complaint and work correctly either
on SBCL or on any other completely compliant Common Lisp system.
+ b: &AUX argument in a boa-constructor without a default value means
+ "do not initilize this slot" and does not cause type error. But
+ an error may be signalled at read time and it would be good if
+ SBCL did it.
+
6:
bogus warnings about undefined functions for magic functions like
SB!C::%%DEFUN and SB!C::%DEFCONSTANT when cross-compiling files
(see bug 203)
+ c. (defun foo (x y)
+ (locally (declare (type fixnum x y))
+ (+ x (* 2 y))))
+ (foo 1.1 2) => 5.1
+
194: "no error from (THE REAL '(1 2 3)) in some cases"
fixed parts:
a. In sbcl-0.7.7.9,
* fixed bug 62: constraints were not propagated into a loop.
* fixed bug in embedded calls of SORT (reported and investigated by
Wolfgang Jenkner).
- * fixed bugs identified by Paul F. Dietz related to printing and
- reading of arrays with some dimensions having length 0. (thanks
- to Gerd Moellmann)
+ * fixed some bugs revealed by Paul Dietz' test suite:
+ ** printing and reading of arrays with some dimensions having
+ length 0 (thanks to Gerd Moellmann);
+ ** BOA constructor with &AUX argument without a default value does
+ not cause a type error;
+ ** CONSTANTP now returns true for all self-evaluating objects.
planned incompatible changes in 0.7.x:
* (not done yet, but planned:) When the profiling interface settles
(length v)))
* IR1 does not optimize away (MAKE-LIST N).
-
-* IR1 thinks that the type of V in (LENGTH V) is (OR LIST SIMPLE-VECTOR), not
- SIMPLE-VECTOR.
--------------------------------------------------------------------------------
(defun bar (v1 v2)
(declare (optimize (speed 3) (safety 0) (space 2))
(incf x)))))))
(format t "~A~%" x)))
--------------------------------------------------------------------------------
+(defun foo (x)
+ (declare (optimize speed (debug 0)))
+ (if (< x 0) x (foo (1- x))))
+
+SBCL generates a full call of FOO (but CMUCL does not).
+--------------------------------------------------------------------------------
+(defun foo (d)
+ (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (declare (type (double-float 0d0 1d0) d))
+ (loop for i fixnum from 1 to 5
+ for x1 double-float = (sin d) ;;; !!!
+ do (loop for j fixnum from 1 to 4
+ sum x1 double-float)))
+
+Without the marked declaration Python will use boxed representation for X1.
+
+This is equivalent to
+
+(let ((x nil))
+ (setq x 0d0)
+ ;; use of X as DOUBLE-FLOAT
+)
+
+The initial binding is effectless, and without it X is of type
+DOUBLE-FLOAT. Unhopefully, IR1 does not optimize away effectless
+SETs/bindings, and IR2 does not perform type inference.
+--------------------------------------------------------------------------------
+(defun foo (x)
+ (if (= (cond ((irgh x) 0)
+ ((buh x) 1)
+ (t 2))
+ 0)
+ :yes
+ :no))
+
+This code could be optimized to
+
+(defun foo (x)
+ (cond ((irgh x) :yes)
+ ((buh x) :no)
+ (t :no)))
+--------------------------------------------------------------------------------
;;; structures can have arbitrary subtypes of VECTOR, not necessarily
;;; SIMPLE-VECTOR.)
;;; * STRUCTURE structures can have raw slots that must also be
-;;; allocated and indirectly referenced.
+;;; allocated and indirectly referenced.
(defun create-vector-constructor (dd cons-name arglist vars types values)
(let ((temp (gensym))
(etype (dd-element-type dd)))
`(setf (aref ,temp ,(cdr x)) ',(car x)))
(find-name-indices dd))
,@(mapcar (lambda (dsd value)
- `(setf (aref ,temp ,(dsd-index dsd)) ,value))
+ (unless (eq value '.do-not-initialize-slot.)
+ `(setf (aref ,temp ,(dsd-index dsd)) ,value)))
(dd-slots dd) values)
,temp))))
(defun create-list-constructor (dd cons-name arglist vars types values)
(dolist (x (find-name-indices dd))
(setf (elt vals (cdr x)) `',(car x)))
(loop for dsd in (dd-slots dd) and val in values do
- (setf (elt vals (dsd-index dsd)) val))
+ (setf (elt vals (dsd-index dsd))
+ (if (eq val '.do-not-initialize-slot.) 0 val)))
`(defun ,cons-name ,arglist
(declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
;; because the slot might be :READ-ONLY, so we
;; whip up new LAMBDA representations of slot
;; setters for the occasion.)
- `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
+ (unless (eq value '.do-not-initialize-slot.)
+ `(,(slot-setter-lambda-form dd dsd) ,value ,instance)))
(dd-slots dd)
values)
,instance))))
(parse-lambda-list (second boa))
(collect ((arglist)
(vars)
- (types))
+ (types)
+ (skipped-vars))
(labels ((get-slot (name)
(let ((res (find name (dd-slots defstruct)
:test #'string=
(arglist arg)
(vars arg)
(types (get-slot arg)))
-
+
(when opt
(arglist '&optional)
(dolist (arg opt)
(when auxp
(arglist '&aux)
(dolist (arg aux)
- (let* ((arg (if (consp arg) arg (list arg)))
- (var (first arg)))
- (arglist arg)
- (vars var)
- (types (get-slot var))))))
+ (arglist arg)
+ (if (proper-list-of-length-p arg 2)
+ (let ((var (first arg)))
+ (vars var)
+ (types (get-slot var)))
+ (skipped-vars (if (consp arg) (first arg) arg))))))
(funcall creator defstruct (first boa)
(arglist) (vars) (types)
- (mapcar (lambda (slot)
- (or (find (dsd-name slot) (vars) :test #'string=)
- (dsd-default slot)))
- (dd-slots defstruct))))))
+ (loop for slot in (dd-slots defstruct)
+ for name = (dsd-name slot)
+ collect (if (find name (skipped-vars) :test #'string=)
+ '.do-not-initialize-slot.
+ (or (find (dsd-name slot) (vars) :test #'string=)
+ (dsd-default slot))))))))
;;; Grovel the constructor options, and decide what constructors (if
;;; any) to create.
#!+sb-doc
"True of any Lisp object that has a constant value: types that eval to
themselves, keywords, constants, and list whose car is QUOTE."
- ;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here?
- ;; They eval to themselves..
- ;;
;; FIXME: Someday it would be nice to make the code recognize foldable
;; functions and call itself recursively on their arguments, so that
;; more of the examples in the ANSI CL definition are recognized.
;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
(declare (ignore environment))
(typecase object
- (number t)
- (character t)
- (array t)
;; (Note that the following test on INFO catches KEYWORDs as well as
;; explicitly DEFCONSTANT symbols.)
(symbol (eq (info :variable :kind object) :constant))
- (list (eq (car object) 'quote))))
+ (list (eq (car object) 'quote))
+ (t t)))
(declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
(defun sb!xc:macro-function (symbol &optional env)
;; From the user's point of view, LET-converting something that
;; has a name is inlining it. (The user can't see what we're doing
;; with anonymous things, and suppressing inlining
- ;; for such things can easily give Python acute indigestion, so
+ ;; for such things can easily give Python acute indigestion, so
;; we don't.)
(when (leaf-has-source-name-p clambda)
;; ANSI requires that explicit NOTINLINE be respected.
(assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
type-error))
+;;; An &AUX variable in a boa-constructor without a default value
+;;; means "do not initialize slot" and does not cause type error
+(defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c))))
+ (a #\! :type (integer 1 2))
+ (b #\? :type (integer 3 4))
+ (c #\# :type (integer 5 6)))
+(let ((s (make-boa-saux)))
+ (setf (boa-saux-a s) 1)
+ (setf (boa-saux-c s) 5)
+ (assert (eql (boa-saux-a s) 1))
+ (assert (eql (boa-saux-b s) 3))
+ (assert (eql (boa-saux-c s) 5)))
+
;;; basic inheritance
(defstruct (astronaut (:include person)
(:conc-name astro-))
;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
(defstruct (binop (:type list) :named (:initial-offset 2))
- (operator '? :type symbol)
+ (operator '? :type symbol)
operand-1
operand-2)
(defstruct (annotated-binop (:type list)
(symbol-macrolet ((foo (symbol-macrolet-bar 1)))
(defmacro symbol-macrolet-bar (x) `(+ ,x 1))
(assert (= foo 2)))
+
+;;; Bug reported by Paul Dietz: CONSTANTP on a self-evaluating object
+;;; must return T
+
+(assert (constantp (find-class 'symbol)))
+(assert (constantp #p""))
\f
;;; success
(sb-ext:quit :unix-status 104)
-
-
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.11.9"
+"0.7.11.10"
projects / sbcl.git / commitdiff