;;;; chicken-entry-points.scm
;
; Copyright (c) 2000-2005, 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


(cond-expand 
 [(not compiling) (error "this file can not be used in interpreted code" "chicken-entry-points.scm")]
 [else] )

(eval-when (compile)
  (set! ##sys#embedded-entry-point-counter 1) )

(define-macro (define-entry-point . form)
  (##sys#check-syntax 'define-entry-point form '(_ list list . #(_ 1)))
  (let ([id (car form)]
	[args (cadr form)]
	[results (caddr form)]
	[body (cdddr form)]
	[wordsperdouble (lambda (n) (fx* n (##sys#fudge 8)))]
	[buffer (gensym)] )

    (define (convert-argument type index)
      (let ([err (lambda () (##sys#error "can not generate entry-point argument conversion for foreign type" type))])
	(case (##compiler#final-foreign-type type)
	  [(int unsigned-int) `(##sys#peek-fixnum ,buffer ,(wordsperdouble index))]
	  [(integer short long) `(##sys#peek-signed-integer ,buffer ,(wordsperdouble index))]
	  [(unsigned-integer unsigned-short unsigned-long)
	   `(##sys#peek-unsigned-integer ,buffer ,(wordsperdouble index)) ]
	  [(char) `(integer->char (##sys#peek-signed-integer ,buffer ,(wordsperdouble index)))]
	  [(unsigned-char) `(integer->char (##sys#peek-unsigned-integer ,buffer ,(wordsperdouble index)))]
	  [(bool) `(not (eq? 0 (##sys#peek-fixnum ,buffer ,(wordsperdouble index))))]
	  [(nonnull-c-pointer nonnull-pointer c-pointer pointer)
	   `(##sys#address->pointer (##sys#peek-unsigned-integer ,buffer ,(wordsperdouble index))) ]
	  [(float double) `(##sys#peek-double ,buffer ,index)]
	  [(number) `(##sys#double->number (##sys#peek-double ,buffer ,index))]
	  [(c-string nonnull-c-string) `(##sys#peek-c-string ,buffer ,(wordsperdouble index))]
	  [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,buffer ,(wordsperdouble index)))]
	  [(scheme-object) `(##sys#slot ,buffer ,(wordsperdouble index))]
	  [else
	   (if (pair? type)
	       (case (car type)
		 [(ref pointer function c-pointer) 
		  `(##sys#address->pointer (##sys#peek-unsigned-integer ,buffer ,(wordsperdouble index)))]
		 [(instance nonnull-instance instance-ref) 
		  `(make ,(caddr type) 'this
			 (##sys#address->pointer (##sys#peek-unsigned-integer ,buffer ,(wordsperdouble index)))) ]
		 [else (err)] )
	       (err) ) ] ) ) )

    (define (convert-result type index val)
      (let ([err (lambda () (##sys#error "can not generate entry-point result conversion for foreign type" type))])
	(case (##compiler#final-foreign-type type)
	  [(scheme-object)
	   `(begin 
	      (##sys#gc)		; make sure pointer will point into heap (not nursery) on return
	      (##sys#setislot ,buffer ,(wordsperdouble index) ,val))]
	  [(int integer short long) `(##sys#poke-integer ,buffer ,(wordsperdouble index) ,val)]
	  [(unsigned-int unsigned-integer unsigned-short unsigned-long)
	   `(##sys#poke-integer ,buffer ,(wordsperdouble index) ,val) ]
	  [(char unsigned-char) `(##sys#poke-integer ,buffer ,(wordsperdouble index) (char->integer ,val))]
	  [(bool) `(##sys#poke-integer ,buffer ,(wordsperdouble index) (if ,val 1 0))]
	  [(c-pointer nonnull-c-pointer byte-vector nonnull-byte-vector
		      u8vector u16vector u32vector s8vector s16vector s32vector f32vector f64vector
		      nonnull-u8vector nonnull-u16vector nonnull-u32vector nonnull-s8vector 
		      nonnull-s16vector nonnull-s32vector nonnull-f32vector nonnull-f64vector)
	   `(##sys#poke-integer ,buffer ,(wordsperdouble index) (##sys#pointer->address ,val)) ]
	  [(scheme-pointer pointer)
	   `(begin
	      (##sys#gc)		; see above
	      (##core#inline "C_poke_pointer_or_null" ,buffer ,(wordsperdouble index) ,val) ) ]
	  [(nonnull-scheme-pointer nonnull-pointer)
	   `(begin
	      (##sys#gc)		; see above
	      (##core#inline "C_poke_pointer" ,buffer ,(wordsperdouble index) ,val) ) ]
	  [(float double number) `(##sys#poke-double ,buffer ,index ,val)]
	  [(c-string nonnull-c-string) `(##sys#poke-c-string ,buffer ,(wordsperdouble index) ,val)]
	  [(symbol) `(##sys#poke-c-string (##sys#symbol->string ,buffer) ,(wordsperdouble index) ,val)]
	  [else
	   (if (pair? type)
	       (case (car type)
		 [(ref pointer c-pointer function)
		  `(##sys#poke-integer ,buffer ,(wordsperdouble index) (##sys#pointer->address ,val))]
		 [(instance nonnull-instance instance-ref)
		  `(##sys#poke-integer ,buffer ,(wordsperdouble index) (##sys#pointer->address (slot-ref ,val 'this)))]
		 [else (err)] )
	       (err) ) ] ) ) )

    (define (doresult type i args val)
      (when (and (memq type '(c-string nonnull-c-string symbol))
		 (or (null? args)
		     (not (memq (cadar args) '(c-string nonnull-c-string symbol))) ) )
	(##sys#error "can not return result of type `c-string' without corresponding string argument") )
      (convert-result type i val) )

    (let ([body  
	   `(let ,(let loop ([args args] [i 0])
		    (if (null? args)
			'()
			(##sys#cons
			 (##sys#list (caar args) (convert-argument (cadar args) i))
			 (loop (cdr args) (fx+ i 1)) ) ) )
	      ,@body) ] )
      `(##sys#register-entry-point
	,id
	(lambda (,(gensym) ,buffer)
	  ,(case (length results)
	     [(0) body]
	     [(1) (let ([var (gensym)])
		    `(let ([,var ,body])
		       ,(doresult (car results) 0 args var) ) ) ]
	     [else
	      `(##sys#call-with-values
		(lambda () ,body)
		(lambda resultvalues
		  ,(let loop ([results results] [args args] [i 0])
		     (let ([r (doresult (car results) i args '(car resultvalues))])
		       (if (null? (cdr results))
			   r
			   `(begin
			      ,r
			      (let ([resultvalues (cdr resultvalues)])
				,(loop (cdr results) (and (pair? args) (cdr args)) (fx+ i 1)) ) ) ) ) ) ) ) ] ) ) ) ) ) )

(define-macro (define-embedded . args0)

  (define (expand-c quals cconv name args rtype n)
    (let ([len (length args)])
      `(declare
	(foreign-declare
	 ,(sprintf "~%~A ~A ~A ~A(~A) {"
		   quals
		   (return-ftype->ctype rtype) 
		   cconv
		   name
		   (string-intersperse
		    (map (lambda (a)
			   (sprintf "~A ~A" (argument-ftype->ctype (car a)) (cadr a)) )
			 args)
		    ", ") )
	 ,(sprintf "  C_parameter C_params[ ~A ];" len)
	 ,@(map (lambda (arg i)
		  (sprintf "  C_params[ ~A ].~A = (~A)~A;" 
			   i
			   (ftype->paramx (car arg))
			   (##compiler#foreign-type-declaration (car arg) "")
			   (cadr arg)) )
		args (iota len))
	 ,(sprintf "  CHICKEN_invoke(~A, C_params, ~A, (void *)C_toplevel);" n (max len 1))
	 ,@(if (eq? rtype 'void)
	       '()
	       (list (sprintf "  return (~A)C_params[ 0 ].~A;"
			      (##compiler#foreign-type-declaration rtype "")
			      (ftype->paramx rtype))) )
	 "}") ) ) )

  (define (return-ftype->ctype ftype)
    (##compiler#foreign-type-declaration ftype "") )

  (define (argument-ftype->ctype ftype)
    (##compiler#foreign-type-declaration ftype "") )

  (define (ftype->paramx ftype)
    (let ([ftype (##compiler#final-foreign-type ftype)])
      (case ftype
	[(double float number) "f"]
	[(char unsigned-char) "c"]
	;; pointer and nonnull-pointer are DEPRECATED
	[(scheme-object c-string c-string* nonnull-c-string scheme-pointer pointer c-pointer nonnull-c-pointer
			nonnull-c-string* nonnull-scheme-pointer nonnull-pointer symbol) "p"]
	[else
	 (if (pair? ftype)
	     (case (car ftype)
	       [(const) (ftype->paramx (cadr ftype))]
	       [(enum) "i"]
	       [else "p"] )
	     "i") ] ) ) )

  (define (expand-scm args rtype body n)
    (let* ([frtype (##compiler#final-foreign-type rtype)]
	   [var (gensym)]
	   [xbody 
	    (case frtype
	      [(c-string) 
	       (set! frtype 'scheme-pointer)
	       `(let ([,var (let () ,@body)])
		  (and ,var (##sys#make-c-string ,var)) ) ]
	      [(symbol)
	       (set! frtype 'nonnull-scheme-pointer)
	       `(##sys#make-c-string (let () ,@body)) ]	;*** Does this work?
	      [(nonnull-c-string)
	       (set! frtype 'nonnull-scheme-pointer)
	       `(##sys#make-c-string (let () ,@body)) ]
	      [(c-string*)
	       (set! frtype 'scheme-object)
	       `(let ([,var (let () ,@body)])
		  (and ,var (##core#inline "C_dupstr" (##sys#make-c-string ,var))) ) ]
	      [(nonnull-c-string*)
	       (set! frtype 'scheme-object)
	       `(##core#inline "C_dupstr" (##sys#make-c-string (let () ,@body))) ]
	      [else `(let () ,@body)] ) ] )
      `(define-entry-point ,n ,(map reverse args) ,(if (eq? frtype 'void) '() (list frtype))
	 ,xbody) ) )

  (let loop ([quals ""] [args args0])
    (if (null? args)
	(error "syntax error in `define-embedded' form" `(define-embedded ,@args0)) 
	(let ([q (car args)])
	  (if (string? q)
	      (loop (string-append quals " " q) (cdr args))
	      (let* ([head q]
		     [cconv ""] )
		(##sys#check-syntax 'define-embedded args '(#(_ 1) _ . #(_ 1)))
		(let ([h1 (car head)])
		  (when (string? h1)
		    (set! cconv h1)
		    (set! head (cdr head)) )
		  (##sys#check-syntax 'define-embedded head '(symbol . #((_ _) 0)))
		  (let ([name (car head)]
			[rtype (cadr args)]
			[body (cddr args)]
			[args (cdr head)] 
			[n ##sys#embedded-entry-point-counter] )
		    (set! ##sys#embedded-entry-point-counter (add1 n))
		    `(begin
		       ,(expand-c quals cconv name args rtype n)
		       ,(expand-scm args rtype body n) ) ) ) ) ) ) ) ) )
