nyacc: starting to work on reframing
[mes.git] / module / nyacc / lang / c99 / body.scm
index 94db22a0661b45a651e631226e45240800ebbbd3..a01a4d7a23323f54900e2846e71b2c9f2dc177c7 100644 (file)
@@ -54,6 +54,7 @@
     ("stdio.h" "FILE" "size_t")
     ("stdlib.h" "div_t" "ldiv_t" "lldiv_t" "wchar_t")
     ("string.h" "size_t")
+    ("strings.h" "size_t")
     ("time.h" "time_t" "clock_t" "size_t")
     ("unistd.h" "size_t" "ssize_t" "div_t" "ldiv_t")
     ("wchar.h" "wchar_t" "wint_t" "mbstate_t" "size_t")
   (apply throw 'c99-error args))
 
 ;; @deffn read-cpp-line ch => #f | (cpp-xxxx)??
-;; Given if ch is #\# read a cpp-statement
-;; includes BUG: #define ABC 123 /* \n
+;; Given if ch is #\# read a cpp-statement.
+;; The standard implies that comments are tossed here but we keep them
+;; so that they can end up in the pretty-print output.
 (define (read-cpp-line ch)
   (if (not (eq? ch #\#)) #f
       (let iter ((cl '()) (ch (read-char)))
        (cond
+        ((eof-object? ch) (throw 'cpp-error "CPP lines must end in newline"))
         ((eq? ch #\newline) (unread-char ch) (list->string (reverse cl)))
         ((eq? ch #\\)
          (let ((c2 (read-char)))
                  (let ((c2 (read-char)))
                    (if (eqv? c2 #\/)
                        (iter (cons* #\/ #\* cl2) (read-char)) ;; keep comment
-                       ;;(iter cl (read-char)) ;; toss comment
                        (iter2 (cons #\* cl2) c2))))
                 (else
                  (iter2 (cons ch cl2) (read-char))))))
        ;; Return the first (tval . lval) pair not excluded by the CPP.
        (lambda ()
 
-         (define (exec-cpp-stmts?)     ; exec (vs pass to parser) CPP stmts?
+         (define (exec-cpp-stmts?) ; exec (vs pass to parser) CPP stmts?
            (eqv? mode 'code))
       
          (define (add-define tree)
             'cpp-error
             (lambda ()
               (let* ((defs (cpi-defs info))
-                     ;;(x (simple-format #t "eval-cpp-cond-text: ~S\n" text))
                      (rhs (cpp-expand-text text defs))
-                     ;;(x (simple-format #t "  rhs=>~S\n" rhs))
-                     (exp (parse-cpp-expr rhs))
-                     ;;(x (simple-format #t "  exp=>~S\n" exp))
-                     )
-                (if (not exp) (throw 'c99-error "CPP parse failed"))
+                     (exp (parse-cpp-expr rhs)))
                 (eval-cpp-expr exp defs)))
             (lambda (key fmt . args)
               (report-error fmt args)
            
          (define (eval-cpp-stmt stmt)
            (case (car stmt)
+             ;; includes
              ((include)
               (let* ((parg (cadr stmt)) (leng (string-length parg))
                      (file (substring parg 1 (1- leng)))
              ((undef)
               (rem-define (cadr stmt))
               (if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
+             ((error)
+              (if (exec-cpp-stmts?)
+                  (report-error "error: #error ~A" (cdr stmt))))
+             ((pragma) ;; std: implementation-defined if expanded
+              #t)
+
+             ;; control flow
              ((if) ;; covers (if ifdef ifndef)
               (cond
                ((exec-cpp-stmts?)
                 (let ((val (eval-cpp-cond-text (cadr stmt))))
+                  (simple-format #t "if ~S=> ~S\n" (cadr stmt) val)
                   (cond
                    ((not val) (p-err "unresolved: ~S" (cadr stmt)))
                    ((zero? val) (set! ppxs (cons* 'skip1-pop 'skip-look ppxs)))
                ((exec-cpp-stmts?)
                 (set! ppxs (cons 'skip1-pop (cdr ppxs))))
                (else (cpi-pop))))
-             ((error)
-              stmt)
+
              (else
               (error "unhandled cpp stmt")))
-           (cons 'cpp-stmt stmt))
+           (case (car stmt)
+             ((pragma) (cons 'cpp-pragma (cdr stmt)))
+             (else (cons 'cpp-stmt stmt))))
          
          (define (eval-cpp-line line)
+           ;;(simple-format #t "eval-cpp-line: ~S\n" line)
            (with-throw-handler
             'cpp-error
             (lambda () (eval-cpp-stmt (read-cpp-stmt line)))
             (lambda (key fmt . rest)
+              (display "body.399\n")
               (report-error fmt rest)
               (throw 'c99-error "CPP error"))))
 
          ;; Composition of @code{read-cpp-line} and @code{eval-cpp-line}.
+         ;; We should not be doing this!
          (define (read-cpp ch)
            (and=> (read-cpp-line ch) eval-cpp-line))
 
                 ((read-comm ch bol) => assc-$)
                 ((read-cpp ch) =>
                  (lambda (res) ;; if '() stmt expanded so re-read
+                   ;;(simple-format #t "read-cpp => ~S\n" res)
                    (if (pair? res) (assc-$ res) (iter (read-char)))))
                 (else (set! bol #f) (iter ch))))
               ((read-ident ch) =>
                (lambda (name)
+                 ;;(simple-format #t "read-ident=>~S\n" name)
                  (let ((symb (string->symbol name)))
                    (cond
                     ((and (x-def? name mode)
                           (expand-cpp-mref name (cpi-defs info)))
                      => (lambda (st)
+                          ;;(simple-format #t "body: st=~S\n" st)
                           (push-input (open-input-string st))
                           (iter (read-char))))
                     ((assq-ref keytab symb)
          (let iter ((pair (read-token)))
            (case (car ppxs)
              ((keep)
+              ;;(simple-format #t "lx=>~S\n" pair)
               pair)
              ((skip-done skip-look)
               (iter (read-token)))