ice-9/slib.scm

   1 ;;;; slib.scm --- definitions needed to get SLIB to work with Guile
   2 ;;;;
   3 ;;;;    Copyright (C) 1997, 1998 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;;   This file is part of GUILE.
   6 ;;;;
   7 ;;;;   GUILE is free software; you can redistribute it and/or modify
   8 ;;;;   it under the terms of the GNU General Public License as
   9 ;;;;   published by the Free Software Foundation; either version 2, or
  10 ;;;;   (at your option) any later version.
  11 ;;;;
  12 ;;;;   GUILE is distributed in the hope that it will be useful, but
  13 ;;;;   WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;;;   GNU General Public License for more details.
  16 ;;;;
  17 ;;;;   You should have received a copy of the GNU General Public
  18 ;;;;   License along with GUILE; see the file COPYING.  If not, write
  19 ;;;;   to the Free Software Foundation, Inc., 59 Temple Place, Suite
  20 ;;;;   330, Boston, MA 02111-1307 USA
  21 ;;;;
  22 (define-module (ice-9 slib)
  23   :no-backtrace)
  24
  25 \f
  26
  27 (define (eval-load <filename> evl)
  28   (if (not (file-exists? <filename>))
  29       (set! <filename> (string-append <filename> (scheme-file-suffix))))
  30   (call-with-input-file <filename>
  31     (lambda (port)
  32       (let ((old-load-pathname *load-pathname*))
  33         (set! *load-pathname* <filename>)
  34         (do ((o (read port) (read port)))
  35             ((eof-object? o))
  36           (evl o))
  37         (set! *load-pathname* old-load-pathname)))))
  38
  39 \f
  40
  41 (define slib:exit quit)
  42 (define slib:error error)
  43 (define slib:warn warn)
  44 (define slib:eval (lambda (x) (eval-in-module x slib-module)))
  45 (define defmacro:eval eval)
  46 (define logical:logand logand)
  47 (define logical:logior logior)
  48 (define logical:logxor logxor)
  49 (define logical:lognot lognot)
  50 (define logical:ash ash)
  51 (define logical:logcount logcount)
  52 (define logical:integer-length integer-length)
  53 (define logical:bit-extract bit-extract)
  54 (define logical:integer-expt integer-expt)
  55 (define logical:ipow-by-squaring ipow-by-squaring)
  56 (define slib:eval-load eval-load)
  57 (define slib:tab #\tab)
  58 (define slib:form-feed #\page)
  59
  60 (define slib-module (current-module))
  61
  62 (define (defined? symbol)
  63   (module-defined? slib-module symbol))
  64
  65 (define slib:features
  66   (append '(source
  67             eval
  68             abort
  69             alist
  70             defmacro
  71             delay
  72             dynamic-wind
  73             full-continuation
  74             hash
  75             hash-table
  76             line-i/o
  77             logical
  78             multiarg/and-
  79             multiarg-apply
  80             promise
  81             rev2-procedures
  82             rev4-optional-procedures
  83             string-port
  84             with-file)
  85
  86           (if (defined? 'getenv)
  87               '(getenv)
  88               '())
  89
  90           (if (defined? 'current-time)
  91               '(current-time)
  92               '())
  93
  94           (if (defined? 'system)
  95               '(system)
  96               '())
  97
  98           (if (defined? 'array?)
  99               '(array)
 100               '())
 101
 102           (if (defined? 'char-ready?)
 103               '(char-ready?)
 104               '())
 105
 106           (if (defined? 'array-for-each)
 107               '(array-for-each)
 108               '())
 109
 110           (if (and (string->number "0.0") (inexact? (string->number "0.0")))
 111               '(inexact)
 112               '())
 113
 114           (if (rational? (string->number "1/19"))
 115               '(rational)
 116               '())
 117
 118           (if (real? (string->number "0.0"))
 119               '(real)
 120               ())
 121
 122           (if (complex? (string->number "1+i"))
 123               '(complex)
 124               '())
 125
 126           (let ((n (string->number "9999999999999999999999999999999")))
 127             (if (and n (exact? n))
 128                 '(bignum)
 129                 '()))))
 130
 131
 132 ;;; FIXME: Because uers want require to search the path, this uses
 133 ;;; load-from-path, which probably isn't a hot idea.  slib
 134 ;;; doesn't expect this function to search a path, so I expect to get
 135 ;;; bug reports at some point complaining that the wrong file gets
 136 ;;; loaded when something accidentally appears in the path before
 137 ;;; slib, etc. ad nauseum.  However, the right fix seems to involve
 138 ;;; changing catalog:get in slib/require.scm, and I don't expect
 139 ;;; Aubrey will integrate such a change.  So I'm just going to punt
 140 ;;; for the time being.
 141 (define-public (slib:load name)
 142   (save-module-excursion
 143    (lambda ()
 144      (set-current-module slib-module)
 145      (let ((errinfo (catch 'system-error
 146                            (lambda ()
 147                              (load-from-path name)
 148                              #f)
 149                            (lambda args args))))
 150        (if (and errinfo
 151                 (catch 'system-error
 152                        (lambda ()
 153                          (load-from-path
 154                           (string-append name ".scm"))
 155                          #f)
 156                        (lambda args args)))
 157            (apply throw errinfo))))))
 158
 159 (define slib:load-source slib:load)
 160 (define defmacro:load slib:load)
 161
 162 (define slib-parent-dir
 163   (let* ((path (%search-load-path "slib/require.scm")))
 164     (if path
 165         (make-shared-substring path 0 (- (string-length path) 17))
 166         (error "Could not find slib/require.scm in " %load-path))))
 167
 168 (define-public (implementation-vicinity)
 169   (string-append slib-parent-dir "/"))
 170 (define (library-vicinity)
 171   (string-append (implementation-vicinity) "slib/"))
 172 (define home-vicinity
 173   (let ((home-path (getenv "HOME")))
 174     (lambda () home-path)))
 175 (define (scheme-implementation-type) 'guile)
 176 (define (scheme-implementation-version) "")
 177
 178 (define (output-port-width . arg) 80)
 179 (define (output-port-height . arg) 24)
 180 (define (identity x) x)
 181
 182 ;;; {Random numbers}
 183 ;;;
 184 (define-public (make-random-state . args)
 185   (let ((seed (if (null? args) *random-state* (car args))))
 186     (cond ((string? seed))
 187           ((number? seed) (set! seed (number->string seed)))
 188           (else (let ()
 189                   (require 'object->string)
 190                   (set! seed (object->limited-string seed 50)))))
 191     (seed->random-state seed)))
 192
 193 ;;; {Time}
 194 ;;;
 195
 196 (define difftime -)
 197 (define offset-time +)
 198
 199 \f
 200 (define %system-define define)
 201
 202 (define define
 203   (procedure->memoizing-macro
 204    (lambda (exp env)
 205      (if (= (length env) 1)
 206          `(define-public ,@(cdr exp))
 207          `(%system-define ,@(cdr exp))))))
 208
 209 ;;; Hack to make syncase macros work in the slib module
 210 (if (nested-ref the-root-module '(app modules ice-9 syncase))
 211     (set-object-property! (module-local-variable (current-module) 'define)
 212                           '*sc-expander*
 213                           '(define)))
 214
 215 (define (software-type) 'UNIX)
 216
 217 (slib:load (in-vicinity (library-vicinity) "require.scm"))
 218
 219 (define-public require require:require)
 220
 221 ;; {Extensions to the require system so that the user can add new
 222 ;;  require modules easily.}
 223
 224 (define *vicinity-table*
 225   (list
 226    (cons 'implementation (implementation-vicinity))
 227    (cons 'library (library-vicinity))))
 228
 229 (define (install-require-vicinity name vicinity)
 230   (let ((entry (assq name *vicinity-table*)))
 231     (if entry
 232         (set-cdr! entry vicinity)
 233         (set! *vicinity-table*
 234               (acons name vicinity *vicinity-table*)))))
 235
 236 (define (install-require-module name vicinity-name file-name)
 237   (if (not *catalog*)        ;Fix which loads catalog in slib
 238       (catalog:get 'random)) ;(doesn't load the feature 'random)
 239   (let ((entry (assq name *catalog*))
 240         (vicinity (cdr (assq vicinity-name *vicinity-table*))))
 241     (let ((path-name (in-vicinity vicinity file-name)))
 242       (if entry
 243           (set-cdr! entry path-name)
 244           (set! *catalog*
 245                 (acons name path-name *catalog*))))))