Mercurial > hg > xemacs-beta

comparison src/fns.c @ 384:bbff43aa5eb7 r21-2-7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-7
author cvs
date Mon, 13 Aug 2007 11:08:24 +0200
parents 8626e4521993
children 6719134a07c2
comparison
equal deleted inserted replaced
383:6a50c6a581a5 384:bbff43aa5eb7
3035 GCPRO1 (args[0]); 3035 GCPRO1 (args[0]);
3036 gcpro1.nvars = nargs; 3036 gcpro1.nvars = nargs;
3037 3037
3038 while (argnum < nargs) 3038 while (argnum < nargs)
3039 { 3039 {
3040 Lisp_Object val = args[argnum]; 3040 Lisp_Object val;
3041 retry:
3042 val = args[argnum];
3041 if (CONSP (val)) 3043 if (CONSP (val))
3042 { 3044 {
3043 /* `val' is the first cons, which will be our return value. */ 3045 /* `val' is the first cons, which will be our return value. */
3044 /* `last_cons' will be the cons cell to mutate. */ 3046 /* `last_cons' will be the cons cell to mutate. */
3045 Lisp_Object last_cons = val; 3047 Lisp_Object last_cons = val;
3046 Lisp_Object tortoise = val; 3048 Lisp_Object tortoise = val;
3047 3049
3048 for (argnum++; argnum < nargs; argnum++) 3050 for (argnum++; argnum < nargs; argnum++)
3049 { 3051 {
3050 Lisp_Object next = args[argnum]; 3052 Lisp_Object next = args[argnum];
3051 retry: 3053 retry_next:
3052 if (CONSP (next) || argnum == nargs -1) 3054 if (CONSP (next) || argnum == nargs -1)
3053 { 3055 {
3054 /* (setcdr (last val) next) */ 3056 /* (setcdr (last val) next) */
3055 int count; 3057 int count;
3056 3058
3071 { 3073 {
3072 continue; 3074 continue;
3073 } 3075 }
3074 else 3076 else
3075 { 3077 {
3076 next = wrong_type_argument (next, Qlistp); 3078 next = wrong_type_argument (Qlistp, next);
3077 goto retry; 3079 goto retry_next;
3078 } 3080 }
3079 } 3081 }
3080 RETURN_UNGCPRO (val); 3082 RETURN_UNGCPRO (val);
3081 } 3083 }
3082 else if (NILP (val)) 3084 else if (NILP (val))
3083 argnum++; 3085 argnum++;
3084 else if (argnum == nargs - 1) /* last arg? */ 3086 else if (argnum == nargs - 1) /* last arg? */
3085 RETURN_UNGCPRO (val); 3087 RETURN_UNGCPRO (val);
3086 else 3088 else
3087 args[argnum] = wrong_type_argument (val, Qlistp); 3089 {
3090 args[argnum] = wrong_type_argument (Qlistp, val);
3091 goto retry;
3092 }
3088 } 3093 }
3089 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */ 3094 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3090 } 3095 }
3091 3096
3092 3097
3093 /* This is the guts of all mapping functions. 3098 /* This is the guts of all mapping functions.
3094 Apply fn to each element of seq, one by one, 3099 Apply fn to each element of seq, one by one,
3095 storing the results into elements of vals, a C vector of Lisp_Objects. 3100 storing the results into elements of vals, a C vector of Lisp_Objects.
3096 leni is the length of vals, which should also be the length of seq. 3101 leni is the length of vals, which should also be the length of seq.
3097 3102
3098 If VALS is a null pointer, do not accumulate the results. */ 3103 If VALS is a null pointer, do not accumulate the results. */
3099 3104
3100 static void 3105 static void
3101 mapcar1 (int leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) 3106 mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
3102 { 3107 {
3103 Lisp_Object tail; 3108 Lisp_Object result;
3104 Lisp_Object dummy = Qnil; 3109 Lisp_Object args[2];
3105 int i; 3110 int i;
3106 struct gcpro gcpro1, gcpro2, gcpro3; 3111 struct gcpro gcpro1;
3107 Lisp_Object result;
3108
3109 GCPRO3 (dummy, fn, seq);
3110 3112
3111 if (vals) 3113 if (vals)
3112 { 3114 {
3113 /* Don't let vals contain any garbage when GC happens. */ 3115 GCPRO1 (vals[0]);
3116 gcpro1.nvars = 0;
3117 }
3118
3119 args[0] = fn;
3120
3121 if (LISTP (seq))
3122 {
3114 for (i = 0; i < leni; i++) 3123 for (i = 0; i < leni; i++)
3115 vals[i] = Qnil; 3124 {
3116 gcpro1.var = vals; 3125 args[1] = XCAR (seq);
3117 gcpro1.nvars = leni; 3126 seq = XCDR (seq);
3118 } 3127 result = Ffuncall (2, args);
3119 3128 if (vals) vals[gcpro1.nvars++] = result;
3120 /* We need not explicitly protect `tail' because it is used only on 3129 }
3121 lists, and 1) lists are not relocated and 2) the list is marked 3130 }
3122 via `seq' so will not be freed */ 3131 else if (VECTORP (seq))
3123 3132 {
3124 if (VECTORP (seq)) 3133 Lisp_Object *objs = XVECTOR_DATA (seq);
3125 {
3126 for (i = 0; i < leni; i++) 3134 for (i = 0; i < leni; i++)
3127 { 3135 {
3128 dummy = XVECTOR_DATA (seq)[i]; 3136 args[1] = *objs++;
3129 result = call1 (fn, dummy); 3137 result = Ffuncall (2, args);
3130 if (vals) 3138 if (vals) vals[gcpro1.nvars++] = result;
3131 vals[i] = result; 3139 }
3140 }
3141 else if (STRINGP (seq))
3142 {
3143 Bufbyte *p = XSTRING_DATA (seq);
3144 for (i = 0; i < leni; i++)
3145 {
3146 args[1] = make_char (charptr_emchar (p));
3147 INC_CHARPTR (p);
3148 result = Ffuncall (2, args);
3149 if (vals) vals[gcpro1.nvars++] = result;
3132 } 3150 }
3133 } 3151 }
3134 else if (BIT_VECTORP (seq)) 3152 else if (BIT_VECTORP (seq))
3135 { 3153 {
3136 struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq); 3154 struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
3137 for (i = 0; i < leni; i++) 3155 for (i = 0; i < leni; i++)
3138 { 3156 {
3139 XSETINT (dummy, bit_vector_bit (v, i)); 3157 args[1] = make_int (bit_vector_bit (v, i));
3140 result = call1 (fn, dummy); 3158 result = Ffuncall (2, args);
3141 if (vals) 3159 if (vals) vals[gcpro1.nvars++] = result;
3142 vals[i] = result; 3160 }
3143 } 3161 }
3144 } 3162 else
3145 else if (STRINGP (seq)) 3163 abort(); /* cannot get here since Flength(seq) did not get an error */
3146 { 3164
3147 for (i = 0; i < leni; i++) 3165 if (vals)
3148 { 3166 UNGCPRO;
3149 result = call1 (fn, make_char (string_char (XSTRING (seq), i)));
3150 if (vals)
3151 vals[i] = result;
3152 }
3153 }
3154 else /* Must be a list, since Flength did not get an error */
3155 {
3156 tail = seq;
3157 for (i = 0; i < leni; i++)
3158 {
3159 result = call1 (fn, Fcar (tail));
3160 if (vals)
3161 vals[i] = result;
3162 tail = Fcdr (tail);
3163 }
3164 }
3165
3166 UNGCPRO;
3167 } 3167 }
3168 3168
3169 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /* 3169 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3170 Apply FN to each element of SEQ, and concat the results as strings. 3170 Apply FN to each element of SEQ, and concat the results as strings.
3171 In between each pair of results, stick in SEP. 3171 In between each pair of results, stick in SEP.
3172 Thus, " " as SEP results in spaces between the values returned by FN. 3172 Thus, " " as SEP results in spaces between the values returned by FN.
3173 */ 3173 */
3174 (fn, seq, sep)) 3174 (fn, seq, sep))
3175 { 3175 {
3176 int len = XINT (Flength (seq)); 3176 size_t len = XINT (Flength (seq));
3177 Lisp_Object *args; 3177 Lisp_Object *args;
3178 int i; 3178 int i;
3179 struct gcpro gcpro1; 3179 struct gcpro gcpro1;
3180 int nargs = len + len - 1; 3180 int nargs = len + len - 1;
3181 3181
3201 The result is a list just as long as SEQUENCE. 3201 The result is a list just as long as SEQUENCE.
3202 SEQUENCE may be a list, a vector, a bit vector, or a string. 3202 SEQUENCE may be a list, a vector, a bit vector, or a string.
3203 */ 3203 */
3204 (fn, seq)) 3204 (fn, seq))
3205 { 3205 {
3206 int len = XINT (Flength (seq)); 3206 size_t len = XINT (Flength (seq));
3207 Lisp_Object *args = alloca_array (Lisp_Object, len); 3207 Lisp_Object *args = alloca_array (Lisp_Object, len);
3208 3208
3209 mapcar1 (len, args, fn, seq); 3209 mapcar1 (len, args, fn, seq);
3210 3210
3211 return Flist (len, args); 3211 return Flist (len, args);
3216 The result is a vector of the same length as SEQUENCE. 3216 The result is a vector of the same length as SEQUENCE.
3217 SEQUENCE may be a list, a vector or a string. 3217 SEQUENCE may be a list, a vector or a string.
3218 */ 3218 */
3219 (fn, seq)) 3219 (fn, seq))
3220 { 3220 {
3221 int len = XINT (Flength (seq)); 3221 size_t len = XINT (Flength (seq));
3222 /* Ideally, this should call make_vector_internal, because we don't
3223 need initialization. */
3224 Lisp_Object result = make_vector (len, Qnil); 3222 Lisp_Object result = make_vector (len, Qnil);
3225 struct gcpro gcpro1; 3223 struct gcpro gcpro1;
3226 3224
3227 GCPRO1 (result); 3225 GCPRO1 (result);
3228 mapcar1 (len, XVECTOR_DATA (result), fn, seq); 3226 mapcar1 (len, XVECTOR_DATA (result), fn, seq);