module/slib/t3.init

   1 ;;; "t3.init" Initialization file for SLIB for T3.1.    -*-scheme-*-
   2 ;;; Authors: David Carlton, Stephen Bevan, F. Javier Thayer, and Aubrey Jaffer.
   3 ;;;
   4 ;;; This code is in the public domain.
   5
   6 ;;; File has T syntax, and should be compiled in standard-env.
   7 ;;; Compiled file has .so suffix.
   8 ;;; File (or compiled version) should be loaded into scheme-env.
   9
  10 ;;; This is provided with ABSOLUTELY NO GUARANTEE.
  11 (herald t3)
  12
  13 (define (software-type) 'UNIX)
  14
  15 (define (scheme-implementation-type) 'T)
  16
  17 (define (scheme-implementation-version) "3.1")
  18
  19 ;;; (scheme-implementation-home-page) should return a (string) URI
  20 ;;; (Uniform Resource Identifier) for this scheme implementation's home
  21 ;;; page; or false if there isn't one.
  22
  23 (define (scheme-implementation-home-page)
  24   "ftp://ftp.cs.indiana.edu:21/pub/scheme-repository/imp/t/README")
  25
  26 ;;; (implementation-vicinity) should be defined to be the pathname of
  27 ;;; the directory where any auxillary files to your Scheme
  28 ;;; implementation reside. It is settable.
  29
  30 (define implementation-vicinity
  31   (make-simple-switch 'implementation-vicinity
  32                       (lambda (x) (or (string? x) (false? x)))
  33                       '#f))
  34 (set (implementation-vicinity) "/usr/local/lib/tsystem/")
  35
  36 ;;; (library-vicinity) should be defined to be the pathname of the
  37 ;;; directory where files of Scheme library functions reside. It is settable.
  38
  39 (define library-vicinity
  40   (make-simple-switch 'library-vicinity
  41                       (lambda (x) (or (string? x) (false? x)))
  42                       '#f))
  43 (set (library-vicinity) "/usr/local/lib/slib/")
  44 ;;Obviously put your value here.
  45
  46 ;;; (home-vicinity) should return the vicinity of the user's HOME
  47 ;;; directory, the directory which typically contains files which
  48 ;;; customize a computer environment for a user.
  49
  50 (define (home-vicinity) #f)
  51
  52 ;;; *FEATURES* should be set to a list of symbols describing features
  53 ;;; of this implementation.  See Template.scm for the list of feature
  54 ;;; names.
  55
  56 (define *features*
  57       '(
  58         source                          ;can load scheme source files
  59                                         ;(slib:load-source "filename")
  60         compiled                        ;can load compiled files
  61                                         ;(slib:load-compiled "filename")
  62         rev3-report
  63         rev4-optional-procedures
  64         rev3-procedures
  65         rev2-procedures
  66         multiarg/and-
  67         multiarg-apply
  68         rationalize
  69         object-hash
  70         delay
  71         i/o-redirection
  72         char-ready?
  73         with-file
  74         transcript
  75         full-continuation
  76         pretty-print
  77         format
  78         trace                           ;has macros: TRACE and UNTRACE
  79         program-arguments
  80         ))
  81
  82 (define substring
  83   (let ((primitive-substring (*value standard-env 'substring)))
  84     (lambda (string start end)
  85       (primitive-substring string start (max 0 (- end 1))))))
  86
  87 ; Modify substring as T's substring takes (start,count) instead of
  88 ; (start,end)
  89
  90 (set (syntax-table-entry (env-syntax-table scheme-env) 'require) '#f)
  91
  92 ; Turn off the macro REQUIRE so that it can be rebound as a function
  93 ; later.
  94
  95 ; extend <, >, <= and >= so that they take more than two arguments.
  96
  97 (define <
  98   (let ((primitive< (*value standard-env '<)))
  99     (labels ((v (lambda (a b . rest)
 100                   (if (null? rest)
 101                       (primitive< a b)
 102                       (and (primitive< a b)
 103                            (apply v b (car rest) (cdr rest)))))))
 104             v)))
 105
 106 (define >
 107   (let ((primitive> (*value standard-env '>)))
 108     (labels ((v (lambda (a b . rest)
 109                   (if (null? rest)
 110                       (primitive> a b)
 111                       (and (primitive> a b)
 112                            (apply v b (car rest) (cdr rest)))))))
 113             v)))
 114
 115 (define <=
 116   (let ((primitive<= (*value standard-env '<=)))
 117     (labels ((v (lambda (a b . rest)
 118                   (if (null? rest)
 119                       (primitive<= a b)
 120                       (and (primitive<= a b)
 121                            (apply v b (car rest) (cdr rest)))))))
 122             v)))
 123
 124 (define >=
 125   (let ((primitive>= (*value standard-env '>=)))
 126     (labels ((v (lambda (a b . rest)
 127                   (if (null? rest)
 128                       (primitive>= a b)
 129                       (and (primitive>= a b)
 130                            (apply v b (car rest) (cdr rest)))))))
 131             v)))
 132
 133 (define =
 134   (let ((primitive= (*value standard-env '=)))
 135     (labels ((v (lambda (a b . rest)
 136                   (if (null? rest)
 137                       (primitive= a b)
 138                       (and (primitive= a b)
 139                            (apply v b (car rest) (cdr rest)))))))
 140             v)))
 141
 142 (define gcd
 143   (let ((prim (*value standard-env 'gcd)))
 144     (labels ((v (lambda x
 145                   (cond ((null? x) 0)
 146                         ((= (length x) 1) (car x))
 147                         ('#t (prim (car x) (apply v (cdr x))))))))
 148             v)))
 149
 150 (define list? (*value standard-env 'proper-list?))
 151
 152 (define program-arguments command-line)
 153
 154 ;;; (OUTPUT-PORT-WIDTH <port>)
 155 (define output-port-width
 156   (lambda x
 157     (if (null? x) (line-length (standard-input))
 158         (line-length (car x)))))
 159
 160 ;;; (OUTPUT-PORT-HEIGHT <port>)
 161 (define (output-port-height . arg) 24)
 162
 163 ;;; (CURRENT-ERROR-PORT)
 164 (define current-error-port
 165   (let ((port (current-output-port)))
 166     (lambda () port)))
 167
 168 ;;; (TMPNAM) makes a temporary file name.
 169 (define tmpnam
 170   (let ((cntr 100))
 171     (lambda () (set! cntr (+ 1 cntr))
 172             (let ((tmp (string-append "slib_" (number->string cntr))))
 173               (if (file-exists? tmp) (tmpnam) tmp)))))
 174
 175 (define delete-file file-delete)
 176
 177 ;;; "rationalize" adjunct procedures.
 178 (define (find-ratio x e)
 179   (let ((rat (rationalize x e)))
 180     (list (numerator rat) (denominator rat))))
 181 (define (find-ratio-between x y)
 182   (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
 183
 184 ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
 185 ;;; be returned by CHAR->INTEGER.
 186 (define char-code-limit 256)
 187
 188 ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
 189 ;;; T already has it.
 190
 191 ;;; Return argument
 192 (define (identity x) x)
 193
 194 ;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
 195 (define (slib:eval form) (eval form scheme-env))
 196
 197 ;;; If your implementation provides R4RS macros:
 198 ;(define macro:eval slib:eval)
 199 ;(define macro:load load)
 200
 201 (define *defmacros*
 202   (list (cons 'defmacro
 203               (lambda (name parms . body)
 204                 `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
 205                                       *defmacros*))))))
 206 (define (defmacro? m) (and (assq m *defmacros*) #t))
 207
 208 (define (macroexpand-1 e)
 209   (if (pair? e) (let ((a (car e)))
 210                   (cond ((symbol? a) (set! a (assq a *defmacros*))
 211                                      (if a (apply (cdr a) (cdr e)) e))
 212                         (else e)))
 213       e))
 214
 215 (define (macroexpand e)
 216   (if (pair? e) (let ((a (car e)))
 217                   (cond ((symbol? a)
 218                          (set! a (assq a *defmacros*))
 219                          (if a (macroexpand (apply (cdr a) (cdr e))) e))
 220                         (else e)))
 221       e))
 222
 223 (define gentemp
 224   (let ((*gensym-counter* -1))
 225     (lambda ()
 226       (set! *gensym-counter* (+ *gensym-counter* 1))
 227       (string->symbol
 228        (string-append "slib:G" (number->string *gensym-counter*))))))
 229
 230 (define base:eval slib:eval)
 231 (define (defmacro:eval x) (base:eval (defmacro:expand* x)))
 232 (define (defmacro:expand* x)
 233   (require 'defmacroexpand) (apply defmacro:expand* x '()))
 234
 235 (define (defmacro:load <pathname>)
 236   (slib:eval-load <pathname> defmacro:eval))
 237
 238 (define (slib:eval-load <pathname> evl)
 239   (if (not (file-exists? <pathname>))
 240       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
 241   (call-with-input-file <pathname>
 242     (lambda (port)
 243       (let ((old-load-pathname *load-pathname*))
 244         (set! *load-pathname* <pathname>)
 245         (do ((o (read port) (read port)))
 246             ((eof-object? o))
 247           (evl o))
 248         (set! *load-pathname* old-load-pathname)))))
 249
 250 (define slib:warn
 251   (lambda args
 252     (let ((cep (current-error-port)))
 253       (if (provided? 'trace) (print-call-stack cep))
 254       (display "Warn: " cep)
 255       (for-each (lambda (x) (display x cep)) args))))
 256
 257 ;;; define an error procedure for the library
 258 (define (slib:error . args)
 259   (if (provided? 'trace) (print-call-stack (current-error-port)))
 260   (apply error args))
 261
 262 ;;; define these as appropriate for your system.
 263 (define slib:tab #\tab)
 264 (define slib:form-feed #\form)
 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+ n) (+ n -1))
 272
 273 (define program-vicinity
 274   (make-simple-switch 'program-vicinity
 275                       (lambda (x) (or (string? x) (false? x)))
 276                       '#f))
 277
 278 (define in-vicinity string-append)
 279
 280 ;;; Define SLIB:EXIT to be the implementation procedure to exit or
 281 ;;; return if exitting not supported.
 282 (define slib:exit (lambda args (exit))
 283
 284 (define (string . args) (apply string-append (map char->string args)))
 285
 286 (define make-string
 287   (let ((t:make-string (*value standard-env 'make-string)))
 288     (lambda (a . b)
 289       (let ((str (t:make-string a)))
 290         (if b (map-string! (lambda (x) (ignore x) (car b)) str) str)))))
 291
 292 (define (string>? a b)
 293   (labels ((aux
 294             (lambda (n a b)
 295               ;;start off with n<=(string-length b) and n<=(string-length a)
 296               ;;a,b coincide for chars <n
 297               (cond ((= (string-length a) n) (< n (string-length b)))
 298                                         ;;now (< n (string-length a))
 299                     ((= (string-length b) n) '#f)
 300                                         ;;now (< n (string-length a))
 301                     ((char=? (nthchar a n) (nthchar b n) ) (aux (+ 1 n) a b))
 302                     ('#t (char<? (nthchar b n) (nthchar a n)))))))
 303     (aux 0 a b)))
 304
 305 (define (string<? a b) (string>? b a))
 306 (define (string<=? a b) (not (string>? a b)))
 307 (define (string>=? a b) (not (string<? a b)))
 308
 309 (define (string-ci<? a b)
 310   (string<? (string-upcase a) (string-upcase b)))
 311
 312 (define (string-ci>? a b)
 313   (string>? (string-upcase a) (string-upcase b)))
 314
 315 (define (string-ci<=? a b)
 316   (string<=? (string-upcase a) (string-upcase b)))
 317
 318 (define (string-ci>=? a b)
 319   (string>=? (string-upcase a) (string-upcase b)))
 320
 321 ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
 322 ;;; use this definition if your system doesn't have such a procedure.
 323 ;;; T already has it, but requires 1 argument.
 324
 325 (define force-output
 326   (let ((t:force-output (*value standard-env 'force-output)))
 327     (lambda x
 328       (if x
 329           (t:force-output (car x))
 330           (t:force-output (current-output-port))))))
 331
 332 ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
 333 ;;; port versions of CALL-WITH-*PUT-FILE.
 334 (define (call-with-output-string proc)
 335   (with-output-to-string var (proc var)))
 336
 337 (define (call-with-input-string string proc)
 338   (with-input-from-string (variable string) (proc variable)))
 339
 340 (define (string->number s . x)
 341   (let ((base (if x (car x) 10))
 342         (s (string-upcase s)))
 343     (or (mem? = base '(8 10 16))
 344         (error (format (current-error-port) "Bad radix ~A" base)))
 345     (if (= (string-length s) 0) '()
 346         (let ((char->number
 347                (lambda (ch)
 348                  (cdr (ass char=? ch
 349                            '((#\0 . 0)
 350                              (#\1 . 1) (#\2 . 2) (#\3 . 3) (#\4 . 4)
 351                              (#\5 . 5) (#\6 . 6) (#\7 . 7) (#\8 . 8)
 352                              (#\9 . 9) (#\A . 10) (#\B . 11) (#\C . 12)
 353                              (#\D . 13) (#\E . 14) (#\F . 15)))))))
 354           (catch not-num
 355                  (iterate loop ((pos (- (string-length s) 1))
 356                                 (power 1) (accum 0))
 357                           (if (< pos 0) accum
 358                               (let ((num (char->number (string-ref s pos))))
 359                                 (or num (not-num '()))
 360                                 (or  (< num base) (not-num '()))
 361                                 (loop (- pos 1)
 362                                       (* power base)
 363                                       (+ accum (*  num power)))))))))))
 364
 365 (define (number->string n . x)
 366   (let ((rad (if (car x) (car x) 10)))
 367     (format nil
 368             (case rad
 369               ((8) "~O")
 370               ((10) "~D")
 371               ((16) "~X")
 372               (else (error (format (current-error-port)
 373                                    "Bad radix ~A" (car x)))))
 374             n)))
 375
 376 (define (inexact? f)
 377   (float? f))
 378
 379 (define (exact? f)
 380   (not (inexact? f)))
 381
 382 (define exact->inexact ->float)
 383
 384 (define peek-char
 385   (let ((t:peek-char (*value standard-env 'peek-char)))
 386     (lambda p
 387       (let ((port (if p (car p) (current-input-port))))
 388         (t:peek-char port)))))
 389
 390 ;;;(set ((*value scheme-env 'standard-early-binding-env) 'load) '#f)
 391 ;;;(set ((*value scheme-env 'standard-early-binding-env) 'substring) '#f)
 392 (set ((*value scheme-env 'standard-early-binding-env) 'less?) '#f)
 393 (set ((*value scheme-env 'standard-early-binding-env) 'greater?) '#f)
 394 (set ((*value scheme-env 'standard-early-binding-env) 'not-less?) '#f)
 395 (set ((*value scheme-env 'standard-early-binding-env) 'not-greater?) '#f)
 396 (set ((*value scheme-env 'standard-early-binding-env) 'number-equal?) '#f)
 397 (set ((*value scheme-internal-env 'standard-early-binding-env) 'list?) '#f)
 398
 399 (set ((*value t-implementation-env 'SOURCE-FILE-EXTENSION)) 'scm)
 400
 401 ;;; Here for backward compatability
 402 (define (scheme-file-suffix) "")
 403
 404 (define load
 405   (let ((t:load (*value standard-env 'load)))
 406     (lambda (filespec . x)
 407       (apply t:load (->filename filespec) x))))
 408
 409 ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
 410 ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
 411
 412 (define slib:load-source load)
 413
 414 ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
 415 ;;; by compiling "foo.scm" if this implementation can compile files.
 416 ;;; See feature 'COMPILED.
 417
 418 (define slib:load-compiled load)
 419
 420 ;;; At this point SLIB:LOAD must be able to load SLIB files.
 421
 422 (define slib:load slib:load-source)
 423
 424 (slib:load (in-vicinity (library-vicinity) "require") scheme-env)
 425
 426 ;;;(define scheme-read-table
 427 ;;;  (make-read-table standard-read-table 'modified-read-table))
 428 ;;;
 429 ;;;(set (read-table-entry scheme-read-table '#\#)
 430 ;;;     (lambda  (p ch rtable)
 431 ;;;       (ignore ch) (ignore rtable)
 432 ;;;       ((*value scheme-env 'string->number)
 433 ;;;     (symbol->string (read-refusing-eof p)) 16)))
 434 ;;;
 435 ;;;(set (port-read-table (standard-input)) scheme-read-table)
 436
 437 ; eof