191 |
|
|
192 |
(defun result-type-from-args (f args &aux tem) |
(defun result-type-from-args (f args &aux tem) |
193 |
(when (and (setq tem (get f 'return-type)) |
(when (and (setq tem (get f 'return-type)) |
194 |
(not (eq tem '*)) |
(not (eq tem '*))) |
195 |
(not (consp tem))) |
; (not (consp tem))) ;; propagate multiple-value types, CM 20041221 |
196 |
(let* ((be (and (not (cddr args)) (get f 'result-type-from-bounded-args))) |
(let* ((be (and (not (cddr args)) (get f 'result-type-from-bounded-args))) |
197 |
(ba (and be |
(ba (and be (funcall be f (car args) (cadr args))))) |
|
(or (atom be) |
|
|
(and (type>= (nil-to-t (car be)) (car args)) |
|
|
(type>= (nil-to-t (cadr be)) (cadr args)))) |
|
|
(super-range f (car args) (cadr args))))) |
|
198 |
(when ba |
(when ba |
199 |
(return-from result-type-from-args ba))) |
(return-from result-type-from-args ba))) |
200 |
(dolist (v '(inline-always inline-unsafe)) |
(dolist (v '(inline-always inline-unsafe)) |
478 |
((eq fname 'si:|#,|) |
((eq fname 'si:|#,|) |
479 |
(cmperr "Sharp-comma-macro was found in a bad place.")) |
(cmperr "Sharp-comma-macro was found in a bad place.")) |
480 |
(t (let* ((info (make-info |
(t (let* ((info (make-info |
481 |
:sp-change (null (get fname 'no-sp-change)))) |
:sp-change (null (get fname 'no-sp-change)))) |
482 |
(forms (c1args args info))) ;; info updated by args here |
(forms (c1args args info))) ;; info updated by args here |
483 |
(let ((return-type (get-return-type fname))) |
(let ((return-type (get-return-type fname))) |
484 |
(when return-type |
(when return-type |
485 |
(if (equal return-type '(*)) |
(if (equal return-type '(*)) |
486 |
(setf return-type nil) |
(setf return-type nil) |
487 |
(setf (info-type info) return-type)))) |
(setf (info-type info) return-type)))) |
488 |
(let ((arg-types (get-arg-types fname))) |
(let ((arg-types (get-arg-types fname))) |
489 |
;;; Add type information to the arguments. |
;;; Add type information to the arguments. |
490 |
(when arg-types |
(when arg-types |
491 |
(do ((fl forms (cdr fl)) |
(do ((fl forms (cdr fl)) |
492 |
(fl1 nil) |
(fl1 nil) |
493 |
(al args (cdr al))) |
(al args (cdr al))) |
494 |
((endp fl) |
((endp fl) |
495 |
(setq forms (reverse fl1))) |
(setq forms (reverse fl1))) |
496 |
(cond ((endp arg-types) (push (car fl) fl1)) |
(cond ((endp arg-types) (push (car fl) fl1)) |
497 |
(t (push (and-form-type (car arg-types) |
(t (push (and-form-type (car arg-types) |
498 |
(car fl) |
(car fl) |
499 |
(car al)) |
(car al)) |
500 |
fl1) |
fl1) |
501 |
(pop arg-types)))))) |
(pop arg-types)))))) |
502 |
(let ((arg-types (get fname 'arg-types))) |
(let ((arg-types (get fname 'arg-types))) |
503 |
;;; Check argument types. |
;;; Check argument types. |
504 |
(when arg-types |
(when arg-types |
505 |
(do ((fl forms (cdr fl)) |
(do ((fl forms (cdr fl)) |
506 |
(al args (cdr al))) |
(al args (cdr al))) |
507 |
((or (endp arg-types) (endp fl))) |
((or (endp arg-types) (endp fl))) |
508 |
(check-form-type (car arg-types) |
(check-form-type (car arg-types) |
509 |
(car fl) (car al)) |
(car fl) (car al)) |
510 |
(pop arg-types)))) |
(pop arg-types)))) |
511 |
(case fname |
(case fname |
512 |
(aref |
(aref |
513 |
(let ((etype (info-type (cadar forms)))) |
(let ((etype (info-type (cadar forms)))) |
514 |
(when (or (and (eq etype 'string) |
(when (or (and (eq etype 'string) |
515 |
(setq etype 'character)) |
(setq etype 'character)) |
516 |
(and (consp etype) |
(and (consp etype) |
517 |
(or (eq (car etype) 'array) |
(or (eq (car etype) 'array) |
518 |
(eq (car etype) 'vector)) |
(eq (car etype) 'vector)) |
519 |
(setq etype (cadr etype)))) |
(setq etype (cadr etype)))) |
520 |
(setq etype |
(setq etype |
521 |
(type-and (info-type info) etype)) |
(type-and (info-type info) etype)) |
522 |
(when (null etype) |
(when (null etype) |
523 |
(cmpwarn |
(cmpwarn |
524 |
"Type mismatch was found in ~s." |
"Type mismatch was found in ~s." |
525 |
(cons fname args))) |
(cons fname args))) |
526 |
(setf (info-type info) etype)))) |
(setf (info-type info) etype)))) |
527 |
(si:aset |
(si:aset |
528 |
(let ((etype (info-type (cadar forms)))) |
(let ((etype (info-type (cadar forms)))) |
529 |
(when (or (and (eq etype 'string) |
(when (or (and (eq etype 'string) |
530 |
(setq etype 'character)) |
(setq etype 'character)) |
531 |
(and (consp etype) |
(and (consp etype) |
532 |
(or (eq (car etype) 'array) |
(or (eq (car etype) 'array) |
533 |
(eq (car etype) 'vector)) |
(eq (car etype) 'vector)) |
534 |
(setq etype (cadr etype)))) |
(setq etype (cadr etype)))) |
535 |
(setq etype |
(setq etype |
536 |
(type-and (info-type info) |
(type-and (info-type info) |
537 |
(type-and (info-type |
(type-and (info-type |
538 |
(cadar (last forms))) |
(cadar (last forms))) |
539 |
etype))) |
etype))) |
540 |
(when (null etype) |
(when (null etype) |
541 |
(cmpwarn |
(cmpwarn |
542 |
"Type mismatch was found in ~s." |
"Type mismatch was found in ~s." |
543 |
(cons fname args))) |
(cons fname args))) |
544 |
(setf (info-type info) etype) |
(setf (info-type info) etype) |
545 |
(setf (info-type (cadar (last forms))) |
(setf (info-type (cadar (last forms))) |
546 |
etype) |
etype) |
547 |
)))) |
)))) |
548 |
;; some functions can have result type deduced from |
;; some functions can have result type deduced from |
549 |
;; arg types. |
;; arg types. |
550 |
|
|
551 |
(let ((tem (result-type-from-args fname |
(let ((tem (result-type-from-args fname |
552 |
(mapcar #'(lambda (x) (info-type (cadr x))) |
(mapcar #'(lambda (x) (info-type (cadr x))) |
553 |
forms)))) |
forms)))) |
554 |
(when tem |
(when tem |
555 |
(setq tem (type-and tem (info-type info))) |
(setq tem (type-and tem (info-type info))) |
556 |
(setf (info-type info) tem))) |
(setf (info-type info) tem))) |
557 |
(list 'call-global info fname forms))) |
(list 'call-global info fname forms))) |
558 |
) |
) |
559 |
) |
) |
560 |
|
|