diff options
Diffstat (limited to 'guile-2.init')
| -rwxr-xr-x | guile-2.init | 714 |
1 files changed, 714 insertions, 0 deletions
diff --git a/guile-2.init b/guile-2.init new file mode 100755 index 0000000..566ca0d --- /dev/null +++ b/guile-2.init @@ -0,0 +1,714 @@ +;"guile.init" Configuration file for SLIB for Guile -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; Author: Andy Wingo +;;; +;;; This code is in the public domain. + +(cond-expand + (guile-2) + (else + (error "Guile 2.0 or later is required."))) + +(define-module (ice-9 slib) + #:use-module ((ice-9 popen) #:select (open-input-pipe close-pipe)) + #:use-module ((ice-9 rdelim) #:select (read-line read-line! write-line)) + #:re-export (read-line read-line! write-line) + #:export (<=? + <? + =? + >=? + >? + A:bool + A:fixN16b + A:fixN32b + A:fixN64b + A:fixN8b + A:fixZ16b + A:fixZ32b + A:fixZ64b + A:fixZ8b + A:floC128b + A:floC16b + A:floC32b + A:floC64b + A:floR128b + A:floR128d + A:floR16b + A:floR32b + A:floR32d + A:floR64b + A:floR64d + a:bool + a:fixn16b + a:fixn32b + a:fixn64b + a:fixn8b + a:fixz16b + a:fixz32b + a:fixz64b + a:fixz8b + a:floc128b + a:floc16b + a:floc32b + a:floc64b + a:flor128b + a:flor128d + a:flor16b + a:flor32b + a:flor32d + a:flor64b + a:flor64d + any-bits-set? + arithmetic-shift + array-indexes + array-null? + array:copy! + ;; ac32 + ;; ac64 + ;; ar32 + ;; ar64 + ;; as16 + ;; as32 + ;; as64 + ;; as8 + ;; at1 + ;; au16 + ;; au32 + ;; au64 + ;; au8 + bit-field + bit-reverse + bit-set? + bitwise-and + bitwise-if + bitwise-ior + bitwise-merge + bitwise-not + bitwise-xor + booleans->integer + browse-url + call-with-open-ports + copy-bit + copy-bit-field + create-array + ;;define + defmacro:eval + defmacro:expand* + defmacro:load + ;;delete-file + difftime + ;;file-position + first-set-bit + gentemp + home-vicinity + implementation-vicinity + integer->list + library-vicinity + list->array + list->integer + log2-binary-factors + logical:ash + logical:bit-extract + logical:integer-expt + logical:integer-length + ;;logical:ipow-by-squaring + logical:logand + logical:logcount + logical:logior + logical:lognot + logical:logxor + macro:eval + macro:load + make-array + make-exchanger + make-random-state + ;;make-uniform-wrapper + make-vicinity + ;; nil + offset-time + ;;open-file + output-port-height + output-port-width + pathname->vicinity + program-vicinity + random:chunk + reverse-bit-field + rotate-bit-field + scheme-implementation-home-page + scheme-implementation-type + scheme-implementation-version + ;; slib-module + slib:error + slib:eval + slib:eval-load + slib:exit + ;; slib:features + slib:form-feed + slib:load + slib:load-compiled + slib:load-source + slib:tab + slib:warn + software-type + sub-vicinity + ;;system + system->line + ;; t + user-vicinity + vector->array + ;; vicinity:suffix? + ;; with-load-pathname + ) + #:replace (file-position + system + open-file + delete-file + char-code-limit + scheme-file-suffix + gentemp + make-array + list->array + provide + provided?)) + +(define slib-module (current-module)) + +(module-export-all! (current-module)) + +;;; (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/") + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. +(define scheme-implementation-version version) + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. +(define implementation-vicinity + (cond ((getenv "GUILE_IMPLEMENTATION_PATH") + => (lambda (path) (lambda () path))) + (else %site-dir))) + +;;; (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 (getenv "SCHEME_LIBRARY_PATH") + (string-append (canonicalize-path (dirname (current-filename))) + "/") + ;; A fallback; normally shouldn't be reached. + "/usr/share/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 (or (getenv "HOME") + (false-if-exception + (passwd:dir (getpwnam (cuserid))))))) + (and home + (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) + home + (string-append home "/"))))) +;@ +(define (user-vicinity) + "") +;@ +(define vicinity:suffix? + (case (software-type) + ((ms-dos windows) + (lambda (chr) (memv chr '(#\/ #\\)))) + (else + (lambda (chr) (eqv? chr #\/))))) +;@ +(define (pathname->vicinity pathname) + (let loop ((i (- (string-length pathname) 1))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref pathname i)) + (substring pathname 0 (+ i 1))) + (else (loop (- i 1)))))) +;@ +(define program-vicinity + (make-parameter (getcwd) pathname->vicinity)) +;@ +(define sub-vicinity + (let ((*vicinity-suffix* + (case (software-type) + ((ms-dos windows atarist os/2) "\\") + ((unix coherent plan9 amiga) "/")))) + (lambda (vic name) + (string-append vic name *vicinity-suffix*)))) +;@ +(define (make-vicinity <pathname>) <pathname>) +;@ +(define (with-load-pathname path thunk) + (parameterize ((program-vicinity path)) + (thunk))) + +;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features +;;; initially supported by this implementation. +(define slib:features + '(source ;can load scheme source files + ;(SLIB:LOAD-SOURCE "filename") + compiled ;can load compiled files + ;(SLIB:LOAD-COMPILED "filename") + vicinity + srfi-59 + srfi-96 + + ;; Scheme report features + ;; R5RS-compliant implementations should provide all 9 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. + char-ready? + rev4-optional-procedures ;LIST-TAIL, STRING-COPY, + ;STRING-FILL!, and VECTOR-FILL! + + ;; These four features are optional in both R4RS and R5RS + + multiarg/and- ;/ and - can take more than 2 args. + rationalize +;;; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF + with-file ;has WITH-INPUT-FROM-FILE and + ;WITH-OUTPUT-TO-FILE + +;;; 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 + hash ;HASH, HASHV, HASHQ + + full-continuation ;can return multiple times + ieee-floating-point ;conforms to IEEE Standard 754-1985 + ;IEEE Standard for Binary + ;Floating-Point Arithmetic. + + ;; Other common features + + srfi-0 ;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 + line-i/o +;;; sort +;;; pretty-print +;;; object->string +;;; format ;Common-lisp output formatting +;;; trace ;has macros: TRACE and UNTRACE +;;; compiler ;has (COMPILER) +;;; ed ;(ED) is editor + system ;posix (system <string>) + getenv ;posix (getenv <string>) + program-arguments ;returns list of strings (argv) + current-time ;returns time in seconds since 1/1/1970 + + ;; Implementation Specific features + + logical + random ;Random numbers + + array + array-for-each + )) + +;;@ (FILE-POSITION <port> . <k>) +(define* (file-position port #:optional k) + (if k + (seek port k SEEK_SET) + (ftell port))) + +;;; (OUTPUT-PORT-WIDTH <port>) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT <port>) +(define (output-port-height . arg) 24) + +;; If the program is killed by a signal, /bin/sh normally gives an +;; exit code of 128+signum. If /bin/sh itself is killed by a signal +;; then we do the same 128+signum here. +;; +;; "status:stop-sig" shouldn't arise here, since system shouldn't be +;; calling waitpid with WUNTRACED, but allow for it anyway, just in +;; case. +(define (system str) + (define st ((@ (guile) system) str)) + (or (status:exit-val st) + (+ 128 (or (status:term-sig st) + (status:stop-sig st))))) + +;;; for line-i/o +(define* (system->line command #:optional tmp) + ;; TMP is the name of a temporary file, and is unused because we use + ;; pipes. + (let ((ipip (open-input-pipe command))) + (define line (read-line ipip)) + (let ((status (close-pipe ipip))) + (and (or (eqv? 0 (status:exit-val status)) + (status:term-sig status) + (status:stop-sig status)) + (if (eof-object? line) "" line))))) + +(define (delete-file filename) + (false-if-exception + ((@ (guile) delete-file) filename))) + +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + ((@ (guile) open-file) + filename + (if (symbol? modes) + (symbol->string modes) + modes))) +;; This has to be done after the definition so that the original +;; binding will still be visible during the definition. +(if (string>=? (scheme-implementation-version) "1.8") + (module-replace! (current-module) '(open-file))) + +(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)) + +;; Nothing special to do for this, so straight from +;; Template.scm. Maybe "sensible-browser" for a debian +;; system would be worth trying too (and would be good on a +;; tty). +(define (browse-url url) + (define (try cmd end) (zero? (system (string-append cmd url end)))) + (or (try "netscape-remote -remote 'openURL(" ")'") + (try "netscape -remote 'openURL(" ")'") + (try "netscape '" "'&") + (try "netscape '" "'"))) + +;;; "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 (+ 1 #x10ffff)) + +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. +(define (slib:eval expression) + (eval expression (interaction-environment))) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exiting not supported. +(define slib:exit quit) + +;@ +(define scheme-file-suffix + (lambda () ".scm")) + +(define (slib:load <pathname>) + (save-module-excursion + (lambda () + (set-current-module slib-module) + (load (string-append <pathname> (scheme-file-suffix)))))) + +;;;(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-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) + (defmacro:expand* x)) + +;@ +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +;;; If your implementation provides R4RS macros: +(define macro:eval slib:eval) +(define macro:load slib:load-source) + +(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 (copy-bit index to bool) + (if bool + (logior to (arithmetic-shift 1 index)) + (logand to (lognot (arithmetic-shift 1 index))))) +(define (bit-field n start end) + (logand (- (expt 2 (- end start)) 1) + (arithmetic-shift n (- start)))) +(define (bitwise-if mask n0 n1) + (logior (logand mask n0) + (logand (lognot mask) n1))) +(define (copy-bit-field to from start end) + (bitwise-if (arithmetic-shift (lognot (ash -1 (- end start))) start) + (arithmetic-shift from start) + to)) +(define (rotate-bit-field n count start end) + (define width (- end start)) + (set! count (modulo count width)) + (let ((mask (lognot (ash -1 width)))) + (define azn (logand mask (arithmetic-shift n (- start)))) + (logior (arithmetic-shift + (logior (logand mask (arithmetic-shift azn count)) + (arithmetic-shift azn (- count width))) + start) + (logand (lognot (ash mask start)) n)))) +(define (log2-binary-factors n) + (+ -1 (integer-length (logand n (- n))))) +(define (bit-reverse k n) + (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1)) + (k (+ -1 k) (+ -1 k)) + (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m)))) + ((negative? k) (if (negative? n) (lognot rvs) rvs)))) +(define (reverse-bit-field n start end) + (define width (- end start)) + (let ((mask (lognot (ash -1 width)))) + (define zn (logand mask (arithmetic-shift n (- start)))) + (logior (arithmetic-shift (bit-reverse width zn) start) + (logand (lognot (ash mask start)) n)))) + +(define* (integer->list k len) + (if len + (do ((idx (+ -1 len) (+ -1 idx)) + (k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((negative? idx) lst)) + (do ((k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((<= k 0) lst)))) +(define (list->integer bools) + (do ((bs bools (cdr bs)) + (acc 0 (+ acc acc (if (car bs) 1 0)))) + ((null? bs) acc))) +(define (booleans->integer . bools) + (list->integer bools)) + +;;;; SRFI-60 aliases +(define arithmetic-shift ash) +(define bitwise-ior logior) +(define bitwise-xor logxor) +(define bitwise-and logand) +(define bitwise-not lognot) +;;(define bit-count logcount) +(define bit-set? logbit?) +(define any-bits-set? logtest) +(define first-set-bit log2-binary-factors) +(define bitwise-merge bitwise-if) + +;;; array-for-each +(define (array-indexes ra) + (let ((ra0 (apply make-array '#() (array-shape ra)))) + (array-index-map! ra0 list) + ra0)) +(define (array:copy! dest source) + (array-map! dest identity source)) +;; DIMENSIONS->UNIFORM-ARRAY and list->uniform-array in Guile-1.6.4 +;; cannot make empty arrays. +(define make-array + (lambda (prot . args) + (dimensions->uniform-array args (array-prototype prot) + (apply array-ref prot + (map car (array-shape prot)))))) + +(define (list->array rank proto lst) + (define dimensions + (do ((shp '() (cons (length row) shp)) + (row lst (car lst)) + (rnk (+ -1 rank) (+ -1 rnk))) + ((negative? rnk) (reverse shp)))) + (let ((nra (apply make-array proto dimensions))) + (define (l2ra dims idxs row) + (cond ((null? dims) + (apply array-set! nra row (reverse idxs))) + ((if (not (eqv? (car dims) (length row))) + (slib:error 'list->array + 'non-rectangular 'array dims dimensions)) + (do ((idx 0 (+ 1 idx)) + (row row (cdr row))) + ((>= idx (car dims))) + (l2ra (cdr dims) (cons idx idxs) (car row)))))) + (l2ra dimensions '() lst) + nra)) + +(define (vector->array vect prototype . dimensions) + (define vdx (vector-length vect)) + (if (not (eqv? vdx (apply * dimensions))) + (slib:error 'vector->array vdx '<> (cons '* dimensions))) + (let ((ra (apply make-array prototype dimensions))) + (define (v2ra dims idxs) + (cond ((null? dims) + (set! vdx (+ -1 vdx)) + (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) + (else + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (v2ra (cdr dims) (cons idx idxs)))))) + (v2ra dimensions '()) + ra)) +(define (array->vector ra) + (define dims (array-dimensions ra)) + (let* ((vdx (apply * dims)) + (vect (make-vector vdx))) + (define (ra2v dims idxs) + (if (null? dims) + (let ((val (apply array-ref ra (reverse idxs)))) + (set! vdx (+ -1 vdx)) + (vector-set! vect vdx val)) + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (ra2v (cdr dims) (cons idx idxs))))) + (ra2v dims '()) + vect)) + +(define create-array make-array) +(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 prot)) + (list->uniform-array 0 prot (car 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)) + +;;; New SRFI-58 names +;; flonums +(define A:floC128b ac64) +(define A:floC64b ac64) +(define A:floC32b ac32) +(define A:floC16b ac32) +(define A:floR128b ar64) +(define A:floR64b ar64) +(define A:floR32b ar32) +(define A:floR16b ar32) +;; decimal flonums +(define A:floR128d ar64) +(define A:floR64d ar64) +(define A:floR32d ar32) +;; fixnums +(define A:fixZ64b as64) +(define A:fixZ32b as32) +(define A:fixZ16b as16) +(define A:fixZ8b as8) +(define A:fixN64b au64) +(define A:fixN32b au32) +(define A:fixN16b au16) +(define A:fixN8b au8) +(define A:bool at1) + +;;; And case-insensitive versions +;; flonums +(define a:floc128b ac64) +(define a:floc64b ac64) +(define a:floc32b ac32) +(define a:floc16b ac32) +(define a:flor128b ar64) +(define a:flor64b ar64) +(define a:flor32b ar32) +(define a:flor16b ar32) +;; decimal flonums +(define a:flor128d ar64) +(define a:flor64d ar64) +(define a:flor32d ar32) +;; fixnums +(define a:fixz64b as64) +(define a:fixz32b as32) +(define a:fixz16b as16) +(define a:fixz8b as8) +(define a:fixn64b au64) +(define a:fixn32b au32) +(define a:fixn16b au16) +(define a:fixn8b au8) +(define a:bool at1) + +;;; {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))) +(define (random:chunk sta) (random 256 sta)) + +(define t #t) +(define nil #f) + +;;; rev2-procedures +(define <? <) +(define <=? <=) +(define =? =) +(define >? >) +(define >=? >=) + +(slib:load (in-vicinity (library-vicinity) "require")) |