ice-9/slib.scm

   1 ;;; installed-scm-file
   2 (define-module #/ice-9/slib)
   3
   4 \f
   5
   6 (define (eval-load <filename> evl)
   7   (if (not (file-exists? <filename>))
   8       (set! <filename> (string-append <filename> (scheme-file-suffix))))
   9   (call-with-input-file <filename>
  10     (lambda (port)
  11       (let ((old-load-pathname *load-pathname*))
  12         (set! *load-pathname* <filename>)
  13         (do ((o (read port #t read-sharp) (read port #t read-sharp)))
  14             ((eof-object? o))
  15           (evl o))
  16         (set! *load-pathname* old-load-pathname)))))
  17
  18 \f
  19
  20 (define slib:exit quit)
  21 (define slib:error error)
  22 (define slib:eval eval)
  23 (define defmacro:eval eval)
  24 (define logical:logand logand)
  25 (define logical:logior logior)
  26 (define logical:logxor logxor)
  27 (define logical:lognot lognot)
  28 (define logical:ash ash)
  29 (define logical:logcount logcount)
  30 (define logical:integer-length integer-length)
  31 (define logical:bit-extract bit-extract)
  32 (define logical:integer-expt integer-expt)
  33 (define logical:ipow-by-squaring ipow-by-squaring)
  34 (define slib:eval-load eval-load)
  35 (define slib:tab #\tab)
  36 (define slib:form-feed #\page)
  37
  38 (define slib-module (current-module))
  39
  40 (define (defined? symbol)
  41   (module-defined? slib-module symbol))
  42
  43 (define slib:features
  44   (append '(source
  45             eval
  46             abort
  47             alist
  48             defmacro
  49             delay
  50             dynamic-wind
  51             full-continuation
  52             hash
  53             hash-table
  54             line-i/o
  55             logical
  56             multiarg/and-
  57             multiarg-apply
  58             promise
  59             rev2-procedures
  60             rev4-optional-procedures
  61             string-port
  62             with-file)
  63
  64           (if (defined? 'getenv)
  65               '(getenv)
  66               '())
  67
  68           (if (defined? 'current-time)
  69               '(current-time)
  70               '())
  71
  72           (if (defined? 'system)
  73               '(system)
  74               '())
  75
  76           (if (defined? 'array?)
  77               '(array)
  78               '())
  79
  80           (if (defined? 'char-ready?)
  81               '(char-ready?)
  82               '())
  83
  84           (if (defined? 'array-for-each)
  85               '(array-for-each)
  86               '())
  87
  88           (if (and (string->number "0.0") (inexact? (string->number "0.0")))
  89               '(inexact)
  90               '())
  91
  92           (if (rational? (string->number "1/19"))
  93               '(rational)
  94               '())
  95
  96           (if (real? (string->number "0.0"))
  97               '(real)
  98               ())
  99
 100           (if (complex? (string->number "1+i"))
 101               '(complex)
 102               '())
 103
 104           (let ((n (string->number "9999999999999999999999999999999")))
 105             (if (and n (exact? n))
 106                 '(bignum)
 107                 '()))))
 108
 109
 110 (define (slib:load name)
 111   (save-module-excursion
 112    (lambda ()
 113      (set-current-module slib-module)
 114      (let* ((errinfo (catch 'system-error
 115                             (lambda ()
 116                               (basic-load name)
 117                               #f)
 118                             (lambda args args)))
 119             (errinfo (and errinfo
 120                           (catch 'system-error
 121                                  (lambda ()
 122                                    (basic-load (string-append name ".scm"))
 123                                    #f)
 124                                  (lambda args args)))))
 125        (if errinfo
 126            (apply throw errinfo))))))
 127
 128 (define slib:load-source slib:load)
 129 (define defmacro:load slib:load)
 130
 131 (define slib-parent-dir
 132   (let* ((path (%search-load-path "slib/require.scm")))
 133     (if path
 134         (make-shared-substring path 0 (- (string-length path) 17))
 135         (error "Could not find slib/require.scm in " %load-path))))
 136
 137 (define-public (implementation-vicinity)
 138   (string-append slib-parent-dir "/"))
 139 (define (library-vicinity)
 140   (string-append (implementation-vicinity) "slib/"))
 141 (define (scheme-implementation-type) 'guile)
 142 (define (scheme-implementation-version) "")
 143
 144 (define (output-port-width . arg) 80)
 145 (define (output-port-height . arg) 24)
 146
 147 ;;; {Time}
 148 ;;;
 149
 150 (define difftime -)
 151 (define offset-time +)
 152
 153 \f
 154 (define %system-define define)
 155
 156 (define define
 157   (procedure->memoizing-macro
 158    (lambda (exp env)
 159      (if (= (length env) 1)
 160          `(define-public ,@(cdr exp))
 161          `(%system-define ,@(cdr exp))))))
 162
 163 (define (software-type) 'UNIX)
 164
 165 (slib:load (in-vicinity (library-vicinity) "require.scm"))
 166
 167 (define-public require require:require)
 168
 169 ;; {Extensions to the require system so that the user can add new
 170 ;;  require modules easily.}
 171
 172 (define *vicinity-table*
 173   (list
 174    (cons 'implementation (implementation-vicinity))
 175    (cons 'library (library-vicinity))))
 176
 177 (define (install-require-vicinity name vicinity)
 178   (let ((entry (assq name *vicinity-table*)))
 179     (if entry
 180         (set-cdr! entry vicinity)
 181         (set! *vicinity-table*
 182               (acons name vicinity *vicinity-table*)))))
 183
 184 (define (install-require-module name vicinity-name file-name)
 185   (let ((entry (assq name *catalog*))
 186         (vicinity (cdr (assq vicinity-name *vicinity-table*))))
 187     (let ((path-name (in-vicinity vicinity file-name)))
 188       (if entry
 189           (set-cdr! entry path-name)
 190           (set! *catalog*
 191                 (acons name path-name *catalog*))))))