/*
     libscheme	
     Copyright (C) 1994 Brent Benson

     This program is free software; you can redistribute it and/or modify
     it under the terms of the GNU General Public License as published by
     the Free Software Foundation; either version 1, or (at your option)
     any later version.

     This program is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU General Public License for more details.

     You should have received a copy of the GNU General Public License
     along with this program; if not, write to the Free Software
     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/

#include "scheme.h"
#include <setjmp.h>
#if defined(sun)
#include <alloca.h>
#endif

/* globals */
Scheme_Object *scheme_prim_type;
Scheme_Object *scheme_closure_type;
Scheme_Object *scheme_cont_type;

/* locals */
static Scheme_Object *procedure_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *closure_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *apply (int argc, Scheme_Object *argv[]);
static Scheme_Object *map (int argc, Scheme_Object *argv[]);
static Scheme_Object *for_each (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_cc (int argc, Scheme_Object *argv[]);
static Scheme_Object *closure_code (int argc, Scheme_Object *argv[]);

#define CONS(a,b) scheme_make_pair(a,b)

void
scheme_init_fun (Scheme_Env *env)
{
  scheme_prim_type = scheme_make_type ("<primitive>");
  scheme_closure_type = scheme_make_type ("<closure>");
  scheme_cont_type = scheme_make_type ("<continuation>");
  scheme_add_global ("<primitive>", scheme_prim_type, env);
  scheme_add_global ("<closure>", scheme_closure_type, env);
  scheme_add_global ("<continuation>", scheme_cont_type, env);
  scheme_add_global ("procedure?", scheme_make_prim (procedure_p), env);
  scheme_add_global ("closure?", scheme_make_prim (closure_p), env);
  scheme_add_global ("apply", scheme_make_prim (apply), env);
  scheme_add_global ("map", scheme_make_prim (map), env);
  scheme_add_global ("for-each", scheme_make_prim (for_each), env);
  scheme_add_global ("call-with-current-continuation", scheme_make_prim (call_cc), env);
  scheme_add_global ("call/cc", scheme_make_prim (call_cc), env);
  scheme_add_global ("closure-code", scheme_make_prim (closure_code), env);
}

Scheme_Object *
scheme_make_prim (Scheme_Prim *fun)
{
  Scheme_Object *prim;

  prim = scheme_alloc_object ();
  SCHEME_TYPE (prim) = scheme_prim_type;
  SCHEME_PRIM (prim) = fun;
  return (prim);
}

Scheme_Object *
scheme_make_closure (Scheme_Env *env, Scheme_Object *code)
{
  Scheme_Object *closure;

  closure = scheme_alloc_object ();
  SCHEME_TYPE (closure) = scheme_closure_type;
  SCHEME_CLOS_ENV (closure) = env;
  SCHEME_CLOS_CODE (closure) = code;
  return (closure);
}

Scheme_Object *
scheme_make_cont (jmp_buf buf)
{
  Scheme_Object *cont;

  cont = scheme_alloc_object ();
  SCHEME_TYPE (cont) = scheme_cont_type;
  SCHEME_PTR_VAL (cont) = buf;
  return (cont);
}

Scheme_Object *
scheme_apply (Scheme_Object *rator, Scheme_Object *rands)
{
  Scheme_Object *fun_type;

  fun_type = SCHEME_TYPE (rator);
  if (fun_type == scheme_closure_type)
    {
      Scheme_Env *env;
      Scheme_Object *params, *forms, *ret, *t1, *t2;
      Scheme_Object *vars, *vals, *vars_last, *vals_last, *pair, *aform;
      int num_int_defs;

      env = SCHEME_CLOS_ENV (rator);
      params = SCHEME_CAR (SCHEME_CLOS_CODE (rator));
      t1 = params;
      t2 = rands;
      while (SCHEME_PAIRP(t1) && (t2 != scheme_null))
	{
	  t1 = SCHEME_CDR (t1);
	  t2 = SCHEME_CDR (t2);
	}
      if (SCHEME_PAIRP(t1) && (!SCHEME_NULLP(t2)))
	{
	  scheme_signal_error ("wrong number of args to procedure");
	}
      env = scheme_add_frame (params, rands, env);
      forms = SCHEME_CDR (SCHEME_CLOS_CODE (rator));
      SCHEME_ASSERT (forms != scheme_null, "apply: no forms in closure body");
      /* process internal defines */
      num_int_defs = 0;
      vars = vals = vars_last = vals_last = scheme_null;
      while (!SCHEME_NULLP(forms) && 
	     SCHEME_PAIRP (SCHEME_CAR(forms)) &&
	     SCHEME_CAR (SCHEME_CAR (forms)) == scheme_intern_symbol ("define"))
	{
	  num_int_defs++;
	  aform = SCHEME_CAR (forms);
	  /* get var */
	  if (SCHEME_PAIRP (SCHEME_CAR (SCHEME_CDR (aform))))
	    pair = scheme_make_pair (SCHEME_CAR (SCHEME_CAR (SCHEME_CDR (aform))), scheme_null);
	  else
	    pair = scheme_make_pair (SCHEME_CAR (SCHEME_CDR (aform)), scheme_null);
	  
	  if (SCHEME_NULLP (vars))
	    vars = vars_last = pair;
	  else
	    {
	      SCHEME_CDR (vars_last) = pair;
	      vars_last = pair;
	    }
	  /* get val */
	  if (SCHEME_PAIRP (SCHEME_CAR (SCHEME_CDR (aform))))
	    pair = CONS (CONS (scheme_intern_symbol("lambda"),
			       CONS (SCHEME_CDR (SCHEME_CAR (SCHEME_CDR (aform))),
				     SCHEME_CDR (SCHEME_CDR (aform)))),
			 scheme_null);
	  else
	    pair = scheme_make_pair (SCHEME_CAR (SCHEME_CDR (SCHEME_CDR (aform))), scheme_null);

	  if (SCHEME_NULLP (vals))
	    vals = vals_last = pair;
	  else
	    {
	      SCHEME_CDR (vals_last) = pair;
	      vals_last = pair;
	    }
	  forms = SCHEME_CDR (forms);
	}
      if ( num_int_defs )
	{
	  env = scheme_add_frame (vars, scheme_alloc_list (num_int_defs), env);
	  while (! SCHEME_NULLP (vars))
	    {
	      scheme_set_value (SCHEME_CAR(vars),
				scheme_eval (SCHEME_CAR (vals), env),
				env);
	      vars = SCHEME_CDR (vars);
	      vals = SCHEME_CDR (vals);
	    }
	}

      while (forms != scheme_null)
	{
	  ret = scheme_eval (SCHEME_CAR (forms), env);
	  forms = SCHEME_CDR (forms);
	}
      /* pop internal define frame */
      if ( num_int_defs )
	{
	  env = scheme_pop_frame (env);
	}
      /* pop regular binding frame */
      env = scheme_pop_frame (env);
      return (ret);
    }
  else if (fun_type == scheme_prim_type)
    {
      int i, len;
      Scheme_Object **rands_vec;

      len = scheme_list_length (rands);
#if 0
      rands_vec = (Scheme_Object **) scheme_malloc (sizeof (Scheme_Object *)*len);
#endif
      rands_vec = (Scheme_Object **) alloca (sizeof (Scheme_Object *)*len);
      for ( i=0 ; i<len ; ++i )
	{
	  rands_vec[i] = SCHEME_CAR (rands);
	  rands = SCHEME_CDR (rands);
	}
      return (SCHEME_PRIM(rator)(len, rands_vec));
    }
  else if (fun_type == scheme_cont_type)
    {
      SCHEME_ASSERT (SCHEME_PAIRP(rands) && SCHEME_NULLP (SCHEME_CDR (rands)), 
		     "apply: wrong number of args to continuation procedure");
      longjmp ((int *)SCHEME_PTR_VAL(rator), (int)SCHEME_CAR (rands));
    }
  else if (fun_type == scheme_struct_proc_type)
    {
      return (scheme_apply_struct_proc (rator, rands));
    }
  else
    {
      scheme_signal_error ("apply: bad procedure");
    }
}

/* locals */

static Scheme_Object *
procedure_p (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 1), "procedure?: wrong number of args");
  return (SCHEME_PROCP (argv[0]) ? scheme_true : scheme_false);
}

static Scheme_Object *
closure_p (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 1), "closure?: wrong number of args");
  return (SCHEME_CLOSUREP (argv[0]) ? scheme_true : scheme_false);
}

static Scheme_Object *
apply (int argc, Scheme_Object *argv[])
{
  Scheme_Object *rands, *rands_last, *pair;
  int i;

  SCHEME_ASSERT ((argc >= 2), "apply: two argument version only");
  SCHEME_ASSERT (SCHEME_PROCP (argv[0]), "apply: first arg must be a procedure");
  rands = rands_last = scheme_null;
  for ( i=1 ; i<(argc-1) ; ++i )
    {
      pair = scheme_make_pair (argv[i], scheme_null);
      if (SCHEME_NULLP (rands))
	{
	  rands = rands_last = pair;
	}
      else
	{
	  SCHEME_CDR (rands_last) = pair;
	  rands_last = pair;
	}
    }
  SCHEME_ASSERT (SCHEME_LISTP (argv[i]), "apply: last arg must be a list");
  if (SCHEME_NULLP (rands))
    {
      rands = argv[i];
    }
  else
    {
      SCHEME_CDR (rands_last) = argv[i];
    }
  return (scheme_apply (argv[0], rands));
}

static Scheme_Object *map_help (Scheme_Object *fun, Scheme_Object *list);

static Scheme_Object *
map (int argc, Scheme_Object *argv[])
{
  int i, size;
  Scheme_Object *first, *last, *pair;
  Scheme_Object *retfirst, *retlast;

  SCHEME_ASSERT ((argc > 1), "map: wrong number of args");
  SCHEME_ASSERT (SCHEME_PROCP (argv[0]), "map: first arg must be a procedure");
  for ( i=1 ; i<argc ; ++i )
    {
      SCHEME_ASSERT (SCHEME_LISTP (argv[i]), "map: all args other than first must be lists");
      if (i == 1)
	{
	  size = scheme_list_length (argv[i]);
	}
      else
	{
	  if (size != scheme_list_length (argv[i]))
	    {
	      scheme_signal_error ("map: all lists must have same size");
	    }
	}
    }

  retfirst = retlast = scheme_null;
  while (! SCHEME_NULLP (argv[1]))
    {
      /* collect args to apply */
      first = last = scheme_null;
      for ( i=1 ; i<argc ; ++i )
	{
	  pair = scheme_make_pair (SCHEME_CAR (argv[i]), scheme_null);
	  if (SCHEME_NULLP (first))
	    {
	      first = last = pair;
	    }
	  else
	    {
	      SCHEME_CDR (last) = pair;
	      last = pair;
	    }
	  argv[i] = SCHEME_CDR (argv[i]);
	}
      pair = scheme_make_pair (scheme_apply (argv[0], first), scheme_null);
      if (SCHEME_NULLP (retfirst))
	{
	  retfirst = retlast = pair;
	}
      else
	{
	  SCHEME_CDR (retlast) = pair;
	  retlast = pair;
	}
    }
  return (retfirst);
}

static Scheme_Object *
map_help (Scheme_Object *fun, Scheme_Object *list)
{
  if (SCHEME_NULLP (list))
    {
      return (scheme_null);
    }
  else
    {
      return (scheme_make_pair 
	      (scheme_apply(fun,scheme_make_pair(SCHEME_CAR(list), scheme_null)),
	       map_help (fun, SCHEME_CDR (list))));
    }
}

static Scheme_Object *
for_each (int argc, Scheme_Object *argv[])
{
  Scheme_Object *ret, *list, *fun;

  SCHEME_ASSERT ((argc == 2), "for-each: two argument version only");
  SCHEME_ASSERT (SCHEME_PROCP (argv[0]), "for-each: first arg must be a procedure");
  SCHEME_ASSERT (SCHEME_LISTP (argv[1]), "for-each: second arg must be a list");
  fun = argv[0];
  list = argv[1];
  while (! SCHEME_NULLP (list))
    {
      ret = scheme_apply (fun, scheme_make_pair (SCHEME_CAR (list), scheme_null));
      list = SCHEME_CDR (list);
    }
  return (ret);
}

static Scheme_Object *
call_cc (int argc, Scheme_Object *argv[])
{
  jmp_buf buf;
  Scheme_Object *ret, *cont;

  SCHEME_ASSERT ((argc == 1), "call-with-current-continuation: wrong number of args");
  SCHEME_ASSERT (SCHEME_PROCP (argv[0]), 
		 "call-with-current-continuation: arg must be a procedure");
  if (ret = (Scheme_Object *)setjmp (buf))
    {
      return (ret);
    }
  else
    {
      cont = scheme_make_cont (buf);
      return (scheme_apply (argv[0], scheme_make_pair (cont, scheme_null)));
    }
}

static Scheme_Object *
closure_code (int argc, Scheme_Object *argv[])
{
    SCHEME_ASSERT ((argc == 1), "closure-code: wrong number of args");
    SCHEME_ASSERT (SCHEME_CLOSUREP(argv[0]), "closure-code: arg must be a closure");
    
    return SCHEME_CLOS_CODE(argv[0]);
}
