Corrected processing of directive in function-line macro arguments; implemented cpp-line.

Pascal J. Bourguignon [2015-07-02 02:24]
Corrected processing of directive in function-line macro arguments; implemented cpp-line.
Filename
languages/cpp/cpp-macro.lisp
languages/cpp/cpp.lisp
languages/cpp/expression.lisp
languages/cpp/packages.lisp
languages/cpp/tests/Makefile
languages/cpp/tests/data.h
languages/cpp/tests/if-embedded.c
languages/cpp/tests/recursive.c
languages/cpp/tests/test.c
diff --git a/languages/cpp/cpp-macro.lisp b/languages/cpp/cpp-macro.lisp
index f5a2ae2..55c4c1c 100644
--- a/languages/cpp/cpp-macro.lisp
+++ b/languages/cpp/cpp-macro.lisp
@@ -430,7 +430,15 @@ concatenation
                    (cpp-error *context* "Reached end of file in function-like macro call ~A"
                               (token-text ,macro-name-token-var))
                    (return-from ,block-name nil))
-                 (setf ,line-var (pop ,tokenized-lines-var)))))
+                 (progn
+                   (setf (context-input-lines *context*)  ,tokenized-lines-var)
+                   (unwind-protect
+                        (loop
+                          :do (setf (context-current-line *context*)  (pop (context-input-lines *context*)))
+                          :while (sharpp (first (context-current-line *context*)))
+                          :do (process-directive *context* (context-current-line *context*)))
+                     (setf ,line-var (context-current-line *context*)
+                           ,tokenized-lines-var  (context-input-lines *context*)))))))

 (defun macro-bindings-expand-arguments (bindings)
   (flet ((marg (tokens)
@@ -582,6 +590,9 @@ concatenation

            :warn-on-undefined-identifier
            ;; in #if expressions warns about undefined identifiers
+
+           :generate-sharp-line
+           ;; #line generates '# NN "file"' token lines.

            :include-disable-current-directory
            ;; When true, files are not searched in the current directory.
@@ -619,7 +630,8 @@ concatenation
     (:include-quote-directories . ())
     (:include-bracket-directories . ())
     (:include-search-functions . ())
-    (:external-format . :default)))
+    (:external-format . :default)
+    (:generate-sharp-line . nil)))

 (defvar *default-environment*         (make-environment))
 (defvar *default-pragma-interpreters* (make-hash-table :test 'equal))
diff --git a/languages/cpp/cpp.lisp b/languages/cpp/cpp.lisp
index 2bb481a..605edab 100644
--- a/languages/cpp/cpp.lisp
+++ b/languages/cpp/cpp.lisp
@@ -1009,13 +1009,41 @@ RETURN: the token text; the end position."
            (skip-branch-and-process context))
     (decf (context-if-level context))))

-
 ;;; --------------------
 ;;; #line
 ;;; --------------------

 (defmethod cpp-line ((context context))
-  ;; TODO:
+  (with-cpp-line (context-current-line context)
+    (labels ((generate (n file)
+               (let ((f (string-value file)))
+                 (when (option context :generate-sharp-line)
+                   (push (list (make-punctuation "#" 1 lino f)
+                               (make-number (prin1-to-string n) 3 lino f)
+                               file)
+                         (context-output-lines context)))
+                 (loop
+                  :for line :in (context-input-lines context)
+                  :do (loop :for token :in line
+                            :do (setf (token-line token) n
+                                      (token-file token) f))
+                      (incf n))))
+             (process-line (line)
+               (cond
+                 ((null line)
+                  (cpp-error context "Missing arguments after #line"))
+                 ((and line (null (cdr line))
+                       (number-token-p (first line)))
+                  ;; #line N
+                  (generate (integer-value (first line)) (make-string-literal (format nil "~S" file) 10 lino file)))
+                 ((and line (null (cddr line))
+                       (number-token-p (first line))
+                       (string-literal-p (second line)))
+                  ;; #line N "file"
+                  (generate (integer-value (first line))  (second line)))
+                 (t
+                  (process-line (first (macro-expand-macros context line '() '() nil '())))))))
+      (process-line (context-current-line context))))
   context)

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

-
 (defmethod cpp-macro-expand ((context context))
   (multiple-value-bind (output input) (macro-expand-macros context
                                                            (context-current-line context)
@@ -1071,6 +1098,36 @@ RETURN: the token text; the end position."
           (context-input-lines context) input)
     context))

+(defmethod process-directive ((context context) line)
+  (cond
+    ((identifierp (second line))
+     (scase (token-text (second line))
+       (("define")  (define  context))
+       (("undef")   (undef   context))
+       (("include") (include context))
+       (("import")  (import  context))
+       (("ifdef")   (ifdef   context))
+       (("ifndef")  (ifndef  context))
+       (("if")      (cpp-if  context))
+       (("elif" "else" "endif")
+        (if (plusp (context-if-level context))
+            (return-from process-directive nil)
+            (cpp-error (second line) "#~A without #if" (token-text (second line))))
+        (uiop/image:print-backtrace))
+       (("line")    (cpp-line         context))
+       (("pragma")  (pragma           context))
+       (("error")   (cpp-error-line   context))
+       (("warning") (cpp-warning-line context))
+       (("ident" "sccs"))
+       (otherwise (cpp-error line "invalid directive ~A" (token-text (second line))))))
+    ((number-token-p (second line)) ;; skip # 1 "file"
+     (push line (context-output-lines context)))
+    ((rest line)
+     (cpp-error line "invalid directive #~A" (token-text (second line))))
+    (t ;; skip # alone.
+     ))
+  t)
+
 (defmethod process-file ((context context))
   "Processes all the INPUT-LINES, pushing onto the OUTPUT-LINES."
   (loop
@@ -1079,33 +1136,8 @@ RETURN: the token text; the end position."
           (setf (context-current-line context) line)
           ;;DEBUG;; (print line)
           (if (sharpp (first line))
-              (cond
-                ((identifierp (second line))
-                 (scase (token-text (second line))
-                   (("define")  (define  context))
-                   (("undef")   (undef   context))
-                   (("include") (include context))
-                   (("import")  (import  context))
-                   (("ifdef")   (ifdef   context))
-                   (("ifndef")  (ifndef  context))
-                   (("if")      (cpp-if  context))
-                   (("elif" "else" "endif")
-                    (if (plusp (context-if-level context))
-                        (return)
-                        (cpp-error (second line) "#~A without #if" (token-text (second line))))
-                    (uiop/image:print-backtrace))
-                   (("line")    (cpp-line context))
-                   (("pragma")  (pragma           context))
-                   (("error")   (cpp-error-line   context))
-                   (("warning") (cpp-warning-line context))
-                   (("ident" "sccs"))
-                   (otherwise (cpp-error line "invalid directive ~A" (token-text (second line))))))
-                ((number-token-p (second line)) ;; skip # 1 "file"
-                 (push line (context-output-lines context)))
-                ((rest line)
-                 (cpp-error line "invalid directive #~A" (token-text (second line))))
-                (t ;; skip # alone.
-                 ))
+              (unless (process-directive context line)
+                (return))
               (cpp-macro-expand context)))
     :finally (setf (context-current-line context) nil))
   context)
@@ -1129,21 +1161,24 @@ RETURN: the token text; the end position."
     (read-and-process-file *context* path)
     (values (reverse (context-output-lines *context*)) *context*)))

-(defun write-processed-lines (lines &optional (*standard-output* *standard-output*))
+(defun write-processed-lines (lines &key (stream *standard-output*)
+                                      write-sharp-line)
   (when lines
-    (let ((*print-circle* nil))
+    (let ((*print-circle* nil)
+          (*standard-output* stream))
      (loop
        :with file := nil
        :with lino := nil
        :for line :in lines
        :when line
-         :do (if (and (equal file (token-file (first line)))
-                      lino
-                      (= (1+ lino) (token-line (first line))))
-                 (incf lino)
-                 (format t "#line ~D ~S~%"
-                         (setf lino (token-line (first line)))
-                         (setf file (token-file (first line)))))
+         :do (when write-sharp-line
+               (if (and (equal file (token-file (first line)))
+                        lino
+                        (= (1+ lino) (token-line (first line))))
+                   (incf lino)
+                   (format t "#line ~D ~S~%"
+                           (setf lino (token-line (first line)))
+                           (setf file (token-file (first line))))))
              (format t "~{~A~^ ~}~%" (mapcar (function token-text) line))))))

 (defmacro with-cpp-error-logging (&body body)
@@ -1157,12 +1192,13 @@ RETURN: the token text; the end position."
                                   (when restart (invoke-restart restart))))))
     ,@body))

-(defun cpp-e (path &optional includes)
+(defun cpp-e (path &rest options &key includes write-sharp-line &allow-other-keys)
   (with-cpp-error-logging
     (multiple-value-bind (lines context)
-        (process-toplevel-file path :options (acons :include-quote-directories includes *default-options*))
+        (process-toplevel-file path :options (append (plist-alist options)
+                                                     (acons :include-quote-directories includes *default-options*)))
       (terpri)
-      (write-processed-lines lines)
+      (write-processed-lines lines :write-sharp-line write-sharp-line)
       ;; (print-hashtable (context-environment context))
       context)))

@@ -1170,23 +1206,22 @@ RETURN: the token text; the end position."

 #-(and) (progn

-          (cpp-e "tests/test.c" '("tests/"))
-          (cpp-e "tests/variadic.c" '("tests/"))
-          (cpp-e "tests/built-ins.c" '("tests/"))
-          (cpp-e "tests/comment.c" '("tests/"))
-          (cpp-e "tests/concat.c" '("tests/"))
-          (cpp-e "tests/interface.c" '("tests/"))
-          (cpp-e "tests/shadow.c" '("tests/"))
-          (cpp-e "tests/stringify.c" '("tests/"))
-          (cpp-e "tests/substitute.c" '("tests/"))
-          (cpp-e "tests/trigraphs.c" '("tests/"))
-          (cpp-e "tests/errors.c" '("tests/"))
-          (cpp-e "tests/empty-macro.c" '("tests/"))
-          (cpp-e "tests/if.c" '("tests/"))
-          (cpp-e "tests/ifdef.c" '("tests/"))
-
-          ;; bugged
-          (cpp-e "tests/recursive.c" '("tests/"))
+          (cpp-e "tests/test.c"          :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/variadic.c"      :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/built-ins.c"     :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/comment.c"       :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/concat.c"        :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/interface.c"     :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/shadow.c"        :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/stringify.c"     :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/substitute.c"    :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/trigraphs.c"     :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/errors.c"        :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/empty-macro.c"   :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/if.c"            :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/ifdef.c"         :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/recursive.c"     :includes '("tests/") :write-sharp-line t)
+          (cpp-e "tests/if-embedded.c"   :includes '("tests/") :write-sharp-line t)


           (let ((file "tests/define.h"))
diff --git a/languages/cpp/expression.lisp b/languages/cpp/expression.lisp
index 769f8f2..a80c1f4 100644
--- a/languages/cpp/expression.lisp
+++ b/languages/cpp/expression.lisp
@@ -71,6 +71,10 @@
         (setf character-string #(#\nul))))
     (char-code (aref character-string 0))))

+(defun string-value (string-token)
+  (with-input-from-string (in (token-text string-token) :start 1)
+    (read-c-string in #\")))
+
 (defmacro with-binary-op-parsers ((&rest definitions) (&rest functions) &body body)
   `(labels (,@(mapcar (lambda (definition)
                         (destructuring-bind (name subexpr &rest ops) definition
diff --git a/languages/cpp/packages.lisp b/languages/cpp/packages.lisp
index 4e9ca2b..873cd13 100644
--- a/languages/cpp/packages.lisp
+++ b/languages/cpp/packages.lisp
@@ -42,6 +42,7 @@
                           "STRING-DESIGNATOR")
   (:shadowing-import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STREAM"
                           "COPY-STREAM")
+  (:import-from "ALEXANDRIA" "PLIST-ALIST")
   (:export "PROCESS-TOPLEVEL-FILE"
            "TOKEN" "TOKEN-LINE" "TOKEN-COLUMN" "TOKEN-FILE"
            "TOKEN-TEXT" "IDENTIFIER-TOKEN" "NUMBER-TOKEN" "PUNCTUATION-TOKEN"
diff --git a/languages/cpp/tests/Makefile b/languages/cpp/tests/Makefile
index 481c6eb..41ca013 100644
--- a/languages/cpp/tests/Makefile
+++ b/languages/cpp/tests/Makefile
@@ -31,4 +31,8 @@ ifdef:
 	gcc -E -o - ifdef.c | cat -s
 if:
 	gcc -E -o - -Wundef if.c | cat -s
+if-embedded:
+	gcc -E -o - if-embedded.c | cat -s
+line:
+	gcc -E -o - line.c | cat -s

diff --git a/languages/cpp/tests/data.h b/languages/cpp/tests/data.h
new file mode 100644
index 0000000..6fde582
--- /dev/null
+++ b/languages/cpp/tests/data.h
@@ -0,0 +1 @@
+11,22,33
diff --git a/languages/cpp/tests/if-embedded.c b/languages/cpp/tests/if-embedded.c
new file mode 100644
index 0000000..53b5507
--- /dev/null
+++ b/languages/cpp/tests/if-embedded.c
@@ -0,0 +1,43 @@
+#define YES 1
+#define NO  0
+#define DEFINED
+#undef UNDEFINED
+
+#if YES
+good: yes;
+#if YES
+good: yes.yes;
+#elif defined(UNDEFINED)
+bad: yes.defined(UNDEFINED);
+#else
+bad: yes.no;
+#endif
+#else
+bad:no;
+#endif
+
+#ifdef YES
+good: yes;
+#ifdef YES
+good: yes.yes;
+#elif defined(UNDEFINED)
+bad: yes.defined(UNDEFINED);
+#else
+bad: yes.no;
+#endif
+#else
+bad:no;
+#endif
+
+#ifndef UNDEFINED
+good: yes;
+#ifndef UNDEFINED
+good: yes.yes;
+#elif defined(UNDEFINED)
+bad: yes.defined(UNDEFINED);
+#else
+bad: yes.no;
+#endif
+#else
+bad:no;
+#endif
diff --git a/languages/cpp/tests/recursive.c b/languages/cpp/tests/recursive.c
index 320992a..0376c98 100644
--- a/languages/cpp/tests/recursive.c
+++ b/languages/cpp/tests/recursive.c
@@ -36,7 +36,7 @@ int i[]={ FOO,
 #define LEFT F("l",
 #define RIGHT ,"r")
 #define FOO LEFT "foo" RIGHT
-1: FOO; /* ok */
+0: FOO; /* ok */
 #define F(a,b,c) a##b##c
 // 2: FOO; /* good: error: unterminated argument list invoking macro "F" */

@@ -62,3 +62,9 @@ int i[]={ FOO,
 #undef F
 #define F(a,b,c) c##c
        );
+
+#undef F
+#define F(a,b,c) int z[]={a,b,c}
+5:F(
+      # include "data.h"
+      );
diff --git a/languages/cpp/tests/test.c b/languages/cpp/tests/test.c
index 9c3932a..584be90 100644
--- a/languages/cpp/tests/test.c
+++ b/languages/cpp/tests/test.c
@@ -8,4 +8,3 @@ int f(int x)
         return 2;
       END
     END
-
ViewGit