Implemented #error and #warning.

Pascal J. Bourguignon [2015-06-30 15:09]
Implemented #error and #warning.
Filename
languages/cpp/cpp-macro.lisp
languages/cpp/cpp.lisp
languages/cpp/tests/Makefile
languages/cpp/tests/errors.c
languages/cpp/token.lisp
diff --git a/languages/cpp/cpp-macro.lisp b/languages/cpp/cpp-macro.lisp
index 40deeb2..0993ee7 100644
--- a/languages/cpp/cpp-macro.lisp
+++ b/languages/cpp/cpp-macro.lisp
@@ -209,6 +209,7 @@
 (defun macro-bind (name parameters arguments)
   (loop
     :with bindings := '()
+    :with no-parameters = (null parameters)
     :while parameters
     :do (let ((par (pop parameters)))
           (cond
@@ -221,7 +222,10 @@
             (t
              (let ((arg (pop arguments)))
                (push (cons par arg) bindings)))))
-    :finally (when arguments
+    :finally (when (and arguments
+                        (not (and no-parameters
+                                  (null (cdr arguments))
+                                  (null (car arguments)))))
                (cpp-error *context* "Too many arguments for function-like macro call ~S" (token-text name))
                (return :error))
              (return bindings)))
diff --git a/languages/cpp/cpp.lisp b/languages/cpp/cpp.lisp
index 339b5d9..1255cdc 100644
--- a/languages/cpp/cpp.lisp
+++ b/languages/cpp/cpp.lisp
@@ -606,28 +606,35 @@ RETURN: the token text; the end position."
            (lino (token-line (first line))))
        (pop line)
        (let ((parameters (loop
-                           :collect (let ((parameter (pop line)))
-                                      (cond
-                                        ((identifierp parameter)
-                                         (if (and line (ellipsisp (first line)))
-                                             (progn
+                           :with result := '()
+                           :for parameter := (first line)
+                           :unless (closep parameter)
+                             :do (let ((par (cond
+                                              ((identifierp parameter)
+                                               (pop line)
+                                               (if (and line (ellipsisp (first line)))
+                                                   (progn
+                                                     (pop line)
+                                                     (unless (and line (closep (first line)))
+                                                       (cpp-error parameter "ellipsis should be the last macro parameter"))
+                                                     (list :ellipsis parameter))
+                                                   (progn
+                                                     (unless (and line (or (commap (first line)) (closep (first line))))
+                                                       (cpp-error "Missing a comma after parameter ~A"  (token-text parameter)))
+                                                     parameter)))
+                                              ((ellipsisp parameter)
                                                (pop line)
                                                (unless (and line (closep (first line)))
                                                  (cpp-error parameter "ellipsis should be the last macro parameter"))
-                                               (list :ellipsis parameter))
-                                             (progn
-                                               (unless (and line (or (commap (first line)) (closep (first line))))
-                                                 (cpp-error "Missing a comma after parameter ~A"  (token-text parameter)))
-                                               parameter)))
-                                        ((ellipsisp parameter)
-                                         (unless (and line (closep (first line)))
-                                           (cpp-error parameter "ellipsis should be the last macro parameter"))
-                                         (list :ellipsis (make-identifier "__VA_ARGS__" 0 0 "-")))
-                                        (t
-                                         (cpp-error parameter "Expected a macro parameter name, not ~S" (token-text parameter))
-                                         parameter)))
+                                               (list :ellipsis (make-identifier "__VA_ARGS__" 0 0 "-")))
+                                              (t
+                                               (cpp-error parameter "Expected a macro parameter name, not ~S" (token-text parameter))
+                                               (unless (commap parameter)
+                                                 (pop line))
+                                               nil))))
+                                   (when par (push par result)))
                            :while (and line (commap (first line)))
-                           :do (pop line)
+                           :do (pop line) ; comma
                            :finally (if (and line (closep (first line)))
                                         (pop line)
                                         (cpp-error (pseudo-token file lino) "Expected a closing parentheses after the parameter list")))))
@@ -844,21 +851,41 @@ RETURN: the token text; the end position."
 ;;; --------------------

 (defun pragma (line environment)
-  )
+  (with-cpp-line line
+    (if line
+
+        (cpp-error (pseudo-token file lino) "Missing a pragma expression after #~(~A~)" "pragma"))))
+
+
+;; #pragma GCC dependency path &rest and-stuff
+;; #pragma GCC poison &rest identifiers
+;; #pragma GCC system_header
+;; #pragma GCC warning message
+;; #pragma GCC error message
+;; // message must be a single string literal.
+
+

 ;;; --------------------
 ;;; #error
 ;;; --------------------

 (defun cpp-error-line (line environment)
-  )
+  (cpp-message 'cpp-error line environment))

 ;;; --------------------
 ;;; #warning
 ;;; --------------------

 (defun cpp-warning-line (line environment)
-  )
+  (cpp-message 'cpp-warning line environment))
+
+(defun cpp-message (operation line environment)
+  (let ((directive (second line)))
+    (with-cpp-line line
+      (if line
+          (funcall operation directive "~{~A~^ ~}" (mapcar (function token-text) line))
+          (cpp-error directive "Missing an expression after #~(~A~)" directive)))))

 ;;; --------------------
 ;;; pre-processing files
@@ -866,7 +893,6 @@ RETURN: the token text; the end position."

 #|

-
 object-like macros
 ------------------

@@ -1238,14 +1264,25 @@ RETURN:          the C-pre-processed source in form of list of list of tokens
                          (setf file (token-file (first line)))))
              (format t "~{~A~^ ~}~%" (mapcar (function token-text) line))))))

+(defmacro with-cpp-error-logging (&body body)
+  `(handler-bind ((cpp-error (lambda (condition)
+                              (princ condition *error-output*) (terpri *error-output*)
+                              (let ((restart (find-restart 'continue condition)))
+                                (when restart (invoke-restart restart)))))
+                 (cpp-warning (lambda (condition)
+                                (princ condition *error-output*) (terpri *error-output*)
+                                (let ((restart (find-restart 'muffle-warning condition)))
+                                  (when restart (invoke-restart restart))))))
+    ,@body))

 (defun cpp-e (path &optional includes)
-  (multiple-value-bind (lines context)
-      (process-toplevel-file path :options (acons :include-quote-directories includes *default-options*))
-    (terpri)
-    (write-processed-lines lines)
-    ;; (print-hashtable (context-environment context))
-    context))
+  (with-cpp-error-logging
+    (multiple-value-bind (lines context)
+        (process-toplevel-file path :options (acons :include-quote-directories includes *default-options*))
+      (terpri)
+      (write-processed-lines lines)
+      ;; (print-hashtable (context-environment context))
+      context)))

 ;;; --------------------

@@ -1261,6 +1298,7 @@ RETURN:          the C-pre-processed source in form of list of list of tokens
           (cpp-e "tests/stringify.c" '("tests/"))
           (cpp-e "tests/substitute.c" '("tests/"))
           (cpp-e "tests/trigraphs.c" '("tests/"))
+          (cpp-e "tests/errors.c" '("tests/"))


           ;; bugged
diff --git a/languages/cpp/tests/Makefile b/languages/cpp/tests/Makefile
index 1d0ffe0..50ba22c 100644
--- a/languages/cpp/tests/Makefile
+++ b/languages/cpp/tests/Makefile
@@ -23,3 +23,6 @@ test:
 	gcc -E -o - test.c
 trigraphs:
 	gcc -E -o - -trigraphs trigraphs.c
+errors:
+	gcc -E -o - errors.c
+
diff --git a/languages/cpp/tests/errors.c b/languages/cpp/tests/errors.c
new file mode 100644
index 0000000..527e263
--- /dev/null
+++ b/languages/cpp/tests/errors.c
@@ -0,0 +1,11 @@
+#define PROC this-proc
+#warning "I warn you, in " PROC ", it won't be pretty."
+#error "I told you, there's a snafu in " PROC
+#pragma GCC warning "I warn you,  it won't be pretty."
+#pragma GCC error "I told you, there's a snafu"
+#define W() _Pragma("GCC warning \"I warn you, it won't be pretty.\"")
+#define E() _Pragma("GCC error \"I told you, there's a snafu\"")
+W()
+E()
+
+
diff --git a/languages/cpp/token.lisp b/languages/cpp/token.lisp
index 9f64d11..008e266 100644
--- a/languages/cpp/token.lisp
+++ b/languages/cpp/token.lisp
@@ -150,6 +150,11 @@
   (typep token 'number-token))


+(define-condition cpp-error (simple-error)
+  ())
+
+(define-condition cpp-warning (simple-warning)
+  ())

 (defun cpp-error (token format-control &rest format-arguments)
   (let ((*context* (if (typep token 'context)
@@ -158,10 +163,11 @@
                                         :line (token-line token)
                                         :column (token-column token)
                                         :file (token-file token)))))
-    (cerror "Continue" "~A:~A: ~?"
-            (context-file *context*)
-            (context-line *context*)
-            format-control format-arguments)))
+    (cerror "Continue" 'cpp-error
+            :format-control "~A:~A: error: ~?"
+            :format-arguments (list (context-file *context*)
+                                    (context-line *context*)
+                                    format-control format-arguments))))

 (defun cpp-warning (token format-control &rest format-arguments)
   (let ((*context* (if (typep token 'context)
@@ -170,10 +176,11 @@
                                         :line (token-line token)
                                         :column (token-column token)
                                         :file (token-file token)))))
-    (warn "~A:~A: ~?"
-          (context-file *context*)
-          (context-line *context*)
-          format-control format-arguments)))
+    (warn 'cpp-warning
+          :format-control "~A:~A: warning: ~?"
+          :format-arguments (list (context-file *context*)
+                                  (context-line *context*)
+                                  format-control format-arguments))))


ViewGit