;;;; support code for cplusplus.syntax


(use big-chicken numbers)
(import matchable miscmacros)


(define (property? x y)
  (get (string->symbol (car x)) y))
 
(line-filter
 (let ((line (irregex "^[ \t]*#[ \t]*([0-9]+)[ \t]+\"([^\"]*)\".*\n")))
   (lambda (state)
     (let ((str (state-buffer state)))
       (cond ((irregex-search line str (state-position state)) =>
	      (lambda (m)
		(let ((end (irregex-match-end-index m)))
		  (make-state 
		   str
		   (sub1 end)		; keep "\n" at end
		   (sub1 (string->number (irregex-match-substring m 1)))
		   end
		   (irregex-match-substring m 2)))))
	     (else #f))))))

(define (mfail loc . args)
  (flush-output)
  (fprintf (current-error-port) "~a: " loc)
  (for-each (cute display <> (current-error-port)) args)
  (newline (current-error-port))
  (reset))

(define typedef-list '())

(define (register-typedef id t)
  (let ((id (string->symbol id)))
    (put! id 'cxx-typedef t)
    (push! id typedef-list)))

(define enum-list '())

(define (register-enum id e)
  (let ((id (string->symbol id)))
    (put! id 'cxx-enum e)
    (push! id enum-list)))

(define class-list '())

(define (register-class id c)
  (let ((id (string->symbol id)))
    (put! id 'cxx-class c)
    (push! id class-list)))

(define (simple-declaration-action loc dss idl)
  (match (list dss idl)
    (((("typedef" . _))
      (((('init_declarator
	  _
	  decl
	  #f)
	()))))
     (register-typedef 
      (or (declarator->id decl)
	  (mfail loc "invalid typedef syntax: " decl))
      #t))
    (((("typedef" . _)) ((#f)))
     (mfail loc "redefinition of type"));
    (((("typedef" . _) . _) . _)
     (mfail loc "invalid typedef syntax: " (list dss idl)))
    (_ #f))
  (default-action))

(define (declarator->id decl)
  (let walk ((decl decl))
    (match decl
      (('ptr_operator _ decl) (walk decl))
      (('direct_declarator _ "(" decl ")" _) (walk decl))
      (('direct_declarator _ ('declarator_id _ #f ('unqualified_id _ id)) . _)
       id)
      (('declarator _ _ decl) (walk decl))
      (('declarator_id _ #f ('unqualified_id _ id)) id)
      (_ #f))))

(define (enum-specifier-action loc id el)
  (let ((id (if (null? id) (gensym "<enum>") (car id))))
    (register-enum id el)
    (default-action)))

(define (class-specifier-action loc ch ms)
  ;;(pp `(c-s-a ,loc ,ch ,ms) (current-error-port))
  (default-action)	    ;XXX
  #;(bomb))				;XXX

(define (char-literal str)
  (let ((long #f))
    (when (char=? #\L (string-ref str 0))
      (set! long #t)
      (set! str (substring str 1)))
    `(literal 
      ,(@)
      ,((if long
	    integer->char
	    (lambda (n) `(long ,(integer->char n))))
	(cond ((irregex-match "'(0.*)'" str) =>
	       (lambda (m)
		 (string->number (irregex-match-substring m 1) 8)))
	      ((irregex-match "'\\\\x(.+)'" str) =>
	       (lambda (m)
		 (string->number (irregex-match-substring m 1) 16)))
	      ((char=? #\\ (string-ref str 1))
	       (char->integer (string-ref str 2)))
	      (else (char->integer (string-ref str 1))))))))

(define (string-literal strs)
  (let ((loc (@)))
    `(literal
      ,loc
      ,(let loop ((strs strs) (long #f) (all '()))
	 (if (null? strs)
	     (let ((str (string-concatenate-reverse all)))
	       (if long 
		   `(long ,str)
		   str))
	     (let ((str (car strs)))
	       (cond ((char=? #\L (string-ref str 0))
		      (loop
		       (cdr strs)
		       #t
		       (cons (parse-string-literal (@) (substring str 1) #t)
			     all)))
		     (long 
		      (mfail loc "can not mix wide and non-wide string literals"))
		     (else 
		      (loop 
		       (cdr strs)
		       #f
		       (cons (parse-string-literal (@) str #f) all))))))))))

(define hex-digits (irregex "^[0-9a-fA-F]+"))
(define octal-digits (irregex "^[0-7]{1,3}"))

(define (parse-string-literal loc str wide) ;XXX "wide" currently ignored
  (let ((len (sub1 (string-length str)))
	(out (open-output-string)))
    (define (emit c)
      (write-char c out))
    (let loop ((i 1))
      (if (fx>= i len)
	  (get-output-string out)
	  (match (string-ref str i)
	    (#\\ (cond ((fx= i (fx- len 1))
			(emit #\\)
			(get-output-string out))
		       (else
			(let ((c2 (string-ref str (fx+ i 1))))
			  (cond ((char=? c2 #\x)
				 (let ((m (irregex-search hex-digits str (fx+ i 2))))
				   (cond (m
					  (emit (integer->char 
						 (string->number 
						  (irregex-match-substring m 0)
						  16)))
					  (loop (irregex-match-end-index m)))
					 (else 
					  (emit #\x)
					  (loop (fx+ i 2))))))
				((char-numeric? c2)
				 (let ((m (irregex-search octal-digits str (fx+ i 1))))
				   (emit (integer->char 
					  (string->number 
					   (irregex-match-substring m 0)
					   8)))
				   (loop (irregex-match-end-index m))))
				(else
				 (emit c2)
				 (loop (fx+ i 2))))))))
	    (c (emit c)
	       (loop (fx+ i 1))))))))

(define (integer-literal str base)
  (let* ((m (irregex-match "([^uUlL]+)([uUlL]*)" str))
	 (n (string->number (irregex-match-substring m 1) base))
	 (q (string-downcase (irregex-match-substring m 2))))
    `(literal 
      ,(@)
      ,((o (if (string-index q #\u)
	       (lambda (n) `(unsigned ,n))
	       identity)
	   (if (string-index q #\l)
	       (lambda (n) `(long ,n))
	       identity)
	   (constantly n))
	n))))

(define (floating-literal str)
  (let* ((m (irregex-match "([^flFL]+)([flFL])?" str))
	 (n (string->number (irregex-match-substring m 1)))
	 (q (irregex-match-substring m 2)))
    `(literal
      ,(@)
      ,(if q
	   (if (string-ci=? q "l")
	       `(double ,n)
	       `(float ,n))
	   `(float ,n)))))