guile-gcc/tests/pragma.scm

;;; Guile-GCC --- Guile extension to GCC.               -*- coding: utf-8 -*-
;;; Copyright (C) 2012 Ludovic Courtès
;;;
;;; This file is part of Guile-GCC.
;;;
;;; Guile-GCC is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Guile-GCC is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Guile-GCC.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-pragma)
  #:use-module (gcc)
  #:use-module (gcc cpp)
  #:use-module (srfi srfi-11))

;; Test whether pragmas can be registered, and whether they can successfully
;; use the libcpp and c-family APIs.

(define (register-pragmas)
  (register-c-pragma "guile" "lex"
                     (lambda (cpp)
                       (let-values (((tok1 type1 loc1)
                                     (c-lex-with-flags #:join-strings? #f))
                                    ((tok2 type2 loc2)
                                     (c-lex-with-flags #:join-strings? #f))
                                    ((type3)
                                     ;; XXX: Using `c-lex-with-flags' here
                                     ;; would confuse the C parser, because
                                     ;; it would miss a token.
                                     (token-type (peek-token cpp 0))))
                         (if (and (= type1 CPP_STRING) (= type2 CPP_STRING)
                                  (= type3 CPP_PRAGMA_EOL)
                                  (= (tree-code tok1) STRING_CST)
                                  (= (tree-code tok2) STRING_CST))
                             (begin
                               (inform loc1 (string-constant-value tok1))
                               (inform loc2 (string-constant-value tok2)))))))

  (register-c-pragma "guile" "goodbye"
                     (lambda (cpp)
                       (let ((fn  (current-function-decl))
                             (loc (token-source-location (peek-token cpp 0))))
                         (inform loc "hello, world from ~a"
                                 (identifier-string (decl-name fn)))
                         (let ((exit (built-in-decl BUILT_IN_EXIT)))
                           (add-statement (tree loc (exit 0))))))))

(register-callback "guile" PLUGIN_PRAGMAS register-pragmas)