In structures ecl_{array,vector,base_string,string}, replaced the bitfields hasfillp and adjustable with a single integer holding all flags. This solves several problems with Microsoft C compiler.

2026-01-12 20:31:55 -08:00 · 2009-07-26 11:56:26 +02:00 · 2009-07-26 11:56:26 +02:00 · da641873e4
commit da641873e4
parent 92d5aac5eb
13 changed files with 88 additions and 74 deletions
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@ -1,6 +1,16 @@
 ECL 9.7.2:
 ==========

+* Ports:
+
+ - The MSVC port now boots also when built without support for Unicode.
+
+ - The mingw32 port builds without threads. For multithreading, the user will
+   have to build version 7.2-alpha2 of the garbage collector manually.
+
+ - The NetBSD port builds with default values using the garbage collector
+   supplied with the pkgsrc distribution.
+
 * Compiler:

 - The compiler now understands FFI types :[u]int{8,16,32,64}-t.
@ -11,14 +21,19 @@ ECL 9.7.2:

 * Visible changes:

- - Cygwin now uses the 'flatinstall' model in which all ECL files are
-   stored in the same directory. This solves problems related to locating
-   the ECL.DLL library and other files.
-
 - New functions ecl_make_[u]int(), ecl_make_[u]long(), ecl_to_[u]int(),
   ecl_to_[u]long(), ecl_to_bool(), ecl_make_bool(), convert between C types
   and cl_object.

+ - The C structures ecl_array, ecl_vector, ecl_base_string and ecl_string have
+   changed. Instead of using bitfields for hasfillp and adjustable we now
+   use a single integer field, and handle the bits manually. See the
+   new macros ECL_ADJUSTABLE_ARRAY_P and ECL_ARRAY_HAS_FILL_POINTER_P.
+
+* Bugs fixed:
+
+ - SI:GET-LIBRARY-PATHNAME did not work properly in Windows.
+

 ECL 9.7.1:
 ==========
--- a/src/c/array.d
+++ b/src/c/array.d
@ -421,7 +421,7 @@ si_make_pure_array(cl_object etype, cl_object dims, cl_object adj,
 	x->array.self.t = NULL;		/* for GC sake */
 	x->array.rank = r;
 	x->array.elttype = (short)ecl_symbol_to_elttype(etype);
-	x->array.hasfillp = 0;
+	x->array.flags = 0; /* no fill pointer, no adjustable */
 	x->array.dims = (cl_index *)ecl_alloc_atomic_align(sizeof(cl_index)*r, sizeof(cl_index));
 	for (i = 0, s = 1;  i < r;  i++, dims = ECL_CONS_CDR(dims)) {
 		j = ecl_fixnum_in_range(@'make-array', "dimension",
@ -431,7 +431,9 @@ si_make_pure_array(cl_object etype, cl_object dims, cl_object adj,
 			FEerror("The array total size, ~D, is too large.", 1, MAKE_FIXNUM(s));
 	}
 	x->array.dim = s;
-	x->array.adjustable = adj != Cnil;
+        if (adj != Cnil) {
+                x->array.flags |= ECL_FLAG_ADJUSTABLE;
+        }
 	if (Null(displ))
 		ecl_array_allocself(x);
 	else
@ -473,15 +475,17 @@ si_make_vector(cl_object etype, cl_object dim, cl_object adj,
 	x->vector.self.t = NULL;		/* for GC sake */
 	x->vector.displaced = Cnil;
 	x->vector.dim = d;
-	x->vector.adjustable = adj != Cnil;
+        x->vector.flags = 0;
+        if (adj != Cnil) {
+                x->vector.flags |= ECL_FLAG_ADJUSTABLE;
+        }
 	if (Null(fillp)) {
-		x->vector.hasfillp = FALSE;
 		f = d;
 	} else if (fillp == Ct) {
-		x->vector.hasfillp = TRUE;
+		x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER;
 		f = d;
 	} else if (FIXNUMP(fillp) && ((f = fix(fillp)) <= d) && (f >= 0)) {
-		x->vector.hasfillp = TRUE;
+		x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER;
 	} else {
 		fillp = ecl_type_error(@'make-array',"fill pointer",fillp,
 				       cl_list(3,@'or',cl_list(3,@'member',Cnil,Ct),
@ -759,7 +763,7 @@ cl_object
 cl_adjustable_array_p(cl_object a)
 {
 	assert_type_array(a);
-	@(return (a->array.adjustable ? Ct : Cnil))
+	@(return (ECL_ADJUSTABLE_ARRAY_P(a) ? Ct : Cnil))
 }

 /*
@ -844,8 +848,7 @@ cl_svref(cl_object x, cl_object index)
 	cl_index i;

 	while (type_of(x) != t_vector ||
-	       x->vector.adjustable ||
-	       x->vector.hasfillp ||
+	       (x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) ||
 	       CAR(x->vector.displaced) != Cnil ||
 	       (cl_elttype)x->vector.elttype != aet_object)
 	{
@ -862,8 +865,7 @@ si_svset(cl_object x, cl_object index, cl_object v)
 	cl_index i;

 	while (type_of(x) != t_vector ||
-	       x->vector.adjustable ||
-	       x->vector.hasfillp ||
+	       (x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) ||
 	       CAR(x->vector.displaced) != Cnil ||
 	       (cl_elttype)x->vector.elttype != aet_object)
 	{
@ -888,7 +890,7 @@ cl_array_has_fill_pointer_p(cl_object a)
 	case t_string:
 #endif
 	case t_base_string:
-		r = a->vector.hasfillp? Ct : Cnil;
+		r = ECL_ARRAY_HAS_FILL_POINTER_P(a)? Ct : Cnil;
 		break;
 	default:
 		a = ecl_type_error(@'array-has-fill-pointer-p',"argument",
@ -903,7 +905,7 @@ cl_fill_pointer(cl_object a)
 {
 	const cl_env_ptr the_env = ecl_process_env();
 	assert_type_vector(a);
-	if (!a->vector.hasfillp) {
+	if (!ECL_ARRAY_HAS_FILL_POINTER_P(a)) {
 		a = ecl_type_error(@'fill-pointer', "argument",
 				   a, c_string_to_object("(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))"));
 	}
@ -918,8 +920,7 @@ si_fill_pointer_set(cl_object a, cl_object fp)
 {
 	const cl_env_ptr the_env = ecl_process_env();
 	assert_type_vector(a);
- AGAIN:
-	if (a->vector.hasfillp) {
+	if (ECL_ARRAY_HAS_FILL_POINTER_P(a)) {
 		a->vector.fillp = 
 			ecl_fixnum_in_range(@'adjust-array',"fill pointer",fp,
 					    0,a->vector.dim);
@ -944,7 +945,7 @@ si_replace_array(cl_object olda, cl_object newa)
 	if (type_of(olda) != type_of(newa)
 	    || (type_of(olda) == t_array && olda->array.rank != newa->array.rank))
 		goto CANNOT;
-	if (!olda->array.adjustable) {
+	if (!ECL_ADJUSTABLE_ARRAY_P(olda)) {
 		/* When an array is not adjustable, we simply output the new array */
 		olda = newa;
 		goto OUTPUT;
--- a/src/c/ffi.d
+++ b/src/c/ffi.d
@ -127,7 +127,7 @@ ecl_base_string_pointer_safe(cl_object f)
 	/* FIXME! Is there a better function name? */
 	f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string);
 	s = f->base_string.self;
-	if (f->base_string.hasfillp && s[f->base_string.fillp] != 0) {
+	if (ECL_ARRAY_HAS_FILL_POINTER_P(f) && s[f->base_string.fillp] != 0) {
 		FEerror("Cannot coerce a string with fill pointer to (char *)", 0);
 	}
 	return (char *)s;
@ -138,7 +138,8 @@ ecl_null_terminated_base_string(cl_object f)
 {
 	/* FIXME! Is there a better function name? */
 	f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string);
-	if (f->base_string.hasfillp && f->base_string.self[f->base_string.fillp] != 0) {
+	if (ECL_ARRAY_HAS_FILL_POINTER_P(f) &&
+            f->base_string.self[f->base_string.fillp] != 0) {
 		return cl_copy_seq(f);
 	} else {
 		return f;
--- a/src/c/file.d
+++ b/src/c/file.d
@ -1421,7 +1421,7 @@ cl_object
 si_make_string_output_stream_from_string(cl_object s)
 {
 	cl_object strm = alloc_stream();
-	if (!ecl_stringp(s) || !s->base_string.hasfillp)
+	if (!ecl_stringp(s) || !ECL_ARRAY_HAS_FILL_POINTER_P(s))
 		FEerror("~S is not a -string with a fill-pointer.", 1, s);
 	strm->stream.ops = duplicate_dispatch_table(&str_out_ops);
 	strm->stream.mode = (short)smm_string_output;
--- a/src/c/format.d
+++ b/src/c/format.d
@ -2116,14 +2116,14 @@ DIRECTIVE:
 	}
 	if (ecl_stringp(strm)) {
 		output = strm;
-		if (!output->base_string.hasfillp) {
+		if (!ECL_ARRAY_HAS_FILL_POINTER_P(output)) {
 			cl_error(7, @'si::format-error',
 				 @':format-control',
 				 make_constant_base_string(
 "Cannot output to a non adjustable string."),
 				 @':control-string', string,
 				 @':offset', MAKE_FIXNUM(0));
-			}
+                }
 		strm = si_make_string_output_stream_from_string(strm);
 		if (null_strm == 0)
 			output = Cnil;
--- a/src/c/num_log.d
+++ b/src/c/num_log.d
@ -855,7 +855,7 @@ si_bit_array_op(cl_object o, cl_object x, cl_object y, cl_object r)
 		  r->array.dims = x->array.dims;
 		  r->array.elttype = aet_bit;
 		  r->array.dim = x->array.dim;
-		  r->array.adjustable = FALSE;
+		  r->array.flags = 0; /* no fill pointer, not adjustable */
 		  ecl_array_allocself(r);
 		}
 	}
--- a/src/c/predicate.d
+++ b/src/c/predicate.d
@ -169,14 +169,14 @@ cl_simple_string_p(cl_object x)
 #ifdef ECL_UNICODE
 	cl_type t = type_of(x);
 	@(return (((t == t_base_string || (t == t_string)) &&
-		     !x->string.adjustable &&
-		     !x->string.hasfillp &&
-		     Null(CAR(x->string.displaced))) ? Ct : Cnil))
+                   !ECL_ADJUSTABLE_ARRAY_P(x) &&
+                   !ECL_ARRAY_HAS_FILL_POINTER_P(x) &&
+                   Null(CAR(x->string.displaced))) ? Ct : Cnil))
 #else
 	@(return ((type_of(x) == t_base_string &&
-		     !x->base_string.adjustable &&
-		     !x->base_string.hasfillp &&
-		     Null(CAR(x->base_string.displaced))) ? Ct : Cnil))
+                   !ECL_ADJUSTABLE_ARRAY_P(x) &&
+                   !ECL_ARRAY_HAS_FILL_POINTER_P(x) &&
+                   Null(CAR(x->base_string.displaced))) ? Ct : Cnil))
 #endif

 }
@ -193,9 +193,9 @@ cl_object
 cl_simple_bit_vector_p(cl_object x)
 {
 	@(return ((type_of(x) == t_bitvector &&
-		     !x->vector.adjustable &&
-		     !x->vector.hasfillp &&
-		     Null(CAR(x->vector.displaced))) ? Ct : Cnil))
+                   !ECL_ADJUSTABLE_ARRAY_P(x) &&
+                   !ECL_ARRAY_HAS_FILL_POINTER_P(x) &&
+                   Null(CAR(x->vector.displaced))) ? Ct : Cnil))
 }

 cl_object
@ -203,10 +203,10 @@ cl_simple_vector_p(cl_object x)
 {
 	cl_type t = type_of(x);
 	@(return ((t == t_vector &&
-		     !x->vector.adjustable &&
-		     !x->vector.hasfillp &&
-		     Null(CAR(x->vector.displaced)) &&
-		     (cl_elttype)x->vector.elttype == aet_object) ? Ct : Cnil))
+                   !ECL_ADJUSTABLE_ARRAY_P(x) &&
+                   !ECL_ARRAY_HAS_FILL_POINTER_P(x) &&
+                   Null(CAR(x->vector.displaced)) &&
+                   (cl_elttype)x->vector.elttype == aet_object) ? Ct : Cnil))
 }

 cl_object
--- a/src/c/sequence.d
+++ b/src/c/sequence.d
@ -36,8 +36,7 @@ ecl_alloc_simple_vector(cl_index l, cl_elttype aet)
 #endif
 	case aet_bit:
 		x = ecl_alloc_object(t_bitvector);
-		x->vector.hasfillp = FALSE;
-		x->vector.adjustable = FALSE;
+		x->vector.flags = 0; /* no fill pointer, not adjustable */
 		x->vector.displaced = Cnil;
 		x->vector.dim = x->vector.fillp = l;
 		x->vector.offset = 0;
@ -46,8 +45,7 @@ ecl_alloc_simple_vector(cl_index l, cl_elttype aet)
 		break;
 	default:
 		x = ecl_alloc_object(t_vector);
-		x->vector.hasfillp = FALSE;
-		x->vector.adjustable = FALSE;
+		x->vector.flags = 0; /* no fill pointer, not adjustable */
 		x->vector.displaced = Cnil;
 		x->vector.dim = x->vector.fillp = l;
 		x->vector.self.t = NULL;
--- a/src/c/string.d
+++ b/src/c/string.d
@ -79,8 +79,7 @@ cl_alloc_simple_base_string(cl_index length)

 	x = ecl_alloc_object(t_base_string);
        x->base_string.elttype      = aet_bc;
-	x->base_string.hasfillp     = FALSE;
-	x->base_string.adjustable   = FALSE;
+        x->base_string.flags        = 0; /* no fill pointer, no adjustable */
 	x->base_string.displaced    = Cnil;
 	x->base_string.dim          = (x->base_string.fillp = length);
 	x->base_string.self         = (ecl_base_char *)ecl_alloc_atomic(length+1);
@ -97,8 +96,7 @@ cl_alloc_simple_extended_string(cl_index length)
        /* should this call si_make_vector? */
 	x = ecl_alloc_object(t_string);
        x->string.elttype    = aet_ch;
-	x->string.hasfillp   = FALSE;
-	x->string.adjustable = FALSE;
+        x->string.flags      = 0;  /* no fill pointer, no adjustable */
 	x->string.displaced  = Cnil;
 	x->string.dim        = x->string.fillp = length;
 	x->string.self       = (ecl_character *)
@ -118,8 +116,7 @@ cl_alloc_adjustable_base_string(cl_index l)
 {
 	cl_object output = cl_alloc_simple_base_string(l);
 	output->base_string.fillp = 0;
-	output->base_string.hasfillp = TRUE;
- 	output->base_string.adjustable = TRUE;
+	output->base_string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE;
 	return output;
 }

@ -128,9 +125,8 @@ cl_object
 ecl_alloc_adjustable_extended_string(cl_index l)
 {
 	cl_object output = cl_alloc_simple_extended_string(l);
-	output->base_string.fillp = 0;
-	output->base_string.hasfillp = TRUE;
- 	output->base_string.adjustable = TRUE;
+	output->string.fillp = 0;
+	output->string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE;
 	return output;
 }
 #endif
@ -146,8 +142,7 @@ make_simple_base_string(char *s)

 	x = ecl_alloc_object(t_base_string);
        x->base_string.elttype = aet_bc;
-	x->base_string.hasfillp = FALSE;
-	x->base_string.adjustable = FALSE;
+        x->base_string.flags = 0; /* no fill pointer, no adjustable */
 	x->base_string.displaced = Cnil;
 	x->base_string.dim = (x->base_string.fillp = l);
 	x->base_string.self = (ecl_base_char *)s;
@ -985,7 +980,7 @@ ecl_string_push_extend(cl_object s, ecl_character c)
 		if (s->base_string.fillp >= s->base_string.dim) {
 			cl_object other;
 			cl_index new_length;
-			if (!s->base_string.adjustable)
+			if (!ECL_ADJUSTABLE_ARRAY_P(s))
 				FEerror("string-push-extend: the string ~S is not adjustable.",
 					1, s);
 			if (s->base_string.dim >= ADIMLIM)
--- a/src/c/typespec.d
+++ b/src/c/typespec.d
@ -367,7 +367,7 @@ cl_type_of(cl_object x)
 			t = @'symbol';
 		break;
 	case t_array:
-		if (x->array.adjustable ||
+		if (ECL_ADJUSTABLE_ARRAY_P(x) ||
 		    !Null(CAR(x->array.displaced)))
 			t = @'array';
 		else
@ -375,11 +375,11 @@ cl_type_of(cl_object x)
 		t = cl_list(3, t, ecl_elttype_to_symbol(ecl_array_elttype(x)), cl_array_dimensions(1, x));
 		break;
 	case t_vector:
-		if (x->vector.adjustable ||
+		if (ECL_ADJUSTABLE_ARRAY_P(x) ||
 		    !Null(CAR(x->vector.displaced))) {
 			t = cl_list(3, @'vector', ecl_elttype_to_symbol(ecl_array_elttype(x)),
 				    MAKE_FIXNUM(x->vector.dim));
-		} else if (x->vector.hasfillp ||
+		} else if (ECL_ARRAY_HAS_FILL_POINTER_P(x) ||
 			   (cl_elttype)x->vector.elttype != aet_object) {
 			t = cl_list(3, @'simple-array', ecl_elttype_to_symbol(ecl_array_elttype(x)),
 				    cl_array_dimensions(1, x));
@ -389,8 +389,8 @@ cl_type_of(cl_object x)
 		break;
 #ifdef ECL_UNICODE
 	case t_string:
-		if (x->string.adjustable ||
-		    x->string.hasfillp ||
+		if (ECL_ADJUSTABLE_ARRAY_P(x) ||
+		    ECL_ARRAY_HAS_FILL_POINTER_P(x) ||
 		    !Null(CAR(x->string.displaced)))
 			t = @'array';
 		else
@ -399,8 +399,8 @@ cl_type_of(cl_object x)
 		break;
 #endif
 	case t_base_string:
-		if (x->base_string.adjustable ||
-		    x->base_string.hasfillp ||
+		if (ECL_ADJUSTABLE_ARRAY_P(x) ||
+		    ECL_ARRAY_HAS_FILL_POINTER_P(x) ||
 		    !Null(CAR(x->base_string.displaced)))
 			t = @'array';
 		else
@ -408,8 +408,8 @@ cl_type_of(cl_object x)
 		t = cl_list(3, t, @'base-char', cl_list(1, MAKE_FIXNUM(x->base_string.dim)));
 		break;
 	case t_bitvector:
-		if (x->vector.adjustable ||
-		    x->vector.hasfillp ||
+		if (ECL_ADJUSTABLE_ARRAY_P(x) ||
+		    ECL_ARRAY_HAS_FILL_POINTER_P(x) ||
 		    !Null(CAR(x->vector.displaced)))
 			t = @'array';
 		else
--- a/src/gc/configure
+++ b/src/gc/configure
@ -4912,7 +4912,7 @@ echo "$as_me: error: \"Pthreads not supported by the GC on this platform.\"" >&2
    cat >>confdefs.h <<\_ACEOF
 #define GC_WIN32_THREADS 1
 _ACEOF
-
+    win32_threads=1
        cat >>confdefs.h <<\_ACEOF
 #define NO_GETENV 1
 _ACEOF
--- a/src/h/ecl-cmp.h
+++ b/src/h/ecl-cmp.h
@ -28,7 +28,7 @@

 #define ecl_def_ct_base_string(name,chars,len,static,const)     \
        static const struct ecl_base_string name ## data = {    \
-                (int8_t)t_base_string, 0, aet_bc, FALSE, FALSE, \
+                (int8_t)t_base_string, 0, aet_bc, 0,            \
                Cnil, (cl_index)(len), (cl_index)(len),         \
                (ecl_base_char*)(chars) };                      \
        static const cl_object name = (cl_object)(& name ## data)
@ -46,10 +46,10 @@
        static const cl_object name = (cl_object)(& name ## data)

 #define ecl_def_ct_vector(name,type,raw,len,static,const)               \
-        static const struct ecl_vector name ## data = {            \
-                (int8_t)t_vector, 0, FALSE, FALSE,                      \
+        static const struct ecl_vector name ## data = {                 \
+                (int8_t)t_vector, 0, (type), 0,                         \
                Cnil, (cl_index)(len), (cl_index)(len),                 \
-                (ecl_base_char*)(raw), (type), 0 };                     \
+                (ecl_base_char*)(raw), 0 };                             \
        static const cl_object name = (cl_object)(& name ## data)
        
 enum ecl_locative_type {
--- a/src/h/object.h
+++ b/src/h/object.h
@ -153,7 +153,6 @@ typedef cl_object (*cl_objectfn_fixed)();
 #define HEADER			int8_t t, m, padding[2]
 #define HEADER1(field)		int8_t t, m, field, padding
 #define HEADER2(field1,field2)	int8_t t, m, field1, field2
-#define HEADER3(field1,flag2,flag3) int8_t t, m, field1; unsigned flag2:1, flag3:1
 #define HEADER4(field1,flag2,flag3,flag4) int8_t t, m, field1; unsigned flag2:4, flag3:2, flag4:2

 struct ecl_singlefloat {
@ -412,10 +411,15 @@ union ecl_array_data {
 	byte          *bit;
 };

+#define ECL_FLAG_HAS_FILL_POINTER 1
+#define ECL_FLAG_ADJUSTABLE       2
+#define ECL_ADJUSTABLE_ARRAY_P(x) ((x)->array.flags & ECL_FLAG_ADJUSTABLE)
+#define ECL_ARRAY_HAS_FILL_POINTER_P(x) ((x)->array.flags & ECL_FLAG_HAS_FILL_POINTER)
+
 struct ecl_array {		/*  array header  */
 				/*  adjustable flag  */
 				/*  has-fill-pointer flag  */
-	HEADER3(elttype,adjustable,hasfillp);
+	HEADER2(elttype,flags);	/*  array element type, has fill ptr, adjustable-p */
 	cl_object displaced;	/*  displaced  */
 	cl_index dim;		/*  dimension  */
 	cl_index *dims;		/*  table of dimensions  */
@ -427,7 +431,7 @@ struct ecl_array {		/*  array header  */
 struct ecl_vector {		/*  vector header  */
 				/*  adjustable flag  */
 				/*  has-fill-pointer flag  */
-	HEADER3(elttype,adjustable,hasfillp);
+	HEADER2(elttype,flags);	/*  array element type, has fill ptr, adjustable-p */
 	cl_object displaced;	/*  displaced  */
 	cl_index dim;		/*  dimension  */
 	cl_index fillp;		/*  fill pointer  */
@ -440,7 +444,7 @@ struct ecl_vector {		/*  vector header  */
 struct ecl_base_string {	/*  string header  */
 				/*  adjustable flag  */
 				/*  has-fill-pointer flag  */
-	HEADER3(elttype,adjustable,hasfillp);
+	HEADER2(elttype,flags);	/*  array element type, has fill ptr, adjustable-p */
 	cl_object displaced;	/*  displaced  */
 	cl_index dim;       	/*  dimension  */
 				/*  string length  */
@ -454,7 +458,7 @@ struct ecl_base_string {	/*  string header  */
 struct ecl_string {		/*  string header  */
 				/*  adjustable flag  */
 				/*  has-fill-pointer flag  */
-	HEADER3(elttype,adjustable,hasfillp);
+	HEADER2(elttype,flags);	/*  array element type, has fill ptr, adjustable-p */
 	cl_object displaced;	/*  displaced  */
 	cl_index dim;       	/*  dimension  */
 				/*  string length  */