/* <string> .pcachequery false */
static int
zpcachequery(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
int len;
char *key;
byte *string;
int code = 0;
check_read_type(*op, t_string);
len = r_size(op);
key = op->value.bytes;
len = gp_cache_query(GP_CACHE_TYPE_TEST, key, len, (void**)&string, &pcache_alloc_callback, i_ctx_p);
if (len < 0) {
make_false(op);
return 0;
}
if (string == NULL)
return_error(e_VMerror);
make_string(op, a_all | icurrent_space, len, string);
push(1);
make_true(op);
return code;
}
/* - .defaultpapersize false */
static int
zdefaultpapersize(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
byte *value;
int len = 0;
if (gp_defaultpapersize((char *)0, &len) > 0) {
/* no default paper size */
push(1);
make_false(op);
return 0;
}
value = ialloc_string(len, "defaultpapersize value");
if (value == 0) {
return_error(e_VMerror);
}
DISCARD(gp_defaultpapersize((char *)value, &len)); /* can't fail */
/* Delete the stupid C string terminator. */
value = iresize_string(value, len, len - 1,
"defaultpapersize value"); /* can't fail */
push(2);
make_string(op - 1, a_all | icurrent_space, len - 1, value);
make_true(op);
return 0;
}
/* <int> .oserrorstring false */
static int
zoserrorstring(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
const char *str;
int code;
uint len;
byte ch;
check_type(*op, t_integer);
str = gp_strerror((int)op->value.intval);
if (str == 0 || (len = strlen(str)) == 0) {
make_false(op);
return 0;
}
check_ostack(1);
code = string_to_ref(str, op, iimemory, ".oserrorstring");
if (code < 0)
return code;
/* Strip trailing end-of-line characters. */
while ((len = r_size(op)) != 0 &&
((ch = op->value.bytes[--len]) == '\r' || ch == '\n')
)
r_dec_size(op, 1);
push(1);
make_true(op);
return 0;
}
/* <file> .filename false */
static int
zfilename(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
stream *s;
gs_const_string fname;
byte *str;
check_file(s, op);
if (sfilename(s, &fname) < 0) {
make_false(op);
return 0;
}
check_ostack(1);
str = ialloc_string(fname.size, "filename");
if (str == 0)
return_error(e_VMerror);
memcpy(str, fname.data, fname.size);
push(1); /* can't fail */
make_const_string( op - 1 ,
a_all | imemory_space((const struct gs_ref_memory_s*) imemory),
fname.size,
str);
make_true(op);
return 0;
}
/* <string> getenv false */
static int
zgetenv(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
char *str;
byte *value;
int len = 0;
check_read_type(*op, t_string);
str = ref_to_string(op, imemory, "getenv key");
if (str == 0)
return_error(e_VMerror);
if (gp_getenv(str, (char *)0, &len) > 0) { /* key missing */
ifree_string((byte *) str, r_size(op) + 1, "getenv key");
make_false(op);
return 0;
}
value = ialloc_string(len, "getenv value");
if (value == 0) {
ifree_string((byte *) str, r_size(op) + 1, "getenv key");
return_error(e_VMerror);
}
DISCARD(gp_getenv(str, (char *)value, &len)); /* can't fail */
ifree_string((byte *) str, r_size(op) + 1, "getenv key");
/* Delete the stupid C string terminator. */
value = iresize_string(value, len, len - 1,
"getenv value"); /* can't fail */
push(1);
make_string(op - 1, a_all | icurrent_space, len - 1, value);
make_true(op);
return 0;
}
/* <key> where false */
int
zwhere(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
ref_stack_enum_t rsenum;
check_op(1);
ref_stack_enum_begin(&rsenum, &d_stack);
do {
const ref *const bot = rsenum.ptr;
const ref *pdref = bot + rsenum.size;
ref *pvalue;
int code;
while (pdref-- > bot) {
check_dict_read(*pdref);
code = dict_find(pdref, op, &pvalue);
if (code < 0 && code != e_dictfull)
return code;
if (code > 0) {
push(1);
ref_assign(op - 1, pdref);
make_true(op);
return 0;
}
}
} while (ref_stack_enum_next(&rsenum));
make_false(op);
return 0;
}
/* <string> .libfile <string> false */
int /* exported for zsysvm.c */
zlibfile(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
int code;
byte cname[DEFAULT_BUFFER_SIZE];
uint clen;
gs_parsed_file_name_t pname;
stream *s;
gx_io_device *iodev_dflt;
check_ostack(2);
code = parse_file_name(op, &pname, i_ctx_p->LockFilePermissions, imemory);
if (code < 0)
return code;
iodev_dflt = iodev_default(imemory);
if (pname.iodev == NULL)
pname.iodev = iodev_dflt;
if (pname.iodev != iodev_dflt) { /* Non-OS devices don't have search paths (yet). */
code = zopen_file(i_ctx_p, &pname, "r", &s, imemory);
if (code >= 0) {
code = ssetfilename(s, op->value.const_bytes, r_size(op));
if (code < 0) {
sclose(s);
return_error(e_VMerror);
}
}
if (code < 0) {
push(1);
make_false(op);
return 0;
}
make_stream_file(op, s, "r");
} else {
ref fref;
code = lib_file_open(i_ctx_p->lib_path, imemory, i_ctx_p, pname.fname, pname.len,
(char *)cname, sizeof(cname), &clen, &fref);
if (code >= 0) {
s = fptr(&fref);
code = ssetfilename(s, cname, clen);
if (code < 0) {
sclose(s);
return_error(e_VMerror);
}
}
if (code < 0) {
if (code == e_VMerror || code == e_invalidfileaccess)
return code;
push(1);
make_false(op);
return 0;
}
ref_assign(op, &fref);
}
push(1);
make_true(op);
return 0;
}
int
ztoken(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
switch (r_type(op)) {
default:
return_op_typecheck(op);
case t_file: {
stream *s;
scanner_state state;
check_read_file(i_ctx_p, s, op);
check_ostack(1);
gs_scanner_init(&state, op);
return token_continue(i_ctx_p, &state, true);
}
case t_string: {
ref token;
/* -1 is to remove the string operand in case of error. */
int orig_ostack_depth = ref_stack_count(&o_stack) - 1;
int code;
/* Don't pop the operand in case of invalidaccess. */
if (!r_has_attr(op, a_read))
return_error(e_invalidaccess);
code = gs_scan_string_token(i_ctx_p, op, &token);
switch (code) {
case scan_EOF: /* no tokens */
make_false(op);
return 0;
default:
if (code < 0) {
/*
* Clear anything that may have been left on the ostack,
* including the string operand.
*/
if (orig_ostack_depth < ref_stack_count(&o_stack))
pop(ref_stack_count(&o_stack)- orig_ostack_depth);
return code;
}
}
push(2);
op[-1] = token;
make_true(op);
return 0;
}
}
}
/* - .currentpagedevice <dict> <bool> */
static int
zcurrentpagedevice(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
gx_device *dev = gs_currentdevice(igs);
push(2);
if ((*dev_proc(dev, get_page_device))(dev) != 0) {
op[-1] = istate->pagedevice;
make_true(op);
} else {
make_null(op - 1);
make_false(op);
}
return 0;
}
/* - .currentshowpagecount false */
static int
zcurrentshowpagecount(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
gx_device *dev = gs_currentdevice(igs);
if ((*dev_proc(dev, get_page_device))(dev) == 0) {
push(1);
make_false(op);
} else {
push(2);
make_int(op - 1, dev->ShowpageCount);
make_true(op);
}
return 0;
}
/* <mask> .instopped <result> true */
static int
zinstopped(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
uint count;
check_type(*op, t_integer);
count = count_to_stopped(i_ctx_p, op->value.intval);
if (count) {
push(1);
op[-1] = *ref_stack_index(&e_stack, count - 2); /* default result */
make_true(op);
} else
make_false(op);
return 0;
}
/* Common code for token reading. */
static int
token_continue(i_ctx_t *i_ctx_p, scanner_state * pstate, bool save)
{
os_ptr op = osp;
int code;
ref token;
/* Note that gs_scan_token may change osp! */
pop(1); /* remove the file or scanner state */
again:
code = gs_scan_token(i_ctx_p, &token, pstate);
op = osp;
switch (code) {
default: /* error */
if (code > 0) /* comment, not possible */
code = gs_note_error(e_syntaxerror);
gs_scanner_error_object(i_ctx_p, pstate, &i_ctx_p->error_object);
break;
case scan_BOS:
code = 0;
case 0: /* read a token */
push(2);
ref_assign(op - 1, &token);
make_true(op);
break;
case scan_EOF: /* no tokens */
push(1);
make_false(op);
code = 0;
break;
case scan_Refill: /* need more data */
code = gs_scan_handle_refill(i_ctx_p, pstate, save,
ztoken_continue);
switch (code) {
case 0: /* state is not copied to the heap */
goto again;
case o_push_estack:
return code;
}
break; /* error */
}
if (code <= 0 && !save) { /* Deallocate the scanner state record. */
ifree_object(pstate, "token_continue");
}
return code;
}
/* <dict> <key> .knownget false */
static int
zknownget(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
register os_ptr op1 = op - 1;
ref *pvalue;
check_type(*op1, t_dictionary);
check_dict_read(*op1);
if (dict_find(op1, op, &pvalue) <= 0) {
make_false(op1);
pop(1);
} else {
ref_assign(op1, pvalue);
make_true(op);
}
return 0;
}
/* [<req_x> <req_y>] [<med_x0> <med_y0> (<med_x1> <med_y1> | )]
* <policy> <orient|null> <roll> <matrix|null> .matchpagesize
* <matrix|null> <med_x> <med_y> true -or- false
*/
static int
zmatchpagesize(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
gs_matrix mat;
float ignore_mismatch = (float)max_long;
gs_point media_size;
int orient;
bool roll;
int code;
check_type(op[-3], t_integer);
if (r_has_type(op - 2, t_null))
orient = -1;
else {
check_int_leu(op[-2], 3);
orient = (int)op[-2].value.intval;
}
check_type(op[-1], t_boolean);
roll = op[-1].value.boolval;
code = zmatch_page_size(imemory,
op - 5, op - 4, (int)op[-3].value.intval,
orient, roll,
&ignore_mismatch, &mat, &media_size);
switch (code) {
default:
return code;
case 0:
make_false(op - 5);
pop(5);
break;
case 1:
code = write_matrix(op, &mat);
if (code < 0 && !r_has_type(op, t_null))
return code;
op[-5] = *op;
make_real(op - 4, media_size.x);
make_real(op - 3, media_size.y);
make_true(op - 2);
pop(2);
break;
}
return 0;
}
/* convenience of reusing procedures that take 1 state parameter */
static int
zreadhexstring_at(i_ctx_t *i_ctx_p, os_ptr op, uint start, int odd)
{
stream *s;
uint len, nread;
byte *str;
int odd_byte = odd;
stream_cursor_write cw;
int status;
check_read_file(s, op - 1);
/*check_write_type(*op, t_string); *//* done by caller */
str = op->value.bytes;
len = r_size(op);
cw.ptr = str + start - 1;
cw.limit = str + len - 1;
for (;;) {
status = s_hex_process(&s->cursor.r, &cw, &odd_byte,
hex_ignore_garbage);
if (status == 1) { /* filled the string */
ref_assign_inline(op - 1, op);
make_true(op);
return 0;
} else if (status != 0) /* error or EOF */
break;
/* Didn't fill, keep going. */
status = spgetc(s);
if (status < 0)
break;
sputback(s);
}
nread = cw.ptr + 1 - str;
if (status != EOFC) { /* Error */
nread |= odd_byte << 24;
return handle_read_status(i_ctx_p, status, op - 1, &nread,
zreadhexstring_continue);
}
/* Reached end-of-file before filling the string. */
/* Return an appropriate substring. */
ref_assign_inline(op - 1, op);
r_set_size(op - 1, nread);
make_false(op);
return 0;
}
/* <string> <pattern> search <string> -false- */
static int
zsearch(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
os_ptr op1 = op - 1;
uint size = r_size(op);
uint count;
byte *pat;
byte *ptr;
byte ch;
check_read_type(*op1, t_string);
check_read_type(*op, t_string);
if (size > r_size(op1)) { /* can't match */
make_false(op);
return 0;
}
count = r_size(op1) - size;
ptr = op1->value.bytes;
if (size == 0)
goto found;
pat = op->value.bytes;
ch = pat[0];
do {
if (*ptr == ch && (size == 1 || !memcmp(ptr, pat, size)))
goto found;
ptr++;
}
while (count--);
/* No match */
make_false(op);
return 0;
found:
op->tas.type_attrs = op1->tas.type_attrs;
op->value.bytes = ptr;
r_set_size(op, size);
push(2);
op[-1] = *op1;
r_set_size(op - 1, ptr - op[-1].value.bytes);
op1->value.bytes = ptr + size;
r_set_size(op1, count);
make_true(op);
return 0;
}
/* <dict> .fontbbox -false- */
static int
zfontbbox(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
double bbox[4];
int code;
check_type(*op, t_dictionary);
check_dict_read(*op);
code = font_bbox_param(imemory, op, bbox);
if (code < 0)
return code;
if (bbox[0] < bbox[2] && bbox[1] < bbox[3]) {
push(4);
make_reals(op - 4, bbox, 4);
make_true(op);
} else { /* No bbox, or an empty one. */
make_false(op);
}
return 0;
}
/* <string> <pattern> anchorsearch <string> -false- */
static int
zanchorsearch(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
os_ptr op1 = op - 1;
uint size = r_size(op);
check_read_type(*op, t_string);
check_read_type(*op1, t_string);
if (size <= r_size(op1) && !memcmp(op1->value.bytes, op->value.bytes, size)) {
os_ptr op0 = op;
push(1);
*op0 = *op1;
r_set_size(op0, size);
op1->value.bytes += size;
r_dec_size(op1, size);
make_true(op);
} else
make_false(op);
return 0;
}
/* the stacks would get restored in case of an error. */
static int
zstop(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
uint count = count_to_stopped(i_ctx_p, 1L);
if (count) {
/*
* If there are any t_oparrays on the e-stack, they will pop
* any new items from the o-stack. Wait to push the 'true'
* until we have run all the unwind procedures.
*/
check_ostack(2);
pop_estack(i_ctx_p, count);
op = osp;
push(1);
make_true(op);
return o_pop_estack;
}
/* No mark, quit. (per Adobe documentation) */
push(2);
return unmatched_exit(op, zstop);
}
static int
zeqproc(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
ref2_t stack[MAX_DEPTH + 1];
ref2_t *top = stack;
make_array(&stack[0].proc1, 0, 1, op - 1);
make_array(&stack[0].proc2, 0, 1, op);
for (;;) {
long i;
if (r_size(&top->proc1) == 0) {
/* Finished these arrays, go up to next level. */
if (top == stack) {
/* We're done matching: it succeeded. */
make_true(op - 1);
pop(1);
return 0;
}
--top;
continue;
}
/* Look at the next elements of the arrays. */
i = r_size(&top->proc1) - 1;
array_get(imemory, &top->proc1, i, &top[1].proc1);
array_get(imemory, &top->proc2, i, &top[1].proc2);
r_dec_size(&top->proc1, 1);
++top;
/*
* Amazingly enough, the objects' executable attributes are not
* required to match. This means { x load } will match { /x load },
* even though this is clearly wrong.
*/
#if 0
if (r_has_attr(&top->proc1, a_executable) !=
r_has_attr(&top->proc2, a_executable)
)
break;
#endif
if (obj_eq(imemory, &top->proc1, &top->proc2)) {
/* Names don't match strings. */
if (r_type(&top->proc1) != r_type(&top->proc2) &&
(r_type(&top->proc1) == t_name ||
r_type(&top->proc2) == t_name)
)
break;
--top; /* no recursion */
continue;
}
if (r_is_array(&top->proc1) && r_is_array(&top->proc2) &&
r_size(&top->proc1) == r_size(&top->proc2) &&
top < stack + (MAX_DEPTH - 1)
) {
/* Descend into the arrays. */
continue;
}
break;
}
/* An exit from the loop indicates that matching failed. */
make_false(op - 1);
pop(1);
return 0;
}
static int
zmatchmedia(i_ctx_t *i_ctx_p)
{
os_ptr op = osp;
os_ptr preq = op - 3;
os_ptr pattr = op - 2;
os_ptr ppol = op - 1;
os_ptr pkeys = op; /* *const */
int policy_default;
float best_mismatch = (float)max_long; /* adhoc */
float mepos_penalty;
float mbest = best_mismatch;
match_record_t match;
ref no_priority;
ref *ppriority;
int mepos, orient;
bool roll;
int code;
int ai;
struct mkd_ {
ref key, dict;
} aelt;
if (r_has_type(pattr, t_null)) {
check_op(4);
make_null(op - 3);
make_true(op - 2);
pop(2);
return 0;
}
check_type(*preq, t_dictionary);
check_dict_read(*preq);
check_type(*pattr, t_dictionary);
check_dict_read(*pattr);
check_type(*ppol, t_dictionary);
check_dict_read(*ppol);
check_array(*pkeys);
check_read(*pkeys);
switch (code = dict_int_null_param(preq, "MediaPosition", 0, 0x7fff,
0, &mepos)) {
default:
return code;
case 2:
case 1:
mepos = -1;
case 0:;
}
switch (code = dict_int_null_param(preq, "Orientation", 0, 3,
0, &orient)) {
default:
return code;
case 2:
case 1:
orient = -1;
case 0:;
}
code = dict_bool_param(preq, "RollFedMedia", false, &roll);
if (code < 0)
return code;
code = dict_int_param(ppol, "PolicyNotFound", 0, 7, 0,
&policy_default);
if (code < 0)
return code;
if (dict_find_string(pattr, "Priority", &ppriority) > 0) {
check_array_only(*ppriority);
check_read(*ppriority);
} else {
make_empty_array(&no_priority, a_readonly);
ppriority = &no_priority;
}
match.no_match_priority = r_size(ppriority);
reset_match(&match);
for (ai = dict_first(pattr);
(ai = dict_next(pattr, ai, (ref * /*[2]*/)&aelt)) >= 0;
) {
if (r_has_type(&aelt.dict, t_dictionary) &&
r_has_attr(dict_access_ref(&aelt.dict), a_read) &&
r_has_type(&aelt.key, t_integer)
) {
bool match_all;
uint ki, pi;
code = dict_bool_param(&aelt.dict, "MatchAll", false,
&match_all);
if (code < 0)
return code;
for (ki = 0; ki < r_size(pkeys); ki++) {
ref key;
ref kstr;
ref *prvalue;
ref *pmvalue;
ref *ppvalue;
int policy;
array_get(imemory, pkeys, ki, &key);
if (dict_find(&aelt.dict, &key, &pmvalue) <= 0)
continue;
if (dict_find(preq, &key, &prvalue) <= 0 ||
r_has_type(prvalue, t_null)
) {
if (match_all)
goto no;
else
continue;
}
/* Look for the Policies entry for this key. */
if (dict_find(ppol, &key, &ppvalue) > 0) {
check_type_only(*ppvalue, t_integer);
policy = ppvalue->value.intval;
} else
policy = policy_default;
/*
* Match a requested attribute value with the attribute value in the
* description of a medium. For all attributes except PageSize,
* matching means equality. PageSize is special; see match_page_size
* below.
*/
if (r_has_type(&key, t_name) &&
(name_string_ref(imemory, &key, &kstr),
r_size(&kstr) == 8 &&
!memcmp(kstr.value.bytes, "PageSize", 8))
) {
gs_matrix ignore_mat;
gs_point ignore_msize;
if (zmatch_page_size(imemory, prvalue, pmvalue,
policy, orient, roll,
&best_mismatch,
&ignore_mat,
&ignore_msize)
<= 0)
goto no;
} else if (!obj_eq(imemory, prvalue, pmvalue))
goto no;
}
mepos_penalty = (mepos < 0 || aelt.key.value.intval == mepos) ?
0 : .001;
/* We have a match. Save the match in case no better match is found */
if (r_has_type(&match.match_key, t_null))
match.match_key = aelt.key;
/*
* If it is a better match than the current best it supersedes it
* regardless of priority. If the match is the same, then update
* to the current only if the key value is lower.
*/
if (best_mismatch + mepos_penalty <= mbest) {
if (best_mismatch + mepos_penalty < mbest ||
(r_has_type(&match.match_key, t_integer) &&
match.match_key.value.intval > aelt.key.value.intval)) {
reset_match(&match);
match.match_key = aelt.key;
mbest = best_mismatch + mepos_penalty;
}
}
/* In case of a tie, see if the new match has priority. */
for (pi = match.priority; pi > 0;) {
ref pri;
pi--;
array_get(imemory, ppriority, pi, &pri);
if (obj_eq(imemory, &aelt.key, &pri)) { /* Yes, higher priority. */
match.best_key = aelt.key;
match.priority = pi;
break;
}
}
no:;
}
}
if (r_has_type(&match.match_key, t_null)) {
make_false(op - 3);
pop(3);
} else {
if (r_has_type(&match.best_key, t_null))
op[-3] = match.match_key;
else
op[-3] = match.best_key;
make_true(op - 2);
pop(2);
}
return 0;
}
/* initialize the dictionaries that hold operator definitions. */
int
obj_init(i_ctx_t **pi_ctx_p, gs_dual_memory_t *idmem)
{
int level = gs_op_language_level();
ref system_dict;
i_ctx_t *i_ctx_p;
int code;
/*
* Create systemdict. The context machinery requires that
* we do this before initializing the interpreter.
*/
code = dict_alloc(idmem->space_global,
(level >= 3 ? SYSTEMDICT_LL3_SIZE :
level >= 2 ? SYSTEMDICT_LEVEL2_SIZE : SYSTEMDICT_SIZE),
&system_dict);
if (code < 0)
return code;
/* Initialize the interpreter. */
code = gs_interp_init(pi_ctx_p, &system_dict, idmem);
if (code < 0)
return code;
i_ctx_p = *pi_ctx_p;
{
#define icount countof(initial_dictionaries)
ref idicts[icount];
int i;
const op_def *const *tptr;
min_dstack_size = MIN_DSTACK_SIZE;
refset_null(idicts, icount);
/* Put systemdict on the dictionary stack. */
if (level >= 2) {
dsp += 2;
/*
* For the moment, let globaldict be an alias for systemdict.
*/
dsp[-1] = system_dict;
min_dstack_size++;
} else {
++dsp;
}
*dsp = system_dict;
/* Create dictionaries which are to be homes for operators. */
for (tptr = op_defs_all; *tptr != 0; tptr++) {
const op_def *def;
for (def = *tptr; def->oname != 0; def++)
if (op_def_is_begin_dict(def)) {
if (make_initial_dict(i_ctx_p, def->oname, idicts) == 0)
return_error(e_VMerror);
}
}
/* Set up the initial dstack. */
for (i = 0; i < countof(initial_dstack); i++) {
const char *dname = initial_dstack[i];
++dsp;
if (!strcmp(dname, "userdict"))
dstack_userdict_index = dsp - dsbot;
ref_assign(dsp, make_initial_dict(i_ctx_p, dname, idicts));
}
/* Enter names of referenced initial dictionaries into systemdict. */
initial_enter_name("systemdict", systemdict);
for (i = 0; i < icount; i++) {
ref *idict = &idicts[i];
if (!r_has_type(idict, t_null)) {
/*
* Note that we enter the dictionary in systemdict
* even if it is in local VM. There is a special
* provision in the garbage collector for this:
* see ivmspace.h for more information.
* In order to do this, we must temporarily
* identify systemdict as local, so that the
* store check in dict_put won't fail.
*/
uint save_space = r_space(systemdict);
r_set_space(systemdict, avm_local);
code = initial_enter_name(initial_dictionaries[i].name,
idict);
r_set_space(systemdict, save_space);
if (code < 0)
return code;
}
}
#undef icount
}
gs_interp_reset(i_ctx_p);
{
ref vnull, vtrue, vfalse;
make_null(&vnull);
make_true(&vtrue);
make_false(&vfalse);
if ((code = initial_enter_name("null", &vnull)) < 0 ||
(code = initial_enter_name("true", &vtrue)) < 0 ||
(code = initial_enter_name("false", &vfalse)) < 0
)
return code;
}
/* Create the error name table */
{
int n = countof(gs_error_names) - 1;
int i;
ref era;
code = ialloc_ref_array(&era, a_readonly, n, "ErrorNames");
if (code < 0)
return code;
for (i = 0; i < n; i++)
if ((code = name_enter_string(imemory, (const char *)gs_error_names[i],
era.value.refs + i)) < 0)
return code;
return initial_enter_name("ErrorNames", &era);
}
}
sexp eval_object(sexp object, sexp environment) {
tail_loop:
if (is_quote_form(object)) return quotation_text(object);
if (is_variable_form(object))
return get_variable_value(object, environment);
if (is_define_form(object)) {
/* sexp value = eval_object(definition_value(object), environment); */
/* add_binding(definition_variable(object), value, environment); */
/* return value; */
return eval_object(define2set(object), environment);
}
if (is_assignment_form(object)) {
sexp value = eval_object(assignment_value(object), environment);
set_binding(assignment_variable(object), value, environment);
return value;
}
if (is_if_form(object)) {
sexp test_part = if_test_part(object);
sexp then_part = if_then_part(object);
sexp else_part = if_else_part(object);
if (!is_false(eval_object(test_part, environment))) {
object = then_part;
} else {
object = else_part;
}
goto tail_loop;
}
if (is_lambda_form(object)) {
sexp parameters = lambda_parameters(object);
sexp body = lambda_body(object);
return make_lambda_procedure(parameters, body, environment);
}
if (is_begin_form(object)) {
return eval_begin(object, environment);
}
if (is_cond_form(object)) {
object = cond2if(object);
goto tail_loop;
}
if (is_let_form(object)) {
object = let2lambda(object);
goto tail_loop;
}
if (is_and_form(object)) {
sexp tests = and_tests(object);
if (is_null(tests))
return make_true();
while (is_pair(pair_cdr(tests))) {
sexp result = eval_object(pair_car(tests), environment);
if (is_false(result))
return make_false();
tests = pair_cdr(tests);
}
return eval_object(pair_car(tests), environment);
}
if (is_or_form(object)) {
sexp tests = or_tests(object);
if (is_null(tests))
return make_false();
while (is_pair(pair_cdr(tests))) {
sexp result = eval_object(pair_car(tests), environment);
if (!is_false(result))
return result;
tests = pair_cdr(tests);
}
return eval_object(pair_car(tests), environment);
}
if (is_macro_form(object)) {
sexp pars = macro_parameters(object);
sexp body = macro_body(object);
return make_macro_procedure(pars, body, environment);
}
if (is_application_form(object)) {
sexp operator = application_operator(object);
sexp operands = application_operands(object);
operator = eval_object(operator, environment);
if (!is_function(operator) && !is_macro(operator)) {
fprintf(stderr, "Illegal functional object ");
write_object(operator, make_file_out_port(stderr));
fprintf(stderr, " from ");
write_object(pair_car(object), make_file_out_port(stderr));
fputc('\n', stderr);
exit(1);
}
/* Expand the macro before evaluating arguments */
if (is_macro(operator)) {
sexp body = macro_proc_body(operator);
sexp vars = macro_proc_pars(operator);
sexp def_env = macro_proc_env(operator);
sexp object = make_pair(S("begin"), body);
sexp env = extend_environment(vars, operands, def_env);
sexp exp = eval_object(object, env);
return eval_object(exp, environment);
}
operands = eval_arguments(operands, environment);
/* if (is_apply(operator)) { */
/* operator = pair_car(operands); */
/* operands = apply_operands_conc(pair_cdr(operands)); */
/* } */
if (is_eval(operator)) {
environment = pair_cadr(operands);
object = pair_car(operands);
goto tail_loop;
}
return eval_application(operator, operands);
} else return object;
}
