grovel.scm

#!

(import (scheme base))
(import (gambit match))
(import (c-groveler))

(define (deb x)
  (parameterize ((current-output-port (current-error-port)))
    (write x)
    (newline)))

(define (symbol-middle symbol prefix-string suffix-string)
  (let ((string (symbol->string symbol)))
    (and (>= (string-length string)
             (+ (string-length prefix-string)
                (string-length suffix-string)))
         (substring string
                    (string-length prefix-string)
                    (- (string-length string)
                       (string-length suffix-string))))))

(define (main input-filename)
  (let ((input (with-input-from-file input-filename read-all)))
    (let ((g (make-c-groveler)))
      (grovel-c-include g "errno.h")
      (for-each (lambda (form)
                  (match form
                    ((include ,header)
                     (cond ((and (symbol? header)
                                 (symbol-middle header "<" ">"))
                            => (lambda (filename)
                                 (grovel-c-include g filename)))
                           (else
                            (error "Huh include?" form))))
                    ((quote-c . ,strings)
                     (apply grovel-c-quote g strings))
                    ((constant signed ,constant)
                     (grovel-c-constant-signed g constant))
                    ((constant unsigned ,constant)
                     (grovel-c-constant-unsigned g constant))
                    ((constant string ,constant)
                     (grovel-c-constant-string g constant))
                    ((constant-ifdef signed ,constant)
                     (grovel-c-constant-ifdef-signed g constant))
                    ((constant-ifdef unsigned ,constant)
                     (grovel-c-constant-ifdef-unsigned g constant))
                    ((call-constant string ,function ,constant)
                     (grovel-c-call-constant-string g function constant))
                    ((call-constant-ifdef string ,function ,constant)
                     (grovel-c-call-constant-ifdef-string g function constant))
                    ((type-signedness ,type)
                     (grovel-c-type-signedness g type))
                    ((type-size ,type)
                     (grovel-c-type-size g type))
                    ((type-slot ,type ,slot)
                     (grovel-c-type-slot g type slot))
                    (,_
                     (error "Huh?" form))))
                input)
      (write-string (c-groveler->string g)))))

(apply main (cdr (command-line)))