summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/system/base/compile.scm7
-rw-r--r--module/system/base/syntax.scm3
-rw-r--r--module/system/vm/assemble.scm2
-rw-r--r--src/envs.c9
-rw-r--r--src/frames.c15
-rw-r--r--src/instructions.c26
-rw-r--r--src/instructions.h10
-rw-r--r--src/objcodes.c34
-rw-r--r--src/programs.c17
-rw-r--r--src/vm.c31
-rw-r--r--src/vm_loader.c12
-rw-r--r--src/vm_scheme.c24
12 files changed, 111 insertions, 79 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index e6b2d1310..49a47eea6 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -41,9 +41,10 @@
(throw 'syntax-error loc msg exp))
(define-public (call-with-compile-error-catch thunk)
- (try (thunk)
- ((syntax-error loc msg exp)
- (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
+ (catch 'syntax-error
+ (thunk)
+ (lambda (key loc msg exp)
+ (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
;;;
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index fba21679c..bcc926bee 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -20,10 +20,9 @@
;;; Code:
(define-module (system base syntax)
- :use-module (ice-9 match)
:use-module (ice-9 receive)
:use-module (ice-9 and-let-star)
- :export (stack-catch match syntax-error receive and-let*))
+ :export (stack-catch receive and-let*))
;;;
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 36dd24ae4..726312ac6 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -27,7 +27,7 @@
:use-module (ice-9 match)
:use-module (ice-9 regex)
:use-module (ice-9 common-list)
- :export (assemble))
+ :export (preprocess assemble))
(define (assemble glil env . opts)
(codegen (preprocess glil #f) #t))
diff --git a/src/envs.c b/src/envs.c
index f1b3ceec2..2f3212b8f 100644
--- a/src/envs.c
+++ b/src/envs.c
@@ -50,8 +50,8 @@ scm_t_bits scm_tc16_env;
SCM
scm_c_make_env (void)
{
- struct scm_env *p = scm_must_malloc (sizeof (struct scm_env),
- "scm_c_make_env");
+ struct scm_env *p = scm_gc_malloc (sizeof (struct scm_env),
+ "env");
p->identifier = SCM_BOOL_F;
p->obarray = scm_c_make_hash_table (ENV_OBARRAY_SIZE);
SCM_RETURN_NEWSMOB (scm_tc16_env, p);
@@ -68,8 +68,9 @@ env_mark (SCM obj)
static scm_sizet
env_free (SCM obj)
{
- scm_must_free (SCM_ENV_DATA (obj));
- return sizeof (struct scm_env);
+ scm_gc_free (SCM_ENV_DATA (obj), sizeof (struct scm_env),
+ "env");
+ return 0;
}
diff --git a/src/frames.c b/src/frames.c
index dc216e98f..f2f16647d 100644
--- a/src/frames.c
+++ b/src/frames.c
@@ -52,10 +52,12 @@ scm_c_make_heap_frame (SCM *fp)
SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
size_t size = sizeof (SCM) * (upper - lower + 1);
- SCM *p = scm_must_malloc (size, "scm_c_make_heap_frame");
+ SCM *p = scm_gc_malloc (size, "frame");
+
SCM_NEWSMOB (frame, scm_tc16_heap_frame, p);
p[0] = frame; /* self link */
memcpy (p + 1, lower, size - sizeof (SCM));
+
return frame;
}
@@ -80,8 +82,10 @@ heap_frame_free (SCM obj)
SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
size_t size = sizeof (SCM) * (upper - lower + 1);
- scm_must_free (SCM_HEAP_FRAME_DATA (obj));
- return size;
+
+ scm_gc_free (SCM_HEAP_FRAME_DATA (obj), size, "frame");
+
+ return 0;
}
/* Scheme interface */
@@ -113,7 +117,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
SCM_VALIDATE_HEAP_FRAME (1, frame);
SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
- SCM_INUM (index));
+ scm_to_int (index));
}
#undef FUNC_NAME
@@ -124,7 +128,8 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
{
SCM_VALIDATE_HEAP_FRAME (1, frame);
SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
- SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame), SCM_INUM (index)) = val;
+ SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
+ scm_to_int (index)) = val;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/src/instructions.c b/src/instructions.c
index 6cfdf636f..93115de91 100644
--- a/src/instructions.c
+++ b/src/instructions.c
@@ -58,10 +58,22 @@ struct scm_instruction *
scm_lookup_instruction (SCM name)
{
struct scm_instruction *ip;
+ char *symbol;
+
if (SCM_SYMBOLP (name))
for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
- if (strcmp (ip->name, SCM_SYMBOL_CHARS (name)) == 0)
- return ip;
+ {
+ symbol = scm_to_locale_string (scm_symbol_to_string (name));
+ if ((symbol) && (strcmp (ip->name, symbol) == 0))
+ {
+ free (symbol);
+ return ip;
+ }
+
+ if (symbol)
+ free (symbol);
+ }
+
return 0;
}
@@ -95,7 +107,7 @@ SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
#define FUNC_NAME s_scm_instruction_length
{
SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_MAKINUM (SCM_INSTRUCTION_LENGTH (inst));
+ return scm_from_schar (SCM_INSTRUCTION_LENGTH (inst));
}
#undef FUNC_NAME
@@ -105,7 +117,7 @@ SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
#define FUNC_NAME s_scm_instruction_pops
{
SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_MAKINUM (SCM_INSTRUCTION_POPS (inst));
+ return scm_from_schar (SCM_INSTRUCTION_POPS (inst));
}
#undef FUNC_NAME
@@ -115,7 +127,7 @@ SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
#define FUNC_NAME s_scm_instruction_pushes
{
SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_MAKINUM (SCM_INSTRUCTION_PUSHES (inst));
+ return scm_from_char (SCM_INSTRUCTION_PUSHES (inst));
}
#undef FUNC_NAME
@@ -125,7 +137,7 @@ SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
#define FUNC_NAME s_scm_instruction_to_opcode
{
SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_MAKINUM (SCM_INSTRUCTION_OPCODE (inst));
+ return scm_from_char (SCM_INSTRUCTION_OPCODE (inst));
}
#undef FUNC_NAME
@@ -136,7 +148,7 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
{
int i;
SCM_VALIDATE_INUM (1, op);
- i = SCM_INUM (op);
+ i = scm_to_int (op);
SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last);
return scm_str2symbol (scm_instruction_table[i].name);
}
diff --git a/src/instructions.h b/src/instructions.h
index 6b6757489..6f1a146cf 100644
--- a/src/instructions.h
+++ b/src/instructions.h
@@ -57,9 +57,13 @@ enum scm_opcode {
struct scm_instruction {
enum scm_opcode opcode; /* opcode */
- char *name; /* instruction name */
- char len; /* instruction length */
- char npop; /* the number of values popped */
+ const char *name; /* instruction name */
+ signed char len; /* Instruction length. This may be -1 for
+ the loader (see the `VM_LOADER'
+ macro). */
+ signed char npop; /* The number of values popped. This may be
+ -1 for insns like `call' which can take
+ any number of arguments. */
char npush; /* the number of values pushed */
};
diff --git a/src/objcodes.c b/src/objcodes.c
index ad0d2e7c3..f845105ad 100644
--- a/src/objcodes.c
+++ b/src/objcodes.c
@@ -62,9 +62,10 @@ static SCM
make_objcode (size_t size)
#define FUNC_NAME "make_objcode"
{
- struct scm_objcode *p = SCM_MUST_MALLOC (sizeof (struct scm_objcode));
+ struct scm_objcode *p = scm_gc_malloc (sizeof (struct scm_objcode),
+ "objcode");
p->size = size;
- p->base = SCM_MUST_MALLOC (size);
+ p->base = scm_gc_malloc (size, "objcode-base");
p->fd = -1;
SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
}
@@ -85,7 +86,7 @@ make_objcode_by_mmap (int fd)
addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
if (addr == MAP_FAILED) SCM_SYSERROR;
- p = SCM_MUST_MALLOC (sizeof (struct scm_objcode));
+ p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode");
p->size = st.st_size;
p->base = addr;
p->fd = fd;
@@ -97,7 +98,7 @@ static scm_sizet
objcode_free (SCM obj)
#define FUNC_NAME "objcode_free"
{
- size_t size = (sizeof (struct scm_objcode));
+ size_t size = sizeof (struct scm_objcode);
struct scm_objcode *p = SCM_OBJCODE_DATA (obj);
if (p->fd >= 0)
@@ -109,13 +110,11 @@ objcode_free (SCM obj)
if (rv < 0) SCM_SYSERROR;
}
else
- {
- size += p->size;
- scm_must_free (p->base);
- }
+ scm_gc_free (p->base, p->size, "objcode-base");
+
+ scm_gc_free (p, size, "objcode");
- scm_must_free (p);
- return size;
+ return 0;
}
#undef FUNC_NAME
@@ -139,21 +138,26 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
#define FUNC_NAME s_scm_bytecode_to_objcode
{
size_t size;
- char *base;
+ char *base, *c_bytecode;
SCM objcode;
SCM_VALIDATE_STRING (1, bytecode);
SCM_VALIDATE_INUM (2, nlocs);
SCM_VALIDATE_INUM (3, nexts);
- size = SCM_STRING_LENGTH (bytecode) + 10;
+ size = scm_c_string_length (bytecode) + 10;
objcode = make_objcode (size);
base = SCM_OBJCODE_BASE (objcode);
memcpy (base, OBJCODE_COOKIE, 8);
- base[8] = SCM_INUM (nlocs);
- base[9] = SCM_INUM (nexts);
- memcpy (base + 10, SCM_STRING_CHARS (bytecode), size - 10);
+ base[8] = scm_to_int (nlocs);
+ base[9] = scm_to_int (nexts);
+
+ /* FIXME: We should really use SRFI-4 u8vectors! (Ludovic) */
+ c_bytecode = scm_to_locale_string (bytecode);
+ memcpy (base + 10, c_bytecode, size - 10);
+ free (c_bytecode);
+
return objcode;
}
#undef FUNC_NAME
diff --git a/src/programs.c b/src/programs.c
index 39f43dee6..5c1cb49c4 100644
--- a/src/programs.c
+++ b/src/programs.c
@@ -53,7 +53,8 @@ SCM
scm_c_make_program (void *addr, size_t size, SCM holder)
#define FUNC_NAME "scm_c_make_program"
{
- struct scm_program *p = SCM_MUST_MALLOC (sizeof (struct scm_program));
+ struct scm_program *p = scm_gc_malloc (sizeof (struct scm_program),
+ "program");
p->size = size;
p->nargs = 0;
p->nrest = 0;
@@ -66,7 +67,7 @@ scm_c_make_program (void *addr, size_t size, SCM holder)
/* If nobody holds bytecode's address, then allocate a new memory */
if (SCM_FALSEP (holder))
- p->base = SCM_MUST_MALLOC (size);
+ p->base = scm_gc_malloc (size, "program-base");
else
p->base = addr;
@@ -98,13 +99,13 @@ program_free (SCM obj)
{
struct scm_program *p = SCM_PROGRAM_DATA (obj);
scm_sizet size = (sizeof (struct scm_program));
+
if (SCM_FALSEP (p->holder))
- {
- size += p->size;
- scm_must_free (p->base);
- }
- scm_must_free (p);
- return size;
+ scm_gc_free (p->base, p->size, "program-base");
+
+ scm_gc_free (p, size, "program");
+
+ return 0;
}
static SCM
diff --git a/src/vm.c b/src/vm.c
index e0904f871..8a4fa1789 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -68,10 +68,10 @@ scm_t_bits scm_tc16_vm_cont;
static SCM
capture_vm_cont (struct scm_vm *vp)
{
- struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont");
+ struct scm_vm *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
p->stack_size = vp->stack_limit - vp->sp;
- p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM),
- "capture_vm_cont");
+ p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
+ "capture_vm_cont");
p->stack_limit = p->stack_base + p->stack_size - 2;
p->ip = vp->ip;
p->sp = (SCM *) (vp->stack_limit - vp->sp);
@@ -110,10 +110,11 @@ static scm_sizet
vm_cont_free (SCM obj)
{
struct scm_vm *p = SCM_VM_CONT_VP (obj);
- int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM);
- scm_must_free (p->stack_base);
- scm_must_free (p);
- return size;
+
+ scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
+ scm_gc_free (p, sizeof (struct scm_vm), "vm");
+
+ return 0;
}
@@ -232,9 +233,11 @@ make_vm (void)
#define FUNC_NAME "make_vm"
{
int i;
- struct scm_vm *vp = SCM_MUST_MALLOC (sizeof (struct scm_vm));
+ struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+
vp->stack_size = VM_DEFAULT_STACK_SIZE;
- vp->stack_base = SCM_MUST_MALLOC (vp->stack_size * sizeof (SCM));
+ vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM),
+ "stack-base");
vp->stack_limit = vp->stack_base + vp->stack_size - 3;
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
@@ -272,10 +275,12 @@ static scm_sizet
vm_free (SCM obj)
{
struct scm_vm *vp = SCM_VM_DATA (obj);
- int size = (sizeof (struct scm_vm) + vp->stack_size * sizeof (SCM));
- scm_must_free (vp->stack_base);
- scm_must_free (vp);
- return size;
+
+ scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
+ "stack-base");
+ scm_gc_free (vp, sizeof (struct scm_vm), "vm");
+
+ return 0;
}
SCM_SYMBOL (sym_debug, "debug");
diff --git a/src/vm_loader.c b/src/vm_loader.c
index cd2eb21ad..fb30b54ee 100644
--- a/src/vm_loader.c
+++ b/src/vm_loader.c
@@ -138,9 +138,9 @@ VM_DEFINE_LOADER (load_program, "load-program")
/* init parameters */
/* NOTE: format defined in system/vm/assemble.scm */
- if (SCM_INUMP (x))
+ if (scm_is_integer (x))
{
- int i = SCM_INUM (x);
+ int i = scm_to_int (x);
if (-128 <= i && i <= 127)
{
/* 8-bit representation */
@@ -162,10 +162,10 @@ VM_DEFINE_LOADER (load_program, "load-program")
{
/* Other cases */
sp -= 4;
- p->nargs = SCM_INUM (sp[0]);
- p->nrest = SCM_INUM (sp[1]);
- p->nlocs = SCM_INUM (sp[2]);
- p->nexts = SCM_INUM (sp[3]);
+ p->nargs = scm_to_int (sp[0]);
+ p->nrest = scm_to_int (sp[1]);
+ p->nlocs = scm_to_int (sp[2]);
+ p->nexts = scm_to_int (sp[3]);
}
PUSH (prog);
diff --git a/src/vm_scheme.c b/src/vm_scheme.c
index bb552d948..a134dfe07 100644
--- a/src/vm_scheme.c
+++ b/src/vm_scheme.c
@@ -164,12 +164,12 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
*/
#undef REL
-#define REL(crel,srel) \
-{ \
- ARGS2 (x, y); \
- if (SCM_INUMP (x) && SCM_INUMP (y)) \
- RETURN (SCM_BOOL (SCM_INUM (x) crel SCM_INUM (y))); \
- RETURN (srel (x, y)); \
+#define REL(crel,srel) \
+{ \
+ ARGS2 (x, y); \
+ if (scm_is_integer (x) && scm_is_integer (y)) \
+ RETURN (SCM_BOOL (scm_to_int (x) crel scm_to_int (y))); \
+ RETURN (srel (x, y)); \
}
VM_DEFINE_FUNCTION (ee, "ee?", 2)
@@ -206,11 +206,11 @@ VM_DEFINE_FUNCTION (ge, "ge?", 2)
#define FUNC1(CEXP,SEXP) \
{ \
ARGS1 (x); \
- if (SCM_INUMP (x)) \
+ if (scm_is_integer (x)) \
{ \
int n = CEXP; \
if (SCM_FIXABLE (n)) \
- RETURN (SCM_MAKINUM (n)); \
+ RETURN (scm_from_int (n)); \
} \
RETURN (SEXP); \
}
@@ -218,12 +218,12 @@ VM_DEFINE_FUNCTION (ge, "ge?", 2)
#undef FUNC2
#define FUNC2(CFUNC,SFUNC) \
{ \
- ARGS2 (x, y); \
- if (SCM_INUMP (x) && SCM_INUMP (y)) \
+ ARGS2 (x, y); \
+ if (scm_is_integer (x) && scm_is_integer (y)) \
{ \
- int n = SCM_INUM (x) CFUNC SCM_INUM (y); \
+ int n = scm_to_int (x) CFUNC scm_to_int (y); \
if (SCM_FIXABLE (n)) \
- RETURN (SCM_MAKINUM (n)); \
+ RETURN (scm_from_int (n)); \
} \
RETURN (SFUNC (x, y)); \
}