;==============================================================================
;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

; file: "host.scm"

;------------------------------------------------------------------------------
;
; Host system interface:
; ---------------------

; This package contains definitions to interface to the host system in which
; the compiler is loaded.  This is the only package that contains non-portable
; scheme code.  So one should be able to port the compiler to another system by
; adjusting this file.  The global variable 'host-system' is assumed to contain
; the name of the host system.

;------------------------------------------------------------------------------

; The host dependent variables:
; ----------------------------

; 'open-input-file*' is like open-input-file but returns #f when the named
; file does not exist.

(define open-input-file* open-input-file)

; 'pp-expression' is used to pretty print an expression on a given port.

(define (pp-expression expr port)
  (newline port)
  (write expr port)
  (newline port))

; 'write-returning-len' is like 'write' but it returns the number of
; characters that were written out.

(define (write-returning-len obj port)
  (write obj port)
  1)

; 'display-returning-len' is like 'display' but it returns the number of
; characters that were written out.

(define (display-returning-len obj port)
  (display obj port)
  1)

; 'write-word' is used to write out files containing binary data.

(define (write-word w port)
  (write-char (integer->char (quotient w 256)) port)
  (write-char (integer->char (modulo w 256)) port))

; Various characters

(define char-newline (integer->char 10))
(define char-tab     (integer->char 9))

; 'character-encoding' is used to convert Scheme characters into their
; corresponding machine representation.

(define character-encoding char->integer)

; Highest value returned by 'character-encoding'.

(define max-character-encoding 255)

; 'fatal-err' is used to signal non recoverable errors.

(define (fatal-err msg arg)
  (error msg arg))

; 'scheme-global-var', 'scheme-global-var-ref', 'scheme-global-var-set!' and
; 'scheme-global-eval' define an interface to the a built-in evaluator (if
; there is one).  The evaluator is only needed for the processing of macros.

(define (scheme-global-var name)
  name)

(define (scheme-global-var-ref var)
  (scheme-global-eval var))

(define (scheme-global-var-set! var val)
  (scheme-global-eval (list 'SET! var (list 'QUOTE val)) fatal-err))

(define (scheme-global-eval expr err)
  (eval expr))

; 'pinpoint-error' is called when the compiler detects a user error in a source
; file.  In a windowed environment this can be used to show the location of
; an error.

(define (pinpoint-error filename line char)
  #t)

; 'path-absolute?', 'file-path', 'file-name', 'file-root', 'file-ext' define
; an interface to the file system's naming conventions.
;
; Under UNIX,
;              (path-absolute? "/foo/bar")   => #t
;              (path-absolute? "foo.scm")    => #f
;              (file-path "foo/bar/baz.scm") => "foo/bar"
;              (file-name "foo/bar/baz.scm") => "baz.scm"
;              (file-ext  "foo/bar/baz.scm") => "scm"
;              (file-root "foo/bar/baz.scm") => "foo/bar/baz"

(define file-path-sep #\/)
(define file-ext-sep #\.)

(define (path-absolute? x)
  (and (> (string-length x) 0)
       (let ((c (string-ref x 0)))
         (or (char=? c #\/) (char=? c #\~)))))

(define (file-path x)
  (let loop1 ((i (string-length x)))
    (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
      (loop1 (- i 1))
      (let ((result (make-string i)))
        (let loop2 ((j (- i 1)))
          (if (< j 0)
            result
            (begin
              (string-set! result j (string-ref x j))
              (loop2 (- j 1)))))))))

(define (file-name x)
  (let loop1 ((i (string-length x)))
    (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
      (loop1 (- i 1))
      (let ((result (make-string (- (string-length x) i))))
        (let loop2 ((j (- (string-length x) 1)))
          (if (< j i)
            result
            (begin
              (string-set! result (- j i) (string-ref x j))
              (loop2 (- j 1)))))))))

(define (file-ext x)
  (let loop1 ((i (string-length x)))
    (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
      ""
      (if (not (char=? (string-ref x (- i 1)) file-ext-sep))
        (loop1 (- i 1))
        (let ((result (make-string (- (string-length x) i))))
          (let loop2 ((j (- (string-length x) 1)))
            (if (< j i)
              result
              (begin
                (string-set! result (- j i) (string-ref x j))
                (loop2 (- j 1))))))))))

(define (file-root x)
  (let loop1 ((i (string-length x)))
    (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
      x
      (if (not (char=? (string-ref x (- i 1)) file-ext-sep))
        (loop1 (- i 1))
        (let ((result (make-string (- i 1))))
          (let loop2 ((j (- i 2)))
            (if (< j 0)
              result
              (begin
                (string-set! result j (string-ref x j))
                (loop2 (- j 1))))))))))


; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Set the variables according to host:
; -----------------------------------

(case host-system


  ((GAMBIT)

   (set! pp-expression
     (lambda (expr port)
       (pp expr port)
       (newline port)))

   (set! write-returning-len write)
   (set! display-returning-len display)

  )


  ((MIT)

   #f

  )


  ((T)

   (set! case-fell-off-end '())

   (let ((original-number->string number->string))
     (set! number->string
       (lambda (n) (original-number->string n '(HEUR)))))

   (let ((original-string->number string->number))
     (set! string->number
       (lambda (str . radix)
         (let ((r (cond ((null? radix)      "")
                        ((= (car radix) 2)  "#b")
                        ((= (car radix) 8)  "#o")
                        ((= (car radix) 16) "#x")
                        (else               ""))))
           (let ((n (original-string->number (string-append r str))))
             (if (number? n) n #f))))))

   (let ((original-make-vector make-vector))
     (set! make-vector
       (lambda (len . init)
         (let ((v (original-make-vector len)))
           (if (not (null? init))
             (let loop ((i (- len 1)))
               (if (>= i 0)
                 (begin (vector-set! v i (car init)) (loop (- i 1))))))
           v))))

   (set! exact?
     (lambda (x) (or (integer? x) (rational? x))))

   (set! inexact?
     (lambda (x) (not (exact? x))))

   (set! make-string
     (lambda l (list->string (vector->list (apply make-vector l)))))

  )


  (else

   (display "The host system '")
   (display host-system)
   (display "' is not known.")
   (newline)
   (display "You must edit file 'host.scm' to account for that system.")
   (newline)
   (fatal-err "Unknown host system" host-system)))

;==============================================================================