cvs diff: Diffing . Index: ChangeLog =================================================================== RCS file: /sources/slib/slib/ChangeLog,v retrieving revision 1.563 diff -u -r1.563 ChangeLog --- ChangeLog 27 Jun 2012 17:10:25 -0000 1.563 +++ ChangeLog 10 Jan 2013 16:16:34 -0000 @@ -1,3 +1,16 @@ +2013-01-10 Andy Wingo + + * README: Update documentation for Guile. + + * guile-2.init: + * guile.init: Factor an initialization file for Guile 2.0 and + later out of guile.init. This does not change the interface, + though -- loading guile.init will load guile-2.init if + appropriate, and otherwise executes its own code. + + * slib.nsi: + * Makefile (ifiles): Update build scripts. + 2012-06-27 Aubrey Jaffer * structure.scm (define-structure): Reconciled with documentation. Index: Makefile =================================================================== RCS file: /sources/slib/slib/Makefile,v retrieving revision 1.273 diff -u -r1.273 Makefile --- Makefile 27 Jun 2012 17:10:25 -0000 1.273 +++ Makefile 10 Jan 2013 16:16:34 -0000 @@ -112,7 +112,7 @@ scheme2c.init scheme48.init gambit.init t3.init vscm.init \ scm.init scsh.init sisc.init pscheme.init STk.init kawa.init \ RScheme.init mzscheme.init umbscheme.init jscheme.init s7.init \ - guile.init guile.use + guile.init guile.use guile-2.init tfiles = macrotst.scm dwindtst.scm formatst.scm sfiles = $(ffiles) $(lfiles) $(revfiles) $(afiles) $(scfiles) $(efiles) \ $(rfiles) colorspc.scm $(scafiles) $(txiscms) $(srfiles) Index: README =================================================================== RCS file: /sources/slib/slib/README,v retrieving revision 1.103 diff -u -r1.103 README --- README 20 Dec 2010 19:56:23 -0000 1.103 +++ README 10 Jan 2013 16:16:34 -0000 @@ -35,7 +35,8 @@ `s7.init' is a configuration file for S7, part of Snd sound-editor. `umbscheme.init' is a configuration file for umb-scheme. `vscm.init' is a configuration file for VSCM. - `guile.init' is a configuration file for guile. + `guile-2.init' is a configuration file for Guile version 2.0 or later. + `guile.init' is a configuration file for older versions of Guile. `jscheme.init' is a configuration file for JScheme. `kawa.init' is a configuration file for Kawa. `mklibcat.scm' builds the *catalog* cache. @@ -351,8 +352,11 @@ kawa -f ${SCHEME_LIBRARY_PATH}kawa.init -- -- Implementation: Guile - Guile versions 1.6 and earlier link to an archaic SLIB version. In - RedHat or Fedora installations: + For Guile 1.8 or later, use: + guile -l ${SCHEME_LIBRARY_PATH}guile.init + + For prehistoric Guile, you may have to remove a prehistoric copy of + SLIB that was included with Guile: rm /usr/share/guile/slib ln -s ${SCHEME_LIBRARY_PATH} /usr/share/guile/slib @@ -364,10 +368,6 @@ `${SCHEME_LIBRARY_PATH}' is where SLIB gets installed. - Guile with SLIB can then be started thus: - - guile -l ${SCHEME_LIBRARY_PATH}guile.init - -- Implementation: Scheme48 To make a Scheme48 image for an installation under `', Index: guile-2.init =================================================================== RCS file: guile-2.init diff -N guile-2.init --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ guile-2.init 10 Jan 2013 16:16:35 -0000 @@ -0,0 +1,718 @@ +;"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 ) ) +;@ +(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 ) + getenv ;posix (getenv ) + 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 . ) +(define* (file-position port #:optional k) + (if k + (seek port k SEEK_SET) + (ftell port))) + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT ) +(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. +;;; +;;; FIXME: Slib assumes that it can make a vector of as many characters +;;; as there are codepoints, using this variable. That's terribly +;;; inefficient, so we artificially limit char-code-limit here. +(define char-code-limit 256) + +;;; 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 ) + (save-module-excursion + (lambda () + (set-current-module slib-module) + (load (string-append (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 >=? >=) + +(slib:load (in-vicinity (library-vicinity) "require")) Index: guile.init =================================================================== RCS file: /sources/slib/slib/guile.init,v retrieving revision 1.75 diff -u -r1.75 guile.init --- guile.init 11 Feb 2010 22:05:15 -0000 1.75 +++ guile.init 10 Jan 2013 16:16:35 -0000 @@ -3,6 +3,11 @@ ;;; ;;; This code is in the public domain. +(cond-expand + (guile-2 + (include "guile-2.init")) + (else + (cond ((and (string<=? "1.6" (version)) (string=? (version) "1.8.6") @@ -160,20 +165,17 @@ (define-module (ice-9 slib)))) (define slib-module (current-module)) -(cond-expand - (guile-2) - (else - (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))))) +(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. @@ -522,16 +524,13 @@ ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. ;; In Guile-1.8.0: (string>? (string #\000) (string #\200)) ==> #t -(cond-expand - (guile-2) - (else (define char-code-limit (if (string=? (version) "1.8.0") 128 char-code-limit)) (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(char-code-limit))) -)) + ;;; MOST-POSITIVE-FIXNUM is used in modular.scm ;;(define most-positive-fixnum #x0FFFFFFF) @@ -574,24 +573,21 @@ (lambda () (read-enable 'case-insensitive)) (lambda () (apply proc args)) (lambda () (read-options old)))))))) -(cond-expand - (guile-2) - (else ;;Here for backward compatability (define scheme-file-suffix (if (string>=? (scheme-implementation-version) "1.8") scheme-file-suffix (let ((suffix (case (software-type) - ((nosve) "_scm") - (else ".scm")))) - (lambda () suffix)))) + ((nosve) "_scm") + (else ".scm")))) + (lambda () suffix)))) (define read (if (string>=? (scheme-implementation-version) "1.8") read (guile:wrap-case-insensitive read))) (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(scheme-file-suffix read))) -)) + (define slib:load (if (string>=? (scheme-implementation-version) "1.8") (slib:load-helper load) @@ -869,22 +865,19 @@ (seed->random-state seed))) (define (random:chunk sta) (random 256 sta)) -(cond-expand - (guile-2) - (else ;;; workaround for Guile 1.6.7 bug (define array? (if (or (array? 'guile) (array? '(1 6 7))) (let ((old-array? array?)) - (lambda (obj) - (and (old-array? obj) - (not (or (list? obj) - (symbol? obj) - (record? obj)))))) + (lambda (obj) + (and (old-array? obj) + (not (or (list? obj) + (symbol? obj) + (record? obj)))))) array?)) (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(array?))) -)) + ;;; 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)) @@ -903,3 +896,5 @@ (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(provide provided?))) + +)) ;; end of cond-expand clause for Guile < 2.0 Index: slib.nsi =================================================================== RCS file: /sources/slib/slib/slib.nsi,v retrieving revision 1.14 diff -u -r1.14 slib.nsi --- slib.nsi 20 Dec 2010 19:56:24 -0000 1.14 +++ slib.nsi 10 Jan 2013 16:16:35 -0000 @@ -270,6 +270,7 @@ File "elk.init" File "gambit.init" File "guile.init" + File "guile-2.init" File "jscheme.init" File "kawa.init" File "macscheme.init" @@ -461,6 +462,7 @@ Delete "$INSTDIR\elk.init" Delete "$INSTDIR\gambit.init" Delete "$INSTDIR\guile.init" + Delete "$INSTDIR\guile-2.init" Delete "$INSTDIR\jscheme.init" Delete "$INSTDIR\kawa.init" Delete "$INSTDIR\macscheme.init" cvs diff: Diffing prevdocs