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

nyacc: CPP working better now

Browse source
This commit is contained in:
Matt Wette 2017-01-15 08:47:49 -08:00 committed by Jan Nieuwenhuizen
parent 7e39956858
commit 50301b8fd7
3 changed files with 49 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -320,7 +320,6 @@
(exp (parse-cpp-expr rhs))) (exp (parse-cpp-expr rhs)))
(eval-cpp-expr exp defs))) (eval-cpp-expr exp defs)))
(lambda (key fmt . args) (lambda (key fmt . args)
(display "body.323\n")
(report-error fmt args) (report-error fmt args)
(throw 'c99-error "CPP error")))) (throw 'c99-error "CPP error"))))
@ -386,7 +385,8 @@
(set! ppxs (cons 'skip1-pop (cdr ppxs)))) (set! ppxs (cons 'skip1-pop (cdr ppxs))))
(else (cpi-pop)))) (else (cpi-pop))))
((error) ((error)
(if (exec-cpp-stmts?) (report-error "CPP error: ~S" (cdr stmt)))) (if (exec-cpp-stmts?)
(report-error "error: #error ~A" (cdr stmt))))
((pragma) ((pragma)
;; standard says implementation-defined if line is expanded ;; standard says implementation-defined if line is expanded
#t) #t)
@ -397,7 +397,6 @@
(else (cons 'cpp-stmt stmt)))) (else (cons 'cpp-stmt stmt))))
(define (eval-cpp-line line) (define (eval-cpp-line line)
(simple-format #t "line=~S\n" line)
(with-throw-handler (with-throw-handler
'cpp-error 'cpp-error
(lambda () (eval-cpp-stmt (read-cpp-stmt line))) (lambda () (eval-cpp-stmt (read-cpp-stmt line)))
@ -431,7 +430,6 @@
((and (x-def? name mode) ((and (x-def? name mode)
(expand-cpp-mref name (cpi-defs info))) (expand-cpp-mref name (cpi-defs info)))
=> (lambda (st) => (lambda (st)
(simple-format #t "st=~S\n" st)
(push-input (open-input-string st)) (push-input (open-input-string st))
(iter (read-char)))) (iter (read-char))))
((assq-ref keytab symb) ((assq-ref keytab symb)
@ -455,9 +453,7 @@
;; 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)))
(case (car ppxs) (case (car ppxs)
((keep) ((keep) pair)
;;(simple-format #t "lx=>~S\n" pair)
pair)
((skip-done skip-look) ((skip-done skip-look)
(iter (read-token))) (iter (read-token)))
((skip1-pop) ((skip1-pop)

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

@ -61,26 +61,27 @@ todo:
(letrec (letrec
((p-cppd ;; parse all ((p-cppd ;; parse all
(lambda () (lambda ()
(let* ((iden (read-c-ident (skip-ws (read-char)))) (let* ((iden (read-c-ident (skip-il-ws (read-char))))
;;(args (or (p-args (skip-ws (read-char))) '()))
;; "define ABC(ARG)" not the same as "define ABC (ARG)" ;; "define ABC(ARG)" not the same as "define ABC (ARG)"
(args (or (p-args (read-char)) '())) (args (or (p-args (read-char)) '()))
(rest (or (p-rest (skip-ws (read-char))) " "))) (rest (or (p-rest (skip-il-ws (read-char))) " ")))
(if (pair? args) (if (pair? args)
`(define (name ,iden) ,(cons 'args args) (repl ,rest)) `(define (name ,iden) ,(cons 'args args) (repl ,rest))
`(define (name ,iden) (repl ,rest)))))) `(define (name ,iden) (repl ,rest))))))
(p-args ;; parse args (p-args ;; parse args
(lambda (la) ;; unread la if no match :( (lambda (la) ;; unread la if no match :(
(if (eq? la #\() (if (eq? la #\()
(let iter ((args '()) (la (skip-ws (read-char)))) (let iter ((args '()) (la (skip-il-ws (read-char))))
(cond (cond
((eq? la #\)) (reverse args)) ((eq? la #\)) (reverse args))
((read-c-ident la) => ((read-c-ident la) =>
(lambda (arg) (iter (cons arg args) (skip-ws (read-char))))) (lambda (arg)
(iter (cons arg args) (skip-il-ws (read-char)))))
((read-ellipsis la) => ((read-ellipsis la) =>
(lambda (arg) (iter (cons arg args) (skip-ws (read-char))))) (lambda (arg)
(iter (cons arg args) (skip-il-ws (read-char)))))
((eq? la #\,) ((eq? la #\,)
(iter args (skip-ws (read-char)))))) (iter args (skip-il-ws (read-char))))))
(begin (if (char? la) (unread-char la)) #f)))) ;; CLEANUP (begin (if (char? la) (unread-char la)) #f)))) ;; CLEANUP
(p-rest ;; parse rest (p-rest ;; parse rest
(lambda (la) (lambda (la)
@ -91,7 +92,7 @@ todo:
;; @deffn cpp-include ;; @deffn cpp-include
;; Parse CPP include statement. ;; Parse CPP include statement.
(define (cpp-include) (define (cpp-include)
(let* ((beg-ch (skip-ws (read-char))) (let* ((beg-ch (skip-il-ws (read-char)))
(end-ch (if (eq? beg-ch #\<) #\> #\")) (end-ch (if (eq? beg-ch #\<) #\> #\"))
(path (let iter ((cl (list beg-ch)) (ch (read-char))) (path (let iter ((cl (list beg-ch)) (ch (read-char)))
(if (eq? ch end-ch) (list->string (reverse (cons ch cl))) (if (eq? ch end-ch) (list->string (reverse (cons ch cl)))
@ -108,14 +109,14 @@ todo:
;; To evaluate the @code{if} statements use @code{parse-cpp-expr} and ;; To evaluate the @code{if} statements use @code{parse-cpp-expr} and
;; @code{eval-cpp-expr}. ;; @code{eval-cpp-expr}.
(define (read-cpp-stmt line) (define (read-cpp-stmt line)
(define (rd-ident) (read-c-ident (skip-ws (read-char)))) (define (rd-ident) (read-c-ident (skip-il-ws (read-char))))
(define (rd-num) (and=> (read-c-num (skip-ws (read-char))) cdr)) (define (rd-num) (and=> (read-c-num (skip-il-ws (read-char))) cdr))
(define (rd-rest) (let ((ch (skip-ws (read-char)))) (define (rd-rest) (let ((ch (skip-il-ws (read-char))))
(if (not (eof-object? ch)) (unread-char ch)) (if (not (eof-object? ch)) (unread-char ch))
(drain-input (current-input-port)))) (drain-input (current-input-port))))
(with-input-from-string line (with-input-from-string line
(lambda () (lambda ()
(let ((cmd (string->symbol (read-c-ident (skip-ws (read-char)))))) (let ((cmd (string->symbol (read-c-ident (skip-il-ws (read-char))))))
(case cmd (case cmd
((include) (cpp-include)) ((include) (cpp-include))
((define) (cpp-define)) ((define) (cpp-define))

75
module/nyacc/lang/c99/cppbody.scm
View file

@ -18,12 +18,15 @@
(define (cpp-err fmt . args) (define (cpp-err fmt . args)
(apply throw 'cpp-error fmt args)) (apply throw 'cpp-error fmt args))
;;.@deffn skip-ws ch ;;.@deffn skip-il-ws ch
(define (skip-ws ch) ;; Skip in-line whitespace
(if (eof-object? ch) ch (define skip-il-ws
(if (char-set-contains? c:ws ch) (let ((il-ws (list->char-set '(#\space #\tab))))
(skip-ws (read-char)) (lambda (ch)
ch))) (cond
((eof-object? ch) ch)
((char-set-contains? il-ws ch) (skip-il-ws (read-char)))
(else ch)))))
;; Since we want to be able to get CPP statements with comment in tact ;; Since we want to be able to get CPP statements with comment in tact
;; (e.g., for passing to @code{pretty-print-c99}) we need to remove ;; (e.g., for passing to @code{pretty-print-c99}) we need to remove
@ -116,10 +119,6 @@
;; value) pairs which will be expanded as needed. This routine is called ;; value) pairs which will be expanded as needed. This routine is called
;; by collect-args, expand-cpp-repl and cpp-expand-text. ;; by collect-args, expand-cpp-repl and cpp-expand-text.
(define (scan-cpp-input argd dict used end-tok) (define (scan-cpp-input argd dict used end-tok)
(let ((res (x-scan-cpp-input argd dict used end-tok)))
(simple-format #t "scan=>~S\n" res)
res))
(define (x-scan-cpp-input argd dict used end-tok)
;; Works like this: scan tokens (comments, parens, strings, char's, etc). ;; Works like this: scan tokens (comments, parens, strings, char's, etc).
;; Tokens (i.e., strings) are collected in a (reverse ordered) list (stl) ;; Tokens (i.e., strings) are collected in a (reverse ordered) list (stl)
;; and merged together on return. Lone characters are collected in the ;; and merged together on return. Lone characters are collected in the
@ -139,28 +138,33 @@
;; We just scanned "defined", now need to scan the arg to inhibit expansion. ;; We just scanned "defined", now need to scan the arg to inhibit expansion.
;; For example, we have scanned "defined"; we now scan "(FOO)" or "FOO", and ;; For example, we have scanned "defined"; we now scan "(FOO)" or "FOO", and
;; return "defined(FOO)". We use ec (end-char) as state indicator: nul at ;; return "defined(FOO)". We use ec (end-char) as terminal char:
;; start, #\) on seeing #\( or #\nul if other. ;; #\) if starts with #( or #\nul if other.
(define (scan-defined-arg) (define (scan-defined-arg)
(let* ((ch (skip-ws ch)) (ec (if (char=? ch #\() #\) #\nul))) (let* ((ch (skip-il-ws (read-char)))
(let iter ((chl '(#\()) (ec ec) (ch ch)) (ec (if (char=? ch #\() #\) #\null)))
(let iter ((chl '(#\()) (ec ec) (ch (if (char=? ec #\)) (read-char) ch)))
(cond (cond
((and (eof-object? ch) (char=? #\nul ec)) ((eof-object? ch)
(string-append "defined" (list->string (reverse (cons #\) chl))))) (if (char=? ec #\null)
((eof-object? ch) (cpp-err "illegal argument to `defined'")) (string-append "defined" (list->string (reverse (cons #\) chl))))
((and (char=? ch #\)) (char=? ec #\))) (cpp-err "illegal argument to `defined'")))
(string-append "defined" (list->string (reverse (cons ch chl)))))
((char-set-contains? c:ir ch) ((char-set-contains? c:ir ch)
(iter (cons ch chl) ec (read-char))) (iter (cons ch chl) ec (read-char)))
(else (cpp-err "illegal identifier")))))) ((char=? ec #\))
(if (char=? #\) (skip-il-ws ch))
(string-append "defined" (list->string (reverse (cons #\) chl))))
(cpp-err "garbage in argument to `defined'")))
((char=? ec #\null) ;; past identifier
(string-append "defined" (list->string (reverse (cons #\) chl)))))
(else
(cpp-err "illegal argument to `defined'"))))))
(let iter ((stl '()) ; string list (i.e., tokens) (let iter ((stl '()) ; string list (i.e., tokens)
(chl '()) ; char-list (current list of input chars) (chl '()) ; char-list (current list of input chars)
(nxt #f) ; next string (nxt #f) ; next string
(lvl 0) ; level (lvl 0) ; level
(ch (read-char))) ; next character (ch (read-char))) ; next character
(simple-format #t "iter ch=~S stl=~S chl=~S nxt=~S lvl=~S ch=~S\n"
ch stl chl nxt lvl ch)
(cond (cond
;; have item to add, but first add in char's ;; have item to add, but first add in char's
(nxt (iter (cons nxt (add-chl chl stl)) '() #f lvl ch)) (nxt (iter (cons nxt (add-chl chl stl)) '() #f lvl ch))
@ -189,20 +193,17 @@
(lambda (st) (iter stl chl st lvl (read-char)))) (lambda (st) (iter stl chl st lvl (read-char))))
((read-c-ident ch) => ((read-c-ident ch) =>
(lambda (iden) (lambda (iden)
;;(simple-format #t " read-c-ident => ~S\n" iden)
(if (equal? iden "defined") (if (equal? iden "defined")
;; "defined" is a special case ;; "defined" is a special case
(iter stl chl (scan-defined-arg) lvl (read-char)) (let ((arg (scan-defined-arg)))
(iter stl chl arg lvl (read-char)))
;; otherwise ... ;; otherwise ...
(let* ((aval (assoc-ref argd iden)) ; lookup argument (let* ((aval (assoc-ref argd iden)) ; lookup argument
(rval (assoc-ref dict iden))) ; lookup macro def (rval (assoc-ref dict iden))) ; lookup macro def
;;(simple-format #t " aval=~S rval=~S\n" aval rval)
(cond (cond
((and (pair? stl) (string=? "#" (car stl))) ((and (pair? stl) (string=? "#" (car stl)))
;;(simple-format #t "TEST iden=~S aval=~S\n" iden aval)
(iter (cdr stl) chl (stringify aval) lvl (read-char))) (iter (cdr stl) chl (stringify aval) lvl (read-char)))
((and (pair? stl) (string=? "##" (car stl))) ((and (pair? stl) (string=? "##" (car stl)))
;;(simple-format #t "TEST iden=~S aval=~S\n" iden aval)
(iter (cddr stl) chl (conjoin (cadr stl) aval) lvl (read-char))) (iter (cddr stl) chl (conjoin (cadr stl) aval) lvl (read-char)))
((member iden used) ; name used ((member iden used) ; name used
(iter stl chl iden lvl (read-char))) (iter stl chl iden lvl (read-char)))
@ -216,7 +217,6 @@
(newl (expand-cpp-repl text argd dict (cons iden used)))) (newl (expand-cpp-repl text argd dict (cons iden used))))
(iter stl chl newl lvl (read-char)))) (iter stl chl newl lvl (read-char))))
(else ; normal identifier (else ; normal identifier
;;(simple-format #t "normal id stl=~S\n" stl)
(iter stl chl iden lvl (read-char)))))))) (iter stl chl iden lvl (read-char))))))))
(else (else
(iter stl (cons ch chl) #f lvl (read-char)))))) (iter stl (cons ch chl) #f lvl (read-char))))))
@ -231,23 +231,17 @@
;; TODO clean this up ;; TODO clean this up
;; should be looking at #\( and eat up to matching #\) ;; should be looking at #\( and eat up to matching #\)
(define (collect-args argl argd dict used) (define (collect-args argl argd dict used)
(simple-format #t "collect-args: argl=~S argd=~S dict=~S\n" argl argd dict) (let iter ((argl argl) (argv '()) (ch (skip-il-ws (read-char))))
(let iter ((argl argl) (argv '()) (ch (skip-ws (read-char))))
;; ch should always be #\(, #\, or #\) ;; ch should always be #\(, #\, or #\)
(simple-format #t " ch=~S\n" ch)
(cond (cond
((eqv? ch #\)) (reverse argv)) ((eqv? ch #\)) (reverse argv))
((null? argl) (cpp-err "arg count")) ((null? argl) (cpp-err "arg count"))
((and (null? (cdr argl)) (string=? (car argl) "...")) ((and (null? (cdr argl)) (string=? (car argl) "..."))
;; depending on scan-cpp-input being called before read-char (let ((val (scan-cpp-input argd dict used #\))))
(iter (cdr argl) (iter (cdr argl) (acons "__VA_ARGS__" val argv) (read-char))))
(acons "__VA_ARGS__" (scan-cpp-input argd dict used #\)) argv)
(read-char)))
((or (eqv? ch #\() (eqv? ch #\,)) ((or (eqv? ch #\() (eqv? ch #\,))
;; depending on scan-cpp-input being called before read-char (let ((val (scan-cpp-input argd dict used #\,)))
(iter (cdr argl) (iter (cdr argl) (acons (car argl) val argv) (read-char))))
(acons (car argl) (scan-cpp-input argd dict used #\,) argv)
(read-char)))
(else (error "coding error, ch=" ch))))) (else (error "coding error, ch=" ch)))))
;; @deffn expand-cpp-repl ;; @deffn expand-cpp-repl
@ -277,9 +271,6 @@
(let ((expd (expand-cpp-repl rval '() dict (cons ident used)))) (let ((expd (expand-cpp-repl rval '() dict (cons ident used))))
expd)) expd))
((pair? rval) ((pair? rval)
(let ((ch (read-char)))
(simple-format #t "expand-cpp-mref: ch=~S\n" ch)
(unread-char ch))
(let* ((argl (car rval)) (repl (cdr rval)) (let* ((argl (car rval)) (repl (cdr rval))
(argd (collect-args argl '() dict '())) (argd (collect-args argl '() dict '()))
(expd (expand-cpp-repl repl argd dict (cons ident used)))) (expd (expand-cpp-repl repl argd dict (cons ident used))))