static sexpr sx_join_work (sexpr a, sexpr b, sexpr c, char *g)
{
const char *s;
int i = 0, j = 0;
s = stringp (a) ? sx_string (a) : sx_symbol(a);
for (j = 0; s[j]; j++) {
g[i] = s[j];
i++;
}
if (stringp (b) || symbolp(b))
{
s = stringp (b) ? sx_string (b) : sx_symbol(b);
for (j = 0; s[j]; j++) {
g[i] = s[j];
i++;
}
}
if (stringp (c) || symbolp(c))
{
s = stringp (c) ? sx_string (c) : sx_symbol(c);
for (j = 0; s[j]; j++) {
g[i] = s[j];
i++;
}
}
g[i] = 0;
return stringp(a) ? make_string (g) : make_symbol (g);
}
//--------eval---------------
int eval(int addr){
int res;
if(atomp(addr)){
if(numberp(addr))
return(addr);
if(symbolp(addr)){
res = findsym(addr);
if(res == -1)
error(CANT_FIND_ERR, "eval", addr);
else
return(res);
}
}
else
if(listp(addr)){
if((symbolp(car(addr))) &&(HAS_NAME(car(addr),"quote")))
return(cadr(addr));
if(numberp(car(addr)))
error(ARG_SYM_ERR, "eval", addr);
if(subrp(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
if(fsubrp(car(addr)))
return(apply(car(addr),cdr(addr)));
if(functionp(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
}
error(CANT_FIND_ERR, "eval", addr);
return(0);
}
/*
* (set-video-mode <width> <height> <bits per pixel>?) or
* (set-video-mode <width> <height> <bits per pixel> <mode flags>+)
*
* where <symbols> are:
* swsurface
* hwsurface
* asyncblit
* anyformat
* hwpalette
* doublebuf
* fullscreen
* opengl
* openglblit
* resizable
* noframe
*
*/
cons_t* set_video_mode(cons_t* p, environment_t*)
{
assert_length_min(p, 2);
assert_type(INTEGER, car(p));
assert_type(INTEGER, cadr(p));
// dimension
int x = car(p)->integer;
int y = cadr(p)->integer;
// default values
int bits = 32;
uint32_t mode = 0;
///////////////////
raise(runtime_exception("Testing"));
///////////////////
// bits per pixel
if ( integerp(caddr(p)) )
bits = caddr(p)->integer;
// options
cons_t *opts = symbolp(caddr(p))? cddr(p) :
symbolp(cadddr(p))? cdddr(p) : nil();;
for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {
assert_type(SYMBOL, car(s));
std::string sym = symbol_name(s);
int size = sizeof(sdl_flags) / sizeof(key_value_t<std::string, uint32_t>);
for ( int n=0; n < size; ++n )
if ( sym == sdl_flags[n].key ) {
///////////////////
printf("flag %s\n", sym.c_str());
printf("value %d and %d\n", sdl_flags[n].value, SDL_HWSURFACE);
///////////////////
mode |= sdl_flags[n].value;
goto NEXT_FLAG;
}
raise(runtime_exception("Unknown SDL video mode flag: " + sym));
NEXT_FLAG:
continue;
}
mode = SDL_HWSURFACE;
///////////////////
printf("video mode\n"); fflush(stdout);
///////////////////
SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);
if ( screen == NULL )
raise(runtime_exception(SDL_GetError()));
return pointer(new pointer_t("sdl-surface", (void*)screen));
}
Node* list_erase(Node* n, Node* pos) {
if (get_next(n) == NULL) {
std::cerr << "ERROR" << std::endl;
exit(1);
}
else if (n == pos) {
Node* next_node = get_next(n);
if (get_elem(n) && symbolp(get_elem(n))) {
free((n->elem_m)->symbol_m);
}
free(n->elem_m);
n->elem_m = get_elem(next_node);
n->next_m = get_next(next_node);
free(next_node);
return n;
}
else if (get_next(n) == pos) {
n->next_m = get_next(pos);
if (get_elem(pos) && symbolp(get_elem(pos))) {
free((pos->elem_m)->symbol_m);
}
free(pos->elem_m);
free(pos);
return n->next_m;
}
else {
return list_erase(get_next(n), pos);
}
}
int test64()
{
/* Bytecode is the same as in test32(), except that we use symbolp()
* to fill up some space to get the distance right for ia64 machines.
*/
__FILE__->testcall(14, symbolp(symbolp(symbolp(symbolp(0)))), this_object());
return 1;
}
sexpr sx_join (sexpr a, sexpr b, sexpr c)
{
unsigned int j = 0, k = 0;
const char *s;
if (integerp (a))
{
a = sx_to_string (a);
}
if (integerp (b))
{
b = sx_to_string (b);
}
if (integerp (c))
{
c = sx_to_string (c);
}
if (stringp (a) || symbolp(a))
{
s = stringp (a) ? sx_string (a) : sx_symbol(a);
for (j = 0; s[j]; j++) k++;
}
else
{
return sx_nil;
}
if (stringp (b) || symbolp(b))
{
s = stringp (b) ? sx_string (b) : sx_symbol(b);
for (j = 0; s[j]; j++) k++;
}
if (stringp (c) || symbolp(c))
{
s = stringp (c) ? sx_string (c) : sx_symbol(c);
for (j = 0; s[j]; j++) k++;
}
k++;
if (k < STACK_BUFFER_SIZE)
{
char buf[STACK_BUFFER_SIZE];
return sx_join_work (a, b, c, buf);
}
else
{
char *g = get_mem (k);
sexpr rv;
rv = sx_join_work (a, b, c, g);
free_mem (k, g);
return rv;
}
}
int eqp(int addr1, int addr2){
if((numberp(addr1)) && (numberp(addr2))
&& ((GET_NUMBER(addr1)) == (GET_NUMBER(addr2))))
return(1);
else if ((symbolp(addr1)) && (symbolp(addr2))
&& (SAME_NAME(addr1,addr2)))
return(1);
else
return(0);
}
// ### kernel-function-p
Value SYS_kernel_function_p(Value arg)
{
if (symbolp(arg))
return the_symbol(arg)->is_kernel_function() ? T : NIL;
if (typed_object_p(arg))
{
Value name = the_typed_object(arg)->operator_name();
if (symbolp(name))
return the_symbol(name)->is_kernel_function() ? T : NIL;
}
return NIL;
}
/*
* (set-video-mode <width> <height> <bits per pixel>?) or
* (set-video-mode <width> <height> <bits per pixel> <mode flags>+)
*
* where <symbols> are:
* swsurface
* hwsurface
* asyncblit
* anyformat
* hwpalette
* doublebuf
* fullscreen
* opengl
* openglblit
* resizable
* noframe
*
*/
cons_t* set_video_mode(cons_t* p, environment_t*)
{
assert_length_min(p, 2);
assert_type(INTEGER, car(p));
assert_type(INTEGER, cadr(p));
// dimension
int x = intval(car(p));
int y = intval(cadr(p));
// default values
int bits = 32;
uint32_t mode = 0;
// bits per pixel
if ( length(p) > 2 && integerp(caddr(p)) )
bits = intval(caddr(p));
// mode options
if ( length(p) > 3 ) {
cons_t *opts = symbolp(caddr(p))? cddr(p) :
symbolp(cadddr(p))? cdddr(p) : nil();;
DPRINT(opts);
for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {
assert_type(SYMBOL, car(s));
std::string sym = symbol_name(car(s));
for ( size_t n=0; n < num_sdl_flags; ++n )
if ( sym == sdl_flags[n].key ) {
mode |= sdl_flags[n].value;
goto NEXT_FLAG;
}
raise(runtime_exception("Unknown SDL video mode flag: " + sym));
NEXT_FLAG:
continue;
}
}
SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);
if ( screen == NULL )
raise(runtime_exception(SDL_GetError()));
return pointer(
new pointer_t("sdl-surface",
reinterpret_cast<void*>(screen)));
}
/* xlgetfname - get a filename */
LVAL xlgetfname(V)
{
LVAL name;
/* get the next argument */
name = xlgetarg();
/* get the filename string */
#ifdef FILETABLE
if (streamp(name) && getfile(name) > CONSOLE)
/* "Steal" name from file stream */
name = cvstring(filetab[getfile(name)].tname);
else
#endif
if (symbolp(name))
name = getpname(name);
else if (!stringp(name))
xlbadtype(name);
if (getslength(name) >= FNAMEMAX)
xlerror("file name too long", name);
/* return the name */
return (name);
}
Cell* op_floor::eval_op(Cell* operand) const
{
Cell* operand_ptr;
no_of_operands(operand,1,1,true,true);
operand_ptr = car(operand);
if (listp(operand_ptr))
{
operand_ptr = eval(operand_ptr);
}
else if (symbolp(operand_ptr))
{
operand_ptr = search_symbol(get_symbol(operand_ptr),true);
}
if (doublep(operand_ptr))
{
return make_int( int(floor(get_double(operand_ptr))) );
}
else
{
if (operand_ptr != NULL)
delete operand_ptr;
throw runtime_error("'floor' only operates with double.");
}
}
oidtype read_partial_tuple(bindtype env, oidtype tag, oidtype x, oidtype stream)
{ // Standard reader
int size = 0, fills = 0, j = 0, k = 0;
oidtype res, x0;
struct ptcell *dres;
//Pass 1: compute sizes
x0 = x;
while (x0 != nil) {
if (hd(x) == nil) fills++;
size++;
x0 = tl(x0);
}
// Allocate PT
res = alloc_partial_tuple(size - fills, fills);
dres = dr(res, ptcell);
//Pass 2: fill PT with values and blanks
x0 = x;
while (x0 != nil) {
if (symbolp(hd(x0)) && strcmp(getpname(hd(x0)), "*") == 0) {
dres->fill[j].pos = k;
dres->fill[j].pendingOps = 0;
a_setelem(dres->tuple, k, nil, FALSE);
j++;
} else a_setelem(dres->tuple, k, hd(x0), FALSE);
k++;
x0 = tl(x0);
}
return res;
}
/* x1macroexpand - expand a macro call */
LVAL x1macroexpand(void)
{
LVAL form,fun,args;
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(args);
/* get the form */
form = xlgetarg();
xllastarg();
/* expand until the form isn't a macro call */
if (consp(form)) {
fun = car(form); /* get the macro name */
args = cdr(form); /* get the arguments */
if (symbolp(fun) && fboundp(fun)) {
fun = xlgetfunction(fun); /* get the expansion function */
macroexpand(fun,args,&form);
}
}
/* restore the stack and return the expansion */
xlpopn(2);
return (form);
}
/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
NODE *xleval(NODE *expr)
{
/* check for control codes */
if (--xlsample <= 0) {
xlsample = SAMPLE;
oscheck();
}
/* check for *evalhook* */
if (getvalue(s_evalhook))
return (evalhook(expr));
/* add trace entry */
if (++xltrace < TDEPTH)
trace_stack[xltrace] = expr;
/* check type of value */
if (consp(expr))
expr = evform(expr);
else if (symbolp(expr))
expr = xlgetvalue(expr);
/* remove trace entry */
--xltrace;
/* return the value */
return (expr);
}
int atomp(int x){
if(numberp(x) || symbolp(x) || charp(x) || stringp(x) || booleanp(x) || identifierp(x)
|| IS_SYNCLO(x))
return(1);
else
return(0);
}
AbstractString * Function::write_to_string()
{
Value name = operator_name();
Thread * thread = current_thread();
if (thread->symbol_value(S_print_readably) != NIL)
{
if (symbolp(name) || is_valid_setf_function_name(name))
{
String * s = new String();
s->append("#.(");
s->append(the_symbol(S_coerce_to_function)->prin1_to_string());
s->append(" '");
s->append(::prin1_to_string(name));
s->append_char(')');
return s;
}
signal_lisp_error(new PrintNotReadable(make_value(this)));
// not reached
return NULL;
}
String * s = new String();
s->append(the_symbol(S_function)->write_to_string());
if (name != NULL_VALUE)
{
s->append_char(' ');
void* last_special_binding = thread->last_special_binding();
thread->bind_special(S_print_length, NIL);
thread->bind_special(S_print_level, NIL);
s->append(::prin1_to_string(name));
thread->set_last_special_binding(last_special_binding);
}
return unreadable_string(s);
}
/* xsymbolp - is this an symbol? */
LVAL xsymbolp(void)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (arg == NIL || symbolp(arg) ? s_true : NIL);
}
static obj_t *
lang_define(obj_t **frame, obj_t **tailp)
{
obj_t *expr = *frame_ref(frame, 0);
obj_t *first, *name, *result;
*tailp = NULL;
first = pair_car(expr);
if (symbolp(first)) {
// Binding an expression
// XXX: check for expr length?
obj_t *to_eval = pair_car(pair_cdr(expr));
// Get the value of the expression before binding.
obj_t **expr_frame = frame_extend(
frame, 1, FR_CONTINUE_ENV | FR_SAVE_PREV);
*frame_ref(expr_frame, 0) = to_eval;
result = eval_frame(expr_frame);
name = first;
}
else if (pairp(first)) {
// short hand for (define name (lambda ...))
// x: the formals, v: the body
obj_t *formals, *body;
name = pair_car(first);
formals = pair_cdr(first);
body = pair_cdr(expr);
result = closure_wrap(frame, frame_env(frame), formals, body);
}
else {
fatal_error("define -- first argument is neither a "
"symbol nor a pair", frame);
}
environ_def(frame, frame_env(frame), name, result);
return unspec_wrap();
}
/* check an item instance variable */
static LVAL check_item_ivar P2C(int, which, LVAL, value)
{
int good=0;
switch (which) {
case 'T': good = (stringp(value) && strlen(getstring(value)) != 0); break;
case 'K': good = (charp(value) || value == NIL); break;
case 'M': good = (charp(value) || value == NIL || value == s_true); break;
case 'S': good = (symbolp(value) || listp(value)); break;
case 'A': good = (value == NIL || symbolp(value) || closurep(value) || subrp(value) || (bcclosurep(value))); break;
case 'E': good = TRUE; value = (value != NIL) ? s_true : NIL; break;
default: xlfail("unknown item instance variable");
}
if (! good) xlerror("bad instance variable value", value);
return(value);
}
/* xlexpandmacros - expand macros in a form */
LVAL xlexpandmacros(LVAL form)
{
LVAL fun,args;
/* protect some pointers */
xlstkcheck(3);
xlprotect(form);
xlsave(fun);
xlsave(args);
/* expand until the form isn't a macro call */
while (consp(form)) {
fun = car(form); /* get the macro name */
args = cdr(form); /* get the arguments */
if (!symbolp(fun) || !fboundp(fun))
break;
fun = xlgetfunction(fun); /* get the expansion function */
if (!macroexpand(fun,args,&form))
break;
}
/* restore the stack and return the expansion */
xlpopn(3);
return (form);
}
bool Condition::typep(Value type) const
{
if (symbolp(type))
return (type == S_condition || type == S_standard_object || type == S_atom || type == T);
else
return (type == C_condition || type == C_standard_object || type == C_t);
}
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;
}
bool SocketStream::typep(Value type) const
{
if (symbolp(type))
return (type == S_socket_stream || type == S_ansi_stream || type == S_stream || type == S_atom || type == T);
else
return (type == C_socket_stream || type == C_ansi_stream || type == C_stream || type == C_t);
}
// ### autoload-macro
Value EXT_autoload_macro(unsigned int numargs, Value args[])
{
switch (numargs)
{
case 1:
if (listp(args[0]))
{
Value list = args[0];
while (list != NIL)
{
Value name = car(list);
check_symbol(name)->set_autoload_macro(new Autoload(name));
list = xcdr(list);
}
return T;
}
else if (symbolp(args[0]))
{
the_symbol(args[0])->set_autoload_macro(new Autoload(args[0]));
return T;
}
else
return signal_type_error(args[0], list3(S_or, S_symbol, S_list));
case 2:
if (listp(args[0]))
{
AbstractString * filename = check_string(args[1]);
Value list = args[0];
while (list != NIL)
{
Value name = car(list);
check_symbol(name)->set_autoload_macro(new Autoload(name, filename));
list = xcdr(list);
}
return T;
}
else if (symbolp(args[0]))
{
the_symbol(args[0])->set_autoload_macro(new Autoload(args[0], check_string(args[1])));
return T;
}
else
return signal_type_error(args[0], list3(S_or, S_symbol, S_list));
default:
return wrong_number_of_arguments(S_autoload, numargs, 1, 2);
}
}
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;
}
// ### function-name function-designator
Value SYS_function_name(Value arg)
{
if (symbolp(arg))
return arg;
if (functionp(arg))
return the_typed_object(arg)->operator_name();
return signal_type_error(arg, S_function_designator);
}
bool StringOutputStream::typep(Value type) const
{
if (symbolp(type))
return (type == S_string_output_stream || type == S_string_stream || type == S_ansi_stream
|| type == S_stream || type == S_atom || type == T);
else
return (type == C_string_stream || type == C_ansi_stream || type == C_stream || type == C_t);
}
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;
}
// ### multiple-value-call
Value CL_multiple_value_call(Value args, Environment * env, Thread * thread)
{
const unsigned long numargs = length(args);
if (numargs == 0)
return wrong_number_of_arguments(S_multiple_value_call, numargs, 1, MANY);
Function * function;
Value value = eval(car(args), env, thread);
args = xcdr(args);
if (symbolp(value))
{
Symbol * sym = the_symbol(value);
if (sym->is_special_operator() || sym->is_macro()
|| (function = (Function *) sym->function()) == NULL)
{
String * string = new String("The symbol ");
string->append(sym->prin1_to_string());
string->append(" does not designate a function.");
return signal_lisp_error(new Error(string));
}
}
else if (functionp(value))
function = the_function(value);
else
{
String * string = new String("The value ");
string->append(::prin1_to_string(value));
string->append(" does not designate a function.");
return signal_lisp_error(new Error(string));
}
Value list = NIL;
while (args != NIL)
{
Value result = eval(car(args), env, thread);
if (thread->values_length() >= 0)
{
Value * values = thread->values();
const long limit = thread->values_length();
for (long i = 0; i < limit; i++)
list = make_cons(values[i], list);
}
else
list = make_cons(result, list);
args = xcdr(args);
}
unsigned long len = length(list);
Value * funcall_args = new (GC) Value[len + 1];
funcall_args[0] = make_value(function);
if (list != NIL)
{
for (long i = len; i > 0; i--)
{
funcall_args[i] = xcar(list);
list = xcdr(list);
}
}
return CL_funcall(len + 1, funcall_args);
}
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);
}
}
}
}
}