comparison src/fns.c @ 149:538048ae2ab8 r20-3b1

Import from CVS: tag r20-3b1
author cvs
date Mon, 13 Aug 2007 09:36:16 +0200
parents 585fb297b004
children 0132846995bd
comparison
equal deleted inserted replaced
148:f659db2a1f73 149:538048ae2ab8
61 struct Lisp_Bit_Vector); 61 struct Lisp_Bit_Vector);
62 62
63 static Lisp_Object 63 static Lisp_Object
64 mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) 64 mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
65 { 65 {
66 return (Qnil); 66 return Qnil;
67 } 67 }
68 68
69 static void 69 static void
70 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 70 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
71 { 71 {
170 with Bytecounts in strings */ 170 with Bytecounts in strings */
171 static Charcount 171 static Charcount
172 length_with_bytecode_hack (Lisp_Object seq) 172 length_with_bytecode_hack (Lisp_Object seq)
173 { 173 {
174 if (!COMPILED_FUNCTIONP (seq)) 174 if (!COMPILED_FUNCTIONP (seq))
175 return (XINT (Flength (seq))); 175 return XINT (Flength (seq));
176 else 176 else
177 { 177 {
178 struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (seq); 178 struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (seq);
179 int intp = b->flags.interactivep;
180 int domainp = b->flags.domainp;
181 179
182 if (intp) 180 return (b->flags.interactivep ? COMPILED_INTERACTIVE :
183 return (COMPILED_INTERACTIVE + 1); 181 b->flags.domainp ? COMPILED_DOMAIN :
184 else if (domainp) 182 COMPILED_DOC_STRING)
185 return (COMPILED_DOMAIN + 1); 183 + 1;
186 else
187 return (COMPILED_DOC_STRING + 1);
188 } 184 }
189 } 185 }
190 186
191 #endif /* LOSING_BYTECODE */ 187 #endif /* LOSING_BYTECODE */
192 188
208 Lisp_Object tail; 204 Lisp_Object tail;
209 int i; 205 int i;
210 206
211 retry: 207 retry:
212 if (STRINGP (obj)) 208 if (STRINGP (obj))
213 return (make_int (string_char_length (XSTRING (obj)))); 209 return make_int (string_char_length (XSTRING (obj)));
214 else if (VECTORP (obj)) 210 else if (VECTORP (obj))
215 return (make_int (vector_length (XVECTOR (obj)))); 211 return make_int (vector_length (XVECTOR (obj)));
216 else if (BIT_VECTORP (obj)) 212 else if (BIT_VECTORP (obj))
217 return (make_int (bit_vector_length (XBIT_VECTOR (obj)))); 213 return make_int (bit_vector_length (XBIT_VECTOR (obj)));
218 else if (CONSP (obj)) 214 else if (CONSP (obj))
219 { 215 {
220 for (i = 0, tail = obj; !NILP (tail); i++) 216 for (i = 0, tail = obj; !NILP (tail); i++)
221 { 217 {
222 QUIT; 218 QUIT;
1196 Lisp_Object 1192 Lisp_Object
1197 assoc_no_quit (Lisp_Object key, Lisp_Object list) 1193 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1198 { 1194 {
1199 int speccount = specpdl_depth (); 1195 int speccount = specpdl_depth ();
1200 specbind (Qinhibit_quit, Qt); 1196 specbind (Qinhibit_quit, Qt);
1201 return (unbind_to (speccount, Fassoc (key, list))); 1197 return unbind_to (speccount, Fassoc (key, list));
1202 } 1198 }
1203 1199
1204 DEFUN ("assq", Fassq, 2, 2, 0, /* 1200 DEFUN ("assq", Fassq, 2, 2, 0, /*
1205 Return non-nil if KEY is `eq' to the car of an element of LIST. 1201 Return non-nil if KEY is `eq' to the car of an element of LIST.
1206 The value is actually the element of LIST whose car is KEY. 1202 The value is actually the element of LIST whose car is KEY.
1569 Lisp_Object 1565 Lisp_Object
1570 remassoc_no_quit (Lisp_Object key, Lisp_Object list) 1566 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
1571 { 1567 {
1572 int speccount = specpdl_depth (); 1568 int speccount = specpdl_depth ();
1573 specbind (Qinhibit_quit, Qt); 1569 specbind (Qinhibit_quit, Qt);
1574 return (unbind_to (speccount, Fremassoc (key, list))); 1570 return unbind_to (speccount, Fremassoc (key, list));
1575 } 1571 }
1576 1572
1577 DEFUN ("remassq", Fremassq, 2, 2, 0, /* 1573 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1578 Delete by side effect any elements of LIST whose car is `eq' to KEY. 1574 Delete by side effect any elements of LIST whose car is `eq' to KEY.
1579 The modified LIST is returned. If the first member of LIST has a car 1575 The modified LIST is returned. If the first member of LIST has a car
2883 if (depth > 200) 2879 if (depth > 200)
2884 error ("Stack overflow in equal"); 2880 error ("Stack overflow in equal");
2885 do_cdr: 2881 do_cdr:
2886 QUIT; 2882 QUIT;
2887 if (EQ_WITH_EBOLA_NOTICE (o1, o2)) 2883 if (EQ_WITH_EBOLA_NOTICE (o1, o2))
2888 return (1); 2884 return 1;
2889 /* Note that (equal 20 20.0) should be nil */ 2885 /* Note that (equal 20 20.0) should be nil */
2890 else if (XTYPE (o1) != XTYPE (o2)) 2886 else if (XTYPE (o1) != XTYPE (o2))
2891 return (0); 2887 return 0;
2892 else if (CONSP (o1)) 2888 else if (CONSP (o1))
2893 { 2889 {
2894 if (!internal_equal (Fcar (o1), Fcar (o2), depth + 1)) 2890 if (!internal_equal (Fcar (o1), Fcar (o2), depth + 1))
2895 return (0); 2891 return 0;
2896 o1 = Fcdr (o1); 2892 o1 = Fcdr (o1);
2897 o2 = Fcdr (o2); 2893 o2 = Fcdr (o2);
2898 goto do_cdr; 2894 goto do_cdr;
2899 } 2895 }
2900 2896
2902 else if (VECTORP (o1)) 2898 else if (VECTORP (o1))
2903 { 2899 {
2904 int indecks; 2900 int indecks;
2905 int len = vector_length (XVECTOR (o1)); 2901 int len = vector_length (XVECTOR (o1));
2906 if (len != vector_length (XVECTOR (o2))) 2902 if (len != vector_length (XVECTOR (o2)))
2907 return (0); 2903 return 0;
2908 for (indecks = 0; indecks < len; indecks++) 2904 for (indecks = 0; indecks < len; indecks++)
2909 { 2905 {
2910 Lisp_Object v1, v2; 2906 Lisp_Object v1, v2;
2911 v1 = vector_data (XVECTOR (o1)) [indecks]; 2907 v1 = vector_data (XVECTOR (o1)) [indecks];
2912 v2 = vector_data (XVECTOR (o2)) [indecks]; 2908 v2 = vector_data (XVECTOR (o2)) [indecks];
2913 if (!internal_equal (v1, v2, depth + 1)) 2909 if (!internal_equal (v1, v2, depth + 1))
2914 return (0); 2910 return 0;
2915 } 2911 }
2916 return (1); 2912 return 1;
2917 } 2913 }
2918 #endif /* !LRECORD_VECTOR */ 2914 #endif /* !LRECORD_VECTOR */
2919 else if (STRINGP (o1)) 2915 else if (STRINGP (o1))
2920 { 2916 {
2921 Bytecount len = XSTRING_LENGTH (o1); 2917 Bytecount len = XSTRING_LENGTH (o1);
2922 if (len != XSTRING_LENGTH (o2)) 2918 if (len != XSTRING_LENGTH (o2))
2923 return (0); 2919 return 0;
2924 if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)) 2920 if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len))
2925 return (0); 2921 return 0;
2926 return (1); 2922 return 1;
2927 } 2923 }
2928 else if (LRECORDP (o1)) 2924 else if (LRECORDP (o1))
2929 { 2925 {
2930 CONST struct lrecord_implementation 2926 CONST struct lrecord_implementation
2931 *imp1 = XRECORD_LHEADER (o1)->implementation, 2927 *imp1 = XRECORD_LHEADER (o1)->implementation,
2932 *imp2 = XRECORD_LHEADER (o2)->implementation; 2928 *imp2 = XRECORD_LHEADER (o2)->implementation;
2933 if (imp1 != imp2) 2929 if (imp1 != imp2)
2934 return (0); 2930 return 0;
2935 else if (imp1->equal == 0) 2931 else if (imp1->equal == 0)
2936 /* EQ-ness of the objects was noticed above */ 2932 /* EQ-ness of the objects was noticed above */
2937 return (0); 2933 return 0;
2938 else 2934 else
2939 return ((imp1->equal) (o1, o2, depth)); 2935 return (imp1->equal) (o1, o2, depth);
2940 } 2936 }
2941 2937
2942 return (0); 2938 return 0;
2943 } 2939 }
2944 2940
2945 /* Note that we may be calling sub-objects that will use 2941 /* Note that we may be calling sub-objects that will use
2946 internal_equal() (instead of internal_old_equal()). Oh well. 2942 internal_equal() (instead of internal_old_equal()). Oh well.
2947 We will get an Ebola note if there's any possibility of confusion, 2943 We will get an Ebola note if there's any possibility of confusion,
2953 if (depth > 200) 2949 if (depth > 200)
2954 error ("Stack overflow in equal"); 2950 error ("Stack overflow in equal");
2955 do_cdr: 2951 do_cdr:
2956 QUIT; 2952 QUIT;
2957 if (HACKEQ_UNSAFE (o1, o2)) 2953 if (HACKEQ_UNSAFE (o1, o2))
2958 return (1); 2954 return 1;
2959 /* Note that (equal 20 20.0) should be nil */ 2955 /* Note that (equal 20 20.0) should be nil */
2960 else if (XTYPE (o1) != XTYPE (o2)) 2956 else if (XTYPE (o1) != XTYPE (o2))
2961 return (0); 2957 return 0;
2962 else if (CONSP (o1)) 2958 else if (CONSP (o1))
2963 { 2959 {
2964 if (!internal_old_equal (Fcar (o1), Fcar (o2), depth + 1)) 2960 if (!internal_old_equal (Fcar (o1), Fcar (o2), depth + 1))
2965 return (0); 2961 return 0;
2966 o1 = Fcdr (o1); 2962 o1 = Fcdr (o1);
2967 o2 = Fcdr (o2); 2963 o2 = Fcdr (o2);
2968 goto do_cdr; 2964 goto do_cdr;
2969 } 2965 }
2970 2966
2972 else if (VECTORP (o1)) 2968 else if (VECTORP (o1))
2973 { 2969 {
2974 int indecks; 2970 int indecks;
2975 int len = vector_length (XVECTOR (o1)); 2971 int len = vector_length (XVECTOR (o1));
2976 if (len != vector_length (XVECTOR (o2))) 2972 if (len != vector_length (XVECTOR (o2)))
2977 return (0); 2973 return 0;
2978 for (indecks = 0; indecks < len; indecks++) 2974 for (indecks = 0; indecks < len; indecks++)
2979 { 2975 {
2980 Lisp_Object v1, v2; 2976 Lisp_Object v1, v2;
2981 v1 = vector_data (XVECTOR (o1)) [indecks]; 2977 v1 = vector_data (XVECTOR (o1)) [indecks];
2982 v2 = vector_data (XVECTOR (o2)) [indecks]; 2978 v2 = vector_data (XVECTOR (o2)) [indecks];
2983 if (!internal_old_equal (v1, v2, depth + 1)) 2979 if (!internal_old_equal (v1, v2, depth + 1))
2984 return (0); 2980 return 0;
2985 } 2981 }
2986 return (1); 2982 return 1;
2987 } 2983 }
2988 #endif /* !LRECORD_VECTOR */ 2984 #endif /* !LRECORD_VECTOR */
2989 else if (STRINGP (o1)) 2985 else if (STRINGP (o1))
2990 { 2986 {
2991 Bytecount len = XSTRING_LENGTH (o1); 2987 Bytecount len = XSTRING_LENGTH (o1);
2992 if (len != XSTRING_LENGTH (o2)) 2988 if (len != XSTRING_LENGTH (o2))
2993 return (0); 2989 return 0;
2994 if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)) 2990 if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len))
2995 return (0); 2991 return 0;
2996 return (1); 2992 return 1;
2997 } 2993 }
2998 else if (LRECORDP (o1)) 2994 else if (LRECORDP (o1))
2999 { 2995 {
3000 CONST struct lrecord_implementation 2996 CONST struct lrecord_implementation
3001 *imp1 = XRECORD_LHEADER (o1)->implementation, 2997 *imp1 = XRECORD_LHEADER (o1)->implementation,
3002 *imp2 = XRECORD_LHEADER (o2)->implementation; 2998 *imp2 = XRECORD_LHEADER (o2)->implementation;
3003 if (imp1 != imp2) 2999 if (imp1 != imp2)
3004 return (0); 3000 return 0;
3005 else if (imp1->equal == 0) 3001 else if (imp1->equal == 0)
3006 /* EQ-ness of the objects was noticed above */ 3002 /* EQ-ness of the objects was noticed above */
3007 return (0); 3003 return 0;
3008 else 3004 else
3009 return ((imp1->equal) (o1, o2, depth)); 3005 return ((imp1->equal) (o1, o2, depth));
3010 } 3006 }
3011 3007
3012 return (0); 3008 return 0;
3013 } 3009 }
3014 3010
3015 DEFUN ("equal", Fequal, 2, 2, 0, /* 3011 DEFUN ("equal", Fequal, 2, 2, 0, /*
3016 T if two Lisp objects have similar structure and contents. 3012 T if two Lisp objects have similar structure and contents.
3017 They must have the same data type. 3013 They must have the same data type.
3019 Vectors and strings are compared element by element. 3015 Vectors and strings are compared element by element.
3020 Numbers are compared by value. Symbols must match exactly. 3016 Numbers are compared by value. Symbols must match exactly.
3021 */ 3017 */
3022 (o1, o2)) 3018 (o1, o2))
3023 { 3019 {
3024 return ((internal_equal (o1, o2, 0)) ? Qt : Qnil); 3020 return internal_equal (o1, o2, 0) ? Qt : Qnil;
3025 } 3021 }
3026 3022
3027 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* 3023 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
3028 T if two Lisp objects have similar structure and contents. 3024 T if two Lisp objects have similar structure and contents.
3029 They must have the same data type. 3025 They must have the same data type.
3033 This function is provided only for byte-code compatibility with v19. 3029 This function is provided only for byte-code compatibility with v19.
3034 Do not use it. 3030 Do not use it.
3035 */ 3031 */
3036 (o1, o2)) 3032 (o1, o2))
3037 { 3033 {
3038 return (internal_old_equal (o1, o2, 0) ? Qt : Qnil); 3034 return internal_old_equal (o1, o2, 0) ? Qt : Qnil;
3039 } 3035 }
3040 3036
3041 3037
3042 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /* 3038 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
3043 Store each element of ARRAY with ITEM. 3039 Store each element of ARRAY with ITEM.
3366 Lisp_Object tem; 3362 Lisp_Object tem;
3367 CHECK_SYMBOL (feature); 3363 CHECK_SYMBOL (feature);
3368 tem = Fmemq (feature, Vfeatures); 3364 tem = Fmemq (feature, Vfeatures);
3369 LOADHIST_ATTACH (Fcons (Qrequire, feature)); 3365 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3370 if (!NILP (tem)) 3366 if (!NILP (tem))
3371 return (feature); 3367 return feature;
3372 else 3368 else
3373 { 3369 {
3374 int speccount = specpdl_depth (); 3370 int speccount = specpdl_depth ();
3375 3371
3376 /* Value saved here is to be restored into Vautoload_queue */ 3372 /* Value saved here is to be restored into Vautoload_queue */
3385 error ("Required feature %s was not provided", 3381 error ("Required feature %s was not provided",
3386 string_data (XSYMBOL (feature)->name)); 3382 string_data (XSYMBOL (feature)->name));
3387 3383
3388 /* Once loading finishes, don't undo it. */ 3384 /* Once loading finishes, don't undo it. */
3389 Vautoload_queue = Qt; 3385 Vautoload_queue = Qt;
3390 return (unbind_to (speccount, feature)); 3386 return unbind_to (speccount, feature);
3391 } 3387 }
3392 } 3388 }
3393 3389
3394 3390
3395 Lisp_Object Qyes_or_no_p; 3391 Lisp_Object Qyes_or_no_p;