From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 8 Mar 2001 17:03:35 +0000 (+0000)
Subject: Add mechanism to allow signalling an error with an arbitrary Scheme
X-Git-Tag: 20090517-FFI~2927
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e6407bba2f4541415a1cbda0edf9b4bd180e83a1;p=mit-scheme.git

Add mechanism to allow signalling an error with an arbitrary Scheme
object as an argument.
---

diff --git a/v7/src/microcode/errors.h b/v7/src/microcode/errors.h
index aaeec0374..56e29fe67 100644
--- a/v7/src/microcode/errors.h
+++ b/v7/src/microcode/errors.h
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: errors.h,v 9.42 1999/01/02 06:11:34 cph Exp $
+$Id: errors.h,v 9.43 2001/03/08 17:03:30 cph Exp $
 
-Copyright (c) 1987-1999 Massachusetts Institute of Technology
+Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
 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
@@ -34,7 +34,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 #define ERR_UNASSIGNED_VARIABLE			0x02
 #define ERR_INAPPLICABLE_OBJECT			0x03
 #define ERR_IN_SYSTEM_CALL			0x04
-/* #define ERR_ENVIRONMENT_CHAIN_TOO_DEEP	0x05 */
+#define ERR_WITH_ARGUMENT			0x05
 #define ERR_BAD_FRAME				0x06
 #define ERR_BROKEN_COMPILED_VARIABLE		0x07
 #define ERR_UNDEFINED_USER_TYPE			0x08
diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h
index 6433e7a52..16eb9dd8d 100644
--- a/v7/src/microcode/prims.h
+++ b/v7/src/microcode/prims.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: prims.h,v 9.47 2001/01/04 22:07:41 cph Exp $
+$Id: prims.h,v 9.48 2001/03/08 17:03:32 cph Exp $
 
 Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
@@ -80,6 +80,7 @@ extern void EXFUN (signal_interrupt_from_primitive, (void));
 extern void EXFUN (error_wrong_type_arg, (int));
 extern void EXFUN (error_bad_range_arg, (int));
 extern void EXFUN (error_external_return, (void));
+extern void EXFUN (error_with_argument, (SCHEME_OBJECT));
 extern long EXFUN (arg_integer, (int));
 extern long EXFUN (arg_nonnegative_integer, (int));
 extern long EXFUN (arg_index_integer, (int, long));
diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c
index 20395684f..ac5c5d178 100644
--- a/v7/src/microcode/utils.c
+++ b/v7/src/microcode/utils.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: utils.c,v 9.75 2000/12/05 21:23:48 cph Exp $
+$Id: utils.c,v 9.76 2001/03/08 17:03:35 cph Exp $
 
 Copyright (c) 1987-2000 Massachusetts Institute of Technology
 
@@ -367,16 +367,27 @@ DEFUN_VOID (error_external_return)
   signal_error_from_primitive (ERR_EXTERNAL_RETURN);
 }
 
-unsigned int syscall_error_code;
-unsigned int syscall_error_name;
+static SCHEME_OBJECT error_argument;
+
+void
+DEFUN (error_with_argument, (argument), SCHEME_OBJECT argument)
+{
+  error_argument = argument;
+  signal_error_from_primitive (ERR_WITH_ARGUMENT);
+  /*NOTREACHED*/
+}
 
 void
 DEFUN (error_in_system_call, (err, name),
        enum syserr_names err AND enum syscall_names name)
 {
-  syscall_error_code = ((unsigned int) err);
-  syscall_error_name = ((unsigned int) name);
-  signal_error_from_primitive (ERR_IN_SYSTEM_CALL);
+  /* System call errors have some additional information.
+     Encode this as a vector in place of the error code.  */
+  SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 0));
+  VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
+  VECTOR_SET (v, 1, (LONG_TO_UNSIGNED_FIXNUM ((unsigned int) err)));
+  VECTOR_SET (v, 2, (LONG_TO_UNSIGNED_FIXNUM ((unsigned int) name)));
+  error_with_argument (v);
   /*NOTREACHED*/
 }
 
@@ -384,8 +395,7 @@ void
 DEFUN (error_system_call, (code, name),
        int code AND enum syscall_names name)
 {
-  error_in_system_call ((OS_error_code_to_syserr (code)),
-			name);
+  error_in_system_call ((OS_error_code_to_syserr (code)), name);
   /*NOTREACHED*/
 }
 
@@ -630,20 +640,12 @@ DEFUN (Do_Micro_Error, (Err, From_Pop_Return),
   /* Arg 2:     Int. mask */
   STACK_PUSH (LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
   /* Arg 1:     Err. No   */
-  if (Err == ERR_IN_SYSTEM_CALL)
-    {
-      /* System call errors have some additional information.
-	 Encode this as a vector in place of the error code.  */
-      SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 0));
-      VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
-      VECTOR_SET (v, 1, (LONG_TO_UNSIGNED_FIXNUM (syscall_error_code)));
-      VECTOR_SET (v, 2, (LONG_TO_UNSIGNED_FIXNUM (syscall_error_name)));
-      STACK_PUSH (v);
-    }
+  if (Err == ERR_WITH_ARGUMENT)
+    STACK_PUSH (error_argument);
   else if ((Err >= SMALLEST_FIXNUM) && (Err <= BIGGEST_FIXNUM))
-      STACK_PUSH (LONG_TO_FIXNUM (Err));
+    STACK_PUSH (LONG_TO_FIXNUM (Err));
   else
-      STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (ERR_BAD_ERROR_CODE));
+    STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (ERR_BAD_ERROR_CODE));
   /* Procedure: Handler   */
   STACK_PUSH (Handler);
   STACK_PUSH (STACK_FRAME_HEADER + 2);