* bug#34531: Guix profile fails on Overdrive 1000
@ 2019-02-18 20:05 Andreas Enge
2019-02-18 20:49 ` Marius Bakke
0 siblings, 1 reply; 22+ messages in thread
From: Andreas Enge @ 2019-02-18 20:05 UTC (permalink / raw)
To: 34531
Hello,
on a newly installed Overdrive 1000 machine with 8 GB of memory, I am trying
guix pull -n
This results in
Updating channel 'guix' from Git repository at 'https://git.savannah.gnu.org/git/guix.git'...
Building from this channel:
guix https://git.savannah.gnu.org/git/guix.git d0d207c
The following derivations will be built:
/gnu/store/qvljgqnsynw113h1062nws9i2zfcz15y-compute-guix-derivation.drv
/gnu/store/rj824ibc8nhhl1j2h25sgw4lyxkxjggc-gdb-8.2.drv
...
/gnu/store/w1jw283cdf6n03qnccsrvxgzy41z0hps-guile-gcrypt-0.1.0.drv
building /gnu/store/wy37294j2rb6fg5fgpybki28vq60jz94-python-minimal-3.6.5.drv...
starting phase `set-SOURCE-DATE-EPOCH'
...
That a build of something starts although the "-n" flag is specified seems
to be a first bug.
Then, during the test phase, the build is killed since the machine runs out
of memory. I also tried to pass "--cores=1" to "guix build", but this
parameter is not honoured: "top" shows that all four cores are running.
This might be a second bug.
In any case, it becomes impossible to upgrade with the usual mechanism,
which is a rather serious bug.
My guix version:
$ guix --version
guix (GNU Guix) 0.15.0-8.71a78ba
There should be a number of possible solutions:
- Try to not depend on python for such basic operations (preferable; where
does this dependency come from anyway?)
- Disable the tests in a bootstrapping python that is used here.
- Disable only tests requiring a lot of memory.
- Update python to a newer version.
What do you think we should try?
Andreas
PS: I am still not convinced that the system is in a coherent state, so it
would be interesting if someone could confirm this bug. For instance, I
observe the following:
$ guix package -i hello -n
guix package: warning: Your Guix installation is 9 days old.
guix package: warning: Consider running 'guix pull' followed by
'guix package -u' to get up-to-date packages and security updates.
The following package would be installed:
hello 2.10 /gnu/store/5hzc1q803ksynz19sr8ymvgzf4v7anzk-hello-2.10
The following derivations would be built:
/gnu/store/1krpkl0axqyn2lpxp3ick3s0p2z5qrnv-profile.drv
/gnu/store/gfxnqasw81kxjjvfmv5i54rbvlpkd8n1-mkfontdir-1.0.7.tar.bz2.drv
/gnu/store/n0fgxl55ni7pmw03p8aqaamqvj31ym0l-libfontenc-1.1.3.tar.bz2.drv
/gnu/store/4c1jfinnpjrxnx7grpwmwh3s1b64b8bc-libfontenc-1.1.3.drv
/gnu/store/x38kid3sf3zw15rlwl375kp0ng1iz8m3-mkfontscale-1.1.3.tar.bz2.drv
/gnu/store/9fb2w29gyfq6hsw064l89vb29jd0jry4-mkfontscale-1.1.3.drv
/gnu/store/iwi0648clfzpp084qic303glv9cp9qwy-module-import-compiled.drv
/gnu/store/lz4psj250m4xh4mpvkd2qchbs9vb9f19-mkfontdir-1.0.7.drv
/gnu/store/w11j7chynk58lzk40agd37ii32rc7d6c-fonts-dir.drv
/gnu/store/rj824ibc8nhhl1j2h25sgw4lyxkxjggc-gdb-8.2.drv
/gnu/store/7g3ybwsd664941qz7jp2c3rcxaxm2nij-valgrind-3.13.0.drv
/gnu/store/swx5jipn1id1qfw60hh1f7icxfflfx6s-scons-python2-3.0.1.drv
/gnu/store/q98m948gmibnccjjdbw4s80vkn5ywmza-boost-1.66.0.drv
/gnu/store/i1a2f33p08brilpkdn35rm5jgng2bnrn-swig-3.0.12.drv
/gnu/store/m8y9k0zqkq6sa0lv9714ql9f4m36pmrh-serf-1.3.9.drv
/gnu/store/sazsmami6651dkgj51ij53x0bx9hl46x-lz4-1.8.1.2.drv
/gnu/store/3g8plb0fvnblmb7ldr4ikmlpv44k0xzp-libxslt-1.1.32.drv
/gnu/store/4nms2l8g8n770harl3f9qzizp0amyqvz-xcb-proto-1.13.drv
/gnu/store/wy37294j2rb6fg5fgpybki28vq60jz94-python-minimal-3.6.5.drv
/gnu/store/zyq4z95r0afywwn9y6283irikgx72885-python-minimal-wrapper-3.6.5.drv
/gnu/store/68bycryid94b46kw9kp1mlmgc0s3y8k6-libxrender-0.9.10.drv
/gnu/store/wgxbfymwcscqmsqn5cbv7sskd9racsr9-libxft-2.3.2.drv
/gnu/store/7jl0aja7msxhnm39x7vbz0r7lxfrk0xh-python-3.6.5.drv
/gnu/store/xmhsaqhlp6fmxny50vs3if8jlv0cclbi-python-wrapper-3.6.5.drv
/gnu/store/jbdy9za2xfxqg65c27lwic1psnz2kikg-ghostscript-9.23.drv
/gnu/store/g9i8l4dnp7a6pr1rz4ly2apyp7cxcmz7-openldap-2.4.46.drv
/gnu/store/jvj8p7qc1y1f15yd34ahysdpkl2120kn-groff-1.22.3.drv
/gnu/store/220nl6licli726kdrvzw8k3j6qak5cq5-libx11-1.6.5.drv
/gnu/store/gnijgdfa363n5jc2qk9wn54x12787yvl-curl-7.59.0.drv
/gnu/store/i3bvnpnjhj6y8d2kzksw6f6gpfbadwl0-libxext-1.3.3.drv
/gnu/store/jf7dxdv6dsrkr75b68whz7nnyss485js-tk-8.6.8.drv
/gnu/store/jga9yslz6zafqchv4mr5hg7106s0lhsx-libxcb-1.13.drv
/gnu/store/lkwynhkq6a4a242i17qbxcx5khkng3wc-asciidoc-8.6.10.drv
/gnu/store/slj73h4y23gdwm6znclijsxi3cggdd57-xmlto-0.0.28.drv
/gnu/store/wn577xbf7fc70kcczmrcn03b0615mlpl-python2-2.7.14.drv
/gnu/store/x2xbfpl32ni1lbq5r515qqh45qsyalri-subversion-1.10.2.drv
/gnu/store/h9v84xaab30a6vqg7ni4g74fwslzz1f2-git-2.19.2.drv
/gnu/store/jrk6szd0b8glb69iqs8kwsr74d47ck78-guile-gdbm-ffi-20120209.fa1d5b6-checkout.drv
/gnu/store/6zgzgmmqa5ghqljwslmsh7xcmz3rckcy-guile-gdbm-ffi-20120209.tar.xz.drv
/gnu/store/g0103wbwhzgv716xn7x2pyzhp0xmypbm-module-import.drv
/gnu/store/nhy3343z8q23f20im1jm8cr0dvax8m3n-module-import-compiled.drv
/gnu/store/81jxzs3h1ryr1jmnzlazqn2i1qswxpxn-module-import-compiled.drv
/gnu/store/8va28xxwi4qidaq5gha55sxwwr2hwsbi-guile-gdbm-ffi-20120209.fa1d5b6.drv
/gnu/store/h64z34a0g2jy57fbfrmdrykfjqsm8ny4-module-import.drv
/gnu/store/cmavl4ahvx5yi1klmn1dmjc004njyi5h-ca-certificate-bundle.drv
/gnu/store/73vrp31a5fg5zgwyb4808dk7g5idq0n0-bash-static-4.4.19.drv
/gnu/store/rybkx8wn2czlbyhqf2hrxa4qjmrm5hkn-glibc-2.27.tar.xz.drv
/gnu/store/2ww5cyacdml0wqmpmpryyamvay1ryqfv-glibc-2.27.drv
/gnu/store/9mf0p34cm53g3l8li2fikmy4ns1f4jfm-linux-libre-headers-4.14.26.drv
/gnu/store/hwc4xr8jx4g4im96rsm5h3fbmr3b5gfv-gzip-1.9.drv
/gnu/store/vjc17j34rl0cvnbj547gk1hn1kxx4jdh-module-import-compiled.drv
/gnu/store/0mppv29wf1wf02hbrsi1i9y3rxj4wg99-info-dir.drv
/gnu/store/7vs1h0b02fzzf02bnmk23lw2sibfhnjy-glibc-utf8-locales-2.27.drv
/gnu/store/v1sz6x6z0nliqqzhvn5956gyq9qsw9k3-manual-database.drv
/gnu/store/zci2ggar92r1zfbfx5rb9klpzjlr6qg0-module-import-compiled.drv
This is an awful lot of unrelated packages required to build hello!
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-18 20:05 bug#34531: Guix profile fails on Overdrive 1000 Andreas Enge
@ 2019-02-18 20:49 ` Marius Bakke
2019-02-19 8:27 ` Andreas Enge
0 siblings, 1 reply; 22+ messages in thread
From: Marius Bakke @ 2019-02-18 20:49 UTC (permalink / raw)
To: Andreas Enge, 34531
[-- Attachment #1: Type: text/plain, Size: 2020 bytes --]
Andreas Enge <andreas@enge.fr> writes:
> Hello,
>
> on a newly installed Overdrive 1000 machine with 8 GB of memory, I am trying
> guix pull -n
>
> This results in
> Updating channel 'guix' from Git repository at 'https://git.savannah.gnu.org/git/guix.git'...
> Building from this channel:
> guix https://git.savannah.gnu.org/git/guix.git d0d207c
> The following derivations will be built:
> /gnu/store/qvljgqnsynw113h1062nws9i2zfcz15y-compute-guix-derivation.drv
> /gnu/store/rj824ibc8nhhl1j2h25sgw4lyxkxjggc-gdb-8.2.drv
> ...
> /gnu/store/w1jw283cdf6n03qnccsrvxgzy41z0hps-guile-gcrypt-0.1.0.drv
> building /gnu/store/wy37294j2rb6fg5fgpybki28vq60jz94-python-minimal-3.6.5.drv...
> starting phase `set-SOURCE-DATE-EPOCH'
> ...
>
> That a build of something starts although the "-n" flag is specified seems
> to be a first bug.
>
> Then, during the test phase, the build is killed since the machine runs out
> of memory. I also tried to pass "--cores=1" to "guix build", but this
> parameter is not honoured: "top" shows that all four cores are running.
> This might be a second bug.
>
> In any case, it becomes impossible to upgrade with the usual mechanism,
> which is a rather serious bug.
>
> My guix version:
> $ guix --version
> guix (GNU Guix) 0.15.0-8.71a78ba
The Python contained within this Guix snapshot has a known bug that
makes it leak memory on newer kernels. The Guix commit that works
around it is 589aca1c183ef1dfdef54d40fdd6a258bbcd39d0.
One thing you could try is bootstrap a Guix checkout through the usual
mechanisms (./bootstrap; ./configure; etc), using packages from the host
system if necessary.
From there you should be able to "./pre-inst-env guix pull".
A dirtier workaround is to delete
"/tmp/guix-build-python-minimal-3.6.5.drv-0/Lib/test/test_socket.py" at
some point during the build process, but you may have to do that a
couple of times.
Finally, installing 0.16.0 "from scratch" should also work.
HTH!
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 487 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-18 20:49 ` Marius Bakke
@ 2019-02-19 8:27 ` Andreas Enge
2019-02-19 13:23 ` Ricardo Wurmus
0 siblings, 1 reply; 22+ messages in thread
From: Andreas Enge @ 2019-02-19 8:27 UTC (permalink / raw)
To: Marius Bakke; +Cc: 34531
Hello Marius,
thanks a lot for your quick and helpful reply!
On Mon, Feb 18, 2019 at 09:49:10PM +0100, Marius Bakke wrote:
> The Python contained within this Guix snapshot has a known bug that
> makes it leak memory on newer kernels. The Guix commit that works
> around it is 589aca1c183ef1dfdef54d40fdd6a258bbcd39d0.
okay, so the main problem is fixed then.
> One thing you could try is bootstrap a Guix checkout through the usual
> mechanisms (./bootstrap; ./configure; etc), using packages from the host
> system if necessary.
The host system is Guix, so this is complicated... But I realise that
there is also a guix-0.16.0 lying around, and with this I get beyond the
python point.
Before closing the bug, I would still like to ask whether there is a way
of getting around the need for python. And why "guix pull -n" builds
such a large number of packages, while one would expect it to just print
a number of packages to be built. But maybe this is also solved in a
later version already.
Andreas
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-19 8:27 ` Andreas Enge
@ 2019-02-19 13:23 ` Ricardo Wurmus
2019-02-19 15:19 ` Danny Milosavljevic
` (2 more replies)
0 siblings, 3 replies; 22+ messages in thread
From: Ricardo Wurmus @ 2019-02-19 13:23 UTC (permalink / raw)
To: Andreas Enge; +Cc: 34531
Andreas Enge <andreas@enge.fr> writes:
> Before closing the bug, I would still like to ask whether there is a way
> of getting around the need for python.
Guix pull needs “guile-git”, and “guile-git” needs “libgit2”, which
needs “python-wrapper”. To remove the need for Python in “guix pull” we
would need to build libgit2 without Python. I don’t know if anyone has
investigated whether this can be done.
> And why "guix pull -n" builds
> such a large number of packages, while one would expect it to just print
> a number of packages to be built.
This is likely due to grafts. When you do “guix pull --no-grafts -n”
the behaviour is as expected.
--
Ricardo
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-19 13:23 ` Ricardo Wurmus
@ 2019-02-19 15:19 ` Danny Milosavljevic
2019-02-20 10:51 ` Danny Milosavljevic
2019-02-19 15:35 ` Andreas Enge
2019-04-04 11:28 ` Ludovic Courtès
2 siblings, 1 reply; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-19 15:19 UTC (permalink / raw)
To: Ricardo Wurmus, Andreas Enge; +Cc: 34531
[-- Attachment #1: Type: text/plain, Size: 1565 bytes --]
Hi Ricardo,
Hi Andreas,
On Tue, 19 Feb 2019 14:23:23 +0100
Ricardo Wurmus <rekado@elephly.net> wrote:
> Andreas Enge <andreas@enge.fr> writes:
>
> > Before closing the bug, I would still like to ask whether there is a way
> > of getting around the need for python.
>
> Guix pull needs “guile-git”, and “guile-git” needs “libgit2”, which
> needs “python-wrapper”. To remove the need for Python in “guix pull” we
> would need to build libgit2 without Python. I don’t know if anyone has
> investigated whether this can be done.
I have read it now--in the interest of simplicity and bootstrappability.
Python is only required to generate some libgit2 tests. It would be easy
to port the one Python program "generate.py" to some other language.
"generate.py" is from clar, which appears to be https://github.com/vmg/clar .
If someone were to replace it, that would be the correct place to contribute
it.
Python is listed as a regular input in libgit2.
I think it should be a native-input instead.
The dependency graph of libgit2 is very small after removing Python.
The languages it still depends on (possibly indirectly) are:
* Perl 5.28.0
* Guile 2.0.14
* bash 4.4.23
So writing the generate.py in one of those languages would not make the
dependency graph bigger than necessary.
generate.py uses regular expressions, simple file I/O, string templating
and that's pretty much it.
In any case, the first simplification would be just to move Python from
regular input to native-input.
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-19 13:23 ` Ricardo Wurmus
2019-02-19 15:19 ` Danny Milosavljevic
@ 2019-02-19 15:35 ` Andreas Enge
2019-02-19 15:40 ` Danny Milosavljevic
2019-04-04 11:28 ` Ludovic Courtès
2 siblings, 1 reply; 22+ messages in thread
From: Andreas Enge @ 2019-02-19 15:35 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34531
On Tue, Feb 19, 2019 at 02:23:23PM +0100, Ricardo Wurmus wrote:
> Guix pull needs “guile-git”, and “guile-git” needs “libgit2”, which
> needs “python-wrapper”. To remove the need for Python in “guix pull” we
> would need to build libgit2 without Python. I don’t know if anyone has
> investigated whether this can be done.
I tried to simply drop python-wrapper from inputs. Actually it is not
referenced by the final output, so it should be in native-inputs. And
here is what happens:
-- Could NOT find PythonInterp (missing: PYTHON_EXECUTABLE)
CMake Error at tests/CMakeLists.txt:4 (MESSAGE):
Could not find a python interpeter, which is needed to build the tests.
Make sure python is available, or pass -DBUILD_CLAR=OFF to skip building
the tests
So we could create a separate package for internal guix use without running
the tests, which would save us from compiling and especially testing python.
Although this is not our usual style - but on the other hand, "guix pull"
is more or less the first command that we recommend to our users, and
it would be nice if it ran fast without requiring (many) additional packages.
Ironically, libgit2 advertises itself as needing "Zero Dependencies" on its
web site...
What do you think?
Andreas
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-19 15:35 ` Andreas Enge
@ 2019-02-19 15:40 ` Danny Milosavljevic
0 siblings, 0 replies; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-19 15:40 UTC (permalink / raw)
To: Andreas Enge; +Cc: 34531
[-- Attachment #1: Type: text/plain, Size: 2665 bytes --]
Hi Andreas,
On Tue, 19 Feb 2019 16:35:53 +0100
Andreas Enge <andreas@enge.fr> wrote:
> I tried to simply drop python-wrapper from inputs. Actually it is not
> referenced by the final output, so it should be in native-inputs. And
> here is what happens:
>
> -- Could NOT find PythonInterp (missing: PYTHON_EXECUTABLE)
> CMake Error at tests/CMakeLists.txt:4 (MESSAGE):
> Could not find a python interpeter, which is needed to build the tests.
> Make sure python is available, or pass -DBUILD_CLAR=OFF to skip building
> the tests
diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm
index b8e967bf6..7452f17b8 100644
--- a/gnu/packages/version-control.scm
+++ b/gnu/packages/version-control.scm
@@ -545,7 +545,8 @@ everything from small to very large projects with speed and efficiency.")
(build-system cmake-build-system)
(outputs '("out" "debug"))
(arguments
- `(#:configure-flags '("-DUSE_SHA1DC=ON") ; SHA-1 collision detection
+ `(#:configure-flags '("-DUSE_SHA1DC=ON" ; SHA-1 collision detection
+ "-DBUILD_CLAR=OFF")
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'fix-hardcoded-paths
@@ -558,11 +559,13 @@ everything from small to very large projects with speed and efficiency.")
#t))
;; Run checks more verbosely.
(replace 'check
- (lambda _ (invoke "./libgit2_clar" "-v" "-Q"))))))
+ (const #t)
+ ))))
(inputs
`(("libssh2" ,libssh2)
("http-parser" ,http-parser)
- ("python" ,python-wrapper)))
+; ("python" ,python-wrapper)
+))
(native-inputs
`(("pkg-config" ,pkg-config)))
(propagated-inputs
> So we could create a separate package for internal guix use without running
> the tests, which would save us from compiling and especially testing python.
Please, let's just replace the test generator in this case. It's ridiculous
to complicate Guix that much for a 250 line test generator, most of which is
templates.
If necessary, I can do it, although a person who knows Perl or Guile better
can probably do it much faster.
> Although this is not our usual style - but on the other hand, "guix pull"
> is more or less the first command that we recommend to our users, and
> it would be nice if it ran fast without requiring (many) additional packages.
>
> Ironically, libgit2 advertises itself as needing "Zero Dependencies" on its
> web site...
>
> What do you think?
Just replace the one script and do run the tests, without depending on Python.
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply related [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-19 15:19 ` Danny Milosavljevic
@ 2019-02-20 10:51 ` Danny Milosavljevic
2019-02-20 11:46 ` Ricardo Wurmus
0 siblings, 1 reply; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-20 10:51 UTC (permalink / raw)
To: Ricardo Wurmus, Andreas Enge; +Cc: 34531
[-- Attachment #1.1: Type: text/plain, Size: 243 bytes --]
I've started on implementing a replacement test generator, see attachment.
Usage is exactly the same as the original generate.py.
However, it hangs somewhere and I can't find how to step through a guile program, even in emacs.
Help?
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: generate.scm --]
[-- Type: text/x-scheme, Size: 8513 bytes --]
;; -*- geiser-scheme-implementation: guile -*-
;; Implementation: Danny Milosavljevic <dannym@scratchpost.org>
;; Based on: Implementation in Python by Vicent Marti.
;; License: ISC, like the original generate.py in clar.
(use-modules (ice-9 ftw))
(use-modules (ice-9 regex))
(use-modules (ice-9 getopt-long))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 match))
(use-modules (ice-9 textual-ports))
(use-modules (srfi srfi-1))
(define (render-callback cb)
(if (> (length cb) 0)
(string-append " { \"" (assoc-ref cb "short-name") "\", &"
(assoc-ref cb "symbol") " }")
" { NULL, NULL }"))
(define (replace needle replacement haystack)
"Replace all occurences of NEEDLE in HAYSTACK by REPLACEMENT.
NEEDLE is a regular expression."
(regexp-substitute/global #f needle haystack 'pre replacement 'post))
(define (skip-comments text)
(replace (string-append "//.*?$|"
"/[*].*?[*]/|"
"'([.]|[^'])*'|"
"\"([.]|[^\"])*")
"" text))
(define (maybe-only items)
(match items
((a) a)
(_ #f)))
(define (Module name path excludes)
(let* ((clean-name (replace "_" "::" name))
(enabled (not (any (lambda (exclude)
(string-prefix? exclude clean-name))
excludes))))
(define (parse contents)
(define (cons-match match prev)
(cons
`(("declaration" ,(match:substring match 1))
("symbol" ,(match:substring match 2))
("short-name" ,(match:substring match 3)))
prev))
(let* ((contents (skip-comments contents))
(entries (fold-matches (string-append "^(void\\s+(test_"
name
"__(\\w+))\\s*\(\\s*void\\s*\\))\\s*\\{")
contents
'()
cons-match))
(callbacks (filter (lambda (entry)
(match (assoc-ref entry "short-name")
(("initialize" value) #f)
(("cleanup" value) #f)
(a #t)))
entries)))
(if (> (length callbacks) 0)
'(("name" name)
("enabled" (if enabled "1" "0"))
("clean-name" clean-name)
("initialize" (maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
(("initialize" value) value)
((_ value) #f)))
entries)))
("cleanup" (maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
(("cleanup" value) value)
((_ value) #f)))
entries)))
("callbacks" callbacks))
#f)))
(define (refresh path)
(and (file-exists? path)
(parse (get-string-all path))))
(refresh path)))
(define (generate-TestSuite path output excludes)
(define (load)
(define enter? (const #t))
(define (leaf file stat result)
(let* ((module-root (string-drop file (string-length path)))
(module-root (filter-map (match-lambda
("" #f)
(a a))
(string-split module-root #\/))))
(define (make-module path)
(let* ((name (string-join (append module-root (list (string-drop-right (basename path) (string-length ".c")))) "_"))
(name (replace "-" "_" name)))
(Module name path excludes)))
(write file)
(write module-root)
(newline)
(if (string-suffix? ".c" file)
(let ((module (make-module file)))
(if module
(cons module result)
result))
result)))
(define (down dir stat result)
result)
(define (up file state result)
result)
(define skip (const #f))
(define error (const #f)) ; FIXME
(write "fold")
(newline)
(file-system-fold enter? leaf down up skip error '() path))
(define (CallbacksTemplate module)
(string-append "static const struct clar_func _clar_cb_" module-name "[] = {\n"
(string-join (map render-callback (assoc-ref module "callbacks")) ",\n")
"\n};\n"))
(define (DeclarationTemplate module)
(string-append (string-join (map (lambda (cb)
(string-append "extern"
(assoc-ref cb "declaration")
";"))
(assoc-ref module "callbacks"))
"\n")
"\n"
(if (assoc-ref module "initialize")
(string-append "extern " (assoc-ref (assoc-ref module "initialize") "declaration") ";\n")
"")
(if (assoc-ref module "cleanup")
(string-append "extern " (assoc-ref (assoc-ref module "cleanup") "declaration") ";\n")
"")))
(define (InfoTemplate module)
(string-append "
{
\"" (assoc-ref module "clean-name") "\",\"
" (render-callback (assoc-ref module "initialize")) ",
" (render-callback (assoc-ref module "cleanup")) ",
_clar_cb_" (assoc-ref module "name") ", "
(length (assoc-ref module "callbacks"))
", " (assoc-ref module "enabled") "
}"))
(define (write data)
(define (name< module-a module-b)
(string<? (assoc-ref module-a "name")
(assoc-ref module-b "name")))
(define modules (sort (load) name<))
(define (suite-count)
(length modules))
(define (callback-count)
(fold + 0 (map (lambda (entry)
(assoc-ref entry "callbacks"))
modules)))
(define (display-x value)
(display value data))
(for-each (compose display-x DeclarationTemplate) modules)
(for-each (compose display-x CallbacksTemplate) modules)
(display-x "static struct clar_suite _clar_suites[] = {")
(display-x (string-join (map InfoTemplate modules) ","))
(display-x "\n};\n")
(display-x "static const size_t _clar_suite_count = ")
(display-x (number->string (suite-count)))
(display-x ";\n")
(display-x "static const size_t _clar_callback_count = ")
(display-x (number->string (callback-count)))
(display-x ";\n")
(display (string-append "Written `clar.suite` (" callback-count " tests in " suite-count " suites"))
#t)
(call-with-output-file (string-append output "/clar.suite") write))
;;; main
(define (main)
(define option-spec
'((force (single-char #\f) (value #f))
(exclude (single-char #\x) (value #t))
(output (single-char #\o) (value #t))
(help (single-char #\h) (value #f))))
(define options (getopt-long (command-line) option-spec #:stop-at-first-non-option #t))
(define args (reverse (option-ref options '() '())))
(when (> (length args) 1)
(display "More than one path given\n")
(exit 1))
(if (< (length args) 1)
(set! args '(".")))
(let* ((path (car args))
(output (option-ref options 'output path))
(excluded (filter-map (match-lambda
(('exclude . value) value)
(_ #f))
options)))
(generate-TestSuite path output excluded)))
(main)
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-20 10:51 ` Danny Milosavljevic
@ 2019-02-20 11:46 ` Ricardo Wurmus
2019-02-20 13:26 ` Danny Milosavljevic
2019-02-20 13:28 ` Danny Milosavljevic
0 siblings, 2 replies; 22+ messages in thread
From: Ricardo Wurmus @ 2019-02-20 11:46 UTC (permalink / raw)
To: Danny Milosavljevic; +Cc: 34531
Danny Milosavljevic <dannym@scratchpost.org> writes:
> I've started on implementing a replacement test generator, see attachment.
Excellent!
> Usage is exactly the same as the original generate.py.
Can you show us how to use it? What files does a proper test require?
--
Ricardo
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-20 11:46 ` Ricardo Wurmus
@ 2019-02-20 13:26 ` Danny Milosavljevic
2019-02-20 15:56 ` Ricardo Wurmus
2019-02-20 13:28 ` Danny Milosavljevic
1 sibling, 1 reply; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-20 13:26 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34531
[-- Attachment #1: Type: text/plain, Size: 288 bytes --]
Hi Ricardo,
unpack libgit2-0.27.7, then invoke
guile generate.scm -o /tmp -f -x online -x stress -x perf .
in there.
Reference:
./tests/CMakeLists.txt: COMMAND ${PYTHON_EXECUTABLE} generate.py -o "${CMAKE_CURRENT_BINARY_DIR}" -f -xonline -xstress -xperf .
(in libgit2)
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-20 11:46 ` Ricardo Wurmus
2019-02-20 13:26 ` Danny Milosavljevic
@ 2019-02-20 13:28 ` Danny Milosavljevic
1 sibling, 0 replies; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-20 13:28 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34531
[-- Attachment #1: Type: text/plain, Size: 207 bytes --]
> What files does a proper test require?
generate.scm scans the files with the glob "*.c" for functions test_... and
refers all of those in a new file "clar.suite" in the directory specified
by "-o".
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-20 13:26 ` Danny Milosavljevic
@ 2019-02-20 15:56 ` Ricardo Wurmus
2019-02-20 16:26 ` Danny Milosavljevic
0 siblings, 1 reply; 22+ messages in thread
From: Ricardo Wurmus @ 2019-02-20 15:56 UTC (permalink / raw)
To: Danny Milosavljevic; +Cc: 34531
[-- Attachment #1: Type: text/plain, Size: 1670 bytes --]
Hi Danny,
> unpack libgit2-0.27.7, then invoke
>
> guile generate.scm -o /tmp -f -x online -x stress -x perf .
>
> in there.
Thanks for the instructions.
One of the problems is that you use and also overwrite “write”,
which is a core Scheme procedure. I renamed it to “Write” and modified
the invocation to
(call-with-output-file (string-append output "/clar.suite") Write)
which leads to this error:
--8<---------------cut here---------------start------------->8---
…
In ice-9/ftw.scm:
482:39 4 (loop _ _ #(64768 139272 16877 51 1000 1000 0 4096 1550677456 0 1550677457 4096 8 directory 493 818358318 0 1550677457) _ _)
In ice-9/eval.scm:
293:34 3 (_ #(#(#(#(#(#<directory (guile-user) 717140> "." ("perf" "stress" "online")) "./tests/clar_libgit2_timer.c" #(64768 132360 33188 1 1000 1000 0 …) …) …) …) …))
191:35 2 (_ #(#(#<directory (guile-user) 717140> #<variable 8e4eb0 value: #<procedure parse (a)>>) "./tests/clar_libgit2_timer.c"))
In ice-9/rdelim.scm:
160:18 1 (read-string _)
In unknown file:
0 (read-char "./tests/clar_libgit2_timer.c")
ERROR: In procedure read-char:
In procedure read-char: Wrong type argument in position 1 (expecting open input port): "./tests/clar_libgit2_timer.c"
--8<---------------cut here---------------end--------------->8---
Simple mistake: you called “get-string-all” on a string (stored in
“path”), but you need to use (call-with-input-file path get-string-all)
instead.
Next error is about a bad regex (forgot one escape character); and
a type error follows that.
The fixed version is attached.
--
Ricardo
[-- Attachment #2: generate.scm --]
[-- Type: application/octet-stream, Size: 8467 bytes --]
;; -*- geiser-scheme-implementation: guile -*-
;; Implementation: Danny Milosavljevic <dannym@scratchpost.org>
;; Based on: Implementation in Python by Vicent Marti.
;; License: ISC, like the original generate.py in clar.
(use-modules (ice-9 ftw))
(use-modules (ice-9 regex))
(use-modules (ice-9 getopt-long))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 match))
(use-modules (ice-9 textual-ports))
(use-modules (srfi srfi-1))
(define (render-callback cb)
(if (> (length cb) 0)
(string-append " { \"" (assoc-ref cb "short-name") "\", &"
(assoc-ref cb "symbol") " }")
" { NULL, NULL }"))
(define (replace needle replacement haystack)
"Replace all occurences of NEEDLE in HAYSTACK by REPLACEMENT.
NEEDLE is a regular expression."
(regexp-substitute/global #f needle haystack 'pre replacement 'post))
(define (skip-comments text)
(replace (string-append "//.*?$|"
"/[*].*?[*]/|"
"'([.]|[^'])*'|"
"\"([.]|[^\"])*")
"" text))
(define (maybe-only items)
(match items
((a) a)
(_ #f)))
(define (Module name path excludes)
(let* ((clean-name (replace "_" "::" name))
(enabled (not (any (lambda (exclude)
(string-prefix? exclude clean-name))
excludes))))
(define (parse contents)
(define (cons-match match prev)
(cons
`(("declaration" ,(match:substring match 1))
("symbol" ,(match:substring match 2))
("short-name" ,(match:substring match 3)))
prev))
(let* ((contents (skip-comments contents))
(entries (fold-matches (string-append "^(void\\s+(test_"
name
"__(\\w+))\\s*\\(\\s*void\\s*\\))\\s*\\{")
contents
'()
cons-match))
(callbacks (filter (lambda (entry)
(match (assoc-ref entry "short-name")
(("initialize" value) #f)
(("cleanup" value) #f)
(a #t)))
entries)))
(if (> (length callbacks) 0)
'(("name" name)
("enabled" (if enabled "1" "0"))
("clean-name" clean-name)
("initialize" (maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
(("initialize" value) value)
((_ value) #f)))
entries)))
("cleanup" (maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
(("cleanup" value) value)
((_ value) #f)))
entries)))
("callbacks" callbacks))
#f)))
(define (refresh path)
(and (file-exists? path)
(parse (call-with-input-file path get-string-all))))
(refresh path)))
(define (generate-TestSuite path output excludes)
(define (load)
(define enter? (const #t))
(define (leaf file stat result)
(let* ((module-root (string-drop file (string-length path)))
(module-root (filter-map (match-lambda
("" #f)
(a a))
(string-split module-root #\/))))
(define (make-module path)
(let* ((name (string-join (append module-root (list (string-drop-right (basename path) (string-length ".c")))) "_"))
(name (replace "-" "_" name)))
(Module name path excludes)))
(write file)
(write module-root)
(newline)
(if (string-suffix? ".c" file)
(let ((module (make-module file)))
(if module
(cons module result)
result))
result)))
(define (down dir stat result)
result)
(define (up file state result)
result)
(define skip (const #f))
(define error (const #f)) ; FIXME
(write "fold")
(newline)
(file-system-fold enter? leaf down up skip error '() path))
(define (CallbacksTemplate module)
(string-append "static const struct clar_func _clar_cb_" module-name "[] = {\n"
(string-join (map render-callback (assoc-ref module "callbacks")) ",\n")
"\n};\n"))
(define (DeclarationTemplate module)
(string-append (string-join (map (lambda (cb)
(string-append "extern"
(assoc-ref cb "declaration")
";"))
(assoc-ref module "callbacks"))
"\n")
"\n"
(if (assoc-ref module "initialize")
(string-append "extern " (assoc-ref (assoc-ref module "initialize") "declaration") ";\n")
"")
(if (assoc-ref module "cleanup")
(string-append "extern " (assoc-ref (assoc-ref module "cleanup") "declaration") ";\n")
"")))
(define (InfoTemplate module)
(string-append "
{
\"" (assoc-ref module "clean-name") "\",\"
" (render-callback (assoc-ref module "initialize")) ",
" (render-callback (assoc-ref module "cleanup")) ",
_clar_cb_" (assoc-ref module "name") ", "
(length (assoc-ref module "callbacks"))
", " (assoc-ref module "enabled") "
}"))
(define (Write data)
(define (name< module-a module-b)
(string<? (assoc-ref module-a "name")
(assoc-ref module-b "name")))
(define modules (sort (load) name<))
(define (suite-count)
(length modules))
(define (callback-count)
(fold + 0 (map (lambda (entry)
(assoc-ref entry "callbacks"))
modules)))
(define (display-x value)
(display value data))
(for-each (compose display-x DeclarationTemplate) modules)
(for-each (compose display-x CallbacksTemplate) modules)
(display-x "static struct clar_suite _clar_suites[] = {")
(display-x (string-join (map InfoTemplate modules) ","))
(display-x "\n};\n")
(let ((suite-count-str (number->string (suite-count)))
(callback-count-str (number->string (callback-count))))
(display-x "static const size_t _clar_suite_count = ")
(display-x suite-count-str)
(display-x ";\n")
(display-x "static const size_t _clar_callback_count = ")
(display-x callback-count-str)
(display-x ";\n")
(display (string-append "Written `clar.suite` (" callback-count-str " tests in " suite-count-str " suites)"))
(newline))
#t)
(call-with-output-file (string-append output "/clar.suite") Write))
;;; main
(define (main)
(define option-spec
'((force (single-char #\f) (value #f))
(exclude (single-char #\x) (value #t))
(output (single-char #\o) (value #t))
(help (single-char #\h) (value #f))))
(define options (getopt-long (command-line) option-spec #:stop-at-first-non-option #t))
(define args (reverse (option-ref options '() '())))
(when (> (length args) 1)
(display "More than one path given\n")
(exit 1))
(if (< (length args) 1)
(set! args '(".")))
(let* ((path (car args))
(output (option-ref options 'output path))
(excluded (filter-map (match-lambda
(('exclude . value) value)
(_ #f))
options)))
(generate-TestSuite path output excluded)))
(main)
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-20 15:56 ` Ricardo Wurmus
@ 2019-02-20 16:26 ` Danny Milosavljevic
2019-02-20 20:53 ` Ricardo Wurmus
0 siblings, 1 reply; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-20 16:26 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34531
[-- Attachment #1: Type: text/plain, Size: 567 bytes --]
Hi Ricardo,
On Wed, 20 Feb 2019 16:56:35 +0100
Ricardo Wurmus <rekado@elephly.net> wrote:
> The fixed version is attached.
Thanks a lot!
It almost works, but it seems not to find the "test_" lines.
I've reduced the problem to:
scheme@(guile-user)> ,use (ice-9 regex)
scheme@(guile-user)> (fold-matches "^void" "blah\nvoid\n" '() cons)
$24 = ()
After reading the documentation, I've revised it to:
scheme@(guile-user)> ,use (ice-9 regex)
scheme@(guile-user)> (fold-matches "^void" "blah\nvoid\n" '() cons regexp/newline)
$25 = ()
Huh?
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-20 16:26 ` Danny Milosavljevic
@ 2019-02-20 20:53 ` Ricardo Wurmus
2019-02-20 22:08 ` Danny Milosavljevic
0 siblings, 1 reply; 22+ messages in thread
From: Ricardo Wurmus @ 2019-02-20 20:53 UTC (permalink / raw)
To: Danny Milosavljevic; +Cc: 34531
Danny Milosavljevic <dannym@scratchpost.org> writes:
> It almost works, but it seems not to find the "test_" lines.
>
> I've reduced the problem to:
>
> scheme@(guile-user)> ,use (ice-9 regex)
> scheme@(guile-user)> (fold-matches "^void" "blah\nvoid\n" '() cons)
> $24 = ()
>
> After reading the documentation, I've revised it to:
>
> scheme@(guile-user)> ,use (ice-9 regex)
> scheme@(guile-user)> (fold-matches "^void" "blah\nvoid\n" '() cons regexp/newline)
> $25 = ()
Try this instead:
(fold-matches (make-regexp "^void" regexp/newline)
"blah\nvoid\n" '() cons)
Or rather
(list-matches (make-regexp "^void" regexp/newline)
"blah\nvoid\n")
--
Ricardo
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-20 20:53 ` Ricardo Wurmus
@ 2019-02-20 22:08 ` Danny Milosavljevic
2019-02-20 22:28 ` Danny Milosavljevic
2019-02-23 11:20 ` Ricardo Wurmus
0 siblings, 2 replies; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-20 22:08 UTC (permalink / raw)
To: 34531
[-- Attachment #1.1: Type: text/plain, Size: 1075 bytes --]
First somewhat working version attached...
It finds 1387 tests in 328 suites.
The original finds 2611 tests in 349 suites.
That's because skip-comments is somehow broken.
An example where it has an error very early is tests/core/futils.c :
(use-modules (ice-9 ftw))
(use-modules (ice-9 regex))
(use-modules (ice-9 getopt-long))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 match))
(use-modules (ice-9 textual-ports))
(use-modules (srfi srfi-1))
(define fname "test/core/futils.c")
(define s (call-with-input-file fname get-string-all))
(define (replace needle replacement haystack)
"Replace all occurences of NEEDLE in HAYSTACK by REPLACEMENT.
NEEDLE is a regular expression."
(regexp-substitute/global #f needle haystack 'pre replacement 'post))
(define (skip-comments text)
(replace (string-append "//[^\n]*?|"
"/[*].*?[*]/|"
"'([.]|[^'])*?'|"
"\"([.]|[^\"])*?\"")
"" text))
(write (skip-comments s)) ; very short, for some reason
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: generate.scm --]
[-- Type: text/x-scheme, Size: 10720 bytes --]
;; -*- geiser-scheme-implementation: guile -*-
;;; Implementation: Danny Milosavljevic <dannym@scratchpost.org>
;;; Based on: Implementation in Python by Vicent Marti.
;;; License: ISC, like the original generate.py in clar.
(use-modules (ice-9 ftw))
(use-modules (ice-9 regex))
(use-modules (ice-9 getopt-long))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 match))
(use-modules (ice-9 textual-ports))
(use-modules (srfi srfi-1))
(define (render-callback cb)
(if cb
(string-append " { \"" (assoc-ref cb "short-name") "\", &"
(assoc-ref cb "symbol") " }")
" { NULL, NULL }"))
(define (rxegexp-substitute/global flags port regexp string . items)
;; If `port' is #f, send output to a string.
(if (not port)
(call-with-output-string
(lambda (p)
(apply regexp-substitute/global flags p regexp string items)))
;; Walk the set of non-overlapping, maximal matches.
(let next-match ((matches (list-matches regexp string flags))
(start 0))
(if (null? matches)
(display (substring string start) port)
(let ((m (car matches)))
;; Process all of the items for this match. Don't use
;; for-each, because we need to make sure 'post at the
;; end of the item list is a tail call.
(let next-item ((items items))
(define (do-item item)
(cond
((string? item) (display item port))
((integer? item) (display (match:substring m item) port))
((procedure? item) (display (item m) port))
((eq? item 'pre)
(display
(substring string start (match:start m))
port))
((eq? item 'post)
(next-match (cdr matches) (match:end m)))
(else (error 'wrong-type-arg item))))
(if (pair? items)
(if (null? (cdr items))
(do-item (car items)) ; This is a tail call.
(begin
(do-item (car items)) ; This is not.
(next-item (cdr items)))))))))))
(define (replace needle replacement haystack)
"Replace all occurences of NEEDLE in HAYSTACK by REPLACEMENT.
NEEDLE is a regular expression."
(regexp-substitute/global #f needle haystack 'pre replacement 'post))
(define (skip-comments text)
(replace (string-append "//[^\n]*?|"
"/[*].*?[*]/|"
"'([.]|[^'])*?'|"
"\"([.]|[^\"])*?\"")
"" text))
(define (maybe-only items)
(match items
((a) a)
(_ #f)))
(define (Module name path excludes)
(write name)
(write path)
(newline)
(let* ((clean-name (replace "_" "::" name))
(enabled (not (any (lambda (exclude)
(string-prefix? exclude clean-name))
excludes))))
(define (parse contents)
(define (cons-match match prev)
(cons
`(("declaration" . ,(match:substring match 1))
("symbol" . ,(match:substring match 2))
("short-name" . ,(match:substring match 3)))
prev))
(let* ((contents (skip-comments contents))
(entries (fold-matches (make-regexp
(string-append "^(void\\s+(test_"
name
"__(\\w+))\\s*\\(\\s*void\\s*\\))\\s*\\{")
regexp/newline)
contents
'()
cons-match))
(callbacks (filter (lambda (entry)
(match (assoc-ref entry "short-name")
("initialize" #f)
("cleanup" #f)
(_ #t)))
entries)))
(write callbacks)
(newline)
(if (> (length callbacks) 0)
`(("name" . ,name)
("enabled" . ,(if enabled "1" "0"))
("clean-name" . ,clean-name)
("initialize" . ,(maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
("initialize" entry)
(_ #f)))
entries)))
("cleanup" . ,(maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
("cleanup" entry)
(_ #f)))
entries)))
("callbacks" . ,callbacks))
#f)))
(define (refresh path)
(and (file-exists? path)
(parse (call-with-input-file path get-string-all))))
(refresh path)))
(define (generate-TestSuite path output excludes)
(define (load)
(define enter? (const #t))
(define (leaf file stat result)
(let* ((module-root (string-drop (dirname file)
(string-length path)))
(module-root (filter-map (match-lambda
("" #f)
(a a))
(string-split module-root #\/))))
(define (make-module path)
(let* ((name (string-join (append module-root (list (string-drop-right (basename path) (string-length ".c")))) "_"))
(name (replace "-" "_" name)))
(Module name path excludes)))
(if (string-suffix? ".c" file)
(let ((module (make-module file)))
(if module
(cons module result)
result))
result)))
(define (down dir stat result)
result)
(define (up file state result)
result)
(define skip (const #f))
(define error (const #f)) ; FIXME
(file-system-fold enter? leaf down up skip error '() path))
(define (CallbacksTemplate module)
(string-append "static const struct clar_func _clar_cb_"
(assoc-ref module "name") "[] = {\n"
(string-join (map render-callback
(assoc-ref module "callbacks"))
",\n")
"\n};\n"))
(define (DeclarationTemplate module)
(string-append (string-join (map (lambda (cb)
(string-append "extern "
(assoc-ref cb "declaration")
";"))
(assoc-ref module "callbacks"))
"\n")
"\n"
(if (assoc-ref module "initialize")
(string-append "extern " (assoc-ref (assoc-ref module "initialize") "declaration") ";\n")
"")
(if (assoc-ref module "cleanup")
(string-append "extern " (assoc-ref (assoc-ref module "cleanup") "declaration") ";\n")
"")))
(define (InfoTemplate module)
(string-append "
{
\"" (assoc-ref module "clean-name") "\",
" (render-callback (assoc-ref module "initialize")) ",
" (render-callback (assoc-ref module "cleanup")) ",
_clar_cb_" (assoc-ref module "name") ", "
(number->string (length (assoc-ref module "callbacks")))
", " (assoc-ref module "enabled") "
}"))
(define (Write data)
(define (name< module-a module-b)
(string<? (assoc-ref module-a "name")
(assoc-ref module-b "name")))
(define modules (sort (load) name<))
(define (suite-count)
(length modules))
(define (callback-count)
(fold + 0 (map (lambda (entry)
(length (assoc-ref entry "callbacks")))
modules)))
(define (display-x value)
(display value data))
(for-each (compose display-x DeclarationTemplate) modules)
(for-each (compose display-x CallbacksTemplate) modules)
(display-x "static struct clar_suite _clar_suites[] = {")
(display-x (string-join (map InfoTemplate modules) ","))
(display-x "\n};\n")
(let ((suite-count-str (number->string (suite-count)))
(callback-count-str (number->string (callback-count))))
(display-x "static const size_t _clar_suite_count = ")
(display-x suite-count-str)
(display-x ";\n")
(display-x "static const size_t _clar_callback_count = ")
(display-x callback-count-str)
(display-x ";\n")
(display (string-append "Written `clar.suite` ("
callback-count-str
" tests in "
suite-count-str
" suites)"))
(newline))
#t)
(call-with-output-file (string-append output "/clar.suite") Write))
;;; main
(define (main)
(define option-spec
'((force (single-char #\f) (value #f))
(exclude (single-char #\x) (value #t))
(output (single-char #\o) (value #t))
(help (single-char #\h) (value #f))))
(define options (getopt-long (command-line) option-spec #:stop-at-first-non-option #t))
(define args (reverse (option-ref options '() '())))
(when (> (length args) 1)
(display "More than one path given\n")
(exit 1))
(if (< (length args) 1)
(set! args '(".")))
(let* ((path (car args))
(output (option-ref options 'output path))
(excluded (filter-map (match-lambda
(('exclude . value) value)
(_ #f))
options)))
(generate-TestSuite path output excluded)))
(main)
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-20 22:08 ` Danny Milosavljevic
@ 2019-02-20 22:28 ` Danny Milosavljevic
2019-02-23 11:20 ` Ricardo Wurmus
1 sibling, 0 replies; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-20 22:28 UTC (permalink / raw)
To: 34531
[-- Attachment #1.1: Type: text/plain, Size: 645 bytes --]
On Wed, 20 Feb 2019 23:08:57 +0100
Danny Milosavljevic <dannym@scratchpost.org> wrote:
> First somewhat working version attached...
>
> It finds 1387 tests in 328 suites.
>
> The original finds 2611 tests in 349 suites.
>
> That's because skip-comments is somehow broken.
Another example is tests/repo/pathspec.c where the vast majority of the file is missing.
In any case, leaving the call of skip-comments off, it finds 2611 tests in 349 suites (see attachment).
So either we find the problem in skip-comments, or we leave it off. In both cases, this can be used in order to generate the test metadata for libgit2 now.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: generate.scm --]
[-- Type: text/x-scheme, Size: 10721 bytes --]
;; -*- geiser-scheme-implementation: guile -*-
;;; Implementation: Danny Milosavljevic <dannym@scratchpost.org>
;;; Based on: Implementation in Python by Vicent Marti.
;;; License: ISC, like the original generate.py in clar.
(use-modules (ice-9 ftw))
(use-modules (ice-9 regex))
(use-modules (ice-9 getopt-long))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 match))
(use-modules (ice-9 textual-ports))
(use-modules (srfi srfi-1))
(define (render-callback cb)
(if cb
(string-append " { \"" (assoc-ref cb "short-name") "\", &"
(assoc-ref cb "symbol") " }")
" { NULL, NULL }"))
(define (rxegexp-substitute/global flags port regexp string . items)
;; If `port' is #f, send output to a string.
(if (not port)
(call-with-output-string
(lambda (p)
(apply regexp-substitute/global flags p regexp string items)))
;; Walk the set of non-overlapping, maximal matches.
(let next-match ((matches (list-matches regexp string flags))
(start 0))
(if (null? matches)
(display (substring string start) port)
(let ((m (car matches)))
;; Process all of the items for this match. Don't use
;; for-each, because we need to make sure 'post at the
;; end of the item list is a tail call.
(let next-item ((items items))
(define (do-item item)
(cond
((string? item) (display item port))
((integer? item) (display (match:substring m item) port))
((procedure? item) (display (item m) port))
((eq? item 'pre)
(display
(substring string start (match:start m))
port))
((eq? item 'post)
(next-match (cdr matches) (match:end m)))
(else (error 'wrong-type-arg item))))
(if (pair? items)
(if (null? (cdr items))
(do-item (car items)) ; This is a tail call.
(begin
(do-item (car items)) ; This is not.
(next-item (cdr items)))))))))))
(define (replace needle replacement haystack)
"Replace all occurences of NEEDLE in HAYSTACK by REPLACEMENT.
NEEDLE is a regular expression."
(regexp-substitute/global #f needle haystack 'pre replacement 'post))
(define (skip-comments text)
(replace (string-append "//[^\n]*?|"
"/[*].*?[*]/|"
"'([.]|[^'])*?'|"
"\"([.]|[^\"])*?\"")
"" text))
(define (maybe-only items)
(match items
((a) a)
(_ #f)))
(define (Module name path excludes)
(write name)
(write path)
(newline)
(let* ((clean-name (replace "_" "::" name))
(enabled (not (any (lambda (exclude)
(string-prefix? exclude clean-name))
excludes))))
(define (parse contents)
(define (cons-match match prev)
(cons
`(("declaration" . ,(match:substring match 1))
("symbol" . ,(match:substring match 2))
("short-name" . ,(match:substring match 3)))
prev))
(let* ((contents2 (skip-comments contents))
(entries (fold-matches (make-regexp
(string-append "^(void\\s+(test_"
name
"__(\\w+))\\s*\\(\\s*void\\s*\\))\\s*\\{")
regexp/newline)
contents
'()
cons-match))
(callbacks (filter (lambda (entry)
(match (assoc-ref entry "short-name")
("initialize" #f)
("cleanup" #f)
(_ #t)))
entries)))
(write callbacks)
(newline)
(if (> (length callbacks) 0)
`(("name" . ,name)
("enabled" . ,(if enabled "1" "0"))
("clean-name" . ,clean-name)
("initialize" . ,(maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
("initialize" entry)
(_ #f)))
entries)))
("cleanup" . ,(maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
("cleanup" entry)
(_ #f)))
entries)))
("callbacks" . ,callbacks))
#f)))
(define (refresh path)
(and (file-exists? path)
(parse (call-with-input-file path get-string-all))))
(refresh path)))
(define (generate-TestSuite path output excludes)
(define (load)
(define enter? (const #t))
(define (leaf file stat result)
(let* ((module-root (string-drop (dirname file)
(string-length path)))
(module-root (filter-map (match-lambda
("" #f)
(a a))
(string-split module-root #\/))))
(define (make-module path)
(let* ((name (string-join (append module-root (list (string-drop-right (basename path) (string-length ".c")))) "_"))
(name (replace "-" "_" name)))
(Module name path excludes)))
(if (string-suffix? ".c" file)
(let ((module (make-module file)))
(if module
(cons module result)
result))
result)))
(define (down dir stat result)
result)
(define (up file state result)
result)
(define skip (const #f))
(define error (const #f)) ; FIXME
(file-system-fold enter? leaf down up skip error '() path))
(define (CallbacksTemplate module)
(string-append "static const struct clar_func _clar_cb_"
(assoc-ref module "name") "[] = {\n"
(string-join (map render-callback
(assoc-ref module "callbacks"))
",\n")
"\n};\n"))
(define (DeclarationTemplate module)
(string-append (string-join (map (lambda (cb)
(string-append "extern "
(assoc-ref cb "declaration")
";"))
(assoc-ref module "callbacks"))
"\n")
"\n"
(if (assoc-ref module "initialize")
(string-append "extern " (assoc-ref (assoc-ref module "initialize") "declaration") ";\n")
"")
(if (assoc-ref module "cleanup")
(string-append "extern " (assoc-ref (assoc-ref module "cleanup") "declaration") ";\n")
"")))
(define (InfoTemplate module)
(string-append "
{
\"" (assoc-ref module "clean-name") "\",
" (render-callback (assoc-ref module "initialize")) ",
" (render-callback (assoc-ref module "cleanup")) ",
_clar_cb_" (assoc-ref module "name") ", "
(number->string (length (assoc-ref module "callbacks")))
", " (assoc-ref module "enabled") "
}"))
(define (Write data)
(define (name< module-a module-b)
(string<? (assoc-ref module-a "name")
(assoc-ref module-b "name")))
(define modules (sort (load) name<))
(define (suite-count)
(length modules))
(define (callback-count)
(fold + 0 (map (lambda (entry)
(length (assoc-ref entry "callbacks")))
modules)))
(define (display-x value)
(display value data))
(for-each (compose display-x DeclarationTemplate) modules)
(for-each (compose display-x CallbacksTemplate) modules)
(display-x "static struct clar_suite _clar_suites[] = {")
(display-x (string-join (map InfoTemplate modules) ","))
(display-x "\n};\n")
(let ((suite-count-str (number->string (suite-count)))
(callback-count-str (number->string (callback-count))))
(display-x "static const size_t _clar_suite_count = ")
(display-x suite-count-str)
(display-x ";\n")
(display-x "static const size_t _clar_callback_count = ")
(display-x callback-count-str)
(display-x ";\n")
(display (string-append "Written `clar.suite` ("
callback-count-str
" tests in "
suite-count-str
" suites)"))
(newline))
#t)
(call-with-output-file (string-append output "/clar.suite") Write))
;;; main
(define (main)
(define option-spec
'((force (single-char #\f) (value #f))
(exclude (single-char #\x) (value #t))
(output (single-char #\o) (value #t))
(help (single-char #\h) (value #f))))
(define options (getopt-long (command-line) option-spec #:stop-at-first-non-option #t))
(define args (reverse (option-ref options '() '())))
(when (> (length args) 1)
(display "More than one path given\n")
(exit 1))
(if (< (length args) 1)
(set! args '(".")))
(let* ((path (car args))
(output (option-ref options 'output path))
(excluded (filter-map (match-lambda
(('exclude . value) value)
(_ #f))
options)))
(generate-TestSuite path output excluded)))
(main)
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-20 22:08 ` Danny Milosavljevic
2019-02-20 22:28 ` Danny Milosavljevic
@ 2019-02-23 11:20 ` Ricardo Wurmus
2019-02-24 10:40 ` Danny Milosavljevic
1 sibling, 1 reply; 22+ messages in thread
From: Ricardo Wurmus @ 2019-02-23 11:20 UTC (permalink / raw)
To: Danny Milosavljevic; +Cc: 34531
Danny Milosavljevic <dannym@scratchpost.org> writes:
> (define (skip-comments text)
> (replace (string-append "//[^\n]*?|"
> "/[*].*?[*]/|"
> "'([.]|[^'])*?'|"
> "\"([.]|[^\"])*?\"")
This last part will remove anything between double quotes, such as every
string. Another problem seems to be the handling of /* comments */.
It’s a greedy regex that will swallow any character until it finally
hits */ — even if the characters in between may have been */.
I would not use regular expressions here but a read loop such as this:
--8<---------------cut here---------------start------------->8---
(define (strip-comments port)
(let loop ((char (get-char port))
(balance 0)
(chars '()))
(cond
;; done!
((eof-object? char)
(list->string (reverse chars)))
;; line comment
((and (equal? char #\/)
(equal? #\/ (peek-char port)))
(begin (read-line port)
(loop (get-char port) balance chars)))
;; begin of block comment
((and (equal? char #\/)
(equal? #\* (peek-char port)))
(begin (read-char port)
(loop (get-char port) (1+ balance) chars)))
;; end of block comment
((and (positive? balance)
(equal? char #\*)
(equal? #\/ (peek-char port)))
(begin (read-char port)
(loop (get-char port) (1- balance) chars)))
;; inside block comment
((positive? balance)
(loop (get-char port) balance chars))
;; just a plain ol’ character
(else (loop (get-char port) balance (cons char chars))))))
;; Strip all comments from the file “fname” and show the result.
(display (call-with-input-file fname strip-comments))
--8<---------------cut here---------------end--------------->8---
--
Ricardo
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-23 11:20 ` Ricardo Wurmus
@ 2019-02-24 10:40 ` Danny Milosavljevic
2019-02-24 11:45 ` Ricardo Wurmus
0 siblings, 1 reply; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-24 10:40 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34531
[-- Attachment #1.1: Type: text/plain, Size: 42 bytes --]
Final version attached. Works fine now.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: generate.scm --]
[-- Type: text/x-scheme, Size: 11228 bytes --]
;; -*- geiser-scheme-implementation: guile -*-
;;; Implementation: Danny Milosavljevic <dannym@scratchpost.org>
;;; Based on: Implementation in Python by Vicent Marti.
;;; License: ISC, like the original generate.py in clar.
(use-modules (ice-9 ftw))
(use-modules (ice-9 regex))
(use-modules (ice-9 getopt-long))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 match))
(use-modules (ice-9 textual-ports))
(use-modules (srfi srfi-1))
(define (render-callback cb)
(if cb
(string-append " { \"" (assoc-ref cb "short-name") "\", &"
(assoc-ref cb "symbol") " }")
" { NULL, NULL }"))
(define (replace needle replacement haystack)
"Replace all occurences of NEEDLE in HAYSTACK by REPLACEMENT.
NEEDLE is a regular expression."
(regexp-substitute/global #f needle haystack 'pre replacement 'post))
(define (skip-comments* text)
(call-with-input-string
text
(lambda (port)
(let loop ((result '())
(section #f))
(define (consume-char)
(cons (read-char port) result))
(define (skip-char)
(read-char port)
result)
(match section
(#f
(match (peek-char port)
(#\/ (loop (consume-char) 'almost-in-block-comment))
(#\" (loop (consume-char) 'in-string-literal))
(#\' (loop (consume-char) 'in-character-literal))
((? eof-object?) result)
(_ (loop (consume-char) section))))
('almost-in-block-comment
(match (peek-char port)
(#\* (loop (consume-char) 'in-block-comment))
(#\/ (loop (consume-char) 'in-line-comment))
((? eof-object?) result)
(_ (loop (consume-char) #f))))
('in-line-comment
(match (peek-char port)
(#\newline (loop (consume-char) #f))
((? eof-object?) result)
(_ (loop (skip-char) section))))
('in-block-comment
(match (peek-char port)
(#\* (loop (skip-char) 'almost-out-of-block-comment))
((? eof-object?) result)
(_ (loop (skip-char) section))))
('almost-out-of-block-comment
(match (peek-char port)
(#\/ (loop (cons (read-char port) (cons #\* result)) #f))
(#\* (loop (skip-char) 'almost-out-of-block-comment))
((? eof-object?) result)
(_ (loop (skip-char) 'in-block-comment))))
('in-string-literal
(match (peek-char port)
(#\\ (loop (skip-char) 'in-string-literal-escape))
(#\" (loop (consume-char) #f))
((? eof-object?) result)
(_ (loop (skip-char) section))))
('in-string-literal-escape
(match (peek-char port)
((? eof-object?) result)
(_ (loop (skip-char) 'in-string-literal))))
('in-character-literal
(match (peek-char port)
(#\\ (loop (skip-char) 'in-character-literal-escape))
(#\' (loop (consume-char) #f))
((? eof-object?) result)
(_ (loop (skip-char) section))))
('in-character-literal-escape
(match (peek-char port)
((? eof-object?) result)
(_ (loop (skip-char) 'in-character-literal)))))))))
(define (skip-comments text)
(list->string (reverse (skip-comments* text))))
(define (maybe-only items)
(match items
((a) a)
(_ #f)))
(define (Module name path excludes)
(let* ((clean-name (replace "_" "::" name))
(enabled (not (any (lambda (exclude)
(string-prefix? exclude clean-name))
excludes))))
(define (parse contents)
(define (cons-match match prev)
(cons
`(("declaration" . ,(match:substring match 1))
("symbol" . ,(match:substring match 2))
("short-name" . ,(match:substring match 3)))
prev))
(let* ((contents (skip-comments contents))
(entries (fold-matches (make-regexp
(string-append "^(void\\s+(test_"
name
"__(\\w+))\\s*\\(\\s*void\\s*\\))\\s*\\{")
regexp/newline)
contents
'()
cons-match))
(callbacks (filter (lambda (entry)
(match (assoc-ref entry "short-name")
("initialize" #f)
("cleanup" #f)
(_ #t)))
entries)))
(if (> (length callbacks) 0)
`(("name" . ,name)
("enabled" . ,(if enabled "1" "0"))
("clean-name" . ,clean-name)
("initialize" . ,(maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
("initialize" entry)
(_ #f)))
entries)))
("cleanup" . ,(maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
("cleanup" entry)
(_ #f)))
entries)))
("callbacks" . ,callbacks))
#f)))
(define (refresh path)
(and (file-exists? path)
(parse (call-with-input-file path get-string-all))))
(refresh path)))
(define (generate-TestSuite path output excludes)
(define (load)
(define enter? (const #t))
(define (leaf file stat result)
(let* ((module-root (string-drop (dirname file)
(string-length path)))
(module-root (filter-map (match-lambda
("" #f)
(a a))
(string-split module-root #\/))))
(define (make-module path)
(let* ((name (string-join (append module-root (list (string-drop-right (basename path) (string-length ".c")))) "_"))
(name (replace "-" "_" name)))
(Module name path excludes)))
(if (string-suffix? ".c" file)
(let ((module (make-module file)))
(if module
(cons module result)
result))
result)))
(define (down dir stat result)
result)
(define (up file state result)
result)
(define skip (const #f))
(define error (const #f)) ; FIXME
(file-system-fold enter? leaf down up skip error '() path))
(define (CallbacksTemplate module)
(string-append "static const struct clar_func _clar_cb_"
(assoc-ref module "name") "[] = {\n"
(string-join (map render-callback
(assoc-ref module "callbacks"))
",\n")
"\n};\n"))
(define (DeclarationTemplate module)
(string-append (string-join (map (lambda (cb)
(string-append "extern "
(assoc-ref cb "declaration")
";"))
(assoc-ref module "callbacks"))
"\n")
"\n"
(if (assoc-ref module "initialize")
(string-append "extern " (assoc-ref (assoc-ref module "initialize") "declaration") ";\n")
"")
(if (assoc-ref module "cleanup")
(string-append "extern " (assoc-ref (assoc-ref module "cleanup") "declaration") ";\n")
"")))
(define (InfoTemplate module)
(string-append "
{
\"" (assoc-ref module "clean-name") "\",
" (render-callback (assoc-ref module "initialize")) ",
" (render-callback (assoc-ref module "cleanup")) ",
_clar_cb_" (assoc-ref module "name") ", "
(number->string (length (assoc-ref module "callbacks")))
", " (assoc-ref module "enabled") "
}"))
(define (Write data)
(define (name< module-a module-b)
(string<? (assoc-ref module-a "name")
(assoc-ref module-b "name")))
(define modules (sort (load) name<))
(define (suite-count)
(length modules))
(define (callback-count)
(fold + 0 (map (lambda (entry)
(length (assoc-ref entry "callbacks")))
modules)))
(define (display-x value)
(display value data))
(for-each (compose display-x DeclarationTemplate) modules)
(for-each (compose display-x CallbacksTemplate) modules)
(display-x "static struct clar_suite _clar_suites[] = {")
(display-x (string-join (map InfoTemplate modules) ","))
(display-x "\n};\n")
(let ((suite-count-str (number->string (suite-count)))
(callback-count-str (number->string (callback-count))))
(display-x "static const size_t _clar_suite_count = ")
(display-x suite-count-str)
(display-x ";\n")
(display-x "static const size_t _clar_callback_count = ")
(display-x callback-count-str)
(display-x ";\n")
(display (string-append "Written `clar.suite` ("
callback-count-str
" tests in "
suite-count-str
" suites)"))
(newline))
#t)
(call-with-output-file (string-append output "/clar.suite") Write))
;;; main
(define (main)
(define option-spec
'((force (single-char #\f) (value #f))
(exclude (single-char #\x) (value #t))
(output (single-char #\o) (value #t))
(help (single-char #\h) (value #f))))
(define options (getopt-long (command-line) option-spec #:stop-at-first-non-option #t))
(define args (reverse (option-ref options '() '())))
(when (> (length args) 1)
(display "More than one path given\n")
(exit 1))
(if (< (length args) 1)
(set! args '(".")))
(let* ((path (car args))
(output (option-ref options 'output path))
(excluded (filter-map (match-lambda
(('exclude . value) value)
(_ #f))
options)))
(generate-TestSuite path output excluded)))
(main)
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-24 10:40 ` Danny Milosavljevic
@ 2019-02-24 11:45 ` Ricardo Wurmus
2019-02-24 12:12 ` Danny Milosavljevic
0 siblings, 1 reply; 22+ messages in thread
From: Ricardo Wurmus @ 2019-02-24 11:45 UTC (permalink / raw)
To: Danny Milosavljevic; +Cc: 34531
Danny Milosavljevic <dannym@scratchpost.org> writes:
> Final version attached. Works fine now.
The loop looks a bit more complicated than it needs to be, I think. Did
my version not work for you?
--
Ricardo
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-24 11:45 ` Ricardo Wurmus
@ 2019-02-24 12:12 ` Danny Milosavljevic
2019-02-26 21:07 ` Ricardo Wurmus
0 siblings, 1 reply; 22+ messages in thread
From: Danny Milosavljevic @ 2019-02-24 12:12 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34531
[-- Attachment #1.1: Type: text/plain, Size: 810 bytes --]
Hi Ricardo,
On Sun, 24 Feb 2019 12:45:34 +0100
Ricardo Wurmus <rekado@elephly.net> wrote:
> Danny Milosavljevic <dannym@scratchpost.org> writes:
>
> > Final version attached. Works fine now.
>
> The loop looks a bit more complicated than it needs to be, I think. Did
> my version not work for you?
It did, but I wanted to make sure the port did exactly the same as the
original generate.py--maybe I overdid it, but I didn't want to break it
by porting it.
What skip_comments in the original does is strip comments, but not strip
"comment-like things" that are in string literals ("/*blah*/").
(as far as I can tell, at least)
I agree your version is easier but does it do the same thing?
Attached a v2 where I fixed a bug in literal handling related to that (oops).
WDYT?
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: generate.scm --]
[-- Type: text/x-scheme, Size: 11246 bytes --]
;; -*- geiser-scheme-implementation: guile -*-
;;; Implementation: Danny Milosavljevic <dannym@scratchpost.org>
;;; Based on: Implementation in Python by Vicent Marti.
;;; License: ISC, like the original generate.py in clar.
(use-modules (ice-9 ftw))
(use-modules (ice-9 regex))
(use-modules (ice-9 getopt-long))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 match))
(use-modules (ice-9 textual-ports))
(use-modules (srfi srfi-1))
(define (render-callback cb)
(if cb
(string-append " { \"" (assoc-ref cb "short-name") "\", &"
(assoc-ref cb "symbol") " }")
" { NULL, NULL }"))
(define (replace needle replacement haystack)
"Replace all occurences of NEEDLE in HAYSTACK by REPLACEMENT.
NEEDLE is a regular expression."
(regexp-substitute/global #f needle haystack 'pre replacement 'post))
(define (skip-comments* text)
(call-with-input-string
text
(lambda (port)
(let loop ((result '())
(section #f))
(define (consume-char)
(cons (read-char port) result))
(define (skip-char)
(read-char port)
result)
(match section
(#f
(match (peek-char port)
(#\/ (loop (consume-char) 'almost-in-block-comment))
(#\" (loop (consume-char) 'in-string-literal))
(#\' (loop (consume-char) 'in-character-literal))
((? eof-object?) result)
(_ (loop (consume-char) section))))
('almost-in-block-comment
(match (peek-char port)
(#\* (loop (consume-char) 'in-block-comment))
(#\/ (loop (consume-char) 'in-line-comment))
((? eof-object?) result)
(_ (loop (consume-char) #f))))
('in-line-comment
(match (peek-char port)
(#\newline (loop (consume-char) #f))
((? eof-object?) result)
(_ (loop (skip-char) section))))
('in-block-comment
(match (peek-char port)
(#\* (loop (skip-char) 'almost-out-of-block-comment))
((? eof-object?) result)
(_ (loop (skip-char) section))))
('almost-out-of-block-comment
(match (peek-char port)
(#\/ (loop (cons (read-char port) (cons #\* result)) #f))
(#\* (loop (skip-char) 'almost-out-of-block-comment))
((? eof-object?) result)
(_ (loop (skip-char) 'in-block-comment))))
('in-string-literal
(match (peek-char port)
(#\\ (loop (consume-char) 'in-string-literal-escape))
(#\" (loop (consume-char) #f))
((? eof-object?) result)
(_ (loop (consume-char) section))))
('in-string-literal-escape
(match (peek-char port)
((? eof-object?) result)
(_ (loop (consume-char) 'in-string-literal))))
('in-character-literal
(match (peek-char port)
(#\\ (loop (consume-char) 'in-character-literal-escape))
(#\' (loop (consume-char) #f))
((? eof-object?) result)
(_ (loop (consume-char) section))))
('in-character-literal-escape
(match (peek-char port)
((? eof-object?) result)
(_ (loop (consume-char) 'in-character-literal)))))))))
(define (skip-comments text)
(list->string (reverse (skip-comments* text))))
(define (maybe-only items)
(match items
((a) a)
(_ #f)))
(define (Module name path excludes)
(let* ((clean-name (replace "_" "::" name))
(enabled (not (any (lambda (exclude)
(string-prefix? exclude clean-name))
excludes))))
(define (parse contents)
(define (cons-match match prev)
(cons
`(("declaration" . ,(match:substring match 1))
("symbol" . ,(match:substring match 2))
("short-name" . ,(match:substring match 3)))
prev))
(let* ((contents (skip-comments contents))
(entries (fold-matches (make-regexp
(string-append "^(void\\s+(test_"
name
"__(\\w+))\\s*\\(\\s*void\\s*\\))\\s*\\{")
regexp/newline)
contents
'()
cons-match))
(callbacks (filter (lambda (entry)
(match (assoc-ref entry "short-name")
("initialize" #f)
("cleanup" #f)
(_ #t)))
entries)))
(if (> (length callbacks) 0)
`(("name" . ,name)
("enabled" . ,(if enabled "1" "0"))
("clean-name" . ,clean-name)
("initialize" . ,(maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
("initialize" entry)
(_ #f)))
entries)))
("cleanup" . ,(maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
("cleanup" entry)
(_ #f)))
entries)))
("callbacks" . ,callbacks))
#f)))
(define (refresh path)
(and (file-exists? path)
(parse (call-with-input-file path get-string-all))))
(refresh path)))
(define (generate-TestSuite path output excludes)
(define (load)
(define enter? (const #t))
(define (leaf file stat result)
(let* ((module-root (string-drop (dirname file)
(string-length path)))
(module-root (filter-map (match-lambda
("" #f)
(a a))
(string-split module-root #\/))))
(define (make-module path)
(let* ((name (string-join (append module-root (list (string-drop-right (basename path) (string-length ".c")))) "_"))
(name (replace "-" "_" name)))
(Module name path excludes)))
(if (string-suffix? ".c" file)
(let ((module (make-module file)))
(if module
(cons module result)
result))
result)))
(define (down dir stat result)
result)
(define (up file state result)
result)
(define skip (const #f))
(define error (const #f)) ; FIXME
(file-system-fold enter? leaf down up skip error '() path))
(define (CallbacksTemplate module)
(string-append "static const struct clar_func _clar_cb_"
(assoc-ref module "name") "[] = {\n"
(string-join (map render-callback
(assoc-ref module "callbacks"))
",\n")
"\n};\n"))
(define (DeclarationTemplate module)
(string-append (string-join (map (lambda (cb)
(string-append "extern "
(assoc-ref cb "declaration")
";"))
(assoc-ref module "callbacks"))
"\n")
"\n"
(if (assoc-ref module "initialize")
(string-append "extern " (assoc-ref (assoc-ref module "initialize") "declaration") ";\n")
"")
(if (assoc-ref module "cleanup")
(string-append "extern " (assoc-ref (assoc-ref module "cleanup") "declaration") ";\n")
"")))
(define (InfoTemplate module)
(string-append "
{
\"" (assoc-ref module "clean-name") "\",
" (render-callback (assoc-ref module "initialize")) ",
" (render-callback (assoc-ref module "cleanup")) ",
_clar_cb_" (assoc-ref module "name") ", "
(number->string (length (assoc-ref module "callbacks")))
", " (assoc-ref module "enabled") "
}"))
(define (Write data)
(define (name< module-a module-b)
(string<? (assoc-ref module-a "name")
(assoc-ref module-b "name")))
(define modules (sort (load) name<))
(define (suite-count)
(length modules))
(define (callback-count)
(fold + 0 (map (lambda (entry)
(length (assoc-ref entry "callbacks")))
modules)))
(define (display-x value)
(display value data))
(for-each (compose display-x DeclarationTemplate) modules)
(for-each (compose display-x CallbacksTemplate) modules)
(display-x "static struct clar_suite _clar_suites[] = {")
(display-x (string-join (map InfoTemplate modules) ","))
(display-x "\n};\n")
(let ((suite-count-str (number->string (suite-count)))
(callback-count-str (number->string (callback-count))))
(display-x "static const size_t _clar_suite_count = ")
(display-x suite-count-str)
(display-x ";\n")
(display-x "static const size_t _clar_callback_count = ")
(display-x callback-count-str)
(display-x ";\n")
(display (string-append "Written `clar.suite` ("
callback-count-str
" tests in "
suite-count-str
" suites)"))
(newline))
#t)
(call-with-output-file (string-append output "/clar.suite") Write))
;;; main
(define (main)
(define option-spec
'((force (single-char #\f) (value #f))
(exclude (single-char #\x) (value #t))
(output (single-char #\o) (value #t))
(help (single-char #\h) (value #f))))
(define options (getopt-long (command-line) option-spec #:stop-at-first-non-option #t))
(define args (reverse (option-ref options '() '())))
(when (> (length args) 1)
(display "More than one path given\n")
(exit 1))
(if (< (length args) 1)
(set! args '(".")))
(let* ((path (car args))
(output (option-ref options 'output path))
(excluded (filter-map (match-lambda
(('exclude . value) value)
(_ #f))
options)))
(generate-TestSuite path output excluded)))
(main)
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-24 12:12 ` Danny Milosavljevic
@ 2019-02-26 21:07 ` Ricardo Wurmus
0 siblings, 0 replies; 22+ messages in thread
From: Ricardo Wurmus @ 2019-02-26 21:07 UTC (permalink / raw)
To: Danny Milosavljevic; +Cc: 34531
Hi Danny,
>> The loop looks a bit more complicated than it needs to be, I think. Did
>> my version not work for you?
>
> It did, but I wanted to make sure the port did exactly the same as the
> original generate.py--maybe I overdid it, but I didn't want to break it
> by porting it.
>
> What skip_comments in the original does is strip comments, but not strip
> "comment-like things" that are in string literals ("/*blah*/").
> (as far as I can tell, at least)
Ah, I see. If your version works fine I think it’s worth using it to
replace the need for Python here.
I’d probably implement this somewhat differently (to remove the
“almost*” symbols and to cut down on duplication), but I don’t think
it’s worth polishing this when the main purpose has been achieved.
Thanks for tackling this!
--
Ricardo
^ permalink raw reply [flat|nested] 22+ messages in thread
* bug#34531: Guix profile fails on Overdrive 1000
2019-02-19 13:23 ` Ricardo Wurmus
2019-02-19 15:19 ` Danny Milosavljevic
2019-02-19 15:35 ` Andreas Enge
@ 2019-04-04 11:28 ` Ludovic Courtès
2 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2019-04-04 11:28 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 34531-done
Hello,
Ricardo Wurmus <rekado@elephly.net> skribis:
> Andreas Enge <andreas@enge.fr> writes:
>
>> Before closing the bug, I would still like to ask whether there is a way
>> of getting around the need for python.
>
> Guix pull needs “guile-git”, and “guile-git” needs “libgit2”, which
> needs “python-wrapper”. To remove the need for Python in “guix pull” we
> would need to build libgit2 without Python. I don’t know if anyone has
> investigated whether this can be done.
Danny Milosavljevic <dannym@scratchpost.org> skribis:
> I've started on implementing a replacement test generator, see attachment.
>
> Usage is exactly the same as the original generate.py.
I gather this bug was fixed with commit
03fb5ff6ae01a680c786d9ee148839543c519411. Closing!
Ludo’.
^ permalink raw reply [flat|nested] 22+ messages in thread
end of thread, other threads:[~2019-04-04 11:29 UTC | newest]
Thread overview: 22+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-02-18 20:05 bug#34531: Guix profile fails on Overdrive 1000 Andreas Enge
2019-02-18 20:49 ` Marius Bakke
2019-02-19 8:27 ` Andreas Enge
2019-02-19 13:23 ` Ricardo Wurmus
2019-02-19 15:19 ` Danny Milosavljevic
2019-02-20 10:51 ` Danny Milosavljevic
2019-02-20 11:46 ` Ricardo Wurmus
2019-02-20 13:26 ` Danny Milosavljevic
2019-02-20 15:56 ` Ricardo Wurmus
2019-02-20 16:26 ` Danny Milosavljevic
2019-02-20 20:53 ` Ricardo Wurmus
2019-02-20 22:08 ` Danny Milosavljevic
2019-02-20 22:28 ` Danny Milosavljevic
2019-02-23 11:20 ` Ricardo Wurmus
2019-02-24 10:40 ` Danny Milosavljevic
2019-02-24 11:45 ` Ricardo Wurmus
2019-02-24 12:12 ` Danny Milosavljevic
2019-02-26 21:07 ` Ricardo Wurmus
2019-02-20 13:28 ` Danny Milosavljevic
2019-02-19 15:35 ` Andreas Enge
2019-02-19 15:40 ` Danny Milosavljevic
2019-04-04 11:28 ` Ludovic Courtès
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).