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

Fixes in how FTYPE proclamations are stored -- the return types were corrupted in previous implementations of DECLARE/PROCLAIM

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2011-12-28 15:58:07 +01:00
parent 04e08b5617
commit 3f3effd034
2 changed files with 8 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/cmp/cmpenv-declare.lsp
View file

@ -132,8 +132,7 @@ special variable declarations, as these have been extracted before."
(si::normalize-type (second decl))
(if (eq type-name 'FUNCTION)
(dolist (v (cddr decl))
(setf env (add-function-declaration v (first args)
(rest args) env)))
(setf env (add-function-declaration v args env)))
(cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
(second decl)))))
env)

26
src/cmp/cmpenv-fun.lsp
View file

@ -25,19 +25,6 @@
;;; The valid return type declaration is:
;;; (( VALUES {type}* )) or ( {type}* ).
(defun function-return-type (return-types)
(cond ((endp return-types) t)
((and (consp (car return-types))
(eq (caar return-types) 'VALUES))
(cond ((not (endp (cdr return-types)))
(warn "The function return types ~s is illegal." return-types)
t)
((or (endp (cdar return-types))
(member (cadar return-types) '(&optional &rest &key)))
t)
(t (car return-types))))
(t (car return-types))))
(defun proclaim-function (fname decl)
(if (si:valid-function-name-p fname)
(let* ((arg-types '*)
@ -49,10 +36,11 @@
(t (warn "The function proclamation ~s ~s is not valid."
fname decl)))
(cond ((null l))
((and (consp l) (null (rest l)))
(setf return-types (function-return-type l)))
(t (warn "The function proclamation ~s ~s is not valid."
fname decl)))
((or (atom l) (rest l))
(warn "The function proclamation ~s ~s is not valid."
fname decl))
(t
(setf return-types (first l))))
(when (eq arg-types '())
(setf arg-types '(&optional)))
(if (eq arg-types '*)
@ -64,12 +52,12 @@
(put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
(warn "The function proclamation ~s ~s is not valid." fname decl)))
(defun add-function-declaration (fname arg-types return-types &optional (env *cmp-env*))
(defun add-function-declaration (fname ftype &optional (env *cmp-env*))
(if (si::valid-function-name-p fname)
(let ((fun (cmp-env-search-function fname)))
(if (functionp fun)
(warn "Found function declaration for local macro ~A" fname)
(cmp-env-register-ftype fname (list arg-types return-types) env)))
(cmp-env-register-ftype fname ftype env)))
(warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname))
env)