ice-9/slib.scm

   1 ;;;; slib.scm --- definitions needed to get SLIB to work with Guile
   2 ;;;;
   3 ;;;;    Copyright (C) 1997, 1998, 2000 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 x slib-module)))
  45 (define defmacro:eval (lambda (x) (eval x (interaction-environment))))
  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         (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-public (library-vicinity)
 171   (string-append (implementation-vicinity) "slib/"))
 172 (define-public home-vicinity
 173   (let ((home-path (getenv "HOME")))
 174     (lambda () home-path)))
 175 (define-public (scheme-implementation-type) 'guile)
 176 (define-public (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)
 216   "Return a symbol describing the current platform's operating system.
 217 This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2,
 218 THINKC, AMIGA, ATARIST, MACH, or ACORN.
 219
 220 Note that most varieties of Unix are considered to be simply \"UNIX\".
 221 That is because when a program depends on features that are not present
 222 on every operating system, it is usually better to test for the presence
 223 or absence of that specific feature.  The return value of
 224 @code{software-type} should only be used for this purpose when there is
 225 no other easy or unambiguous way of detecting such features."
 226  'UNIX)
 227
 228 (slib:load (in-vicinity (library-vicinity) "require.scm"))
 229
 230 (define-public require require:require)
 231
 232 ;; {Extensions to the require system so that the user can add new
 233 ;;  require modules easily.}
 234
 235 (define *vicinity-table*
 236   (list
 237    (cons 'implementation (implementation-vicinity))
 238    (cons 'library (library-vicinity))))
 239
 240 (define (install-require-vicinity name vicinity)
 241   (let ((entry (assq name *vicinity-table*)))
 242     (if entry
 243         (set-cdr! entry vicinity)
 244         (set! *vicinity-table*
 245               (acons name vicinity *vicinity-table*)))))
 246
 247 (define (install-require-module name vicinity-name file-name)
 248   (if (not *catalog*)        ;Fix which loads catalog in slib
 249       (catalog:get 'random)) ;(doesn't load the feature 'random)
 250   (let ((entry (assq name *catalog*))
 251         (vicinity (cdr (assq vicinity-name *vicinity-table*))))
 252     (let ((path-name (in-vicinity vicinity file-name)))
 253       (if entry
 254           (set-cdr! entry path-name)
 255           (set! *catalog*
 256                 (acons name path-name *catalog*))))))