From 302e3218b7d487539ec305bf23881a6ee7d5be99 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:29 -0800
Subject: Import Upstream version 5e1

---
 eval.c | 47 +++++++++++++++++++++++++++++++++++------------
 1 file changed, 35 insertions(+), 12 deletions(-)

(limited to 'eval.c')

diff --git a/eval.c b/eval.c
index d5bba5f..3e39bee 100644
--- a/eval.c
+++ b/eval.c
@@ -144,7 +144,7 @@ SCM m_define_syntax P((SCM xorig, SCM env, SCM ctxt));
 SCM m_let_syntax P((SCM xorig, SCM env, SCM ctxt));
 SCM m_letrec_syntax P((SCM xorig, SCM env, SCM ctxt));
 SCM m_the_macro P((SCM xorig, SCM env, SCM ctxt));
-void scm_dynthrow P((SCM cont, SCM val));
+void scm_dynthrow P((SCM cont, SCM arg1, SCM arg2, SCM rest));
 void scm_egc P((void));
 void scm_estk_grow P((void));
 void scm_estk_shrink P((void));
@@ -757,6 +757,7 @@ static SCM toplevel_define(xorig, env)
   SCM name = CAR(x);
   ASRTER(scm_nullenv_p(env), xorig, s_placement, s_define);
   ENV_PUSH;
+  scm_env_tmp = EOL;		/* Make sure multiple values -> error */
   x = cons(m_binding(name, CAR(CDR(x)), env, EOL), EOL);
   x = evalcar(x);
   ENV_POP;
@@ -1056,10 +1057,12 @@ static int in_atcase_aux = 0;
 SCM m_case(xorig, env, ctxt)
      SCM xorig, env, ctxt;
 {
-  SCM clause, x = CDR(xorig), key_expr = CAR(x);
+  SCM clause, key_expr, x = CDR(xorig);
   SCM s, keys = EOL, action, actions = EOL, else_action = list_unspecified;
   int opt = !scm_nullenv_p(env);
+
   ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case);
+  key_expr = CAR(x);
   while(NIMP(x = CDR(x))) {
     clause = CAR(x);
     s = scm_check_linum(clause, 0L);
@@ -1773,6 +1776,12 @@ static SCM macroexp1(xorig, env, ctxt, mode)
 	goto retx;
       }
     }
+#ifndef RECKLESS
+    if (ilength(x) < 0) {
+      what = s_expr;
+      goto errout;
+    }
+#endif
     x = cons2(IM_FUNCALL, proc, CDR(x));
     goto retx;
   }
@@ -1930,8 +1939,10 @@ int scm_arity_check(proc, argc, what)
     if (what) wta(proc, (char *)WNA, what);
     return 0;
   case tc7_subr_0: ASRTGO(0==argc, wrongnumargs) return !0;
-  case tc7_cxr:
   case tc7_contin:
+    if (IM_VALUES_TOKEN == CONT(proc)->other.stkframe[1]) return !0;
+				/* else fall through */
+  case tc7_cxr:
   case tc7_subr_1: ASRTGO(1==argc, wrongnumargs) return !0;
   case tc7_subr_1o: ASRTGO(0==argc || 1==argc, wrongnumargs) return !0;
   case tc7_subr_2: ASRTGO(2==argc, wrongnumargs) return !0;
@@ -2193,6 +2204,8 @@ static SCM ceval_1(x)
 	goto cdrxbegin;
 	}
     */
+    scm_env_tmp = EOL;		/* needed so multiple values cause an error
+                               to be signaled when this is a top-level form. */
     do {
       scm_env_tmp = EVALCAR(proc);
       proc = CDR(proc);
@@ -2403,6 +2416,7 @@ static SCM ceval_1(x)
 	return scm_values(UNDEFINED, UNDEFINED, EOL, s_values);
       }
     case tc7_contin:
+      scm_dynthrow(proc, UNDEFINED, UNDEFINED, EOL);
     case tc7_subr_1:
     case tc7_subr_2:
     case tc7_subr_2o:
@@ -2493,7 +2507,7 @@ evap1:
 	goto clo_checked;
       }
     case tc7_contin:
-      scm_dynthrow(proc, arg1);
+      scm_dynthrow(proc, arg1, UNDEFINED, EOL);
     case tc7_specfun:
       switch TYP16(proc) {
       case tc16_call_cc:
@@ -2625,6 +2639,7 @@ evap1:
       case tc7_subr_1:
       case tc7_subr_3:
       case tc7_contin:
+	scm_dynthrow(proc, arg1, arg2, EOL);
 	goto wrongnumargs;
       default:
 	goto badfun;
@@ -2721,13 +2736,14 @@ evap1:
 	case tc16_values:
 	  return scm_values(arg1, arg2, cons(arg3, x), s_values);
 	}
+      case tc7_contin:
+	  scm_dynthrow(proc, arg1, arg2, cons(arg3, x));
       case tc7_subr_2:
       case tc7_subr_1o:
       case tc7_subr_2o:
       case tc7_subr_0:
       case tc7_cxr:
       case tc7_subr_1:
-      case tc7_contin:
 	goto wrongnumargs;
       default:
 	goto badfun;
@@ -2922,8 +2938,8 @@ SCM apply(proc, arg1, args)
     return arg1;
   }
   case tc7_contin:
-    ASRTGO(NULLP(args), wrongnumargs);
-    scm_dynthrow(proc, arg1);
+    if (NULLP(args)) scm_dynthrow(proc, arg1, UNDEFINED, EOL);
+				/* else fall through */
   case tc7_specfun:
     args = UNBNDP(arg1) ? EOL : cons(arg1, args);
     arg1 = proc;
@@ -3023,7 +3039,8 @@ SCM scm_cvapply(proc, n, argv)
     return res;
   }
   case tc7_contin:
-    scm_dynthrow(proc, argv[0]);
+    if (1 == n) scm_dynthrow(proc, argv[0], UNDEFINED, EOL);
+    goto call_apply;
   case tc7_specfun:
     if (tc16_apply==TYP16(proc)) {
       proc = argv[0];
@@ -3034,6 +3051,7 @@ SCM scm_cvapply(proc, n, argv)
 #endif
       goto tail;
     }
+  call_apply:
     res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv, EOL));
 #ifdef CCLO
     proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure);
@@ -3375,10 +3393,15 @@ SCM eval(obj)
   return EVAL(obj, EOL, EOL);
 }
 
-SCM definedp(x, env)
-     SCM x, env;
+static char s_definedp[] = "defined?";
+SCM definedp(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM proc = CAR(x = CDR(x));
+  SCM x = CDR(xorig);
+  SCM proc;
+
+  ASSYNT(1 == ilength(x), xorig, s_body, s_definedp);
+  proc = CAR(x);
 #ifdef MACRO
   proc = id2sym(proc);
 #endif
@@ -3661,7 +3684,7 @@ void init_eval()
   loc_atcase_aux = &CDR(sysintern("@case-aux", UNDEFINED));
 
   /* acros */
-  make_synt("defined?", MAC_ACRO, definedp);
+  make_synt(s_definedp, MAC_ACRO, definedp);
   /* end of acros */
 
   make_synt(s_and, MAC_MMACRO, m_and);
-- 
cgit v1.2.3