Re: User-reserved element in byte code vectors

[Miles Bader <miles@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 290 bytes --]

This is a patch that adds `curried functions' as discussed, using the
#[...] syntax.

E.g., 

   (curry 'concat "The ")
   => #[curry concat "The "]

   (mapcar (curry 'concat "The ") '("a" "b" "c"))
   => ("The a" "The b" "The c")

Does this look useful for your purposes Lars?


Patch:



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: +funvec-20030514-2.patch --]
[-- Type: text/x-patch, Size: 27855 bytes --]

lisp/ChangeLog:
2004-05-14  Miles Bader  <miles@gnu.org>

	* subr.el (functionp): Use `funvecp' instead of
	`byte-compiled-function-p'.

src/ChangeLog:
2004-05-14  Miles Bader  <miles@gnu.org>

	* 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;
  }
  \f
+ 
+ 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;
+ }
+ \f
+ 
  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 <rms@gnu.ai.mit.edu> 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 ****
  
  \f
  static Lisp_Object
! read_vector (readcharfun, bytecodeflag)
       Lisp_Object readcharfun;
!      int bytecodeflag;
  {
    register int i;
    register int size;
--- 2790,2798 ----
  
  \f
  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;




[-- Attachment #3: Type: text/plain, Size: 53 bytes --]



-Miles
-- 
`Life is a boundless sea of bitterness'

[-- Attachment #4: Type: text/plain, Size: 141 bytes --]

_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/emacs-devel