Esempio n. 1
0
void add_let(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) {
  
  Obj *bindings = form->cdr->car;
  Obj *body = form->cdr->cdr->car;
  shadow_stack_push(process, bindings);
  shadow_stack_push(process, body);

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

  Obj *bindings_only_symbols = obj_new_array(bindings->count / 2);
  shadow_stack_push(process, bindings_only_symbols);
  
  for(int i = 0; i < bindings_only_symbols->count; i++) {
    bindings_only_symbols->array[i] = bindings->array[i * 2];
    visit_form(process, env, bytecodeObj, position, bindings->array[i * 2 + 1]);
  }
  //printf("bindings_only_symbols: %s\n", obj_to_string(process, bindings_only_symbols)->s);

  Obj *literals = bytecodeObj->bytecode_literals;
  char new_literal_index = literals->count;
  Obj *let_body_code = form_to_bytecode(process, env, body);

  obj_array_mut_append(literals, bindings_only_symbols);
  obj_array_mut_append(literals, let_body_code);
  
  bytecodeObj->bytecode[*position] = 't';
  bytecodeObj->bytecode[*position + 1] = new_literal_index + 65;
  bytecodeObj->bytecode[*position + 2] = new_literal_index + 1 + 65;

  *position += 3;

  shadow_stack_pop(process);
  shadow_stack_pop(process);
  shadow_stack_pop(process);
}
Esempio n. 2
0
File: match.c Progetto: JonasG/Carp
void match(Process *process, Obj *env, Obj *value, Obj *attempts) {
  Obj *p = attempts;
  while(p && p->car) {
    //printf("\nWill match %s with value %s\n", obj_to_string(p->car)->s, obj_to_string(value)->s);
    Obj *new_env = obj_new_environment(env);
    shadow_stack_push(process, new_env);
    bool result = obj_match(process, new_env, p->car, value);

    if(result) {
      //printf("Match found, evaling %s in env\n", obj_to_string(p->cdr->car)->s); //, obj_to_string(new_env)->s);
      eval_internal(process, new_env, p->cdr->car); // eval the following form using the new environment
      Obj *pop = shadow_stack_pop(process); // new_env
      if(eval_error) {
        return;
      }
      assert(pop == new_env);
      return;
    }

    if(!p->cdr) {
      set_error("Uneven nr of forms in match.", attempts);
    }

    p = p->cdr->cdr;

    Obj *e = shadow_stack_pop(process); // new_env
    assert(e == new_env);
  }

  set_error("Failed to find a suitable match for: ", value);
}
Esempio n. 3
0
Obj *obj_to_string_not_prn(Process *process, const Obj *o) {
    Obj *s = obj_new_string("");
    shadow_stack_push(process, s);
    obj_to_string_internal(process, s, o, false, 0);
    shadow_stack_pop(process);
    return s;
}
Esempio n. 4
0
Obj *bytecode_eval(Process *process, Obj *bytecodeObj) {

  if(bytecodeObj->tag != 'X') {
    set_error_return_nil("The code to eval must be bytecode, ", bytecodeObj);
  }
  
  shadow_stack_push(process, bytecodeObj);
  
  process->frames[process->frame].p = 0;
  process->frames[process->frame].bytecodeObj = bytecodeObj;
  process->frames[process->frame].env = process->global_env;

  Obj *final_result = NULL;
  while(!final_result) {
    final_result = bytecode_eval_internal(process, bytecodeObj, 100);
  }

  shadow_stack_pop(process);
  return final_result;
}
Esempio n. 5
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;
}
Esempio n. 6
0
void obj_to_string_internal(Obj *total, const Obj *o, bool prn, int indent) {
  assert(o);
  int x = indent;
  if(o->tag == 'C') {
    obj_string_mut_append(total, "(");
    x++;
    int save_x = x;
    const Obj *p = o;
    while(p && p->car) {
      obj_to_string_internal(total, p->car, true, x);
      if(p->cdr && p->cdr->tag != 'C') {
      	obj_string_mut_append(total, " . ");
      	obj_to_string_internal(total, o->cdr, true, x);
      	break;
      }
      else if(p->cdr && p->cdr->car) {
	if(/* p->car->tag == 'C' ||  */p->car->tag == 'E') {
	  obj_string_mut_append(total, "\n");
	  x = save_x;
	  add_indentation(total, x);
	}
	else {
	  obj_string_mut_append(total, " ");
	  x++;
	}
      }
      p = p->cdr;
    }
    obj_string_mut_append(total, ")");
    x++;
  }
  else if(o->tag == 'A') {
    //printf("Will print Obj Array with count %d\n", o->count);
    shadow_stack_push((struct Obj *)o);
    x++;
    //int save_x = x;
    obj_string_mut_append(total, "[");
    for(int i = 0; i < o->count; i++) {
      obj_to_string_internal(total, o->array[i], true, x);
      if(i < o->count - 1) {
        /* if(o->array[i]->car->tag == 'Q' || o->array[i]->car->tag == 'E') { */
	/*   obj_string_mut_append(total, "\n"); */
	/*   x = save_x; */
	/*   add_indentation(total, x); */
	/* } */
	/* else { */
	/*   obj_string_mut_append(total, " "); */
	/*   x++; */
	/* } */
	obj_string_mut_append(total, " ");
      }
    }
    obj_string_mut_append(total, "]");
    shadow_stack_pop();
    x++;
  }
  else if(o->tag == 'E') {
    shadow_stack_push((struct Obj *)o);
    obj_string_mut_append(total, "{");
    x++;
    Obj *p = o->bindings;
    while(p && p->car) {
      char *key_s = obj_to_string(p->car->car)->s;
      obj_string_mut_append(total, key_s);
      obj_string_mut_append(total, " ");
      obj_to_string_internal(total, p->car->cdr, true, x + (int)strlen(key_s) + 1);
      p = p->cdr;
      if(p && p->car && p->car->car) {
	obj_string_mut_append(total, ", \n");
	add_indentation(total, x);
      }
    }
    obj_string_mut_append(total, "}");
    if(o->parent) {
      obj_string_mut_append(total, " -> \n");
      Obj *parent_printout = obj_to_string(o->parent);
      obj_string_mut_append(total, parent_printout->s);
    }
    shadow_stack_pop();
  }
  else if(o->tag == 'I') {
    static char temp[64];
    snprintf(temp, 64, "%d", o->i);
    obj_string_mut_append(total, temp);
  }
  else if(o->tag == 'V') {
    static char temp[64];
    snprintf(temp, 64, "%f", o->f32);
    obj_string_mut_append(total, temp);
    obj_string_mut_append(total, "f");
  }
  else if(o->tag == 'W') {
    static char temp[64];
    snprintf(temp, 64, "%f", o->f64);
    obj_string_mut_append(total, temp);
  }
  else if(o->tag == 'S') {
    if(prn) {
      obj_string_mut_append(total, "\"");
    }
    obj_string_mut_append(total, o->s);
    if(prn) {
      obj_string_mut_append(total, "\"");
    }
  }
  else if(o->tag == 'Y') {
    obj_string_mut_append(total, o->s);
  }
  else if(o->tag == 'K') {
    obj_string_mut_append(total, ":");
    obj_string_mut_append(total, o->s);
  }
  else if(o->tag == 'P') {
    obj_string_mut_append(total, "<primop:");
    static char temp[256];
    snprintf(temp, 256, "%p", o->primop);
    obj_string_mut_append(total, temp);
    if(o->meta) {
      Obj *name = env_lookup(o->meta, obj_new_keyword("name"));
      if(name) {
	obj_string_mut_append(total, ":");
	obj_string_mut_append(total, obj_to_string_not_prn(name)->s);
      }
    }
    obj_string_mut_append(total, ">");
  }
  else if(o->tag == 'D') {
    obj_string_mut_append(total, "<dylib:");
    static char temp[256];
    snprintf(temp, 256, "%p", o->primop);
    obj_string_mut_append(total, temp);
    obj_string_mut_append(total, ">");
  }
  else if(o->tag == 'Q') {
    shadow_stack_push((struct Obj *)o);
    Obj *type_lookup;
    if(o->meta && (type_lookup = env_lookup(o->meta, obj_new_keyword("type")))) {
      if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(type_lookup->car, obj_new_keyword("Array"))) {
	print_generic_array_or_struct(total, type_lookup, (struct Obj *)o);
      }
      else {
	print_generic_array_or_struct(total, type_lookup, (struct Obj *)o);

	/* obj_string_mut_append(total, "<ptr"); */
	/* obj_string_mut_append(total, obj_to_string(type_lookup)->s); */
	/* obj_string_mut_append(total, ">"); */
      }
    }
    else {
      obj_string_mut_append(total, "<ptr:");
      static char temp[256];
      snprintf(temp, 256, "%p", o->primop);
      obj_string_mut_append(total, temp);
      obj_string_mut_append(total, " of unknown type");
      obj_string_mut_append(total, ">");
    }
    shadow_stack_pop();
  }
  else if(o->tag == 'F') {
    obj_string_mut_append(total, "<ffi:");
    static char temp[256];
    snprintf(temp, 256, "%p", o->funptr);
    obj_string_mut_append(total, temp);
    if(o->meta) {
      Obj *name = env_lookup(o->meta, obj_new_keyword("name"));
      if(name) {
	obj_string_mut_append(total, ":");
	obj_string_mut_append(total, obj_to_string_not_prn(name)->s);
      }
    }
    else {
      
    }
    obj_string_mut_append(total, ">");
  }
  else if(o->tag == 'L') {
    if(setting_print_lambda_body) {
      obj_string_mut_append(total, "(fn");
      obj_string_mut_append(total, " ");
      obj_string_mut_append(total, obj_to_string(o->params)->s);
      obj_string_mut_append(total, " ");
      obj_string_mut_append(total, obj_to_string(o->body)->s);
      obj_string_mut_append(total, ")");
    }
    else {
      obj_string_mut_append(total, "<lambda>");
    }
  }
  else if(o->tag == 'M') {
    if(setting_print_lambda_body) {
      obj_string_mut_append(total, "(macro");
      obj_string_mut_append(total, " ");
      obj_string_mut_append(total, obj_to_string(o->params)->s);
      obj_string_mut_append(total, " ");
      obj_string_mut_append(total, obj_to_string(o->body)->s);
      obj_string_mut_append(total, ")");
    }
    else {
      obj_string_mut_append(total, "<macro>");
    }
  }
  else if(o->tag == 'T') {
    char s[2] = { o->character, '\0' };
    if(prn) {
      obj_string_mut_append(total, "\\");
    }
    obj_string_mut_append(total, s);
  }
  else if(o->tag == 'B') {
    if(o->boolean) {
      obj_string_mut_append(total, "true");
    }
    else {
      obj_string_mut_append(total, "false");
    }
  }
  else {
    printf("obj_to_string() can't handle type tag %c (%d).\n", o->tag, o->tag);
    assert(false);
  }
}
Esempio n. 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;
}
Esempio n. 8
0
void obj_to_string_internal(Process *process, Obj *total, const Obj *o, bool prn, int indent) {
    assert(o);
    int x = indent;
    if(o->tag == 'C') {
        obj_string_mut_append(total, "(");
        x++;
        int save_x = x;
        const Obj *p = o;
        while(p && p->car) {
            obj_to_string_internal(process, total, p->car, true, x);
            if(p->cdr && p->cdr->tag != 'C') {
                obj_string_mut_append(total, " . ");
                obj_to_string_internal(process, total, o->cdr, true, x);
                break;
            }
            else if(p->cdr && p->cdr->car) {
                if(/* p->car->tag == 'C' ||  */ p->car->tag == 'E') {
                    obj_string_mut_append(total, "\n");
                    x = save_x;
                    add_indentation(total, x);
                }
                else {
                    obj_string_mut_append(total, " ");
                    x++;
                }
            }
            p = p->cdr;
        }
        obj_string_mut_append(total, ")");
        x++;
    }
    else if(o->tag == 'A') {
        //printf("Will print Obj Array with count %d\n", o->count);
        shadow_stack_push(process, (struct Obj *)o);
        x++;
        //int save_x = x;
        obj_string_mut_append(total, "[");
        for(int i = 0; i < o->count; i++) {
            obj_to_string_internal(process, total, o->array[i], true, x);
            if(i < o->count - 1) {
                /* if(o->array[i]->car->tag == 'Q' || o->array[i]->car->tag == 'E') { */
                /*   obj_string_mut_append(total, "\n"); */
                /*   x = save_x; */
                /*   add_indentation(total, x); */
                /* } */
                /* else { */
                /*   obj_string_mut_append(total, " "); */
                /*   x++; */
                /* } */
                obj_string_mut_append(total, " ");
            }
        }
        obj_string_mut_append(total, "]");
        shadow_stack_pop(process);
        x++;
    }
    else if(o->tag == 'E') {
        shadow_stack_push(process, (struct Obj *)o);

        if(o == process->global_env) {
            obj_string_mut_append(total, "{ GLOBAL ENVIRONMENT }");
            return;
        }

        obj_string_mut_append(total, "{");
        x++;
        Obj *p = o->bindings;
        while(p && p->car) {
            char *key_s = obj_to_string(process, p->car->car)->s;
            obj_string_mut_append(total, key_s);
            obj_string_mut_append(total, " ");
            obj_to_string_internal(process, total, p->car->cdr, true, x + (int)strlen(key_s) + 1);
            p = p->cdr;
            if(p && p->car && p->car->car) {
                obj_string_mut_append(total, ", \n");
                add_indentation(total, x);
            }
        }
        obj_string_mut_append(total, "}");
        if(o->parent) {
            obj_string_mut_append(total, " -> \n");
            Obj *parent_printout = obj_to_string(process, o->parent);
            obj_string_mut_append(total, parent_printout->s);
        }
        shadow_stack_pop(process);
    }
    else if(o->tag == 'I') {
        static char temp[64];
        snprintf(temp, 64, "%d", o->i);
        obj_string_mut_append(total, temp);
    }
    else if(o->tag == 'V') {
        static char temp[64];
        snprintf(temp, 64, "%f", o->f32);
        obj_string_mut_append(total, temp);
        obj_string_mut_append(total, "f");
    }
    else if(o->tag == 'W') {
        static char temp[64];
        snprintf(temp, 64, "%f", o->f64);
        obj_string_mut_append(total, temp);
    }
    else if(o->tag == 'S') {
        if(prn) {
            obj_string_mut_append(total, "\"");
        }
        obj_string_mut_append(total, o->s);
        if(prn) {
            obj_string_mut_append(total, "\"");
        }
    }
    else if(o->tag == 'Y') {
        obj_string_mut_append(total, o->s);
    }
    else if(o->tag == 'K') {
        obj_string_mut_append(total, ":");
        obj_string_mut_append(total, o->s);
    }
    else if(o->tag == 'P') {
        obj_string_mut_append(total, "<primop:");
        static char temp[256];
        snprintf(temp, 256, "%p", o->primop);
        obj_string_mut_append(total, temp);
        if(o->meta) {
            Obj *name = env_lookup(process, o->meta, obj_new_keyword("name"));
            if(name) {
                obj_string_mut_append(total, ":");
                obj_string_mut_append(total, obj_to_string_not_prn(process, name)->s);
            }
        }
        obj_string_mut_append(total, ">");
    }
    else if(o->tag == 'D') {
        obj_string_mut_append(total, "<dylib:");
        static char temp[256];
        snprintf(temp, 256, "%p", o->primop);
        obj_string_mut_append(total, temp);
        obj_string_mut_append(total, ">");
    }
    else if(o->tag == 'Q') {
        shadow_stack_push(process, (struct Obj *)o);
        Obj *type_lookup;
        if(o->meta && (type_lookup = env_lookup(process, o->meta, obj_new_keyword("type")))) {
            if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(process, type_lookup->car, obj_new_keyword("Array"))) {
                print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)o);
            }
            else {
                print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)o);
                /* obj_string_mut_append(total, "<ptr"); */
                /* obj_string_mut_append(total, obj_to_string(type_lookup)->s); */
                /* obj_string_mut_append(total, ">"); */
            }
        }
        else {
            obj_string_mut_append(total, "<ptr:");
            static char temp[256];
            snprintf(temp, 256, "%p", o->primop);
            obj_string_mut_append(total, temp);
            obj_string_mut_append(total, " of unknown type");
            obj_string_mut_append(total, ">");
        }
        shadow_stack_pop(process);
    }
    else if(o->tag == 'R') {
        shadow_stack_push(process, (struct Obj *)o);

        if(!o->void_ptr) {
            eval_error = obj_new_string("Pointer to global is NULL.\n");
            return;
        }

        Obj *type_lookup;
        //printf("o %p %p\n", o, o->void_ptr);

        if(o->void_ptr == NULL) {
            obj_string_mut_append(total, "NULL");
        }
        else if(o->meta && (type_lookup = env_lookup(process, o->meta, obj_new_keyword("type")))) {
            //printf("type %s\n", obj_to_string(type_lookup)->s);
            if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(process, type_lookup->car, obj_new_keyword("Array"))) {
                void *dereffed = *(void **)o->void_ptr;
                assert(dereffed);
                Obj *x = primitive_to_obj(process, dereffed, type_lookup);
                shadow_stack_push(process, x);
                obj_string_mut_append(total, obj_to_string(process, x)->s);
                shadow_stack_pop(process); // x
            }
            else if(obj_eq(process, type_lookup, type_int)) {
                //int i = 123;
                void *dereffed = *(void **)o->void_ptr;
                assert(dereffed);
                Obj *x = primitive_to_obj(process, dereffed, type_int);
                obj_string_mut_append(total, obj_to_string(process, x)->s);
            }
            else if(obj_eq(process, type_lookup, type_float)) {
                //int i = 123;
                void *dereffed = *(void **)o->void_ptr;
                assert(dereffed);
                Obj *x = primitive_to_obj(process, dereffed, type_float);
                obj_string_mut_append(total, obj_to_string(process, x)->s);
            }
            else if(obj_eq(process, type_lookup, type_double)) {
                void *dereffed = *(void **)o->void_ptr;
                assert(dereffed);
                Obj *x = primitive_to_obj(process, dereffed, type_double);
                obj_string_mut_append(total, obj_to_string(process, x)->s);
            }
            else if(obj_eq(process, type_lookup, type_bool)) {
                void *dereffed = *(void **)o->void_ptr;
                // can't assert since false == NULL
                Obj *x = primitive_to_obj(process, dereffed, type_bool);
                obj_string_mut_append(total, obj_to_string(process, x)->s);
            }
            else if(obj_eq(process, type_lookup, type_string)) {
                void *dereffed = *(void **)o->void_ptr;
                assert(dereffed);
                Obj *x = primitive_to_obj(process, dereffed, type_string);
                obj_string_mut_append(total, x->s);
            }
            else if(obj_eq(process, type_lookup, type_char)) {
                void *dereffed = *(void **)o->void_ptr;
                assert(dereffed);
                Obj *x = primitive_to_obj(process, dereffed, type_char);
                obj_string_mut_append(total, obj_to_string(process, x)->s);
            }
            else {
                void *dereffed = *(void **)o->void_ptr;
                assert(dereffed);
                Obj *x = primitive_to_obj(process, dereffed, type_lookup);
                print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)x);
                /* obj_string_mut_append(total, "<ptr"); */
                /* obj_string_mut_append(total, obj_to_string(type_lookup)->s); */
                /* obj_string_mut_append(total, ">"); */
            }
        }

        obj_string_mut_append(total, " ; ptr-to-global");

        shadow_stack_pop(process);
    }
    else if(o->tag == 'F') {
        obj_string_mut_append(total, "<ffi:");
        static char temp[256];
        snprintf(temp, 256, "%p", o->funptr);
        obj_string_mut_append(total, temp);
        if(o->meta) {
            Obj *name = env_lookup(process, o->meta, obj_new_keyword("name"));
            if(name) {
                obj_string_mut_append(total, ":");
                obj_string_mut_append(total, obj_to_string_not_prn(process, name)->s);
            }
        }
        else {
        }
        obj_string_mut_append(total, ">");
    }
    else if(o->tag == 'L') {
        if(setting_print_lambda_body) {
            obj_string_mut_append(total, "(fn");
            obj_string_mut_append(total, " ");
            obj_string_mut_append(total, obj_to_string(process, o->params)->s);
            obj_string_mut_append(total, " ");
            obj_string_mut_append(total, obj_to_string(process, o->body)->s);
            obj_string_mut_append(total, ")");
        }
        else {
            obj_string_mut_append(total, "<lambda>");
        }
    }
    else if(o->tag == 'M') {
        if(setting_print_lambda_body) {
            obj_string_mut_append(total, "(macro");
            obj_string_mut_append(total, " ");
            obj_string_mut_append(total, obj_to_string(process, o->params)->s);
            obj_string_mut_append(total, " ");
            obj_string_mut_append(total, obj_to_string(process, o->body)->s);
            obj_string_mut_append(total, ")");
        }
        else {
            obj_string_mut_append(total, "<macro>");
        }
    }
    else if(o->tag == 'T') {
        char s[2] = {o->character, '\0'};
        if(prn) {
            obj_string_mut_append(total, "\\");
        }
        obj_string_mut_append(total, s);
    }
    else if(o->tag == 'B') {
        if(o->boolean) {
            obj_string_mut_append(total, "true");
        }
        else {
            obj_string_mut_append(total, "false");
        }
    }
    else if(o->tag == 'X') {
        obj_string_mut_append(total, "(\n");

        for(char *p = o->bytecode; *p != '\0';) {
            const int buffer_size = 128;
            char buffer[buffer_size];

            snprintf(buffer, buffer_size, "%4d  ", (int)(p - o->bytecode));
            obj_string_mut_append(total, buffer);

            char c = *p;
            p++;

            if(c == 'l') {
                snprintf(buffer, buffer_size, "LOAD LIT %d", *((int*)p));
                p += sizeof(int);
            }
            else if(c == 'a') {
                snprintf(buffer, buffer_size, "LOAD λ %d", *((int*)p));
                p += sizeof(int);
            }
            else if(c == 'c') {
                snprintf(buffer, buffer_size, "CALL %d", *((int*)p));
                p += sizeof(int);
            }
            else if(c == 'd') {
                snprintf(buffer, buffer_size, "DEFINE %d", *((int*)p));
                p += sizeof(int);
            }
            else if(c == 'y') {
                snprintf(buffer, buffer_size, "LOOKUP %d", *((int*)p));
                p += sizeof(int);
            }
            else if(c == 'i') {
                snprintf(buffer, buffer_size, "JUMP IF NOT %d", *((int*)p));
                p += sizeof(int);
            }
            else if(c == 'j') {
                snprintf(buffer, buffer_size, "JUMP %d", *((int*)p));
                p += sizeof(int);
            }
            else if(c == 'r') {
                snprintf(buffer, buffer_size, "RESET %d", *((int*)p));
                p += sizeof(int);
            }
            else if(c == 't') {
                snprintf(buffer, buffer_size, "LET %d", *((int*)p));
                p += sizeof(int);
            }
            else if(c == 'e') {
                snprintf(buffer, buffer_size, "DISCARD");
            }
            else if(c == 'g') {
                snprintf(buffer, buffer_size, "CATCH");
            }
            else if(c == 'n') {
                snprintf(buffer, buffer_size, "NOT");
            }
            else if(c == 'p') {
                snprintf(buffer, buffer_size, "PUSH NIL");
            }
            else if(c == 'v') {
                snprintf(buffer, buffer_size, "POP LET-SCOPE");
            }
            else if(c == 'x') {
                snprintf(buffer, buffer_size, "DIRECT LOOKUP");
            }
            else if(c == 'q') {
                snprintf(buffer, buffer_size, "END");
            }
            else {
                snprintf(buffer, buffer_size, "UNHANDLED OP (%c)", *p);
                p++;
            }

            obj_string_mut_append(total, buffer);
            obj_string_mut_append(total, "\n");
        }

        obj_string_mut_append(total, "Literals: ");
        obj_string_mut_append(total, obj_to_string(process, o->bytecode_literals)->s);
        obj_string_mut_append(total, "\n");
        obj_string_mut_append(total, ")");
    }
    else {
        printf("obj_to_string() can't handle type tag %c (%d).\n", o->tag, o->tag);
        assert(false);
    }
}
Esempio n. 9
0
File: eval.c Progetto: JonasG/Carp
void call_struct_constructor(Process *process, Obj *function, Obj **args, int arg_count) {
  // Evaluation of a struct-definition (a dictionary) in function position (which means that it is used as a constructor)
  Obj *name_obj = env_lookup(process, function, obj_new_keyword("name"));
  assert_or_set_error(name_obj, "no key 'name' on struct definition: ", function);
  char *name = name_obj->s;

  Obj *struct_size_obj = env_lookup(process, function, obj_new_keyword("size"));
  assert_or_set_error(struct_size_obj, "no key 'size' on struct definition: ", function);
  int struct_size = struct_size_obj->i;

  Obj *struct_member_count_obj = env_lookup(process, function, obj_new_keyword("member-count"));
  assert_or_set_error(struct_member_count_obj, "no key 'member-count' on struct definition: ", function);
  int member_count = struct_member_count_obj->i;

  Obj *offsets_obj = env_lookup(process, function, obj_new_keyword("member-offsets"));
  assert_or_set_error(offsets_obj, "no key 'member-offsets' on struct definition: ", function);
  assert_or_set_error(offsets_obj->tag == 'A', "offsets must be an array: ", function);
  Obj **offsets = offsets_obj->array;

  Obj *member_types_obj = env_lookup(process, function, obj_new_keyword("member-types"));
  assert_or_set_error(member_types_obj, "no key 'member-types' on struct definition: ", function);
  assert_or_set_error(member_types_obj->tag == 'A', "member-types must be an array: ", function);
  Obj **member_types = member_types_obj->array;

  //printf("Will create a %s of size %d and member count %d.\n", name, size, member_count);
  void *p = malloc(struct_size);
  Obj *new_struct = obj_new_ptr(p);

  shadow_stack_push(process, new_struct);

  if(!new_struct->meta) {
    new_struct->meta = obj_new_environment(NULL);
  }
  env_assoc(process, new_struct->meta, obj_new_keyword("type"), obj_new_keyword(name));

  assert_or_set_error(!(arg_count < member_count), "Too few args to struct constructor: ", obj_new_string(name));
  assert_or_set_error(!(arg_count > member_count), "Too many args to struct constructor: ", obj_new_string(name));

  for(int i = 0; i < arg_count; i++) {
    Obj *member_type = member_types[i];
    int offset = offsets[i]->i;
    if(args[i]->tag == 'V') {
      assert_or_set_error(obj_eq(process, member_type, type_float), "Can't assign float to a member of type ", obj_to_string(process, member_type));
      float *fp = (float *)(((char *)new_struct->void_ptr) + offset);
      float f = args[i]->f32;
      //printf("Setting member %d at offset %d to %f.\n", i, offset, f);
      *fp = f;
    }
    else if(args[i]->tag == 'I') {
      assert_or_set_error(obj_eq(process, member_type, type_int), "Can't assign int to a member of type ", obj_to_string(process, member_type));
      int *xp = (int *)(((char *)new_struct->void_ptr) + offset);
      int x = args[i]->i;
      *xp = x;
    }
    else if(args[i]->tag == 'B') {
      assert_or_set_error(obj_eq(process, member_type, type_bool), "Can't assign bool to a member of type ", obj_to_string(process, member_type));
      bool *xp = (bool *)(((char *)new_struct->void_ptr) + offset);
      bool x = args[i]->boolean;
      *xp = x;
    }
    else if(args[i]->tag == 'Q') {
      assert_or_set_error(!obj_eq(process, member_type, type_char), "Can't assign char to a member of type ", obj_to_string(process, member_type));
      assert_or_set_error(!obj_eq(process, member_type, type_int), "Can't assign int to a member of type ", obj_to_string(process, member_type));
      assert_or_set_error(!obj_eq(process, member_type, type_float), "Can't assign float to a member of type ", obj_to_string(process, member_type));
      assert_or_set_error(!obj_eq(process, member_type, type_string), "Can't assign string to a member of type ", obj_to_string(process, member_type));
      void **vp = (void **)(((char *)new_struct->void_ptr) + offset);
      *vp = args[i]->void_ptr;
    }
    else if(args[i]->tag == 'S') {
      assert_or_set_error(obj_eq(process, member_type, type_string), "Can't assign int to a member of type ", obj_to_string(process, member_type));
      char **sp = (char **)(((char *)new_struct->void_ptr) + offset);
      *sp = strdup(args[i]->s); // must strdup or the struct will ref Obj's on the stack that will get gc:ed
    }
    else if(args[i]->tag == 'T') {
      assert_or_set_error(obj_eq(process, member_type, type_char), "Can't assign char to a member of type ", obj_to_string(process, member_type));
      char *cp = (char *)(((char *)new_struct->void_ptr) + offset);
      *cp = args[i]->character;
    }
    else if(args[i]->tag == 'A') {
      //assert_or_set_error(obj_eq(member_type, type_array), "Can't assign array to a member of type ", obj_to_string(member_type));

      // TODO: use this code for sending arrays to normal FFI functions too!!!
      // TODO: use the SAME code for sending data to FFI and struct constructors.
      // TODO: check that we send the expected type to the constructor

      Array *a = obj_array_to_carp_array(process, args[i]);
      if(!a) {
        return;
      }

      void **ap = (void **)(((char *)new_struct->void_ptr) + offset);
      *ap = a;
    }
    else {
      eval_error = obj_new_string("Can't set member ");
      char buffer[32];
      sprintf(buffer, "%d", i);
      obj_string_mut_append(eval_error, buffer);
      obj_string_mut_append(eval_error, " of struct ");
      obj_string_mut_append(eval_error, name);
      obj_string_mut_append(eval_error, " to ");
      obj_string_mut_append(eval_error, obj_to_string(process, args[i])->s);
      obj_string_mut_append(eval_error, " (handled type).");
      return;
    }
  }
  shadow_stack_pop(process); // pop new_struct
  stack_push(process, new_struct);
}
Esempio n. 10
0
File: eval.c Progetto: 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);
  }
}