mescc: Be silent.
[mes.git] / 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 "") verbose?)
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          (includes (append
86                     includes
87                     (cons* kernel-include
88                            sys-include
89                            (append (or (and=> (getenv "CPATH")
90                                               (cut string-split <> #\:)) '())
91                                    (or (and=> (getenv "C_INCLUDE_PATH")
92                                               (cut string-split <> #\:)) '())))))
93          (defines `(
94                     "NULL=0"
95                     "__linux__=1"
96                     "_POSIX_SOURCE=0"
97                     "SYSTEM_LIBC=0"
98                     "__STDC__=1"
99                     "__MESC__=1"
100                     ,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
101                     ,@defines)))
102     (when (and verbose? (> verbose? 1))
103       (stderr "includes: ~s\n" includes)
104       (stderr "defines: ~s\n" defines))
105     (parse-c99
106      #:inc-dirs includes
107      #:cpp-defs defines
108      #:mode 'code)))
109
110 (define* (c99-input->ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
111   (when verbose?
112     (stderr "parsing: input\n"))
113   ((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?)))
114
115 (define (ast-strip-comment o)
116   (pmatch o
117     ((comment . ,comment) #f)
118     (((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
119     (((comment . ,comment) . ,cdr) cdr)
120     ((,car . (comment . ,comment)) car)
121     ((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
122                    (cons (ast-strip-comment h) (ast-strip-comment t))))
123     (_  o)))
124
125 (define (ast-strip-const o)
126   (pmatch o
127     ((type-qual ,qual) (if (equal? qual "const") #f o))
128     ((pointer (type-qual-list (type-qual ,qual)) . ,rest)
129      (if (equal? qual "const") `(pointer ,@rest) o))
130     ((decl-spec-list (type-qual ,qual))
131      (if (equal? qual "const") #f
132          `(decl-spec-list (type-qual ,qual))))
133     ((decl-spec-list (type-qual ,qual) . ,rest)
134      (if (equal? qual "const") `(decl-spec-list ,@rest)
135          `(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
136     ((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
137      (if (equal? qual "const") `(decl-spec-list ,@rest)
138          `(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
139     ((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
140                    (cons (ast-strip-const h) (ast-strip-const t))))
141     (_  o)))