(declare (uses srfi-18)
	 (run-time-macros))

(define-macro (guard . form)
  (let* ((clause (or (and (pair? form) (car form))
                     (error "guard: syntax error in" form)))
         (body (cdr form))
	 (condition (gensym))
	 (handler-k (gensym))
	 (return (gensym))
	 (oldh (gensym)))
    `((call-with-current-continuation
       (lambda (,return)
	 (let ((,oldh (current-exception-handler)))
	   (with-exception-handler
	    (lambda (,condition)
	      (with-exception-handler
	       ,oldh
	       (call-with-current-continuation
		(lambda (,handler-k)
		  (,return (lambda ()
			    ((lambda (,(car clause))
			       ,(let loop ((clauses (cdr clause)))
				  (if (null? clauses)
				      `(raise ,(car clause))
				      (let ((c (car clauses)))
					(cond
					 ((eq? 'else (car c))
					  (if (null? (cdr c))
					      '#f
					      (if (null? (cddr c))
						  (cadr c)
						  `(begin . ,(cdr c)))))
					 ((and (pair? c) (pair? (cdr c)) (eq? '=> (cadr c)))
					  (let ((v (gensym)))
					    `(let ((,v ,(car c)))
					       (if ,v (,(caddr c)) ,(loop (cdr clauses))))))
					 ((and (pair? c) (null? (cdr c)))
					  (let ((v (gensym)))
					    `(let ((,v ,(car c)))
					       (if ,v ,v ,(loop (cdr clauses))))))
					 ((pair? c)
					  `(if ,(car c)
					       ,(if (null? (cddr c))
						    (cadr c)
						    `(begin . ,(cdr c)))
					       ,(loop (cdr clauses))))
					 (else (error "guard syntax error in ~a" c)))))))
			     ,condition)))))))
	    (lambda ()
	      (##sys#call-with-values
	       (lambda ()
		 ,(if (and (pair? body) (null? (cdr body)))
		      (car body) `(begin . ,body) ))
	       (lambda args
		 (,return (lambda () (##sys#apply ##sys#values args)))) ) ) )) ) ))))

(define (logerr . args)
  (apply format (current-error-port) args)
  (flush-output (current-error-port))
  (format (current-error-port) "let's do some garbage\n")
  (flush-output (current-error-port))
  (let ((s ""))
    (do ((i 0 (+ i 1)))
	((eqv? i 20000) #t)
      (set! s (string-append s (number->string i)))))
  (format (current-error-port) "enough garbage\n")
  (flush-output (current-error-port)))

(define *local-timeout-symbol* '(timeout))

(define (timeout-object) *local-timeout-symbol*)

(define (timeout-object? obj)
  (eq? *local-timeout-symbol* obj))

(define (with-timeout timeout thunk)
  (if timeout
      (let ([thread (thread-start! (make-thread thunk
						;; (string-append (thread-name (current-thread)) "-worker")
						))])
	(guard
	 (condition
	  ((join-timeout-exception? condition)
	   (thread-terminate! thread)
	   (raise (timeout-object)))
	  (else
	   (raise (if (uncaught-exception? condition)
		      (uncaught-exception-reason condition)
		      condition))))
	 (thread-join! thread timeout)))
      (thunk)))

(define (load-or-die str)
  (guard
   (exception (else (logerr "Fatal load error in ~a:~s ~a\n" file ((condition-property-accessor 'exn 'message #f) exception) ((condition-property-accessor 'exn 'arguments #f) exception))
                    (exit 0)))
   (call-with-input-string str
     (lambda (port)
       (let loop ((expr (read port))
                  (last #f))
         (if (eof-object? expr)
             last
             (loop (read port)
                   (guard
                    (ex (else (logerr "Load error in ~a:~a in ~a\n"
                                      str ex expr) #f))
                    (eval expr)))))))))

(print "test")
(load-or-die "(define aa (with-timeout 3 (lambda () (do () (#f) #t))))")
(logerr "done\n")
(exit 0)