summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Makefile.am15
-rw-r--r--src/envs.c29
-rw-r--r--src/envs.h4
-rw-r--r--src/frames.c4
-rw-r--r--src/guile-disasm.in11
-rw-r--r--src/instructions.c2
-rw-r--r--src/objcodes.c17
-rw-r--r--src/programs.c13
8 files changed, 67 insertions, 28 deletions
diff --git a/src/Makefile.am b/src/Makefile.am
index e1d8db014..82d8604d4 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -1,5 +1,5 @@
bin_PROGRAMS = guile-vm
-bin_SCRIPTS = guilec
+bin_SCRIPTS = guilec guile-disasm
guile_vm_SOURCES = guile-vm.c
guile_vm_LDADD = libguilevm.la
guile_vm_LDFLAGS = $(GUILE_LDFLAGS)
@@ -14,7 +14,8 @@ libguilevm_la_SOURCES = \
vm_engine.h vm_expand.h
libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic
libguilevm_la_LDFLAGS += -pg
-EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c
+EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c \
+ guilec.in guile-disasm.in
BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \
envs.x frames.x instructions.x objcodes.x programs.x vm.x
@@ -32,7 +33,7 @@ SUFFIXES = .i .x
grep '^VM_DEFINE' $< > $@
.c.x:
- $(SNARF) $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
+ $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
|| { rm $@; false; }
@@ -44,9 +45,9 @@ SUFFIXES = .i .x
%.s: %.c
$(CC) -S -dA $(DEFS) $(INCLUDES) $(CFLAGS) $(CPPFLAGS) -o $@ $<
-GUILE = "$(bindir)/guile"
-guilec: guilec.in
- sed "s!@guile@!$(GUILE)!" guilec.in > guilec
- @chmod 755 guilec
+
+%: %.in
+ sed "s!@guile@!$(GUILE)!" $^ > $@
+ @chmod 755 $@
$(BUILT_SOURCES): config.h vm_expand.h
diff --git a/src/envs.c b/src/envs.c
index 2f3212b8f..c6ace0300 100644
--- a/src/envs.c
+++ b/src/envs.c
@@ -85,7 +85,7 @@ SCM
scm_c_lookup_env (SCM identifier)
{
/* Check if the env is already loaded */
- SCM vcell = scm_sym2ovcell_soft (identifier, env_table);
+ SCM vcell = scm_hash_get_handle (env_table, identifier);
/* If not, load the env */
if (SCM_FALSEP (vcell))
@@ -95,21 +95,24 @@ scm_c_lookup_env (SCM identifier)
if (!SCM_ENV_P (env))
scm_misc_error ("scm_c_lookup_env",
"Invalid env: ~S", SCM_LIST1 (env));
- scm_intern_symbol (env_table, identifier);
- vcell = scm_sym2ovcell_soft (identifier, env_table);
- SCM_SETCDR (vcell, env);
+ vcell = scm_hash_create_handle_x (env_table, identifier, env);
}
- return SCM_CDR (vcell);
+ return (SCM_CDR (vcell));
}
SCM
scm_c_env_vcell (SCM env, SCM name, int intern)
{
+ SCM vcell;
SCM ob = SCM_ENV_OBARRAY (env);
+
if (intern)
- scm_intern_symbol (ob, name);
- return scm_sym2ovcell_soft (name, ob);
+ vcell = scm_hash_create_handle_x (ob, name, SCM_UNSPECIFIED);
+ else
+ vcell = scm_hash_get_handle (ob, name);
+
+ return vcell;
}
@@ -162,10 +165,13 @@ SCM_DEFINE (scm_env_bound_p, "env-bound?", 2, 0, 0,
"")
#define FUNC_NAME s_scm_env_bound_p
{
- SCM vcell;
+ SCM obarray, vcell;
SCM_VALIDATE_ENV (1, env);
SCM_VALIDATE_SYMBOL (2, name);
- vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env));
+
+ obarray = SCM_ENV_OBARRAY (env);
+ vcell = scm_hash_get_handle (obarray, name);
+
return SCM_BOOL (!SCM_FALSEP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell)));
}
#undef FUNC_NAME
@@ -178,7 +184,7 @@ SCM_DEFINE (scm_env_ref, "env-ref", 2, 0, 0,
SCM vcell;
SCM_VALIDATE_ENV (1, env);
SCM_VALIDATE_SYMBOL (2, name);
- vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env));
+ vcell = scm_hash_get_handle (name, SCM_ENV_OBARRAY (env));
if (SCM_FALSEP (vcell) || SCM_UNBNDP (SCM_CDR (vcell)))
SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A",
SCM_LIST2 (env, name));
@@ -194,11 +200,12 @@ SCM_DEFINE (scm_env_set_x, "env-set!", 3, 0, 0,
SCM vcell;
SCM_VALIDATE_ENV (1, env);
SCM_VALIDATE_SYMBOL (2, name);
- vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env));
+ vcell = scm_hash_get_handle (name, SCM_ENV_OBARRAY (env));
if (SCM_FALSEP (vcell))
SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A",
SCM_LIST2 (env, name));
SCM_SETCDR (vcell, val);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/src/envs.h b/src/envs.h
index 79a410de7..455cd1daa 100644
--- a/src/envs.h
+++ b/src/envs.h
@@ -47,10 +47,12 @@
extern scm_t_bits scm_tc16_env;
-struct scm_env {
+struct scm_env
+{
SCM identifier;
SCM obarray;
};
+typedef struct scm_env scm_env_t;
#define SCM_ENV_P(x) SCM_SMOB_PREDICATE (scm_tc16_env, x)
#define SCM_ENV_DATA(x) ((struct scm_env *) SCM_SMOB_DATA (x))
diff --git a/src/frames.c b/src/frames.c
index 1b83bf022..80c2147af 100644
--- a/src/frames.c
+++ b/src/frames.c
@@ -115,7 +115,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
#define FUNC_NAME s_scm_frame_local_ref
{
SCM_VALIDATE_HEAP_FRAME (1, frame);
- SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
+ SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
SCM_I_INUM (index));
}
@@ -127,7 +127,7 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
#define FUNC_NAME s_scm_frame_local_set_x
{
SCM_VALIDATE_HEAP_FRAME (1, frame);
- SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
+ SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
SCM_I_INUM (index)) = val;
return SCM_UNSPECIFIED;
diff --git a/src/guile-disasm.in b/src/guile-disasm.in
new file mode 100644
index 000000000..08095f505
--- /dev/null
+++ b/src/guile-disasm.in
@@ -0,0 +1,11 @@
+#!@guile@ -s
+!#
+
+;; Obviously, this is -*- Scheme -*-.
+
+(use-modules (system vm core)
+ (system vm disasm))
+
+(for-each (lambda (file)
+ (disassemble-objcode (load-objcode file)))
+ (cdr (command-line)))
diff --git a/src/instructions.c b/src/instructions.c
index ae04d82d4..f2a2b1ec9 100644
--- a/src/instructions.c
+++ b/src/instructions.c
@@ -147,7 +147,7 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
#define FUNC_NAME s_scm_opcode_to_instruction
{
int i;
- SCM_VALIDATE_INUM (1, op);
+ SCM_MAKE_VALIDATE (1, op, I_INUMP);
i = SCM_I_INUM (op);
SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last);
return scm_from_locale_symbol (scm_instruction_table[i].name);
diff --git a/src/objcodes.c b/src/objcodes.c
index 0e494b77a..8903bd338 100644
--- a/src/objcodes.c
+++ b/src/objcodes.c
@@ -82,10 +82,15 @@ make_objcode_by_mmap (int fd)
struct scm_objcode *p;
ret = fstat (fd, &st);
- if (ret < 0) SCM_SYSERROR;
+ if ((ret < 0) || (st.st_size <= strlen (OBJCODE_COOKIE)))
+ SCM_SYSERROR;
addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
- if (addr == MAP_FAILED) SCM_SYSERROR;
+ if (addr == MAP_FAILED)
+ SCM_SYSERROR;
+
+ if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
+ SCM_SYSERROR;
p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode");
p->size = st.st_size;
@@ -179,8 +184,8 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
- SCM_VALIDATE_INUM (2, nlocs);
- SCM_VALIDATE_INUM (3, nexts);
+ SCM_VALIDATE_NUMBER (2, nlocs);
+ SCM_VALIDATE_NUMBER (3, nexts);
c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
assert (increment == 1);
@@ -191,8 +196,8 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
base = SCM_OBJCODE_BASE (objcode);
memcpy (base, OBJCODE_COOKIE, 8);
- base[8] = SCM_I_INUM (nlocs);
- base[9] = SCM_I_INUM (nexts);
+ base[8] = scm_to_uint8 (nlocs);
+ base[9] = scm_to_uint8 (nexts);
memcpy (base + 10, c_bytecode, size - 10);
diff --git a/src/programs.c b/src/programs.c
index 423b14b11..50848a774 100644
--- a/src/programs.c
+++ b/src/programs.c
@@ -186,6 +186,19 @@ SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
+ (SCM program, SCM external),
+ "Modify the list of closure variables of @var{program} (for "
+ "debugging purposes).")
+#define FUNC_NAME s_scm_program_external_set_x
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ SCM_VALIDATE_LIST (2, external);
+ SCM_PROGRAM_DATA (program)->external = external;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
(SCM program),
"Return a u8vector containing @var{program}'s bytecode.")