;;; nyacc/lang/c99/util.scm - C parser utilities

;; Copyright (C) 2015-2019,2022 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.

;;; Code:

(define-module (nyacc lang c99 util)
  #:export (c99-def-help
            c99-std-help
            get-sys-cpp-defs get-sys-inc-dirs split-cpp-defs 
            remove-comments remove-comments!
            remove-inc-trees merge-includes!
            move-attributes attrl->attrs attrs->attrl extract-attr
            elifify
            ;; deprecated:
            merge-inc-trees! get-gcc-cpp-defs get-gcc-inc-dirs
            )
  #:use-module (nyacc lang util)
  #:use-module (nyacc lang sx-util)
  #:use-module ((srfi srfi-1) #:select (append-reverse fold fold-right))
  #:use-module (srfi srfi-2)            ; and-let*
  #:use-module (sxml fold)
  #:use-module (ice-9 popen)            ; gen-gcc-cpp-defs
  #:use-module (ice-9 rdelim)           ; gen-gcc-cpp-defs
  #:use-module (ice-9 match))

(define c99-def-help
  (let ((base
         '(("__builtin"
            "__builtin_va_list=void*"
            "__inline__=inline" "__inline=__inline__"
            "__restrict__=restrict" "__restrict=__restrict__"
            "__signed__=signed" "__signed=__signed__"
            "asm(X)=__asm__(X)" "__asm(X)=__asm__(X)"
            "__attribute(X)=__attribute__(X)"
            "__volatile__=volatile" "__volatile=__volatile__"
            "__extension__=" "__extension=__extension__"
            "asm=__asm__" "__asm=__asm__"))))
    (cond
     ((string-contains %host-type "apple-darwin")
      (cons
       '("<Availability.h>"
         "__API_AVAILABLE(X,...)=" "__API_UNAVAILABLE(X,...)="
         "__API_DEPRECATED(X,Y)=" "__API_DEPRECATED_WITH_REPLACEMENT(X,Y)="
         "__IOS_AVAILABLE(X,...)=" "__IOS_DEPRECATED(X,Y)=" "__IOS_PROHIBITED="
         "__OSX_AVAILABLE(X,...)=" "__OSX_AVAILABLE_STARTING(X,...)="
         "__OSX_UNAVAILABLE=" "__OSX_AVAILABLE_BUT_DEPRECATED(X,...)="
         "__OS_AVAILABILITY_MSG(X,...)="
         "__TVOS_AVAILABLE(X)=" "__TVOS_DEPRECATED(X,...)=" "__TVOS_PROHIBITED="
         "__WATCHOS_AVAILABLE(X)=" "__WATCHOS_DEPRECATED(X)="
         "__WATCHOS_PROHIBITED=") base))
     (else base))))

;; include-helper for C99 std
(define c99-std-help
  (append
   c99-def-help
   '(("alloca.h")
     ("complex.h" "complex" "imaginary" "_Imaginary_I=C99_ANY" "I=C99_ANY")
     ("ctype.h")
     ("fenv.h" "fenv_t" "fexcept_t")
     ("float.h" "float_t" "FLT_MAX=C99_ANY" "DBL_MAX=C99_ANY")
     ("inttypes.h"
      "int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
      "int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
      "int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
      "int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t"
      "imaxdiv_t")
     ("limits.h"
      "INT_MIN=C99_ANY" "INT_MAX=C99_ANY" "LONG_MIN=C99_ANY" "LONG_MAX=C99_ANY")
     ("math.h" "float_t" "double_t")
     ("regex.h" "regex_t" "regmatch_t")
     ("setjmp.h" "jmp_buf")
     ("signal.h" "sig_atomic_t")
     ("stdarg.h" "va_list")
     ("stddef.h" "ptrdiff_t" "size_t" "wchar_t")
     ("stdint.h"
      "int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
      "int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
      "int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
      "int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t")
     ("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")
     ("wctype.h" "wctrans_t" "wctype_t" "wint_t"))))

(define (resolve-CC CC)
  (cond
   (CC CC)
   ((getenv "CC") => identity)
   (else "gcc")))

;; @deffn {Procedure} convert-def line
;; Convert string in gcc cpp defs to pair of strings for term and replacement.
;; @end deffn
(define (convert-line line)
  (with-input-from-string line
    (lambda ()
      (let loop ((term '()) (acc '()) (st 0) (ch (read-char)))
        (case st
          ((0) ;; skip #define
           (if (char=? ch #\space)
               (loop term acc 1 (read-char))
               (loop term acc 0 (read-char))))
          ((1) ;; read term
           (if (char=? ch #\space)
               (loop (reverse-list->string acc) '() 2 (read-char))
               (loop term (cons ch acc) st (read-char))))
          ((2) ;; read rest
           (if (or (eof-object? ch) (char=? ch #\newline))
               (string-append term "=" (reverse-list->string acc))
               (loop term (cons ch acc) st (read-char)))))))))

;; @deffn {Procedure} get-sys-cpp-defs [args] [#:CC "gcc"] => '("ABC=123" ...)
;; Generate a list of default defines produced by gcc (or other comiler).
;; If keyword arg @arg{CC} is not provided this procedure looks for environment
;; variable @code{"CC"}, else it defaults to @code{"gcc"}.
;; @end deffn
(define* (get-sys-cpp-defs #:optional (args '()) #:key CC)
  ;; @code{"gcc -dM -E"} will generate lines like @code{"#define ABC 123"}.
  ;; We generate and return a list like @code{'(("ABC" . "123") ...)}.
  (let* ((cmd (string-append (resolve-CC CC) " -dM -E - </dev/null"))
         (ip (open-input-pipe cmd)))
    (let loop ((line (read-line ip 'trim)))
      (if (eof-object? line) '()
          (cons (convert-line line) (loop (read-line ip 'trim)))))))


;; @deffn {Procedure} get-sys-inc-dirs [args] [#:CC "gcc"] =>
;; Generate a list of compiler-internal include directories (for cc).  If
;; keyword arg @arg{CC} is not provided this procedure looks for environment
;; variable @code{"CC"}, else it defaults to @code{"gcc"}.
;; @end deffn
(define* (get-sys-inc-dirs #:optional (args '()) #:key CC)
  (let ((ip (open-input-pipe (string-append
                              (resolve-CC CC) " -E -Wp,-v - </dev/null 2>&1"))))
    (let loop ((dirs '()) (grab #f) (line (read-line ip 'trim)))
      (cond
       ((eof-object? line) (reverse dirs))
       ((string=? line "#include <...> search starts here:")
        (loop dirs #t (read-line ip 'trim)))
       ((string=? line "End of search list.") dirs)
       (grab
        (loop (cons (string-trim-both line) dirs)
              grab (read-line ip 'trim)))
       (else
        (loop dirs grab (read-line ip 'trim)))))))

(define (add-cppdef def dict)
  (let ((x2st (string-index def #\())
        (x3 (string-index def #\=)))
    (cond
     (x2st dict)
     (x3 (acons (substring def 0 x3) (substring def (1+ x3)) dict))
     (else dict))))

;; @deffn {Procedure} split-cpp-defs defs [dict]
;; Given list of defs as returned by @code{get-sys-cpp-defs} (e.g.,
;; @code{"ABC=123", ...}) return list of pairs (e.g.,
;; @code{(("ABC" . "123") ...)}).
;; @end deffn
(define* (split-cpp-defs defs #:optional (dict '()))
  (fold-right add-cppdef dict defs))
      
;; @deffn {Procedure} remove-inc-trees tree
;; Remove the trees included with cpp-include statements.
;; @example
;; '(... (cpp-stmt (include "<foo.h>" (trans-unit ...))) ...)
;; => '(... (cpp-stmt (include "<foo.h>")) ...)
;; @end example
;; @end deffn
(define (remove-inc-trees tree)
  (if (not (eqv? 'trans-unit (car tree)))
      (throw 'nyacc-error "expecting c-tree"))
  (tl->list
   (fold
    (lambda (elt res)
      (tl-append res (if (and (eqv? 'cpp-stmt (sx-tag elt))
                              (eqv? 'include (sx-tag (sx-ref elt 1))))
                         `(cpp-stmt (include ,(sx-ref* elt 1 1)))
                         elt)))
    (make-tl 'trans-unit) (sx-tail tree))))

;; @deffn {Procedure} merge-includes! tree => tree
;; This will (recursively) merge code from cpp-includes into the tree.
;; @example
;; (trans-unit
;;  (decl (a))
;;  (cpp-stmt (include "<hello.h>" (trans-unit (decl (b)))))
;;  (decl (c)))
;; =>
;; (trans-unit (decl (a)) (decl (b)) (decl (c)))
;; @end example
;; @end deffn
(define (merge-includes! tree)
  (define (merge-tail pl tl)
    (cond
     ((null? tl) pl)
     ((sx-match (car tl)
        ((cpp-stmt (include ,file (trans-unit . ,kids))) kids)
        (,_ #f)) =>
        (lambda (kids)
          (set-cdr! pl kids)
          (let ((pn (merge-tail pl kids)))
            (set-cdr! pn (cdr tl))
            (merge-tail pn (cdr tl)))))
     (else (merge-tail tl (cdr tl)))))

  (merge-tail tree (cdr tree))
  tree)

;; --- attributes ----------------------

(define (join-string-literal str-lit)
  (sx-list 'string (sx-attr str-lit) (string-join (sx-tail str-lit) "")))

;; used in c99-spec actions for attribute-specifiers
(define (attr-expr-list->string attr-expr-list)
  (string-append "(" (string-join (cdr attr-expr-list) ",") ")"))

;; ((attribute-list ...) (type-spec ...) (attribute-list ...)) =>
;;   (values (attribute-list ...)  ((type-spec ...) ...))

;; @deffn extract-attr tail => (values attr-tree tail)
;; Extract attributes from a sexp tail.
;; @end deffn
(define (extract-attr tail) ;; => (values attr-tree tail)
  (let loop ((atl '()) (tail1 '()) (tail0 tail))
    (cond
     ((null? tail0)
      (if (null? atl)
          (values '() tail)
          (values `(attribute-list . ,atl) (reverse tail1))))
     ((eq? 'attribute-list (sx-tag (car tail0)))
      (loop (append (sx-tail (car tail0)) atl) tail1 (cdr tail0)))
     (else
      (loop atl (cons (car tail0) tail1) (cdr tail0))))))

;; (attribute-list (attribute (ident "__packed__")) ...)
;;  =>
;; (attributes "__packed__;...")
;; OR
;; () => ()
(define (attrl->attrs attr-list)
  (define (spec->str spec)
    (sx-match spec
      ((ident ,name) name)
      ((attribute ,name) (spec->str name))
      ((attribute ,name ,args)
       (string-append (spec->str name) "(" (spec->str args) ")"))
      ((attr-expr-list . ,expr-list)
       (string-join (map spec->str expr-list) ","))
      ((fixed ,val) val)
      ((float ,val) val)
      ((char ,val) val)
      ((string . ,val) (string-append "\"" (string-join val "") "\""))
      ((type-name (decl-spec-list (type-spec ,spec))) (spec->str spec))
      ((fixed-type ,name) name)
      ((float-type ,name) name)
      (,_ (sferr "c99/util: missed ~S\n" spec) "MISSED")))
  (if (null? attr-list) '()
      `(attributes ,(string-join (map spec->str (sx-tail attr-list)) ";"))))

;; (attributes "__packed__;__aligned__;__alignof__(8)")
;;   =>
;; (attribute-list (attribute "__packed
;; OR
;; #f => #f
(use-modules (nyacc lex))

(define (astng->atree form)
  (define a-mtab
    '(("(" . lparen) ((")" . rparen))
      ("," . comma) ($ident . ident)))
  (define attlexgen (make-lexer-generator a-mtab))
  (define attlex (attlexgen))

  (with-input-from-string form
    (lambda ()
      (define (p-expr-list lx) ;; see 'lparen
        (and
         (eq? 'lparen (car lx))
         (let loop ((args '()) (lx (attlex)))
           (case (car lx)
             ((rparen) `(attr-expr-list . ,args))
             ((comma) (loop args (attlex)))
             (else (p-expr lx))))))
      (define (p-expr lx)
        #f)
      (let ((lx (attlex)))
        (sferr "lx=~S\n" lx)
        (case (car lx)
          ((ident)
           (let* ((id (cdr lx)) (lx (attlex)))
             (case (car lx)
               (($end) `(attribute ,id))
               ((lparen) `(attribute ,id ,(p-expr-list lx)))
               (else (throw 'nyacc-error "error ~S" lx)))))
          (else (throw 'nyacc-error "missed ~S" lx)))))))
                
(define (attrs->attrl attr-sexp)
  (and
   attr-sexp 
   (let* ((attrs (cadr attr-sexp))
          (attl (string-split attrs #\;)))
     `(attribute-list ,@(map astng->atree attl)))))

;; @deffn {Procedure} move-attributes sexp
;; Given a sexpr, combine attribute-list kids and move to attribute ??
;; @example
;; (decl (decl-spec-list
;;         (attributes "__packed__" "__aligned__")
;;         (attributes "__alignof__(8)"))
;;         (type-spec (fixed-type "int")))
;;       (declr-init-list ...))
;;  =>
;; (decl (decl-spec-list
;;         (@ (attributes "__packed__;__aligned__;__alignof__(8)"))
;;         (type-spec (fixed-type "int")))
;;       (declr-init-list ...))
;; @end example
;; @end deffn
(define (move-attributes sexp)
  (let ((tag (sx-tag sexp)) (attr (sx-attr sexp)) (tail (sx-tail sexp)))
    (call-with-values (lambda () (extract-attr tail))
      (lambda (attrl stail)
        (sx-cons*
         tag 
         (cond
          ((null? attrl) attr)
          ((null? attr)`(@ ,(attrl->attrs attrl)))
          (else (append attr (list (attrl->attrs attrl)))))
         stail)))))

;; --- random stuff 

;; @deffn {Procedure} remove-comments sx0 => sx1
;; Remove comments from the parse tree @var{sx0} generated by @code{parse-c99}.
;; @end deffn
(define (remove-comments tree)
  (define (rem-com sx)
    (match sx
      ('() sx)
      (`((@ (comment . ,_)) . ,tail) (rem-com tail))
      (`((@ (comment . ,_) . ,rest) . ,tail) `((@ rest) . ,(rem-com tail)))
      (`((comment . ,_) . ,tail) (rem-com tail))
      ((head . tail) (cons (rem-com head) (rem-com tail)))
      (atom atom)))
  (rem-com tree))

(define (remove-comments! sx0)
  (define (merge-tail pl tl)
    (match tl
     ('() pl)
     (`((comment . ,_) . ,tail)
      (set-cdr! pl tail)
      (merge-tail pl tail))
     (`((@ (comment . ,_)) . ,tail)
      (set-cdr! pl tail)
      (merge-tail pl tail))
     (`((@ . ,attr) . ,tail)
      (set-car! tl `(@ . ,(assq-remove! attr 'comment)))
      (merge-tail tl (cdr tl)))
     (((h . t) . tail)
      (merge-tail (car tl) t)
      (merge-tail tl tail))
     ((_ . tail) (merge-tail tl (cdr tl)))))
  (merge-tail sx0 (cdr sx0))
  sx0)

;; @deffn {Procedure} elifify tree => tree
;; This procedure will find patterns of
;; @example
;; (if cond-1 then-part-1
;;            (if cond-2 then-part-2
;;                       else-part-2
;; @end example
;; @noindent
;; and convert to
;; @example
;; (if cond-1 then-part-1
;;            (elif cond-2 then-part-2)
;;            else-part-2
;; @end example
;; @end deffn
(define (elifify tree)
  (define (fU tree)
    (sx-match tree
      ((if ,x1 ,t1 (if ,x2 ,t2 (else-if ,x3 ,t3) . ,rest))
       `(if ,x1 ,t1 (else-if ,x2 ,t2) (else-if ,x3 ,t3) . ,rest))
      ((if ,x1 ,t1 (if ,x2 ,t2 . ,rest))
       `(if ,x1 ,t1 (else-if ,x2 ,t2) . ,rest))
      (,_
       tree)))
  (foldt fU identity tree))


;; === deprecated =============================================================

(define get-gcc-cpp-defs get-sys-cpp-defs)
(define get-gcc-inc-dirs get-sys-inc-dirs)

(define (merge-inc-trees! tree)

  ;; @item find-span (trans-unit a b c) => ((a . +->) . (c . '())
  (define (find-span tree)
    (cond
     ((not (pair? tree)) '())           ; maybe parse failed
     ((not (eqv? 'trans-unit (car tree))) (throw 'c99-error "expecting c-tree"))
     ((null? (cdr tree)) (throw 'c99-error "null c99-tree"))
     (else
      (let ((fp tree))                  ; first pair
        (let loop ((lp tree)            ; last pair
                   (np (cdr tree)))     ; next pair
          (cond
           ((null? np) (cons (cdr fp) lp))
           ;; The following is an ugly hack to find cpp-include
           ;; with trans-unit attached.
           ((and-let* ((expr (car np))
                       ((eqv? 'cpp-stmt (car expr)))
                       ((eqv? 'include (caadr expr)))
                       (rest (cddadr expr))
                       ((pair? rest))
                       (span (find-span (car rest))))
              (set-cdr! lp (car span))
              (loop (cdr span) (cdr np))))
           (else
            (set-cdr! lp np)
            (loop np (cdr np)))))))))

  ;; Use cons to generate a new reference:
  ;; (cons (car tree) (car (find-span tree)))
  ;; or not:
  (find-span tree)
  tree)


;; --- last line ---
