;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
;;;; 
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
;;;; 
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (system foreign unions)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module ((srfi srfi-1) #:select (fold every))
  #:use-module ((rnrs base)   #:select (assert))
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:export (<union>
	    union
	    union-ref
	    alignof*
	    sizeof*
            make-c-struct*
            parse-c-struct*))


(define (tree-map f tree . trees)
  (cond ((null? tree)       '())
	((list? (car tree)) (cons (tree-map f (car tree)) 
				  (tree-map f (cdr tree))))
	(else               (cons (f (car tree))
				  (tree-map f (cdr tree))))))


;;+TODO: memoize alignof and sizeof
(define-record-type <union>
  (%make-union members)
  union?
  (members %union-members))

(set-record-type-printer! <union>
  (lambda (union port)
    (display "(union " port)
    (map (lambda (x)
	   (display x port)
	   (write-char #\Space port))
	 (%union-members union))
    (write-char #\) port)))

(define (union . members)
  "Used to build a union type specifier. MEMBERS should be an
assoc. list, where keys are used to access each union member in
`union-ref`."
  (assert (every list? members))
  (%make-union members))

(define (union-ref union key)
  (or (assq-ref (%union-members union) key)
      (error 'invalid-arg "union-ref" key)))

(define (union-members union)
  "Returns a list of all the variants of a union (the MEMBERS
assoc. list that was given to `union` without its keys)."
  (map cdr (%union-members union)))

;; represents a padding (a space) in a C struct
(define-record-type <pad>
  (pad offset)
  pad?
  (offset pad-offset))

(set-record-type-printer! <pad>
  (lambda (pad port)
    (simple-format port "(pad ~a)" (pad-offset pad))))


(define (padding? types)
  "Returns #t if the only primitive types in TYPES are paddings."
  (cond ((null? types)       #t)
        ((list? (car types)) (and (padding? (car types))
                                  (padding? (cdr types))))
        (else                (and (pad? (car types))
                                  (padding? (cdr types))))))
;; (align offset alignment) → smallest multiple of alignment that is
;;                            greater than or equal to offset.
;;                            alignment must be a power of 2.
(define align (@@ (system foreign) align))

(define (alignof* type)
  "A variant of alignof that accepts unions (and paddings)."
  (define (maxalign l)
    (fold (lambda (x m) (max m (alignof* x))) 1 l))
  (cond ((union? type) (maxalign (union-members type)))
	((pad?   type) 1)
	((list?  type) (maxalign type))
	(else          (alignof  type))))

;;; note: until Guile 2.1.0, sizeof does not consider structures
;;; trailing padding (this is corrected in commit
;;; cff1d39b2003470b5dcdab988e279587ae2eed8c). Therefore, the
;;; following version of sizeof reimplements the computation of a
;;; structure’s size.

(define (sizeof* type)
  "A variant of sizeof that accepts unions (and paddings)."
  (define (maxsize l)
    (fold (lambda (x m) (max m (sizeof* x))) 0 l))
  (define (sumsize l)
    (fold (lambda (x s) (+   s (sizeof* x))) 0 l))
  (cond ((union? type) (maxsize (union-members type)))
	((pad?   type) (pad-offset type))
	((list?  type) (let ((struct-alignment (alignof* type)))
			 (align
			  (fold (lambda (type offset)
				  (+ (align offset (alignof* type))
				     (sizeof* type)))
				0
				type)
			  struct-alignment)))
	(else (sizeof type))))

(define (union-ref-padded union key)
  (cond (key
         (let* ((type   (union-ref union key))
                (offset (- (sizeof* union) (sizeof* type))))
           (append type (if (> offset 0)
                            (list (pad offset))
                            '()))))
        (else
         (list (pad (sizeof* union))))))

(define (replace-unions types union-refs)
  (let* ((stack         (list-copy union-refs)))
    (let lp ((types types))
      (cond ((null? types)        '())
	    ((list? (car types))  (cons (lp (car types))
					(lp (cdr types))))
	    ((union? (car types))
	     (when (null? stack)
	       (throw 'invalid-arg "replace-unions" union-refs))
	     (let ((key (car stack)))
	       (set! stack (cdr stack))
	       (cons (lp (union-ref-padded (car types) key))
		     (lp (cdr types)))))
	    (else                (cons (car types)
				       (lp (cdr types))))))))

;; file separed for copyright reasons
(include "unions-read-write.scm")