From 869c137fd84eddf71b074898ff7210cddc35a877 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès
Date: Fri, 30 Mar 2018 15:34:38 +0200
Subject: Do not mutate lists that may be literal.

On Guile 2.2 this would lead to a segmentation fault or a 'set-car!'
error ("expecting mutable pair") on 2.2.3+.

* src/guile/skribilo/engine.scm (engine-custom-set!): Do not mutate
CUSTOMS.
* src/guile/skribilo/resolve.scm (do-resolve! <pair>): Do not mutate AST.
(do-resolve! <node>): Do not mutate OPTIONS.
(do-resolve! <document>): Do not mutate the list of customs.
---
 src/guile/skribilo/engine.scm  | 10 ++++----
 src/guile/skribilo/resolve.scm | 52 +++++++++++++++++++-----------------------
 2 files changed, 29 insertions(+), 33 deletions(-)

(limited to 'src')

diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm
index fb1bcb2..5f82044 100644
--- a/src/guile/skribilo/engine.scm
+++ b/src/guile/skribilo/engine.scm
@@ -29,6 +29,7 @@
   :use-module (ice-9 optargs)
   :use-module (ice-9 format)
 
+  :use-module (srfi srfi-1)
   :autoload   (srfi srfi-34)  (raise guard)
   :use-module (srfi srfi-35)
   :autoload   (srfi srfi-39)  (make-parameter)
@@ -350,11 +351,10 @@ otherwise the requested engine is returned."
 
 
 (define (engine-custom-set! e id val)
-  (let* ((customs (slot-ref e 'customs))
-	 (c       (assq id customs)))
-    (if (pair? c)
-	(set-car! (cdr c) val)
-	(slot-set! e 'customs (cons (list id val) customs)))))
+  (let ((customs (slot-ref e 'customs)))
+    (slot-set! e 'customs
+               (cons (list id val)
+                     (alist-delete id customs eq?)))))
 
 (define (engine-custom-add! e id val)
    (let ((old (engine-custom e id)))
diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm
index 2ef49b1..7058d90 100644
--- a/src/guile/skribilo/resolve.scm
+++ b/src/guile/skribilo/resolve.scm
@@ -1,6 +1,6 @@
 ;;; resolve.scm  --  Skribilo reference resolution.
 ;;;
-;;; Copyright 2005, 2006, 2008, 2009  Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2005, 2006, 2008, 2009, 2018  Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright 2003, 2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 ;;;
 ;;;
@@ -30,6 +30,7 @@
   :use-module (skribilo condition)
   :use-module (srfi srfi-34)
   :use-module (srfi srfi-35)
+  :use-module (ice-9 match)
 
   :export (resolve! resolve-search-parent
 	   resolve-counter resolve-parent resolve-ident
@@ -91,21 +92,14 @@
 
 
 (define-method (do-resolve! (ast <pair>) engine env)
-  (let Loop ((n* ast))
-    (cond
-      ((null? n*)
-       ast)
-      ((list? n*)
-       (set-car! n* (do-resolve! (car n*) engine env))
-       (Loop (cdr n*)))
-      ((pair? n*)
-       (set-car! n* (do-resolve! (car n*) engine env))
-       (set-cdr! n* (do-resolve! (cdr n*) engine env))
-       n*)
-      (else
-       (raise (condition (&invalid-argument-error
-			  (proc-name "do-resolve!<pair>")
-			  (argument n*))))))))
+  (match ast
+    ((? list?)                                    ;proper list
+     (map (lambda (elt)
+            (do-resolve! elt engine env))
+          ast))
+    ((head . tail)                                ;pair or improper list
+     (cons (do-resolve! head engine env)
+           (do-resolve! tail engine env)))))
 
 
 (define-method (do-resolve! (node <node>) engine env)
@@ -125,11 +119,13 @@
 
              (when (pair? options)
                (debug-item "unresolved options=" options)
-               (for-each (lambda (o)
-                           (set-car! (cdr o)
-                                     (do-resolve! (cadr o) engine env)))
-                         options)
-               (debug-item "resolved options=" options))
+               (let ((resolved (map (match-lambda
+                                      ((option value)
+                                       (list option
+                                             (do-resolve! value engine env))))
+                                    options)))
+                 (slot-set! node 'options resolved)
+                 (debug-item "resolved options=" options)))
 
 	     (slot-set! node 'body (do-resolve! body engine env))
 	     (slot-set! node 'resolved? (not (*unresolved*))))
@@ -182,13 +178,13 @@
   (parameterize ((*document-being-resolved* node))
     (next-method)
     ;; resolve the engine custom
-    (let ((env (append `((parent ,node)) env0)))
-      (for-each (lambda (c)
-		  (let ((i (car c))
-			(a (cadr c)))
-		    (debug-item "custom=" i " " a)
-		    (set-car! (cdr c) (do-resolve! a engine env))))
-		(slot-ref engine 'customs)))
+    (let* ((env (append `((parent ,node)) env0))
+           (resolved (map (match-lambda
+                            ((i a)
+                             (debug-item "custom=" i " " a)
+                             (list i (do-resolve! a engine env))))
+                          (slot-ref engine 'customs))))
+      (slot-set! engine 'customs resolved))
     node))
 
 
-- 
cgit v1.2.3