From d8eeb67c89ea3f68f25bd1d7633a91cd3e8c1b68 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 22 Apr 2005 16:00:33 +0000 Subject: [PATCH] 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 --- module/system/base/compile.scm | 7 ++++--- module/system/base/syntax.scm | 3 +-- module/system/vm/assemble.scm | 2 +- src/envs.c | 9 +++++---- src/frames.c | 15 ++++++++++----- src/instructions.c | 26 +++++++++++++++++++------- src/instructions.h | 10 +++++++--- src/objcodes.c | 34 +++++++++++++++++++--------------- src/programs.c | 17 +++++++++-------- src/vm.c | 31 ++++++++++++++++++------------- src/vm_loader.c | 12 ++++++------ src/vm_scheme.c | 24 ++++++++++++------------ 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)); \ } -- 2.20.1