(datatype type
  (pointer ty)
  (array size ty)
  (function from-tys to-ty)
  (qual qualificator ty)
  (bitfield size ty)
  (struct tag var-entries)
  (union tag var-entries)
  (enum tag var-entries))

(define basic-types
  '(
    ; signed integer types
    signed-char short-int int long-int
    ; unsigned integer types
    unsigned-char unsigned-short-int unsigned-int unsigned-long-int
    ; floating types
    float double long-double
    char void))

(define (arith? ty)
  (member
   (unqual ty)
   '(signed-char short-int int long-int
     unsigned-char unsigned-short-int unsigned-int unsigned-long-int
     float double long-double)))

(define (scalar? ty)
  (or (arith? ty) (pointer? ty)))

(define (int? ty)
  (member
   (unqual ty)
   '(signed-char short-int int long-int
     unsigned-char unsigned-short-int unsigned-int unsigned-long-int
     char)))

(define make-pointer type.pointer)
(define (pointer? ty)
  (type.pointer? (unqual ty)))
(define pointer->ty type.pointer->ty)

(define (make-array size ty)
  (if (function? ty)
      (error "make-array: illegal type `array of ~a'" ty)
      (type.array size ty)))
(define array->ty type.array->ty)
(define array->size type.array->size)
(define (array? ty)
  (type.array? (unqual ty)))

(define (make-function from-tys to-ty)
  (if (or (array? to-ty) (function? to-ty))
      (error "illegal return type")
      (type.function from-tys to-ty)))

(define function->from-tys type.function->from-tys)
(define function->to-ty type.function->to-ty)
(define (function? ty)
  (type.function? (unqual ty)))

; Funktionen auf Typen

(define qual? type.qual?)
(define qual->qualificator type.qual->qualificator)

(define (unqual ty)
  (if (qual? ty)
      (type.qual->ty ty)
      ty))

(define make-qual
  (let ((comp (lambda (q1 q2)
		(if (or (and (eq? q1 'const) (eq? q2 'volatile))
			(and (eq? q1 'volatile) (eq? q2 'const)))
		    'const+volatile
		    (error "illegal type: multiple const or volatile")))))
    (lambda (op type)
      (cond ((array? type)
	     (make-array (array->size type) (make-qual op (array->ty type))))
	    ((function? type)
	     (warn "qualified function type ignored")
	     type)
	    ((qual? type)
	     (type.qual (comp op (qual->qualificator type)) (unqual type)))
	    (else
	     (type.qual op type))))))

(define (volatile? ty)
  (and (qual? ty) (member (qual->qualificator ty) '(volatile const+volatile))))

(define (const? ty)
  (and (qual? ty) (member (qual->qualificator ty) '(const const+volatile))))

(define make-enum type.enum)
(define enum? type.enum?)

(define (const-volatile-lst->type lst type)
  (fold-left
   (lambda (type cv)
     (make-qual cv type))
   type
   lst))

(define binary
  (let* ((type-prio-lst '((int               . 1)
			  (unsigned-int      . 2)
			  (long-int          . 3)
			  (unsigned-long-int . 4)
			  (float             . 5)
			  (double            . 6)
			  (long-double       . 7)))
	 (prio-type-lst (map (lambda (p)
			       (cons (cdr p) (car p)))
			     type-prio-lst))
	 (prio (lambda (type)
		 (cond ((assoc type type-prio-lst)
			=> cdr)
		       (else
			1)))))
    (lambda (type1 type2)
      (cdr (assoc (max (prio type1) (prio type2)) prio-type-lst)))))

(define (eqtype ty1 ty2 ret)
  (cond ((and (pointer? ty1) (pointer? ty2))
	 (eqtype (pointer->ty ty1) (pointer->ty ty2) #t))
	((and (array? ty1) (array? ty2))
	 (if (eqtype (array->ty ty1) (array->ty ty2) #t)
	     (if (= (array->size ty1) (array->size ty2))
		 #t
		 (if (or (zero? (array->size ty1)) (zero? (array->size ty2)))
		     ret
		     #f))
	     #f))
	((and (function? ty1) (function? ty2))
	 (let ((all (map cons (function->from-tys ty1) (function->from-tys ty2))))
	   (every? (lambda (p)
		     (eqtype (car p) (cdr p) #t))
		   (cons (cons (function->to-ty ty1)
			       (function->to-ty ty2))
			 all))))
	((and (qual? ty1) (qual? ty2))
	 (and (equal? (qual->qualificator ty1) (qual->qualificator ty2))
	      (eqtype (unqual ty1) (unqual ty2) #t)))
	(else ; basic-types
	 (equal? ty1 ty2))))

(define (complete? ty)
  (cond ((pointer? ty)
	 (complete? (pointer->ty ty)))
	((array? ty)
	 (and (positive? (array->size ty))
	      (complete? (array->ty ty))))
	((qual? ty)
	 (complete? (unqual ty)))
	(else
	 #t)))

(define (promote ty)
  ty)

(define (compose ty1 ty2)
  (cond ((and (pointer? ty1) (pointer? ty2))
	 (make-pointer (compose (pointer->ty ty1) (pointer->ty ty2))))
	((and (qual? ty1) (qual? ty2)
	      (equal? (qual->qualificator ty1) (qual->qualificator ty2)))
	 (make-qual (qual->qualificator ty1) (compose (unqual ty1) (unqual ty2))))
	((and (array? ty1) (array? ty2))
	 (let ((ty (compose (array->ty ty1) (array->ty ty2)))
	       (size (cond ((complete? ty1)
			    (array->size ty1))
			   ((complete? ty2)
			    (array->size ty2))
			   (else
			    0))))
	   (make-array size ty)))
	((and (function? ty1) (function? ty2))
	 (let ((dom (compose (function->to-ty ty1) (function->to-ty ty2)))
	       (codom
		(map
		 (lambda (arg-ty1 arg-ty2)
		   (let ((ty (compose (unqual arg-ty1) (unqual arg-ty2))))
		     (if (or (const? arg-ty1) (const? arg-ty2))
			 (set! ty (make-qual 'const ty)))
		     (if (or (volatile? arg-ty1) (volatile? arg-ty2))
			 (set! ty (make-qual 'volatile ty)))
		     ty))
		 (function->from-tys ty1)
		 (function->from-tys ty2))))
	   (make-function codom dom)))
	(else ; basic-types
	 ty1)))

(define (array->pointer ty)
  (if (array? ty)
      (make-pointer (array->ty ty))
      (error "array->pointer: type-error")))

(define (compatible? ty1 ty2)
  (and (pointer? ty1) (not (function? (pointer->ty ty1)))
       (pointer? ty2) (not (function? (pointer->ty ty2)))
       (eqtype (unqual (pointer->ty ty1)) (unqual (pointer->ty ty2)) #f)))

(define (voidpointer? ty)
  (and (pointer? ty) (eq? (unqual (pointer->ty ty)) 'void)))

(define (decl-specs->base-type decl-specs)
  (let* ((aux (list (cons 'cls  #f)
		    (cons 'cons #f)
		    (cons 'sign #f)
		    (cons 'size #f)
		    (cons 'type #f)
		    (cons 'vol  #f)))
	 (get-info (lambda (p) (cdr (assoc p aux))))
	 (set-info (lambda (p val) (set-cdr! (assoc p aux) val))))

    (for-each
     (lambda (sym)
       (let* ((p
	       (case sym
		 ((auto register)
		  'cls)
		 ((static extern typedef)
		  'cls)
		 ((const)
		  'cons)
		 ((volatile)
		  'vol)
		 ((signed unsigned)
		  'sign)
		 ((long short)
		  'size)
		 ((void char int float double)
		  'type)
		 ((enum)
		  'type)
		 ((struct union)
		  'type))))
	 (if (get-info p)
	     (error "dublicate declaration-specifier")
	     (set-info p sym))))
     decl-specs)

    (and (not (get-info 'type)) (set-info 'type 'int))

    (let* ((base-type
	    (cond ((or (and (eq? (get-info 'size) 'short)
			    (not (eq? (get-info 'type) 'int)))
		       (and (eq? (get-info 'size) 'long)
			    (not (eq? (get-info 'type) 'int))
			    (not (eq? (get-info 'type) 'double)))
		       (and (get-info 'sign)
			    (not (eq? (get-info 'type) 'int))
			    (not (eq? (get-info 'type) 'char))))
		   (error "invalid type specification"))
		  ((and (eq? (get-info 'type) 'char)
			(get-info 'sign))
		   (if (eq? (get-info 'sign) 'unsigned)
		       'unsigned-char
		       'signed-char))
		  ((eq? (get-info 'size) 'short)
		   (if (eq? (get-info 'sign) 'unsigned)
		       'unsigned-short
		       'short-int))
		  ((and (eq? (get-info 'size) 'long)
			(eq? (get-info 'type) 'double))
		   'long-double)
		  ((eq? (get-info 'size) 'long)
		   (if (eq? (get-info 'sign) 'unsigned)
		       'unsigned-long-int
		       'long-int))
		  ((and (eq? (get-info 'sign) 'unsigned)
			(eq? (get-info 'type) 'int))
		   'unsigned-int)
		  (else
		   (get-info 'type))))
	   (maybe-qualified-type
	    (let* ((c (get-info 'cons))
		   (v (get-info 'vol))
		   (t (if c (make-qual c base-type) base-type)))
	      (if v (make-qual v t) t))))
		   
      (values (get-info 'cls) maybe-qualified-type))))