From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 17 Nov 2018 07:07:17 +0000 (-0800)
Subject: Empty out host-adapter now that the release is out.
X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~45
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4452eb9fe313ec41fa0807954a325b3f693b899f;p=mit-scheme.git

Empty out host-adapter now that the release is out.
---

diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index 0c32242fd..e7af3e285 100644
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -35,132 +35,4 @@ USA.
 ;;; the new runtime.  It contains temporary hacks that will be kept
 ;;; only until the new runtime is released.
 
-(let ()
-
-  (define (unbound? env name)
-    (eq? 'unbound (environment-reference-type env name)))
-
-  (let ((env (->environment '())))
-
-    (if (unbound? env 'guarantee)
-	(eval `(define (guarantee predicate object #!optional caller)
-		 (if (predicate object)
-		     object
-		     (error:wrong-type-argument
-		      object
-		      (string-append "object satisfying "
-				     (call-with-output-string
-				       (lambda (port)
-					 (write predicate port))))
-		      caller)))
-	      env))
-
-    (if (unbound? env 'bundle)
-	(eval '(define-syntax bundle
-		 (syntax-rules ()
-		   ((_ predicate name ...)
-		    (alist->bundle predicate
-				   (list (cons 'name name) ...)))))
-	      env))
-
-    (if (unbound? env 'delay-force)
-	(eval '(begin
-		 (define-syntax delay-force
-		   (syntax-rules ()
-		     ((delay-force expression)
-		      (make-unforced-promise (lambda () expression)))))
-		 (define-syntax delay
-		   (syntax-rules ()
-		     ((delay expression)
-		      (delay-force (make-promise expression))))))
-	      env))
-
-    (if (unbound? env 'parameterize)
-	(eval '(define-syntax parameterize
-		 (syntax-rules ()
-		   ((parameterize ((param value) ...) form ...)
-		    (parameterize* (list (cons param value) ...)
-				   (lambda () form ...)))))
-	      env)))
-
-  (if (name->package '(scode-optimizer))
-      (begin
-	(let ((env (->environment '(scode-optimizer))))
-	  (eval '(if (not (memq 'scode-lambda-name:unnamed
-				global-constant-objects))
-		     (begin
-		       (environment-define system-global-environment
-					   'scode-lambda-name:unnamed
-					   lambda-tag:unnamed)
-		       (set! global-constant-objects
-			     (cons 'scode-lambda-name:unnamed
-				   global-constant-objects))
-		       (usual-integrations/cache!)))
-		env))
-	(let ((env (->environment '(scode-optimizer expansion))))
-	  (eval '(let ((pred
-			(let ((names
-			       '(set-string-length!
-				 string->char-syntax
-				 string-allocate
-				 string-length
-				 string-ref
-				 string-set!
-				 string?
-				 vector-8b-ref
-				 vector-8b-set!)))
-			  (lambda (p)
-			    (memq (car p) names)))))
-		   (if (any pred usual-integrations/expansion-alist)
-		       (begin
-			 (set! usual-integrations/expansion-alist
-			       (remove! pred
-					usual-integrations/expansion-alist))
-			 (set! usual-integrations/expansion-names
-			       (map car usual-integrations/expansion-alist))
-			 (set! usual-integrations/expansion-values
-			       (map cdr usual-integrations/expansion-alist)))))
-		env))))
-
-  (let ((env (->environment '(runtime))))
-    (if (unbound? env 'select-on-bytes-per-word)
-	(begin
-	  (eval '(define-syntax select-on-bytes-per-word
-		   (er-macro-transformer
-		    (lambda (form rename compare)
-		      rename compare
-		      (syntax-check '(_ expression expression) form)
-		      (let ((bpo (bytes-per-object)))
-			(case bpo
-			  ((4) (cadr form))
-			  ((8) (caddr form))
-			  (else (error "Unsupported bytes-per-object:" bpo)))))))
-		env)
-	  (eval '(define (bytes-per-object)
-		   (vector-ref (gc-space-status) 0))
-		system-global-environment)))
-    (if (unbound? env 'variable-setter)
-	(eval '(define-syntax variable-setter
-		 (syntax-rules ()
-		   ((_ identifier)
-		    (lambda (value)
-		      (set! identifier value)
-		      unspecific))))
-	      env)))
-
-  (let ((env (->environment '(runtime microcode-tables))))
-    (if (eval '(or (not (microcode-type/name->code 'bytevector))
-		   (not (microcode-type/name->code 'tagged-object))
-		   (not (microcode-type/name->code 'unicode-string)))
-	      env)
-        (begin
-          (eval '(define (microcode-type name)
-                   (or (microcode-type/name->code name)
-                       (cond ((eq? name 'bytevector) #x33)
-                             ((eq? name 'tagged-object) #x25)
-                             ((eq? name 'unicode-string) #x1B)
-                             (else #t))
-                       (error "MICROCODE-TYPE: Unknown name:" name)))
-                env)
-          (link-variables system-global-environment 'microcode-type
-                          env 'microcode-type)))))
\ No newline at end of file
+unspecific
\ No newline at end of file