From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 2 May 2007 00:11:10 +0000 (+0000)
Subject: Add new variable MICROCODE-ID/COMPILED-CODE-TYPE.  Add optional ERROR?
X-Git-Tag: 20090517-FFI~604
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d9f19922dd7f4e9335fe44871187afcb414485fa;p=mit-scheme.git

Add new variable MICROCODE-ID/COMPILED-CODE-TYPE.  Add optional ERROR?
argument to MICROCODE-IDENTIFICATION-VECTOR-SLOT and
MICROCODE-IDENTIFICATION-ITEM.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 03bcb9055..78770b51b 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.616 2007/04/29 19:25:27 cph Exp $
+$Id: runtime.pkg,v 14.617 2007/05/02 00:11:05 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -2477,6 +2477,7 @@ USA.
 	  microcode-error/code->name
 	  microcode-error/code-limit
 	  microcode-error/name->code
+	  microcode-id/compiled-code-type
 	  microcode-id/floating-epsilon
 	  microcode-id/floating-mantissa-bits
 	  microcode-id/machine-type
diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm
index 38271157e..183815f68 100644
--- a/v7/src/runtime/utabs.scm
+++ b/v7/src/runtime/utabs.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: utabs.scm,v 14.24 2007/04/15 15:50:42 cph Exp $
+$Id: utabs.scm,v 14.25 2007/05/02 00:11:10 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -75,14 +75,7 @@ USA.
   (set! system-call-names-slot (fixed-object/name->code 'SYSTEM-CALL-NAMES))
   (set! system-call-errors-slot (fixed-object/name->code 'SYSTEM-CALL-ERRORS))
   (set! microcode-version-string
-	(let ((version (microcode-identification-item 'MICROCODE-VERSION)))
-	  (if (string? version)
-	      version
-	      (string-append
-	       (number->string version)
-	       "."
-	       (number->string
-		(microcode-identification-item 'MICROCODE-MODIFICATION))))))
+	(microcode-identification-item 'MICROCODE-VERSION))
   (set! char:newline (microcode-identification-item 'NEWLINE-CHAR))
   (set! microcode-id/floating-mantissa-bits
 	(microcode-identification-item 'FLONUM-MANTISSA-LENGTH))
@@ -99,9 +92,11 @@ USA.
 		((not string) 'STANDARD)
 		(else (error "Illegal stack type:" string)))))
   (set! microcode-id/machine-type
-	(if (microcode-table-search identifications-slot 'MACHINE-TYPE-STRING)
-	    (microcode-identification-item 'MACHINE-TYPE-STRING)
+	(or (microcode-identification-item 'MACHINE-TYPE-STRING #f)
 	    "unknown-machine"))
+  (set! microcode-id/compiled-code-type
+	(intern (or (microcode-identification-item 'CC-ARCH-STRING #f)
+		    "unknown")))
   (set! microcode-id/tty-x-size
 	(microcode-identification-item 'CONSOLE-WIDTH))
   (set! microcode-id/tty-y-size
@@ -135,6 +130,7 @@ USA.
 (define microcode-id/operating-system-variant)
 (define microcode-id/stack-type)
 (define microcode-id/machine-type)
+(define microcode-id/compiled-code-type)
 
 (define-integrable fixed-objects-slot 15)
 (define non-object-slot)
@@ -234,13 +230,16 @@ USA.
 (define identifications-slot)
 (define identification-vector)
 
-(define (microcode-identification-vector-slot name)
-  (or (microcode-table-search identifications-slot name)
-      (error:bad-range-argument name 'MICROCODE-IDENTIFICATION-VECTOR-SLOT)))
+(define (microcode-identification-vector-slot name #!optional error?)
+  (let ((v (microcode-table-search identifications-slot name)))
+    (if (and (not v) (if (default-object? error?) #t error?))
+	(error:bad-range-argument name 'MICROCODE-IDENTIFICATION-VECTOR-SLOT))
+    v))
 
-(define (microcode-identification-item name)
-  (vector-ref identification-vector
-	      (microcode-identification-vector-slot name)))
+(define (microcode-identification-item name #!optional error?)
+  (let ((slot (microcode-identification-vector-slot name error?)))
+    (and slot
+	 (vector-ref identification-vector slot))))
 
 (define system-call-names-slot)