diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Makefile.am | 15 | ||||
-rw-r--r-- | src/envs.c | 29 | ||||
-rw-r--r-- | src/envs.h | 4 | ||||
-rw-r--r-- | src/frames.c | 4 | ||||
-rw-r--r-- | src/guile-disasm.in | 11 | ||||
-rw-r--r-- | src/instructions.c | 2 | ||||
-rw-r--r-- | src/objcodes.c | 17 | ||||
-rw-r--r-- | src/programs.c | 13 |
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.") |