home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Interp⁄Comp (.scm) / host.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  6.9 KB  |  196 lines  |  [TEXT/gamI]
  1. (##declare (standard-bindings) (block) (fixnum))
  2. (##declare
  3.   (namespace "c#")
  4.   (namespace ""
  5.     not boolean? eqv? eq? equal? pair? cons car cdr set-car! set-cdr!
  6.     caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
  7.     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr
  8.     cdadar cdaddr cddaar cddadr cdddar cddddr null? list? list length
  9.     append reverse list-ref memq memv member assq assv assoc symbol?
  10.     symbol->string string->symbol number? complex? real? rational?
  11.     integer? exact? inexact? = < > <= >= zero? positive? negative? odd?
  12.     even? max min + * - / abs quotient remainder modulo gcd lcm numerator
  13.     denominator floor ceiling truncate round rationalize exp log sin cos
  14.     tan asin acos atan sqrt expt make-rectangular make-polar real-part
  15.     imag-part magnitude angle exact->inexact inexact->exact number->string
  16.     string->number char? char=? char<? char>? char<=? char>=? char-ci=?
  17.     char-ci<? char-ci>? char-ci<=? char-ci>=? char-alphabetic?
  18.     char-numeric? char-whitespace? char-upper-case? char-lower-case?
  19.     char->integer integer->char char-upcase char-downcase string?
  20.     make-string string string-length string-ref string-set! string=?
  21.     string<? string>? string<=? string>=? string-ci=? string-ci<?
  22.     string-ci>? string-ci<=? string-ci>=? substring string-append vector?
  23.     make-vector vector vector-length vector-ref vector-set! procedure?
  24.     apply map for-each call-with-current-continuation call-with-input-file
  25.     call-with-output-file input-port? output-port? current-input-port
  26.     current-output-port open-input-file open-output-file close-input-port
  27.     close-output-port eof-object? read read-char peek-char write display
  28.     newline write-char
  29.  
  30.     eval error
  31.   ))
  32. ;==============================================================================
  33.  
  34. ; file: "host.scm"
  35.  
  36. ;------------------------------------------------------------------------------
  37. ;
  38. ; Host system interface:
  39. ; ---------------------
  40.  
  41. ; This package contains definitions to interface to the host system in which
  42. ; the compiler is loaded.  This is the only package that contains non-portable
  43. ; scheme code.  So one should be able to port the compiler to another system by
  44. ; adjusting this file.  The global variable 'host-system' is assumed to contain
  45. ; the name of the host system.
  46.  
  47. ;------------------------------------------------------------------------------
  48.  
  49. ; The host dependent variables:
  50. ; ----------------------------
  51.  
  52. ; 'open-input-file*' is like open-input-file but returns #f when the named
  53. ; file does not exist.
  54.  
  55. (define open-input-file* ##open-input-file)
  56.  
  57. ; 'pp-expression' is used to pretty print an expression on a given port.
  58.  
  59. (define (pp-expression expr port)
  60.   (##pretty-print expr port (##port-width port))
  61.   (##newline port))
  62.  
  63. ; 'write-returning-len' is like 'write' but it returns the number of
  64. ; characters that were written out.
  65.  
  66. (define (write-returning-len obj port)
  67.   (##write obj port #t))
  68.  
  69. ; 'display-returning-len' is like 'display' but it returns the number of
  70. ; characters that were written out.
  71.  
  72. (define (display-returning-len obj port)
  73.   (##display obj port #t))
  74.  
  75. ; 'write-word' is used to write out files containing binary data.
  76.  
  77. (define (write-word w port)
  78.   (write-char (integer->char (quotient w 256)) port)
  79.   (write-char (integer->char (modulo w 256)) port))
  80.  
  81. ; Various characters
  82.  
  83. (define char-newline (integer->char 10))
  84. (define char-tab     (integer->char 9))
  85.  
  86. ; 'character-encoding' is used to convert Scheme characters into their
  87. ; corresponding machine representation.
  88.  
  89. (define character-encoding char->integer)
  90.  
  91. ; Highest value returned by 'character-encoding'.
  92.  
  93. (define max-character-encoding 255)
  94.  
  95. ; 'fatal-err' is used to signal non recoverable errors.
  96.  
  97. (define (fatal-err msg arg)
  98.   (error msg arg))
  99.  
  100. ; 'scheme-global-var', 'scheme-global-var-ref', 'scheme-global-var-set!' and
  101. ; 'scheme-global-eval' define an interface to the a built-in evaluator (if
  102. ; there is one).  The evaluator is only needed for the processing of macros.
  103.  
  104. (define (scheme-global-var name)
  105.   name)
  106.  
  107. (define (scheme-global-var-ref var)
  108.   (scheme-global-eval var))
  109.  
  110. (define (scheme-global-var-set! var val)
  111.   (scheme-global-eval (list 'SET! var (list 'QUOTE val)) fatal-err))
  112.  
  113. (define (scheme-global-eval expr err)
  114.   (eval expr))
  115.  
  116. ; 'pinpoint-error' is called when the compiler detects a user error in a source
  117. ; file.  In a windowed environment this can be used to show the location of
  118. ; an error.
  119.  
  120. (define (pinpoint-error filename line char)
  121.   #t)
  122.  
  123. ; 'path-absolute?', 'file-path', 'file-name', 'file-root', 'file-ext' define
  124. ; an interface to the file system's naming conventions.
  125. ;
  126. ; Under UNIX,
  127. ;              (path-absolute? "/foo/bar")   => #t
  128. ;              (path-absolute? "foo.scm")    => #f
  129. ;              (file-path "foo/bar/baz.scm") => "foo/bar"
  130. ;              (file-name "foo/bar/baz.scm") => "baz.scm"
  131. ;              (file-ext  "foo/bar/baz.scm") => "scm"
  132. ;              (file-root "foo/bar/baz.scm") => "foo/bar/baz"
  133.  
  134. (define file-path-sep #\:)
  135. (define file-ext-sep #\.)
  136.  
  137. (define (path-absolute? x)
  138.   (and (> (string-length x) 0)
  139.        (let ((c (string-ref x 0)))
  140.          (or (char=? c #\/) (char=? c #\~)))))
  141.  
  142. (define (file-path x)
  143.   (let loop1 ((i (string-length x)))
  144.     (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
  145.       (loop1 (- i 1))
  146.       (let ((result (make-string i)))
  147.         (let loop2 ((j (- i 1)))
  148.           (if (< j 0)
  149.             result
  150.             (begin
  151.               (string-set! result j (string-ref x j))
  152.               (loop2 (- j 1)))))))))
  153.  
  154. (define (file-name x)
  155.   (let loop1 ((i (string-length x)))
  156.     (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
  157.       (loop1 (- i 1))
  158.       (let ((result (make-string (- (string-length x) i))))
  159.         (let loop2 ((j (- (string-length x) 1)))
  160.           (if (< j i)
  161.             result
  162.             (begin
  163.               (string-set! result (- j i) (string-ref x j))
  164.               (loop2 (- j 1)))))))))
  165.  
  166. (define (file-ext x)
  167.   (let loop1 ((i (string-length x)))
  168.     (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
  169.       ""
  170.       (if (not (char=? (string-ref x (- i 1)) file-ext-sep))
  171.         (loop1 (- i 1))
  172.         (let ((result (make-string (- (string-length x) i))))
  173.           (let loop2 ((j (- (string-length x) 1)))
  174.             (if (< j i)
  175.               result
  176.               (begin
  177.                 (string-set! result (- j i) (string-ref x j))
  178.                 (loop2 (- j 1))))))))))
  179.  
  180. (define (file-root x)
  181.   (let loop1 ((i (string-length x)))
  182.     (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
  183.       x
  184.       (if (not (char=? (string-ref x (- i 1)) file-ext-sep))
  185.         (loop1 (- i 1))
  186.         (let ((result (make-string (- i 1))))
  187.           (let loop2 ((j (- i 2)))
  188.             (if (< j 0)
  189.               result
  190.               (begin
  191.                 (string-set! result j (string-ref x j))
  192.                 (loop2 (- j 1))))))))))
  193.  
  194.  
  195. ;==============================================================================
  196.