ice-9/slib.scm

   1 ;;;; slib.scm --- definitions needed to get SLIB to work with Guile
   2 ;;;;
   3 ;;;;    Copyright (C) 1997, 1998, 2000, 2001 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 it
   8 ;;;; under the terms of the GNU General Public License as published by
   9 ;;;; the Free Software Foundation; either version 2, or (at your
  10 ;;;; 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 GNU
  15 ;;;; General Public License for more details.
  16 ;;;;
  17 ;;;; You should have received a copy of the GNU General Public License
  18 ;;;; along with GUILE; see the file COPYING.  If not, write to the
  19 ;;;; Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  20 ;;;; Boston, MA 02111-1307 USA
  21 ;;;;
  22 ;;;; As a special exception, the Free Software Foundation gives permission
  23 ;;;; for additional uses of the text contained in its release of GUILE.
  24 ;;;;
  25 ;;;; The exception is that, if you link the GUILE library with other files
  26 ;;;; to produce an executable, this does not by itself cause the
  27 ;;;; resulting executable to be covered by the GNU General Public License.
  28 ;;;; Your use of that executable is in no way restricted on account of
  29 ;;;; linking the GUILE library code into it.
  30 ;;;;
  31 ;;;; This exception does not however invalidate any other reasons why
  32 ;;;; the executable file might be covered by the GNU General Public License.
  33 ;;;;
  34 ;;;; This exception applies only to the code released by the
  35 ;;;; Free Software Foundation under the name GUILE.  If you copy
  36 ;;;; code from other Free Software Foundation releases into a copy of
  37 ;;;; GUILE, as the General Public License permits, the exception does
  38 ;;;; not apply to the code that you add in this way.  To avoid misleading
  39 ;;;; anyone as to the status of such modified files, you must delete
  40 ;;;; this exception notice from them.
  41 ;;;;
  42 ;;;; If you write modifications of your own for GUILE, it is your choice
  43 ;;;; whether to permit this exception to apply to your modifications.
  44 ;;;; If you do not wish that, delete this exception notice.
  45 ;;;;
  46 (define-module (ice-9 slib)
  47   :export (slib:load slib:load-source defmacro:load
  48            implementation-vicinity library-vicinity home-vicinity
  49            scheme-implementation-type scheme-implementation-version
  50            output-port-width output-port-height identity array-indexes
  51            make-random-state require slib:error slib:exit slib:warn slib:eval
  52            defmacro:eval logical:logand logical:logior logical:logxor
  53            logical:lognot logical:ash logical:logcount logical:integer-length
  54            logical:bit-extract logical:integer-expt logical:ipow-by-squaring
  55            slib:eval-load slib:tab slib:form-feed difftime offset-time
  56            software-type)
  57   :no-backtrace)
  58
  59 \f
  60
  61 (define (eval-load <filename> evl)
  62   (if (not (file-exists? <filename>))
  63       (set! <filename> (string-append <filename> (scheme-file-suffix))))
  64   (call-with-input-file <filename>
  65     (lambda (port)
  66       (let ((old-load-pathname *load-pathname*))
  67         (set! *load-pathname* <filename>)
  68         (do ((o (read port) (read port)))
  69             ((eof-object? o))
  70           (evl o))
  71         (set! *load-pathname* old-load-pathname)))))
  72
  73 \f
  74
  75 (define slib:exit quit)
  76 (define slib:error error)
  77 (define slib:warn warn)
  78 (define slib:eval (lambda (x) (eval x slib-module)))
  79 (define defmacro:eval (lambda (x) (eval x (interaction-environment))))
  80 (define logical:logand logand)
  81 (define logical:logior logior)
  82 (define logical:logxor logxor)
  83 (define logical:lognot lognot)
  84 (define logical:ash ash)
  85 (define logical:logcount logcount)
  86 (define logical:integer-length integer-length)
  87 (define logical:bit-extract bit-extract)
  88 (define logical:integer-expt integer-expt)
  89 (define logical:ipow-by-squaring ipow-by-squaring)
  90 (define slib:eval-load eval-load)
  91 (define slib:tab #\tab)
  92 (define slib:form-feed #\page)
  93
  94 (define slib-module (current-module))
  95
  96 (define (defined? symbol)
  97   (module-defined? slib-module symbol))
  98
  99 ;;; *FEATURES* should be set to a list of symbols describing features
 100 ;;; of this implementation.  Suggestions for features are:
 101 (define *features*
 102   (append
 103       '(
 104         source                          ;can load scheme source files
 105                                         ;(slib:load-source "filename")
 106 ;       compiled                        ;can load compiled files
 107                                         ;(slib:load-compiled "filename")
 108
 109                        ;; Scheme report features
 110
 111 ;       rev5-report                     ;conforms to
 112         eval                            ;R5RS two-argument eval
 113 ;       values                          ;R5RS multiple values
 114         dynamic-wind                    ;R5RS dynamic-wind
 115 ;       macro                           ;R5RS high level macros
 116         delay                           ;has DELAY and FORCE
 117         multiarg-apply                  ;APPLY can take more than 2 args.
 118 ;       rationalize
 119         rev4-optional-procedures        ;LIST-TAIL, STRING->LIST,
 120                                         ;LIST->STRING, STRING-COPY,
 121                                         ;STRING-FILL!, LIST->VECTOR,
 122                                         ;VECTOR->LIST, and VECTOR-FILL!
 123
 124 ;       rev4-report                     ;conforms to
 125
 126 ;       ieee-p1178                      ;conforms to
 127
 128 ;       rev3-report                     ;conforms to
 129
 130         rev2-procedures                 ;SUBSTRING-MOVE-LEFT!,
 131                                         ;SUBSTRING-MOVE-RIGHT!,
 132                                         ;SUBSTRING-FILL!,
 133                                         ;STRING-NULL?, APPEND!, 1+,
 134                                         ;-1+, <?, <=?, =?, >?, >=?
 135 ;       object-hash                     ;has OBJECT-HASH
 136
 137         multiarg/and-                   ;/ and - can take more than 2 args.
 138         with-file                       ;has WITH-INPUT-FROM-FILE and
 139                                         ;WITH-OUTPUT-FROM-FILE
 140 ;       transcript                      ;TRANSCRIPT-ON and TRANSCRIPT-OFF
 141 ;       ieee-floating-point             ;conforms to IEEE Standard 754-1985
 142                                         ;IEEE Standard for Binary
 143                                         ;Floating-Point Arithmetic.
 144         full-continuation               ;can return multiple times
 145
 146                         ;; Other common features
 147
 148 ;       srfi                            ;srfi-0, COND-EXPAND finds all srfi-*
 149 ;       sicp                            ;runs code from Structure and
 150                                         ;Interpretation of Computer
 151                                         ;Programs by Abelson and Sussman.
 152         defmacro                        ;has Common Lisp DEFMACRO
 153 ;       record                          ;has user defined data structures
 154         string-port                     ;has CALL-WITH-INPUT-STRING and
 155                                         ;CALL-WITH-OUTPUT-STRING
 156 ;       sort
 157 ;       pretty-print
 158 ;       object->string
 159 ;       format                          ;Common-lisp output formatting
 160 ;       trace                           ;has macros: TRACE and UNTRACE
 161 ;       compiler                        ;has (COMPILER)
 162 ;       ed                              ;(ED) is editor
 163         random
 164         )
 165
 166         (if (defined? 'getenv)
 167             '(getenv)
 168             '())
 169
 170         (if (defined? 'current-time)
 171             '(current-time)
 172             '())
 173
 174         (if (defined? 'system)
 175             '(system)
 176             '())
 177
 178         (if (defined? 'array?)
 179             '(array)
 180             '())
 181
 182         (if (defined? 'char-ready?)
 183             '(char-ready?)
 184             '())
 185
 186         (if (defined? 'array-for-each)
 187             '(array-for-each)
 188             '())
 189
 190         *features*))
 191
 192
 193 ;;; FIXME: Because uers want require to search the path, this uses
 194 ;;; load-from-path, which probably isn't a hot idea.  slib
 195 ;;; doesn't expect this function to search a path, so I expect to get
 196 ;;; bug reports at some point complaining that the wrong file gets
 197 ;;; loaded when something accidentally appears in the path before
 198 ;;; slib, etc. ad nauseum.  However, the right fix seems to involve
 199 ;;; changing catalog:get in slib/require.scm, and I don't expect
 200 ;;; Aubrey will integrate such a change.  So I'm just going to punt
 201 ;;; for the time being.
 202 (define (slib:load name)
 203   (save-module-excursion
 204    (lambda ()
 205      (set-current-module slib-module)
 206      (let ((errinfo (catch 'system-error
 207                            (lambda ()
 208                              (load-from-path name)
 209                              #f)
 210                            (lambda args args))))
 211        (if (and errinfo
 212                 (catch 'system-error
 213                        (lambda ()
 214                          (load-from-path
 215                           (string-append name ".scm"))
 216                          #f)
 217                        (lambda args args)))
 218            (apply throw errinfo))))))
 219
 220 (define slib:load-source slib:load)
 221 (define defmacro:load slib:load)
 222
 223 (define slib-parent-dir
 224   (let* ((path (%search-load-path "slib/require.scm")))
 225     (if path
 226         (substring path 0 (- (string-length path) 17))
 227         (error "Could not find slib/require.scm in " %load-path))))
 228
 229 (define (implementation-vicinity)
 230   (string-append slib-parent-dir "/"))
 231 (define (library-vicinity)
 232   (string-append (implementation-vicinity) "slib/"))
 233 (define home-vicinity
 234   (let ((home-path (getenv "HOME")))
 235     (lambda () home-path)))
 236 (define (scheme-implementation-type) 'guile)
 237 (define scheme-implementation-version version)
 238 ;;; (scheme-implementation-home-page) should return a (string) URI
 239 ;;; (Uniform Resource Identifier) for this scheme implementation's home
 240 ;;; page; or false if there isn't one.
 241 (define (scheme-implementation-home-page)
 242   "http://www.gnu.org/software/guile/guile.html")
 243
 244 (define (output-port-width . arg) 80)
 245 (define (output-port-height . arg) 24)
 246 (define (identity x) x)
 247
 248 ;;; {array-for-each}
 249 (define (array-indexes ra)
 250   (let ((ra0 (apply make-array '() (array-shape ra))))
 251     (array-index-map! ra0 list)
 252     ra0))
 253
 254 ;;; {Random numbers}
 255 ;;;
 256 (define (make-random-state . args)
 257   (let ((seed (if (null? args) *random-state* (car args))))
 258     (cond ((string? seed))
 259           ((number? seed) (set! seed (number->string seed)))
 260           (else (let ()
 261                   (require 'object->string)
 262                   (set! seed (object->limited-string seed 50)))))
 263     (seed->random-state seed)))
 264
 265 ;;; {Time}
 266 ;;;
 267
 268 (define difftime -)
 269 (define offset-time +)
 270
 271 \f
 272 (define %system-define define)
 273
 274 (define define
 275   (procedure->memoizing-macro
 276    (lambda (exp env)
 277      (if (= (length env) 1)
 278          `(define-public ,@(cdr exp))
 279          `(%system-define ,@(cdr exp))))))
 280
 281 ;;; Hack to make syncase macros work in the slib module
 282 (if (nested-ref the-root-module '(app modules ice-9 syncase))
 283     (set-object-property! (module-local-variable (current-module) 'define)
 284                           '*sc-expander*
 285                           '(define)))
 286
 287 (define (software-type)
 288   "Return a symbol describing the current platform's operating system.
 289 This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2,
 290 THINKC, AMIGA, ATARIST, MACH, or ACORN.
 291
 292 Note that most varieties of Unix are considered to be simply \"UNIX\".
 293 That is because when a program depends on features that are not present
 294 on every operating system, it is usually better to test for the presence
 295 or absence of that specific feature.  The return value of
 296 @code{software-type} should only be used for this purpose when there is
 297 no other easy or unambiguous way of detecting such features."
 298  'UNIX)
 299
 300 (slib:load (in-vicinity (library-vicinity) "require.scm"))
 301
 302 (define require require:require)
 303
 304 ;; {Extensions to the require system so that the user can add new
 305 ;;  require modules easily.}
 306
 307 (define *vicinity-table*
 308   (list
 309    (cons 'implementation (implementation-vicinity))
 310    (cons 'library (library-vicinity))))
 311
 312 (define (install-require-vicinity name vicinity)
 313   (let ((entry (assq name *vicinity-table*)))
 314     (if entry
 315         (set-cdr! entry vicinity)
 316         (set! *vicinity-table*
 317               (acons name vicinity *vicinity-table*)))))
 318
 319 (define (install-require-module name vicinity-name file-name)
 320   (if (not *catalog*)        ;Fix which loads catalog in slib
 321       (catalog:get 'random)) ;(doesn't load the feature 'random)
 322   (let ((entry (assq name *catalog*))
 323         (vicinity (cdr (assq vicinity-name *vicinity-table*))))
 324     (let ((path-name (in-vicinity vicinity file-name)))
 325       (if entry
 326           (set-cdr! entry path-name)
 327           (set! *catalog*
 328                 (acons name path-name *catalog*))))))