(herald tfix)

;;; Don't print warnings about what we're patching here.

(set (print-env-warnings?) '#f)

;;; Orbit fixes.

(load-quietly-if-present `(tsystem ,(concatenate-symbol
                                     'ofix
                                     (link-edit t-system)))
                         orbit-env)

;;; By default, this uses the loading environment; this is inconsistent
;;; with Orbit, which uses the user environment.  Neither is correct,
;;; but this is most expedient for now.

(define (get-target-syntax herald env)
  (cond ((herald-syntax-table herald)
         => (lambda (st)
              (eval st user-env)))
        (else
         (env-syntax-table env))))

;;; The built-in FILE-PROBE is just broken.

(define (file-probe filespec)           ; unix_port.t
  (with-open-ports ((port (maybe-open filespec 'inquire)))
    (and port (->filename (port-truename port)))))

(*define standard-env 'file-probe file-probe)

;;; Can't use JOIN with units.  AUGMENT-UNIT in the loader, though,
;;; erroneously does.  (The JOIN mechanism should be fixed.)

(define unit-write-dates (make-weak-table 'unit-write-dates))

(define (augment-unit unit id)          ; load.t
  (if (and id (file-probe id))
      (set (weak-table-entry unit-write-dates unit)
           (file-write-date id)))
  unit)

(define (unit-write-date unit)
  (or (weak-table-entry unit-write-dates unit)
      0))

;;; Fix all those broken loaded file specifiers.

(iterate label ((locale-set top-level-environments))
  (walk-weak-set (lambda (locale)
                   (let ((alist '())
                         (table (loaded-files locale)))
                     (table-walk table
                       (lambda (filename unit)
                         (if (and (joined? unit)
                                  (unit? (joined-rhs unit)))
                             (block (augment-unit (joined-rhs unit)
                                                  filename)
                                    (push alist
                                          (cons filename
                                                (joined-rhs unit)))))))
                     ;; Patch the table.
                     (walk (lambda (f.u)
                             (set (table-entry table (car f.u))
                                  (cdr f.u)))
                           alist))
                   (label (locale-inferiors locale)))
                 locale-set))

;;; Muffle unreferenced variable warnings if REPL-EVAL is set to be an
;;; evaluator which might spew those warnings, like one that invokes
;;; Orbit and subsequently runs the Orbit-compiled code.

(define (hack-compiled-source form a-list obj)
  (receive (offset a-list)
           (if (eq? (caar a-list) '#t)
               (return (cdar a-list) (cdr a-list))
               (return nil a-list))
    (let ((expr `((,(t-syntax 'lambda) ,(map car a-list)
                    (,(t-syntax 'declare) ignorable ,@(map car a-list))
                    ,form)
                  ,@(map (lambda (x)
                           `(,(t-syntax 'quote)
                             ,(extend-elt obj (cdr x))))
                         a-list))))
      (if offset
          (let* ((n (extend-elt obj offset))
                 (real (if (template-internal-bit? (extend-header n))
                           (closure-enclosing-object n)
                           n))
                 (dl (get-debug-env (extend-header real))))
            (if dl
                (hack-compiled-source expr dl real)
                expr))
          expr))))

;;; Fix VM-READ-BLOCK so that it is careful only to use the low-level
;;; %VM-READ-PARTIAL-BLOCK if it is safe.  This fixes READ-BLOCK on
;;; string input ports (in the sense of STRING->INPUT-PORT).

(define (vm-read-block iob target size)
  (labels (((copy-from-buffer index)
            (let ((limit (iob-limit iob))
                  (offset (iob-offset iob))
                  (buffer (iob-buffer iob)))
              (cond ((fx>= (fx- limit offset)
                           (fx- size index))
                     (move-text buffer offset target index
                                (fx- size index))
                     (set (iob-offset iob)
                          (fx+ offset (fx- size index)))
                     '#f)
                    ((fx< offset limit)
                     (move-text buffer offset target index
                                (fx- limit offset))
                     (set (iob-offset iob) limit)
                     (fx+ index (fx- limit offset)))
                    (else index)))))
    (cond ((copy-from-buffer 0)
           => (lambda (index)
                (if (nonnegative-fixnum? (iob-xeno iob))
                    (%vm-read-partial-block
                     iob
                     (make-extend-locative target index
                                           (fx- size index)))
                    (iterate loop ((index index))
                      (let ((result ((iob-underflow iob) iob '#t)))
                        (if (eof? result)
                            (if (fx-zero? index) result index)
                            (cond ((copy-from-buffer index)
                                   => loop)
                                  (else size))))))))
          (else size))))

;;; Done patching.

(set (print-env-warnings?) '#t)