#lang racket/base

(define re:start "^START ([a-z]+);")
(define re:end "^END ([a-z]+);")

(define re:form "^([a-zA-Z0-9_]+) [{]")

(define re:mark "^ mark:")
(define re:size "^ size:")
(define re:size-or-more "^ (?:size|more):")
(define re:fixup-start "^ fixup:")
(define re:close "^}")

(define re:const-size (regexp "^[ \t]*gcBYTES_TO_WORDS[(]sizeof[(][A-Za-z0-9_]*[)][)];[ \t]*$"))

(define (do-form name)
  (let ([read-lines
	 (lambda (re:done)
	   (let loop ()
	     (let ([l (read-line)])
	       (if (eof-object? l)
		   (error 'mkmark.rkt "unexpected EOF")
		   (cond
		    [(regexp-match re:done l)
		     null]
		    [(or (regexp-match re:mark l)
                         (regexp-match re:size-or-more l)
			 (regexp-match re:fixup-start l))
		     (error 'mkmark.rkt "unexpected label: ~a at ~a" l
			    (file-position (current-input-port)))]
		    [(regexp-match re:close l)
		     (error 'mkmark.rkt "unexpected close")]
		    [else (cons l (loop))])))))]
	[print-lines (lambda (l [skip-rx #f])
                       (let loop ([l l] [skip? #f])
                         (cond
                          [(null? l) (void)]
                          [(and skip-rx (regexp-match? skip-rx (car l)))
                           (loop (cdr l) (not skip?))]
                          [skip?
                           (loop (cdr l) #t)]
                          [(regexp-match? #rx"(START|END)_[A-Z]+_ONLY;" (car l))
                           (loop (cdr l) skip?)]
                          [else
                           (printf "~a\n" (car l))
                           (loop (cdr l) #f)])))])
    (let ([prefix (read-lines re:mark)]
	  [mark (read-lines re:size-or-more)]
	  [fixup (if (regexp-match-peek re:fixup-start (current-input-port))
                     (begin
                       (regexp-match re:fixup-start (current-input-port))
                       (read-lines re:size))
                     null)]
	  [size (read-lines re:close)])
      (printf "static int ~a_SIZE(void *p, struct NewGC *gc) {\n" name)
      (print-lines prefix)
      (printf "  return\n")
      (print-lines size)
      (printf "}\n\n")

      (printf "static int ~a_MARK(void *p, struct NewGC *gc) {\n" name)
      (print-lines prefix)
      (print-lines (map (lambda (s)
			  (regexp-replace* 
			   "FIXUP_ONLY[(]([^;]*;)[)]" 
			   (regexp-replace* 
			    "FIXUP2_TYPED_NOW[(][^,]*," 
			    s 
			    "MARK2(")
			   ""))
			mark)
                   #rx"FIXUP_ONLY")
      (printf "  return\n")
      (print-lines size)
      (printf "}\n\n")

      (printf "static int ~a_FIXUP(void *p, struct NewGC *gc) {\n" name)
      (print-lines prefix)
      (print-lines (map (lambda (s)
			  (regexp-replace* 
			   "FIXUP_ONLY[(]([^;]*;)[)]" 
			   (regexp-replace* 
			    "MARK(?!_ONLY)" 
			    s 
			    "FIXUP")
			   "\\1"))
			(append
                         mark
                         fixup))
                   #rx"MARK_ONLY")
      (printf "  return\n")
      (print-lines size)
      (printf "}\n\n")

      (printf "#define ~a_IS_ATOMIC ~a\n" 
	      name
	      (if (null? mark)
		  "1" 
		  "0"))

      (printf "#define ~a_IS_CONST_SIZE ~a\n\n" 
	      name
	      (if (and (= 1 (length size))
		       (regexp-match re:const-size (car size)))
		  "1" 
		  "0")))))

(let loop ()
  (let ([l (read-line)])
    (unless (eof-object? l)
      (cond
       [(regexp-match re:start l)
	=> (lambda (m)
	     (let ([who (cadr m)]
                   [so (open-output-bytes)])
               (parameterize ([current-output-port so])
                 (printf "/* >>>> Generated by mkmark.rkt from mzmarksrc.c <<<< */\n")
                 (let file-loop ()
                   (let ([l (read-line)])
                     (if (eof-object? l)
                         (error 'mkmark.rkt "unexpected EOF")
                         (cond
                          [(regexp-match re:end l)
                           => (lambda (m) (void))]
                          [(regexp-match re:form l)
                           => (lambda (m)
                                (do-form (cadr m))
                                (file-loop))]
                          [else (printf "~a\n" l)
                                (file-loop)])))))
               (let* ([b (get-output-bytes so)]
                      [file (build-path
                             (vector-ref (current-command-line-arguments) 0)
                             (format "mzmark_~a.inc" who))]
                      [so2 (open-output-bytes)])
                 (when (file-exists? file)
                   (call-with-input-file*
                    file
                    (lambda (i)
                      (let loop ()
                        (let ([s (read-bytes 4096 i)])
                          (unless (eof-object? s)
                            (write-bytes s so2)
                            (loop)))))))
                 (let ([b2 (get-output-bytes so2)])
                   (unless (equal? b b2)
                     (printf "Writing ~a\n" file)
                     (call-with-output-file*
                      file
                      #:exists 'truncate/replace
                      (lambda (o)
                        (write-bytes b o)))))))
             (loop))]
       [else (loop)]))))
