module/mescc/preprocess.scm

   1 ;;; GNU Mes --- Maxwell Equations of Software
   2 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Mes.
   5 ;;;
   6 ;;; GNU Mes is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Mes is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;; Commentary:
  20
  21 ;;; Code:
  22
  23 (define-module (mescc preprocess)
  24   #:use-module (ice-9 optargs)
  25   #:use-module (system base pmatch)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-26)
  28   #:use-module (nyacc lang c99 parser)
  29   #:use-module (nyacc lang c99 parser)
  30   #:use-module (nyacc version)
  31   #:use-module (mes guile)
  32   #:export (c99-input->ast))
  33
  34 (when (getenv "MESC_DEBUG")
  35   (format (current-error-port) "*nyacc-version*=~a\n" *nyacc-version*))
  36
  37 ;; list of which rules you want progress reported
  38 (define need-progress
  39   (or (assoc-ref
  40        '(("0.85.3" (1 2 3))
  41          ("0.86.0" (1 2 3)))
  42        *nyacc-version*)
  43       '(1 2 3)))
  44
  45 (define (progress o)
  46   (when (and o (getenv "NYACC_DEBUG"))
  47     (display "    :" (current-error-port))
  48     (display o (current-error-port))
  49     (display "\n" (current-error-port))))
  50
  51 (define (insert-progress-monitors act-v len-v)
  52   (let ((n (vector-length act-v)))
  53     (let loop ((ix 0))
  54       (when (< ix n)
  55         (if (memq ix need-progress)
  56             (vector-set!
  57              act-v ix
  58              (lambda args
  59                (progress (list-ref args (1- (vector-ref len-v ix))))
  60                (apply (vector-ref act-v ix) args))))
  61         (loop (1+ ix))))))
  62
  63 (cond-expand
  64  (guile
  65   (insert-progress-monitors (@@ (nyacc lang c99 parser) c99-act-v)
  66                             (@@ (nyacc lang c99 parser) c99-len-v)))
  67  (mes
  68   (insert-progress-monitors c99-act-v c99-len-v)))
  69
  70 (define (logf port string . rest)
  71   (apply format (cons* port string rest))
  72   (force-output port)
  73   #t)
  74
  75 (define (stderr string . rest)
  76   (apply logf (cons* (current-error-port) string rest)))
  77
  78 (define mes? (pair? (current-module)))
  79
  80 (define* (c99-input->full-ast #:key (prefix "") (defines '()) (includes '()) (arch ""))
  81   (let* ((sys-include (if (equal? prefix "") "include"
  82                           (string-append prefix "/include")))
  83          (kernel "linux")
  84          (kernel-include (string-append sys-include "/" kernel "/" arch)))
  85     (parse-c99
  86      #:inc-dirs (append
  87                  includes
  88                  (cons* kernel-include
  89                         sys-include
  90                         (append (or (and=> (getenv "CPATH")
  91                                            (cut string-split <> #\:)) '())
  92                                 (or (and=> (getenv "C_INCLUDE_PATH")
  93                                            (cut string-split <> #\:)) '()))))
  94      #:cpp-defs `(
  95                   "NULL=0"
  96                   "__linux__=1"
  97                   "_POSIX_SOURCE=0"
  98                   "SYSTEM_LIBC=0"
  99                   "__STDC__=1"
 100                   "__MESC__=1"
 101                   ,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
 102                   ,@defines)
 103      #:mode 'code)))
 104
 105 (define* (c99-input->ast #:key (prefix "") (defines '()) (includes '()) (arch ""))
 106   (stderr "parsing: input\n")
 107   ((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:prefix prefix #:defines defines #:includes includes #:arch arch)))
 108
 109 (define (ast-strip-comment o)
 110   (pmatch o
 111     ((comment . ,comment) #f)
 112     (((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
 113     (((comment . ,comment) . ,cdr) cdr)
 114     ((,car . (comment . ,comment)) car)
 115     ((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
 116                    (cons (ast-strip-comment h) (ast-strip-comment t))))
 117     (_  o)))
 118
 119 (define (ast-strip-const o)
 120   (pmatch o
 121     ((type-qual ,qual) (if (equal? qual "const") #f o))
 122     ((pointer (type-qual-list (type-qual ,qual)) . ,rest)
 123      (if (equal? qual "const") `(pointer ,@rest) o))
 124     ((decl-spec-list (type-qual ,qual))
 125      (if (equal? qual "const") #f
 126          `(decl-spec-list (type-qual ,qual))))
 127     ((decl-spec-list (type-qual ,qual) . ,rest)
 128      (if (equal? qual "const") `(decl-spec-list ,@rest)
 129          `(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
 130     ((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
 131      (if (equal? qual "const") `(decl-spec-list ,@rest)
 132          `(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
 133     ((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
 134                    (cons (ast-strip-const h) (ast-strip-const t))))
 135     (_  o)))