--- /dev/null
+*.eps
+*.go
+*.log
+*.pdf
+*.png
+*.tar.xz
+*.tar.gz
+*.tmp
+*~
+.#*
+\#*\#
+,*
+/ABOUT-NLS
+/INSTALL
+/aclocal.m4
+/autom4te.cache
+/build-aux/ar-lib
+/build-aux/compile
+/build-aux/config.guess
+/build-aux/config.rpath
+/build-aux/config.sub
+/build-aux/depcomp
+/build-aux/install-sh
+/build-aux/mdate-sh
+/build-aux/missing
+/build-aux/test-driver
+/build-aux/texinfo.tex
+/config.status
+/configure
+/doc/*.1
+/doc/.dirstamp
+/doc/contributing.*.texi
+/doc/*.aux
+/doc/*.cp
+/doc/*.cps
+/doc/*.fn
+/doc/*.fns
+/doc/*.html
+/doc/*.info
+/doc/*.info-[0-9]
+/doc/*.ky
+/doc/*.pg
+/doc/*.toc
+/doc/*.t2p
+/doc/*.tp
+/doc/*.vr
+/doc/*.vrs
+/doc/stamp-vti
+/doc/version.texi
+/doc/version-*.texi
+/m4/*
+/pre-inst-env
+/test-env
+/test-tmp
+/tests/*.trs
+GPATH
+GRTAGS
+GTAGS
+Makefile
+Makefile.in
+config.cache
+stamp-h[0-9]
+tmp
+/.version
+/doc/stamp-[0-9]
--- /dev/null
+Contributors to Vouivre 0.1.0:
+
+ Vouivre Digital Corporation <admin@vouivredigital.com>
--- /dev/null
+# -*- mode: org; coding: utf-8; -*-
+
+#+TITLE: Hacking Vouivre
+
+* Requirements
+
+To build the system you will need:
+ - autoconf
+ - automake
+ - guile
+ - guix[fn:: This (somewhat big) dependency is used to download the MNIST
+ dataset automatically. It can be avoided by downloading and extracting both
+ train-images-idx3-ubyte.gz and train-labels-idx1-ubyte.gz from
+ [[http://yann.lecun.com/exdb/mnist][the official website]] to a 'mnist' directory at the project's
+ root, and hacking vouivre/mnist.scm to remove the dependency.]
+
+* Building
+
+#+BEGIN_SRC bash
+ autoreconf -vif
+ ./configure
+ make
+#+END_SRC
+
+* Testing
+
+#+BEGIN_SRC bash
+ make check
+#+END_SRC
+
+* Installing
+
+Install the Scheme source code and generated binaries so that Guile can find
+them:
+#+BEGIN_SRC bash
+ make install
+#+END_SRC
--- /dev/null
+bin_SCRIPTS = examples/example.scm \
+ examples/base.scm
+
+# Handle substitution of fully-expanded Autoconf variables.
+do_subst = $(SED) \
+ -e 's,[@]GUILE[@],$(GUILE),g' \
+ -e 's,[@]guilemoduledir[@],$(guilemoduledir),g' \
+ -e 's,[@]guileobjectdir[@],$(guileobjectdir),g' \
+ -e 's,[@]localedir[@],$(localedir),g'
+
+nodist_noinst_SCRIPTS = pre-inst-env
+
+GOBJECTS = $(SOURCES:%.scm=%.go)
+
+moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
+godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
+ccachedir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
+
+nobase_dist_mod_DATA = $(filter-out $(BUILT_SOURCES),$(SOURCES)) $(NOCOMP_SOURCES)
+nobase_nodist_mod_DATA = $(BUILT_SOURCES)
+nobase_go_DATA = $(GOBJECTS)
+
+# Make sure source files are installed first, so that the mtime of
+# installed compiled files is greater than that of installed source
+# files. See
+# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
+# for details.
+guile_install_go_files = install-nobase_goDATA
+$(guile_install_go_files): install-nobase_dist_modDATA
+
+GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
+SUFFIXES = .scm .go
+.scm.go:
+ $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_TARGET) $(GUILE_WARNINGS) -o "$@" "$<"
+
+SOURCES = vouivre.scm \
+ language/vouivre/decompile-tree-il.scm \
+ language/vouivre/spec.scm \
+ language/vouivre/compile-tree-il.scm \
+ vouivre/hconfig.scm \
+ vouivre/curry.scm \
+ vouivre/autodiff.scm \
+ vouivre/misc.scm \
+ vouivre/promises.scm \
+ vouivre/mnist.scm
+
+TESTS = tests/curry.scm \
+ tests/autodiff.scm
+
+TEST_EXTENSIONS = .scm
+SCM_LOG_DRIVER = \
+ $(top_builddir)/pre-inst-env \
+ $(GUILE) --no-auto-compile -e main \
+ $(top_srcdir)/build-aux/test-driver.scm
+
+# Tell 'build-aux/test-driver.scm' to display only source file names,
+# not indivdual test names.
+AM_SCM_LOG_DRIVER_FLAGS = --brief=yes
+
+AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)"
+
+AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)"
+
+info_TEXINFOS = doc/version.texi \
+ doc/vouivre.texi
+
+EXTRA_DIST = README.org \
+ README \
+ HACKING \
+ COPYING \
+ doc/vouivre.info \
+ doc/version.info \
+ doc/.dirstamp \
+ doc/stamp-vti \
+ NEWS \
+ AUTHORS \
+ ChangeLog \
+ guix.scm \
+ .gitignore \
+ hall.scm \
+ build-aux/texinfo.tex \
+ build-aux/mdate-sh \
+ build-aux/test-driver.scm \
+ build-aux/missing \
+ build-aux/install-sh \
+ configure.ac \
+ pre-inst-env.in \
+ Makefile.am \
+ build-aux/test-driver.scm \
+ $(TESTS)
+
+ACLOCAL_AMFLAGS = -I m4
+
+AM_DISTCHECK_DVI_TARGET = info # Disable DVI as part of distcheck
+
+clean-go:
+ -$(RM) $(GOBJECTS)
+.PHONY: clean-go
+
+CLEANFILES = \
+ $(BUILT_SOURCES) \
+ $(GOBJECTS) \
+ $(TESTS:tests/%.scm=%.log)
--- /dev/null
+# -*- mode: org; coding: utf-8; -*-
+
+#+TITLE: Vouivre NEWS – history of user-visible changes
+#+STARTUP: content hidestars
+
+Copyright © (2023) Vouivre Digital Corporation <admin@vouivredigital.com>
+
+ Copying and distribution of this file, with or without modification,
+ are permitted in any medium without royalty provided the copyright
+ notice and this notice are preserved.
+
+Please send Vouivre bug reports to admin@vouivredigital.com.
+
+* Publication at 0.1.0
--- /dev/null
+README.org
\ No newline at end of file
--- /dev/null
+# -*- mode: org; coding: utf-8; -*-
+
+#+TITLE: README for Vouivre
+
+++ /dev/null
-;;;; Copyright (C) 2023 Vouivre Digital Corporation
-;;;;
-;;;; This file is part of Vouivre.
-;;;;
-;;;; Vouivre is free software: you can redistribute it and/or
-;;;; modify it under the terms of the GNU General Public
-;;;; License as published by the Free Software Foundation, either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; Vouivre is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public
-;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
-
-(define-module (vouivre autodiff tests)
- #:use-module ((vouivre autodiff) #:prefix v:)
- #:use-module (ice-9 receive)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-64)
- #:use-module (vouivre misc)
- #:export
- (apply-diff
- a~
- const-generator
- differentiable-func-generator
- lambda-const-call
- ndiff
- n~
- random-array
- random-array-shape
- random-func1
- random-func2
- random-func2-rank&dims>0
- random-input
- random-list-element
- random-non-empty-array
- random-shape
- random-shared
- random-shared-array-rank&dims>0
- random-shared-contractible
- with-generators
- ~))
-
-(define f1s (list v:abs v:cos v:exp v:identity v:sin))
-(define f2s (list v:+ v:- v:* v:max v:min))
-
-(define (with-generators% generators equal proc1 proc2 . more)
- "Check that all procedures return the same value according to `equal' when
-evaluated on arguments produced by the generators (the number of generators
-being the number of arguments to each procedure."
- (let ((times 100)
- (procs (cons proc1 (cons proc2 more))))
- (call/cc
- (lambda (break)
- (do ((i 0 (1+ i)))
- ((= i times) #t)
- (let ((zs (map-in-order (lambda (g) (g)) generators)))
- (with-exception-handler
- (lambda (e)
- (break #f zs))
- (lambda ()
- (let* ((rs (map (lambda (f) (apply f zs)) procs))
- (head (car rs)))
- (unless (every (lambda (x) (equal x head))
- (cdr rs))
- (break #f zs rs))))
- #:unwind? #t)))))))
-
-(define-syntax-rule (with-generators (g1 g2 ...) equal expected given more ...)
- (with-generators% (list g1 g2 ...) equal expected given more ...))
-
-(define (lambda-const-call f . consts)
- (lambda _
- (apply f consts)))
-
-(define* (random-array-shape
- #:optional (min-rank 0) (max-rank 5) (min-dim 0) (max-dim 5))
- (list-tabulate (+ min-rank (random (- max-rank min-rank)))
- (lambda _ (+ min-dim (random (- max-dim min-dim))))))
-
-(define (random-shape)
- (if (= 0 (random 2))
- 0
- (random-array-shape)))
-
-(define* (random-array #:optional shape)
- (apply produce-typed-array
- (lambda _ (random:uniform))
- v:*atype* (or shape (random-array-shape))))
-
-(define (random-non-empty-array)
- "Random array of at least one element."
- (random-array (random-array-shape 0 5 1 5)))
-
-(define* (random-input #:optional shape)
- (let ((shape (or shape (random-shape))))
- (if (eq? 0 shape)
- (random:uniform)
- (random-array shape))))
-
-(define (random-shared)
- (let ((shape (random-shape)))
- (values
- (lambda ()
- (random-input shape))
- (lambda ()
- (let ((x (random-input
- (random-list-element
- (list 0 (if (list? shape)
- shape
- (random-shape)))))))
- (set! shape (random-shape))
- x)))))
-
-(define (random-shared-array-rank&dims>0)
- (let ((shape (random-array-shape 1 5 1 5)))
- (values
- (lambda ()
- (random-array shape))
- (lambda ()
- (let ((x (random-array shape)))
- (set! shape (random-array-shape 1 5 1 5))
- x)))))
-
-(define (random-list-element lst)
- (list-ref lst (random (length lst))))
-
-(define (const-generator generator)
- (lambda ()
- generator))
-
-(define (differentiable-func-generator lst . input-generators)
- (lambda ()
- (random-list-element
- (cons
- (apply
- lambda-const-call
- (random-list-element lst)
- (map (lambda (g) (g))
- input-generators))
- lst))))
-
-(define random-func1
- (differentiable-func-generator f1s random-input))
-(define random-func2
- (receive (gx gy) (random-shared)
- (differentiable-func-generator f2s gx gy)))
-
-(define* (n~ x y #:optional (error 1e-4))
- (and
- (>= y (- x error))
- (<= y (+ x error))))
-
-(define* (a~ x y #:optional (error 1e-4))
- (and
- (equal? (array-dimensions x)
- (array-dimensions y))
- (call/cc
- (lambda (break)
- (array-for-each
- (lambda (x y)
- (unless (~ x y error)
- (break #f)))
- x y)
- #t))))
-
-(define* (~ x y #:optional (error 1e-4))
- (cond
- ((and (number? x) (number? y))
- (n~ x y error))
- ((and (array? x) (array? y))
- (a~ x y error))
- (else #f)))
-
-(define* (ndiff f #:optional (axis 0) (step 1e-6))
- "Differentiation using a numerical centered difference approximation."
- (define (axis-add xs dh . indices)
- "Add `dh' to the number or array at the given `axis' of `xs',
-and, when it's an array, at the given index."
- (map-indexed
- (lambda (x i)
- (ifn (= i axis)
- x
- (if (number? x)
- (+ x dh)
- (array-map-indexed
- (lambda (x . indices_)
- (ifn (equal? indices indices_)
- x
- (+ x dh)))
- x))))
- xs))
- (lambda xs
- ;; We need the output shape and the input shape along the
- ;; differentiated axis.
- (let ((fxs (apply f xs))
- (x (list-ref xs axis)))
- (cond
- ((and (number? fxs)
- (number? x))
- (/ (- (apply f (axis-add xs step))
- (apply f (axis-add xs (- step))))
- (* 2 step)))
- ((and (number? fxs)
- (array? x))
- (apply
- produce-typed-array
- (lambda indices
- (/ (- (apply f (apply axis-add xs step indices))
- (apply f (apply axis-add xs (- step) indices)))
- (* 2 step)))
- v:*atype*
- (array-dimensions x)))
- ((and (array? fxs)
- (number? x))
- ((v:extend /)
- ((v:extend -)
- (apply f (axis-add xs step))
- (apply f (axis-add xs (- step))))
- (* 2 step)))
- ((and (array? fxs)
- (array? x))
- (let ((a (apply
- make-typed-array v:*atype* *unspecified*
- (append (array-dimensions fxs)
- (array-dimensions x)))))
- (for-indices-in-range
- (lambda indices-in
- (let ((dfxs ((v:extend /)
- ((v:extend -)
- (apply f (apply axis-add xs step indices-in))
- (apply f (apply axis-add xs (- step) indices-in)))
- (* 2 step))))
- (for-indices-in-range
- (lambda indices-out
- (apply
- array-set!
- a
- (apply array-ref dfxs indices-out)
- (append indices-out indices-in)))
- (list-zeros (array-rank fxs))
- (array-dimensions fxs))))
- (list-zeros (array-rank x))
- (array-dimensions x))
- a))))))
-
-(define* (apply-diff differentiator #:optional (axis 0))
- "Apply a differentiator (`ndiff', `fdiff', `rdiff') to a function and its
-arguments (this is a convenience function)."
- (lambda (f . args)
- (apply (differentiator f axis) args)))
-
-(test-begin "autodiff")
-
-;; not differentiating
-(test-assert (with-generators (random-input) ~ (v:extend identity) v:identity))
-(test-assert (with-generators (random-input) ~ (v:extend exp) v:exp))
-(test-assert
- (receive (gx gy) (random-shared)
- (with-generators (gx gy) ~ (v:extend *) v:*)))
-
-;; differentiation in one variable
-(test-assert
- (with-generators
- (random-func1 random-input)
- ~ (apply-diff ndiff) (apply-diff v:fdiff) (apply-diff v:rdiff)))
-
-;; `v:mean' only takes non-empty arrays so we treat it separately
-(test-assert
- (with-generators
- ((differentiable-func-generator (list v:mean) random-non-empty-array)
- random-non-empty-array)
- ~ (apply-diff ndiff) (apply-diff v:fdiff) (apply-diff v:rdiff)))
-
-;; differentiation in two variables
-(test-assert
- (receive (gx gy) (random-shared)
- (with-generators
- (random-func2 gx gy)
- ~ (apply-diff ndiff 0) (apply-diff v:fdiff 0) (apply-diff v:rdiff 0))))
-(test-assert
- (receive (gx gy) (random-shared)
- (with-generators
- (random-func2 gx gy)
- ~ (apply-diff ndiff 1) (apply-diff v:fdiff 1) (apply-diff v:rdiff 1))))
-
-;; `v:amap2' only takes arrays of rank > 0 and batch-size > 0 so we treat it
-;; separately
-(define random-func2-rank&dims>0
- (receive (gx gy) (random-shared-array-rank&dims>0)
- (differentiable-func-generator f2s gx gy)))
-(test-assert
- (receive (gx gy) (random-shared-array-rank&dims>0)
- (with-generators
- ((const-generator v:amap2) random-func2-rank&dims>0 gx gy)
- ;; NOTE: for `v:amap2' the differentiable axes are 1 and 2.
- ~ (apply-diff ndiff 1) (apply-diff v:fdiff 1) (apply-diff v:rdiff 1))))
-(test-assert
- (receive (gx gy) (random-shared-array-rank&dims>0)
- (with-generators
- ((const-generator v:amap2) random-func2-rank&dims>0 gx gy)
- ~ (apply-diff ndiff 2) (apply-diff v:fdiff 2) (apply-diff v:rdiff 2))))
-(let* ((z #(1 2 3))
- (f (lambda (a)
- (v:amap2 (lambda (x y)
- (v:* a a))
- #(10 20 30)
- #(40 50 60))))
- (e ((ndiff f) z)))
- (test-assert (~ e ((v:fdiff f) z)))
- (test-assert (~ e ((v:rdiff f) z))))
-
-;; `v:adot'
-(define (random-shared-contractible)
- "Returns three generators: the first two generate arrays that are contractible
-according to the number generated by the third one."
- (let* ((n (random 5))
- (sa (random-array-shape n))
- (sb (append (reverse (take (reverse sa)
- n))
- (random-array-shape 0 (- 5 n)))))
- (values
- (lambda ()
- (random-array sa))
- (lambda ()
- (random-array sb))
- (lambda ()
- (let ((tmp n))
- (set! n (random 5))
- (set! sa (random-array-shape n))
- (set! sb (append (reverse (take (reverse sa)
- n))
- (random-array-shape 0 (- 5 n))))
- tmp)))))
-(test-assert
- (receive (gx gy gz) (random-shared-contractible)
- (with-generators
- ((const-generator v:adot) gx gy gz)
- ~ (apply-diff ndiff 0) (apply-diff v:fdiff 0) (apply-diff v:rdiff 0))))
-(test-assert
- (receive (gx gy gz) (random-shared-contractible)
- (with-generators
- ((const-generator v:adot) gx gy gz)
- ~ (apply-diff ndiff 1) (apply-diff v:fdiff 1) (apply-diff v:rdiff 1))))
-
-;; let binding re-entry
-(test-assert
- (with-generators
- ((const-generator
- (lambda (x)
- (let ((c (v:maximum x)))
- (v:+ c (v:- x c)))))
- random-non-empty-array)
- ~ (apply-diff ndiff) (apply-diff v:fdiff) (apply-diff v:rdiff)))
-
-;; chain rule
-(test-assert
- (with-generators
- (random-func1 random-func1 random-input)
- ~
- (lambda (f g x) ((ndiff (compose f g)) x))
- (lambda (f g x) ((v:fdiff (compose f g)) x))
- (lambda (f g x) ((v:rdiff (compose f g)) x))))
-
-(test-end "autodiff")
+++ /dev/null
-;;;; Copyright (C) 2023 Vouivre Digital Corporation
-;;;;
-;;;; This file is part of Vouivre.
-;;;;
-;;;; Vouivre is free software: you can redistribute it and/or
-;;;; modify it under the terms of the GNU General Public
-;;;; License as published by the Free Software Foundation, either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; Vouivre is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public
-;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
-
-(define-module (vouivre autodiff)
- #:use-module (ice-9 receive)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (vouivre misc)
- #:use-module (vouivre promises)
- #:export
- (*atype*
- adot
- amap2
- contract-arrays
- differentiable-wrapper
- dot
- do-times
- ewise1
- ewise2
- extend
- fdiff
- rdiff
- make-batch
- make-internal
- maximum
- mean
- rank-of
- sum)
- #:replace
- ((i:sqrt . sqrt)
- (i:exp . exp)
- (i:expt . expt)
- (i:log . log)
- (i:sin . sin)
- (i:cos . cos)
- (i:tan . tan)
- (i:+ . +)
- (i:- . -)
- (i:* . *)
- (i:/ . /)
- (i:max . max)
- (i:min . min)
- (i:abs . abs)
- (i:identity . identity)
- (i:array-ref . array-ref)
- (i:array-cell-ref . array-cell-ref))
- #:re-export
- (fold
- reduce))
-
-;;;; array utilities
-
-(define (rel->abs indices dimensions)
- (let rec ((s 0)
- (p 1)
- (is (reverse indices))
- (ds (reverse dimensions)))
- (if (null? is)
- s
- (rec (+ s (* p (car is)))
- (* p (car ds))
- (cdr is)
- (cdr ds)))))
-
-(define(do-times n proc)
- (let rec ((i 0))
- (unless (= i n)
- (proc i)
- (rec (1+ i)))))
-
-(define (contract-arrays a b n)
- (let* ((dims-a (array-dimensions a))
- (dims-b (array-dimensions b))
- (free-dims-a (take dims-a (- (array-rank a) n)))
- (free-dims-b (drop dims-b n))
- (bound-dims (take dims-b n))
- (n-free-dims-a (apply * free-dims-a))
- (n-free-dims-b (apply * free-dims-b))
- (n-bound-dims (apply * bound-dims))
- (s 0)
- (r (apply make-typed-array *atype* *unspecified* (append free-dims-a
- free-dims-b)))
- (ac (array-contents a))
- (bc (array-contents b))
- (rc (array-contents r)))
- (do-times
- n-free-dims-a
- (lambda (i)
- (let ((i-k (* n-bound-dims i))
- (i-j (* n-free-dims-b i)))
- (do-times
- n-free-dims-b
- (lambda (j)
- (set! s 0)
- (do-times
- n-bound-dims
- (lambda (k)
- (set! s (+ s (* (array-ref ac (+ i-k k))
- (array-ref bc (+ (* n-free-dims-b k) j)))))))
- (array-set! rc s (+ i-j j)))))))
- r))
-
-;;;; utilities that work on both numbers and arrays
-
-(define (extend f)
- "Extend a function of one or more scalars to apply to numbers/arrays
-element-wise. All arrays must have the same dimension."
- (define (apply-elemwise f indices args)
- (apply f (map (lambda (x)
- (if (number? x)
- x
- (apply array-ref x indices)))
- args)))
- (lambda xs
- (if-let (x (find array? xs))
- (apply
- produce-typed-array
- (lambda is
- (apply-elemwise f is xs))
- *atype*
- (array-dimensions x))
- (apply f xs))))
-
-(define (dot x y n)
- (cond
- ((and (number? x) (number? y))
- (* x y))
- ((and (array? x) (array? y))
- (contract-arrays x y n))
- ((and (array? x) (number? y))
- ((extend *) x y))
- ((and (number? x) (array? y))
- ((extend *) x y))
- (else (error "can't dot because of invalid types or ranks" x y n))))
-
-(define (rank-of x)
- (if (number? x)
- 0
- (array-rank x)))
-
-;;;; differentiation
-
-(define-record-type internal
- (make-internal forward jacobian)
- internal?
- (forward internal-forward)
- (jacobian internal-jacobian))
-
-;;(define *atype* 'f32)
-(define *atype* #t)
-(define *differentiation-mode* (make-parameter #f))
-(define *n-y-dims* (make-parameter #f))
-(define *j* (make-parameter #f))
-
-(define-syntax-rule (w/j val body ...)
- (parameterize ((*j* val))
- body ...))
-
-(define (wrap axis)
- (lambda (x i)
- (if (= i axis)
- (make-internal x 'input)
- x)))
-
-(define (unwrap-fwd x)
- (if (internal? x)
- (internal-forward x)
- x))
-
-(define (unwrap-jac x)
- (if (internal? x)
- (internal-jacobian x)
- x))
-
-(define (dims-of x)
- (if (number? x)
- '()
- (array-dimensions x)))
-
-(define (add dst-buf src-buf n-dims)
- (do-times
- n-dims
- (lambda (i)
- (array-set!
- dst-buf
- (+ (array-ref dst-buf i)
- (array-ref src-buf i))
- i)))
- dst-buf)
-
-(define (movg dst-buf n-dst-dims generator naked-inputs data j)
- (do-times
- n-dst-dims
- (lambda (i)
- (array-set!
- dst-buf
- (apply generator naked-inputs i j data)
- i)))
- dst-buf)
-
-(define (addg dst-buf n-dst-dims generator naked-inputs data j)
- (do-times
- n-dst-dims
- (lambda (i)
- (array-set!
- dst-buf
- (+ (array-ref dst-buf i)
- (apply generator naked-inputs i j data))
- i)))
- dst-buf)
-
-(define (movc dst-buf n-dst-dims src-buf n-src-dims
- generator naked-inputs data)
- "Contract the Jacobian column produced by the generator with the source buffer
-storing the result in the destination buffer."
- (let ((s 0))
- (do-times
- n-dst-dims
- (lambda (i)
- (set! s 0)
- (do-times
- n-src-dims
- (lambda (k)
- (set! s (+ s (* (apply generator naked-inputs i k data)
- (array-ref src-buf k))))))
- (array-set! dst-buf s i))))
- dst-buf)
-
-(define (addc dst-buf n-dst-dims src-buf n-src-dims
- generator naked-inputs data)
- "Contract the Jacobian column produced by the generator with the source buffer
-adding the result to the destination buffer."
- (let ((s 0))
- (do-times
- n-dst-dims
- (lambda (i)
- (set! s (array-ref dst-buf i))
- (do-times
- n-src-dims
- (lambda (k)
- (set! s (+ s (* (apply generator naked-inputs i k data)
- (array-ref src-buf k))))))
- (array-set! dst-buf s i))))
- dst-buf)
-
-(define (transpose-generator generator)
- (lambda (xs i j . data)
- (apply generator xs j i data)))
-
-(define* (fdiff f #:optional (axis 0))
- (lambda xs
- (parameterize (((@@ (vouivre autodiff) *differentiation-mode*) 'fwd)
- ((@@ (vouivre autodiff) *promises*) (cons '() #f)))
- (let* ((internal (apply f (map-indexed (wrap axis) xs)))
- (fx (internal-forward internal))
- (y (list-ref xs axis)) ; variable to differentiate w.r.t
- (pre-Jx (internal-jacobian internal))
- (Jx (cond
- ;; TODO: implement 'input case and test 'zero and 'input
- ((eq? pre-Jx 'zero)
- (lambda (j)
- (lambda (i)
- 0)))
- ((eq? pre-Jx 'input)
- (error "TBD."))
- (else
- (lambda (j)
- (reset-promises (car (*promises*)))
- (let ((column-jac (w/j j (force pre-Jx))))
- (lambda (i)
- (array-ref column-jac i))))))))
- (cond
- ((and (number? fx) (number? y))
- ((Jx 0) 0))
- ((and (number? fx) (array? y))
- (let* ((y-dims (array-dimensions y))
- (a (apply make-array *unspecified* y-dims))
- (ac (array-contents a)))
- (do-times
- (apply * y-dims)
- (lambda (j)
- (array-set! ac ((Jx j) 0)
- j)))
- a))
- ((and (array? fx) (number? y))
- (let* ((fx-dims (array-dimensions fx))
- (a (apply make-array *unspecified* fx-dims))
- (ac (array-contents a))
- (Jx (Jx 0)))
- (do-times
- (apply * fx-dims)
- (lambda (i)
- (array-set! ac (Jx i)
- i)))
- a))
- (else
- (let* ((fx-dims (array-dimensions fx))
- (y-dims (array-dimensions y))
- (n-fx-dims (apply * fx-dims))
- (n-y-dims (apply * y-dims))
- (a (apply make-array *unspecified* (append fx-dims y-dims)))
- (ac (array-contents a)))
- (do-times
- n-y-dims
- (lambda (j)
- (let ((Jx (Jx j)))
- (do-times
- n-fx-dims
- (lambda (i)
- (array-set! ac (Jx i)
- (+ j (* n-y-dims i))))))))
- a)))))))
-
-(define* (rdiff f #:optional (axis 0))
- (lambda xs
- (parameterize (((@@ (vouivre autodiff) *differentiation-mode*) 'rev)
- ((@@ (vouivre autodiff) *promises*) (cons '() #f)))
- (let* ((internal (apply f (map-indexed (wrap axis) xs)))
- (fx (internal-forward internal))
- (y (list-ref xs axis)) ; variable to differentiate w.r.t
- (y-dims (dims-of y))
- (pre-Jx (internal-jacobian internal))
- (Jx (cond
- ;; TODO: implement 'input case and test 'zero and 'input
- ((eq? pre-Jx 'zero)
- (lambda (i)
- (lambda (j)
- 0)))
- ((eq? pre-Jx 'input)
- (error "TBD."))
- (else
- (let ((pre-Jx (pre-Jx #f)))
- (lambda (i)
- (let ((row-jac (pre-Jx i)))
- (lambda (j)
- (array-ref row-jac j)))))))))
- (parameterize ((*n-y-dims* (apply * y-dims)))
- (cond
- ((and (number? fx) (number? y))
- ((Jx 0) 0))
- ((and (number? fx) (array? y))
- (let* ((a (apply make-array *unspecified* y-dims))
- (ac (array-contents a))
- (Jx (Jx 0)))
- (do-times
- (*n-y-dims*)
- (lambda (j)
- (array-set! ac (Jx j)
- j)))
- a))
- ((and (array? fx) (number? y))
- (let* ((fx-dims (array-dimensions fx))
- (a (apply make-array *unspecified* fx-dims))
- (ac (array-contents a)))
- (do-times
- (apply * fx-dims)
- (lambda (i)
- (array-set! ac ((Jx i) 0)
- i)))
- a))
- (else
- (let* ((fx-dims (array-dimensions fx))
- (n-fx-dims (apply * fx-dims))
- (a (apply make-array *unspecified* (append fx-dims y-dims)))
- (ac (array-contents a)))
- (do-times
- n-fx-dims
- (lambda (i)
- (let ((Jx (Jx i)))
- (do-times
- (*n-y-dims*)
- (lambda (j)
- (array-set! ac (Jx j)
- (+ j (* (*n-y-dims*) i))))))))
- a))))))))
-
-;; In the comment that follows:
-;;
-;; `n' is the number of arguments to `proc'.
-;; `generators is not a `Vec' but a `List' we only use the former to illustrate
-;; its length.
-;; `X1', ..., `Xn' are the types of inputs and thus `Array's of some dimension.
-;; `I' is the type of multi-indices indexing the output of `function'.
-;; `J' is the type of multi-indices indexing the input array being differentiated.
-;; `|I|' (resp. `|J|') is the type of absolute indices of `I' (resp. `J').
-;; `Array I' is the type of arrays indexed by multi-indices of `I'.
-;; `[X]' means that `X' is boxed in an internal as when returned by
-;; `differentiable-wrapper' with the array being `X' and the promise that
-;; given a |J| we will get the change of `X' with a change of the
-;; the differentiated argument at multi-index `J'.
-;; (∷ (→ (Vec n (→ X1 ... Xn |I| |J| Number))
-;; (→ X1 ... Xn (Array I))*
-;; [X1] ... [Xn]
-;; (Internal (Array I) (Promise |J| (Array |I|)))))
-;;
-;; (*) We extend this definition to allow `proc' to be a list of procedures
-;; the head of which is as described above and the remaining elements
-;; are procedures of the same arguments but returning values that are
-;; then fed as extra data to the generators.
-;;
-;; NOTE: In cases where an argument isn't meant to be differentiable its
-;; corresponding generator should be `#f'.
-(define (differentiable-wrapper generators proc* arg . more)
- (define (precompute-data naked-args)
- (if (procedure? proc*)
- '()
- (map (lambda (g)
- (apply g naked-args))
- (cdr proc*))))
- (let* ((args (cons arg more))
- (proc (if (procedure? proc*)
- proc*
- (car proc*)))
- (naked-args (map unwrap-fwd args))
- (out (apply proc naked-args)))
- (case (*differentiation-mode*)
- ((#f)
- out)
- ((fwd)
- (let* ((data (precompute-data naked-args))
- (n-out-dims (apply * (dims-of out)))
- (buf (make-array *unspecified* n-out-dims)))
- (make-internal
- out
- (fold
- (lambda (generator arg prev)
- (if (or (not (internal? arg))
- (eq? 'zero (internal-jacobian arg)))
- prev
- (let ((Jx (internal-jacobian arg))
- (n-fwd-dims (apply * (dims-of (unwrap-fwd arg)))))
- (if (eq? Jx 'input)
- (if (eq? prev 'zero)
- (delay
- (movg buf n-out-dims
- generator naked-args data (*j*)))
- (delay
- (addg (force prev) n-out-dims
- generator naked-args data (*j*))))
- (if (eq? prev 'zero)
- (delay
- (movc buf n-out-dims (force Jx) n-fwd-dims
- generator naked-args data))
- (delay
- (addc (force prev) n-out-dims
- (force Jx) n-fwd-dims
- generator naked-args data)))))))
- 'zero generators args))))
- ((rev)
- (let ((data (precompute-data naked-args))
- (n-out-dims (apply * (dims-of out))))
- (make-internal
- out
- (fold
- (lambda (generator arg prev)
- (let ((generator (transpose-generator generator)))
- (if (or (not (internal? arg))
- (eq? 'zero (internal-jacobian arg)))
- prev
- (let* ((Jx (internal-jacobian arg))
- (n-fwd-dims (apply * (dims-of (unwrap-fwd arg)))))
- (if (eq? Jx 'input)
- (if (eq? prev 'zero)
- (lambda (buf?)
- (let ((dst-buf (make-array *unspecified*
- n-fwd-dims)))
- (if buf?
- (lambda (buf)
- (movc dst-buf n-fwd-dims
- buf n-out-dims
- generator naked-args data))
- (lambda (i)
- (movg dst-buf n-fwd-dims
- generator naked-args data
- i)))))
- (lambda (buf?)
- (let ((prev (prev buf?)))
- (if buf?
- (lambda (buf)
- (addc (prev buf) n-fwd-dims
- buf n-out-dims
- generator naked-args data))
- (lambda (i)
- (addg (prev i) n-fwd-dims
- generator naked-args data
- i))))))
- (if (eq? prev 'zero)
- (lambda (buf?)
- (let ((Jx (Jx #t))
- (dst-buf (make-array *unspecified*
- n-fwd-dims)))
- (if buf?
- (lambda (buf)
- (Jx
- (movc dst-buf n-fwd-dims buf
- n-out-dims
- generator naked-args data)))
- (lambda (i)
- (Jx
- (movg dst-buf n-fwd-dims
- generator naked-args data
- i))))))
- (lambda (buf?)
- (let ((prev (prev buf?))
- (Jx (Jx #t))
- (dst-buf (make-array *unspecified*
- n-fwd-dims)))
- (if buf?
- (lambda (buf)
- (add (prev buf)
- (Jx
- (movc dst-buf n-fwd-dims
- buf n-out-dims
- generator naked-args data))
- (*n-y-dims*)))
- (lambda (i)
- (add (prev i)
- (Jx
- (movg dst-buf n-fwd-dims
- generator naked-args data
- i))
- (*n-y-dims*))))))))))))
- 'zero generators args)))))))
-
-(define (ewise1 f)
- (lambda (xs i j)
- (let ((x (car xs)))
- (if (number? x)
- (f x)
- (ifn (= i j)
- 0
- (f (array-ref (array-contents x)
- j)))))))
-
-(define (ewise2 proc axis)
- (lambda (xs i j)
- (let ((x (car xs))
- (y (cadr xs)))
- (cond
- ((and (number? x) (number? y))
- (proc x y))
- ((and (number? x) (array? y))
- (if (= axis 0)
- (proc x (array-ref (array-contents y)
- i))
- (ifn (= i j)
- 0
- (proc x (array-ref (array-contents y)
- j)))))
- ((and (array? x) (number? y))
- (if (= axis 1)
- (proc (array-ref (array-contents x)
- i)
- y)
- (ifn (= i j)
- 0
- (proc (array-ref (array-contents x)
- j)
- y))))
- (else
- (ifn (= i j)
- 0
- (proc (array-ref (array-contents x)
- j)
- (array-ref (array-contents y)
- j))))))))
-
-(define (i:identity x)
- "Differentiable identity."
- (differentiable-wrapper
- (list (ewise1 (lambda _ 1)))
- identity
- x))
-
-(define (i:sqrt x)
- "Differentiable square root."
- (differentiable-wrapper
- (list (ewise1 (lambda (x) (/ 1 2 (sqrt x)))))
- (extend sqrt)
- x))
-
-(define (i:exp x)
- "Differentiable exponential."
- (differentiable-wrapper
- (list (ewise1 exp))
- (extend exp)
- x))
-
-(define (i:expt x y)
- "Differentiable power."
- (differentiable-wrapper
- (list (ewise2 (lambda (x y) (* y (expt x (1- y)))) 0)
- (ewise2 (lambda (x y) (* (expt x y) (log x))) 1))
- (extend expt)
- x y))
-
-(define (i:log x)
- "Differentiable logarithm."
- (differentiable-wrapper
- (list (ewise1 (lambda (x) (/ x))))
- (extend log)
- x))
-
-(define (i:sin x)
- "Differentiable sine."
- (differentiable-wrapper
- (list (ewise1 cos))
- (extend sin)
- x))
-
-(define (i:cos x)
- "Differentiable cosine."
- (differentiable-wrapper
- (list (ewise1 (lambda (x) (- (sin x)))))
- (extend cos)
- x))
-
-(define (i:tan x)
- "Differentiable tangent."
- (differentiable-wrapper
- (list (ewise1 (lambda (x) (/ (expt (cos x) 2)))))
- (extend tan)
- x))
-
-(define (i:+ x y)
- "Differentiable element-wise addition."
- (differentiable-wrapper
- (list
- (ewise2 (lambda _ +1) 0)
- (ewise2 (lambda _ +1) 1))
- (extend +)
- x y))
-
-(define (i:- x y)
- "Differentiable element-wise subtraction."
- (differentiable-wrapper
- (list
- (ewise2 (lambda _ +1) 0)
- (ewise2 (lambda _ -1) 1))
- (extend -)
- x y))
-
-(define (i:* x y)
- "Differentiable element-wise multiplication."
- (differentiable-wrapper
- (list
- (ewise2 (lambda (x y) y) 0)
- (ewise2 (lambda (x y) x) 1))
- (extend *)
- x y))
-
-(define (i:/ x y)
- "Differentiable element-wise division."
- (differentiable-wrapper
- (list
- (ewise2 (lambda (x y) (/ y)) 0)
- (ewise2 (lambda (x y) (- (/ x y y))) 1))
- (extend /)
- x y))
-
-(define (i:max x y)
- "Differentiable element-wise maximum."
- (define (dmax x y)
- (cond
- ((> x y)
- 1)
- ((= x y)
- 1/2)
- (else
- 0)))
- (differentiable-wrapper
- (list
- (ewise2 dmax 0)
- (ewise2 (flip dmax) 1))
- (extend max)
- x y))
-
-(define (i:min x y)
- "Differentiable element-wise minimum."
- (define (dmin x y)
- (cond
- ((< x y)
- 1)
- ((= x y)
- 1/2)
- (else
- 0)))
- (differentiable-wrapper
- (list
- (ewise2 dmin 0)
- (ewise2 (flip dmin) 1))
- (extend min)
- x y))
-
-(define (i:abs x)
- "Differentiable absolute."
- (differentiable-wrapper
- (list (ewise1 (lambda (x)
- (cond ((> x 0)
- +1)
- ((= x 0)
- 1/2)
- ((< x 0)
- -1)))))
- (extend abs)
- x))
-
-(define (mean x)
- "Differentiable mean on arrays."
- (differentiable-wrapper
- (list
- (lambda (xs i j one-over-n)
- one-over-n))
- (let ((n 0))
- (list
- (lambda (x)
- (let ((sum 0))
- (array-for-each
- (lambda (x)
- (set! sum (+ sum x))
- (set! n (1+ n)))
- x)
- (/ sum n)))
- (lambda _ (/ n))))
- x))
-
-(define (i:array-ref x . indices)
- "Differentiable array-ref w.r.t `x'."
- (apply
- differentiable-wrapper
- (cons
- (lambda (xs i j abs-index)
- (if (= j abs-index)
- 1
- 0))
- (map not indices))
- (list
- array-ref
- (lambda (x . indices)
- (rel->abs indices (array-dimensions x))))
- x indices))
-
-(define (i:array-cell-ref x . indices)
- (apply
- differentiable-wrapper
- (cons
- (lambda (xs i j abs-index n-rst-dims)
- (receive (j-ref j-rst) (euclidean/ j n-rst-dims)
- (if (and (= j-ref abs-index)
- (= j-rst i))
- 1
- 0)))
- (map not indices))
- (list
- array-cell-ref
- (lambda (x . indices)
- (rel->abs indices (take (array-dimensions x)
- (length indices))))
- (lambda (x . indices)
- (apply * (drop (array-dimensions x)
- (length indices)))))
- x indices))
-
-(define (make-batch elem . more)
- (let ((batch-size (1+ (length more))))
- (apply
- differentiable-wrapper
- (list-tabulate
- batch-size
- (lambda (b)
- (lambda (xs i j n-rest-dims)
- (receive (i-batch i-rest) (euclidean/ i n-rest-dims)
- (if (and (= i-batch b)
- (= i-rest j))
- 1
- 0
- )))))
- (list
- (lambda (elem . more)
- (let ((a (apply make-typed-array *atype* *unspecified* batch-size
- (dims-of elem))))
- (for-each
- (lambda (x b)
- (array-cell-set! a x b))
- (cons elem more)
- (list-tabulate batch-size identity))
- a))
- (lambda (elem . more)
- (apply * (dims-of elem))))
- elem more)))
-
-(define (maximum x)
- "Differentiable maximum on arrays."
- (differentiable-wrapper
- (list
- (lambda (xs i j max-index)
- (if (= j max-index)
- 1
- 0)))
- (let ((max-index 'TBD))
- (list
- (lambda (x)
- (let ((m (- (inf)))
- (i 0))
- (array-for-each
- (lambda (x)
- (when (< m x)
- (set! m x)
- (set! max-index i))
- (set! i (1+ i)))
- x)
- m))
- (lambda _ max-index)))
- x))
-
-(define (sum x)
- "Differentiable sum on arrays."
- (differentiable-wrapper
- (list (lambda _ 1))
- (lambda (x)
- (let ((sum 0))
- (array-for-each
- (lambda (x)
- (set! sum (+ sum x)))
- x)
- sum))
- x))
-
-(define (adot x y n)
- (differentiable-wrapper
- (list
- (lambda (xs i j n-free-dims-y n-bound-dims)
- (receive (i-x i-y) (euclidean/ i n-free-dims-y)
- (receive (j-free j-bound) (euclidean/ j n-bound-dims)
- (ifn (= i-x j-free)
- 0
- (array-ref (array-contents (cadr xs))
- (+ i-y (* n-free-dims-y j-bound)))))))
- (lambda (xs i j n-free-dims-y n-bound-dims)
- (receive (i-x i-y) (euclidean/ i n-free-dims-y)
- (receive (j-bound j-free) (euclidean/ j n-free-dims-y)
- (ifn (= i-y j-free)
- 0
- (array-ref (array-contents (car xs))
- (+ j-bound (* n-bound-dims i-x)))))))
- #f)
- (list
- contract-arrays
- (lambda (x y n)
- (apply * (drop (array-dimensions y)
- n)))
- (lambda (x y n)
- (apply * (take (array-dimensions y)
- n))))
- x y n))
-
-(define (amap2 f x y)
- (apply make-batch
- (list-tabulate (car (dims-of (unwrap-fwd x)))
- (lambda (b)
- (f (i:array-cell-ref x b)
- (i:array-cell-ref y b))))))
+++ /dev/null
-;;;; Copyright (C) 2023 Vouivre Digital Corporation
-;;;;
-;;;; This file is part of Vouivre.
-;;;;
-;;;; Vouivre is free software: you can redistribute it and/or
-;;;; modify it under the terms of the GNU General Public
-;;;; License as published by the Free Software Foundation, either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; Vouivre is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public
-;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
-
-(define-module (vouivre base)
- #:use-module ((guile) #:select (1+) #:prefix guile:)
- #:use-module ((rnrs base) #:prefix rnrs:)
- #:use-module ((srfi srfi-1) #:prefix srfi-1:)
- #:use-module (vouivre curry)
- #:export
- (∘
- ⊙
- flip)
- #:replace
- (boolean?
- not
- symbol?
- symbol->string
- string->symbol
- char?
- char=?
- char<?
- char>?
- char<=?
- char>=?
- integer->char
- char->integer
- list?
- null?
- pair?
- cons
- car
- cdr
- caar
- cadr
- cdar
- cddr
- caaar
- cadar
- cdaar
- caddr
- cdadr
- cddar
- cdddr
- caaaar
- caaadr
- caadar
- cadaar
- cdaaar
- cddaar
- cdadar
- cdaadr
- cadadr
- caaddr
- caddar
- cadddr
- cdaddr
- cddadr
- cdddar
- cddddr
- number?
- string?
- procedure?
- eq?
- eqv?
- equal?
- symbol=?
- complex?
- real-part
- imag-part
- make-rectangular
- make-polar
- magnitude
- angle
- sqrt
- exp
- expt
- log
- sin
- cos
- tan
- asin
- acos
- atan
- real?
- rational?
- numerator
- denominator
- rationalize
- exact?
- inexact?
- integer?
- odd?
- even?
- gcd
- lcm
- exact-integer-sqrt
- =
- <
- >
- <=
- >=
- zero?
- positive?
- negative?
- length
- list-ref
- list-tail
- append
- reverse
- number->string
- string->number
- make-string
- list->string
- string->list
- string-length
- string-ref
- string-copy
- substring
- string=?
- string<?
- string>?
- string<=?
- string>=?
- string-append
- +
- -
- *
- /
- max
- min
- abs
- truncate
- floor
- ceiling
- round
- div
- mod
- real-valued?
- rational-valued?
- integer-valued?
- nan?
- infinite?
- finite?
- fold
- fold-right
- reduce
- reduce-right
- map
- 1+
- identity))
-
-;; abbreviation
-(define-syntax cudefine (identifier-syntax curried-untyped-define))
-
-(∷ boolean? (0 . 0))
-(cudefine (boolean? x) (rnrs:boolean? x))
-
-(∷ not (0 . 0))
-(cudefine (not x) (rnrs:not x))
-
-(∷ symbol? (0 . 0))
-(cudefine (symbol? x) (rnrs:symbol? x))
-
-(∷ symbol->string (0 . 0))
-(cudefine (symbol->string x) (rnrs:symbol->string x))
-
-(∷ string->symbol (0 . 0))
-(cudefine (string->symbol x) (rnrs:string->symbol x))
-
-(∷ char? (0 . 0))
-(cudefine (char? x) (rnrs:char? x))
-
-(∷ char=? (0 . (0 . 0)))
-(cudefine (char=? x y) (rnrs:char=? x y))
-
-(∷ char<? (0 . (0 . 0)))
-(cudefine (char<? x y) (rnrs:char<? x y))
-
-(∷ char>? (0 . (0 . 0)))
-(cudefine (char>? x y) (rnrs:char>? x y))
-
-(∷ char<=? (0 . (0 . 0)))
-(cudefine (char<=? x y) (rnrs:char<=? x y))
-
-(∷ char>=? (0 . (0 . 0)))
-(cudefine (char>=? x y) (rnrs:char>=? x y))
-
-(∷ integer->char (0 . 0))
-(cudefine (integer->char x) (rnrs:integer->char x))
-
-(∷ char->integer (0 . 0))
-(cudefine (char->integer x) (rnrs:char->integer x))
-
-(∷ list? (0 . 0))
-(cudefine (list? x) (rnrs:list? x))
-
-(∷ null? (0 . 0))
-(cudefine (null? x) (rnrs:null? x))
-
-(∷ pair? (0 . 0))
-(cudefine (pair? x) (rnrs:pair? x))
-
-(∷ cons (0 . (0 . 0)))
-(cudefine (cons x y) (rnrs:cons x y))
-
-(∷ car (0 . 0))
-(cudefine (car x) (rnrs:car x))
-
-(∷ cdr (0 . 0))
-(cudefine (cdr x) (rnrs:cdr x))
-
-(∷ caar (0 . 0))
-(cudefine (caar x) (rnrs:caar x))
-
-(∷ cadr (0 . 0))
-(cudefine (cadr x) (rnrs:cadr x))
-
-(∷ cdar (0 . 0))
-(cudefine (cdar x) (rnrs:cdar x))
-
-(∷ cddr (0 . 0))
-(cudefine (cddr x) (rnrs:cddr x))
-
-(∷ caaar (0 . 0))
-(cudefine (caaar x) (rnrs:caaar x))
-
-(∷ caadr (0 . 0))
-(cudefine (caadr x) (rnrs:caadr x))
-
-(∷ cadar (0 . 0))
-(cudefine (cadar x) (rnrs:cadar x))
-
-(∷ cdaar (0 . 0))
-(cudefine (cdaar x) (rnrs:cdaar x))
-
-(∷ caddr (0 . 0))
-(cudefine (caddr x) (rnrs:caddr x))
-
-(∷ cdadr (0 . 0))
-(cudefine (cdadr x) (rnrs:cdadr x))
-
-(∷ cddar (0 . 0))
-(cudefine (cddar x) (rnrs:cddar x))
-
-(∷ cdddr (0 . 0))
-(cudefine (cdddr x) (rnrs:cdddr x))
-
-(∷ caaaar (0 . 0))
-(cudefine (caaaar x) (rnrs:caaaar x))
-
-(∷ caaadr (0 . 0))
-(cudefine (caaadr x) (rnrs:caaadr x))
-
-(∷ caadar (0 . 0))
-(cudefine (caadar x) (rnrs:caadar x))
-
-(∷ cadaar (0 . 0))
-(cudefine (cadaar x) (rnrs:cadaar x))
-
-(∷ cdaaar (0 . 0))
-(cudefine (cdaaar x) (rnrs:cdaaar x))
-
-(∷ cddaar (0 . 0))
-(cudefine (cddaar x) (rnrs:cddaar x))
-
-(∷ cdadar (0 . 0))
-(cudefine (cdadar x) (rnrs:cdadar x))
-
-(∷ cdaadr (0 . 0))
-(cudefine (cdaadr x) (rnrs:cdaadr x))
-
-(∷ cadadr (0 . 0))
-(cudefine (cadadr x) (rnrs:cadadr x))
-
-(∷ caaddr (0 . 0))
-(cudefine (caaddr x) (rnrs:caaddr x))
-
-(∷ caddar (0 . 0))
-(cudefine (caddar x) (rnrs:caddar x))
-
-(∷ cadddr (0 . 0))
-(cudefine (cadddr x) (rnrs:cadddr x))
-
-(∷ cdaddr (0 . 0))
-(cudefine (cdaddr x) (rnrs:cdaddr x))
-
-(∷ cddadr (0 . 0))
-(cudefine (cddadr x) (rnrs:cddadr x))
-
-(∷ cdddar (0 . 0))
-(cudefine (cdddar x) (rnrs:cdddar x))
-
-(∷ cddddr (0 . 0))
-(cudefine (cddddr x) (rnrs:cddddr x))
-
-(∷ number? (0 . 0))
-(cudefine (number? x) (rnrs:number? x))
-
-(∷ string? (0 . 0))
-(cudefine (string? x) (rnrs:string? x))
-
-(∷ procedure? (0 . 0))
-(cudefine (procedure? x) (rnrs:procedure? x))
-
-(∷ eq? (0 . (0 . 0)))
-(cudefine (eq? x y) (rnrs:eq? x y))
-
-(∷ eqv? (0 . (0 . 0)))
-(cudefine (eqv? x y) (rnrs:eqv? x y))
-
-(∷ equal? (0 . (0 . 0)))
-(cudefine (equal? x y) (rnrs:equal? x y))
-
-(∷ symbol=? (0 . (0 . 0)))
-(cudefine (symbol=? x y) (rnrs:symbol=? x y))
-
-(∷ complex? (0 . 0))
-(cudefine (complex? x) (rnrs:complex? x))
-
-(∷ real-part (0 . 0))
-(cudefine (real-part x) (rnrs:real-part x))
-
-(∷ imag-part (0 . 0))
-(cudefine (imag-part x) (rnrs:imag-part x))
-
-(∷ make-rectangular (0 . (0 . 0)))
-(cudefine (make-rectangular x y) (rnrs:make-rectangular x y))
-
-(∷ make-polar (0 . (0 . 0)))
-(cudefine (make-polar x y) (rnrs:make-polar x y))
-
-(∷ magnitude (0 . 0))
-(cudefine (magnitude x) (rnrs:magnitude x))
-
-(∷ angle (0 . 0))
-(cudefine (angle x) (rnrs:angle x))
-
-(∷ sqrt (0 . 0))
-(cudefine (sqrt x) (rnrs:sqrt x))
-
-(∷ exp (0 . 0))
-(cudefine (exp x) (rnrs:exp x))
-
-(∷ expt (0 . (0 . 0)))
-(cudefine (expt x y) (rnrs:expt x y))
-
-(∷ log (0 . 0))
-(cudefine (log x) (rnrs:log x))
-
-(∷ sin (0 . 0))
-(cudefine (sin x) (rnrs:sin x))
-
-(∷ cos (0 . 0))
-(cudefine (cos x) (rnrs:cos x))
-
-(∷ tan (0 . 0))
-(cudefine (tan x) (rnrs:tan x))
-
-(∷ asin (0 . 0))
-(cudefine (asin x) (rnrs:asin x))
-
-(∷ acos (0 . 0))
-(cudefine (acos x) (rnrs:acos x))
-
-(∷ atan (0 . 0))
-(cudefine (atan x) (rnrs:atan x))
-
-(∷ real? (0 . 0))
-(cudefine (real? x) (rnrs:real? x))
-
-(∷ rational? (0 . 0))
-(cudefine (rational? x) (rnrs:rational? x))
-
-(∷ numerator (0 . 0))
-(cudefine (numerator x) (rnrs:numerator x))
-
-(∷ denominator (0 . 0))
-(cudefine (denominator x) (rnrs:denominator x))
-
-(∷ rationalize (0 . (0 . 0)))
-(cudefine (rationalize x eps) (rnrs:rationalize x eps))
-
-(∷ exact? (0 . 0))
-(cudefine (exact? x) (rnrs:exact? x))
-
-(∷ inexact? (0 . 0))
-(cudefine (inexact? x) (rnrs:inexact? x))
-
-(∷ integer? (0 . 0))
-(cudefine (integer? x) (rnrs:integer? x))
-
-(∷ odd? (0 . 0))
-(cudefine (odd? x) (rnrs:odd? x))
-
-(∷ even? (0 . 0))
-(cudefine (even? x) (rnrs:even? x))
-
-(∷ gcd (0 . (0 . 0)))
-(cudefine (gcd x y) (rnrs:gcd x y))
-
-(∷ lcm (0 . (0 . 0)))
-(cudefine (lcm x y) (rnrs:lcm x y))
-
-(∷ exact-integer-sqrt (0 . 0))
-(cudefine (exact-integer-sqrt x) (rnrs:exact-integer-sqrt x))
-
-(∷ = (0 . (0 . 0)))
-(cudefine (= x y) (rnrs:= x y))
-
-(∷ < (0 . (0 . 0)))
-(cudefine (< x y) (rnrs:< x y))
-
-(∷ > (0 . (0 . 0)))
-(cudefine (> x y) (rnrs:> x y))
-
-(∷ <= (0 . (0 . 0)))
-(cudefine (<= x y) (rnrs:<= x y))
-
-(∷ >= (0 . (0 . 0)))
-(cudefine (>= x y) (rnrs:>= x y))
-
-(∷ zero? (0 . 0))
-(cudefine (zero? x) (rnrs:zero? x))
-
-(∷ positive? (0 . 0))
-(cudefine (positive? x) (rnrs:positive? x))
-
-(∷ negative? (0 . 0))
-(cudefine (negative? x) (rnrs:negative? x))
-
-(∷ length (0 . 0))
-(cudefine (length x) (rnrs:length x))
-
-(∷ list-ref (0 . (0 . 0)))
-(cudefine (list-ref lst k) (rnrs:list-ref lst k))
-
-(∷ list-tail (0 . (0 . 0)))
-(cudefine (list-tail lst k) (rnrs:list-tail lst k))
-
-(∷ append (0 . (0 . 0)))
-(cudefine (append x y) (rnrs:append x y))
-
-(∷ reverse (0 . 0))
-(cudefine (reverse x) (rnrs:reverse x))
-
-(∷ number->string (0 . (0 . 0)))
-(cudefine (number->string n radix) (rnrs:number->string n radix))
-
-(∷ string->number (0 . (0 . 0)))
-(cudefine (string->number str radix) (rnrs:string->number str radix))
-
-(∷ make-string (0 . (0 . 0)))
-(cudefine (make-string k char) (rnrs:make-string k char))
-
-(∷ list->string (0 . 0))
-(cudefine (list->string x) (rnrs:list->string x))
-
-(∷ string->list (0 . (0 . (0 . 0))))
-(cudefine (string->list str start end) (rnrs:string->list str start end))
-
-(∷ string-length (0 . 0))
-(cudefine (string-length x) (rnrs:string-length x))
-
-(∷ string-ref (0 . (0 . 0)))
-(cudefine (string-ref str k) (rnrs:string-ref str k))
-
-(∷ string-copy (0 . (0 . (0 . 0))))
-(cudefine (string-copy str start end) (rnrs:string-copy str start end))
-
-(∷ substring (0 . (0 . (0 . 0))))
-(cudefine (substring str start end) (rnrs:substring str start end))
-
-(∷ string=? (0 . (0 . 0)))
-(cudefine (string=? x y) (rnrs:string=? x y))
-
-(∷ string<? (0 . (0 . 0)))
-(cudefine (string<? x y) (rnrs:string<? x y))
-
-(∷ string>? (0 . (0 . 0)))
-(cudefine (string>? x y) (rnrs:string>? x y))
-
-(∷ string<=? (0 . (0 . 0)))
-(cudefine (string<=? x y) (rnrs:string<=? x y))
-
-(∷ string>=? (0 . (0 . 0)))
-(cudefine (string>=? x y) (rnrs:string>=? x y))
-
-(∷ string-append (0 . (0 . 0)))
-(cudefine (string-append x y) (rnrs:string-append x y))
-
-(∷ + (0 . (0 . 0)))
-(cudefine (+ x y) (rnrs:+ x y))
-
-(∷ - (0 . (0 . 0)))
-(cudefine (- x y) (rnrs:- x y))
-
-(∷ * (0 . (0 . 0)))
-(cudefine (* x y) (rnrs:* x y))
-
-(∷ / (0 . (0 . 0)))
-(cudefine (/ x y) (rnrs:/ x y))
-
-(∷ max (0 . (0 . 0)))
-(cudefine (max x y) (rnrs:max x y))
-
-(∷ min (0 . (0 . 0)))
-(cudefine (min x y) (rnrs:min x y))
-
-(∷ abs (0 . 0))
-(cudefine (abs x) (rnrs:abs x))
-
-(∷ truncate (0 . 0))
-(cudefine (truncate x) (rnrs:truncate x))
-
-(∷ floor (0 . 0))
-(cudefine (floor x) (rnrs:floor x))
-
-(∷ ceiling (0 . 0))
-(cudefine (ceiling x) (rnrs:ceiling x))
-
-(∷ round (0 . 0))
-(cudefine (round x) (rnrs:round x))
-
-(∷ div (0 . (0 . 0)))
-(cudefine (div x y) (rnrs:div x y))
-
-(∷ mod (0 . (0 . 0)))
-(cudefine (mod x y) (rnrs:mod x y))
-
-(∷ real-valued? (0 . 0))
-(cudefine (real-valued? x) (rnrs:real-valued? x))
-
-(∷ rational-valued? (0 . 0))
-(cudefine (rational-valued? x) (rnrs:rational-valued? x))
-
-(∷ integer-valued? (0 . 0))
-(cudefine (integer-valued? x) (rnrs:integer-valued? x))
-
-(∷ nan? (0 . 0))
-(cudefine (nan? x) (rnrs:nan? x))
-
-(∷ infinite? (0 . 0))
-(cudefine (infinite? x) (rnrs:infinite? x))
-
-(∷ finite? (0 . 0))
-(cudefine (finite? x) (rnrs:finite? x))
-
-(∷ fold ((0 . (0 . 0)) . (0 . (0 . 0))))
-(cudefine (fold f x xs)
- (srfi-1:fold
- (lambda (x prev)
- ((f x) prev))
- x xs))
-
-(∷ fold-right ((0 . (0 . 0)) . (0 . (0 . 0))))
-(cudefine (fold-right f x xs)
- (srfi-1:fold-right
- (lambda (x prev)
- ((f x) prev))
- x xs))
-
-(∷ reduce ((0 . (0 . 0)) . (0 . 0)))
-(cudefine (reduce f xs)
- (when (null? xs)
- (error "empty list"))
- (srfi-1:reduce
- (lambda (x prev)
- ((f x) prev))
- 0
- xs))
-
-(∷ reduce-right ((0 . (0 . 0)) . (0 . 0)))
-(cudefine (reduce-right f xs)
- (when (null? xs)
- (error "empty list"))
- (srfi-1:reduce-right
- (lambda (x prev)
- ((f x) prev))
- 0
- xs))
-
-(∷ map ((0 . 0) . (0 . 0)))
-(cudefine (map f xs) (srfi-1:map f xs))
-
-(∷ 1+ (0 . 0))
-(cudefine (1+ x) (guile:1+ x))
-
-(definec (identity x) x)
-(definec (∘ g f) (λc x (g (f x))))
-(definec (⊙ f g) (∘ g f))
-(definec (flip f) (λc y (λc x (f x y))))
+++ /dev/null
-;;;; Copyright (C) 2023 Vouivre Digital Corporation
-;;;;
-;;;; This file is part of Vouivre.
-;;;;
-;;;; Vouivre is free software: you can redistribute it and/or
-;;;; modify it under the terms of the GNU General Public
-;;;; License as published by the Free Software Foundation, either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; Vouivre is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public
-;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
-
-(define* (b #:optional test)
- (load "misc.scm")
- (load "curry.scm")
- (load "compile-tree-il.scm")
- (load "decompile-tree-il.scm")
- (load "spec.scm")
- (when test
- (load "curry-tests.scm"))
- (values))
-(b)
--- /dev/null
+;;;; test-driver.scm - Guile test driver for Automake testsuite harness
+
+(define script-version "2019-01-15.13") ;UTC
+
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2019 Alex Sassmannshausen <alex@pompo.co>
+;;;
+;;; This program is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Commentary:
+;;;
+;;; This script provides a Guile test driver using the SRFI-64 Scheme API for
+;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9.
+;;;
+;;; This script is a lightly modified version of the orignal written by
+;;; Matthieu Lirzin. The changes make it suitable for use as part of the
+;;; guile-hall infrastructure.
+;;;
+;;;; Code:
+
+(use-modules (ice-9 getopt-long)
+ (ice-9 pretty-print)
+ (srfi srfi-26)
+ (srfi srfi-64))
+
+(define (show-help)
+ (display "Usage:
+ test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
+ [--expect-failure={yes|no}] [--color-tests={yes|no}]
+ [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--]
+ TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
+The '--test-name', '--log-file' and '--trs-file' options are mandatory.
+"))
+
+(define %options
+ '((test-name (value #t))
+ (log-file (value #t))
+ (trs-file (value #t))
+ (color-tests (value #t))
+ (expect-failure (value #t)) ;XXX: not implemented yet
+ (enable-hard-errors (value #t)) ;not implemented in SRFI-64
+ (brief (value #t))
+ (help (single-char #\h) (value #f))
+ (version (single-char #\V) (value #f))))
+
+(define (option->boolean options key)
+ "Return #t if the value associated with KEY in OPTIONS is 'yes'."
+ (and=> (option-ref options key #f) (cut string=? <> "yes")))
+
+(define* (test-display field value #:optional (port (current-output-port))
+ #:key pretty?)
+ "Display 'FIELD: VALUE\n' on PORT."
+ (if pretty?
+ (begin
+ (format port "~A:~%" field)
+ (pretty-print value port #:per-line-prefix "+ "))
+ (format port "~A: ~S~%" field value)))
+
+(define* (result->string symbol #:key colorize?)
+ "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t."
+ (let ((result (string-upcase (symbol->string symbol))))
+ (if colorize?
+ (string-append (case symbol
+ ((pass) "\e[0;32m") ;green
+ ((xfail) "\e[1;32m") ;light green
+ ((skip) "\e[1;34m") ;blue
+ ((fail xpass) "\e[0;31m") ;red
+ ((error) "\e[0;35m")) ;magenta
+ result
+ "\e[m") ;no color
+ result)))
+
+(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port)
+ "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the
+file name of the current the test. COLOR? specifies whether to use colors,
+and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The
+current output port is supposed to be redirected to a '.log' file."
+
+ (define (test-on-test-begin-gnu runner)
+ ;; Procedure called at the start of an individual test case, before the
+ ;; test expression (and expected value) are evaluated.
+ (let ((result (cute assq-ref (test-result-alist runner) <>)))
+ (format #t "test-name: ~A~%" (result 'test-name))
+ (format #t "location: ~A~%"
+ (string-append (result 'source-file) ":"
+ (number->string (result 'source-line))))
+ (test-display "source" (result 'source-form) #:pretty? #t)))
+
+ (define (test-on-test-end-gnu runner)
+ ;; Procedure called at the end of an individual test case, when the result
+ ;; of the test is available.
+ (let* ((results (test-result-alist runner))
+ (result? (cut assq <> results))
+ (result (cut assq-ref results <>)))
+ (unless brief?
+ ;; Display the result of each test case on the console.
+ (format out-port "~A: ~A - ~A~%"
+ (result->string (test-result-kind runner) #:colorize? color?)
+ test-name (test-runner-test-name runner)))
+ (when (result? 'expected-value)
+ (test-display "expected-value" (result 'expected-value)))
+ (when (result? 'expected-error)
+ (test-display "expected-error" (result 'expected-error) #:pretty? #t))
+ (when (result? 'actual-value)
+ (test-display "actual-value" (result 'actual-value)))
+ (when (result? 'actual-error)
+ (test-display "actual-error" (result 'actual-error) #:pretty? #t))
+ (format #t "result: ~a~%" (result->string (result 'result-kind)))
+ (newline)
+ (format trs-port ":test-result: ~A ~A~%"
+ (result->string (test-result-kind runner))
+ (test-runner-test-name runner))))
+
+ (define (test-on-group-end-gnu runner)
+ ;; Procedure called by a 'test-end', including at the end of a test-group.
+ (let ((fail (or (positive? (test-runner-fail-count runner))
+ (positive? (test-runner-xpass-count runner))))
+ (skip (or (positive? (test-runner-skip-count runner))
+ (positive? (test-runner-xfail-count runner)))))
+ ;; XXX: The global results need some refinements for XPASS.
+ (format trs-port ":global-test-result: ~A~%"
+ (if fail "FAIL" (if skip "SKIP" "PASS")))
+ (format trs-port ":recheck: ~A~%"
+ (if fail "yes" "no"))
+ (format trs-port ":copy-in-global-log: ~A~%"
+ (if (or fail skip) "yes" "no"))
+ (when brief?
+ ;; Display the global test group result on the console.
+ (format out-port "~A: ~A~%"
+ (result->string (if fail 'fail (if skip 'skip 'pass))
+ #:colorize? color?)
+ test-name))
+ #f))
+
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-begin! runner test-on-test-begin-gnu)
+ (test-runner-on-test-end! runner test-on-test-end-gnu)
+ (test-runner-on-group-end! runner test-on-group-end-gnu)
+ (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+ runner))
+
+;;;
+;;; Entry point.
+;;;
+
+(define (main . args)
+ (let* ((opts (getopt-long (command-line) %options))
+ (option (cut option-ref opts <> <>)))
+ (cond
+ ((option 'help #f) (show-help))
+ ((option 'version #f) (format #t "test-driver.scm ~A" script-version))
+ (else
+ (let ((log (open-file (option 'log-file "") "w0"))
+ (trs (open-file (option 'trs-file "") "wl"))
+ (out (duplicate-port (current-output-port) "wl")))
+ (redirect-port log (current-output-port))
+ (redirect-port log (current-warning-port))
+ (redirect-port log (current-error-port))
+ (test-with-runner
+ (test-runner-gnu (option 'test-name #f)
+ #:color? (option->boolean opts 'color-tests)
+ #:brief? (option->boolean opts 'brief)
+ #:out-port out #:trs-port trs)
+ (load-from-path (option 'test-name #f)))
+ (close-port log)
+ (close-port trs)
+ (close-port out))))
+ (exit 0)))
+++ /dev/null
-;;; Guile Scheme specification
-
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;;; This file has been modified by Vouivre Digital Corporation. The exact
-;;;; modifications can be seen in a shell using:
-;;;; $ git diff 5226e2890df9a25bd1d33514ff67539da7794905 compile-tree-il.scm
-
-;;; Code:
-
-(define-module (language vouivre compile-tree-il)
- #:use-module (language tree-il)
- #:use-module (srfi srfi-71)
- #:use-module (vouivre curry)
- #:export (compile-tree-il))
-
-;;; environment := MODULE
-
-(define (compile-tree-il x e opts)
- (save-module-excursion
- (lambda ()
- (set-current-module e)
- ;; TODO: Why do we need to use `(@@ (vouivre curry) symtab)' here instead of
- ;; simply `symtab'? If we don't it always return an empty symtab.
- (let ((t expr (expand (@@ (vouivre curry) symtab) (syntax->datum x))))
- (let* ((x (macroexpand expr 'c '(compile load eval)))
- (cenv (current-module)))
- (values x cenv cenv))))))
--- /dev/null
+dnl -*- Autoconf -*-
+
+AC_INIT(vouivre, 0.1.0)
+AC_SUBST(HVERSION, "\"0.1.0\"")
+AC_SUBST(AUTHOR, "\"Vouivre Digital Corporation\"")
+AC_SUBST(COPYRIGHT, "'(2023)")
+AC_SUBST(LICENSE, gpl3+)
+AC_CONFIG_SRCDIR(vouivre.scm)
+AC_CONFIG_AUX_DIR([build-aux])
+AM_INIT_AUTOMAKE([1.12 gnu silent-rules subdir-objects color-tests parallel-tests -Woverride -Wno-portability])
+AM_SILENT_RULES([yes])
+
+AC_CONFIG_FILES([Makefile])
+AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
+
+dnl Search for 'guile' and 'guild'. This macro defines
+dnl 'GUILE_EFFECTIVE_VERSION'.
+GUILE_PKG([3.0 2.2 2.0])
+GUILE_PROGS
+GUILE_SITE_DIR
+if test "x$GUILD" = "x"; then
+ AC_MSG_ERROR(['guild' binary not found; please check your guile-2.x installation.])
+fi
+
+if test "$cross_compiling" != no; then
+ GUILE_TARGET="--target=$host_alias"
+ AC_SUBST([GUILE_TARGET])
+fi
+
+dnl Hall auto-generated guile-module dependencies
+
+
+dnl Installation directories for .scm and .go files.
+guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION"
+guileobjectdir="${libdir}/guile/$GUILE_EFFECTIVE_VERSION/site-ccache"
+AC_SUBST([guilemoduledir])
+AC_SUBST([guileobjectdir])
+
+AC_OUTPUT
+++ /dev/null
-;;;; Copyright (C) 2023 Vouivre Digital Corporation
-;;;;
-;;;; This file is part of Vouivre.
-;;;;
-;;;; Vouivre is free software: you can redistribute it and/or
-;;;; modify it under the terms of the GNU General Public
-;;;; License as published by the Free Software Foundation, either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; Vouivre is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public
-;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
-
-(define-module (vouivre curry tests)
- #:use-module (vouivre curry)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-64)
- #:use-module (srfi srfi-71))
-
-(test-begin "curry")
-;; TODO: map the reduxtab to a bare version for unit-testing
-;; (test-assert
-;; (lset=
-;; 'equal?
-;; '((1 . (2 . 4)) (2 . 2) (3 . 2))
-;; (compare
-;; (parse '(1 . (2 . 3)))
-;; (parse '((1 . 2) . (1 . 1))))))
-
-(define-syntax-rule (test-type given expected-bare)
- (test-assert (equal-types? given (parse expected-bare))))
-
-(define (sym-sets symtab alist)
- (fold (lambda (x prev)
- ((@@ (vouivre curry) sym-set) prev (car x) (cdr x)))
- symtab alist))
-
-(let ((t e (expand '() '(λc x x))))
- (test-type t '(1 . 1))
- (test-equal '(lambda (x) x) e))
-(let ((t e (expand '() '(λc g (λc f (λc x (g (f x))))))))
- (test-type t '((3 . 4) . ((2 . 3) . (2 . 4))))
- (test-equal '(lambda (g) (lambda (f) (lambda (x) (g (f x))))) e))
-(let ((t e (expand '() '((λc x x) #t))))
- (test-type t 0)
- (test-equal #t (primitive-eval e)))
-(let ((bindings
- (sym-sets
- '()
- `((id . ,(parse '(1 . 1)))
- (∘ . ,(parse '((2 . 3) . ((1 . 2) . (1 . 3)))))
- (⊙ . ,(parse '((1 . 2) . ((2 . 3) . (1 . 3)))))
- (map . ,(parse '((0 . 0) . (0 . 0))))
- (+ . ,(parse '(0 . (0 . 0))))))))
- (let ((t e (expand bindings '(∘ id id))))
- (test-type t '(7 . 7))
- (test-equal e '((∘ id) id)))
- (let ((t e (expand bindings '((∘ id id) #t))))
- (test-type t 0)
- (test-equal e '(((∘ id) id) #t)))
- (let ((t e (expand bindings '(∘ id id #t))))
- (test-type t 0)
- (test-equal e '(((∘ id) id) #t)))
- (let ((t e (expand bindings '(λc f (∘ f)))))
- (test-type t '((2 . 3) . ((1 . 2) . (1 . 3)))))
- (let ((t e (expand bindings '(map (+ 1) '(1 2 3)))))
- (test-type t 0)
- (test-equal e '((map (+ 1)) '(1 2 3))))
- (let ((t e (expand bindings '(∘ +))))
- (test-type t '((1 . 0) . (1 . (0 . 0))))
- (test-equal e '(∘ +)))
- (let ((t e (expand bindings '((∘ +) (+ 1) 2 3))))
- (test-type t 0)
- (test-equal e '((((∘ +) (+ 1)) 2) 3)))
- (let ((t e (expand bindings '((∘ + (+ 1)) 2 3))))
- (test-type t 0)
- (test-equal e '((((∘ +) (+ 1)) 2) 3)))
- (let ((t e (expand bindings '(((∘ + (+ 1)) 2) 3))))
- (test-type t 0)
- (test-equal e '((((∘ +) (+ 1)) 2) 3)))
- (let ((t e (expand bindings '((∘ (∘ (+ 1)) +) 2 3))))
- (test-type t 0)
- (test-equal e '((((∘ (∘ (+ 1))) +) 2) 3)))
- (let ((t e (expand bindings '((∘ (⊙ (+ 1)) +) 2 3))))
- (test-type t 0)
- (test-equal e '((((∘ (⊙ (+ 1))) +) 2) 3))))
-
-;;; interaction between typed and untyped (regular) scheme
-
-;; Untyped scheme produces untyped return.
-(let ((t e (expand '() '(+ 1 2 3))))
- (test-type t #f)
- (test-equal e '(+ 1 2 3)))
-
-(let ((bindings
- (sym-sets
- '()
- `((* . ,(parse '(0 . (0 . 0))))))))
- ;; Typed Scheme can be used by untyped Scheme...
- (let ((t e (expand bindings '(+ 1 (* 2 3) 4))))
- (test-type t #f)
- (test-equal e '(+ 1 ((* 2) 3) 4)))
-
- ;; ... although, sometimes, with terrible runtime consequences!
- (let ((t e (expand bindings '(+ 1 (* 2) 3))))
- (test-type t #f)
- (test-equal e '(+ 1 (* 2) 3)))
-
- ;; On the other hand, typed Scheme expects typed Scheme.
- (test-error (expand bindings '(* 1 (+ 2 3)))))
-
-(test-end "curry")
+++ /dev/null
-;;;; Copyright (C) 2023 Vouivre Digital Corporation
-;;;;
-;;;; This file is part of Vouivre.
-;;;;
-;;;; Vouivre is free software: you can redistribute it and/or
-;;;; modify it under the terms of the GNU General Public
-;;;; License as published by the Free Software Foundation, either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; Vouivre is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public
-;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
-
-(define-module (vouivre curry)
- #:use-module ((ice-9 curried-definitions) :prefix c)
- #:use-module (ice-9 match)
- #:use-module (ice-9 receive)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-64)
- #:use-module (srfi srfi-71)
- #:use-module (vouivre misc)
- #:export
- (curried-untyped-define
- equal-types?
- expand
- parse
- symtab
- type-of
- ∷))
-
-(define symtab '())
-
-(define-record-type node
- (make-node content)
- node?
- (content node-content set-node-content!))
-
-(define (type-error n . args)
- (let ((errors '((0 . TBD)
- (1 . INCOMPATIBLE)
- (2 . BAD-INPUT)
- (3 . BAD-APPLICATION)
- (4 . UNBOUND-SYMBOL)
- (5 . TYPE-EXPECT-TYPES))))
- (apply error "type error" (assoc-ref errors n) args)))
-
-(define (zo? x)
- "Predicate for the zero type."
- (and (number? x) (zero? x)))
-
-(define (tv? x)
- "Predicate for type variables."
- (and (number? x) (positive? x) #t))
-
-;; Return a unique type variable.
-(define next
- (let ((count 1))
- (lambda ()
- (set! count (1+ count))
- (1- count))))
-
-(define (copy-tree node)
- "Return a copy of the tree rooted in `node'."
- (let ((x (node-content node)))
- (if (pair? x)
- (make-node (cons (copy-tree (car x))
- (copy-tree (cdr x))))
- (make-node x))))
-
-(define (map-tree! proc nx)
- "Map `proc' in-place over the content of the leaves of `nx'."
- (let ((x (node-content nx)))
- (if (pair? x)
- (begin
- (map-tree! proc (car x))
- (map-tree! proc (cdr x)))
- (set-node-content! nx (proc x)))
- nx))
-
-(define (compare nx ny)
- ""
- (define (create-reduxtab m)
- ;; Each `x' point (through `mx') to a list `ys' of elements `y' who
- ;; themselves point (through `my') to lists of things equal to `x'.
- ;; We unionize these, sort them, and, bind them as "things equal to `x'".
- (let* ((mx (first m))
- (my (second m))
- (mxf (third m))
- (φ (lambda (x)
- (assoc-ref mx x)))
- (φ* (lambda (y)
- (assoc-ref my y)))
- (Φ* (lambda (ys)
- (apply lset-union eq? (map φ* ys)))))
- (append
- (lset-difference
- (lambda (x y) (eq? (car x) (car y)))
- mxf mx)
- (map
- (match-lambda
- ((x . ys)
- (cons
- x
- (let ((new-x (first (sort-list (Φ* ys) <)))
- (fy (assoc-ref mxf x)))
- (if (and (zo? new-x) fy)
- (type-error 1 new-x fy)
- (if (not fy)
- new-x
- (node-content
- (map-tree!
- (lambda (y)
- (first
- (sort-list
- (or (φ* y)
- (list (next)))
- <)))
- (copy-tree (make-node fy))))))))))
- mx))))
- (define (massoc m x y)
- (define (assoc! m x y)
- (assoc-set! m x (cons y (or (assoc-ref m x) '()))))
- (list (if (and (not (pair? x))
- (not (pair? y)))
- (assoc! (first m) x y)
- (first m))
- (if (and (not (pair? x))
- (not (pair? y)))
- (assoc! (second m) y x)
- (second m))
- (if (not (pair? y))
- (third m)
- (if (assoc-ref (third m) x)
- (type-error 0 "type variable already a function")
- (assoc-set! (third m) x y)))))
- (create-reduxtab
- (let compare% ((m `(()
- ;; 0_x ≡ 0_y (though we only use 0y→0x).
- ;; Also, associations in an alist need to be mutable.
- (,(cons 0 '(0)))
- ()))
- (nx nx)
- (ny ny))
- (let ((x (node-content nx))
- (y (node-content ny)))
- (cond
- ;; same same
- ((eq? nx ny)
- m)
- ((and (not x) (not y))
- m)
- ((and (zo? x) (zo? y))
- m)
- ((and (tv? x) (tv? y))
- (massoc m x y))
- ((and (pair? x) (pair? y))
- (compare% (compare% m (car x) (car y))
- (cdr x) (cdr y)))
- ;; cases with #f
- ((and (zo? x) (not y))
- (set-node-content! ny x)
- m)
- ((and (zo? y) (not x))
- (set-node-content! nx y)
- m)
- ((and (tv? y) (not x))
- (let ((z (next)))
- (set-node-content! nx z)
- (massoc m y z)))
- ((and (tv? x) (not y))
- (let ((z (next)))
- (set-node-content! ny z)
- (massoc m x z)))
- ((and (pair? x) (not y))
- (set-node-content! ny x)
- m)
- ((and (pair? y) (not x))
- (type-error 0 nx ny))
- ;; cases with TVs
- ((and (tv? x) (zo? y))
- (massoc m x y))
- ((and (tv? y) (zo? x))
- (massoc m x y))
- ((and (tv? x) (pair? y))
- (massoc m x y))
- ((and (tv? y) (pair? x))
- (type-error 0 nx ny))
- ;; outright incompatible cases
- ((or (and (zo? x) (pair? y))
- (and (zo? y) (pair? x)))
- (type-error 1 x y))
- ;; bad input
- (else
- (type-error 2 nx ny)))))))
-
-(define (reduce-tvs! reduxtab node)
- (map-tree!
- (lambda (x)
- (if (number? x)
- (or (assoc-ref reduxtab x)
- x)
- x))
- node))
-
-(define (rename-tvs! node)
- (let ((mapping (cons '() #f)))
- (map-tree!
- (lambda (x)
- (if (tv? x)
- (if-let (z (assoc-ref (car mapping) x))
- z
- (let ((z (next)))
- (set-car! mapping (assoc-set! (car mapping) x z))
- z))
- x))
- node)))
-
-(define (apply-1 nx ny)
- (let ((x (node-content nx))
- (y (node-content ny)))
- (cond
- ((not x)
- (set-node-content! nx (cons ny (make-node #f)))
- (cdr (node-content nx)))
- ((zo? x)
- (type-error 3 x y))
- ((tv? x)
- (type-error 2 nx ny)
- )
- ((pair? x)
- (reduce-tvs! (compare (car x) ny)
- (copy-tree (cdr x))))
- (else
- (type-error 2 nx ny)))))
-
-(define (var-list? lst)
- "Predicate for valid macro variable lists."
- (and (every symbol? lst)
- (equal? lst (delete-duplicates lst))))
-
-(define (sym-set! symtab name value)
- "Associate a type to a symbol in a symtab."
- (let ((m (module-name (current-module))))
- (assoc-set! symtab m
- (assoc-set! (or (assoc-ref symtab m) '())
- name value))))
-
-(define (sym-set symtab sym value)
- "Like `sym-set!' but returns a copy of the symtab."
- (sym-set! (alist-copy symtab) sym value))
-
-(define (sym-ref symtab name)
- "Reference a symbol in a symtab returning its type."
- (let ((m (module-name (current-module))))
- (assoc-ref (or (assoc-ref symtab m) '()) name)))
-
-(define (populate-tvs! node)
- "Add (in-place) new type variables to empty nodes of a tree."
- (map-tree!
- (lambda (x)
- (if (not x)
- (next)
- x))
- node))
-
-(define (expand symtab expr)
- "Type check an expression returning two values: its resulting type and an
-expansion where all applications of symbols present in the symtab are curried.
-Raise a type error if the expression is invalid."
- (match expr
- (('quote x)
- (values
- (make-node 0)
- `',x))
- (('λc (? symbol? var) body)
- (let ((var-node (make-node #f)))
- (let ((bodyt bodye (expand (sym-set symtab var var-node)
- body)))
- (unless bodyt
- (type-error 5 "in body of" `(λc ,var ,body)))
- (populate-tvs! var-node)
- (values
- (make-node
- (cons var-node bodyt))
- `(lambda (,var) ,bodye)))))
- (('letrecc1 ((? symbol? name) expr) body)
- (type-error 0 'letrecc1 name expr body))
- (('cudefine name-vars body ..1)
- (values
- #f
- `(cudefine ,name-vars ,@body)))
- (('definec (? (lambda (x)
- (and
- (pair? x)
- (symbol? (car x))
- (var-list? (cdr x))))
- (name vars ..1))
- body)
- (expand
- symtab
- `(definec ,name
- ,(fold-right (lambda (x prev)
- `(λc ,x ,prev))
- body vars))))
- (('definec (? symbol? name) body)
- (let ((t e (expand symtab body)))
- (if (not t)
- (type-error 5 "in body of" `(definec ,name ,body))
- ;; We need to declare the type twice. Once, in `expand', to ensure
- ;; the type will be available in future `expand' calls. Second, in
- ;; the expanded expression, so that it gets compiled.
- (begin
- (∷% name t)
- (values
- #f
- `(begin
- ((@@ (vouivre curry) ∷%)
- ',name
- ((@ (vouivre curry) parse)
- ',(bare-type t)))
- (define ,name ,e)))))))
- ((f)
- (let ((t e (expand symtab f)))
- (values
- (if t
- (type-error 3 expr)
- #f)
- `(,e))))
- ((f as ..1)
- (let ((ft fe (expand symtab f))
- (ats aes (unzip2
- (map
- (lambda (a)
- (receive vals (expand symtab a) vals))
- as))))
- (if (not ft)
- (values #f `(,fe ,@aes))
- (values
- (fold
- (lambda (at a prev)
- (apply-1 prev (or at (type-error 5 f a))))
- ft ats as)
- (fold
- (lambda (ae prev)
- (list prev ae))
- fe aes)))))
- (x
- (values
- (if (symbol? x)
- (sym-ref symtab x)
- (make-node 0))
- x))))
-
-(define (bare-type x)
- "Return a type as tree s-expression without nodes."
- (and=>
- x
- (lambda (node)
- (let ((x (node-content node)))
- (cond
- ((pair? x)
- (cons (bare-type (car x)) (bare-type (cdr x))))
- (else x))))))
-
-(define* (pt node #:optional (port current-output-port))
- "Print a tree to the given port in a cons cell format with '?' for empty
-nodes."
- (format
- port "~a~%"
- (let pt% ((nx node))
- (let ((x (node-content nx)))
- (cond
- ((not x)
- "?")
- ((number? x)
- (number->string x))
- ((pair? x)
- (format #f "(~a . ~a)"
- (pt% (car x))
- (pt% (cdr x)))))))))
-
-(define (parse x)
- "Parse a type from its cons cells representation to a tree."
- (if (not x)
- #f
- (second
- (let parse% ((tvs '())
- (x x))
- (cond
- ((eq? x '?)
- (list tvs (make-node #f)))
- ((zo? x)
- (list tvs (make-node 0)))
- ((tv? x)
- (if-let (z (assoc-ref tvs x))
- (list tvs (make-node z))
- (let ((tv (next)))
- (list (assoc-set! tvs x tv)
- (make-node tv)))))
- ((pair? x)
- (let* ((a (parse% tvs (car x)))
- (b (parse% (first a) (cdr x))))
- (list (first b) (make-node (cons (second a) (second b)))))))))))
-
-(define (equal-types? ta tb)
- "Check the equality of two types."
- (define (equal-types?% ta tb correspondances)
- (let ((a (node-content ta))
- (b (node-content tb)))
- (or
- (eq? a b)
- (let ((correspond?
- (lambda (tx ty correspondances)
- (let ((x (node-content tx))
- (y (node-content ty)))
- (cond
- ((and (zo? x)
- (zo? y))
- correspondances)
- ((and (tv? x)
- (tv? y))
- (let ((xy (assoc-ref (car correspondances) x))
- (yx (assoc-ref (cdr correspondances) y)))
- (if (and (not xy) (not yx))
- (cons (assoc-set! (car correspondances) x y)
- (assoc-set! (cdr correspondances) y x))
- (and (eq? xy y) (eq? yx x) correspondances))))
- ((and (pair? x) (pair? y))
- (equal-types?% tx ty correspondances))
- (else #f))))))
- (match (list a b)
- (((a1 . a2) (b1 . b2))
- (and=>
- (correspond? a1 b1 correspondances)
- (lambda (correspondances)
- (correspond? a2 b2 correspondances))))
- (else #f))))))
- (if (or (not ta) (not tb))
- (eq? ta tb)
- (and (equal-types?% ta tb '(() . ()))
- #t)))
-
-(define-syntax curried-untyped-define
- (syntax-rules ()
- ((_ (name var) body ...)
- (cdefine (name var) body ...))
- ((_ (name var1 var2 ...) body ...)
- (curried-untyped-define ((name var1) var2 ...) body ...))))
-
-(define (∷% name type)
- (set! symtab (sym-set! symtab name type)))
-
-(define-syntax-rule (∷ name type)
- (∷% 'name (parse 'type)))
-
-(define* (type-of x #:optional port)
- "Print the type of a declared symbol to the given port."
- (if-let (x (expand symtab x))
- (pt x port)
- (format port "#f~%")))
+++ /dev/null
-;;; Guile VM code converters
-
-;; Copyright (C) 2001, 2009, 2012, 2013 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;;; This file has been modified by Vouivre Digital Corporation. The exact
-;;;; modifications can be seen in a shell using:
-;;;; $ git diff 5226e2890df9a25bd1d33514ff67539da7794905 decompile-tree-il.scm
-
-;;; Code:
-
-(define-module (language vouivre decompile-tree-il)
- #:use-module (language tree-il)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:use-module (ice-9 receive)
- #:use-module (ice-9 vlist)
- #:use-module (ice-9 match)
- #:use-module (system base syntax)
- #:export (decompile-tree-il))
-
-(define (decompile-tree-il e env opts)
- (apply do-decompile e env opts))
-
-(define* (do-decompile e env
- #:key
- (use-derived-syntax? #t)
- (avoid-lambda? #t)
- (use-case? #t)
- (strip-numeric-suffixes? #f)
- #:allow-other-keys)
-
- (receive (output-name-table occurrence-count-table)
- (choose-output-names e use-derived-syntax? strip-numeric-suffixes?)
-
- (define (output-name s) (hashq-ref output-name-table s))
- (define (occurrence-count s) (hashq-ref occurrence-count-table s))
-
- (define (const x) (lambda (_) x))
- (define (atom? x) (not (or (pair? x) (vector? x))))
-
- (define (build-void) '(if #f #f))
-
- (define (build-begin es)
- (match es
- (() (build-void))
- ((e) e)
- (_ `(begin ,@es))))
-
- (define (build-lambda-body e)
- (match e
- (('let () body ...) body)
- (('begin es ...) es)
- (_ (list e))))
-
- (define (build-begin-body e)
- (match e
- (('begin es ...) es)
- (_ (list e))))
-
- (define (build-define name e)
- (match e
- ((? (const avoid-lambda?)
- ('lambda formals body ...))
- `(define (,name ,@formals) ,@body))
- ((? (const avoid-lambda?)
- ('lambda* formals body ...))
- `(define* (,name ,@formals) ,@body))
- (_ `(define ,name ,e))))
-
- (define (build-let names vals body)
- (match `(let ,(map list names vals)
- ,@(build-lambda-body body))
- ((_ () e) e)
- ((_ (b) ('let* (bs ...) body ...))
- `(let* (,b ,@bs) ,@body))
- ((? (const use-derived-syntax?)
- (_ (b1) ('let (b2) body ...)))
- `(let* (,b1 ,b2) ,@body))
- (e e)))
-
- (define (build-letrec in-order? names vals body)
- (match `(,(if in-order? 'letrec* 'letrec)
- ,(map list names vals)
- ,@(build-lambda-body body))
- ((_ () e) e)
- ((_ () body ...) `(let () ,@body))
- ((_ ((name ('lambda (formals ...) body ...)))
- (name args ...))
- (=> failure)
- (if (= (length formals) (length args))
- `(let ,name ,(map list formals args) ,@body)
- (failure)))
- ((? (const avoid-lambda?)
- ('letrec* _ body ...))
- `(let ()
- ,@(map build-define names vals)
- ,@body))
- (e e)))
-
- (define (build-if test consequent alternate)
- (match alternate
- (('if #f _) `(if ,test ,consequent))
- (_ `(if ,test ,consequent ,alternate))))
-
- (define (build-and xs)
- (match xs
- (() #t)
- ((x) x)
- (_ `(and ,@xs))))
-
- (define (build-or xs)
- (match xs
- (() #f)
- ((x) x)
- (_ `(or ,@xs))))
-
- (define (case-test-var test)
- (match test
- (('memv (? atom? v) ('quote (datums ...)))
- v)
- (('eqv? (? atom? v) ('quote datum))
- v)
- (_ #f)))
-
- (define (test->datums v test)
- (match (cons v test)
- ((v 'memv v ('quote (xs ...)))
- xs)
- ((v 'eqv? v ('quote x))
- (list x))
- (_ #f)))
-
- (define (build-else-tail e)
- (match e
- (('if #f _) '())
- (('and xs ... x) `((,(build-and xs) ,@(build-begin-body x))
- (else #f)))
- (_ `((else ,@(build-begin-body e))))))
-
- (define (build-cond-else-tail e)
- (match e
- (('cond clauses ...) clauses)
- (_ (build-else-tail e))))
-
- (define (build-case-else-tail v e)
- (match (cons v e)
- ((v 'case v clauses ...)
- clauses)
- ((v 'if ('memv v ('quote (xs ...))) consequent . alternate*)
- `((,xs ,@(build-begin-body consequent))
- ,@(build-case-else-tail v (build-begin alternate*))))
- ((v 'if ('eqv? v ('quote x)) consequent . alternate*)
- `(((,x) ,@(build-begin-body consequent))
- ,@(build-case-else-tail v (build-begin alternate*))))
- (_ (build-else-tail e))))
-
- (define (clauses+tail clauses)
- (match clauses
- ((cs ... (and c ('else . _))) (values cs (list c)))
- (_ (values clauses '()))))
-
- (define (build-cond tests consequents alternate)
- (case (length tests)
- ((0) alternate)
- ((1) (build-if (car tests) (car consequents) alternate))
- (else `(cond ,@(map (lambda (test consequent)
- `(,test ,@(build-begin-body consequent)))
- tests consequents)
- ,@(build-cond-else-tail alternate)))))
-
- (define (build-cond-or-case tests consequents alternate)
- (if (not use-case?)
- (build-cond tests consequents alternate)
- (let* ((v (and (not (null? tests))
- (case-test-var (car tests))))
- (datum-lists (take-while identity
- (map (cut test->datums v <>)
- tests)))
- (n (length datum-lists))
- (tail (build-case-else-tail v (build-cond
- (drop tests n)
- (drop consequents n)
- alternate))))
- (receive (clauses tail) (clauses+tail tail)
- (let ((n (+ n (length clauses)))
- (datum-lists (append datum-lists
- (map car clauses)))
- (consequents (append consequents
- (map build-begin
- (map cdr clauses)))))
- (if (< n 2)
- (build-cond tests consequents alternate)
- `(case ,v
- ,@(map cons datum-lists (map build-begin-body
- (take consequents n)))
- ,@tail)))))))
-
- (define (recurse e)
-
- (define (recurse-body e)
- (build-lambda-body (recurse e)))
-
- (record-case e
- ((<void>)
- (build-void))
-
- ((<const> exp)
- (if (and (self-evaluating? exp) (not (vector? exp)))
- exp
- `(quote ,exp)))
-
- ((<seq> head tail)
- (build-begin (cons (recurse head)
- (build-begin-body
- (recurse tail)))))
-
- ((<call> proc args)
- (match `(,(recurse proc) ,@(map recurse args))
- ((('lambda (formals ...) body ...) args ...)
- (=> failure)
- (if (= (length formals) (length args))
- (build-let formals args (build-begin body))
- (failure)))
- (e e)))
-
- ((<primcall> name args)
- `(,name ,@(map recurse args)))
-
- ((<primitive-ref> name)
- name)
-
- ((<lexical-ref> gensym)
- (output-name gensym))
-
- ((<lexical-set> gensym exp)
- `(set! ,(output-name gensym) ,(recurse exp)))
-
- ((<module-ref> mod name public?)
- `(,(if public? '@ '@@) ,mod ,name))
-
- ((<module-set> mod name public? exp)
- `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp)))
-
- ((<toplevel-ref> name)
- name)
-
- ((<toplevel-set> name exp)
- `(set! ,name ,(recurse exp)))
-
- ((<toplevel-define> name exp)
- (build-define name (recurse exp)))
-
- ((<lambda> meta body)
- (if body
- (let ((body (recurse body))
- (doc (assq-ref meta 'documentation)))
- (if (not doc)
- body
- (match body
- (('lambda formals body ...)
- `(lambda ,formals ,doc ,@body))
- (('lambda* formals body ...)
- `(lambda* ,formals ,doc ,@body))
- (('case-lambda (formals body ...) clauses ...)
- `(case-lambda (,formals ,doc ,@body) ,@clauses))
- (('case-lambda* (formals body ...) clauses ...)
- `(case-lambda* (,formals ,doc ,@body) ,@clauses))
- (e e))))
- '(case-lambda)))
-
- ((<lambda-case> req opt rest kw inits gensyms body alternate)
- (let ((names (map output-name gensyms)))
- (cond
- ((and (not opt) (not kw) (not alternate))
- `(lambda ,(if rest (apply cons* names) names)
- ,@(recurse-body body)))
- ((and (not opt) (not kw))
- (let ((alt-expansion (recurse alternate))
- (formals (if rest (apply cons* names) names)))
- (case (car alt-expansion)
- ((lambda)
- `(case-lambda (,formals ,@(recurse-body body))
- ,(cdr alt-expansion)))
- ((lambda*)
- `(case-lambda* (,formals ,@(recurse-body body))
- ,(cdr alt-expansion)))
- ((case-lambda)
- `(case-lambda (,formals ,@(recurse-body body))
- ,@(cdr alt-expansion)))
- ((case-lambda*)
- `(case-lambda* (,formals ,@(recurse-body body))
- ,@(cdr alt-expansion))))))
- (else
- (let* ((alt-expansion (and alternate (recurse alternate)))
- (nreq (length req))
- (nopt (if opt (length opt) 0))
- (restargs (if rest (list-ref names (+ nreq nopt)) '()))
- (reqargs (list-head names nreq))
- (optargs (if opt
- `(#:optional
- ,@(map list
- (list-head (list-tail names nreq) nopt)
- (map recurse
- (list-head inits nopt))))
- '()))
- (kwargs (if kw
- `(#:key
- ,@(map list
- (map output-name (map caddr (cdr kw)))
- (map recurse
- (list-tail inits nopt))
- (map car (cdr kw)))
- ,@(if (car kw)
- '(#:allow-other-keys)
- '()))
- '()))
- (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
- (if (not alt-expansion)
- `(lambda* ,formals ,@(recurse-body body))
- (case (car alt-expansion)
- ((lambda lambda*)
- `(case-lambda* (,formals ,@(recurse-body body))
- ,(cdr alt-expansion)))
- ((case-lambda case-lambda*)
- `(case-lambda* (,formals ,@(recurse-body body))
- ,@(cdr alt-expansion))))))))))
-
- ((<conditional> test consequent alternate)
- (define (simplify-test e)
- (match e
- (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b)))
- `(memv ,v '(,a ,b)))
- (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...))))
- `(memv ,v '(,a ,@bs)))
- (('case (? atom? v)
- ((datum) #t) ...
- ('else ('eqv? v ('quote last-datum))))
- `(memv ,v '(,@datum ,last-datum)))
- (_ e)))
- (match `(if ,(simplify-test (recurse test))
- ,(recurse consequent)
- ,@(if (void? alternate) '()
- (list (recurse alternate))))
- (('if test ('if ('and xs ...) consequent))
- (build-if (build-and (cons test xs))
- consequent
- (build-void)))
- ((? (const use-derived-syntax?)
- ('if test1 ('if test2 consequent)))
- (build-if (build-and (list test1 test2))
- consequent
- (build-void)))
- (('if (? atom? x) x ('or ys ...))
- (build-or (cons x ys)))
- ((? (const use-derived-syntax?)
- ('if (? atom? x) x y))
- (build-or (list x y)))
- (('if test consequent)
- `(if ,test ,consequent))
- (('if test ('and xs ...) #f)
- (build-and (cons test xs)))
- ((? (const use-derived-syntax?)
- ('if test consequent #f))
- (build-and (list test consequent)))
- ((? (const use-derived-syntax?)
- ('if test1 consequent1
- ('if test2 consequent2 . alternate*)))
- (build-cond-or-case (list test1 test2)
- (list consequent1 consequent2)
- (build-begin alternate*)))
- (('if test consequent ('cond clauses ...))
- `(cond (,test ,@(build-begin-body consequent))
- ,@clauses))
- (('if ('memv (? atom? v) ('quote (xs ...))) consequent
- ('case v clauses ...))
- `(case ,v (,xs ,@(build-begin-body consequent))
- ,@clauses))
- (('if ('eqv? (? atom? v) ('quote x)) consequent
- ('case v clauses ...))
- `(case ,v ((,x) ,@(build-begin-body consequent))
- ,@clauses))
- (e e)))
-
- ((<let> gensyms vals body)
- (match (build-let (map output-name gensyms)
- (map recurse vals)
- (recurse body))
- (('let ((v e)) ('or v xs ...))
- (=> failure)
- (if (and (not (null? gensyms))
- (= 3 (occurrence-count (car gensyms))))
- `(or ,e ,@xs)
- (failure)))
- (('let ((v e)) ('case v clauses ...))
- (=> failure)
- (if (and (not (null? gensyms))
- ;; FIXME: This fails if any of the 'memv's were
- ;; optimized into multiple 'eqv?'s, because the
- ;; occurrence count will be higher than we expect.
- (= (occurrence-count (car gensyms))
- (1+ (length (clauses+tail clauses)))))
- `(case ,e ,@clauses)
- (failure)))
- (e e)))
-
- ((<letrec> in-order? gensyms vals body)
- (build-letrec in-order?
- (map output-name gensyms)
- (map recurse vals)
- (recurse body)))
-
- ((<fix> gensyms vals body)
- ;; not a typo, we really do translate back to letrec. use letrec* since it
- ;; doesn't matter, and the naive letrec* transformation does not require an
- ;; inner let.
- (build-letrec #t
- (map output-name gensyms)
- (map recurse vals)
- (recurse body)))
-
- ((<let-values> exp body)
- `(call-with-values (lambda () ,@(recurse-body exp))
- ,(recurse (make-lambda #f '() body))))
-
- ((<prompt> escape-only? tag body handler)
- `(call-with-prompt
- ,(recurse tag)
- ,(if escape-only?
- `(lambda () ,(recurse body))
- (recurse body))
- ,(recurse handler)))
-
-
- ((<abort> tag args tail)
- `(apply abort ,(recurse tag) ,@(map recurse args)
- ,(recurse tail)))))
- (values (recurse e) env)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Algorithm for choosing better variable names
-;; ============================================
-;;
-;; First we perform an analysis pass, collecting the following
-;; information:
-;;
-;; * For each gensym: how many occurrences will occur in the output?
-;;
-;; * For each gensym A: which gensyms does A conflict with? Gensym A
-;; and gensym B conflict if they have the same base name (usually the
-;; same as the source name, but see below), and if giving them the
-;; same name would cause a bad variable reference due to unintentional
-;; variable capture.
-;;
-;; The occurrence counter is indexed by gensym and is global (within each
-;; invocation of the algorithm), implemented using a hash table. We also
-;; keep a global mapping from gensym to source name as provided by the
-;; binding construct (we prefer not to trust the source names in the
-;; lexical ref or set).
-;;
-;; As we recurse down into lexical binding forms, we keep track of a
-;; mapping from base name to an ordered list of bindings, innermost
-;; first. When we encounter a variable occurrence, we increment the
-;; counter, look up the base name (preferring not to trust the 'name' in
-;; the lexical ref or set), and then look up the bindings currently in
-;; effect for that base name. Hopefully our gensym will be the first
-;; (innermost) binding. If not, we register a conflict between the
-;; referenced gensym and the other bound gensyms with the same base name
-;; that shadow the binding we want. These are simply the gensyms on the
-;; binding list that come before our gensym.
-;;
-;; Top-level bindings are treated specially. Whenever top-level
-;; references are found, they conflict with every lexical binding
-;; currently in effect with the same base name. They are guaranteed to
-;; be assigned to their source names. For purposes of recording
-;; conflicts (which are normally keyed on gensyms) top-level identifiers
-;; are assigned a pseudo-gensym that is an interned pair of the form
-;; (top-level . <name>). This allows them to be compared using 'eq?'
-;; like other gensyms.
-;;
-;; The base name is normally just the source name. However, if the
-;; source name has a suffix of the form "-N" (where N is a positive
-;; integer without leading zeroes), then we strip that suffix (multiple
-;; times if necessary) to form the base name. We must do this because
-;; we add suffixes of that form in order to resolve conflicts, and we
-;; must ensure that only identifiers with the same base name can
-;; possibly conflict with each other.
-;;
-;; XXX FIXME: Currently, primitives are treated exactly like top-level
-;; bindings. This handles conflicting lexical bindings properly, but
-;; does _not_ handle the case where top-level bindings conflict with the
-;; needed primitives.
-;;
-;; Also note that this requires that 'choose-output-names' be kept in
-;; sync with 'tree-il->scheme'. Primitives that are introduced by
-;; 'tree-il->scheme' must be anticipated by 'choose-output-name'.
-;;
-;; We also ensure that lexically-bound identifiers found in operator
-;; position will never be assigned one of the standard primitive names.
-;; This is needed because 'tree-il->scheme' recognizes primitive names
-;; in operator position and assumes that they have the standard
-;; bindings.
-;;
-;;
-;; How we assign an output name to each gensym
-;; ===========================================
-;;
-;; We process the gensyms in order of decreasing occurrence count, with
-;; each gensym choosing the best output name possible, as long as it
-;; isn't the same name as any of the previously-chosen output names of
-;; conflicting gensyms.
-;;
-
-
-;;
-;; 'choose-output-names' analyzes the top-level form e, chooses good
-;; variable names that are as close as possible to the source names,
-;; and returns two values:
-;;
-;; * a hash table mapping gensym to output name
-;; * a hash table mapping gensym to number of occurrences
-;;
-(define choose-output-names
- (let ()
- (define primitive?
- ;; This is a list of primitives that 'tree-il->scheme' assumes
- ;; will have the standard bindings when found in operator
- ;; position.
- (let* ((primitives '(if quote @ @@ set! define define*
- begin let let* letrec letrec*
- and or cond case
- lambda lambda* case-lambda case-lambda*
- apply call-with-values dynamic-wind
- with-fluids fluid-ref fluid-set!
- call-with-prompt abort memv eqv?))
- (table (make-hash-table (length primitives))))
- (for-each (cut hashq-set! table <> #t) primitives)
- (lambda (name) (hashq-ref table name))))
-
- ;; Repeatedly strip suffix of the form "-N", where N is a string
- ;; that could be produced by number->string given a positive
- ;; integer. In other words, the first digit of N may not be 0.
- (define compute-base-name
- (let ((digits (string->char-set "0123456789")))
- (define (base-name-string str)
- (let ((i (string-skip-right str digits)))
- (if (and i (< (1+ i) (string-length str))
- (eq? #\- (string-ref str i))
- (not (eq? #\0 (string-ref str (1+ i)))))
- (base-name-string (substring str 0 i))
- str)))
- (lambda (sym)
- (string->symbol (base-name-string (symbol->string sym))))))
-
- ;; choose-output-names
- (lambda (e use-derived-syntax? strip-numeric-suffixes?)
-
- (define lexical-gensyms '())
-
- (define top-level-intern!
- (let ((table (make-hash-table)))
- (lambda (name)
- (let ((h (hashq-create-handle! table name #f)))
- (or (cdr h) (begin (set-cdr! h (cons 'top-level name))
- (cdr h)))))))
- (define (top-level? s) (pair? s))
- (define (top-level-name s) (cdr s))
-
- (define occurrence-count-table (make-hash-table))
- (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0))
- (define (increment-occurrence-count! s)
- (let ((h (hashq-create-handle! occurrence-count-table s 0)))
- (if (zero? (cdr h))
- (set! lexical-gensyms (cons s lexical-gensyms)))
- (set-cdr! h (1+ (cdr h)))))
-
- (define base-name
- (let ((table (make-hash-table)))
- (lambda (name)
- (let ((h (hashq-create-handle! table name #f)))
- (or (cdr h) (begin (set-cdr! h (compute-base-name name))
- (cdr h)))))))
-
- (define source-name-table (make-hash-table))
- (define (set-source-name! s name)
- (if (not (top-level? s))
- (let ((name (if strip-numeric-suffixes?
- (base-name name)
- name)))
- (hashq-set! source-name-table s name))))
- (define (source-name s)
- (if (top-level? s)
- (top-level-name s)
- (hashq-ref source-name-table s)))
-
- (define conflict-table (make-hash-table))
- (define (conflicts s) (or (hashq-ref conflict-table s) '()))
- (define (add-conflict! a b)
- (define (add! a b)
- (if (not (top-level? a))
- (let ((h (hashq-create-handle! conflict-table a '())))
- (if (not (memq b (cdr h)))
- (set-cdr! h (cons b (cdr h)))))))
- (add! a b)
- (add! b a))
-
- (let recurse-with-bindings ((e e) (bindings vlist-null))
- (let recurse ((e e))
-
- ;; We call this whenever we encounter a top-level ref or set
- (define (top-level name)
- (let ((bname (base-name name)))
- (let ((s (top-level-intern! name))
- (conflicts (vhash-foldq* cons '() bname bindings)))
- (for-each (cut add-conflict! s <>) conflicts))))
-
- ;; We call this whenever we encounter a primitive reference.
- ;; We must also call it for every primitive that might be
- ;; inserted by 'tree-il->scheme'. It is okay to call this
- ;; even when 'tree-il->scheme' will not insert the named
- ;; primitive; the worst that will happen is for a lexical
- ;; variable of the same name to be renamed unnecessarily.
- (define (primitive name) (top-level name))
-
- ;; We call this whenever we encounter a lexical ref or set.
- (define (lexical s)
- (increment-occurrence-count! s)
- (let ((conflicts
- (take-while
- (lambda (s*) (not (eq? s s*)))
- (reverse! (vhash-foldq* cons
- '()
- (base-name (source-name s))
- bindings)))))
- (for-each (cut add-conflict! s <>) conflicts)))
-
- (record-case e
- ((<void>) (primitive 'if)) ; (if #f #f)
- ((<const>) (primitive 'quote))
-
- ((<call> proc args)
- (if (lexical-ref? proc)
- (let* ((gensym (lexical-ref-gensym proc))
- (name (source-name gensym)))
- ;; If the operator position contains a bare variable
- ;; reference with the same source name as a standard
- ;; primitive, we must ensure that it will be given a
- ;; different name, so that 'tree-il->scheme' will not
- ;; misinterpret the resulting expression.
- (if (primitive? name)
- (add-conflict! gensym (top-level-intern! name)))))
- (recurse proc)
- (for-each recurse args))
-
- ((<primitive-ref> name) (primitive name))
- ((<primcall> name args) (primitive name) (for-each recurse args))
-
- ((<lexical-ref> gensym) (lexical gensym))
- ((<lexical-set> gensym exp)
- (primitive 'set!) (lexical gensym) (recurse exp))
-
- ((<module-ref> public?) (primitive (if public? '@ '@@)))
- ((<module-set> public? exp)
- (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp))
-
- ((<toplevel-ref> name) (top-level name))
- ((<toplevel-set> name exp)
- (primitive 'set!) (top-level name) (recurse exp))
- ((<toplevel-define> name exp) (top-level name) (recurse exp))
-
- ((<conditional> test consequent alternate)
- (cond (use-derived-syntax?
- (primitive 'and) (primitive 'or)
- (primitive 'cond) (primitive 'case)
- (primitive 'else) (primitive '=>)))
- (primitive 'if)
- (recurse test) (recurse consequent) (recurse alternate))
-
- ((<seq> head tail)
- (primitive 'begin) (recurse head) (recurse tail))
-
- ((<lambda> body)
- (if body (recurse body) (primitive 'case-lambda)))
-
- ((<lambda-case> req opt rest kw inits gensyms body alternate)
- (primitive 'lambda)
- (cond ((or opt kw alternate)
- (primitive 'lambda*)
- (primitive 'case-lambda)
- (primitive 'case-lambda*)))
- (primitive 'let)
- (if use-derived-syntax? (primitive 'let*))
- (let* ((names (append req (or opt '()) (if rest (list rest) '())
- (map cadr (if kw (cdr kw) '()))))
- (base-names (map base-name names))
- (body-bindings
- (fold vhash-consq bindings base-names gensyms)))
- (for-each increment-occurrence-count! gensyms)
- (for-each set-source-name! gensyms names)
- (for-each recurse inits)
- (recurse-with-bindings body body-bindings)
- (if alternate (recurse alternate))))
-
- ((<let> names gensyms vals body)
- (primitive 'let)
- (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
- (for-each increment-occurrence-count! gensyms)
- (for-each set-source-name! gensyms names)
- (for-each recurse vals)
- (recurse-with-bindings
- body (fold vhash-consq bindings (map base-name names) gensyms)))
-
- ((<letrec> in-order? names gensyms vals body)
- (primitive 'let)
- (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
- (primitive (if in-order? 'letrec* 'letrec))
- (for-each increment-occurrence-count! gensyms)
- (for-each set-source-name! gensyms names)
- (let* ((base-names (map base-name names))
- (bindings (fold vhash-consq bindings base-names gensyms)))
- (for-each (cut recurse-with-bindings <> bindings) vals)
- (recurse-with-bindings body bindings)))
-
- ((<fix> names gensyms vals body)
- (primitive 'let)
- (primitive 'letrec*)
- (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
- (for-each increment-occurrence-count! gensyms)
- (for-each set-source-name! gensyms names)
- (let* ((base-names (map base-name names))
- (bindings (fold vhash-consq bindings base-names gensyms)))
- (for-each (cut recurse-with-bindings <> bindings) vals)
- (recurse-with-bindings body bindings)))
-
- ((<let-values> exp body)
- (primitive 'call-with-values)
- (recurse exp) (recurse body))
-
- ((<prompt> tag body handler)
- (primitive 'call-with-prompt)
- (recurse tag) (recurse body) (recurse handler))
-
- ((<abort> tag args tail)
- (primitive 'apply)
- (primitive 'abort)
- (recurse tag) (for-each recurse args) (recurse tail)))))
-
- (let ()
- (define output-name-table (make-hash-table))
- (define (set-output-name! s name)
- (hashq-set! output-name-table s name))
- (define (output-name s)
- (if (top-level? s)
- (top-level-name s)
- (hashq-ref output-name-table s)))
-
- (define sorted-lexical-gensyms
- (sort-list lexical-gensyms
- (lambda (a b) (> (occurrence-count a)
- (occurrence-count b)))))
-
- (for-each (lambda (s)
- (set-output-name!
- s
- (let ((the-conflicts (conflicts s))
- (the-source-name (source-name s)))
- (define (not-yet-taken? name)
- (not (any (lambda (s*)
- (and=> (output-name s*)
- (cut eq? name <>)))
- the-conflicts)))
- (if (not-yet-taken? the-source-name)
- the-source-name
- (let ((prefix (string-append
- (symbol->string the-source-name)
- "-")))
- (let loop ((i 1) (name the-source-name))
- (if (not-yet-taken? name)
- name
- (loop (+ i 1)
- (string->symbol
- (string-append
- prefix
- (number->string i)))))))))))
- sorted-lexical-gensyms)
- (values output-name-table occurrence-count-table)))))
--- /dev/null
+\input texinfo
+@c -*-texinfo-*-
+
+@c %**start of header
+@setfilename vouivre.info
+@documentencoding UTF-8
+@settitle Vouivre Reference Manual
+@c %**end of header
+
+@include version.texi
+
+@copying
+Copyright @copyright{} 2023 Vouivre Digital Corporation
+
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A
+copy of the license is included in the section entitled ``GNU Free
+Documentation License''.
+@end copying
+
+@dircategory The Algorithmic Language Scheme
+@direntry
+* Vouivre: (vouivre).
+@end direntry
+
+@titlepage
+@title The Vouivre Manual
+@author Vouivre Digital Corporation
+
+@page
+@vskip 0pt plus 1filll
+Edition @value{EDITION} @*
+@value{UPDATED} @*
+
+@insertcopying
+@end titlepage
+
+@contents
+
+@c *********************************************************************
+@node Top
+@top Vouivre
+
+This document describes Vouivre version @value{VERSION}.
+
+@menu
+* Introduction:: Why Vouivre?
+@end menu
+
+@c *********************************************************************
+@node Introduction
+@chapter Introduction
+
+INTRODUCTION HERE
+
+This documentation is a stub.
+
+@bye
--- /dev/null
+;;;; Copyright (C) 2023 Vouivre Digital Corporation
+;;;;
+;;;; This file is part of Vouivre.
+;;;;
+;;;; Vouivre is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public
+;;;; License as published by the Free Software Foundation, either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; Vouivre is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (vouivre base)
+ #:use-module ((guile) #:select (1+) #:prefix guile:)
+ #:use-module ((rnrs base) #:prefix rnrs:)
+ #:use-module ((srfi srfi-1) #:prefix srfi-1:)
+ #:use-module (vouivre curry)
+ #:use-module ((vouivre autodiff) #:prefix v:)
+ #:export
+ (∘
+ ⊙
+ flip
+ fdiff
+ rdiff)
+ #:replace
+ (boolean?
+ not
+ symbol?
+ symbol->string
+ string->symbol
+ char?
+ char=?
+ char<?
+ char>?
+ char<=?
+ char>=?
+ integer->char
+ char->integer
+ list?
+ null?
+ pair?
+ cons
+ car
+ cdr
+ caar
+ cadr
+ cdar
+ cddr
+ caaar
+ cadar
+ cdaar
+ caddr
+ cdadr
+ cddar
+ cdddr
+ caaaar
+ caaadr
+ caadar
+ cadaar
+ cdaaar
+ cddaar
+ cdadar
+ cdaadr
+ cadadr
+ caaddr
+ caddar
+ cadddr
+ cdaddr
+ cddadr
+ cdddar
+ cddddr
+ number?
+ string?
+ procedure?
+ eq?
+ eqv?
+ equal?
+ symbol=?
+ complex?
+ real-part
+ imag-part
+ make-rectangular
+ make-polar
+ magnitude
+ angle
+ sqrt
+ exp
+ expt
+ log
+ sin
+ cos
+ tan
+ asin
+ acos
+ atan
+ real?
+ rational?
+ numerator
+ denominator
+ rationalize
+ exact?
+ inexact?
+ integer?
+ odd?
+ even?
+ gcd
+ lcm
+ exact-integer-sqrt
+ =
+ <
+ >
+ <=
+ >=
+ zero?
+ positive?
+ negative?
+ length
+ list-ref
+ list-tail
+ append
+ reverse
+ number->string
+ string->number
+ make-string
+ list->string
+ string->list
+ string-length
+ string-ref
+ string-copy
+ substring
+ string=?
+ string<?
+ string>?
+ string<=?
+ string>=?
+ string-append
+ +
+ -
+ *
+ /
+ max
+ min
+ abs
+ truncate
+ floor
+ ceiling
+ round
+ div
+ mod
+ real-valued?
+ rational-valued?
+ integer-valued?
+ nan?
+ infinite?
+ finite?
+ fold
+ fold-right
+ reduce
+ reduce-right
+ map
+ 1+
+ identity))
+
+;; abbreviation
+(define-syntax cudefine (identifier-syntax curried-untyped-define))
+
+(∷ boolean? (0 . 0))
+(cudefine (boolean? x) (rnrs:boolean? x))
+
+(∷ not (0 . 0))
+(cudefine (not x) (rnrs:not x))
+
+(∷ symbol? (0 . 0))
+(cudefine (symbol? x) (rnrs:symbol? x))
+
+(∷ symbol->string (0 . 0))
+(cudefine (symbol->string x) (rnrs:symbol->string x))
+
+(∷ string->symbol (0 . 0))
+(cudefine (string->symbol x) (rnrs:string->symbol x))
+
+(∷ char? (0 . 0))
+(cudefine (char? x) (rnrs:char? x))
+
+(∷ char=? (0 . (0 . 0)))
+(cudefine (char=? x y) (rnrs:char=? x y))
+
+(∷ char<? (0 . (0 . 0)))
+(cudefine (char<? x y) (rnrs:char<? x y))
+
+(∷ char>? (0 . (0 . 0)))
+(cudefine (char>? x y) (rnrs:char>? x y))
+
+(∷ char<=? (0 . (0 . 0)))
+(cudefine (char<=? x y) (rnrs:char<=? x y))
+
+(∷ char>=? (0 . (0 . 0)))
+(cudefine (char>=? x y) (rnrs:char>=? x y))
+
+(∷ integer->char (0 . 0))
+(cudefine (integer->char x) (rnrs:integer->char x))
+
+(∷ char->integer (0 . 0))
+(cudefine (char->integer x) (rnrs:char->integer x))
+
+(∷ list? (0 . 0))
+(cudefine (list? x) (rnrs:list? x))
+
+(∷ null? (0 . 0))
+(cudefine (null? x) (rnrs:null? x))
+
+(∷ pair? (0 . 0))
+(cudefine (pair? x) (rnrs:pair? x))
+
+(∷ cons (0 . (0 . 0)))
+(cudefine (cons x y) (rnrs:cons x y))
+
+(∷ car (0 . 0))
+(cudefine (car x) (rnrs:car x))
+
+(∷ cdr (0 . 0))
+(cudefine (cdr x) (rnrs:cdr x))
+
+(∷ caar (0 . 0))
+(cudefine (caar x) (rnrs:caar x))
+
+(∷ cadr (0 . 0))
+(cudefine (cadr x) (rnrs:cadr x))
+
+(∷ cdar (0 . 0))
+(cudefine (cdar x) (rnrs:cdar x))
+
+(∷ cddr (0 . 0))
+(cudefine (cddr x) (rnrs:cddr x))
+
+(∷ caaar (0 . 0))
+(cudefine (caaar x) (rnrs:caaar x))
+
+(∷ caadr (0 . 0))
+(cudefine (caadr x) (rnrs:caadr x))
+
+(∷ cadar (0 . 0))
+(cudefine (cadar x) (rnrs:cadar x))
+
+(∷ cdaar (0 . 0))
+(cudefine (cdaar x) (rnrs:cdaar x))
+
+(∷ caddr (0 . 0))
+(cudefine (caddr x) (rnrs:caddr x))
+
+(∷ cdadr (0 . 0))
+(cudefine (cdadr x) (rnrs:cdadr x))
+
+(∷ cddar (0 . 0))
+(cudefine (cddar x) (rnrs:cddar x))
+
+(∷ cdddr (0 . 0))
+(cudefine (cdddr x) (rnrs:cdddr x))
+
+(∷ caaaar (0 . 0))
+(cudefine (caaaar x) (rnrs:caaaar x))
+
+(∷ caaadr (0 . 0))
+(cudefine (caaadr x) (rnrs:caaadr x))
+
+(∷ caadar (0 . 0))
+(cudefine (caadar x) (rnrs:caadar x))
+
+(∷ cadaar (0 . 0))
+(cudefine (cadaar x) (rnrs:cadaar x))
+
+(∷ cdaaar (0 . 0))
+(cudefine (cdaaar x) (rnrs:cdaaar x))
+
+(∷ cddaar (0 . 0))
+(cudefine (cddaar x) (rnrs:cddaar x))
+
+(∷ cdadar (0 . 0))
+(cudefine (cdadar x) (rnrs:cdadar x))
+
+(∷ cdaadr (0 . 0))
+(cudefine (cdaadr x) (rnrs:cdaadr x))
+
+(∷ cadadr (0 . 0))
+(cudefine (cadadr x) (rnrs:cadadr x))
+
+(∷ caaddr (0 . 0))
+(cudefine (caaddr x) (rnrs:caaddr x))
+
+(∷ caddar (0 . 0))
+(cudefine (caddar x) (rnrs:caddar x))
+
+(∷ cadddr (0 . 0))
+(cudefine (cadddr x) (rnrs:cadddr x))
+
+(∷ cdaddr (0 . 0))
+(cudefine (cdaddr x) (rnrs:cdaddr x))
+
+(∷ cddadr (0 . 0))
+(cudefine (cddadr x) (rnrs:cddadr x))
+
+(∷ cdddar (0 . 0))
+(cudefine (cdddar x) (rnrs:cdddar x))
+
+(∷ cddddr (0 . 0))
+(cudefine (cddddr x) (rnrs:cddddr x))
+
+(∷ number? (0 . 0))
+(cudefine (number? x) (rnrs:number? x))
+
+(∷ string? (0 . 0))
+(cudefine (string? x) (rnrs:string? x))
+
+(∷ procedure? (0 . 0))
+(cudefine (procedure? x) (rnrs:procedure? x))
+
+(∷ eq? (0 . (0 . 0)))
+(cudefine (eq? x y) (rnrs:eq? x y))
+
+(∷ eqv? (0 . (0 . 0)))
+(cudefine (eqv? x y) (rnrs:eqv? x y))
+
+(∷ equal? (0 . (0 . 0)))
+(cudefine (equal? x y) (rnrs:equal? x y))
+
+(∷ symbol=? (0 . (0 . 0)))
+(cudefine (symbol=? x y) (rnrs:symbol=? x y))
+
+(∷ complex? (0 . 0))
+(cudefine (complex? x) (rnrs:complex? x))
+
+(∷ real-part (0 . 0))
+(cudefine (real-part x) (rnrs:real-part x))
+
+(∷ imag-part (0 . 0))
+(cudefine (imag-part x) (rnrs:imag-part x))
+
+(∷ make-rectangular (0 . (0 . 0)))
+(cudefine (make-rectangular x y) (rnrs:make-rectangular x y))
+
+(∷ make-polar (0 . (0 . 0)))
+(cudefine (make-polar x y) (rnrs:make-polar x y))
+
+(∷ magnitude (0 . 0))
+(cudefine (magnitude x) (rnrs:magnitude x))
+
+(∷ angle (0 . 0))
+(cudefine (angle x) (rnrs:angle x))
+
+(∷ sqrt (0 . 0))
+(cudefine (sqrt x) (rnrs:sqrt x))
+
+(∷ exp (0 . 0))
+(cudefine (exp x) (rnrs:exp x))
+
+(∷ expt (0 . (0 . 0)))
+(cudefine (expt x y) (rnrs:expt x y))
+
+(∷ log (0 . 0))
+(cudefine (log x) (rnrs:log x))
+
+(∷ sin (0 . 0))
+(cudefine (sin x) (v:sin x))
+
+(∷ cos (0 . 0))
+(cudefine (cos x) (rnrs:cos x))
+
+(∷ tan (0 . 0))
+(cudefine (tan x) (rnrs:tan x))
+
+(∷ asin (0 . 0))
+(cudefine (asin x) (rnrs:asin x))
+
+(∷ acos (0 . 0))
+(cudefine (acos x) (rnrs:acos x))
+
+(∷ atan (0 . 0))
+(cudefine (atan x) (rnrs:atan x))
+
+(∷ real? (0 . 0))
+(cudefine (real? x) (rnrs:real? x))
+
+(∷ rational? (0 . 0))
+(cudefine (rational? x) (rnrs:rational? x))
+
+(∷ numerator (0 . 0))
+(cudefine (numerator x) (rnrs:numerator x))
+
+(∷ denominator (0 . 0))
+(cudefine (denominator x) (rnrs:denominator x))
+
+(∷ rationalize (0 . (0 . 0)))
+(cudefine (rationalize x eps) (rnrs:rationalize x eps))
+
+(∷ exact? (0 . 0))
+(cudefine (exact? x) (rnrs:exact? x))
+
+(∷ inexact? (0 . 0))
+(cudefine (inexact? x) (rnrs:inexact? x))
+
+(∷ integer? (0 . 0))
+(cudefine (integer? x) (rnrs:integer? x))
+
+(∷ odd? (0 . 0))
+(cudefine (odd? x) (rnrs:odd? x))
+
+(∷ even? (0 . 0))
+(cudefine (even? x) (rnrs:even? x))
+
+(∷ gcd (0 . (0 . 0)))
+(cudefine (gcd x y) (rnrs:gcd x y))
+
+(∷ lcm (0 . (0 . 0)))
+(cudefine (lcm x y) (rnrs:lcm x y))
+
+(∷ exact-integer-sqrt (0 . 0))
+(cudefine (exact-integer-sqrt x) (rnrs:exact-integer-sqrt x))
+
+(∷ = (0 . (0 . 0)))
+(cudefine (= x y) (rnrs:= x y))
+
+(∷ < (0 . (0 . 0)))
+(cudefine (< x y) (rnrs:< x y))
+
+(∷ > (0 . (0 . 0)))
+(cudefine (> x y) (rnrs:> x y))
+
+(∷ <= (0 . (0 . 0)))
+(cudefine (<= x y) (rnrs:<= x y))
+
+(∷ >= (0 . (0 . 0)))
+(cudefine (>= x y) (rnrs:>= x y))
+
+(∷ zero? (0 . 0))
+(cudefine (zero? x) (rnrs:zero? x))
+
+(∷ positive? (0 . 0))
+(cudefine (positive? x) (rnrs:positive? x))
+
+(∷ negative? (0 . 0))
+(cudefine (negative? x) (rnrs:negative? x))
+
+(∷ length (0 . 0))
+(cudefine (length x) (rnrs:length x))
+
+(∷ list-ref (0 . (0 . 0)))
+(cudefine (list-ref lst k) (rnrs:list-ref lst k))
+
+(∷ list-tail (0 . (0 . 0)))
+(cudefine (list-tail lst k) (rnrs:list-tail lst k))
+
+(∷ append (0 . (0 . 0)))
+(cudefine (append x y) (rnrs:append x y))
+
+(∷ reverse (0 . 0))
+(cudefine (reverse x) (rnrs:reverse x))
+
+(∷ number->string (0 . (0 . 0)))
+(cudefine (number->string n radix) (rnrs:number->string n radix))
+
+(∷ string->number (0 . (0 . 0)))
+(cudefine (string->number str radix) (rnrs:string->number str radix))
+
+(∷ make-string (0 . (0 . 0)))
+(cudefine (make-string k char) (rnrs:make-string k char))
+
+(∷ list->string (0 . 0))
+(cudefine (list->string x) (rnrs:list->string x))
+
+(∷ string->list (0 . (0 . (0 . 0))))
+(cudefine (string->list str start end) (rnrs:string->list str start end))
+
+(∷ string-length (0 . 0))
+(cudefine (string-length x) (rnrs:string-length x))
+
+(∷ string-ref (0 . (0 . 0)))
+(cudefine (string-ref str k) (rnrs:string-ref str k))
+
+(∷ string-copy (0 . (0 . (0 . 0))))
+(cudefine (string-copy str start end) (rnrs:string-copy str start end))
+
+(∷ substring (0 . (0 . (0 . 0))))
+(cudefine (substring str start end) (rnrs:substring str start end))
+
+(∷ string=? (0 . (0 . 0)))
+(cudefine (string=? x y) (rnrs:string=? x y))
+
+(∷ string<? (0 . (0 . 0)))
+(cudefine (string<? x y) (rnrs:string<? x y))
+
+(∷ string>? (0 . (0 . 0)))
+(cudefine (string>? x y) (rnrs:string>? x y))
+
+(∷ string<=? (0 . (0 . 0)))
+(cudefine (string<=? x y) (rnrs:string<=? x y))
+
+(∷ string>=? (0 . (0 . 0)))
+(cudefine (string>=? x y) (rnrs:string>=? x y))
+
+(∷ string-append (0 . (0 . 0)))
+(cudefine (string-append x y) (rnrs:string-append x y))
+
+(∷ + (0 . (0 . 0)))
+(cudefine (+ x y) (rnrs:+ x y))
+
+(∷ - (0 . (0 . 0)))
+(cudefine (- x y) (rnrs:- x y))
+
+(∷ * (0 . (0 . 0)))
+(cudefine (* x y) (rnrs:* x y))
+
+(∷ / (0 . (0 . 0)))
+(cudefine (/ x y) (rnrs:/ x y))
+
+(∷ max (0 . (0 . 0)))
+(cudefine (max x y) (rnrs:max x y))
+
+(∷ min (0 . (0 . 0)))
+(cudefine (min x y) (rnrs:min x y))
+
+(∷ abs (0 . 0))
+(cudefine (abs x) (rnrs:abs x))
+
+(∷ truncate (0 . 0))
+(cudefine (truncate x) (rnrs:truncate x))
+
+(∷ floor (0 . 0))
+(cudefine (floor x) (rnrs:floor x))
+
+(∷ ceiling (0 . 0))
+(cudefine (ceiling x) (rnrs:ceiling x))
+
+(∷ round (0 . 0))
+(cudefine (round x) (rnrs:round x))
+
+(∷ div (0 . (0 . 0)))
+(cudefine (div x y) (rnrs:div x y))
+
+(∷ mod (0 . (0 . 0)))
+(cudefine (mod x y) (rnrs:mod x y))
+
+(∷ real-valued? (0 . 0))
+(cudefine (real-valued? x) (rnrs:real-valued? x))
+
+(∷ rational-valued? (0 . 0))
+(cudefine (rational-valued? x) (rnrs:rational-valued? x))
+
+(∷ integer-valued? (0 . 0))
+(cudefine (integer-valued? x) (rnrs:integer-valued? x))
+
+(∷ nan? (0 . 0))
+(cudefine (nan? x) (rnrs:nan? x))
+
+(∷ infinite? (0 . 0))
+(cudefine (infinite? x) (rnrs:infinite? x))
+
+(∷ finite? (0 . 0))
+(cudefine (finite? x) (rnrs:finite? x))
+
+(∷ fold ((0 . (0 . 0)) . (0 . (0 . 0))))
+(cudefine (fold f x xs)
+ (srfi-1:fold
+ (lambda (x prev)
+ ((f x) prev))
+ x xs))
+
+(∷ fold-right ((0 . (0 . 0)) . (0 . (0 . 0))))
+(cudefine (fold-right f x xs)
+ (srfi-1:fold-right
+ (lambda (x prev)
+ ((f x) prev))
+ x xs))
+
+(∷ reduce ((0 . (0 . 0)) . (0 . 0)))
+(cudefine (reduce f xs)
+ (when (null? xs)
+ (error "empty list"))
+ (srfi-1:reduce
+ (lambda (x prev)
+ ((f x) prev))
+ 0
+ xs))
+
+(∷ reduce-right ((0 . (0 . 0)) . (0 . 0)))
+(cudefine (reduce-right f xs)
+ (when (null? xs)
+ (error "empty list"))
+ (srfi-1:reduce-right
+ (lambda (x prev)
+ ((f x) prev))
+ 0
+ xs))
+
+(∷ map ((0 . 0) . (0 . 0)))
+(cudefine (map f xs) (srfi-1:map f xs))
+
+(∷ 1+ (0 . 0))
+(cudefine (1+ x) (guile:1+ x))
+
+(definec (identity x) x)
+(definec (∘ g f) (λc x (g (f x))))
+(definec (⊙ f g) (∘ g f))
+(definec (flip f) (λc y (λc x (f x y))))
+
+(define fdiff v:fdiff)
+(define rdiff v:rdiff)
--- /dev/null
+(use-modules
+ (guix packages)
+ ((guix licenses) #:prefix license:)
+ (guix download)
+ (guix gexp)
+ (guix build-system gnu)
+ (gnu packages)
+ (gnu packages autotools)
+ (gnu packages guile)
+ (gnu packages guile-xyz)
+ (gnu packages pkg-config)
+ (gnu packages texinfo)
+ (srfi srfi-1))
+
+(package
+ (name "vouivre")
+ (version "0.1.0")
+ (source
+ (local-file
+ (dirname (current-filename))
+ #:recursive?
+ #t
+ #:select?
+ (lambda (file stat)
+ (not (any (lambda (my-string) (string-contains file my-string))
+ (list ".git" ".dir-locals.el" "guix.scm"))))))
+ (build-system gnu-build-system)
+ (arguments `())
+ (native-inputs (list autoconf automake pkg-config texinfo))
+ (inputs (list guile-3.0))
+ (propagated-inputs (list))
+ (synopsis "")
+ (description "")
+ (home-page "https://vouivredigital.com")
+ (license license:gpl3+))
+
--- /dev/null
+(hall-description
+ (name "vouivre")
+ (prefix "")
+ (version "0.1.0")
+ (author "Vouivre Digital Corporation")
+ (email "admin@vouivredigital.com")
+ (copyright (2023))
+ (synopsis "")
+ (description "")
+ (home-page "https://vouivredigital.com")
+ (license gpl3+)
+ (dependencies `())
+ (skip ())
+ (features ((guix #f) (native-language-support #f) (licensing #f)))
+ (files (libraries
+ ((scheme-file "vouivre")
+ (directory
+ "language"
+ ((directory
+ "vouivre"
+ ((scheme-file "decompile-tree-il")
+ (scheme-file "spec")
+ (scheme-file "compile-tree-il")))))
+ (directory
+ "vouivre"
+ ((scheme-file "hconfig")
+ (scheme-file "curry")
+ (scheme-file "autodiff")
+ (scheme-file "misc")
+ (scheme-file "promises")
+ (scheme-file "mnist")))))
+ (tests ((directory
+ "tests"
+ ((scheme-file "curry") (scheme-file "autodiff")))))
+ (programs ((directory "scripts" ())
+ (directory "examples" ((scheme-file "example")
+ (scheme-file "base")))))
+ (documentation
+ ((org-file "README")
+ (symlink "README" "README.org")
+ (text-file "HACKING")
+ (text-file "COPYING")
+ (text-file "COPYING.LESSER")
+ (directory
+ "doc"
+ ((info-file "vouivre")
+ (info-file "version")
+ (texi-file "version")
+ (text-file ".dirstamp")
+ (texi-file "vouivre")
+ (text-file "stamp-vti")))
+ (text-file "LICENSE")
+ (text-file "NEWS")
+ (text-file "AUTHORS")
+ (text-file "ChangeLog")))
+ (infrastructure
+ ((scheme-file "guix")
+ (text-file ".gitignore")
+ (scheme-file "hall")
+ (directory
+ "build-aux"
+ ((tex-file "texinfo")
+ (text-file "mdate-sh")
+ (scheme-file "test-driver")
+ (text-file "missing")
+ (text-file "install-sh")))
+ (autoconf-file "configure")
+ (in-file "pre-inst-env")
+ (automake-file "Makefile")))))
--- /dev/null
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;;; This file has been modified by Vouivre Digital Corporation. The exact
+;;;; modifications can be seen in a shell using:
+;;;; $ git diff 5226e2890df9a25bd1d33514ff67539da7794905 compile-tree-il.scm
+
+;;; Code:
+
+(define-module (language vouivre compile-tree-il)
+ #:use-module (language tree-il)
+ #:use-module (srfi srfi-71)
+ #:use-module (vouivre curry)
+ #:export (compile-tree-il))
+
+;;; environment := MODULE
+
+(define (compile-tree-il x e opts)
+ (save-module-excursion
+ (lambda ()
+ (set-current-module e)
+ ;; TODO: Why do we need to use `(@@ (vouivre curry) symtab)' here instead of
+ ;; simply `symtab'? If we don't it always return an empty symtab.
+ (let ((t expr (expand (@@ (vouivre curry) symtab) (syntax->datum x))))
+ (let* ((x (macroexpand expr 'c '(compile load eval)))
+ (cenv (current-module)))
+ (values x cenv cenv))))))
--- /dev/null
+;;; Guile VM code converters
+
+;; Copyright (C) 2001, 2009, 2012, 2013 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;;; This file has been modified by Vouivre Digital Corporation. The exact
+;;;; modifications can be seen in a shell using:
+;;;; $ git diff 5226e2890df9a25bd1d33514ff67539da7794905 decompile-tree-il.scm
+
+;;; Code:
+
+(define-module (language vouivre decompile-tree-il)
+ #:use-module (language tree-il)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (system base syntax)
+ #:export (decompile-tree-il))
+
+(define (decompile-tree-il e env opts)
+ (apply do-decompile e env opts))
+
+(define* (do-decompile e env
+ #:key
+ (use-derived-syntax? #t)
+ (avoid-lambda? #t)
+ (use-case? #t)
+ (strip-numeric-suffixes? #f)
+ #:allow-other-keys)
+
+ (receive (output-name-table occurrence-count-table)
+ (choose-output-names e use-derived-syntax? strip-numeric-suffixes?)
+
+ (define (output-name s) (hashq-ref output-name-table s))
+ (define (occurrence-count s) (hashq-ref occurrence-count-table s))
+
+ (define (const x) (lambda (_) x))
+ (define (atom? x) (not (or (pair? x) (vector? x))))
+
+ (define (build-void) '(if #f #f))
+
+ (define (build-begin es)
+ (match es
+ (() (build-void))
+ ((e) e)
+ (_ `(begin ,@es))))
+
+ (define (build-lambda-body e)
+ (match e
+ (('let () body ...) body)
+ (('begin es ...) es)
+ (_ (list e))))
+
+ (define (build-begin-body e)
+ (match e
+ (('begin es ...) es)
+ (_ (list e))))
+
+ (define (build-define name e)
+ (match e
+ ((? (const avoid-lambda?)
+ ('lambda formals body ...))
+ `(define (,name ,@formals) ,@body))
+ ((? (const avoid-lambda?)
+ ('lambda* formals body ...))
+ `(define* (,name ,@formals) ,@body))
+ (_ `(define ,name ,e))))
+
+ (define (build-let names vals body)
+ (match `(let ,(map list names vals)
+ ,@(build-lambda-body body))
+ ((_ () e) e)
+ ((_ (b) ('let* (bs ...) body ...))
+ `(let* (,b ,@bs) ,@body))
+ ((? (const use-derived-syntax?)
+ (_ (b1) ('let (b2) body ...)))
+ `(let* (,b1 ,b2) ,@body))
+ (e e)))
+
+ (define (build-letrec in-order? names vals body)
+ (match `(,(if in-order? 'letrec* 'letrec)
+ ,(map list names vals)
+ ,@(build-lambda-body body))
+ ((_ () e) e)
+ ((_ () body ...) `(let () ,@body))
+ ((_ ((name ('lambda (formals ...) body ...)))
+ (name args ...))
+ (=> failure)
+ (if (= (length formals) (length args))
+ `(let ,name ,(map list formals args) ,@body)
+ (failure)))
+ ((? (const avoid-lambda?)
+ ('letrec* _ body ...))
+ `(let ()
+ ,@(map build-define names vals)
+ ,@body))
+ (e e)))
+
+ (define (build-if test consequent alternate)
+ (match alternate
+ (('if #f _) `(if ,test ,consequent))
+ (_ `(if ,test ,consequent ,alternate))))
+
+ (define (build-and xs)
+ (match xs
+ (() #t)
+ ((x) x)
+ (_ `(and ,@xs))))
+
+ (define (build-or xs)
+ (match xs
+ (() #f)
+ ((x) x)
+ (_ `(or ,@xs))))
+
+ (define (case-test-var test)
+ (match test
+ (('memv (? atom? v) ('quote (datums ...)))
+ v)
+ (('eqv? (? atom? v) ('quote datum))
+ v)
+ (_ #f)))
+
+ (define (test->datums v test)
+ (match (cons v test)
+ ((v 'memv v ('quote (xs ...)))
+ xs)
+ ((v 'eqv? v ('quote x))
+ (list x))
+ (_ #f)))
+
+ (define (build-else-tail e)
+ (match e
+ (('if #f _) '())
+ (('and xs ... x) `((,(build-and xs) ,@(build-begin-body x))
+ (else #f)))
+ (_ `((else ,@(build-begin-body e))))))
+
+ (define (build-cond-else-tail e)
+ (match e
+ (('cond clauses ...) clauses)
+ (_ (build-else-tail e))))
+
+ (define (build-case-else-tail v e)
+ (match (cons v e)
+ ((v 'case v clauses ...)
+ clauses)
+ ((v 'if ('memv v ('quote (xs ...))) consequent . alternate*)
+ `((,xs ,@(build-begin-body consequent))
+ ,@(build-case-else-tail v (build-begin alternate*))))
+ ((v 'if ('eqv? v ('quote x)) consequent . alternate*)
+ `(((,x) ,@(build-begin-body consequent))
+ ,@(build-case-else-tail v (build-begin alternate*))))
+ (_ (build-else-tail e))))
+
+ (define (clauses+tail clauses)
+ (match clauses
+ ((cs ... (and c ('else . _))) (values cs (list c)))
+ (_ (values clauses '()))))
+
+ (define (build-cond tests consequents alternate)
+ (case (length tests)
+ ((0) alternate)
+ ((1) (build-if (car tests) (car consequents) alternate))
+ (else `(cond ,@(map (lambda (test consequent)
+ `(,test ,@(build-begin-body consequent)))
+ tests consequents)
+ ,@(build-cond-else-tail alternate)))))
+
+ (define (build-cond-or-case tests consequents alternate)
+ (if (not use-case?)
+ (build-cond tests consequents alternate)
+ (let* ((v (and (not (null? tests))
+ (case-test-var (car tests))))
+ (datum-lists (take-while identity
+ (map (cut test->datums v <>)
+ tests)))
+ (n (length datum-lists))
+ (tail (build-case-else-tail v (build-cond
+ (drop tests n)
+ (drop consequents n)
+ alternate))))
+ (receive (clauses tail) (clauses+tail tail)
+ (let ((n (+ n (length clauses)))
+ (datum-lists (append datum-lists
+ (map car clauses)))
+ (consequents (append consequents
+ (map build-begin
+ (map cdr clauses)))))
+ (if (< n 2)
+ (build-cond tests consequents alternate)
+ `(case ,v
+ ,@(map cons datum-lists (map build-begin-body
+ (take consequents n)))
+ ,@tail)))))))
+
+ (define (recurse e)
+
+ (define (recurse-body e)
+ (build-lambda-body (recurse e)))
+
+ (record-case e
+ ((<void>)
+ (build-void))
+
+ ((<const> exp)
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ `(quote ,exp)))
+
+ ((<seq> head tail)
+ (build-begin (cons (recurse head)
+ (build-begin-body
+ (recurse tail)))))
+
+ ((<call> proc args)
+ (match `(,(recurse proc) ,@(map recurse args))
+ ((('lambda (formals ...) body ...) args ...)
+ (=> failure)
+ (if (= (length formals) (length args))
+ (build-let formals args (build-begin body))
+ (failure)))
+ (e e)))
+
+ ((<primcall> name args)
+ `(,name ,@(map recurse args)))
+
+ ((<primitive-ref> name)
+ name)
+
+ ((<lexical-ref> gensym)
+ (output-name gensym))
+
+ ((<lexical-set> gensym exp)
+ `(set! ,(output-name gensym) ,(recurse exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp)))
+
+ ((<toplevel-ref> name)
+ name)
+
+ ((<toplevel-set> name exp)
+ `(set! ,name ,(recurse exp)))
+
+ ((<toplevel-define> name exp)
+ (build-define name (recurse exp)))
+
+ ((<lambda> meta body)
+ (if body
+ (let ((body (recurse body))
+ (doc (assq-ref meta 'documentation)))
+ (if (not doc)
+ body
+ (match body
+ (('lambda formals body ...)
+ `(lambda ,formals ,doc ,@body))
+ (('lambda* formals body ...)
+ `(lambda* ,formals ,doc ,@body))
+ (('case-lambda (formals body ...) clauses ...)
+ `(case-lambda (,formals ,doc ,@body) ,@clauses))
+ (('case-lambda* (formals body ...) clauses ...)
+ `(case-lambda* (,formals ,doc ,@body) ,@clauses))
+ (e e))))
+ '(case-lambda)))
+
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ (let ((names (map output-name gensyms)))
+ (cond
+ ((and (not opt) (not kw) (not alternate))
+ `(lambda ,(if rest (apply cons* names) names)
+ ,@(recurse-body body)))
+ ((and (not opt) (not kw))
+ (let ((alt-expansion (recurse alternate))
+ (formals (if rest (apply cons* names) names)))
+ (case (car alt-expansion)
+ ((lambda)
+ `(case-lambda (,formals ,@(recurse-body body))
+ ,(cdr alt-expansion)))
+ ((lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,(cdr alt-expansion)))
+ ((case-lambda)
+ `(case-lambda (,formals ,@(recurse-body body))
+ ,@(cdr alt-expansion)))
+ ((case-lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,@(cdr alt-expansion))))))
+ (else
+ (let* ((alt-expansion (and alternate (recurse alternate)))
+ (nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (restargs (if rest (list-ref names (+ nreq nopt)) '()))
+ (reqargs (list-head names nreq))
+ (optargs (if opt
+ `(#:optional
+ ,@(map list
+ (list-head (list-tail names nreq) nopt)
+ (map recurse
+ (list-head inits nopt))))
+ '()))
+ (kwargs (if kw
+ `(#:key
+ ,@(map list
+ (map output-name (map caddr (cdr kw)))
+ (map recurse
+ (list-tail inits nopt))
+ (map car (cdr kw)))
+ ,@(if (car kw)
+ '(#:allow-other-keys)
+ '()))
+ '()))
+ (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
+ (if (not alt-expansion)
+ `(lambda* ,formals ,@(recurse-body body))
+ (case (car alt-expansion)
+ ((lambda lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,(cdr alt-expansion)))
+ ((case-lambda case-lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,@(cdr alt-expansion))))))))))
+
+ ((<conditional> test consequent alternate)
+ (define (simplify-test e)
+ (match e
+ (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b)))
+ `(memv ,v '(,a ,b)))
+ (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...))))
+ `(memv ,v '(,a ,@bs)))
+ (('case (? atom? v)
+ ((datum) #t) ...
+ ('else ('eqv? v ('quote last-datum))))
+ `(memv ,v '(,@datum ,last-datum)))
+ (_ e)))
+ (match `(if ,(simplify-test (recurse test))
+ ,(recurse consequent)
+ ,@(if (void? alternate) '()
+ (list (recurse alternate))))
+ (('if test ('if ('and xs ...) consequent))
+ (build-if (build-and (cons test xs))
+ consequent
+ (build-void)))
+ ((? (const use-derived-syntax?)
+ ('if test1 ('if test2 consequent)))
+ (build-if (build-and (list test1 test2))
+ consequent
+ (build-void)))
+ (('if (? atom? x) x ('or ys ...))
+ (build-or (cons x ys)))
+ ((? (const use-derived-syntax?)
+ ('if (? atom? x) x y))
+ (build-or (list x y)))
+ (('if test consequent)
+ `(if ,test ,consequent))
+ (('if test ('and xs ...) #f)
+ (build-and (cons test xs)))
+ ((? (const use-derived-syntax?)
+ ('if test consequent #f))
+ (build-and (list test consequent)))
+ ((? (const use-derived-syntax?)
+ ('if test1 consequent1
+ ('if test2 consequent2 . alternate*)))
+ (build-cond-or-case (list test1 test2)
+ (list consequent1 consequent2)
+ (build-begin alternate*)))
+ (('if test consequent ('cond clauses ...))
+ `(cond (,test ,@(build-begin-body consequent))
+ ,@clauses))
+ (('if ('memv (? atom? v) ('quote (xs ...))) consequent
+ ('case v clauses ...))
+ `(case ,v (,xs ,@(build-begin-body consequent))
+ ,@clauses))
+ (('if ('eqv? (? atom? v) ('quote x)) consequent
+ ('case v clauses ...))
+ `(case ,v ((,x) ,@(build-begin-body consequent))
+ ,@clauses))
+ (e e)))
+
+ ((<let> gensyms vals body)
+ (match (build-let (map output-name gensyms)
+ (map recurse vals)
+ (recurse body))
+ (('let ((v e)) ('or v xs ...))
+ (=> failure)
+ (if (and (not (null? gensyms))
+ (= 3 (occurrence-count (car gensyms))))
+ `(or ,e ,@xs)
+ (failure)))
+ (('let ((v e)) ('case v clauses ...))
+ (=> failure)
+ (if (and (not (null? gensyms))
+ ;; FIXME: This fails if any of the 'memv's were
+ ;; optimized into multiple 'eqv?'s, because the
+ ;; occurrence count will be higher than we expect.
+ (= (occurrence-count (car gensyms))
+ (1+ (length (clauses+tail clauses)))))
+ `(case ,e ,@clauses)
+ (failure)))
+ (e e)))
+
+ ((<letrec> in-order? gensyms vals body)
+ (build-letrec in-order?
+ (map output-name gensyms)
+ (map recurse vals)
+ (recurse body)))
+
+ ((<fix> gensyms vals body)
+ ;; not a typo, we really do translate back to letrec. use letrec* since it
+ ;; doesn't matter, and the naive letrec* transformation does not require an
+ ;; inner let.
+ (build-letrec #t
+ (map output-name gensyms)
+ (map recurse vals)
+ (recurse body)))
+
+ ((<let-values> exp body)
+ `(call-with-values (lambda () ,@(recurse-body exp))
+ ,(recurse (make-lambda #f '() body))))
+
+ ((<prompt> escape-only? tag body handler)
+ `(call-with-prompt
+ ,(recurse tag)
+ ,(if escape-only?
+ `(lambda () ,(recurse body))
+ (recurse body))
+ ,(recurse handler)))
+
+
+ ((<abort> tag args tail)
+ `(apply abort ,(recurse tag) ,@(map recurse args)
+ ,(recurse tail)))))
+ (values (recurse e) env)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Algorithm for choosing better variable names
+;; ============================================
+;;
+;; First we perform an analysis pass, collecting the following
+;; information:
+;;
+;; * For each gensym: how many occurrences will occur in the output?
+;;
+;; * For each gensym A: which gensyms does A conflict with? Gensym A
+;; and gensym B conflict if they have the same base name (usually the
+;; same as the source name, but see below), and if giving them the
+;; same name would cause a bad variable reference due to unintentional
+;; variable capture.
+;;
+;; The occurrence counter is indexed by gensym and is global (within each
+;; invocation of the algorithm), implemented using a hash table. We also
+;; keep a global mapping from gensym to source name as provided by the
+;; binding construct (we prefer not to trust the source names in the
+;; lexical ref or set).
+;;
+;; As we recurse down into lexical binding forms, we keep track of a
+;; mapping from base name to an ordered list of bindings, innermost
+;; first. When we encounter a variable occurrence, we increment the
+;; counter, look up the base name (preferring not to trust the 'name' in
+;; the lexical ref or set), and then look up the bindings currently in
+;; effect for that base name. Hopefully our gensym will be the first
+;; (innermost) binding. If not, we register a conflict between the
+;; referenced gensym and the other bound gensyms with the same base name
+;; that shadow the binding we want. These are simply the gensyms on the
+;; binding list that come before our gensym.
+;;
+;; Top-level bindings are treated specially. Whenever top-level
+;; references are found, they conflict with every lexical binding
+;; currently in effect with the same base name. They are guaranteed to
+;; be assigned to their source names. For purposes of recording
+;; conflicts (which are normally keyed on gensyms) top-level identifiers
+;; are assigned a pseudo-gensym that is an interned pair of the form
+;; (top-level . <name>). This allows them to be compared using 'eq?'
+;; like other gensyms.
+;;
+;; The base name is normally just the source name. However, if the
+;; source name has a suffix of the form "-N" (where N is a positive
+;; integer without leading zeroes), then we strip that suffix (multiple
+;; times if necessary) to form the base name. We must do this because
+;; we add suffixes of that form in order to resolve conflicts, and we
+;; must ensure that only identifiers with the same base name can
+;; possibly conflict with each other.
+;;
+;; XXX FIXME: Currently, primitives are treated exactly like top-level
+;; bindings. This handles conflicting lexical bindings properly, but
+;; does _not_ handle the case where top-level bindings conflict with the
+;; needed primitives.
+;;
+;; Also note that this requires that 'choose-output-names' be kept in
+;; sync with 'tree-il->scheme'. Primitives that are introduced by
+;; 'tree-il->scheme' must be anticipated by 'choose-output-name'.
+;;
+;; We also ensure that lexically-bound identifiers found in operator
+;; position will never be assigned one of the standard primitive names.
+;; This is needed because 'tree-il->scheme' recognizes primitive names
+;; in operator position and assumes that they have the standard
+;; bindings.
+;;
+;;
+;; How we assign an output name to each gensym
+;; ===========================================
+;;
+;; We process the gensyms in order of decreasing occurrence count, with
+;; each gensym choosing the best output name possible, as long as it
+;; isn't the same name as any of the previously-chosen output names of
+;; conflicting gensyms.
+;;
+
+
+;;
+;; 'choose-output-names' analyzes the top-level form e, chooses good
+;; variable names that are as close as possible to the source names,
+;; and returns two values:
+;;
+;; * a hash table mapping gensym to output name
+;; * a hash table mapping gensym to number of occurrences
+;;
+(define choose-output-names
+ (let ()
+ (define primitive?
+ ;; This is a list of primitives that 'tree-il->scheme' assumes
+ ;; will have the standard bindings when found in operator
+ ;; position.
+ (let* ((primitives '(if quote @ @@ set! define define*
+ begin let let* letrec letrec*
+ and or cond case
+ lambda lambda* case-lambda case-lambda*
+ apply call-with-values dynamic-wind
+ with-fluids fluid-ref fluid-set!
+ call-with-prompt abort memv eqv?))
+ (table (make-hash-table (length primitives))))
+ (for-each (cut hashq-set! table <> #t) primitives)
+ (lambda (name) (hashq-ref table name))))
+
+ ;; Repeatedly strip suffix of the form "-N", where N is a string
+ ;; that could be produced by number->string given a positive
+ ;; integer. In other words, the first digit of N may not be 0.
+ (define compute-base-name
+ (let ((digits (string->char-set "0123456789")))
+ (define (base-name-string str)
+ (let ((i (string-skip-right str digits)))
+ (if (and i (< (1+ i) (string-length str))
+ (eq? #\- (string-ref str i))
+ (not (eq? #\0 (string-ref str (1+ i)))))
+ (base-name-string (substring str 0 i))
+ str)))
+ (lambda (sym)
+ (string->symbol (base-name-string (symbol->string sym))))))
+
+ ;; choose-output-names
+ (lambda (e use-derived-syntax? strip-numeric-suffixes?)
+
+ (define lexical-gensyms '())
+
+ (define top-level-intern!
+ (let ((table (make-hash-table)))
+ (lambda (name)
+ (let ((h (hashq-create-handle! table name #f)))
+ (or (cdr h) (begin (set-cdr! h (cons 'top-level name))
+ (cdr h)))))))
+ (define (top-level? s) (pair? s))
+ (define (top-level-name s) (cdr s))
+
+ (define occurrence-count-table (make-hash-table))
+ (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0))
+ (define (increment-occurrence-count! s)
+ (let ((h (hashq-create-handle! occurrence-count-table s 0)))
+ (if (zero? (cdr h))
+ (set! lexical-gensyms (cons s lexical-gensyms)))
+ (set-cdr! h (1+ (cdr h)))))
+
+ (define base-name
+ (let ((table (make-hash-table)))
+ (lambda (name)
+ (let ((h (hashq-create-handle! table name #f)))
+ (or (cdr h) (begin (set-cdr! h (compute-base-name name))
+ (cdr h)))))))
+
+ (define source-name-table (make-hash-table))
+ (define (set-source-name! s name)
+ (if (not (top-level? s))
+ (let ((name (if strip-numeric-suffixes?
+ (base-name name)
+ name)))
+ (hashq-set! source-name-table s name))))
+ (define (source-name s)
+ (if (top-level? s)
+ (top-level-name s)
+ (hashq-ref source-name-table s)))
+
+ (define conflict-table (make-hash-table))
+ (define (conflicts s) (or (hashq-ref conflict-table s) '()))
+ (define (add-conflict! a b)
+ (define (add! a b)
+ (if (not (top-level? a))
+ (let ((h (hashq-create-handle! conflict-table a '())))
+ (if (not (memq b (cdr h)))
+ (set-cdr! h (cons b (cdr h)))))))
+ (add! a b)
+ (add! b a))
+
+ (let recurse-with-bindings ((e e) (bindings vlist-null))
+ (let recurse ((e e))
+
+ ;; We call this whenever we encounter a top-level ref or set
+ (define (top-level name)
+ (let ((bname (base-name name)))
+ (let ((s (top-level-intern! name))
+ (conflicts (vhash-foldq* cons '() bname bindings)))
+ (for-each (cut add-conflict! s <>) conflicts))))
+
+ ;; We call this whenever we encounter a primitive reference.
+ ;; We must also call it for every primitive that might be
+ ;; inserted by 'tree-il->scheme'. It is okay to call this
+ ;; even when 'tree-il->scheme' will not insert the named
+ ;; primitive; the worst that will happen is for a lexical
+ ;; variable of the same name to be renamed unnecessarily.
+ (define (primitive name) (top-level name))
+
+ ;; We call this whenever we encounter a lexical ref or set.
+ (define (lexical s)
+ (increment-occurrence-count! s)
+ (let ((conflicts
+ (take-while
+ (lambda (s*) (not (eq? s s*)))
+ (reverse! (vhash-foldq* cons
+ '()
+ (base-name (source-name s))
+ bindings)))))
+ (for-each (cut add-conflict! s <>) conflicts)))
+
+ (record-case e
+ ((<void>) (primitive 'if)) ; (if #f #f)
+ ((<const>) (primitive 'quote))
+
+ ((<call> proc args)
+ (if (lexical-ref? proc)
+ (let* ((gensym (lexical-ref-gensym proc))
+ (name (source-name gensym)))
+ ;; If the operator position contains a bare variable
+ ;; reference with the same source name as a standard
+ ;; primitive, we must ensure that it will be given a
+ ;; different name, so that 'tree-il->scheme' will not
+ ;; misinterpret the resulting expression.
+ (if (primitive? name)
+ (add-conflict! gensym (top-level-intern! name)))))
+ (recurse proc)
+ (for-each recurse args))
+
+ ((<primitive-ref> name) (primitive name))
+ ((<primcall> name args) (primitive name) (for-each recurse args))
+
+ ((<lexical-ref> gensym) (lexical gensym))
+ ((<lexical-set> gensym exp)
+ (primitive 'set!) (lexical gensym) (recurse exp))
+
+ ((<module-ref> public?) (primitive (if public? '@ '@@)))
+ ((<module-set> public? exp)
+ (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp))
+
+ ((<toplevel-ref> name) (top-level name))
+ ((<toplevel-set> name exp)
+ (primitive 'set!) (top-level name) (recurse exp))
+ ((<toplevel-define> name exp) (top-level name) (recurse exp))
+
+ ((<conditional> test consequent alternate)
+ (cond (use-derived-syntax?
+ (primitive 'and) (primitive 'or)
+ (primitive 'cond) (primitive 'case)
+ (primitive 'else) (primitive '=>)))
+ (primitive 'if)
+ (recurse test) (recurse consequent) (recurse alternate))
+
+ ((<seq> head tail)
+ (primitive 'begin) (recurse head) (recurse tail))
+
+ ((<lambda> body)
+ (if body (recurse body) (primitive 'case-lambda)))
+
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ (primitive 'lambda)
+ (cond ((or opt kw alternate)
+ (primitive 'lambda*)
+ (primitive 'case-lambda)
+ (primitive 'case-lambda*)))
+ (primitive 'let)
+ (if use-derived-syntax? (primitive 'let*))
+ (let* ((names (append req (or opt '()) (if rest (list rest) '())
+ (map cadr (if kw (cdr kw) '()))))
+ (base-names (map base-name names))
+ (body-bindings
+ (fold vhash-consq bindings base-names gensyms)))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (for-each recurse inits)
+ (recurse-with-bindings body body-bindings)
+ (if alternate (recurse alternate))))
+
+ ((<let> names gensyms vals body)
+ (primitive 'let)
+ (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (for-each recurse vals)
+ (recurse-with-bindings
+ body (fold vhash-consq bindings (map base-name names) gensyms)))
+
+ ((<letrec> in-order? names gensyms vals body)
+ (primitive 'let)
+ (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+ (primitive (if in-order? 'letrec* 'letrec))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (let* ((base-names (map base-name names))
+ (bindings (fold vhash-consq bindings base-names gensyms)))
+ (for-each (cut recurse-with-bindings <> bindings) vals)
+ (recurse-with-bindings body bindings)))
+
+ ((<fix> names gensyms vals body)
+ (primitive 'let)
+ (primitive 'letrec*)
+ (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (let* ((base-names (map base-name names))
+ (bindings (fold vhash-consq bindings base-names gensyms)))
+ (for-each (cut recurse-with-bindings <> bindings) vals)
+ (recurse-with-bindings body bindings)))
+
+ ((<let-values> exp body)
+ (primitive 'call-with-values)
+ (recurse exp) (recurse body))
+
+ ((<prompt> tag body handler)
+ (primitive 'call-with-prompt)
+ (recurse tag) (recurse body) (recurse handler))
+
+ ((<abort> tag args tail)
+ (primitive 'apply)
+ (primitive 'abort)
+ (recurse tag) (for-each recurse args) (recurse tail)))))
+
+ (let ()
+ (define output-name-table (make-hash-table))
+ (define (set-output-name! s name)
+ (hashq-set! output-name-table s name))
+ (define (output-name s)
+ (if (top-level? s)
+ (top-level-name s)
+ (hashq-ref output-name-table s)))
+
+ (define sorted-lexical-gensyms
+ (sort-list lexical-gensyms
+ (lambda (a b) (> (occurrence-count a)
+ (occurrence-count b)))))
+
+ (for-each (lambda (s)
+ (set-output-name!
+ s
+ (let ((the-conflicts (conflicts s))
+ (the-source-name (source-name s)))
+ (define (not-yet-taken? name)
+ (not (any (lambda (s*)
+ (and=> (output-name s*)
+ (cut eq? name <>)))
+ the-conflicts)))
+ (if (not-yet-taken? the-source-name)
+ the-source-name
+ (let ((prefix (string-append
+ (symbol->string the-source-name)
+ "-")))
+ (let loop ((i 1) (name the-source-name))
+ (if (not-yet-taken? name)
+ name
+ (loop (+ i 1)
+ (string->symbol
+ (string-append
+ prefix
+ (number->string i)))))))))))
+ sorted-lexical-gensyms)
+ (values output-name-table occurrence-count-table)))))
--- /dev/null
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2021 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;;; This file has been modified by Vouivre Digital Corporation. The exact
+;;;; modifications can be seen in a shell using:
+;;;; $ git diff 5226e2890df9a25bd1d33514ff67539da7794905 spec.scm
+
+;;; Code:
+
+(define-module (language vouivre spec)
+ #:use-module (system base compile)
+ #:use-module (system base language)
+ #:use-module (language vouivre compile-tree-il)
+ #:use-module (language vouivre decompile-tree-il)
+ #:use-module (vouivre curry)
+ #:export (vouivre))
+
+;;;
+;;; Language definition
+;;;
+
+(define-language vouivre
+ #:title "Vouivre"
+ #:reader (lambda (port env)
+ ;; Use the binding of current-reader from the environment.
+ ;; FIXME: Handle `read-options' as well?
+ ((or (and=> (and=> (module-variable env 'current-reader)
+ variable-ref)
+ fluid-ref)
+ read-syntax)
+ port))
+
+ #:compilers `((tree-il . ,compile-tree-il))
+ #:decompilers `((tree-il . ,decompile-tree-il))
+ #:evaluator (lambda (x module) (primitive-eval x))
+ #:printer write
+ #:make-default-environment
+ (lambda ()
+ ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
+ ;; `fluid-set!', etc. don't have any effect in the current environment.
+ (let ((m (make-fresh-user-module)))
+ ;; Provide a separate `current-reader' fluid so that
+ ;; compile-time changes to `current-reader' are
+ ;; limited to the current compilation unit.
+ (module-define! m 'current-reader (make-fluid))
+
+ ;; Default to `simple-format', as is the case until
+ ;; (ice-9 format) is loaded. This allows
+ ;; compile-time warnings to be emitted when using
+ ;; unsupported options.
+ (module-set! m 'format simple-format)
+
+ m)))
+++ /dev/null
-;;;; Copyright (C) 2023 Vouivre Digital Corporation
-;;;;
-;;;; This file is part of Vouivre.
-;;;;
-;;;; Vouivre is free software: you can redistribute it and/or
-;;;; modify it under the terms of the GNU General Public
-;;;; License as published by the Free Software Foundation, either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; Vouivre is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public
-;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
-
-(define-module (vouivre misc)
- #:use-module (ice-9 arrays)
- #:use-module (srfi srfi-1)
- #:export
- (array-map
- array-map-indexed
- flip
- for-indices-in-range
- if-let
- ifn
- list-zeros
- map-indexed
- produce-array
- produce-typed-array))
-
-(define (flip f)
- "Returns a procedure behaving as `f', but with arguments taken in reverse
-order."
- (lambda args
- (apply f (reverse args))))
-
-(define-syntax if-let
- (syntax-rules ()
- [(_ (x test) consequent alternate)
- (let ([x test])
- (if x consequent alternate))]
- [(_ (x test) consequent)
- (let ([x test])
- (if x consequent))]))
-
-(define-syntax ifn
- (syntax-rules ()
- [(_ test alternate consequent)
- (if test consequent alternate)]
- [(_ test alternate)
- (if (not test) alternate)]))
-
-(define (list-zeros n)
- (list-tabulate n (lambda _ 0)))
-
-(define (map-indexed f . lists)
- "Like `map' but the last argument of `f' is passed the corresponding index."
- (apply map f (append lists (list (list-tabulate (length (car lists))
- identity)))))
-
-(define (for-indices-in-range f starts ends)
- (define (for-indices-in-range% f indices starts ends)
- (if (null? starts)
- (apply f (reverse indices))
- (do ((i (car starts) (1+ i)))
- ((= i (car ends)))
- (for-indices-in-range%
- f
- (cons i indices)
- (cdr starts)
- (cdr ends)))))
- (for-indices-in-range% f '() starts ends))
-
-;;;; array utilities
-
-(define (produce-typed-array f type . dims)
- (let ((a (apply make-typed-array type *unspecified* dims)))
- (array-index-map! a f)
- a))
-
-(define (produce-array f . dims)
- (apply produce-typed-array f #t dims))
-
-(define (array-map proc array . more)
- (let ((x (array-copy array)))
- (apply array-map! x proc array more)
- x))
-
-(define (array-map-indexed proc array)
- (let ((x (array-copy array)))
- (array-index-map!
- x
- (lambda indices
- (apply proc
- (apply array-ref array indices)
- indices)))
- x))
+++ /dev/null
-;;;; Copyright (C) 2023 Vouivre Digital Corporation
-;;;;
-;;;; This file is part of Vouivre.
-;;;;
-;;;; Vouivre is free software: you can redistribute it and/or
-;;;; modify it under the terms of the GNU General Public
-;;;; License as published by the Free Software Foundation, either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; Vouivre is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public
-;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
-
-(define-module (vouivre mnist)
- #:use-module (guix build download)
- #:use-module (guix build utils)
- #:use-module (ice-9 binary-ports)
- #:use-module (rnrs bytevectors)
- #:use-module (srfi srfi-1)
- #:use-module (vouivre misc)
- #:use-module (web uri)
- #:export (load-mnist))
-
-;; NOTE: The directory and url must not include any trailing '/' character.
-(define directory "mnist")
-(define url "http://yann.lecun.com/exdb/mnist")
-(define trn-imgs-fname "train-images-idx3-ubyte")
-(define trn-lbls-fname "train-labels-idx1-ubyte")
-
-(define (exists? fname)
- "Return `#t' if the file with the given name exists and `#f' otherwise."
- (catch 'system-error
- (lambda ()
- (with-input-from-file fname
- (lambda () #t)
- #:binary #t))
- (lambda _ #f)))
-
-(define (load-mnist nb-items download?)
- "Return the given number of data points from the MNIST dataset downloading it
-if needed and requested in the ./mnist directory.
-
-The data is a cons cell containing an array (nb-items, height, width) of
-training images and an array (nb-items) of corresponding labels."
- (define (read-uint bytes)
- (bytevector-uint-ref (get-bytevector-n (current-input-port)
- bytes)
- 0
- (endianness big)
- bytes))
- (apply
- cons
- (map
- (lambda (base-name magic rank)
- (let ((fname (string-append directory "/" base-name)))
- (let redo ((download? download?))
- (if (exists? fname)
- (with-input-from-file fname
- (lambda ()
- (when (not (= magic (read-uint 4)))
- (error "Unsupported file magic number."))
- (let* ((n (min nb-items (read-uint 4)))
- (dims (list-tabulate rank (lambda (x) (read-uint 4))))
- (n-dims (apply * n dims))
- (a (apply make-typed-array 'u8 0 n dims))
- (ac (array-contents a)))
- (let lp ((i 0))
- (if (= i n-dims)
- a
- (begin
- (array-set! ac (read-uint 1) i)
- (lp (1+ i)))))))
- #:binary #t)
- (ifn download?
- (error (string-append "The MNIST dataset doesn't exist. If you tried with `download?' to `#t' already, to no avail, you can download the files manually from " url ", and extract them to a \"mnist\" directory at the root of the project. You can also file a bug report."))
- (let ((gzname (string-append fname ".gz")))
- (invoke "mkdir" "-p" directory)
- (call-with-output-file gzname
- (lambda (port)
- (put-bytevector
- port
- (get-bytevector-all
- (http-fetch
- (string->uri
- (string-append url "/" base-name ".gz"))))))
- #:binary #t)
- (invoke "gunzip" gzname)
- (redo #f)))))))
- (list trn-imgs-fname trn-lbls-fname)
- (list 2051 2049)
- (list 2 0))))
--- /dev/null
+#!/bin/sh
+
+abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`"
+abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`"
+
+GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
+GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH"
+export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
+
+PATH="$abs_top_builddir/scripts:$PATH"
+export PATH
+
+exec "$@"
+++ /dev/null
-;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms
-
-;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
-;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
-
-;; Permission is hereby granted, free of charge, to any person
-;; obtaining a copy of this software and associated documentation
-;; files (the "Software"), to deal in the Software without
-;; restriction, including without limitation the rights to use, copy,
-;; modify, merge, publish, distribute, sublicense, and/or sell copies
-;; of the Software, and to permit persons to whom the Software is
-;; furnished to do so, subject to the following conditions:
-
-;; The above copyright notice and this permission notice shall be
-;; included in all copies or substantial portions of the Software.
-
-;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-;; SOFTWARE.
-
-;; This file has been modified by Vouivre Digital Corporation. The exact
-;; modifications can be seen in a shell using:
-;; $ git diff b4695cd888df6511915262884d2ce317156f92e8 promises.scm
-
-;;; Commentary:
-
-;; This is the code of the reference implementation of SRFI-45, modified
-;; to use SRFI-9 and to add 'promise?' to the list of exports.
-
-;; This module is documented in the Guile Reference Manual.
-
-;;; Code:
-
-(define-module (vouivre promises)
- #:export (*promises* reset-promises)
- #:replace (delay force)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-9 gnu))
-
-(define *promises* (make-parameter #f))
-
-(define-record-type promise (make-promise val) promise?
- (val promise-val promise-val-set!))
-
-(define-record-type value (make-value tag proc rec) value?
- (tag value-tag value-tag-set!)
- (proc value-proc value-proc-set!)
- (rec value-rec value-rec-set!))
-
-(define-syntax-rule (lazy exp)
- (let ((proc (lambda () exp)))
- (make-promise (make-value 'lazy proc proc))))
-
-(define (eager x)
- (make-promise (make-value 'eager x #f)))
-
-(define-syntax-rule (delay exp)
- (let ((promise (lazy (eager exp)))
- (promises-ptr (*promises*)))
- (set-car! promises-ptr (cons promise (car promises-ptr)))
- promise))
-
-(define (force promise)
- (let ((content (promise-val promise)))
- (case (value-tag content)
- ((eager)
- (value-proc content))
- ((lazy)
- (let* ((promise* ((value-proc content)))
- (content (promise-val promise))) ; *
- (unless (eqv? 'eager (value-tag content)) ; *
- (value-tag-set! content (value-tag (promise-val promise*)))
- (value-proc-set! content (value-proc (promise-val promise*)))
- (promise-val-set! promise* content))
- (force promise))))))
-;; (*) These two lines re-fetch and check the original promise in case
-;; the first line of the let* caused it to be forced. For an example
-;; where this happens, see reentrancy test 3 below.
-
-(define (reset-promises promises)
- (unless (null? promises)
- (let ((v (promise-val (car promises))))
- (when (value-rec v)
- (value-proc-set! v (value-rec v))
- (value-tag-set! v 'lazy))
- (reset-promises (cdr promises)))))
-
-(define* (promise-visit promise #:key on-eager on-lazy)
- (define content (promise-val promise))
- (case (value-tag content)
- ((eager) (on-eager (value-proc content)))
- ((lazy) (on-lazy (value-proc content)))))
-
-(set-record-type-printer! promise
- (lambda (promise port)
- (promise-visit promise
- #:on-eager (lambda (value)
- (format port "#<promise = ~s>" value))
- #:on-lazy (lambda (proc)
- (format port "#<promise => ~s>" proc)))))
+++ /dev/null
-;;; Guile Scheme specification
-
-;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2021 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;;; This file has been modified by Vouivre Digital Corporation. The exact
-;;;; modifications can be seen in a shell using:
-;;;; $ git diff 5226e2890df9a25bd1d33514ff67539da7794905 spec.scm
-
-;;; Code:
-
-(define-module (language vouivre spec)
- #:use-module (system base compile)
- #:use-module (system base language)
- #:use-module (language vouivre compile-tree-il)
- #:use-module (language vouivre decompile-tree-il)
- #:use-module (vouivre curry)
- #:export (vouivre))
-
-;;;
-;;; Language definition
-;;;
-
-(define-language vouivre
- #:title "Vouivre"
- #:reader (lambda (port env)
- ;; Use the binding of current-reader from the environment.
- ;; FIXME: Handle `read-options' as well?
- ((or (and=> (and=> (module-variable env 'current-reader)
- variable-ref)
- fluid-ref)
- read-syntax)
- port))
-
- #:compilers `((tree-il . ,compile-tree-il))
- #:decompilers `((tree-il . ,decompile-tree-il))
- #:evaluator (lambda (x module) (primitive-eval x))
- #:printer write
- #:make-default-environment
- (lambda ()
- ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
- ;; `fluid-set!', etc. don't have any effect in the current environment.
- (let ((m (make-fresh-user-module)))
- ;; Provide a separate `current-reader' fluid so that
- ;; compile-time changes to `current-reader' are
- ;; limited to the current compilation unit.
- (module-define! m 'current-reader (make-fluid))
-
- ;; Default to `simple-format', as is the case until
- ;; (ice-9 format) is loaded. This allows
- ;; compile-time warnings to be emitted when using
- ;; unsupported options.
- (module-set! m 'format simple-format)
-
- m)))
--- /dev/null
+;;;; Copyright (C) 2023 Vouivre Digital Corporation
+;;;;
+;;;; This file is part of Vouivre.
+;;;;
+;;;; Vouivre is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public
+;;;; License as published by the Free Software Foundation, either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; Vouivre is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (vouivre autodiff tests)
+ #:use-module ((vouivre autodiff) #:prefix v:)
+ #:use-module (ice-9 receive)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-64)
+ #:use-module (vouivre misc)
+ #:export
+ (apply-diff
+ a~
+ const-generator
+ differentiable-func-generator
+ lambda-const-call
+ ndiff
+ n~
+ random-array
+ random-array-shape
+ random-func1
+ random-func2
+ random-func2-rank&dims>0
+ random-input
+ random-list-element
+ random-non-empty-array
+ random-shape
+ random-shared
+ random-shared-array-rank&dims>0
+ random-shared-contractible
+ with-generators
+ ~))
+
+(define f1s (list v:abs v:cos v:exp v:identity v:sin))
+(define f2s (list v:+ v:- v:* v:max v:min))
+
+(define (with-generators% generators equal proc1 proc2 . more)
+ "Check that all procedures return the same value according to `equal' when
+evaluated on arguments produced by the generators (the number of generators
+being the number of arguments to each procedure."
+ (let ((times 100)
+ (procs (cons proc1 (cons proc2 more))))
+ (call/cc
+ (lambda (break)
+ (do ((i 0 (1+ i)))
+ ((= i times) #t)
+ (let ((zs (map-in-order (lambda (g) (g)) generators)))
+ (with-exception-handler
+ (lambda (e)
+ (break #f zs))
+ (lambda ()
+ (let* ((rs (map (lambda (f) (apply f zs)) procs))
+ (head (car rs)))
+ (unless (every (lambda (x) (equal x head))
+ (cdr rs))
+ (break #f zs rs))))
+ #:unwind? #t)))))))
+
+(define-syntax-rule (with-generators (g1 g2 ...) equal expected given more ...)
+ (with-generators% (list g1 g2 ...) equal expected given more ...))
+
+(define (lambda-const-call f . consts)
+ (lambda _
+ (apply f consts)))
+
+(define* (random-array-shape
+ #:optional (min-rank 0) (max-rank 5) (min-dim 0) (max-dim 5))
+ (list-tabulate (+ min-rank (random (- max-rank min-rank)))
+ (lambda _ (+ min-dim (random (- max-dim min-dim))))))
+
+(define (random-shape)
+ (if (= 0 (random 2))
+ 0
+ (random-array-shape)))
+
+(define* (random-array #:optional shape)
+ (apply produce-typed-array
+ (lambda _ (random:uniform))
+ v:*atype* (or shape (random-array-shape))))
+
+(define (random-non-empty-array)
+ "Random array of at least one element."
+ (random-array (random-array-shape 0 5 1 5)))
+
+(define* (random-input #:optional shape)
+ (let ((shape (or shape (random-shape))))
+ (if (eq? 0 shape)
+ (random:uniform)
+ (random-array shape))))
+
+(define (random-shared)
+ (let ((shape (random-shape)))
+ (values
+ (lambda ()
+ (random-input shape))
+ (lambda ()
+ (let ((x (random-input
+ (random-list-element
+ (list 0 (if (list? shape)
+ shape
+ (random-shape)))))))
+ (set! shape (random-shape))
+ x)))))
+
+(define (random-shared-array-rank&dims>0)
+ (let ((shape (random-array-shape 1 5 1 5)))
+ (values
+ (lambda ()
+ (random-array shape))
+ (lambda ()
+ (let ((x (random-array shape)))
+ (set! shape (random-array-shape 1 5 1 5))
+ x)))))
+
+(define (random-list-element lst)
+ (list-ref lst (random (length lst))))
+
+(define (const-generator generator)
+ (lambda ()
+ generator))
+
+(define (differentiable-func-generator lst . input-generators)
+ (lambda ()
+ (random-list-element
+ (cons
+ (apply
+ lambda-const-call
+ (random-list-element lst)
+ (map (lambda (g) (g))
+ input-generators))
+ lst))))
+
+(define random-func1
+ (differentiable-func-generator f1s random-input))
+(define random-func2
+ (receive (gx gy) (random-shared)
+ (differentiable-func-generator f2s gx gy)))
+
+(define* (n~ x y #:optional (error 1e-4))
+ (and
+ (>= y (- x error))
+ (<= y (+ x error))))
+
+(define* (a~ x y #:optional (error 1e-4))
+ (and
+ (equal? (array-dimensions x)
+ (array-dimensions y))
+ (call/cc
+ (lambda (break)
+ (array-for-each
+ (lambda (x y)
+ (unless (~ x y error)
+ (break #f)))
+ x y)
+ #t))))
+
+(define* (~ x y #:optional (error 1e-4))
+ (cond
+ ((and (number? x) (number? y))
+ (n~ x y error))
+ ((and (array? x) (array? y))
+ (a~ x y error))
+ (else #f)))
+
+(define* (ndiff f #:optional (axis 0) (step 1e-6))
+ "Differentiation using a numerical centered difference approximation."
+ (define (axis-add xs dh . indices)
+ "Add `dh' to the number or array at the given `axis' of `xs',
+and, when it's an array, at the given index."
+ (map-indexed
+ (lambda (x i)
+ (ifn (= i axis)
+ x
+ (if (number? x)
+ (+ x dh)
+ (array-map-indexed
+ (lambda (x . indices_)
+ (ifn (equal? indices indices_)
+ x
+ (+ x dh)))
+ x))))
+ xs))
+ (lambda xs
+ ;; We need the output shape and the input shape along the
+ ;; differentiated axis.
+ (let ((fxs (apply f xs))
+ (x (list-ref xs axis)))
+ (cond
+ ((and (number? fxs)
+ (number? x))
+ (/ (- (apply f (axis-add xs step))
+ (apply f (axis-add xs (- step))))
+ (* 2 step)))
+ ((and (number? fxs)
+ (array? x))
+ (apply
+ produce-typed-array
+ (lambda indices
+ (/ (- (apply f (apply axis-add xs step indices))
+ (apply f (apply axis-add xs (- step) indices)))
+ (* 2 step)))
+ v:*atype*
+ (array-dimensions x)))
+ ((and (array? fxs)
+ (number? x))
+ ((v:extend /)
+ ((v:extend -)
+ (apply f (axis-add xs step))
+ (apply f (axis-add xs (- step))))
+ (* 2 step)))
+ ((and (array? fxs)
+ (array? x))
+ (let ((a (apply
+ make-typed-array v:*atype* *unspecified*
+ (append (array-dimensions fxs)
+ (array-dimensions x)))))
+ (for-indices-in-range
+ (lambda indices-in
+ (let ((dfxs ((v:extend /)
+ ((v:extend -)
+ (apply f (apply axis-add xs step indices-in))
+ (apply f (apply axis-add xs (- step) indices-in)))
+ (* 2 step))))
+ (for-indices-in-range
+ (lambda indices-out
+ (apply
+ array-set!
+ a
+ (apply array-ref dfxs indices-out)
+ (append indices-out indices-in)))
+ (list-zeros (array-rank fxs))
+ (array-dimensions fxs))))
+ (list-zeros (array-rank x))
+ (array-dimensions x))
+ a))))))
+
+(define* (apply-diff differentiator #:optional (axis 0))
+ "Apply a differentiator (`ndiff', `fdiff', `rdiff') to a function and its
+arguments (this is a convenience function)."
+ (lambda (f . args)
+ (apply (differentiator f axis) args)))
+
+(test-begin "autodiff")
+
+;; not differentiating
+(test-assert (with-generators (random-input) ~ (v:extend identity) v:identity))
+(test-assert (with-generators (random-input) ~ (v:extend exp) v:exp))
+(test-assert
+ (receive (gx gy) (random-shared)
+ (with-generators (gx gy) ~ (v:extend *) v:*)))
+
+;; differentiation in one variable
+(test-assert
+ (with-generators
+ (random-func1 random-input)
+ ~ (apply-diff ndiff) (apply-diff v:fdiff) (apply-diff v:rdiff)))
+
+;; `v:mean' only takes non-empty arrays so we treat it separately
+(test-assert
+ (with-generators
+ ((differentiable-func-generator (list v:mean) random-non-empty-array)
+ random-non-empty-array)
+ ~ (apply-diff ndiff) (apply-diff v:fdiff) (apply-diff v:rdiff)))
+
+;; differentiation in two variables
+(test-assert
+ (receive (gx gy) (random-shared)
+ (with-generators
+ (random-func2 gx gy)
+ ~ (apply-diff ndiff 0) (apply-diff v:fdiff 0) (apply-diff v:rdiff 0))))
+(test-assert
+ (receive (gx gy) (random-shared)
+ (with-generators
+ (random-func2 gx gy)
+ ~ (apply-diff ndiff 1) (apply-diff v:fdiff 1) (apply-diff v:rdiff 1))))
+
+;; `v:amap2' only takes arrays of rank > 0 and batch-size > 0 so we treat it
+;; separately
+(define random-func2-rank&dims>0
+ (receive (gx gy) (random-shared-array-rank&dims>0)
+ (differentiable-func-generator f2s gx gy)))
+(test-assert
+ (receive (gx gy) (random-shared-array-rank&dims>0)
+ (with-generators
+ ((const-generator v:amap2) random-func2-rank&dims>0 gx gy)
+ ;; NOTE: for `v:amap2' the differentiable axes are 1 and 2.
+ ~ (apply-diff ndiff 1) (apply-diff v:fdiff 1) (apply-diff v:rdiff 1))))
+(test-assert
+ (receive (gx gy) (random-shared-array-rank&dims>0)
+ (with-generators
+ ((const-generator v:amap2) random-func2-rank&dims>0 gx gy)
+ ~ (apply-diff ndiff 2) (apply-diff v:fdiff 2) (apply-diff v:rdiff 2))))
+(let* ((z #(1 2 3))
+ (f (lambda (a)
+ (v:amap2 (lambda (x y)
+ (v:* a a))
+ #(10 20 30)
+ #(40 50 60))))
+ (e ((ndiff f) z)))
+ (test-assert (~ e ((v:fdiff f) z)))
+ (test-assert (~ e ((v:rdiff f) z))))
+
+;; `v:adot'
+(define (random-shared-contractible)
+ "Returns three generators: the first two generate arrays that are contractible
+according to the number generated by the third one."
+ (let* ((n (random 5))
+ (sa (random-array-shape n))
+ (sb (append (reverse (take (reverse sa)
+ n))
+ (random-array-shape 0 (- 5 n)))))
+ (values
+ (lambda ()
+ (random-array sa))
+ (lambda ()
+ (random-array sb))
+ (lambda ()
+ (let ((tmp n))
+ (set! n (random 5))
+ (set! sa (random-array-shape n))
+ (set! sb (append (reverse (take (reverse sa)
+ n))
+ (random-array-shape 0 (- 5 n))))
+ tmp)))))
+(test-assert
+ (receive (gx gy gz) (random-shared-contractible)
+ (with-generators
+ ((const-generator v:adot) gx gy gz)
+ ~ (apply-diff ndiff 0) (apply-diff v:fdiff 0) (apply-diff v:rdiff 0))))
+(test-assert
+ (receive (gx gy gz) (random-shared-contractible)
+ (with-generators
+ ((const-generator v:adot) gx gy gz)
+ ~ (apply-diff ndiff 1) (apply-diff v:fdiff 1) (apply-diff v:rdiff 1))))
+
+;; let binding re-entry
+(test-assert
+ (with-generators
+ ((const-generator
+ (lambda (x)
+ (let ((c (v:maximum x)))
+ (v:+ c (v:- x c)))))
+ random-non-empty-array)
+ ~ (apply-diff ndiff) (apply-diff v:fdiff) (apply-diff v:rdiff)))
+
+;; chain rule
+(test-assert
+ (with-generators
+ (random-func1 random-func1 random-input)
+ ~
+ (lambda (f g x) ((ndiff (compose f g)) x))
+ (lambda (f g x) ((v:fdiff (compose f g)) x))
+ (lambda (f g x) ((v:rdiff (compose f g)) x))))
+
+(test-end "autodiff")
--- /dev/null
+;;;; Copyright (C) 2023 Vouivre Digital Corporation
+;;;;
+;;;; This file is part of Vouivre.
+;;;;
+;;;; Vouivre is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public
+;;;; License as published by the Free Software Foundation, either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; Vouivre is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (vouivre curry tests)
+ #:use-module (vouivre curry)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-71))
+
+(test-begin "curry")
+;; TODO: map the reduxtab to a bare version for unit-testing
+;; (test-assert
+;; (lset=
+;; 'equal?
+;; '((1 . (2 . 4)) (2 . 2) (3 . 2))
+;; (compare
+;; (parse '(1 . (2 . 3)))
+;; (parse '((1 . 2) . (1 . 1))))))
+
+(define-syntax-rule (test-type given expected-bare)
+ (test-assert (equal-types? given (parse expected-bare))))
+
+(define (sym-sets symtab alist)
+ (fold (lambda (x prev)
+ ((@@ (vouivre curry) sym-set) prev (car x) (cdr x)))
+ symtab alist))
+
+(let ((t e (expand '() '(λc x x))))
+ (test-type t '(1 . 1))
+ (test-equal '(lambda (x) x) e))
+(let ((t e (expand '() '(λc g (λc f (λc x (g (f x))))))))
+ (test-type t '((3 . 4) . ((2 . 3) . (2 . 4))))
+ (test-equal '(lambda (g) (lambda (f) (lambda (x) (g (f x))))) e))
+(let ((t e (expand '() '((λc x x) #t))))
+ (test-type t 0)
+ (test-equal #t (primitive-eval e)))
+(let ((bindings
+ (sym-sets
+ '()
+ `((id . ,(parse '(1 . 1)))
+ (∘ . ,(parse '((2 . 3) . ((1 . 2) . (1 . 3)))))
+ (⊙ . ,(parse '((1 . 2) . ((2 . 3) . (1 . 3)))))
+ (map . ,(parse '((0 . 0) . (0 . 0))))
+ (+ . ,(parse '(0 . (0 . 0))))))))
+ (let ((t e (expand bindings '(∘ id id))))
+ (test-type t '(7 . 7))
+ (test-equal e '((∘ id) id)))
+ (let ((t e (expand bindings '((∘ id id) #t))))
+ (test-type t 0)
+ (test-equal e '(((∘ id) id) #t)))
+ (let ((t e (expand bindings '(∘ id id #t))))
+ (test-type t 0)
+ (test-equal e '(((∘ id) id) #t)))
+ (let ((t e (expand bindings '(λc f (∘ f)))))
+ (test-type t '((2 . 3) . ((1 . 2) . (1 . 3)))))
+ (let ((t e (expand bindings '(map (+ 1) '(1 2 3)))))
+ (test-type t 0)
+ (test-equal e '((map (+ 1)) '(1 2 3))))
+ (let ((t e (expand bindings '(∘ +))))
+ (test-type t '((1 . 0) . (1 . (0 . 0))))
+ (test-equal e '(∘ +)))
+ (let ((t e (expand bindings '((∘ +) (+ 1) 2 3))))
+ (test-type t 0)
+ (test-equal e '((((∘ +) (+ 1)) 2) 3)))
+ (let ((t e (expand bindings '((∘ + (+ 1)) 2 3))))
+ (test-type t 0)
+ (test-equal e '((((∘ +) (+ 1)) 2) 3)))
+ (let ((t e (expand bindings '(((∘ + (+ 1)) 2) 3))))
+ (test-type t 0)
+ (test-equal e '((((∘ +) (+ 1)) 2) 3)))
+ (let ((t e (expand bindings '((∘ (∘ (+ 1)) +) 2 3))))
+ (test-type t 0)
+ (test-equal e '((((∘ (∘ (+ 1))) +) 2) 3)))
+ (let ((t e (expand bindings '((∘ (⊙ (+ 1)) +) 2 3))))
+ (test-type t 0)
+ (test-equal e '((((∘ (⊙ (+ 1))) +) 2) 3))))
+
+;;; interaction between typed and untyped (regular) scheme
+
+;; Untyped scheme produces untyped return.
+(let ((t e (expand '() '(+ 1 2 3))))
+ (test-type t #f)
+ (test-equal e '(+ 1 2 3)))
+
+(let ((bindings
+ (sym-sets
+ '()
+ `((* . ,(parse '(0 . (0 . 0))))))))
+ ;; Typed Scheme can be used by untyped Scheme...
+ (let ((t e (expand bindings '(+ 1 (* 2 3) 4))))
+ (test-type t #f)
+ (test-equal e '(+ 1 ((* 2) 3) 4)))
+
+ ;; ... although, sometimes, with terrible runtime consequences!
+ (let ((t e (expand bindings '(+ 1 (* 2) 3))))
+ (test-type t #f)
+ (test-equal e '(+ 1 (* 2) 3)))
+
+ ;; On the other hand, typed Scheme expects typed Scheme.
+ (test-error (expand bindings '(* 1 (+ 2 3)))))
+
+(test-end "curry")
--- /dev/null
+;;;; Copyright (C) 2023 Vouivre Digital Corporation
+;;;;
+;;;; This file is part of Vouivre.
+;;;;
+;;;; Vouivre is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public
+;;;; License as published by the Free Software Foundation, either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; Vouivre is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (vouivre autodiff)
+ #:use-module (ice-9 receive)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (vouivre misc)
+ #:use-module (vouivre promises)
+ #:export
+ (*atype*
+ adot
+ amap2
+ contract-arrays
+ differentiable-wrapper
+ dot
+ do-times
+ ewise1
+ ewise2
+ extend
+ fdiff
+ rdiff
+ make-batch
+ make-internal
+ maximum
+ mean
+ rank-of
+ sum)
+ #:replace
+ ((i:sqrt . sqrt)
+ (i:exp . exp)
+ (i:expt . expt)
+ (i:log . log)
+ (i:sin . sin)
+ (i:cos . cos)
+ (i:tan . tan)
+ (i:+ . +)
+ (i:- . -)
+ (i:* . *)
+ (i:/ . /)
+ (i:max . max)
+ (i:min . min)
+ (i:abs . abs)
+ (i:identity . identity)
+ (i:array-ref . array-ref)
+ (i:array-cell-ref . array-cell-ref))
+ #:re-export
+ (fold
+ reduce))
+
+;;;; array utilities
+
+(define (rel->abs indices dimensions)
+ (let rec ((s 0)
+ (p 1)
+ (is (reverse indices))
+ (ds (reverse dimensions)))
+ (if (null? is)
+ s
+ (rec (+ s (* p (car is)))
+ (* p (car ds))
+ (cdr is)
+ (cdr ds)))))
+
+(define(do-times n proc)
+ (let rec ((i 0))
+ (unless (= i n)
+ (proc i)
+ (rec (1+ i)))))
+
+(define (contract-arrays a b n)
+ (let* ((dims-a (array-dimensions a))
+ (dims-b (array-dimensions b))
+ (free-dims-a (take dims-a (- (array-rank a) n)))
+ (free-dims-b (drop dims-b n))
+ (bound-dims (take dims-b n))
+ (n-free-dims-a (apply * free-dims-a))
+ (n-free-dims-b (apply * free-dims-b))
+ (n-bound-dims (apply * bound-dims))
+ (s 0)
+ (r (apply make-typed-array *atype* *unspecified* (append free-dims-a
+ free-dims-b)))
+ (ac (array-contents a))
+ (bc (array-contents b))
+ (rc (array-contents r)))
+ (do-times
+ n-free-dims-a
+ (lambda (i)
+ (let ((i-k (* n-bound-dims i))
+ (i-j (* n-free-dims-b i)))
+ (do-times
+ n-free-dims-b
+ (lambda (j)
+ (set! s 0)
+ (do-times
+ n-bound-dims
+ (lambda (k)
+ (set! s (+ s (* (array-ref ac (+ i-k k))
+ (array-ref bc (+ (* n-free-dims-b k) j)))))))
+ (array-set! rc s (+ i-j j)))))))
+ r))
+
+;;;; utilities that work on both numbers and arrays
+
+(define (extend f)
+ "Extend a function of one or more scalars to apply to numbers/arrays
+element-wise. All arrays must have the same dimension."
+ (define (apply-elemwise f indices args)
+ (apply f (map (lambda (x)
+ (if (number? x)
+ x
+ (apply array-ref x indices)))
+ args)))
+ (lambda xs
+ (if-let (x (find array? xs))
+ (apply
+ produce-typed-array
+ (lambda is
+ (apply-elemwise f is xs))
+ *atype*
+ (array-dimensions x))
+ (apply f xs))))
+
+(define (dot x y n)
+ (cond
+ ((and (number? x) (number? y))
+ (* x y))
+ ((and (array? x) (array? y))
+ (contract-arrays x y n))
+ ((and (array? x) (number? y))
+ ((extend *) x y))
+ ((and (number? x) (array? y))
+ ((extend *) x y))
+ (else (error "can't dot because of invalid types or ranks" x y n))))
+
+(define (rank-of x)
+ (if (number? x)
+ 0
+ (array-rank x)))
+
+;;;; differentiation
+
+(define-record-type internal
+ (make-internal forward jacobian)
+ internal?
+ (forward internal-forward)
+ (jacobian internal-jacobian))
+
+;;(define *atype* 'f32)
+(define *atype* #t)
+(define *differentiation-mode* (make-parameter #f))
+(define *n-y-dims* (make-parameter #f))
+(define *j* (make-parameter #f))
+
+(define-syntax-rule (w/j val body ...)
+ (parameterize ((*j* val))
+ body ...))
+
+(define (wrap axis)
+ (lambda (x i)
+ (if (= i axis)
+ (make-internal x 'input)
+ x)))
+
+(define (unwrap-fwd x)
+ (if (internal? x)
+ (internal-forward x)
+ x))
+
+(define (unwrap-jac x)
+ (if (internal? x)
+ (internal-jacobian x)
+ x))
+
+(define (dims-of x)
+ (if (number? x)
+ '()
+ (array-dimensions x)))
+
+(define (add dst-buf src-buf n-dims)
+ (do-times
+ n-dims
+ (lambda (i)
+ (array-set!
+ dst-buf
+ (+ (array-ref dst-buf i)
+ (array-ref src-buf i))
+ i)))
+ dst-buf)
+
+(define (movg dst-buf n-dst-dims generator naked-inputs data j)
+ (do-times
+ n-dst-dims
+ (lambda (i)
+ (array-set!
+ dst-buf
+ (apply generator naked-inputs i j data)
+ i)))
+ dst-buf)
+
+(define (addg dst-buf n-dst-dims generator naked-inputs data j)
+ (do-times
+ n-dst-dims
+ (lambda (i)
+ (array-set!
+ dst-buf
+ (+ (array-ref dst-buf i)
+ (apply generator naked-inputs i j data))
+ i)))
+ dst-buf)
+
+(define (movc dst-buf n-dst-dims src-buf n-src-dims
+ generator naked-inputs data)
+ "Contract the Jacobian column produced by the generator with the source buffer
+storing the result in the destination buffer."
+ (let ((s 0))
+ (do-times
+ n-dst-dims
+ (lambda (i)
+ (set! s 0)
+ (do-times
+ n-src-dims
+ (lambda (k)
+ (set! s (+ s (* (apply generator naked-inputs i k data)
+ (array-ref src-buf k))))))
+ (array-set! dst-buf s i))))
+ dst-buf)
+
+(define (addc dst-buf n-dst-dims src-buf n-src-dims
+ generator naked-inputs data)
+ "Contract the Jacobian column produced by the generator with the source buffer
+adding the result to the destination buffer."
+ (let ((s 0))
+ (do-times
+ n-dst-dims
+ (lambda (i)
+ (set! s (array-ref dst-buf i))
+ (do-times
+ n-src-dims
+ (lambda (k)
+ (set! s (+ s (* (apply generator naked-inputs i k data)
+ (array-ref src-buf k))))))
+ (array-set! dst-buf s i))))
+ dst-buf)
+
+(define (transpose-generator generator)
+ (lambda (xs i j . data)
+ (apply generator xs j i data)))
+
+(define* (fdiff f #:optional (axis 0))
+ (lambda xs
+ (parameterize (((@@ (vouivre autodiff) *differentiation-mode*) 'fwd)
+ ((@@ (vouivre autodiff) *promises*) (cons '() #f)))
+ (let* ((internal (apply f (map-indexed (wrap axis) xs)))
+ (fx (internal-forward internal))
+ (y (list-ref xs axis)) ; variable to differentiate w.r.t
+ (pre-Jx (internal-jacobian internal))
+ (Jx (cond
+ ;; TODO: implement 'input case and test 'zero and 'input
+ ((eq? pre-Jx 'zero)
+ (lambda (j)
+ (lambda (i)
+ 0)))
+ ((eq? pre-Jx 'input)
+ (error "TBD."))
+ (else
+ (lambda (j)
+ (reset-promises (car (*promises*)))
+ (let ((column-jac (w/j j (force pre-Jx))))
+ (lambda (i)
+ (array-ref column-jac i))))))))
+ (cond
+ ((and (number? fx) (number? y))
+ ((Jx 0) 0))
+ ((and (number? fx) (array? y))
+ (let* ((y-dims (array-dimensions y))
+ (a (apply make-array *unspecified* y-dims))
+ (ac (array-contents a)))
+ (do-times
+ (apply * y-dims)
+ (lambda (j)
+ (array-set! ac ((Jx j) 0)
+ j)))
+ a))
+ ((and (array? fx) (number? y))
+ (let* ((fx-dims (array-dimensions fx))
+ (a (apply make-array *unspecified* fx-dims))
+ (ac (array-contents a))
+ (Jx (Jx 0)))
+ (do-times
+ (apply * fx-dims)
+ (lambda (i)
+ (array-set! ac (Jx i)
+ i)))
+ a))
+ (else
+ (let* ((fx-dims (array-dimensions fx))
+ (y-dims (array-dimensions y))
+ (n-fx-dims (apply * fx-dims))
+ (n-y-dims (apply * y-dims))
+ (a (apply make-array *unspecified* (append fx-dims y-dims)))
+ (ac (array-contents a)))
+ (do-times
+ n-y-dims
+ (lambda (j)
+ (let ((Jx (Jx j)))
+ (do-times
+ n-fx-dims
+ (lambda (i)
+ (array-set! ac (Jx i)
+ (+ j (* n-y-dims i))))))))
+ a)))))))
+
+(define* (rdiff f #:optional (axis 0))
+ (lambda xs
+ (parameterize (((@@ (vouivre autodiff) *differentiation-mode*) 'rev)
+ ((@@ (vouivre autodiff) *promises*) (cons '() #f)))
+ (let* ((internal (apply f (map-indexed (wrap axis) xs)))
+ (fx (internal-forward internal))
+ (y (list-ref xs axis)) ; variable to differentiate w.r.t
+ (y-dims (dims-of y))
+ (pre-Jx (internal-jacobian internal))
+ (Jx (cond
+ ;; TODO: implement 'input case and test 'zero and 'input
+ ((eq? pre-Jx 'zero)
+ (lambda (i)
+ (lambda (j)
+ 0)))
+ ((eq? pre-Jx 'input)
+ (error "TBD."))
+ (else
+ (let ((pre-Jx (pre-Jx #f)))
+ (lambda (i)
+ (let ((row-jac (pre-Jx i)))
+ (lambda (j)
+ (array-ref row-jac j)))))))))
+ (parameterize ((*n-y-dims* (apply * y-dims)))
+ (cond
+ ((and (number? fx) (number? y))
+ ((Jx 0) 0))
+ ((and (number? fx) (array? y))
+ (let* ((a (apply make-array *unspecified* y-dims))
+ (ac (array-contents a))
+ (Jx (Jx 0)))
+ (do-times
+ (*n-y-dims*)
+ (lambda (j)
+ (array-set! ac (Jx j)
+ j)))
+ a))
+ ((and (array? fx) (number? y))
+ (let* ((fx-dims (array-dimensions fx))
+ (a (apply make-array *unspecified* fx-dims))
+ (ac (array-contents a)))
+ (do-times
+ (apply * fx-dims)
+ (lambda (i)
+ (array-set! ac ((Jx i) 0)
+ i)))
+ a))
+ (else
+ (let* ((fx-dims (array-dimensions fx))
+ (n-fx-dims (apply * fx-dims))
+ (a (apply make-array *unspecified* (append fx-dims y-dims)))
+ (ac (array-contents a)))
+ (do-times
+ n-fx-dims
+ (lambda (i)
+ (let ((Jx (Jx i)))
+ (do-times
+ (*n-y-dims*)
+ (lambda (j)
+ (array-set! ac (Jx j)
+ (+ j (* (*n-y-dims*) i))))))))
+ a))))))))
+
+;; In the comment that follows:
+;;
+;; `n' is the number of arguments to `proc'.
+;; `generators is not a `Vec' but a `List' we only use the former to illustrate
+;; its length.
+;; `X1', ..., `Xn' are the types of inputs and thus `Array's of some dimension.
+;; `I' is the type of multi-indices indexing the output of `function'.
+;; `J' is the type of multi-indices indexing the input array being differentiated.
+;; `|I|' (resp. `|J|') is the type of absolute indices of `I' (resp. `J').
+;; `Array I' is the type of arrays indexed by multi-indices of `I'.
+;; `[X]' means that `X' is boxed in an internal as when returned by
+;; `differentiable-wrapper' with the array being `X' and the promise that
+;; given a |J| we will get the change of `X' with a change of the
+;; the differentiated argument at multi-index `J'.
+;; (∷ (→ (Vec n (→ X1 ... Xn |I| |J| Number))
+;; (→ X1 ... Xn (Array I))*
+;; [X1] ... [Xn]
+;; (Internal (Array I) (Promise |J| (Array |I|)))))
+;;
+;; (*) We extend this definition to allow `proc' to be a list of procedures
+;; the head of which is as described above and the remaining elements
+;; are procedures of the same arguments but returning values that are
+;; then fed as extra data to the generators.
+;;
+;; NOTE: In cases where an argument isn't meant to be differentiable its
+;; corresponding generator should be `#f'.
+(define (differentiable-wrapper generators proc* arg . more)
+ (define (precompute-data naked-args)
+ (if (procedure? proc*)
+ '()
+ (map (lambda (g)
+ (apply g naked-args))
+ (cdr proc*))))
+ (let* ((args (cons arg more))
+ (proc (if (procedure? proc*)
+ proc*
+ (car proc*)))
+ (naked-args (map unwrap-fwd args))
+ (out (apply proc naked-args)))
+ (case (*differentiation-mode*)
+ ((#f)
+ out)
+ ((fwd)
+ (let* ((data (precompute-data naked-args))
+ (n-out-dims (apply * (dims-of out)))
+ (buf (make-array *unspecified* n-out-dims)))
+ (make-internal
+ out
+ (fold
+ (lambda (generator arg prev)
+ (if (or (not (internal? arg))
+ (eq? 'zero (internal-jacobian arg)))
+ prev
+ (let ((Jx (internal-jacobian arg))
+ (n-fwd-dims (apply * (dims-of (unwrap-fwd arg)))))
+ (if (eq? Jx 'input)
+ (if (eq? prev 'zero)
+ (delay
+ (movg buf n-out-dims
+ generator naked-args data (*j*)))
+ (delay
+ (addg (force prev) n-out-dims
+ generator naked-args data (*j*))))
+ (if (eq? prev 'zero)
+ (delay
+ (movc buf n-out-dims (force Jx) n-fwd-dims
+ generator naked-args data))
+ (delay
+ (addc (force prev) n-out-dims
+ (force Jx) n-fwd-dims
+ generator naked-args data)))))))
+ 'zero generators args))))
+ ((rev)
+ (let ((data (precompute-data naked-args))
+ (n-out-dims (apply * (dims-of out))))
+ (make-internal
+ out
+ (fold
+ (lambda (generator arg prev)
+ (let ((generator (transpose-generator generator)))
+ (if (or (not (internal? arg))
+ (eq? 'zero (internal-jacobian arg)))
+ prev
+ (let* ((Jx (internal-jacobian arg))
+ (n-fwd-dims (apply * (dims-of (unwrap-fwd arg)))))
+ (if (eq? Jx 'input)
+ (if (eq? prev 'zero)
+ (lambda (buf?)
+ (let ((dst-buf (make-array *unspecified*
+ n-fwd-dims)))
+ (if buf?
+ (lambda (buf)
+ (movc dst-buf n-fwd-dims
+ buf n-out-dims
+ generator naked-args data))
+ (lambda (i)
+ (movg dst-buf n-fwd-dims
+ generator naked-args data
+ i)))))
+ (lambda (buf?)
+ (let ((prev (prev buf?)))
+ (if buf?
+ (lambda (buf)
+ (addc (prev buf) n-fwd-dims
+ buf n-out-dims
+ generator naked-args data))
+ (lambda (i)
+ (addg (prev i) n-fwd-dims
+ generator naked-args data
+ i))))))
+ (if (eq? prev 'zero)
+ (lambda (buf?)
+ (let ((Jx (Jx #t))
+ (dst-buf (make-array *unspecified*
+ n-fwd-dims)))
+ (if buf?
+ (lambda (buf)
+ (Jx
+ (movc dst-buf n-fwd-dims buf
+ n-out-dims
+ generator naked-args data)))
+ (lambda (i)
+ (Jx
+ (movg dst-buf n-fwd-dims
+ generator naked-args data
+ i))))))
+ (lambda (buf?)
+ (let ((prev (prev buf?))
+ (Jx (Jx #t))
+ (dst-buf (make-array *unspecified*
+ n-fwd-dims)))
+ (if buf?
+ (lambda (buf)
+ (add (prev buf)
+ (Jx
+ (movc dst-buf n-fwd-dims
+ buf n-out-dims
+ generator naked-args data))
+ (*n-y-dims*)))
+ (lambda (i)
+ (add (prev i)
+ (Jx
+ (movg dst-buf n-fwd-dims
+ generator naked-args data
+ i))
+ (*n-y-dims*))))))))))))
+ 'zero generators args)))))))
+
+(define (ewise1 f)
+ (lambda (xs i j)
+ (let ((x (car xs)))
+ (if (number? x)
+ (f x)
+ (ifn (= i j)
+ 0
+ (f (array-ref (array-contents x)
+ j)))))))
+
+(define (ewise2 proc axis)
+ (lambda (xs i j)
+ (let ((x (car xs))
+ (y (cadr xs)))
+ (cond
+ ((and (number? x) (number? y))
+ (proc x y))
+ ((and (number? x) (array? y))
+ (if (= axis 0)
+ (proc x (array-ref (array-contents y)
+ i))
+ (ifn (= i j)
+ 0
+ (proc x (array-ref (array-contents y)
+ j)))))
+ ((and (array? x) (number? y))
+ (if (= axis 1)
+ (proc (array-ref (array-contents x)
+ i)
+ y)
+ (ifn (= i j)
+ 0
+ (proc (array-ref (array-contents x)
+ j)
+ y))))
+ (else
+ (ifn (= i j)
+ 0
+ (proc (array-ref (array-contents x)
+ j)
+ (array-ref (array-contents y)
+ j))))))))
+
+(define (i:identity x)
+ "Differentiable identity."
+ (differentiable-wrapper
+ (list (ewise1 (lambda _ 1)))
+ identity
+ x))
+
+(define (i:sqrt x)
+ "Differentiable square root."
+ (differentiable-wrapper
+ (list (ewise1 (lambda (x) (/ 1 2 (sqrt x)))))
+ (extend sqrt)
+ x))
+
+(define (i:exp x)
+ "Differentiable exponential."
+ (differentiable-wrapper
+ (list (ewise1 exp))
+ (extend exp)
+ x))
+
+(define (i:expt x y)
+ "Differentiable power."
+ (differentiable-wrapper
+ (list (ewise2 (lambda (x y) (* y (expt x (1- y)))) 0)
+ (ewise2 (lambda (x y) (* (expt x y) (log x))) 1))
+ (extend expt)
+ x y))
+
+(define (i:log x)
+ "Differentiable logarithm."
+ (differentiable-wrapper
+ (list (ewise1 (lambda (x) (/ x))))
+ (extend log)
+ x))
+
+(define (i:sin x)
+ "Differentiable sine."
+ (differentiable-wrapper
+ (list (ewise1 cos))
+ (extend sin)
+ x))
+
+(define (i:cos x)
+ "Differentiable cosine."
+ (differentiable-wrapper
+ (list (ewise1 (lambda (x) (- (sin x)))))
+ (extend cos)
+ x))
+
+(define (i:tan x)
+ "Differentiable tangent."
+ (differentiable-wrapper
+ (list (ewise1 (lambda (x) (/ (expt (cos x) 2)))))
+ (extend tan)
+ x))
+
+(define (i:+ x y)
+ "Differentiable element-wise addition."
+ (differentiable-wrapper
+ (list
+ (ewise2 (lambda _ +1) 0)
+ (ewise2 (lambda _ +1) 1))
+ (extend +)
+ x y))
+
+(define (i:- x y)
+ "Differentiable element-wise subtraction."
+ (differentiable-wrapper
+ (list
+ (ewise2 (lambda _ +1) 0)
+ (ewise2 (lambda _ -1) 1))
+ (extend -)
+ x y))
+
+(define (i:* x y)
+ "Differentiable element-wise multiplication."
+ (differentiable-wrapper
+ (list
+ (ewise2 (lambda (x y) y) 0)
+ (ewise2 (lambda (x y) x) 1))
+ (extend *)
+ x y))
+
+(define (i:/ x y)
+ "Differentiable element-wise division."
+ (differentiable-wrapper
+ (list
+ (ewise2 (lambda (x y) (/ y)) 0)
+ (ewise2 (lambda (x y) (- (/ x y y))) 1))
+ (extend /)
+ x y))
+
+(define (i:max x y)
+ "Differentiable element-wise maximum."
+ (define (dmax x y)
+ (cond
+ ((> x y)
+ 1)
+ ((= x y)
+ 1/2)
+ (else
+ 0)))
+ (differentiable-wrapper
+ (list
+ (ewise2 dmax 0)
+ (ewise2 (flip dmax) 1))
+ (extend max)
+ x y))
+
+(define (i:min x y)
+ "Differentiable element-wise minimum."
+ (define (dmin x y)
+ (cond
+ ((< x y)
+ 1)
+ ((= x y)
+ 1/2)
+ (else
+ 0)))
+ (differentiable-wrapper
+ (list
+ (ewise2 dmin 0)
+ (ewise2 (flip dmin) 1))
+ (extend min)
+ x y))
+
+(define (i:abs x)
+ "Differentiable absolute."
+ (differentiable-wrapper
+ (list (ewise1 (lambda (x)
+ (cond ((> x 0)
+ +1)
+ ((= x 0)
+ 1/2)
+ ((< x 0)
+ -1)))))
+ (extend abs)
+ x))
+
+(define (mean x)
+ "Differentiable mean on arrays."
+ (differentiable-wrapper
+ (list
+ (lambda (xs i j one-over-n)
+ one-over-n))
+ (let ((n 0))
+ (list
+ (lambda (x)
+ (let ((sum 0))
+ (array-for-each
+ (lambda (x)
+ (set! sum (+ sum x))
+ (set! n (1+ n)))
+ x)
+ (/ sum n)))
+ (lambda _ (/ n))))
+ x))
+
+(define (i:array-ref x . indices)
+ "Differentiable array-ref w.r.t `x'."
+ (apply
+ differentiable-wrapper
+ (cons
+ (lambda (xs i j abs-index)
+ (if (= j abs-index)
+ 1
+ 0))
+ (map not indices))
+ (list
+ array-ref
+ (lambda (x . indices)
+ (rel->abs indices (array-dimensions x))))
+ x indices))
+
+(define (i:array-cell-ref x . indices)
+ (apply
+ differentiable-wrapper
+ (cons
+ (lambda (xs i j abs-index n-rst-dims)
+ (receive (j-ref j-rst) (euclidean/ j n-rst-dims)
+ (if (and (= j-ref abs-index)
+ (= j-rst i))
+ 1
+ 0)))
+ (map not indices))
+ (list
+ array-cell-ref
+ (lambda (x . indices)
+ (rel->abs indices (take (array-dimensions x)
+ (length indices))))
+ (lambda (x . indices)
+ (apply * (drop (array-dimensions x)
+ (length indices)))))
+ x indices))
+
+(define (make-batch elem . more)
+ (let ((batch-size (1+ (length more))))
+ (apply
+ differentiable-wrapper
+ (list-tabulate
+ batch-size
+ (lambda (b)
+ (lambda (xs i j n-rest-dims)
+ (receive (i-batch i-rest) (euclidean/ i n-rest-dims)
+ (if (and (= i-batch b)
+ (= i-rest j))
+ 1
+ 0
+ )))))
+ (list
+ (lambda (elem . more)
+ (let ((a (apply make-typed-array *atype* *unspecified* batch-size
+ (dims-of elem))))
+ (for-each
+ (lambda (x b)
+ (array-cell-set! a x b))
+ (cons elem more)
+ (list-tabulate batch-size identity))
+ a))
+ (lambda (elem . more)
+ (apply * (dims-of elem))))
+ elem more)))
+
+(define (maximum x)
+ "Differentiable maximum on arrays."
+ (differentiable-wrapper
+ (list
+ (lambda (xs i j max-index)
+ (if (= j max-index)
+ 1
+ 0)))
+ (let ((max-index 'TBD))
+ (list
+ (lambda (x)
+ (let ((m (- (inf)))
+ (i 0))
+ (array-for-each
+ (lambda (x)
+ (when (< m x)
+ (set! m x)
+ (set! max-index i))
+ (set! i (1+ i)))
+ x)
+ m))
+ (lambda _ max-index)))
+ x))
+
+(define (sum x)
+ "Differentiable sum on arrays."
+ (differentiable-wrapper
+ (list (lambda _ 1))
+ (lambda (x)
+ (let ((sum 0))
+ (array-for-each
+ (lambda (x)
+ (set! sum (+ sum x)))
+ x)
+ sum))
+ x))
+
+(define (adot x y n)
+ (differentiable-wrapper
+ (list
+ (lambda (xs i j n-free-dims-y n-bound-dims)
+ (receive (i-x i-y) (euclidean/ i n-free-dims-y)
+ (receive (j-free j-bound) (euclidean/ j n-bound-dims)
+ (ifn (= i-x j-free)
+ 0
+ (array-ref (array-contents (cadr xs))
+ (+ i-y (* n-free-dims-y j-bound)))))))
+ (lambda (xs i j n-free-dims-y n-bound-dims)
+ (receive (i-x i-y) (euclidean/ i n-free-dims-y)
+ (receive (j-bound j-free) (euclidean/ j n-free-dims-y)
+ (ifn (= i-y j-free)
+ 0
+ (array-ref (array-contents (car xs))
+ (+ j-bound (* n-bound-dims i-x)))))))
+ #f)
+ (list
+ contract-arrays
+ (lambda (x y n)
+ (apply * (drop (array-dimensions y)
+ n)))
+ (lambda (x y n)
+ (apply * (take (array-dimensions y)
+ n))))
+ x y n))
+
+(define (amap2 f x y)
+ (apply make-batch
+ (list-tabulate (car (dims-of (unwrap-fwd x)))
+ (lambda (b)
+ (f (i:array-cell-ref x b)
+ (i:array-cell-ref y b))))))
--- /dev/null
+;;;; Copyright (C) 2023 Vouivre Digital Corporation
+;;;;
+;;;; This file is part of Vouivre.
+;;;;
+;;;; Vouivre is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public
+;;;; License as published by the Free Software Foundation, either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; Vouivre is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (vouivre curry)
+ #:use-module ((ice-9 curried-definitions) :prefix c)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-71)
+ #:use-module (vouivre misc)
+ #:export
+ (curried-untyped-define
+ equal-types?
+ expand
+ parse
+ symtab
+ type-of
+ ∷))
+
+(define symtab '())
+
+(define-record-type node
+ (make-node content)
+ node?
+ (content node-content set-node-content!))
+
+(define (type-error n . args)
+ (let ((errors '((0 . TBD)
+ (1 . INCOMPATIBLE)
+ (2 . BAD-INPUT)
+ (3 . BAD-APPLICATION)
+ (4 . UNBOUND-SYMBOL)
+ (5 . TYPE-EXPECT-TYPES))))
+ (apply error "type error" (assoc-ref errors n) args)))
+
+(define (zo? x)
+ "Predicate for the zero type."
+ (and (number? x) (zero? x)))
+
+(define (tv? x)
+ "Predicate for type variables."
+ (and (number? x) (positive? x) #t))
+
+;; Return a unique type variable.
+(define next
+ (let ((count 1))
+ (lambda ()
+ (set! count (1+ count))
+ (1- count))))
+
+(define (copy-tree node)
+ "Return a copy of the tree rooted in `node'."
+ (let ((x (node-content node)))
+ (if (pair? x)
+ (make-node (cons (copy-tree (car x))
+ (copy-tree (cdr x))))
+ (make-node x))))
+
+(define (map-tree! proc nx)
+ "Map `proc' in-place over the content of the leaves of `nx'."
+ (let ((x (node-content nx)))
+ (if (pair? x)
+ (begin
+ (map-tree! proc (car x))
+ (map-tree! proc (cdr x)))
+ (set-node-content! nx (proc x)))
+ nx))
+
+(define (compare nx ny)
+ ""
+ (define (create-reduxtab m)
+ ;; Each `x' point (through `mx') to a list `ys' of elements `y' who
+ ;; themselves point (through `my') to lists of things equal to `x'.
+ ;; We unionize these, sort them, and, bind them as "things equal to `x'".
+ (let* ((mx (first m))
+ (my (second m))
+ (mxf (third m))
+ (φ (lambda (x)
+ (assoc-ref mx x)))
+ (φ* (lambda (y)
+ (assoc-ref my y)))
+ (Φ* (lambda (ys)
+ (apply lset-union eq? (map φ* ys)))))
+ (append
+ (lset-difference
+ (lambda (x y) (eq? (car x) (car y)))
+ mxf mx)
+ (map
+ (match-lambda
+ ((x . ys)
+ (cons
+ x
+ (let ((new-x (first (sort-list (Φ* ys) <)))
+ (fy (assoc-ref mxf x)))
+ (if (and (zo? new-x) fy)
+ (type-error 1 new-x fy)
+ (if (not fy)
+ new-x
+ (node-content
+ (map-tree!
+ (lambda (y)
+ (first
+ (sort-list
+ (or (φ* y)
+ (list (next)))
+ <)))
+ (copy-tree (make-node fy))))))))))
+ mx))))
+ (define (massoc m x y)
+ (define (assoc! m x y)
+ (assoc-set! m x (cons y (or (assoc-ref m x) '()))))
+ (list (if (and (not (pair? x))
+ (not (pair? y)))
+ (assoc! (first m) x y)
+ (first m))
+ (if (and (not (pair? x))
+ (not (pair? y)))
+ (assoc! (second m) y x)
+ (second m))
+ (if (not (pair? y))
+ (third m)
+ (if (assoc-ref (third m) x)
+ (type-error 0 "type variable already a function")
+ (assoc-set! (third m) x y)))))
+ (create-reduxtab
+ (let compare% ((m `(()
+ ;; 0_x ≡ 0_y (though we only use 0y→0x).
+ ;; Also, associations in an alist need to be mutable.
+ (,(cons 0 '(0)))
+ ()))
+ (nx nx)
+ (ny ny))
+ (let ((x (node-content nx))
+ (y (node-content ny)))
+ (cond
+ ;; same same
+ ((eq? nx ny)
+ m)
+ ((and (not x) (not y))
+ m)
+ ((and (zo? x) (zo? y))
+ m)
+ ((and (tv? x) (tv? y))
+ (massoc m x y))
+ ((and (pair? x) (pair? y))
+ (compare% (compare% m (car x) (car y))
+ (cdr x) (cdr y)))
+ ;; cases with #f
+ ((and (zo? x) (not y))
+ (set-node-content! ny x)
+ m)
+ ((and (zo? y) (not x))
+ (set-node-content! nx y)
+ m)
+ ((and (tv? y) (not x))
+ (let ((z (next)))
+ (set-node-content! nx z)
+ (massoc m y z)))
+ ((and (tv? x) (not y))
+ (let ((z (next)))
+ (set-node-content! ny z)
+ (massoc m x z)))
+ ((and (pair? x) (not y))
+ (set-node-content! ny x)
+ m)
+ ((and (pair? y) (not x))
+ (type-error 0 nx ny))
+ ;; cases with TVs
+ ((and (tv? x) (zo? y))
+ (massoc m x y))
+ ((and (tv? y) (zo? x))
+ (massoc m x y))
+ ((and (tv? x) (pair? y))
+ (massoc m x y))
+ ((and (tv? y) (pair? x))
+ (type-error 0 nx ny))
+ ;; outright incompatible cases
+ ((or (and (zo? x) (pair? y))
+ (and (zo? y) (pair? x)))
+ (type-error 1 x y))
+ ;; bad input
+ (else
+ (type-error 2 nx ny)))))))
+
+(define (reduce-tvs! reduxtab node)
+ (map-tree!
+ (lambda (x)
+ (if (number? x)
+ (or (assoc-ref reduxtab x)
+ x)
+ x))
+ node))
+
+(define (rename-tvs! node)
+ (let ((mapping (cons '() #f)))
+ (map-tree!
+ (lambda (x)
+ (if (tv? x)
+ (if-let (z (assoc-ref (car mapping) x))
+ z
+ (let ((z (next)))
+ (set-car! mapping (assoc-set! (car mapping) x z))
+ z))
+ x))
+ node)))
+
+(define (apply-1 nx ny)
+ (let ((x (node-content nx))
+ (y (node-content ny)))
+ (cond
+ ((not x)
+ (set-node-content! nx (cons ny (make-node #f)))
+ (cdr (node-content nx)))
+ ((zo? x)
+ (type-error 3 x y))
+ ((tv? x)
+ (type-error 2 nx ny)
+ )
+ ((pair? x)
+ (reduce-tvs! (compare (car x) ny)
+ (copy-tree (cdr x))))
+ (else
+ (type-error 2 nx ny)))))
+
+(define (var-list? lst)
+ "Predicate for valid macro variable lists."
+ (and (every symbol? lst)
+ (equal? lst (delete-duplicates lst))))
+
+(define (sym-set! symtab name value)
+ "Associate a type to a symbol in a symtab."
+ (let ((m (module-name (current-module))))
+ (assoc-set! symtab m
+ (assoc-set! (or (assoc-ref symtab m) '())
+ name value))))
+
+(define (sym-set symtab sym value)
+ "Like `sym-set!' but returns a copy of the symtab."
+ (sym-set! (alist-copy symtab) sym value))
+
+(define (sym-ref symtab name)
+ "Reference a symbol in a symtab returning its type."
+ (let ((m (module-name (current-module))))
+ (assoc-ref (or (assoc-ref symtab m) '()) name)))
+
+(define (populate-tvs! node)
+ "Add (in-place) new type variables to empty nodes of a tree."
+ (map-tree!
+ (lambda (x)
+ (if (not x)
+ (next)
+ x))
+ node))
+
+(define (expand symtab expr)
+ "Type check an expression returning two values: its resulting type and an
+expansion where all applications of symbols present in the symtab are curried.
+Raise a type error if the expression is invalid."
+ (match expr
+ (('quote x)
+ (values
+ (make-node 0)
+ `',x))
+ (('λc (? symbol? var) body)
+ (let ((var-node (make-node #f)))
+ (let ((bodyt bodye (expand (sym-set symtab var var-node)
+ body)))
+ (unless bodyt
+ (type-error 5 "in body of" `(λc ,var ,body)))
+ (populate-tvs! var-node)
+ (values
+ (make-node
+ (cons var-node bodyt))
+ `(lambda (,var) ,bodye)))))
+ (('letrecc1 ((? symbol? name) expr) body)
+ (type-error 0 'letrecc1 name expr body))
+ (('cudefine name-vars body ..1)
+ (values
+ #f
+ `(cudefine ,name-vars ,@body)))
+ (('definec (? (lambda (x)
+ (and
+ (pair? x)
+ (symbol? (car x))
+ (var-list? (cdr x))))
+ (name vars ..1))
+ body)
+ (expand
+ symtab
+ `(definec ,name
+ ,(fold-right (lambda (x prev)
+ `(λc ,x ,prev))
+ body vars))))
+ (('definec (? symbol? name) body)
+ (let ((t e (expand symtab body)))
+ (if (not t)
+ (type-error 5 "in body of" `(definec ,name ,body))
+ ;; We need to declare the type twice. Once, in `expand', to ensure
+ ;; the type will be available in future `expand' calls. Second, in
+ ;; the expanded expression, so that it gets compiled.
+ (begin
+ (∷% name t)
+ (values
+ #f
+ `(begin
+ ((@@ (vouivre curry) ∷%)
+ ',name
+ ((@ (vouivre curry) parse)
+ ',(bare-type t)))
+ (define ,name ,e)))))))
+ ((f)
+ (let ((t e (expand symtab f)))
+ (values
+ (if t
+ (type-error 3 expr)
+ #f)
+ `(,e))))
+ ((f as ..1)
+ (let ((ft fe (expand symtab f))
+ (ats aes (unzip2
+ (map
+ (lambda (a)
+ (receive vals (expand symtab a) vals))
+ as))))
+ (if (not ft)
+ (values #f `(,fe ,@aes))
+ (values
+ (fold
+ (lambda (at a prev)
+ (apply-1 prev (or at (type-error 5 f a))))
+ ft ats as)
+ (fold
+ (lambda (ae prev)
+ (list prev ae))
+ fe aes)))))
+ (x
+ (values
+ (if (symbol? x)
+ (sym-ref symtab x)
+ (make-node 0))
+ x))))
+
+(define (bare-type x)
+ "Return a type as tree s-expression without nodes."
+ (and=>
+ x
+ (lambda (node)
+ (let ((x (node-content node)))
+ (cond
+ ((pair? x)
+ (cons (bare-type (car x)) (bare-type (cdr x))))
+ (else x))))))
+
+(define* (pt node #:optional (port current-output-port))
+ "Print a tree to the given port in a cons cell format with '?' for empty
+nodes."
+ (format
+ port "~a~%"
+ (let pt% ((nx node))
+ (let ((x (node-content nx)))
+ (cond
+ ((not x)
+ "?")
+ ((number? x)
+ (number->string x))
+ ((pair? x)
+ (format #f "(~a . ~a)"
+ (pt% (car x))
+ (pt% (cdr x)))))))))
+
+(define (parse x)
+ "Parse a type from its cons cells representation to a tree."
+ (if (not x)
+ #f
+ (second
+ (let parse% ((tvs '())
+ (x x))
+ (cond
+ ((eq? x '?)
+ (list tvs (make-node #f)))
+ ((zo? x)
+ (list tvs (make-node 0)))
+ ((tv? x)
+ (if-let (z (assoc-ref tvs x))
+ (list tvs (make-node z))
+ (let ((tv (next)))
+ (list (assoc-set! tvs x tv)
+ (make-node tv)))))
+ ((pair? x)
+ (let* ((a (parse% tvs (car x)))
+ (b (parse% (first a) (cdr x))))
+ (list (first b) (make-node (cons (second a) (second b)))))))))))
+
+(define (equal-types? ta tb)
+ "Check the equality of two types."
+ (define (equal-types?% ta tb correspondances)
+ (let ((a (node-content ta))
+ (b (node-content tb)))
+ (or
+ (eq? a b)
+ (let ((correspond?
+ (lambda (tx ty correspondances)
+ (let ((x (node-content tx))
+ (y (node-content ty)))
+ (cond
+ ((and (zo? x)
+ (zo? y))
+ correspondances)
+ ((and (tv? x)
+ (tv? y))
+ (let ((xy (assoc-ref (car correspondances) x))
+ (yx (assoc-ref (cdr correspondances) y)))
+ (if (and (not xy) (not yx))
+ (cons (assoc-set! (car correspondances) x y)
+ (assoc-set! (cdr correspondances) y x))
+ (and (eq? xy y) (eq? yx x) correspondances))))
+ ((and (pair? x) (pair? y))
+ (equal-types?% tx ty correspondances))
+ (else #f))))))
+ (match (list a b)
+ (((a1 . a2) (b1 . b2))
+ (and=>
+ (correspond? a1 b1 correspondances)
+ (lambda (correspondances)
+ (correspond? a2 b2 correspondances))))
+ (else #f))))))
+ (if (or (not ta) (not tb))
+ (eq? ta tb)
+ (and (equal-types?% ta tb '(() . ()))
+ #t)))
+
+(define-syntax curried-untyped-define
+ (syntax-rules ()
+ ((_ (name var) body ...)
+ (cdefine (name var) body ...))
+ ((_ (name var1 var2 ...) body ...)
+ (curried-untyped-define ((name var1) var2 ...) body ...))))
+
+(define (∷% name type)
+ (set! symtab (sym-set! symtab name type)))
+
+(define-syntax-rule (∷ name type)
+ (∷% 'name (parse 'type)))
+
+(define* (type-of x #:optional port)
+ "Print the type of a declared symbol to the given port."
+ (if-let (x (expand symtab x))
+ (pt x port)
+ (format port "#f~%")))
--- /dev/null
+(define-module
+ (vouivre hconfig)
+ #:use-module
+ (srfi srfi-26)
+ #:export
+ (%version
+ %author
+ %license
+ %copyright
+ %gettext-domain
+ G_
+ N_
+ init-nls
+ init-locale))
+
+(define %version "0.1")
+
+(define %author "Vouivre Digital Corporation")
+
+(define %license 'gpl3+)
+
+(define %copyright '(2023))
+
--- /dev/null
+;;;; Copyright (C) 2023 Vouivre Digital Corporation
+;;;;
+;;;; This file is part of Vouivre.
+;;;;
+;;;; Vouivre is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public
+;;;; License as published by the Free Software Foundation, either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; Vouivre is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (vouivre misc)
+ #:use-module (ice-9 arrays)
+ #:use-module (srfi srfi-1)
+ #:export
+ (array-map
+ array-map-indexed
+ flip
+ for-indices-in-range
+ if-let
+ ifn
+ list-zeros
+ map-indexed
+ produce-array
+ produce-typed-array))
+
+(define (flip f)
+ "Returns a procedure behaving as `f', but with arguments taken in reverse
+order."
+ (lambda args
+ (apply f (reverse args))))
+
+(define-syntax if-let
+ (syntax-rules ()
+ [(_ (x test) consequent alternate)
+ (let ([x test])
+ (if x consequent alternate))]
+ [(_ (x test) consequent)
+ (let ([x test])
+ (if x consequent))]))
+
+(define-syntax ifn
+ (syntax-rules ()
+ [(_ test alternate consequent)
+ (if test consequent alternate)]
+ [(_ test alternate)
+ (if (not test) alternate)]))
+
+(define (list-zeros n)
+ (list-tabulate n (lambda _ 0)))
+
+(define (map-indexed f . lists)
+ "Like `map' but the last argument of `f' is passed the corresponding index."
+ (apply map f (append lists (list (list-tabulate (length (car lists))
+ identity)))))
+
+(define (for-indices-in-range f starts ends)
+ (define (for-indices-in-range% f indices starts ends)
+ (if (null? starts)
+ (apply f (reverse indices))
+ (do ((i (car starts) (1+ i)))
+ ((= i (car ends)))
+ (for-indices-in-range%
+ f
+ (cons i indices)
+ (cdr starts)
+ (cdr ends)))))
+ (for-indices-in-range% f '() starts ends))
+
+;;;; array utilities
+
+(define (produce-typed-array f type . dims)
+ (let ((a (apply make-typed-array type *unspecified* dims)))
+ (array-index-map! a f)
+ a))
+
+(define (produce-array f . dims)
+ (apply produce-typed-array f #t dims))
+
+(define (array-map proc array . more)
+ (let ((x (array-copy array)))
+ (apply array-map! x proc array more)
+ x))
+
+(define (array-map-indexed proc array)
+ (let ((x (array-copy array)))
+ (array-index-map!
+ x
+ (lambda indices
+ (apply proc
+ (apply array-ref array indices)
+ indices)))
+ x))
--- /dev/null
+;;;; Copyright (C) 2023 Vouivre Digital Corporation
+;;;;
+;;;; This file is part of Vouivre.
+;;;;
+;;;; Vouivre is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public
+;;;; License as published by the Free Software Foundation, either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; Vouivre is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with Vouivre. If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (vouivre mnist)
+ #:use-module (guix build download)
+ #:use-module (guix build utils)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (vouivre misc)
+ #:use-module (web uri)
+ #:export (load-mnist))
+
+;; NOTE: The directory and url must not include any trailing '/' character.
+(define directory "mnist")
+(define url "http://yann.lecun.com/exdb/mnist")
+(define trn-imgs-fname "train-images-idx3-ubyte")
+(define trn-lbls-fname "train-labels-idx1-ubyte")
+
+(define (exists? fname)
+ "Return `#t' if the file with the given name exists and `#f' otherwise."
+ (catch 'system-error
+ (lambda ()
+ (with-input-from-file fname
+ (lambda () #t)
+ #:binary #t))
+ (lambda _ #f)))
+
+(define (load-mnist nb-items download?)
+ "Return the given number of data points from the MNIST dataset downloading it
+if needed and requested in the ./mnist directory.
+
+The data is a cons cell containing an array (nb-items, height, width) of
+training images and an array (nb-items) of corresponding labels."
+ (define (read-uint bytes)
+ (bytevector-uint-ref (get-bytevector-n (current-input-port)
+ bytes)
+ 0
+ (endianness big)
+ bytes))
+ (apply
+ cons
+ (map
+ (lambda (base-name magic rank)
+ (let ((fname (string-append directory "/" base-name)))
+ (let redo ((download? download?))
+ (if (exists? fname)
+ (with-input-from-file fname
+ (lambda ()
+ (when (not (= magic (read-uint 4)))
+ (error "Unsupported file magic number."))
+ (let* ((n (min nb-items (read-uint 4)))
+ (dims (list-tabulate rank (lambda (x) (read-uint 4))))
+ (n-dims (apply * n dims))
+ (a (apply make-typed-array 'u8 0 n dims))
+ (ac (array-contents a)))
+ (let lp ((i 0))
+ (if (= i n-dims)
+ a
+ (begin
+ (array-set! ac (read-uint 1) i)
+ (lp (1+ i)))))))
+ #:binary #t)
+ (ifn download?
+ (error (string-append "The MNIST dataset doesn't exist. If you tried with `download?' to `#t' already, to no avail, you can download the files manually from " url ", and extract them to a \"mnist\" directory at the root of the project. You can also file a bug report."))
+ (let ((gzname (string-append fname ".gz")))
+ (invoke "mkdir" "-p" directory)
+ (call-with-output-file gzname
+ (lambda (port)
+ (put-bytevector
+ port
+ (get-bytevector-all
+ (http-fetch
+ (string->uri
+ (string-append url "/" base-name ".gz"))))))
+ #:binary #t)
+ (invoke "gunzip" gzname)
+ (redo #f)))))))
+ (list trn-imgs-fname trn-lbls-fname)
+ (list 2051 2049)
+ (list 2 0))))
--- /dev/null
+;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms
+
+;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;; This file has been modified by Vouivre Digital Corporation. The exact
+;; modifications can be seen in a shell using:
+;; $ git diff b4695cd888df6511915262884d2ce317156f92e8 promises.scm
+
+;;; Commentary:
+
+;; This is the code of the reference implementation of SRFI-45, modified
+;; to use SRFI-9 and to add 'promise?' to the list of exports.
+
+;; This module is documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (vouivre promises)
+ #:export (*promises* reset-promises)
+ #:replace (delay force)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu))
+
+(define *promises* (make-parameter #f))
+
+(define-record-type promise (make-promise val) promise?
+ (val promise-val promise-val-set!))
+
+(define-record-type value (make-value tag proc rec) value?
+ (tag value-tag value-tag-set!)
+ (proc value-proc value-proc-set!)
+ (rec value-rec value-rec-set!))
+
+(define-syntax-rule (lazy exp)
+ (let ((proc (lambda () exp)))
+ (make-promise (make-value 'lazy proc proc))))
+
+(define (eager x)
+ (make-promise (make-value 'eager x #f)))
+
+(define-syntax-rule (delay exp)
+ (let ((promise (lazy (eager exp)))
+ (promises-ptr (*promises*)))
+ (set-car! promises-ptr (cons promise (car promises-ptr)))
+ promise))
+
+(define (force promise)
+ (let ((content (promise-val promise)))
+ (case (value-tag content)
+ ((eager)
+ (value-proc content))
+ ((lazy)
+ (let* ((promise* ((value-proc content)))
+ (content (promise-val promise))) ; *
+ (unless (eqv? 'eager (value-tag content)) ; *
+ (value-tag-set! content (value-tag (promise-val promise*)))
+ (value-proc-set! content (value-proc (promise-val promise*)))
+ (promise-val-set! promise* content))
+ (force promise))))))
+;; (*) These two lines re-fetch and check the original promise in case
+;; the first line of the let* caused it to be forced. For an example
+;; where this happens, see reentrancy test 3 below.
+
+(define (reset-promises promises)
+ (unless (null? promises)
+ (let ((v (promise-val (car promises))))
+ (when (value-rec v)
+ (value-proc-set! v (value-rec v))
+ (value-tag-set! v 'lazy))
+ (reset-promises (cdr promises)))))
+
+(define* (promise-visit promise #:key on-eager on-lazy)
+ (define content (promise-val promise))
+ (case (value-tag content)
+ ((eager) (on-eager (value-proc content)))
+ ((lazy) (on-lazy (value-proc content)))))
+
+(set-record-type-printer! promise
+ (lambda (promise port)
+ (promise-visit promise
+ #:on-eager (lambda (value)
+ (format port "#<promise = ~s>" value))
+ #:on-lazy (lambda (proc)
+ (format port "#<promise => ~s>" proc)))))
projects / vouivre.git / commitdiff