;;; 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