mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Translation from Scheme to GHIL, and compilation to GLIL work.

Browse source 
* 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 2005-04-22 16:00:33 +00:00 • committed by Ludovic Courtès
parent f9e8c09d42
commit d8eeb67c89
12 changed files with 111 additions and 79 deletions
Download patch file Download diff file Expand all files Collapse all files

5
module/system/base/compile.scm
View file

@ -41,8 +41,9 @@
(throw 'syntax-error loc msg exp))
(define-public (call-with-compile-error-catch thunk)
(try (thunk)
((syntax-error loc msg exp)
(catch 'syntax-error
(thunk)
(lambda (key loc msg exp)
(format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))

3
module/system/base/syntax.scm
View file

@ -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*))
;;;

2
module/system/vm/assemble.scm
View file

@ -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))

9
src/envs.c
View file

@ -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
View file

@ -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

24
src/instructions.c
View file

@ -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)
{
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);
}

10
src/instructions.h
View file

@ -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 */
};

34
src/objcodes.c
View file

@ -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

17
src/programs.c
View file

@ -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

29
src/vm.c
View file

@ -68,9 +68,9 @@ 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),
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;
@ -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");

12
src/vm_loader.c
View file

@ -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);

14
src/vm_scheme.c
View file

@ -167,8 +167,8 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
#define REL(crel,srel) \
{ \
ARGS2 (x, y); \
if (SCM_INUMP (x) && SCM_INUMP (y)) \
RETURN (SCM_BOOL (SCM_INUM (x) crel SCM_INUM (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)); \
}
@ -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); \
}
@ -219,11 +219,11 @@ VM_DEFINE_FUNCTION (ge, "ge?", 2)
#define FUNC2(CFUNC,SFUNC) \
{ \
ARGS2 (x, y); \
if (SCM_INUMP (x) && SCM_INUMP (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)); \
}