X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=src%2Ffns.c;h=d5f5ae3fe83f484ca9f109b360bb24873e3709ed;hp=55d5e2fe53efe82bec6b038fd0d6ebe83301e991;hb=3e447015251ce6dcde843cbed10d9033d5538622;hpb=937bb3ce20f4819a75e8234cb91a1acaa19847f8 diff --git a/src/fns.c b/src/fns.c index 55d5e2f..d5f5ae3 100644 --- a/src/fns.c +++ b/src/fns.c @@ -61,7 +61,7 @@ Lisp_Object Qidentity; static int internal_old_equal (Lisp_Object, Lisp_Object, int); static Lisp_Object -mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) +mark_bit_vector (Lisp_Object obj) { return Qnil; } @@ -69,10 +69,10 @@ mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) static void print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { - int i; - struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj); - int len = bit_vector_length (v); - int last = len; + size_t i; + Lisp_Bit_Vector *v = XBIT_VECTOR (obj); + size_t len = bit_vector_length (v); + size_t last = len; if (INTP (Vprint_length)) last = min (len, XINT (Vprint_length)); @@ -92,8 +92,8 @@ print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) static int bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); - struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); + Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); + Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); return ((bit_vector_length (v1) == bit_vector_length (v2)) && !memcmp (v1->bits, v2->bits, @@ -104,17 +104,32 @@ bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) static unsigned long bit_vector_hash (Lisp_Object obj, int depth) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj); + Lisp_Bit_Vector *v = XBIT_VECTOR (obj); return HASH2 (bit_vector_length (v), memory_hash (v->bits, BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) * sizeof (long))); } -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector, - mark_bit_vector, print_bit_vector, 0, - bit_vector_equal, bit_vector_hash, 0, - struct Lisp_Bit_Vector); +static size_t +size_bit_vector (const void *lheader) +{ + Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader; + return offsetof (Lisp_Bit_Vector, + bits[BIT_VECTOR_LONG_STORAGE (bit_vector_length (v))]); +} + +static const struct lrecord_description bit_vector_description[] = { + { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) }, + { XD_END } +}; + + +DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector, + mark_bit_vector, print_bit_vector, 0, + bit_vector_equal, bit_vector_hash, + bit_vector_description, size_bit_vector, + Lisp_Bit_Vector); DEFUN ("identity", Fidentity, 1, 1, 0, /* Return the argument unchanged. @@ -177,7 +192,7 @@ length_with_bytecode_hack (Lisp_Object seq) return XINT (Flength (seq)); else { - struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); return (f->flags.interactivep ? COMPILED_INTERACTIVE : f->flags.domainp ? COMPILED_DOMAIN : @@ -189,7 +204,7 @@ length_with_bytecode_hack (Lisp_Object seq) #endif /* LOSING_BYTECODE */ void -check_losing_bytecode (CONST char *function, Lisp_Object seq) +check_losing_bytecode (const char *function, Lisp_Object seq) { if (COMPILED_FUNCTIONP (seq)) error_with_frob @@ -208,7 +223,7 @@ Return the length of vector, bit vector, list or string SEQUENCE. return make_int (XSTRING_CHAR_LENGTH (sequence)); else if (CONSP (sequence)) { - int len; + size_t len; GET_EXTERNAL_LIST_LENGTH (sequence, len); return make_int (len); } @@ -235,7 +250,7 @@ which is at least the number of distinct elements. (list)) { Lisp_Object hare, tortoise; - int len; + size_t len; for (hare = tortoise = list, len = 0; CONSP (hare) && (! EQ (hare, tortoise) || len == 0); @@ -261,7 +276,7 @@ Symbols are also allowed; their print names are used instead. (s1, s2)) { Bytecount len; - struct Lisp_String *p1, *p2; + Lisp_String *p1, *p2; if (SYMBOLP (s1)) p1 = XSYMBOL (s1)->name; @@ -308,7 +323,7 @@ may be solved. */ (s1, s2)) { - struct Lisp_String *p1, *p2; + Lisp_String *p1, *p2; Charcount end, len2; int i; @@ -387,7 +402,7 @@ of the string are changed (e.g. with `aset'). It wraps around occasionally. */ (string)) { - struct Lisp_String *s; + Lisp_String *s; CHECK_STRING (string); s = XSTRING (string); @@ -400,7 +415,7 @@ of the string are changed (e.g. with `aset'). It wraps around occasionally. void bump_string_modiff (Lisp_Object str) { - struct Lisp_String *s = XSTRING (str); + Lisp_String *s = XSTRING (str); Lisp_Object *ptr = &s->plist; #ifdef I18N3 @@ -515,7 +530,7 @@ copy_list (Lisp_Object list) Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list)); Lisp_Object last = list_copy; Lisp_Object hare, tortoise; - int len; + size_t len; for (tortoise = hare = XCDR (list), len = 1; CONSP (hare); @@ -906,85 +921,78 @@ Relevant parts of the string-extent-data are copied in the new string. } DEFUN ("subseq", Fsubseq, 2, 3, 0, /* -Return a subsequence of SEQ, starting at index FROM and ending before TO. -TO may be nil or omitted; then the subsequence runs to the end of SEQ. -If FROM or TO is negative, it counts from the end. -The resulting subsequence is always the same type as the original - sequence. -If SEQ is a string, relevant parts of the string-extent-data are copied - to the new string. +Return the subsequence of SEQUENCE starting at START and ending before END. +END may be omitted; then the subsequence runs to the end of SEQUENCE. +If START or END is negative, it counts from the end. +The returned subsequence is always of the same type as SEQUENCE. +If SEQUENCE is a string, relevant parts of the string-extent-data +are copied to the new string. */ - (seq, from, to)) + (sequence, start, end)) { - int len, f, t; - - if (STRINGP (seq)) - return Fsubstring (seq, from, to); + EMACS_INT len, s, e; - if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq)) - { - check_losing_bytecode ("subseq", seq); - seq = wrong_type_argument (Qsequencep, seq); - } + if (STRINGP (sequence)) + return Fsubstring (sequence, start, end); - len = XINT (Flength (seq)); + len = XINT (Flength (sequence)); - CHECK_INT (from); - f = XINT (from); - if (f < 0) - f = len + f; + CHECK_INT (start); + s = XINT (start); + if (s < 0) + s = len + s; - if (NILP (to)) - t = len; + if (NILP (end)) + e = len; else { - CHECK_INT (to); - t = XINT (to); - if (t < 0) - t = len + t; + CHECK_INT (end); + e = XINT (end); + if (e < 0) + e = len + e; } - if (!(0 <= f && f <= t && t <= len)) - args_out_of_range_3 (seq, make_int (f), make_int (t)); + if (!(0 <= s && s <= e && e <= len)) + args_out_of_range_3 (sequence, make_int (s), make_int (e)); - if (VECTORP (seq)) + if (VECTORP (sequence)) { - Lisp_Object result = make_vector (t - f, Qnil); - int i; - Lisp_Object *in_elts = XVECTOR_DATA (seq); + Lisp_Object result = make_vector (e - s, Qnil); + EMACS_INT i; + Lisp_Object *in_elts = XVECTOR_DATA (sequence); Lisp_Object *out_elts = XVECTOR_DATA (result); - for (i = f; i < t; i++) - out_elts[i - f] = in_elts[i]; + for (i = s; i < e; i++) + out_elts[i - s] = in_elts[i]; return result; } - - if (LISTP (seq)) + else if (LISTP (sequence)) { Lisp_Object result = Qnil; - int i; + EMACS_INT i; - seq = Fnthcdr (make_int (f), seq); + sequence = Fnthcdr (make_int (s), sequence); - for (i = f; i < t; i++) + for (i = s; i < e; i++) { - result = Fcons (Fcar (seq), result); - seq = Fcdr (seq); + result = Fcons (Fcar (sequence), result); + sequence = Fcdr (sequence); } return Fnreverse (result); } + else if (BIT_VECTORP (sequence)) + { + Lisp_Object result = make_bit_vector (e - s, Qzero); + EMACS_INT i; - /* bit vector */ - { - Lisp_Object result = make_bit_vector (t - f, Qzero); - int i; - - for (i = f; i < t; i++) - set_bit_vector_bit (XBIT_VECTOR (result), i - f, - bit_vector_bit (XBIT_VECTOR (seq), i)); - return result; - } + for (i = s; i < e; i++) + set_bit_vector_bit (XBIT_VECTOR (result), i - s, + bit_vector_bit (XBIT_VECTOR (sequence), i)); + return result; + } + else + abort (); /* unreachable, since Flength (sequence) did not get an error */ } @@ -993,7 +1001,7 @@ Take cdr N times on LIST, and return the result. */ (n, list)) { - REGISTER int i; + REGISTER size_t i; REGISTER Lisp_Object tail = list; CHECK_NATNUM (n); for (i = XINT (n); i; i--) @@ -1052,7 +1060,7 @@ Return element of SEQUENCE at index N. #ifdef LOSING_BYTECODE else if (COMPILED_FUNCTIONP (sequence)) { - int idx = XINT (n); + EMACS_INT idx = XINT (n); if (idx < 0) { lose: @@ -1104,7 +1112,7 @@ If N is greater than the length of LIST, then LIST itself is returned. */ (list, n)) { - int int_n, count; + EMACS_INT int_n, count; Lisp_Object retval, tortoise, hare; CHECK_LIST (list); @@ -1140,7 +1148,7 @@ If LIST has N or fewer elements, nil is returned and LIST is unmodified. */ (list, n)) { - int int_n; + EMACS_INT int_n; CHECK_LIST (list); @@ -1843,7 +1851,7 @@ int plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, int laxp, int depth) { - int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */ + int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ int la, lb, m, i, fill; Lisp_Object *keys, *vals; char *flags; @@ -1887,10 +1895,10 @@ plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, { if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth)) { - if ((eqp - /* We narrowly escaped being Ebolified here. */ - ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) - : !internal_equal (v, vals [i], depth))) + if (eqp + /* We narrowly escaped being Ebolified here. */ + ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) + : !internal_equal (v, vals [i], depth)) /* a property in B has a different value than in A */ goto MISMATCH; flags [i] = 1; @@ -2361,8 +2369,7 @@ This means that it's a malformed or circular plist. DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /* Given a plist, return non-nil if its format is correct. If it returns nil, `check-valid-plist' will signal an error when given -the plist; that means it's a malformed or circular plist or has non-symbols -as keywords. +the plist; that means it's a malformed or circular plist. */ (plist)) { @@ -2439,9 +2446,7 @@ properties on the list. (lax_plist, prop, default_)) { Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME); - if (UNBOUNDP (val)) - return default_; - return val; + return UNBOUNDP (val) ? default_ : val; } DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* @@ -2561,228 +2566,87 @@ See also `alist-to-plist'. return head; } -/* Symbol plists are directly accessible, so we need to protect against - invalid property list structure */ - -static Lisp_Object -symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object default_) -{ - Lisp_Object val = external_plist_get (&XSYMBOL (sym)->plist, propname, - 0, ERROR_ME); - return UNBOUNDP (val) ? default_ : val; -} - -static void -symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value) -{ - external_plist_put (&XSYMBOL (sym)->plist, propname, value, 0, ERROR_ME); -} - -static int -symbol_remprop (Lisp_Object symbol, Lisp_Object propname) -{ - return external_remprop (&XSYMBOL (symbol)->plist, propname, 0, ERROR_ME); -} - -/* We store the string's extent info as the first element of the string's - property list; and the string's MODIFF as the first or second element - of the string's property list (depending on whether the extent info - is present), but only if the string has been modified. This is ugly - but it reduces the memory allocated for the string in the vast - majority of cases, where the string is never modified and has no - extent info. */ - - -static Lisp_Object * -string_plist_ptr (struct Lisp_String *s) -{ - Lisp_Object *ptr = &s->plist; - - if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) - ptr = &XCDR (*ptr); - if (CONSP (*ptr) && INTP (XCAR (*ptr))) - ptr = &XCDR (*ptr); - return ptr; -} - -static Lisp_Object -string_getprop (struct Lisp_String *s, Lisp_Object property, - Lisp_Object default_) -{ - Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0, - ERROR_ME); - return UNBOUNDP (val) ? default_ : val; -} - -static void -string_putprop (struct Lisp_String *s, Lisp_Object property, - Lisp_Object value) -{ - external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME); -} - -static int -string_remprop (struct Lisp_String *s, Lisp_Object property) -{ - return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME); -} - -static Lisp_Object -string_plist (struct Lisp_String *s) -{ - return *string_plist_ptr (s); -} - DEFUN ("get", Fget, 2, 3, 0, /* -Return the value of OBJECT's PROPNAME property. -This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'. +Return the value of OBJECT's PROPERTY property. +This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'. If there is no such property, return optional third arg DEFAULT -\(which defaults to `nil'). OBJECT can be a symbol, face, extent, -or string. See also `put', `remprop', and `object-plist'. +\(which defaults to `nil'). OBJECT can be a symbol, string, extent, +face, or glyph. See also `put', `remprop', and `object-plist'. */ - (object, propname, default_)) + (object, property, default_)) { /* Various places in emacs call Fget() and expect it not to quit, so don't quit. */ + Lisp_Object val; - /* It's easiest to treat symbols specially because they may not - be an lrecord */ - if (SYMBOLP (object)) - return symbol_getprop (object, propname, default_); - else if (STRINGP (object)) - return string_getprop (XSTRING (object), propname, default_); - else if (LRECORDP (object)) - { - CONST struct lrecord_implementation *imp - = XRECORD_LHEADER_IMPLEMENTATION (object); - if (!imp->getprop) - goto noprops; - - { - Lisp_Object val = (imp->getprop) (object, propname); - if (UNBOUNDP (val)) - val = default_; - return val; - } - } + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop) + val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property); else - { - noprops: - signal_simple_error ("Object type has no properties", object); - return Qnil; /* Not reached */ - } + signal_simple_error ("Object type has no properties", object); + + return UNBOUNDP (val) ? default_ : val; } DEFUN ("put", Fput, 3, 3, 0, /* -Store OBJECT's PROPNAME property with value VALUE. -It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a -symbol, face, extent, or string. - +Set OBJECT's PROPERTY to VALUE. +It can be subsequently retrieved with `(get OBJECT PROPERTY)'. +OBJECT can be a symbol, face, extent, or string. For a string, no properties currently have predefined meanings. For the predefined properties for extents, see `set-extent-property'. For the predefined properties for faces, see `set-face-property'. - See also `get', `remprop', and `object-plist'. */ - (object, propname, value)) + (object, property, value)) { - CHECK_SYMBOL (propname); CHECK_LISP_WRITEABLE (object); - if (SYMBOLP (object)) - symbol_putprop (object, propname, value); - else if (STRINGP (object)) - string_putprop (XSTRING (object), propname, value); - else if (LRECORDP (object)) + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER_IMPLEMENTATION (object); - if (imp->putprop) - { - if (! (imp->putprop) (object, propname, value)) - signal_simple_error ("Can't set property on object", propname); - } - else - goto noprops; + if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop + (object, property, value)) + signal_simple_error ("Can't set property on object", property); } else - { - noprops: - signal_simple_error ("Object type has no settable properties", object); - } + signal_simple_error ("Object type has no settable properties", object); return value; } -void -pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val) -{ - Fput (sym, prop, Fpurecopy (val)); -} - DEFUN ("remprop", Fremprop, 2, 2, 0, /* -Remove from OBJECT's property list the property PROPNAME and its -value. OBJECT can be a symbol, face, extent, or string. Returns -non-nil if the property list was actually changed (i.e. if PROPNAME -was present in the property list). See also `get', `put', and -`object-plist'. +Remove, from OBJECT's property list, PROPERTY and its corresponding value. +OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil +if the property list was actually modified (i.e. if PROPERTY was present +in the property list). See also `get', `put', and `object-plist'. */ - (object, propname)) + (object, property)) { - int retval = 0; + int ret = 0; - CHECK_SYMBOL (propname); CHECK_LISP_WRITEABLE (object); - if (SYMBOLP (object)) - retval = symbol_remprop (object, propname); - else if (STRINGP (object)) - retval = string_remprop (XSTRING (object), propname); - else if (LRECORDP (object)) + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER_IMPLEMENTATION (object); - if (imp->remprop) - { - retval = (imp->remprop) (object, propname); - if (retval == -1) - signal_simple_error ("Can't remove property from object", - propname); - } - else - goto noprops; + ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property); + if (ret == -1) + signal_simple_error ("Can't remove property from object", property); } else - { - noprops: - signal_simple_error ("Object type has no removable properties", object); - } + signal_simple_error ("Object type has no removable properties", object); - return retval ? Qt : Qnil; + return ret ? Qt : Qnil; } DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /* -Return a property list of OBJECT's props. -For a symbol this is equivalent to `symbol-plist'. -Do not modify the property list directly; this may or may not have -the desired effects. (In particular, for a property with a special -interpretation, this will probably have no effect at all.) +Return a property list of OBJECT's properties. +For a symbol, this is equivalent to `symbol-plist'. +OBJECT can be a symbol, string, extent, face, or glyph. +Do not modify the returned property list directly; +this may or may not have the desired effects. Use `put' instead. */ (object)) { - if (SYMBOLP (object)) - return Fsymbol_plist (object); - else if (STRINGP (object)) - return string_plist (XSTRING (object)); - else if (LRECORDP (object)) - { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER_IMPLEMENTATION (object); - if (imp->plist) - return (imp->plist) (object); - else - signal_simple_error ("Object type has no properties", object); - } + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist) + return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object); else signal_simple_error ("Object type has no properties", object); @@ -2803,7 +2667,7 @@ internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) return 0; if (LRECORDP (obj1)) { - CONST struct lrecord_implementation + const struct lrecord_implementation *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); @@ -2863,7 +2727,7 @@ Do not use it. DEFUN ("fillarray", Ffillarray, 2, 2, 0, /* -Store each element of ARRAY with ITEM. +Destructively modify ARRAY by replacing each element with ITEM. ARRAY is a vector, bit vector, or string. */ (array, item)) @@ -2871,15 +2735,28 @@ ARRAY is a vector, bit vector, or string. retry: if (STRINGP (array)) { - Emchar charval; - struct Lisp_String *s = XSTRING (array); - Charcount len = string_char_length (s); - Charcount i; + Lisp_String *s = XSTRING (array); + Bytecount old_bytecount = string_length (s); + Bytecount new_bytecount; + Bytecount item_bytecount; + Bufbyte item_buf[MAX_EMCHAR_LEN]; + Bufbyte *p; + Bufbyte *end; + CHECK_CHAR_COERCE_INT (item); CHECK_LISP_WRITEABLE (array); - charval = XCHAR (item); - for (i = 0; i < len; i++) - set_string_char (s, i, charval); + + item_bytecount = set_charptr_emchar (item_buf, XCHAR (item)); + new_bytecount = item_bytecount * string_char_length (s); + + resize_string (s, -1, new_bytecount - old_bytecount); + + for (p = string_data (s), end = p + new_bytecount; + p < end; + p += item_bytecount) + memcpy (p, item_buf, item_bytecount); + *p = '\0'; + bump_string_modiff (array); } else if (VECTORP (array)) @@ -2892,7 +2769,7 @@ ARRAY is a vector, bit vector, or string. } else if (BIT_VECTORP (array)) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (array); + Lisp_Bit_Vector *v = XBIT_VECTOR (array); int len = bit_vector_length (v); int bit; CHECK_BIT (item); @@ -3042,15 +2919,16 @@ changing the value of `foo'. } -/* This is the guts of all mapping functions. - Apply fn to each element of seq, one by one, - storing the results into elements of vals, a C vector of Lisp_Objects. - leni is the length of vals, which should also be the length of seq. +/* This is the guts of several mapping functions. + Apply FUNCTION to each element of SEQUENCE, one by one, + storing the results into elements of VALS, a C vector of Lisp_Objects. + LENI is the length of VALS, which should also be the length of SEQUENCE. If VALS is a null pointer, do not accumulate the results. */ static void -mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) +mapcar1 (size_t leni, Lisp_Object *vals, + Lisp_Object function, Lisp_Object sequence) { Lisp_Object result; Lisp_Object args[2]; @@ -3063,21 +2941,61 @@ mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) gcpro1.nvars = 0; } - args[0] = fn; + args[0] = function; - if (LISTP (seq)) + if (LISTP (sequence)) { - for (i = 0; i < leni; i++) + /* A devious `function' could either: + - insert garbage into the list in front of us, causing XCDR to crash + - amputate the list behind us using (setcdr), causing the remaining + elts to lose their GCPRO status. + + if (vals != 0) we avoid this by copying the elts into the + `vals' array. By a stroke of luck, `vals' is exactly large + enough to hold the elts left to be traversed as well as the + results computed so far. + + if (vals == 0) we don't have any free space available and + don't want to eat up any more stack with alloca(). + So we use EXTERNAL_LIST_LOOP_3 and GCPRO the tail. */ + + if (vals) { - args[1] = XCAR (seq); - seq = XCDR (seq); - result = Ffuncall (2, args); - if (vals) vals[gcpro1.nvars++] = result; + Lisp_Object *val = vals; + Lisp_Object elt; + + LIST_LOOP_2 (elt, sequence) + *val++ = elt; + + gcpro1.nvars = leni; + + for (i = 0; i < leni; i++) + { + args[1] = vals[i]; + vals[i] = Ffuncall (2, args); + } + } + else + { + Lisp_Object elt, tail; + struct gcpro ngcpro1; + + NGCPRO1 (tail); + + { + EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + args[1] = elt; + Ffuncall (2, args); + } + } + + NUNGCPRO; } } - else if (VECTORP (seq)) + else if (VECTORP (sequence)) { - Lisp_Object *objs = XVECTOR_DATA (seq); + Lisp_Object *objs = XVECTOR_DATA (sequence); for (i = 0; i < leni; i++) { args[1] = *objs++; @@ -3085,10 +3003,16 @@ mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) if (vals) vals[gcpro1.nvars++] = result; } } - else if (STRINGP (seq)) + else if (STRINGP (sequence)) { - Bufbyte *p = XSTRING_DATA (seq); - for (i = 0; i < leni; i++) + /* The string data of `sequence' might be relocated during GC. */ + Bytecount slen = XSTRING_LENGTH (sequence); + Bufbyte *p = alloca_array (Bufbyte, slen); + Bufbyte *end = p + slen; + + memcpy (p, XSTRING_DATA (sequence), slen); + + while (p < end) { args[1] = make_char (charptr_emchar (p)); INC_CHARPTR (p); @@ -3096,9 +3020,9 @@ mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) if (vals) vals[gcpro1.nvars++] = result; } } - else if (BIT_VECTORP (seq)) + else if (BIT_VECTORP (sequence)) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq); + Lisp_Bit_Vector *v = XBIT_VECTOR (sequence); for (i = 0; i < leni; i++) { args[1] = make_int (bit_vector_bit (v, i)); @@ -3107,86 +3031,87 @@ mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) } } else - abort(); /* cannot get here since Flength(seq) did not get an error */ + abort (); /* unreachable, since Flength (sequence) did not get an error */ if (vals) UNGCPRO; } DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /* -Apply FN to each element of SEQ, and concat the results as strings. -In between each pair of results, stick in SEP. -Thus, " " as SEP results in spaces between the values returned by FN. +Apply FUNCTION to each element of SEQUENCE, and concat the results as strings. +In between each pair of results, insert SEPARATOR. Thus, using " " as +SEPARATOR results in spaces between the values returned by FUNCTION. +SEQUENCE may be a list, a vector, a bit vector, or a string. */ - (fn, seq, sep)) + (function, sequence, separator)) { - size_t len = XINT (Flength (seq)); + size_t len = XINT (Flength (sequence)); Lisp_Object *args; int i; - struct gcpro gcpro1; int nargs = len + len - 1; - if (nargs < 0) return build_string (""); + if (len == 0) return build_string (""); args = alloca_array (Lisp_Object, nargs); - GCPRO1 (sep); - mapcar1 (len, args, fn, seq); - UNGCPRO; + mapcar1 (len, args, function, sequence); for (i = len - 1; i >= 0; i--) args[i + i] = args[i]; for (i = 1; i < nargs; i += 2) - args[i] = sep; + args[i] = separator; return Fconcat (nargs, args); } DEFUN ("mapcar", Fmapcar, 2, 2, 0, /* -Apply FUNCTION to each element of SEQUENCE, and make a list of the results. -The result is a list just as long as SEQUENCE. +Apply FUNCTION to each element of SEQUENCE; return a list of the results. +The result is a list of the same length as SEQUENCE. SEQUENCE may be a list, a vector, a bit vector, or a string. */ - (fn, seq)) + (function, sequence)) { - size_t len = XINT (Flength (seq)); + size_t len = XINT (Flength (sequence)); Lisp_Object *args = alloca_array (Lisp_Object, len); - mapcar1 (len, args, fn, seq); + mapcar1 (len, args, function, sequence); return Flist (len, args); } DEFUN ("mapvector", Fmapvector, 2, 2, 0, /* -Apply FUNCTION to each element of SEQUENCE, making a vector of the results. +Apply FUNCTION to each element of SEQUENCE; return a vector of the results. The result is a vector of the same length as SEQUENCE. -SEQUENCE may be a list, a vector or a string. +SEQUENCE may be a list, a vector, a bit vector, or a string. */ - (fn, seq)) + (function, sequence)) { - size_t len = XINT (Flength (seq)); + size_t len = XINT (Flength (sequence)); Lisp_Object result = make_vector (len, Qnil); struct gcpro gcpro1; GCPRO1 (result); - mapcar1 (len, XVECTOR_DATA (result), fn, seq); + mapcar1 (len, XVECTOR_DATA (result), function, sequence); UNGCPRO; return result; } -DEFUN ("mapc", Fmapc, 2, 2, 0, /* +DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /* Apply FUNCTION to each element of SEQUENCE. SEQUENCE may be a list, a vector, a bit vector, or a string. This function is like `mapcar' but does not accumulate the results, which is more efficient if you do not use the results. + +The difference between this and `mapc' is that `mapc' supports all +the spiffy Common Lisp arguments. You should normally use `mapc'. */ - (fn, seq)) + (function, sequence)) { - mapcar1 (XINT (Flength (seq)), 0, fn, seq); + mapcar1 (XINT (Flength (sequence)), 0, function, sequence); - return seq; + return sequence; } @@ -3871,7 +3796,7 @@ syms_of_fns (void) DEFSUBR (Fnconc); DEFSUBR (Fmapcar); DEFSUBR (Fmapvector); - DEFSUBR (Fmapc); + DEFSUBR (Fmapc_internal); DEFSUBR (Fmapconcat); DEFSUBR (Fload_average); DEFSUBR (Ffeaturep);