(herald orbit-util)

;;; Load into ORBIT-ENV.

(define (orbit-eval exp env)
  (bind ((*noise+error* (error-output))
         (*noise+terminal* null-port)
         (*noise-stream* null-port))
    (receive (comex #f #f)
             (compile `(,syntax/lambda () ,exp)
                      (if (eq? env t-implementation-env)
                          base-early-binding-env
                          standard-early-binding-env)
                      (env-syntax-table env)
                      bogus-filename
                      '(anonymous))
      (instantiate-comex comex env))))

(set *noise-flag* '#f)
(set *debug-flag* '#f)

(define (orbit-noisily exp . env)
  (let ((env (if (null? env) (repl-env) (car env))))
    (with-noisy-orbit nil               ; No external noise port.
      (lambda ()
        (receive (comex #f #f)
                 (compile* `(,syntax/lambda () ,exp)
                           (if (eq? env t-implementation-env)
                               base-early-binding-env
                               standard-early-binding-env)
                           (env-syntax-table env)
                           bogus-filename
                           '(anonymous)
                           quicklist)
          (instantiate-comex comex env))))))

(define (cl-noisily exp . env)
  (let ((env (if (null? env) (repl-env) (car env))))
    ((lambda (body)
       (cond ((not (procedure? exp))
              (body exp))
             ((disclose exp)
              => body)
             (else
              (cl-noisily (error "cannot get source code for ~S" exp)
                          env))))
     (lambda (exp)
       (with-noisy-orbit nil
         (lambda ()
           (compile* `(,syntax/lambda () ,exp)
                     (if (eq? env t-implementation-env)
                         base-early-binding-env
                         standard-early-binding-env)
                     (env-syntax-table env)
                     bogus-filename
                     '(cl)
                     quicklist)
           (return)))))))

(define (compile-file-noisily filespec . maybe-out-filespec)
  (let* ((in-filename  (->filename filespec))
         (out-filename (if (null? maybe-out-filespec)
                           in-filename
                           (->filename (car maybe-out-filespec)))))
    (with-open-ports
        ((noise (open (filename-with-type out-filename
                                          *noise-file-extension*)
                      'out)))
      (with-noisy-orbit noise
        (lambda ()
          (receive (exp support syntax herald)
                   (read-file in-filename)
            (receive (comex infex debugex)
                     (compile* exp support syntax in-filename herald
                               quicklist)
              (write-support-file infex out-filename)
              (write-object-file  comex out-filename)
              (write-debug-file debugex out-filename)
              t)))))))

(define-constant comfile-noisily compile-file-noisily)

(define (with-noisy-orbit noise thunk)
  (bind ((*noise-flag*           t)
         (*debug-flag*           t)
         (*front-debug*          t)
         (*assembly-comments?*   t))
    (if noise
        (bind ((*noise+error*
                (make-broadcast-port noise (error-output)))
               (*noise+terminal*
                (make-broadcast-port noise (terminal-output)))
               (*noise-stream*   noise))
          (thunk))
        (bind ((*noise+error*    (error-output))
               (*noise+terminal* (terminal-output))
               (*noise-stream*   (terminal-output)))
          (thunk)))))

(define (compile* exp support syntax filename herald thunk)
  (front-init support
    (lambda ()
      (generate-init
        (lambda ()
          (assemble-init
            (lambda ()
              (receive vals
                       (really-compile exp syntax filename herald)
                (thunk)
                (apply return vals)))))))))



(define-local-syntax (export env . names)
  (let ((env-name (generate-symbol 'ENV)))
    `(LET ((,env-name ,env))
       ,@(map (lambda (name)
                `(*DEFINE ,env-name (QUOTE ,name) ,name))
              names))))

(export standard-env
  orbit-eval
  orbit-noisily
  cl-noisily
  compile-file-noisily
  comfile-noisily)

(export t-implementation-env
  orbit-eval
  orbit-noisily
  cl-noisily
  compile-file-noisily
  comfile-noisily)