module/slib/elk.init

   1 ;;;"elk.init" Initialisation file for SLIB for ELK 2.1  -*- Scheme -*-
   2 ;;; Author: Aubrey Jaffer
   3 ;;;
   4 ;;; This code is in the public domain.
   5
   6 ; No guarantees are given about the correctness of any of the
   7 ; choices made below.  Only enough work was done to get the require
   8 ; mechanism to work correctly.
   9 ;
  10 ; Stephen J. Bevan <bevan@cs.man.ac.uk> 19920912 modified by Mike
  11 ; Sperber to work correctly with statically-linked Elk and slib1d.  Be
  12 ; sure to change the library vicinities according to your local
  13 ; configuration.  If you're running MS-DOS (which is possible since
  14 ; 2.1), you probably have to change this file to make everything work
  15 ; correctly.
  16
  17 ;;; (software-type) should be set to the generic operating system type.
  18 ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
  19
  20 (define (software-type) 'UNIX)
  21
  22 ;;; (scheme-implementation-type) should return the name of the scheme
  23 ;;; implementation loading this file.
  24
  25 (define (scheme-implementation-type) 'Elk)
  26
  27 ;;; (scheme-implementation-home-page) should return a (string) URI
  28 ;;; (Uniform Resource Identifier) for this scheme implementation's home
  29 ;;; page; or false if there isn't one.
  30
  31 (define (scheme-implementation-home-page)
  32   "http://www.informatik.uni-bremen.de/~net/elk/")
  33
  34 ;;; (scheme-implementation-version) should return a string describing
  35 ;;; the version the scheme implementation loading this file.
  36
  37 (define (scheme-implementation-version) "3.0")
  38
  39 ;;; (implementation-vicinity) should be defined to be the pathname of
  40 ;;; the directory where any auxillary files to your Scheme
  41 ;;; implementation reside.
  42
  43 (define (implementation-vicinity)
  44   (case (software-type)
  45     ((UNIX)      "/usr/local/lib/elk-2.1/scm/")
  46     ((VMS)      "scheme$src:")
  47     ((MS-DOS)   "C:\\scheme\\")))
  48
  49 ;;; (library-vicinity) should be defined to be the pathname of the
  50 ;;; directory where files of Scheme library functions reside.
  51
  52 (require 'unix)
  53 (define getenv unix-getenv)
  54 (define system unix-system)
  55
  56 (define library-vicinity
  57   (let ((library-path
  58          (or (getenv "SCHEME_LIBRARY_PATH")
  59              ;; Uses this path if SCHEME_LIBRARY_PATH is not defined.
  60              (case (software-type)
  61                ((UNIX) "/usr/local/lib/slib/")
  62                ((VMS) "lib$scheme:")
  63                ((MS-DOS) "C:\\SLIB\\")
  64                (else "")))))
  65     (lambda () library-path)))
  66
  67 ;;; (home-vicinity) should return the vicinity of the user's HOME
  68 ;;; directory, the directory which typically contains files which
  69 ;;; customize a computer environment for a user.
  70
  71 (define home-vicinity
  72   (let ((home-path (getenv "HOME")))
  73     (lambda () home-path)))
  74
  75 ;;; *features* should be set to a list of symbols describing features
  76 ;;; of this implementation.  Suggestions for features are:
  77
  78 (define *features*
  79       '(
  80         source                          ;can load scheme source files
  81                                         ;(slib:load-source "filename")
  82         compiled                        ;can load compiled files
  83                                         ;(slib:load-compiled "filename")
  84         rev4-report
  85         ieee-p1178
  86         sicp
  87         rev4-optional-procedures
  88         rev3-procedures
  89         rev2-procedures
  90         multiarg/and-
  91         multiarg-apply
  92         delay
  93         transcript
  94         full-continuation
  95         sort
  96         format
  97         system
  98         getenv
  99         program-arguments
 100         string-port
 101         ))
 102
 103 ;------------
 104
 105 (define program-arguments
 106   (lambda ()
 107     (cons "undefined-program-name" (command-line-args))))
 108
 109 ; EXACT? appears to always return #f which isn't very useful.
 110 ; Approximating it with INTEGER? at least means that some
 111 ; of the code in the library will work correctly
 112
 113 (define exact? integer?)  ; WARNING: redefining EXACT?
 114
 115 (define (inexact? arg)
 116   (not (exact? arg)))
 117
 118 ;;; (TMPNAM) makes a temporary file name.
 119 (define tmpnam
 120   (let ((cntr 100))
 121     (lambda () (set! cntr (+ 1 cntr))
 122             (let ((tmp (string-append "slib_" (number->string cntr))))
 123               (if (file-exists? tmp) (tmpnam) tmp)))))
 124
 125 ; Pull in GENTENV and SYSTEM
 126
 127 ;;; (FILE-EXISTS? <string>) already here.
 128
 129 ;;; (DELETE-FILE <string>)
 130 (define (delete-file f) (system (string-append "rm " f)))
 131
 132 ;------------
 133
 134 ;;; (OUTPUT-PORT-WIDTH <port>)
 135 (define (output-port-width . arg) 79)
 136
 137 ;;; (OUTPUT-PORT-HEIGHT <port>)
 138 (define (output-port-height . arg) 24)
 139
 140 ;;; (CURRENT-ERROR-PORT)
 141 ;;; is already defined in Elk 2.1
 142
 143 ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
 144 ;;; use this definition if your system doesn't have such a procedure.
 145 (define force-output flush-output-port)
 146
 147 ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
 148 ;;; port versions of CALL-WITH-*PUT-FILE.
 149 (define (call-with-output-string f)
 150   (let ((outsp (open-output-string)))
 151     (f outsp)
 152     (let ((s (get-output-string outsp)))
 153       (close-output-port outsp)
 154       s)))
 155
 156 (define (call-with-input-string s f)
 157   (let* ((insp (open-input-string s))
 158          (res (f insp)))
 159     (close-input-port insp)
 160     res))
 161
 162 ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
 163 ;;; be returned by CHAR->INTEGER.
 164 (define char-code-limit 256)
 165
 166 ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
 167 (define most-positive-fixnum 8388608)  ; 23 bit integers ?
 168
 169 ;;; Return argument
 170 (define (identity x) x)
 171
 172 ;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
 173 (define slib:eval eval)
 174
 175 (define *macros* '())
 176 (define (defmacro? m) (and (assq m *macros*) #t))
 177
 178 (define-macro (defmacro key pattern . body)
 179   `(begin
 180      (define-macro ,(cons key pattern) ,@body)
 181      (set! *macros* (cons (cons ',key (lambda ,pattern ,@body)) *macros*))))
 182
 183 (define (macroexpand-1 e)
 184   (if (pair? e) (let ((a (car e)))
 185                   (cond ((symbol? a) (set! a (assq a *macros*))
 186                                      (if a (apply (cdr a) (cdr e)) e))
 187                         (else e)))
 188       e))
 189
 190 (define (macroexpand e)
 191   (if (pair? e) (let ((a (car e)))
 192                   (cond ((symbol? a)
 193                          (set! a (assq a *macros*))
 194                          (if a (macroexpand (apply (cdr a) (cdr e))) e))
 195                         (else e)))
 196       e))
 197
 198 (define gentemp
 199   (let ((*gensym-counter* -1))
 200     (lambda ()
 201       (set! *gensym-counter* (+ *gensym-counter* 1))
 202       (string->symbol
 203        (string-append "slib:G" (number->string *gensym-counter*))))))
 204
 205 (define defmacro:eval slib:eval)
 206 (define defmacro:load load)
 207 ;;; If your implementation provides R4RS macros:
 208 ;(define macro:eval slib:eval)
 209 ;(define macro:load load)
 210
 211 (define (slib:eval-load <pathname> evl)
 212   (if (not (file-exists? <pathname>))
 213       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
 214   (call-with-input-file <pathname>
 215     (lambda (port)
 216       (let ((old-load-pathname *load-pathname*))
 217         (set! *load-pathname* <pathname>)
 218         (do ((o (read port) (read port)))
 219             ((eof-object? o))
 220           (evl o))
 221         (set! *load-pathname* old-load-pathname)))))
 222
 223 (define slib:warn
 224   (lambda args
 225     (let ((cep (current-error-port)))
 226       (if (provided? 'trace) (print-call-stack cep))
 227       (display "Warn: " cep)
 228       (for-each (lambda (x) (display x cep)) args))))
 229
 230 ;;; define an error procedure for the library
 231 (define slib:error
 232   (lambda args
 233 (define (slib:error . args)
 234   (if (provided? 'trace) (print-call-stack (current-error-port)))
 235   (apply s48-error args))
 236     (let ((port (open-output-string))
 237           (err (if (and (pair? args) (symbol? (car args)))
 238                    (car args) 'slib))
 239           (args (if (and (pair? args) (symbol? (car args)))
 240                     (cdr args) args)))
 241       (for-each (lambda (x) (display x port) (display " " port)) args)
 242       (let ((str (get-output-string port)))
 243         (close-output-port port)
 244         (error err str)))))
 245
 246 ;;; define these as appropriate for your system.
 247 (define slib:tab #\tab)
 248 (define slib:form-feed #\formfeed)
 249
 250 ;;; Define these if your implementation's syntax can support it and if
 251 ;;; they are not already defined.
 252
 253 ;(define (1+ n) (+ n 1))
 254 ;(define (-1+ n) (+ n -1))
 255 ;(define 1- -1+)
 256
 257 (define in-vicinity string-append)
 258
 259 ;;; Define SLIB:EXIT to be the implementation procedure to exit or
 260 ;;; return if exitting not supported.
 261 (define slib:exit
 262   (lambda args
 263     (exit (cond ((null? args) 0)
 264                 ((eqv? #t (car args)) 0)
 265                 ((and (number? (car args)) (integer? (car args))) (car args))
 266                 (else 1)))))
 267
 268 ;;; Here for backward compatability
 269 (define scheme-file-suffix
 270   (let ((suffix (case (software-type)
 271                   ((NOSVE) "_scm")
 272                   (else ".scm"))))
 273     (lambda () suffix)))
 274
 275 ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
 276 ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
 277
 278 ; Modify the already modified _load_ so that it copes with
 279 ; environments correctly.  The change involves using
 280 ; _(global-environment)_ if none is explicitly specified.
 281 ; If this is not done, definitions in files loaded by other files will
 282 ; not be loaded in the correct environment.
 283
 284 (define slib:load-source
 285   (let ((primitive-load load))
 286     (lambda (<pathname> . rest)
 287       (let ((env (if (null? rest) (list (global-environment)) rest)))
 288         (apply primitive-load <pathname> env)))))
 289
 290 ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
 291 ;;; by compiling "foo.scm" if this implementation can compile files.
 292 ;;; See feature 'COMPILED.
 293
 294 (define slib:load-compiled
 295   (let ((primitive-load load))
 296     (lambda (<pathname> . rest)
 297       (apply primitive-load (string->symbol (string-append name ".o")) rest))))
 298
 299 ;;; At this point SLIB:LOAD must be able to load SLIB files.
 300
 301 (define slib:load slib:load-source)     ;WARNING: redefining LOAD
 302
 303 (slib:load (in-vicinity (library-vicinity) "require"))