[Tinyos-commits]
CVS: tinyos-1.x/tos/lib/VM/languages/motlle/standalone
scheme.c, NONE, 1.1 scheme.h, NONE, 1.1 scheme.txt, NONE,
1.1 scompile.c, NONE, 1.1 scompile.h, NONE, 1.1 Makefile.am,
1.3, 1.4 compile.c, 1.2, 1.3 compile.h, 1.2, 1.3 global.c, 1.2,
1.3 global.h, 1.2, 1.3 lexer.l, 1.2, 1.3 module.c, 1.2,
1.3 mparser.c, 1.2, 1.3 parser.y, 1.2, 1.3 table.c, 1.2,
1.3 table.h, 1.2, 1.3 tokens.h, 1.2, 1.3 tree.c, 1.2,
1.3 tree.h, 1.2, 1.3
David Gay
idgay at users.sourceforge.net
Thu Oct 6 16:38:03 PDT 2005
- Next message: [Tinyos-commits]
CVS: tinyos-1.x/tos/lib/VM/languages/motlle/standalone
compile.c, 1.3, 1.4 env.c, 1.2, 1.3 env.h, 1.2, 1.3 lexer.h,
1.2, 1.3 lexer.l, 1.3, 1.4 mparser.c, 1.3, 1.4 parser.y, 1.3,
1.4 scheme.c, 1.1, 1.2
- Messages sorted by:
[ date ]
[ thread ]
[ subject ]
[ author ]
Update of /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23431
Modified Files:
Makefile.am compile.c compile.h global.c global.h lexer.l
module.c mparser.c parser.y table.c table.h tokens.h tree.c
tree.h
Added Files:
scheme.c scheme.h scheme.txt scompile.c scompile.h
Log Message:
tinyscheme time
--- NEW FILE: scheme.c ---
#include "mudlle.h"
#include "ins.h"
#include "code.h"
#include "scompile.h"
#include "compile.h"
#include "lexer.h"
#include "env.h"
#include "mcompile.h"
#include "scheme.h"
#include <string.h>
static void ins_undefined(fncode fn)
{
ins_constant(makeint(42), fn);
}
static int list_length(value v)
{
int len = 0;
for (; TYPE(v, type_pair); v = ((struct list *)v)->cdr)
len++;
if (v)
return -len - 1;
else
return len;
}
static value nth(struct list *l, int n)
{
while (--n)
l = l->cdr;
return l->car;
}
static const char *sym2str(block_t region, value sym)
{
struct symbol *s = sym;
return bstrdup(region, s->name->str);
}
static vlist sym2vlist(block_t region, value sym)
{
return new_vlist(region, sym2str(region, sym), stype_any, NULL, NULL);
}
static struct {
const char *name;
int nargs;
int builtin;
} builtins[] = {
{ "+", 2, b_add },
};
static int lookup_builtin(const char *name, int nargs)
{
int i;
for (i = 0; i < sizeof builtins / sizeof *builtins; i++)
if (nargs == builtins[i].nargs &&
!strcmp(name, builtins[i].name))
return builtins[i].builtin;
return last_builtin;
}
static int is_builtin_call(value v, fncode fn)
{
if (TYPE(v, type_pair))
{
struct list *call = v;
if (TYPE(call->car, type_symbol))
{
struct symbol *called = call->car;
return lookup_builtin(called->name->str, list_length(call->cdr));
}
}
return last_builtin;
}
static void compile_args(location l, struct list *args, fncode fn)
{
GCPRO1(args);
while (args)
{
scheme_compile(l, args->car, FALSE, fn);
args = args->cdr;
}
GCPOP(1);
}
typedef void (*gencode)(location l, void *data, fncode fn);
void sgen_condition(location l, value condition,
label slab, gencode scode, void *sdata,
label flab, gencode fcode, void *fdata,
fncode fn)
{
int builtin = is_builtin_call(condition, fn);
switch (builtin)
{
case b_not:
/* Just swap conclusions */
sgen_condition(l, nth(condition, 2),
flab, fcode, fdata, slab, scode, sdata, fn);
break;
default:
scheme_compile(l, condition, FALSE, fn);
if (scode)
{
branch(OPmbf3, flab, fn);
scode(l, sdata, fn);
if (fcode)
fcode(l, fdata, fn);
}
else
{
branch(OPmbt3, slab, fn);
if (fcode)
fcode(l, fdata, fn);
else
branch(OPmba3, flab, fn);
}
break;
}
}
struct ifdata
{
label slab, flab, endlab;
value success, failure;
bool discard;
};
static void ifs_code(location l, void *_data, fncode fn)
{
struct ifdata *data = _data;
set_label(data->slab, fn);
scheme_compile(l, data->success, data->discard, fn);
branch(OPmba3, data->endlab, fn);
if (!data->discard)
adjust_depth(-1, fn);
}
static void iff_code(location l, void *_data, fncode fn)
{
struct ifdata *data = _data;
set_label(data->flab, fn);
scheme_compile(l, data->failure, data->discard, fn);
branch(OPmba3, data->endlab, fn);
if (!data->discard)
adjust_depth(-1, fn);
}
void sgen_if(location l, value condition, value success, value failure,
bool discard, fncode fn)
{
struct ifdata ifdata;
ifdata.slab = new_label(fn);
ifdata.flab = new_label(fn);
ifdata.endlab = new_label(fn);
ifdata.success = success;
ifdata.failure = failure;
ifdata.discard = discard;
GCPRO2(ifdata.success, ifdata.failure);
if (failure)
sgen_condition(l, condition, ifdata.slab, ifs_code, &ifdata,
ifdata.flab, iff_code, &ifdata, fn);
else
sgen_condition(l, condition, ifdata.slab, ifs_code, &ifdata,
ifdata.endlab, NULL, NULL, fn);
set_label(ifdata.endlab, fn);
if (!discard)
adjust_depth(1, fn);
GCPOP(2);
}
static void compile_quote(location l, struct list *args, bool discard, fncode fn)
{
if (!discard)
ins_constant(args->car, fn);
}
void compile_begin(location l, struct list *blk, bool discard, fncode fn)
{
GCPRO1(blk);
for (; blk; blk = blk->cdr)
scheme_compile(l, blk->car, blk->cdr || discard, fn);
GCPOP(1);
}
static void sgen_function(location l, struct string *varname, value formals,
value body, bool discard, fncode fn)
{
struct code *c;
struct string *help, *afilename;
fncode newfn;
vlist fnargs;
u16 clen;
i8 nargs;
u8 nb_locals, *cvars;
varlist closure, cvar;
block_t region = fnmemory(fn);
if (discard)
return;
GCPRO2(varname, formals);
GCPRO1(body);
help = NULL;
GCPRO1(help);
/* Make filename string */
afilename = make_filename(l.filename);
GCPRO1(afilename);
nargs = list_length(formals);
if (nargs < -1) /* we don't support (arg1 ... argn . argrest) */
{
log_error(l, "(x1 ... xn . rest) parameter syntax not supported");
nargs = 0;
fnargs = NULL;
}
else if (nargs == -1)
{
if (!TYPE(formals, type_symbol))
log_error(l, "symbol expected");
else
fnargs = sym2vlist(region, formals);
}
else
{
struct list *actual_args;
vlist *nextarg = &fnargs;
fnargs = NULL;
for (actual_args = formals; actual_args; actual_args = actual_args->cdr)
if (!TYPE(actual_args->car, type_symbol))
log_error(l, "function parameters must be symbols");
else
{
*nextarg = sym2vlist(region, actual_args->car);
nextarg = &(*nextarg)->next;
}
}
newfn = new_fncode(fnglobals(fn), l, FALSE, nargs);
/* Generate code of function */
env_push(fnargs, newfn);
start_block("<return>", FALSE, FALSE, newfn);
compile_begin(l, body, FALSE, newfn);
end_block(newfn);
ins0(OPmreturn, newfn);
closure = env_pop(&nb_locals);
c = generate_fncode(newfn, nb_locals, help, varname, afilename, l.lineno);
/* Generate code for creating closure */
/* Count length of closure */
clen = 0;
for (cvar = closure; cvar; cvar = cvar->next) clen++;
/* Generate closure */
cvars = ins_closure(c, clen, fn);
/* Add variables to it */
for (cvar = closure; cvar; cvar = cvar->next)
*cvars++ = (cvar->offset << 1) + cvar->vclass;
delete_fncode(newfn);
GCPOP(5);
}
static void compile_lambda(location l, struct list *lambda_args, bool discard, fncode fn)
{
sgen_function(l, NULL, lambda_args->car, lambda_args->cdr, discard, fn);
}
static void compile_if(location l, struct list *args, bool discard, fncode fn)
{
value cond, true;
cond = args->car;
args = args->cdr;
true = args->car;
args = args->cdr;
if (args)
sgen_if(l, cond, true, args->car, discard, fn);
else
{
sgen_if(l, cond, true, NULL, TRUE, fn);
if (!discard)
ins_undefined(fn);
}
}
static void sgen_assign(location l, const char *name, bool discard, fncode fn)
{
u16 offset;
mtype t;
variable_class vclass = env_lookup(l, name, &offset, &t, FALSE);
if (vclass == global_var)
massign(l, offset, name, fn);
else if (vclass == closure_var)
ins1(OPmwritec, offset, fn);
else
ins1(OPmwritel, offset, fn);
if (discard)
ins0(OPmpop, fn);
}
static void compile_setb(location l, struct list *args, bool discard, fncode fn)
{
GCPRO1(args);
scheme_compile(l, nth(args, 2), FALSE, fn);
GCPOP(1);
if (!TYPE(args->car, type_symbol))
{
log_error(l, "must assign a symbol");
return;
}
sgen_assign(l, sym2str(fnmemory(fn), args->car), discard, fn);
}
static void compile_define(location l, struct list *args, bool discard, fncode fn)
{
vlist vfn = NULL;
if (TYPE(args->car, type_symbol))
{
vfn = sym2vlist(fnmemory(fn), args->car);
env_declare(vfn, fntoplevel(fn), in_loop(fn));
scheme_compile(l, nth(args, 2), FALSE, fn);
}
else if (TYPE(args->car, type_pair))
{
struct list *fndecl = args->car;
if (TYPE(fndecl->car, type_symbol))
{
struct symbol *name = fndecl->car;
vfn = sym2vlist(fnmemory(fn), name);
env_declare(vfn, fntoplevel(fn), in_loop(fn));
sgen_function(l, name->name, fndecl->cdr, args->cdr, FALSE, fn);
}
}
if (!vfn)
log_error(l, "invalid define syntax");
else
sgen_assign(l, vfn->var, discard, fn);
}
static void compile_let(location l, struct list *args, bool discard, fncode fn)
{
struct list *bindings;
int error = FALSE;
/* Recast as recursive functioin. currently broken. */
for (bindings = args->car; TYPE(bindings, type_pair); bindings = bindings->cdr)
if (check_binding(l, bindings, &error))
sgen_binding_init(l, bindings);
if (bindings)
log_error(l, "invalid bindings");
if (!error)
for (bindings = args->car; TYPE(bindings, type_pair); bindings = bindings->cdr)
{
sgen_binding_decl(l, bindings);
sgen_binding_assign(l, bindings);
}
}
static struct {
const char *keyword;
int nargs;
void (*compile)(location l, struct list *args, bool discard, fncode fn);
int maxargs;
} syntax[] = {
{ "quote", 1, compile_quote },
{ "lambda", -2, compile_lambda },
{ "begin", -1, compile_begin },
{ "if", -2, compile_if, 3 },
{ "set!", 2, compile_setb },
{ "define", -1, compile_define },
{ "let", -2, compile_let },
};
static void compile_list(location l, struct list *list, bool discard, fncode fn)
{
int nargs = list_length(list->cdr);
if (nargs < 0)
{
log_error(l, "improper list");
return;
}
if (TYPE(list->car, type_symbol))
{
struct string *symname = ((struct symbol *)list->car)->name;
int i;
for (i = 0; i < sizeof syntax / sizeof *syntax; i++)
if (!strcmp(symname->str, syntax[i].keyword))
{
if (syntax[i].nargs > 0)
{
if (nargs != syntax[i].nargs)
{
log_error(l, "%s expected %d arguments",
syntax[i].keyword, syntax[i].nargs);
break;
}
}
else if (syntax[i].nargs < 0)
{
if (nargs < -syntax[i].nargs)
{
log_error(l, "%s expected at least %d arguments",
syntax[i].keyword, -syntax[i].nargs);
break;
}
if (syntax[i].maxargs && nargs > syntax[i].maxargs)
{
log_error(l, "%s expected at most %d arguments",
syntax[i].keyword, syntax[i].maxargs);
break;
}
}
syntax[i].compile(l, list->cdr, discard, fn);
return;
}
}
/* Annoyingly, small changes make this code hard to share with
generate_execute */
if (nargs >= 16)
log_error(l, "no more than 15 arguments allowed");
GCPRO1(list);
compile_args(l, list->cdr, fn);
GCPOP(1);
/* Optimise main case: calling a given global function. Also
support implicit function declaration. */
if (TYPE(list->car, type_symbol))
{
const char *name = sym2str(fnmemory(fn), list->car);
u16 offset;
mtype t;
variable_class vclass = env_lookup(l, name, &offset, &t, TRUE);
if (vclass == global_var)
{
int builtin = lookup_builtin(name, nargs);
if (builtin != last_builtin)
ins0(builtin_ops[builtin], fn);
else
mexecute(l, offset, name, nargs, fn);
return;
}
}
scheme_compile(l, list->car, FALSE, fn);
ins0(OPmexec4 + (nargs & 0xf), fn);
if (discard)
ins0(OPmpop, fn);
}
void scheme_compile(location l, value v, bool discard, fncode fn) /* MAYGC */
{
if (INTEGERP(v))
{
if (!discard)
ins_constant(v, fn);
return;
}
else if (POINTERP(v))
{
switch (OBJTYPE(v))
{
case type_string:
if (!discard)
ins_constant(v, fn);
return;
case type_pair:
compile_list(l, v, discard, fn);
return;
case type_symbol:
if (!discard)
scompile_recall(l, sym2str(fnmemory(fn), v), fn);
return;
}
}
log_error(l, "invalid scheme expression");
}
--- NEW FILE: scheme.h ---
/*
* Copyright (c) 1993-1999 David Gay and Gustav Hållberg
* All rights reserved.
*
* Permission to use, copy, modify, and distribute this software for any
* purpose, without fee, and without written agreement is hereby granted,
* provided that the above copyright notice and the following two paragraphs
* appear in all copies of this software.
*
* IN NO EVENT SHALL DAVID GAY OR GUSTAV HALLBERG BE LIABLE TO ANY PARTY FOR
* DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
* OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF DAVID GAY OR
* GUSTAV HALLBERG HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* DAVID GAY AND GUSTAV HALLBERG SPECIFICALLY DISCLAIM ANY WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
* FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN
* "AS IS" BASIS, AND DAVID GAY AND GUSTAV HALLBERG HAVE NO OBLIGATION TO
* PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
*/
#ifndef SCHEME_H
#define SCHEME_H
#include "ins.h"
void scheme_compile(location l, value v, bool discard, fncode fn);
#endif
--- NEW FILE: scheme.txt ---
missing:
(lambda (x1 x2 . rest) ...)
changes:
(lambda allargs ...)
makes allargs a vector, not a list
(if cond truecase)
returns an undefined result even when truecase is executed
--- NEW FILE: scompile.c ---
/*
* Copyright (c) 1993-1999 David Gay and Gustav Hållberg
* All rights reserved.
*
* Permission to use, copy, modify, and distribute this software for any
* purpose, without fee, and without written agreement is hereby granted,
* provided that the above copyright notice and the following two paragraphs
* appear in all copies of this software.
*
* IN NO EVENT SHALL DAVID GAY OR GUSTAV HALLBERG BE LIABLE TO ANY PARTY FOR
* DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
* OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF DAVID GAY OR
* GUSTAV HALLBERG HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* DAVID GAY AND GUSTAV HALLBERG SPECIFICALLY DISCLAIM ANY WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
* FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN
* "AS IS" BASIS, AND DAVID GAY AND GUSTAV HALLBERG HAVE NO OBLIGATION TO
* PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
*/
#include "mudlle.h"
#include "tree.h"
#include "alloc.h"
#include "types.h"
#include "code.h"
#include "ins.h"
#include "env.h"
#include "global.h"
#include "valuelist.h"
#include "calloc.h"
#include "utils.h"
#include "module.h"
#include "mcompile.h"
#include "compile.h"
#include "mparser.h"
#include "call.h"
#include "table.h"
#include "interpret.h"
#include "scompile.h"
#include <string.h>
#include <stdlib.h>
void scompile_recall(location l, const char *name, fncode fn)
{
u16 offset;
mtype t;
variable_class vclass = env_lookup(l, name, &offset, &t, FALSE);
if (vclass == global_var)
mrecall(l, offset, name, fn);
else if (vclass == closure_var)
ins1(OPmreadc, offset, fn);
else
ins1(OPmreadl, offset, fn);
}
--- NEW FILE: scompile.h ---
/*
* Copyright (c) 1993-1999 David Gay and Gustav Hållberg
* All rights reserved.
*
* Permission to use, copy, modify, and distribute this software for any
* purpose, without fee, and without written agreement is hereby granted,
* provided that the above copyright notice and the following two paragraphs
* appear in all copies of this software.
*
* IN NO EVENT SHALL DAVID GAY OR GUSTAV HALLBERG BE LIABLE TO ANY PARTY FOR
* DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
* OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF DAVID GAY OR
* GUSTAV HALLBERG HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* DAVID GAY AND GUSTAV HALLBERG SPECIFICALLY DISCLAIM ANY WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
* FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN
* "AS IS" BASIS, AND DAVID GAY AND GUSTAV HALLBERG HAVE NO OBLIGATION TO
* PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
*/
#ifndef SCOMPILE_H
#define SCOMPILE_H
void scompile_recall(location l, const char *name, fncode fn);
#endif
Index: Makefile.am
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/Makefile.am,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** Makefile.am 10 Dec 2004 00:34:13 -0000 1.3
--- Makefile.am 6 Oct 2005 23:37:59 -0000 1.4
***************
*** 6,10 ****
WARN_FLAGS = -Wall -Wshadow -Wnested-externs -Wno-char-subscripts -Wno-parentheses -Wno-unused
! AM_CFLAGS = $(WARN_FLAGS) @TARGET_FLAGS@
COMMON_PRIMS = \
--- 6,10 ----
WARN_FLAGS = -Wall -Wshadow -Wnested-externs -Wno-char-subscripts -Wno-parentheses -Wno-unused
! AM_CFLAGS = $(WARN_FLAGS) @TARGET_FLAGS@ -fno-strict-aliasing
COMMON_PRIMS = \
***************
*** 102,105 ****
--- 102,109 ----
objenv.c \
objenv.h \
+ scheme.c \
+ scheme.h \
+ scompile.c \
+ scompile.h \
this_machine.c \
this_machine.h \
Index: compile.c
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/compile.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** compile.c 30 Nov 2004 18:52:44 -0000 1.2
--- compile.c 6 Oct 2005 23:38:00 -0000 1.3
***************
*** 34,37 ****
--- 34,38 ----
#include "module.h"
#include "mcompile.h"
+ #include "compile.h"
#include "mparser.h"
#include "call.h"
***************
*** 39,42 ****
--- 40,45 ----
#include "interpret.h"
#include "lexer.h"
+ #include "scompile.h"
+ #include "scheme.h"
#include <string.h>
***************
*** 103,109 ****
}
! value make_constant(constant c);
! static value make_list(cstlist csts, int has_tail)
{
struct list *l;
--- 106,112 ----
}
! value make_constant(constant c, fncode fn);
! static value make_list(cstlist csts, int has_tail, fncode fn)
{
struct list *l;
***************
*** 111,115 ****
if (has_tail && csts != NULL)
{
! l = csts->cst ? make_constant(csts->cst) : NULL;
csts = csts->next;
}
--- 114,118 ----
if (has_tail && csts != NULL)
{
! l = csts->cst ? make_constant(csts->cst, fn) : NULL;
csts = csts->next;
}
***************
*** 121,125 ****
while (csts)
{
! value tmp = make_constant(csts->cst);
l = alloc_list(tmp, l);
--- 124,128 ----
while (csts)
{
! value tmp = make_constant(csts->cst, fn);
l = alloc_list(tmp, l);
***************
*** 132,136 ****
}
! static value make_array(cstlist csts)
{
struct list *l;
--- 135,139 ----
}
! static value make_array(cstlist csts, fncode fn)
{
struct list *l;
***************
*** 143,147 ****
/* This intermediate step is necessary as v is IMMUTABLE
(so must be allocated after its contents) */
! l = make_list(csts, 0);
GCPRO1(l);
v = alloc_vector(size);
--- 146,150 ----
/* This intermediate step is necessary as v is IMMUTABLE
(so must be allocated after its contents) */
! l = make_list(csts, 0, fn);
GCPRO1(l);
v = alloc_vector(size);
***************
*** 159,163 ****
}
! static value make_table(cstlist csts)
{
struct table *t = alloc_table(DEF_TABLE_SIZE);
--- 162,166 ----
}
! static value make_table(cstlist csts, fncode fn)
{
struct table *t = alloc_table(DEF_TABLE_SIZE);
***************
*** 166,170 ****
for (; csts; csts = csts->next)
table_set(t, csts->cst->u.constpair->cst1->u.string,
! make_constant(csts->cst->u.constpair->cst2));
table_foreach(t, protect_symbol);
SET_READONLY(t);
--- 169,173 ----
for (; csts; csts = csts->next)
table_set(t, csts->cst->u.constpair->cst1->u.string,
! make_constant(csts->cst->u.constpair->cst2, fn), NULL);
table_foreach(t, protect_symbol);
SET_READONLY(t);
***************
*** 174,178 ****
}
! static value make_symbol(cstpair p)
{
struct symbol *sym;
--- 177,181 ----
}
! static value make_symbol(cstpair p, fncode fn)
{
struct symbol *sym;
***************
*** 181,191 ****
GCPRO1(s);
SET_IMMUTABLE(s); SET_READONLY(s);
! sym = alloc_symbol(s, make_constant(p->cst2));
SET_IMMUTABLE(sym); SET_READONLY(sym);
GCPOP(1);
return sym;
}
! value make_constant(constant c)
{
struct obj *cst;
--- 184,220 ----
GCPRO1(s);
SET_IMMUTABLE(s); SET_READONLY(s);
! sym = alloc_symbol(s, make_constant(p->cst2, fn));
SET_IMMUTABLE(sym); SET_READONLY(sym);
GCPOP(1);
+
return sym;
}
! static value make_gsymbol(const char *name, fncode fn)
! {
! struct symbol *gsym;
!
! table_set((fn ? fnglobals(fn) : globals)->gsymbols, name, makeint(1), &gsym);
!
! return gsym;
! }
!
! static value make_quote(constant c, fncode fn)
! {
! struct list *l;
! value quote;
!
! l = alloc_list(make_constant(c, fn), NULL);
! SET_READONLY(l); SET_IMMUTABLE(l);
! GCPRO1(l);
! quote = make_gsymbol("quote", fn);
! l = alloc_list(quote, l);
! SET_READONLY(l); SET_IMMUTABLE(l);
! GCPOP(1);
!
! return l;
! }
!
! value make_constant(constant c, fncode fn)
{
struct obj *cst;
***************
*** 197,206 ****
SET_READONLY(cst); SET_IMMUTABLE(cst);
return cst;
! case cst_list: return make_list(c->u.constants, 1);
! case cst_array: return make_array(c->u.constants);
case cst_int: return makeint(c->u.integer);
case cst_float: return alloc_mudlle_float(c->u.mudlle_float);
! case cst_table: return make_table(c->u.constants);
! case cst_symbol: return make_symbol(c->u.constpair);
default:
abort();
--- 226,237 ----
SET_READONLY(cst); SET_IMMUTABLE(cst);
return cst;
! case cst_gsymbol: return make_gsymbol(c->u.string, fn);
! case cst_quote: return make_quote(c->u.constant, fn);
! case cst_list: return make_list(c->u.constants, 1, fn);
! case cst_array: return make_array(c->u.constants, fn);
case cst_int: return makeint(c->u.integer);
case cst_float: return alloc_mudlle_float(c->u.mudlle_float);
! case cst_table: return make_table(c->u.constants, fn);
! case cst_symbol: return make_symbol(c->u.constpair, fn);
default:
abort();
***************
*** 567,585 ****
}
case c_recall:
! {
! u16 offset;
! mtype t;
! variable_class vclass = env_lookup(comp->l, comp->u.recall, &offset, &t, FALSE);
!
! if (vclass == global_var)
! mrecall(comp->l, offset, comp->u.recall, fn);
! else if (vclass == closure_var)
! ins1(OPmreadc, offset, fn);
! else
! ins1(OPmreadl, offset, fn);
! break;
! }
case c_constant:
! ins_constant(make_constant(comp->u.cst), fn);
break;
case c_closure:
--- 598,609 ----
}
case c_recall:
! scompile_recall(comp->l, comp->u.recall, fn);
! break;
case c_constant:
! ins_constant(make_constant(comp->u.cst, fn), fn);
! break;
! case c_scheme:
! scheme_compile(comp->l, make_constant(comp->u.cst, fn), discard, fn);
! discard = FALSE;
break;
case c_closure:
Index: compile.h
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/compile.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** compile.h 30 Nov 2004 18:52:44 -0000 1.2
--- compile.h 6 Oct 2005 23:38:00 -0000 1.3
***************
*** 24,31 ****
#include "tree.h"
extern component component_undefined, component_true, component_false;
! value make_constant(constant c);
struct string *make_filename(const char *fname);
--- 24,32 ----
#include "tree.h"
+ #include "ins.h"
extern component component_undefined, component_true, component_false;
! value make_constant(constant c, fncode fn);
struct string *make_filename(const char *fname);
Index: global.c
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/global.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** global.c 30 Nov 2004 18:52:44 -0000 1.2
--- global.c 6 Oct 2005 23:38:00 -0000 1.3
***************
*** 44,47 ****
--- 44,48 ----
gstate->names = alloc_vector(GLOBAL_SIZE);
gstate->global = alloc_table(GLOBAL_SIZE);
+ gstate->gsymbols = alloc_table(DEF_TABLE_SIZE);
gstate->environment = alloc_env(GLOBAL_SIZE);
gstate->machine = machine;
***************
*** 67,70 ****
--- 68,72 ----
tmp = copy_vector(gstate->names); newp->names = tmp;
tmp = copy_table(gstate->global); newp->global = tmp;
+ tmp = copy_table(gstate->gsymbols); newp->gsymbols = tmp;
tmp = copy_env(gstate->environment); newp->environment = tmp;
newp->machine = gstate->machine;
***************
*** 85,88 ****
--- 87,91 ----
g1->names = g2->names;
g1->global = g2->global;
+ g1->gsymbols = g2->gsymbols;
g1->environment = g2->environment;
}
Index: global.h
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/global.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** global.h 30 Nov 2004 18:52:44 -0000 1.2
--- global.h 6 Oct 2005 23:38:00 -0000 1.3
***************
*** 35,38 ****
--- 35,39 ----
for implicitly declared ones) */
struct table *global; /* Known global variables */
+ struct table *gsymbols; /* Global (scheme) symbols */
struct env *environment; /* Values of global variables */
struct machine_specification *machine;
Index: lexer.l
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/lexer.l,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** lexer.l 30 Nov 2004 18:52:44 -0000 1.2
--- lexer.l 6 Oct 2005 23:38:00 -0000 1.3
***************
*** 75,79 ****
{ "reads", READS },
{ "writes", WRITES },
! { "defines", DEFINES }
};
#define NKEYWORDS (sizeof keywords / sizeof(struct lkeyword))
--- 75,80 ----
{ "reads", READS },
{ "writes", WRITES },
! { "defines", DEFINES },
! { "scheme", SCHEME }
};
#define NKEYWORDS (sizeof keywords / sizeof(struct lkeyword))
***************
*** 215,224 ****
int i;
for (i = 0; i < NKEYWORDS; i++)
if (stricmp(yytext, keywords[i].name) == 0)
return keywords[i].value;
- yylval.symbol = allocate(parser_memory,strlen(yytext) + 1);
- strlwr(strcpy(yylval.symbol, yytext));
return SYMBOL;
}
--- 216,226 ----
int i;
+ yylval.symbol = allocate(parser_memory,strlen(yytext) + 1);
+ strlwr(strcpy(yylval.symbol, yytext));
+
for (i = 0; i < NKEYWORDS; i++)
if (stricmp(yytext, keywords[i].name) == 0)
return keywords[i].value;
return SYMBOL;
}
Index: module.c
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/module.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** module.c 30 Nov 2004 18:52:44 -0000 1.2
--- module.c 6 Oct 2005 23:38:00 -0000 1.3
***************
*** 62,66 ****
*/
{
! table_set(gstate->modules, name, makeint(status));
}
--- 62,66 ----
*/
{
! table_set(gstate->modules, name, makeint(status), NULL);
}
Index: mparser.c
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/mparser.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** mparser.c 30 Nov 2004 18:52:44 -0000 1.2
--- mparser.c 6 Oct 2005 23:38:00 -0000 1.3
***************
*** 57,94 ****
CONTINUE = 266,
RETURN = 267,
! INTEGER = 268,
! STRING = 269,
! SYMBOL = 270,
! FLOAT = 271,
! BIGINT = 272,
! SINK = 273,
! SWITCH = 274,
! CASE = 275,
[...2916 lines suppressed...]
--- 2422,2426 ----
# undef YYRECOVERING
/* Line 671 of glr.c. */
! #line 2424 "parser.tab.c"
}
***************
*** 3649,3653 ****
! #line 755 "../standalone/parser.y"
--- 3705,3709 ----
! #line 762 "../standalone/parser.y"
Index: parser.y
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/parser.y,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** parser.y 30 Nov 2004 18:52:44 -0000 1.2
--- parser.y 6 Oct 2005 23:38:01 -0000 1.3
***************
*** 59,67 ****
}
! %token FUNCTION IF ELSE WHILE FOR ASSIGN QUOTE BREAK CONTINUE RETURN
! %token INTEGER STRING SYMBOL FLOAT BIGINT SINK SWITCH CASE DEFAULT
! %token ELLIPSIS INCREMENTER DO
! %token MODULE LIBRARY IMPORTS DEFINES READS WRITES OP_ASSIGN
!
--- 59,70 ----
}
! %token <symbol> FUNCTION IF ELSE WHILE FOR ASSIGN QUOTE BREAK CONTINUE RETURN
! %token <symbol> SYMBOL BIGINT SINK SWITCH CASE DEFAULT
! %token <symbol> ELLIPSIS DO SCHEME
! %token <symbol> MODULE LIBRARY IMPORTS DEFINES READS WRITES
! %token <integer> INTEGER
! %token <string> STRING
! %token <mudlle_float> FLOAT
! %token <operator> OP_ASSIGN INCREMENTER
***************
*** 89,97 ****
%type <tparameters> parameters
%type <tmtype> type optional_type
! %type <string> optional_help STRING
! %type <symbol> variable SYMBOL label optional_symbol
%type <symbol> variable_name
- %type <integer> INTEGER
- %type <mudlle_float> FLOAT
%type <tconstant> constant simple_constant optional_constant_tail table_entry
%type <tconstant> string_constant
--- 92,98 ----
%type <tparameters> parameters
%type <tmtype> type optional_type
! %type <string> optional_help
! %type <symbol> variable label optional_symbol anysymbol
%type <symbol> variable_name
%type <tconstant> constant simple_constant optional_constant_tail table_entry
%type <tconstant> string_constant
***************
*** 105,109 ****
%type <tmatchcond> match_pattern match_patterns
%type <tmatchnodelist> match_list
- %type <operator> OP_ASSIGN INCREMENTER
%glr-parser
--- 106,109 ----
***************
*** 393,396 ****
--- 393,397 ----
expression :
control_expression |
+ SCHEME constant { $$ = new_component(parser_memory, c_scheme, $2); } |
e0 ;
***************
*** 619,622 ****
--- 620,625 ----
constant :
simple_constant |
+ QUOTE constant { $$ = new_constant(parser_memory, cst_quote, $2); } |
+ anysymbol { $$ = new_constant(parser_memory, cst_gsymbol, $1); } |
'{' table_entry_list '}' { $$ = new_constant(parser_memory, cst_table, $2); } |
'{' '}' { $$ = new_constant(parser_memory, cst_table, NULL); } |
***************
*** 706,709 ****
--- 709,716 ----
} ;
+ anysymbol :
+ SYMBOL |
+ '+' { $$ = "+"; } ;
+
variable :
SYMBOL ;
Index: table.c
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/table.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** table.c 30 Nov 2004 18:52:44 -0000 1.2
--- table.c 6 Oct 2005 23:38:01 -0000 1.3
***************
*** 175,180 ****
}
! int table_set(struct table *table, const char *name, value data)
/* Effects: Sets table[name] to data, adds it if not already present
Modifies: table
Returns: FALSE if entry name was readonly
--- 175,182 ----
}
! int table_set(struct table *table, const char *name, value data,
! struct symbol **osym)
/* Effects: Sets table[name] to data, adds it if not already present
+ Sets *osym to the symbol if non-null
Modifies: table
Returns: FALSE if entry name was readonly
***************
*** 182,190 ****
{
struct symbol *sym;
if (table_lookup(table, name, &sym))
{
! if (readonlyp(sym)) return FALSE;
! sym->data = data;
}
else if (data)
--- 184,195 ----
{
struct symbol *sym;
+ int ok = TRUE;
if (table_lookup(table, name, &sym))
{
! if (readonlyp(sym))
! ok = FALSE;
! else
! sym->data = data;
}
else if (data)
***************
*** 196,202 ****
SET_READONLY(s);
GCPOP(2);
! table_add_fast(table, s, data);
}
! return TRUE;
}
--- 201,210 ----
SET_READONLY(s);
GCPOP(2);
! sym = table_add_fast(table, s, data);
}
! if (osym)
! *osym = sym;
!
! return ok;
}
Index: table.h
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/table.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** table.h 30 Nov 2004 18:52:44 -0000 1.2
--- table.h 6 Oct 2005 23:38:01 -0000 1.3
***************
*** 49,54 ****
*/
! int table_set(struct table *table, const char *name, value data);
/* Effects: Sets table[name] to data, adds it if not already present
Modifies: table
Returns: FALSE if entry name was readonly
--- 49,56 ----
*/
! int table_set(struct table *table, const char *name, value data,
! struct symbol **osym);
/* Effects: Sets table[name] to data, adds it if not already present
+ Sets *osym to the symbol if non-null
Modifies: table
Returns: FALSE if entry name was readonly
Index: tokens.h
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/tokens.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** tokens.h 30 Nov 2004 18:52:44 -0000 1.2
--- tokens.h 6 Oct 2005 23:38:01 -0000 1.3
***************
*** 35,72 ****
CONTINUE = 266,
RETURN = 267,
! INTEGER = 268,
! STRING = 269,
! SYMBOL = 270,
! FLOAT = 271,
! BIGINT = 272,
! SINK = 273,
! SWITCH = 274,
! CASE = 275,
! DEFAULT = 276,
! ELLIPSIS = 277,
! INCREMENTER = 278,
! DO = 279,
! MODULE = 280,
! LIBRARY = 281,
! IMPORTS = 282,
! DEFINES = 283,
! READS = 284,
! WRITES = 285,
OP_ASSIGN = 286,
! XOR = 287,
! OR = 288,
! SC_OR = 289,
! AND = 290,
! SC_AND = 291,
! GE = 292,
! GT = 293,
! LE = 294,
! LT = 295,
! NE = 296,
! EQ = 297,
! SHIFT_RIGHT = 298,
! SHIFT_LEFT = 299,
! UMINUS = 300,
! NOT = 301
};
#endif
--- 35,73 ----
CONTINUE = 266,
RETURN = 267,
! SYMBOL = 268,
! BIGINT = 269,
! SINK = 270,
! SWITCH = 271,
! CASE = 272,
! DEFAULT = 273,
! ELLIPSIS = 274,
! DO = 275,
! SCHEME = 276,
! MODULE = 277,
! LIBRARY = 278,
! IMPORTS = 279,
! DEFINES = 280,
! READS = 281,
! WRITES = 282,
! INTEGER = 283,
! STRING = 284,
! FLOAT = 285,
OP_ASSIGN = 286,
! INCREMENTER = 287,
! XOR = 288,
! OR = 289,
! SC_OR = 290,
! AND = 291,
! SC_AND = 292,
! GE = 293,
! GT = 294,
! LE = 295,
! LT = 296,
! NE = 297,
! EQ = 298,
! SHIFT_RIGHT = 299,
! SHIFT_LEFT = 300,
! UMINUS = 301,
! NOT = 302
};
#endif
***************
*** 81,118 ****
#define CONTINUE 266
#define RETURN 267
! #define INTEGER 268
! #define STRING 269
! #define SYMBOL 270
! #define FLOAT 271
! #define BIGINT 272
! #define SINK 273
! #define SWITCH 274
! #define CASE 275
! #define DEFAULT 276
! #define ELLIPSIS 277
! #define INCREMENTER 278
! #define DO 279
! #define MODULE 280
! #define LIBRARY 281
! #define IMPORTS 282
! #define DEFINES 283
! #define READS 284
! #define WRITES 285
#define OP_ASSIGN 286
! #define XOR 287
! #define OR 288
! #define SC_OR 289
! #define AND 290
! #define SC_AND 291
! #define GE 292
! #define GT 293
! #define LE 294
! #define LT 295
! #define NE 296
! #define EQ 297
! #define SHIFT_RIGHT 298
! #define SHIFT_LEFT 299
! #define UMINUS 300
! #define NOT 301
--- 82,120 ----
#define CONTINUE 266
#define RETURN 267
! #define SYMBOL 268
! #define BIGINT 269
! #define SINK 270
! #define SWITCH 271
! #define CASE 272
! #define DEFAULT 273
! #define ELLIPSIS 274
! #define DO 275
! #define SCHEME 276
! #define MODULE 277
! #define LIBRARY 278
! #define IMPORTS 279
! #define DEFINES 280
! #define READS 281
! #define WRITES 282
! #define INTEGER 283
! #define STRING 284
! #define FLOAT 285
#define OP_ASSIGN 286
! #define INCREMENTER 287
! #define XOR 288
! #define OR 289
! #define SC_OR 290
! #define AND 291
! #define SC_AND 292
! #define GE 293
! #define GT 294
! #define LE 295
! #define LT 296
! #define NE 297
! #define EQ 298
! #define SHIFT_RIGHT 299
! #define SHIFT_LEFT 300
! #define UMINUS 301
! #define NOT 302
***************
*** 145,149 ****
} YYSTYPE;
/* Line 1985 of glr.c. */
! #line 147 "parser.tab.h"
# define YYSTYPE_IS_DECLARED 1
# define YYSTYPE_IS_TRIVIAL 1
--- 147,151 ----
} YYSTYPE;
/* Line 1985 of glr.c. */
! #line 149 "parser.tab.h"
# define YYSTYPE_IS_DECLARED 1
# define YYSTYPE_IS_TRIVIAL 1
Index: tree.c
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/tree.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** tree.c 30 Nov 2004 18:52:44 -0000 1.2
--- tree.c 6 Oct 2005 23:38:01 -0000 1.3
***************
*** 152,156 ****
newp->u.integer = va_arg(args, int);
break;
! case cst_string:
newp->u.string = va_arg(args, const char *);
break;
--- 152,156 ----
newp->u.integer = va_arg(args, int);
break;
! case cst_string: case cst_gsymbol:
newp->u.string = va_arg(args, const char *);
break;
***************
*** 158,161 ****
--- 158,164 ----
newp->u.constants = va_arg(args, cstlist);
break;
+ case cst_quote:
+ newp->u.constant = va_arg(args, constant);
+ break;
case cst_float:
newp->u.mudlle_float = va_arg(args, double);
***************
*** 203,206 ****
--- 206,212 ----
newp->u.cst = va_arg(args, constant);
break;
+ case c_scheme:
+ newp->u.cst = va_arg(args, constant);
+ break;
case c_closure:
newp->u.closure = va_arg(args, function);
***************
*** 457,462 ****
break;
! case c_constant:
! val = make_constant(c->u.cst);
mc->data[1] = val;
break;
--- 463,468 ----
break;
! case c_constant: case c_scheme:
! val = make_constant(c->u.cst, NULL);
mc->data[1] = val;
break;
***************
*** 576,582 ****
--- 582,595 ----
fprintf(f, "\"%s\"" , c->u.string);
break;
+ case cst_gsymbol:
+ fprintf(f, "`%s'" , c->u.string);
+ break;
case cst_float:
fprintf(f, "%f", c->u.mudlle_float);
break;
+ case cst_quote:
+ fprintf(f, "'");
+ print_constant(f, c->u.constant);
+ break;
case cst_list:
fprintf(f, "(");
***************
*** 659,662 ****
--- 672,679 ----
print_constant(f, c->u.cst);
break;
+ case c_scheme:
+ fprintf(f, "scheme ");
+ print_constant(f, c->u.cst);
+ break;
case c_closure:
print_function(f, c->u.closure);
Index: tree.h
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/tree.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** tree.h 30 Nov 2004 18:52:44 -0000 1.2
--- tree.h 6 Oct 2005 23:38:01 -0000 1.3
***************
*** 72,76 ****
enum constant_class {
cst_int, cst_string, cst_list, cst_array, cst_float, cst_table,
! cst_symbol
};
--- 72,76 ----
enum constant_class {
cst_int, cst_string, cst_list, cst_array, cst_float, cst_table,
! cst_symbol, cst_gsymbol, cst_quote
};
***************
*** 80,85 ****
int integer;
float mudlle_float;
! const char *string;
cstlist constants; /* Stored in reverse order ... */
cstpair constpair;
} u;
--- 80,86 ----
int integer;
float mudlle_float;
! const char *string; /* for cst_string and cst_gsymbol */
cstlist constants; /* Stored in reverse order ... */
+ constant constant; /* for cst_quote */
cstpair constpair;
} u;
***************
*** 140,144 ****
enum component_class {
c_assign, c_recall, c_constant, c_closure, c_execute, c_builtin, c_block,
! c_labeled, c_exit, c_continue, c_decl
};
--- 141,145 ----
enum component_class {
c_assign, c_recall, c_constant, c_closure, c_execute, c_builtin, c_block,
! c_labeled, c_exit, c_continue, c_decl, c_scheme
};
***************
*** 152,156 ****
} assign;
const char *recall;
! constant cst;
function closure;
clist execute; /* 1st element is fn, rest are args */
--- 153,157 ----
} assign;
const char *recall;
! constant cst; /* for c_constant and c_scheme */
function closure;
clist execute; /* 1st element is fn, rest are args */
- Next message: [Tinyos-commits]
CVS: tinyos-1.x/tos/lib/VM/languages/motlle/standalone
compile.c, 1.3, 1.4 env.c, 1.2, 1.3 env.h, 1.2, 1.3 lexer.h,
1.2, 1.3 lexer.l, 1.3, 1.4 mparser.c, 1.3, 1.4 parser.y, 1.3,
1.4 scheme.c, 1.1, 1.2
- Messages sorted by:
[ date ]
[ thread ]
[ subject ]
[ author ]
More information about the Tinyos-commits
mailing list