summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/debug.c1
-rw-r--r--libguile/eval.c3
-rw-r--r--libguile/eval.i.c22
-rw-r--r--libguile/evalext.c1
-rw-r--r--libguile/frames.c2
-rw-r--r--libguile/frames.h7
-rw-r--r--libguile/gc-card.c4
-rw-r--r--libguile/gc-mark.c8
-rw-r--r--libguile/goops.c1
-rw-r--r--libguile/print.c4
-rw-r--r--libguile/procprop.c6
-rw-r--r--libguile/procs.c5
-rw-r--r--libguile/programs.c70
-rw-r--r--libguile/programs.h18
-rw-r--r--libguile/tags.h4
-rw-r--r--libguile/vm-engine.c2
-rw-r--r--libguile/vm-i-system.c4
-rw-r--r--libguile/vm.h6
-rw-r--r--test-suite/tests/procprop.test4
19 files changed, 91 insertions, 81 deletions
diff --git a/libguile/debug.c b/libguile/debug.c
index 71278c5e4..4bf311136 100644
--- a/libguile/debug.c
+++ b/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! */
diff --git a/libguile/eval.c b/libguile/eval.c
index 6a6a0ce7b..1563b5125 100644
--- a/libguile/eval.c
+++ b/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:
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index 99aa265de..461349a2b 100644
--- a/libguile/eval.i.c
+++ b/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);
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 19d8f2e02..b1f185cc5 100644
--- a/libguile/evalext.c
+++ b/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;
diff --git a/libguile/frames.c b/libguile/frames.c
index 86480e352..737babc1a 100644
--- a/libguile/frames.c
+++ b/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");
diff --git a/libguile/frames.h b/libguile/frames.h
index cce661f8f..0165924a7 100644
--- a/libguile/frames.h
+++ b/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);
diff --git a/libguile/gc-card.c b/libguile/gc-card.c
index 85520f8e4..af2923396 100644
--- a/libguile/gc-card.c
+++ b/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:
diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c
index 84714507b..ccbcdcc2f 100644
--- a/libguile/gc-mark.c
+++ b/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)
diff --git a/libguile/goops.c b/libguile/goops.c
index c286dbe4c..8145e4162 100644
--- a/libguile/goops.c
+++ b/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;
diff --git a/libguile/print.c b/libguile/print.c
index 152baef6e..74f7d8db6 100644
--- a/libguile/print.c
+++ b/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))
diff --git a/libguile/procprop.c b/libguile/procprop.c
index df96eaad4..5054291b1 100644
--- a/libguile/procprop.c
+++ b/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;
diff --git a/libguile/procs.c b/libguile/procs.c
index d873ff55e..815e29fe7 100644
--- a/libguile/procs.c
+++ b/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;
diff --git a/libguile/programs.c b/libguile/programs.c
index 5c43ac525..b2bf80674 100644
--- a/libguile/programs.c
+++ b/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
-program_mark (SCM obj)
-{
- 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)
+void
+scm_i_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);
-
- print_error = 1;
- scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
- print_error = 0;
- return 1;
+ {
+ 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;
+ }
}
@@ -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);
}
diff --git a/libguile/programs.h b/libguile/programs.h
index 040e8ea2c..d52631fbb 100644
--- a/libguile/programs.h
+++ b/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_F_PROGRAM_IS_BOOT (1<<0)
-
-#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_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
+#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
+#define SCM_PROGRAM_OBJTABLE(x) (SCM_CELL_OBJECT_2 (x))
+#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_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);
diff --git a/libguile/tags.h b/libguile/tags.h
index 329453341..9a11df51f 100644
--- a/libguile/tags.h
+++ b/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
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 32780b87a..b373cd017 100644
--- a/libguile/vm-engine.c
+++ b/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 */
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index cda985d15..0662f8188 100644
--- a/libguile/vm-i-system.c
+++ b/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),
- SCM_PROGRAM_OBJTABLE (*sp), vect);
+ *sp = scm_double_cell (scm_tc7_program, (scm_t_bits)SCM_PROGRAM_OBJCODE (*sp),
+ (scm_t_bits)SCM_PROGRAM_OBJTABLE (*sp), (scm_t_bits)vect);
NEXT;
}
diff --git a/libguile/vm.h b/libguile/vm.h
index b079c7aa0..eace1cb69 100644
--- a/libguile/vm.h
+++ b/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;
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index 5768e1a64..6af73f6bb 100644
--- a/test-suite/tests/procprop.test
+++ b/test-suite/tests/procprop.test
@@ -43,9 +43,7 @@
'(1 0 #f)))
(pass-if "apply"
- (equal? (if ((@ (system vm program) program?) apply)
- (throw 'unresolved)
- (procedure-property apply 'arity))
+ (equal? (procedure-property apply 'arity)
'(1 0 #t)))
(pass-if "cons*"