From bb256c9cdd10e2392406534fe5318ca11f8d9c85 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 6 Dec 2025 11:49:24 +0200 Subject: [PATCH] Add SRFI-27, start 98, 106, 112 --- Dockerfile | 7 +- Makefile | 36 +-- srfi/106.scm | 0 srfi/106.sld | 44 ++++ srfi/112.scm | 83 +++++++ srfi/112.sld | 11 + srfi/112/LICENSE | 165 ++++++++++++++ srfi/112/README.md | 2 + srfi/112/VERSION | 1 + srfi/112/test.scm | 18 ++ srfi/170/README.md | 2 +- srfi/27.scm | 544 +++++++++++++++++++++++++++++++++++++++++++++ srfi/27.sld | 67 ++++++ srfi/27/LICENSE | 165 ++++++++++++++ srfi/27/README.md | 0 srfi/27/VERSION | 1 + srfi/27/test.scm | 5 + srfi/98.scm | 11 + srfi/98.sld | 10 + srfi/srfi-112.scm | 11 + 20 files changed, 1166 insertions(+), 17 deletions(-) create mode 100644 srfi/106.scm create mode 100644 srfi/106.sld create mode 100644 srfi/112.scm create mode 100644 srfi/112.sld create mode 100644 srfi/112/LICENSE create mode 100644 srfi/112/README.md create mode 100644 srfi/112/VERSION create mode 100644 srfi/112/test.scm create mode 100644 srfi/27.scm create mode 100644 srfi/27.sld create mode 100644 srfi/27/LICENSE create mode 100644 srfi/27/README.md create mode 100644 srfi/27/VERSION create mode 100644 srfi/27/test.scm create mode 100644 srfi/98.scm create mode 100644 srfi/98.sld create mode 100644 srfi/srfi-112.scm diff --git a/Dockerfile b/Dockerfile index 5d1c239..bbc32a6 100644 --- a/Dockerfile +++ b/Dockerfile @@ -10,6 +10,7 @@ RUN wget https://gitlab.com/-/project/6808260/uploads/094ce726ce3c6cf8c14560f1e3 && mv akku-1.1.0.amd64-linux akku RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1 RUN git clone https://codeberg.org/retropikzel/compile-scheme.git --depth=1 +RUN git clone https://codeberg.org/retropikzel/foreign-c-libraries.git --depth=1 WORKDIR /build/chibi-scheme RUN make RUN make install @@ -36,10 +37,12 @@ RUN bash install.sh ENV PATH=/root/.local/bin:${PATH} RUN akku update WORKDIR /build/foreign-c -RUN if [ ! "${SCHEME}" = "racket" ]; then timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 64)"; fi -RUN if [ ! "${SCHEME}" = "larceny" ]; then timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(foreign c)"; fi +RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 64)" || true +RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(foreign c)" || true +RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(retropikzel shell)" || true RUN make SCHEME=${SCHEME} build install WORKDIR /workdir +RUN cp -r /build/foreign-c-libraries/retropikzel retropikzel/ RUN cp -r /build/foreign-c/foreign . COPY Makefile . COPY srfi srfi/ diff --git a/Makefile b/Makefile index 71385d6..292f309 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,5 @@ -.SILENT: build install test test-docker clean +.SILENT: build install clean test-r6rs test-r6rs-docker test-r7rs \ + test-r7rs-docker .PHONY: test-r6rs test-r7rs SCHEME=chibi SRFI=170 @@ -9,6 +10,7 @@ VERSION=$(shell cat srfi/${SRFI}/VERSION) DESCRIPTION=$(shell head -n1 srfi/${SRFI}/README.md) README=srfi/${SRFI}/README.html TESTFILE=srfi/${SRFI}/test.scm +TMPDIR=./tmp/${SCHEME} PKG=srfi-${SRFI}-${VERSION}.tgz @@ -29,26 +31,32 @@ install: uninstall: -snow-chibi remove --impls=${SCHEME} ${PKG} -test-r7rs: - echo "(import (scheme base) (scheme write) (scheme file) (scheme process-context) (srfi ${SRFI}) (srfi 64))" > test-r7rs.scm - cat srfi/${SRFI}/test.scm >> test-r7rs.scm - COMPILE_R7RS=${SCHEME} compile-scheme -I . -o test-r7rs test-r7rs.scm - printf "\n" | ./test-r7rs +test-r7rs: tmpdir + @if [ "${SCHEME}" = "chibi" ]; then rm -rf ${TMPDIR}/srfi/98.*; fi + cd ${TMPDIR} && echo "(import (scheme base) (scheme write) (scheme file) (scheme process-context) (srfi ${SRFI}) (srfi 64))" > test-r7rs.scm + cd ${TMPDIR} && cat srfi/${SRFI}/test.scm >> test-r7rs.scm + cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} compile-scheme -I . -o test-r7rs test-r7rs.scm + cd ${TMPDIR} && printf "\n" | ./test-r7rs test-r7rs-docker: - docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-srfi-test-${SCHEME} . + docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-srfi-test-${SCHEME} --quiet . docker run -t foreign-c-srfi-test-${SCHEME} sh -c "make SCHEME=${SCHEME} SRFI=${SRFI} SNOW_CHIBI_ARGS=--always-yes build install test-r7rs" -test-r6rs: - echo "(import (rnrs) (srfi ${SRFI}) (srfi :64))" > test-r6rs.sps - cat srfi/${SRFI}/test.scm >> test-r6rs.sps - akku install chez-srfi akku-r7rs "(foreign c)" - COMPILE_R7RS=${SCHEME} compile-scheme -I .akku/lib -o test-r6rs test-r6rs.sps - ./test-r6rs +test-r6rs: tmpdir + cd ${TMPDIR} && echo "(import (rnrs) (srfi :${SRFI}) (srfi :64))" > test-r6rs.sps + cd ${TMPDIR} && cat srfi/${SRFI}/test.scm >> test-r6rs.sps + cd ${TMPDIR} && akku install chez-srfi akku-r7rs "(foreign c)" #"(retropikzel shell)" + cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} compile-scheme -I .akku/lib -o test-r6rs test-r6rs.sps + cd ${TMPDIR} && ./test-r6rs test-r6rs-docker: - docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-srfi-test-${SCHEME} . + docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-srfi-test-${SCHEME} --quiet . docker run -t foreign-c-srfi-test-${SCHEME} sh -c "make SCHEME=${SCHEME} SRFI=${SRFI} test-r6rs" +tmpdir: + rm -rf ${TMPDIR} + mkdir -p ${TMPDIR} + cp -r srfi ${TMPDIR}/ + clean: git clean -X -f diff --git a/srfi/106.scm b/srfi/106.scm new file mode 100644 index 0000000..e69de29 diff --git a/srfi/106.sld b/srfi/106.sld new file mode 100644 index 0000000..36eb96e --- /dev/null +++ b/srfi/106.sld @@ -0,0 +1,44 @@ +(define-library + (srfi 106) + (import (scheme base) + (foreign c)) + (export make-client-socket + make-server-socket + socket? + socket-accept + socket-send + socket-recv + socket-shutdown + socket-close + socket-input-port + socket-output-port + call-with-socket + address-family + address-info + socket-domain + ip-protocol + message-type + shutdown-method + socket-merge-flags + socket-purge-flags + *af-unspec* + *af-inet* + *af-inet6* + *sock-stream* + *sock-dgram* + *ai-canonname* + *ai-numerichost* + *ai-v4mapped* + *ai-all* + *ai-addrconfig* + *ipproto-ip* + *ipproto-tcp* + *ipproto-udp* + *msg-peek* + *msg-oob* + *msg-waitall* + *shut-rd* + *shut-wr* + *shut-rdwr*) + (include "106.scm")) + diff --git a/srfi/112.scm b/srfi/112.scm new file mode 100644 index 0000000..d7263e3 --- /dev/null +++ b/srfi/112.scm @@ -0,0 +1,83 @@ +(define (implementation-name) + (cond-expand + (capyscheme "capyscheme") + (chezscheme "chezscheme") + (chibi "chibi") + (chicken "chicken") + (cyclone "cyclone") + (foment "foment") + (gambit "gambit") + (gauche "gauche") + (guile "guile") + (ikarus "ikarus") + (ironscheme "ironscheme") + (kawa "kawa") + (larceny "larceny") + (loko "loko") + (meevax "meevax") + (mit "mit-scheme") + (mosh "mosh") + (racket "racket") + (sagittarius "sagittarius") + (stklos "stklos") + (tr7 "tr7") + (ypsilon "ypsilon") + (else #f))) + +(define (implementation-version) + (let ((version-list + (cond-expand + (capyscheme + (list-ref + (shell->list ("capy --help | head -n1 | tr ' ' '\n'")) + 1)) + (chezscheme (shell->list "chezscheme --version")) + (chibi (shell->list "chibi-scheme -V | tr ' ' '\n'") 2) + (chicken (cdr (shell->list "csc -version | grep Version | tr ' ' '\n'"))) + (cyclone (cdr (reverse (shell->list "cyclone -v | grep Version | tr ' ' '\n'")))) + (foment "foment") + (gambit "gambit") + (gauche (cdr (shell->sexp "gosh -V | grep \"(version\""))) + (guile "guile") + (ikarus "ikarus") + (ironscheme "ironscheme") + (kawa "kawa") + (larceny "larceny") + (loko "loko") + (meevax "meevax") + (mit "mit-scheme") + (mosh "mosh") + (racket "racket") + (sagittarius "sagittarius") + (stklos "stklos") + (tr7 "tr7") + (ypsilon "ypsilon") + (else #f)))) + (if (and (shell-exit-code) + (= (shell-exit-code) 0)) + (car version-list) + #f))) + +(define (cpu-architecture) + (let ((arch (shell->list "uname --machine"))) + (if (= (shell-exit-code) 0) + (car arch) + #f))) + +(define (machine-name) + (let ((name (shell->list "uname --nodename"))) + (if (= (shell-exit-code) 0) + (car name) + #f))) + +(define (os-name) + (let ((name (shell->list "uname --sysname"))) + (if (= (shell-exit-code) 0) + (car name) + #f))) + +(define (os-version) + (let ((version-list (shell->list "uname --kernel-version | tr ' ' '\n'"))) + (if (= (shell-exit-code) 0) + (list-ref (reverse version-list) 1) + #f))) diff --git a/srfi/112.sld b/srfi/112.sld new file mode 100644 index 0000000..77ccf76 --- /dev/null +++ b/srfi/112.sld @@ -0,0 +1,11 @@ +(define-library + (srfi 112) + (import (scheme base) + (retropikzel shell)) + (export implementation-name + implementation-version + cpu-architecture + machine-name + os-name + os-version) + (include "112.scm")) diff --git a/srfi/112/LICENSE b/srfi/112/LICENSE new file mode 100644 index 0000000..0a04128 --- /dev/null +++ b/srfi/112/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/srfi/112/README.md b/srfi/112/README.md new file mode 100644 index 0000000..630de37 --- /dev/null +++ b/srfi/112/README.md @@ -0,0 +1,2 @@ +Implementation of [SRFI 112](https://srfi.schemers.org/srfi-112/srfi-112.html) +Environment Inquiry using (foreign c)]. diff --git a/srfi/112/VERSION b/srfi/112/VERSION new file mode 100644 index 0000000..3eefcb9 --- /dev/null +++ b/srfi/112/VERSION @@ -0,0 +1 @@ +1.0.0 diff --git a/srfi/112/test.scm b/srfi/112/test.scm new file mode 100644 index 0000000..acb7208 --- /dev/null +++ b/srfi/112/test.scm @@ -0,0 +1,18 @@ + +(test-begin "srfi-112") + +(write (implementation-name)) +(newline) +(write (implementation-version)) +(newline) +(write (cpu-architecture)) +(newline) +(write (machine-name)) +(newline) +(write (os-name)) +(newline) +(write (os-version)) +(newline) + + +(test-end "srfi-112") diff --git a/srfi/170/README.md b/srfi/170/README.md index 808a6eb..9d09ba4 100644 --- a/srfi/170/README.md +++ b/srfi/170/README.md @@ -1,5 +1,5 @@ Implementation of [SRFI 170](https://srfi.schemers.org/srfi-170/srfi-170.html) -POSIX API using [(foreign c)](https://git.sr.ht/~retropikzel/foreign-c). +POSIX API using (foreign c)]. Currently only supports Linux. diff --git a/srfi/27.scm b/srfi/27.scm new file mode 100644 index 0000000..a4d4a9f --- /dev/null +++ b/srfi/27.scm @@ -0,0 +1,544 @@ +; 54-BIT INTEGER IMPLEMENTATION OF THE "MRG32K3A"-GENERATOR +; ========================================================= +; +; Sebastian.Egner@philips.com, Mar-2002. +; +; This file is an implementation of Pierre L'Ecuyer's MRG32k3a +; pseudo random number generator. Please refer to 'mrg32k3a.scm' +; for more information. +; +; compliance: +; Scheme R5RS with integers covering at least {-2^53..2^53-1}. +; +; history of this file: +; SE, 18-Mar-2002: initial version +; SE, 22-Mar-2002: comments adjusted, range added +; SE, 25-Mar-2002: pack/unpack just return their argument + +; the actual generator + +(define (mrg32k3a-random-m1 state) + (let ((x11 (vector-ref state 0)) + (x12 (vector-ref state 1)) + (x13 (vector-ref state 2)) + (x21 (vector-ref state 3)) + (x22 (vector-ref state 4)) + (x23 (vector-ref state 5))) + (let ((x10 (modulo (- (* 1403580 x12) (* 810728 x13)) 4294967087)) + (x20 (modulo (- (* 527612 x21) (* 1370589 x23)) 4294944443))) + (vector-set! state 0 x10) + (vector-set! state 1 x11) + (vector-set! state 2 x12) + (vector-set! state 3 x20) + (vector-set! state 4 x21) + (vector-set! state 5 x22) + (modulo (- x10 x20) 4294967087)))) + +; interface to the generic parts of the generator + +(define (mrg32k3a-pack-state unpacked-state) + unpacked-state) + +(define (mrg32k3a-unpack-state state) + state) + +(define (mrg32k3a-random-range) ; m1 + 4294967087) + +(define (mrg32k3a-random-integer state range) ; rejection method + (let* ((q (quotient 4294967087 range)) + (qn (* q range))) + (do ((x (mrg32k3a-random-m1 state) (mrg32k3a-random-m1 state))) + ((< x qn) (quotient x q))))) + +(define (mrg32k3a-random-real state) ; normalization is 1/(m1+1) + (* 0.0000000002328306549295728 (+ 1.0 (mrg32k3a-random-m1 state)))) + + +; GENERIC PART OF MRG32k3a-GENERATOR FOR SRFI-27 +; ============================================== +; +; Sebastian.Egner@philips.com, 2002. +; +; This is the generic R5RS-part of the implementation of the MRG32k3a +; generator to be used in SRFI-27. It is based on a separate implementation +; of the core generator (presumably in native code) and on code to +; provide essential functionality not available in R5RS (see below). +; +; compliance: +; Scheme R5RS with integer covering at least {-2^53..2^53-1}. +; In addition, +; SRFI-23: error +; +; history of this file: +; SE, 22-Mar-2002: refactored from earlier versions +; SE, 25-Mar-2002: pack/unpack need not allocate +; SE, 27-Mar-2002: changed interface to core generator +; SE, 10-Apr-2002: updated spec of mrg32k3a-random-integer + +; Generator +; ========= +; +; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive +; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n} +; defined by the two recursive generators +; +; x[1,n] = ( a12 x[1,n-2] + a13 x[1,n-3]) mod m1, +; x[2,n] = (a21 x[2,n-1] + a23 x[2,n-3]) mod m2, +; +; where the constants are +; m1 = 4294967087 = 2^32 - 209 modulus of 1st component +; m2 = 4294944443 = 2^32 - 22853 modulus of 2nd component +; a12 = 1403580 recursion coefficients +; a13 = -810728 +; a21 = 527612 +; a23 = -1370589 +; +; The generator passes all tests of G. Marsaglia's Diehard testsuite. +; Its period is (m1^3 - 1)(m2^3 - 1)/2 which is nearly 2^191. +; L'Ecuyer reports: "This generator is well-behaved in all dimensions +; up to at least 45: ..." [with respect to the spectral test, SE]. +; +; The period is maximal for all values of the seed as long as the +; state of both recursive generators is not entirely zero. +; +; As the successor state is a linear combination of previous +; states, it is possible to advance the generator by more than one +; iteration by applying a linear transformation. The following +; publication provides detailed information on how to do that: +; +; [1] P. L'Ecuyer, R. Simard, E. J. Chen, W. D. Kelton: +; An Object-Oriented Random-Number Package With Many Long +; Streams and Substreams. 2001. +; To appear in Operations Research. +; +; Arithmetics +; =========== +; +; The MRG32k3a generator produces values in {0..2^32-209-1}. All +; subexpressions of the actual generator fit into {-2^53..2^53-1}. +; The code below assumes that Scheme's "integer" covers this range. +; In addition, it is assumed that floating point literals can be +; read and there is some arithmetics with inexact numbers. +; +; However, for advancing the state of the generator by more than +; one step at a time, the full range {0..2^32-209-1} is needed. + + +; Required: Backbone Generator +; ============================ +; +; At this point in the code, the following procedures are assumed +; to be defined to execute the core generator: +; +; (mrg32k3a-pack-state unpacked-state) -> packed-state +; (mrg32k3a-unpack-state packed-state) -> unpacked-state +; pack/unpack a state of the generator. The core generator works +; on packed states, passed as an explicit argument, only. This +; allows native code implementations to store their state in a +; suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22) +; with integer x_ij. Pack/unpack need not allocate new objects +; in case packed and unpacked states are identical. +; +; (mrg32k3a-random-range) -> m-max +; (mrg32k3a-random-integer packed-state range) -> x in {0..range-1} +; advance the state of the generator and return the next random +; range-limited integer. +; Note that the state is not necessarily advanced by just one +; step because we use the rejection method to avoid any problems +; with distribution anomalies. +; The range argument must be an exact integer in {1..m-max}. +; It can be assumed that range is a fixnum if the Scheme system +; has such a number representation. +; +; (mrg32k3a-random-real packed-state) -> x in (0,1) +; advance the state of the generator and return the next random +; real number between zero and one (both excluded). The type of +; the result should be a flonum if possible. + +; Required: Record Data Type +; ========================== +; +; At this point in the code, the following procedures are assumed +; to be defined to create and access a new record data type: +; +; (:random-source-make a0 a1 a2 a3 a4 a5) -> s +; constructs a new random source object s consisting of the +; objects a0 .. a5 in this order. +; +; (:random-source? obj) -> bool +; tests if a Scheme object is a :random-source. +; +; (:random-source-state-ref s) -> a0 +; (:random-source-state-set! s) -> a1 +; (:random-source-randomize! s) -> a2 +; (:random-source-pseudo-randomize! s) -> a3 +; (:random-source-make-integers s) -> a4 +; (:random-source-make-reals s) -> a5 +; retrieve the values in the fields of the object s. + +; Required: Current Time as an Integer +; ==================================== +; +; At this point in the code, the following procedure is assumed +; to be defined to obtain a value that is likely to be different +; for each invokation of the Scheme system: +; +; (:random-source-current-time) -> x +; an integer that depends on the system clock. It is desired +; that the integer changes as fast as possible. + + +; Accessing the State +; =================== + +(define (mrg32k3a-state-ref packed-state) + (cons 'lecuyer-mrg32k3a + (vector->list (mrg32k3a-unpack-state packed-state)))) + +(define (mrg32k3a-state-set external-state) + + (define (check-value x m) + (if (and (integer? x) + (exact? x) + (<= 0 x (- m 1))) + #t + (error "illegal value" x))) + + (if (and (list? external-state) + (= (length external-state) 7) + (eq? (car external-state) 'lecuyer-mrg32k3a)) + (let ((s (cdr external-state))) + (check-value (list-ref s 0) mrg32k3a-m1) + (check-value (list-ref s 1) mrg32k3a-m1) + (check-value (list-ref s 2) mrg32k3a-m1) + (check-value (list-ref s 3) mrg32k3a-m2) + (check-value (list-ref s 4) mrg32k3a-m2) + (check-value (list-ref s 5) mrg32k3a-m2) + (if (or (zero? (+ (list-ref s 0) (list-ref s 1) (list-ref s 2))) + (zero? (+ (list-ref s 3) (list-ref s 4) (list-ref s 5)))) + (error "illegal degenerate state" external-state)) + (mrg32k3a-pack-state (list->vector s))) + (error "malformed state" external-state))) + + +; Pseudo-Randomization +; ==================== +; +; Reference [1] above shows how to obtain many long streams and +; substream from the backbone generator. +; +; The idea is that the generator is a linear operation on the state. +; Hence, we can express this operation as a 3x3-matrix acting on the +; three most recent states. Raising the matrix to the k-th power, we +; obtain the operation to advance the state by k steps at once. The +; virtual streams and substreams are now simply parts of the entire +; periodic sequence (which has period around 2^191). +; +; For the implementation it is necessary to compute with matrices in +; the ring (Z/(m1*m1)*Z)^(3x3). By the Chinese-Remainder Theorem, this +; is isomorphic to ((Z/m1*Z) x (Z/m2*Z))^(3x3). We represent such a pair +; of matrices +; [ [[x00 x01 x02], +; [x10 x11 x12], +; [x20 x21 x22]], mod m1 +; [[y00 y01 y02], +; [y10 y11 y12], +; [y20 y21 y22]] mod m2] +; as a vector of length 18 of the integers as writen above: +; #(x00 x01 x02 x10 x11 x12 x20 x21 x22 +; y00 y01 y02 y10 y11 y12 y20 y21 y22) +; +; As the implementation should only use the range {-2^53..2^53-1}, the +; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32, +; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0 +; where w = 2^16. In this case, all operations fit the range because +; w^2 mod m is a small number. If proper multiprecision integers are +; available this is not necessary, but pseudo-randomize! is an expected +; to be called only occasionally so we do not provide this implementation. + +(define mrg32k3a-m1 4294967087) ; modulus of component 1 +(define mrg32k3a-m2 4294944443) ; modulus of component 2 + +(define mrg32k3a-initial-state ; 0 3 6 9 12 15 of A^16, see below + '#( 1062452522 + 2961816100 + 342112271 + 2854655037 + 3321940838 + 3542344109)) + +(define mrg32k3a-generators #f) ; computed when needed + +(define (mrg32k3a-pseudo-randomize-state i j) + + (define (product A B) ; A*B in ((Z/m1*Z) x (Z/m2*Z))^(3x3) + + (define w 65536) ; wordsize to split {0..2^32-1} + (define w-sqr1 209) ; w^2 mod m1 + (define w-sqr2 22853) ; w^2 mod m2 + + (define (lc i0 i1 i2 j0 j1 j2 m w-sqr) ; linear combination + (let ((a0h (quotient (vector-ref A i0) w)) + (a0l (modulo (vector-ref A i0) w)) + (a1h (quotient (vector-ref A i1) w)) + (a1l (modulo (vector-ref A i1) w)) + (a2h (quotient (vector-ref A i2) w)) + (a2l (modulo (vector-ref A i2) w)) + (b0h (quotient (vector-ref B j0) w)) + (b0l (modulo (vector-ref B j0) w)) + (b1h (quotient (vector-ref B j1) w)) + (b1l (modulo (vector-ref B j1) w)) + (b2h (quotient (vector-ref B j2) w)) + (b2l (modulo (vector-ref B j2) w))) + (modulo + (+ (* (+ (* a0h b0h) + (* a1h b1h) + (* a2h b2h)) + w-sqr) + (* (+ (* a0h b0l) + (* a0l b0h) + (* a1h b1l) + (* a1l b1h) + (* a2h b2l) + (* a2l b2h)) + w) + (* a0l b0l) + (* a1l b1l) + (* a2l b2l)) + m))) + + (vector + (lc 0 1 2 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_00 mod m1 + (lc 0 1 2 1 4 7 mrg32k3a-m1 w-sqr1) ; (A*B)_01 + (lc 0 1 2 2 5 8 mrg32k3a-m1 w-sqr1) + (lc 3 4 5 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_10 + (lc 3 4 5 1 4 7 mrg32k3a-m1 w-sqr1) + (lc 3 4 5 2 5 8 mrg32k3a-m1 w-sqr1) + (lc 6 7 8 0 3 6 mrg32k3a-m1 w-sqr1) + (lc 6 7 8 1 4 7 mrg32k3a-m1 w-sqr1) + (lc 6 7 8 2 5 8 mrg32k3a-m1 w-sqr1) + (lc 9 10 11 9 12 15 mrg32k3a-m2 w-sqr2) ; (A*B)_00 mod m2 + (lc 9 10 11 10 13 16 mrg32k3a-m2 w-sqr2) + (lc 9 10 11 11 14 17 mrg32k3a-m2 w-sqr2) + (lc 12 13 14 9 12 15 mrg32k3a-m2 w-sqr2) + (lc 12 13 14 10 13 16 mrg32k3a-m2 w-sqr2) + (lc 12 13 14 11 14 17 mrg32k3a-m2 w-sqr2) + (lc 15 16 17 9 12 15 mrg32k3a-m2 w-sqr2) + (lc 15 16 17 10 13 16 mrg32k3a-m2 w-sqr2) + (lc 15 16 17 11 14 17 mrg32k3a-m2 w-sqr2))) + + (define (power A e) ; A^e + (cond + ((zero? e) + '#(1 0 0 0 1 0 0 0 1 1 0 0 0 1 0 0 0 1)) + ((= e 1) + A) + ((even? e) + (power (product A A) (quotient e 2))) + (else + (product (power A (- e 1)) A)))) + + (define (power-power A b) ; A^(2^b) + (if (zero? b) + A + (power-power (product A A) (- b 1)))) + + (define A ; the MRG32k3a recursion + '#( 0 1403580 4294156359 + 1 0 0 + 0 1 0 + 527612 0 4293573854 + 1 0 0 + 0 1 0)) + + ; check arguments + (if (not (and (integer? i) + (exact? i) + (integer? j) + (exact? j))) + (error "i j must be exact integer" i j)) + + ; precompute A^(2^127) and A^(2^76) only once + + (if (not mrg32k3a-generators) + (set! mrg32k3a-generators + (list (power-power A 127) + (power-power A 76) + (power A 16)))) + + ; compute M = A^(16 + i*2^127 + j*2^76) + (let ((M (product + (list-ref mrg32k3a-generators 2) + (product + (power (list-ref mrg32k3a-generators 0) + (modulo i (expt 2 28))) + (power (list-ref mrg32k3a-generators 1) + (modulo j (expt 2 28))))))) + (mrg32k3a-pack-state + (vector + (vector-ref M 0) + (vector-ref M 3) + (vector-ref M 6) + (vector-ref M 9) + (vector-ref M 12) + (vector-ref M 15))))) + +; True Randomization +; ================== +; +; The value obtained from the system time is feed into a very +; simple pseudo random number generator. This in turn is used +; to obtain numbers to randomize the state of the MRG32k3a +; generator, avoiding period degeneration. + +(define (mrg32k3a-randomize-state state) + ;; G. Marsaglia's simple 16-bit generator with carry + (let* ((m 65536) + (x (modulo (:random-source-current-time) m))) + (define (random-m) + (let ((y (modulo x m))) + (set! x (+ (* 30903 y) (quotient x m))) + y)) + (define (random n) ; m < n < m^2 + (modulo (+ (* (random-m) m) (random-m)) n)) + + ; modify the state + (let ((m1 mrg32k3a-m1) + (m2 mrg32k3a-m2) + (s (mrg32k3a-unpack-state state))) + (mrg32k3a-pack-state + (vector + (+ 1 (modulo (+ (vector-ref s 0) (random (- m1 1))) (- m1 1))) + (modulo (+ (vector-ref s 1) (random m1)) m1) + (modulo (+ (vector-ref s 2) (random m1)) m1) + (+ 1 (modulo (+ (vector-ref s 3) (random (- m2 1))) (- m2 1))) + (modulo (+ (vector-ref s 4) (random m2)) m2) + (modulo (+ (vector-ref s 5) (random m2)) m2)))))) + + +; Large Integers +; ============== +; +; To produce large integer random deviates, for n > m-max, we first +; construct large random numbers in the range {0..m-max^k-1} for some +; k such that m-max^k >= n and then use the rejection method to choose +; uniformly from the range {0..n-1}. + +(define mrg32k3a-m-max + (mrg32k3a-random-range)) + +(define (mrg32k3a-random-power state k) ; n = m-max^k, k >= 1 + (if (= k 1) + (mrg32k3a-random-integer state mrg32k3a-m-max) + (+ (* (mrg32k3a-random-power state (- k 1)) mrg32k3a-m-max) + (mrg32k3a-random-integer state mrg32k3a-m-max)))) + +(define (mrg32k3a-random-large state n) ; n > m-max + (do ((k 2 (+ k 1)) + (mk (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max))) + ((>= mk n) + (let* ((mk-by-n (quotient mk n)) + (a (* mk-by-n n))) + (do ((x (mrg32k3a-random-power state k) + (mrg32k3a-random-power state k))) + ((< x a) (quotient x mk-by-n))))))) + + +; Multiple Precision Reals +; ======================== +; +; To produce multiple precision reals we produce a large integer value +; and convert it into a real value. This value is then normalized. +; The precision goal is unit <= 1/(m^k + 1), or 1/unit - 1 <= m^k. +; If you know more about the floating point number types of the +; Scheme system, this can be improved. + +(define (mrg32k3a-random-real-mp state unit) + (do ((k 1 (+ k 1)) + (u (- (/ 1 unit) 1) (/ u mrg32k3a-m1))) + ((<= u 1) + (/ (exact->inexact (+ (mrg32k3a-random-power state k) 1)) + (exact->inexact (+ (expt mrg32k3a-m-max k) 1)))))) + + +; Provide the Interface as Specified in the SRFI +; ============================================== +; +; An object of type random-source is a record containing the procedures +; as components. The actual state of the generator is stored in the +; binding-time environment of make-random-source. + +(define (make-random-source) + (let ((state (mrg32k3a-pack-state ; make a new copy + (list->vector (vector->list mrg32k3a-initial-state))))) + (:random-source-make + (lambda () + (mrg32k3a-state-ref state)) + (lambda (new-state) + (set! state (mrg32k3a-state-set new-state))) + (lambda () + (set! state (mrg32k3a-randomize-state state))) + (lambda (i j) + (set! state (mrg32k3a-pseudo-randomize-state i j))) + (lambda () + (lambda (n) + (cond + ((not (and (integer? n) (exact? n) (positive? n))) + (error "range must be exact positive integer" n)) + ((<= n mrg32k3a-m-max) + (mrg32k3a-random-integer state n)) + (else + (mrg32k3a-random-large state n))))) + (lambda args + (cond + ((null? args) + (lambda () + (mrg32k3a-random-real state))) + ((null? (cdr args)) + (let ((unit (car args))) + (cond + ((not (and (real? unit) (< 0 unit 1))) + (error "unit must be real in (0,1)" unit)) + ((<= (- (/ 1 unit) 1) mrg32k3a-m1) + (lambda () + (mrg32k3a-random-real state))) + (else + (lambda () + (mrg32k3a-random-real-mp state unit)))))) + (else + (error "illegal arguments" args))))))) + +(define random-source? + :random-source?) + +(define (random-source-state-ref s) + ((:random-source-state-ref s))) + +(define (random-source-state-set! s state) + ((:random-source-state-set! s) state)) + +(define (random-source-randomize! s) + ((:random-source-randomize! s))) + +(define (random-source-pseudo-randomize! s i j) + ((:random-source-pseudo-randomize! s) i j)) + +; --- + +(define (random-source-make-integers s) + ((:random-source-make-integers s))) + +(define (random-source-make-reals s . unit) + (apply (:random-source-make-reals s) unit)) + +; --- + +(define default-random-source + (make-random-source)) + +(define random-integer + (random-source-make-integers default-random-source)) + +(define random-real + (random-source-make-reals default-random-source)) diff --git a/srfi/27.sld b/srfi/27.sld new file mode 100644 index 0000000..7fc78d4 --- /dev/null +++ b/srfi/27.sld @@ -0,0 +1,67 @@ +; MODULE DEFINITION FOR SRFI-27 +; ============================= +; +; Sebastian.Egner@philips.com, Mar-2002, in Scheme 48 0.57 +; +; This file contains the top-level definition for the 54-bit integer-only +; implementation of SRFI-27 for the Scheme 48 0.57 system. +; +; 1. The core generator is implemented in 'mrg32k3a-a.scm'. +; 2. The generic parts of the interface are in 'mrg32k3a.scm'. +; 3. The non-generic parts (record type, time, error) are here. +; +; creating the module: +; ,config ,load srfi-27-a.scm +; +; loading the module, once created: +; ,open srfi-27 +; +; history of this file: +; SE, 22-Mar-2002: initial version +; SE, 27-Mar-2002: checked again + +(define-library + (srfi 27) + (import (scheme base) + (scheme time)) + (export random-integer + random-real + default-random-source + make-random-source + random-source? + random-source-state-ref + random-source-state-set! + random-source-randomize! + random-source-pseudo-randomize! + random-source-make-integers + random-source-make-reals) + #;(open + scheme-level-1 + (subset srfi-9 (define-record-type)) + (subset srfi-23 (error)) + (subset posix-time (current-time)) + (subset posix (time-seconds))) + + (begin + (define-record-type :random-source + (:random-source-make + state-ref + state-set! + randomize! + pseudo-randomize! + make-integers + make-reals) + :random-source? + (state-ref :random-source-state-ref) + (state-set! :random-source-state-set!) + (randomize! :random-source-randomize!) + (pseudo-randomize! :random-source-pseudo-randomize!) + (make-integers :random-source-make-integers) + (make-reals :random-source-make-reals)) + + (define (:random-source-current-time) + (exact (floor (current-second))))) + + ;(include "mrg32k3a-a.scm") + ;(include "mrg32k3a.scm") +(include "27.scm")) diff --git a/srfi/27/LICENSE b/srfi/27/LICENSE new file mode 100644 index 0000000..0a04128 --- /dev/null +++ b/srfi/27/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/srfi/27/README.md b/srfi/27/README.md new file mode 100644 index 0000000..e69de29 diff --git a/srfi/27/VERSION b/srfi/27/VERSION new file mode 100644 index 0000000..6e8bf73 --- /dev/null +++ b/srfi/27/VERSION @@ -0,0 +1 @@ +0.1.0 diff --git a/srfi/27/test.scm b/srfi/27/test.scm new file mode 100644 index 0000000..2989a1b --- /dev/null +++ b/srfi/27/test.scm @@ -0,0 +1,5 @@ + + (random-source-randomize! default-random-source) + +(display (random-integer 100)) +(newline) diff --git a/srfi/98.scm b/srfi/98.scm new file mode 100644 index 0000000..b1de0c6 --- /dev/null +++ b/srfi/98.scm @@ -0,0 +1,11 @@ +(define-c-library libc '("stdlib.h") libc-name '((additional-versions ("0" "6")))) +(define-c-procedure c-getenv libc 'getenv 'pointer '(pointer)) + +(define (get-environment-variable name) + (let* ((name (c-getenv (string->c-utf8 name))) + (result (if (c-null? name) #f (string-copy (c-utf8->string name))))) + (c-free name) + result)) + +(define (get-environment-variables) + '()) diff --git a/srfi/98.sld b/srfi/98.sld new file mode 100644 index 0000000..0fa2af7 --- /dev/null +++ b/srfi/98.sld @@ -0,0 +1,10 @@ +(define-library + (srfi 98) + (import (except (scheme base) + get-environment-variable + get-environment-variables) + (foreign c)) + (export get-environment-variable + get-environment-variables + ) + (include "98.scm")) diff --git a/srfi/srfi-112.scm b/srfi/srfi-112.scm new file mode 100644 index 0000000..d1d3a20 --- /dev/null +++ b/srfi/srfi-112.scm @@ -0,0 +1,11 @@ +(define-library + (srfi srfi-112) + (import (scheme base) + (retropikzel shell)) + (export implementation-name + implementation-version + cpu-architecture + machine-name + os-name + os-version) + (include "112.scm"))