vx-scheme/src/vx-main.cpp

239 lines
5.8 KiB
C++
Raw Permalink Normal View History

//----------------------------------------------------------------------
// vx-scheme : Scheme interpreter.
// Copyright (c) 2002,2003,2006 and onwards Colin Smith.
//
// You may distribute under the terms of the Artistic License,
// as specified in the LICENSE file.
//
// vx-main.cpp : startup code for VxWorks execution environment.
#include "vx-scheme.h"
#include "tickLib.h"
#include "sysSymTbl.h"
#include "setjmp.h"
static jmp_buf jb;
static psymbol s_vx_invoke;
static psymbol s_args;
int vxSchemeDebug = 0;
extern "C" int sysClkRateGet ();
typedef int (* VX_FUNC) (...);
//----------------------------------------------------------------------------
//
// OS-SPECIFIC FEATURES
//
// This area fills in definitions for OS-specific features named
// in class OS.
//
double OS::get_time() {
double t = tickGet ();
return t / sysClkRateGet();
}
unsigned int OS::flags() {
return vxSchemeDebug;
}
bool OS::interactive (int fd)
{
return isatty (fd);
}
Cell * mget (Context * ctx, void * key)
{
int * pi = (int *) key;
int val = *pi;
return ctx->make_int (val);
}
void mset (Context * ctx, void * key, Cell * rhs)
{
int value;
Cell::Type t = rhs->type ();
if (t == Cell::Int)
value = rhs->IntValue ();
else if (t == Cell::String)
value = reinterpret_cast <int> (rhs->StringValue ());
else if (t == Cell::Char)
value = rhs->CharValue ();
else
error ("cannot convert rvalue to compatible type");
int * pi = static_cast <int *> (key);
*pi = value;
}
Cell * OS::undef (Context * ctx, const char * name)
{
char * value;
SYM_TYPE type;
// See if it's a symbol.
if (symFindByCName (sysSymTbl,
const_cast <char*> (name),
&value,
&type) == OK)
{
switch (type)
{
case SYM_GLOBAL | SYM_BSS:
case SYM_GLOBAL | SYM_DATA:
// It's a global in a data section. Treat
// it as an integer variable.
return ctx->make_magic (value, mset, mget);
case SYM_GLOBAL | SYM_TEXT:
// It's a global in a text section. Treat
// it as a function. To do this, we construct
// a lambda which will call the VxWorks
// function below:
//
// (lambda args (vx-invoke <function-address> args))
Cell *vx_invoke, *addr, *args, *nu;
vx_invoke = ctx->make_symbol (s_vx_invoke);
ctx->gc_protect (vx_invoke);
addr = ctx->make_int (reinterpret_cast <int> (value));
ctx->gc_protect (addr);
args = ctx->make_symbol (s_args);
ctx->gc_protect (args);
nu = ctx->make_list3 (vx_invoke, addr, args);
ctx->gc_protect (nu);
nu = ctx->cons (nu, nil);
ctx->gc_unprotect (4);
return ctx->make_procedure (ctx->root (), nu, args);
}
}
return 0;
}
Cell * vx_invoke (Context * ctx, Cell * arglist)
{
Cell * cfunc = car (arglist);
Cell * alist = cadr (arglist);
const int nargs = 10;
int a [nargs];
int ix = 0;
VX_FUNC vx_func = reinterpret_cast <VX_FUNC> (cfunc->IntValue ());
// Fill up argument array. We support integer and string
// arguments (which we pass by address). If we see a
// symbol (most likely someone wrote, e.g., 'taskDelay),
// we look up its value in the VxWorks symbol table. This
// makes "(sp 'taskDelay 100)" work (if the quote were omitted,
// then taskDelay would receive a procedure value, rather than
// a numeric one).
FOR_EACH (arg, alist)
{
Cell * ar = car (arg);
Cell::Type t = ar->type ();
if (t == Cell::Int)
a [ix++] = ar->IntValue ();
else if (t == Cell::String)
a [ix++] = reinterpret_cast <int> (ar->StringValue ());
else if (t == Cell::Symbol)
{
const char * name = ar->SymbolValue ()->truename;
char * value;
SYM_TYPE type;
if (symFindByCName (sysSymTbl,
const_cast <char *> (name),
&value,
&type) == OK)
a [ix++] = reinterpret_cast <int> (value);
else
error ("symbol absent from sysSymTbl");
}
else
error ("incompatible argument type");
}
// Fill up the remaining argument slots with '0'.
for (; ix < nargs; ++ix)
a [ix] = 0;
// Invoke VxWorks function. Make an integer cell of the
// return value.
return ctx->make_int (vx_func (a[0],a[1],a[2],a[3],a[4],
a[5],a[6],a[7],a[8],a[9]));
}
void OS::exception (const char * s)
{
longjmp (jb, 1);
}
void interact (Context * ctx)
{
bool interactive = isatty (0);
while (ctx->read_eval_print (stdin, stdout, interactive))
;
if (OS::flag (DEBUG_MEMSTATS_AT_EXIT))
ctx->print_mem_stats (stdout);
exit (0);
}
extern "C" int scheme (char * a0)
{
Context ctx;
// Sanity check: we need to make sure that the "unique cells"
// (e.g., things like nil, etc.) are 8-byte aligned. If this
// scheme image has been dynamically loaded to a VxWorks system,
// this is not easy to guarantee! We try to favor this outcome by
// making env.o (where these objects are defined) first in the
// link order, but we make sure that whatever happens things have
// worked out ok. The garbage collector will be very unhappy if
// any cells are not 8-aligned.
if ((reinterpret_cast<intptr_t>(nil)) & 7)
{
printf ("code module error: standard cells not 8-aligned\n");
exit (1);
}
s_args = intern ("args");
s_vx_invoke = intern ("vx-invoke");
ctx.bind (ctx.make_symbol (intern ("vx-invoke")),
ctx.make_subr (vx_invoke, "vx-invoke"));
if (a0 != 0)
{
sstring ss;
ss.append (a0);
Cell * result = ctx.eval (ctx.read (ss));
if (result != unspecified)
{
result->write (stdout);
fputc ('\n', stdout);
}
}
else while (1)
{
if (setjmp (jb) == 0)
interact (&ctx);
else
fprintf (stderr, "caught: %s\n", OS::errbuf);
}
}