Exemple #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);
}
Exemple #2
0
bool obj_match_arrays(Process *process, Obj *env, Obj *attempt, Obj *value) {
  //printf("Matching arrays %s with %s\n", obj_to_string(attempt)->s, obj_to_string(value)->s);
  int i;
  for(i = 0; i < attempt->count; i++) {
    Obj *o = attempt->array[i];
    if(obj_eq(process, o, dotdotdot) && ((i + 1) < attempt->count)) {
      int rest_count = value->count - i;
      //printf("rest_count: %d\n", rest_count);
      Obj *rest = obj_new_array(rest_count);
      for(int j = 0; j < rest_count; j++) {
        rest->array[j] = value->array[i + j]; // copy the rest of the objects to a smaller array
      }
      //printf("rest: %s\n", obj_to_string(rest)->s);
      Obj *symbol_after_dotdotdot = attempt->array[i + 1];
      //printf("symbol_after_dotdotdot: %s\n", obj_to_string(symbol_after_dotdotdot)->s);
      bool matched_rest = obj_match(process, env, symbol_after_dotdotdot, rest);
      //printf("%s\n", matched_rest ? "match" : "no match");
      return matched_rest;
    }
    else if(i >= value->count) {
      return false;
    }
    bool result = obj_match(process, env, o, value->array[i]);
    if(!result) {
      return false;
    }
  }
  if(i < value->count) {
    //printf("The value list is too long.\n");
    return false;
  }
  else {
    //printf("Found end of list, it's a match.\n");
    return true;
  }
}
Exemple #3
0
void env_extend_with_args(Process *process, Obj *calling_env, Obj *function, int arg_count, Obj **args, bool allow_restargs) {

  // TODO: remove the whole 'C' branch and only allow arrays for parameters

  Obj *paramp = function->params;
  if(paramp->tag == 'C') {
    for(int i = 0; i < arg_count; i++) {
      if(allow_restargs && obj_eq(process, paramp->car, dotdotdot)) {
        printf("Found dotdotdot\n");
        if(paramp->cdr->car) {
          int rest_count = arg_count - i;
          printf("Rest count: %d\n", rest_count);
          Obj *rest_array = obj_new_array(rest_count);
          for(int j = 0; j < rest_count; j++) {
            rest_array->array[j] = args[i + j];
          }
          env_extend(calling_env, paramp->cdr->car, rest_array);
          return;
        }
        else {
          printf("No arguments after dotdotdot\n");
          return;
        }
      }
      if(!paramp || !paramp->car) {
        set_error("Too many arguments (C) to function: ", function);
      }
      env_extend(calling_env, paramp->car, args[i]);
      paramp = paramp->cdr;
    }
    if(paramp && paramp->cdr) {
      set_error("Too few arguments to function: ", function);
    }
  }
  else if(paramp->tag == 'A') {

    int i = 0;
    for(; i < arg_count; i++) {
      if(allow_restargs && obj_eq(process, paramp->array[i], dotdotdot)) {
        int rest_count = arg_count - i;
        Obj *rest_list = obj_new_cons(NULL, NULL);
        Obj *last = rest_list;
        for(int j = 0; j < rest_count; j++) {
          Obj *new_element = args[i + j];
          last->car = new_element;
          Obj *new_last = obj_new_cons(NULL, NULL);
          last->cdr = new_last;
          last = new_last;
        }
        env_extend(calling_env, paramp->array[i + 1], rest_list);
        return;
      }

      env_extend(calling_env, paramp->array[i], args[i]);
    }

    if(i < paramp->count) {
      if(allow_restargs && obj_eq(process, paramp->array[i], dotdotdot)) {
        env_extend(calling_env, paramp->array[i + 1], obj_new_array(0));
      }
      else {
        set_error("Too few arguments to function/macro: ", function);
      }
    }

    if(arg_count > paramp->count) {
      printf("arguments: %s\n", obj_to_string(process, paramp)->s);
      //printf("meta: %s\n", (function->meta ? obj_to_string(process, function->meta)->s : "NULL"));
      Obj *name = function;
      if(function->meta) {
        Obj *name_lookup = env_lookup(process, function->meta, obj_new_keyword("name"));
        if(name_lookup) {
          name = name_lookup;
        }
      }
      set_error("Too many arguments (A) to function/macro: ", name);
    }
  }
}
Exemple #4
0
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);
  }
}