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

src/CHANGELOG

@@ -22,6 +22,10 @@ ECL 0.9k:
 
 * Visible changes:
 
+ - When (>= SAFETY 1), for each compiled function, the compiler will
+   automatically generate CHECK-TYPE forms to ensure that the arguments have
+   the values that the user declared.
+
  - The documentation is slowly disappearing form this source tree, as there
    is a different tree (ecl-doc) which contains the XML sources for a more
    complete manual.

src/clos/change.lsp

@@ -199,8 +199,9 @@
   class)
 
 (defun remove-optional-slot-accessors (class)
-  (declare (si::c-local)
-	   (class class))
+  (declare (class class)
+	   (optimize (safety 0))
+	   (si::c-local))
   (let ((class-name (class-name class)))
     (dolist (slotd (class-slots class))
       ;; remove previous defined reader methods

src/clos/defclass.lsp

@@ -250,7 +250,8 @@
   (declare (si::c-local))
   (setq path (cons element (reverse (member element (reverse path) :test #'eq))))
   (flet ((pretty (class)
-	   (declare (type class class))
+	   (declare (type class class)
+		    (optimize (safety 0)))
 	   (or (class-name class) class)))
     (let ((explanations ()))
       (do ((tail path (cdr tail)))

src/clos/method.lsp

@@ -79,11 +79,11 @@
 			'(&allow-other-keys)
 			(and x (subseq lambda-list x))))))
     (let* ((class-declarations
-	    (nconc (mapcan #'(lambda (p s) (and (symbolp s) s
-						(not (eq s 't))
-						`((type ,s ,p))))
-			   required-parameters
-			   specializers)
+	    (nconc (loop for name in required-parameters
+		      for type in specializers
+		      when (and (not (eq type t)) (symbolp type))
+		      nconc `((type ,name ,type)
+			      (si::no-check-type ,name)))
 		   (cdar declarations)))
 	   (method-lambda
 	    ;; Remove the documentation string and insert the

src/clos/standard.lsp

@@ -491,6 +491,7 @@ because it contains a reference to the undefined class~%  ~A"
 (defun unbound-slot-error (object index)
   (declare (type standard-object object)
 	   (type fixnum index)
+	   (optimize (safety 0))
 	   (si::c-local))
   (let* ((class (class-of object))
 	 (slotd (find index (class-slots class) :key #'slot-definition-location)))

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))))

src/lsp/arraylib.lsp

@@ -71,7 +71,8 @@ contiguous block."
   (declare (si::c-local))
   (labels ((iterate-over-contents (array contents dims written)
 	     (declare (fixnum written)
-		      (array array))
+		      (array array)
+		      (optimize (safety 0)))
 	     (when (/= (length contents) (first dims))
 	       (error "In MAKE-ARRAY: the elements in :INITIAL-CONTENTS do not match the array dimensions"))
 	     (if (= (length dims) 1)
@@ -285,7 +286,8 @@ pointer is 0 already."
     (aref vector (the fixnum (1- fp)))))
 
 (defun copy-array-contents (dest orig)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (optimize (safety 0)))
   (labels
       ((do-copy (dest orig dims1 dims2 start1 start2)
 	 (declare (array dest orig)

src/lsp/pprint.lsp

@@ -358,10 +358,6 @@
   (declare (si::c-local)
 	   (type string prefix)
 	   (type pretty-stream stream))
-  #+ecl
-  (progn
-    (check-type prefix string)
-    (check-type suffix string))
   (let ((prefix-len (length prefix)))
     (when (plusp prefix-len)
       (pretty-sout stream prefix 0 prefix-len))
@@ -932,10 +928,6 @@
   (declare (type (member :linear :miser :fill :mandatory) kind)
 	   (type (or stream (member t nil)) stream)
 	   (values null))
-  #+ecl
-  (progn
-    (check-type kind (member :linear :miser :fill :mandatory))
-    (check-type stream (or stream (member t nil))))
   (let ((stream (case stream
 		  ((t) *terminal-io*)
 		  ((nil) *standard-output*)
@@ -958,11 +950,6 @@
 	   (type real n)
 	   (type (or stream (member t nil)) stream)
 	   (values null))
-  #+ecl
-  (progn
-    (check-type relative-to (member :block :current))
-    (check-type n real)
-    (check-type stream (or stream (member t nil))))
   (let ((stream (case stream
 		  ((t) *terminal-io*)
 		  ((nil) *standard-output*)
@@ -987,12 +974,6 @@
 	   (type unsigned-byte colnum colinc)
 	   (type (or stream (member t nil)) stream)
 	   (values null))
-  #+ecl
-  (progn
-    (check-type kind (member :line :section :line-relative
-			     :section-relative))
-    (check-type colinc unsigned-byte)
-    (check-type colnum unsigned-byte))
   (let ((stream (case stream
 		  ((t) *terminal-io*)
 		  ((nil) *standard-output*)

src/lsp/seqlib.lsp

@@ -558,6 +558,7 @@ evaluates to NIL.  See STABLE-SORT."
 
 
 (defun list-merge-sort (l predicate key)
+  (declare (si::c-local))
   (unless key (setq key #'identity))
   (labels
    ((sort (l)
@@ -613,7 +614,9 @@ evaluates to NIL.  See STABLE-SORT."
 
 
 (defun quick-sort (seq start end pred key)
-  (declare (fixnum start end))
+  (declare (fixnum start end)
+	   (optimize (safety 0))
+	   (si::c-local))
   (unless key (setq key #'identity))
   (if (<= end (the fixnum (1+ start)))
       seq