/[cmucl]/src/compiler/checkgen.lisp
ViewVC logotype

Diff of /src/compiler/checkgen.lisp

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

revision 1.24.2.4 by dtc, Sun Jul 9 14:00:18 2000 UTC revision 1.24.2.5 by dtc, Sun Jul 9 14:03:12 2000 UTC
# Line 140  Line 140 
140            types))            types))
141    
142    
143    ;;; Values-types-asserted  --  Internal
144    ;;;
145    ;;;    Like values-types, but when an argument is proven to be delivered,
146    ;;; convert asserted optional and rest arguments to required arguments. This
147    ;;; makes it clear that these required arguments may all be type checked.
148    ;;;
149    (defun values-types-asserted (atype ptype)
150      (declare (type ctype atype ptype))
151      (cond ((eq atype *wild-type*)
152             (values nil :unknown))
153            ((not (values-type-p atype))
154             (values (list atype) 1))
155            ((or (args-type-keyp atype)
156                 (args-type-allowp atype))
157             (values nil :unknown))
158            (t
159             (let* ((ptype (kernel::coerce-to-values ptype))
160                    (preq (args-type-required ptype))
161                    (popt (args-type-optional ptype))
162                    (prest (args-type-rest ptype)))
163               (collect ((types))
164                 (do ((args (args-type-required atype) (rest args)))
165                     ((endp args))
166                   (if (or (pop preq) (pop popt) prest)
167                       (types (single-value-type (first args)))
168                       (return-from values-types-asserted (values nil :unknown))))
169                 (do ((args (args-type-optional atype) (rest args)))
170                     ((endp args))
171                   (if (pop preq)
172                       (types (single-value-type (first args)))
173                       (return-from values-types-asserted (values nil :unknown))))
174                 (let ((arest (args-type-rest atype)))
175                   (when arest
176                     (do ((arg (pop preq) (pop preq)))
177                         ((null arg))
178                       (types (single-value-type arest)))
179                     (when (or popt prest)
180                       (return-from values-types-asserted (values nil :unknown)))))
181                 (values (types) (length (types))))))))
182    
183    
184  ;;; Switch to disable check complementing, for evaluation.  ;;; Switch to disable check complementing, for evaluation.
185  ;;;  ;;;
186  (defvar *complement-type-checks* t)  (defvar *complement-type-checks* t)
# Line 243  Line 284 
284          (dest (continuation-dest cont)))          (dest (continuation-dest cont)))
285      (assert (not (eq atype *wild-type*)))      (assert (not (eq atype *wild-type*)))
286      (multiple-value-bind (types count)      (multiple-value-bind (types count)
287          (values-types atype)          (values-types-asserted atype (continuation-proven-type cont))
288        (cond ((not (eq count :unknown))        (cond ((not (eq count :unknown))
289               (let ((types (no-function-types types)))               (let ((types (no-function-types types)))
290                 (if (or (exit-p dest)                 (if (or (exit-p dest)

Legend:
Removed from v.1.24.2.4  
changed lines
  Added in v.1.24.2.5

  ViewVC Help
Powered by ViewVC 1.1.5