guile-gcc/examples/meta.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 (meta)
  #:use-module (gcc)
  #:use-module (gcc cpp)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (system base compile)
  #:use-module (system base message))

;;;
;;; Meta-programming with interspersed Scheme code!
;;;

(define %definitions
  ;; Map names to procedures.
  (make-hash-table))

(define %user-module
  ;; Module where user code is run.
  (let ((m (make-fresh-user-module)))
    (module-use! m (resolve-interface '(gcc)))
    m))

(define (handle-definition cpp)
  "Handle the `define' pragma."
  (let ((name (peek-token cpp 0))
        (arg  (peek-token cpp 1)))
    (if (= CPP_NAME (token-type name))
        (if (= CPP_STRING (token-type arg))
            (let* ((loc  (token-source-location name))
                   (name (string->symbol (token-as-text cpp name)))
                   (str  (with-input-from-string (token-as-text cpp arg)
                           read))
                   (code (call-with-input-string str
                           (lambda (port)
                             (let ((loc (expand-location
                                         (token-source-location arg))))
                               ;; XXX: This isn't great since `token-as-text'
                               ;; returns a single string without newlines.
                               (set-port-filename! port (location-file loc))
                               (set-port-line! port (1- (location-line loc)))
                               (set-port-column! port (1- (location-column loc)))
                               (read port))))))
              (inform loc "seen definition of `~a'" name)
              (hashq-set! %definitions name
                          (with-fluids ((*current-warning-prefix* ""))
                            (compile code
                                     #:env %user-module
                                     #:opts %auto-compilation-options))))
            (error-at (token-source-location arg) "expected a code string"))
        (error-at (token-source-location name) "expected a name"))))

(define (handle-invocation cpp)
  "Handle the `invoke' pragma."
  (let ((name (peek-token cpp 0)))
    (if (= CPP_NAME (token-type name))
        (let* ((proc-name (string->symbol (token-as-text cpp name)))
               (proc      (hashq-ref %definitions proc-name #f)))
          (if (procedure? proc)
              (let* ((decl (compose lookup-name get-identifier
                                    (cut token-as-text cpp <>)))
                     (args (unfold-right (lambda (i)
                                          (let ((t (peek-token cpp i)))
                                            (or (not t)
                                                (= CPP_EOF (token-type t))
                                                (= CPP_PRAGMA_EOL
                                                   (token-type t)))))
                                        (lambda (i)
                                          (decl (peek-token cpp i)))
                                        1+
                                        1)))
                (inform (token-source-location name)
                        "invoking `~a'" proc-name)
                (apply proc args))
              (error-at (token-source-location name)
                        "~a: no procedure by that name" proc-name)))
        (error-at (token-source-location name)
                  "expected a procedure name"))))

(define (register-incredible-pragmas)
  (register-c-pragma "guile" "define" handle-definition)
  (register-c-pragma "guile" "invoke" handle-invocation))

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