Commit 41835a5a authored by eg's avatar eg

Bug fix: valc was incorrect when applying from C

parent cfd60e3f
2006-02-07 Erick Gallesio <eg@essi.fr>
* src/vm.c (STk_C_apply): Return STk_void if valc == 0.
* src/read.c (read_srfi10):
* src/port.c (format): Use STk_apply_C_list instead of
(apply (apply ...))
2006-02-03 Erick Gallesio <eg@essi.fr>
* src/system.c: primitive CURRENT-TIME as been renamed to
......
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 3-Feb-2006 16:32 (eg)
# Last file update: 7-Feb-2006 10:16 (eg)
SUBDIRS = Match.d SILex.d Lalr.d
......@@ -33,12 +33,12 @@ scheme_BOOT = assembler.stk \
scheme_SRCS = STklos.init \
bigloo.stk \
compfile.stk \
date.stk \
describe.stk \
expand.ss \
full-syntax.stk \
full-conditions.stk \
getopt.stk \
lalr.stk \
lex-rt.stk \
make-C-boot.stk \
match.stk \
......@@ -62,16 +62,17 @@ scheme_SRCS = STklos.init \
srfi-48.stk \
srfi-60.stk \
srfi-66.stk \
srfi-69.stk \
srfi-70.stk \
trace.stk
scheme_OBJS = date.ostk \
compfile.ostk \
scheme_OBJS = compfile.ostk \
full-syntax.ostk \
full-conditions.ostk \
describe.ostk \
getopt.ostk \
lex-rt.ostk \
lalr.ostk \
match.ostk \
pp.ostk \
srfi-1.ostk \
......@@ -92,6 +93,7 @@ scheme_OBJS = date.ostk \
srfi-48.ostk \
srfi-60.ostk \
srfi-66.ostk \
srfi-69.ostk \
srfi-70.ostk \
trace.ostk
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 3-Feb-2006 16:32 (eg)
# Last file update: 7-Feb-2006 10:16 (eg)
SHELL = @SHELL@
srcdir = @srcdir@
......@@ -147,12 +147,12 @@ scheme_BOOT = assembler.stk \
scheme_SRCS = STklos.init \
bigloo.stk \
compfile.stk \
date.stk \
describe.stk \
expand.ss \
full-syntax.stk \
full-conditions.stk \
getopt.stk \
lalr.stk \
lex-rt.stk \
make-C-boot.stk \
match.stk \
......@@ -176,17 +176,18 @@ scheme_SRCS = STklos.init \
srfi-48.stk \
srfi-60.stk \
srfi-66.stk \
srfi-69.stk \
srfi-70.stk \
trace.stk
scheme_OBJS = date.ostk \
compfile.ostk \
scheme_OBJS = compfile.ostk \
full-syntax.ostk \
full-conditions.ostk \
describe.ostk \
getopt.ostk \
lex-rt.ostk \
lalr.ostk \
match.ostk \
pp.ostk \
srfi-1.ostk \
......@@ -207,6 +208,7 @@ scheme_OBJS = date.ostk \
srfi-48.ostk \
srfi-60.ostk \
srfi-66.ostk \
srfi-69.ostk \
srfi-70.ostk \
trace.ostk
......
......@@ -21,19 +21,65 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Jan-2006 22:56 (eg)
;;;; Last file update: 26-Jan-2006 23:03 (eg)
;;;; Last file update: 6-Feb-2006 13:32 (eg)
;;;;
(define (%thread-timeout->seconds timeout)
(cond
((time? timeout) timeout)
((not timeout) timeout)
((real? timeout) (+ (time->seconds (current-time))
timeout))
(else (error "bad timeout ~S" timeout))))
(define (make-thread thunk :optional (name (symbol->string (gensym "thread"))))
(define (thread-handler c)
(DEBUG "Erreur dans une thread. Type de cond ~S" c)
(describe c)
(%thread-end-exception-set! (current-thread) c)
c)
(%make-thread (lambda ()
(with-handler thread-handler
(thunk)))
name))
(define (thread-sleep! timeout)
(let* ((now (current-time))
(diff (- timeout now)))
(if (> diff 0)
(sleep (* diff 1000)))))
(let ((n (%thread-timeout->seconds timeout)))
(unless n
(error 'thread-sleep! "cannot used #f as timeout"))
(sleep (inexact->exact (round (* 1000 n))))))
(define (thread-join! thread :optional timeout (timeout-val #f timeout-val?))
(if (and (eq? thread (current-thread)) (not timeout))
(error 'thread-join! "cannot join on myself (deadlock will occur)")
(let ((join (%thread-join! thread
(%thread-timeout->seconds timeout))))
(cond
(join
;; We had a timeout
(if timeout-val?
timeout-val
(raise (make-condition &thead-join-timeout))))
((%thread-end-exception thread)
;; We had an exceptionin thread. Raise it
(raise (%thread-end-exception thread)))
(else
;; No exception. Return the thread-result
(%thread-end-result thread))))))
(define (mutex-lock! mtx :optional timeout (thread (current-thread)))
(let ((res (%mutex-lock! mtx (%thread-timeout->seconds timeout) thread)))
;; Different cases for res:
;; - The owning thread which is now terminated (a condition must be raised)
;; - #f: we had a timeout
;; - #t: otherwise
(if (thread? res)
(make-condition &thread-abandonned-mutex)
res)))
(let ((start (current-time))
(let loop ((x 1))
(thread-sleep! (seconds->time (+ x start)))
(write x)
(loop (+ x 1))))
\ No newline at end of file
(define (mutex-unlock! mtx :optional condv timeout)
(%mutex-unlock! mtx condv timeout))
/*
This file was automatically generated on Fri Feb 3 18:30:59 2006 by make-C-boot
This file was automatically generated on Tue Feb 7 17:58:18 2006 by make-C-boot
This is a dump of the image in file /mnt/users/eg/Projects/STklos/lib/boot.img3
***DO NOT EDIT BY HAND***
*/
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 1-Feb-2006 17:11 (eg)
* Last file update: 7-Feb-2006 18:24 (eg)
*
*/
......@@ -746,14 +746,9 @@ static SCM internal_format(int argc, SCM *argv, int error)
STk_error_bad_io_param("bad list for ~~? format ~S", args);
/* Do (apply format port fmt args) */
STk_C_apply(STk_lookup(STk_intern("apply"),
STk_current_module, &ref, TRUE),
4,
STk_lookup(STk_intern("format"),
STk_current_module, &ref, TRUE),
port,
fmt,
args);
STk_C_apply_list(STk_lookup(STk_intern("format"),
STk_current_module, &ref, TRUE),
STk_cons(port, STk_cons(fmt, args)));
break;
}
case 'H':
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 1-Feb-2006 17:13 (eg)
* Last file update: 7-Feb-2006 17:53 (eg)
*
*/
......@@ -740,13 +740,10 @@ static SCM read_srfi10(SCM port, SCM l)
tmp = STk_int_assq(CAR(l), ctor_table);
if (tmp == STk_false)
signal_error(port, "bad tag in a #,(...) form ~S", CAR(l));
else
else {
/* result is (apply (cdr tmp) (cdr l)) */
return STk_C_apply(STk_lookup(STk_intern("apply"),
STk_current_module, &ref, TRUE),
2,
CDR(tmp),
CDR (l));
return STk_C_apply_list(CDR(tmp), CDR (l));
}
return STk_void; /* For the C compiler */
}
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 3-Feb-2006 10:45 (eg)
* Last file update: 7-Feb-2006 16:07 (eg)
*/
#ifndef STKLOS_H
......@@ -1128,6 +1128,7 @@ int STk_init_vector(void);
void STk_execute_current_handler(SCM kind, SCM location, SCM message);
void STk_raise_exception(SCM cond);
SCM STk_C_apply(SCM func, int nargs, ...);
SCM STk_C_apply_list(SCM func, SCM l);
void STk_get_stack_pointer(void **addr);
SCM STk_n_values(int n, ...);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 2-Feb-2006 22:25 (eg)
* Last file update: 7-Feb-2006 18:27 (eg)
*/
// INLINER values
......@@ -426,6 +426,7 @@ DEFINE_PRIMITIVE("apply", scheme_apply, apply, (void))
/* This function is never called. It is just here to declare the primitive
* apply, as a primitive of type tc_apply
*/
STk_debug("CALL apply");
return STk_void;
}
......@@ -439,12 +440,11 @@ DEFINE_PRIMITIVE("apply", scheme_apply, apply, (void))
* an "excv" or an "execl" function. If nargs is > 0 it is as a Unix "execl"
* function:
* STk_C_apply(STk_cons, 2, MAKE_INT(1), MAKE_INT(2)) => (1 . 2)
* If nargs is < 0, we have something similar to an "execv fucntion
* If nargs is < 0, we have something similar to an "execv function
* STk_C_apply(...STk_intern("cons")..., -2, Argv)
* where Argv[0] == MAKE_INT(1) and Argv[1] == MAKE_INT(2) ==> (1 . 2)
*
\*===========================================================================*/
SCM STk_C_apply(SCM func, int nargs, ...)
{
static STk_instr code[]= {INVOKE, 0, END_OF_CODE};
......@@ -476,7 +476,23 @@ SCM STk_C_apply(SCM func, int nargs, ...)
FULL_RESTORE_VM_STATE(vm->sp);
return vm->val;
return (vm->valc) ? vm->val : STk_void;
}
/* Another way to call apply from C. This time with a Scheme list */
SCM STk_C_apply_list(SCM func, SCM l)
{
int i, argc = STk_int_length(l);
SCM *argv = NULL;
if (argc > 0) {
argv = STk_must_malloc(argc * sizeof (SCM *));
for (i = 0; i < argc; i++) {
argv[i] = CAR(l);
l = CDR(l);
}
}
return STk_C_apply(func, -argc, argv);
}
......@@ -864,7 +880,7 @@ CASE(LOCAL_SET1) { FRAME_LOCAL(vm->env, 1) = vm->val; NEXT0;}
CASE(LOCAL_SET2) { FRAME_LOCAL(vm->env, 2) = vm->val; NEXT0;}
CASE(LOCAL_SET3) { FRAME_LOCAL(vm->env, 3) = vm->val; NEXT0;}
CASE(LOCAL_SET4) { FRAME_LOCAL(vm->env, 4) = vm->val; NEXT0;}
CASE(LOCAL_SET) { FRAME_LOCAL(vm->env,fetch_next()) = vm->val; NEXT0; }
CASE(LOCAL_SET) { FRAME_LOCAL(vm->env,fetch_next()) = vm->val; NEXT0;}
CASE(DEEP_LOCAL_SET) {
int level, info = fetch_next();
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment