define-data.k

(require "osdefs.k")

(define-function data-type-size (type)
  (cond
    ((= type 'char)		sizeof-char)
    ((= type 'short)		sizeof-short)
    ((= type 'wchar)		sizeof-wchar)
    ((= type 'int)		sizeof-int)
    ((= type 'int32)		sizeof-int32)
    ((= type 'int64)		sizeof-int64)
    ((= type 'long)		sizeof-long)
    ((= type 'longlong)		sizeof-longlong)
    ((= type 'float)		sizeof-float)
    ((= type 'double)		sizeof-double)
    ((= type 'longdouble)	sizeof-longdouble)
    ((= type 'pointer)		sizeof-pointer)
    (else			(error "unknown data field type: "type))))

(define-function data-field-size (field)
  (let* ((type  (cadr field))
	 (size  (data-type-size type))
	 (count (and (caddr field) (eval (caddr field)))))
    (* (or count 1) size)))

(define-function data-type-alignment (type)
  (cond
    ((= type 'char)		alignof-char)
    ((= type 'short)		alignof-short)
    ((= type 'wchar)		alignof-wchar)
    ((= type 'int)		alignof-int)
    ((= type 'int32)		alignof-int32)
    ((= type 'int64)		alignof-int64)
    ((= type 'long)		alignof-long)
    ((= type 'longlong)		alignof-longlong)
    ((= type 'float)		alignof-float)
    ((= type 'double)		alignof-double)
    ((= type 'longdouble)	alignof-longdouble)
    ((= type 'pointer)		alignof-pointer)
    (else			(error "unknown data field type: "type))))

(define-function data-field-alignment (field)
  (let* ((type (cadr field)))
    (data-type-alignment type)))

(define-function define-data-size (fields)
  (if (pair? fields)
      (+ (data-field-size (car fields))
	 (define-data-size (cdr fields)))
    0))

(define-function make-data-accessors (prefix offset fields)
  (and (pair? fields)
       (let* ((field  	 (car  fields))
	      (name   	 (car  field))
	      (type   	 (cadr field))
	      (size   	 (data-field-size field))
	      (alignment (data-field-alignment field))
	      (foff	 (align offset alignment))
	      (facc	 foff)
	      (sig       '(self)))
	 (println offset)
	 (println sig)
	 (println facc)
	 (when (caddr field)
	   (set sig '(self index))
	   (set facc (list 'list (list 'quote '+) facc (list 'list '* (println (data-type-size type)) 'index))))
	 (println sig)
	 (println facc)
	 (cons (dumpln (list 'define-form
			      (concat-symbol prefix name)
			      sig
			      (list 'println
			      (list 'list (list 'quote (concat-symbol type '-at)) 'self facc 1))))
	       (make-data-accessors prefix (+ foff size) (cdr fields))))))

(define-function make-data-accessors (prefix offset fields)
  (and (pair? fields)
       (let* ((field  	 (car  fields))
	      (name   	 (car  field))
	      (type   	 (cadr field))
	      (size   	 (data-field-size field))
	      (alignment (data-field-alignment field))
	      (foff	 (align offset alignment))
	      (facc	 foff)
	      (sig       '(self)))
	 (when (caddr field)
	   (set sig  '(self index))
	   (set facc `(+ ,facc (* ,(data-type-size type) ,(list 'unquote 'index)))))
	 (cons `(define-form ,(concat-symbol prefix name) ,sig
		  `(,(concat-symbol type '-at) ,(list 'unquote 'self) ,facc 1))
	       (make-data-accessors prefix (+ foff size) (cdr fields))))))

(define-form define-data (name . fields)
  (let ((type (%allocate-type name))
	(size (define-data-size fields)))
    (set-array-at %structure-sizes type size)
     `(let ()
	(define ,name ,type)
	(define-function ,(concat-symbol 'new- name) () (allocate-atomic ,type ,size))
	(define-constant ,(concat-symbol 'sizeof- name) ,size)
	,@(make-data-accessors (concat-symbol name '-) 0 fields)
	)))