935e98e351d9397c11d0fa34b903f5de03771c36
[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 ""))
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)))