145 lines
5.4 KiB
Scheme
145 lines
5.4 KiB
Scheme
;;; GNU Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016,2017,2018,2020,2023 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of GNU Mes.
|
|
;;;
|
|
;;; GNU Mes 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.
|
|
;;;
|
|
;;; GNU Mes 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
|
|
(define-module (mescc preprocess)
|
|
#:use-module (ice-9 optargs)
|
|
#:use-module (system base pmatch)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (nyacc lang c99 parser)
|
|
#:use-module (nyacc version)
|
|
#:use-module (mes guile)
|
|
#:export (c99-input->ast))
|
|
|
|
(define mes-or-reproducible? #t)
|
|
|
|
(when (getenv "MESC_DEBUG")
|
|
(format (current-error-port) "*nyacc-version*=~a\n" *nyacc-version*))
|
|
|
|
;; list of which rules you want progress reported
|
|
(define need-progress
|
|
(or (assoc-ref
|
|
'(("0.85.3" (1 2 3))
|
|
("0.86.0" (1 2 3)))
|
|
*nyacc-version*)
|
|
'((1 2 3))))
|
|
|
|
(define (progress o)
|
|
(when (and o (getenv "NYACC_DEBUG"))
|
|
(display " :" (current-error-port))
|
|
(display o (current-error-port))
|
|
(display "\n" (current-error-port))))
|
|
|
|
(define (insert-progress-monitors act-v len-v)
|
|
(let ((n (vector-length act-v)))
|
|
(let loop ((ix 0))
|
|
(when (< ix n)
|
|
(if (memq ix need-progress)
|
|
(vector-set!
|
|
act-v ix
|
|
(lambda args
|
|
(progress (list-ref args (1- (vector-ref len-v ix))))
|
|
(apply (vector-ref act-v ix) args))))
|
|
(loop (1+ ix))))))
|
|
|
|
(cond-expand
|
|
(guile
|
|
(insert-progress-monitors (@@ (nyacc lang c99 parser) c99-act-v)
|
|
(@@ (nyacc lang c99 parser) c99-len-v)))
|
|
(mes
|
|
(insert-progress-monitors c99-act-v c99-len-v)))
|
|
|
|
(define* (c99-input->full-ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
|
|
(let* ((sys-include (if (equal? prefix "") "include"
|
|
(string-append prefix "/include")))
|
|
(kernel "linux")
|
|
(kernel-include (string-append sys-include "/" kernel "/" arch))
|
|
(includes (append
|
|
includes
|
|
(cons* kernel-include
|
|
sys-include
|
|
(append (or (and=> (getenv "CPATH")
|
|
(cut string-split <> #\:)) '())
|
|
(or (and=> (getenv "C_INCLUDE_PATH")
|
|
(cut string-split <> #\:)) '())))))
|
|
(defines `(
|
|
"NULL=0"
|
|
"__linux__=1"
|
|
"_POSIX_SOURCE=0"
|
|
"SYSTEM_LIBC=0"
|
|
"__STDC__=1"
|
|
"__MESC__=1"
|
|
,(if mes-or-reproducible? "__MESC_MES__=1" "__MESC_MES__=0")
|
|
,@defines)))
|
|
(when (and verbose? (> verbose? 1))
|
|
(format (current-error-port) "includes: ~s\n" includes)
|
|
(format (current-error-port) "defines: ~s\n" defines))
|
|
(parse-c99
|
|
#:inc-dirs includes
|
|
#:cpp-defs defines
|
|
#:mode 'code)))
|
|
|
|
(define* (c99-input->ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
|
|
(when verbose?
|
|
(format (current-error-port) "parsing: input\n"))
|
|
((compose ast-strip-attributes
|
|
ast-strip-const
|
|
ast-strip-comment)
|
|
(c99-input->full-ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?)))
|
|
|
|
(define (ast-strip-comment o)
|
|
(pmatch o
|
|
((@ (comment . ,comment)) #f) ; Nyacc 0.90.2/0.93.0?
|
|
((comment . ,comment) #f)
|
|
(((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
|
|
(((comment . ,comment) . ,cdr) cdr)
|
|
((,car . (comment . ,comment)) car)
|
|
((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
|
|
(cons (ast-strip-comment h) (ast-strip-comment t))))
|
|
(_ o)))
|
|
|
|
(define (ast-strip-const o)
|
|
(pmatch o
|
|
((type-qual ,qual) (if (equal? qual "const") #f o))
|
|
((pointer (type-qual-list (type-qual ,qual)) . ,rest)
|
|
(if (equal? qual "const") `(pointer ,@rest) o))
|
|
((decl-spec-list (type-qual ,qual))
|
|
(if (equal? qual "const") #f
|
|
`(decl-spec-list (type-qual ,qual))))
|
|
((decl-spec-list (type-qual ,qual) . ,rest)
|
|
(if (equal? qual "const") `(decl-spec-list ,@rest)
|
|
`(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
|
|
((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
|
|
(if (equal? qual "const") `(decl-spec-list ,@rest)
|
|
`(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
|
|
((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
|
|
(cons (ast-strip-const h) (ast-strip-const t))))
|
|
(_ o)))
|
|
|
|
(define (ast-strip-attributes o)
|
|
(pmatch o
|
|
((decl-spec-list (@ (attributes . ,attributes)) . ,rest)
|
|
`(decl-spec-list ,@rest))
|
|
((,h . ,t) (if (list? o) (filter-map ast-strip-attributes o)
|
|
(cons (ast-strip-attributes h) (ast-strip-attributes t))))
|
|
(_ o)))
|