module/slib/scsh.init

   1 ;;; "scsh.init" Initialisation for SLIB for Scsh 0.5.1  -*-scheme-*-
   2 ;;; Author: Aubrey Jaffer
   3 ;;;
   4 ;;; This code is in the public domain.
   5
   6 ;;; (software-type) should be set to the generic operating system type.
   7 ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
   8
   9 (define (software-type) 'UNIX)
  10
  11 ;;; (scheme-implementation-type) should return the name of the scheme
  12 ;;; implementation loading this file.
  13
  14 (define (scheme-implementation-type) 'Scsh)
  15
  16 ;;; (scheme-implementation-home-page) should return a (string) URI
  17 ;;; (Uniform Resource Identifier) for this scheme implementation's home
  18 ;;; page; or false if there isn't one.
  19
  20 (define (scheme-implementation-home-page)
  21   "http://swissnet.ai.mit.edu/ftpdir/scsh/")
  22
  23 ;;; (scheme-implementation-version) should return a string describing
  24 ;;; the version the scheme implementation loading this file.
  25
  26 (define (scheme-implementation-version) "0.5.1")
  27
  28 ;;; (implementation-vicinity) should be defined to be the pathname of
  29 ;;; the directory where any auxillary files to your Scheme
  30 ;;; implementation reside.
  31
  32 (define (implementation-vicinity)
  33   "/home/tomas/src/scsh-0.5.1/")
  34
  35 ;;; (library-vicinity) should be defined to be the pathname of the
  36 ;;; directory where files of Scheme library functions reside.
  37
  38 (define (library-vicinity)
  39   "/home/tomas/src/slib2b1/")
  40
  41 ;;; (home-vicinity) should return the vicinity of the user's HOME
  42 ;;; directory, the directory which typically contains files which
  43 ;;; customize a computer environment for a user.
  44
  45 (define home-vicinity
  46   (let ((home-path (getenv "HOME")))
  47     (lambda () home-path)))
  48
  49 ;;; *FEATURES* should be set to a list of symbols describing features
  50 ;;; of this implementation.  Suggestions for features are:
  51
  52 (define *features*
  53       '(
  54         source                          ;can load scheme source files
  55                                         ;(slib:load-source "filename")
  56 ;       compiled                        ;can load compiled files
  57                                         ;(slib:load-compiled "filename")
  58         rev4-report                     ;conforms to
  59 ;       rev3-report                     ;conforms to
  60         ieee-p1178                      ;conforms to
  61 ;       sicp                            ;runs code from Structure and
  62                                         ;Interpretation of Computer
  63                                         ;Programs by Abelson and Sussman.
  64         rev4-optional-procedures        ;LIST-TAIL, STRING->LIST,
  65                                         ;LIST->STRING, STRING-COPY,
  66                                         ;STRING-FILL!, LIST->VECTOR,
  67                                         ;VECTOR->LIST, and VECTOR-FILL!
  68 ;       rev2-procedures                 ;SUBSTRING-MOVE-LEFT!,
  69                                         ;SUBSTRING-MOVE-RIGHT!,
  70                                         ;SUBSTRING-FILL!,
  71                                         ;STRING-NULL?, APPEND!, 1+,
  72                                         ;-1+, <?, <=?, =?, >?, >=?
  73         multiarg/and-                   ;/ and - can take more than 2 args.
  74         multiarg-apply                  ;APPLY can take more than 2 args.
  75         rationalize
  76         delay                           ;has DELAY and FORCE
  77         with-file                       ;has WITH-INPUT-FROM-FILE and
  78                                         ;WITH-OUTPUT-FROM-FILE
  79 ;       string-port                     ;has CALL-WITH-INPUT-STRING and
  80                                         ;CALL-WITH-OUTPUT-STRING
  81 ;       transcript                      ;TRANSCRIPT-ON and TRANSCRIPT-OFF
  82         char-ready?
  83         macro                           ;has R4RS high level macros
  84 ;       defmacro                        ;has Common Lisp DEFMACRO
  85         eval                            ;proposed 2-arugment eval
  86 ;       record                          ;has user defined data structures
  87         values                          ;proposed multiple values
  88         dynamic-wind                    ;proposed dynamic-wind
  89 ;       ieee-floating-point             ;conforms to
  90         full-continuation               ;can return multiple times
  91 ;       object-hash                     ;has OBJECT-HASH
  92
  93 ;       sort
  94 ;       queue                           ;queues
  95 ;       pretty-print
  96 ;       object->string
  97         format
  98 ;       trace                           ;has macros: TRACE and UNTRACE
  99 ;       compiler                        ;has (COMPILER)
 100 ;       ed                              ;(ED) is editor
 101 ;       system                          ;posix (system <string>)
 102         getenv                          ;posix (getenv <string>)
 103 ;       program-arguments               ;returns list of strings (argv)
 104 ;       Xwindows                        ;X support
 105 ;       curses                          ;screen management package
 106 ;       termcap                         ;terminal description package
 107 ;       terminfo                        ;sysV terminal description
 108 ;       current-time                    ;returns time in seconds since 1/1/1970
 109         ))
 110
 111 ;;; (OUTPUT-PORT-WIDTH <port>)
 112 (define (output-port-width . arg) 79)
 113
 114 ;;; (OUTPUT-PORT-HEIGHT <port>)
 115 (define (output-port-height . arg) 24)
 116
 117 ;;; (CURRENT-ERROR-PORT)
 118 (define current-error-port error-output-port)
 119
 120 ;;; (TMPNAM) makes a temporary file name.
 121 (define (tmpnam)
 122   (create-temp-file "slib_"))
 123
 124 ;;; (FILE-EXISTS? <string>)
 125 ;(define (file-exists? f) #f)
 126
 127 ;;; (DELETE-FILE <string>)
 128 ;(define (delete-file f) #f)
 129
 130 ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
 131 ;;; use this definition if your system doesn't have such a procedure.
 132 ;(define (force-output . arg) #t)
 133
 134 ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
 135 ;;; port versions of CALL-WITH-*PUT-FILE.
 136
 137 ;;; "rationalize" adjunct procedures.
 138 (define (find-ratio x e)
 139   (let ((rat (rationalize x e)))
 140     (list (numerator rat) (denominator rat))))
 141 (define (find-ratio-between x y)
 142   (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
 143
 144 ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
 145 ;;; be returned by CHAR->INTEGER.
 146 (define char-code-limit 256)
 147
 148 ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
 149 (define most-positive-fixnum #x0FFFFFFF)
 150
 151 ;;; Return argument
 152 (define (identity x) x)
 153
 154 ;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
 155
 156 ; [s48 has two argument eval]
 157 (define (slib:eval form)
 158   (eval form (interaction-environment)))
 159
 160 ;;; If your implementation provides R4RS macros:
 161 (define macro:eval slib:eval)
 162 (define macro:load load)
 163
 164 (define *defmacros*
 165   (list (cons 'defmacro
 166               (lambda (name parms . body)
 167                 `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
 168                                       *defmacros*))))))
 169
 170 (define (defmacro? m) (and (assq m *defmacros*) #t))
 171
 172 (define (macroexpand-1 e)
 173   (if (pair? e) (let ((a (car e)))
 174                   (cond ((symbol? a) (set! a (assq a *defmacros*))
 175                                      (if a (apply (cdr a) (cdr e)) e))
 176                         (else e)))
 177       e))
 178
 179 (define (macroexpand e)
 180   (if (pair? e) (let ((a (car e)))
 181                   (cond ((symbol? a)
 182                          (set! a (assq a *defmacros*))
 183                          (if a (macroexpand (apply (cdr a) (cdr e))) e))
 184                         (else e)))
 185       e))
 186
 187 (define gentemp
 188   (let ((*gensym-counter* -1))
 189     (lambda ()
 190       (set! *gensym-counter* (+ *gensym-counter* 1))
 191       (string->symbol
 192        (string-append "slib:G" (number->string *gensym-counter*))))))
 193
 194 (define base:eval slib:eval)
 195 (define (defmacro:eval x) (base:eval (defmacro:expand* x)))
 196 (define (defmacro:expand* x)
 197   (require 'defmacroexpand) (apply defmacro:expand* x '()))
 198
 199 (define (defmacro:load pathname)
 200   (slib:eval-load pathname defmacro:eval))
 201
 202 (define (slib:eval-load pathname evl)
 203   (if (not (file-exists? pathname))
 204       (set! pathname (string-append pathname (scheme-file-suffix))))
 205   (call-with-input-file pathname
 206     (lambda (port)
 207       (let ((old-load-pathname *load-pathname*))
 208         (set! *load-pathname* pathname)
 209         (do ((o (read port) (read port)))
 210             ((eof-object? o))
 211           (evl o))
 212         (set! *load-pathname* old-load-pathname)))))
 213
 214 (define slib:warn
 215   (lambda args
 216     (let ((cep (current-error-port)))
 217       (if (provided? 'trace) (print-call-stack cep))
 218       (display "Warn: " cep)
 219       (for-each (lambda (x) (display x cep)) args))))
 220
 221 ;;; define an error procedure for the library
 222 (define (slib:error . args)
 223   (if (provided? 'trace) (print-call-stack (current-error-port)))
 224   (apply error args))
 225
 226 ;;; define these as appropriate for your system.
 227 (define slib:tab (ascii->char 9))
 228 (define slib:form-feed (ascii->char 12))
 229
 230 ;;; Support for older versions of Scheme.  Not enough code for its own file.
 231 (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
 232 (define t #t)
 233 (define nil #f)
 234
 235 (define append! append)
 236
 237 ;;; Define these if your implementation's syntax can support it and if
 238 ;;; they are not already defined.
 239
 240 (define (1+ n) (+ n 1))
 241 (define (-1+ n) (+ n -1))
 242 (define 1- -1+)
 243
 244 (define in-vicinity string-append)
 245
 246 ;;; Define SLIB:EXIT to be the implementation procedure to exit or
 247 ;;; return if exitting not supported.
 248 (define slib:exit (lambda args #f))
 249
 250 ;;; Here for backward compatability
 251 (define scheme-file-suffix
 252   (let ((suffix (case (software-type)
 253                   ((NOSVE) "_scm")
 254                   (else ".scm"))))
 255     (lambda () suffix)))
 256
 257 ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
 258 ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
 259
 260 (define (slib:load-source f) (load (string-append f ".scm")))
 261
 262 ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
 263 ;;; by compiling "foo.scm" if this implementation can compile files.
 264 ;;; See feature 'COMPILED.
 265
 266 (define slib:load-compiled load)
 267
 268 ;;; At this point SLIB:LOAD must be able to load SLIB files.
 269
 270 (define slib:load slib:load-source)
 271
 272 ;;; Scheme48 complains that these are not defined (even though they
 273 ;;; won't be called until they are).
 274 (define synclo:load #f)
 275 (define syncase:load #f)
 276 (define macwork:load #f)
 277 (define transcript-on #f)
 278 (define transcript-off #f)
 279
 280 (define array? #f)
 281 (define record? #f)
 282 (define sort! #f)
 283
 284 (slib:load (in-vicinity (library-vicinity) "require"))