* GNU Guile 2.0.6 released
@ 2012-07-09 17:02 David Pirotte
2012-07-10 8:18 ` Guile build failure Ludovic Courtès
0 siblings, 1 reply; 14+ messages in thread
From: David Pirotte @ 2012-07-09 17:02 UTC (permalink / raw
To: guile-devel
Hello,
It compiles fine here, from git, debian testing on both 32/64bit boxes. Make check
fails on our 64bit box though, with the following message ...
please note that here our /usr/local is an nfs mounting point [there were
some problems that Mark addressed about half a year ago].
[the 32bit box on which make check pass does not use nfs]
i'll be happy to give more info and offer some time on irc to help you debug if
needed ...
Cheers,
David
;; --
...
Running load.test
Backtrace:
In ice-9/boot-9.scm:
157: 12 [catch #t #<catch-closure be6960> ...]
In unknown file:
?: 11 [apply-smob/1 #<catch-closure be6960>]
In ice-9/boot-9.scm:
63: 10 [call-with-prompt prompt0 ...]
In ice-9/eval.scm:
414: 9 [eval # #]
414: 8 [eval # #]
In ice-9/boot-9.scm:
693: 7 [for-each #<procedure 10b1690 at ice-9/eval.scm:403:13 (a)> #]
In ice-9/eval.scm:
463: 6 [lp (#<fluid 22>) (("load.test"))]
In ice-9/boot-9.scm:
2131: 5 [save-module-excursion #<procedure 348d200 at ice-9/boot-9.scm:3660:3 ()>]
3665: 4 [#<procedure 348d200 at ice-9/boot-9.scm:3660:3 ()>]
1456: 3 [%start-stack load-stack ...]
1461: 2 [#<procedure 3499810 ()>]
In unknown file:
?: 1 [primitive-load "/usr/local/src/guile/git-clone/test-suite/tests/load.test"]
?: 0 [rmdir "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir"]
ERROR: In procedure rmdir:
ERROR: In procedure rmdir: Directory not empty
FAIL: check-guile
==================================
1 of 1 test failed
Please report to bug-guile@gnu.org
==================================
make[3]: *** [check-TESTS] Error 1
make[3]: Leaving directory `/mnt/galia/linux/64/local/src/guile/git-clone'
make[2]: *** [check-am] Error 2
make[2]: Leaving directory `/mnt/galia/linux/64/local/src/guile/git-clone'
make[1]: *** [check-recursive] Error 1
make[1]: Leaving directory `/mnt/galia/linux/64/local/src/guile/git-clone'
make: *** [check] Error 2
david@automatix:/usr/local/src/guile/git-clone 24 $
^ permalink raw reply [flat|nested] 14+ messages in thread
* Guile build failure
2012-07-09 17:02 GNU Guile 2.0.6 released David Pirotte
@ 2012-07-10 8:18 ` Ludovic Courtès
2012-07-10 15:50 ` David Pirotte
0 siblings, 1 reply; 14+ messages in thread
From: Ludovic Courtès @ 2012-07-10 8:18 UTC (permalink / raw
To: David Pirotte; +Cc: guile-devel
Hi David,
David Pirotte <david@altosw.be> skribis:
> It compiles fine here, from git,
Which branch is it? Did you try the 2.0.6 tarball?
[...]
> ?: 1 [primitive-load "/usr/local/src/guile/git-clone/test-suite/tests/load.test"]
> ?: 0 [rmdir "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir"]
Could you rm -rf this directory and try again?
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2012-07-10 8:18 ` Guile build failure Ludovic Courtès
@ 2012-07-10 15:50 ` David Pirotte
2012-07-11 9:43 ` Ludovic Courtès
0 siblings, 1 reply; 14+ messages in thread
From: David Pirotte @ 2012-07-10 15:50 UTC (permalink / raw
To: Ludovic Courtès; +Cc: guile-devel
Hi Ludovic,
> Which branch is it? Did you try the 2.0.6 tarball?
This was using stable. No I didn't try the tarball, but since you asked i just did
and did in 2 different locations: /opt [no nfs] and /usr/local/src [uses nfs] and
make check passes on /opt but fails on /usr/local/src
...
Totals for this test run:
passes: 34490
failures: 0
unexpected passes: 0
expected failures: 30
unresolved test cases: 564
untested test cases: 1
unsupported test cases: 9
errors: 0
PASS: check-guile
=============
1 test passed
=============
make[3]: Leaving directory `/opt/guile-2.0.6'
make[2]: Leaving directory `/opt/guile-2.0.6'
make[1]: Leaving directory `/opt/guile-2.0.6'
david@automatix:/opt/guile-2.0.6 28 $
Here is in /usr/local/src...
...
In ice-9/boot-9.scm:
2131: 5 [save-module-excursion #<procedure 4209480 at ice-9/boot-9.scm:3660:3 ()>]
3665: 4 [#<procedure 4209480 at ice-9/boot-9.scm:3660:3 ()>]
1456: 3 [%start-stack load-stack ...]
1461: 2 [#<procedure 4214630 ()>]
In unknown file:
?: 1 [primitive-load
"/usr/local/src/guile/guile-2.0.6/test-suite/tests/load.test"] ?: 0 [rmdir
"/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir"]
ERROR: In procedure rmdir:
ERROR: In procedure rmdir: Directory not empty
FAIL: check-guile
==================================
1 of 1 test failed
Please report to bug-guile@gnu.org
==================================
make[3]: *** [check-TESTS] Error 1
make[3]: Leaving directory `/mnt/galia/linux/64/local/src/guile/guile-2.0.6'
make[2]: *** [check-am] Error 2
make[2]: Leaving directory `/mnt/galia/linux/64/local/src/guile/guile-2.0.6'
make[1]: *** [check-recursive] Error 1
make[1]: Leaving directory `/mnt/galia/linux/64/local/src/guile/guile-2.0.6'
make: *** [check] Error 2
david@automatix:/usr/local/src/guile/guile-2.0.6 9 $
> > ?: 1 [primitive-load
> > "/usr/local/src/guile/git-clone/test-suite/tests/load.test"] ?: 0 [rmdir
> > "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir"]
>
> Could you rm -rf this directory and try again?
I did try that before to send the email, but it didn't help
Cheers,
David
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2012-07-10 15:50 ` David Pirotte
@ 2012-07-11 9:43 ` Ludovic Courtès
2012-07-19 13:59 ` David Pirotte
0 siblings, 1 reply; 14+ messages in thread
From: Ludovic Courtès @ 2012-07-11 9:43 UTC (permalink / raw
To: David Pirotte; +Cc: guile-devel
Hi,
David Pirotte <david@altosw.be> skribis:
> This was using stable. No I didn't try the tarball, but since you asked i just did
> and did in 2 different locations: /opt [no nfs] and /usr/local/src [uses nfs] and
> make check passes on /opt but fails on /usr/local/src
So the problem seems to be NFS-related. Could you check rmdir
"/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir" fails?
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2012-07-11 9:43 ` Ludovic Courtès
@ 2012-07-19 13:59 ` David Pirotte
2012-07-19 16:02 ` Ludovic Courtès
0 siblings, 1 reply; 14+ messages in thread
From: David Pirotte @ 2012-07-19 13:59 UTC (permalink / raw
To: Ludovic Courtès; +Cc: guile-devel
Hello Ludovic,
> So the problem seems to be NFS-related. Could you check rmdir
> "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir" fails?
Yes, but I'd rather say it is a guile NFS related problem:
rmdir /mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir
works fine.
Cheers,
David
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2012-07-19 13:59 ` David Pirotte
@ 2012-07-19 16:02 ` Ludovic Courtès
2012-07-19 16:45 ` David Pirotte
0 siblings, 1 reply; 14+ messages in thread
From: Ludovic Courtès @ 2012-07-19 16:02 UTC (permalink / raw
To: David Pirotte; +Cc: guile-devel
Hi David,
David Pirotte <david@altosw.be> skribis:
>> So the problem seems to be NFS-related. Could you check rmdir
>> "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir" fails?
I meant, could you run the thing through strace? Like:
strace -f -o log ./check-guile
and then send the part of the log surrounding the failing rmdir(2) call.
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2012-07-19 16:02 ` Ludovic Courtès
@ 2012-07-19 16:45 ` David Pirotte
2012-07-21 11:15 ` Ludovic Courtès
0 siblings, 1 reply; 14+ messages in thread
From: David Pirotte @ 2012-07-19 16:45 UTC (permalink / raw
To: Ludovic Courtès; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 127 bytes --]
> strace -f -o log ./check-guile
> and then send the part of the log surrounding the failing rmdir(2) call.
sure, attached
[-- Attachment #2: log.bz2 --]
[-- Type: application/x-bzip, Size: 3062 bytes --]
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2012-07-19 16:45 ` David Pirotte
@ 2012-07-21 11:15 ` Ludovic Courtès
2012-07-28 15:55 ` David Pirotte
0 siblings, 1 reply; 14+ messages in thread
From: Ludovic Courtès @ 2012-07-21 11:15 UTC (permalink / raw
To: David Pirotte; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 564 bytes --]
Hi!
Sorry, I’m still pretty clueless.
Can you try the attached patch, and run “./check-guile load.test” with
this NFS setup?
For me, it displays this:
;;; (remaining "/home/ludo/src/guile/load-test.dir/dir3" ("." ".."))
;;; (remaining "/home/ludo/src/guile/load-test.dir/dir1/subdir1" ("." ".."))
;;; (remaining "/home/ludo/src/guile/load-test.dir/dir1" ("." ".."))
;;; (remaining "/home/ludo/src/guile/load-test.dir/dir2" ("." ".."))
;;; (remaining "/home/ludo/src/guile/load-test.dir" ("." ".."))
Thanks,
Ludo’.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 659 bytes --]
diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test
index 1cf8d65..a43573c 100644
--- a/test-suite/tests/load.test
+++ b/test-suite/tests/load.test
@@ -20,7 +20,8 @@
(define-module (test-suite test-load)
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
- #:use-module (system base compile))
+ #:use-module (system base compile)
+ #:use-module (ice-9 ftw))
(define temp-dir (data-file-name "load-test.dir"))
@@ -61,6 +62,7 @@
(delete-tree name)
(loop))))))
(closedir dir)
+ (pk 'remaining tree (scandir tree))
(rmdir tree)))
((file-exists? tree)
(delete-file tree))
^ permalink raw reply related [flat|nested] 14+ messages in thread
* Re: Guile build failure
2012-07-21 11:15 ` Ludovic Courtès
@ 2012-07-28 15:55 ` David Pirotte
2012-08-09 13:57 ` Ludovic Courtès
0 siblings, 1 reply; 14+ messages in thread
From: David Pirotte @ 2012-07-28 15:55 UTC (permalink / raw
To: Ludovic Courtès; +Cc: guile-devel
Heya Ludovic,
Sorry for the delay.
> Can you try the attached patch, and run “./check-guile load.test” with
> this NFS setup?
Running load.test
;;; (remaining "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir/dir3" ("." ".."))
;;; (remaining "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir/dir2" ("." ".."))
;;; (remaining "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir/dir1/subdir1" ("." ".."))
;;; (remaining "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir/dir1" ("." ".."))
;;; (remaining "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir" ("." ".." ".nfs00000000121e01b200000019" ".nfs00000000121e01b30000001a"))
Backtrace:
In ice-9/boot-9.scm:
157: 12 [catch #t #<catch-closure ffaae0> ...]
Cheers,
David
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2012-07-28 15:55 ` David Pirotte
@ 2012-08-09 13:57 ` Ludovic Courtès
2013-01-21 9:26 ` Andy Wingo
0 siblings, 1 reply; 14+ messages in thread
From: Ludovic Courtès @ 2012-08-09 13:57 UTC (permalink / raw
To: David Pirotte; +Cc: guile-devel
Hi David, and sorry for the delay,
David Pirotte <david@altosw.be> skribis:
> ;;; (remaining "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir" ("." ".." ".nfs00000000121e01b200000019" ".nfs00000000121e01b30000001a"))
Aaah, those hidden files are the culprit.
I’ll guess we’ll have to live with the fact that those tests won’t work
over some NFS implementations, because I don’t see what could be done to
work around it.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2012-08-09 13:57 ` Ludovic Courtès
@ 2013-01-21 9:26 ` Andy Wingo
2013-01-21 10:47 ` Ludovic Courtès
0 siblings, 1 reply; 14+ messages in thread
From: Andy Wingo @ 2013-01-21 9:26 UTC (permalink / raw
To: Ludovic Courtès; +Cc: guile-devel, David Pirotte
On Thu 09 Aug 2012 15:57, ludo@gnu.org (Ludovic Courtès) writes:
> Hi David, and sorry for the delay,
>
> David Pirotte <david@altosw.be> skribis:
>
>> ;;; (remaining "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir" ("." ".." ".nfs00000000121e01b200000019" ".nfs00000000121e01b30000001a"))
>
> Aaah, those hidden files are the culprit.
From http://www.redhat.com/archives/rhelv5-list/2008-May/msg00156.html:
.nfs000* are the ghosts of departed files. For example, if you have a
file handle for /home/user/foo open on an nfs client and the file gets
removed somewhere else, then the .nfs* file shows up/is used by the
original process until it closes the file handle.
Use "fuser .nfs*" to see which process is using it.
Could Guile be keeping a handle open to these files?
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2013-01-21 9:26 ` Andy Wingo
@ 2013-01-21 10:47 ` Ludovic Courtès
2013-01-21 11:39 ` Andy Wingo
0 siblings, 1 reply; 14+ messages in thread
From: Ludovic Courtès @ 2013-01-21 10:47 UTC (permalink / raw
To: Andy Wingo; +Cc: guile-devel, David Pirotte
Hi,
Andy Wingo <wingo@pobox.com> skribis:
> On Thu 09 Aug 2012 15:57, ludo@gnu.org (Ludovic Courtès) writes:
>
>> Hi David, and sorry for the delay,
>>
>> David Pirotte <david@altosw.be> skribis:
>>
>>> ;;; (remaining "/mnt/galia/linux/64/local/src/guile/guile-2.0.6/load-test.dir" ("." ".." ".nfs00000000121e01b200000019" ".nfs00000000121e01b30000001a"))
>>
>> Aaah, those hidden files are the culprit.
>
> From http://www.redhat.com/archives/rhelv5-list/2008-May/msg00156.html:
>
> .nfs000* are the ghosts of departed files. For example, if you have a
> file handle for /home/user/foo open on an nfs client and the file gets
> removed somewhere else, then the .nfs* file shows up/is used by the
> original process until it closes the file handle.
>
> Use "fuser .nfs*" to see which process is using it.
>
> Could Guile be keeping a handle open to these files?
‘load.test’ uses ‘compile-file’, and it seems that ‘compile-file’ does
an ‘open-input-file’ with no corresponding ‘close-port’. That may be
the problem.
Ludo’.
^ permalink raw reply [flat|nested] 14+ messages in thread
* Re: Guile build failure
2013-01-21 10:47 ` Ludovic Courtès
@ 2013-01-21 11:39 ` Andy Wingo
2013-01-22 16:43 ` David Pirotte
0 siblings, 1 reply; 14+ messages in thread
From: Andy Wingo @ 2013-01-21 11:39 UTC (permalink / raw
To: David Pirotte; +Cc: guile-devel
Hi David,
On Mon 21 Jan 2013 11:47, ludo@gnu.org (Ludovic Courtès) writes:
> ‘load.test’ uses ‘compile-file’, and it seems that ‘compile-file’ does
> an ‘open-input-file’ with no corresponding ‘close-port’. That may be
> the problem.
Can you try the following patch? ./check-guile load.test on your NFS
machine should do it.
Andy
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index afcb55a..d6a57e6 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -1,6 +1,6 @@
;;; High-level compiler interface
-;; Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 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
@@ -150,6 +150,7 @@
(read-and-compile in #:env env #:from from #:to to #:opts opts)
port))
file)
+ (close-port in)
comp)))
(define* (compile-and-load file #:key (from 'scheme) (to 'value)
@@ -200,6 +201,7 @@
(let ((x ((language-reader (current-language)) port cenv)))
(cond
((eof-object? x)
+ (close-port port)
(compile ((language-joiner joint) (reverse exps) env)
#:from joint #:to to
;; env can be false if no expressions were read.
--
http://wingolog.org/
^ permalink raw reply related [flat|nested] 14+ messages in thread
* Re: Guile build failure
2013-01-21 11:39 ` Andy Wingo
@ 2013-01-22 16:43 ` David Pirotte
0 siblings, 0 replies; 14+ messages in thread
From: David Pirotte @ 2013-01-22 16:43 UTC (permalink / raw
To: Andy Wingo; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 2918 bytes --]
Hi Andy,
> > ‘load.test’ uses ‘compile-file’, and it seems that ‘compile-file’ does
> > an ‘open-input-file’ with no corresponding ‘close-port’. That may be
> > the problem.
>
> Can you try the following patch? ./check-guile load.test on your NFS
> machine should do it.
I did try and it still raise a bug. I had to manually apply the patch[*] and could
have missed a place though: to make sure, here is the compile.scm i used [attached].
note that since the close-port have been added, [1] the remaining trace shows one .nfs* file
- there were two in the trace I sent to Ludovic - and [2] checking manually the directory just
after the trace, it is empty [see below]
Cheers,
David
[*] i did a git pull before and compile.scm changed ... i could only find one
place to add, (close-port in) [in (define (compile-file ...))], it seems you already
added the other (close-port port).
;;
;; trace ...
;;
david@idefix:/usr/local/src/guile/git-clone 61 $ ./check-guile load.test
Testing /usr/local/src/guile/git-clone/meta/guile ... load.test
with GUILE_LOAD_PATH=/usr/local/src/guile/git-clone/test-suite
Running load.test
;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir/dir3" ("." ".."))
;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir/dir2" ("." ".."))
;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir/dir1/subdir1" ("." ".."))
;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir/dir1" ("." ".."))
;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir" ("." ".." ".nfs00000000138c196300000041"))
Backtrace:
In ice-9/boot-9.scm:
157: 12 [catch #t #<catch-closure baf280> ...]
In unknown file:
?: 11 [apply-smob/1 #<catch-closure baf280>]
In ice-9/boot-9.scm:
63: 10 [call-with-prompt prompt0 ...]
In ice-9/eval.scm:
432: 9 [eval # #]
432: 8 [eval # #]
In ice-9/boot-9.scm:
696: 7 [for-each #<procedure cb1f60 at ice-9/eval.scm:416:20 (a)> ("load.test")]
In ice-9/eval.scm:
481: 6 [lp (#<fluid 23>) (("load.test"))]
In ice-9/boot-9.scm:
2131: 5 [save-module-excursion #<procedure f53380 at ice-9/boot-9.scm:3771:3 ()>]
3776: 4 [#<procedure f53380 at ice-9/boot-9.scm:3771:3 ()>]
1456: 3 [%start-stack load-stack #<procedure f579c0 at ice-9/boot-9.scm:3767:10 ()>]
1461: 2 [#<procedure cb1cf0 ()>]
In unknown file:
?: 1 [primitive-load "/usr/local/src/guile/git-clone/test-suite/tests/load.test"]
?: 0 [rmdir "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir"]
ERROR: In procedure rmdir:
ERROR: In procedure rmdir: Directory not empty
david@idefix:/usr/local/src/guile/git-clone 62 $ ls -lsa load-test.dir/
total 8
4 drwxrwxr-x 2 david alto 4096 Jan 22 14:35 ./
4 drwxr-xr-x 21 david alto 4096 Jan 22 14:35 ../
david@idefix:/usr/local/src/guile/git-clone 63 $
[-- Attachment #2: compile.scm --]
[-- Type: text/x-scheme, Size: 9898 bytes --]
;;; High-level compiler interface
;; Copyright (C) 2001, 2009, 2010, 2011, 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
;;; Code:
(define-module (system base compile)
#:use-module (system base syntax)
#:use-module (system base language)
#:use-module (system base message)
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
#:export (compiled-file-name
compile-file
compile-and-load
read-and-compile
compile
decompile))
;;;
;;; Compiler
;;;
(define (call-once thunk)
(let ((entered #f))
(dynamic-wind
(lambda ()
(if entered
(error "thunk may only be entered once: ~a" thunk))
(set! entered #t))
thunk
(lambda () #t))))
;; (put 'call-with-output-file/atomic 'scheme-indent-function 1)
(define* (call-with-output-file/atomic filename proc #:optional reference)
(let* ((template (string-append filename ".XXXXXX"))
(tmp (mkstemp! template)))
(call-once
(lambda ()
(with-throw-handler #t
(lambda ()
(proc tmp)
(chmod tmp (logand #o0666 (lognot (umask))))
(close-port tmp)
(rename-file template filename))
(lambda args
(delete-file template)))))))
(define (ensure-language x)
(if (language? x)
x
(lookup-language x)))
;; Throws an exception if `dir' is not writable. The mkdir occurs
;; before the check, so that we avoid races (possibly due to parallel
;; compilation).
;;
(define (ensure-directory dir)
(catch 'system-error
(lambda ()
(mkdir dir))
(lambda (k subr fmt args rest)
(let ((errno (and (pair? rest) (car rest))))
(cond
((eqv? errno EEXIST)
;; Assume it's a writable directory, to avoid TOCTOU errors,
;; as well as UID/EUID mismatches that occur with access(2).
#t)
((eqv? errno ENOENT)
(ensure-directory (dirname dir))
(ensure-directory dir))
(else
(throw k subr fmt args rest)))))))
;;; This function is among the trickiest I've ever written. I tried many
;;; variants. In the end, simple is best, of course.
;;;
;;; After turning this around a number of times, it seems that the
;;; desired behavior is that .go files should exist in a path, for
;;; searching. That is orthogonal to this function. For writing .go
;;; files, either you know where they should go, in which case you tell
;;; compile-file explicitly, as in the srcdir != builddir case; or you
;;; don't know, in which case this function is called, and we just put
;;; them in your own ccache dir in ~/.cache/guile/ccache.
;;;
;;; See also boot-9.scm:load.
(define (compiled-file-name file)
;; FIXME: would probably be better just to append SHA1(canon-path)
;; to the %compile-fallback-path, to avoid deep directory stats.
(define (canonical->suffix canon)
(cond
((string-prefix? "/" canon) canon)
((and (> (string-length canon) 2)
(eqv? (string-ref canon 1) #\:))
;; Paths like C:... transform to /C...
(string-append "/" (substring canon 0 1) (substring canon 2)))
(else canon)))
(define (compiled-extension)
(cond ((or (null? %load-compiled-extensions)
(string-null? (car %load-compiled-extensions)))
(warn "invalid %load-compiled-extensions"
%load-compiled-extensions)
".go")
(else (car %load-compiled-extensions))))
(and %compile-fallback-path
(let ((f (string-append
%compile-fallback-path
(canonical->suffix (canonicalize-path file))
(compiled-extension))))
(and (false-if-exception (ensure-directory (dirname f)))
f))))
(define* (compile-file file #:key
(output-file #f)
(from (current-language))
(to 'objcode)
(env (default-environment from))
(opts '())
(canonicalization 'relative))
(with-fluids ((%file-port-name-canonicalization canonicalization))
(let* ((comp (or output-file (compiled-file-name file)
(error "failed to create path for auto-compiled file"
file)))
(in (open-input-file file))
(enc (file-encoding in)))
;; Choose the input encoding deterministically.
(set-port-encoding! in (or enc "UTF-8"))
(ensure-directory (dirname comp))
(call-with-output-file/atomic comp
(lambda (port)
((language-printer (ensure-language to))
(read-and-compile in #:env env #:from from #:to to #:opts opts)
port))
file)
(close-port in)
comp)))
(define* (compile-and-load file #:key (from (current-language)) (to 'value)
(env (current-module)) (opts '())
(canonicalization 'relative))
(with-fluids ((%file-port-name-canonicalization canonicalization))
(read-and-compile (open-input-file file)
#:from from #:to to #:opts opts
#:env env)))
\f
;;;
;;; Compiler interface
;;;
(define (compile-passes from to opts)
(map cdr
(or (lookup-compilation-order from to)
(error "no way to compile" from "to" to))))
(define (compile-fold passes exp env opts)
(let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
(if (null? passes)
(values x e cenv)
(receive (x e new-cenv) ((car passes) x e opts)
(lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
(define (find-language-joint from to)
(let lp ((in (reverse (or (lookup-compilation-order from to)
(error "no way to compile" from "to" to))))
(lang to))
(cond ((null? in) to)
((language-joiner lang) lang)
(else
(lp (cdr in) (caar in))))))
(define (default-language-joiner lang)
(lambda (exps env)
(if (and (pair? exps) (null? (cdr exps)))
(car exps)
(error
"Multiple expressions read and compiled, but language has no joiner"
lang))))
(define (read-and-parse lang port cenv)
(let ((exp ((language-reader lang) port cenv)))
(cond
((eof-object? exp) exp)
((language-parser lang) => (lambda (parse) (parse exp)))
(else exp))))
(define* (read-and-compile port #:key
(from (current-language))
(to 'objcode)
(env (default-environment from))
(opts '()))
(let ((from (ensure-language from))
(to (ensure-language to)))
(let ((joint (find-language-joint from to)))
(parameterize ((current-language from))
(let lp ((exps '()) (env #f) (cenv env))
(let ((x (read-and-parse (current-language) port cenv)))
(cond
((eof-object? x)
(close-port port)
(compile ((or (language-joiner joint)
(default-language-joiner joint))
(reverse exps)
env)
#:from joint #:to to
;; env can be false if no expressions were read.
#:env (or env (default-environment joint))
#:opts opts))
(else
;; compile-fold instead of compile so we get the env too
(receive (jexp jenv jcenv)
(compile-fold (compile-passes (current-language) joint opts)
x cenv opts)
(lp (cons jexp exps) jenv jcenv))))))))))
(define* (compile x #:key
(from (current-language))
(to 'value)
(env (default-environment from))
(opts '()))
(let ((warnings (memq #:warnings opts)))
(if (pair? warnings)
(let ((warnings (cadr warnings)))
;; Sanity-check the requested warnings.
(for-each (lambda (w)
(or (lookup-warning-type w)
(warning 'unsupported-warning #f w)))
warnings))))
(receive (exp env cenv)
(compile-fold (compile-passes from to opts) x env opts)
exp))
\f
;;;
;;; Decompiler interface
;;;
(define (decompile-passes from to opts)
(map cdr
(or (lookup-decompilation-order from to)
(error "no way to decompile" from "to" to))))
(define (decompile-fold passes exp env opts)
(if (null? passes)
(values exp env)
(receive (exp env) ((car passes) exp env opts)
(decompile-fold (cdr passes) exp env opts))))
(define* (decompile x #:key
(env #f)
(from 'value)
(to 'assembly)
(opts '()))
(decompile-fold (decompile-passes from to opts)
x
env
opts))
^ permalink raw reply [flat|nested] 14+ messages in thread
end of thread, other threads:[~2013-01-22 16:43 UTC | newest]
Thread overview: 14+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2012-07-09 17:02 GNU Guile 2.0.6 released David Pirotte
2012-07-10 8:18 ` Guile build failure Ludovic Courtès
2012-07-10 15:50 ` David Pirotte
2012-07-11 9:43 ` Ludovic Courtès
2012-07-19 13:59 ` David Pirotte
2012-07-19 16:02 ` Ludovic Courtès
2012-07-19 16:45 ` David Pirotte
2012-07-21 11:15 ` Ludovic Courtès
2012-07-28 15:55 ` David Pirotte
2012-08-09 13:57 ` Ludovic Courtès
2013-01-21 9:26 ` Andy Wingo
2013-01-21 10:47 ` Ludovic Courtès
2013-01-21 11:39 ` Andy Wingo
2013-01-22 16:43 ` David Pirotte
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).