/[cmucl]/src/code/macros.lisp
ViewVC logotype

Diff of /src/code/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.103 by rtoy, Wed Dec 15 16:21:58 2004 UTC revision 1.103.2.1 by rtoy, Mon Dec 19 01:09:51 2005 UTC
# Line 235  Line 235 
235                     ,@(when doc `(,doc)))))))                     ,@(when doc `(,doc)))))))
236  ;;;  ;;;
237  (defun %deftype (name expander &optional doc)  (defun %deftype (name expander &optional doc)
238      (when (info declaration recognized name)
239        (error "Deftype already names a declaration: ~S." name))
240    (ecase (info type kind name)    (ecase (info type kind name)
241      (:primitive      (:primitive
242       (when *type-system-initialized*       (when *type-system-initialized*
# Line 544  Line 546 
546  (defmacro multiple-value-setq (varlist value-form)  (defmacro multiple-value-setq (varlist value-form)
547    (unless (and (listp varlist) (every #'symbolp varlist))    (unless (and (listp varlist) (every #'symbolp varlist))
548      (simple-program-error "Varlist is not a list of symbols: ~S." varlist))      (simple-program-error "Varlist is not a list of symbols: ~S." varlist))
549    `(values (setf (values ,@varlist) ,value-form)))    (if varlist
550          `(values (setf (values ,@varlist) ,value-form))
551          `(values ,value-form)))
552    
553  ;;;  ;;;
554  (defmacro multiple-value-bind (varlist value-form &body body)  (defmacro multiple-value-bind (varlist value-form &body body)
# Line 1510  Line 1514 
1514  (defun check-type-error (place place-value type type-string)  (defun check-type-error (place place-value type type-string)
1515    (let ((cond (if type-string    (let ((cond (if type-string
1516                    (make-condition 'simple-type-error                    (make-condition 'simple-type-error
1517                                    :datum place :expected-type type                                    :datum place-value :expected-type type
1518                                    :format-control                                    :format-control
1519                                    "The value of ~S is ~S, which is not ~A."                                    "The value of ~S is ~S, which is not ~A."
1520                                    :format-arguments                                    :format-arguments
1521                                    (list place place-value type-string))                                    (list place place-value type-string))
1522                    (make-condition 'simple-type-error                    (make-condition 'simple-type-error
1523                                    :datum place :expected-type type                                    :datum place-value :expected-type type
1524                                    :format-control                                    :format-control
1525                            "The value of ~S is ~S, which is not of type ~S."                                    "The value of ~S is ~S, which is not of type ~S."
1526                                    :format-arguments                                    :format-arguments
1527                                    (list place place-value type)))))                                    (list place place-value type)))))
1528      (restart-case (error cond)      (restart-case (error cond)
# Line 1590  Line 1594 
1594                      `(make-string-input-stream ,string ,(or start 0) ,end)))))                      `(make-string-input-stream ,string ,(or start 0) ,end)))))
1595         ,@decls         ,@decls
1596         (unwind-protect         (unwind-protect
1597             (progn ,@forms)              (multiple-value-prog1
1598           (close ,var)                  (progn ,@forms)
1599           ,@(if index `((setf ,index (string-input-stream-current ,var))))))))                ,@(when index
1600                       `((setf ,index (string-input-stream-current ,var)))))
1601             (close ,var)))))
1602    
1603    
1604  (defmacro with-output-to-string ((var &optional string &key element-type)  (defmacro with-output-to-string ((var &optional string &key element-type)
# Line 1617  Line 1623 
1623    
1624  ;;;; Iteration macros:  ;;;; Iteration macros:
1625    
1626    ;;; Make sure we iterate the given number of times, independent of
1627    ;;; what the body might do to the index variable.  We do this by
1628    ;;; repeatedly binding the var in the body and also in the result
1629    ;;; form.  We also spuriously reference the var in case the body or
1630    ;;; result form don't reference the var either.  (Mostly modeled on
1631    ;;; the dolist macro below.)
1632  (defmacro dotimes ((var count &optional (result nil)) &body body)  (defmacro dotimes ((var count &optional (result nil)) &body body)
1633    (cond ((numberp count)    (let ((count-var (gensym "CTR-")))
1634           `(do ((,var 0 (1+ ,var)))      (multiple-value-bind (forms decls)
1635                ((>= ,var ,count) ,result)          (parse-body body nil nil)
1636              (declare (type (integer 0 ,count) ,var))        (cond ((numberp count)
1637              ,@body))               `(do ((,count-var 0 (1+ ,count-var)))
1638          (t (let ((v1 (gensym)))                    ((>= ,count-var ,count)
1639               `(do ((,var 0 (1+ ,var)) (,v1 ,count))                     (let ((,var ,count-var))
1640                    ((>= ,var ,v1) ,result)                       ,var
1641                  (declare (type unsigned-byte ,var))                       ,result))
1642                  ,@body)))))                  (declare (type (integer 0 ,count) ,count-var))
1643                    (let ((,var ,count-var))
1644                      ,@decls
1645                      ,var
1646                      (tagbody
1647                         ,@forms))))
1648                (t (let ((v1 (gensym)))
1649                     `(do ((,count-var 0 (1+ ,count-var))
1650                           (,v1 ,count))
1651                          ((>= ,count-var ,v1)
1652                           (let ((,var ,count-var))
1653                             ,var
1654                             ,result))
1655                        (declare (type unsigned-byte ,count-var))
1656                        (let ((,var ,count-var))
1657                          ,@decls
1658                          ,var
1659                          (tagbody
1660                             ,@forms)))))))))
1661    
1662    
1663  ;;; We repeatedly bind the var instead of setting it so that we never give the  ;;; We repeatedly bind the var instead of setting it so that we never give the

Legend:
Removed from v.1.103  
changed lines
  Added in v.1.103.2.1

  ViewVC Help
Powered by ViewVC 1.1.5