From 1fb1d1a21458e93f001010de569d1f16610d5bf5 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Thu, 26 Feb 2009 12:07:20 +0100 Subject: [PATCH 1/2] SETENV ensures that strings are null terminated. --- src/CHANGELOG | 2 ++ src/c/main.d | 15 +++++++-------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index a439f6bd1..d4aa0cf32 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -79,6 +79,8 @@ ECL 9.1.0: - DEFSTRUCT :INCLUDE did not work with read only slots. + - EXT:SETENV now ensures that strings are null terminated. + * Visible changes: - New function (EXT:HEAP-SIZE &optional NEW-MAX-HEAP-SIZE) can change the diff --git a/src/c/main.d b/src/c/main.d index 7e34641cc..118fffc51 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -698,7 +698,8 @@ si_setenv(cl_object var, cl_object value) const cl_env_ptr the_env = ecl_process_env(); cl_fixnum ret_val; - var = ecl_check_cl_type(@'ext::setenv', var, t_base_string); + /* Strings have to be null terminated base strings */ + var = si_copy_to_simple_base_string(var); if (value == Cnil) { #ifdef HAVE_SETENV /* Remove the variable when setting to nil, so that @@ -715,22 +716,20 @@ si_setenv(cl_object var, cl_object value) ret_val = 0; } else { #ifdef HAVE_SETENV - value = ecl_check_cl_type(@'intern', value, t_base_string); + value = si_copy_to_simple_base_string(value); ret_val = setenv((char*)var->base_string.self, (char*)value->base_string.self, 1); #else - cl_object temp = - cl_format(4, Cnil, make_constant_base_string("~A=~A"), var, - value); - if (temp->base_string.hasfillp && temp->base_string.fillp < temp->base_string.dim) - temp->base_string.self[temp->base_string.fillp] = '\0'; + value = cl_format(4, Cnil, make_constant_base_string("~A=~A"), var, + value); + value = si_copy_to_simple_base_string(value); putenv((char*)temp->base_string.self); #endif } if (ret_val == -1) CEerror(Ct, "SI:SETENV failed: insufficient space in environment.", 1, Cnil); - @(return (value)) + @(return value) } #endif From d9919fa312482550cd5f6fd90caf4a856111d73c Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Fri, 27 Feb 2009 20:05:40 +0100 Subject: [PATCH 2/2] Ignore TYPE declarations that contain a function type, even if it is a DEFTYPE'd one. --- src/CHANGELOG | 5 +++++ src/cmp/cmplam.lsp | 5 ++++- src/cmp/cmptype.lsp | 26 +++++++++++++++++++------- 3 files changed, 28 insertions(+), 8 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index d4aa0cf32..d1fb2df91 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -81,6 +81,11 @@ ECL 9.1.0: - EXT:SETENV now ensures that strings are null terminated. + - For high safety settings, ECL produces a CHECK-TYPE for each declaration + at the beginning of a function. If the declaration has a function type, + these checks were wrong, for TYPEP cannot take an arbitrary function type + as argument. + * Visible changes: - New function (EXT:HEAP-SIZE &optional NEW-MAX-HEAP-SIZE) can change the diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 08fe6993f..2154533bd 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -232,7 +232,10 @@ The function thus belongs to the type of functions that cl_make_cfun accepts." 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 + ;; safety settings which are checked by OPTIONAL-CHECK-TYPE. Note + ;; that not all type declarations can be checked (take for instance + ;; (type (function (t t) t) foo)) We let OPTIONAL-CHECK-TYPE do the + ;; job. ;; (let* ((pairs (loop for var in type-checks nconc (let* ((name (var-name var)) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 66e67c426..f2042330c 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -440,13 +440,25 @@ ;; (defun remove-function-types (type) - (if (atom type) - type - (case (first type) - ((OR AND NOT) - (cons (first type) (loop for i in (rest type) collect (remove-function-types i)))) - (FUNCTION 'FUNCTION) - (otherwise type)))) + ;; We replace this type by an approximate one that contains no function + ;; types. This function may not produce the best approximation. Hence, + ;; it is only used for optional type checks where we do not want to pass + ;; TYPEP a complex type. + (flet ((simplify-type (type) + (cond ((subtypep type '(NOT FUNCTION)) + type) + ((subtypep type 'FUNCTION) + 'FUNCTION) + (t + T)))) + (if (atom type) + (simplify-type type) + (case (first type) + ((OR AND NOT) + (cons (first type) + (loop for i in (rest type) collect (remove-function-types i)))) + (FUNCTION 'FUNCTION) + (otherwise (simplify-type type)))))) (defmacro optional-check-type (&whole whole var-name type &environment env) "Generates a type check that is only activated for the appropriate