;;; -*- Mode: Scheme; scheme48-package: define-c-struct-expander -*-

;;;; C Data Groveller
;;;; DEFINE-C-STRUCT Macro Expander

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

;;; (DEFINE-C-STRUCT <name> <size> <default-byte-order>
;;;   (FIELD <offset> <name> <size> <representation>)
;;;   ...)
;;;
;;; Example:
;;;
;;;   (define-c-struct sockaddr-in 16 be
;;;     (field 1 FAMILY  1 integer)
;;;     (field 2 PORT    2 (be integer))
;;;     (field 4 ADDRESS 4 (array 1 integer)))
;;;
;;;     =>
;;;
;;;   (define sockaddr-in-size 16)
;;;
;;;   (define (allocate-sockaddr-in)
;;;     (make-byte-vector 16 0))
;;;
;;;   (define (make-sockaddr-in family port address)
;;;     (let ((sockaddr-in (allocate-sockaddr-in)))
;;;       (store-sockaddr-in! sockaddr-in 0 family port address)
;;;       sockaddr-in))
;;;
;;;   (define (store-sockaddr-in! bytev base family port address)
;;;     (set-sockaddr-in.family! sockaddr-in base family)
;;;     (set-sockaddr-in.port! sockaddr-in base port)
;;;     (copy-bytes! address 0 bytev (+ base 4) 4))
;;;
;;;   (define sockaddr-in.family-offset 1)
;;;   (define sockaddr-in.family-size 1)
;;;
;;;   (define (sockaddr-in.family bv base)
;;;     (byte-vector-ref bv (+ base 1)))
;;;
;;;   (define (set-sockaddr-in.family! bv base family)
;;;     (byte-vector-set! bv (+ base 1) (bitwise-and family #xFF)))
;;;
;;;   (define sockaddr-in.port-offset 2)
;;;   (define sockaddr-in.port-size 2)
;;;
;;;   (define (sockaddr-in.port bv base)
;;;     (bitwise-ior (arithmetic-shift (byte-vector-ref bv (+ base 2))
;;;                                    8)
;;;                  (byte-vector-ref bv (+ base 3))))
;;;
;;;   (define (set-sockaddr-in.port! bv base port)
;;;     (byte-vector-set! bv (+ base 2)
;;;                       (bitwise-and (arithmetic-shift port -8)
;;;                                    #xFF))
;;;     (byte-vector-set! bv (+ base 3) (bitwise-and port #xFF)))
;;;
;;;   (define sockaddr-in.address-offset 4)
;;;   (define sockaddr-in.address-size 4)
;;;
;;;   (define (sockaddr-in.address-ref bv base index)
;;;     (byte-vector-ref bv (+ base 4 index)))
;;;
;;;   (define (sockaddr-in.address-set! bv base index value)
;;;     (byte-vector-set! bv (+ base 4 index)
;;;                       (bitwise-and value #xFF)))

;;; This code would be a lot nicer with syntactic closures.

(define (expand-define-c-struct form rename compare)
  (check-define-c-struct-syntax form rename compare)
  (with-renamer rename
    (lambda ()
      (destructure (((keyword prefix size byte-order . fields) form))
        (with-byte-order byte-order '(for default byte order)
          (lambda ()
            (make-begin
             `(,(make-definition (make-size-name prefix) size)
               ,(make-definition (make-allocator-name prefix)
                                 (make-allocator size))
               ,(make-definition (make-maker-name prefix)
                                 (make-maker prefix fields))
               ,(make-definition (make-store-name prefix)
                                 (make-store prefix fields))
               ,@(append-map (field-processor prefix) fields)))))))))

(define (make-allocator size)
  (make-lambda '() `(,(rename 'MAKE-BYTE-VECTOR) ,size 0)))

(define (generate-field-variables fields)
  (map (lambda (field)
         (destructure (((keyword offset name size rep) field))
           (generate-symbol name)))
       fields))

(define (make-maker prefix fields)
  (let ((field-vars (generate-field-variables fields)))
    (make-lambda field-vars
                 (let ((%allocate (make-allocator-name prefix))
                       (%store (make-store-name prefix)))
                   (make-let '(BV) `((,%allocate))
                             (make-begin
                              `((,%store ,(rename 'BV) 0
                                         ,@(map rename field-vars))
                                ,(rename 'BV))))))))

(define (make-store prefix fields)
  (let ((field-vars (generate-field-variables fields)))
    (make-lambda `(BV BASE ,@field-vars)
                 (make-begin
                  (append (make-store-body (rename 'BV) (rename 'BASE)
                                           field-vars
                                           prefix fields)
                          ;; Ensure that the body is non-empty, in case
                          ;; there are no fields.
                          `((,(rename 'IF) #F #F)))))))

(define (make-store-body bv base field-vars prefix fields)
  (map (lambda (var field)
         (let ((var (rename var)))
           (destructure (((keyword offset name size rep) field))
             (if (array-representation? rep)
                 (let ((%copy-bytes! (rename 'COPY-BYTES!)))
                   `(,%copy-bytes! ,var 0
                                   ,bv ,(make-offset base offset)
                                   ,size))
                 (let ((%setter (make-fixed-setter-name prefix name)))
                   `(,%setter ,bv ,base ,var))))))
       field-vars
       fields))

(define (field-processor prefix)
  (lambda (field)
    (destructure (((offset name size rep) (cdr field)))
      `(,(make-definition (make-field-size-name   prefix name) size)
        ,(make-definition (make-field-offset-name prefix name) offset)
        ,@(make-setters prefix name size offset rep)
        ;; Anything else that should be defined for the field?
        ))))

(define (make-setters prefix name size offset rep)
  (cond ((array-representation rep)
         => (lambda (unit-rep.dims)
              (let ((unit-rep (car unit-rep.dims))
                    (dims (cdr unit-rep.dims)))
                `(,(make-indexed-accessor prefix name size offset
                                          dims unit-rep)
                  ,(make-indexed-setter prefix name size offset
                                        dims unit-rep)))))
        ((byte-ordered-representation rep)
         => (lambda (byte-order.rep)
              (with-byte-order (car byte-order.rep)
                  `(in representation for ,name)
                (lambda ()
                  (make-setters prefix name size offset
                                (cdr byte-order.rep))))))
        (else
         `(,(make-fixed-accessor prefix name size offset rep)
           ,(make-fixed-setter prefix name size offset rep)))))

;;;; Syntax Checker

(define (check-define-c-struct-syntax form rename compare)
  (syntax-check form compare
                `(DEFINE-C-STRUCT ,(lambda (prefix)
                                     (or (symbol? prefix)
                                         (and (pair? prefix)
                                              (symbol? (car prefix))
                                              (null? (cdr prefix)))))
                   ,integer?
                   (FIELD ,integer? ,symbol? ,integer?
                          ,representation?)
                   ...)
                (lambda (form)          ;Unique name lists
                  (destructure (((keyword prefix size . fields) form))
                    (list (map (lambda (field)
                                 (destructure (((keyword offset
                                                         name
                                                         size
                                                         rep)
                                                field))
                                   name))
                               fields))))))

(define (syntax-check form compare syntax compute-unique-name-lists)
  (values))

(define (representation? obj)
  (cond ((symbol? obj)
         (named-representation? obj))
        ((pair? obj)
         (or (byte-ordered-representation? obj)
             (array-representation? obj)))
        (else #f)))

(define (named-representation? obj)
  (and (assq obj *accessors*) #t))

(define (byte-ordered-representation? obj)
  (and (byte-ordered-representation obj) #t))

(define (byte-ordered-representation obj)
  (and (pair? obj)
       (pair? (cdr obj))
       (null? (cddr obj))
       (let ((byte-order (car obj))
             (rep (cadr obj)))
         (and (memq byte-order known-byte-orders)
              (cons byte-order rep)))))

(define (array-representation? obj)
  (and (array-representation obj) #t))

(define (array-representation obj)
  (and (pair? obj)
       (list? (cdr obj))
       (eq? 'ARRAY (car obj))
       (let loop ((obj (cdr obj))
                  (dimensions '()))
         (and (number? (car obj))
              (let ((dimensions (cons (car obj) dimensions))
                    (tail (cdr obj)))
                (and (pair? tail)
                     (if (symbol? (car tail))
                         (and (null? (cdr tail))
                              (named-representation? (car tail))
                              (cons (car tail) (reverse dimensions)))
                         (loop tail dimensions))))))))

(define (make-fixed-accessor prefix field size offset rep)
  (make-definition (make-fixed-accessor-name prefix field)
                   (make-lambda '(BV BASE)
                                (load (rename 'BV)
                                      size
                                      (make-offset (rename 'BASE)
                                                   offset)
                                      rep
                                      `(,prefix ,field)))))

(define (make-fixed-setter prefix field size offset rep)
  (make-definition (make-fixed-setter-name prefix field)
                   (let ((value-var (generate-symbol field)))
                     (make-lambda `(BV BASE ,value-var)
                                  (store (rename 'BV)
                                         size
                                         (make-offset (rename 'BASE)
                                                      offset)
                                         rep
                                         (rename value-var)
                                         `(,prefix ,field))))))

(define (make-indexed-accessor prefix field size offset dimensions rep)
  (make-definition
   (make-indexed-accessor-name prefix field)
   (let ((indices (list-tabulate (length dimensions)
                                 (lambda (i)
                                   (generate-symbol "INDEX." i)))))
     (make-lambda `(BV BASE ,@indices)
                  (receive (size offset)
                           (make-indexed-offset (rename 'BASE) offset
                                                indices dimensions)
                    (load (rename 'BV) size offset rep
                          `(,prefix ,field)))))))

(define (make-indexed-setter prefix field size offset dimensions rep)
  (make-definition
   (make-indexed-setter-name prefix field)
   (let ((value-var (generate-symbol field))
         (indices (list-tabulate (length dimensions)
                                 (lambda (i)
                                   (generate-symbol "INDEX." i)))))
     (make-lambda `(BV BASE ,@indices ,value-var)
                  (receive (size offset)
                           (make-indexed-offset (rename 'BASE) offset
                                                indices dimensions)
                    (store (rename 'BV) size offset rep
                           (rename value-var)
                           `(,prefix ,field)))))))

(define (make-indexed-offset base offset indices dimensions)
  (let ((%+ (rename '+))
        (%* (rename '*)))
    (let loop ((ds dimensions)
               (is indices)
               (offset (make-offset base offset)))
      (let ((offset `(,%+ ,offset (,%* ,(rename (car is)) ,(car ds)))))
        (if (null? (cdr ds))
            (values (car ds) offset)
            (loop (cdr ds) (cdr is) offset))))))

(define (maybe-car x)
  (if (pair? x)
      (car x)
      x))

(define (make-size-name prefix)
  (concatenate-symbol (maybe-car prefix) "-SIZE"))

(define (make-allocator-name prefix)
  (concatenate-symbol "ALLOCATE-" (maybe-car prefix)))

(define (make-maker-name prefix)
  (concatenate-symbol "MAKE-" (maybe-car prefix)))

(define (make-store-name prefix)
  (concatenate-symbol "STORE-" (maybe-car prefix) "!"))

(define (maybe-prefix prefix string)
  (if (pair? prefix)
      ""
      (concatenate-symbol prefix string)))

(define (make-field-size-name prefix field)
  (concatenate-symbol (maybe-prefix prefix ".") field "-SIZE"))

(define (make-field-offset-name prefix field)
  (concatenate-symbol (maybe-prefix prefix ".") field "-OFFSET"))

(define (make-fixed-accessor-name prefix field)
  (concatenate-symbol (maybe-prefix prefix ".") field))

(define (make-fixed-setter-name prefix field)
  (concatenate-symbol "SET-" (maybe-prefix prefix ".") field "!"))

(define (make-indexed-accessor-name prefix field)
  (concatenate-symbol (maybe-prefix prefix ".") field "-REF"))

(define (make-indexed-setter-name prefix field)
  (concatenate-symbol (maybe-prefix prefix ".") field "-SET!"))

(define (make-definition name expression)
  `(,(rename 'DEFINE) ,name ,expression))

(define (make-lambda variables body)
  `(,(rename 'LAMBDA) ,(map rename variables) ,body))

(define (make-let variables values body)
  `(,(make-lambda variables body) ,@values))

(define (make-begin body)
  `(,(rename 'BEGIN) ,@body))

(define (make-offset base offset)
  (if (zero? offset)
      base
      `(,(rename '+) ,base ,offset)))

(define $rename (make-fluid
                 ;; Default value for development & debugging.
                 (lambda (identifier) identifier)))

(define (rename identifier) ((fluid $rename) identifier))

(define (with-renamer renamer thunk)
  (let-fluid $rename renamer thunk))

(define define-c-struct-auxiliary-names
  '(+ * ARITHMETIC-SHIFT ASCII->CHAR BEGIN BITWISE-AND BITWISE-IOR
      BYTE-VECTOR-REF BYTE-VECTOR-SET! CHAR->ASCII COPY-BYTES! DEFINE
      LAMBDA MAKE-BYTE-VECTOR))

(define known-byte-orders '(BE LE))

(define $byte-order (make-fluid #f))

(define (with-byte-order byte-order context thunk)
  (if (memq byte-order known-byte-orders)
      (let-fluid $byte-order byte-order thunk)
      (error "unknown byte order" byte-order context)))

(define (current-byte-order) (fluid $byte-order))

(define (load bv size base rep context)
  (cond ((assq rep *accessors*)
         => (lambda (probe)
              ((cdr probe) bv size base context)))
        (else
         (error "unrecognized representation specifier"
                rep
                context))))

(define *accessors* '())

(define (define-accessor name accessor)
  (cond ((assq name *accessors*)
         => (lambda (probe)
              (set-cdr! probe accessor)))
        (else
         (set! *accessors* (cons (cons name accessor) *accessors*)))))

(define-accessor 'ASCII-CHAR
  (lambda (bv size base context)
    `(,(rename 'ASCII->CHAR) ,(load-byte bv base 0 0))))

(define-accessor 'INTEGER
  (lambda (bv size base context)
    (if (= size 1)
        (load-byte bv base 0 0)
        ((lambda (load-bytes)
           (make-let '(BASE) (list base)
                     `(,(rename 'BITWISE-IOR)
                       ,@(load-bytes bv size (rename 'BASE)))))
         (case (current-byte-order)
           ((BE) load-bytes-be)
           ((LE) load-bytes-le)
           (else (error "unknown byte order"
                        (current-byte-order)
                        context)))))))

(define (load-byte bv base offset shift)
  (let* ((index (make-offset base offset))
         (load `(,(rename 'BYTE-VECTOR-REF) ,bv ,index)))
    (if (zero? shift)
        load
        `(,(rename 'ARITHMETIC-SHIFT) ,load ,shift))))

(define (load-bytes-be bv count base)
  (let loop ((offset 0)
             (shift (* count 8))
             (result '()))
    (if (zero? shift)
        (reverse result)                ;Looks prettier.  This could be
        (let ((shift (- shift 8)))      ;done otherwise, but whatever.
          (loop (+ offset 1)
                shift
                (cons (load-byte bv base offset shift)
                      result))))))

(define (load-bytes-le bv count base)
  (let loop ((offset 0)
             (shift 0)
             (result '()))
    (if (= offset count)
        (reverse result)
        (loop (+ offset 1)
              (+ shift 8)
              (cons (load-byte bv base offset shift)
                    result)))))

(define (store bv size base rep value context)
  (cond ((assq rep *setters*)
         => (lambda (probe)
              ((cdr probe) bv size base value context)))
        (else
         (error "unrecognized representation specifier"
                rep
                context))))

(define *setters* '())

(define (define-setter name setter)
  (cond ((assq name *setters*)
         => (lambda (probe)
              (set-cdr! probe setter)))
        (else
         (set! *setters* (cons (cons name setter) *setters*)))))

(define-setter 'ASCII-CHAR
  (lambda (bv size base value context)
    ;; This has a superfluous masking operation to enforce bytes, but
    ;; that is probably not too much of an issue.
    (store-byte bv base 0 0 `(,(rename 'CHAR->ASCII) ,value))))

(define-setter 'INTEGER
  (lambda (bv size base value context)
    (if (= size 1)
        (store-byte bv base 0 0 value)
        ((lambda (store-bytes)
           (make-let '(BASE) (list base)
                     (make-begin
                      (store-bytes bv size (rename 'BASE) value))))
         (case (current-byte-order)
           ((BE) store-bytes-be)
           ((LE) store-bytes-le)
           (else (error "unknown byte order"
                        (current-byte-order)
                        context)))))))

(define (store-byte bv base offset shift value)
  (let ((index (make-offset base offset))
        (byte `(,(rename 'BITWISE-AND)
                ,(if (zero? shift)
                     value
                     `(,(rename 'ARITHMETIC-SHIFT) ,value ,shift))
                #xFF)))
    `(,(rename 'BYTE-VECTOR-SET!) ,bv ,index ,byte)))

(define (store-bytes-be bv count base value)
  (let loop ((offset 0)
             (shift (- (* count 8)))
             (result '()))
    (if (zero? shift)
        (reverse result)
        (let ((shift (+ shift 8)))
          (loop (+ offset 1)
                shift
                (cons (store-byte bv base offset shift value)
                      result))))))

(define (store-bytes-le bv count base value)
  (let loop ((offset 0)
             (shift 0)
             (result '()))
    (if (= offset count)
        (reverse result)
        (loop (+ offset 1)
              (- shift 8)
              (cons (store-byte bv base offset shift value)
                    result)))))

;;;; Utilities

(define *symbol-generator-count* 0)

(define (generate-symbol . parts)
  (let ((count *symbol-generator-count*))
    (set! *symbol-generator-count* (+ count 1))
    (apply concatenate-symbol "G" count "." parts)))

(define (concatenate-symbol . parts)
  (string->symbol
   (apply string-append
          (map (lambda (part)
                 (cond ((symbol? part) (symbol->string part))
                       ((string? part) (string-reader-case part))
                       ((number? part) (number->string part 10))
                       (else (error "invalid symbol part"
                                    part))))
               parts))))

(define char-reader-case
  (if (char=? (string-ref (symbol->string 'T) 0)
              #\t)
      char-downcase
      char-upcase))

(define (string-reader-case string)
  (let* ((length (string-length string))
         (result (make-string length)))
    (do ((i 0 (+ i 1)))
        ((= i length))
      (string-set! result i (char-reader-case (string-ref string i))))
    result))