;;;; datatype.scm - Variant record types from "Essentials of Programming Languages" - felix
;
; Copyright (c) 2008, The CHICKEN Team
; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(module datatype (define-datatype
		   (cases invoke-variant-case))
  
  (import scheme chicken)

(declare (fixnum))

(define-syntax define-datatype
  (lambda (x r c)
    (##sys#check-syntax 'define-datatype x '(_ symbol . #(_ 1)))
    (let ((typename (cadr x))
	  (pred (and (symbol? (caddr x)) (caddr x)))
	  (rest (if (symbol? (caddr x)) (cdddr x) (cddr x)))
	  (%define (r 'define))
	  (%begin (r 'begin))
	  (%if (r 'if)))
      `(,%begin
	,@(if pred
	      `((,%define (,pred x) (##sys#structure? x ',typename)))
	      '() )
	,@(map (lambda (variant)
		 (##sys#check-syntax 'define-datatype variant '(symbol . #((symbol _) 0)))
		 (let ((variantname (car variant))
		       (fieldnames (map car (cdr variant)))
		       (fieldpreds (map cadr (cdr variant))) )
		   `(,%define (,(car variant) ,@fieldnames)
			      (##sys#make-structure
			       ',typename ',variantname
			       ,@(map (lambda (name pred)
					`(,%if (##core#check (,pred ,name))
					       ,name
					       (##sys#signal-hook
						#:type-error 
						"bad argument type to variant constructor"
						,name ',variantname ',name) ) )
				      fieldnames fieldpreds) ) ) ) )
	       rest)))))

(define-syntax cases
  (lambda (x r c)
    (##sys#check-syntax 'cases x '(_ symbol _ . #(_ 0)))
    (let ((typename (cadr x))
	  (exp (caddr x))
	  (clauses (cdddr x))
	  (%let (r 'let))
	  (%if (r 'if))
	  (%else (r 'else))
	  (%eq? (r 'eq?))
	  (%invoke (r 'invoke-variant-case))
	  (%lambda (r 'lambda))
	  (%tmp (r 'tmp))
	  (%cond (r 'cond))
	  (%tag (r 'tag)))
      `(,%let ((,%tmp ,exp))
	      (,%if (##core#check (##sys#structure? ,%tmp ',typename))
		    (,%let ((,%tag (##sys#slot ,%tmp 1)))
			   (,%cond ,@(map (lambda (clause)
					    (cond ((c %else (car clause))
						   `(,%else (,%let () ,@(cdr clause))))
						  (else
						   (##sys#check-syntax 'cases clause '(symbol #(symbol 0) . #(_ 1)))
						   (let ((variantname (car clause))
							 (fields (cadr clause)))
						     `((,%eq? ,%tag ',variantname)
						       (,%invoke
							',variantname ,%tmp 
							,(length fields) 
							(,%lambda 
							 ,fields
							 ,@(cddr clause)) ) ) ) ) ) )
					  clauses) ) )
		    (##sys#signal-hook #:type-error "bad argument type to `cases'" 
				       ,%tmp ',typename) ) ) ) ))

(define (invoke-variant-case name block count proc)
  (apply 
   proc
   (let ((limit (fx- (##sys#size block) 2)))
     (let rec ((i 0))
       (cond ((fx>= i count) '())
	     ((fx>= i limit) (error 'cases "too many record fields accessed" name block))
	     (else (cons (##sys#slot block (fx+ i 2)) (rec (fx+ i 1)))) ) ) ) ) )

)