ice-9/slib.scm

   1 ;;;; slib.scm --- definitions needed to get SLIB to work with Guile
   2 ;;;;
   3 ;;;;    Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 2.1 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 ;;;;
  19 (define-module (ice-9 slib)
  20   :export (slib:load slib:load-source defmacro:load
  21            implementation-vicinity library-vicinity home-vicinity
  22            scheme-implementation-type scheme-implementation-version
  23            output-port-width output-port-height array-indexes
  24            make-random-state
  25            -1+ <? <=? =? >? >=?
  26            require slib:error slib:exit slib:warn slib:eval
  27            defmacro:eval logical:logand logical:logior logical:logxor
  28            logical:lognot logical:ash logical:logcount logical:integer-length
  29            logical:bit-extract logical:integer-expt logical:ipow-by-squaring
  30            slib:eval-load slib:tab slib:form-feed difftime offset-time
  31            software-type)
  32   :replace (delete-file open-file provide provided? system)
  33   :no-backtrace)
  34
  35 \f
  36
  37 (define (eval-load <filename> evl)
  38   (if (not (file-exists? <filename>))
  39       (set! <filename> (string-append <filename> (scheme-file-suffix))))
  40   (call-with-input-file <filename>
  41     (lambda (port)
  42       (let ((old-load-pathname *load-pathname*))
  43         (set! *load-pathname* <filename>)
  44         (do ((o (read port) (read port)))
  45             ((eof-object? o))
  46           (evl o))
  47         (set! *load-pathname* old-load-pathname)))))
  48
  49 \f
  50
  51 (define slib:exit quit)
  52 (define slib:error error)
  53 (define slib:warn warn)
  54 (define slib:eval (lambda (x) (eval x slib-module)))
  55 (define defmacro:eval (lambda (x) (eval x (interaction-environment))))
  56 (define logical:logand logand)
  57 (define logical:logior logior)
  58 (define logical:logxor logxor)
  59 (define logical:lognot lognot)
  60 (define logical:ash ash)
  61 (define logical:logcount logcount)
  62 (define logical:integer-length integer-length)
  63 (define logical:bit-extract bit-extract)
  64 (define logical:integer-expt integer-expt)
  65 (define slib:eval-load eval-load)
  66 (define slib:tab #\tab)
  67 (define slib:form-feed #\page)
  68
  69 (define slib-module (current-module))
  70
  71 (define (defined? symbol)
  72   (module-defined? slib-module symbol))
  73
  74 ;;; *FEATURES* should be set to a list of symbols describing features
  75 ;;; of this implementation.  Suggestions for features are:
  76 (set! *features*
  77   (append
  78       '(
  79         source                          ;can load scheme source files
  80                                         ;(slib:load-source "filename")
  81 ;       compiled                        ;can load compiled files
  82                                         ;(slib:load-compiled "filename")
  83
  84                        ;; Scheme report features
  85
  86 ;       rev5-report                     ;conforms to
  87         eval                            ;R5RS two-argument eval
  88 ;       values                          ;R5RS multiple values
  89         dynamic-wind                    ;R5RS dynamic-wind
  90 ;       macro                           ;R5RS high level macros
  91         delay                           ;has DELAY and FORCE
  92         multiarg-apply                  ;APPLY can take more than 2 args.
  93 ;       rationalize
  94         rev4-optional-procedures        ;LIST-TAIL, STRING->LIST,
  95                                         ;LIST->STRING, STRING-COPY,
  96                                         ;STRING-FILL!, LIST->VECTOR,
  97                                         ;VECTOR->LIST, and VECTOR-FILL!
  98
  99 ;       rev4-report                     ;conforms to
 100
 101 ;       ieee-p1178                      ;conforms to
 102
 103 ;       rev3-report                     ;conforms to
 104
 105         rev2-procedures                 ;SUBSTRING-MOVE-LEFT!,
 106                                         ;SUBSTRING-MOVE-RIGHT!,
 107                                         ;SUBSTRING-FILL!,
 108                                         ;STRING-NULL?, APPEND!, 1+,
 109                                         ;-1+, <?, <=?, =?, >?, >=?
 110 ;       object-hash                     ;has OBJECT-HASH
 111
 112         multiarg/and-                   ;/ and - can take more than 2 args.
 113         with-file                       ;has WITH-INPUT-FROM-FILE and
 114                                         ;WITH-OUTPUT-FROM-FILE
 115 ;       transcript                      ;TRANSCRIPT-ON and TRANSCRIPT-OFF
 116 ;       ieee-floating-point             ;conforms to IEEE Standard 754-1985
 117                                         ;IEEE Standard for Binary
 118                                         ;Floating-Point Arithmetic.
 119         full-continuation               ;can return multiple times
 120
 121                         ;; Other common features
 122
 123 ;       srfi                            ;srfi-0, COND-EXPAND finds all srfi-*
 124 ;       sicp                            ;runs code from Structure and
 125                                         ;Interpretation of Computer
 126                                         ;Programs by Abelson and Sussman.
 127         defmacro                        ;has Common Lisp DEFMACRO
 128 ;       record                          ;has user defined data structures
 129         string-port                     ;has CALL-WITH-INPUT-STRING and
 130                                         ;CALL-WITH-OUTPUT-STRING
 131 ;       sort
 132 ;       pretty-print
 133 ;       object->string
 134 ;       format                          ;Common-lisp output formatting
 135 ;       trace                           ;has macros: TRACE and UNTRACE
 136 ;       compiler                        ;has (COMPILER)
 137 ;       ed                              ;(ED) is editor
 138
 139         ;; core definitions compatible, plus `make-random-state' below
 140         random
 141         )
 142
 143         (if (defined? 'getenv)
 144             '(getenv)
 145             '())
 146
 147         (if (defined? 'current-time)
 148             '(current-time)
 149             '())
 150
 151         (if (defined? 'system)
 152             '(system)
 153             '())
 154
 155         (if (defined? 'char-ready?)
 156             '(char-ready?)
 157             '())
 158
 159         *features*))
 160
 161 ;; The array module specified by slib 3a1 is not the same as what guile
 162 ;; provides, so we must remove `array' from the features list.
 163 ;;
 164 ;; The main difference is `create-array' which is similar to
 165 ;; `make-uniform-array', but the `Ac64' etc prototype procedures incorporate
 166 ;; an initial fill element into the prototype.
 167 ;;
 168 ;; Believe the array-for-each module will need to be taken from slib when
 169 ;; the array module is taken from there, since what the array module creates
 170 ;; won't be understood by the guile functions.  So remove `array-for-each'
 171 ;; from the features list too.
 172 ;;
 173 ;; Also, slib 3a1 array-for-each specifies an `array-map' which is not in
 174 ;; guile (but could be implemented quite easily).
 175 ;;
 176 ;; ENHANCE-ME: It'd be nice to implement what's necessary, since the guile
 177 ;; functions should be more efficient than the implementation in slib.
 178 ;;
 179 ;; FIXME: Since the *features* variable is shared by slib and the guile
 180 ;; core, removing these feature symbols has the unhappy effect of making it
 181 ;; look like they aren't in the core either.  Let's assume that arrays have
 182 ;; been present unconditionally long enough that no guile-specific code will
 183 ;; bother to test.  An alternative would be to make a new separate
 184 ;; *features* variable which the slib stuff operated on, leaving the core
 185 ;; mechanism alone.  That might be a good thing anyway.
 186 ;;
 187 (set! *features* (delq 'array          *features*))
 188 (set! *features* (delq 'array-for-each *features*))
 189
 190 ;; The random module in slib 3a1 provides a `random:chunk' which is used by
 191 ;; the random-inexact module.  Guile doesn't provide random:chunk so we must
 192 ;; remove 'random from `*features*' to use the slib code.
 193 ;;
 194 ;; ENHANCE-ME: Maybe Guile could provide a `random:chunk', the rest of the
 195 ;; random module is already the same as Guile.
 196 ;;
 197 ;; FIXME: As per the array bits above, *features* is shared by slib and the
 198 ;; guile core, so removing 'random has the unhappy effect of making it look
 199 ;; like this isn't in the core.  Let's assume random numbers have been
 200 ;; present unconditionally long enough that no guile-specific code will
 201 ;; bother to test.
 202 ;;
 203 (set! *features* (delq 'random *features*))
 204
 205
 206 ;;; FIXME: Because uers want require to search the path, this uses
 207 ;;; load-from-path, which probably isn't a hot idea.  slib
 208 ;;; doesn't expect this function to search a path, so I expect to get
 209 ;;; bug reports at some point complaining that the wrong file gets
 210 ;;; loaded when something accidentally appears in the path before
 211 ;;; slib, etc. ad nauseum.  However, the right fix seems to involve
 212 ;;; changing catalog:get in slib/require.scm, and I don't expect
 213 ;;; Aubrey will integrate such a change.  So I'm just going to punt
 214 ;;; for the time being.
 215 (define (slib:load name)
 216   (save-module-excursion
 217    (lambda ()
 218      (set-current-module slib-module)
 219      (let ((errinfo (catch 'system-error
 220                            (lambda ()
 221                              (load-from-path name)
 222                              #f)
 223                            (lambda args args))))
 224        (if (and errinfo
 225                 (catch 'system-error
 226                        (lambda ()
 227                          (load-from-path
 228                           (string-append name ".scm"))
 229                          #f)
 230                        (lambda args args)))
 231            (apply throw errinfo))))))
 232
 233 (define slib:load-source slib:load)
 234 (define defmacro:load slib:load)
 235
 236 (define slib-parent-dir
 237   (let* ((path (%search-load-path "slib/require.scm")))
 238     (if path
 239         (substring path 0 (- (string-length path) 17))
 240         (error "Could not find slib/require.scm in " %load-path))))
 241
 242 (define (implementation-vicinity)
 243   (string-append slib-parent-dir "/"))
 244 (define (library-vicinity)
 245   (string-append (implementation-vicinity) "slib/"))
 246 (define home-vicinity
 247   (let ((home-path (getenv "HOME")))
 248     (lambda () home-path)))
 249 (define (scheme-implementation-type) 'guile)
 250 (define scheme-implementation-version version)
 251 ;;; (scheme-implementation-home-page) should return a (string) URI
 252 ;;; (Uniform Resource Identifier) for this scheme implementation's home
 253 ;;; page; or false if there isn't one.
 254 (define (scheme-implementation-home-page)
 255   "http://www.gnu.org/software/guile/guile.html")
 256
 257 ;; legacy from r3rs, but slib says all implementations provide these
 258 ;; ("Legacy" section of the "Miscellany" node in the manual)
 259 (define-public t   #t)
 260 (define-public nil #f)
 261
 262 ;; ENHANCE-ME: Could call ioctl TIOCGWINSZ to get the size of a tty (see
 263 ;; "man 4 tty_ioctl" on a GNU/Linux system), on systems with that.
 264 (define (output-port-width . arg) 80)
 265 (define (output-port-height . arg) 24)
 266
 267 ;; slib 3a1 and up, straight from Template.scm
 268 (define-public (call-with-open-ports . ports)
 269   (define proc (car ports))
 270   (cond ((procedure? proc) (set! ports (cdr ports)))
 271         (else (set! ports (reverse ports))
 272               (set! proc (car ports))
 273               (set! ports (reverse (cdr ports)))))
 274   (let ((ans (apply proc ports)))
 275     (for-each close-port ports)
 276     ans))
 277
 278 ;; slib (version 3a1) requires open-file accept a symbol r, rb, w or wb for
 279 ;; MODES, so extend the guile core open-file accordingly.
 280 ;;
 281 ;; slib (version 3a1) also calls open-file with strings "rb" or "wb", not
 282 ;; sure if that's intentional, but in any case this extension continues to
 283 ;; accept strings to make that work.
 284 ;;
 285 (define-public (open-file filename modes)
 286   (if (symbol? modes)
 287       (set! modes (symbol->string modes)))
 288   ((@ (guile) open-file) filename modes))
 289
 290 ;; returning #t/#f instead of throwing an error for failure
 291 (define-public (delete-file filename)
 292   (catch 'system-error
 293     (lambda () ((@ (guile) delete-file) filename) #t)
 294     (lambda args #f)))
 295
 296 ;; Nothing special to do for this, so straight from Template.scm.  Maybe
 297 ;; "sensible-browser" for a debian system would be worth trying too (and
 298 ;; would be good on a tty).
 299 (define-public (browse-url url)
 300   (define (try cmd end) (zero? (system (string-append cmd url end))))
 301   (or (try "netscape-remote -remote 'openURL(" ")'")
 302       (try "netscape -remote 'openURL(" ")'")
 303       (try "netscape '" "'&")
 304       (try "netscape '" "'")))
 305
 306 ;;; {array-for-each}
 307 (define (array-indexes ra)
 308   (let ((ra0 (apply make-array '() (array-shape ra))))
 309     (array-index-map! ra0 list)
 310     ra0))
 311
 312 ;;; {Random numbers}
 313 ;;;
 314 (define (make-random-state . args)
 315   (let ((seed (if (null? args) *random-state* (car args))))
 316     (cond ((string? seed))
 317           ((number? seed) (set! seed (number->string seed)))
 318           (else (let ()
 319                   (require 'object->string)
 320                   (set! seed (object->limited-string seed 50)))))
 321     (seed->random-state seed)))
 322
 323 ;;; {rev2-procedures}
 324 ;;;
 325
 326 (define -1+ 1-)
 327 (define <?  <)
 328 (define <=? <=)
 329 (define =?  =)
 330 (define >?  >)
 331 (define >=? >=)
 332
 333 ;;; {system}
 334 ;;;
 335 ;; If the program run is killed by a signal, the shell normally gives an
 336 ;; exit code of 128+signum.  If the shell itself is killed by a signal then
 337 ;; we do the same 128+signum here.
 338 ;;
 339 ;; "stop-sig" shouldn't arise here, since system shouldn't be calling
 340 ;; waitpid with WUNTRACED, but allow for it anyway, just in case.
 341 ;;
 342 (if (memq 'system *features*)
 343     (define-public system
 344       (lambda (str)
 345         (let ((st ((@ (guile) system) str)))
 346           (or (status:exit-val st)
 347               (+ 128 (or (status:term-sig st)
 348                          (status:stop-sig st))))))))
 349
 350 ;;; {Time}
 351 ;;;
 352
 353 (define difftime -)
 354 (define offset-time +)
 355
 356 \f
 357 (define define
 358   (procedure->memoizing-macro
 359    (lambda (exp env)
 360      (if (= (length env) 1)
 361          `(define-public ,@(cdr exp))
 362          `(define-private ,@(cdr exp))))))
 363
 364 ;;; Hack to make syncase macros work in the slib module
 365 (if (nested-ref the-root-module '(app modules ice-9 syncase))
 366     (set-object-property! (module-local-variable (current-module) 'define)
 367                           '*sc-expander*
 368                           '(define)))
 369
 370 (define (software-type)
 371   "Return a symbol describing the current platform's operating system.
 372 This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2,
 373 THINKC, AMIGA, ATARIST, MACH, or ACORN.
 374
 375 Note that most varieties of Unix are considered to be simply \"UNIX\".
 376 That is because when a program depends on features that are not present
 377 on every operating system, it is usually better to test for the presence
 378 or absence of that specific feature.  The return value of
 379 @code{software-type} should only be used for this purpose when there is
 380 no other easy or unambiguous way of detecting such features."
 381  'UNIX)
 382
 383 (slib:load (in-vicinity (library-vicinity) "require.scm"))
 384
 385 (define require require:require)
 386
 387 ;; {Extensions to the require system so that the user can add new
 388 ;;  require modules easily.}
 389
 390 (define *vicinity-table*
 391   (list
 392    (cons 'implementation (implementation-vicinity))
 393    (cons 'library (library-vicinity))))
 394
 395 (define (install-require-vicinity name vicinity)
 396   (let ((entry (assq name *vicinity-table*)))
 397     (if entry
 398         (set-cdr! entry vicinity)
 399         (set! *vicinity-table*
 400               (acons name vicinity *vicinity-table*)))))
 401
 402 (define (install-require-module name vicinity-name file-name)
 403   (if (not *catalog*)        ;Fix which loads catalog in slib
 404       (catalog:get 'random)) ;(doesn't load the feature 'random)
 405   (let ((entry (assq name *catalog*))
 406         (vicinity (cdr (assq vicinity-name *vicinity-table*))))
 407     (let ((path-name (in-vicinity vicinity file-name)))
 408       (if entry
 409           (set-cdr! entry path-name)
 410           (set! *catalog*
 411                 (acons name path-name *catalog*))))))
 412
 413 (define (make-exchanger obj)
 414   (lambda (rep) (let ((old obj)) (set! obj rep) old)))