From 287e744e9aa96b8eebeb530b68e2854e8ffe5580 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Fri, 6 Jul 2018 23:58:45 +0100
Subject: [PATCH] src/module-{proto,impl}.lisp, etc.: Don't output erroneous
 modules.

Add a new reader `module-errors' which reports the number of errors
found while processing the module.  Notice (but decline to handle)
errors while loading modules.  And, in the front-end, don't try to
output erroneous modules.

This fixes an annoying problem where errors are reported and cause
`make' to fail, and then a subsequent `make' apparently succeeds,
possibly with bogus C code.
---
 doc/SYMBOLS           |  3 +++
 doc/module.tex        |  1 +
 src/frontend.lisp     |  4 +++-
 src/module-impl.lisp  | 16 +++++++++++-----
 src/module-proto.lisp |  4 +++-
 5 files changed, 21 insertions(+), 7 deletions(-)

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 4f13521..944a975 100644
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -588,6 +588,7 @@ module-proto.lisp
   finalize-module                               generic
   module                                        class
   module-dependencies                           generic setf
+  module-errors                                 generic
   module-import                                 generic
   module-items                                  generic setf
   module-name                                   generic
@@ -1323,6 +1324,8 @@ module-dependencies
   module
 (setf module-dependencies)
   t module
+module-errors
+  module
 module-import
   t
   module
diff --git a/doc/module.tex b/doc/module.tex
index 3c62625..802e32b 100644
--- a/doc/module.tex
+++ b/doc/module.tex
@@ -53,6 +53,7 @@
 \begin{describe*}
     {\dhead{gf}{module-name @<module> @> @<pathname>}
      \dhead{gf}{module-pset @<module> @> @<pset>}
+     \dhead{gf}{module-errors @<module> @> @<integer>}
      \dhead{gf}{module-items @<module> @> @<list>}
      \dhead{gf}{module-dependencies @<module> @> @<list>}
      \dhead{gf}{module-state @<module> @> @<keyword>}}
diff --git a/src/frontend.lisp b/src/frontend.lisp
index a4625f7..7648e2d 100644
--- a/src/frontend.lisp
+++ b/src/frontend.lisp
@@ -182,7 +182,9 @@
 
 	       ;; Parse and write out the remaining modules.
 	       (dolist (arg args)
-		 (hack-module (read-module arg)))))
+		 (let ((module (read-module arg)))
+		   (when (zerop (module-errors module))
+		     (hack-module module))))))
 
       (if backtracep (hack-modules)
 	  (multiple-value-bind (hunoz nerror nwarn)
diff --git a/src/module-impl.lisp b/src/module-impl.lisp
index cb3a8ad..4da7804 100644
--- a/src/module-impl.lisp
+++ b/src/module-impl.lisp
@@ -73,9 +73,11 @@
     (let ((existing (gethash truename *module-map*)))
       (cond ((null existing))
 	    ((eq (module-state existing) t)
+	     (when (plusp (module-errors existing))
+	       (error "Module `~A' contains errors" name))
 	     (return-from build-module existing))
 	    (t
-	     (error "Module ~A already being imported at ~A"
+	     (error "Module `~A' already being imported at ~A"
 		    name (module-state existing))))))
 
   ;; Construct the new module.
@@ -101,10 +103,14 @@
   (progv
       (mapcar #'car *module-bindings-alist*)
       (module-variables module)
-    (unwind-protect (funcall thunk)
-      (setf (module-variables module)
-	    (mapcar (compose #'car #'symbol-value)
-		    *module-bindings-alist*)))))
+    (handler-bind ((error (lambda (cond)
+			    (declare (ignore cond))
+			    (incf (slot-value module 'errors))
+			    :decline)))
+      (unwind-protect (funcall thunk)
+	(setf (module-variables module)
+	      (mapcar (compose #'car #'symbol-value)
+		      *module-bindings-alist*))))))
 
 (defun call-with-temporary-module (thunk)
   "Invoke THUNK in the context of a temporary module, returning its values.
diff --git a/src/module-proto.lisp b/src/module-proto.lisp
index a79069a..7e42a5b 100644
--- a/src/module-proto.lisp
+++ b/src/module-proto.lisp
@@ -148,11 +148,13 @@
 ;;;--------------------------------------------------------------------------
 ;;; Module objects.
 
-(export '(module module-name module-pset module-items module-dependencies))
+(export '(module module-name module-pset module-errors
+	  module-items module-dependencies))
 (defclass module ()
   ((name :initarg :name :type pathname :reader module-name)
    (%pset :initarg :pset :initform (make-pset)
 	  :type pset :reader module-pset)
+   (errors :initarg :errors :initform 0 :type fixnum :reader module-errors)
    (items :initarg :items :initform nil :type list :accessor module-items)
    (dependencies :initarg :dependencies :initform nil
 		 :type list :accessor module-dependencies)
-- 
2.11.0