From ea7f0b3a01d310428bb39698be711635c105dca3 Mon Sep 17 00:00:00 2001 From: Matt Wette Date: Sat, 11 Feb 2017 13:04:38 -0800 Subject: [PATCH] nyacc: working on cpp issues --- module/nyacc/lang/c99/body.scm | 69 ++++++++++--------- module/nyacc/lang/c99/cpp.scm | 117 ++++++++++----------------------- 2 files changed, 70 insertions(+), 116 deletions(-) diff --git a/module/nyacc/lang/c99/body.scm b/module/nyacc/lang/c99/body.scm index d270a895..762a6907 100644 --- a/module/nyacc/lang/c99/body.scm +++ b/module/nyacc/lang/c99/body.scm @@ -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))) diff --git a/module/nyacc/lang/c99/cpp.scm b/module/nyacc/lang/c99/cpp.scm index b4d8b3ca..b3f657de 100644 --- a/module/nyacc/lang/c99/cpp.scm +++ b/module/nyacc/lang/c99/cpp.scm @@ -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 . - -(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))))