Automatically generate type checks for arguments of a lambda form if the safety settings are high enough

src/cmp/cmpdefs.lsp

@@ -297,6 +297,9 @@ The default value is NIL.")
 (defvar *space* 0)
 (defvar *debug* 0)
 
+;;; Emit automatic CHECK-TYPE forms for function arguments in lambda forms.
+(defvar *automatic-check-type-in-lambda* t)
+
 ;;;
 ;;; Compiled code uses the following kinds of variables:
 ;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl)

src/cmp/cmpenv.lsp

@@ -331,7 +331,7 @@
 	      (:READ-ONLY
 	       (push decl others))
 	      ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
-		DYNAMIC-EXTENT IGNORABLE VALUES)
+		DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE)
 	       (push decl others))
 	      (otherwise
 	       (if (member decl-name si::*alien-declarations*)
@@ -404,7 +404,7 @@
 	   (cmperr "Not a valid function name ~s in declaration ~s" fun decl))))
       (DECLARATION
        (do-declaration (rest decl) #'cmperr))
-      ((SI::C-LOCAL SI::C-GLOBAL))
+      ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE))
       ((DYNAMIC-EXTENT IGNORABLE)
        ;; FIXME! SOME ARE IGNORED!
        )
@@ -591,6 +591,7 @@
   "Do we assume that arguments are the right type?"
   (> (cmp-env-optimization 'safety env) 1))
 
-(defun policy-automatic-type-checks-p (&optional env)
+(defun policy-automatic-check-type-p (&optional env)
   "Do we generate CHECK-TYPE forms for function arguments with type declarations?"
-  (>= (cmp-env-optimization 'safety env) 1))
+  (and *automatic-check-type-in-lambda*
+       (>= (cmp-env-optimization 'safety env) 1)))

src/cmp/cmpffi.lsp

@@ -152,7 +152,10 @@
 	    (wt "((" (rep-type-name dest-rep-type) ")" loc ")"))
 	   ((:object)
 	    (ensure-valid-object-type dest-type)
-	    (wt (if (subtypep (loc-type loc) 'fixnum) "fix(" "ecl_to_fixnum(")
+	    (wt (if (or (subtypep (loc-type loc) 'fixnum)
+			(not (policy-check-all-arguments-p)))
+		    "fix("
+		    "ecl_to_fixnum(")
 		loc ")"))
 	   (otherwise
 	    (coercion-error))))
@@ -163,7 +166,10 @@
 	    (wt "((" (rep-type-name dest-rep-type) ")" loc ")"))
 	   ((:object)
 	    (ensure-valid-object-type dest-type)
-	    (wt (if (subtypep (loc-type loc) 'fixnum) "fix(" "ecl_to_unsigned_integer(")
+	    (wt (if (or (subtypep (loc-type loc) 'fixnum)
+			(not (policy-check-all-arguments-p)))
+		    "fix("
+		    "ecl_to_unsigned_integer(")
 		loc ")"))
 	   (otherwise
 	    (coercion-error))))

src/cmp/cmplam.lsp

@@ -149,6 +149,7 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
                       &aux doc body ss is ts
                            other-decls
 		           new-variables
+		           (type-checks '())
 			   (*permanent-data* t)
 			   (old-env *cmp-env*)
                            (*cmp-env* (cmp-env-copy)))
@@ -168,8 +169,11 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
 
     (do ((specs (setq requireds (cdr requireds)) (cdr specs)))
 	((endp specs))
-      (let* ((name (first specs)))
-	(push-vars (setf (first specs) (c1make-var name ss is ts)))))
+      (let* ((name (first specs))
+	     (var (c1make-var name ss is ts)))
+	(push var type-checks)
+	(setf (first specs) var)
+	(push-vars var)))
 
     (do ((specs (setq optionals (cdr optionals)) (cdddr specs)))
 	((endp specs))
@@ -181,6 +185,7 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
 		       (and-form-type (var-type var) (c1expr init) init
 				      :safe "In (LAMBDA ~a...)" block-name)
 		       (default-init var)))
+	(push var type-checks)
 	(push-vars var)
 	(when flag
 	  (push-vars (setq flag (c1make-var flag ss is ts))))
@@ -202,6 +207,7 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
 		       (and-form-type (var-type var) (c1expr init) init
 				      :safe "In (LAMBDA ~a...)" block-name)
 		       (default-init var)))
+	(push var type-checks)
 	(push-vars var)
 	(when flag
 	  (push-vars (setq flag (c1make-var flag ss is ts))))
@@ -224,6 +230,24 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
       (loop for (var . type) in ts
 	    unless (member var new-variable-names)
 	    do (push `(type ,type ,var) declarations))
+      ;; We generate automatic type checks for function arguments that
+      ;; are declared These checks can be deactivated by appropriate
+      ;; safety settings which are checked by OPTIONAL-CHECK-TYPE
+      ;;
+      (let* ((type-checks (loop for var in type-checks
+			     unless (or (eq (var-type var) t)
+					(loop for decl in other-decls
+					   when (and (consp decl)
+						     (eq (first decl) 'si::no-check-type)
+						     (member (var-name var) (rest decl)))
+					   do (return t)))
+			     collect var)))
+	(when (and type-checks (policy-automatic-check-type-p))
+	  (cmpnote "In ~:[an anonymous function~;function ~:*~A~], checking types of argument~@[s~]~{ ~A~}."
+		   block-name
+		   (mapcar #'var-name type-checks))
+	  (loop for var in (nreverse type-checks)
+	     do (push `(optional-check-type ,(var-name var) ,(var-type var)) body))))
       (setq body
 	    (cond (aux-vars
 		   (let ((let nil))

src/cmp/cmptype.lsp

@@ -407,3 +407,16 @@
   `(put-sysprop ',fname 'C1TYPE-PROPAGATOR
     #'(ext:lambda-block ,fname ,lambda-list ,body)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; TYPE CHECKING
+;;
+
+(defmacro optional-check-type (&whole whole var-name type &environment env)
+  "Generates a type check that is only activated for the appropriate
+safety settings and when the type is not trivial."
+  (unless (policy-automatic-check-type-p env)
+    (cmpnote "Unable to emit check for variable ~A" whole))
+  (when (policy-automatic-check-type-p env)
+    (unless (subtypep 't type)
+      `(check-type ,var-name ,type))))