mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
Translation from Scheme to GHIL, and compilation to GLIL work.
* src/*.c: Removed calls to `scm_must_malloc', `SCM_MUST_MALLOC' and `scm_must_free'. Same for `SCM_INUMP', `SCM_INUM', `SCM_STRING_CHARS', and the likes. * module/system/base/syntax.scm: Do not import `(ice-9 match)' and do not re-export `match', do not export `syntax-error' which was not defined here. * module/system/base/compile.scm (call-with-compile-error-catch): Use the `catch' form instead of `try'. * src/instructions.c: Use `scm_from_char ()' instead of the deprecated macro `SCM_MAKINUM ()'. * src/instructions.h (scm_instruction): Made `npop' a signed char. git-archimport-id: lcourtes@laas.fr--2004-libre/guile-vm--revival--0.6--patch-2
This commit is contained in:
Ludovic Court`es
Ludovic Courtès
parent
f9e8c09d42
commit
d8eeb67c89
12 changed files with 111 additions and 79 deletions
|
|
@ -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))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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*))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
15
src/frames.c
15
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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
};
|
||||
|
||||
|
|
|
|||
|
|
@ -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_must_free (p);
|
||||
return size;
|
||||
scm_gc_free (p, size, "objcode");
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
31
src/vm.c
31
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");
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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)); \
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue