;;;; crunch-compiler.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-compiler (crunch-export->foreign-lambda
			 crunch-foreign-type
			 crunch-register-primitive
			 crunch-register-special-form
			 crunch-compile)

(import scheme chicken)

(use srfi-1 miscmacros srfi-13)
(use defstruct srfi-4 srfi-69 data-structures ports extras
     matchable crunch-expander)

#+compiling
(declare (fixnum))

(define *functions*)			 ; ((ID . LAMBDA) ...)
(define *globals* (make-hash-table eq?)) ; NAME -> BINDING
(define *output*)			 ; PORT
(define *environment*)			 ; (BINDING ...)
(define *function-environment*)
(define *types*)
(define *substitutions*)
(define *header-path* "chicken/")
(define *literals*)
(define *export-prefix* "static ")
(define *integer-types* '(int long short))
(define *floating-point-types* '(float double))
(define *number-types* (append *integer-types* *floating-point-types*))
(define *lexical-environment* '())
(define *indent* "")
(define *resolution* 0)
(define *context* '())
(define *special-forms* (make-hash-table eq?))
(define *verbatim* '())

(define-syntax with-context
  (syntax-rules ()
    ((_ c body ...)
     (fluid-let ((*context* (cons c *context*)))
       body ...))))

(define (get-context)
  (let ((c (filter identity *context*)))
    (cond ((null? c) "")
	  (else
	   (with-output-to-string 
	     (lambda ()
	       (printf "~%~%  context:~%~%")
	       (for-each
		(lambda (c)
		  (##sys#with-print-length-limit 
		   256 
		   (lambda ()
		     (write-char #\tab)
		     (pp c) ) ) )
		(reverse c))))) ) ) )

(define *crunch-debug*
  (cond ((feature? 'crunch-debug-total) 3)
	((feature? 'crunch-debug-expand) 2)
	((feature? 'crunch-debug) 1)
	((and (feature? 'compiling) ##compiler#verbose-mode) 1)
	(else #f)))

(define *type-specifiers*
  '(bool int char string double float void short long
	 c-string blob c-pointer
	 u8vector s8vector u16vector s16vector
	 u32vector s32vector f32vector f64vector))

(defstruct binding
  name					; SYMBOL
  real-name				; STRING | #f
  id					; SYMBOL
  (type (make-typevar name))		; TYPE
  assigned?				; BOOLEAN | * | +
  referenced?				; BOOLEAN | *
  primitive?				; BOOLEAN
  callback?				; BOOLEAN
  (calls '())				; (BINDING ...)
  refreturn?				; BOOLEAN
  loop)					; (ID ...) | #f

(define-record-printer (binding b p)
  (fprintf p "#<binding ~s>" (binding-name b)))

(define (binding-c-name b)
  (or (binding-id b)
      (binding-real-name b)
      (cify-name (binding-name b))))

(define (binding-display-name b)
  (if (binding? b)
      (binding-name b)
      b) )

(define (binding-global? b)
  (not (binding-id b)))

(define (binding-assign! b top)
  (cond ((binding-assigned? b) (binding-assigned?-set! b '*))
	(else (binding-assigned?-set! b (if top '+ #t)))))

(define (binding-reference! b)
  (cond ((binding-referenced? b) (binding-referenced?-set! b '*))
	(else (binding-referenced?-set! b #t))))

(define (binding-update! b t)
  (binding-type-set! 
   b 
   (let* ((t0 (binding-type b))
	  (t (if t0 
		 (unify t t0)
		 t0) ) )
     (dribble2 "(binding updated) ~s -> ~s" b t) 
     t) ) )

(define (binding-update-calls! b cb)
  (binding-calls-set! 
   b
   (lset-adjoin eq? (binding-calls b) cb) ) )

(defstruct typevar id context type)

(define-record-printer (typevar tv p)
  (fprintf p "#<~a" (typevar-id tv) )
  (and-let* ((t (typevar-type tv)))
    (fprintf p " ~s" t) )
  (and-let* ((c (typevar-context tv))
	     ((pair? c)))
    (display " = " p)
    (##sys#with-print-length-limit
     20
     (lambda () (write (car c) p)) ) )
  (write-char #\> p) )

(define (type->string t)
  (cond ((typevar? t) (->string (typevar-id t)))
	(else (->string (native-type t)))))

(define make-typevar
  (let ((make-typevar make-typevar))
    (lambda (#!optional context1)
      (let ((tv (make-typevar id: (gensym 'type) context: (cons context1 *context*))))
	(push! tv *types*)
	tv) ) ) )

(define (emit fstr . xs)
  (fprintf *output* "\n~?" fstr xs) )

(define (temp) (gensym 't))

(define (dribble2 fstr . args)
  (when (and (number? *crunch-debug*) (> *crunch-debug* 2))
    (printf "[crunch]~a ~?~%" *indent* fstr args) ) )

(define (dribble fstr . args)
  (when *crunch-debug*
    (printf "[crunch]~a ~?~%" *indent* fstr args) ) )

(define (complain loc msg . args)
  (when (enable-warnings)
    (printf "[crunch] Warning: ~a~?~%"
	    (let ((name (binding-display-name loc)))
	      (if name
		  (sprintf "(in ~s) " name)
		  "") )
	    msg args) ) )

(define (bomb loc msg . args)
  (error
   (sprintf "[crunch] ~a~?~a"
	    (let ((name (binding-display-name loc)))
	      (if name
		  (sprintf "(in ~s) " name)
		  "") )
	    msg args
	    (get-context))))

(define (cify-name name)
  (string-intersperse
   (map (lambda (c)
	  (if (or (char-alphabetic? c)
		  (char-numeric? c) )
	      (string c)
	      (let ((n (char->integer c)))
		(sprintf "_~a" (string-pad (number->string n 16) 2 #\0)))))
	(string->list (->string name)))
   ""))

(define (lookup v)
  (or (find (lambda (b) (eq? v (binding-name b))) *environment*)
      (hash-table-ref/default *globals* v #f)
      (let ((b (make-binding name: v id: (gensym 'g))))
	(hash-table-set! *globals* v b)
	b)))

(define (resolve t0 #!optional (miss (cut bomb #f <> <...>)) (done '()))
  (define (merge t1 t2)
    (define (fail)
      (miss "can not unify with both ~a and ~a: ~s" t1 t2 t0))
    (dribble2 "merging ~a with ~a" t1 t2)
    (let ((mt (cond ((typevar? t1) (merge (walk t1) t2))
		    ((typevar? t2) (merge t2 t1))
		    ((merge-simple-types t1 t2))
		    (else
		     (match t1
		       (((args1 ...) '-> result1)
			(match t2
			  (((args2 ...) '-> result2)
			   (if (= (length args1) (length args2))
			       (list (map merge args1 args2) 
				     '-> 
				     (merge result1 result2))
			       (bomb #f "procedure arities do not match: ~s + ~s" t1 t2)) )
			  (_ (fail)) ) )
		       (_ (fail) ) ) ) ) ) )
      (dribble2 "  merged: ~a" mt)
      mt) )
  (define (walk t)
    (dribble2 "resolve: ~s" t)
    (match t
      ((? typevar?)
       (when (memq t done)
	 (miss "circular substitution: ~s" t))
       (push! t done)
       (or (typevar-type t)
	   (let ((fs (filter (lambda (s) (eq? (car s) t)) *substitutions*)))
	     (cond ((null? fs) 
		    (miss "unresolvable type: ~s" t) )
		   (else
		    (dribble2 "resolve set: ~s" fs)
		    (let ((set (filter-map
				(lambda (t)
				  (let ((t (cdr t)))
				    (call/cc
				     (lambda (k)
				       (resolve 
					t
					(lambda (fstr . args)
					  (dribble2 "  resolve failed: ~s (~?)" t fstr args)
					  (k #f))
					done)))))
				fs) ) )
		      (dribble2 "merge set: ~s" set)
		      (let ((t2 (walk (reduce 
				       (cut merge <> <>) 
				       #f
				       (let ((ts (remove typevar? set))) 
					 (if (null? ts)
					     (miss "no resolution for set ~s of ~s" set t)
					     ts))))))
			(when (and t2 (not (typevar? t2)) (not (eq? (typevar-type t) t2)))
			  (when (<= *resolution* 1)
			    (typevar-type-set! t t2)
			    (dribble2 "updated ~s" t) ) )
			t2) ) ) ) ) ) )
      (((args ...) '-> result)
       (list (map walk args) '-> (walk result)))
      (_ t) ) )
  (fluid-let ((*indent* (string-append *indent* " "))
	      (*context* (if (typevar? t0)
			     (append (typevar-context t0) *context*)
			     *context*))
	      (*resolution* (add1 *resolution*)))
    (walk t0) ) )

(define (extend tv t)
  (dribble2 "(extend) ~s => ~s" tv t)
  (push! (cons tv t) *substitutions*) )

(define (merge-simple-types t1 t2)
  (cond ((equal? t1 t2) t1)
	((or (eq? t1 'void) (eq? t2 'void))
	 'void)
	((eq? t1 '*) t2)
	((eq? t2 '*) t1)
	((eq? t1 'bool) t2)
	((eq? t2 'bool) t1)
	((eq? t1 'number) 
	 (and (memq t2 *number-types*)
	      t2) )
	((eq? t2 'number) 
	 (and (memq t1 *number-types*)
	      t1) )
	((eq? 'double t1)
	 (and (or (eq? t2 'float) (memq t2 *integer-types*))
	      t1) )
	((eq? 'double t2)
	 (and (or (eq? t1 'float) (memq t1 *integer-types*))
	      t2) )
	((memq t1 *floating-point-types*)
	 (and (memq t2 *integer-types*)
	      t1) )
	((memq t2 *floating-point-types*)
	 (and (memq t1 *integer-types*)
	      t2) )
	(else #f) ) )

(define (unify t1 t2)
  (define (un-n*type result args)
    (case result
      ((number*)
       (let ((t (make-typevar)))
	 (for-each (cut unify t <>) args)
	 t) )
      (else result) ) )
  (dribble2 "(unify) ~s == ~s" t1 t2)
  (let ((u (cond 
	    ((typevar? t1)
	     (extend t1 t2)
	     (when (typevar? t2) (extend t2 t1))
	     t2)
	    ((typevar? t2) 
	     (extend t2 t1)
	     t1)
	    ((merge-simple-types t1 t2))
	    (else
	     (match t1
	       ((args1 '-> result1)
		(match t2
		  ((args2 '-> result2)
		   (when (not (= (length args1) (length args2)))
		     (bomb #f "number of arguments in procedure call does not match"))
		   (let ((args3 (map unify args1 args2)))
		     (list 
		      args3
		      '-> 
		      (unify (un-n*type result1 args3) (un-n*type result2 args3) ) ) ) )
		  (_ (bomb #f "can not unify ~a and ~a" t1 t2)) ) )
	       (_ (bomb #f "can not unify ~a and ~a" t1 t2)) ) ) ) ) )
    (dribble2 "(unified)   ==> ~s" u)
    u) )

(define (result-type t args)
  (match t
    ((? typevar? t)
     (let ((rt (make-typevar)))
       (unify t `(,(map make-typevar args) -> ,rt))
       rt) )
    ((_ '-> rt) rt)
    (_ (bomb #f "unable to compute result type: ~a" t))))

(define (literal-type lit)
  (cond ((string? lit) 'string)
	((fixnum? lit) 'int)
	((number? lit) 'double)
	((char? lit) 'char)
	((boolean? lit) 'bool)
	((u8vector? lit) 'u8vector)
	((s8vector? lit) 's8vector)
	((u16vector? lit) 'u16vector)
	((s16vector? lit) 's16vector)
	((u32vector? lit) 'u32vector)
	((s32vector? lit) 's32vector)
	((f32vector? lit) 'f32vector)
	((f64vector? lit) 'f64vector)
	(else (bomb #f "invalid literal: ~s" lit))))

(define (case-literal? x)
  (or (boolean? x) (number? x) (char? x)))

(define (literal-text x)
  (cond ((number? x) (number->string x))
	((char? x)
	 (sprintf "'\\~a'" 
		  (string-pad (number->string (char->integer x) 8) 3 #\0)))
	((boolean? x) (if x "true" "false"))
	(else (bomb #f "invalid literal: ~s" x))))

(define (compile-literal x)
  (let ((t (temp))
	(lt (literal-type x)) )
    (cond ((number? x)
	   (emit "~a ~a = ~a;" (type->string lt) t x) )
	  ((char? x)
	   (emit "~a ~a = '\\~a\';" 
		 (type->string lt) t
		 (string-pad (number->string (char->integer x) 8) 3 #\0)))
	  ((boolean? x)
	   (emit "~a ~a =~a;" (native-type 'bool) t (if x "true" "false")))
	  (else
	   (let ((id (gensym 'c)))
	     (push! (list id lt x) *literals*)
	     (emit "~a ~a = ~a;" (type->string lt) t id) ) ) )
    (cons t lt) ) )

(define (crunch-register-special-form name proc)
  (hash-table-set! *special-forms* name proc) )

(define (crunch-expr x e top? tail? dest loc)
  (let ((w crunch-expr))
    (dribble2 "(compile) ~s" x)
    ;; (dribble "(compile) ~s  (tail: ~s, top: ~s, dest: ~s, loc: ~s" x tail? top? (binding-display-name dest)
    ;;          (binding-display-name loc))
    (match x
      ((? symbol?)
       (let ((t (temp))
	     (b (lookup x)) )
	 (cond ((binding-primitive? b)
		(let ((vars (list-tabulate (length (car (binding-type b))) (lambda _ (gensym 'a)))))
		  (w `(lambda ,vars (,x ,@vars)) e top? tail? dest loc)) )
	       ((and (binding-global? b)
		     (any (cut memq x <>) *lexical-environment*))
		(bomb loc "reference to lexical binding: ~s" x))
	       (else
		(when (and loc (binding-global? b)) (binding-update-calls! loc b))
		(binding-reference! b)
		(emit "~a = ~a;\t// ~s"
		      (c-type (binding-type b) t)
		      (binding-c-name b)
		      x)
		(cons t (binding-type b)))) ) )
      ((or (? boolean?) (? number?) (? char?) (? string?)) (compile-literal x))
      (('quote x) (compile-literal x))
      (('if x y)
       (w `(if ,x ,y (void)) e top? tail? dest loc))
      (('if x y z)
       (with-context 
	`(if ,x ...)
	(let ((v (w x e top? #f #f loc))
	      (t (temp))
	      (tv (make-typevar x) ) )
	  (emit "~a;" (c-type tv t))
	  (emit "if(~a(~a).f) {" (native-type 'bool) (car v))
	  (let ((x1 (w y e top? tail? dest loc)))
	    (emit "~a = ~a; }\nelse {" t (car x1))
	    (let ((x2 (w z e top? tail? dest loc)))
	      (emit "~a = ~a; }" t (car x2))
	      (cons
	       t
	       (unify tv (unify (cdr x1) (cdr x2)) ) ) ) ) ) ) )
      (((or 'set! 'define) x y)
       (let-values (((var type) (vartype x)))
	 (with-context 
	  `(set! ,x ...)
	  (let* ((b (lookup var))
		 (v (w y e top? #f b loc))
		 (tmp (temp)) )
	    (when (binding-primitive? b)
	      (bomb loc "assignment to primitive binding: ~s" var))
	    (binding-assign! b top?)
	    (binding-update! b (unify type (cdr v)))
	    (emit "~a = ~a;\t// set! ~s" (binding-c-name b) (car v) var)
	    (emit "~a ~a;" (native-type 'void) tmp)
	    (cons tmp 'void))) ) )
      (('let bindings . body)
       (with-context
	`(let ,bindings ...)
	(if (null? bindings)
	    (w `(begin ,@body) e top? tail? dest loc)
	    (let* ((bs (map (lambda (b)
			      (let-values (((var type) (vartype (car b))))
				(make-binding name: var id: (gensym 'v) type: type)))
			    bindings ) )
		   (vs (map (lambda (b bi) 
			      (let ((v (w (second b) e top? #f bi loc)))
				(cons (car v) (unify (binding-type bi) (cdr v))) ) )
			    bindings bs) ) 
		   (t (temp))
		   (e2 (cons (map car bindings) e))
		   (tv (make-typevar x)))
	      (emit "~a;~%{" (c-type tv t))
	      (for-each
	       (lambda (b v)
		 (emit "~a = ~a;\t// ~s" (c-type (binding-type b) (binding-id b)) (car v)
		       (binding-name b)) )
	       bs vs)
	      (fluid-let ((*environment* (append bs *environment*)))
		(let ((r (w `(begin ,@body) e2 top? tail? dest loc) ))
		  (emit "~a = ~a; }" t (car r))
		  (cons t (unify tv (cdr r)))))))) )
      ((or '(void) '(##core#undefined))
       (let ((t (temp)))
	 (emit "~a ~a;" (native-type 'void) t)
	 (cons t 'void)))
      (('begin body ...)
       (cond ((null? body)
	      (let ((tmp (temp)))
		(emit "~a ~a;" (native-type 'void) tmp)
		(cons tmp 'void) ) )
	     (else
	      (let ((r #f))
		(pair-for-each
		 (lambda (x) 
		   (set! r (w (car x) e top? (null? (cdr x)) 
			      (if (null? (cdr x)) dest #f)
			      loc) ) )
		 body)
		r) ) ) )
      (('lambda llist body ...)
       (with-context
	`(lambda ,llist ...)
	(let-values (((llist args) (parse-llist llist x loc)))
	  (let ((f (gensym 'f))
		(e2 (cons llist e))
		(t (list args '-> (make-typevar x))) )
	    ;; use inner let to force local definitions (since we expand the
	    ;; lambda body manually):
	    (push! (vector 
		    (binding-display-name dest)
		    f t
		    `(lambda ,llist (let () ,@body)) 
		    dest e2)
		   *functions*)
	    (cons f t) ) ) ) )
      (('letrec bindings . _)
       (with-context 
	`(letrec ,bindings ...)
	(bomb loc "`letrec' is not supported")))
      ((op args ...)
       (cond
	((hash-table-ref/default *special-forms* op #f) =>
	 (lambda (sf)
	   (sf x e top? tail? dest loc) ) )
	((and (pair? op) (eq? 'lambda (car op)))
	 (w `(let ,(zip (cadr op) args) ,@(cddr op)) e top? #f dest loc))
	(else
	 (with-context
	  x
	  (let* ((fx op)
		 (vs (map (cut w <> e top? #f #f loc) args)))
	    (cond ((and (symbol? fx)
			loc
			(binding? loc)
			(eq? fx (binding-name loc)) 
			tail?)
		   ;; self-call in tail position
		   (let ((bound (lookup fx)))
		     (binding-reference! bound)
		     (when (binding-global? bound)
		       (binding-update-calls! loc bound)))
		   (let* ((ts (map (lambda _ (temp)) vs))
			  (ft1 (list (map cdr vs) '-> (make-typevar x))) 
			  (ft (unify ft1 (binding-type loc))))
		     (for-each
		      (lambda (v t)
			(emit "~a = ~a;~%" (c-type (cdr v) t) (car v)))
		      vs ts)
		     (for-each
		      (lambda (b t)
			(emit "~a = ~a;~%" (binding-c-name b) t))
		      *function-environment* ts)
		     (emit "goto crunch_loop;")
		     (let ((r (temp)))
		       (emit "~a;" (c-type (third ft) r))
		       (cons r (third ft)) ) ) )
		  ((and (symbol? fx) (lookup fx))
		   (lambda (b) (and b (binding-loop b))) =>
		   (lambda (b)
		     ;; call to loop variable
		     (when (and loc (binding-global? b))
		       (binding-update-calls! loc b))
		     (unless tail?
		       (bomb loc "call to loop variable not in tail position: ~s" fx))
		     (dribble2 "looping: ~s" fx)
		     (match-let (((vars ...) (binding-loop b)))
		       (let ((temps (map (lambda (v)
					   (let ((t (temp)))
					     (emit "~a = ~a;" (c-type (cdr v) t) (car v)) 
					     t) )
					 vs) ) 
			     (tr (temp)))
			 (for-each 
			  (lambda (var val tmp)
			    (let ((b (lookup var)))
			      (binding-assign! b top?)
			      (binding-update! b (cdr val))
			      (emit "~a = ~a;" (binding-c-name b) tmp) ) )
			  vars vs temps)
			 (emit "goto ~a;" (binding-id b))
			 (emit "~a ~a;" (native-type 'void) tr)
			 (cons tr 'void)))))
		  (else
		   ;; normal call
		   (let* ((ft (list (map cdr vs) '-> (make-typevar x))) 
			  (bound (and (symbol? fx) (lookup fx)) )
			  (finfo (cond ((and bound (binding-global? bound))
					(binding-reference! bound)
					(when loc (binding-update-calls! loc bound))
					(cons (binding-c-name bound)
					      (unify
					       (binding-type bound)
					       ft) ) )
				       (else
					(when tail? 
					  (complain loc "call in tail position is not iterative: ~s" x))
					(let ((fv (w fx e top? #f #f loc)))
					  (cons (car fv) (unify ft (cdr fv)))))))
			  (t (temp))
			  (rt (result-type ft (cdr x))) 
			  (uzvs (map ->string (unzip1 vs))))
		     (cond ((and bound (binding-refreturn? bound))
			    (emit "~a;" (c-type rt t))
			    (emit "~a(~a, ~a);\t// ~s" 
				  (car finfo)
				  (string-intersperse uzvs ", ")
				  t
				  fx) )
			   ((and (binding-callback? bound)
				 (eq? 'void (third (binding-type bound))))
			    (emit "~a;~%~a(~a);\t// ~s"
				  (c-type rt t)
				  (car finfo)
				  (string-intersperse uzvs ", ")
				  fx) )
			   (else
			    (emit "~a = ~a(~a);\t// ~s" 
				  (c-type rt t)
				  (car finfo)
				  (string-intersperse uzvs ", ")
				  fx) ) )
		     (cons t rt) ) ) ) ) ) ) ) )
      (_ (bomb loc "invalid syntax" x)))))

(define-syntax define-special-form
  (syntax-rules ()
    ((_ (name . llist) body ...)
     (crunch-register-special-form 'name (lambda llist body ...)))))

(define-special-form (crunch:switch x e top? tail? dest loc)
  (with-context
   `(case ,(second x) ...)
   (let* ((v (crunch-expr (second x) e top? #f #f loc))
	  (tval (cdr v))
	  (t (temp))
	  (tv (make-typevar x) ) )
     (emit "~a;" (c-type tv t))
     (emit "switch(~a) {" (car v))
     (do ((cases (cddr x) (cdr cases)))
	 ((null? cases) 
	  (emit "}")
	  (cons t tv))
       (match (car cases)
	 (('crunch:case vals+body ...)
	  (let loop ((vb vals+body))
	    (match vb
	      (() (bomb loc "empty body in `case' clause: ~s" x))
	      ((body)
	       (emit "{")
	       (let ((v (crunch-expr body e top? tail? dest loc)))
		 (emit "~a = ~a; break; }" t (car v))
		 (set! tv (unify tv (cdr v)))) )
	      (((or (? case-literal? lit) ('quote (? case-literal? lit))) . more)
	       (emit "case ~a: // ~a" (literal-text lit) lit)
	       (unify tval (literal-type lit))
	       (loop more) ) 
	      ((lit . _)
	       (bomb loc "invalid literal type in `case' clause: ~s" lit) ) ) ) )
	 (('crunch:default . body)
	  (emit "default:")
	  (let ((v (crunch-expr `(begin ,@body) e top? tail? dest loc)))
	    (emit "~a = ~a; break;" t (car v))
	    (set! tv (unify tv (cdr v)))))
	 (else (bomb loc "invalid `crunch:case' syntax: ~s" x)) ) ) ) ) )

(define-special-form (crunch:loop x e top? tail? dest loc)
  (let* ((label (gensym 'crunch_loop))
	 (lvar (caadr x))
	 (b (make-binding id: label name: lvar type: #f loop: (cdadr x))))
    (emit "~a:;" label)
    (fluid-let ((*environment* (cons b *environment*)))
      (crunch-expr `(begin ,@(cddr x)) e top? #f dest loc))))

(define-special-form (crunch:verbatim x e top? tail? dest loc)
  (set! *verbatim* 
    (append-reverse
     (map (lambda (s)
	    (if (string? s)
		s
		(bomb loc "verbatim argument is not a string" s) ) )
	  (cdr x) )
     *verbatim*) )
  (crunch-expr '(##core#undefined) e top? tail? dest loc))

(define (c-type t name)
  (match t
    (((args ...) '-> result)
     (sprintf
      "~a (*~a)(~a)"
      (c-type result "")
      name 
      (string-intersperse (map (lambda (x) (c-type x "")) args) ", ")))
    (t (sprintf "~a~a" (type->string t) (if name (conc " " name) "")))))

(define (emit-types port)
  (dribble2 "(substitutions) ~s~%" *substitutions*)
  (for-each
   (lambda (tv)
     (fprintf 
      port "typedef ~a;~%" 
      (c-type (resolve tv) (typevar-id tv))) )
   *types*) )

(define (emit-literal lit port)
  (define (nvec lst)
    (fprintf port "{ ~a }" (string-intersperse lst ", ")))
  (match lit
    ((id type x)
     (fprintf port "static ~a::eltype l~a[] = " (c-type type #f) id)
     (cond ((string? x) 
	    (write-char #\" port)
	    (for-each
	     (lambda (c)
	       (fprintf 
		port "\\~a"
		(string-pad (number->string (char->integer c) 8) 3 #\0)))
	     (string->list x))
	    (write-char #\" port))
	   ((u8vector? x) (nvec (u8vector->list x)))
	   ((s8vector? x) (nvec (s8vector->list x)))
	   ((u16vector? x) (nvec (u16vector->list x)))
	   ((s16vector? x) (nvec (s16vector->list x)))
	   ((u32vector? x) (nvec (u32vector->list x)))
	   ((s32vector? x) (nvec (s32vector->list x)))
	   ((f32vector? x) (nvec (f32vector->list x)))
	   ((f64vector? x) (nvec (f64vector->list x)))
	   (else (bomb #f "invalid literal: ~s" x)))
     (fprintf port ";~%static ~a(l~a);~%" (c-type type id) id))))

(define (crunch-compile expr #!optional (port (current-output-port))
			#!key (debug *crunch-debug*) entry-point)
  (fluid-let ((*crunch-debug* debug)
	      (*types* '())) ; bind first because of call to `make-typevar' below
    (dribble "expanding ...")
    (let ((f (gensym 'f))
	  (expr (crunch-expand expr))
	  (t0 (make-typevar))
	  (protos '()) )
      (when (and *crunch-debug* (> *crunch-debug* 1))
	(dribble2 "expanded:")
	(pp expr) )
      (fluid-let ((*functions* 
		   (list 
		    (vector
		     '*TOPLEVEL*
		     f
		     `(() -> ,t0)
		     `(lambda () ,expr)
		     (make-binding name: 'TOPLEVEL type: t0)
		     '())) )
		  (*output* (open-output-string))
		  (*substitutions* '())
		  (*literals* '())
		  (*verbatim* '())
		  (*globals* (hash-table-copy *globals*)))
	(when entry-point
	  (hash-table-set! 
	   *globals* entry-point
	   (make-binding name: entry-point real-name: (symbol->string entry-point))))
	(do () ((null? *functions*))
	  (match-let ((#(name id (argtypes '-> rtype) (_ vs body) loc e) (pop! *functions*)))
	    (dribble "compiling ~s ..." name)
	    (fluid-let ((*environment* 
			 (map (lambda (v at) 
				(make-binding name: v id: (gensym 'a) type: at))
			      vs argtypes) ) 
			(*context* (cons `(define ,name ...) *context*))
			(*lexical-environment* e) )
	       (fluid-let ((*function-environment* *environment*))
		 (let* ((ts (c-type rtype id))
			(args (map 
			       (lambda (b at) 
				 (c-type at (binding-id b)))
			       *environment* argtypes) )
			(hdr (sprintf
			      "crunch_local ~a(~a)"
			      ts (string-intersperse args ", "))))
		   (push! (sprintf "~a;\t// ~s" hdr (or name "?")) protos)
		   (emit "~a {\t// ~s~%crunch_loop:;" hdr (or name "?"))
		   (let ((v (crunch-expr body e #t #t #f loc) ) )
		     (unify rtype (cdr v))
		     (emit "return ~a; }\n" (car v)) ) ) ) ) ) )
	(dribble "~a globals, ~a types" 
		 (hash-table-size *globals*)
		 (length *types*))
	(dribble "generating code ...")
	(display "// ---------- CRUNCH ----------\n\n" port)
	(for-each
	 (lambda (x)
	   (fprintf port "~a~%~%" x))
	 (reverse *verbatim*))
	(fprintf port "#include \"~acrunch.h\"~%~%" *header-path*)
	(hash-table-walk
	 *globals*
	 (lambda (v b)
	   (unless (binding-primitive? b)
	     (dribble2 "global: ~s (assigned: ~s, referenced: ~s)" 
		       (binding-display-name b)
		       (binding-assigned? b)
		       (binding-referenced? b))
	     (when (and (not (binding-assigned? b))
			(binding-referenced? b))
	       (bomb #f "undefined global variable: ~s" (binding-display-name b))))) )
	(emit-types port)
	(newline port)
	(for-each (cut fprintf port "~a~%" <>) protos)
	(newline port)
	(for-each (cut emit-literal <> port) *literals*)
	(let ((exports '())
	      (cb #f) )
	  (hash-table-walk
	   *globals*
	   (lambda (v b)
	     (with-context
	      v
	      (when (and (not (binding-primitive? b))
			 (or (binding-assigned? b) 
			     (binding-referenced? b)))
		(dribble2 "resolve global: ~s = ~s" b (binding-type b))
		(let ((cname (binding-c-name b))
		      (t (resolve (binding-type b))))
		  (fprintf port "~a~a;\t// ~s~%" *export-prefix* 
			   (c-type t cname) (binding-display-name b))
		  (dribble "global: ~s\t= ~s" v t)
		  (let ((calls (binding-calls b)))
		    (when (pair? calls)
		      (dribble " references: ~s" (map binding-name calls))
		      (set! cb (check-for-callback calls)) 
		      (when cb (dribble "  (calls back)")) ) )
		  (when (and (eq? '+ (binding-assigned? b)) (list? t))
		    (push! (cons* (binding-name b) cname cb (third t) (first t)) exports)))))))
	  (display (get-output-string *output*) port)
	  (display "\n// ---------- END CRUNCH ----------\n" port)
	  (values f exports) ) ) ) ) )

(define (check-for-callback calls)	; doesn't work for eta-expanded callbacks!
  (let loop ((calls calls) (done '()))
    (any (lambda (b) 
	   (dribble2 "callback check: ~a -> ~a" (binding-name b) (binding-callback? b))
	   (and (not (memq b done))
		(or (binding-callback? b)
		    (loop (binding-calls b) (append calls done)))))
	 calls) ) )

(define (->symbol x)
  (cond ((symbol? x) x)
	((string? x) (string->symbol x))
	(else (string->symbol (->string x)))))

(define (crunch-export->foreign-lambda exp)
  (match exp
    ((name cname cb result args ...)
     `(define ,(->symbol name)
	(,(if cb 'foreign-safe-lambda 'foreign-lambda) ,(translate-type result) ,cname
	  ,@(map translate-type args) ) ) ) ) )

(define (parse-llist llist0 expr loc)
  (let loop ((llist llist0) (vars '()) (types '()))
    (cond ((null? llist) (values (reverse vars) (reverse types)))
	  ((not-pair? llist)
	   (bomb loc "rest arguments not supported: ~s" expr) )
	  ((symbol? (car llist))
	   (let-values (((v t) (vartype (car llist))))
	     (loop (cdr llist) (cons v vars) (cons t types))))
	  (else (bomb loc "invalid lambda-list syntax" llist0)))))

(define (vartype sym)
  (let* ((s (symbol->string sym))
	 (i (substring-index "::" s)))
    (if i
	(values 
	 sym
	 (basic-type (string->symbol (substring s (+ i 2)))))
	(values sym (make-typevar sym)))))

(define (basic-type t)
  (if (memq t *type-specifiers*)
      t
      (bomb #f "invalid type specifier: ~s" t)))

(define (translate-type t)
  (case t
    ((number) 'int)
    ((string) 'c-string*)
    (else
     (if (memq t *type-specifiers*)
	 t
	 (bomb #f "invalid foreign type: ~s" t)))))

(define (crunch-foreign-type t)
  (case t
    ((int) 'number)
    ((blob) 'c-pointer)
    ((number*) 'number)
    (else
     (if (memq t *type-specifiers*)
	 t
	 (bomb #f "invalid foreign type: ~s" t)))))

(define (native-type t)
  (case t
    ((int) "int")
    ((long) "long")
    ((short) "short")
    ((char) "char")
    ((float) "float")
    ((double) "double")
    ((bool) "crunch_bool")
    ((number) "int")
    ((blob) "crunch_blob")
    ((c-string string) "crunch_string")
    ((pointer c-pointer) "void *")
    ((u8vector)   "crunch_u8vector")
    ((s8vector)   "crunch_s8vector")
    ((u16vector)  "crunch_u16vector")
    ((s16vector)  "crunch_s16vector")
    ((u32vector)  "crunch_u32vector")
    ((s32vector)  "crunch_s32vector")
    ((f32vector)  "crunch_f32vector")
    ((f64vector)  "crunch_f64vector")
    ((void)       "crunch_unspecified")
    (else (bomb #f "invalid native type: ~a" t))))

(define (crunch-register-primitive name args result realname #!optional callback refreturn)
  (dribble2 "registering primitive: ~a (~a), callback: ~a" name realname callback)
  (hash-table-set!
   *globals* name 
   (make-binding
    name: name
    real-name: realname
    type: (list args '-> result)
    callback?: callback
    refreturn?: refreturn
    primitive?: #t) ) )

(include "primitives.scm")

)