module/slib/gambit.init

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