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.

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