Obj *read_sexp(Env *env, Obj *root, char **p) {
VAR(obj);
VAR(head);
VAR(tail);
VAR(tmp);
for (;;) {
*obj = read_one(env, root, p);
if (!*obj)
error("unclosed parenthesis");
if (*obj == Dot) {
if (*head == NULL)
error("stray dot");
*tmp = read_one(env, root, p);
(*tail)->cdr = *tmp;
break;
}
if (*obj == Cparen) {
if (*head == NULL)
return Nil;
break;
}
if (*head == NULL) {
(*head) = (*tail) = make_cell(env, root, obj, &Nil);
} else {
*tmp = make_cell(env, root, obj, &Nil);
(*tail)->cdr = *tmp;
(*tail) = (*tail)->cdr;
}
}
return *head;
}
void add_var_int(Env *env, Obj *root, Obj **sym, Obj **val) {
VAR(cell);
VAR(tmp);
*cell = make_cell(env, root, sym, val);
*tmp = env->vars;
*tmp = make_cell(env, root, cell, tmp);
env->vars = *tmp;
}
Obj *read_quote(Env *env, Obj *root, char **p) {
VAR(sym);
VAR(tmp);
*sym = intern(env, root, "quote");
*tmp = read(env, root, p);
*tmp = make_cell(env, root, tmp, &Nil);
*tmp = make_cell(env, root, sym, tmp);
return *tmp;
}
static SCM make_board (SCM s_width, SCM s_height) {
int i;
int j;
SCM smob;
struct board *board;
int width = scm_to_int(s_width);
int height = scm_to_int(s_height);
board = (struct board *) scm_gc_malloc(sizeof(struct board), "board");
board->width = width;
board->height = height;
board->update_func = SCM_BOOL_F;
board->cell_list = SCM_EOL;
for (i = height - 1; i >= 0; i--) {
SCM row = SCM_EOL;
for (j = width - 1; j >= 0; j--) {
SCM y_offset = scm_from_int(i);
SCM x_offset = scm_from_int(j);
row = scm_cons(make_cell(x_offset, y_offset, scm_from_int(0)), row);
}
board->cell_list = scm_cons(row, board->cell_list);
}
SCM_NEWSMOB(smob, board_tag, board);
return smob;
}
void os_erase_area (int top, int left, int bottom, int right, int winnum)
{
int row, col;
top--; left--; bottom--; right--;
for (row = top; row <= bottom; row++)
for (col = left; col <= right; col++)
dumb_set_cell(row, col, make_cell(current_style, ' '));
}
static void clear_row(int row)
{
uint16_t cell = make_cell(' ', WHITE_ON_BLACK);
uint16_t *mem = get_vga_base() + row * MAX_COLS;
for (int i = 0; i < MAX_COLS; ++i)
{
mem[i] = cell;
}
}
ListPtr Parser::read_list()
{
CellPtr head = make_cell();
CellPtr current = head;
m_word = m_scanner->get_word();
ExprPtr expr;
if (m_word.type == ")") {
return head;
}
else {
expr = read_expr();
head->setcar(expr);
m_word = m_scanner->get_word();
}
while (m_word.type != ")") {
if (m_word.type == ".") {
m_word = m_scanner->get_word();
expr = read_expr();
current->setcdr(expr);
m_word = m_scanner->get_word();
}
else if (m_word.type == ")") {
break;
}
else {
expr = read_expr();
CellPtr new_cell = make_cell();
new_cell->setcar(expr);
current->setcdr(new_cell);
current = new_cell;
m_word = m_scanner->get_word();
}
}
return head;
}
static ERL_NIF_TERM
make_row(ErlNifEnv *env, sqlite3_stmt *statement, ERL_NIF_TERM *array, int size)
{
if(!array)
return make_error_tuple(env, "no_memory");
for(int i = 0; i < size; i++)
array[i] = make_cell(env, statement, i);
return enif_make_tuple_from_array(env, array, size);
}
/* put a character in the cell at the cursor and advance the cursor. */
static void dumb_display_char(char c)
{
dumb_set_cell(cursor_row, cursor_col, make_cell(current_style, c));
if (++cursor_col == h_screen_cols)
if (cursor_row == h_screen_rows - 1)
cursor_col--;
else {
cursor_row++;
cursor_col = 0;
}
}
Obj *eval_list(Env *env, Obj *root, Obj **list) {
VAR(head);
VAR(tail);
VAR(lp);
VAR(tmp);
for (lp = list; *lp != Nil; *lp = (*lp)->cdr) {
*tmp = (*lp)->car;
*tmp = eval(env, root, tmp);
if (*head == NULL) {
*head = *tail = make_cell(env, root, tmp, &Nil);
} else {
*tmp = make_cell(env, root, tmp, &Nil);
(*tail)->cdr = *tmp;
*tail = (*tail)->cdr;
}
}
if (head == NULL)
error("eval_list: empty list?");
return *head;
}
void add_env(Env *env, Obj *root, Env *newenv, Obj **vars, Obj **values) {
if (list_length(*vars) != list_length(*values))
error("cannot apply function: number of argument does not match");
VAR(p);
VAR(q);
VAR(sym);
VAR(val);
VAR(def);
VAR(map);
*map = Nil;
int i;
for (p = vars, q = values; *p != Nil; *p = (*p)->cdr, *q = (*q)->cdr) {
*val = (*q)->car;
*sym = (*p)->car;
*def = make_cell(env, root, sym, val);
*map = make_cell(env, root, def, map);
}
newenv->vars = *map;
newenv->next = env;
}
static void __lambda_15(void *data, int argc, object self_7381, object k_7349, object obj_7313) {
closureN_type c_73106;
c_73106.hdr.mark = gc_color_red;
c_73106.hdr.grayed = 0;
c_73106.tag = closureN_tag;
c_73106.fn = (function_type)__lambda_14;
c_73106.num_args = 1;
c_73106.num_elements = 2;
c_73106.elements = (object *)alloca(sizeof(object) * 2);
c_73106.elements[0] = ((closureN)self_7381)->elements[0];
c_73106.elements[1] = k_7349;
make_cell(c_73178,obj_7313);
return_closcall1(data,(closure)&c_73106, &c_73178);;
}
static ERL_NIF_TERM
make_row(ErlNifEnv *env, sqlite3_stmt *statement)
{
int i, size;
ERL_NIF_TERM *array;
ERL_NIF_TERM row;
size = sqlite3_column_count(statement);
array = (ERL_NIF_TERM *) malloc(sizeof(ERL_NIF_TERM)*size);
if(!array)
return make_error_tuple(env, "no_memory");
for(i = 0; i < size; i++)
array[i] = make_cell(env, statement, i);
row = make_row_tuple(env, enif_make_tuple_from_array(env, array, size));
free(array);
return row;
}
void insert(int value, cell *tree){
cell *new_cell = make_cell(value, NULL, NULL);
while(true){
if(value <= tree->value){
if(tree->left != NULL){
tree = tree->left;
}else{
tree->left = new_cell;
break;
}
}else{
if(tree->right != NULL){
tree = tree->right;
}else{
tree->right = new_cell;
break;
}
}
}
}
void cell_spin(int rank, int ncell, MPI_Comm comm)
{
cell_list cells;
int i;
int msg;
cells = make_cell_list();
/* Build the list of cells */
for ( i = 0; i < ncell; i++ ) {
if ( rank == get_cell_rank(i) ) {
push(make_cell(i), &(cells->cells));
}
}
i = 0;
/* Loop, updating the list of cells. Every time through the loop,
* we look to see if we have a control message (from the master)
* and if so, act accordingly (reset cells for end of year, or
* finish simulation). Note the the control message could arrive
* while in the update_cell_list function, so that also probes for
* interrupts and returns early if it gets one. */
do {
MPI_Status status;
int flag;
msg = -1;
update_cell_list(cells, comm);
MPI_Iprobe(0, CONTROL_TAG, comm, &flag, &status);
if ( flag ) {
MPI_Recv(&msg, 1, MPI_INT, status.MPI_SOURCE,
status.MPI_TAG, comm, &status);
}
if ( msg == YEAR_END ) {
list it;
for ( it = cells->cells; it; it = it->next ) {
print_cell((cell)(it->data));
}
reset_cell_list(cells);
}
} while ( msg != SIMULATION_END )
;
delete_cell_list(cells);
}
void vga_putc(char c)
{
struct cursor cur = get_cursor();
if (c == '\n')
{
++cur.row;
cur.column = 0;
}
else
{
uint16_t cell = make_cell(c, WHITE_ON_BLACK);
*get_vga_address(cur) = cell;
++cur.column;
if (cur.column == MAX_COLS)
{
++cur.row;
cur.column = 0;
}
}
update_screen(cur);
}
Obj *prim_cons(Env *env, Obj *root, Obj **list)
{
VAR(args);
*args = eval_list(env, root, list);
return make_cell(env, root, &(*args)->car, &(*args)->cdr->car);
}
CellPtr make_nil()
{
return make_cell(nullptr, nullptr);
}
CellPtr cons(ExprPtr a, ExprPtr d)
{
CellPtr c = make_cell(a, d);
return c;
}
bool dumb_output_handle_setting(const char *setting, bool show_cursor,
bool startup)
{
char *p;
int i;
if (!strncmp(setting, "pb", 2)) {
toggle(&show_pictures, setting[2]);
printf("Picture outlines display %s\n", show_pictures ? "ON" : "OFF");
if (startup)
return TRUE;
for (i = 0; i < screen_cells; i++)
screen_changes[i] = (cell_style(screen_data[i]) == PICTURE_STYLE);
dumb_show_screen(show_cursor);
} else if (!strncmp(setting, "vb", 2)) {
toggle(&visual_bell, setting[2]);
printf("Visual bell %s\n", visual_bell ? "ON" : "OFF");
os_beep(1); os_beep(2);
} else if (!strncmp(setting, "ln", 2)) {
toggle(&show_line_numbers, setting[2]);
printf("Line numbering %s\n", show_line_numbers ? "ON" : "OFF");
} else if (!strncmp(setting, "lt", 2)) {
toggle(&show_line_types, setting[2]);
printf("Line-type display %s\n", show_line_types ? "ON" : "OFF");
} else if (*setting == 'c') {
switch (setting[1]) {
case 'm': compression_mode = COMPRESSION_MAX; break;
case 's': compression_mode = COMPRESSION_SPANS; break;
case 'n': compression_mode = COMPRESSION_NONE; break;
case 'h': hide_lines = atoi(&setting[2]); break;
default: return FALSE;
}
printf("Compression mode %s, hiding top %d lines\n",
compression_names[compression_mode], hide_lines);
} else if (*setting == 'r') {
switch (setting[1]) {
case 'n': rv_mode = RV_NONE; break;
case 'o': rv_mode = RV_DOUBLESTRIKE; break;
case 'u': rv_mode = RV_UNDERLINE; break;
case 'c': rv_mode = RV_CAPS; break;
case 'b': rv_blank_char = setting[2] ? setting[2] : ' '; break;
default: return FALSE;
}
printf("Reverse-video mode %s, blanks reverse to '%c': ",
rv_names[rv_mode], rv_blank_char);
for (p = "sample reverse text"; *p; p++)
show_cell(make_cell(REVERSE_STYLE, *p));
putchar('\n');
for (i = 0; i < screen_cells; i++)
screen_changes[i] = (cell_style(screen_data[i]) == REVERSE_STYLE);
dumb_show_screen(show_cursor);
} else if (!strcmp(setting, "set")) {
printf("Compression Mode %s, hiding top %d lines\n",
compression_names[compression_mode], hide_lines);
printf("Picture Boxes display %s\n", show_pictures ? "ON" : "OFF");
printf("Visual Bell %s\n", visual_bell ? "ON" : "OFF");
os_beep(1); os_beep(2);
printf("Line Numbering %s\n", show_line_numbers ? "ON" : "OFF");
printf("Line-Type display %s\n", show_line_types ? "ON" : "OFF");
printf("Reverse-Video mode %s, Blanks reverse to '%c': ",
rv_names[rv_mode], rv_blank_char);
for (p = "sample reverse text"; *p; p++)
show_cell(make_cell(REVERSE_STYLE, *p));
putchar('\n');
} else
return FALSE;
return TRUE;
}
void dumb_display_user_input(char *s)
{
/* copy to screen without marking it as a change. */
while (*s)
dumb_row(cursor_row)[cursor_col++] = make_cell(0, *s++);
}
void dumb_set_picture_cell(int row, int col, char c)
{
dumb_set_cell(row, col, make_cell(PICTURE_STYLE, c));
}
