Implemented #include_next. Added :defines option to cpp-e.

Pascal J. Bourguignon [2015-07-02 03:59]
Implemented #include_next. Added :defines option to cpp-e.
Filename
languages/cpp/cpp-macro.lisp
languages/cpp/cpp.lisp
languages/cpp/expression.lisp
languages/cpp/tests/emacs.c
languages/cpp/token.lisp
diff --git a/languages/cpp/cpp-macro.lisp b/languages/cpp/cpp-macro.lisp
index 55c4c1c..3bd8906 100644
--- a/languages/cpp/cpp-macro.lisp
+++ b/languages/cpp/cpp-macro.lisp
@@ -626,6 +626,7 @@ concatenation
     (:accept-unicode-escapes . t)
     (:dollar-is-punctuation . nil)
     (:warn-on-undefined-identifier . nil)
+    (:trace-includes . nil)
     (:include-disable-current-directory . nil)
     (:include-quote-directories . ())
     (:include-bracket-directories . ())
@@ -640,6 +641,10 @@ concatenation
   ((base-file             :initarg :base-file
                           :initform "-"
                           :accessor context-base-file)
+   (directory             :initarg :directory
+                          :initform nil
+                          :accessor context-directory
+                          :documentation "Include directory of the currently included/imported file, for #include_next.")
    (file                  :initarg :file
                           :initform "-"
                           :accessor context-file)
@@ -696,8 +701,9 @@ concatenation
 (defmethod context-include-level ((context context))
   (length (context-file-stack context)))

-(defmethod context-push-file ((context context) path input-lines)
-  (push (list (context-file context)
+(defmethod context-push-file ((context context) path directory input-lines)
+  (push (list (context-directory context)
+              (context-file context)
               (context-line context)
               (context-column context)
               (context-token context)
@@ -705,7 +711,8 @@ concatenation
               (context-input-lines context)
               (context-current-line context))
         (context-file-stack context))
-  (setf (context-file context) path
+  (setf (context-directory context) directory
+        (context-file context) path
         (context-line context) 1
         (context-column context) 1
         (context-token context) nil
@@ -716,7 +723,8 @@ concatenation

 (defmethod context-pop-file ((context context))
   (let ((data (pop (context-file-stack context))))
-    (setf (context-file context) (pop data)
+    (setf (context-directory context) (pop data)
+          (context-file context) (pop data)
           (context-line context) (pop data)
           (context-column context) (pop data)
           (context-token context) (pop data)
diff --git a/languages/cpp/cpp.lisp b/languages/cpp/cpp.lisp
index d0547ff..594e8d5 100644
--- a/languages/cpp/cpp.lisp
+++ b/languages/cpp/cpp.lisp
@@ -711,7 +711,7 @@ RETURN: the token text; the end position."
                              nil)))
                      (merge-pathnames include-file directory))
     :when (and path (or (eq t path) (probe-file path)))
-      :do (return path)
+      :do (return (values path directory))
     :finally (return nil)))

 (defun include-directories (kind)
@@ -728,18 +728,26 @@ RETURN: the token text; the end position."
             (remove-duplicates include-bracket-directories :test (function equal)))))

 (defmethod perform-include ((context context) include-file kind directive)
-  (flet ((include (path)
-           (read-and-process-file context path)))
-    (let* ((include-directories (include-directories kind))
-           (path                (search-file-in-directories include-file include-directories kind directive)))
-      (cond ((eq t path) #|done|#)
-            (path        (include path))
-            (t           (cpp-error context
-                                    "Cannot find a file ~C~A~C in the include directories ~S"
-                                    (if (eq kind :quote) #\" #\<)
-                                    include-file
-                                    (if (eq kind :quote) #\" #\>)
-                                    include-directories))))))
+  ;; TODO: skip duplicate #import and #ifndef/#define #include
+  (flet ((include (path directory)
+           (when (option context :trace-includes)
+             (format *trace-output* "Including ~S~%" path))
+           (read-and-process-file context path directory)))
+    (let ((include-directories (include-directories kind)))
+      (when (eq directive :include-next)
+        (setf include-directories (cdr (member (context-directory context)
+                                               include-directories
+                                               :test (function equal)))))
+      (multiple-value-bind (path directory)
+          (search-file-in-directories include-file include-directories kind directive)
+        (cond ((eq t path) #|done|#)
+              (path        (include path directory))
+              (t           (cpp-error context
+                                      "Cannot find a file ~C~A~C in the include directories ~S"
+                                      (if (eq kind :quote) #\" #\<)
+                                      include-file
+                                      (if (eq kind :quote) #\" #\>)
+                                      include-directories)))))))

 (defgeneric token-string (token)
   (:method ((token token)) (token-text token))
@@ -777,9 +785,6 @@ RETURN: the token text; the end position."
                   directive (mapconcat (function token-text) line ""))
        (values nil nil nil)))))

-
-
-
 (defmethod include-common ((context context) directive)
   (with-cpp-line (context-current-line context)
     (if (context-current-line context)
@@ -795,6 +800,9 @@ RETURN: the token text; the end position."
         (cpp-error context "Missing path after #~(~A~)" directive)))
   context)

+(defmethod include-next ((context context))
+  (include-common context :include-next))
+
 (defmethod include ((context context))
   (include-common context :include))

@@ -1101,23 +1109,24 @@ RETURN: the token text; the end position."
   (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))
+       (("define")         (define           context))
+       (("undef")          (undef            context))
+       (("include")        (include          context))
+       (("include_next")   (include-next     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)))))
-       (("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))))))
+       (("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)
@@ -1140,22 +1149,26 @@ RETURN: the token text; the end position."
     :finally (setf (context-current-line context) nil))
   context)

-(defmethod read-and-process-file ((context context) path)
-  (with-open-file (input path :external-format (option *context* :external-format))
-    (context-push-file context path (read-cpp-tokens
-                                     input
-                                     :file-name (namestring path)
-                                     :substitute-trigraphs            (option *context* :substitute-trigraphs)
-                                     :warn-on-trigraph                (option *context* :warn-on-trigraph)
-                                     :warn-spaces-in-continued-lines  (option *context* :warn-spaces-in-continued-lines)
-                                     :single-line-comments            (option *context* :single-line-comments)
-                                     :accept-unicode-escapes          (option *context* :accept-unicode-escapes)
-                                     :dollar-is-punctuation           (option *context* :dollar-is-punctuation)))
-    (process-file context)
+(defmethod read-and-process-stream ((context context) stream &optional (path (pathname stream)) directory)
+  (context-push-file context path directory
+                     (read-cpp-tokens
+                      stream
+                      :file-name (namestring path)
+                      :substitute-trigraphs            (option *context* :substitute-trigraphs)
+                      :warn-on-trigraph                (option *context* :warn-on-trigraph)
+                      :warn-spaces-in-continued-lines  (option *context* :warn-spaces-in-continued-lines)
+                      :single-line-comments            (option *context* :single-line-comments)
+                      :accept-unicode-escapes          (option *context* :accept-unicode-escapes)
+                      :dollar-is-punctuation           (option *context* :dollar-is-punctuation)))
+  (unwind-protect (process-file context)
     (context-pop-file context)))

-(defun process-toplevel-file (path &key (options *default-options*))
-  (let ((*context* (make-instance 'context :base-file path :file path :options options)))
+(defmethod read-and-process-file ((context context) path &optional directory)
+  (with-open-file (input path :external-format (option *context* :external-format))
+    (read-and-process-stream context input path directory)))
+
+(defun process-toplevel-file (path &key (options *default-options*) (environment (copy-hash-table *default-environment*)))
+  (let ((*context* (make-instance 'context :base-file path :file path :options options :environment environment)))
     (read-and-process-file *context* path)
     (values (reverse (context-output-lines *context*)) *context*)))

@@ -1190,19 +1203,49 @@ RETURN: the token text; the end position."
                                   (when restart (invoke-restart restart))))))
     ,@body))

-(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 (append (plist-alist options)
-                                                     (acons :include-quote-directories includes *default-options*)))
-      (terpri)
-      (write-processed-lines lines :write-sharp-line write-sharp-line)
-      ;; (print-hashtable (context-environment context))
-      context)))
+(defun cpp-e (path &rest options &key defines includes write-sharp-line &allow-other-keys)
+  "
+DEFINE:     a plist of object-like macro definitions: (macro-name macro-value)
+            macro-name is a string designator.
+            macro-values can be any string that is parsed into tokens.
+
+INCLUDES:   This is a shortcut for :include-quote-directories.
+            If both are given, :include-quote-directories takes precedence.
+
+WRITE-SHARP-LINE:
+            produces #line N \"file\" lines, in the output listing.
+
+Other keys shall be context option keys.
+"
+  (let ((environment (copy-hash-table *default-environment*)))
+    (loop :for (name definition) :on defines :by (function cddr)
+          :do (let ((name (string name))
+                    (new-definition (parse-macro-definition
+                                     name
+                                     (with-input-from-string (input definition)
+                                       (first (read-cpp-tokens input :file-name "-"))))))
+                (when (prefixp "__" name)
+                  (cpp-warning nil "Definiting a system macro named ~S" name))
+                (setf (environment-macro-definition environment name) new-definition)))
+    (with-cpp-error-logging
+      (multiple-value-bind (lines context)
+          (process-toplevel-file path
+                                 :options (append (plist-alist options)
+                                                  (acons :include-quote-directories includes
+                                                         *default-options*))
+                                 :environment environment)
+        (terpri)
+        (write-processed-lines lines :write-sharp-line write-sharp-line)
+        ;; (print-hashtable (context-environment context))
+        context))))

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

 #-(and) (progn
+          (cpp-e "tests/test.c"          :includes '("tests/") :write-sharp-line t
+                                         :define '("FOO" "1" "BAR" "FOO"))
+
+

           (cpp-e "tests/test.c"          :includes '("tests/") :write-sharp-line t)
           (cpp-e "tests/variadic.c"      :includes '("tests/") :write-sharp-line t)
diff --git a/languages/cpp/expression.lisp b/languages/cpp/expression.lisp
index a80c1f4..9db9f86 100644
--- a/languages/cpp/expression.lisp
+++ b/languages/cpp/expression.lisp
@@ -34,28 +34,31 @@
 (in-package "COM.INFORMATIMAGO.COMMON-LISP.LANGUAGES.CPP")

 (defun integer-value (integer-token)
-  (let ((integer-text (token-text integer-token)))
+  (let* ((integer-text (token-text integer-token))
+         (end          (length integer-text)))
+    (loop :while (and (< 1 end) (find (aref integer-text (1- end)) "UL" :test (function char-equal)))
+          :do (decf end))
     (cond
       ((and (< 2 (length integer-text))
             (string= "0x" integer-text :start2 0 :end2 2))
-       (or (ignore-errors (parse-integer integer-text :start 2 :radix 16 :junk-allowed nil))
+       (or (ignore-errors (parse-integer integer-text :start 2 :end end :radix 16 :junk-allowed nil))
            (progn
              (cpp-error integer-token "Invalid hexadecimal integer syntax in ~S" integer-text)
              0)))
       ((and (< 2 (length integer-text))
             (string= "0b" integer-text :start2 0 :end2 2))
-       (or (ignore-errors (parse-integer integer-text :start 2 :radix 2 :junk-allowed nil))
+       (or (ignore-errors (parse-integer integer-text :start 2  :end end :radix 2 :junk-allowed nil))
            (progn
              (cpp-error integer-token "Invalid binary integer syntax in ~S" integer-text)
              0)))
       ((and (< 1 (length integer-text))
             (string= "0" integer-text :start2 0 :end2 1))
-       (or (ignore-errors (parse-integer integer-text :start 1 :radix 8 :junk-allowed nil))
+       (or (ignore-errors (parse-integer integer-text :start 1  :end end :radix 8 :junk-allowed nil))
            (progn
              (cpp-error integer-token "Invalid octal integer syntax in ~S" integer-text)
              0)))
       (t
-       (or (ignore-errors (parse-integer integer-text :junk-allowed nil))
+       (or (ignore-errors (parse-integer integer-text  :end end :junk-allowed nil))
            (progn
              (cpp-error integer-token "Invalid decimal integer syntax in ~S" integer-text)
              0))))))
@@ -176,7 +179,19 @@
                            (expr5  expr4  (op-left-shift-p left-shift) (op-right-shift-p right-shift))
                            (expr4  expr3  (op-plus-p +) (op-minus-p -))
                            (expr3  expr2  (op-times-p *) (op-divides-p truncate)  (op-remainder-p mod)))
-      ((expr2 ()
+      ((expr13 ()
+               (let ((test (expr12)))
+                 (if (op-question-p (peek))
+                     (progn
+                       (eat)
+                       (let ((then (expr12)))
+                         (if (op-colon-p (peek))
+                             (progn
+                               (eat)
+                               `(if (zerop ,test) ,(expr12) ,then))
+                             (cpp-error (peek) "Expected a colon in ternary if expression, got ~S instead" (token-text (eat))))))
+                     test)))
+       (expr2 ()
               (let ((op (peek)))
                 (cond ((op-plus-p op)   (eat) (expr1))
                       ((op-minus-p op)  (eat) `(- ,(expr1)))
@@ -194,7 +209,7 @@
                 (cond
                   ((openp next)
                    (eat)
-                   (prog1 (expr12)
+                   (prog1 (expr13)
                      (if (closep (peek))
                          (eat)
                          (progn (cpp-error next "Missing close parenthesis in #if expression, got ~S instead" (token-text (eat)))
@@ -219,7 +234,7 @@
                      (return-from parse-expression 0)))))
        (eat  () (pop   line))
        (peek () (first line)))
-    (prog1 (expr12)
+    (prog1 (expr13)
       (unless (null (peek))
         (cpp-error (peek) "missing binary operator before token ~S" (eat))))))

diff --git a/languages/cpp/tests/emacs.c b/languages/cpp/tests/emacs.c
new file mode 100644
index 0000000..5a86883
--- /dev/null
+++ b/languages/cpp/tests/emacs.c
@@ -0,0 +1,2 @@
+#include <config.h>
+#include <lisp.h>
diff --git a/languages/cpp/token.lisp b/languages/cpp/token.lisp
index f7009e6..2fdce4e 100644
--- a/languages/cpp/token.lisp
+++ b/languages/cpp/token.lisp
@@ -148,6 +148,8 @@
 (define-punctuation-predicate op-bitxor-p      "^")
 (define-punctuation-predicate op-logand-p      "&&")
 (define-punctuation-predicate op-logior-p      "||")
+(define-punctuation-predicate op-question-p    "?")
+(define-punctuation-predicate op-colon-p       ":")


 (defun identifierp (token)
ViewGit