Commit 8589777a authored by Erick Gallesio's avatar Erick Gallesio

current-module is now thread specific

parent 1839ff0b
2006-04-05 Erick Gallesio <eg@essi.fr>
* lib/computils.stk (symbol-bound?): Use SYMBOL-VALUE* instead of
SYMBOL-VALUE. This avoids some undefined symbols warnings.
2006-03-22 Erick Gallesio <eg@essi.fr>
* lib/srfi-27.stk (%random-source-current-time): Change
......
;;;;
;;;; utils.stk -- Compiler Utilities
;;;;
;;;; Copyright 2000-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Mar-2001 13:57 (eg)
;;;; Last file update: 20-Nov-2004 19:34 (eg)
;;;; Last file update: 5-Apr-2006 10:14 (eg)
;;;;
......@@ -92,7 +92,7 @@
(define symbol-bound?
(let ((unbound (list 'unbound)))
(lambda (symbol)
(not (eq? (symbol-value symbol (current-module) unbound) unbound)))))
(not (eq? (symbol-value* symbol (current-module) unbound) unbound)))))
......
......@@ -2,7 +2,7 @@
*
* b o o l e a n . c -- Booleans and Equivalence predicates
*
* Copyright © 1993-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 1993-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -22,7 +22,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 23-Oct-1993 21:37
* Last file update: 12-May-2004 18:01 (eg)
* Last file update: 4-Apr-2006 18:44 (eg)
*/
#include "stklos.h"
......@@ -194,7 +194,8 @@ DEFINE_PRIMITIVE("eqv?", eqv, subr2, (SCM x, SCM y))
if (STk_oo_initialized) {
SCM fg, res;
fg = STk_lookup(STk_intern("object-eqv?"), STk_current_module, &res, FALSE);
fg = STk_lookup(STk_intern("object-eqv?"), STk_current_module(),
&res, FALSE);
res = STk_C_apply(fg, 2, x, y);
return res;
}
......@@ -323,7 +324,8 @@ DEFINE_PRIMITIVE("equal?", equal, subr2, (SCM x, SCM y))
if (STk_oo_initialized) {
SCM fg, res;
fg = STk_lookup(STk_intern("object-equal?"),STk_current_module,&res,FALSE);
fg = STk_lookup(STk_intern("object-equal?"),STk_current_module(),
&res,FALSE);
res = STk_C_apply(fg, 2, x, y);
return res;
}
......
This diff is collapsed.
This diff is collapsed.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 22-May-2004 08:57 (eg)
* Last file update: 1-Feb-2006 18:13 (eg)
* Last file update: 4-Apr-2006 20:07 (eg)
*/
#include "stklos.h"
......@@ -465,7 +465,7 @@ SCM STk_make_C_cond(SCM type, int nargs, ...)
int STk_init_cond(void)
{
SCM module = STk_current_module;
SCM module = STk_STklos_module;
/* Build the special value SRFI-35 &condition */
NEWCELL(root_condition, struct_type);
......
......@@ -2,7 +2,7 @@
*
* e n v . c -- Environment management
*
* Copyright 1993-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1993-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -22,11 +22,13 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 23-Oct-1993 21:37
* Last file update: 23-Aug-2005 08:28 (eg)
* Last file update: 4-Apr-2006 23:58 (eg)
*/
#include "stklos.h"
#include "hash.h"
#include "vm.h"
#include "thread.h"
static void error_bad_module_name(SCM obj)
......@@ -82,8 +84,7 @@ struct module_obj {
#define VISIBLE_P(symb, mod) (STk_memq((symb), MODULE_EXPORTS(mod))!=STk_false)
SCM STk_current_module; /* The current module */
static SCM stklos_module; /* The module whose name is STklos */
SCM STk_STklos_module; /* The module whose name is STklos */
static SCM all_modules; /* List of all knowm modules */
......@@ -102,7 +103,7 @@ static SCM STk_makemodule(SCM name)
NEWCELL(z, module);
MODULE_NAME(z) = name;
MODULE_EXPORTS(z) = STk_nil;
MODULE_IMPORTS(z) = (name == STk_void)? STk_nil : LIST1(stklos_module);
MODULE_IMPORTS(z) = (name == STk_void)? STk_nil : LIST1(STk_STklos_module);
/* Initialize the associated hash table & stor the module in the global list*/
STk_hashtable_init(&MODULE_HASH_TABLE(z), HASH_VAR_FLAG);
all_modules = STk_cons(z, all_modules);
......@@ -115,7 +116,7 @@ static SCM find_module(SCM name, int create)
SCM tmp;
if (name == STk_intern("STklos") || name == STk_intern("stklos"))
return stklos_module;
return STk_STklos_module;
for (tmp = all_modules; !NULLP(tmp); tmp = CDR(tmp)) {
if (MODULE_NAME(CAR(tmp)) == name)
......@@ -141,9 +142,10 @@ DEFINE_PRIMITIVE("%create-module", create_module, subr1, (SCM name))
DEFINE_PRIMITIVE("%select-module", select_module, subr1, (SCM module))
{
vm_thread_t *vm = STk_get_current_vm();
if (!MODULEP(module)) error_bad_module(module);
STk_current_module = module;
vm->current_module= module;
return STk_void;
}
......@@ -224,9 +226,14 @@ DEFINE_PRIMITIVE("find-module", scheme_find_module, subr12, (SCM name, SCM def))
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("current-module", scheme_current_module, subr0, (void))
DEFINE_PRIMITIVE("current-module", current_module, subr0, (void))
{
return STk_current_module;
if (STk_primordial_thread) {
vm_thread_t *vm = STk_get_current_vm();
return vm->current_module;
} else {
return STk_STklos_module;
}
}
......@@ -272,7 +279,7 @@ DEFINE_PRIMITIVE("module-exports", module_exports, subr1, (SCM module))
if (!MODULEP(module)) error_bad_module(module);
/* STklos module is special: everything is exported ==> module-symbols */
return (module == stklos_module) ?
return (module == STk_STklos_module) ?
STk_hash_keys(&MODULE_HASH_TABLE(module)) :
MODULE_EXPORTS(module);
}
......@@ -413,8 +420,8 @@ SCM STk_lookup(SCM symbol, SCM env, SCM *ref, int err_if_unbound)
/* Not found in the imported modules. Try in the stklos module (if we
* didn't had searched it yet
*/
if (env != stklos_module) {
res = STk_hash_get_variable(&MODULE_HASH_TABLE(stklos_module), symbol, &i);
if (env != STk_STklos_module) {
res = STk_hash_get_variable(&MODULE_HASH_TABLE(STk_STklos_module), symbol, &i);
if (res) {
*ref = res;
return CDR(res);
......@@ -456,8 +463,7 @@ int STk_init_env(void)
all_modules = STk_nil;
/* Create the stklos module */
stklos_module = STk_makemodule(STk_void); /* will be changed later */
STk_current_module = stklos_module;
STk_STklos_module = STk_makemodule(STk_void); /* will be changed later */
/* Declare the extended types module_obj and frame_obj */
DEFINE_XTYPE(module, &xtype_module);
......@@ -468,7 +474,7 @@ int STk_init_env(void)
int STk_late_init_env(void)
{
/* Now that symbols are initialized change the STklos module name */
MODULE_NAME(stklos_module) = STk_intern("stklos");
MODULE_NAME(STk_STklos_module) = STk_intern("stklos");
/* ==== Undocumented primitives ==== */
ADD_PRIMITIVE(create_module);
......@@ -479,7 +485,7 @@ int STk_late_init_env(void)
/* ==== User primitives ==== */
ADD_PRIMITIVE(modulep);
ADD_PRIMITIVE(scheme_find_module);
ADD_PRIMITIVE(scheme_current_module);
ADD_PRIMITIVE(current_module);
ADD_PRIMITIVE(module_name);
ADD_PRIMITIVE(module_imports);
ADD_PRIMITIVE(module_exports);
......@@ -492,4 +498,3 @@ int STk_late_init_env(void)
return TRUE;
}
/*
* f p o r t . c -- File ports
*
* Copyright 2000-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 8-Jan-2000 14:48 (eg)
* Last file update: 13-Sep-2005 22:41 (eg)
* Last file update: 4-Apr-2006 18:59 (eg)
*
* This implementation is built by reverse engineering on an old SUNOS 4.1.1
* stdio.h. It has been simplified to fit the needs for STklos. In particular
......@@ -752,7 +752,7 @@ SCM STk_load_source_file(SCM f)
*/
sexpr = STk_read_constant(f, STk_read_case_sensitive);
if (sexpr == STk_eof) break;
eval = STk_lookup(eval_symb, STk_current_module, &ref, TRUE);
eval = STk_lookup(eval_symb, STk_current_module(), &ref, TRUE);
STk_C_apply(eval, 1, sexpr);
}
STk_close_port(f);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 5-Jan-2000 12:17 (eg)
* Last file update: 2-Feb-2006 22:25 (eg)
* Last file update: 4-Apr-2006 23:52 (eg)
*/
......
/*
* m i s c . c -- Misc. functions
*
* Copyright © 2000-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 9-Jan-2000 12:50 (eg)
* Last file update: 25-Apr-2005 17:14 (eg)
* Last file update: 4-Apr-2006 19:00 (eg)
*/
#include "stklos.h"
......@@ -55,7 +55,7 @@ void STk_add_primitive(struct primitive_obj *o)
SCM symbol;
symbol = STk_intern(o->name);
STk_define_variable(symbol, (SCM) o, STk_current_module);
STk_define_variable(symbol, (SCM) o, STk_current_module());
}
......@@ -484,8 +484,8 @@ DEFINE_PRIMITIVE("%debug", set_debug, subr0, (void))
DEFINE_PRIMITIVE("%test", test, subr1, (SCM s))
{
/* A special place for doing tests */
STk_eval_C_string("(display \"Hello, world!\")", STk_current_module);
STk_eval_C_string("(display (fact 200))", STk_current_module);
STk_eval_C_string("(display \"Hello, world!\")", STk_current_module());
STk_eval_C_string("(display (fact 200))", STk_current_module());
return STk_void;
}
#endif
......
......@@ -2,7 +2,7 @@
*
* o b j e c t . c -- Objects support
*
* Copyright 1994-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1994-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 9-Feb-1994 15:56
* Last file update: 25-Apr-2005 17:06 (eg)
* Last file update: 4-Apr-2006 20:10 (eg)
*/
#include "stklos.h"
......@@ -29,7 +29,7 @@
#include "struct.h"
#define GF_VAL(name) (STk_lookup(STk_intern(name), \
STk_current_module, &unused, FALSE))
STk_current_module(), &unused, FALSE))
#define CALL_GF1(name,a) (STk_C_apply(GF_VAL(name), 1, (a)))
#define CALL_GF2(name,a,b) (STk_C_apply(GF_VAL(name), 2, (a), (b)))
#define CALL_GF3(name,a,b,c) (STk_C_apply(GF_VAL(name), 3, (a), (b), (c)))
......@@ -812,6 +812,7 @@ static void create_Top_Object_Class(void)
STk_cons(STk_intern("getters-n-setters"),
STk_cons(STk_intern("redefined"),
STk_nil))))))))));
SCM current_module = STk_STklos_module;
/* ========== Creation of the <Class> class ========== */
......@@ -833,21 +834,21 @@ static void create_Top_Object_Class(void)
INST_SLOT(Class, S_getters_n_setters) = INST_ACCESSORS(Class);
INST_SLOT(Class, S_redefined) = STk_false;
STk_define_variable(tmp, Class, STk_current_module);
STk_define_variable(tmp, Class, current_module);
/* ========== Creation of the <Top> class ========== */
tmp = STk_intern("<top>");
Top = basic_make_class(Class, tmp, STk_nil, STk_nil);
STk_define_variable(tmp, Top, STk_current_module);
STk_define_variable(tmp, Top, current_module);
/* ========== Creation of the <Object> class ========== */
tmp = STk_intern("<object>");
Object = basic_make_class(Class, tmp, LIST1(Top), STk_nil);
STk_define_variable(tmp, Object, STk_current_module);
STk_define_variable(tmp, Object, current_module);
/*
* <top> <object> and <class> were partially initialized.
......@@ -864,7 +865,7 @@ static void mk_cls(SCM *var, char *name, SCM meta, SCM super, SCM slots)
SCM tmp = STk_intern(name);
*var = basic_make_class(meta, tmp, LIST1(super), slots);
STk_define_variable(tmp, *var, STk_current_module);
STk_define_variable(tmp, *var, STk_STklos_module);
}
static void make_standard_classes(void)
......@@ -1088,7 +1089,7 @@ static void print_instance(SCM inst, SCM port, int mode)
SCM fct, res;
fct_name = (mode == DSP_MODE) ? "display-object" : "write-object";
fct = STk_lookup(STk_intern(fct_name), STk_current_module, &res, FALSE);
fct = STk_lookup(STk_intern(fct_name), STk_current_module(), &res, FALSE);
if (fct == STk_void) {
/* Do a default print */
......
/*
* parameter.c -- Parameter Objects (SRFI-39)
*
* Copyright © 2003-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 2003-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 1-Jul-2003 11:38 (eg)
* Last file update: 26-Dec-2005 19:05 (eg)
* Last file update: 4-Apr-2006 19:02 (eg)
*/
......@@ -92,7 +92,7 @@ SCM STk_make_C_parameter(SCM symbol, SCM value, SCM (*proc)(SCM new_value))
PARAMETER_C_TYPE(z) = 1;
/* Bind it to the given symbol */
STk_define_variable(STk_intern(symbol), z, STk_current_module);
STk_define_variable(STk_intern(symbol), z, STk_current_module());
return z;
}
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 7-Feb-2006 18:24 (eg)
* Last file update: 4-Apr-2006 19:07 (eg)
*
*/
......@@ -674,7 +674,7 @@ static SCM internal_format(int argc, SCM *argv, int error)
if (argc-- <= 0) goto TooMuch;
pp = STk_lookup(STk_intern("pp"),
STk_current_module,
STk_current_module(),
&ref,
TRUE);
STk_print(STk_C_apply(pp, 3, *argv--,
......@@ -714,7 +714,7 @@ static SCM internal_format(int argc, SCM *argv, int error)
* Call the Scheme routine srfi48:format-fixed
*/
ff = STk_lookup(STk_intern("srfi48:format-fixed"),
STk_current_module,
STk_current_module(),
&ref,
TRUE);
tmp = STk_C_apply(ff, 3,
......@@ -747,7 +747,7 @@ static SCM internal_format(int argc, SCM *argv, int error)
/* Do (apply format port fmt args) */
STk_C_apply_list(STk_lookup(STk_intern("format"),
STk_current_module, &ref, TRUE),
STk_current_module(), &ref, TRUE),
STk_cons(port, STk_cons(fmt, args)));
break;
}
......@@ -756,7 +756,7 @@ static SCM internal_format(int argc, SCM *argv, int error)
SCM ref, help;
help = STk_lookup(STk_intern("srfi48:help"),
STk_current_module,
STk_current_module(),
&ref,
TRUE);
STk_C_apply(help, 1, port);
......@@ -1284,7 +1284,7 @@ DEFINE_PRIMITIVE("port-rewind", port_rewind, subr1, (SCM port))
\*===========================================================================*/
static void initialize_io_conditions(void)
{
SCM module = STk_current_module;
SCM module = STk_STklos_module;
#define DEFCOND(x, name, parent, slots) \
x = STk_defcond_type(name, parent, slots, module)
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 7-Feb-2006 17:53 (eg)
* Last file update: 4-Apr-2006 19:31 (eg)
*
*/
......@@ -42,7 +42,7 @@ int STk_read_case_sensitive = 0;
#define PLACEHOLDERP(x) (CONSP(x) && (BOXED_INFO(x) & CONS_PLACEHOLDER))
#define PLACEHOLDER_VAL(x) (CDR(x))
#define SYMBOL_VALUE(x,ref) STk_lookup((x), STk_current_module, &(ref), FALSE)
#define SYMBOL_VALUE(x,ref) STk_lookup((x), STk_current_module(), &(ref), FALSE)
/*===========================================================================*\
*
......@@ -732,7 +732,7 @@ DEFINE_PRIMITIVE("define-reader-ctor",reader_ctor, subr2, (SCM symbol, SCM proc)
static SCM read_srfi10(SCM port, SCM l)
{
int len = STk_int_length(l);
SCM tmp, ref;
SCM tmp;
if (len < 0)
signal_error(port, "bad list in a #,(...) form ~S", l);
......@@ -804,7 +804,7 @@ int STk_init_reader(void)
STk_intern("column"),
STk_intern("position"),
STk_intern("span")),
STk_current_module);
STk_STklos_module);
/* Declare SRFI-10 support function */
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 21:19 (eg)
* Last file update: 1-Feb-2006 13:41 (eg)
* Last file update: 4-Apr-2006 19:26 (eg)
*/
#include <stklos.h>
......@@ -134,7 +134,8 @@ static void build_scheme_args(int argc, char *argv[], char *argv0)
ADD_BOOL_OPTION(vanilla, ":no-init-file");
ADD_BOOL_OPTION(STk_interactive, ":interactive")
STk_define_variable(STk_intern("*%program-args*"), options, STk_current_module);
STk_define_variable(STk_intern("*%program-args*"), options,
STk_STklos_module);
}
int main(int argc, char *argv[])
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 7-Feb-2006 16:07 (eg)
* Last file update: 4-Apr-2006 19:23 (eg)
*/
#ifndef STKLOS_H
......@@ -378,8 +378,6 @@ struct frame_obj {
/* modules are defined in env.c but are private */
#define MODULEP(p) (BOXED_TYPE_EQ((p), tc_module))
extern SCM STk_current_module;
SCM STk_make_frame(int len);
SCM STk_clone_frame(SCM f);
......@@ -390,7 +388,11 @@ void STk_define_variable(SCM symbol, SCM value, SCM module);
int STk_init_env(void);
int STk_late_init_env(void); /* must be done after symbol initialization */
extern SCM STk_STklos_module;
EXTERN_PRIMITIVE("%create-module", create_module, subr1, (SCM name))
EXTERN_PRIMITIVE("current-module", current_module, subr0, (void))
EXTERN_PRIMITIVE("%select-module", select_module, subr1, (SCM module))
/*
------------------------------------------------------------------------------
......
......@@ -16,7 +16,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 29-Mar-1994 10:57
* Last file update: 3-Feb-2006 17:12 (eg)
* Last file update: 4-Apr-2006 19:26 (eg)
*/
#include <unistd.h>
......@@ -1027,6 +1027,8 @@ DEFINE_PRIMITIVE("%chmod", change_mode, subr2, (SCM file, SCM value))
int STk_init_system(void)
{
SCM current_module = STk_STklos_module;
/* Create the system-date structure-type */
date_type = STk_make_struct_type(STk_intern("%date"),
STk_false,
......@@ -1040,14 +1042,14 @@ int STk_init_system(void)
STk_intern("year-day"),
STk_intern("dst"),
STk_intern("tz")));
STk_define_variable(STk_intern("%date"), date_type, STk_current_module);
STk_define_variable(STk_intern("%date"), date_type, current_module);
/* Create the time structure-type */
time_type = STk_make_struct_type(STk_intern("%time"),
STk_false,
LIST2(STk_intern("second"),
STk_intern("microsecond")));
STk_define_variable(STk_intern("%time"), time_type, STk_current_module);
STk_define_variable(STk_intern("%time"), time_type, current_module);
/* Declare primitives */
ADD_PRIMITIVE(clock);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg)
* Last file update: 5-Feb-2006 21:52 (eg)
* Last file update: 4-Apr-2006 23:58 (eg)
*/
......@@ -33,7 +33,7 @@
#include "vm.h"
#include "thread.h"
static SCM primordial;
SCM STk_primordial_thread = NULL;
static SCM cond_thread_terminated, cond_join_timeout, cond_thread_abandonned_mutex;
static SCM all_threads = STk_nil;
......@@ -345,6 +345,7 @@ static struct extended_type_descr xtype_thread = {
int STk_init_threads(int stack_size)
{
vm_thread_t *vm = STk_allocate_vm(stack_size);
SCM primordial;
/* Thread Type declaration */
DEFINE_XTYPE(thread, &xtype_thread);
......@@ -356,19 +357,20 @@ int STk_init_threads(int stack_size)
/* Define the threads exceptions */
cond_thread_terminated = STk_defcond_type("&thread-terminated", STk_false,
LIST1(STk_intern("canceller")),
STk_current_module);
STk_STklos_module);
cond_thread_abandonned_mutex = STk_defcond_type("&thread-abandonned-mutex",
STk_false,
STk_nil,
STk_current_module);
STk_STklos_module);
cond_join_timeout = STk_defcond_type("&thead-join-timeout", STk_false,
STk_nil, STk_current_module);
STk_nil, STk_STklos_module);
/* Wrap the main thread in a thread called "primordial" */
primordial = do_make_thread(STk_false, STk_Cstring2string("primordial"));
THREAD_STATE(primordial) = th_runnable;
THREAD_VM(primordial) = vm;
vm->scheme_thread = primordial;
STk_primordial_thread = primordial;
/* Thread primitives */
ADD_PRIMITIVE(current_thread);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 4-Feb-2006 11:03 (eg)
* Last file update: 4-Feb-2006 11:04 (eg)
* Last file update: 4-Apr-2006 23:55 (eg)
*/
//FIX:
......@@ -53,8 +53,11 @@ struct thread_obj {
#define THREAD_SPECIFIC(p) (((struct thread_obj *) (p))->specific)
#define THREAD_RESULT(p) (((struct thread_obj *) (p))->end_result)
#define THREAD_EXCEPTION(p) (((struct thread_obj *) (p))->end_exception)
#define THREAD_CURMOD(p) (((struct thread_obj *) (p))->current_module)
#define THREAD_STATE(p) (((struct thread_obj *) (p))->state)
#define THREAD_VM(p) (((struct thread_obj *) (p))->vm)
#define THREAD_PTHREAD(p) (((struct thread_obj *) (p))->pthread)
#define THREAD_MYMUTEX(p) (((struct thread_obj *) (p))->mymutex)
#define THREAD_MYCONDV(p) (((struct thread_obj *) (p))->mycondv)
extern SCM STk_primordial_thread;
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 7-Feb-2006 18:27 (eg)
* Last file update: 4-Apr-2006 19:32 (eg)
*/
// INLINER values
......@@ -131,13 +131,14 @@ vm_thread_t *STk_allocate_vm(int stack_size)
}
/* Initialize the VM registers */
vm->sp = vm->stack + vm->stack_len;
vm->fp = vm->sp;
vm->val = STk_void;
vm->env = STk_current_module;
vm->handlers = NULL;
vm->top_jmp_buf = NULL;
vm->scheme_thread = STk_false;
vm->sp = vm->stack + vm->stack_len;
vm->fp = vm->sp;
vm->val = STk_void;
vm->current_module = STk_current_module();
vm->env = vm->current_module;
vm->handlers = NULL;
vm->top_jmp_buf = NULL;
vm->scheme_thread = STk_false;
return vm;
}
......@@ -502,7 +503,7 @@ DEFINE_PRIMITIVE("%execute", execute, subr23, (SCM code, SCM consts, SCM envt))
STk_instr *vinstr, *p;
vm_thread_t *vm = STk_get_current_vm();
if (!envt) envt = STk_current_module;
if (!envt) envt = vm->current_module;
if (!VECTORP(code)) STk_error("bad code vector ~S", code);
if (!VECTORP(consts)) STk_error("bad constant list ~S", consts);
......@@ -954,8 +955,8 @@ CASE(DEFINE_SYMBOL) {
CASE(SET_CUR_MOD) {
if (!MODULEP(vm->val)) STk_error("bad module ~S", vm->val);
STk_current_module = vm->env = vm->val;
vm->env = vm->val;
STk_select_module(vm->val);
NEXT0;
}
......@@ -1089,7 +1090,7 @@ CASE(MAKE_EXPANDER) {
SCM name = fetch_const();
SCM ref;
STk_lookup(STk_intern("*expander-list*"), STk_current_module, &ref, TRUE);
STk_lookup(STk_intern("*expander-list*"), STk_current_module(), &ref, TRUE);
CDR(ref) = STk_cons(STk_cons(name, vm->val), CDR(ref));
vm->valc = 2;
vm->val = STk_void;
......@@ -1220,7 +1221,7 @@ FUNCALL: /* (int nargs, int tailp) */
args = listify_top(nargs, vm);
push(vm->val);
push(args);
vm->val = STk_lookup(STk_intern("apply-generic"), STk_current_module,
vm->val = STk_lookup(STk_intern("apply-generic"), vm->current_module,
&gf, FALSE);
nargs = 2;
goto FUNCALL;
......@@ -1284,7 +1285,7 @@ FUNCALL: /* (int nargs, int tailp) */
push(NXT_MTHD_METHOD(vm->val));
push(argv);
nargs = 3;
vm->val = STk_lookup(STk_intern("no-next-method"), STk_current_module,
vm->val = STk_lookup(STk_intern("no-next-method"), vm->current_module,
&proc, FALSE);
} else {
/* Call the next method after creating a new next-method */
......@@ -1683,7 +1684,7 @@ SCM STk_load_bcode_file(SCM f)
vm->pc = read_code(f, size); /* Read the code */
vm->constants = VECTOR_DATA(consts);
vm->env = STk_current_module;
vm->env = vm->current_module;
run_vm(vm);
}
......@@ -1725,7 +1726,7 @@ int STk_boot_from_C(void)
/* Run the VM */
vm->pc = STk_boot_code;
vm->constants = VECTOR_DATA(consts);
vm->env = STk_current_module;
vm->env = vm->current_module;
run_vm(vm);
system_has_booted = 1;
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 26-Jan-2006 20:20 (eg)
* Last file update: 4-Apr-2006 19:29 (eg)
*/
......@@ -100,6 +100,7 @@ typedef struct {
SCM *stack;
int stack_len;
SCM current_module;
SCM scheme_thread; /* Scheme associated thread */
} vm_thread_t;
......
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