static void cell_write(SExp s, int b_escape, struct StreamBase* strm) {
// 省略表示系のチェック
if (consp(CDR(s)) && nullp(CDDR(s))) {
SExp t = CAR(s);
const char* str = NULL;
if (eq(t, intern("quote"))) {
str = "'";
} else if (eq(t, intern("quasiquote"))) {
str = "`";
}
if (str != NULL) {
strm_puts(strm, str, 0);
swrite(CADR(s), b_escape, strm);
return;
}
}
{
int first = TRUE;
SExp p;
strm_puts(strm, "(", 0);
for (p = s; consp(p); p = CDR(p)) {
if (!first) strm_puts(strm, " ", 0);
first = FALSE;
swrite(CAR(p), b_escape, strm);
}
if (!nullp(p)) {
strm_puts(strm, " . ", 0);
swrite(p, b_escape, strm);
}
strm_puts(strm, ")", 0);
}
}
/* pplist - pretty print a list */
LOCAL void pplist(LVAL expr)
{
int n;
/* if the expression will fit on one line, print it on one */
if ((n = flatsize(expr)) < ppmaxlen) {
xlprint(ppfile,expr,TRUE);
pplevel += n;
}
/* otherwise print it on several lines */
else {
n = ppmargin;
ppputc('(');
if (atomp(car(expr))) {
ppexpr(car(expr));
ppputc(' ');
ppmargin = pplevel;
expr = cdr(expr);
}
else
ppmargin = pplevel;
for (; consp(expr); expr = cdr(expr)) {
pp(car(expr));
if (consp(cdr(expr)))
ppterpri();
}
if (expr != NIL) {
ppputc(' '); ppputc('.'); ppputc(' ');
ppexpr(expr);
}
ppputc(')');
ppmargin = n;
}
}
/* to reflect the shift in position */
void StMObDeleteItem(LVAL menu, LVAL item)
{
HMENU addr;
int n, i, j, id, flags;
LVAL items;
char *s;
if (StMObAllocated(menu)) {
addr = get_menu_address(menu);
id = get_menu_id(menu);
i = get_item_position(menu, item);
for (j = 0, items = slot_value(menu, s_items);
j < i && consp(items);
j++, items = cdr(items));
n = GetMenuItemCount((HMENU) addr);
for (; i < n; n--) DeleteMenu((HMENU) addr, i, MF_BYPOSITION);
if (consp(items)) items = cdr(items);
for (; consp(items); items = cdr(items), i++) {
item = car(items);
s = get_item_string(item);
if (s[0] == '-') AppendMenu((HMENU) addr, MF_SEPARATOR, 0, NULL);
else {
flags = MF_STRING;
if (slot_value(item, s_mark) != NIL) flags |= MF_CHECKED;
if (slot_value(item, s_enabled) == NIL) flags |= MF_GRAYED;
AppendMenu((HMENU) addr, flags, MAKEITEMINDEX(id, i), s);
}
}
}
}
LISPTR lisp_print(LISPTR x, FILE* out)
{
if (consp(x)) {
fputwc('(', out);
while (true) {
lisp_print(car(x), out);
x = cdr(x);
if (!consp(x)) {
if (x != NIL) {
fputws(L" . ", out);
lisp_print(x, out);
}
break;
}
fputwc(' ', out);
}
fputwc(')', out);
} else if (symbolp(x)) {
fputws(string_text(symbol_name(x)), out);
} else if (numberp(x)) {
fwprintf(out, L"%g", number_value(x));
} else if (stringp(x)) {
fputwc('"', out);
fputws(string_text(x), out);
fputwc('"', out);
} else {
fputws(L"*UNKOBJ*", out);
}
return x;
}
int is_labels(LVAL expr)
{
/* make sure that we have a list whose first element is a
list of the form (time "label") */
if (!consp(expr))
return 0;
if (!consp(car(expr)))
return 0;
if (!(floatp(car(car(expr))) || fixp(car(car(expr)))))
return 0;
if (!consp(cdr(car(expr))))
return 0;
if (!(stringp(car(cdr(car(expr))))))
return 0;
/* If this is the end of the list, we're done */
if (cdr(expr) == NULL)
return 1;
/* Otherwise recurse */
return is_labels(cdr(expr));
}
/* xnconc - destructively append lists */
LVAL xnconc(void)
{
LVAL next,last=NULL,val;
/* initialize */
val = NIL;
/* concatenate each argument */
if (moreargs()) {
while (xlargc > 1) {
/* ignore everything except lists */
if ((next = nextarg()) && consp(next)) {
/* concatenate this list to the result list */
if (val) rplacd(last,next);
else val = next;
/* find the end of the list */
while (consp(cdr(next)))
next = cdr(next);
last = next;
}
}
/* handle the last argument */
if (val) rplacd(last,nextarg());
else val = nextarg();
}
/* return the list */
return (val);
}
/* xassoc - built-in function 'assoc' */
LVAL xassoc(void)
{
LVAL x,alist,fcn,pair,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the association list */
x = xlgetarg();
alist = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(alist); alist = cdr(alist))
if ((pair = car(alist)) && consp(pair))
if (dotest2(x,car(pair),fcn) == tresult) {
val = pair;
break;
}
/* restore the stack */
xlpop();
/* return result */
return (val);
}
static sexpr get_acceptable_type (sexpr lq)
{
sexpr types = get_acceptable_types (lq), ta,
mape = lx_environment_alist (mime_map), n;
while (consp (types))
{
ta = car (types);
n = mape;
while (consp (n))
{
if (truep (equalp (ta, cdr (car (n)))))
{
return ta;
}
n = cdr (n);
}
types = cdr (types);
}
return default_type;
}
LISPTR bind_args(LISPTR formals, LISPTR acts, LISPTR prev)
{
if (!consp(formals)) {
return prev;
}
return cons(cons(car(formals), consp(acts) ? eval(car(acts)) : NIL), bind_args(cdr(formals), consp(acts) ? cdr(acts) : NIL, prev));
}
/* xlapply - apply a function to a list of arguments */
NODE *xlapply(NODE *fun,NODE *args)
{
NODE *env,*val;
val = 0; //BUG: uninitialized variable is used if xlfail returns
/* check for a null function */
if (fun == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun))
val = (*getsubr(fun))(args);
else if (consp(fun)) {
if (consp(car(fun))) {
env = cdr(fun);
fun = car(fun);
}
else
env = xlenv;
if (car(fun) != s_lambda)
xlfail("bad function type");
val = evfun(fun,args,env);
}
else
xlfail("bad function");
/* return the result value */
return (val);
}
bool Array_T::typep(Value type) const
{
if (consp(type))
{
Value type_specifier_atom = xcar(type);
Value tail = xcdr(type);
if (type_specifier_atom == S_array)
{
if (consp(tail))
{
Value element_type = xcar(tail);
tail = xcdr(tail);
if (element_type == UNSPECIFIED || ::equal(element_type, _element_type)
|| (_element_type == S_bit && ::equal(element_type, BIT_TYPE)))
{
if (tail == NIL)
return true;
if (::length(tail) == 1)
{
Value dimensions = xcar(tail);
if (dimensions == UNSPECIFIED)
return true;
if (dimensions == make_fixnum(_rank))
return true;
if (consp(dimensions))
{
if (::length(dimensions) == _rank)
{
unsigned long i = 0;
while (dimensions != NIL)
{
Value dim = xcar(dimensions);
if (dim == UNSPECIFIED || dim == make_fixnum(_dimensions[i]))
; // ok
else
return false;
dimensions = xcdr(dimensions);
++i;
}
return true;
}
}
}
}
}
}
}
else if (symbolp(type))
{
if (type == S_array || type == S_atom || type == T)
return true;
}
else
{
if (type == C_array || type == C_t)
return true;
}
return false;
}
/* findprop - find a property pair */
LOCAL NODE *findprop(NODE *sym,NODE *prp)
{
NODE *p;
for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
if (car(p) == prp)
return (cdr(p));
return (NIL);
}
/* findprop - find a property pair */
LVAL findprop(LVAL sym, LVAL prp)
{
LVAL p;
for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
if (car(p) == prp)
return (cdr(p));
return (NIL);
}
bool SimpleArray_UB16_1::typep(Value type) const
{
if (consp(type))
{
Value type_specifier_atom = xcar(type);
Value tail = xcdr(type);
if (type_specifier_atom == S_array || type_specifier_atom == S_simple_array)
{
if (consp(tail))
{
Value element_type = xcar(tail);
if (element_type == UNSPECIFIED)
; // ok
else
{
Value upgraded_element_type = upgraded_array_element_type(element_type);
if (::equal(upgraded_element_type, UB16_TYPE))
; // ok
else if (::equal(upgraded_element_type,
list3(S_integer, FIXNUM_ZERO, make_fixnum(65535))))
; // ok
else if (::equal(upgraded_element_type,
list3(S_integer, FIXNUM_ZERO, list1(make_fixnum(65536)))))
; // ok
else
return false;
}
tail = xcdr(tail);
if (tail == NIL)
return true;
if (cdr(tail) == NIL) // i.e. length(tail) == 1
{
Value dimensions = xcar(tail);
if (dimensions == UNSPECIFIED)
return true;
if (dimensions == FIXNUM_ONE)
return true;
if (::equal(dimensions, list1(UNSPECIFIED)))
return true;
if (::equal(dimensions, list1(make_fixnum(_capacity))))
return true;
}
}
}
}
else if (symbolp(type))
{
if (type == S_vector || type == S_sequence || type == S_simple_array
|| type == S_array || type == S_atom || type == T)
return true;
}
else
{
if (type == C_vector || type == C_array || type == C_sequence || type == C_t)
return true;
}
return false;
}
LOCAL void test_one_env(LVAL environment, int i, char *s)
{
register LVAL fp,ep;
LVAL val;
/* check the environment list */
for (fp = environment; fp; fp = cdr(fp)) {
/* check that xlenv is good */
if (!consp(fp)) {
sprintf(buf,"%s: xlenv 0x%lx, frame 0x%lx, type(frame) %d\n",
s, xlenv, fp, ntype(fp));
errputstr(buf);
report_exit("xlenv points to a bad list", i);
}
/* check for an instance variable */
if ((ep = car(fp)) && objectp(car(ep))) {
/* do nothing */
}
/* check an environment stack frame */
else {
for (; ep; ep = cdr(ep)) {
/* check that ep is good */
if (!consp(ep)) {
sprintf(buf,"%s: fp 0x%lx, ep 0x%lx, type(ep) %d\n",
s, fp, ep, ntype(ep));
errputstr(buf);
report_exit("car(fp) points to a bad list", i);
}
/* check that car(ep) is nonnull */
if (!car(ep)) {
sprintf(buf,"%s: ep 0x%lx, car(ep) 0x%lx\n",
s, ep, car(ep));
errputstr(buf);
report_exit("car(ep) (an association) is NULL", i);
}
/* check that car(ep) is a cons */
if (!consp(car(ep))) {
sprintf(buf,"%s: ep 0x%lx, car(ep) 0x%lx, type(car(ep)) %d\n",
s, ep, car(ep), ntype(car(ep)));
errputstr(buf);
report_exit("car(ep) (an association) is not a cons", i);
}
/* check that car(car(ep)) is a symbol */
if (!symbolp(car(car(ep)))) {
sprintf(buf,"%s: ep 0x%lx, car(ep) 0x%lx, car(car(ep)) 0x%lx, type(car(car(ep))) %d\n",
s, ep, car(ep), car(car(ep)), ntype(car(car(ep))));
errputstr(buf);
report_exit("car(car(ep)) is not a symbol", i);
}
}
}
}
}
bool SimpleString::typep(Value type) const
{
if (classp(type))
return (type == C_string || type == C_vector || type == C_array
|| type == C_sequence || type == C_t);
if (symbolp(type))
return (type == S_string || type == S_base_string || type == S_simple_string
|| type == S_simple_base_string || type == S_vector
|| type == S_simple_array || type == S_array || type == S_sequence
|| type == S_atom || type == T);
if (consp(type))
{
Value type_specifier_atom = xcar(type);
Value tail = xcdr(type);
if (type_specifier_atom == S_array || type_specifier_atom == S_simple_array)
{
if (consp(tail))
{
Value element_type = xcar(tail);
tail = xcdr(tail);
if (element_type == UNSPECIFIED || element_type == S_character
|| element_type == S_base_char)
{
if (tail == NIL)
return true;
if (cdr(tail) == NIL) // i.e. length(tail) == 1
{
Value dimensions = xcar(tail);
if (dimensions == UNSPECIFIED)
return true;
if (dimensions == FIXNUM_ONE)
return true;
if (consp(dimensions))
{
if (::length(dimensions) == 1)
{
Value dim = xcar(dimensions);
if (dim == UNSPECIFIED || dim == make_fixnum(_capacity))
return true;
}
}
}
}
}
}
else if (type_specifier_atom == S_string
|| type_specifier_atom == S_base_string
|| type_specifier_atom == S_simple_string
|| type_specifier_atom == S_simple_base_string)
{
Value size = car(tail);
return (size == UNSPECIFIED || check_index(size) == _capacity);
}
}
return false;
}
static sexpr sexpr_to_graph (sexpr sx)
{
sexpr g = graph_create ();
sexpr c = car(sx);
while (consp(c))
{
sexpr cx = car (c);
sexpr cxcar = car (cx);
graph_add_node (g, cxcar);
c = cdr (c);
}
c = cdr(sx);
while (consp(c))
{
sexpr cx = car (c);
sexpr cxcar = car (cx);
sexpr cxcdr = cdr (cx);
sexpr cxcadr = car (cxcdr);
sexpr cxcddr = cdr (cxcdr);
struct graph_node *ns = graph_search_node (g, cxcar);
struct graph_node *nt = graph_search_node (g, cxcadr);
if ((ns != (struct graph_node *)0) && (nt != (struct graph_node *)0))
{
graph_node_add_edge (ns, nt, cxcddr);
}
c = cdr (c);
}
c = car(sx);
while (consp(c))
{
sexpr cx = car (c);
sexpr cxcar = car (cx);
sexpr cxcdr = cdr (cx);
struct graph_node *n = graph_search_node (g, cxcar);
if (n != (struct graph_node *)0)
{
n->label = cxcdr;
}
c = cdr (c);
}
return g;
}
LOCAL int nyx_is_labels(LVAL expr)
{
/* make sure that we have a list whose first element is a
list of the form (time "label") */
LVAL label;
LVAL first;
LVAL second;
LVAL third;
if (expr == NULL) {
return 0;
}
while (expr != NULL) {
if (!consp(expr)) {
return 0;
}
label = car(expr);
if (!consp(label)) {
return 0;
}
first = car(label);
if (!(floatp(first) || fixp(first))) {
return 0;
}
if (!consp(cdr(label))) {
return 0;
}
second = car(cdr(label));
if (floatp(second) || fixp(second)) {
if (!consp(cdr(cdr(label)))) {
return 0;
}
third = car(cdr(cdr(label)));
if (!(stringp(third))) {
return 0;
}
}
else {
if (!(stringp(second))) {
return 0;
}
}
expr = cdr(expr);
}
return 1;
}
/* assoc - find a pair in an association list */
LOCAL LVAL assoc(LVAL expr, LVAL alist, LVAL fcn, int tresult)
{
LVAL pair;
for (; consp(alist); alist = cdr(alist))
if ((pair = car(alist)) && consp(pair))
if (dotest2(expr,car(pair),fcn) == tresult)
return (pair);
return (NIL);
}
static void handle_external_mod_update
(struct kyu_module *newdef, struct kyu_module *mydef)
{
sexpr c, a, module, rv = sx_nil, flags = newdef->schedulerflags;
c = sx_set_difference (mydef->schedulerflags, newdef->schedulerflags);
if (eolp (c))
{
return;
}
while (consp (c) && nilp (rv))
{
a = car (c);
if (truep (equalp (a, sym_enabling)))
{
if (falsep (sx_set_memberp (mydef->schedulerflags, sym_enabling)))
{
rv = handle_enable_request (mydef);
if (falsep (rv))
{
flags = sx_set_add (mydef->schedulerflags, sym_blocked);
}
}
}
else if (truep (equalp (a, sym_disabling)))
{
if (falsep (sx_set_memberp (mydef->schedulerflags, sym_disabling)))
{
rv = handle_disable_request (mydef);
}
}
else if (consp (a) &&
falsep (sx_set_memberp (mydef->schedulerflags, a)))
{
rv = handle_action (mydef, cdr (a));
}
c = cdr (c);
}
module = kyu_make_module
(mydef->name, mydef->description, mydef->provides,
mydef->requires, mydef->before, mydef->after, mydef->conflicts,
flags, mydef->functions);
my_modules = lx_environment_unbind (my_modules, mydef->name);
my_modules = lx_environment_bind (my_modules, mydef->name, module);
kyu_command (cons (sym_update, cons (native_system,
cons (module, sx_end_of_list))));
}
/* xlremprop - remove a property from a property list */
void xlremprop(NODE *sym,NODE *prp)
{
NODE *last,*p;
last = NIL;
for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
if (car(p) == prp)
if (last)
rplacd(last,cdr(cdr(p)));
else
setplist(sym,cdr(cdr(p)));
last = cdr(p);
}
}
/* evform - evaluate a form */
LOCAL NODE *evform(NODE *expr)
{
NODE ***oldstk,*fun __HEAPIFY,*args __HEAPIFY,*env,*val,*type;
val = 0; //BUG: uninitialized variable is used if xlfail returns
/* create a stack frame */
oldstk = xlsave2(&fun,&args);
/* get the function and the argument list */
fun = car(expr);
args = cdr(expr);
/* evaluate the first expression */
if ((fun = xleval(fun)) == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun) || fsubrp(fun)) {
if (subrp(fun))
args = xlevlist(args);
val = (*getsubr(fun))(args);
}
else if (consp(fun)) {
if (consp(car(fun))) {
env = cdr(fun);
fun = car(fun);
}
else
env = xlenv;
if ((type = car(fun)) == s_lambda) {
args = xlevlist(args);
val = evfun(fun,args,env);
}
else if (type == s_macro) {
args = evfun(fun,args,env);
val = xleval(args);
}
else
xlfail("bad function type");
}
else if (objectp(fun))
val = xlsend(fun,args);
else
xlfail("bad function");
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xlremprop - remove a property from a property list */
void xlremprop(LVAL sym, LVAL prp)
{
LVAL last,p;
last = NIL;
for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
if (car(p) == prp) {
if (last)
rplacd(last,cdr(cdr(p)));
else
setplist(sym,cdr(cdr(p)));
}
last = cdr(p);
}
}
/// <summary>
/// Retreive type macro expansion
/// <para>
/// Note: We don't allow to put nil to m_types. If we detect it, we put
/// (lambda () nil) instead of nil.
/// </para>
/// </summary>
Val find_type(Val typespec, Val errorp, Val env)
{
Val name = consp(typespec) ? car(typespec) : typespec;
for (;;)
{
Environment* pEnv = env->DynamicCast<Environment>();
if (NULL == pEnv)
{
if (nil != errorp)
{
error("Undefined type specifier: ~S", typespec);
}
return nil;
}
if (hash_table_p(pEnv->m_types))
{
Val found;
Val thing = gethash(name, pEnv->m_types, nil, &found);
if (nil != found)
{
return thing;
}
}
env = pEnv->m_outer;
} // for
} // find_type
/* splitlist - split the list around the pivot */
LOCAL void splitlist(LVAL pivot, LVAL list, LVAL *psmaller, LVAL *plarger, LVAL fcn)
{
LVAL next;
xlprot1(list); // protect list from gc
// the rplacd disconnects list, and next is the only
// reference to it, but next is immediately assigned to list
// before dotest2 which is where gc might run.
/* initialize the result lists */
*psmaller = *plarger = NIL;
/* split the list */
for (; consp(list); list = next) {
next = cdr(list);
if (dotest2(car(list),car(pivot),fcn)) {
rplacd(list,*psmaller);
*psmaller = list;
}
else {
rplacd(list,*plarger);
*plarger = list;
}
}
xlpop();
}
/* xlength - return the length of a list or string */
LVAL xlength(void)
{
FIXTYPE n=0;
LVAL arg;
/* get the list or string */
arg = xlgetarg();
xllastarg();
/* find the length of a list */
if (listp(arg))
for (n = 0; consp(arg); n++)
arg = cdr(arg);
/* find the length of a string */
else if (stringp(arg))
n = (FIXTYPE)getslength(arg)-1;
/* find the length of a vector */
else if (vectorp(arg))
n = (FIXTYPE)getsize(arg);
/* otherwise, bad argument type */
else
xlerror("bad argument type",arg);
/* return the length */
return (cvfixnum(n));
}
/* remif - common code for 'remove-if' and 'remove-if-not' */
LOCAL LVAL remif(int tresult)
{
LVAL list,fcn,val,last=NULL,next;
/* protect some pointers */
xlstkcheck(2);
xlsave(fcn);
xlsave(val);
/* get the expression to remove and the list */
fcn = xlgetarg();
list = xlgalist();
xllastarg();
/* remove matches */
for (; consp(list); list = cdr(list))
/* check to see if this element should be deleted */
if (dotest1(car(list),fcn) != tresult) {
next = consa(car(list));
if (val) rplacd(last,next);
else val = next;
last = next;
}
/* restore the stack */
xlpopn(2);
/* return the updated list */
return (val);
}
/* listlength - find the length of a list */
LOCAL int listlength(LVAL list)
{
int len;
for (len = 0; consp(list); len++)
list = cdr(list);
return (len);
}
/* xmember - built-in function 'member' */
LVAL xmember(void)
{
LVAL x,list,fcn,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the list */
x = xlgetarg();
list = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(list); list = cdr(list))
if (dotest2(x,car(list),fcn) == tresult) {
val = list;
break;
}
/* restore the stack */
xlpop();
/* return the result */
return (val);
}
/* xappend - built-in function append */
LVAL xappend(void)
{
LVAL list,last=NULL,next,val;
/* protect some pointers */
xlsave1(val);
/* initialize */
val = NIL;
/* append each argument */
if (moreargs()) {
while (xlargc > 1) {
/* append each element of this list to the result list */
for (list = nextarg(); consp(list); list = cdr(list)) {
next = consa(car(list));
if (val) rplacd(last,next);
else val = next;
last = next;
}
}
/* handle the last argument */
if (val) rplacd(last,nextarg());
else val = nextarg();
}
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
