summaryrefslogtreecommitdiffstats
path: root/guile.init.local
diff options
context:
space:
mode:
Diffstat (limited to 'guile.init.local')
-rw-r--r--guile.init.local416
1 files changed, 0 insertions, 416 deletions
diff --git a/guile.init.local b/guile.init.local
deleted file mode 100644
index 551a7a2..0000000
--- a/guile.init.local
+++ /dev/null
@@ -1,416 +0,0 @@
-;"guile.init" Configuration file for SLIB for GUILE -*-scheme-*-
-;;; Author: Aubrey Jaffer
-;;;
-;;; This code is in the public domain.
-
-(if (string<? (version) "1.6")
- (define-module (ice-9 slib))) ; :no-backtrace
-(define slib-module (current-module))
-(define (defined? symbol) (module-defined? slib-module symbol))
-
-(define base:define define)
-(define define
- (procedure->memoizing-macro
- (lambda (exp env)
- (cons (if (= 1 (length env)) 'define-public 'base:define) (cdr exp)))))
-
-;;; Hack to make syncase macros work in the slib module
-(if (nested-ref the-root-module '(app modules ice-9 syncase))
- (set-object-property! (module-local-variable (current-module) 'define)
- '*sc-expander*
- '(define)))
-
-;;; (software-type) should be set to the generic operating system type.
-;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
-(define (software-type) 'unix)
-
-;;; (scheme-implementation-type) should return the name of the scheme
-;;; implementation loading this file.
-(define (scheme-implementation-type) 'guile)
-
-;;; (scheme-implementation-home-page) should return a (string) URI
-;;; (Uniform Resource Identifier) for this scheme implementation's home
-;;; page; or false if there isn't one.
-(define (scheme-implementation-home-page)
- "http://www.gnu.org/software/guile/guile.html")
-
-;;; (scheme-implementation-version) should return a string describing
-;;; the version the scheme implementation loading this file.
-(define scheme-implementation-version version)
-
-(define in-vicinity string-append)
-
-;;; (implementation-vicinity) should be defined to be the pathname of
-;;; the directory where any auxillary files to your Scheme
-;;; implementation reside.
-(define implementation-vicinity
- (let ((path '"."))
- (lambda () path)))
-
-;;; (library-vicinity) should be defined to be the pathname of the
-;;; directory where files of Scheme library functions reside.
-(define library-vicinity
- (let ((library-path
- (or
- ;; Use this getenv if your implementation supports it.
- (and (defined? 'getenv) (getenv "SCHEME_LIBRARY_PATH"))
- ;; Use this path if your scheme does not support GETENV
- ;; or if SCHEME_LIBRARY_PATH is not set.
- (in-vicinity (implementation-vicinity) "slib/"))))
- (lambda () library-path)))
-
-;;; (home-vicinity) should return the vicinity of the user's HOME
-;;; directory, the directory which typically contains files which
-;;; customize a computer environment for a user.
-(define (home-vicinity)
- (let ((home (getenv "HOME")))
- (and home
- (case (software-type)
- ((unix coherent ms-dos) ;V7 unix has a / on HOME
- (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
- home
- (string-append home "/")))
- (else home)))))
-
-;;; *FEATURES* should be set to a list of symbols describing features
-;;; of this implementation. Suggestions for features are:
-(define *features*
- (append
- '(
- source ;can load scheme source files
- ;(slib:load-source "filename")
-; compiled ;can load compiled files
- ;(slib:load-compiled "filename")
-
- ;; Scheme report features
-
-; r5rs ;conforms to
- eval ;R5RS two-argument eval
-; values ;R5RS multiple values
- dynamic-wind ;R5RS dynamic-wind
-; macro ;R5RS high level macros
- delay ;has DELAY and FORCE
- multiarg-apply ;APPLY can take more than 2 args.
-; rationalize
- rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
- ;LIST->STRING, STRING-COPY,
- ;STRING-FILL!, LIST->VECTOR,
- ;VECTOR->LIST, and VECTOR-FILL!
-
-; r4rs ;conforms to
-
-; ieee-p1178 ;conforms to
-
-; r3rs ;conforms to
-
- rev2-procedures ;SUBSTRING-MOVE-LEFT!,
- ;SUBSTRING-MOVE-RIGHT!,
- ;SUBSTRING-FILL!,
- ;STRING-NULL?, APPEND!, 1+,
- ;-1+, <?, <=?, =?, >?, >=?
-; object-hash ;has OBJECT-HASH
-
- multiarg/and- ;/ and - can take more than 2 args.
- with-file ;has WITH-INPUT-FROM-FILE and
- ;WITH-OUTPUT-TO-FILE
-; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
-; ieee-floating-point ;conforms to IEEE Standard 754-1985
- ;IEEE Standard for Binary
- ;Floating-Point Arithmetic.
- full-continuation ;can return multiple times
-
- ;; Other common features
-
-; srfi ;srfi-0, COND-EXPAND finds all srfi-*
-; sicp ;runs code from Structure and
- ;Interpretation of Computer
- ;Programs by Abelson and Sussman.
- defmacro ;has Common Lisp DEFMACRO
-; record ;has user defined data structures
- string-port ;has CALL-WITH-INPUT-STRING and
- ;CALL-WITH-OUTPUT-STRING
-; sort
-; pretty-print
-; object->string
-; format ;Common-lisp output formatting
-; trace ;has macros: TRACE and UNTRACE
-; compiler ;has (COMPILER)
-; ed ;(ED) is editor
- random
- )
-
- (if (defined? 'getenv)
- '(getenv)
- '())
-
- (if (defined? 'current-time)
- '(current-time)
- '())
-
- (if (defined? 'system)
- '(system)
- '())
-
- (if (defined? 'array?)
- '(array)
- '())
-
- (if (defined? 'char-ready?)
- '(char-ready?)
- '())
-
- (if (defined? 'array-for-each)
- '(array-for-each)
- '())
-
- *features*))
-
-;;; (OUTPUT-PORT-WIDTH <port>)
-(define (output-port-width . arg) 79)
-
-;;; (OUTPUT-PORT-HEIGHT <port>)
-(define (output-port-height . arg) 24)
-
-;;; (CURRENT-ERROR-PORT)
-;;(define current-error-port
-;; (let ((port (current-output-port)))
-;; (lambda () port)))
-
-;;; (TMPNAM) makes a temporary file name.
-;;(define tmpnam (let ((cntr 100))
-;; (lambda () (set! cntr (+ 1 cntr))
-;; (string-append "slib_" (number->string cntr)))))
-
-;;; (FILE-EXISTS? <string>)
-;;(define (file-exists? f) #f)
-
-;;; (DELETE-FILE <string>)
-;;(define (delete-file f) #f)
-
-;;; FORCE-OUTPUT flushes any pending output on optional arg output port
-;;; use this definition if your system doesn't have such a procedure.
-;;(define (force-output . arg) #t)
-
-;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
-;;; port versions of CALL-WITH-*PUT-FILE.
-
-(define (make-exchanger obj)
- (lambda (rep) (let ((old obj)) (set! obj rep) old)))
-
-(define (port? obj) (or (input-port? obj) (output-port? obj)))
-(define (call-with-open-ports . ports)
- (define proc (car ports))
- (cond ((procedure? proc) (set! ports (cdr ports)))
- (else (set! ports (reverse ports))
- (set! proc (car ports))
- (set! ports (reverse (cdr ports)))))
- (let ((ans (apply proc ports)))
- (for-each close-port ports)
- ans))
-
-;;; "rationalize" adjunct procedures.
-;;(define (find-ratio x e)
-;; (let ((rat (rationalize x e)))
-;; (list (numerator rat) (denominator rat))))
-;;(define (find-ratio-between x y)
-;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
-
-;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
-;;; be returned by CHAR->INTEGER.
-;;(define char-code-limit 256)
-
-;;; MOST-POSITIVE-FIXNUM is used in modular.scm
-;;(define most-positive-fixnum #x0FFFFFFF)
-
-;;; Return argument
-(define (identity x) x)
-
-;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
-(define slib:eval
- (if (string<? (scheme-implementation-version) "1.5")
- eval
- (let ((ie (interaction-environment)))
- (lambda (expression)
- (eval expression ie)))))
-
-;;; Define SLIB:EXIT to be the implementation procedure to exit or
-;;; return if exitting not supported.
-(define slib:exit quit)
-
-;;; Here for backward compatability
-;;(define scheme-file-suffix
-;; (let ((suffix (case (software-type)
-;; ((NOSVE) "_scm")
-;; (else ".scm"))))
-;; (lambda () suffix)))
-
-(define (slib:eval-load <pathname> evl)
- (if (not (file-exists? <pathname>))
- (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
- (call-with-input-file <pathname>
- (lambda (port)
- (let ((old-load-pathname *load-pathname*))
- (set! *load-pathname* <pathname>)
- (do ((o (read port) (read port)))
- ((eof-object? o))
- (evl o))
- (set! *load-pathname* old-load-pathname)))))
-
-(define (guile:wrap-case-insensitive proc)
- (lambda args
- (save-module-excursion
- (lambda ()
- (set-current-module slib-module)
- (let ((old (read-options)))
- (dynamic-wind
- (lambda () (read-enable 'case-insensitive))
- (lambda () (apply proc args))
- (lambda () (read-options old))))))))
-
-(define read (guile:wrap-case-insensitive read))
-
-;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
-;;; suffix all the module files in SLIB have. See feature 'SOURCE.
-(define slib:load
- (let ((load-file (guile:wrap-case-insensitive load)))
- (lambda (<pathname>)
- (load-file (string-append <pathname> (scheme-file-suffix))))))
-
-(define slib:load-source slib:load)
-
-;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
-;;; by compiling "foo.scm" if this implementation can compile files.
-;;; See feature 'COMPILED.
-(define slib:load-compiled slib:load)
-
-(define defmacro:eval slib:eval)
-(define defmacro:load slib:load)
-
-(define (defmacro:expand* x)
- (require 'defmacroexpand) (apply defmacro:expand* x '()))
-
-;;; If your implementation provides R4RS macros:
-(define macro:eval slib:eval)
-(define macro:load slib:load)
-
-(define slib:warn warn)
-(define slib:error error)
-
-;;; define these as appropriate for your system.
-(define slib:tab #\tab)
-(define slib:form-feed #\page)
-
-;;; {Time}
-(define difftime -)
-(define offset-time +)
-
-;;; Early version of 'logical is built-in
-(define logical:logand logand)
-(define logical:logior logior)
-;;(define logical:logxor logxor)
-;;(define logical:lognot lognot)
-;;(define logical:logtest logtest)
-;;(define logical:logbit? logbit?)
-(define (copy-bit index to bool)
- (if bool
- (logical:logior to (logical:ash 1 index))
- (logical:logand to (logical:lognot (logical:ash 1 index)))))
-;;(define copy-bit logical:copy-bit)
-;;(define logical:ash ash)
-;;(define logical:logcount logcount)
-;;(define logical:integer-length integer-length)
-(define (logical:bit-field n start end)
- (logical:logand (- (logical:integer-expt 2 (- end start)) 1)
- (logical:ash n (- start))))
-;;(define bit-field logical:bit-field)
-(define (bitwise-if mask n0 n1)
- (logical:logior (logical:logand mask n0)
- (logical:logand (logical:lognot mask) n1)))
-(define logical:bitwise-if bitwise-if)
-;;(define logical:bit-extract bit-extract)
-(define (copy-bit-field to start end from)
- (logical:bitwise-if
- (logical:ash (- (logical:integer-expt 2 (- end start)) 1) start)
- (logical:ash from start)
- to))
-;;(define copy-bit-field logical:copy-bit-field)
-(define logical:integer-expt integer-expt)
-;;(define logical:ipow-by-squaring ipow-by-squaring)
-
-;;guile> (expt 2 -1)
-;;ERROR: In procedure integer-expt:
-;;ERROR: Argument out of range: -1
-;;ABORT: (out-of-range)
-(define expt
- (let ((integer-expt integer-expt))
- (lambda (z1 z2)
- (cond ((zero? z1) (if (zero? z2) 1 0))
- ((and (exact? z2) (not (negative? z2)))
- (integer-expt z1 z2))
- ((and (real? z2) (real? z1) (>= z1 0))
- ($expt z1 z2))
- (else
- (exp (* z2 (log z1))))))))
-
-;;; array-for-each
-(define (array-indexes ra)
- (let ((ra0 (apply create-array '#() (array-shape ra))))
- (array-index-map! ra0 list)
- ra0))
-(define (array-copy! source dest)
- (array-map! dest identity source))
-(define (array-null? array)
- (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd)))
- (array-shape array)))))
-(define (create-array prot . args)
- (if (array-null? prot)
- (dimensions->uniform-array args (array-prototype prot))
- (dimensions->uniform-array args (array-prototype prot)
- (apply array-ref prot
- (map car (array-shape prot))))))
-(define (make-uniform-wrapper prot)
- (if (string? prot) (set! prot (string->number prot)))
- (if prot
- (lambda opt (if (null? opt)
- (list->uniform-array 1 prot '())
- (list->uniform-array 1 prot opt)))
- vector))
-(define ac64 (make-uniform-wrapper "+i"))
-(define ac32 ac64)
-(define ar64 (make-uniform-wrapper "1/3"))
-(define ar32 (make-uniform-wrapper "1."))
-(define as64 vector)
-(define as32 (make-uniform-wrapper -32))
-(define as16 as32)
-(define as8 as32)
-(define au64 vector)
-(define au32 (make-uniform-wrapper 32))
-(define au16 au32)
-(define au8 au32)
-(define at1 (make-uniform-wrapper #t))
-
-;;; {Random numbers}
-(define (make-random-state . args)
- (let ((seed (if (null? args) *random-state* (car args))))
- (cond ((string? seed))
- ((number? seed) (set! seed (number->string seed)))
- (else (let ()
- (require 'object->string)
- (set! seed (object->limited-string seed 50)))))
- (seed->random-state seed)))
-
-;;; Support for older versions of Scheme. Not enough code for its own file.
-;;(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
-
-;;; Guile has nil and t as self-sets
-;;(define t #t)
-;;(define nil #f)
-
-;;; Define these if your implementation's syntax can support it and if
-;;; they are not already defined.
-
-;;(define (1+ n) (+ n 1))
-;;(define (-1+ n) (+ n -1))
-;;(define 1- -1+)
-
-(slib:load (in-vicinity (library-vicinity) "require"))