nyacc: working on cpp issues
This commit is contained in:
Matt Wette
Jan Nieuwenhuizen
parent
d03ea06c84
commit
ea7f0b3a01
|
|
@ -291,6 +291,7 @@
|
|||
(let* ((defs (cpi-defs info))
|
||||
(rhs (cpp-expand-text text defs))
|
||||
(exp (parse-cpp-expr rhs)))
|
||||
(simple-format #t "defs: ~S\n" defs)
|
||||
(eval-cpp-expr exp defs)))
|
||||
(lambda (key fmt . args)
|
||||
(report-error fmt args)
|
||||
|
|
@ -397,8 +398,39 @@
|
|||
(case (car stmt)
|
||||
((pragma) (cons 'cpp-pragma (cdr stmt)))
|
||||
(else (cons 'cpp-stmt stmt))))
|
||||
|
||||
|
||||
(define (eval-cpp-stmt-1/code stmt)
|
||||
;; eval control flow: states are {skip-look, keep, skip-done}
|
||||
(case (car stmt)
|
||||
((if)
|
||||
(let ((val (eval-cpp-cond-text (cadr stmt))))
|
||||
(simple-format #t "if ~S=> ~S\n" (cadr stmt) val)
|
||||
(if (not val) (p-err "unresolved: ~S" (cadr stmt)))
|
||||
(if (eq? 'keep (car ppxs))
|
||||
(if (zero? val)
|
||||
(set! ppxs (cons 'skip-look ppxs))
|
||||
(set! ppxs (cons 'keep ppxs)))
|
||||
(set! ppxs (cons 'skip-done ppxs)))))
|
||||
((elif)
|
||||
(let ((val (eval-cpp-cond-text (cadr stmt))))
|
||||
(simple-format #t "elif ~S=> ~S\n" (cadr stmt) val)
|
||||
(if (not val) (p-err "unresolved: ~S" (cadr stmt)))
|
||||
(case (car ppxs)
|
||||
((skip-look) (if (not (zero? val)) (set-car! ppxs 'keep)))
|
||||
((keep) (set-car! ppxs 'skip-done)))))
|
||||
((else)
|
||||
(simple-format #t "else (was ~S)\n" (car ppxs))
|
||||
(case (car ppxs)
|
||||
((skip-look) (set-car! ppxs 'keep))
|
||||
((keep) (set-car! ppxs 'skip-done))))
|
||||
((endif)
|
||||
(set! ppxs (cdr ppxs)))
|
||||
(else
|
||||
(if (eqv? 'keep (car ppxs))
|
||||
(eval-cpp-stmt-2/code stmt)))))
|
||||
|
||||
(define (eval-cpp-stmt-2/code stmt)
|
||||
;; eval non-control flow
|
||||
(case (car stmt)
|
||||
;; actions
|
||||
((include)
|
||||
|
|
@ -408,38 +440,11 @@
|
|||
(push-input (open-input-file path))))
|
||||
((define) (add-define stmt))
|
||||
((undef) (rem-define (cadr stmt)))
|
||||
((error) (report-error "error: #error ~A" (cdr stmt)))
|
||||
((error) (p-err "error: #error ~A" (cadr stmt)))
|
||||
((pragma) #t) ;; ignore for now
|
||||
;; control flow: states are {skip-look, keep, skip-done}
|
||||
((if) ;; and ifdef ifndef
|
||||
(let ((val (eval-cpp-cond-text (cadr stmt))))
|
||||
;;(simple-format #t "if ~S=> ~S\n" (cadr stmt) val)
|
||||
(if (not val) (p-err "unresolved: ~S" (cadr stmt)))
|
||||
(if (eq? 'keep (car ppxs))
|
||||
(if (zero? val)
|
||||
(set! ppxs (cons 'skip-look ppxs))
|
||||
;; keep if keeping, skip if skipping, ??? if skip-look
|
||||
(set! ppxs (cons (car ppxs) ppxs)))
|
||||
(set! ppxs (cons 'skip-done ppxs)))))
|
||||
((elif)
|
||||
(let ((val (eval-cpp-cond-text (cadr stmt))))
|
||||
;;(simple-format #t "elif ~S=> ~S\n" (cadr stmt) val)
|
||||
(if (not val) (p-err "unresolved: ~S" (cadr stmt)))
|
||||
(if (eq? 'keep (car ppxs))
|
||||
(if (zero? val)
|
||||
(set! ppxs (cons 'skip-look ppxs))
|
||||
;; keep if keeping, skip if skipping, ??? if skip-look
|
||||
(set! ppxs (cons* (car ppxs) ppxs)))
|
||||
(set! ppxs (cons 'skip-done ppxs)))))
|
||||
((else)
|
||||
;;(simple-format #t "else\n")
|
||||
(if (eqv? 'skip-look (car ppxs))
|
||||
(set! ppxs (cons 'keep (cdr ppxs)))))
|
||||
((endif)
|
||||
(set! ppxs (cdr ppxs)))
|
||||
(else
|
||||
(error "bad cpp flow stmt"))))
|
||||
|
||||
|
||||
(define (eval-cpp-stmt/code stmt)
|
||||
;;(simple-format #t "eval-cpp-stmt: ~S\n" stmt)
|
||||
(with-throw-handler
|
||||
|
|
@ -511,10 +516,10 @@
|
|||
|
||||
;; Loop between reading tokens and skipping tokens via CPP logic.
|
||||
(let iter ((pair (read-token)))
|
||||
;;(simple-format #t "iter ~S\n" (car ppxs)) (sleep 1)
|
||||
(simple-format #t "iter ~S\n" (car ppxs)) (sleep 1)
|
||||
(case (car ppxs)
|
||||
((keep)
|
||||
;;(simple-format #t "lx=>~S\n" pair)
|
||||
(simple-format #t "lx=>~S\n" pair)
|
||||
pair)
|
||||
((skip-done skip-look)
|
||||
(iter (read-token)))
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@
|
|||
#:use-module (nyacc lex)
|
||||
#:use-module (nyacc lang util)
|
||||
#:use-module (rnrs arithmetic bitwise)
|
||||
#:use-module (ice-9 match)
|
||||
)
|
||||
|
||||
(cond-expand
|
||||
|
|
@ -37,6 +38,28 @@
|
|||
(use-modules (ice-9 syncase)))
|
||||
(mes))
|
||||
|
||||
(define c99-std-defs
|
||||
'("__DATE__" "__FILE__" "__LINE__" "__STDC__" "__STDC_HOSTED__"
|
||||
"__STDC_VERSION__" "__TIME__"))
|
||||
|
||||
(define (c99-std-def? str)
|
||||
(let iter ((defs c99-std-defs))
|
||||
(cond
|
||||
((null? defs) #f)
|
||||
((string=? (car defs) str) #t)
|
||||
(else (iter (cdr defs))))))
|
||||
|
||||
(define (c99-std-val str)
|
||||
(cond
|
||||
((string=? str "__DATE__") "M01 01 2001")
|
||||
((string=? str "__FILE__") "(unknown)")
|
||||
((string=? str "__LINE__") 0)
|
||||
((string=? str "__STDC__") 1)
|
||||
((string=? str "__STDC_HOSTED__") 0)
|
||||
((string=? "__STDC_VERSION__") 201701)
|
||||
((string=? "__TIME__") "00:00:00")
|
||||
(else #f)))
|
||||
|
||||
;; @deffn read-ellipsis ch
|
||||
;; read ellipsis
|
||||
(define (read-ellipsis ch)
|
||||
|
|
@ -46,6 +69,9 @@
|
|||
(else #f)))
|
||||
|
||||
;; @deffn cpp-define => (define (name "ADD") (args "X" "Y") (repl "X+Y"))
|
||||
;; output is like
|
||||
;; @code{(name "ABC") (repl "123")} or
|
||||
;; @code{(name "ABC") (args "X" "Y") (repl "X+Y")}
|
||||
(define (cpp-define)
|
||||
|
||||
(define (p-args la) ;; parse args
|
||||
|
|
@ -66,7 +92,7 @@
|
|||
(define (p-rest la) ;; parse rest
|
||||
(cond ((eof-object? la) "")
|
||||
(else
|
||||
(if (not (char=? #\=)) (unread-char ch)) ; handle ABC=DEF
|
||||
(if (not (char=? #\=)) (unread-char la)) ; handle ABC=DEF
|
||||
(drain-input (current-input-port)))))
|
||||
|
||||
(let* ((name (read-c-ident (skip-il-ws (read-char))))
|
||||
|
|
@ -77,44 +103,6 @@
|
|||
`(define (name ,name) (repl ,repl)))))
|
||||
|
||||
|
||||
;; where @code{...} is
|
||||
;; @code{(name "ABC") (repl "123")} or
|
||||
;; @code{(name "ABC") (args "X" "Y") (repl "X+Y")}
|
||||
(define (x-cpp-define)
|
||||
;; The (weak?) parse architecture is "unread la argument if no match"
|
||||
(letrec
|
||||
((p-cppd ;; parse all
|
||||
(lambda ()
|
||||
(let* ((iden (read-c-ident (skip-il-ws (read-char))))
|
||||
;; "define ABC(ARG)" not the same as "define ABC (ARG)"
|
||||
(args (or (p-args (read-char)) '()))
|
||||
(rest (p-rest (skip-il-ws (read-char)))))
|
||||
(if (pair? args)
|
||||
`(define (name ,iden) ,(cons 'args args) (repl ,rest))
|
||||
`(define (name ,iden) (repl ,rest))))))
|
||||
(p-args ;; parse args
|
||||
(lambda (la) ;; unread la if no match :(
|
||||
(if (eq? la #\()
|
||||
(let iter ((args '()) (la (skip-il-ws (read-char))))
|
||||
(cond
|
||||
((eq? la #\)) (reverse args))
|
||||
((read-c-ident la) =>
|
||||
(lambda (arg)
|
||||
(iter (cons arg args) (skip-il-ws (read-char)))))
|
||||
((read-ellipsis la) =>
|
||||
(lambda (arg)
|
||||
(iter (cons arg args) (skip-il-ws (read-char)))))
|
||||
((eq? la #\,)
|
||||
(iter args (skip-il-ws (read-char))))))
|
||||
(begin (if (char? la) (unread-char la)) #f)))) ;; CLEANUP
|
||||
(p-rest ;; parse rest
|
||||
(lambda (la)
|
||||
(cond ((eof-object? la) "")
|
||||
(else
|
||||
(if (not (char=? #\=)) (unread-char ch)) ; handle ABC=DEF
|
||||
(drain-input (current-input-port)))))))
|
||||
(p-cppd)))
|
||||
|
||||
;; @deffn cpp-include
|
||||
;; Parse CPP include statement.
|
||||
(define (cpp-include)
|
||||
|
|
@ -162,51 +150,6 @@
|
|||
(list (cons 'len-v len-v) (cons 'pat-v pat-v) (cons 'rto-v rto-v)
|
||||
(cons 'mtab mtab) (cons 'act-v act-v))))
|
||||
|
||||
;; Provide gen-cpp-lexer parse-cpp-expr eval-cpp-expr:
|
||||
;;(include-from-path "nyacc/lang/c99/cppbody.scm")
|
||||
|
||||
;; --- last line ---
|
||||
;;; nyacc/lang/c99/cppbody.scm
|
||||
;;;
|
||||
;;; Copyright (C) 2016-2017 Matthew R. Wette
|
||||
;;;
|
||||
;;; This program 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.
|
||||
;;;
|
||||
;;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(use-modules (ice-9 match))
|
||||
|
||||
(define c99-std-defs
|
||||
'("__DATE__" "__FILE__" "__LINE__" "__STDC__" "__STDC_HOSTED__"
|
||||
"__STDC_VERSION__" "__TIME__"))
|
||||
|
||||
(define (c99-std-def? str)
|
||||
(let iter ((defs c99-std-defs))
|
||||
(cond
|
||||
((null? defs) #f)
|
||||
((string=? (car defs) str) #t)
|
||||
(else (iter (cdr defs))))))
|
||||
|
||||
(define (c99-std-val str)
|
||||
(cond
|
||||
((string=? str "__DATE__") "M01 01 2001")
|
||||
((string=? str "__FILE__") "(unknown)")
|
||||
((string=? str "__LINE__") 0)
|
||||
((string=? str "__STDC__") 1)
|
||||
((string=? str "__STDC_HOSTED__") 0)
|
||||
((string=? "__STDC_VERSION__") 201701)
|
||||
((string=? "__TIME__") "00:00:00")
|
||||
(else #f)))
|
||||
|
||||
(define (cpp-err fmt . args)
|
||||
(apply throw 'cpp-error fmt args))
|
||||
|
||||
|
|
@ -489,6 +432,12 @@
|
|||
(cond
|
||||
((not rval) #f)
|
||||
((string=? rval "C99_ANY") #f) ; don't expand: could be anything
|
||||
;; move FILE LINE to expand-cpp-repl?
|
||||
((string=? rval "__FILE__")
|
||||
(string-append "\"" (or (port-filename (current-input-port))
|
||||
"(unknown)") "\""))
|
||||
((string=? rval "__LINE__") (1+ (port-line (current-input-port))))
|
||||
;;
|
||||
((member ident used) ident)
|
||||
((string? rval)
|
||||
(let ((expd (expand-cpp-repl rval '() dict (cons ident used))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue