From: Taylor R. Campbell <net/mumble/campbell>
Date: Mon, 2 Feb 2009 20:06:33 +0000 (+0000)
Subject: Use SCODE/PRIMITIVE-PROCEDURE?, not PRIMITIVE-PROCEDURE?, before
X-Git-Tag: 20090517-FFI~80
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1a1d576f0ad9dae1b58b251a38f8204b4207ab0d;p=mit-scheme.git

Use SCODE/PRIMITIVE-PROCEDURE?, not PRIMITIVE-PROCEDURE?, before
calling PRIMITIVE-PROCEDURE-NAME or PRIMITIVE-PROCEDURE-ARITY in the
compiler.  The SCODE/ variant excludes the compiled error procedure
`primitive', which is actually a string employed as a token, not a
primitive proper.
---

diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm
index ee45738b4..d78468edb 100644
--- a/v7/src/compiler/base/blocks.scm
+++ b/v7/src/compiler/base/blocks.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: blocks.scm,v 4.21 2008/01/30 20:01:42 cph Exp $
+$Id: blocks.scm,v 4.22 2009/02/02 20:06:32 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -159,7 +159,7 @@ from the continuation, and then "glued" into place afterwards.
     (if (boolean? checks)
 	checks
 	(let ((primitive
-	       (if (primitive-procedure? primitive)
+	       (if (scode/primitive-procedure? primitive)
 		   (primitive-procedure-name primitive)
 		   primitive))
 	      (default (car checks))
diff --git a/v7/src/compiler/machines/C/stackify.scm b/v7/src/compiler/machines/C/stackify.scm
index 6461a6113..96e23dc08 100644
--- a/v7/src/compiler/machines/C/stackify.scm
+++ b/v7/src/compiler/machines/C/stackify.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: stackify.scm,v 1.4 2008/01/30 20:01:46 cph Exp $
+$Id: stackify.scm,v 1.5 2009/02/02 20:06:33 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -135,7 +135,7 @@ USA.
       (symbol? obj)
       (string? obj)
       (bit-string? obj)
-      (primitive-procedure? obj)
+      (scode/primitive-procedure? obj)
       ;; The runtime system needs the following
       (interpreter-return-address? obj)))
 
@@ -508,7 +508,7 @@ USA.
 			 (bit-string->unsigned-integer obj)
 			 16))
 		       (build/push-nat (bit-string-length obj) prog)))
-	((primitive-procedure? obj)
+	((scode/primitive-procedure? obj)
 	 (let ((arity (primitive-procedure-arity obj))
 	       (name (symbol-name (primitive-procedure-name obj))))
 	   (cond ((fix:< arity 0)
diff --git a/v7/src/compiler/machines/C/traditional.scm b/v7/src/compiler/machines/C/traditional.scm
index ed8ea243b..2b15f0080 100644
--- a/v7/src/compiler/machines/C/traditional.scm
+++ b/v7/src/compiler/machines/C/traditional.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: traditional.scm,v 1.7 2008/01/30 20:01:46 cph Exp $
+$Id: traditional.scm,v 1.8 2009/02/02 20:06:33 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -225,7 +225,7 @@ USA.
 	((eq? #t object) "SHARP_T")
 	((null? object) "EMPTY_LIST")
 	((eq? object unspecific) "UNSPECIFIC")
-	((primitive-procedure? object)
+	((scode/primitive-procedure? object)
 	 (let ((arity (primitive-procedure-arity object)))
 	   (if (< arity -1)
 	       (error "->simple-C-object: Unknown arity primitive:" object))