/[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.5 by dtc, Sun Jul 9 14:03:12 2000 UTC revision 1.36 by rtoy, Tue Apr 20 17:57:46 2010 UTC
# Line 17  Line 17 
17  ;;; Written by Rob MacLachlan  ;;; Written by Rob MacLachlan
18  ;;;  ;;;
19  (in-package "C")  (in-package "C")
20    (intl:textdomain "cmucl")
21    
22    
23  ;;;; Cost estimation:  ;;;; Cost estimation:
# Line 70  Line 71 
71             (dolist (mem (union-type-types type))             (dolist (mem (union-type-types type))
72               (res (type-test-cost mem)))               (res (type-test-cost mem)))
73             (res)))             (res)))
74            (intersection-type
75             (collect ((res 0 +))
76               (dolist (mem (intersection-type-types type))
77                 (res (type-test-cost mem)))
78               (res)))
79          (member-type          (member-type
80           (* (length (member-type-members type))           (* (length (member-type-members type))
81              (function-cost 'eq)))              (function-cost 'eq)))
# Line 148  Line 154 
154  ;;;  ;;;
155  (defun values-types-asserted (atype ptype)  (defun values-types-asserted (atype ptype)
156    (declare (type ctype atype ptype))    (declare (type ctype atype ptype))
157    (cond ((eq atype *wild-type*)    (flet ((give-up ()
158           (values nil :unknown))             (return-from values-types-asserted (values nil :unknown))))
159          ((not (values-type-p atype))      (cond ((eq atype *wild-type*)
160           (values (list atype) 1))             (give-up))
161          ((or (args-type-keyp atype)            ((not (values-type-p atype))
162               (args-type-allowp atype))             (values (list atype) 1))
163           (values nil :unknown))            ((or (values-type-keyp atype)
164          (t                 (values-type-allowp atype))
165           (let* ((ptype (kernel::coerce-to-values ptype))             (give-up))
166                  (preq (args-type-required ptype))            ;;
167                  (popt (args-type-optional ptype))            ;; FIXME: Values type checking is done with a form like
168                  (prest (args-type-rest ptype)))            ;;
169             (collect ((types))            ;; (multiple-value-bind (x y z) <form>
170               (do ((args (args-type-required atype) (rest args)))            ;;   <type checks for x y z>
171                   ((endp args))            ;;   (values x y z))
172                 (if (or (pop preq) (pop popt) prest)            ;;
173                     (types (single-value-type (first args)))            ;; see Make-Type-Check-Form.  This has the unfortunate
174                     (return-from values-types-asserted (values nil :unknown))))            ;; effect of chopping values when <form> actually returns
175               (do ((args (args-type-optional atype) (rest args)))            ;; more values than are being checked.  The downside of
176                   ((endp args))            ;; including this is that it produces a lot of notes.
177                 (if (pop preq)            #+nil
178                     (types (single-value-type (first args)))            ((or (eq *wild-type* ptype)
179                     (return-from values-types-asserted (values nil :unknown))))                 (and (values-type-p ptype)
180               (let ((arest (args-type-rest atype)))                      (or (values-type-optional ptype)
181                 (when arest                          (values-type-rest ptype))))
182                   (do ((arg (pop preq) (pop preq)))             (give-up))
183                       ((null arg))            (t
184                     (types (single-value-type arest)))             (let* ((ptype (kernel::coerce-to-values ptype))
185                   (when (or popt prest)                    (preq (values-type-required ptype))
186                     (return-from values-types-asserted (values nil :unknown)))))                    (popt (values-type-optional ptype))
187               (values (types) (length (types))))))))                    (prest (values-type-rest ptype)))
188                 ;;
189                 ;; FIXME: ptype = * is not handled right, I think
190                 ;; because * = (VALUES &REST T).  It never was
191                 ;; handled right.  Gerd 2003-05-08.
192                 (collect ((types))
193                   (dolist (type (values-type-required atype))
194                     (if (or (pop preq) (pop popt) prest)
195                         (types (single-value-type type))
196                         (give-up)))
197                   (dolist (type (values-type-optional atype))
198                     (if (pop preq)
199                         (types (single-value-type type))
200                         (give-up)))
201                   (let ((arest (values-type-rest atype)))
202                     (when arest
203                       (loop with rest-type = (single-value-type arest)
204                             for arg = (pop preq) while arg do
205                               (types rest-type))
206                       (when (or popt prest)
207                         (give-up))))
208                   (values (types) (length (types)))))))))
209    
210    
211  ;;; Switch to disable check complementing, for evaluation.  ;;; Switch to disable check complementing, for evaluation.
# Line 278  Line 305 
305  ;;; destination receives only a single value, a :hairy type check is  ;;; destination receives only a single value, a :hairy type check is
306  ;;; generated for the single-values-type of the asserted type.  ;;; generated for the single-values-type of the asserted type.
307  ;;;  ;;;
308  (defun continuation-check-types (cont)  (defun continuation-check-types (cont &optional force-hairy)
309    (declare (type continuation cont))    (declare (type continuation cont))
310    (let ((atype (continuation-asserted-type cont))    (let ((atype (continuation-asserted-type cont))
311          (dest (continuation-dest cont)))          (dest (continuation-dest cont))
312            (proven (continuation-proven-type cont)))
313      (assert (not (eq atype *wild-type*)))      (assert (not (eq atype *wild-type*)))
314      (multiple-value-bind (types count)      (multiple-value-bind (types count)
315          (values-types-asserted atype (continuation-proven-type cont))          (values-types-asserted atype proven)
316        (cond ((not (eq count :unknown))        (cond ((not (eq count :unknown))
317               (let ((types (no-function-types types)))               (let ((types (no-function-types types)))
318                 (if (or (exit-p dest)                 (if (or (exit-p dest)
# Line 295  Line 323 
323                                (declare (ignore ignore))                                (declare (ignore ignore))
324                                (eq count :unknown))))                                (eq count :unknown))))
325                     (maybe-negate-check cont types t)                     (maybe-negate-check cont types t)
326                     (maybe-negate-check cont types nil))))                     (maybe-negate-check cont types force-hairy))))
327                #+nil
328                ((eq *wild-type* proven)
329                 (values :too-hairy nil))
330              ((and (mv-combination-p dest)              ((and (mv-combination-p dest)
331                    (eq (basic-combination-kind dest) :local))                    (eq (basic-combination-kind dest) :local))
332               (assert (values-type-p atype))               (assert (values-type-p atype))
333               (assert (null (args-type-required atype)))               (maybe-negate-check cont (append (args-type-required atype)
334               (maybe-negate-check cont (args-type-optional atype) nil))                                                (args-type-optional atype))
335                                     force-hairy))
336              ((or (exit-p dest) (return-p dest) (mv-combination-p dest))              ((or (exit-p dest) (return-p dest) (mv-combination-p dest))
337               (values :too-hairy nil))               (values :too-hairy nil))
338              (t              (t
# Line 338  Line 370 
370    (let ((dest (continuation-dest cont)))    (let ((dest (continuation-dest cont)))
371      (cond ((eq (continuation-type-check cont) :error)      (cond ((eq (continuation-type-check cont) :error)
372             (if (and (combination-p dest) (eq (combination-kind dest) :error))             (if (and (combination-p dest) (eq (combination-kind dest) :error))
373                 nil                 (policy dest (= safety 3))
374                 t))                 t))
375            ((or (not dest)            ((or (not dest)
376                 (policy dest (zerop safety)))                 (policy dest (zerop safety)))
# Line 486  Line 518 
518                            (eq (combination-kind dest) :local))                            (eq (combination-kind dest) :local))
519                   (let ((lambda (combination-lambda dest))                   (let ((lambda (combination-lambda dest))
520                         (pos (eposition cont (combination-args dest))))                         (pos (eposition cont (combination-args dest))))
521                     (format nil "~:[A possible~;The~] binding of ~S"                     (format nil (intl:gettext "~:[A possible~;The~] binding of ~S")
522                             (and (continuation-use cont)                             (and (continuation-use cont)
523                                  (eq (functional-kind lambda) :let))                                  (eq (functional-kind lambda) :let))
524                             (leaf-name (elt (lambda-vars lambda) pos)))))))                             (leaf-name (elt (lambda-vars lambda) pos)))))))
525      (cond ((eq dtype *empty-type*))      (cond ((eq dtype *empty-type*))
526            ((and (ref-p node) (constant-p (ref-leaf node)))            ((and (ref-p node) (constant-p (ref-leaf node)))
527             (compiler-warning "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~%  ~S"             (compiler-warning _N"~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~%  ~S"
528                               what atype-spec (constant-value (ref-leaf node))))                               what atype-spec (constant-value (ref-leaf node))))
529            (t            (t
530             (compiler-warning             (compiler-warning
531              "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"              _N"~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
532              what (type-specifier dtype) atype-spec))))              what (type-specifier dtype) atype-spec))))
533    (undefined-value))    (undefined-value))
534    
# Line 577  Line 609 
609    
610      (dolist (cont (conts))      (dolist (cont (conts))
611        (multiple-value-bind (check types)        (multiple-value-bind (check types)
612            (continuation-check-types cont)            (continuation-check-types
613               cont
614               (and (eq (continuation-%type-check cont) :error)
615                    (policy (continuation-dest cont) (= safety 3))))
616          (ecase check          (ecase check
617            (:simple)            (:simple)
618            (:hairy            (:hairy
# Line 587  Line 622 
622                    (*compiler-error-context* context))                    (*compiler-error-context* context))
623               (when (policy context (>= safety brevity))               (when (policy context (>= safety brevity))
624                 (compiler-note                 (compiler-note
625                  "Type assertion too complex to check:~% ~S."                  _N"Type assertion too complex to check:~% ~S."
626                  (type-specifier (continuation-asserted-type cont)))))                  (type-specifier (continuation-asserted-type cont)))))
627             (setf (continuation-%type-check cont) :deleted))))))             (setf (continuation-%type-check cont) :deleted))))))
628    

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

  ViewVC Help
Powered by ViewVC 1.1.5