crec.lsp

(define-macro (define-crecord record-name fields)
  (let* ((record-name-string (symbol->string record-name))
         (constructor-name (intern (string-append "MAKE-" record-name-string)))
         (indexer-name (intern (string-append record-name-string "-ADDRESS")))
         (size-name (intern (string-append record-name-string "-SIZE")))
         (field-macros '())
         (field-offset 0)
         (make-field-macros 
           (named-lambda make-field-macros (field-def)
             (let* ((field-name (first field-def))
                    (field-name-string (symbol->string field-name))
                    (field-type-name (second field-def))
                    (field-type (crecord-type field-type-name))
                    (field-is-array? (not (null? (cddr field-def))))
                    (field-count (if field-is-array? (third field-def) 1))
                    (field-size (get-crecord-type-size field-type))
                    (getter-name (intern (string-append record-name-string "-" field-name-string)))
                    (get-addr-name (intern (string-append record-name-string "-" field-name-string "-ADDRESS")))
                    (setter-name (intern (string-append "SET-" record-name-string "-" field-name-string "!")))
                    (offset-name (intern (string-append record-name-string "-" field-name-string "-OFFSET"))))
               (push! `(define-macro (,getter-name record &optional i)
                         (if i
                           `(get-crecord-field ,record ,(simplify-index ,field-offset ,field-size i) ,,field-type)
                           `(get-crecord-field ,record ,,field-offset ,,field-type))) field-macros)
               (push! `(define-macro (,get-addr-name record &optional i)
                         (if i
                           `(get-crecord-field-address ,record ,(simplify-index ,field-offset ,field-size i) 'pointer)
                           `(get-crecord-field-address ,record ,,field-offset 'pointer))) field-macros)
               (push! `(define-macro (,setter-name record value &optional i)
                         (if i
                           (let ((value i)	; looks better to have index before value
                                 (i value))
                             `(set-crecord-field! ,record ,(simplify-index ,field-offset ,field-size i) ,,field-type ,value))
                           `(set-crecord-field! ,record ,,field-offset ,,field-type ,value))) field-macros)
               (push! `(define ,offset-name ,field-offset) field-macros)
               (+ field-offset (* field-size field-count))))))
    (let loop ((fields fields))
      (when fields
        (let ((field-def (car fields)))
          (if (atom? (car field-def))
            (set! field-offset (make-field-macros field-def))
            (let ((new-offset field-offset))
              (let field-loop ((fields field-def))
                (when fields
                  (let* ((field-def (car fields))
                         (this-offset (make-field-macros field-def)))
                    (when (> this-offset new-offset)
                      (set! new-offset this-offset))
                    (field-loop (cdr fields)))))
              (set! field-offset new-offset)))
          (loop (cdr fields)))))
    (push! `',record-name field-macros)
    `(begin
       (define-macro (,constructor-name &optional size)
         (if size
           `(allocate-cmemory ',',record-name (* ,,field-offset ,size))
           `(allocate-cmemory ',',record-name ,,field-offset)))
       (define-macro (,indexer-name record i)
         `(get-crecord-field-address ,record (* ,,field-offset ,i) 'pointer))
       (define ,size-name ,field-offset)
       ,@(reverse field-macros))))

(define (simplify-index base size i)
  (let ((offset (if (number? i)
                  (* size i)
                  (if (= size 1)
                    i
                    `(* ,size ,i)))))
    (if (= base 0)
      offset
      (if (number? offset)
        (+ base offset)
        `(+ ,base ,offset)))))

(define (crecord-type name)
  (case name
    (char 1)
    (uchar 2)
    (short 3)
    (ushort 4)
    (int 5)
    (uint 6)
    (long 7)
    (ulong 8)
    (ptr 9)
    (else (error "unknown type ~S" name))))