Example #1
0
static void pack_list(t_pack *x, t_symbol *s, int ac, t_atom *av)
{
#ifdef ROCKBOX
    (void) s;
#endif
    obj_list(&x->x_obj, 0, ac, av);
}
Example #2
0
static void pack_list(t_pack *x, t_symbol *s, int ac, t_atom *av)
{
	if (ac==0)
		pack_bang(x);
	else
	    obj_list(&x->x_obj, 0, ac, av);
}
Example #3
0
static void pack_anything(t_pack *x, t_symbol *s, int ac, t_atom *av)
{
    t_atom *av2 = (t_atom *)getbytes((ac + 1) * sizeof(t_atom));
    int i;
    for (i = 0; i < ac; i++)
    	av2[i + 1] = av[i];
    SETSYMBOL(av2, s);
    obj_list(&x->x_obj, 0, ac+1, av2);
    freebytes(av2, (ac + 1) * sizeof(t_atom));
}
Example #4
0
char *build_module(struct manifest *m, bool keep, char **errstr)
{
	char *name = link_objects(m, m->basename, false, obj_list(m), errstr);
	if (name) {
		if (keep) {
			char *realname = talloc_asprintf(m, "%s.o", m->dir);
			/* We leave this object file around, all built. */
			if (!move_file(name, realname))
				err(1, "Renaming %s to %s", name, realname);
			name = realname;
		}
	}
	return name;
}
Example #5
0
    /* handle "list" messages to Pds without explicit list methods defined. */
static void pd_defaultlist(t_pd *x, t_symbol *s, int argc, t_atom *argv)
{
            /* a list with no elements is handled by the 'bang' method if
            one exists. */
    if (argc == 0 && *(*x)->c_bangmethod != pd_defaultbang)
    {
        (*(*x)->c_bangmethod)(x);
        return;
    }
            /* a list with one element which is a number can be handled by a
            "float" method if any is defined; same for "symbol", "pointer". */
    if (argc == 1)
    {
        if (argv->a_type == A_FLOAT &&
        *(*x)->c_floatmethod != pd_defaultfloat)
        {
            (*(*x)->c_floatmethod)(x, argv->a_w.w_float);
            return;
        }
        else if (argv->a_type == A_SYMBOL &&
            *(*x)->c_symbolmethod != pd_defaultsymbol)
        {
            (*(*x)->c_symbolmethod)(x, argv->a_w.w_symbol);
            return;
        }
        else if (argv->a_type == A_POINTER &&
            *(*x)->c_pointermethod != pd_defaultpointer)
        {
            (*(*x)->c_pointermethod)(x, argv->a_w.w_gpointer);
            return;
        }
    }
        /* Next try for an "anything" method */
    if ((*x)->c_anymethod != pd_defaultanything)
        (*(*x)->c_anymethod)(x, &s_list, argc, argv);

        /* if the object is patchable (i.e., can have proper inlets)
            send it on to obj_list which will unpack the list into the inlets */
    else if (argc>0 && (*x)->c_patchable)
        obj_list((t_object *)x, s, argc, argv);
            /* otherwise give up and complain. */
    else pd_defaultanything(x, &s_list, argc, argv);
}
Example #6
0
void print_generic_array_or_struct(Obj *total, Obj *type_lookup, struct Obj *arg_to_str_obj) {
  assert(total);
  assert(total->tag == 'S');
  assert(type_lookup);
  assert(arg_to_str_obj);
  
  shadow_stack_push(total);
  shadow_stack_push(type_lookup);
  shadow_stack_push(arg_to_str_obj);
	
  Obj *reffed_arg_type = obj_list(obj_new_keyword("ref"), type_lookup); // HACK: ref needed when sending arrays into str
  Obj *args_type = obj_list(reffed_arg_type);
  Obj *signature = obj_list(obj_new_keyword("fn"), args_type, type_string);
  Obj *quoted_sig = obj_list(lisp_quote, signature);

  //printf("quoted_sig: %s\n", obj_to_string(quoted_sig)->s);
	
  Obj *call_to_generic_name = obj_list(obj_new_symbol("generic-name"), obj_new_string("str"), quoted_sig);

  shadow_stack_push(call_to_generic_name);
  Obj *generic_name_result = eval(global_env, call_to_generic_name);
  shadow_stack_push(generic_name_result);

  if(eval_error) {
    printf("Error when calling generic-name:\n");
    printf("%s\n", obj_to_string(eval_error)->s);
    return;
  }
  else {
    //printf("Generic name: %s\n", obj_to_string_not_prn(generic_name_result)->s);
  }

  // Also make sure this particular version of the str primop has been baked:
  Obj *call_to_bake_generic_primop_auto = obj_list(obj_new_symbol("bake-generic-primop-auto"), obj_new_string("str"), quoted_sig);
  shadow_stack_push(call_to_bake_generic_primop_auto);
  eval(global_env, call_to_bake_generic_primop_auto);

  if(eval_error) {
    printf("Error when calling bake-generic-primop-auto from print_generic_array_or_struct:\n");
    printf("%s\n", obj_to_string(eval_error)->s);
    function_trace_print();
    return;
  }
  else {
    //printf("%s should now exists\n", obj_to_string_not_prn(generic_name_result)->s);
  }

  char *generic_name = obj_to_string_not_prn(generic_name_result)->s;
  //printf("generic_name 1: %s\n", generic_name);

  Obj *call_to_str = obj_list(obj_new_symbol(generic_name), (struct Obj *)arg_to_str_obj);
  
  //   OBS!!!
  //
  //   Calling obj_to_string on the call_to_str form will result in an infinite loop:
  //   printf("Call to str: %s\n", obj_to_string(call_to_str)->s);
  //
  //   DON'T DO IT!!!

  shadow_stack_push(call_to_str);
  Obj *array_to_string_result = eval(global_env, call_to_str);
  shadow_stack_push(array_to_string_result);
  if(eval_error) {
    printf("Error when calling str function for void ptr of type '%s':\n", obj_to_string(type_lookup)->s);
    printf("%s\n", obj_to_string(eval_error)->s);
    assert(false);
    stack_pop();
    obj_string_mut_append(total, "FAIL");
    return;
  }
  obj_string_mut_append(total, obj_to_string_not_prn(array_to_string_result)->s);

  Obj *pop1 = shadow_stack_pop();
  assert(pop1 == array_to_string_result);
  shadow_stack_pop();
  shadow_stack_pop();
  shadow_stack_pop();
  shadow_stack_pop();
  shadow_stack_pop();
  shadow_stack_pop();
  Obj *pop8 = shadow_stack_pop();
  assert(pop8 == total);

  return;
}
Example #7
0
void print_generic_array_or_struct(Process *process, Obj *total, Obj *type_lookup, struct Obj *arg_to_str_obj) {
    assert(total);
    assert(total->tag == 'S');
    assert(type_lookup);
    assert(arg_to_str_obj);

    shadow_stack_push(process, total);
    shadow_stack_push(process, type_lookup);
    shadow_stack_push(process, arg_to_str_obj);

    Obj *reffed_arg_type = obj_list(obj_new_keyword("ref"), type_lookup); // HACK: ref needed when sending arrays into str
    Obj *args_type = obj_list(reffed_arg_type);
    Obj *signature = obj_list(obj_new_keyword("fn"), args_type, type_string);
    Obj *quoted_sig = obj_list(lisp_quote, signature);

    //printf("quoted_sig: %s\n", obj_to_string(quoted_sig)->s);

    Obj *generic_name_result = generic_name(process, "prn", quoted_sig);
    if(eval_error) {
        return;
    }
    shadow_stack_push(process, generic_name_result);

    bake_generic_primop_auto(process, "prn", quoted_sig);
    if(eval_error) {
        return;
    }

    // TODO: why this conversion?
    char *generic_name = obj_to_string_not_prn(process, generic_name_result)->s;
    //printf("generic_name 1: %s\n", generic_name);

    Obj *call_to_str = obj_list(obj_new_symbol(generic_name), (struct Obj *)arg_to_str_obj);

    //   OBS!!!
    //
    //   Calling obj_to_string on the call_to_str form will result in an infinite loop:
    //   printf("Call to str: %s\n", obj_to_string(call_to_str)->s);
    //
    //   DON'T DO IT!!!

    shadow_stack_push(process, call_to_str);

    Obj *array_to_string_result = NULL;
    if(BYTECODE_EVAL) {
        array_to_string_result = bytecode_sub_eval_form(process, process->global_env, call_to_str);
    }
    else {
        array_to_string_result = eval(process, process->global_env, call_to_str);
    }

    shadow_stack_push(process, array_to_string_result);
    if(eval_error) {
        printf("Error when calling str function for void ptr of type '%s':\n", obj_to_string(process, type_lookup)->s);
        printf("%s\n", obj_to_string(process, eval_error)->s);
        assert(false);
        stack_pop(process);
        obj_string_mut_append(total, "FAIL");
        return;
    }
    obj_string_mut_append(total, obj_to_string_not_prn(process, array_to_string_result)->s);

    Obj *pop1 = shadow_stack_pop(process);
    assert(pop1 == array_to_string_result);
    shadow_stack_pop(process);
    shadow_stack_pop(process);
    shadow_stack_pop(process);
    shadow_stack_pop(process);
    Obj *pop8 = shadow_stack_pop(process);
    assert(pop8 == total);

    return;
}
static void pack_list(t_pack *x, t_symbol *s, int ac, t_atom *av)
{
    obj_list(&x->x_obj, 0, ac, av);
}
Example #9
0
File: eval.c Project: JonasG/Carp
void apply(Process *process, Obj *function, Obj **args, int arg_count) {
  if(function->tag == 'L') {

//printf("Calling lambda "); obj_print_cout(function); printf(" with params: "); obj_print_cout(function->params); printf("\n");
//printf("Applying %s with arg count %d\n", obj_to_string(process, function)->s, arg_count);

#if BYTECODE_EVAL

    Obj *calling_env = obj_new_environment(function->env);

    bool allow_rest_args = true;
    env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args);

    //printf("calling_env: %s\n", obj_to_string(process, calling_env)->s);

    shadow_stack_push(process, function);
    shadow_stack_push(process, calling_env);

    /* printf("before\n"); */
    /* shadow_stack_print(process); */

    Obj *result = bytecode_sub_eval_internal(process, calling_env, function->body);

    if(eval_error) {
      return;
    }
    assert(result);

    //printf("result = %s\n", obj_to_string(process, result)->s);
    stack_push(process, result); // put it back on stack (TODO: fix this unnecessary work?)

    /* printf("after\n"); */
    /* shadow_stack_print(process); */

    Obj *pop1 = shadow_stack_pop(process);
    Obj *pop2 = shadow_stack_pop(process);
    assert(pop1 == calling_env);
    assert(pop2 == function);

#else

    Obj *calling_env = obj_new_environment(function->env);
    bool allow_rest_args = true;
    env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args);
    //printf("Lambda env: %s\n", obj_to_string(calling_env)->s);

    shadow_stack_push(process, function);
    shadow_stack_push(process, calling_env);

    if(function->body->tag == 'X') {
      eval_error = obj_new_string("Can't apply lambda with bytecode body.");
    }
    else {
      eval_internal(process, calling_env, function->body);
    }

    if(eval_error) {
      return;
    }

    Obj *pop1 = shadow_stack_pop(process);
    Obj *pop2 = shadow_stack_pop(process);
    assert(pop1 == calling_env);
    assert(pop2 == function);
#endif
  }
  else if(function->tag == 'P') {
    Obj *result = function->primop((struct Process *)process, args, arg_count);
    stack_push(process, result);
  }
  else if(function->tag == 'F') {
    call_foreign_function(process, function, args, arg_count);
  }
  else if(function->tag == 'K') {
    if(arg_count != 1) {
      eval_error = obj_new_string("Args to keyword lookup must be a single arg.");
    }
    else if(args[0]->tag != 'E') {
      eval_error = obj_new_string("Arg 0 to keyword lookup must be a dictionary: ");
      obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s);
    }
    else {
      Obj *value = env_lookup(process, args[0], function);
      if(value) {
        stack_push(process, value);
      }
      else {
        eval_error = obj_new_string("Failed to lookup keyword '");
        obj_string_mut_append(eval_error, obj_to_string(process, function)->s);
        obj_string_mut_append(eval_error, "'");
        obj_string_mut_append(eval_error, " in \n");
        obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s);
        obj_string_mut_append(eval_error, "\n");
      }
    }
  }
  else if(function->tag == 'E' && obj_eq(process, env_lookup(process, function, obj_new_keyword("struct")), lisp_true)) {
    //printf("Calling struct: %s\n", obj_to_string(process, function)->s);
    if(obj_eq(process, env_lookup(process, function, obj_new_keyword("generic")), lisp_true)) {
      //printf("Calling generic struct constructor.\n");
      Obj *function_call_symbol = obj_new_symbol("dynamic-generic-constructor-call");
      shadow_stack_push(process, function_call_symbol);

      Obj **copied_args = malloc(sizeof(Obj *) * arg_count);
      for(int i = 0; i < arg_count; i++) {
        copied_args[i] = obj_copy(process, args[i]);
        if(args[i]->meta) {
          copied_args[i]->meta = obj_copy(process, args[i]->meta);
        }
      }

      Obj *carp_array = obj_new_array(arg_count);
      carp_array->array = copied_args;

      Obj *call_to_concretize_struct = obj_list(function_call_symbol,
                                                function,
                                                carp_array);

      shadow_stack_push(process, call_to_concretize_struct);
      eval_internal(process, process->global_env, call_to_concretize_struct);

      shadow_stack_pop(process);
      shadow_stack_pop(process);
    }
    else {
      call_struct_constructor(process, function, args, arg_count);
    }
  }
  else {
    set_error("Can't call non-function: ", function);
  }
}
Example #10
0
Process *process_new() {
  Process *process = malloc(sizeof(Process));
  process->dead = false;
  process->final_result = NULL;

#if BYTECODE_EVAL
  process->frame = 0;
#else
  process->frame = -1;
#endif

  process->bytecodeObj = NULL;
  pop_stacks_to_zero(process);

  process->global_env = obj_new_environment(NULL);

  nil = obj_new_cons(NULL, NULL);
  define("nil", nil);

  lisp_false = obj_new_bool(false);
  define("false", lisp_false);

  lisp_true = obj_new_bool(true);
  define("true", lisp_true);

  lisp_quote = obj_new_symbol("quote");
  define("quote", lisp_quote);

  ampersand = obj_new_symbol("&");
  define("&", ampersand);

  dotdotdot = obj_new_symbol("dotdotdot");
  define("dotdotdot", dotdotdot);

  hash = obj_new_keyword("hash");
  define("hash", hash);

  lisp_NULL = obj_new_ptr(NULL);
  define("NULL", lisp_NULL);

  type_ref = obj_new_keyword("ref");
  define("type_ref", type_ref);

  type_int = obj_new_keyword("int");
  define("type-int", type_int); // without this it will get GC'd!

  type_bool = obj_new_keyword("bool");
  define("type-bool", type_bool);

  type_float = obj_new_keyword("float");
  define("type-float", type_float);

  type_double = obj_new_keyword("double");
  define("type-double", type_double);

  type_string = obj_new_keyword("string");
  define("type-string", type_string);

  type_symbol = obj_new_keyword("symbol");
  define("type-symbol", type_symbol);

  type_keyword = obj_new_keyword("keyword");
  define("type-keyword", type_keyword);

  type_foreign = obj_new_keyword("foreign");
  define("type-foreign", type_foreign);

  type_primop = obj_new_keyword("primop");
  define("type-primop", type_primop);

  type_env = obj_new_keyword("env");
  define("type-env", type_env);

  type_macro = obj_new_keyword("macro");
  define("type-macro", type_macro);

  type_lambda = obj_new_keyword("lambda");
  define("type-lambda", type_lambda);

  type_list = obj_new_keyword("list");
  define("type-list", type_list);

  type_void = obj_new_keyword("void");
  define("type-void", type_void);

  type_ptr = obj_new_keyword("ptr");
  define("type-ptr", type_ptr);

  type_char = obj_new_keyword("char");
  define("type-char", type_char);

  type_array = obj_new_keyword("array");
  define("type-array", type_array);

  type_ptr_to_global = obj_new_keyword("ptr-to-global");
  define("type-ptr-to-global", type_ptr_to_global);

  prompt = define("prompt", obj_new_string(PROMPT));
  prompt_unfinished_form = define("prompt-unfinished-form", obj_new_string(PROMPT_UNFINISHED_FORM));

  register_primop(process, "open", p_open_file);
  register_primop(process, "save", p_save_file);
  register_primop(process, "+", p_add);
  register_primop(process, "-", p_sub);
  register_primop(process, "*", p_mul);
  register_primop(process, "/", p_div);
  //register_primop(process, "mod", p_mod);
  register_primop(process, "=", p_eq);
  register_primop(process, "list", p_list);
  register_primop(process, "array", p_array);
  register_primop(process, "dictionary", p_dictionary);
  register_primop(process, "str", p_str);
  register_primop(process, "str-append!", p_str_append_bang);
  register_primop(process, "str-replace", p_str_replace);
  register_primop(process, "join", p_join);
  register_primop(process, "register", p_register);
  register_primop(process, "register-variable", p_register_variable);
  register_primop(process, "register-builtin", p_register_builtin);
  register_primop(process, "print", p_print);
  register_primop(process, "println", p_println);
  register_primop(process, "prn", p_prn);
  register_primop(process, "def?", p_def_QMARK);
  //register_primop(process, "system", p_system);
  register_primop(process, "get", p_get);
  register_primop(process, "get-maybe", p_get_maybe);
  register_primop(process, "dict-set!", p_dict_set_bang);
  register_primop(process, "dict-remove!", p_dict_remove_bang);
  register_primop(process, "first", p_first);
  register_primop(process, "rest", p_rest);
  register_primop(process, "cons", p_cons);
  register_primop(process, "cons-last", p_cons_last);
  register_primop(process, "concat", p_concat);
  register_primop(process, "nth", p_nth);
  register_primop(process, "count", p_count);
  register_primop(process, "map", p_map);
  register_primop(process, "map-copy", p_map); // only matters when compiling to C
  register_primop(process, "map2", p_map2);
  register_primop(process, "filter", p_filter);
  register_primop(process, "reduce", p_reduce);
  register_primop(process, "apply", p_apply);
  register_primop(process, "type", p_type);
  register_primop(process, "<", p_lt);
  register_primop(process, "env", p_env);
  register_primop(process, "load-lisp", p_load_lisp);
  register_primop(process, "load-dylib", p_load_dylib);
  register_primop(process, "unload-dylib", p_unload_dylib);
  register_primop(process, "read", p_read);
  register_primop(process, "read-many", p_read_many);
  register_primop(process, "code", p_code);
  register_primop(process, "copy", p_copy);
  register_primop(process, "now", p_now);
  register_primop(process, "name", p_name);
  register_primop(process, "symbol", p_symbol);
  register_primop(process, "keyword", p_keyword);
  register_primop(process, "error", p_error);
  register_primop(process, "keys", p_keys);
  register_primop(process, "values", p_values);
  register_primop(process, "signature", p_signature);
  register_primop(process, "eval", p_eval);
  register_primop(process, "meta-set!", p_meta_set_BANG);
  register_primop(process, "meta-get", p_meta_get);
  register_primop(process, "meta-get-all", p_meta_get_all);
  register_primop(process, "array-to-list", p_array_to_list);
  register_primop(process, "array-of-size", p_array_of_size);
  register_primop(process, "array-set!", p_array_set_BANG);
  register_primop(process, "array-set", p_array_set);
  register_primop(process, "gc", p_gc);
  register_primop(process, "hash", p_hash);
  register_primop(process, "delete", p_delete);
  register_primop(process, "stop", p_stop);
  register_primop(process, "parallell", p_parallell);
  register_primop(process, "bytecode", p_bytecode);
  register_primop(process, "eval-bytecode", p_bytecode_eval);
  register_primop(process, "lookup-in-substs-fast", p_lookup_in_substs_fast);
  register_primop(process, "replace-subst-from-right-fast", p_replace_subst_from_right_fast);
  register_primop(process, "types-exactly-eq?", p_types_exactly_eq);
  register_primop(process, "extend-substitutions-fast", p_extend_substitutions_fast);
  register_primop(process, "sort-by-fast", p_sort_by);

  Obj *abs_args = obj_list(type_int);
  register_ffi_internal(process, "abs", (VoidFn)abs, abs_args, type_int, true);

  Obj *exit_args = obj_list(type_int);
  register_ffi_internal(process, "exit", (VoidFn)exit, exit_args, type_void, true);

  Obj *getenv_args = obj_list(type_string);
  register_ffi_internal(process, "getenv", (VoidFn)getenv, getenv_args, type_string, true);

  //printf("Global env: %s\n", obj_to_string(env)->s);

  return process;
}