artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

nyacc: working on cpp issues

Browse source
This commit is contained in:
Matt Wette 2017-02-11 13:04:38 -08:00 committed by Jan Nieuwenhuizen
parent d03ea06c84
commit ea7f0b3a01
2 changed files with 70 additions and 116 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

69
module/nyacc/lang/c99/body.scm
View file

@ -291,6 +291,7 @@
(let* ((defs (cpi-defs info)) (let* ((defs (cpi-defs info))
(rhs (cpp-expand-text text defs)) (rhs (cpp-expand-text text defs))
(exp (parse-cpp-expr rhs))) (exp (parse-cpp-expr rhs)))
(simple-format #t "defs: ~S\n" defs)
(eval-cpp-expr exp defs))) (eval-cpp-expr exp defs)))
(lambda (key fmt . args) (lambda (key fmt . args)
(report-error fmt args) (report-error fmt args)
@ -397,8 +398,39 @@
(case (car stmt) (case (car stmt)
((pragma) (cons 'cpp-pragma (cdr stmt))) ((pragma) (cons 'cpp-pragma (cdr stmt)))
(else (cons 'cpp-stmt stmt)))) (else (cons 'cpp-stmt stmt))))
(define (eval-cpp-stmt-1/code 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) (case (car stmt)
;; actions ;; actions
((include) ((include)
@ -408,38 +440,11 @@
(push-input (open-input-file path)))) (push-input (open-input-file path))))
((define) (add-define stmt)) ((define) (add-define stmt))
((undef) (rem-define (cadr 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 ((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 (else
(error "bad cpp flow stmt")))) (error "bad cpp flow stmt"))))
(define (eval-cpp-stmt/code stmt) (define (eval-cpp-stmt/code stmt)
;;(simple-format #t "eval-cpp-stmt: ~S\n" stmt) ;;(simple-format #t "eval-cpp-stmt: ~S\n" stmt)
(with-throw-handler (with-throw-handler
@ -511,10 +516,10 @@
;; Loop between reading tokens and skipping tokens via CPP logic. ;; Loop between reading tokens and skipping tokens via CPP logic.
(let iter ((pair (read-token))) (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) (case (car ppxs)
((keep) ((keep)
;;(simple-format #t "lx=>~S\n" pair) (simple-format #t "lx=>~S\n" pair)
pair) pair)
((skip-done skip-look) ((skip-done skip-look)
(iter (read-token))) (iter (read-token)))

117
module/nyacc/lang/c99/cpp.scm
View file

@ -29,6 +29,7 @@
#:use-module (nyacc lex) #:use-module (nyacc lex)
#:use-module (nyacc lang util) #:use-module (nyacc lang util)
#:use-module (rnrs arithmetic bitwise) #:use-module (rnrs arithmetic bitwise)
#:use-module (ice-9 match)
) )
(cond-expand (cond-expand
@ -37,6 +38,28 @@
(use-modules (ice-9 syncase))) (use-modules (ice-9 syncase)))
(mes)) (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 ;; @deffn read-ellipsis ch
;; read ellipsis ;; read ellipsis
(define (read-ellipsis ch) (define (read-ellipsis ch)
@ -46,6 +69,9 @@
(else #f))) (else #f)))
;; @deffn cpp-define => (define (name "ADD") (args "X" "Y") (repl "X+Y")) ;; @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 (cpp-define)
(define (p-args la) ;; parse args (define (p-args la) ;; parse args
@ -66,7 +92,7 @@
(define (p-rest la) ;; parse rest (define (p-rest la) ;; parse rest
(cond ((eof-object? la) "") (cond ((eof-object? la) "")
(else (else
(if (not (char=? #\=)) (unread-char ch)) ; handle ABC=DEF (if (not (char=? #\=)) (unread-char la)) ; handle ABC=DEF
(drain-input (current-input-port))))) (drain-input (current-input-port)))))
(let* ((name (read-c-ident (skip-il-ws (read-char)))) (let* ((name (read-c-ident (skip-il-ws (read-char))))
@ -77,44 +103,6 @@
`(define (name ,name) (repl ,repl))))) `(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 ;; @deffn cpp-include
;; Parse CPP include statement. ;; Parse CPP include statement.
(define (cpp-include) (define (cpp-include)
@ -162,51 +150,6 @@
(list (cons 'len-v len-v) (cons 'pat-v pat-v) (cons 'rto-v rto-v) (list (cons 'len-v len-v) (cons 'pat-v pat-v) (cons 'rto-v rto-v)
(cons 'mtab mtab) (cons 'act-v act-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) (define (cpp-err fmt . args)
(apply throw 'cpp-error fmt args)) (apply throw 'cpp-error fmt args))
@ -489,6 +432,12 @@
(cond (cond
((not rval) #f) ((not rval) #f)
((string=? rval "C99_ANY") #f) ; don't expand: could be anything ((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) ((member ident used) ident)
((string? rval) ((string? rval)
(let ((expd (expand-cpp-repl rval '() dict (cons ident used)))) (let ((expd (expand-cpp-repl rval '() dict (cons ident used))))