From fd2848c9c7dd1b8e5047d82f73bd8d6f972c8feb Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 28 Jun 2010 21:39:20 +0200 Subject: [PATCH] Function proclamations are also used to deduce the argument types and automatically generate type checks. --- src/CHANGELOG | 3 + src/cmp/cmpenv-fun.lsp | 13 +++-- src/cmp/cmpenv-proclaim.lsp | 2 + src/cmp/cmplam.lsp | 9 ++- src/cmp/cmptype-prop.lsp | 2 +- src/cmp/cmptype.lsp | 109 ++++++++++++++++++++++++++---------- 6 files changed, 97 insertions(+), 41 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 8c6b4b842..4ae75bc0f 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -89,6 +89,9 @@ ECL 10.5.1: - ECL exports a new feature, :C++, when it is built with a C++ compiler. + - Function proclamations and declarations are also used to deduce the type + of their arguments. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/cmp/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp index b20788ce7..8b9d3e7e6 100644 --- a/src/cmp/cmpenv-fun.lsp +++ b/src/cmp/cmpenv-fun.lsp @@ -73,17 +73,22 @@ (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)) env) -(defun get-arg-types (fname &optional (env *cmp-env*)) +(defun get-arg-types (fname &optional (env *cmp-env*) (may-be-global t)) (let ((x (cmp-env-search-ftype fname env))) (if x - (values (first x) t) - (sys:get-sysprop fname 'PROCLAIMED-ARG-TYPES)))) + (values x t) + (when may-be-global + (let ((fun (cmp-env-search-function fname env))) + (when (or (null fun) (and (fun-p fun) (fun-global fun))) + (sys:get-sysprop fname 'PROCLAIMED-ARG-TYPES))))))) (defun get-return-type (fname &optional (env *cmp-env*)) (let ((x (cmp-env-search-ftype fname env))) (if x (values (second x) t) - (sys:get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))) + (let ((fun (cmp-env-search-function fname env))) + (when (or (null fun) (and (fun-p fun) (fun-global fun))) + (sys:get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))))) (defun get-local-arg-types (fun &optional (env *cmp-env*)) (let ((x (cmp-env-search-ftype (fun-name fun)))) diff --git a/src/cmp/cmpenv-proclaim.lsp b/src/cmp/cmpenv-proclaim.lsp index f57f2a619..9b145aa98 100644 --- a/src/cmp/cmpenv-proclaim.lsp +++ b/src/cmp/cmpenv-proclaim.lsp @@ -110,11 +110,13 @@ (when ok (proclaim-var type (rest decl)) t))) + ((maybe-add-policy decl *cmp-env-root*)) ((let ((proclaimer (get-sysprop (car decl) :proclaim))) (when (functionp proclaimer) (mapc proclaimer (rest decl)) t))) (t + (break) (warn "Unknown declaration specifier ~s" decl-name)))))) (defun proclaim-var (type vl) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index f29764e95..4a9935ab3 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -85,11 +85,11 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (*cmp-env* (setf (fun-cmp-env fun) (cmp-env-mark CB/LB))) (setjmps *setjmps*) (decl (si::process-declarations (rest lambda-list-and-body))) + (global (and (assoc 'SI::C-GLOBAL decl) (setf (fun-global fun) T))) + (no-entry (assoc 'SI::C-LOCAL decl)) (lambda-expr (c1lambda-expr lambda-list-and-body (si::function-block-name name))) (children (fun-child-funs fun)) - (global (and (assoc 'SI::C-GLOBAL decl) 'T)) - (no-entry (assoc 'SI::C-LOCAL decl)) cfun exported minarg maxarg) (when (and no-entry (policy-debug-ihs-frame)) (setf no-entry nil) @@ -115,7 +115,6 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (multiple-value-setq (minarg maxarg) (lambda-form-allowed-nargs lambda-expr))) (setf (fun-cfun fun) cfun - (fun-global fun) global (fun-exported fun) exported (fun-closure fun) nil (fun-minarg fun) minarg @@ -227,7 +226,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." ;; arguments, have to be applied to the body. At the same time, we ;; replace &aux variables with a LET* form that defines them. (let* ((declarations other-decls) - (type-checks (extract-lambda-type-checks requireds optionals + (type-checks (extract-lambda-type-checks block-name requireds optionals keywords ts other-decls)) (type-check-forms (car type-checks)) (let-vars (loop for spec on (nconc (cdr type-checks) aux-vars) @@ -435,7 +434,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." ;; which is what we do here. (let ((va-arg-loc (if simple-varargs 'VA-ARG 'CL-VA-ARG))) ;; counter for optionals - (wt "{int i=" nreq ";") + (wt-nl "{int i=" nreq ";") (do ((opt optionals (cdddr opt))) ((endp opt)) (wt-nl "if (i >= narg) {") diff --git a/src/cmp/cmptype-prop.lsp b/src/cmp/cmptype-prop.lsp index 65e1942ca..f266ef024 100644 --- a/src/cmp/cmptype-prop.lsp +++ b/src/cmp/cmptype-prop.lsp @@ -71,7 +71,7 @@ (setf lambda-list (append lambda-list (list '&rest var)) body (list* `(declare (ignorable ,var)) body)))) `(setf (gethash ',fname *p0-dispatch-table*) - #'(ext:lambda-block ,fname ,lambda-list ,@body))) + #'(lambda ,lambda-list ,@body))) (defun copy-type-propagator (orig dest-list) (loop with function = (gethash orig *p0-dispatch-table*) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 421fd2dcd..dbe0f5c16 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -56,42 +56,89 @@ ;; TYPE CHECKING ;; -(defun extract-lambda-type-checks (requireds optionals keywords ts other-decls) +(defun lambda-type-check-associate (fname requireds optionals keywords global-fun-p) + (multiple-value-bind (arg-types found) + (get-arg-types fname *cmp-env* global-fun-p) + (if found + (multiple-value-bind (req-types opt-types rest-flag key-flag + key-types allow-other-keys) + (si::process-lambda-list arg-types 'ftype) + (nconc + (loop for var in requireds + for type in (rest req-types) + collect (cons var type)) + (loop for optional in optionals by #'cdddr + for type in (rest opt-types) by #'cdddr + collect (cons optional type)) + (loop for key-list on keywords by #'cddddr + for keyword = (first key-list) + for key-var = (second key-list) + for type = (loop for key-list on (rest key-types) by #'cddr + when (eq keyword (first key-list)) + return (second key-list) + finally (return t)) + collect (cons key-var type)))) + (nconc + (loop for var in requireds + collect (cons var t)) + (loop for optional in optionals by #'cdddr + collect (cons optional t)) + (loop for key-list on keywords by #'cddddr + for key-var = (second key-list) + collect (cons key-var t)))))) + +(defun lambda-type-check-precise (assoc-list ts) + (loop for record in assoc-list + for var = (car record) + for type = (assoc (var-name var) ts) + when type + do + ;; Instead of trusting the global proclamation, we set a check based + ;; on the local declaration, without type merging. + (rplacd record (cdr type)) + #+(or) + (rplacd record (type-and (cdr record) (cdr type)))) + assoc-list) + +(defun extract-lambda-type-checks (fname requireds optionals keywords ts other-decls) ;; We generate automatic type checks for function arguments that ;; are declared These checks can be deactivated by appropriate ;; safety settings which are checked by ASSERT-TYPE. Note ;; that not all type declarations can be checked (take for instance ;; (type (function (t t) t) foo)) We let the macro do the job. - (when (policy-check-arguments-type) - (loop with type-checks = (append (loop for spec on optionals by #'cdddr - collect (first spec)) - (loop for spec on keywords by #'cddddr - collect (second spec)) - requireds) - for var in type-checks - for name = (var-name var) - for type = (cdr (assoc name ts)) - for checked = (and type - (loop for decl in other-decls - never (and (consp decl) - (eq (first decl) - 'si::no-check-type) - (member name (rest decl))))) - when checked - collect `(assert-type-if-known ,name ,type) into checks - ;; We remove assumption about types, which will be checked later - when checked - do (setf (var-type var) T) - ;; And we add additional variables with proclaimed types - when (and checked (not (eq (var-kind var) 'SPECIAL))) - nconc `(,name (the ,type ,name)) into new-auxs - finally - (progn - (when checks - (cmpnote "In ~:[an anonymous function~;function ~:*~A~], checking types of argument~@[s~]~{ ~A~}." - (fun-name *current-function*) - (mapcar #'second checks))) - (return (cons checks new-auxs)))))) + (loop with policy-check-type = (policy-check-arguments-type) + with checks = '() + with new-auxs = '() + with global-fun-p = (member '(si::c-global) other-decls :test #'equal) + with type-checks = (lambda-type-check-precise + (lambda-type-check-associate fname requireds + optionals keywords + global-fun-p) + ts) + for (var . type) in type-checks + for name = (var-name var) + ;; Non trivial types are the only ones we care about + unless (eq type t) + do (if (and policy-check-type + (loop for decl in other-decls + never (and (consp decl) + (eq (first decl) + 'si::no-check-type) + (member name (rest decl))))) + ;; We remove assumption about types, which will be checked + ;; later due to this assertion... + (setf (var-type var) t + checks (list* `(assert-type-if-known ,name ,type) checks) + new-auxs (list* `(the ,type ,name) name new-auxs)) + ;; Or simply enforce the variable's type. + (setf (var-type var) (type-and (var-type var) type))) + finally + (progn + (when checks + (cmpnote "In ~:[an anonymous function~;function ~:*~A~], checking types of argument~@[s~]~{ ~A~}." + (fun-name *current-function*) + (mapcar #'second checks))) + (return (cons (nreverse checks) (nreverse new-auxs)))))) (defun type-error-check (value type) (case type