;;; -*- Mode: Scheme; scheme48-package: c-groveller-output -*-

;;;; C Data Groveller
;;;; Output Generation

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

;;; By separating out each individual element, we avoid constructing a
;;; gigantic output closure: we instead make little ones, use them, and
;;; then let them quickly become garbage as we move on.  This is known
;;; as 'premature optimization.'

(define (write-grovel-prelude prelude port)
  ((sequence
     (line (c-comment "Emacs, this is -*- C -*- code.       "))
     newline
     (line (c-comment "THIS CODE IS AUTOMATICALLY GENERATED!"))
     (line (c-comment "Modify at your peril!                "))
     newline
     (cpp-system-include "stdio.h")
     prelude
     newline
     (line "int")
     (line "main (int argc, char *argv[])")
     (line "{")
     byte-order-detection-code
     (with-c-indentation 2
       (sequence
         (c-printf ";;; Emacs, this is -*- Scheme -*- code.\\n")
         (c-printf ";;;\\n")
         (c-printf ";;; THIS CODE IS AUTOMATICALLY GENERATED!\\n")
         (c-printf ";;; Modify at your peril!\\n\\n"))))
   port))

(define (write-grovel-postlude port)
  (write-grovel-item (c-return "0") port)
  ((line "}") port))

(define (write-grovel-item item port)
  ((with-c-indentation 2 item) port))

(define byte-order-detection-code "
  char *byte_order;
  union {
    char c[sizeof (long)];
    long l;
  } byte_order_test;

  byte_order_test.l = 1;
  if (1 == byte_order_test.c[0])
    byte_order = \"le\";
  else if (1 == byte_order_test.c[(sizeof (long)) - 1])
    byte_order = \"be\";
  else
    {
      fprintf (stderr, \"** Error: unknown byte order\\n\");
      fflush (stderr);
      return (-1);
    }
")

(define (c-constant-definition scheme c)
  ;; This is a bit of a hack, suggested by jamesjb.  It might be better
  ;; to alter the DEFINE syntax to include a type specification; e.g.,
  ;; (DEFINE INTERNET-ADDRESS/BROADCAST (UNSIGNED "INADDR_BROADCAST")).
  ;; This would generalize beyond even integers; for instance, (DEFINE
  ;; INTERNET-ADDRESS/ANY (INTEGER->BYTE-VECTOR "INADDR_ANY")) would be
  ;; a possibility.
  (c-call-statement
   "printf"
   (list (c-parenthesize
          (sequence "((" c ") < 0)"
                    " ? \"(define %s %d)\\n\""
                    " : \"(define %s %u)\\n\""))
         (stringify (symbol->string scheme))
         c)))

(define (scheme-constant-definition symbol value)
  (c-printf "(define %s %s)\\n"
            (stringify (symbol->string symbol))
            (stringify value)))

;;; (define scheme <C constant>), if defined
;;; (define scheme #f>), if not

(define (conditional-c-constant-definition scheme c)
  (cpp-ifdef c
             (c-constant-definition scheme c)
             (cpp-else)
             (scheme-constant-definition scheme "#f")))

;;; (define scheme <C constant>), for the first <C constant> defined in
;;; the list of alternatives.

(define (alternative-constant-definition scheme alternatives error)
  (cond ((null? alternatives)
         (scheme-constant-definition scheme "#f"))
        ((null? (cdr alternatives))
         (c-constant-definition scheme (car alternatives)))
        (else
         (cpp-if (cpp-defined? (car alternatives))
                 (c-constant-definition scheme (car alternatives))
                 (fold-right (lambda (alternative tail)
                               (sequence
                                 (cpp-elif (cpp-defined? alternative))
                                 (c-constant-definition scheme
                                                        alternative)
                                 tail))
                             (sequence)
                             (cdr alternatives))
                 (cpp-else)
                 error))))

(define (scheme-struct scheme-struct-name c-struct-name
                       field-specifiers)
  (sequence (c-printf "(define-c-struct %s %ld %s"
                      (stringify (writer scheme-struct-name))
                      (c-sizeof (c-struct-type c-struct-name))
                      "byte_order")
            (list-sequence
             (map (lambda (field-specifier)
                    (destructure (((keyword scheme-field-name
                                            c-field-name
                                            scheme-rep)
                                   field-specifier))
                      (c-printf "\\n  (field %ld %s %ld %s)"
                                (c-field-offset c-struct-name
                                                c-field-name)
                                (stringify (writer scheme-field-name))
                                (c-field-size c-struct-name
                                              c-field-name)
                                (stringify (writer scheme-rep)))))
                  field-specifiers))
            (c-printf ")\\n")))

(define (c-field-offset struct-name field-name)
  (c-cast "long"
          (c-cast (c-address-type)
                  (c-address-of
                   (c-zero-field struct-name field-name)))))

(define (c-field-size struct-name field-name)
  (c-sizeof (c-zero-field struct-name field-name)))

(define (c-zero-field struct-name field-name)
  (c-pointer-field (c-cast (c-struct-pointer-type struct-name)
                           "0")
                   field-name))

;;; Useful abbreviations

(define (c-printf control-string . arguments)
  (c-call-statement "printf"
                    ;; Careful with the control string here.  We don't
                    ;; want to escape it because we use \n, but any
                    ;; other naughty quotes & backslashes must be
                    ;; escaped manually.  It would be nice if printf(3)
                    ;; had a formatting directive for newlines, as CL
                    ;; FORMAT does, but noooo, they'd rather have a
                    ;; very hard time dealing with newline translation
                    ;; issues...
                    (cons (sequence #\" control-string #\")
                          arguments)))