data_ptr run(call_info fci) {
if (!utils::all_types_are(fci.args, data_type::integer))
throw error(error_type::invalid_arguments, "Not A Integer", fci.debug);
long long start = fci.args.at(0)->as_integer().as_int();
long long end = fci.args.at(1)->as_integer().as_int();
long long step = fci.args.at(2)->as_integer().as_int();
if (start > end && step >= 0)
throw error(error_type::invalid_arguments, "Range Invalid", fci.debug);
else if (start < end && step <= 0)
throw error(error_type::invalid_arguments, "Range Invalid", fci.debug);
else if (step == 0 || start == end)
throw error(error_type::invalid_arguments, "Range Invalid", fci.debug);
std::vector<data_ptr> return_value;
if (start > end) {
while (start > end) {
return_value.push_back(make_integer(start));
start += step;
}
} else if (start < end) {
while (start < end) {
return_value.push_back(make_integer(start));
start += step;
}
}
return make_tuple(return_value);
}
static void global_death_notification (struct exec_context *ctx, void *aux)
{
sexpr rv = (ctx->exitstatus == 0) ? sx_true
: make_integer (ctx->exitstatus);
sx_write (monitorconnection,
cons (sym_process_terminated,
cons (make_integer (ctx->pid),
cons (rv, sx_end_of_list))));
}
cell pp_curs_getyx(cell x) {
int cx, cy;
cell n;
if (!Running) return UNSPECIFIC;
getyx(stdscr, cy, cx);
n = make_integer(cx);
n = cons(n, NIL);
save(n);
n = cons(make_integer(cy), n);
unsave(1);
return n;
}
/*---------------------------------------------------------------------*/
obj_t *
readobj( FILE *file ) {
token_t *tok = parse_token( file );
if( !tok ) {
return 0L;
} else {
switch( tok->tok ) {
case TOKEN_OPENPAR:
return (obj_t *)readlist( file );
case TOKEN_SYMBOL:
return (obj_t *)make_symbol( tok->val );
case TOKEN_STRING:
return (obj_t *)make_string( tok->val );
case TOKEN_INT:
return (obj_t *)make_integer( atol( tok->val ) );
default:
fprintf( stderr, "Illegal %s: %s\n",
token_type( tok ),
tok->val );
return (obj_t *)NIL;
}
}
}
Value Bignum::type_of() const
{
if (mpz_sgn(_z) > 0)
return list2(S_integer, make_integer(MOST_POSITIVE_FIXNUM + 1));
else
return S_bignum;
}
static void parse_num(char **pscan)
{
char rbuf[50];
char *rbufp = rbuf;
*rbufp++ = **pscan;
++*pscan;
while (!is_delimiter(**pscan) && **pscan != '\0'){
*rbufp++ = **pscan;
if (!is_digit(**pscan)){
printf("Error: Bad number constant %s -- READ\n", rbuf);
do_input_error(pscan);
}
++*pscan;
}
*rbufp = '\0';
reg = make_integer(atoi(rbuf));
current_state = stack_pop(&state_stack);
if (current_state == STATE_QUOTE){
reg = cons(reg, NIL);
reg = cons(make_symbol("quote"), reg);
current_state = stack_pop(&state_stack);
}
stack_push(&parser_stack, reg);
}
void builtin_allocation(struct Value *argument, struct Value *env,
struct Value **out)
{
(void) argument;
(void) env;
*out = make_integer(memory_used);
}
int cmain ()
{
programme_identification = cons (sym_server_seteh, make_integer (1));
initialise_kyu_script_commands ();
initialise_kyu_types ();
multiplex_add_kyu_stdio (on_event, (void *)0);
graph_initialise();
global_environment = kyu_sx_default_environment ();
global_environment =
lx_environment_bind (global_environment, sym_action_wrap,
lx_foreign_mu (sym_action_wrap, action_wrap));
global_environment =
lx_environment_bind (global_environment, sym_action_dispatch,
lx_foreign_mu (sym_action_dispatch,
action_dispatch));
my_modules = lx_make_environment (sx_end_of_list);
mod_functions = lx_make_environment (sx_end_of_list);
mod_metadata = lx_make_environment (sx_end_of_list);
read_configuration ();
while (multiplex() == mx_ok);
return 0;
}
// (expt x y)
Cell* op_expt(Scheme *sc) {
Cell* x = first(sc->args);
Cell* y = second(sc->args);
double result;
int real_result = TRUE;
if (x->_num.isFix && y->_num.isFix)
real_result = FALSE;
/* This 'if' is an R5RS compatibility fix. */
/* NOTE: Remove this 'if' fix for R6RS. */
if (double_value(x) == 0 && double_value(y) < 0) {
result = 0.0;
} else {
result = pow(double_value(x), double_value(y));
}
/* Before returning integer result make sure we can. */
/* If the test fails, result is too big for integer. */
if (!real_result) {
long result_as_long = (long) result; //如果result有小数位，必然导致result_as_long和result不相等
if (result != (double) result_as_long)
real_result = TRUE;
}
if (real_result) {
return s_return_helper(sc, make_real(sc, result));
} else {
return s_return_helper(sc, make_integer(sc, (long) result));
}
}
cell pp_curs_getch(cell x) {
int c;
if (!Running) return UNSPECIFIC;
c = getch();
if (c == ERR)
return S9_FALSE;
return make_integer(c);
}
//Here we should make the call, and if we are saving the result, tell the regdesc that
void code_call(FILE *file, RegDesc *registers, Symbol *function, Symbol *result)
{
code_spill_all(file, registers);
clear_registers(registers);
if (function->external != NULL)
{
//If this is printf, push the appropriate string
if (strcmp(function->external, "printf") == 0)
{
arg_count++;
code_instruction(file, PUSH, "$.LC0", NULL);
}
//This an external call, so drop the instruction using the linked name
code_instruction(file, CALL, function->external, NULL);
}
else
{
//This is an internal routine
//Therefore, we need to set up the static link
int caller_nested = current_scope->symbols->nested;
int callee_nested = function->symbols->nested;
debug("Static Linking - Caller: %d to Callee: %d", caller_nested, callee_nested);
if (caller_nested < callee_nested)
{
//This is one hop, so we can Load address
code_instruction(file, LOAD_ADDRESS, CURRENT_STATIC_LINK, EAX);
code_instruction(file, MOVE, EAX, NEXT_STATIC_LINK);
}
else
{
code_instruction(file, MOVE, CURRENT_STATIC_LINK, EDI);
int i;
int hops = caller_nested - callee_nested + 1;
for (i = 0; i < hops - 1; i++)
code_instruction(file, MOVE, make_relative_address(0, EDI), EDI);
code_instruction(file, MOVE, EDI, NEXT_STATIC_LINK);
}
code_instruction(file, CALL, function->name, NULL);
}
//Clean up the stack
if (arg_count > 0)
{
code_instruction(file, ADD, make_integer(arg_count * 4), ESP);
arg_count = 0;
}
if (result != NULL)
{
//Return values are put in eax
insert_register(registers, REG_EAX, result, TRUE);
}
}
void code_begin_function(FILE *file, Symbol *symbol)
{
debug("Setting Scope to %s from %s", symbol_to_string(symbol), symbol_to_string(current_scope));
//Set our scope
current_scope = symbol;
//print label
fprintf(file, "%s:\n", symbol->name);
//print our function header
code_instruction(file, PUSH, EBP, NULL);
code_instruction(file, MOVE, ESP, EBP);
if (symbol->symbols->nested == 1)
{
//this is main
code_instruction(file, MOVE, make_integer(0), CURRENT_STATIC_LINK);
}
//Get the last offset, and adjust stack pointer
//FIX 5-19-2011
//int offset = -4;
int offset = -8;
int i;
SymbolTable *table = symbol->symbols;
Symbol *current;
for (i = 0; i < HASHSIZE; i++)
{
current = table->entries[i];
while (current != NULL)
{
if (current->offset < offset)
offset = current->offset;
current = current->next;
}
}
//Set esp to point to the next location after our variables, make it positive so we subtract
int esp_fix = -offset;
code_instruction(file, SUBTRACT, make_integer(esp_fix), ESP);
}
static sexpr graph_to_sexpr (sexpr gsx)
{
struct graph *g = (struct graph *)sx_pointer(gsx);
sexpr sx = sx_false;
if (g != (struct graph *)0)
{
sexpr nodes = sx_end_of_list;
sexpr edges = sx_end_of_list;
unsigned int i;
for (i = 0; i < g->node_count; i++)
{
struct graph_node *n = g->nodes[i];
sexpr sxx = n->label;
sexpr sxn = make_integer(i);
unsigned int j;
nodes = cons (cons (sxn, sxx), nodes);
for (j = 0; j < n->edge_count; j++)
{
struct graph_edge *e = n->edges[j];
unsigned int k;
for (k = 0; k < g->node_count; k++)
{
if (g->nodes[k] == e->target)
{
edges = cons (cons (sxn,
cons (make_integer(k),
e->label)),
edges);
}
}
}
}
sx = cons (nodes, edges);
}
return sx;
}
static void output_add (struct sexpr_io *io)
{
struct memory_pool pool =
MEMORY_POOL_INITIALISER (sizeof (struct output_channel));
struct output_channel *out =
get_pool_mem (&pool);
struct datetime dt;
out->io = io;
out->next = output_channels;
output_channels = out;
multiplex_add_sexpr (io, timer_io_read, (void *)0);
dt = dt_get ();
sx_write (io, sx_list3 (sym_link_initialised,
make_integer (dt.date), make_integer (dt.time)));
}
cell pp_curs_mvgetch(cell x) {
char name[] = "curs:mvgetch";
int c;
if (!Running) return UNSPECIFIC;
c = mvgetch(integer_value(name, car(x)),
integer_value(name, cadr(x)));
if (c == ERR)
return S9_FALSE;
return make_integer(c);
}
//将一个数字（整型或浮点型）无损的转化为整型
// (inexact->exact x)
Cell* op_inexact2exact(Scheme *sc) {
Cell* num;
double dd;
num = first(sc->args);
if (num->_num.isFix) {
return s_return_helper(sc, num);
} else if (modf(num->_num.doubleValue, &dd) == 0.0) {
return s_return_helper(sc, make_integer(sc, long_value(num)));
} else {
return error_helper(sc, "inexact->exact: not integral:", num);
}
}
static FILE *open_terminfo (char *file, SLterminfo_Type *h)
{
FILE *fp;
unsigned char buf[12];
/* Alan Cox reported a security problem here if the application using the
* library is setuid. So, I need to make sure open the file as a normal
* user. Unfortunately, there does not appear to be a portable way of
* doing this, so I am going to use 'setfsgid' and 'setfsuid', which
* are not portable.
*
* I will also look into the use of setreuid, seteuid and setregid, setegid.
* FIXME: Priority=medium
*/
fp = fopen (file, "rb");
if (fp == NULL) return NULL;
if ((12 == fread ((char *) buf, 1, 12, fp) && (MAGIC == make_integer (buf))))
{
h->name_section_size = make_integer (buf + 2);
h->boolean_section_size = make_integer (buf + 4);
h->num_numbers = make_integer (buf + 6);
h->num_string_offsets = make_integer (buf + 8);
h->string_table_size = make_integer (buf + 10);
}
else
{
fclose (fp);
fp = NULL;
}
return fp;
}
int _pSLtt_tigetnum (SLterminfo_Type *t, SLCONST char *cap)
{
int offset;
if (t == NULL)
return -1;
if (t->flags == SLTERMCAP) return tcap_getnum (cap, t);
offset = compute_cap_offset (cap, t, Tgetnum_Map, t->num_numbers);
if (offset < 0) return -1;
return make_integer (t->numbers + 2 * offset);
}
void code_arg(FILE *file, RegDesc *registers, Symbol *result)
{
arg_count++;
debug("Code_Arg - Symbol: %s, Arg Count: %d", symbol_to_string(result), arg_count);
code_spill_all(file, registers);
clear_registers(registers);
if (result->type->code == TYPE_NATURAL)
code_instruction(file, PUSH, make_integer(result->value.integer), NULL);
else
code_instruction(file, PUSH, get_location(file, registers, result), NULL);
}
int main()
{
Atom p;
p = make_integer(42);
print_expr(p);
printf("\n");
p = make_symbol("jacky lau");
print_expr(p);
printf("\n");
p = cons(make_integer(1), nil);
print_expr(p);
printf("\n");
p = nil;
print_expr(p);
printf("\n");
p = cons(make_integer(1), cons(make_integer(2), cons(make_integer(3), nil)));
print_expr(p);
printf("\n");
p = cons(make_integer(1), cons(make_integer(2), cons(make_integer(3), make_symbol("hello world"))));
print_expr(p);
printf("\n");
p = cons(make_symbol("X"), make_symbol("Y"));
print_expr(p);
printf("\n");
p = cons(make_symbol("+"), cons(cons(make_symbol("+"), cons(make_integer(2), cons(make_integer(3), nil))), cons(make_integer(4), nil)));
print_expr(p);
printf("\n");
}
char *_pSLtt_tigetstr (SLterminfo_Type *t, SLCONST char *cap)
{
int offset;
if (t == NULL)
return NULL;
if (t->flags == SLTERMCAP) return tcap_getstr (cap, t);
offset = compute_cap_offset (cap, t, Tgetstr_Map, t->num_string_offsets);
if (offset < 0) return NULL;
offset = make_integer (t->string_offsets + 2 * offset);
if (offset < 0) return NULL;
return t->string_table + offset;
}
void code_load_reg(FILE *file, RegDesc *registers, int reg, Symbol *symbol)
{
char *name = registers[reg].name;
debug("Code_Load_Reg %s to %d", symbol->name, reg);
switch (symbol->type->code)
{
case TYPE_NATURAL:
code_instruction(file, MOVE, make_integer(symbol->value.integer), name);
break;
default:
code_instruction(file, MOVE, get_destination(file, registers, symbol), name);
break;
}
}
/*---------------------------------------------------------------------*/
pair_t *
readlist( FILE *file ) {
token_t *tok = parse_token( file );
pair_t *res = NIL;
if( !tok ) {
fprintf( stderr, "Premature end of file\n" );
return 0L;
} else {
if( tok->tok == TOKEN_CLOPAR ) {
return res;
} else {
obj_t *car;
switch( tok->tok ) {
case TOKEN_OPENPAR:
car = (obj_t *)readlist( file );
break;
case TOKEN_SYMBOL:
car = (obj_t *)make_symbol( tok->val );
break;
case TOKEN_GUIL:
car = (obj_t *)readguil( file );
if( !car ) car = (obj_t *)NIL;
break;
case TOKEN_INT:
car = (obj_t *)make_integer( atol( tok->val ) );
break;
default:
fprintf( stderr, "Illegal %s: %s\n",
token_type( tok ),
tok->val );
car = (obj_t *)NIL;
}
return cons( car, readlist( file ) );
}
}
}
void add_int_constant(Scheme *sc, char *name, long value) {
add_constant(sc, name, make_integer(sc, value));
}
cell pp_curs_lines(cell x) {
return make_integer(LINES);
}
char *get_destination(FILE *file, RegDesc *registers, Symbol *symbol)
{
debug("Getting destination for %s in scope %s", symbol->name, current_scope->name);
char *name;
if (symbol->is_array_element)
name = symbol->array->name;
else
name = symbol->name;
Symbol *lookup = symboltable_lookup(current_scope->symbols, name);
char *base;
if (lookup == NULL)
{
debug("Variable declared in another scope");
//Load our SL into EDI
code_instruction(file, MOVE, CURRENT_STATIC_LINK, EDI);
int hops = 0;
SymbolTable *current = current_scope->symbols;
while (symboltable_lookup(current, name) == NULL)
{
hops++;
current = current->parent;
}
int i;
for (i = 0; i < hops - 1; i++)
{
code_instruction(file, MOVE, make_relative_address(0, EDI), EDI);
}
code_instruction(file, ADD, make_integer(4), EDI);
base = EDI;
}
else
{
base = EBP;
}
if (symbol->is_array_element == FALSE)
{
code_comment(file, "Variable %s", symbol->name);
return make_memory_offset(symbol, base);
}
else
{
//We have a bit more work
//If the index is a constant, we can give a constant address
Symbol *array = symbol->array;
Symbol *index = symbol->index;
if (index->type->code == TYPE_NATURAL)
{
//Calculate constant offset
int offset = array->type->c + index->value.integer * 4;
debug("Constant offset");
code_comment(file, "Array Constant Index for %s", symbol->name);
return make_relative_address(offset, base);
}
else
{
//AT&T has a syntax for arrays:
//0(%ebp, %esi, 4) -> 0 + %ebp + %esi * 4
//I want to avoidl multiplying the index by negative one...lets think about this
//Well I flipped the array in memory so the last index is first, we now solved our problem
code_comment(file, "Array Variable Index for %s", symbol->name);
//Step 1: load index
code_instruction(file, MOVE, get_location(file, registers, index), ESI);
//code_instruction(file, MOVE, get_destination(file, registers, index), ESI);
//Step 2: print
char *dest = make_array_offset(array->type->c, base, ESI);
code_comment(file, "Index: %s", dest);
return dest;
}
}
}
// ### %run-shell-command
// run-shell-command is defined in run-shell-command.lisp
Value SYS_run_shell_command_internal(Value arg)
{
AbstractString * command = check_string(arg);
int ret = system(command->copy_to_c_string());
return make_integer(ret == -1 ? ret : WEXITSTATUS(ret));
}
cell pp_curs_get_magic_value(cell x) {
char *s = string(car(x));
if (!strcmp(s, "A_BOLD")) return make_integer(A_BOLD);
if (!strcmp(s, "A_NORMAL")) return make_integer(A_NORMAL);
if (!strcmp(s, "A_STANDOUT")) return make_integer(A_STANDOUT);
if (!strcmp(s, "A_UNDERLINE")) return make_integer(A_UNDERLINE);
if (!strcmp(s, "KEY_BACKSPACE")) return make_integer(KEY_BACKSPACE);
if (!strcmp(s, "KEY_DC")) return make_integer(KEY_DC);
if (!strcmp(s, "KEY_DOWN")) return make_integer(KEY_DOWN);
if (!strcmp(s, "KEY_END")) return make_integer(KEY_END);
if (!strcmp(s, "KEY_IC")) return make_integer(KEY_IC);
if (!strcmp(s, "KEY_HOME")) return make_integer(KEY_HOME);
if (!strcmp(s, "KEY_LEFT")) return make_integer(KEY_LEFT);
if (!strcmp(s, "KEY_NPAGE")) return make_integer(KEY_NPAGE);
if (!strcmp(s, "KEY_PPAGE")) return make_integer(KEY_PPAGE);
if (!strcmp(s, "KEY_RIGHT")) return make_integer(KEY_RIGHT);
if (!strcmp(s, "KEY_UP")) return make_integer(KEY_UP);
return error("curs:get-magic-value: requested value not found",
car(x));
}
cell pp_curs_cols(cell x) {
return make_integer(COLS);
}
void parser_init(void)
{
//init state constants
state_constants = cons(make_integer(0), NIL);
state_constants = cons(make_integer(1), state_constants);
state_constants = cons(make_integer(2), state_constants);
state_constants = cons(make_integer(3), state_constants);
state_constants = cons(make_integer(4), state_constants);
state_constants = cons(make_integer(5), state_constants);
state_constants = cons(make_integer(6), state_constants);
state_constants = cons(make_integer(7), state_constants);
state_constants = cons(make_integer(8), state_constants);
state_constants = cons(make_integer(9), state_constants);
state_constants = cons(make_integer(10), state_constants);
state_constants = cons(make_integer(11), state_constants);
//set state constants
set_state_constants();
//init current_state
current_state = STATE_INIT;
}
