/*
* Enumerate the next glyph from a directory. This is essentially a
* wrapper around dict_first/dict_next to implement the enumerate_glyph
* font procedure.
*
* Note that *prdict will be null if the font is a subfont of a
* CIDFontType 0 CIDFont.
*/
int
zchar_enumerate_glyph(const gs_memory_t *mem, const ref *prdict, int *pindex, gs_glyph *pglyph)
{
int index = *pindex - 1;
ref elt[2];
if (!r_has_type(prdict, t_dictionary))
return 0; /* *pindex was 0, is still 0 */
if (index < 0)
index = dict_first(prdict);
next:
index = dict_next(prdict, index, elt);
*pindex = index + 1;
if (index >= 0) {
switch (r_type(elt)) {
case t_integer:
*pglyph = gs_min_cid_glyph + elt[0].value.intval;
break;
case t_name:
*pglyph = name_index(mem, elt);
break;
default: /* can't handle it */
goto next;
}
}
return 0;
}
int
dict_find(const ref * pdref, const ref * pkey, ref ** ppvalue)
{
dict *pdict = pdref->value.pdict;
int code = real_dict_find(pdref, pkey, ppvalue);
stats_dict.lookups++;
if (r_has_type(pkey, t_name) && dict_is_packed(pdict)) {
uint nidx = name_index(dict_mem(pdict), pkey);
uint hash =
dict_hash_mod(dict_name_index_hash(nidx), npairs(pdict)) + 1;
if (pdict->keys.value.packed[hash] ==
pt_tag(pt_literal_name) + nidx
)
stats_dict.probe1++;
else if (pdict->keys.value.packed[hash - 1] ==
pt_tag(pt_literal_name) + nidx
)
stats_dict.probe2++;
}
/* Do the cheap flag test before the expensive remainder test. */
if (gs_debug_c('d') && !(stats_dict.lookups % 1000))
dlprintf3("[d]lookups=%ld probe1=%ld probe2=%ld\n",
stats_dict.lookups, stats_dict.probe1, stats_dict.probe2);
return code;
}
int udev_node_add(struct udev_device *dev, mode_t mode, uid_t uid, gid_t gid, int test)
{
struct udev *udev = udev_device_get_udev(dev);
int i;
int num;
struct udev_list_entry *list_entry;
int err = 0;
info(udev, "creating device node '%s', devnum=%d:%d, mode=%#o, uid=%d, gid=%d\n",
udev_device_get_devnode(dev),
major(udev_device_get_devnum(dev)), minor(udev_device_get_devnum(dev)),
mode, uid, gid);
util_create_path(udev, udev_device_get_devnode(dev));
if (!test)
if (udev_node_mknod(dev, NULL, makedev(0,0), mode, uid, gid) != 0) {
err = -1;
goto exit;
}
/* create all_partitions if requested */
num = udev_device_get_num_fake_partitions(dev);
if (num > 0) {
info(udev, "creating device partition nodes '%s[1-%i]'\n", udev_device_get_devnode(dev), num);
if (!test) {
for (i = 1; i <= num; i++) {
char partitionname[UTIL_PATH_SIZE];
dev_t part_devnum;
snprintf(partitionname, sizeof(partitionname), "%s%d",
udev_device_get_devnode(dev), i);
partitionname[sizeof(partitionname)-1] = '\0';
part_devnum = makedev(major(udev_device_get_devnum(dev)),
minor(udev_device_get_devnum(dev)) + i);
udev_node_mknod(dev, partitionname, part_devnum, mode, uid, gid);
}
}
}
/* add node to name index */
name_index(udev, udev_device_get_devpath(dev), udev_device_get_devnode(dev), 1, test);
/* create/update symlinks, add symlinks to name index */
udev_list_entry_foreach(list_entry, udev_device_get_devlinks_list_entry(dev)) {
name_index(udev, udev_device_get_devpath(dev), udev_list_entry_get_name(list_entry), 1, test);
update_link(dev, udev_list_entry_get_name(list_entry), test);
}
/* Print a ref */
void
debug_print_full_ref(const ref *pref)
{ unsigned size = r_size(pref);
ref nref;
dprintf1("(%x)", r_type_attrs(pref));
switch ( r_type(pref) )
{
case t_array:
dprintf2("array(%u)0x%lx", size, (ulong)pref->value.refs); break;
case t_boolean:
dprintf1("boolean %x", pref->value.index); break;
case t_condition:
dprintf1("condition 0x%lx", (ulong)pref->value.pcond); break;
case t_device:
dprintf1("device 0x%lx", (ulong)pref->value.pdevice); break;
case t_dictionary:
dprintf3("dict(%u/%u)0x%lx",
dict_length(pref), dict_maxlength(pref),
(ulong)pref->value.pdict);
break;
case t_file:
dprintf1("file 0x%lx", (ulong)pref->value.pfile); break;
case t_gstate:
dprintf1("gstate 0x%lx", (ulong)pref->value.pgstate); break;
case t_integer: dprintf1("int %ld", pref->value.intval); break;
case t_lock:
dprintf1("lock 0x%lx", (ulong)pref->value.plock); break;
case t_mark: dprintf("mark"); break;
case t_mixedarray:
dprintf2("mixed packedarray(%u)0x%lx", size,
(ulong)pref->value.packed); break;
case t_name:
dprintf2("name(0x%lx#%x)", (ulong)pref->value.pname,
name_index(pref));
debug_print_name(pref);
break;
case t_null: dprintf("null"); break;
case t_oparray:
dprintf1("op_array(0x%x)", size);
name_index_ref(op_array_nx_table[size - op_def_count], &nref);
debug_print_name(&nref);
break;
case t_operator:
dprintf1("op(0x%x", size);
if ( size )
dprintf1(":%s", (const char *)(op_def_table[size]->oname + 1));
dprintf1(")0x%lx", (ulong)pref->value.opproc);
break;
case t_real: dprintf1("real %f", pref->value.realval); break;
case t_shortarray:
dprintf2("short packedarray(%u)0x%lx", size,
(ulong)pref->value.packed); break;
case t_string:
dprintf2("string(%u)0x%lx", size, (ulong)pref->value.bytes); break;
default: dprintf1("type 0x%x", r_type(pref));
}
}
extern int udev_node_remove(struct udev_device *dev, int test)
{
struct udev *udev = udev_device_get_udev(dev);
struct udev_list_entry *list_entry;
const char *devnode;
char partitionname[UTIL_PATH_SIZE];
struct stat stats;
int err = 0;
int num;
/* remove node from name index */
name_index(udev, udev_device_get_devpath(dev), udev_device_get_devnode(dev), 0, test);
/* remove,update symlinks, remove symlinks from name index */
udev_list_entry_foreach(list_entry, udev_device_get_devlinks_list_entry(dev)) {
name_index(udev, udev_device_get_devpath(dev), udev_list_entry_get_name(list_entry), 0, test);
update_link(dev, udev_list_entry_get_name(list_entry), test);
}
/* Get a global glyph code. */
static int
zfont_global_glyph_code(const gs_memory_t *mem, gs_const_string *gstr, gs_glyph *pglyph)
{
ref v;
int code = name_ref(mem, gstr->data, gstr->size, &v, 0);
if (code < 0)
return code;
*pglyph = (gs_glyph)name_index(mem, &v);
return 0;
}
/*
* We make this into a separate procedure because
* the interpreter will almost always call it directly.
*/
int
zop_def(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
os_ptr op1 = op - 1;
ref *pvslot;
/* The following combines a check_op(2) with a type check. */
switch (r_type(op1)) {
case t_name: {
/* We can use the fast single-probe lookup here. */
uint nidx = name_index(imemory, op1);
uint htemp;
if_dict_find_name_by_index_top(nidx, htemp, pvslot) {
if (dtop_can_store(op))
goto ra;
}
break; /* handle all slower cases */
}
case t_null:
return_error(e_typecheck);
case t__invalid:
return_error(e_stackunderflow);
}
/*
* Combine the check for a writable top dictionary with
* the global/local store check. See dstack.h for details.
*/
if (!dtop_can_store(op)) {
check_dict_write(*dsp);
/*
* If the dictionary is writable, the problem must be
* an invalid store.
*/
return_error(e_invalidaccess);
}
/*
* Save a level of procedure call in the common (redefinition)
* case. With the current interfaces, we pay a double lookup
* in the uncommon case.
*/
if (dict_find(dsp, op1, &pvslot) <= 0)
return idict_put(dsp, op1, op);
ra:
if ((pvslot->tas.type_attrs & (&i_ctx_p->memory)->test_mask) == 0)
alloc_save_change(idmemory, &dsp->value.pdict->values, (ref_packed *)pvslot, "dict_put(value)");
ref_assign_new_inline(pvslot,op);
return 0;
}
void udev_node_update_old_links(struct udev_device *dev, struct udev_device *dev_old, int test)
{
struct udev *udev = udev_device_get_udev(dev);
struct udev_list_entry *list_entry;
const char *devnode_old;
/* update possible left-over symlinks */
udev_list_entry_foreach(list_entry, udev_device_get_devlinks_list_entry(dev_old)) {
const char *name = udev_list_entry_get_name(list_entry);
struct udev_list_entry *list_entry_current;
int found;
/* check if old link name is now our node name */
if (strcmp(name, udev_device_get_devnode(dev)) == 0)
continue;
/* check if old link name still belongs to this device */
found = 0;
udev_list_entry_foreach(list_entry_current, udev_device_get_devlinks_list_entry(dev)) {
const char *name_current = udev_list_entry_get_name(list_entry_current);
if (strcmp(name, name_current) == 0) {
found = 1;
break;
}
}
if (found)
continue;
info(udev, "update old symlink '%s' no longer belonging to '%s'\n", name, udev_device_get_devpath(dev));
name_index(udev, udev_device_get_devpath(dev), name, 0, test);
update_link(dev, name, test);
}
/*
* if the node name has changed, delete the node,
* and possibly restore a symlink of another device
*/
devnode_old = udev_device_get_devnode(dev_old);
if (devnode_old != NULL) {
const char *devnode = udev_device_get_devnode(dev);
if (devnode != NULL && strcmp(devnode_old, devnode) != 0)
update_link(dev, devnode_old, test);
}
}
/* Common setup for glyphshow and .glyphwidth. */
static int
glyph_show_setup(i_ctx_t *i_ctx_p, gs_glyph *pglyph)
{
os_ptr op = osp;
switch (gs_currentfont(igs)->FontType) {
case ft_CID_encrypted:
case ft_CID_user_defined:
case ft_CID_TrueType:
case ft_CID_bitmap:
check_int_leu(*op, gs_max_glyph - gs_min_cid_glyph);
*pglyph = (gs_glyph) op->value.intval + gs_min_cid_glyph;
break;
default:
check_type(*op, t_name);
*pglyph = name_index(imemory, op);
}
return op_show_enum_setup(i_ctx_p);
}
/* Encode a character. */
gs_glyph
zfont_encode_char(gs_font *pfont, gs_char chr, gs_glyph_space_t gspace)
{
font_data *pdata = pfont_data(pfont);
const ref *pencoding = &pdata->Encoding;
ulong index = chr; /* work around VAX widening bug */
ref cname;
int code = array_get(pfont->memory, pencoding, (long)index, &cname);
if (code < 0 || !r_has_type(&cname, t_name))
return gs_no_glyph;
if (pfont->FontType == ft_user_defined && r_type(&pdata->BuildGlyph) == t_null) {
ref nsref, tname;
name_string_ref(pfont->memory, &cname, &nsref);
if (r_size(&nsref) == 7 &&
!memcmp(nsref.value.const_bytes, ".notdef", r_size(&nsref))) {
/* A special support for high level devices.
They need a glyph name but the font doesn't provide one
due to an instandard BuildChar.
Such fonts don't conform to PLRM section 5.3.7,
but we've got real examples that we want to handle (Bug 686982).
Construct a name here.
Low level devices don't pass here, because regular PS interpretation
doesn't need such names.
*/
char buf[20];
int code;
if (gspace == GLYPH_SPACE_NOGEN)
return gs_no_glyph;
sprintf(buf, "j%ld", chr); /* 'j' is arbutrary. */
code = name_ref(pfont->memory, (const byte *)buf, strlen(buf), &tname, 1);
if (code < 0) {
/* Can't propagate the error due to interface limitation,
return with .notdef */
} else
cname = tname;
}
}
return (gs_glyph)name_index(pfont->memory, &cname);
}
void block_generation_loop()
{
while( !_block_gen_loop_complete.canceled() )
{
if( _pending.size() && (fc::time_point::now() - _current_block.timestamp) > fc::seconds(60) )
{
signed_block next_block;
next_block.number = _current_block.number + 1;
auto next_diff = _current_block.difficulty * 500 / _pending.size();
next_diff = (_current_block.difficulty * 99 + next_diff) / 100;
next_block.difficulty = std::max<uint64_t>(next_diff, 1000 );
next_block.timestamp = fc::time_point::now();
for( auto rec : _pending )
{
next_block.records.push_back( rec.second );
}
next_block.sign( _trustee_key );
_block_database.store(next_block.number,next_block);
for( uint32_t rec = 0; rec < next_block.records.size(); ++rec )
{
auto new_rec = next_block.records[rec];
auto hist = _self->fetch_history( new_rec.name );
hist.updates.push_back( name_index( next_block.number, rec ) );
_name_index.store( new_rec.name, hist );
_key_to_name.store( new_rec.active_key.to_base58(), new_rec.name );
}
_current_block = next_block;
_current_block_id = _current_block.id();
fc::path block_file = _data_dir / "block" / fc::to_string( uint64_t(_current_block.number) );
std::ofstream out( block_file.generic_string().c_str() );
auto block_str = fc::json::to_pretty_string( _current_block );
out.write( block_str.c_str(), block_str.size() );
}
fc::usleep( fc::seconds( 1 ) );
}
}
/* <name> <proc> .makeoperator <oper> */
static int
zmakeoperator(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
op_array_table *opt;
uint count;
ref *tab;
check_type(op[-1], t_name);
check_proc(*op);
switch (r_space(op)) {
case avm_global:
opt = &i_ctx_p->op_array_table_global;
break;
case avm_local:
opt = &i_ctx_p->op_array_table_local;
break;
default:
return_error(e_invalidaccess);
}
count = opt->count;
tab = opt->table.value.refs;
/*
* restore doesn't reset op_array_table.count, but it does
* remove entries from op_array_table.table. Since we fill
* the table in order, we can detect that a restore has occurred
* by checking whether what should be the most recent entry
* is occupied. If not, we scan backwards over the vacated entries
* to find the true end of the table.
*/
while (count > 0 && r_has_type(&tab[count - 1], t_null))
--count;
if (count == r_size(&opt->table))
return_error(e_limitcheck);
ref_assign_old(&opt->table, &tab[count], op, "makeoperator");
opt->nx_table[count] = name_index(imemory, op - 1);
op_index_ref(imemory, opt->base_index + count, op - 1);
opt->count = count + 1;
pop(1);
return 0;
}
/*
* DeviceN and NChannel color spaces can have an attributes dict. In the
* attribute dict can be a Colorants dict which contains Separation color
* spaces. If the Colorant dict is present, the PS logic will build each of
* the Separation color spaces in a temp gstate and then call this procedure
* to attach the Separation color space to the DeviceN color space.
* The parameter to this procedure is a colorant name. The Separation
* color space is in the current (temp) gstate. The DeviceN color space is
* in the next gstate down in the gstate list (pgs->saved).
*/
static int
zattachdevicenattributespace(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
gs_separation_name sep_name;
int code;
/* Pick up the names of the component */
switch (r_type(op)) {
case t_string:
code = name_from_string(imemory, op, op);
if (code < 0)
return code;
/* falls through */
case t_name:
sep_name = name_index(imemory, op);
break;
default:
return_error(e_typecheck);
}
code = gs_attachattributecolorspace(sep_name, igs);
pop(1);
return code;
}
SEXP do_dprior (SEXP object, SEXP params, SEXP log, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int npars, nreps;
SEXP Pnames, F, fn, fcall;
SEXP pompfun;
int *dim;
PROTECT(params = as_matrix(params)); nprotect++;
dim = INTEGER(GET_DIM(params));
npars = dim[0]; nreps = dim[1];
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
// extract the user-defined function
PROTECT(pompfun = GET_SLOT(object,install("dprior"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
// to store results
PROTECT(F = NEW_NUMERIC(nreps)); nprotect++;
// first do setup
switch (mode) {
case Rfun: // use R function
{
SEXP pvec, rho;
double *pp, *ps, *pt;
int j;
// temporary storage
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++;
SET_TAG(fcall,install("log"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
pp = REAL(pvec);
for (j = 0, ps = REAL(params), pt = REAL(F); j < nreps; j++, ps += npars, pt++) {
memcpy(pp,ps,npars*sizeof(double));
*pt = *(REAL(AS_NUMERIC(eval(fcall,rho))));
}
}
break;
case native: // use native routine
{
int give_log, *pidx = 0;
pomp_dprior *ff = NULL;
double *ps, *pt;
int j;
// construct state, parameter, covariate, observable indices
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames"))); nprotect++;
// address of native routine
ff = (pomp_dprior *) R_ExternalPtrAddr(fn);
give_log = *(INTEGER(AS_INTEGER(log)));
R_CheckUserInterrupt(); // check for user interrupt
set_pomp_userdata(fcall);
// loop over replicates
for (j = 0, pt = REAL(F), ps = REAL(params); j < nreps; j++, ps += npars, pt++)
(*ff)(pt,ps,give_log,pidx);
unset_pomp_userdata();
}
break;
default:
error("unrecognized 'mode' slot in 'dprior'");
break;
}
UNPROTECT(nprotect);
return F;
}
static int
zsethalftone5(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
uint count;
gs_halftone_component *phtc;
gs_halftone_component *pc;
int code = 0;
int j;
gs_halftone *pht;
gx_device_halftone *pdht;
ref sprocs[GS_CLIENT_COLOR_MAX_COMPONENTS + 1];
ref tprocs[GS_CLIENT_COLOR_MAX_COMPONENTS + 1];
gs_memory_t *mem;
uint edepth = ref_stack_count(&e_stack);
int npop = 2;
int dict_enum = dict_first(op);
ref rvalue[2];
int cname, colorant_number;
byte * pname;
uint name_size;
int halftonetype, type = 0;
gs_state *pgs = igs;
int space_index = r_space_index(op - 1);
mem = (gs_memory_t *) idmemory->spaces_indexed[space_index];
check_type(*op, t_dictionary);
check_dict_read(*op);
check_type(op[-1], t_dictionary);
check_dict_read(op[-1]);
/*
* We think that Type 2 and Type 4 halftones, like
* screens set by setcolorscreen, adapt automatically to
* the device color space, so we need to mark them
* with a different internal halftone type.
*/
dict_int_param(op - 1, "HalftoneType", 1, 5, 0, &type);
halftonetype = (type == 2 || type == 4)
? ht_type_multiple_colorscreen
: ht_type_multiple;
/* Count how many components that we will actually use. */
for (count = 0; ;) {
bool have_default = false;
/* Move to next element in the dictionary */
if ((dict_enum = dict_next(op, dict_enum, rvalue)) == -1)
break;
/*
* Verify that we have a valid component. We may have a
* /HalfToneType entry.
*/
if (!r_has_type(&rvalue[1], t_dictionary))
continue;
/* Get the name of the component verify that we will use it. */
cname = name_index(mem, &rvalue[0]);
code = gs_get_colorname_string(mem, cname, &pname, &name_size);
if (code < 0)
break;
colorant_number = gs_cname_to_colorant_number(pgs, pname, name_size,
halftonetype);
if (colorant_number < 0)
continue;
else if (colorant_number == GX_DEVICE_COLOR_MAX_COMPONENTS) {
/* If here then we have the "Default" component */
if (have_default)
return_error(e_rangecheck);
have_default = true;
}
count++;
/*
* Check to see if we have already reached the legal number of
* components.
*/
if (count > GS_CLIENT_COLOR_MAX_COMPONENTS + 1) {
code = gs_note_error(e_rangecheck);
break;
}
}
check_estack(5); /* for sampling Type 1 screens */
refset_null(sprocs, count);
refset_null(tprocs, count);
rc_alloc_struct_0(pht, gs_halftone, &st_halftone,
imemory, pht = 0, ".sethalftone5");
phtc = gs_alloc_struct_array(mem, count, gs_halftone_component,
&st_ht_component_element,
".sethalftone5");
rc_alloc_struct_0(pdht, gx_device_halftone, &st_device_halftone,
imemory, pdht = 0, ".sethalftone5");
if (pht == 0 || phtc == 0 || pdht == 0) {
j = 0; /* Quiet the compiler:
gs_note_error isn't necessarily identity,
so j could be left ununitialized. */
code = gs_note_error(e_VMerror);
} else {
dict_enum = dict_first(op);
for (j = 0, pc = phtc; ;) {
int type;
/* Move to next element in the dictionary */
if ((dict_enum = dict_next(op, dict_enum, rvalue)) == -1)
break;
/*
* Verify that we have a valid component. We may have a
* /HalfToneType entry.
*/
if (!r_has_type(&rvalue[1], t_dictionary))
continue;
/* Get the name of the component */
cname = name_index(mem, &rvalue[0]);
code = gs_get_colorname_string(mem, cname, &pname, &name_size);
if (code < 0)
break;
colorant_number = gs_cname_to_colorant_number(pgs, pname, name_size,
halftonetype);
if (colorant_number < 0)
continue; /* Do not use this component */
pc->cname = cname;
pc->comp_number = colorant_number;
/* Now process the component dictionary */
check_dict_read(rvalue[1]);
if (dict_int_param(&rvalue[1], "HalftoneType", 1, 7, 0, &type) < 0) {
code = gs_note_error(e_typecheck);
break;
}
switch (type) {
default:
code = gs_note_error(e_rangecheck);
break;
case 1:
code = dict_spot_params(&rvalue[1], &pc->params.spot,
sprocs + j, tprocs + j);
pc->params.spot.screen.spot_function = spot1_dummy;
pc->type = ht_type_spot;
break;
case 3:
code = dict_threshold_params(&rvalue[1], &pc->params.threshold,
tprocs + j);
pc->type = ht_type_threshold;
break;
case 7:
code = dict_threshold2_params(&rvalue[1], &pc->params.threshold2,
tprocs + j, imemory);
pc->type = ht_type_threshold2;
break;
}
if (code < 0)
break;
pc++;
j++;
}
}
if (code >= 0) {
pht->type = halftonetype;
pht->params.multiple.components = phtc;
pht->params.multiple.num_comp = j;
pht->params.multiple.get_colorname_string = gs_get_colorname_string;
code = gs_sethalftone_prepare(igs, pht, pdht);
}
if (code >= 0) {
/*
* Put the actual frequency and angle in the spot function component dictionaries.
*/
dict_enum = dict_first(op);
for (pc = phtc; ; ) {
/* Move to next element in the dictionary */
if ((dict_enum = dict_next(op, dict_enum, rvalue)) == -1)
break;
/* Verify that we have a valid component */
if (!r_has_type(&rvalue[1], t_dictionary))
continue;
/* Get the name of the component and verify that we will use it. */
cname = name_index(mem, &rvalue[0]);
code = gs_get_colorname_string(mem, cname, &pname, &name_size);
if (code < 0)
break;
colorant_number = gs_cname_to_colorant_number(pgs, pname, name_size,
halftonetype);
if (colorant_number < 0)
continue;
if (pc->type == ht_type_spot) {
code = dict_spot_results(i_ctx_p, &rvalue[1], &pc->params.spot);
if (code < 0)
break;
}
pc++;
}
}
if (code >= 0) {
/*
* Schedule the sampling of any Type 1 screens,
* and any (Type 1 or Type 3) TransferFunctions.
* Save the stack depths in case we have to back out.
*/
uint odepth = ref_stack_count(&o_stack);
ref odict, odict5;
odict = op[-1];
odict5 = *op;
pop(2);
op = osp;
esp += 5;
make_mark_estack(esp - 4, es_other, sethalftone_cleanup);
esp[-3] = odict;
make_istruct(esp - 2, 0, pht);
make_istruct(esp - 1, 0, pdht);
make_op_estack(esp, sethalftone_finish);
for (j = 0; j < count; j++) {
gx_ht_order *porder = NULL;
if (pdht->components == 0)
porder = &pdht->order;
else {
/* Find the component in pdht that matches component j in
the pht; gs_sethalftone_prepare() may permute these. */
int k;
int comp_number = phtc[j].comp_number;
for (k = 0; k < count; k++) {
if (pdht->components[k].comp_number == comp_number) {
porder = &pdht->components[k].corder;
break;
}
}
}
switch (phtc[j].type) {
case ht_type_spot:
code = zscreen_enum_init(i_ctx_p, porder,
&phtc[j].params.spot.screen,
&sprocs[j], 0, 0, space_index);
if (code < 0)
break;
/* falls through */
case ht_type_threshold:
if (!r_has_type(tprocs + j, t__invalid)) {
/* Schedule TransferFunction sampling. */
/****** check_xstack IS WRONG ******/
check_ostack(zcolor_remap_one_ostack);
check_estack(zcolor_remap_one_estack);
code = zcolor_remap_one(i_ctx_p, tprocs + j,
porder->transfer, igs,
zcolor_remap_one_finish);
op = osp;
}
break;
default: /* not possible here, but to keep */
/* the compilers happy.... */
;
}
if (code < 0) { /* Restore the stack. */
ref_stack_pop_to(&o_stack, odepth);
ref_stack_pop_to(&e_stack, edepth);
op = osp;
op[-1] = odict;
*op = odict5;
break;
}
npop = 0;
}
}
if (code < 0) {
gs_free_object(mem, pdht, ".sethalftone5");
gs_free_object(mem, phtc, ".sethalftone5");
gs_free_object(mem, pht, ".sethalftone5");
return code;
}
pop(npop);
return (ref_stack_count(&e_stack) > edepth ? o_push_estack : 0);
}
SEXP do_rmeasure (SEXP object, SEXP x, SEXP times, SEXP params, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs;
SEXP Snames, Pnames, Cnames, Onames;
SEXP cvec, tvec = R_NilValue, xvec = R_NilValue, pvec = R_NilValue;
SEXP fn, fcall, rho = R_NilValue, ans, nm;
SEXP pompfun;
SEXP Y;
int *dim;
int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0;
struct lookup_table covariate_table;
pomp_measure_model_simulator *ff = NULL;
PROTECT(times = AS_NUMERIC(times)); nprotect++;
ntimes = length(times);
if (ntimes < 1)
errorcall(R_NilValue,"in 'rmeasure': length('times') = 0, no work to do");
PROTECT(x = as_state_array(x)); nprotect++;
dim = INTEGER(GET_DIM(x));
nvars = dim[0]; nrepsx = dim[1];
if (ntimes != dim[2])
errorcall(R_NilValue,"in 'rmeasure': length of 'times' and 3rd dimension of 'x' do not agree");
PROTECT(params = as_matrix(params)); nprotect++;
dim = INTEGER(GET_DIM(params));
npars = dim[0]; nrepsp = dim[1];
nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx;
if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0))
errorcall(R_NilValue,"in 'rmeasure': larger number of replicates is not a multiple of smaller");
dim = INTEGER(GET_DIM(GET_SLOT(object,install("data"))));
nobs = dim[0];
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(GET_SLOT(object,install("data"))))); nprotect++;
// set up the covariate table
covariate_table = make_covariate_table(object,&ncovars);
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
{
int dim[3] = {nobs, nreps, ntimes};
const char *dimnm[3] = {"variable","rep","time"};
PROTECT(Y = makearray(3,dim)); nprotect++;
setrownames(Y,Onames,3);
fixdimnames(Y,dimnm,3);
}
// extract the user-defined function
PROTECT(pompfun = GET_SLOT(object,install("rmeasure"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
// first do setup
switch (mode) {
case Rfun: // use R function
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // use native routine
// construct state, parameter, covariate, observable indices
oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++;
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov
break;
}
// now do computations
switch (mode) {
case Rfun: // R function
{
int first = 1;
int use_names = 0;
double *yt = REAL(Y);
double *time = REAL(times);
double *tp = REAL(tvec);
double *cp = REAL(cvec);
double *xp = REAL(xvec);
double *pp = REAL(pvec);
double *xs = REAL(x);
double *ps = REAL(params);
double *ys;
int *posn;
int i, j, k;
for (k = 0; k < ntimes; k++, time++) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
*tp = *time; // copy the time
table_lookup(&covariate_table,*tp,cp); // interpolate the covariates
for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates
// copy the states and parameters into place
for (i = 0; i < nvars; i++) xp[i] = xs[i+nvars*((j%nrepsx)+nrepsx*k)];
for (i = 0; i < npars; i++) pp[i] = ps[i+npars*(j%nrepsp)];
if (first) {
// evaluate the call
PROTECT(ans = eval(fcall,rho)); nprotect++;
if (LENGTH(ans) != nobs) {
errorcall(R_NilValue,"in 'rmeasure': user 'rmeasure' returns a vector of %d observables but %d are expected: compare 'data' slot?",
LENGTH(ans),nobs);
}
// get name information to fix potential alignment problems
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) { // match names against names from data slot
posn = INTEGER(PROTECT(matchnames(Onames,nm,"observables"))); nprotect++;
} else {
posn = 0;
}
ys = REAL(AS_NUMERIC(ans));
first = 0;
} else {
ys = REAL(AS_NUMERIC(eval(fcall,rho)));
}
if (use_names) {
for (i = 0; i < nobs; i++) yt[posn[i]] = ys[i];
} else {
for (i = 0; i < nobs; i++) yt[i] = ys[i];
}
}
}
}
break;
case native: // native routine
{
double *yt = REAL(Y);
double *time = REAL(times);
double *xs = REAL(x);
double *ps = REAL(params);
double *cp = REAL(cvec);
double *xp, *pp;
int j, k;
set_pomp_userdata(fcall);
GetRNGstate();
for (k = 0; k < ntimes; k++, time++) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,*time,cp);
for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates
xp = &xs[nvars*((j%nrepsx)+nrepsx*k)];
pp = &ps[npars*(j%nrepsp)];
(*ff)(yt,xp,pp,oidx,sidx,pidx,cidx,ncovars,cp,*time);
}
}
PutRNGstate();
unset_pomp_userdata();
}
break;
default:
errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov
break;
}
UNPROTECT(nprotect);
return Y;
}
/* The current color space is the alternate space for the separation space. */
static int
zsetseparationspace(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
const ref *pcsa;
gs_color_space *pcs;
gs_color_space * pacs;
ref_colorspace cspace_old;
ref sname, name_none, name_all;
gs_function_t *pfn = NULL;
separation_type sep_type;
int code;
const gs_memory_t * mem = imemory;
/* Verify that we have an array as our input parameter */
check_read_type(*op, t_array);
if (r_size(op) != 4)
return_error(e_rangecheck);
/* The alternate color space has been selected as the current color space */
pacs = gs_currentcolorspace(igs);
if (!pacs->type->can_be_alt_space)
return_error(e_rangecheck);
/*
* pcsa is a pointer to element 1 (2nd element) in the Separation colorspace
* description array. Thus pcsa[2] is element #3 (4th element) which is the
* tint transform.
*/
pcsa = op->value.const_refs + 1;
sname = *pcsa;
switch (r_type(&sname)) {
default:
return_error(e_typecheck);
case t_string:
code = name_from_string(mem, &sname, &sname);
if (code < 0)
return code;
/* falls through */
case t_name:
break;
}
if ((code = name_ref(mem, (const byte *)"All", 3, &name_all, 0)) < 0)
return code;
if ((code = name_ref(mem, (const byte *)"None", 4, &name_none, 0)) < 0)
return code;
sep_type = ( name_eq(&sname, &name_all) ? SEP_ALL :
name_eq(&sname, &name_none) ? SEP_NONE : SEP_OTHER);
/* Check tint transform procedure. */
/* See comment above about psca */
check_proc(pcsa[2]);
pfn = ref_function(pcsa + 2);
if (pfn == NULL)
return_error(e_rangecheck);
cspace_old = istate->colorspace;
/* Now set the current color space as Separation */
code = gs_cspace_new_Separation(&pcs, pacs, imemory);
if (code < 0)
return code;
pcs->params.separation.sep_type = sep_type;
pcs->params.separation.sep_name = name_index(mem, &sname);
pcs->params.separation.get_colorname_string = gs_get_colorname_string;
istate->colorspace.procs.special.separation.layer_name = pcsa[0];
istate->colorspace.procs.special.separation.tint_transform = pcsa[2];
if (code >= 0)
code = gs_cspace_set_sepr_function(pcs, pfn);
if (code >= 0)
code = gs_setcolorspace(igs, pcs);
/* release reference from construction */
rc_decrement_only(pcs, "zsetseparationspace");
if (code < 0) {
istate->colorspace = cspace_old;
return code;
}
pop(1);
return 0;
}
/* ensuring that refs in mixed arrays are properly aligned. */
#undef idmemory /****** NOTA BENE ******/
int
make_packed_array(ref * parr, ref_stack_t * pstack, uint size,
gs_dual_memory_t *idmemory, client_name_t cname)
{
uint i;
const ref *pref;
uint idest = 0, ishort = 0;
ref_packed *pbody;
ref_packed *pdest;
ref_packed *pshort; /* points to start of */
/* last run of short elements */
gs_ref_memory_t *imem = idmemory->current;
uint space = imemory_space(imem);
int skip = 0, pad;
ref rtemp;
int code;
/* Do a first pass to calculate the size of the array, */
/* and to detect local-into-global stores. */
for (i = size; i != 0; i--) {
pref = ref_stack_index(pstack, i - 1);
switch (r_btype(pref)) { /* not r_type, opers are special */
case t_name:
if (name_index(imem, pref) >= packed_name_max_index)
break; /* can't pack */
idest++;
continue;
case t_integer:
if (pref->value.intval < packed_min_intval ||
pref->value.intval > packed_max_intval
)
break;
idest++;
continue;
case t_oparray:
/* Check for local-into-global store. */
store_check_space(space, pref);
/* falls through */
case t_operator:
{
uint oidx;
if (!r_has_attr(pref, a_executable))
break;
oidx = op_index(pref);
if (oidx == 0 || oidx > packed_int_mask)
break;
}
idest++;
continue;
default:
/* Check for local-into-global store. */
store_check_space(space, pref);
}
/* Can't pack this element, use a full ref. */
/* We may have to unpack up to align_packed_per_ref - 1 */
/* preceding short elements. */
/* If we are at the beginning of the array, however, */
/* we can just move the elements up. */
{
int i = (idest - ishort) & (align_packed_per_ref - 1);
if (ishort == 0) /* first time */
idest += skip = -i & (align_packed_per_ref - 1);
else
idest += (packed_per_ref - 1) * i;
}
ishort = idest += packed_per_ref;
}
pad = -(int)idest & (packed_per_ref - 1); /* padding at end */
/* Now we can allocate the array. */
code = gs_alloc_ref_array(imem, &rtemp, 0, (idest + pad) / packed_per_ref,
cname);
if (code < 0)
return code;
pbody = (ref_packed *) rtemp.value.refs;
/* Make sure any initial skipped elements contain legal packed */
/* refs, so that the garbage collector can scan storage. */
pshort = pbody;
for (; skip; skip--)
*pbody++ = pt_tag(pt_integer);
pdest = pbody;
for (i = size; i != 0; i--) {
pref = ref_stack_index(pstack, i - 1);
switch (r_btype(pref)) { /* not r_type, opers are special */
case t_name:
{
uint nidx = name_index(imem, pref);
if (nidx >= packed_name_max_index)
break; /* can't pack */
*pdest++ = nidx +
(r_has_attr(pref, a_executable) ?
pt_tag(pt_executable_name) :
pt_tag(pt_literal_name));
}
continue;
case t_integer:
if (pref->value.intval < packed_min_intval ||
pref->value.intval > packed_max_intval
)
break;
*pdest++ = pt_tag(pt_integer) +
((short)pref->value.intval - packed_min_intval);
continue;
case t_oparray:
case t_operator:
{
uint oidx;
if (!r_has_attr(pref, a_executable))
break;
oidx = op_index(pref);
if (oidx == 0 || oidx > packed_int_mask)
break;
*pdest++ = pt_tag(pt_executable_operator) + oidx;
}
continue;
}
/* Can't pack this element, use a full ref. */
/* We may have to unpack up to align_packed_per_ref - 1 */
/* preceding short elements. */
/* Note that if we are at the beginning of the array, */
/* 'skip' already ensures that we don't need to do this. */
{
int i = (pdest - pshort) & (align_packed_per_ref - 1);
const ref_packed *psrc = pdest;
ref *pmove =
(ref *) (pdest += (packed_per_ref - 1) * i);
ref_assign_new(pmove, pref);
while (--i >= 0) {
--psrc;
--pmove;
packed_get(imem->non_gc_memory, psrc, pmove);
}
}
pshort = pdest += packed_per_ref;
}
{
int atype =
(pdest == pbody + size ? t_shortarray : t_mixedarray);
/* Pad with legal packed refs so that the garbage collector */
/* can scan storage. */
for (; pad; pad--)
*pdest++ = pt_tag(pt_integer);
/* Finally, make the array. */
ref_stack_pop(pstack, size);
make_tasv_new(parr, atype, a_readonly | space, size,
packed, pbody + skip);
}
return 0;
}
SEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi)
{
int nprotect = 0;
SEXP Pnames, Snames;
SEXP x = R_NilValue;
int *dim;
int npar, nrep, nvar, ns;
int definit;
int xdim[2];
const char *dimnms[2] = {"variable","rep"};
ns = *(INTEGER(AS_INTEGER(nsim)));
PROTECT(params = as_matrix(params)); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
dim = INTEGER(GET_DIM(params));
npar = dim[0]; nrep = dim[1];
if (ns % nrep != 0)
errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')");
definit = *(INTEGER(GET_SLOT(object,install("default.init"))));
if (definit) { // default initializer
SEXP fcall, pat, repl, val, ivpnames, statenames;
int *pidx, j, k;
double *xp, *pp;
PROTECT(pat = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(pat,0,mkChar("\\.0$"));
PROTECT(repl = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(repl,0,mkChar(""));
PROTECT(val = NEW_LOGICAL(1)); nprotect++;
*(INTEGER(val)) = 1;
// extract names of IVPs
PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++;
SET_TAG(fcall,install("value"));
PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++;
PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++;
nvar = LENGTH(ivpnames);
if (nvar < 1) {
errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'.");
}
pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++;
for (k = 0; k < nvar; k++) pidx[k]--;
// construct names of state variables
PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(repl,fcall)); nprotect++;
SET_TAG(fcall,install("replacement"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++;
PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++;
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,statenames,2);
fixdimnames(x,dimnms,2);
for (j = 0, xp = REAL(x); j < ns; j++) {
pp = REAL(params) + npar*(j%nrep);
for (k = 0; k < nvar; k++, xp++)
*xp = pp[pidx[k]];
}
} else { // user-supplied initializer
SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue;
pompfunmode mode = undef;
double *cp = NULL;
// extract the initializer function and its environment
PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract covariates and interpolate
PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++;
if (LENGTH(tcovar) > 0) { // do table lookup
PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++;
PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++;
cp = REAL(covars);
}
// extract userdata
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
switch (mode) {
case Rfun: // use R function
{
SEXP par, rho, x1, x2;
double *p, *pp, *xp, *xt;
int j, *midx;
// extract covariates and interpolate
if (LENGTH(tcovar) > 0) { // add covars to call
PROTECT(fcall = LCONS(covars,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
}
// parameter vector
PROTECT(par = NEW_NUMERIC(npar)); nprotect++;
SET_NAMES(par,Pnames);
pp = REAL(par);
// finish constructing the call
PROTECT(fcall = LCONS(t0,fcall)); nprotect++;
SET_TAG(fcall,install("t0"));
PROTECT(fcall = LCONS(par,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// evaluation environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
p = REAL(params);
memcpy(pp,p,npar*sizeof(double)); // copy the parameters
PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call
PROTECT(Snames = GET_NAMES(x1)); nprotect++;
if (!IS_NUMERIC(x1) || isNull(Snames)) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector");
}
nvar = LENGTH(x1);
xp = REAL(x1);
midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++;
for (j = 0; j < nvar; j++) {
if (midx[j]!=0) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j)));
}
}
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
xt = REAL(x);
memcpy(xt,xp,nvar*sizeof(double));
for (j = 1, xt += nvar; j < ns; j++, xt += nvar) {
memcpy(pp,p+npar*(j%nrep),npar*sizeof(double));
PROTECT(x2 = eval(fcall,rho));
xp = REAL(x2);
if (LENGTH(x2)!=nvar)
errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length");
memcpy(xt,xp,nvar*sizeof(double));
UNPROTECT(1);
}
}
break;
case native: // use native routine
{
SEXP Cnames;
int *sidx, *pidx, *cidx;
double *xt, *ps, time;
pomp_initializer *ff = NULL;
int j;
PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
// construct state, parameter, covariate, observable indices
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
nvar = LENGTH(Snames);
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
set_pomp_userdata(fcall);
GetRNGstate();
time = *(REAL(t0));
// loop over replicates
for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar)
(*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp);
PutRNGstate();
unset_pomp_userdata();
}
break;
default:
errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov
break;
}
}
UNPROTECT(nprotect);
return x;
}
/*
* Look up a name on the dictionary stack.
* Return the pointer to the value if found, 0 if not.
*/
ref *
dstack_find_name_by_index(dict_stack_t * pds, uint nidx)
{
ds_ptr pdref = pds->stack.p;
/* Since we know the hash function is the identity function, */
/* there's no point in allocating a separate variable for it. */
#define hash dict_name_index_hash(nidx)
ref_packed kpack = packed_name_key(nidx);
do {
dict *pdict = pdref->value.pdict;
uint size = npairs(pdict);
const gs_memory_t *mem = dict_mem(pdict);
#ifdef DEBUG
if (gs_debug_c('D')) {
ref dnref;
name_index_ref(mem, nidx, &dnref);
dlputs("[D]lookup ");
debug_print_name(mem, &dnref);
dprintf3(" in 0x%lx(%u/%u)\n",
(ulong) pdict, dict_length(pdref),
dict_maxlength(pdref));
}
#endif
#define INCR_DEPTH(pdref)\
INCR(depth[min(MAX_STATS_DEPTH, pds->stack.p - pdref)])
if (dict_is_packed(pdict)) {
packed_search_1(INCR_DEPTH(pdref),
return packed_search_value_pointer,
DO_NOTHING, goto miss);
packed_search_2(INCR_DEPTH(pdref),
return packed_search_value_pointer,
DO_NOTHING, break);
miss:;
} else {
ref *kbot = pdict->keys.value.refs;
register ref *kp;
int wrap = 0;
/* Search the dictionary */
for (kp = kbot + dict_hash_mod(hash, size) + 2;;) {
--kp;
if (r_has_type(kp, t_name)) {
if (name_index(mem, kp) == nidx) {
INCR_DEPTH(pdref);
return pdict->values.value.refs + (kp - kbot);
}
} else if (r_has_type(kp, t_null)) { /* Empty, deleted, or wraparound. */
/* Figure out which. */
if (!r_has_attr(kp, a_executable))
break;
if (kp == kbot) { /* wrap */
if (wrap++)
break; /* 2 wraps */
kp += size + 1;
}
}
}
}
#undef INCR_DEPTH
}
SEXP do_partrans (SEXP object, SEXP params, SEXP dir, SEXP gnsi)
{
int nprotect = 0;
SEXP fn, fcall, rho, ans, nm;
SEXP pdim, pvec;
SEXP pompfun;
SEXP tparams = R_NilValue;
pompfunmode mode = undef;
char direc;
int qmat;
int ndim[2], *dim, *idx;
double *pp, *ps, *pt, *pa;
int npar1, npar2, nreps;
pomp_transform_fn *ff = NULL;
int k;
direc = *(INTEGER(dir));
// extract the user-defined function
switch (direc) {
case 1: // forward transformation
PROTECT(pompfun = GET_SLOT(object,install("from.trans"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
break;
case -1: // inverse transformation
PROTECT(pompfun = GET_SLOT(object,install("to.trans"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
break;
default:
error("impossible error");
break;
}
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
PROTECT(pdim = GET_DIM(params)); nprotect++;
if (isNull(pdim)) { // a single vector
npar1 = LENGTH(params); nreps = 1;
qmat = 0;
} else { // a parameter matrix
dim = INTEGER(pdim);
npar1 = dim[0]; nreps = dim[1];
qmat = 1;
}
switch (mode) {
case Rfun: // use user-supplied R function
// set up the function call
if (qmat) { // matrix case
PROTECT(pvec = NEW_NUMERIC(npar1)); nprotect++;
SET_NAMES(pvec,GET_ROWNAMES(GET_DIMNAMES(params)));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
} else { // vector case
PROTECT(fcall = LCONS(params,fcall)); nprotect++;
}
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
if (qmat) { // matrix case
const char *dimnm[2] = {"variable","rep"};
ps = REAL(params);
pp = REAL(pvec);
memcpy(pp,ps,npar1*sizeof(double));
PROTECT(ans = eval(fcall,rho)); nprotect++;
PROTECT(nm = GET_NAMES(ans)); nprotect++;
if (isNull(nm))
error("user transformation functions must return a named numeric vector");
// set up matrix to hold the results
npar2 = LENGTH(ans);
ndim[0] = npar2; ndim[1] = nreps;
PROTECT(tparams = makearray(2,ndim)); nprotect++;
setrownames(tparams,nm,2);
fixdimnames(tparams,dimnm,2);
pt = REAL(tparams);
pa = REAL(AS_NUMERIC(ans));
memcpy(pt,pa,npar2*sizeof(double));
ps += npar1;
pt += npar2;
for (k = 1; k < nreps; k++, ps += npar1, pt += npar2) {
memcpy(pp,ps,npar1*sizeof(double));
pa = REAL(AS_NUMERIC(eval(fcall,rho)));
memcpy(pt,pa,npar2*sizeof(double));
}
} else { // vector case
PROTECT(tparams = eval(fcall,rho)); nprotect++;
if (isNull(GET_NAMES(tparams)))
error("user transformation functions must return a named numeric vector");
}
break;
case native: // use native routine
ff = (pomp_transform_fn *) R_ExternalPtrAddr(fn);
if (qmat) {
idx = INTEGER(PROTECT(name_index(GET_ROWNAMES(GET_DIMNAMES(params)),pompfun,"paramnames"))); nprotect++;
} else {
idx = INTEGER(PROTECT(name_index(GET_NAMES(params),pompfun,"paramnames"))); nprotect++;
}
set_pomp_userdata(fcall);
PROTECT(tparams = duplicate(params)); nprotect++;
for (k = 0, ps = REAL(params), pt = REAL(tparams); k < nreps; k++, ps += npar1, pt += npar1) {
R_CheckUserInterrupt();
(*ff)(pt,ps,idx);
}
unset_pomp_userdata();
break;
default:
error("unrecognized 'mode' slot in 'partrans'");
}
UNPROTECT(nprotect);
return tparams;
}
SEXP do_dmeasure (SEXP object, SEXP y, SEXP x, SEXP times, SEXP params, SEXP log, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int give_log;
int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs;
SEXP Snames, Pnames, Cnames, Onames;
SEXP pompfun;
SEXP cvec, tvec = R_NilValue;
SEXP xvec = R_NilValue, yvec = R_NilValue, pvec = R_NilValue;
SEXP fn, ans, fcall, rho = R_NilValue;
SEXP F;
int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0;
int *dim;
struct lookup_table covariate_table;
pomp_measure_model_density *ff = NULL;
PROTECT(times = AS_NUMERIC(times)); nprotect++;
ntimes = length(times);
if (ntimes < 1)
errorcall(R_NilValue,"in 'dmeasure': length('times') = 0, no work to do");
PROTECT(y = as_matrix(y)); nprotect++;
dim = INTEGER(GET_DIM(y));
nobs = dim[0];
if (ntimes != dim[1])
errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 2nd dimension of 'y' do not agree");
PROTECT(x = as_state_array(x)); nprotect++;
dim = INTEGER(GET_DIM(x));
nvars = dim[0]; nrepsx = dim[1];
if (ntimes != dim[2])
errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 3rd dimension of 'x' do not agree");
PROTECT(params = as_matrix(params)); nprotect++;
dim = INTEGER(GET_DIM(params));
npars = dim[0]; nrepsp = dim[1];
nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx;
if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0))
errorcall(R_NilValue,"in 'dmeasure': larger number of replicates is not a multiple of smaller");
PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(y))); nprotect++;
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
give_log = *(INTEGER(AS_INTEGER(log)));
// set up the covariate table
covariate_table = make_covariate_table(object,&ncovars);
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
// extract the user-defined function
PROTECT(pompfun = GET_SLOT(object,install("dmeasure"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
// first do setup
switch (mode) {
case Rfun: // R function
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(yvec = NEW_NUMERIC(nobs)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(yvec,Onames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++;
SET_TAG(fcall,install("log"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(yvec,fcall)); nprotect++;
SET_TAG(fcall,install("y"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // native code
// construct state, parameter, covariate, observable indices
oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++;
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov
break;
}
// create array to store results
{
int dim[2] = {nreps, ntimes};
const char *dimnm[2] = {"rep","time"};
PROTECT(F = makearray(2,dim)); nprotect++;
fixdimnames(F,dimnm,2);
}
// now do computations
switch (mode) {
case Rfun: // R function
{
int first = 1;
double *ys = REAL(y);
double *xs = REAL(x);
double *ps = REAL(params);
double *cp = REAL(cvec);
double *tp = REAL(tvec);
double *xp = REAL(xvec);
double *yp = REAL(yvec);
double *pp = REAL(pvec);
double *ft = REAL(F);
double *time = REAL(times);
int j, k;
for (k = 0; k < ntimes; k++, time++, ys += nobs) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
*tp = *time; // copy the time
table_lookup(&covariate_table,*time,cp); // interpolate the covariates
memcpy(yp,ys,nobs*sizeof(double));
for (j = 0; j < nreps; j++, ft++) { // loop over replicates
// copy the states and parameters into place
memcpy(xp,&xs[nvars*((j%nrepsx)+nrepsx*k)],nvars*sizeof(double));
memcpy(pp,&ps[npars*(j%nrepsp)],npars*sizeof(double));
if (first) {
// evaluate the call
PROTECT(ans = eval(fcall,rho)); nprotect++;
if (LENGTH(ans) != 1)
errorcall(R_NilValue,"in 'dmeasure': user 'dmeasure' returns a vector of length %d when it should return a scalar",LENGTH(ans));
*ft = *(REAL(AS_NUMERIC(ans)));
first = 0;
} else {
*ft = *(REAL(AS_NUMERIC(eval(fcall,rho))));
}
}
}
}
break;
case native: // native code
set_pomp_userdata(fcall);
{
double *yp = REAL(y);
double *xs = REAL(x);
double *ps = REAL(params);
double *cp = REAL(cvec);
double *ft = REAL(F);
double *time = REAL(times);
double *xp, *pp;
int j, k;
for (k = 0; k < ntimes; k++, time++, yp += nobs) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,*time,cp);
for (j = 0; j < nreps; j++, ft++) { // loop over replicates
xp = &xs[nvars*((j%nrepsx)+nrepsx*k)];
pp = &ps[npars*(j%nrepsp)];
(*ff)(ft,yp,xp,pp,give_log,oidx,sidx,pidx,cidx,ncovars,cp,*time);
}
}
}
unset_pomp_userdata();
break;
default:
errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov
break;
}
UNPROTECT(nprotect);
return F;
}
// name
Symbol* name() const { return constants()->symbol_at(name_index()); }
/*
* Look up a key in a dictionary. Store a pointer to the value slot
* where found, or to the (value) slot for inserting.
* See idict.h for the possible return values.
*/
int
dict_find(const ref * pdref, const ref * pkey,
ref ** ppvalue /* result is stored here */ )
{
dict *pdict = pdref->value.pdict;
uint size = npairs(pdict);
register int etype;
uint nidx;
ref_packed kpack;
uint hash;
int ktype;
const gs_memory_t *mem = dict_mem(pdict);
/* Compute hash. The only types we bother with are strings, */
/* names, and (unlikely, but worth checking for) integers. */
switch (r_type(pkey)) {
case t_name:
nidx = name_index(mem, pkey);
nh:
hash = dict_name_index_hash(nidx);
kpack = packed_name_key(nidx);
ktype = t_name;
break;
case t_string: /* convert to a name first */
{
ref nref;
int code;
if (!r_has_attr(pkey, a_read))
return_error(gs_error_invalidaccess);
code = name_ref(mem, pkey->value.bytes, r_size(pkey), &nref, 1);
if (code < 0)
return code;
nidx = name_index(mem, &nref);
}
goto nh;
case t_real:
/*
* Make sure that equal reals and integers hash the same.
*/
{
int expt, i;
double mant = frexp(pkey->value.realval, &expt);
/*
* The value is mant * 2^expt, where 0.5 <= mant < 1,
* or else expt == mant == 0.
*/
if (expt < sizeof(long) * 8 || pkey->value.realval == min_long)
i = (int)pkey->value.realval;
else
i = (int)(mant * min_long); /* MSVC 6.00.8168.0 cannot compile this */
hash = (uint)i * 30503; /* with -O2 as a single expression */
}
goto ih;
case t_integer:
hash = (uint)pkey->value.intval * 30503;
ih:
kpack = packed_key_impossible;
ktype = -1;
nidx = 0; /* only to pacify gcc */
break;
case t_null: /* not allowed as a key */
return_error(gs_error_typecheck);
default:
hash = r_btype(pkey) * 99; /* yech */
kpack = packed_key_impossible;
ktype = -1;
nidx = 0; /* only to pacify gcc */
}
/* Search the dictionary */
if (dict_is_packed(pdict)) {
const ref_packed *pslot = 0;
# define found *ppvalue = packed_search_value_pointer; return 1
# define deleted if (pslot == 0) pslot = kp
# define missing goto miss
# include "idicttpl.h"
# undef missing
# undef deleted
# undef found
/*
* Double wraparound, dict is full.
* Note that even if there was an empty slot (pslot != 0),
* we must return dictfull if length = maxlength.
*/
if (pslot == 0 || d_length(pdict) == d_maxlength(pdict))
return_error(gs_error_dictfull);
*ppvalue = pdict->values.value.refs + (pslot - kbot);
return 0;
miss: /* Key is missing, not double wrap. See above re dictfull. */
if (d_length(pdict) == d_maxlength(pdict))
return_error(gs_error_dictfull);
if (pslot == 0)
pslot = kp;
*ppvalue = pdict->values.value.refs + (pslot - kbot);
return 0;
} else {
ref *kbot = pdict->keys.value.refs;
register ref *kp;
ref *pslot = 0;
int wrap = 0;
for (kp = kbot + dict_hash_mod(hash, size) + 2;;) {
--kp;
if ((etype = r_type(kp)) == ktype) { /* Fast comparison if both keys are names */
if (name_index(mem, kp) == nidx) {
*ppvalue = pdict->values.value.refs + (kp - kbot);
return 1;
}
} else if (etype == t_null) { /* Empty, deleted, or wraparound. */
/* Figure out which. */
if (kp == kbot) { /* wrap */
if (wrap++) { /* wrapped twice */
if (pslot == 0)
return_error(gs_error_dictfull);
break;
}
kp += size + 1;
} else if (r_has_attr(kp, a_executable)) { /* Deleted entry, save the slot. */
if (pslot == 0)
pslot = kp;
} else /* key not found */
break;
} else {
if (obj_eq(mem, kp, pkey)) {
*ppvalue = pdict->values.value.refs + (kp - kbot);
return 1;
}
}
}
if (d_length(pdict) == d_maxlength(pdict))
return_error(gs_error_dictfull);
*ppvalue = pdict->values.value.refs +
((pslot != 0 ? pslot : kp) - kbot);
return 0;
}
}
/*
* Enter a key-value pair in a dictionary.
* See idict.h for the possible return values.
*/
int
dict_put(ref * pdref /* t_dictionary */ , const ref * pkey, const ref * pvalue,
dict_stack_t *pds)
{
dict *pdict = pdref->value.pdict;
gs_ref_memory_t *mem = dict_memory(pdict);
gs_memory_t *pmem = dict_mem(pdict);
int rcode = 0;
int code;
ref *pvslot, kname;
/* Check the value. */
store_check_dest(pdref, pvalue);
top:if ((code = dict_find(pdref, pkey, &pvslot)) <= 0) { /* not found *//* Check for overflow */
uint index;
switch (code) {
case 0:
break;
case gs_error_dictfull:
if (!pmem->gs_lib_ctx->dict_auto_expand)
return_error(gs_error_dictfull);
code = dict_grow(pdref, pds);
if (code < 0)
return code;
goto top; /* keep things simple */
default: /* gs_error_typecheck */
return code;
}
index = pvslot - pdict->values.value.refs;
/* If the key is a string, convert it to a name. */
if (r_has_type(pkey, t_string)) {
int code;
if (!r_has_attr(pkey, a_read))
return_error(gs_error_invalidaccess);
code = name_from_string(pmem, pkey, &kname);
if (code < 0)
return code;
pkey = &kname;
}
if (dict_is_packed(pdict)) {
ref_packed *kp;
if (!r_has_type(pkey, t_name) ||
name_index(pmem, pkey) > packed_name_max_index
) { /* Change to unpacked representation. */
int code = dict_unpack(pdref, pds);
if (code < 0)
return code;
goto top;
}
kp = pdict->keys.value.writable_packed + index;
if (ref_must_save_in(mem, &pdict->keys)) { /* See initial comment for why it is safe */
/* not to save the change if the keys */
/* array itself is new. */
ref_do_save_in(mem, &pdict->keys, kp, "dict_put(key)");
}
*kp = pt_tag(pt_literal_name) + name_index(pmem, pkey);
} else {
ref *kp = pdict->keys.value.refs + index;
if_debug2m('d', (const gs_memory_t *)mem, "[d]0x%lx: fill key at 0x%lx\n",
(ulong) pdict, (ulong) kp);
store_check_dest(pdref, pkey);
ref_assign_old_in(mem, &pdict->keys, kp, pkey,
"dict_put(key)"); /* set key of pair */
}
ref_save_in(mem, pdref, &pdict->count, "dict_put(count)");
pdict->count.value.intval++;
/* If the key is a name, update its 1-element cache. */
if (r_has_type(pkey, t_name)) {
name *pname = pkey->value.pname;
if (pname->pvalue == pv_no_defn &&
CAN_SET_PVALUE_CACHE(pds, pdref, mem)
) { /* Set the cache. */
if_debug0m('d', (const gs_memory_t *)mem, "[d]set cache\n");
pname->pvalue = pvslot;
} else { /* The cache can't be used. */
if_debug0m('d', (const gs_memory_t *)mem, "[d]no cache\n");
pname->pvalue = pv_other;
}
}
rcode = 1;
}
if_debug8m('d', (const gs_memory_t *)mem,
"[d]0x%lx: put key 0x%lx 0x%lx\n value at 0x%lx: old 0x%lx 0x%lx, new 0x%lx 0x%lx\n",
(ulong) pdref->value.pdict,
((const ulong *)pkey)[0], ((const ulong *)pkey)[1],
(ulong) pvslot,
((const ulong *)pvslot)[0], ((const ulong *)pvslot)[1],
((const ulong *)pvalue)[0], ((const ulong *)pvalue)[1]);
ref_assign_old_in(mem, &pdref->value.pdict->values, pvslot, pvalue,
"dict_put(value)");
return rcode;
}
/* The current color space is the alternate space for the DeviceN space. */
static int
zsetdevicenspace(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
const ref *pcsa;
gs_separation_name *names;
gs_device_n_map *pmap;
uint num_components;
gs_color_space *pcs;
gs_color_space *pacs;
ref_colorspace cspace_old;
gs_function_t *pfn;
int code;
/* Verify that we have an array as our input parameter */
check_read_type(*op, t_array);
if (r_size(op) < 4 || r_size(op) > 5)
return_error(e_rangecheck);
/* pcsa is a pointer to the color names array (element 1 in input array) */
pcsa = op->value.const_refs + 1;
if (!r_is_array(pcsa))
return_error(e_typecheck);
num_components = r_size(pcsa);
if (num_components == 0)
return_error(e_rangecheck);
if (num_components > GS_CLIENT_COLOR_MAX_COMPONENTS)
return_error(e_limitcheck);
/* Check tint transform procedure. Note: Cheap trick to get pointer to it.
The tint transform procedure is element 3 in the input array */
check_proc(pcsa[2]);
/* The alternate color space has been selected as the current color space */
pacs = gs_currentcolorspace(igs);
code = gs_cspace_new_DeviceN(&pcs, num_components, pacs, imemory);
if (code < 0)
return code;
names = pcs->params.device_n.names;
pmap = pcs->params.device_n.map;
pcs->params.device_n.get_colorname_string = gs_get_colorname_string;
/* Pick up the names of the components */
{
uint i;
ref sname;
for (i = 0; i < num_components; ++i) {
array_get(imemory, pcsa, (long)i, &sname);
switch (r_type(&sname)) {
case t_string:
code = name_from_string(imemory, &sname, &sname);
if (code < 0) {
rc_decrement(pcs, ".setdevicenspace");
return code;
}
/* falls through */
case t_name:
names[i] = name_index(imemory, &sname);
break;
default:
rc_decrement(pcs, ".setdevicenspace");
return_error(e_typecheck);
}
}
}
/* Now set the current color space as DeviceN */
cspace_old = istate->colorspace;
/*
* pcsa is a pointer to element 1 (2nd element) in the DeviceN
* description array. Thus pcsa[2] is element #3 (4th element)
* which is the tint transform.
*/
istate->colorspace.procs.special.device_n.layer_names = pcsa[0];
istate->colorspace.procs.special.device_n.tint_transform = pcsa[2];
pfn = ref_function(pcsa + 2); /* See comment above */
if (!pfn)
code = gs_note_error(e_rangecheck);
if (code < 0) {
istate->colorspace = cspace_old;
rc_decrement_only(pcs, "zsetdevicenspace");
return code;
}
gs_cspace_set_devn_function(pcs, pfn);
code = gs_setcolorspace(igs, pcs);
/* release reference from construction */
rc_decrement_only(pcs, "zsetdevicenspace");
if (code < 0) {
istate->colorspace = cspace_old;
return code;
}
pop(1);
return 0;
}
