mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-14 13:21:54 -08:00
Code Issues Projects Releases Packages Wiki Activity

Implemented TYPE-AND for multiple value types

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-07-05 09:42:38 +02:00
parent 8034185d4a
commit 1b8bb0bef1
1 changed files with 113 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

122
src/cmp/cmptype.lsp
View file

@ -157,6 +157,109 @@
(cmpwarn "Unknown type ~S. Assuming it is T." t2)
t1))))
(defun values-type-primary-type (type)
(when (and (consp type) (eq (first type) 'VALUES))
(let ((subtype (second type)))
(when (or (eq subtype '&optional) (eq subtype '&rest))
(setf subtype (third (c1form-type form)))
(when (eq subtype '&optional)
(cmperr "Syntax error in type expression ~S" type)))
(when (eq subtype '&rest)
(cmperr "Syntax error in type expression ~S" type))
(setf type subtype)))
type)
(defun values-type-and (t1 t2)
(labels ((values-type-p (type)
(and (consp type) (eq (first type) 'VALUES)))
(values-and-ordinary (v type)
(let* ((v (rest v))
(first-type (first v)))
(cond ((or (eq first-type '&optional) (eq first-type '&rest))
(type-and (second v) type))
((null (rest v))
(type-and first-type type))
(t
(return-from values-type-and nil)))))
(type-error (type)
(error "Invalid type ~A" type))
(do-values-type-and (t1-orig t2-orig)
(do* ((t1 (rest t1-orig))
(t2 (rest t2-orig))
(i1 (first t1))
(i2 (first t2))
(phase1 nil)
(phase2 nil)
(phase3 nil)
(output (list 'VALUES)))
((or (null t1) (null t2))
(if (or (eq t1 t2)
(eq i1 '&rest) (eq i1 '&optional)
(eq i2 '&rest) (eq i2 '&optional))
(nreverse output)
nil))
(print (list i1 i2 t1 t2 phase1 phase2 phase3 output))
(cond ((eq i1 '&optional)
(when phase1 (type-error t1-orig))
(setf phase1 '&optional)
(setf t1 (rest t1) i1 (first t1))
(unless t1 (type-error t1-orig)))
((eq i1 '&rest)
(when (eq phase1 '&rest) (type-error t1-orig))
(setf phase1 '&rest)
(setf t1 (rest t1) i1 (first t1))
(when (or (null t1) (rest t1)) (type-error t1-orig))))
(cond ((eq i2 '&optional)
(when phase2 (type-error t2-orig))
(setf phase2' &optional)
(setf t2 (rest t2) i2 (first t2))
(unless t2 (type-error t2-orig)))
((eq i2 '&rest)
(when (eq phase2 '&rest) (type-error t2-orig))
(setf phase2 '&rest)
(setf t2 (rest t2) i2 (first t2))
(when (or (null t2) (rest t2)) (type-error t2-orig))))
(cond ((and (null phase1) (null phase2))
(push (type-and i1 i2) output)
(setf t1 (rest t1) i1 (first t1)
t2 (rest t2) i2 (first t2)))
((null phase2)
(push (type-and i1 i2) output)
(unless (eq phase1 '&rest)
(setf t1 (rest t1) i1 (first t1)))
(setf t2 (rest t2) i2 (first t2)))
((null phase1)
(push (type-and i1 i2) output)
(unless (eq phase2 '&rest)
(setf t2 (rest t2) i2 (first t2)))
(setf t1 (rest t1) i1 (first t1)))
((eq phase1 phase2)
(unless (eq phase3 phase2)
(push (setf phase3 phase2) output))
(push (type-and i1 i2) output)
(cond ((eq phase1 '&rest) (setf t1 nil t2 nil))
(t (setf t1 (rest t1) i1 (first t1)
t2 (rest t2) i2 (first t2)))))
((eq phase1 '&optional)
(unless (eq phase3 phase1)
(push (setf phase3 phase1) output))
(push (type-and i1 i2) output)
(setf t1 (rest t1) i1 (first t1)))
((eq phase2 '&optional)
(unless (eq phase3 phase2)
(push (setf phase3 phase2) output))
(push (type-and i1 i2) output)
(setf t2 (rest t2) i2 (first t2)))))))
(if (equal t1 t2)
t1
(if (values-type-p t1)
(if (values-type-p t2)
(do-values-type-and t1 t2)
(values-and-ordinary t1 t2))
(if (values-type-p t2)
(values-and-ordinary t2 t1)
(type-and t1 t2))))))
(defun type-or (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
@ -420,15 +523,16 @@
(unless in-optionals
(cmpwarn "Too few arguments for proclaimed function ~A" fname))
(return))
(let* ((form (first fl))
(lisp-form (first al))
(old-type (c1form-type form)))
(and-form-type expected-type form lisp-form
:safe "In the argument ~d of a call to ~a" i fname)
;; In safe mode, we cannot assume that the type of the
;; argument is going to be the right one.
(unless (zerop (cmp-env-optimization 'safety))
(setf (c1form-type form) old-type))))))
(when lisp-forms
(let* ((form (first fl))
(lisp-form (first al))
(old-type (c1form-type form)))
(and-form-type expected-type form lisp-form
:safe "In the argument ~d of a call to ~a" i fname)
;; In safe mode, we cannot assume that the type of the
;; argument is going to be the right one.
(unless (zerop (cmp-env-optimization 'safety))
(setf (c1form-type form) old-type)))))))
return-type))
(defmacro def-type-propagator (fname lambda-list &body body)