X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Ffns.c;h=55d5e2fe53efe82bec6b038fd0d6ebe83301e991;hb=f8b0dcc32dce11bef09e2fbcde040aecd1f86fd1;hp=2f306280f8856168de128acf81c24c6d60b5c160;hpb=fc475e6669a613cd6d98eb5511c749a23b63c7ac;p=chise%2Fxemacs-chise.git- diff --git a/src/fns.c b/src/fns.c index 2f30628..55d5e2f 100644 --- a/src/fns.c +++ b/src/fns.c @@ -43,7 +43,6 @@ Boston, MA 02111-1307, USA. */ #include "buffer.h" #include "bytecode.h" -#include "commands.h" #include "device.h" #include "events.h" #include "extents.h" @@ -91,10 +90,10 @@ print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) } static int -bit_vector_equal (Lisp_Object o1, Lisp_Object o2, int depth) +bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (o1); - struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (o2); + struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); + struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); return ((bit_vector_length (v1) == bit_vector_length (v2)) && !memcmp (v1->bits, v2->bits, @@ -114,7 +113,7 @@ bit_vector_hash (Lisp_Object obj, int depth) DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector, mark_bit_vector, print_bit_vector, 0, - bit_vector_equal, bit_vector_hash, + bit_vector_equal, bit_vector_hash, 0, struct Lisp_Bit_Vector); DEFUN ("identity", Fidentity, 1, 1, 0, /* @@ -178,10 +177,10 @@ length_with_bytecode_hack (Lisp_Object seq) return XINT (Flength (seq)); else { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (seq); + struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); - return (b->flags.interactivep ? COMPILED_INTERACTIVE : - b->flags.domainp ? COMPILED_DOMAIN : + return (f->flags.interactivep ? COMPILED_INTERACTIVE : + f->flags.domainp ? COMPILED_DOMAIN : COMPILED_DOC_STRING) + 1; } @@ -209,16 +208,9 @@ Return the length of vector, bit vector, list or string SEQUENCE. return make_int (XSTRING_CHAR_LENGTH (sequence)); else if (CONSP (sequence)) { - Lisp_Object tail; - int i = 0; - - EXTERNAL_LIST_LOOP (tail, sequence) - { - QUIT; - i++; - } - - return make_int (i); + int len; + GET_EXTERNAL_LIST_LENGTH (sequence, len); + return make_int (len); } else if (VECTORP (sequence)) return make_int (XVECTOR_LENGTH (sequence)); @@ -234,9 +226,6 @@ Return the length of vector, bit vector, list or string SEQUENCE. } } -/* This does not check for quits. That is safe - since it must terminate. */ - DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /* Return the length of a list, but avoid error or infinite loop. This function never gets an error. If LIST is not really a list, @@ -245,17 +234,15 @@ which is at least the number of distinct elements. */ (list)) { - Lisp_Object halftail = list; /* Used to detect circular lists. */ - Lisp_Object tail; - int len = 0; + Lisp_Object hare, tortoise; + int len; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + for (hare = tortoise = list, len = 0; + CONSP (hare) && (! EQ (hare, tortoise) || len == 0); + hare = XCDR (hare), len++) { - if (EQ (tail, halftail) && len != 0) - break; - len++; - if ((len & 1) == 0) - halftail = XCDR (halftail); + if (len & 1) + tortoise = XCDR (tortoise); } return make_int (len); @@ -352,32 +339,41 @@ may be solved. properly, it would still not work because strcoll() does not handle multiple locales. This is the fundamental flaw in the locale model. */ - Bytecount bcend = charcount_to_bytecount (string_data (p1), end); - /* Compare strings using collation order of locale. */ - /* Need to be tricky to handle embedded nulls. */ + { + Bytecount bcend = charcount_to_bytecount (string_data (p1), end); + /* Compare strings using collation order of locale. */ + /* Need to be tricky to handle embedded nulls. */ - for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1) - { - int val = strcoll ((char *) string_data (p1) + i, - (char *) string_data (p2) + i); - if (val < 0) - return Qt; - if (val > 0) - return Qnil; - } + for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1) + { + int val = strcoll ((char *) string_data (p1) + i, + (char *) string_data (p2) + i); + if (val < 0) + return Qt; + if (val > 0) + return Qnil; + } + } #else /* not I18N2, or MULE */ - /* #### It is not really necessary to do this: We could compare - byte-by-byte and still get a reasonable comparison, since this - would compare characters with a charset in the same way. - With a little rearrangement of the leading bytes, we could - make most inter-charset comparisons work out the same, too; - even if some don't, this is not a big deal because inter-charset - comparisons aren't really well-defined anyway. */ - for (i = 0; i < end; i++) - { - if (string_char (p1, i) != string_char (p2, i)) - return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil; - } + { + Bufbyte *ptr1 = string_data (p1); + Bufbyte *ptr2 = string_data (p2); + + /* #### It is not really necessary to do this: We could compare + byte-by-byte and still get a reasonable comparison, since this + would compare characters with a charset in the same way. With + a little rearrangement of the leading bytes, we could make most + inter-charset comparisons work out the same, too; even if some + don't, this is not a big deal because inter-charset comparisons + aren't really well-defined anyway. */ + for (i = 0; i < end; i++) + { + if (charptr_emchar (ptr1) != charptr_emchar (ptr2)) + return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil; + INC_CHARPTR (ptr1); + INC_CHARPTR (ptr2); + } + } #endif /* not I18N2, or MULE */ /* Can't do i < len2 because then comparison between "foo" and "foo^@" won't work right in I18N2 case */ @@ -511,38 +507,65 @@ arguments. Each argument may be a list, vector, bit vector, or string. return concat (nargs, args, c_bit_vector, 0); } -DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /* -Return a copy of a list, vector, bit vector or string. -The elements of a list or vector are not copied; they are shared +/* Copy a (possibly dotted) list. LIST must be a cons. + Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */ +static Lisp_Object +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; + + for (tortoise = hare = XCDR (list), len = 1; + CONSP (hare); + hare = XCDR (hare), len++) + { + XCDR (last) = Fcons (XCAR (hare), XCDR (hare)); + last = XCDR (last); + + if (len < CIRCULAR_LIST_SUSPICION_LENGTH) + continue; + if (len & 1) + tortoise = XCDR (tortoise); + if (EQ (tortoise, hare)) + signal_circular_list_error (list); + } + + return list_copy; +} + +DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /* +Return a copy of list LIST, which may be a dotted list. +The elements of LIST are not copied; they are shared with the original. */ - (arg)) + (list)) { again: - if (NILP (arg)) return arg; - /* We handle conses separately because concat() is big and hairy and - doesn't handle (copy-sequence '(a b . c)) and it's easier to redo this - than to fix concat() without worrying about breaking other things. - */ - if (CONSP (arg)) - { - Lisp_Object head = Fcons (XCAR (arg), XCDR (arg)); - Lisp_Object tail = head; + if (NILP (list)) return list; + if (CONSP (list)) return copy_list (list); - for (arg = XCDR (arg); CONSP (arg); arg = XCDR (arg)) - { - XCDR (tail) = Fcons (XCAR (arg), XCDR (arg)); - tail = XCDR (tail); - QUIT; - } - return head; - } - if (STRINGP (arg)) return concat (1, &arg, c_string, 0); - if (VECTORP (arg)) return concat (1, &arg, c_vector, 0); - if (BIT_VECTORP (arg)) return concat (1, &arg, c_bit_vector, 0); + list = wrong_type_argument (Qlistp, list); + goto again; +} - check_losing_bytecode ("copy-sequence", arg); - arg = wrong_type_argument (Qsequencep, arg); +DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /* +Return a copy of list, vector, bit vector or string SEQUENCE. +The elements of a list or vector are not copied; they are shared +with the original. SEQUENCE may be a dotted list. +*/ + (sequence)) +{ + again: + if (NILP (sequence)) return sequence; + if (CONSP (sequence)) return copy_list (sequence); + if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0); + if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0); + if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0); + + check_losing_bytecode ("copy-sequence", sequence); + sequence = wrong_type_argument (Qsequencep, sequence); goto again; } @@ -867,19 +890,18 @@ Relevant parts of the string-extent-data are copied in the new string. (string, from, to)) { Charcount ccfr, ccto; - Bytecount bfr, bto; + Bytecount bfr, blen; Lisp_Object val; CHECK_STRING (string); - /* Historically, FROM could not be omitted. Whatever ... */ CHECK_INT (from); get_string_range_char (string, from, to, &ccfr, &ccto, GB_HISTORICAL_STRING_BEHAVIOR); bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr); - bto = charcount_to_bytecount (XSTRING_DATA (string), ccto); - val = make_string (XSTRING_DATA (string) + bfr, bto - bfr); + blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr); + val = make_string (XSTRING_DATA (string) + bfr, blen); /* Copy any applicable extent information into the new string: */ - copy_string_extents (val, string, 0, bfr, bto - bfr); + copy_string_extents (val, string, 0, bfr, blen); return val; } @@ -1023,9 +1045,9 @@ Return element of SEQUENCE at index N. args_out_of_range (sequence, n); #endif } - else if (STRINGP (sequence) - || VECTORP (sequence) - || BIT_VECTORP (sequence)) + else if (STRINGP (sequence) || + VECTORP (sequence) || + BIT_VECTORP (sequence)) return Faref (sequence, n); #ifdef LOSING_BYTECODE else if (COMPILED_FUNCTIONP (sequence)) @@ -1038,24 +1060,24 @@ Return element of SEQUENCE at index N. } /* Utter perversity */ { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (sequence); + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence); switch (idx) { case COMPILED_ARGLIST: - return b->arglist; - case COMPILED_BYTECODE: - return b->bytecodes; + return compiled_function_arglist (f); + case COMPILED_INSTRUCTIONS: + return compiled_function_instructions (f); case COMPILED_CONSTANTS: - return b->constants; + return compiled_function_constants (f); case COMPILED_STACK_DEPTH: - return make_int (b->maxdepth); + return compiled_function_stack_depth (f); case COMPILED_DOC_STRING: - return compiled_function_documentation (b); + return compiled_function_documentation (f); case COMPILED_DOMAIN: - return compiled_function_domain (b); + return compiled_function_domain (f); case COMPILED_INTERACTIVE: - if (b->flags.interactivep) - return compiled_function_interactive (b); + if (f->flags.interactivep) + return compiled_function_interactive (f); /* if we return nil, can't tell interactive with no args from noninteractive. */ goto lose; @@ -1073,19 +1095,126 @@ Return element of SEQUENCE at index N. } } +DEFUN ("last", Flast, 1, 2, 0, /* +Return the tail of list LIST, of length N (default 1). +LIST may be a dotted list, but not a circular list. +Optional argument N must be a non-negative integer. +If N is zero, then the atom that terminates the list is returned. +If N is greater than the length of LIST, then LIST itself is returned. +*/ + (list, n)) +{ + int int_n, count; + Lisp_Object retval, tortoise, hare; + + CHECK_LIST (list); + + if (NILP (n)) + int_n = 1; + else + { + CHECK_NATNUM (n); + int_n = XINT (n); + } + + for (retval = tortoise = hare = list, count = 0; + CONSP (hare); + hare = XCDR (hare), + (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0), + count++) + { + if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = XCDR (tortoise); + if (EQ (hare, tortoise)) + signal_circular_list_error (list); + } + + return retval; +} + +DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /* +Modify LIST to remove the last N (default 1) elements. +If LIST has N or fewer elements, nil is returned and LIST is unmodified. +*/ + (list, n)) +{ + int int_n; + + CHECK_LIST (list); + + if (NILP (n)) + int_n = 1; + else + { + CHECK_NATNUM (n); + int_n = XINT (n); + } + + { + Lisp_Object last_cons = list; + + EXTERNAL_LIST_LOOP_1 (list) + { + if (int_n-- < 0) + last_cons = XCDR (last_cons); + } + + if (int_n >= 0) + return Qnil; + + XCDR (last_cons) = Qnil; + return list; + } +} + +DEFUN ("butlast", Fbutlast, 1, 2, 0, /* +Return a copy of LIST with the last N (default 1) elements removed. +If LIST has N or fewer elements, nil is returned. +*/ + (list, n)) +{ + int int_n; + + CHECK_LIST (list); + + if (NILP (n)) + int_n = 1; + else + { + CHECK_NATNUM (n); + int_n = XINT (n); + } + + { + Lisp_Object retval = Qnil; + Lisp_Object tail = list; + + EXTERNAL_LIST_LOOP_1 (list) + { + if (--int_n < 0) + { + retval = Fcons (XCAR (tail), retval); + tail = XCDR (tail); + } + } + + return Fnreverse (retval); + } +} + DEFUN ("member", Fmember, 2, 2, 0, /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'. The value is actually the tail of LIST whose car is ELT. */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - CONCHECK_CONS (tail); - if (internal_equal (elt, XCAR (tail), 0)) + if (internal_equal (elt, list_elt, 0)) return tail; - QUIT; } return Qnil; } @@ -1098,13 +1227,11 @@ Do not use it. */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - CONCHECK_CONS (tail); - if (internal_old_equal (elt, XCAR (tail), 0)) + if (internal_old_equal (elt, list_elt, 0)) return tail; - QUIT; } return Qnil; } @@ -1115,14 +1242,11 @@ The value is actually the tail of LIST whose car is ELT. */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) + if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) return tail; - QUIT; } return Qnil; } @@ -1135,14 +1259,11 @@ Do not use it. */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem)) + if (HACKEQ_UNSAFE (elt, list_elt)) return tail; - QUIT; } return Qnil; } @@ -1150,11 +1271,10 @@ Do not use it. Lisp_Object memq_no_quit (Lisp_Object elt, Lisp_Object list) { - REGISTER Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object list_elt, tail; + LIST_LOOP_3 (list_elt, list, tail) { - REGISTER Lisp_Object tem; - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) + if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) return tail; } return Qnil; @@ -1167,15 +1287,11 @@ The value is actually the element of LIST whose car equals KEY. (key, list)) { /* This function can GC. */ - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (XCAR (elt), key, 0)) + if (internal_equal (key, elt_car, 0)) return elt; - QUIT; } return Qnil; } @@ -1187,15 +1303,11 @@ The value is actually the element of LIST whose car equals KEY. (key, list)) { /* This function can GC. */ - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_old_equal (XCAR (elt), key, 0)) + if (internal_old_equal (key, elt_car, 0)) return elt; - QUIT; } return Qnil; } @@ -1215,15 +1327,11 @@ Elements of LIST that are not conses are ignored. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) return elt; - QUIT; } return Qnil; } @@ -1237,15 +1345,11 @@ Do not use it. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), HACKEQ_UNSAFE (key, tem))) + if (HACKEQ_UNSAFE (key, elt_car)) return elt; - QUIT; } return Qnil; } @@ -1257,13 +1361,12 @@ Lisp_Object assq_no_quit (Lisp_Object key, Lisp_Object list) { /* This cannot GC. */ - REGISTER Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object elt; + LIST_LOOP_2 (elt, list) { - REGISTER Lisp_Object tem, elt; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) - return elt; + Lisp_Object elt_car = XCAR (elt); + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) + return elt; } return Qnil; } @@ -1274,15 +1377,11 @@ The value is actually the element of LIST whose cdr equals KEY. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (XCDR (elt), key, 0)) + if (internal_equal (key, elt_cdr, 0)) return elt; - QUIT; } return Qnil; } @@ -1293,15 +1392,11 @@ The value is actually the element of LIST whose cdr equals KEY. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_old_equal (XCDR (elt), key, 0)) + if (internal_old_equal (key, elt_cdr, 0)) return elt; - QUIT; } return Qnil; } @@ -1312,15 +1407,11 @@ The value is actually the element of LIST whose cdr is KEY. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) + if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr)) return elt; - QUIT; } return Qnil; } @@ -1331,28 +1422,25 @@ The value is actually the element of LIST whose cdr is KEY. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), HACKEQ_UNSAFE (key, tem))) + if (HACKEQ_UNSAFE (key, elt_cdr)) return elt; - QUIT; } return Qnil; } +/* Like Frassq, but caller must ensure that LIST is properly + nil-terminated and ebola-free. */ Lisp_Object rassq_no_quit (Lisp_Object key, Lisp_Object list) { - REGISTER Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object elt; + LIST_LOOP_2 (elt, list) { - REGISTER Lisp_Object elt, tem; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) + Lisp_Object elt_cdr = XCDR (elt); + if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr)) return elt; } return Qnil; @@ -1369,24 +1457,9 @@ Also see: `remove'. */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - CONCHECK_CONS (tail); - if (internal_equal (elt, XCAR (tail), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (internal_equal (elt, list_elt, 0))); return list; } @@ -1399,24 +1472,9 @@ of changing the value of `foo'. */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - CONCHECK_CONS (tail); - if (internal_old_equal (elt, XCAR (tail), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (internal_old_equal (elt, list_elt, 0))); return list; } @@ -1429,25 +1487,9 @@ changing the value of `foo'. */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); return list; } @@ -1460,50 +1502,21 @@ changing the value of `foo'. */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (HACKEQ_UNSAFE (elt, list_elt))); return list; } -/* no quit, no errors; be careful */ +/* Like Fdelq, but caller must ensure that LIST is properly + nil-terminated and ebola-free. */ Lisp_Object delq_no_quit (Lisp_Object elt, Lisp_Object list) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (CONSP (tail)) - { - REGISTER Lisp_Object tem; - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - } + Lisp_Object list_elt; + LIST_LOOP_DELETE_IF (list_elt, list, + (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); return list; } @@ -1519,26 +1532,24 @@ delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list) { REGISTER Lisp_Object tail = list; REGISTER Lisp_Object prev = Qnil; - struct Lisp_Cons *cons_to_free = NULL; - while (CONSP (tail)) + while (!NILP (tail)) { - REGISTER Lisp_Object tem; - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) + REGISTER Lisp_Object tem = XCAR (tail); + if (EQ (elt, tem)) { + Lisp_Object cons_to_free = tail; if (NILP (prev)) list = XCDR (tail); else XCDR (prev) = XCDR (tail); - cons_to_free = XCONS (tail); + tail = XCDR (tail); + free_cons (XCONS (cons_to_free)); } else - prev = tail; - tail = XCDR (tail); - if (cons_to_free) { - free_cons (cons_to_free); - cons_to_free = NULL; + prev = tail; + tail = XCDR (tail); } } return list; @@ -1553,26 +1564,10 @@ the value of `foo'. */ (key, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (key, XCAR (elt), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + internal_equal (key, XCAR (elt), 0))); return list; } @@ -1593,26 +1588,10 @@ the value of `foo'. */ (key, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); return list; } @@ -1621,24 +1600,10 @@ the value of `foo'. Lisp_Object remassq_no_quit (Lisp_Object key, Lisp_Object list) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (CONSP (tail)) - { - REGISTER Lisp_Object elt, tem; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - } + Lisp_Object elt; + LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); return list; } @@ -1651,26 +1616,10 @@ the value of `foo'. */ (value, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (value, XCDR (elt), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + internal_equal (value, XCDR (elt), 0))); return list; } @@ -1683,52 +1632,21 @@ the value of `foo'. */ (value, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (value, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); return list; } -/* no quit, no errors; be careful */ - +/* Like Fremrassq, fast and unsafe; be careful */ Lisp_Object remrassq_no_quit (Lisp_Object value, Lisp_Object list) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (CONSP (tail)) - { - REGISTER Lisp_Object elt, tem; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (value, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - } + Lisp_Object elt; + LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); return list; } @@ -1748,7 +1666,6 @@ Also see: `reverse'. while (!NILP (tail)) { REGISTER Lisp_Object next; - QUIT; CONCHECK_CONS (tail); next = XCDR (tail); XCDR (tail) = prev; @@ -1765,17 +1682,13 @@ See also the function `nreverse', which is used more often. */ (list)) { - REGISTER Lisp_Object tail; - Lisp_Object new = Qnil; - - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object reversed_list = Qnil; + Lisp_Object elt; + EXTERNAL_LIST_LOOP_2 (elt, list) { - new = Fcons (XCAR (tail), new); - QUIT; + reversed_list = Fcons (elt, reversed_list); } - if (!NILP (tail)) - dead_wrong_type_argument (Qlistp, tail); - return new; + return reversed_list; } static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, @@ -2081,13 +1994,12 @@ If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with Lisp_Object internal_plist_get (Lisp_Object plist, Lisp_Object property) { - Lisp_Object tail = plist; + Lisp_Object tail; - for (; !NILP (tail); tail = XCDR (XCDR (tail))) + for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail))) { - struct Lisp_Cons *c = XCONS (tail); - if (EQ (c->car, property)) - return XCAR (c->cdr); + if (EQ (XCAR (tail), property)) + return XCAR (XCDR (tail)); } return Qunbound; @@ -2117,26 +2029,22 @@ internal_plist_put (Lisp_Object *plist, Lisp_Object property, int internal_remprop (Lisp_Object *plist, Lisp_Object property) { - Lisp_Object tail = *plist; + Lisp_Object tail, prev; - if (NILP (tail)) - return 0; - - if (EQ (XCAR (tail), property)) - { - *plist = XCDR (XCDR (tail)); - return 1; - } - - for (tail = XCDR (tail); !NILP (XCDR (tail)); + for (tail = *plist, prev = Qnil; + !NILP (tail); tail = XCDR (XCDR (tail))) { - struct Lisp_Cons *c = XCONS (tail); - if (EQ (XCAR (c->cdr), property)) + if (EQ (XCAR (tail), property)) { - c->cdr = XCDR (XCDR (c->cdr)); + if (NILP (prev)) + *plist = XCDR (XCDR (tail)); + else + XCDR (XCDR (prev)) = XCDR (XCDR (tail)); return 1; } + else + prev = tail; } return 0; @@ -2211,7 +2119,7 @@ advance_plist_pointers (Lisp_Object *plist, Lisp_Object *tortsave = *tortoise; /* Note that our "fixing" may be more brutal than necessary, - but it's the user's own problem, not ours. if they went in and + but it's the user's own problem, not ours, if they went in and manually fucked up a plist. */ for (i = 0; i < 2; i++) @@ -2385,9 +2293,7 @@ one of the properties on the list. (plist, prop, default_)) { Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME); - if (UNBOUNDP (val)) - return default_; - return val; + return UNBOUNDP (val) ? default_ : val; } DEFUN ("plist-put", Fplist_put, 3, 3, 0, /* @@ -2423,7 +2329,8 @@ Return t if PROP has a value specified in PLIST. */ (plist, prop)) { - return UNBOUNDP (Fplist_get (plist, prop, Qunbound)) ? Qnil : Qt; + Lisp_Object val = Fplist_get (plist, prop, Qunbound); + return UNBOUNDP (val) ? Qnil : Qt; } DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /* @@ -2512,7 +2419,8 @@ The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the /* external_remprop returns 1 if it removed any property. We have to loop till it didn't remove anything, in case the property occurs many times. */ - while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)); + while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)) + DO_NOTHING; plist = Fcdr (next); } @@ -2523,7 +2431,7 @@ DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /* Extract a value from a lax property list. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. This function returns the value corresponding to the given PROP, or DEFAULT if PROP is not one of the properties on the list. @@ -2539,7 +2447,7 @@ properties on the list. DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* Change value in LAX-PLIST of PROP to VAL. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. PROP is usually a symbol and VAL is any object. If PROP is already a property on the list, its value is set to VAL, otherwise the new PROP VAL pair is added. The new plist @@ -2555,7 +2463,7 @@ use the new value. The LAX-PLIST is modified by side effects. DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /* Remove from LAX-PLIST the property PROP and its value. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. PROP is usually a symbol. The new plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be sure to use the new value. The LAX-PLIST is modified by side effects. @@ -2569,7 +2477,7 @@ sure to use the new value. The LAX-PLIST is modified by side effects. DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /* Return t if PROP has a value specified in LAX-PLIST. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. */ (lax_plist, prop)) @@ -2612,7 +2520,8 @@ The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the /* external_remprop returns 1 if it removed any property. We have to loop till it didn't remove anything, in case the property occurs many times. */ - while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)); + while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)) + DO_NOTHING; lax_plist = Fcdr (next); } @@ -2733,37 +2642,35 @@ or string. See also `put', `remprop', and `object-plist'. */ (object, propname, default_)) { - Lisp_Object val; - /* Various places in emacs call Fget() and expect it not to quit, so don't quit. */ /* It's easiest to treat symbols specially because they may not be an lrecord */ if (SYMBOLP (object)) - val = symbol_getprop (object, propname, default_); + return symbol_getprop (object, propname, default_); else if (STRINGP (object)) - val = string_getprop (XSTRING (object), propname, default_); + return string_getprop (XSTRING (object), propname, default_); else if (LRECORDP (object)) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER_IMPLEMENTATION (object); - if (imp->getprop) - { - val = (imp->getprop) (object, propname); - if (UNBOUNDP (val)) - val = default_; - } - else + 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; + } } else { noprops: signal_simple_error ("Object type has no properties", object); + return Qnil; /* Not reached */ } - - return val; } DEFUN ("put", Fput, 3, 3, 0, /* @@ -2780,7 +2687,7 @@ See also `get', `remprop', and `object-plist'. (object, propname, value)) { CHECK_SYMBOL (propname); - CHECK_IMPURE (object); + CHECK_LISP_WRITEABLE (object); if (SYMBOLP (object)) symbol_putprop (object, propname, value); @@ -2825,7 +2732,7 @@ was present in the property list). See also `get', `put', and int retval = 0; CHECK_SYMBOL (propname); - CHECK_IMPURE (object); + CHECK_LISP_WRITEABLE (object); if (SYMBOLP (object)) retval = symbol_remprop (object, propname); @@ -2884,63 +2791,25 @@ interpretation, this will probably have no effect at all.) int -internal_equal (Lisp_Object o1, Lisp_Object o2, int depth) +internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); -#ifndef LRECORD_CONS - do_cdr: -#endif QUIT; - if (EQ_WITH_EBOLA_NOTICE (o1, o2)) + if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) return 1; /* Note that (equal 20 20.0) should be nil */ - else if (XTYPE (o1) != XTYPE (o2)) + if (XTYPE (obj1) != XTYPE (obj2)) return 0; -#ifndef LRECORD_CONS - else if (CONSP (o1)) - { - if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1)) - return 0; - o1 = XCDR (o1); - o2 = XCDR (o2); - goto do_cdr; - } -#endif -#ifndef LRECORD_VECTOR - else if (VECTORP (o1)) - { - Lisp_Object *v1 = XVECTOR_DATA (o1); - Lisp_Object *v2 = XVECTOR_DATA (o2); - int len = XVECTOR_LENGTH (o1); - if (len != XVECTOR_LENGTH (o2)) - return 0; - while (len--) - if (!internal_equal (*v1++, *v2++, depth + 1)) - return 0; - return 1; - } -#endif -#ifndef LRECORD_STRING - else if (STRINGP (o1)) - { - Bytecount len; - return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) && - !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)); - } -#endif - else if (LRECORDP (o1)) + if (LRECORDP (obj1)) { CONST struct lrecord_implementation - *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1), - *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2); - if (imp1 != imp2) - return 0; - else if (imp1->equal == 0) + *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), + *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); + + return (imp1 == imp2) && /* EQ-ness of the objects was noticed above */ - return 0; - else - return (imp1->equal) (o1, o2, depth); + (imp1->equal && (imp1->equal) (obj1, obj2, depth)); } return 0; @@ -2952,72 +2821,18 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth) but that seems unlikely. */ static int -internal_old_equal (Lisp_Object o1, Lisp_Object o2, int depth) +internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); -#ifndef LRECORD_CONS - do_cdr: -#endif QUIT; - if (HACKEQ_UNSAFE (o1, o2)) + if (HACKEQ_UNSAFE (obj1, obj2)) return 1; /* Note that (equal 20 20.0) should be nil */ - else if (XTYPE (o1) != XTYPE (o2)) + if (XTYPE (obj1) != XTYPE (obj2)) return 0; -#ifndef LRECORD_CONS - else if (CONSP (o1)) - { - if (!internal_old_equal (XCAR (o1), XCAR (o2), depth + 1)) - return 0; - o1 = XCDR (o1); - o2 = XCDR (o2); - goto do_cdr; - } -#endif -#ifndef LRECORD_VECTOR - else if (VECTORP (o1)) - { - int indice; - int len = XVECTOR_LENGTH (o1); - if (len != XVECTOR_LENGTH (o2)) - return 0; - for (indice = 0; indice < len; indice++) - { - if (!internal_old_equal (XVECTOR_DATA (o1) [indice], - XVECTOR_DATA (o2) [indice], - depth + 1)) - return 0; - } - return 1; - } -#endif -#ifndef LRECORD_STRING - else if (STRINGP (o1)) - { - Bytecount len = XSTRING_LENGTH (o1); - if (len != XSTRING_LENGTH (o2)) - return 0; - if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)) - return 0; - return 1; - } -#endif - else if (LRECORDP (o1)) - { - CONST struct lrecord_implementation - *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1), - *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2); - if (imp1 != imp2) - return 0; - else if (imp1->equal == 0) - /* EQ-ness of the objects was noticed above */ - return 0; - else - return (imp1->equal) (o1, o2, depth); - } - return 0; + return internal_equal (obj1, obj2, depth); } DEFUN ("equal", Fequal, 2, 2, 0, /* @@ -3027,9 +2842,9 @@ Conses are compared by comparing the cars and the cdrs. Vectors and strings are compared element by element. Numbers are compared by value. Symbols must match exactly. */ - (o1, o2)) + (obj1, obj2)) { - return internal_equal (o1, o2, 0) ? Qt : Qnil; + return internal_equal (obj1, obj2, 0) ? Qt : Qnil; } DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* @@ -3041,9 +2856,9 @@ this is known as the "char-int confoundance disease." See `eq' and This function is provided only for byte-code compatibility with v19. Do not use it. */ - (o1, o2)) + (obj1, obj2)) { - return internal_old_equal (o1, o2, 0) ? Qt : Qnil; + return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil; } @@ -3061,7 +2876,7 @@ ARRAY is a vector, bit vector, or string. Charcount len = string_char_length (s); Charcount i; CHECK_CHAR_COERCE_INT (item); - CHECK_IMPURE (array); + CHECK_LISP_WRITEABLE (array); charval = XCHAR (item); for (i = 0; i < len; i++) set_string_char (s, i, charval); @@ -3071,7 +2886,7 @@ ARRAY is a vector, bit vector, or string. { Lisp_Object *p = XVECTOR_DATA (array); int len = XVECTOR_LENGTH (array); - CHECK_IMPURE (array); + CHECK_LISP_WRITEABLE (array); while (len--) *p++ = item; } @@ -3081,7 +2896,7 @@ ARRAY is a vector, bit vector, or string. int len = bit_vector_length (v); int bit; CHECK_BIT (item); - CHECK_IMPURE (array); + CHECK_LISP_WRITEABLE (array); bit = XINT (item); while (len--) set_bit_vector_bit (v, len, bit); @@ -3095,12 +2910,53 @@ ARRAY is a vector, bit vector, or string. } Lisp_Object -nconc2 (Lisp_Object s1, Lisp_Object s2) +nconc2 (Lisp_Object arg1, Lisp_Object arg2) { Lisp_Object args[2]; - args[0] = s1; - args[1] = s2; - return Fnconc (2, args); + struct gcpro gcpro1; + args[0] = arg1; + args[1] = arg2; + + GCPRO1 (args[0]); + gcpro1.nvars = 2; + + RETURN_UNGCPRO (bytecode_nconc2 (args)); +} + +Lisp_Object +bytecode_nconc2 (Lisp_Object *args) +{ + retry: + + if (CONSP (args[0])) + { + /* (setcdr (last args[0]) args[1]) */ + Lisp_Object tortoise, hare; + int count; + + for (hare = tortoise = args[0], count = 0; + CONSP (XCDR (hare)); + hare = XCDR (hare), count++) + { + if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = XCDR (tortoise); + if (EQ (hare, tortoise)) + signal_circular_list_error (args[0]); + } + XCDR (hare) = args[1]; + return args[0]; + } + else if (NILP (args[0])) + { + return args[1]; + } + else + { + args[0] = wrong_type_argument (args[0], Qlistp); + goto retry; + } } DEFUN ("nconc", Fnconc, 0, MANY, 0, /* @@ -3128,25 +2984,37 @@ changing the value of `foo'. while (argnum < nargs) { - Lisp_Object val = args[argnum]; + Lisp_Object val; + retry: + val = args[argnum]; if (CONSP (val)) { - /* Found the first cons, which will be our return value. */ - Lisp_Object last = val; + /* `val' is the first cons, which will be our return value. */ + /* `last_cons' will be the cons cell to mutate. */ + Lisp_Object last_cons = val; + Lisp_Object tortoise = val; for (argnum++; argnum < nargs; argnum++) { Lisp_Object next = args[argnum]; - redo: + retry_next: if (CONSP (next) || argnum == nargs -1) { /* (setcdr (last val) next) */ - while (CONSP (XCDR (last))) + int count; + + for (count = 0; + CONSP (XCDR (last_cons)); + last_cons = XCDR (last_cons), count++) { - last = XCDR (last); - QUIT; + if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = XCDR (tortoise); + if (EQ (last_cons, tortoise)) + signal_circular_list_error (args[argnum-1]); } - XCDR (last) = next; + XCDR (last_cons) = next; } else if (NILP (next)) { @@ -3154,8 +3022,8 @@ changing the value of `foo'. } else { - next = wrong_type_argument (next, Qlistp); - goto redo; + next = wrong_type_argument (Qlistp, next); + goto retry_next; } } RETURN_UNGCPRO (val); @@ -3165,86 +3033,84 @@ changing the value of `foo'. else if (argnum == nargs - 1) /* last arg? */ RETURN_UNGCPRO (val); else - args[argnum] = wrong_type_argument (val, Qlistp); + { + args[argnum] = wrong_type_argument (Qlistp, val); + goto retry; + } } RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */ } /* 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. + 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. - If VALS is a null pointer, do not accumulate the results. */ + If VALS is a null pointer, do not accumulate the results. */ static void -mapcar1 (int leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) +mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) { - Lisp_Object tail; - Lisp_Object dummy = Qnil; - int i; - struct gcpro gcpro1, gcpro2, gcpro3; Lisp_Object result; - - GCPRO3 (dummy, fn, seq); + Lisp_Object args[2]; + int i; + struct gcpro gcpro1; if (vals) { - /* Don't let vals contain any garbage when GC happens. */ - for (i = 0; i < leni; i++) - vals[i] = Qnil; - gcpro1.var = vals; - gcpro1.nvars = leni; + GCPRO1 (vals[0]); + gcpro1.nvars = 0; } - /* We need not explicitly protect `tail' because it is used only on - lists, and 1) lists are not relocated and 2) the list is marked - via `seq' so will not be freed */ + args[0] = fn; - if (VECTORP (seq)) + if (LISTP (seq)) { for (i = 0; i < leni; i++) { - dummy = XVECTOR_DATA (seq)[i]; - result = call1 (fn, dummy); - if (vals) - vals[i] = result; + args[1] = XCAR (seq); + seq = XCDR (seq); + result = Ffuncall (2, args); + if (vals) vals[gcpro1.nvars++] = result; } } - else if (BIT_VECTORP (seq)) + else if (VECTORP (seq)) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq); + Lisp_Object *objs = XVECTOR_DATA (seq); for (i = 0; i < leni; i++) { - XSETINT (dummy, bit_vector_bit (v, i)); - result = call1 (fn, dummy); - if (vals) - vals[i] = result; + args[1] = *objs++; + result = Ffuncall (2, args); + if (vals) vals[gcpro1.nvars++] = result; } } else if (STRINGP (seq)) { + Bufbyte *p = XSTRING_DATA (seq); for (i = 0; i < leni; i++) { - result = call1 (fn, make_char (string_char (XSTRING (seq), i))); - if (vals) - vals[i] = result; + args[1] = make_char (charptr_emchar (p)); + INC_CHARPTR (p); + result = Ffuncall (2, args); + if (vals) vals[gcpro1.nvars++] = result; } } - else /* Must be a list, since Flength did not get an error */ + else if (BIT_VECTORP (seq)) { - tail = seq; + struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq); for (i = 0; i < leni; i++) { - result = call1 (fn, Fcar (tail)); - if (vals) - vals[i] = result; - tail = Fcdr (tail); + args[1] = make_int (bit_vector_bit (v, i)); + result = Ffuncall (2, args); + if (vals) vals[gcpro1.nvars++] = result; } } + else + abort(); /* cannot get here since Flength(seq) did not get an error */ - UNGCPRO; + if (vals) + UNGCPRO; } DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /* @@ -3254,7 +3120,7 @@ Thus, " " as SEP results in spaces between the values returned by FN. */ (fn, seq, sep)) { - int len = XINT (Flength (seq)); + size_t len = XINT (Flength (seq)); Lisp_Object *args; int i; struct gcpro gcpro1; @@ -3284,7 +3150,7 @@ SEQUENCE may be a list, a vector, a bit vector, or a string. */ (fn, seq)) { - int len = XINT (Flength (seq)); + size_t len = XINT (Flength (seq)); Lisp_Object *args = alloca_array (Lisp_Object, len); mapcar1 (len, args, fn, seq); @@ -3299,9 +3165,7 @@ SEQUENCE may be a list, a vector or a string. */ (fn, seq)) { - int len = XINT (Flength (seq)); - /* Ideally, this should call make_vector_internal, because we don't - need initialization. */ + size_t len = XINT (Flength (seq)); Lisp_Object result = make_vector (len, Qnil); struct gcpro gcpro1; @@ -3527,9 +3391,12 @@ If FILENAME is omitted, the printname of FEATURE is used as the file name. } /* base64 encode/decode functions. - Based on code from GNU recode. */ -#define MIME_LINE_LENGTH 76 + Originally based on code from GNU recode. Ported to FSF Emacs by + Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and + subsequently heavily hacked by Hrvoje Niksic. */ + +#define MIME_LINE_LENGTH 72 #define IS_ASCII(Character) \ ((Character) < 128) @@ -3585,11 +3452,11 @@ static short base64_char_to_value[128] = base64 characters. */ #define ADVANCE_INPUT(c, stream) \ - (ec = Lstream_get_emchar (stream), \ - ec == -1 ? 0 : \ + ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \ ((ec > 255) ? \ - (error ("Non-ascii character detected in base64 input"), 0) \ - : (c = (Bufbyte)ec, 1))) + (signal_simple_error ("Non-ascii character in base64 input", \ + make_char (ec)), 0) \ + : (c = (Bufbyte)ec), 1)) static Bytind base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break) @@ -3645,114 +3512,94 @@ base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break) *e++ = base64_value_to_char[0x3f & c]; } - /* Complete last partial line. */ - if (line_break) - if (counter > 0) - *e++ = '\n'; - return e - to; } #undef ADVANCE_INPUT -#define ADVANCE_INPUT(c, stream) \ - (ec = Lstream_get_emchar (stream), \ - ec == -1 ? 0 : (c = (Bufbyte)ec, 1)) - -#define INPUT_EOF_P(stream) \ - (ADVANCE_INPUT (c2, stream) \ - ? (Lstream_unget_emchar (stream, (Emchar)c2), 0) \ - : 1) - -#define STORE_BYTE(pos, val) do { \ +/* Get next character from the stream, except that non-base64 + characters are ignored. This is in accordance with rfc2045. EC + should be an Emchar, so that it can hold -1 as the value for EOF. */ +#define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \ + ec = Lstream_get_emchar (stream); \ + ++streampos; \ + /* IS_BASE64 may not be called with negative arguments so check for \ + EOF first. */ \ + if (ec < 0 || IS_BASE64 (ec) || ec == '=') \ + break; \ +} while (1) + +#define STORE_BYTE(pos, val, ccnt) do { \ pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \ - ++*ccptr; \ + ++ccnt; \ } while (0) static Bytind base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr) { - EMACS_INT counter = 0; - Emchar ec; + Charcount ccnt = 0; Bufbyte *e = to; - unsigned long value; + EMACS_INT streampos = 0; - *ccptr = 0; while (1) { - Bufbyte c, c2; - - if (!ADVANCE_INPUT (c, istream)) - break; - - /* Accept wrapping lines, reversibly if at each 76 characters. */ - if (c == '\n') - { - if (!ADVANCE_INPUT (c, istream)) - break; - if (INPUT_EOF_P (istream)) - break; - /* FSF Emacs has this check, apparently inherited from - recode. However, I see no reason to be this picky about - line length -- why reject base64 with say 72-byte lines? - (yes, there are programs that generate them.) */ - /*if (counter != MIME_LINE_LENGTH / 4) return -1;*/ - counter = 1; - } - else - counter++; + Emchar ec; + unsigned long value; /* Process first byte of a quadruplet. */ - if (!IS_BASE64 (c)) - return -1; - value = base64_char_to_value[c] << 18; + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + break; + if (ec == '=') + signal_simple_error ("Illegal `=' character while decoding base64", + make_int (streampos)); + value = base64_char_to_value[ec] << 18; /* Process second byte of a quadruplet. */ - if (!ADVANCE_INPUT (c, istream)) - return -1; - - if (!IS_BASE64 (c)) - return -1; - value |= base64_char_to_value[c] << 12; - - STORE_BYTE (e, value >> 16); + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); + if (ec == '=') + signal_simple_error ("Illegal `=' character while decoding base64", + make_int (streampos)); + value |= base64_char_to_value[ec] << 12; + STORE_BYTE (e, value >> 16, ccnt); /* Process third byte of a quadruplet. */ - if (!ADVANCE_INPUT (c, istream)) - return -1; + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); - if (c == '=') + if (ec == '=') { - if (!ADVANCE_INPUT (c, istream)) - return -1; - if (c != '=') - return -1; + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); + if (ec != '=') + signal_simple_error ("Padding `=' expected but not found while decoding base64", + make_int (streampos)); continue; } - if (!IS_BASE64 (c)) - return -1; - value |= base64_char_to_value[c] << 6; - - STORE_BYTE (e, 0xff & value >> 8); + value |= base64_char_to_value[ec] << 6; + STORE_BYTE (e, 0xff & value >> 8, ccnt); /* Process fourth byte of a quadruplet. */ - if (!ADVANCE_INPUT (c, istream)) - return -1; - - if (c == '=') + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); + if (ec == '=') continue; - if (!IS_BASE64 (c)) - return -1; - value |= base64_char_to_value[c]; - - STORE_BYTE (e, 0xff & value); + value |= base64_char_to_value[ec]; + STORE_BYTE (e, 0xff & value, ccnt); } + *ccptr = ccnt; return e - to; } #undef ADVANCE_INPUT -#undef INPUT_EOF_P +#undef ADVANCE_INPUT_IGNORE_NONBASE64 +#undef STORE_BYTE static Lisp_Object free_malloced_ptr (Lisp_Object unwind_obj) @@ -3771,20 +3618,20 @@ free_malloced_ptr (Lisp_Object unwind_obj) ways these functions can blow up, and we don't want to have memory leaks in those cases. */ #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \ - if ((len) > MAX_ALLOCA) \ + size_t XOA_len = (len); \ + if (XOA_len > MAX_ALLOCA) \ { \ - ptr = (type *)xmalloc ((len) * sizeof (type)); \ - speccount = specpdl_depth (); \ + ptr = xnew_array (type, XOA_len); \ record_unwind_protect (free_malloced_ptr, \ make_opaque_ptr ((void *)ptr)); \ } \ else \ - ptr = alloca_array (type, len); \ + ptr = alloca_array (type, XOA_len); \ } while (0) -#define XMALLOC_UNBIND(ptr, len) do { \ - if ((len) > MAX_ALLOCA) \ - unbind_to (speccount, Qnil); \ +#define XMALLOC_UNBIND(ptr, len, speccount) do { \ + if ((len) > MAX_ALLOCA) \ + unbind_to (speccount, Qnil); \ } while (0) DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /* @@ -3801,9 +3648,10 @@ into shorter lines. struct buffer *buf = current_buffer; Bufpos begv, zv, old_pt = BUF_PT (buf); Lisp_Object input; - int speccount; + int speccount = specpdl_depth(); get_buffer_range_char (buf, beg, end, &begv, &zv, 0); + barf_if_buffer_read_only (buf, begv, zv); /* We need to allocate enough room for encoding the text. We need 33 1/3% more space, plus a newline every 76 @@ -3825,11 +3673,11 @@ into shorter lines. /* Now we have encoded the region, so we insert the new contents and delete the old. (Insert first in order to preserve markers.) */ buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0); - XMALLOC_UNBIND (encoded, allength); + XMALLOC_UNBIND (encoded, allength, speccount); buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); - /* Simulate FSF Emacs: if point was in the region, place it at the - beginning. */ + /* Simulate FSF Emacs implementation of this function: if point was + in the region, place it at the beginning. */ if (old_pt >= begv && old_pt < zv) BUF_SET_PT (buf, begv); @@ -3837,30 +3685,32 @@ into shorter lines. return make_int (encoded_length); } -DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 1, 0, /* +DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /* Base64 encode STRING and return the result. */ - (string)) + (string, no_line_break)) { Charcount allength, length; Bytind encoded_length; Bufbyte *encoded; Lisp_Object input, result; - int speccount; + int speccount = specpdl_depth(); CHECK_STRING (string); length = XSTRING_CHAR_LENGTH (string); - allength = length + length/3 + 1 + 6; + allength = length + length/3 + 1; + allength += allength / MIME_LINE_LENGTH + 1 + 6; input = make_lisp_string_input_stream (string, 0, -1); XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte); - encoded_length = base64_encode_1 (XLSTREAM (input), encoded, 0); + encoded_length = base64_encode_1 (XLSTREAM (input), encoded, + NILP (no_line_break)); if (encoded_length > allength) abort (); Lstream_delete (XLSTREAM (input)); result = make_string (encoded, encoded_length); - XMALLOC_UNBIND (encoded, allength); + XMALLOC_UNBIND (encoded, allength, speccount); return result; } @@ -3868,6 +3718,7 @@ DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /* Base64-decode the region between BEG and END. Return the length of the decoded text. If the region can't be decoded, return nil and don't modify the buffer. +Characters out of the base64 alphabet are ignored. */ (beg, end)) { @@ -3877,9 +3728,11 @@ If the region can't be decoded, return nil and don't modify the buffer. Bytind decoded_length; Charcount length, cc_decoded_length; Lisp_Object input; - int speccount; + int speccount = specpdl_depth(); get_buffer_range_char (buf, beg, end, &begv, &zv, 0); + barf_if_buffer_read_only (buf, begv, zv); + length = zv - begv; input = make_lisp_buffer_input_stream (buf, begv, zv, 0); @@ -3890,23 +3743,16 @@ If the region can't be decoded, return nil and don't modify the buffer. abort (); Lstream_delete (XLSTREAM (input)); - if (decoded_length < 0) - { - /* The decoding wasn't possible. */ - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); - return Qnil; - } - /* Now we have decoded the region, so we insert the new contents and delete the old. (Insert first in order to preserve markers.) */ BUF_SET_PT (buf, begv); buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0); - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); buffer_delete_range (buf, begv + cc_decoded_length, zv + cc_decoded_length, 0); - /* Simulate FSF Emacs: if point was in the region, place it at the - beginning. */ + /* Simulate FSF Emacs implementation of this function: if point was + in the region, place it at the beginning. */ if (old_pt >= begv && old_pt < zv) BUF_SET_PT (buf, begv); @@ -3915,6 +3761,7 @@ If the region can't be decoded, return nil and don't modify the buffer. DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /* Base64-decode STRING and return the result. +Characters out of the base64 alphabet are ignored. */ (string)) { @@ -3922,7 +3769,7 @@ Base64-decode STRING and return the result. Bytind decoded_length; Charcount length, cc_decoded_length; Lisp_Object input, result; - int speccount; + int speccount = specpdl_depth(); CHECK_STRING (string); @@ -3937,14 +3784,8 @@ Base64-decode STRING and return the result. abort (); Lstream_delete (XLSTREAM (input)); - if (decoded_length < 0) - { - return Qnil; - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); - } - result = make_string (decoded, decoded_length); - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); return result; } @@ -3968,6 +3809,7 @@ syms_of_fns (void) DEFSUBR (Fconcat); DEFSUBR (Fvconcat); DEFSUBR (Fbvconcat); + DEFSUBR (Fcopy_list); DEFSUBR (Fcopy_sequence); DEFSUBR (Fcopy_alist); DEFSUBR (Fcopy_tree); @@ -3976,6 +3818,9 @@ syms_of_fns (void) DEFSUBR (Fnthcdr); DEFSUBR (Fnth); DEFSUBR (Felt); + DEFSUBR (Flast); + DEFSUBR (Fbutlast); + DEFSUBR (Fnbutlast); DEFSUBR (Fmember); DEFSUBR (Fold_member); DEFSUBR (Fmemq); @@ -4046,4 +3891,6 @@ A list of symbols which are the features of the executing emacs. Used by `featurep' and `require', and altered by `provide'. */ ); Vfeatures = Qnil; + + Fprovide (intern ("base64")); }