lisp/ChangeLog: 2004-05-14 Miles Bader * subr.el (functionp): Use `funvecp' instead of `byte-compiled-function-p'. src/ChangeLog: 2004-05-14 Miles Bader * lisp.h: Declare Ffunvec and Fmake_funvec. (enum pvec_type): Rename `PVEC_COMPILED' to `PVEC_FUNVEC'. (XSETFUNVEC): Renamed from `XSETCOMPILED'. (FUNVEC_SIZE, FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): New macros. (COMPILEDP): Define in terms of funvec macros. (FUNVECP, GC_FUNVECP): Renamed from `COMPILEDP' & `GC_COMPILEDP'. (FUNCTIONP): Use FUNVECP instead of COMPILEDP. * alloc.c (Fmake_char_table, Fmake_byte_code): New functions. (Fmake_byte_code): Make sure the first element is a list. * eval.c (Qcurry): New variable. (syms_of_eval): Initialize it. (Ffuncall): Handle curried and byte-code funvec objects. (Fcurry): New function. * lread.c (read1): Return result of read_vector for `#[' syntax directly; read_vector now does any extra work required. (read_vector): Handle both funvec and byte-code objects, converting the type as necessary. `bytecodeflag' argument is now called `read_funvec'. * data.c (Ffunvecp): New function. * eval.c (Ffunctionp): Use `funvec' operators instead of `compiled' operators. * alloc.c (Fmake_byte_code, Fpurecopy, mark_object): Likewise. * keyboard.c (Fcommand_execute): Likewise. * image.c (parse_image_spec): Likewise. * fns.c (Flength, concat, internal_equal): Likewise. * data.c (Faref, Ftype_of): Likewise. * print.c (print_preprocess, print_object): Likewise. M src/eval.c M src/image.c M src/data.c M src/ChangeLog M src/alloc.c M src/keyboard.c M src/fns.c M src/lisp.h M src/lread.c M src/print.c M lisp/ChangeLog M lisp/subr.el * modified files *** orig/lisp/subr.el --- mod/lisp/subr.el *************** *** 2313,2319 **** (error nil)) (eq (car-safe object) 'autoload) (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object))))))) ! (subrp object) (byte-code-function-p object) (eq (car-safe object) 'lambda))) (defun assq-delete-all (key alist) --- 2313,2320 ---- (error nil)) (eq (car-safe object) 'autoload) (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object))))))) ! (subrp object) ! (funvecp object) (eq (car-safe object) 'lambda))) (defun assq-delete-all (key alist) *** orig/src/alloc.c --- mod/src/alloc.c *************** *** 2643,2648 **** --- 2643,2674 ---- } + DEFUN ("make-funvec", Fmake_funvec, Smake_funvec, 2, 3, 0, + doc: /* Return a new `function vector' containing KIND, and NUM_PARAMS more elements. + A `function vector', AKA, `funvec' is a funcallable vector in emacs lisp. + KIND should be a non-nil symbol describing the type of funvec. + The resulting vector-like object will have KIND as the first element, and + NUM_PARAMS further elements initialize to INIT (which defaults to nil). + See also the function `funvec'. */) + (kind, num_params, init) + register Lisp_Object kind, num_params, init; + { + Lisp_Object funvec; + + CHECK_NATNUM (num_params); + + if (NILP (kind) || !SYMBOLP (kind)) + error ("Invalid funvec kind"); + + funvec = Fmake_vector (make_number (XFASTINT (num_params) + 1), init); + + ASET (funvec, 0, kind); + XSETFUNVEC (funvec, XVECTOR (funvec)); + + return funvec; + } + + DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0, doc: /* Return a newly created char-table, with purpose PURPOSE. Each element is initialized to INIT, which defaults to nil. *************** *** 2707,2712 **** --- 2733,2761 ---- } + DEFUN ("funvec", Ffunvec, Sfunvec, 1, MANY, 0, + doc: /* Return a newly created `function vector' of kind KIND. + A `function vector', AKA, `funvec' is a funcallable vector in emacs lisp. + KIND is a non-nil symbol specifying the kind of funvec. The meaning of the + remaining arguments depends on KIND. + usage: (funvec KIND &rest OBJECTS) */) + (nargs, args) + register int nargs; + Lisp_Object *args; + { + register int index; + register Lisp_Object num_params, funvec; + + XSETFASTINT (num_params, nargs - 1); + funvec = Fmake_funvec (args[0], num_params, Qnil); + + for (index = 1; index < nargs; index++) + ASET (funvec, index, args[index]); + + return funvec; + } + + DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, doc: /* Create a byte-code object with specified arguments as elements. The arguments should be the arglist, bytecode-string, constant vector, *************** *** 2722,2727 **** --- 2771,2780 ---- register int index; register struct Lisp_Vector *p; + /* Make sure the arg-list is really a list, as that's what's used to + distinguish a byte-compiled object from other funvecs. */ + CHECK_LIST (args[0]); + XSETFASTINT (len, nargs); if (!NILP (Vpurify_flag)) val = make_pure_vector ((EMACS_INT) nargs); *************** *** 2743,2749 **** args[index] = Fpurecopy (args[index]); p->contents[index] = args[index]; } ! XSETCOMPILED (val, p); return val; } --- 2796,2802 ---- args[index] = Fpurecopy (args[index]); p->contents[index] = args[index]; } ! XSETFUNVEC (val, p); return val; } *************** *** 4228,4234 **** return make_pure_string (SDATA (obj), SCHARS (obj), SBYTES (obj), STRING_MULTIBYTE (obj)); ! else if (COMPILEDP (obj) || VECTORP (obj)) { register struct Lisp_Vector *vec; register int i; --- 4281,4287 ---- return make_pure_string (SDATA (obj), SCHARS (obj), SBYTES (obj), STRING_MULTIBYTE (obj)); ! else if (FUNVECP (obj) || VECTORP (obj)) { register struct Lisp_Vector *vec; register int i; *************** *** 4240,4247 **** vec = XVECTOR (make_pure_vector (size)); for (i = 0; i < size; i++) vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); ! if (COMPILEDP (obj)) ! XSETCOMPILED (obj, vec); else XSETVECTOR (obj, vec); return obj; --- 4293,4300 ---- vec = XVECTOR (make_pure_vector (size)); for (i = 0; i < size; i++) vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); ! if (FUNVECP (obj)) ! XSETFUNVEC (obj, vec); else XSETVECTOR (obj, vec); return obj; *************** *** 4799,4805 **** } else if (GC_SUBRP (obj)) break; ! else if (GC_COMPILEDP (obj)) /* We could treat this just like a vector, but it is better to save the COMPILED_CONSTANTS element for last and avoid recursion there. */ --- 4852,4858 ---- } else if (GC_SUBRP (obj)) break; ! else if (GC_FUNVECP (obj) && FUNVEC_COMPILED_P (obj)) /* We could treat this just like a vector, but it is better to save the COMPILED_CONSTANTS element for last and avoid recursion there. */ *************** *** 5758,5766 **** --- 5811,5821 ---- defsubr (&Scons); defsubr (&Slist); defsubr (&Svector); + defsubr (&Sfunvec); defsubr (&Smake_byte_code); defsubr (&Smake_list); defsubr (&Smake_vector); + defsubr (&Smake_funvec); defsubr (&Smake_char_table); defsubr (&Smake_string); defsubr (&Smake_bool_vector); *** orig/src/data.c --- mod/src/data.c *************** *** 92,98 **** static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; static Lisp_Object Qfloat, Qwindow_configuration, Qwindow; Lisp_Object Qprocess; ! static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector; static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; static Lisp_Object Qsubrp, Qmany, Qunevalled; --- 92,98 ---- static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; static Lisp_Object Qfloat, Qwindow_configuration, Qwindow; Lisp_Object Qprocess; ! static Lisp_Object Qcompiled_function, Qfunction_vector, Qbuffer, Qframe, Qvector; static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; static Lisp_Object Qsubrp, Qmany, Qunevalled; *************** *** 231,238 **** return Qwindow; if (GC_SUBRP (object)) return Qsubr; ! if (GC_COMPILEDP (object)) ! return Qcompiled_function; if (GC_BUFFERP (object)) return Qbuffer; if (GC_CHAR_TABLE_P (object)) --- 231,241 ---- return Qwindow; if (GC_SUBRP (object)) return Qsubr; ! if (GC_FUNVECP (object)) ! if (FUNVEC_COMPILED_P (object)) ! return Qcompiled_function; ! else ! return Qfunction_vector; if (GC_BUFFERP (object)) return Qbuffer; if (GC_CHAR_TABLE_P (object)) *************** *** 444,449 **** --- 447,460 ---- return Qnil; } + DEFUN ("funvecp", Ffunvecp, Sfunvecp, 1, 1, 0, + doc: /* Return t if OBJECT is a `function vector' object. */) + (object) + Lisp_Object object; + { + return FUNVECP (object) ? Qt : Qnil; + } + DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, doc: /* Return t if OBJECT is a character (an integer) or a string. */) (object) *************** *** 2040,2054 **** { int size = 0; if (VECTORP (array)) ! size = XVECTOR (array)->size; ! else if (COMPILEDP (array)) ! size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK; else wrong_type_argument (Qarrayp, array); if (idxval < 0 || idxval >= size) args_out_of_range (array, idx); ! return XVECTOR (array)->contents[idxval]; } } --- 2051,2065 ---- { int size = 0; if (VECTORP (array)) ! size = ASIZE (array); ! else if (FUNVECP (array)) ! size = FUNVEC_SIZE (array); else wrong_type_argument (Qarrayp, array); if (idxval < 0 || idxval >= size) args_out_of_range (array, idx); ! return AREF (array, idxval); } } *************** *** 3221,3226 **** --- 3232,3238 ---- Qwindow = intern ("window"); /* Qsubr = intern ("subr"); */ Qcompiled_function = intern ("compiled-function"); + Qfunction_vector = intern ("function-vector"); Qbuffer = intern ("buffer"); Qframe = intern ("frame"); Qvector = intern ("vector"); *************** *** 3240,3245 **** --- 3252,3258 ---- staticpro (&Qwindow); /* staticpro (&Qsubr); */ staticpro (&Qcompiled_function); + staticpro (&Qfunction_vector); staticpro (&Qbuffer); staticpro (&Qframe); staticpro (&Qvector); *************** *** 3276,3281 **** --- 3289,3295 ---- defsubr (&Smarkerp); defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); + defsubr (&Sfunvecp); defsubr (&Schar_or_string_p); defsubr (&Scar); defsubr (&Scdr); *** orig/src/eval.c --- mod/src/eval.c *************** *** 93,98 **** --- 93,99 ---- Lisp_Object Qand_rest, Qand_optional; Lisp_Object Qdebug_on_error; Lisp_Object Qdeclare; + Lisp_Object Qcurry; /* This holds either the symbol `run-hooks' or nil. It is nil at an early stage of startup, and when Emacs *************** *** 2770,2777 **** abort (); } } ! if (COMPILEDP (fun)) ! val = funcall_lambda (fun, numargs, args + 1); else { if (!CONSP (fun)) --- 2771,2812 ---- abort (); } } ! ! if (FUNVECP (fun)) ! /* A `function vector' object holds various types of funcallable ! vectors. */ ! { ! if (FUNVEC_COMPILED_P (fun)) ! val = funcall_lambda (fun, numargs, args + 1); ! else ! { ! int size = FUNVEC_SIZE (fun); ! ! if (size > 1 && EQ (AREF (fun, 0), Qcurry)) ! { ! /* A curried function is a way to attach arguments to a ! another function. The first element of the vector is ! the identifier `curry', the second is the wrapped ! function, and remaining elements are the attached ! arguments. */ ! int num_curried_args = size - 2; ! ! internal_args = (Lisp_Object *) alloca ((num_curried_args + nargs) ! * sizeof (Lisp_Object)); ! ! /* Curried function + curried args are first in the new arg vector. */ ! bcopy (XVECTOR (fun)->contents + 1, internal_args, ! (num_curried_args + 1) * sizeof (Lisp_Object)); ! /* User args (not including the old function) are last. */ ! bcopy (args + 1, internal_args + num_curried_args + 1, ! (nargs - 1) * sizeof (Lisp_Object)); ! ! val = Ffuncall (num_curried_args + nargs, internal_args); ! } ! else ! return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); ! } ! } else { if (!CONSP (fun)) *************** *** 3123,3128 **** --- 3158,3193 ---- return value; } + + DEFUN ("curry", Fcurry, Scurry, 1, MANY, 0, + doc: /* Return FUN curried with ARGS. + The result is a function-like object that will append any arguments it + is called with to ARGS, and call FUN with the resulting list of arguments. + + For instance: + (funcall (curry '+ 3 4 5) 2) is the same as (funcall '+ 3 4 5 2) + and: + (mapcar (curry 'concat "The ") '("a" "b" "c")) + => ("The a" "The b" "The c") + + usage: (curry FUN &rest ARGS) */) + (nargs, args) + register int nargs; + Lisp_Object *args; + { + register int index; + register Lisp_Object num_params, funvec; + + XSETFASTINT (num_params, nargs); + funvec = Fmake_funvec (Qcurry, num_params, Qnil); + + for (index = 0; index < nargs; index++) + ASET (funvec, index + 1, args[index]); + + return funvec; + } + + DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. The debugger is entered when that frame exits, if the flag is non-nil. */) *************** *** 3313,3318 **** --- 3378,3386 ---- Qand_optional = intern ("&optional"); staticpro (&Qand_optional); + Qcurry = intern ("curry"); + staticpro (&Qcurry); + DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error, doc: /* *Non-nil means errors display a backtrace buffer. More precisely, this happens for any error that is handled *************** *** 3430,3435 **** --- 3498,3504 ---- defsubr (&Srun_hook_with_args_until_success); defsubr (&Srun_hook_with_args_until_failure); defsubr (&Sfetch_bytecode); + defsubr (&Scurry); defsubr (&Sbacktrace_debug); defsubr (&Sbacktrace); defsubr (&Sbacktrace_frame); *** orig/src/fns.c --- mod/src/fns.c *************** *** 152,159 **** XSETFASTINT (val, MAX_CHAR); else if (BOOL_VECTOR_P (sequence)) XSETFASTINT (val, XBOOL_VECTOR (sequence)->size); ! else if (COMPILEDP (sequence)) ! XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK); else if (CONSP (sequence)) { i = 0; --- 152,159 ---- XSETFASTINT (val, MAX_CHAR); else if (BOOL_VECTOR_P (sequence)) XSETFASTINT (val, XBOOL_VECTOR (sequence)->size); ! else if (FUNVECP (sequence)) ! XSETFASTINT (val, FUNVEC_SIZE (sequence)); else if (CONSP (sequence)) { i = 0; *************** *** 579,585 **** { this = args[argnum]; if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) ! || COMPILEDP (this) || BOOL_VECTOR_P (this))) { args[argnum] = wrong_type_argument (Qsequencep, this); } --- 579,585 ---- { this = args[argnum]; if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) ! || FUNVECP (this) || BOOL_VECTOR_P (this))) { args[argnum] = wrong_type_argument (Qsequencep, this); } *************** *** 2225,2235 **** if (WINDOW_CONFIGURATIONP (o1)) return compare_window_configurations (o1, o2, 0); ! /* Aside from them, only true vectors, char-tables, and compiled ! functions are sensible to compare, so eliminate the others now. */ if (size & PSEUDOVECTOR_FLAG) { ! if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE))) return 0; size &= PSEUDOVECTOR_SIZE_MASK; } --- 2225,2235 ---- if (WINDOW_CONFIGURATIONP (o1)) return compare_window_configurations (o1, o2, 0); ! /* Aside from them, only true vectors, char-tables, and function ! vectors are sensible to compare, so eliminate the others now. */ if (size & PSEUDOVECTOR_FLAG) { ! if (!(size & (PVEC_FUNVEC | PVEC_CHAR_TABLE))) return 0; size &= PSEUDOVECTOR_SIZE_MASK; } *** orig/src/image.c --- mod/src/image.c *************** *** 875,881 **** case IMAGE_FUNCTION_VALUE: value = indirect_function (value); if (SUBRP (value) ! || COMPILEDP (value) || (CONSP (value) && EQ (XCAR (value), Qlambda))) break; return 0; --- 875,881 ---- case IMAGE_FUNCTION_VALUE: value = indirect_function (value); if (SUBRP (value) ! || FUNVECP (value) || (CONSP (value) && EQ (XCAR (value), Qlambda))) break; return 0; *** orig/src/keyboard.c --- mod/src/keyboard.c *************** *** 9658,9664 **** return Fexecute_kbd_macro (final, prefixarg, Qnil); } ! if (CONSP (final) || SUBRP (final) || COMPILEDP (final)) { backtrace.next = backtrace_list; backtrace_list = &backtrace; --- 9658,9664 ---- return Fexecute_kbd_macro (final, prefixarg, Qnil); } ! if (CONSP (final) || SUBRP (final) || FUNVECP (final)) { backtrace.next = backtrace_list; backtrace_list = &backtrace; *** orig/src/lisp.h --- mod/src/lisp.h *************** *** 259,265 **** PVEC_NORMAL_VECTOR = 0, PVEC_PROCESS = 0x200, PVEC_FRAME = 0x400, ! PVEC_COMPILED = 0x800, PVEC_WINDOW = 0x1000, PVEC_WINDOW_CONFIGURATION = 0x2000, PVEC_SUBR = 0x4000, --- 259,265 ---- PVEC_NORMAL_VECTOR = 0, PVEC_PROCESS = 0x200, PVEC_FRAME = 0x400, ! PVEC_FUNVEC = 0x800, PVEC_WINDOW = 0x1000, PVEC_WINDOW_CONFIGURATION = 0x2000, PVEC_SUBR = 0x4000, *************** *** 535,541 **** #define XSETPROCESS(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_PROCESS)) #define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) #define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) ! #define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) #define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) --- 535,541 ---- #define XSETPROCESS(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_PROCESS)) #define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) #define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) ! #define XSETFUNVEC(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FUNVEC)) #define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) *************** *** 546,551 **** --- 546,554 ---- #define ASET(ARRAY, IDX, VAL) (AREF ((ARRAY), (IDX)) = (VAL)) #define ASIZE(ARRAY) XVECTOR ((ARRAY))->size + /* Return the size of the psuedo-vector object FUNVEC. */ + #define FUNVEC_SIZE(funvec) (ASIZE (funvec) & PSEUDOVECTOR_SIZE_MASK) + /* Convenience macros for dealing with Lisp strings. */ #define SREF(string, index) (XSTRING (string)->data[index] + 0) *************** *** 1261,1267 **** typedef unsigned char UCHAR; #endif ! /* Meanings of slots in a Lisp_Compiled: */ #define COMPILED_ARGLIST 0 #define COMPILED_BYTECODE 1 --- 1264,1270 ---- typedef unsigned char UCHAR; #endif ! /* Meanings of slots in a byte-compiled function vector: */ #define COMPILED_ARGLIST 0 #define COMPILED_BYTECODE 1 *************** *** 1270,1275 **** --- 1273,1296 ---- #define COMPILED_DOC_STRING 4 #define COMPILED_INTERACTIVE 5 + /* Return non-zero if TAG, the first element from a funvec object, refers + to a byte-code object. Byte-code objects are distinguished from other + `funvec' objects by having a (possibly empty) list as their first + element -- other funvec types use a non-nil symbol there. */ + #define FUNVEC_COMPILED_TAG_P(tag) \ + (NILP (tag) || CONSP (tag)) + + /* Return non-zero if FUNVEC, which should be a `funvec' object, is a + byte-compiled function. Byte-compiled function are funvecs with the + arglist as the first element (other funvec types will have a symbol + identifying the type as the first object). */ + #define FUNVEC_COMPILED_P(funvec) \ + (FUNVEC_SIZE (funvec) > 0 && FUNVEC_COMPILED_TAG_P (AREF (funvec, 0))) + + /* Return non-zero if OBJ is byte-compile function. */ + #define COMPILEDP(obj) \ + (FUNVECP (obj) && FUNVEC_COMPILED_P (obj)) + /* Flag bits in a character. These also get used in termhooks.h. Richard Stallman thinks that MULE (MUlti-Lingual Emacs) might need 22 bits for the character value *************** *** 1438,1445 **** #define GC_WINDOWP(x) GC_PSEUDOVECTORP (x, PVEC_WINDOW) #define SUBRP(x) PSEUDOVECTORP (x, PVEC_SUBR) #define GC_SUBRP(x) GC_PSEUDOVECTORP (x, PVEC_SUBR) ! #define COMPILEDP(x) PSEUDOVECTORP (x, PVEC_COMPILED) ! #define GC_COMPILEDP(x) GC_PSEUDOVECTORP (x, PVEC_COMPILED) #define BUFFERP(x) PSEUDOVECTORP (x, PVEC_BUFFER) #define GC_BUFFERP(x) GC_PSEUDOVECTORP (x, PVEC_BUFFER) #define CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_CHAR_TABLE) --- 1459,1466 ---- #define GC_WINDOWP(x) GC_PSEUDOVECTORP (x, PVEC_WINDOW) #define SUBRP(x) PSEUDOVECTORP (x, PVEC_SUBR) #define GC_SUBRP(x) GC_PSEUDOVECTORP (x, PVEC_SUBR) ! #define FUNVECP(x) PSEUDOVECTORP (x, PVEC_FUNVEC) ! #define GC_FUNVECP(x) GC_PSEUDOVECTORP (x, PVEC_FUNVEC) #define BUFFERP(x) PSEUDOVECTORP (x, PVEC_BUFFER) #define GC_BUFFERP(x) GC_PSEUDOVECTORP (x, PVEC_BUFFER) #define CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_CHAR_TABLE) *************** *** 1626,1632 **** #define FUNCTIONP(OBJ) \ ((CONSP (OBJ) && EQ (XCAR (OBJ), Qlambda)) \ || (SYMBOLP (OBJ) && !NILP (Ffboundp (OBJ))) \ ! || COMPILEDP (OBJ) \ || SUBRP (OBJ)) /* defsubr (Sname); --- 1647,1653 ---- #define FUNCTIONP(OBJ) \ ((CONSP (OBJ) && EQ (XCAR (OBJ), Qlambda)) \ || (SYMBOLP (OBJ) && !NILP (Ffboundp (OBJ))) \ ! || FUNVECP (OBJ) \ || SUBRP (OBJ)) /* defsubr (Sname); *************** *** 2449,2454 **** --- 2470,2476 ---- extern Lisp_Object allocate_misc P_ ((void)); EXFUN (Fmake_vector, 2); EXFUN (Fvector, MANY); + EXFUN (Ffunvec, MANY); EXFUN (Fmake_symbol, 1); EXFUN (Fmake_marker, 0); EXFUN (Fmake_string, 2); *************** *** 2466,2471 **** --- 2488,2494 ---- extern Lisp_Object pure_cons P_ ((Lisp_Object, Lisp_Object)); extern Lisp_Object make_pure_vector P_ ((EMACS_INT)); EXFUN (Fgarbage_collect, 0); + EXFUN (Fmake_funvec, 3); EXFUN (Fmake_byte_code, MANY); EXFUN (Fmake_bool_vector, 2); EXFUN (Fmake_char_table, 2); *** orig/src/lread.c --- mod/src/lread.c *************** *** 2021,2034 **** Qnil)); } if (c == '[') ! { ! /* Accept compiled functions at read-time so that we don't have to ! build them using function calls. */ ! Lisp_Object tmp; ! tmp = read_vector (readcharfun, 1); ! return Fmake_byte_code (XVECTOR (tmp)->size, ! XVECTOR (tmp)->contents); ! } if (c == '(') { Lisp_Object tmp; --- 2021,2028 ---- Qnil)); } if (c == '[') ! /* `function vector' objects, including byte-compiled functions. */ ! return read_vector (readcharfun, 1); if (c == '(') { Lisp_Object tmp; *************** *** 2796,2804 **** static Lisp_Object ! read_vector (readcharfun, bytecodeflag) Lisp_Object readcharfun; ! int bytecodeflag; { register int i; register int size; --- 2790,2798 ---- static Lisp_Object ! read_vector (readcharfun, read_funvec) Lisp_Object readcharfun; ! int read_funvec; { register int i; register int size; *************** *** 2806,2811 **** --- 2800,2810 ---- register Lisp_Object tem, item, vector; register struct Lisp_Cons *otem; Lisp_Object len; + /* If we're reading a funvec object we start out assuming it's also a + byte-code object (a subset of funvecs), so we can do any special + processing needed. If it's just an ordinary funvec object, we'll + realize that as soon as we've read the first element. */ + int read_bytecode = read_funvec; tem = read_list (1, readcharfun); len = Flength (tem); *************** *** 2816,2826 **** for (i = 0; i < size; i++) { item = Fcar (tem); /* If `load-force-doc-strings' is t when reading a lazily-loaded bytecode object, the docstring containing the bytecode and constants values must be treated as unibyte and passed to Fread, to get the actual bytecode string and constants vector. */ ! if (bytecodeflag && load_force_doc_strings) { if (i == COMPILED_BYTECODE) { --- 2815,2833 ---- for (i = 0; i < size; i++) { item = Fcar (tem); + + /* If READ_BYTECODE is set, check whether this is really a byte-code + object, or just an ordinary `funvec' object -- non-byte-code + funvec objects use the same reader syntax. We can tell from the + first element which one it is. */ + if (read_bytecode && i == 0 && ! FUNVEC_COMPILED_TAG_P (item)) + read_bytecode = 0; /* Nope. */ + /* If `load-force-doc-strings' is t when reading a lazily-loaded bytecode object, the docstring containing the bytecode and constants values must be treated as unibyte and passed to Fread, to get the actual bytecode string and constants vector. */ ! if (read_bytecode && load_force_doc_strings) { if (i == COMPILED_BYTECODE) { *************** *** 2864,2869 **** --- 2871,2884 ---- tem = Fcdr (tem); free_cons (otem); } + + if (read_bytecode && size >= 4) + /* Convert this vector to a bytecode object. */ + vector = Fmake_byte_code (size, XVECTOR (vector)->contents); + else if (read_funvec && size >= 1) + /* Convert this vector to an ordinary funvec object. */ + XSETFUNVEC (vector, XVECTOR (vector)); + return vector; } *** orig/src/print.c --- mod/src/print.c *************** *** 1303,1309 **** loop: if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) ! || COMPILEDP (obj) || CHAR_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) && !SYMBOL_INTERNED_P (obj))) --- 1303,1309 ---- loop: if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) ! || FUNVECP (obj) || CHAR_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) && !SYMBOL_INTERNED_P (obj))) *************** *** 1406,1412 **** /* Detect circularities and truncate them. */ if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) ! || COMPILEDP (obj) || CHAR_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) && !SYMBOL_INTERNED_P (obj))) --- 1406,1412 ---- /* Detect circularities and truncate them. */ if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) ! || FUNVECP (obj) || CHAR_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) && !SYMBOL_INTERNED_P (obj))) *************** *** 1933,1939 **** else { EMACS_INT size = XVECTOR (obj)->size; ! if (COMPILEDP (obj)) { PRINTCHAR ('#'); size &= PSEUDOVECTOR_SIZE_MASK; --- 1933,1939 ---- else { EMACS_INT size = XVECTOR (obj)->size; ! if (FUNVECP (obj)) { PRINTCHAR ('#'); size &= PSEUDOVECTOR_SIZE_MASK;