diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 32ddff434..98a935f8d 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -115,52 +115,54 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (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 - name - (si::function-block-name name))) cfun exported minarg maxarg) - (when (and no-entry (policy-debug-ihs-frame)) - (setf no-entry nil) - (cmpnote "Ignoring SI::C-LOCAL declaration for~%~4I~A~%because the debug level is large" name)) - (unless (eql setjmps *setjmps*) - (setf (c1form-volatile lambda-expr) t)) - (setf (fun-lambda fun) lambda-expr) - (if global - (multiple-value-setq (cfun exported) (exported-fname name)) - (setf cfun (next-cfun "LC~D~A" name) exported nil)) - #+ecl-min - (when (member name c::*in-all-symbols-functions*) - (setf no-entry t)) - (if exported - ;; Check whether the function was proclaimed to have a certain - ;; number of arguments, and otherwise produce a function with - ;; a flexible signature. - (progn - (multiple-value-setq (minarg maxarg) (get-proclaimed-narg name)) - (cmpdebug "~&;;; Function ~A proclaimed (~A,~A)" name minarg maxarg) - (unless minarg - (setf minarg 0 maxarg call-arguments-limit))) - (multiple-value-setq (minarg maxarg) - (lambda-form-allowed-nargs lambda-expr))) - (setf (fun-cfun fun) cfun - (fun-exported fun) exported - (fun-closure fun) nil - (fun-minarg fun) minarg - (fun-maxarg fun) maxarg - (fun-description fun) name - (fun-no-entry fun) no-entry) - (loop for child in (fun-child-funs fun) - do (add-to-fun-referenced-vars fun (fun-referenced-vars child)) - do (add-to-fun-referenced-funs fun (fun-referenced-funs child))) - (loop for f in (fun-referenced-funs fun) - do (add-to-fun-referenced-vars fun (fun-referenced-vars f))) - (update-fun-closure-type fun) - (when global - (if (fun-closure fun) - (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}" - (fun-name fun) (mapcar #'var-name (fun-referenced-vars fun))) - (new-defun fun (fun-no-entry fun))))) - fun) + (multiple-value-bind (lambda-expr optional-type-checks keyword-type-checks) + (c1lambda-expr lambda-list-and-body name + (si::function-block-name name)) + (when (and no-entry (policy-debug-ihs-frame)) + (setf no-entry nil) + (cmpnote "Ignoring SI::C-LOCAL declaration for~%~4I~A~%because the debug level is large" name)) + (unless (eql setjmps *setjmps*) + (setf (c1form-volatile lambda-expr) t)) + (setf (fun-lambda fun) lambda-expr) + (if global + (multiple-value-setq (cfun exported) (exported-fname name)) + (setf cfun (next-cfun "LC~D~A" name) exported nil)) + #+ecl-min + (when (member name c::*in-all-symbols-functions*) + (setf no-entry t)) + (if exported + ;; Check whether the function was proclaimed to have a certain + ;; number of arguments, and otherwise produce a function with + ;; a flexible signature. + (progn + (multiple-value-setq (minarg maxarg) (get-proclaimed-narg name)) + (cmpdebug "~&;;; Function ~A proclaimed (~A,~A)" name minarg maxarg) + (unless minarg + (setf minarg 0 maxarg call-arguments-limit))) + (multiple-value-setq (minarg maxarg) + (lambda-form-allowed-nargs lambda-expr))) + (setf (fun-cfun fun) cfun + (fun-exported fun) exported + (fun-closure fun) nil + (fun-minarg fun) minarg + (fun-maxarg fun) maxarg + (fun-description fun) name + (fun-no-entry fun) no-entry + (fun-optional-type-check-forms fun) optional-type-checks + (fun-keyword-type-check-forms fun) keyword-type-checks) + (loop for child in (fun-child-funs fun) + do (add-to-fun-referenced-vars fun (fun-referenced-vars child)) + do (add-to-fun-referenced-funs fun (fun-referenced-funs child))) + (loop for f in (fun-referenced-funs fun) + do (add-to-fun-referenced-vars fun (fun-referenced-vars f))) + (update-fun-closure-type fun) + (when global + (if (fun-closure fun) + (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}" + (fun-name fun) (mapcar #'var-name (fun-referenced-vars fun))) + (new-defun fun (fun-no-entry fun))))) + fun)) (defun cmp-process-lambda-list (list) (handler-case (si::process-lambda-list list 'function) @@ -241,56 +243,60 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." :initial-value *cmp-env*)) ;; After creating all variables and processing the initalization - ;; forms, we wil process the body. However, all free declarations, + ;; forms, we will process the body. However, all free declarations, ;; that is declarations which do not refer to the function ;; 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 - function-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) - by #'cddr - for name = (first spec) - for init = (second spec) - collect (list name init))) - (new-variables (cmp-env-new-variables *cmp-env* old-env)) - (already-declared-names (set-difference (mapcar #'var-name new-variables) - (mapcar #'car let-vars)))) - ;; Gather declarations for &aux variables, either special... - (let ((specials (set-difference ss already-declared-names))) - (when specials - (push `(special ,@specials) declarations))) - ;; ...ignorable... - (let ((ignorables (loop for (var . expected-uses) in is - unless (member var already-declared-names) - collect var))) - (when ignorables - (push `(ignorable ,@ignorables) declarations))) - ;; ...or type declarations - (loop for (var . type) in ts - unless (member var already-declared-names) - do (push `(type ,type ,var) declarations)) - ;; ...create the enclosing LET* form for the &aux variables - (when (or let-vars declarations) - (setq body `((let* ,let-vars - (declare ,@declarations) - ,@body)))) - ;; ...wrap around the optional type checks - (setq body (nconc type-check-forms body)) - ;; ...now finally compile the body with the type checks - (let ((*cmp-env* (cmp-env-copy *cmp-env*))) - (setf body (c1progn body))) - ;; - ;; ...and verify whether all variables are used. - (dolist (var new-variables) - (check-vref var)) - (make-c1form* 'LAMBDA - :local-vars new-variables - :args (list requireds optionals rest key-flag keywords - allow-other-keys) - doc body)))) + (multiple-value-bind (required-type-check-forms optional-type-check-forms keyword-type-check-forms new-auxs) + (extract-lambda-type-checks function-name requireds optionals + keywords ts other-decls) + (let* ((declarations other-decls) + (let-vars (loop for spec on (nconc new-auxs aux-vars) + by #'cddr + for name = (first spec) + for init = (second spec) + collect (list name init))) + (new-variables (cmp-env-new-variables *cmp-env* old-env)) + (already-declared-names (set-difference (mapcar #'var-name new-variables) + (mapcar #'car let-vars)))) + ;; Gather declarations for &aux variables, either special... + (let ((specials (set-difference ss already-declared-names))) + (when specials + (push `(special ,@specials) declarations))) + ;; ...ignorable... + (let ((ignorables (loop for (var . expected-uses) in is + unless (member var already-declared-names) + collect var))) + (when ignorables + (push `(ignorable ,@ignorables) declarations))) + ;; ...or type declarations + (loop for (var . type) in ts + unless (member var already-declared-names) + do (push `(type ,type ,var) declarations)) + ;; ...create the enclosing LET* form for the &aux variables + (when (or let-vars declarations) + (setq body `((let* ,let-vars + (declare ,@declarations) + ,@body)))) + ;; ...wrap around the type checks for required variables, removing + ;; unnecessary nil's + (setq body (nconc (delete nil required-type-check-forms) body)) + ;; ...now finally compile the body with the type checks + (let ((*cmp-env* (cmp-env-copy *cmp-env*))) + (setf body (c1progn body))) + ;; + ;; ...and verify whether all variables are used. + (dolist (var new-variables) + (check-vref var)) + (values (make-c1form* 'LAMBDA + :local-vars new-variables + :args (list requireds optionals rest key-flag keywords + allow-other-keys) + doc body) + (mapcar #'(lambda (x) (if x (c1expr x) nil)) + optional-type-check-forms) + (mapcar #'(lambda (x) (if x (c1expr x) nil)) + keyword-type-check-forms)))))) (defun lambda-form-allowed-nargs (lambda) (let ((minarg 0) @@ -319,6 +325,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (defun c2lambda-expr (lambda-list body cfun fname use-narg required-lcls closure-type + optional-type-check-forms keyword-type-check-forms &aux (requireds (first lambda-list)) (optionals (second lambda-list)) (rest (third lambda-list)) rest-loc @@ -445,7 +452,8 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." ;; counter for optionals (wt-nl-open-brace) (wt-nl "int i = " nreq ";") - (do ((opt optionals (cdddr opt))) + (do ((opt optionals (cdddr opt)) + (type-check optional-type-check-forms (cdr type-check))) ((endp opt)) (wt-nl "if (i >= narg) {") (let ((*opened-c-braces* (1+ *opened-c-braces*))) @@ -456,6 +464,8 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (*unwind-exit* *unwind-exit*)) (wt-nl "i++;") (bind va-arg-loc (first opt)) + (if (car type-check) + (c2expr* (car type-check))) (when (third opt) (bind t (third opt)))) (wt-nl "}")) (wt-nl-close-brace))) @@ -483,7 +493,8 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (do ((kwd keywords (cddddr kwd)) (all-kwd nil) (KEYVARS[i] `(KEYVARS 0)) - (i 0 (1+ i))) + (i 0 (1+ i)) + (type-check keyword-type-check-forms (cdr type-check))) ((endp kwd) (when all-kwd (wt-nl-h "#define " cfun "keys (&" (add-keywords (nreverse all-kwd)) ")") @@ -510,7 +521,9 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (wt-nl "} else {") (let ((*opened-c-braces* (1+ *opened-c-braces*))) (setf (second KEYVARS[i]) i) - (bind KEYVARS[i] var)) + (bind KEYVARS[i] var) + (if (car type-check) + (c2expr* (car type-check)))) (wt-nl "}"))) (when flag (setf (second KEYVARS[i]) (+ nkey i)) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 74b1243cf..3fdad9563 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -706,7 +706,9 @@ (fun-name fun) (fun-needs-narg fun) (fun-required-lcls fun) - (fun-closure fun)))) + (fun-closure fun) + (fun-optional-type-check-forms fun) + (fun-keyword-type-check-forms fun)))) string)) (defun t3local-fun-declaration (fun) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index dde3141b3..8dedd02da 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -57,7 +57,7 @@ key-types allow-other-keys) (si::process-lambda-list arg-types 'ftype) (declare (ignore rest-flag key-flag allow-other-keys)) - (nconc + (list (loop for var in requireds for type in (rest req-types) collect (cons var type)) @@ -72,7 +72,7 @@ return (second key-list) finally (return t)) collect (cons key-var type)))) - (nconc + (list (loop for var in requireds collect (cons var t)) (loop for optional in optionals by #'cdddr @@ -94,45 +94,59 @@ (rplacd record (type-and (cdr record) (cdr type)))) assoc-list) +(defun lambda-type-check-expand (type-checks policy-check-type other-decls) + (loop with checks = '() + with new-auxs = '() + for (var . type) in type-checks + for name = (var-name var) + do (if (eq type t) ;; Non trivial types are the only ones we care about + (setf checks (list* nil checks)) + (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* `(type-assertion ,name ,type) checks) + new-auxs (list* `(truly-the ,type ,name) name new-auxs)) + ;; Or simply enforce the variable's type. + (setf (var-type var) (type-and (var-type var) type)))) + finally + (return (values checks new-auxs)))) + (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 + ;; 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. - (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* `(type-assertion ,name ,type) checks) - new-auxs (list* `(truly-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)))))) + ;; Returns 4 values: type assertions for required, optional, keyword + ;; arguments and &aux type declarations. Type assertions may be nil, + ;; if no type check is necessary. + (let* ((global-fun-p (member '(si::c-global) other-decls :test #'equal)) + (policy-check-type (policy-check-arguments-type)) + (all-type-checks (mapcar #'(lambda (checks) + (lambda-type-check-precise checks ts)) + (lambda-type-check-associate fname requireds optionals keywords global-fun-p))) + (checks '()) + (new-auxs '())) + (setq checks + (loop for i in all-type-checks + collect (multiple-value-bind (check new-aux) + (lambda-type-check-expand i policy-check-type + other-decls) + (setq new-auxs (nconc new-aux new-auxs)) + check))) + (when new-auxs + (cmpnote "In ~:[an anonymous function~;function ~:*~A~], checking types of argument~@[s~]~{ ~A~}." + (fun-name *current-function*) + (nreverse + (loop for i in (cdr new-auxs) by #'cddr collect i)))) + (values (nreverse (car checks)) (nreverse (cadr checks)) + (nreverse (caddr checks)) (nreverse new-auxs)))) (defun type-error-check (value type) (case type diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index 9a5e7df9e..4b0cd68d5 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -159,6 +159,8 @@ ;;; Top-level form number in source file (cmp-env (cmp-env-copy)) ;;; Environment required-lcls ;;; Names of the function arguments + (optional-type-check-forms nil) ;;; Type check forms for optional arguments + (keyword-type-check-forms nil) ;;; Type check forms for keyword arguments ) (defstruct (blk (:include ref)) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 5c5991521..ad9cecbdd 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -1289,3 +1289,17 @@ (test cmp.0060.loop-on-dotted-list (finishes (funcall (compile nil '(lambda () (loop for (i) on '(1 2 . 3))))))) + +;;; Date 2017-12-02 +;;; Description +;;; +;;; type declarations for optional and keyword function arguments +;;; resulted in an error, when the default values weren't of the +;;; specified type. +;;; +;;; Bug https://gitlab.com/embeddable-common-lisp/ecl/issues/292 +(test cmp.0061.optional-type-declaration + (declaim (ftype (function (real &optional real &key (:c symbol)) real) foo)) + (defun foo (a &optional (b 'test) &key (c 1)) (if b c a)) + (compile 'foo) + (finishes (foo 1)))