;;;; chicken-default-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


(include "chicken-entry-points")

(define-foreign-variable chicken_entry_point_status bool "C_entry_point_status")

(define ##sys#default-entry-point-error "")

(define ##sys#safe-execute
  (let ([open-output-string open-output-string]
	[get-output-string get-output-string] 
	[print-error-message print-error-message] )
    (lambda (thunk)
      (set! chicken_entry_point_status #t)
      (handle-exceptions ex 
	  (let ([o (open-output-string)])
	    (print-error-message ex o)
	    (set! ##sys#default-entry-point-error (get-output-string o))
	    (set! chicken_entry_point_status #f) 
	    #f)
	(thunk) ) ) ) )

(define (##sys#check-entry-point-result-size len rlen)
  (when (fx>= len rlen)
    (##sys#error "Error: not enough room for result string" len rlen) ) )

(define-foreign-variable chicken_yield_entry_point int "CHICKEN_YIELD_ENTRY_POINT")
(define-foreign-variable chicken_eval_entry_point int "CHICKEN_EVAL_ENTRY_POINT")
(define-foreign-variable chicken_eval_string_entry_point int "CHICKEN_EVAL_STRING_ENTRY_POINT")
(define-foreign-variable chicken_eval_to_string_entry_point int "CHICKEN_EVAL_TO_STRING_ENTRY_POINT")
(define-foreign-variable chicken_eval_string_to_string_entry_point int "CHICKEN_EVAL_STRING_TO_STRING_ENTRY_POINT")
(define-foreign-variable chicken_apply_entry_point int "CHICKEN_APPLY_ENTRY_POINT")
(define-foreign-variable chicken_apply_to_string_entry_point int "CHICKEN_APPLY_TO_STRING_ENTRY_POINT")
(define-foreign-variable chicken_read_entry_point int "CHICKEN_READ_ENTRY_POINT")
(define-foreign-variable chicken_load_entry_point int "CHICKEN_LOAD_ENTRY_POINT")
(define-foreign-variable chicken_get_error_message_entry_point int "CHICKEN_GET_ERROR_MESSAGE_ENTRY_POINT")
(define-foreign-variable chicken_default_entry_point_count int "CHICKEN_DEFAULT_ENTRY_POINT_COUNT")

(define-entry-point chicken_yield_entry_point () ()
  (##sys#safe-execute thread-yield!) )

(define-entry-point chicken_eval_entry_point ([exp scheme-object]) (scheme-object)
  (##sys#safe-execute (lambda () (eval exp))) )

(define-entry-point chicken_eval_string_entry_point ([str c-string]) (scheme-object)
  (##sys#safe-execute
   (lambda ()
     (let ([i (open-input-string str)])
       (eval (read i)) ) ) ) )

(define-entry-point chicken_eval_to_string_entry_point ([exp scheme-object] [buf c-string] [bufsize int]) (int c-string)
  (let ([result 
	 (##sys#safe-execute
	  (lambda ()
	    (let ([o (open-output-string)])
	      (write (eval exp) o) 
	      (get-output-string o) ) ) ) ] )
    (if result
	(begin
	  (##sys#check-entry-point-result-size (##sys#size result) bufsize)
	  (values 0 result) )
	(values 0 "") ) ) )

(define-entry-point chicken_eval_string_to_string_entry_point ([str c-string] [buf c-string] [bufsize int]) (int c-string)
  (let ([result 
	 (##sys#safe-execute
	  (lambda ()
	    (let ([o (open-output-string)]
		  [i (open-input-string str)] )
	      (write (eval (read i)) o) 
	      (get-output-string o) ) ) ) ] )
    (if result
	(begin
	  (##sys#check-entry-point-result-size (##sys#size result) bufsize)
	  (values 0 result) )
	(values 0 "") ) ) )

(define-entry-point chicken_apply_entry_point ([func scheme-object] [args scheme-object]) (scheme-object)
  (##sys#safe-execute (lambda () (apply func args))) )

(define-entry-point chicken_apply_to_string_entry_point ([func scheme-object] [args scheme-object] [buf c-string] [bufsize int]) (int int c-string)
  (let ([result 
	 (##sys#safe-execute 
	  (lambda ()
	    (let ([o (open-output-string)])
	      (write (apply func args) o)
	      (get-output-string o) ) ) ) ] )
    (if result
	(begin
	  (##sys#check-entry-point-result-size (##sys#size result) bufsize)
	  (values 0 0 result) )
	(values 0 0 "") ) ) )

(define-entry-point chicken_read_entry_point ([str c-string]) (scheme-object)
  (##sys#safe-execute
   (lambda ()
     (let ([i (open-input-string str)])
       (read i) ) ) ) )

(define-entry-point chicken_load_entry_point ([str c-string]) ()
  (##sys#safe-execute (lambda () (load str))) )

(define-entry-point chicken_get_error_message_entry_point ([buf c-string] [bufsize int]) (c-string)
  (##sys#check-entry-point-result-size (##sys#size ##sys#default-entry-point-error) bufsize)
  ##sys#default-entry-point-error)

(define ##sys#embedded-entry-point-counter chicken_default_entry_point_count)
