From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Sat, 28 Aug 1993 05:45:25 +0000 (+0000)
Subject: Add primitive dynamic loading ability to the microcode.
X-Git-Tag: 20090517-FFI~7972
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=09ad8b9d9adbe545e0062ec8204a62119a044c36;p=mit-scheme.git

Add primitive dynamic loading ability to the microcode.
---

diff --git a/v7/src/microcode/primutl.c b/v7/src/microcode/primutl.c
index 6a1c4fabc..41338040e 100644
--- a/v7/src/microcode/primutl.c
+++ b/v7/src/microcode/primutl.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: primutl.c,v 9.64 1993/08/04 22:21:35 cph Exp $
+$Id: primutl.c,v 9.65 1993/08/28 05:42:28 gjr Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -90,6 +90,7 @@ extern SCHEME_OBJECT
   EXFUN (make_primitive, (char *)),
   EXFUN (find_primitive, (SCHEME_OBJECT, Boolean, Boolean, int)),
   EXFUN (declare_primitive, (char *, primitive_procedure_t, int, int, char *)),
+  EXFUN (install_primitive, (char *, primitive_procedure_t, int, int, char *)),
   EXFUN (dump_renumber_primitive, (SCHEME_OBJECT)),
   * EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)),
   * EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
@@ -461,19 +462,11 @@ DEFUN_VOID (initialize_primitives)
   return;
 }
 
-/* declare_primitive returns SHARP_F if it could not allocate
-   the storage needed for the new primitive, or a primitive object.
-   The primitive object may correspond to a pre-existend primitive
-   if there is already a primitive by the same name.
-   If it is a new primitive, its PRIMITIVE_NUMBER will be the
-   previous value of MAX_PRIMITIVE.
-   Note that it can return the value of an old primitive if it
-   was previously unimplemented and the arity matches.
- */
-
-SCHEME_OBJECT
-DEFUN (declare_primitive, (name, code, nargs_lo, nargs_hi, docstr),
-       char * name
+static SCHEME_OBJECT
+DEFUN (declare_primitive_internal,
+       (override_p, code, nargs_lo, nargs_hi, docstr),
+       Boolean override_p
+       AND char * name
        AND primitive_procedure_t code
        AND int nargs_lo
        AND int nargs_hi
@@ -482,16 +475,19 @@ DEFUN (declare_primitive, (name, code, nargs_lo, nargs_hi, docstr),
 {
   int index;
   SCHEME_OBJECT primitive;
+  char * ndocstr = docstr;
   node prim = (tree_lookup (prim_procedure_tree, name));
 
   if (prim != ((node) NULL))
   {
     index = prim->value;
     primitive = (MAKE_PRIMITIVE_OBJECT (prim->value));
-    if ((IMPLEMENTED_PRIMITIVE_P (primitive))
-	|| (((PRIMITIVE_ARITY (primitive)) != nargs_hi)
-	    && ((PRIMITIVE_ARITY (primitive)) != UNKNOWN_PRIMITIVE_ARITY)))
-      return (primitive);
+    if ((((PRIMITIVE_ARITY (primitive)) != nargs_hi)
+	 && ((PRIMITIVE_ARITY (primitive)) != UNKNOWN_PRIMITIVE_ARITY))
+	|| ((IMPLEMENTED_PRIMITIVE_P (primitive)) && (! override_p)))
+      return (LONG_TO_UNSIGNED_FIXNUM (PRIMITIVE_NUMBER (primitive)));
+    if (docstr == ((char *) NULL))
+      ndocstr = Primitive_Documentation_Table[index];
   }
   else
   {
@@ -518,13 +514,53 @@ DEFUN (declare_primitive, (name, code, nargs_lo, nargs_hi, docstr),
 
   Primitive_Procedure_Table[index]     = code;
   Primitive_Arity_Table[index]         = nargs_hi;
-  Primitive_Count_Table[index]         = (nargs_hi
-					  * (sizeof (SCHEME_OBJECT)));
-  Primitive_Documentation_Table[index] = docstr;
+  Primitive_Count_Table[index]         = (nargs_hi * (sizeof (SCHEME_OBJECT)));
+  Primitive_Documentation_Table[index] = ndocstr;
   UPDATE_PRIMITIVE_TABLE_HOOK (index, (index + 1));
   return (primitive);
 }
 
+/* declare_primitive installs a new primitive in the system.
+   It returns:
+   - A primitive object if it succeeds.
+   - SHARP_F if there was a problem trying to install it (e.g. out of memory).
+   - A fixnum whose value is the number of the pre-existing primitive
+     that it would replace.
+   Note that even if a primitive is returned, its number may not
+   be the previous value of MAX_PRIMITIVE, since the system may
+   have pre-existent references to the previously-unimplemented primitive.
+ */
+
+SCHEME_OBJECT
+DEFUN (declare_primitive, (name, code, nargs_lo, nargs_hi, docstr),
+       char * name
+       AND primitive_procedure_t code
+       AND int nargs_lo
+       AND int nargs_hi
+       AND char * docstr)
+{
+  return (declare_primitive_internal (false, name, code,
+				      nargs_lo, nargs_hi, docstr));
+}
+
+/* install_primitive is similar to declare_primitive, but will
+   replace a pre-existing primitive if the arities are consistent.
+   If they are not, it returns a fixnum whose value is the index
+   of the pre-existing primitive.
+ */
+
+SCHEME_OBJECT
+DEFUN (install_primitive, (name, code, nargs_lo, nargs_hi, docstr),
+       char * name
+       AND primitive_procedure_t code
+       AND int nargs_lo
+       AND int nargs_hi
+       AND char * docstr)
+{
+  return (declare_primitive_internal (true, name, code,
+				      nargs_lo, nargs_hi, docstr));
+}
+
 /*
   make_primitive returns a primitive object,
   constructing one if necessary.
@@ -533,11 +569,16 @@ DEFUN (declare_primitive, (name, code, nargs_lo, nargs_hi, docstr),
 SCHEME_OBJECT
 DEFUN (make_primitive, (name), char * name)
 {
-  return (declare_primitive (name,
-			     Prim_unimplemented,
-			     UNKNOWN_PRIMITIVE_ARITY,
-			     UNKNOWN_PRIMITIVE_ARITY,
-			     ((char *) NULL)));
+  SCHEME_OBJECT result;
+
+  result = (declare_primitive (name,
+			       Prim_unimplemented,
+			       UNKNOWN_PRIMITIVE_ARITY,
+			       UNKNOWN_PRIMITIVE_ARITY,
+			       ((char *) NULL)));
+  return ((result == SHARP_F)
+	  ? SHARP_F
+	  : (OBJECT_NEW_TYPE (TC_PRIMITIVE, result)));
 }
 
 /* This returns all sorts of different things that the runtime
diff --git a/v7/src/microcode/syscall.h b/v7/src/microcode/syscall.h
index 2c0187dd1..e96701e16 100644
--- a/v7/src/microcode/syscall.h
+++ b/v7/src/microcode/syscall.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: syscall.h,v 1.2 1993/08/03 17:40:04 gjr Exp $
+$Id: syscall.h,v 1.3 1993/08/28 05:43:32 gjr Exp $
 
 Copyright (c) 1993 Massachusetts Institute of Technology
 
@@ -96,7 +96,8 @@ enum syscall_names
   syscall_write,
   syscall_stat,
   syscall_lstat,
-  syscall_mktime
+  syscall_mktime,
+  syscall_dld
 };
 
 enum syserr_names
diff --git a/v7/src/microcode/unxutl/ymkfile b/v7/src/microcode/unxutl/ymkfile
index b8dad10d5..9f1cde4d2 100644
--- a/v7/src/microcode/unxutl/ymkfile
+++ b/v7/src/microcode/unxutl/ymkfile
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: ymkfile,v 1.77 1993/08/24 18:27:43 bal Exp $
+$Id: ymkfile,v 1.78 1993/08/28 05:45:00 gjr Exp $
 
 Copyright (c) 1989-1993 Massachusetts Institute of Technology
 
@@ -87,6 +87,10 @@ MIT in each case. */
 #define C_OPTIMIZE_SWITCH -O
 #endif
 
+#ifndef LD_SWITCH_CF
+#define LD_SWITCH_CF
+#endif
+
 #ifndef LD_SWITCH_SYSTEM
 #define LD_SWITCH_SYSTEM
 #endif
@@ -297,9 +301,9 @@ MACHINE_OBJECTS = cmpint.o
 GC_HEAD_FILES = gccode.h cmpgc.h
 #endif /* PROC_TYPE_KNOWN */
 
-USER_PRIM_SOURCES =
-USER_PRIM_OBJECTS =
-USER_LIBS =
+USER_PRIM_SOURCES = $(CF_USER_PRIM_SOURCES)
+USER_PRIM_OBJECTS = $(CF_USER_PRIM_OBJECTS)
+USER_LIBS = $(CF_USER_LIBS)
 
 SHELL = /bin/sh
 
@@ -341,7 +345,7 @@ AS = as
 #define LIB_DEBUG
 #endif
 
-LDFLAGS = LD_SWITCH_SYSTEM LD_SWITCH_MACHINE C_DEBUG_SWITCH
+LDFLAGS = LD_SWITCH_CF LD_SWITCH_SYSTEM LD_SWITCH_MACHINE C_DEBUG_SWITCH
 
 CFLAGS = -DMIT_SCHEME C_OPTIMIZE_SWITCH C_DEBUG_SWITCH C_SWITCH_MACHINE C_SWITCH_SYSTEM C_SWITCH_FEATURES $(MACHINE_SWITCHES)
 
diff --git a/v7/src/microcode/usrdef.h b/v7/src/microcode/usrdef.h
index a55c0811c..63da155c9 100644
--- a/v7/src/microcode/usrdef.h
+++ b/v7/src/microcode/usrdef.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: usrdef.h,v 9.40 1993/08/03 08:30:02 gjr Exp $
+$Id: usrdef.h,v 9.41 1993/08/28 05:43:00 gjr Exp $
 
 Copyright (c) 1987-1993 Massachusetts Institute of Technology
 
@@ -54,6 +54,9 @@ extern long MAX_STATIC_PRIMITIVE;
 extern SCHEME_OBJECT
   EXFUN (declare_primitive, (char *, primitive_procedure_t, int, int, char *));
 
+extern SCHEME_OBJECT
+  EXFUN (install_primitive, (char *, primitive_procedure_t, int, int, char *));
+
 extern void
   EXFUN (Microcode_Termination, (int)),
   EXFUN (signal_error_from_primitive, (long));
diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm
index 90cac649e..3b7fd5070 100644
--- a/v7/src/microcode/utabmd.scm
+++ b/v7/src/microcode/utabmd.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: utabmd.scm,v 9.68 1993/08/23 22:30:08 cph Exp $
+;;; $Id: utabmd.scm,v 9.69 1993/08/28 05:44:07 gjr Exp $
 ;;;
 ;;;	Copyright (c) 1987-1993 Massachusetts Institute of Technology
 ;;;
@@ -637,6 +637,7 @@
 	       STAT
 	       LSTAT
 	       MKTIME
+	       DYNAMIC-LOAD
 	       ))
 
 ;;; [] System-call errors
@@ -702,4 +703,4 @@
 
 ;;; This identification string is saved by the system.
 
-"$Id: utabmd.scm,v 9.68 1993/08/23 22:30:08 cph Exp $"
\ No newline at end of file
+"$Id: utabmd.scm,v 9.69 1993/08/28 05:44:07 gjr Exp $"
\ No newline at end of file
diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h
index 22555cb0a..1ac7e2372 100644
--- a/v7/src/microcode/version.h
+++ b/v7/src/microcode/version.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: version.h,v 11.138 1993/08/22 22:39:06 gjr Exp $
+$Id: version.h,v 11.139 1993/08/28 05:45:25 gjr Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -46,5 +46,5 @@ MIT in each case. */
 #define VERSION		11
 #endif
 #ifndef SUBVERSION
-#define SUBVERSION	138
+#define SUBVERSION	139
 #endif
diff --git a/v8/src/microcode/utabmd.scm b/v8/src/microcode/utabmd.scm
index 90cac649e..3b7fd5070 100644
--- a/v8/src/microcode/utabmd.scm
+++ b/v8/src/microcode/utabmd.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: utabmd.scm,v 9.68 1993/08/23 22:30:08 cph Exp $
+;;; $Id: utabmd.scm,v 9.69 1993/08/28 05:44:07 gjr Exp $
 ;;;
 ;;;	Copyright (c) 1987-1993 Massachusetts Institute of Technology
 ;;;
@@ -637,6 +637,7 @@
 	       STAT
 	       LSTAT
 	       MKTIME
+	       DYNAMIC-LOAD
 	       ))
 
 ;;; [] System-call errors
@@ -702,4 +703,4 @@
 
 ;;; This identification string is saved by the system.
 
-"$Id: utabmd.scm,v 9.68 1993/08/23 22:30:08 cph Exp $"
\ No newline at end of file
+"$Id: utabmd.scm,v 9.69 1993/08/28 05:44:07 gjr Exp $"
\ No newline at end of file
diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h
index 22555cb0a..1ac7e2372 100644
--- a/v8/src/microcode/version.h
+++ b/v8/src/microcode/version.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: version.h,v 11.138 1993/08/22 22:39:06 gjr Exp $
+$Id: version.h,v 11.139 1993/08/28 05:45:25 gjr Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -46,5 +46,5 @@ MIT in each case. */
 #define VERSION		11
 #endif
 #ifndef SUBVERSION
-#define SUBVERSION	138
+#define SUBVERSION	139
 #endif