From e8f08ac8d4822eac0f1b0daec22acd05710d8fae Mon Sep 17 00:00:00 2001 From: jgarcia Date: Tue, 26 Dec 2006 18:57:13 +0000 Subject: [PATCH] Arrays can now be displaced to foreign data --- msvc/ecl-threads.def | 1 - msvc/ecl.def | 1 - src/CHANGELOG | 6 +- src/c/array.d | 157 ++++++++++++++++--------------------------- src/c/string.d | 43 +++++------- src/h/external.h | 1 - src/lsp/ffi.lsp | 2 +- 7 files changed, 80 insertions(+), 131 deletions(-) diff --git a/msvc/ecl-threads.def b/msvc/ecl-threads.def index eb14e8841..f2fbce0ab 100755 --- a/msvc/ecl-threads.def +++ b/msvc/ecl-threads.def @@ -51,7 +51,6 @@ EXPORTS aset aset1 array_allocself - adjust_displaced array_elttype ecl_symbol_to_elttype ecl_elttype_to_symbol diff --git a/msvc/ecl.def b/msvc/ecl.def index b39afc1ad..8f38fae62 100644 --- a/msvc/ecl.def +++ b/msvc/ecl.def @@ -51,7 +51,6 @@ EXPORTS aset aset1 array_allocself - adjust_displaced array_elttype ecl_symbol_to_elttype ecl_elttype_to_symbol diff --git a/src/CHANGELOG b/src/CHANGELOG index 603543b9d..d01e24653 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -34,6 +34,10 @@ ECL 1.0: - TIME outputs information about consed bytes and calls to the garbage collector. + - MAKE-ARRAY accepts a foreign pointer as an argument to :DISPLACED-TO That + creates a lisp array on top of the foreign data and can be used to directly + scan C strings, or unboxed arrays of numbers. + * Bugs fixed: - STREAMP signals an error for Gray streams. @@ -189,7 +193,7 @@ ECL 1.0: - C functions which disappear: si_set_compiled_function_name(), si_extended_string_concatenate(), assert_type_string(), assert_type_character(), assert_type_symbol(), make_symbol(), - parse_number(), parse_integer(). + parse_number(), parse_integer(), adjust_displaced(). - Lisp functions which disappear: si:set-compiled-function-name, si:extended-string-concatenate, si:list-nth, si:rplaca-nthcdr. diff --git a/src/c/array.d b/src/c/array.d index 6637b5d6e..993b0ce72 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -555,33 +555,41 @@ ecl_elttype_to_symbol(cl_elttype aet) } static void * -array_address(cl_object x, cl_index inc) +address_inc(void *address, cl_fixnum inc, cl_elttype elt_type) { - switch(array_elttype(x)) { + union ecl_array_data aux; + aux.t = address; + switch (elt_type) { #ifdef ECL_UNICODE case aet_ch: #endif case aet_object: - return x->array.self.t + inc; + return aux.t + inc; case aet_fix: - return x->array.self.fix + inc; + return aux.fix + inc; case aet_index: - return x->array.self.fix + inc; + return aux.fix + inc; case aet_sf: - return x->array.self.sf + inc; + return aux.sf + inc; case aet_bc: - return x->base_string.self + inc; + return aux.ch + inc; case aet_df: - return x->array.self.df + inc; + return aux.df + inc; case aet_b8: - return x->array.self.b8 + inc; + return aux.b8 + inc; case aet_i8: - return x->array.self.i8 + inc; + return aux.i8 + inc; default: FEbad_aet(); } } +static void * +array_address(cl_object x, cl_index inc) +{ + return address_inc(x->array.self.t, inc, array_elttype(x)); +} + cl_object cl_array_element_type(cl_object a) { @@ -601,85 +609,41 @@ static void displace(cl_object from, cl_object to, cl_object offset) { cl_index j; + void *base; cl_elttype totype, fromtype; - - totype = array_elttype(to); fromtype = array_elttype(from); - if (totype != fromtype) - FEerror("Cannot displace the array,~%\ + if (type_of(to) == t_foreign) { + if (fromtype == aet_bit) { + FEerror("Cannot displace bit vectors onto foreign data",0); + } + base = to->foreign.data; + j = ecl_fixnum_in_range(@'adjust-array',"array displacement", offset, + 0, MOST_POSITIVE_FIXNUM); + from->array.displaced = to; + } else { + totype = array_elttype(to); + if (totype != fromtype) + FEerror("Cannot displace the array,~%\ because the element types don't match.", 0); - if (from->array.dim > to->array.dim) - FEerror("Cannot displace the array,~%\ + if (from->array.dim > to->array.dim) + FEerror("Cannot displace the array,~%\ because the total size of the to-array is too small.", 0); - j = ecl_fixnum_in_range(@'adjust-array',"array displacement",offset, - 0, to->array.dim - from->array.dim); - from->array.displaced = CONS(to, Cnil); - if (Null(to->array.displaced)) - to->array.displaced = CONS(Cnil, Cnil); - CDR(to->array.displaced) = - CONS(from, CDR(to->array.displaced)); - if (fromtype == aet_bit) { - j += to->vector.offset; - from->vector.self.bit = to->vector.self.bit + j/CHAR_BIT; - from->vector.offset = j%CHAR_BIT; - } -#ifndef BYTE_ADDRESS - else if (fromtype != aet_bc) - from->array.self.t = (cl_object *)(array_address(to, j)); -#endif - else - from->base_string.self = (char *)array_address(to, j); -} - -/* - Check_displaced(dlist, orig, newdim) checks if the displaced - arrays can keep the displacement when the original array is - adjusted. - Dlist is the list of displaced arrays, orig is the original array - and newdim is the new dimension of the original array. -*/ -static void -check_displaced(cl_object dlist, cl_object orig, cl_index newdim) -{ - cl_object x; - - for (; dlist != Cnil; dlist = CDR(dlist)) { - x = CAR(dlist); - if (x->array.self.t == NULL) - continue; - if (array_elttype(x) != aet_bit) { - if (array_address(x, x->array.dim) > - array_address(orig, newdim)) - FEerror("Can't keep displacement.", 0); - } else { - if ((x->vector.self.bit - orig->vector.self.bit)*CHAR_BIT + - x->vector.dim - newdim + - x->vector.offset - orig->vector.offset > 0) - FEerror("Can't keep displacement.", 0); + j = ecl_fixnum_in_range(@'adjust-array',"array displacement",offset, + 0, to->array.dim - from->array.dim); + from->array.displaced = CONS(to, Cnil); + if (Null(to->array.displaced)) + to->array.displaced = CONS(Cnil, Cnil); + CDR(to->array.displaced) = + CONS(from, CDR(to->array.displaced)); + if (fromtype == aet_bit) { + j += to->vector.offset; + from->vector.offset = j%CHAR_BIT; + from->vector.self.bit = to->vector.self.bit + j/CHAR_BIT; + return; } - check_displaced(CDR(x->array.displaced), orig, newdim); - } -} - -/* - Adjust_displaced(x, diff) adds the int value diff - to the a_self field of the array x and all the arrays displaced to x. - This function is used in @si::replace-array (ADJUST-ARRAY) and - the garbage collector. -*/ -void adjust_displaced(cl_object x, ptrdiff_t diff) -{ - if (x->array.self.t != NULL) { - if (array_elttype(x) == aet_bit) { - ptrdiff_t aux = diff + x->array.offset; - x->array.offset = aux % CHAR_BIT; - x->array.self.bit += aux / CHAR_BIT; - } else { - x->array.self.t = (cl_object *)((char*)(x->array.self.t) + diff); - } - for (x = CDR(x->array.displaced); x != Cnil; x = CDR(x)) - adjust_displaced(CAR(x), diff); + base = to->array.self.t; } + from->array.self.t = address_inc(base, j, fromtype); } cl_elttype @@ -780,7 +744,8 @@ cl_array_displacement(cl_object a) break; case aet_bit: offset = a->array.self.bit - to_array->array.self.bit; - offset = offset * CHAR_BIT + a->array.offset; + offset = offset * CHAR_BIT + a->array.offset + - to_array->array.offset; break; case aet_fix: offset = a->array.self.fix - to_array->array.self.fix; @@ -902,9 +867,7 @@ si_fill_pointer_set(cl_object a, cl_object fp) cl_object si_replace_array(cl_object olda, cl_object newa) { - cl_object displaced, dlist; - ptrdiff_t diff; - + cl_object dlist; if (type_of(olda) != type_of(newa) || (type_of(olda) == t_array && olda->array.rank != newa->array.rank)) goto CANNOT; @@ -913,23 +876,22 @@ si_replace_array(cl_object olda, cl_object newa) olda = newa; goto OUTPUT; } - diff = (char*)(newa->array.self.t) - (char*)(olda->array.self.t); - if (array_elttype(newa) == aet_bit) { - diff = diff * CHAR_BIT + (newa->array.offset - olda->array.offset); + for (dlist = CDR(olda->array.displaced); dlist != Cnil; dlist = CDR(dlist)) { + cl_object other_array = CAR(dlist); + cl_object offset; + cl_array_displacement(other_array); + offset = VALUES(1); + displace(other_array, newa, offset); } - dlist = CDR(olda->array.displaced); - displaced = CONS(CAR(newa->array.displaced), dlist); - check_displaced(dlist, olda, newa->array.dim); - adjust_displaced(olda, diff); switch (type_of(olda)) { case t_array: -#ifdef ECL_UNICODE - case t_string: -#endif case t_vector: case t_bitvector: olda->array = newa->array; break; +#ifdef ECL_UNICODE + case t_string: +#endif case t_base_string: olda->base_string = newa->base_string; break; @@ -938,7 +900,6 @@ si_replace_array(cl_object olda, cl_object newa) FEerror("Cannot replace the array ~S by the array ~S.", 2, olda, newa); } - olda->array.displaced = displaced; OUTPUT: @(return olda) } diff --git a/src/c/string.d b/src/c/string.d index 71dd599d9..1e3354136 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -947,46 +947,33 @@ nstring_case(cl_narg narg, cl_object fun, int (*casefun)(int, bool *), cl_va_lis int ecl_string_push_extend(cl_object s, int c) { - cl_index new_length; AGAIN: switch(type_of(s)) { #ifdef ECL_UNICODE case t_string: - if (s->string.fillp >= s->string.dim) { - cl_object *p; - if (!s->string.adjustable) - FEerror("string-push-extend: the string ~S is not adjustable.", - 1, s); - start_critical_section(); /* avoid losing p */ - if (s->string.dim >= ADIMLIM/2) - FEerror("Can't extend the string.", 0); - new_length = (s->string.dim + 1) * 2; - p = (cl_object *)cl_alloc_align(sizeof (cl_object)*new_length, sizeof (cl_object)); - memcpy(p, s->string.self, s->string.dim * sizeof (cl_object)); - s->string.dim = new_length; - adjust_displaced(s, p - s->string.self); - end_critical_section(); - } - s->string.self[s->string.fillp++] = CODE_CHAR(c); - return c; #endif case t_base_string: + /* We use the fact that both string types are + byte-compatible except for the data. */ if (s->base_string.fillp >= s->base_string.dim) { - char *p; + cl_object other; + cl_index new_length; if (!s->base_string.adjustable) FEerror("string-push-extend: the string ~S is not adjustable.", 1, s); - start_critical_section(); /* avoid losing p */ - if (s->base_string.dim >= ADIMLIM/2) + if (s->base_string.dim >= ADIMLIM) FEerror("Can't extend the string.", 0); - new_length = (s->base_string.dim + 1) * 2; - p = (char *)cl_alloc_atomic(new_length+1); p[new_length] = 0; - memcpy(p, s->base_string.self, s->base_string.dim * sizeof(char)); - s->base_string.dim = new_length; - adjust_displaced(s, p - (char *)s->base_string.self); - end_critical_section(); + new_length = 1 + s->base_string.dim + (s->base_string.dim / 2); + if (new_length > ADIMLIM) + new_length = ADIMLIM; + other = si_make_vector(cl_array_element_type(s), + MAKE_FIXNUM(new_length), Ct, + MAKE_FIXNUM(s->base_string.fillp), + Cnil, MAKE_FIXNUM(0)); + ecl_copy_subarray(other, 0, s, 0, s->base_string.fillp); + s = si_replace_array(s, other); } - s->base_string.self[s->base_string.fillp++] = c; + ecl_char_set(s, s->base_string.fillp++, c); return c; default: s = ecl_type_error(@'vector-push-extend',"",s,@'string'); diff --git a/src/h/external.h b/src/h/external.h index d63b3ff80..f480a743a 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -275,7 +275,6 @@ extern cl_object aref1(cl_object v, cl_index index); extern cl_object aset(cl_object x, cl_index index, cl_object value); extern cl_object aset1(cl_object v, cl_index index, cl_object val); extern void array_allocself(cl_object x); -extern void adjust_displaced(cl_object x, ptrdiff_t diff); extern cl_elttype array_elttype(cl_object x); extern cl_elttype ecl_symbol_to_elttype(cl_object x); extern cl_object ecl_elttype_to_symbol(cl_elttype aet); diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 0c4477bd6..270f5ce22 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -648,7 +648,7 @@ (dyn-form #+dffi (when (and (not system-library) si::*use-dffi*) `((si:load-foreign-module ,filename))) #-dffi nil)) - `(progn ,@compile-form ,@dyn-form)))) + `(progn ,@compile-form ,@dyn-form))) ;;;---------------------------------------------------------------------- ;;; CALLBACKS