[csw-devel] SF.net SVN: gar:[20257] csw/mgar/pkg/slib/trunk
pfelecan at users.sourceforge.net
pfelecan at users.sourceforge.net
Mon Feb 4 16:05:07 CET 2013
Revision: 20257
http://gar.svn.sourceforge.net/gar/?rev=20257&view=rev
Author: pfelecan
Date: 2013-02-04 15:05:06 +0000 (Mon, 04 Feb 2013)
Log Message:
-----------
slib/trunk: transition toward guile 2.0
Modified Paths:
--------------
csw/mgar/pkg/slib/trunk/Makefile
Added Paths:
-----------
csw/mgar/pkg/slib/trunk/files/0003-Adapt-to-Guile-2.patch
csw/mgar/pkg/slib/trunk/files/0004-Force-libraries-directory.patch
Modified: csw/mgar/pkg/slib/trunk/Makefile
===================================================================
--- csw/mgar/pkg/slib/trunk/Makefile 2013-02-04 13:20:29 UTC (rev 20256)
+++ csw/mgar/pkg/slib/trunk/Makefile 2013-02-04 15:05:06 UTC (rev 20257)
@@ -13,8 +13,17 @@
DISTFILES = $(DISTNAME).tar.gz
PATCHFILES = 0001-Fix-configure-shebang.patch
PATCHFILES += 0002-Fix-slib-script-shebang.patch
+PATCHFILES += 0003-Adapt-to-Guile-2.patch
+PATCHFILES += 0004-Force-libraries-directory.patch
-ARCHALL = 1
+PACKAGES = CSWslib
+CATALOGNAME_CSWslib = slib
+SPKG_DESC_CSWslib = $(DESCRIPTION)
+RUNTIME_DEP_PKGS_CSWslib += CSWguile
+CHECKPKG_OVERRIDES_CSWslib += surplus-dependency|CSWguile
+RUNTIME_DEP_PKGS_CSWslib += CSWscm
+CHECKPKG_OVERRIDES_CSWslib += surplus-dependency|CSWscm
+ARCHALL_CSWslib = 1
EXTRA_CONFIGURE_ENV = PATH=$(prefix)/gnu:$(PATH)
CONFIGURE_ARGS = $(DIRPATHS)
Added: csw/mgar/pkg/slib/trunk/files/0003-Adapt-to-Guile-2.patch
===================================================================
--- csw/mgar/pkg/slib/trunk/files/0003-Adapt-to-Guile-2.patch (rev 0)
+++ csw/mgar/pkg/slib/trunk/files/0003-Adapt-to-Guile-2.patch 2013-02-04 15:05:06 UTC (rev 20257)
@@ -0,0 +1,966 @@
+From 646fb01a812f1b6caf9cb23bfa528136a0014b35 Mon Sep 17 00:00:00 2001
+From: Peter Felecan <pfelecan at opencsw.org>
+Date: Mon, 4 Feb 2013 11:59:36 +0100
+Subject: [PATCH] Adapt to Guile 2 Andy Wigo patches taken from
+ http://lists.gnu.org/archive/html/guile-user/2013-01/msg00014.html
+
+---
+ ChangeLog | 13 ++
+ Makefile | 2 +-
+ README | 14 +-
+ guile-2.init | 718 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ guile.init | 63 +++---
+ slib.nsi | 2 +
+ 6 files changed, 770 insertions(+), 42 deletions(-)
+ create mode 100644 guile-2.init
+
+diff --git a/ChangeLog b/ChangeLog
+index cff5bd3..8738d3a 100644
+--- a/ChangeLog
++++ b/ChangeLog
+@@ -1,3 +1,16 @@
++2013-01-10 Andy Wingo <address at hidden>
++
++ * 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.
++
+ 2010-07-02 Aubrey Jaffer <agj at alum.mit.edu>
+
+ * require.scm (*slib-version*): Bumped from 3b2 to 3b3.
+diff --git a/Makefile b/Makefile
+index 8cc5256..143eafb 100644
+--- a/Makefile
++++ b/Makefile
+@@ -105,7 +105,7 @@ ifiles = bigloo.init chez.init elk.init macscheme.init mitscheme.init \
+ 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)
+diff --git a/README b/README
+index eb5e8a6..c6d8954 100644
+--- a/README
++++ b/README
+@@ -35,7 +35,8 @@ The maintainer can be reached at agj @ alum.mit.edu.
+ `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.
+@@ -350,8 +351,11 @@ above.
+ 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
+@@ -363,10 +367,6 @@ above.
+
+ `${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 `<prefix>',
+
+diff --git a/guile-2.init b/guile-2.init
+new file mode 100644
+index 0000000..9e35729
+--- /dev/null
++++ b/guile-2.init
+@@ -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 <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.
++;;;
++;;; 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 <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"))
+diff --git a/guile.init b/guile.init
+index c58d498..7ab6256 100644
+--- a/guile.init
++++ b/guile.init
+@@ -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.3")))
+ ((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
+diff --git a/slib.nsi b/slib.nsi
+index 60445c1..07fbb32 100644
+--- a/slib.nsi
++++ b/slib.nsi
+@@ -269,6 +269,7 @@ Section "MainSection" SEC01
+ File "elk.init"
+ File "gambit.init"
+ File "guile.init"
++ File "guile-2.init"
+ File "jscheme.init"
+ File "kawa.init"
+ File "macscheme.init"
+@@ -460,6 +461,7 @@ Section Uninstall
+ 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"
+--
+1.8.1
+
Added: csw/mgar/pkg/slib/trunk/files/0004-Force-libraries-directory.patch
===================================================================
--- csw/mgar/pkg/slib/trunk/files/0004-Force-libraries-directory.patch (rev 0)
+++ csw/mgar/pkg/slib/trunk/files/0004-Force-libraries-directory.patch 2013-02-04 15:05:06 UTC (rev 20257)
@@ -0,0 +1,57 @@
+From 0ec1101ec54fa4989485c2b9867e51e0f9694373 Mon Sep 17 00:00:00 2001
+From: Peter Felecan <pfelecan at opencsw.org>
+Date: Mon, 4 Feb 2013 15:56:43 +0100
+Subject: [PATCH] Force libraries directory
+
+---
+ Makefile | 11 ++++-------
+ 1 file changed, 4 insertions(+), 7 deletions(-)
+
+diff --git a/Makefile b/Makefile
+index 143eafb..ebb1ad0 100644
+--- a/Makefile
++++ b/Makefile
+@@ -17,9 +17,11 @@ TEXI2PDF = texi2pdf
+ RSYNC = rsync -av
+ Uploadee = csail
+
++slibdir = /opt/csw/share/guile/
++
+ RUNNABLE = scheme48
+ S48INIT = scheme48.init
+-S48LIB = $(libdir)$(RUNNABLE)/
++S48LIB = $(slibdir)$(RUNNABLE)/
+ S48SLIB = $(S48LIB)slib/
+ IMAGE48 = slib.image
+
+@@ -40,7 +42,7 @@ Makefile: config.status
+ include config.status
+
+ prevdocsdir = prevdocs/
+-libslibdir = $(libdir)slib/
++libslibdir = $(slibdir)slib/
+ windistdir = /c/Voluntocracy/dist/
+ rpm_prefix = $(HOME)/rpmbuild/
+
+@@ -172,9 +174,6 @@ slib.info: slib-$(VERSION).info
+ else cp $< $@;fi
+ $(DESTDIR)$(infodir)slib.info: slib.info installdirs
+ $(INSTALL_DATA) $< $@
+- -rm $(DESTDIR)$(infodir)slib.info.gz
+- $(POST_INSTALL) # Post-install commands follow.
+- -$(INSTALL_INFO) $@ $(DESTDIR)$(infodir)dir
+ install-info: $(DESTDIR)$(infodir)slib.info
+ info: install-info
+ $(DESTDIR)$(infodir)slib.info.gz: $(DESTDIR)$(infodir)slib.info
+@@ -282,8 +281,6 @@ install: install-script install-lib install-infoz install-man
+
+ uninstall: uninstall48
+ $(PRE_UNINSTALL) # Pre-uninstall commands follow.
+- -$(INSTALL_INFO) --delete $(DESTDIR)$(infodir)slib.info \
+- $(DESTDIR)$(infodir)dir
+ $(NORMAL_UNINSTALL) # Normal commands follow.
+ -rm $(DESTDIR)$(infodir)slib.info*
+ -rm $(DESTDIR)$(mandir)man1/slib.1
+--
+1.8.1
+
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
More information about the devel
mailing list