diff --git a/src/CHANGELOG b/src/CHANGELOG index 0305c6bf2..6421ac33d 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -85,6 +85,13 @@ ECL 9.1.0: - DEFSTRUCT :INCLUDE did not work with read only slots. + - 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/c/main.d b/src/c/main.d index 962348fdb..40e52d31a 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -703,7 +703,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 @@ -720,22 +721,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 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 76dba60fb..ba24e5e3d 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -441,13 +441,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