02/03: read-print: Report missing closing parens instead of looping.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit ebda12e1d2c64480bb7d5977e580d8b2eabeb503
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Aug 10 16:37:34 2022 +0200

    read-print: Report missing closing parens instead of looping.
    
    Fixes <https://issues.guix.gnu.org/57093>.
    Reported by Mohammed AMAR-BENSABER <renken@shione.net>.
    
    Previously 'read-with-comments' would enter an infinite loop.
    
    * guix/read-print.scm (read-with-comments)[missing-closing-paren-error]:
    New procedure.
    Call it when 'loop' as called from 'liip' returns EOF.
    * tests/read-print.scm ("read-with-comments: missing closing paren"):
    New test.
---
 guix/read-print.scm  | 33 +++++++++++++++++++++++++++------
 tests/read-print.scm |  7 +++++++
 2 files changed, 34 insertions(+), 6 deletions(-)

diff --git a/guix/read-print.scm b/guix/read-print.scm
index 9d666d7f70..08e219e204 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -24,6 +24,11 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (guix i18n)
+  #:use-module ((guix diagnostics)
+                #:select (formatted-message
+                          &fix-hint &error-location
+                          location))
   #:export (pretty-print-with-comments
             pretty-print-with-comments/splice
             read-with-comments
@@ -158,6 +163,19 @@ BLANK-LINE? is true, assume PORT is at the beginning of a 
new line."
   (define dot (list 'dot))
   (define (dot? x) (eq? x dot))
 
+  (define (missing-closing-paren-error)
+    (raise (make-compound-condition
+            (formatted-message (G_ "unexpected end of file"))
+            (condition
+             (&error-location
+              (location (match (port-filename port)
+                          (#f #f)
+                          (file (location file
+                                          (port-line port)
+                                          (port-column port))))))
+             (&fix-hint
+              (hint (G_ "Did you forget a closing parenthesis?")))))))
+
   (define (reverse/dot lst)
     ;; Reverse LST and make it an improper list if it contains DOT.
     (let loop ((result '())
@@ -190,12 +208,15 @@ BLANK-LINE? is true, assume PORT is at the beginning of a 
new line."
              ((memv chr '(#\( #\[))
               (let/ec return
                 (let liip ((lst '()))
-                  (liip (cons (loop (match lst
-                                      (((? blank?) . _) #t)
-                                      (_ #f))
-                                    (lambda ()
-                                      (return (reverse/dot lst))))
-                              lst)))))
+                  (define item
+                    (loop (match lst
+                            (((? blank?) . _) #t)
+                            (_ #f))
+                          (lambda ()
+                            (return (reverse/dot lst)))))
+                  (if (eof-object? item)
+                      (missing-closing-paren-error)
+                      (liip (cons item lst))))))
              ((memv chr '(#\) #\]))
               (return))
              ((eq? chr #\')
diff --git a/tests/read-print.scm b/tests/read-print.scm
index b484e28022..4dabcc1e64 100644
--- a/tests/read-print.scm
+++ b/tests/read-print.scm
@@ -19,6 +19,8 @@
 (define-module (tests-style)
   #:use-module (guix read-print)
   #:use-module (guix gexp)                        ;for the reader extensions
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
@@ -46,6 +48,11 @@ expressions."
 
 (test-begin "read-print")
 
+(test-assert "read-with-comments: missing closing paren"
+  (guard (c ((error? c) #t))
+    (call-with-input-string "(what is going on?"
+      read-with-comments)))
+
 (test-equal "read-with-comments: dot notation"
   (cons 'a 'b)
   (call-with-input-string "(a . b)"