diff options
Diffstat (limited to 'guile.init')
| -rw-r--r-- | guile.init | 392 |
1 files changed, 286 insertions, 106 deletions
@@ -22,7 +22,10 @@ ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. -(define (software-type) 'unix) +(define software-type + (if (string<? (version) "1.6") + (lambda () 'UNIX) + (lambda () 'unix))) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. @@ -38,8 +41,6 @@ ;;; 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. @@ -73,72 +74,155 @@ 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 in-vicinity string-append) +;@ +(define (user-vicinity) + (case (software-type) + ((VMS) "[.]") + (else ""))) +;@ +(define vicinity:suffix? + (let ((suffi + (case (software-type) + ((amiga) '(#\: #\/)) + ((macos thinkc) '(#\:)) + ((ms-dos windows atarist os/2) '(#\\ #\/)) + ((nosve) '(#\: #\.)) + ((unix coherent plan9) '(#\/)) + ((vms) '(#\: #\])) + (else + (warn "require.scm" 'unknown 'software-type (software-type)) + "/")))) + (lambda (chr) (and (memv chr suffi) #t)))) +;@ +(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) + (define clp (current-load-port)) + (if clp + (pathname->vicinity (port-filename clp)) + (slib:error 'program-vicinity " called; use slib:load to load"))) +;@ +(define sub-vicinity + (case (software-type) + ((VMS) (lambda + (vic name) + (let ((l (string-length vic))) + (if (or (zero? (string-length vic)) + (not (char=? #\] (string-ref vic (- l 1))))) + (string-append vic "[" name "]") + (string-append (substring vic 0 (- l 1)) + "." name "]"))))) + (else (let ((*vicinity-suffix* + (case (software-type) + ((NOSVE) ".") + ((MACOS THINKC) ":") + ((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 + (let ((exchange + (lambda (new) + (let ((old program-vicinity)) + (set! program-vicinity new) + old)))) + (lambda (path thunk) + (define old #f) + (define vic (pathname->vicinity path)) + (dynamic-wind + (lambda () (set! old (exchange (lambda () vic)))) + thunk + (lambda () (exchange old)))))) + +;;@ *FEATURES* is a list of symbols naming the (SLIB) features +;;; initially supported by this implementation. (define *features* (append '( source ;can load scheme source files - ;(slib:load-source "filename") -; compiled ;can load compiled files - ;(slib:load-compiled "filename") + ;(SLIB:LOAD-SOURCE "filename") +;;; compiled ;can load compiled files + ;(SLIB:LOAD-COMPILED "filename") + vicinity + srfi-59 ;; Scheme report features + ;; R5RS-compliant implementations should provide all 9 features. -; r5rs ;conforms to +;;; r5rs ;conforms to eval ;R5RS two-argument eval -; values ;R5RS multiple values + values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind -; macro ;R5RS high level macros +;;; 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! +;;; char-ready? + rev4-optional-procedures ;LIST-TAIL, STRING-COPY, + ;STRING-FILL!, and VECTOR-FILL! -; r4rs ;conforms to + ;; These four features are optional in both R4RS and R5RS -; ieee-p1178 ;conforms to + 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 -; r3rs ;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 +;;; 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 + full-continuation ;can return multiple times +;;; 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 +;;; 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 +;;; 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 +;;; 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 + ) (if (defined? 'getenv) @@ -178,6 +262,21 @@ ;; (let ((port (current-output-port))) ;; (lambda () port))) +;; 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 + (let ((guile-core-system system)) + (lambda (str) + (define st (guile-core-system str)) + (or (status:exit-val st) + (+ 128 (or (status:term-sig st) + (status:stop-sig st))))))) + ;;; (TMPNAM) makes a temporary file name. ;;(define tmpnam (let ((cntr 100)) ;; (lambda () (set! cntr (+ 1 cntr)) @@ -188,6 +287,12 @@ ;;; (DELETE-FILE <string>) ;;(define (delete-file f) #f) +(define delete-file + (let ((guile-core-delete-file delete-file)) + (lambda (filename) + (catch 'system-error + (lambda () (guile-core-delete-file filename) #t) + (lambda args #f))))) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. @@ -198,7 +303,13 @@ (define (make-exchanger obj) (lambda (rep) (let ((old obj)) (set! obj rep) old))) - +(define open-file + (let ((guile-core-open-file open-file)) + (lambda (filename modes) + (guile-core-open-file filename + (if (symbol? modes) + (symbol->string modes) + modes))))) (define (port? obj) (or (input-port? obj) (output-port? obj))) (define (call-with-open-ports . ports) (define proc (car ports)) @@ -234,9 +345,10 @@ (let ((ie (interaction-environment))) (lambda (expression) (eval expression ie))))) +;; slib:eval-load definition moved to "require.scm" ;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. +;;; return if exiting not supported. (define slib:exit quit) ;;; Here for backward compatability @@ -246,18 +358,6 @@ ;; (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 @@ -307,75 +407,97 @@ (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) + (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) - (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)))))))) + (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 (null? len) + (do ((k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((<= k 0) lst)) + (do ((idx (+ -1 (car len)) (+ -1 idx)) + (k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((negative? idx) 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 create-array '#() (array-shape ra)))) + (let ((ra0 (apply make-array '#() (array-shape ra)))) (array-index-map! ra0 list) ra0)) -(define (array-copy! source dest) +(define (array:copy! dest source) (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) +;; DIMENSIONS->UNIFORM-ARRAY and list->uniform-array in Guile-1.6.4 +;; cannot make empty arrays. +(define (make-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 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->uniform-array 1 prot opt))) + (list->uniform-array 1 prot (list prot)) + (list->uniform-array 0 prot opt))) vector)) (define ac64 (make-uniform-wrapper "+i")) (define ac32 ac64) @@ -391,6 +513,56 @@ (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)))) @@ -400,19 +572,27 @@ (require 'object->string) (set! seed (object->limited-string seed 50))))) (seed->random-state seed))) +(if (not (defined? 'random:chunk)) + (define (random:chunk sta) (random 256 sta))) ;;; 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 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+) +(define (1+ n) (+ n 1)) +(define (-1+ n) (+ n -1)) +(define 1- -1+) + +;;; rev2-procedures +(define <? <) +(define <=? <=) +(define =? =) +(define >? >) +(define >=? >=) (slib:load (in-vicinity (library-vicinity) "require")) |