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; }