From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 13 Apr 2017 05:24:20 +0000 (-0700)
Subject: Implement select-on-bytes-per-word for gnerating word-length-specific code.
X-Git-Tag: mit-scheme-pucked-9.2.12~158^2~48
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=639f9ea8d65f62f8e7060b26d938b38b7b53b254;p=mit-scheme.git

Implement select-on-bytes-per-word for gnerating word-length-specific code.
---

diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index a27224d75..94e38aadc 100644
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -107,4 +107,16 @@ USA.
 			(guarantee-binding source-environment source-name)
 			(link-variables environment (vector-ref binding 0)
 					source-environment source-name)))))))))
-       (->environment '(package)))))
\ No newline at end of file
+       (->environment '(package)))
+      (eval
+       '(define-syntax select-on-bytes-per-word
+	  (er-macro-transformer
+	   (lambda (form rename compare)
+	     rename compare
+	     (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form)
+	     (let ((bpo (bytes-per-object)))
+	       (case bpo
+		 ((4) (cadr form))
+		 ((8) (caddr form))
+		 (else (error "Unsupported bytes-per-object:" bpo)))))))
+       (->environment '(runtime)))))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f31af4396..4b1a24121 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4702,6 +4702,7 @@ USA.
   (export (runtime)
 	  define-deferred
 	  define-primitives
+	  select-on-bytes-per-word
 	  ucode-primitive
 	  ucode-return-address
 	  ucode-type))
diff --git a/src/runtime/sysmac.scm b/src/runtime/sysmac.scm
index d1d661d9b..cd0d0e929 100644
--- a/src/runtime/sysmac.scm
+++ b/src/runtime/sysmac.scm
@@ -73,7 +73,7 @@ USA.
    (lambda (form environment)
      environment
      (make-return-address (apply microcode-return (cdr form))))))
-
+
 (define-syntax define-guarantee
   (sc-macro-transformer
    (lambda (form environment)
@@ -104,4 +104,15 @@ USA.
 	  (,(rename 'ADD-BOOT-INIT!)
 	   (,(rename 'LAMBDA) ()
 	     (,(rename 'SET!) ,name ,value)
-	     ,(rename 'UNSPECIFIC))))))))
\ No newline at end of file
+	     ,(rename 'UNSPECIFIC))))))))
+
+(define-syntax select-on-bytes-per-word
+  (er-macro-transformer
+   (lambda (form rename compare)
+     rename compare
+     (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form)
+     (let ((bpo (bytes-per-object)))
+       (case bpo
+	 ((4) (cadr form))
+	 ((8) (caddr form))
+	 (else (error "Unsupported bytes-per-object:" bpo)))))))
\ No newline at end of file