Empty out host-adapter now that the release is out.
authorChris Hanson <org/chris-hanson/cph>
Sat, 17 Nov 2018 07:07:17 +0000 (23:07 -0800)
committerChris Hanson <org/chris-hanson/cph>
Sun, 18 Nov 2018 05:34:36 +0000 (21:34 -0800)
src/runtime/host-adapter.scm

index 0c32242fd3618d29be55f8e8b2384fbe70ec5441..e7af3e2850174c138fcf8b5c24741328fcef517a 100644 (file)
@@ -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