extern MLvalue c2ml_tuple1(int count, MLvalue table[])
{ mlval tup;
int i;
tup = allocate_record((size_t)count);
for (i=0; i < count; i++)
FIELD(tup,i) = TO_mlval(table[i]);
return_MLvalue(tup);
}
static mlval ml_save_image(mlval argument)
{
mlval global, filename;
/* license_edition is a global C enum */
if ((license_edition == PERSONAL) || act_as_free) {
display_simple_message_box(
"Saving images is not enabled in the Personal edition of MLWorks");
return MLUNIT;
}
filename = FIELD(argument, 0);
image_continuation = FIELD(argument, 1);
declare_root(&filename, 1);
global = global_pack(0); /* 0 = not delivery */
declare_root(&global, 1);
{
mlval old_message_level = MLSUB(gc_message_level,0);
MLUPDATE(gc_message_level,0,MLINT(-1));
gc_collect_all();
MLUPDATE(gc_message_level,0,old_message_level);
}
argument = allocate_record(2);
FIELD(argument, 0) = filename;
FIELD(argument, 1) = global;
retract_root(&filename);
retract_root(&global);
if(image_save(argument) == MLERROR)
switch(errno)
{
case EIMPL:
exn_raise_string(perv_exn_ref_save, "Image save not implemented");
case EIMAGEWRITE:
exn_raise_string(perv_exn_ref_save, "Error writing opened image file");
case EIMAGEOPEN:
exn_raise_string(perv_exn_ref_save, "Unable to open image file");
default:
exn_raise_string(perv_exn_ref_save, "Unexpected error from image_save()");
}
argument = image_continuation;
image_continuation = MLUNIT;
return(argument);
}
struct closure *alloc_closure0(struct code *code)
{
struct closure *newp;
GCCHECK(code);
GCPRO1(code);
newp = (struct closure *)allocate_record(type_function, 1);
GCPOP(1);
newp->code = code;
SET_READONLY(newp);
return newp;
}
static void make_global_state(int argc, const char **argv)
{
struct machine_specification *this_machine =
(struct machine_specification *)allocate_record(type_vector, 4);
struct extptr *tms;
GCPRO1(this_machine);
tms = alloc_extptr(&this_machine_specification);
GCPOP(1);
this_machine->c_machine_specification = tms;
globals = new_global_state(this_machine);
staticpro((value *)&globals);
runtime_setup(globals, argc, argv);
}
CC compile_and_run(block_t region,
struct global_state *gstate,
const char *nicename, u8 *noreload,
bool dontrun)
{
struct compile_and_run_frame *frame;
struct compile_context *ccontext;
GCPRO1(gstate);
frame = push_frame(compile_and_run_action, sizeof(struct compile_and_run_frame));
ccontext = (struct compile_context *)allocate_record(type_vector, 2);
frame->dontrun = dontrun;
frame->ps.ccontext = ccontext;
ccontext->gstate = gstate;
/* no evaluation_state yet */
GCPOP(1);
frame->state = init;
if (!region)
region = new_block();
frame->parser_block = region;
/* Set filename */
lexloc.filename = bstrdup(region, nicename);
normal_lexing();
if ((frame->f = parse(frame->parser_block)))
{
if (noreload)
{
if (frame->f->name &&
module_status(frame->ps.ccontext->gstate, frame->f->name) != module_unloaded)
{
free_block(frame->parser_block);
*noreload = TRUE;
FA_POP(&fp, &sp);
return;
}
*noreload = FALSE;
}
if (mprepare(&frame->ps, frame->parser_block, frame->f))
{
frame->state = preparing;
continue_prepare(frame);
return;
}
}
runtime_error(error_compile_error);
}
extern MLvalue c2ml_tuple(int count, ...)
{ mlval tup;
va_list ap;
int i;
tup = allocate_record((size_t)count);
va_start(ap,count);
for (i=0; i < count; i++)
FIELD(tup,i) = TO_mlval(va_arg(ap,MLvalue));
va_end(ap);
return_MLvalue(tup);
}
extern MLvalue call_ml_function (MLvalue fn_handle, int arity, ...)
{ mlval tup;
va_list ap;
int i;
tup = allocate_record((size_t)arity);
va_start(ap,arity);
for (i=0; i < arity; i++)
FIELD(tup,i) = TO_mlval(va_arg(ap,MLvalue));
va_end(ap);
return_MLvalue(callml(tup,fn_handle));
}
static mlval from_exp (mlval arg)
{
double x = GETREAL(arg);
int exp;
double man;
mlval result;
man = frexp (x,&exp);
root = allocate_real();
SETREAL (root,man);
result = allocate_record (2);
FIELD (result,0) = MLINT (exp);
FIELD (result,1) = root;
root = MLUNIT;
return (result);
}
static mlval decimal_rep (mlval arg)
{
int dec;
int sign;
char * digits;
mlval result;
digits = dtoa (GETREAL(arg),0,100,&dec,&sign,NULL);
root = allocate_string (strlen(digits) + 1);
strcpy (CSTRING(root),digits);
freedtoa (digits);
result = allocate_record (3);
FIELD (result,0) = root;
FIELD (result,1) = MLINT (dec);
FIELD (result,2) = sign ? MLTRUE : MLFALSE;
return (result);
}
struct global_state *new_global_state(struct machine_specification *machine)
/* Returns: A new global state for a motlle interpreter for machine
*/
{
struct global_state *gstate;
GCPRO1(machine);
gstate = (struct global_state *)allocate_record(type_vector, 5);
GCPRO1(gstate);
gstate->modules = alloc_table(DEF_TABLE_SIZE);
gstate->mvars = alloc_vector(GLOBAL_SIZE);
gstate->global = alloc_table(GLOBAL_SIZE);
gstate->environment = alloc_env(GLOBAL_SIZE);
gstate->machine = machine;
GCPOP(2);
return gstate;
}
static mlval ml_save_image(mlval argument)
{
mlval global, filename;
filename = FIELD(argument, 0);
image_continuation = FIELD(argument, 1);
declare_root(&filename, 1);
global = global_pack(0); /* 0 = not delivery */
declare_root(&global, 1);
{
mlval old_message_level = MLSUB(gc_message_level,0);
MLUPDATE(gc_message_level,0,MLINT(-1));
gc_collect_all();
MLUPDATE(gc_message_level,0,old_message_level);
}
argument = allocate_record(2);
FIELD(argument, 0) = filename;
FIELD(argument, 1) = global;
retract_root(&filename);
retract_root(&global);
if(image_save(argument) == MLERROR)
switch(errno)
{
case EIMPL:
exn_raise_string(perv_exn_ref_save, "Image save not implemented");
case EIMAGEWRITE:
exn_raise_string(perv_exn_ref_save, "Error writing opened image file");
case EIMAGEOPEN:
exn_raise_string(perv_exn_ref_save, "Unable to open image file");
default:
exn_raise_string(perv_exn_ref_save, "Unexpected error from image_save()");
}
argument = image_continuation;
image_continuation = MLUNIT;
return(argument);
}
/* This should raise an exception when an error occurs */
static mlval ml_load_link(mlval arg)
{
const char *filename = CSTRING(arg);
/* Maybe this should use options properly -- how are they propagated here? */
mlval mod_name = MLUNIT;
mlval result = internal_load_link(filename,&mod_name,0,1,0);
if(result == MLERROR)
switch(errno)
{
case ELOADREAD:
exn_raise_format (perv_exn_ref_load,"The loader was unable to read from the file '%s'", filename);
case ELOADOPEN:
exn_raise_format (perv_exn_ref_load,"The loader was unable to open the file '%s'", filename);
case ELOADALLOC:
exn_raise_string (perv_exn_ref_load,"The loader was unable to allocate enough memory");
case ELOADVERSION:
exn_raise_format (perv_exn_ref_load,"The file '%s' contains a module of a version the loader does not understand", filename);
case ELOADFORMAT:
exn_raise_format (perv_exn_ref_load,"The file '%s' is not in the correct loader format", filename);
case ELOADEXTERNAL:
exn_raise_format (perv_exn_ref_load,"The module in the file '%s' references an unloaded external module '%s'", filename, CSTRING(load_external));
default:
exn_raise_string (perv_exn_ref_load,"The loader returned an invalid error code.");
}
else
{
mlval pair;
declare_root (&mod_name, 0);
declare_root (&result, 0);
pair = allocate_record(2);
FIELD(pair, 0) = mod_name;
FIELD(pair, 1) = result;
retract_root (&mod_name);
retract_root (&result);
return(pair);
}
}
struct global_state *copy_global_state(struct global_state *gstate)
/* Returns: A copy of global state gstate, which includes copying
global variable and module state
*/
{
struct global_state *newp;
value tmp;
GCPRO1(gstate);
newp = (struct global_state *)allocate_record(type_vector, 8);
GCPRO1(newp);
tmp = copy_table(gstate->modules); newp->modules = tmp;
tmp = copy_vector(gstate->mvars); newp->mvars = tmp;
tmp = copy_vector(gstate->types); newp->types = tmp;
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;
GCPOP(2);
return newp;
}
static mlval split (mlval arg)
{
double x = GETREAL(arg);
double intpart;
double fracpart = modf (x,&intpart);
mlval result;
root = allocate_real();
SETREAL (root,fracpart);
root1 = allocate_real();
SETREAL (root1,intpart);
result = allocate_record (2);
FIELD (result,0) = root;
FIELD (result,1) = root1;
root = MLUNIT;
root1 = MLUNIT;
return (result);
}
struct vector *alloc_vector(uvalue size)
{
return (struct vector *)allocate_record(type_vector, size);
}
extern mlval unix_rusage(mlval unit)
{
mlval utime, stime, result;
/* on Solaris we can't do getrusage without the BSD-compatibility
* library, which sucks, so we have to fake it : */
prusage_t usage;
prpsinfo_t psinfo;
if (pioc(PIOCPSINFO,&psinfo) == -1 ||
pioc(PIOCUSAGE,&usage) == -1)
exn_raise_syserr(ml_string(strerror(errno)), errno);
utime = ml_time(&usage.pr_utime);
declare_root(&utime, 0);
stime = ml_time(&usage.pr_stime);
declare_root(&stime, 0);
result = allocate_record(16);
retract_root(&utime);
retract_root(&stime);
/* Lexical ordering for fields -- the result is a record with name fields.
*
* idrss integral resident set size
* inblock block input operations
* isrss currently 0
* ixrss currently 0
* majflt page faults requiring physical I/O
* maxrss maximum resident set size Solaris : resident set size
* minflt page faults not requiring physical I/O
* msgrcv messages received
* msgsnd messages sent
* nivcsw involuntary context switches
* nsignals signals received
* nswap swaps voluntary
* nvcsw context switches
* oublock block output operations
* stime system time used
* utime user time used
*/
FIELD(result, 0) = MLINT(psinfo.pr_rssize);
FIELD(result, 1) = MLINT(usage.pr_inblk);
FIELD(result, 2) = MLINT(0);
FIELD(result, 3) = MLINT(0);
FIELD(result, 4) = MLINT(usage.pr_majf);
FIELD(result, 5) = MLINT(psinfo.pr_rssize);
FIELD(result, 6) = MLINT(usage.pr_minf);
FIELD(result, 7) = MLINT(usage.pr_msnd);
FIELD(result, 8) = MLINT(usage.pr_mrcv);
FIELD(result, 9) = MLINT(usage.pr_ictx);
FIELD(result, 10) = MLINT(usage.pr_sigs);
FIELD(result, 11) = MLINT(usage.pr_nswap);
FIELD(result, 12) = MLINT(usage.pr_vctx);
FIELD(result, 13) = MLINT(usage.pr_oublk);
FIELD(result, 14) = stime;
FIELD(result, 15) = utime;
return result;
}
