programs have their own tc7 now

* libguile/tags.h (scm_tc7_program):
* libguile/programs.h: Programs now have their own tc7 code. Fix up the
  macros appropriately.

* libguile/programs.c: Remove smobby bits, leaving marking, printing,
  and application for other parts of Guile.

* libguile/debug.c (scm_procedure_source):
* libguile/eval.c (scm_trampoline_0, scm_trampoline_1)
  (scm_trampoline_2): Add cases for tc7_program.
* libguile/eval.i.c (CEVAL, SCM_APPLY):
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/gc-card.c (scm_i_sweep_card, scm_i_tag_name):
* libguile/gc-mark.c (1):
* libguile/print.c (iprin1):
* libguile/procs.c (scm_procedure_p, scm_thunk_p)
* libguile/vm-i-system.c (make-closure): Adapt to new procedure
  representation.

* libguile/procprop.c (scm_i_procedure_arity): Do the right thing for
  programs.
* test-suite/tests/procprop.test ("procedure-arity"): Arity test now
  succeeds.

* libguile/goops.c (scm_class_of): Programs now belong to the class
  <procedure>, not a smob class.

* libguile/vm.h (struct vm, struct vm_cont):
* libguile/vm-engine.c (vm_engine):
* libguile/frames.h (SCM_FRAME_BYTE_CAST, struct vm_frame):
* libguile/frames.c (scm_c_make_vm_frame): Fix usages of scm_byte_t,
  changing them to scm_t_uint8.

libguile/debug.c

@@ -363,6 +363,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
     if (!SCM_SMOB_DESCRIPTOR (proc).apply)
       break;
   case scm_tcs_subrs:
+  case scm_tc7_program:
   procprop:
     /* It would indeed be a nice thing if we supplied source even for
        built in procedures! */

libguile/eval.c

@@ -3328,6 +3328,7 @@ scm_trampoline_0 (SCM proc)
     case scm_tc7_rpsubr:
     case scm_tc7_gsubr:
     case scm_tc7_pws:
+    case scm_tc7_program:
       trampoline = scm_call_0;
       break;
     default:
@@ -3454,6 +3455,7 @@ scm_trampoline_1 (SCM proc)
     case scm_tc7_rpsubr:
     case scm_tc7_gsubr:
     case scm_tc7_pws:
+    case scm_tc7_program:
       trampoline = scm_call_1;
       break;
     default:
@@ -3548,6 +3550,7 @@ scm_trampoline_2 (SCM proc)
       break;
     case scm_tc7_gsubr:
     case scm_tc7_pws:
+    case scm_tc7_program:
       trampoline = scm_call_2;
       break;
     default:

libguile/eval.i.c

@@ -1132,6 +1132,8 @@ dispatch:
 	RETURN (SCM_BOOL_T);
       case scm_tc7_asubr:
 	RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
+      case scm_tc7_program:
+        RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
       case scm_tc7_smob:
 	if (!SCM_SMOB_APPLICABLE_P (proc))
 	  goto badfun;
@@ -1243,6 +1245,8 @@ dispatch:
 	    RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
 	  case scm_tc7_rpsubr:
 	    RETURN (SCM_BOOL_T);
+          case scm_tc7_program:
+            RETURN (scm_c_vm_run (scm_the_vm (), proc, &arg1, 1));
 	  case scm_tc7_asubr:
 	    RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
 	  case scm_tc7_lsubr:
@@ -1353,6 +1357,12 @@ dispatch:
 	  case scm_tc7_rpsubr:
 	  case scm_tc7_asubr:
 	    RETURN (SCM_SUBRF (proc) (arg1, arg2));
+          case scm_tc7_program:
+            { SCM args[2];
+              args[0] = arg1;
+              args[1] = arg2;
+              RETURN (scm_c_vm_run (scm_the_vm (), proc, args, 2));
+            }
 	  case scm_tc7_smob:
 	    if (!SCM_SMOB_APPLICABLE_P (proc))
 	      goto badfun;
@@ -1492,6 +1502,8 @@ dispatch:
 				    SCM_CDDR (debug.info->a.args)));
 	case scm_tc7_gsubr:
 	  RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
+        case scm_tc7_program:
+          RETURN (scm_vm_apply (scm_the_vm (), proc, debug.info->a.args));
 	case scm_tc7_pws:
 	  proc = SCM_PROCEDURE (proc);
 	  debug.info->a.proc = proc;
@@ -1563,6 +1575,11 @@ dispatch:
 					    scm_cons2 (arg1, arg2,
 						       scm_ceval_args (x, env,
 								       proc))));
+        case scm_tc7_program:
+          RETURN (scm_vm_apply
+                  (scm_the_vm (), proc,
+                   scm_cons (arg1, scm_cons (arg2,
+                                             scm_ceval_args (x, env, proc)))));
 	case scm_tc7_pws:
 	  proc = SCM_PROCEDURE (proc);
 	  if (!SCM_CLOSUREP (proc))
@@ -1798,6 +1815,11 @@ tail:
 	  args = SCM_CDR (args);
 	}
       RETURN (arg1);
+    case scm_tc7_program:
+      if (SCM_UNBNDP (arg1))
+        RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
+      else
+        RETURN (scm_vm_apply (scm_the_vm (), proc, scm_cons (arg1, args)));
     case scm_tc7_rpsubr:
       if (scm_is_null (args))
 	RETURN (SCM_BOOL_T);

libguile/evalext.c

@@ -82,6 +82,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
 	case scm_tc7_string:
 	case scm_tc7_smob:
 	case scm_tc7_pws:
+	case scm_tc7_program:
 	case scm_tcs_subrs:
 	case scm_tcs_struct:
 	  return SCM_BOOL_T;

libguile/frames.c

@@ -33,7 +33,7 @@ scm_t_bits scm_tc16_vm_frame;
 
 SCM
 scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
-                     scm_byte_t *ip, scm_t_ptrdiff offset)
+                     scm_t_uint8 *ip, scm_t_ptrdiff offset)
 {
   struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
                                           "vmframe");

libguile/frames.h

@@ -56,7 +56,7 @@
    + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
 #define SCM_FRAME_LOWER_ADDRESS(fp)	(fp - 4)
 
-#define SCM_FRAME_BYTE_CAST(x)		((scm_byte_t *) SCM_UNPACK (x))
+#define SCM_FRAME_BYTE_CAST(x)		((scm_t_uint8 *) SCM_UNPACK (x))
 #define SCM_FRAME_STACK_CAST(x)		((SCM *) SCM_UNPACK (x))
 
 #define SCM_FRAME_RETURN_ADDRESS(fp)				\
@@ -86,7 +86,7 @@ struct scm_vm_frame
   SCM stack_holder;
   SCM *fp;
   SCM *sp;
-  scm_byte_t *ip;
+  scm_t_uint8 *ip;
   scm_t_ptrdiff offset;
 };
 
@@ -99,9 +99,8 @@ struct scm_vm_frame
 #define SCM_VM_FRAME_OFFSET(f)	SCM_VM_FRAME_DATA(f)->offset
 #define SCM_VALIDATE_VM_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
 
-/* FIXME rename scm_byte_t */
 SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
-                                scm_byte_t *ip, scm_t_ptrdiff offset);
+                                 scm_t_uint8 *ip, scm_t_ptrdiff offset);
 SCM_API SCM scm_vm_frame_p (SCM obj);
 SCM_API SCM scm_vm_frame_program (SCM frame);
 SCM_API SCM scm_vm_frame_arguments (SCM frame);

libguile/gc-card.c

@@ -162,6 +162,8 @@ scm_i_sweep_card (scm_t_cell *card, SCM *free_list, scm_t_heap_segment *seg)
 	  break;
 	case scm_tc7_variable:
 	  break;
+	case scm_tc7_program:
+	  break;
 	case scm_tcs_subrs:
 	  /* the various "subrs" (primitives) are never freed */
 	  continue;
@@ -386,6 +388,8 @@ scm_i_tag_name (scm_t_bits tag)
       return "closures";
     case scm_tc7_pws:
       return "pws";
+    case scm_tc7_program:
+      return "program";
     case scm_tc7_wvect:
       return "weak vector";
     case scm_tc7_vector:

libguile/gc-mark.c

@@ -40,6 +40,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
 #include "libguile/smob.h"
 #include "libguile/unif.h"
 #include "libguile/async.h"
+#include "libguile/programs.h"
 #include "libguile/ports.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
@@ -285,6 +286,13 @@ scm_gc_mark_dependencies (SCM p)
       scm_gc_mark (SCM_CLOSCAR (ptr));
       ptr = SCM_ENV (ptr);
       goto gc_mark_nimp;
+    case scm_tc7_program:
+      if (SCM_PROGRAM_FREE_VARIABLES (ptr) != SCM_BOOL_F)
+        scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (ptr));
+      if (SCM_PROGRAM_OBJTABLE (ptr) != SCM_BOOL_F)
+        scm_gc_mark (SCM_PROGRAM_OBJTABLE (ptr));
+      ptr = SCM_PROGRAM_OBJCODE (ptr);
+      goto gc_mark_nimp;
     case scm_tc7_vector:
       i = SCM_SIMPLE_VECTOR_LENGTH (ptr);
       if (i == 0)

libguile/goops.c

@@ -241,6 +241,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 	  else
 	    return scm_class_procedure;
 	case scm_tc7_gsubr:
+	case scm_tc7_program:
 	  return scm_class_procedure;
 	case scm_tc7_pws:
 	  return scm_class_procedure_with_setter;

libguile/print.c

@@ -35,6 +35,7 @@
 #include "libguile/procprop.h"
 #include "libguile/read.h"
 #include "libguile/weaks.h"
+#include "libguile/programs.h"
 #include "libguile/unif.h"
 #include "libguile/alist.h"
 #include "libguile/struct.h"
@@ -682,6 +683,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	case scm_tc7_variable:
 	  scm_i_variable_print (exp, port, pstate);
 	  break;
+	case scm_tc7_program:
+	  scm_i_program_print (exp, port, pstate);
+	  break;
 	case scm_tc7_wvect:
 	  ENTER_NESTED_DATA (pstate, exp, circref);
 	  if (SCM_IS_WHVEC (exp))

libguile/procprop.c

@@ -33,6 +33,7 @@
 #include "libguile/root.h"
 #include "libguile/vectors.h"
 #include "libguile/hashtab.h"
+#include "libguile/programs.h"
 
 #include "libguile/validate.h"
 #include "libguile/procprop.h"
@@ -72,6 +73,11 @@ scm_i_procedure_arity (SCM proc)
     case scm_tc7_lsubr:
       r = 1;
       break;
+    case scm_tc7_program:
+      a += SCM_PROGRAM_DATA (proc)->nargs;
+      r = SCM_PROGRAM_DATA (proc)->nrest;
+      a -= r;
+      break;
     case scm_tc7_lsubr_2:
       a += 2;
       r = 1;

libguile/procs.c

@@ -112,6 +112,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
       case scm_tcs_closures:
       case scm_tcs_subrs:
       case scm_tc7_pws:
+      case scm_tc7_program:
 	return SCM_BOOL_T;
       case scm_tc7_smob:
 	return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
@@ -151,6 +152,10 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
 	  return SCM_BOOL_T;
 	case scm_tc7_gsubr:
 	  return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
+	case scm_tc7_program:
+	  return scm_from_bool (SCM_PROGRAM_DATA (obj)->nargs == 0
+                                || (SCM_PROGRAM_DATA (obj)->nargs == 1
+                                    && SCM_PROGRAM_DATA (obj)->nrest));
 	case scm_tc7_pws:
 	  obj = SCM_PROCEDURE (obj);
 	  goto again;

libguile/programs.c

@@ -31,8 +31,6 @@
 #include "vm.h"
 
 
-scm_t_bits scm_tc16_program;
-
 static SCM write_program = SCM_BOOL_F;
 
 SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
@@ -50,49 +48,13 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
   else if (free_variables != SCM_BOOL_F)
     SCM_VALIDATE_VECTOR (3, free_variables);
 
-  SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_variables);
+  return scm_double_cell (scm_tc7_program, (scm_t_bits)objcode,
+                          (scm_t_bits)objtable, (scm_t_bits)free_variables);
 }
 #undef FUNC_NAME
 
-static SCM
+void
-program_mark (SCM obj)
+scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
-{
-  if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
-    scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
-  if (scm_is_true (SCM_PROGRAM_FREE_VARIABLES (obj)))
-    scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (obj));
-  return SCM_PROGRAM_OBJCODE (obj);
-}
-
-static SCM
-program_apply (SCM program, SCM args)
-{
-  return scm_vm_apply (scm_the_vm (), program, args);
-}
-
-static SCM
-program_apply_0 (SCM program)
-{
-  return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
-}
-
-static SCM
-program_apply_1 (SCM program, SCM a)
-{
-  return scm_c_vm_run (scm_the_vm (), program, &a, 1);
-}
-
-static SCM
-program_apply_2 (SCM program, SCM a, SCM b)
-{
-  SCM args[2];
-  args[0] = a;
-  args[1] = b;
-  return scm_c_vm_run (scm_the_vm (), program, args, 2);
-}
-
-static int
-program_print (SCM program, SCM port, scm_print_state *pstate)
 {
   static int print_error = 0;
 
@@ -102,12 +64,17 @@ program_print (SCM program, SCM port, scm_print_state *pstate)
        scm_from_locale_symbol ("write-program"));
   
   if (SCM_FALSEP (write_program) || print_error)
-    return scm_smob_print (program, port, pstate);
+    {
-
+      scm_puts ("#<program ", port);
+      scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
+      scm_putc ('>', port);
+    }
+  else
+    {
       print_error = 1;
       scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
       print_error = 0;
-  return 1;
+    }
 }
 
 
@@ -319,13 +286,6 @@ SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
 void
 scm_bootstrap_programs (void)
 {
-  scm_tc16_program = scm_make_smob_type ("program", 0);
-  scm_set_smob_mark (scm_tc16_program, program_mark);
-  scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
-  scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_0 = program_apply_0;
-  scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1;
-  scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2;
-  scm_set_smob_print (scm_tc16_program, program_print);
   scm_c_register_extension ("libguile", "scm_init_programs",
                             (scm_t_extension_init_func)scm_init_programs, NULL);
 }

libguile/programs.h

@@ -26,19 +26,15 @@
  * Programs
  */
 
-typedef unsigned char scm_byte_t;
+#define SCM_F_PROGRAM_IS_BOOT (1<<16)
 
-SCM_API scm_t_bits scm_tc16_program;
+#define SCM_PROGRAM_P(x)	(!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
-
+#define SCM_PROGRAM_OBJCODE(x)	(SCM_CELL_OBJECT_1 (x))
-#define SCM_F_PROGRAM_IS_BOOT (1<<0)
+#define SCM_PROGRAM_OBJTABLE(x)	(SCM_CELL_OBJECT_2 (x))
-
+#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_3 (x))
-#define SCM_PROGRAM_P(x)	(SCM_SMOB_PREDICATE (scm_tc16_program, x))
-#define SCM_PROGRAM_OBJCODE(x)	(SCM_SMOB_OBJECT (x))
-#define SCM_PROGRAM_OBJTABLE(x)	(SCM_SMOB_OBJECT_2 (x))
-#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_SMOB_OBJECT_3 (x))
 #define SCM_PROGRAM_DATA(x)	(SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
 #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
-#define SCM_PROGRAM_IS_BOOT(x)	(SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
+#define SCM_PROGRAM_IS_BOOT(x)	(SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
 
 SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
 
@@ -58,6 +54,8 @@ SCM_API SCM scm_program_objcode (SCM program);
 
 SCM_API SCM scm_c_program_source (SCM program, size_t ip);
 
+SCM_INTERNAL void scm_i_program_print (SCM program, SCM port,
+                                       scm_print_state *pstate);
 SCM_INTERNAL void scm_bootstrap_programs (void);
 SCM_INTERNAL void scm_init_programs (void);
 

libguile/tags.h

@@ -3,7 +3,7 @@
 #ifndef SCM_TAGS_H
 #define SCM_TAGS_H
 
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -453,11 +453,11 @@ typedef unsigned long scm_t_bits;
 #define scm_tc7_unused_6	55
 #define scm_tc7_unused_7	71
 #define scm_tc7_unused_8	77
-#define scm_tc7_unused_9	79
 
 #define scm_tc7_dsubr		61
 #define scm_tc7_gsubr		63
 #define scm_tc7_rpsubr		69
+#define scm_tc7_program		79
 #define scm_tc7_subr_0		85
 #define scm_tc7_subr_1		87
 #define scm_tc7_cxr		93

libguile/vm-engine.c

@@ -41,7 +41,7 @@ static SCM
 VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
 {
   /* VM registers */
-  register scm_byte_t *ip IP_REG;	/* instruction pointer */
+  register scm_t_uint8 *ip IP_REG;	/* instruction pointer */
   register SCM *sp SP_REG;		/* stack pointer */
   register SCM *fp FP_REG;		/* frame pointer */
 

libguile/vm-i-system.c

@@ -1032,8 +1032,8 @@ VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1)
   POP (vect);
   SYNC_BEFORE_GC ();
   /* fixme underflow */
-  SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
+  *sp = scm_double_cell (scm_tc7_program, (scm_t_bits)SCM_PROGRAM_OBJCODE (*sp),
-                SCM_PROGRAM_OBJTABLE (*sp), vect);
+                         (scm_t_bits)SCM_PROGRAM_OBJTABLE (*sp), (scm_t_bits)vect);
   NEXT;
 }
 

libguile/vm.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -41,7 +41,7 @@ typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, SCM program, SCM *argv, int n
 #define SCM_VM_NUM_ENGINES 2
 
 struct scm_vm {
-  scm_byte_t *ip;		/* instruction pointer */
+  scm_t_uint8 *ip;		/* instruction pointer */
   SCM *sp;			/* stack pointer */
   SCM *fp;			/* frame pointer */
   size_t stack_size;		/* stack size */
@@ -88,7 +88,7 @@ SCM_API SCM scm_vm_stats (SCM vm);
 SCM_API SCM scm_vm_trace_frame (SCM vm);
 
 struct scm_vm_cont {
-  scm_byte_t *ip;
+  scm_t_uint8 *ip;
   SCM *sp;
   SCM *fp;
   scm_t_ptrdiff stack_size;

test-suite/tests/procprop.test

@@ -43,9 +43,7 @@
             '(1 0 #f)))
 
   (pass-if "apply"
-    (equal? (if ((@ (system vm program) program?) apply)
+    (equal? (procedure-property apply 'arity)
-                (throw 'unresolved)
-                (procedure-property apply 'arity))
             '(1 0 #t)))
 
   (pass-if "cons*"