static void do_state_dot(char **pscan)
{
if (is_digit(**pscan)){
//deal with real, this for extend
;
} else if (**pscan == '.'){
++*pscan;
if (**pscan != '.'){
printf("Error: illegally uses '.' -- READ\n");
do_input_error(pscan);
} else{
++*pscan;
if (is_delimiter(**pscan) || **pscan == '\0'){
reg = make_symbol("...");
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);
} else{
printf("Error: illegally uses '.' -- READ\n");
do_input_error(pscan);
}
}
} else if (is_delimiter(**pscan) && stack_top(&state_stack) == STATE_LIST){
stack_push(&parser_stack, make_symbol("."));
current_state = stack_pop(&state_stack);
} else{
printf("Error: illegally uses '.' -- READ\n");
do_input_error(pscan);
}
}
static void parse_sym(char **pscan)
{
char rbuf[50];
char *rbufp = rbuf;
*rbufp++ = **pscan;
++*pscan;
while (!is_delimiter(**pscan) && **pscan != '\0'){
*rbufp++ = **pscan;
if (!is_subsequent(**pscan)){
printf("Error: %s is a illegal symbol. -- READ\n", rbuf);
do_input_error(pscan);
}
++*pscan;
}
*rbufp = '\0';
reg = make_symbol(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);
}
static data_t *transform_let_star(const data_t *assignment, const data_t *body) {
if(cdr(assignment) == NULL)
return cons(make_symbol("let"), cons(assignment, body));
return cons(make_symbol("let"),
cons(cons(car(assignment), NULL),
cons(transform_let_star(cdr(assignment), body), NULL)));
}
static void parse_char(char **pscan)
{
char rbuf[50];
char *rbufp = NULL;
if (**pscan == '\0'){
reg = make_char('\n');
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);
return;
}
rbufp = rbuf;
*rbufp++ = **pscan;
++*pscan;
if (is_delimiter(**pscan) || **pscan == '\0'){
reg = make_char(*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);
}else {
while (!is_delimiter(**pscan) && **pscan != '\0'){
*rbufp++ = **pscan;
++*pscan;
}
*rbufp = '\0';
if (strcmp(rbuf, "space") == 0){
reg = make_char(' ');
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);
}else if (strcmp(rbuf, "newline") == 0){
reg = make_char('\n');
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);
}else {
printf("Error: Bad character constant #\\%s -- READ", rbuf);
do_input_error(pscan);
}
}
}
/*
* call-seq:
* play( options={} ) -> self
*
* Play the Sound, optionally fading in, repeating a certain number of
* times (or forever), and/or stopping automatically after a certain time.
*
* See also #pause and #stop.
*
* options:: Hash of options, listed below. (Hash, required)
*
* :fade_in:: Fade in from silence over the given number of seconds.
* (Numeric)
* :repeats:: Repeat the sound the given number of times, or forever
* (or until stopped) if -1. (Integer)
* :stop_after:: Automatically stop playing after playing for the given
* number of seconds. (Numeric)
*
* Returns:: The receiver (self).
* May raise:: SDLError, if the sound file could not be played.
*
* **NOTE**: If the sound is already playing (or paused), it will be stopped
* and played again from the beginning.
*
* Example:
* # Fade in over 2 seconds, play 4 times (1 + 3 repeats),
* # but stop playing after 5 seconds.
* sound.play( :fade_in => 2, :repeats => 3, :stop_after => 5 );
*
*/
static VALUE rg_sound_play( int argc, VALUE *argv, VALUE self )
{
RG_Sound *sound;
Data_Get_Struct(self, RG_Sound, sound);
VALUE options;
rb_scan_args(argc, argv, "01", &options);
int fade_in = 0;
int repeats = 0;
int stop_after = -1;
/* If we got some options */
if( RTEST(options) )
{
/* Make sure options is a Hash table */
if( TYPE(options) != T_HASH )
{
rb_raise(rb_eTypeError, "wrong argument type %s (expected Hash)",
rb_obj_classname(options));
}
VALUE temp;
temp = rb_hash_aref(options, make_symbol("fade_in"));
if( RTEST(temp) )
{
fade_in = (int)(1000 * NUM2DBL( temp ));
}
temp = rb_hash_aref(options, make_symbol("repeats"));
if( RTEST(temp) )
{
repeats = NUM2INT(temp);
}
temp = rb_hash_aref(options, make_symbol("stop_after"));
if( RTEST(temp) )
{
stop_after = (int)(1000 * NUM2DBL( temp ));
}
}
int result = _rg_sound_play( sound, fade_in, repeats, stop_after );
if( result == -1 )
{
rb_raise(eSDLError, "Could not play Sound: %s", Mix_GetError());
}
return self;
}
data_t *extend_environment(const data_t *vars, const data_t *vals, data_t *env) {
int lvars = length(vars), lvals = length(vals);
if(lvars == lvals)
return cons(make_frame(vars, vals), env);
if(lvars < lvals) {
printf("Too many arguments supplied. (Expected %d, got %d)\n", lvars, lvals);
return make_symbol("error");
} else {
printf("Too few arguments supplied (Expected %d, got %d)\n", lvars, lvals);
return make_symbol("error");
}
}
///////////////////////////////////////////////////////////////////
//let* expression
///////////////////////////////////////////////////////////////////
static cellpoint is_letstar(cellpoint exp)
{
reg = exp;
args_push(make_symbol("let*"));
args_push(reg);
return is_tagged_list();
}
//two args: bindings & body
static cellpoint make_let(void)
{
reg = cons(args_ref(1), args_ref(2));
reg = cons(make_symbol("let"), reg);
args_pop(2);
return reg;
}
////////////////////////////////////////////////////////////////
//and & or expressions
///////////////////////////////////////////////////////////////
static cellpoint is_and(cellpoint exp)
{
reg = exp;
args_push(make_symbol("and"));
args_push(reg);
return is_tagged_list();
}
//one arg: exps
static cellpoint make_begin(void)
{
reg = make_symbol("begin");
reg = cons(reg, args_ref(1));
args_pop(1);
return reg;
}
/* this doesn't read the peculiar identifiers, they are scanned in the
* main reader body */
static object read_identifier(FILE *in)
{
object o;
int str_len = 0;
int str_size = STRING_MIN_BUFFER;
char *buffer;
int c;
buffer = xmalloc(str_size);
c = tolower(fgetc(in));
assert(is_initial(c));
buffer[str_len++] = c;
while (1) {
c = fgetc(in);
if (is_delimiter(c)) {
ungetc(c, in);
break;
}
if (!is_subsequent(c))
error("Symbol has bad name -- read", nil);
/* we're a lower case scheme */
buffer[str_len++] = tolower(c);
}
o = make_symbol(buffer, str_len);
xfree(buffer);
return o;
}
/*---------------------------------------------------------------------*/
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;
}
}
}
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);
}
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);
}
static void parse_string(char *ibuf, char **pscan)
{
char rbuf[100];
char *rbufp = rbuf;
while (**pscan != '"'){
if (**pscan == '\\'){
++*pscan;
if (**pscan == '\\' || **pscan == '"'){
*rbufp++ = **pscan;
++*pscan;
}else {
printf("Error: unknown escape sequence \\%c in string. -- READ\n",**pscan);
do_input_error(pscan);
return;
}
}else if (**pscan == '\0'){
*rbufp++ = '\n';
*pscan = reload_ibuffer(ibuf);
}else {
*rbufp++ = **pscan;
++*pscan;
}
}
*rbufp = '\0';
reg = chars_2_string(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);
++*pscan;
}
int parse_simple(char *start, char *end, Atom *result)
{
char *p;
int value = strtoimax(start, &p, 10);
/*it is integer*/
if(p == end) {
result->type = ATOM_INTEGER;
result->value.integer = value;
//return true;
return ERROR_OK;
}
/*nil or symbol*/
char *buf = malloc(end - start + 1);
p = buf;
while(start != end) {
*p++= *start++;
}
*p = '\0';
/*convert to uppercase*/
convertToUpperCase(buf);
if(strcmp(buf, "NIL") == 0)
*result = nil;
else
*result = make_symbol(buf);
free(buf);
return ERROR_OK;
}
scm_closure_t
VM::lookup_system_closure(const char* name)
{
scm_obj_t proc = m_heap->lookup_system_environment(make_symbol(m_heap, name));
if (CLOSUREP(proc)) return (scm_closure_t)proc;
fatal("fatal: #<closure %s> not available in system environment", name);
}
static void do_state_sub(char **pscan)
{
if (is_delimiter(**pscan) || **pscan == '\0'){
reg = make_symbol("-");
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);
}else {
printf("Error: illegally uses '-' -- READ\n");
do_input_error(pscan);
}
}
def_t *
emit_structure (const char *name, int su, struct_def_t *defs, type_t *type,
void *data, storage_class_t storage)
{
int i, j;
int saw_null = 0;
int saw_func = 0;
symbol_t *struct_sym;
symbol_t *field_sym;
def_t *struct_def;
def_t field_def;
name = save_string (name);
if (!type)
type = make_structure (0, su, defs, 0)->type;
if (!is_struct (type) || (su == 's' && type->meta != ty_struct)
|| (su == 'u' && type->meta != ty_union))
internal_error (0, "structure %s type mismatch", name);
for (i = 0, field_sym = type->t.symtab->symbols; field_sym;
i++, field_sym = field_sym->next) {
if (!defs[i].name)
internal_error (0, "structure %s unexpected end of defs", name);
if (field_sym->type != defs[i].type)
internal_error (0, "structure %s.%s field type mismatch", name,
defs[i].name);
if ((!defs[i].emit && saw_func) || (defs[i].emit && saw_null))
internal_error (0, "structure %s mixed emit/copy", name);
if (!defs[i].emit)
saw_null = 1;
if (defs[i].emit)
saw_func = 1;
}
if (defs[i].name)
internal_error (0, "structure %s too many defs", name);
if (storage != sc_global && storage != sc_static)
internal_error (0, "structure %s must be global or static", name);
struct_sym = make_symbol (name, type, pr.far_data, storage);
struct_def = struct_sym->s.def;
if (struct_def->initialized)
internal_error (0, "structure %s already initialized", name);
struct_def->initialized = struct_def->constant = 1;
struct_def->nosave = 1;
for (i = 0, field_sym = type->t.symtab->symbols; field_sym;
i++, field_sym = field_sym->next) {
field_def.type = field_sym->type;
field_def.name = save_string (va ("%s.%s", name, field_sym->name));
field_def.space = struct_def->space;
field_def.offset = struct_def->offset + field_sym->s.offset;
if (!defs[i].emit) {
//FIXME relocs? arrays? structs?
pr_type_t *val = (pr_type_t *) data;
memcpy (D_POINTER (void, &field_def), val,
type_size (field_def.type) * sizeof (pr_type_t));
data = &val[type_size (field_def.type)];
} else {
if (is_array (field_def.type)) {
static void write_section_sym(Elf *elf, int *index, String *symtab, String *strtab) {
for (int i = 0; i < LIST_LEN(elf->sections); i++) {
Section *sect = LIST_REF(elf->sections, i);
Symbol *sym = make_symbol(NULL, sect, 0, STB_LOCAL, STT_SECTION, 1);
write_one_symbol(sym, index, symtab, strtab);
sect->symindex = sym->index;
}
}
END_TEST
START_TEST (test_make_symbol)
{
object *o = make_symbol ("test");
ck_assert (lookup ("test") != NULL);
ck_assert_str_eq (o->data.string.value, "test");
}
/////////////////////////////////////////////////////
//assignment
//format: (set! <var> <value>)
/////////////////////////////////////////////////////
static cellpoint is_assignment(cellpoint exp)
{
reg = exp;
args_push(make_symbol("set!"));
args_push(reg);
reg = is_tagged_list();
return reg;
}
///////////////////////////////////////////////////////////////
//definition
//format: (define <var> <value>) or
// (define (var <formals>) <body>)
//////////////////////////////////////////////////////////////
static cellpoint is_definition(cellpoint exp)
{
reg = exp;
args_push(make_symbol("define"));
args_push(reg);
reg = is_tagged_list();
return reg;
}
/////////////////////////////////////////////////////////////////
//begin
//format: (begin <exps>)
/////////////////////////////////////////////////////////////////
static cellpoint is_begin(cellpoint exp)
{
reg = exp;
args_push(make_symbol("begin"));
args_push(reg);
reg = is_tagged_list();
return reg;
}
//////////////////////////////////////////////////////////
//lambda
//format: (lambda <formal> <body>)
//////////////////////////////////////////////////////////
static cellpoint is_lambda(cellpoint exp)
{
reg = exp;
args_push(make_symbol("lambda"));
args_push(reg);
reg = is_tagged_list();
return reg;
}
//////////////////////////////////////////////////////
//quotation
//format: (quote <datum>)
//////////////////////////////////////////////////////
static cellpoint is_quoted(cellpoint exp)
{
reg = exp;
args_push(make_symbol("quote"));
args_push(reg);
reg = is_tagged_list();
return reg;
}
static void iterator(void *key, void *value, void *user_data) {
char *name = (char *)key;
OperatorFunc func = (OperatorFunc)value;
Scheme *sc = (Scheme *)user_data;
if (!is_internal_operator(name))
new_slot_in_env(sc, make_symbol(sc, name), make_func(sc, func));
}
// May create a new symbol. If there's a symbol with the same name, it will not create a new symbol
// but return the existing one.
static Obj *intern(void *root, char *name) {
for (Obj *p = Symbols; p != Nil; p = p->cdr)
if (strcmp(name, p->car->name) == 0)
return p->car;
DEFINE1(sym);
*sym = make_symbol(root, name);
Symbols = cons(root, sym, &Symbols);
return *sym;
}
SchemeObject* SchemeObjectCreator::make_tagged_list(
std::string tag,
SchemeObject* obj)
{
return make_pair(
make_symbol(tag),
make_pair(obj, make_empty_list())
);
}
static symbol_t *
param_symbol (const char *name)
{
symbol_t *sym;
sym = make_symbol (name, &type_param, pr.symtab->space, sc_extern);
if (!sym->table)
symtab_addsymbol (pr.symtab, sym);
return sym;
}