[Openmcl-cvs-notifications] r10722 - /trunk/source/lib/setf.lisp

[gz at clozure.com]

Author: gz
Date: Fri Sep 12 10:13:55 2008
New Revision: 10722

Log:
make incf/decf propagate explicit type info, so that (incf (the fixnum (svr=
ef x y))) knows to do a fixnum addition without overflow checking

Modified:
    trunk/source/lib/setf.lisp

Modified: trunk/source/lib/setf.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/setf.lisp (original)
+++ trunk/source/lib/setf.lisp Fri Sep 12 10:13:55 2008
@@ -315,11 +315,17 @@
     `(setq ,place (+ ,place ,delta))
     (multiple-value-bind (dummies vals newval setter getter)
         (get-setf-method place env)
-      (let ((d (gensym)))
+      (let ((d (gensym))
+            ;; Doesn't propagate inferred types, but better than nothing.
+            (d-type (cond ((constantp delta) (type-of delta))
+                          ((and (consp delta) (eq (car delta) 'the)) (cadr=
 delta))
+                          (t t)))
+            (v-type (if (and (consp place) (eq (car place) 'the)) (cadr pl=
ace) t)))
         `(let* (,@(mapcar #'list dummies vals)
                 (,d ,delta)
                 (,(car newval) (+ ,getter ,d)))
-          ,setter)))))
+           (declare (type ,d-type ,d) (type ,v-type ,(car newval)))
+           ,setter)))))
 =

 (defmacro decf (place &optional (delta 1) &environment env)
   "The first argument is some location holding a number.  This number is
@@ -331,11 +337,17 @@
     `(setq ,place (- ,place ,delta))
     (multiple-value-bind (dummies vals newval setter getter)
         (get-setf-method place env)
-      (let ((d (gensym)))
+      (let* ((d (gensym))
+             ;; Doesn't propagate inferred types, but better than nothing.
+             (d-type (cond ((constantp delta) (type-of delta))
+                           ((and (consp delta) (eq (car delta) 'the)) (cad=
r delta))
+                           (t t)))
+             (v-type (if (and (consp place) (eq (car place) 'the)) (cadr p=
lace) t)))
         `(let* (,@(mapcar #'list dummies vals)
                 (,d ,delta)
                 (,(car newval) (- ,getter ,d)))
-          ,setter)))))
+           (declare (type ,d-type ,d) (type ,v-type ,(car newval)))
+           ,setter)))))
   =

 (defmacro psetf (&whole call &rest pairs &environment env)  ;same structur=
e as psetq
   "This is to SETF as PSETQ is to SETQ. Args are alternating place