;;;; crunch.scm
;
; Copyright (c) 2007-2009, 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.
;
; Send bugs, suggestions and ideas to: 
;
; felix@call-with-current-continuation.org
;
; Felix L. Winkelmann
; Unter den Gleichen 1
; 37130 Gleichen
; Germany


(module crunch (crunch
		define-crunch-primitives
		define-crunch-callback)

(import scheme chicken foreign)

(begin-for-syntax
 (require-extension crunch-compiler))

(cond-expand
 (disable-crunch
  (define-syntax crunch
    (syntax-rules ()
      ((_ body ...) (begin body ...)) )))
 (else
  (define-syntax (crunch x r c)
    (let ((body (##sys#strip-syntax (cdr x)))
	  (out (open-output-string)))
      (let-values (((f exports) (crunch-compile `(begin ,@body) out)))
	`(,(r 'begin)
	  ,@(map crunch-export->foreign-lambda exports)
	  (,(r 'foreign-declare) ,(get-output-string out))
	  (,(r 'foreign-code) ,(conc f "();")) ) ) ) ) ) )

(define-syntax (define-crunch-primitives x r c)
  (let ((prims (cdr x)))
    (for-each
     (lambda (p)
       (unless (and (list? p) (list? (car p)) 
		    (or (c (cadr p) (r '->))
			(c (cadr p) (r '+>)))
		    (>= 3 (length p)) (symbol? (caar p)))
	 (syntax-error 
	  'define-crunch-primitives
	  "invalid primitive specification" p) )
       (let* ((arg (and (pair? (cdddr p)) (cadddr p)))
	      (real-name (if (string? arg)
			     arg
			     (symbol->string (caar p))) ))
	 (crunch-register-primitive
	  (caar p) (cdar p) (caddr p)
	  real-name #f 
	  (and (pair? (car p)) (c (r '+>) (cadr p))))))
     prims)
    '(,(r 'void) ) ) )

(define-syntax (define-crunch-callback x r c)
  (let ((head (cadr x))
	(body (cddr x)))
    (unless (and (pair? head) (symbol? (car head)))
      (syntax-error 'define-crunch-callback "invalid callback definition" head) )
    (let ((name (gensym 'crunch_callback)))
      (crunch-register-primitive
       (car head)
       (map (lambda (a) (crunch-foreign-type (car a))) (cdr head))
       (crunch-foreign-type (car body))
       name #t) 
      `(,(r 'define-external) (,name ,@(cdr head)) ,@body) ) ) )

)