aboutsummaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-08-30 14:18:34 +0200
committerLudovic Courtès <ludo@gnu.org>2013-08-30 14:18:51 +0200
commitffc1074f86be782035a2162c60515c0a9db999ca (patch)
tree0c2bc348504b9f5bddc40ccfcc036a7f9a0a5157 /gnu
parent46cb9da28597039a7d158ce4b8e0bcacf7700fe3 (diff)
downloadguix-ffc1074f86be782035a2162c60515c0a9db999ca.tar
guix-ffc1074f86be782035a2162c60515c0a9db999ca.tar.gz
gnu: hop: Allow compilation with Bigloo 4.0b.
Fixes <http://bugs.gnu.org/15194>. Reported by Mark H Weaver <mhw@netris.org>. * gnu/packages/patches/hop-bigloo-4.0b.patch: New file. * gnu-system.am (dist_patch_DATA): Add it. * gnu/packages/scheme.scm (hop): Use it.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/packages/patches/hop-bigloo-4.0b.patch122
-rw-r--r--gnu/packages/scheme.scm6
2 files changed, 127 insertions, 1 deletions
diff --git a/gnu/packages/patches/hop-bigloo-4.0b.patch b/gnu/packages/patches/hop-bigloo-4.0b.patch
new file mode 100644
index 0000000000..312bfdd117
--- /dev/null
+++ b/gnu/packages/patches/hop-bigloo-4.0b.patch
@@ -0,0 +1,122 @@
+Bigloo 4.0b removes `xml-attribute-encode', which leads to a build failure
+in Hop.
+
+This patch allows Hop to be compiled with Bigloo 4.0b.
+
+
+changeset: 3327:3515f7f1aef2
+branch: 2.4.x
+user: Manuel Serrano <Manuel.Serrano@inria.fr>
+date: Wed Jul 31 12:41:10 2013 +0200
+summary: Fix serialization bug
+
+diff -r 7244c4d30ad4 -r 3515f7f1aef2 runtime/js_comp.scm
+--- a/runtime/js_comp.scm Fri Jul 19 08:28:13 2013 +0200
++++ b/runtime/js_comp.scm Wed Jul 31 12:41:10 2013 +0200
+@@ -143,10 +143,17 @@
+ (display "{ " op)
+ (display-seq fields op
+ (lambda (f op)
++ (let ((iv (class-field-info f)))
+ (display "'" op)
+ (display (class-field-name f) op)
+ (display "': " op)
+- (compile ((class-field-accessor f) obj) op)))
++ (cond
++ ((and (pair? iv) (memq :client iv))
++ =>
++ (lambda (x)
++ (compile (when (pair? (cdr x)) (cadr x)) op)))
++ (else
++ (compile ((class-field-accessor f) obj) op))))))
+ (display "}" op))
+
+ (let ((klass (object-class obj)))
+diff -r 7244c4d30ad4 -r 3515f7f1aef2 runtime/xml.scm
+--- a/runtime/xml.scm Fri Jul 19 08:28:13 2013 +0200
++++ b/runtime/xml.scm Wed Jul 31 12:41:10 2013 +0200
+@@ -55,6 +55,7 @@
+ (generic xml-write-attribute ::obj ::obj ::output-port ::xml-backend)
+ (generic xml-write-expression ::obj ::output-port)
+ (xml-write-attributes ::pair-nil ::output-port ::xml-backend)
++ (xml-attribute-encode obj)
+
+ (xml->string ::obj ::xml-backend)
+
+@@ -613,6 +614,52 @@
+ (display ">" p))))
+
+ ;*---------------------------------------------------------------------*/
++;* xml-attribute-encode ... */
++;*---------------------------------------------------------------------*/
++(define (xml-attribute-encode obj)
++ (if (not (string? obj))
++ obj
++ (let ((ol (string-length obj)))
++ (define (count str ol)
++ (let loop ((i 0)
++ (j 0))
++ (if (=fx i ol)
++ j
++ (let ((c (string-ref str i)))
++ ;; attribute values should escape &#...
++ (if (or (char=? c #\') (char=? c #\&))
++ (loop (+fx i 1) (+fx j 5))
++ (loop (+fx i 1) (+fx j 1)))))))
++ (define (encode str ol nl)
++ (if (=fx nl ol)
++ obj
++ (let ((nstr (make-string nl)))
++ (let loop ((i 0)
++ (j 0))
++ (if (=fx j nl)
++ nstr
++ (let ((c (string-ref str i)))
++ (case c
++ ((#\')
++ (string-set! nstr j #\&)
++ (string-set! nstr (+fx j 1) #\#)
++ (string-set! nstr (+fx j 2) #\3)
++ (string-set! nstr (+fx j 3) #\9)
++ (string-set! nstr (+fx j 4) #\;)
++ (loop (+fx i 1) (+fx j 5)))
++ ((#\&)
++ (string-set! nstr j #\&)
++ (string-set! nstr (+fx j 1) #\#)
++ (string-set! nstr (+fx j 2) #\3)
++ (string-set! nstr (+fx j 3) #\8)
++ (string-set! nstr (+fx j 4) #\;)
++ (loop (+fx i 1) (+fx j 5)))
++ (else
++ (string-set! nstr j c)
++ (loop (+fx i 1) (+fx j 1))))))))))
++ (encode obj ol (count obj ol)))))
++
++;*---------------------------------------------------------------------*/
+ ;* xml-write-attributes ... */
+ ;*---------------------------------------------------------------------*/
+ (define (xml-write-attributes attr p backend)
+diff -r 7244c4d30ad4 -r 3515f7f1aef2 share/hop-serialize.js
+--- a/share/hop-serialize.js Fri Jul 19 08:28:13 2013 +0200
++++ b/share/hop-serialize.js Wed Jul 31 12:41:10 2013 +0200
+@@ -942,7 +942,7 @@
+ case 0x2e /* . */: return null;
+ case 0x3c /* < */: return read_cnst();
+ case 0x22 /* " */: return read_string( s );
+- case 0x25 /* " */: return decodeURIComponent( read_string( s ) );
++ case 0x25 /* % */: return decodeURIComponent( read_string( s ) );
+ case 0x55 /* U */: return read_string( s );
+ case 0x5b /* [ */: return read_vector( read_size( s ) );
+ case 0x28 /* ( */: return read_list( read_size( s ) );
+diff -r 7244c4d30ad4 -r 3515f7f1aef2 src/main.scm
+--- a/src/main.scm Fri Jul 19 08:28:13 2013 +0200
++++ b/src/main.scm Wed Jul 31 12:41:10 2013 +0200
+@@ -59,8 +59,6 @@
+ (for-each register-srfi! (cons 'hop-server (hop-srfis)))
+ ;; set the library load path
+ (bigloo-library-path-set! (hop-library-path))
+- ;; define the Hop macros
+- (hop-install-expanders!)
+ ;; setup the hop readers
+ (bigloo-load-reader-set! hop-read)
+ (bigloo-load-module-set!
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index eb339d7236..43853fa08c 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -251,6 +251,7 @@ between Scheme and C# programs.")
"\\.so$")))))
%standard-phases))
#:tests? #f ; no test suite
+ #:patches (list (assoc-ref %build-inputs "patch/bigloo-4.0b"))
#:modules ((guix build gnu-build-system)
(guix build utils)
(ice-9 popen)
@@ -259,7 +260,10 @@ between Scheme and C# programs.")
(srfi srfi-1))))
(inputs `(("bigloo" ,bigloo)
("which" ,which)
- ("patchelf" ,patchelf)))
+ ("patchelf" ,patchelf)
+
+ ("patch/bigloo-4.0b"
+ ,(search-patch "hop-bigloo-4.0b.patch"))))
(home-page "http://hop.inria.fr/")
(synopsis "A multi-tier programming language for the Web 2.0")
(description