;; -*-theme-d-*-

;; Copyright (C) 2017 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

;; Most forms are ported from SRFI-72 source code by Andre van Tonder.

(define-interface (standard-library core-forms)


  (define-syntax with-syntax
    ($lambda (x)
      (syntax-case x ()
	((_ () e1 e2 ...)
	 (syntax (begin e1 e2 ...)))
	((_ ((out in)) e1 e2 ...)
	 (syntax (syntax-case in ()
		   (out (begin e1 e2 ...)))))
	((_ ((out in) ...) e1 e2 ...)
	 (syntax (syntax-case ($list in ...) ()
		   ((out ...) (begin e1 e2 ...))))))))

  (define-syntax syntax-rules
    ($lambda (x)
      ($define clause
	($lambda (y)
	  (syntax-case y ()
	    (((keyword . pattern) template)
	     (syntax ((dummy . pattern) (syntax template))))
	    (_
	     ($syntax-violation 'syntax-rules "Invalid expression" x)))))
      (syntax-case x ()
	((_ (k ...) cl ...)
	 ($for-all $identifier? (syntax (k ...)))
	 (with-syntax (((cl ...) ($map clause (syntax (cl ...)))))
		      (syntax
		       ($lambda (x) (syntax-case x (k ...) cl ...))))))))

  (define-syntax $let
    ($lambda (x)
      (syntax-case x ()
	((_ ((x v) ...) e1 e2 ...)
	 ($for-all $identifier? (syntax (x ...)))
	 (syntax (($lambda (x ...) e1 e2 ...) v ...)))
	((_ f ((x v) ...) e1 e2 ...)
	 ($for-all $identifier? (syntax (f x ...)))
	 (syntax (($letrec ((f ($lambda (x ...) e1 e2 ...))) f) v ...))))))

  (define-syntax $letrec
    ($lambda (x)
      (syntax-case x ()
	((_ ((i v) ...) e1 e2 ...)
	 (with-syntax (((t ...) ($generate-temporaries (syntax (i ...)))))
		      (syntax ($let ((i $undefined) ...)
				($let ((t v) ...)
				  (set! i t) ...
				  ($let () e1 e2 ...)))))))))

  (define-syntax $letrec*
    ($lambda (x)
      (syntax-case x ()
	((_ ((i v) ...) e1 e2 ...)
	 (syntax ($let ()
		   ($define i v) ...
		   ($let () e1 e2 ...)))))))

  (define-syntax $let*
    ($lambda (x)
      (syntax-case x ()
	((_ () e1 e2 ...)
	 (syntax ($let () e1 e2 ...)))
	((_ ((x v) ...) e1 e2 ...)
	 ($for-all $identifier? (syntax (x ...)))
	 ($let f ((bindings (syntax ((x v) ...))))
	   (syntax-case bindings ()
	     (((x v))        (syntax ($let ((x v)) e1 e2 ...)))
	     (((x v) . rest) (with-syntax ((body (f (syntax rest))))
					  (syntax ($let ((x v)) body))))))))))

  (define-syntax cond
    (syntax-rules (else)
      ((_ (else result1 result2 ...))
       (begin result1 result2 ...))
      ;; The => form is not very useful when the condition is boolean valued.
      ;; ((_ (test => result))
      ;;  (let ((temp test))
      ;; 	 (if temp (result temp))))
      ;; ((_ (test => result) clause1 clause2 ...)
      ;;  (let ((temp test))
      ;; 	 (if temp
      ;; 	     (result temp)
      ;; 	     (cond clause1 clause2 ...))))
      ((_ (test)) test)
      ((_ (test) clause1 clause2 ...)
       (let ((temp test))
	 (if temp
	     temp
	     (cond clause1 clause2 ...))))
      ((_ (test result1 result2 ...))
       (if test (begin result1 result2 ...)))
      ((_ (test result1 result2 ...)
	  clause1 clause2 ...)
       (if test
	   (begin result1 result2 ...)
	   (cond clause1 clause2 ...)))))

  (define-syntax cond-object
    ($lambda (x)
      (syntax-case x ()
	((_ c1 c2 ...)
	 ($let f ((c1  (syntax c1))
		  (c2* (syntax (c2 ...))))
	   (syntax-case c2* ()
	     (()
	      (syntax-case c1 (else =>)
		((else e1 e2 ...) (syntax (begin e1 e2 ...)))
		((e0)             (syntax (let ((t e0)) (if-object t t))))
		((e0 => e1)       (syntax (let ((t e0)) (if-object t (e1 t)))))
		((e0 e1 e2 ...)   (syntax (if-object e0 (begin e1 e2 ...))))
		(_                ($syntax-violation 'cond-object
						     "Invalid expression" x))))
	     ((c2 c3 ...)
	      (with-syntax ((rest (f (syntax c2)
				     (syntax (c3 ...)))))
			   (syntax-case c1 (else =>)
			     ((e0)           (syntax (let ((t e0)) (if-object t t rest))))
			     ((e0 => e1)     (syntax (let ((t e0)) (if-object t (e1 t) rest))))
			     ((e0 e1 e2 ...) (syntax (if-object e0 (begin e1 e2 ...) rest)))
			     (_              ($syntax-violation 'cond-object
								"Invalid expression" x)))))))))))

  (define-syntax case
    ($lambda (x)
      (syntax-case x ()
	((_ e c1 c2 ...)
	 (with-syntax ((body
			($let f ((c1 (syntax c1))
				 (cmore (syntax (c2 ...))))
			  (if-object ($null? cmore)
				   (syntax-case c1 (else)
				     ((else e1 e2 ...)    (syntax (begin e1 e2 ...)))
				     (((k ...) e1 e2 ...) (syntax (if (member? t '(k ...))
								      (begin e1 e2 ...)))))
				   (with-syntax ((rest (f ($car cmore) ($cdr cmore))))
						(syntax-case c1 ()
						  (((k ...) e1 e2 ...)
						   (syntax (if (member? t '(k ...))
							       (begin e1 e2 ...)
							       rest)))))))))
		      (syntax (let ((t e)) body)))))))

  (define-syntax =>
    ($lambda (x)
      ($syntax-violation '=> "Invalid expression" x)))
  
  (define-syntax else
    ($lambda (x)
      ($syntax-violation 'else "Invalid expression" x)))

  ;; Taken from module (ice-9 boot-9) in guile.
  (define-syntax and
    (syntax-rules ()
      ((_) #t)
      ((_ x) x)
      ((_ x y ...) (if x (and y ...) #f))))

  ;; Taken from module (ice-9 boot-9) in guile.
  (define-syntax or
    (syntax-rules ()
      ((_) #f)
      ((_ x) x)
      ((_ x y ...) (let ((t x)) (if t t (or y ...))))))

  ;; Ported from module (ice-9 boot-9) in guile.
  (define-syntax $and
    (syntax-rules ()
      ((_) #t)
      ((_ x) x)
      ((_ x y ...) (if-object x ($and y ...) #f))))

  ;; Ported from module (ice-9 boot-9) in guile.
  (define-syntax $or
    (syntax-rules ()
      ((_) #f)
      ((_ x) x)
      ((_ x y ...) ($let ((t x)) (if-object t t ($or y ...))))))

  ;; Ported from module (ice-9 boot-9) in guile.
  (define-syntax and-object
    (syntax-rules ()
      ((_) #t)
      ((_ x) x)
      ((_ x y ...) (if-object x (and-object y ...) #f))))

  ;; Ported from module (ice-9 boot-9) in guile.
  (define-syntax or-object
    (syntax-rules ()
      ((_) #f)
      ((_ x) x)
      ((_ x y ...) (let ((t x)) (if-object t t (or-object y ...))))))

  (define-syntax quasisyntax
    ($lambda (e)
      
      ;; Expand returns a list of the form
      ;;    [template[t/e, ...] (replacement ...)]
      ;; Here template[t/e ...] denotes the original template
      ;; with unquoted expressions e replaced by fresh
      ;; variables t, followed by the appropriate ellipses
      ;; if e is also spliced.
      ;; The second part of the return value is the list of
      ;; replacements, each of the form (t e) if e is just
      ;; unquoted, or ((t ...) e) if e is also spliced.
      ;; This will be the list of bindings of the resulting
      ;; with-syntax expression.
      
      ($define expand
	($lambda (x level)
	  (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
	    ((quasisyntax e)
	     (with-syntax (((k _)     x) ;; original identifier must be copied
			   ((e* reps) (expand (syntax e) ($+ level 1))))
			  (syntax ((k e*) reps))))                                  
	    ((unsyntax e)
	     ($= level 0)
	     (with-syntax (((t) ($generate-temporaries '(t))))
			  (syntax (t ((t e))))))
	    (((unsyntax e ...) . r)
	     ($= level 0)
	     (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
			   ((t ...)        ($generate-temporaries (syntax (e ...)))))
			  (syntax ((t ... . r*)
				   ((t e) ... rep ...)))))
	    (((unsyntax-splicing e ...) . r)
	     ($= level 0)
	     (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
			   ((t ...)        ($generate-temporaries (syntax (e ...)))))
			  (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
				       (syntax ((t ... ... . r*)
						(((t ...) e) ... rep ...))))))
	    ((k . r)
	     ($and ($> level 0)
		   ($identifier? (syntax k))
		   ($or ($free-identifier=? (syntax k) (syntax unsyntax))
			($free-identifier=? (syntax k) (syntax unsyntax-splicing))))
	     (with-syntax (((r* reps) (expand (syntax r) ($- level 1))))
			  (syntax ((k . r*) reps))))
	    ((h . t)
	     (with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
			   ((t* (rep2 ...)) (expand (syntax t) level)))
			  (syntax ((h* . t*)
				   (rep1 ... rep2 ...)))))
	    ;; (#(e ...)                                                               
	    ;;  (with-syntax ((((e* ...) reps)
	    ;; 		    (expand ($vector->list (syntax #(e ...))) level)))
	    ;; 		  (syntax (#(e* ...) reps))))
	    (other
	     (syntax (other ()))))))
      
      (syntax-case e ()
	((_ template)
	 (with-syntax (((template* replacements) (expand (syntax template) 0)))
		      (syntax
		       (with-syntax replacements (syntax template*))))))))

  (define-syntax unsyntax
    ($lambda (e)
      ($syntax-violation 'unsyntax "Invalid expression" e)))

  (define-syntax unsyntax-splicing
    ($lambda (e)
      ($syntax-violation 'unsyntax "Invalid expression" e)))

  ;; Optimised version copied from portable syntax-case (Dybvig)

  (define-syntax quasiquote
    ($let ()
      ($define quasi
	($lambda (p lev)
	  (syntax-case p (unquote quasiquote)
	    ((unquote p)
	     (if ($= lev 0)
		 (syntax ("value" p))
		 (quasicons (syntax ("quote" unquote)) (quasi (syntax (p)) ($- lev 1)))))
	    ((quasiquote p) (quasicons (syntax ("quote" quasiquote)) (quasi (syntax (p)) ($+ lev 1))))
	    ((p . q)
	     (syntax-case (syntax p) (unquote unquote-splicing)
	       ((unquote p ...)
		(if ($= lev 0)
		    (quasilist* (syntax (("value" p) ...)) (quasi (syntax q) lev))
		    (quasicons
		     (quasicons (syntax ("quote" unquote)) (quasi (syntax (p ...)) ($- lev 1)))
		     (quasi (syntax q) lev))))
	       ((unquote-splicing p ...)
		(if ($= lev 0)
		    (quasiappend (syntax (("value" p) ...)) (quasi (syntax q) lev))
		    (quasicons
		     (quasicons (syntax ("quote" unquote-splicing)) (quasi (syntax (p ...)) ($- lev 1)))
		     (quasi (syntax q) lev))))
	       (_ (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))))
	    ;; (#(x ...) (quasivector (vquasi (syntax (x ...)) lev)))
	    (p (syntax ("quote" p))))))
      ($define vquasi
	($lambda (p lev)
	  (syntax-case p ()
	    ((p . q)
	     (syntax-case (syntax p) (unquote unquote-splicing)
	       ((unquote p ...)
		(if ($= lev 0)
		    (quasilist* (syntax (("value" p) ...)) (vquasi (syntax q) lev))
		    (quasicons
		     (quasicons (syntax ("quote" unquote)) (quasi (syntax (p ...)) ($- lev 1)))
		     (vquasi (syntax q) lev))))
	       ((unquote-splicing p ...)
		(if ($= lev 0)
		    (quasiappend (syntax (("value" p) ...)) (vquasi (syntax q) lev))
		    (quasicons
		     (quasicons
		      (syntax ("quote" unquote-splicing))
		      (quasi (syntax (p ...)) ($- lev 1)))
		     (vquasi (syntax q) lev))))
	       (_ (quasicons (quasi (syntax p) lev) (vquasi (syntax q) lev)))))
	    (() (syntax ("quote" ()))))))
      ($define quasicons
	($lambda (x y)
	  (with-syntax ((x x) (y y))
		       (syntax-case (syntax y) ()
			 (("quote" dy)
			  (syntax-case (syntax x) ()
			    (("quote" dx) (syntax ("quote" (dx . dy))))
			    (_ (if ($null? (syntax dy)) (syntax ("list" x)) (syntax ("list*" x y))))))
			 (("list" . stuff) (syntax ("list" x . stuff)))
			 (("list*" . stuff) (syntax ("list*" x . stuff)))
			 (_ (syntax ("list*" x y)))))))
      ($define quasiappend
	($lambda (x y)
	  (syntax-case y ()
	    (("quote" ())
	     (cond
	      (($null? x) (syntax ("quote" ())))
	      (($null? ($cdr x)) ($car x))
	      (else (with-syntax (((p ...) x)) (syntax ("append" p ...))))))
	    (_
	     (cond
	      (($null? x) y)
	      (else (with-syntax (((p ...) x) (y y)) (syntax ("append" p ... y)))))))))
      ($define quasilist*
	($lambda (x y)
	  ($let f ((x x))
	    (if ($null? x)
		y
		(quasicons ($car x) (f ($cdr x)))))))
      ;; ($define quasivector
      ;; 	($lambda (x)
      ;; 	  (syntax-case x ()
      ;; 	    (("quote" (x ...)) (syntax ("quote" #(x ...))))
      ;; 	    (_
      ;; 	     ($let f ((y x) (k ($lambda (ls) (quasisyntax ("vector" (unsyntax-splicing ls))))))
      ;; 	       (syntax-case y ()
      ;; 		 (("quote" (y ...)) (k (syntax (("quote" y) ...))))
      ;; 		 (("list" y ...) (k (syntax (y ...))))
      ;; 		 (("list*" y ... z) (f (syntax z) ($lambda (ls) (k ($append (syntax (y ...)) ls)))))
      ;; 		 (else (quasisyntax ("list->vector" (unsyntax x))))))))))
      ($define emit
	($lambda (x)
	  (syntax-case x ()
	    (("quote" x) (syntax 'x))
	    (("list" x ...) (quasisyntax (list (unsyntax-splicing ($map emit (syntax (x ...)))))))
	    ;; could emit list* for 3+ arguments if implementation supports list*
	    (("list*" x ... y)
	     ($let f ((x* (syntax (x ...))))
	       (if ($null? x*)
		   (emit (syntax y))
		   (quasisyntax (cons (unsyntax (emit ($car x*))) (unsyntax (f ($cdr x*))))))))
	    (("append" x ...) (quasisyntax ($append (unsyntax-splicing ($map emit (syntax (x ...)))))))
	    ;; (("vector" x ...) (quasisyntax ($vector (unsyntax-splicing ($map emit (syntax (x ...)))))))
	    ;; (("list->vector" x) (quasisyntax ($list->vector (unsyntax (emit (syntax x))))))
	    (("value" x) (syntax x)))))
      ($lambda (x)
	(syntax-case x ()
	  ;; convert to intermediate language, combining introduced (but not
	  ;; unquoted source) quote expressions where possible and choosing
	  ;; optimal construction code otherwise, then emit Scheme code
	  ;; corresponding to the intermediate language forms.
	  ((_ e) (emit (quasi (syntax e) 0)))))))

  (define-syntax unquote
    ($lambda (e)
      ($syntax-violation 'unquote "Invalid expression" e)))

  (define-syntax unquote-splicing
    ($lambda (e)
      ($syntax-violation 'unquote-splicing "Invalid expression" e)))

  (define-syntax identifier-syntax
    ($lambda (x)
      (syntax-case x (set!)
        ((_ e)
         (syntax ($lambda (x)
                   (syntax-case x ()
                     (id ($identifier? (syntax id)) (syntax e))
                     ((_ x (... ...))              (syntax (e x (... ...))))))))
        ((_ (id exp1) 
            ((set! var val) exp2))
         ($and ($identifier? (syntax id)) 
	       ($identifier? (syntax var)))
         (syntax 
          ($make-variable-transformer
           ($lambda (x)
             (syntax-case x (set!)
               ((set! var val)               (syntax exp2))
               ((id x (... ...))             (syntax (exp1 x (... ...))))
               (id ($identifier? (syntax id)) (syntax exp1))))))))))

  (define-syntax let*
    (syntax-rules ()
      ((_ () body1 ...)
       (let () body1 ...))
      ((_ ((var val)) body1 ...)
       (let ((var val)) body1 ...))
      ((_ ((var type val)) body1 ...)
       (let ((var type val)) body1 ...))
      ((_ ((var val) var1 var2 ...) body1 ...)
       (let ((var val)) (let* (var1 var2 ...) body1 ...)))
      ((_ ((var type val) var1 var2 ...) body1 ...)
       (let ((var type val)) (let* (var1 var2 ...) body1 ...)))))

  (define-syntax let*-mutable
    (syntax-rules ()
      ((_ () body1 ...)
       (let-mutable () body1 ...))
      ((_ ((var type val)) body1 ...)
       (let-mutable ((var type val)) body1 ...))
      ((_ ((var type val) var1 var2 ...) body1 ...)
       (let-mutable ((var type val)) (let*-mutable (var1 var2 ...) body1 ...)))))

  (define-syntax let*-volatile
    (syntax-rules ()
      ((_ () body1 ...)
       (let-volatile () body1 ...))
      ((_ ((var type val)) body1 ...)
       (let-volatile ((var type val)) body1 ...))
      ((_ ((var type val) var1 var2 ...) body1 ...)
       (let-volatile ((var type val)) (let*-volatile (var1 var2 ...) body1 ...)))))

  (define-syntax do
    (syntax-rules ()
      ((_ ((var type init update) ...) (condition result) body1 ...)
       (let-mutable ((var type init) ...)
	 (until (condition result)
	   body1 ...
	   (set! var update) ...)))
      ((_ ((var type init update) ...) (condition) body1 ...)
       (let-mutable ((var type init) ...)
	 (until (condition)
	   body1 ...
	   (set! var update) ...)))))

  (define-syntax define-simple-proc
    (syntax-rules ()
      ((_ name (((arg-name arg-type) ...) result-type attrs)
	  body1 body2 ...)
       (begin
	 (declare name (:simple-proc (arg-type ...)
				     result-type attrs))
	 (define name (lambda (((arg-name arg-type) ...)
			       result-type attrs)
			body1 body2 ...))))))

  (define-syntax define-param-proc
    (syntax-rules ()
      ((_ name
	  (param1 param2 ...)
	  (((arg-name arg-type) ...) result-type attrs)
	  body1 body2 ...)
       (begin
	 (declare name (:param-proc (param1 param2 ...)
				    (arg-type ...) result-type
				    attrs))
	 (define name (param-lambda
			  (param1 param2 ...)
			  (((arg-name arg-type) ...) result-type
			   attrs)
			body1 body2 ...))))))

  (define-syntax define-simple-method
    (syntax-rules ()
      ((_ name (((arg-name arg-type) ...) result-type attrs)
	  body1 body2 ...)
       (begin
	 (declare-method name (:simple-proc (arg-type ...)
					    result-type attrs))
	 (add-method name (lambda (((arg-name arg-type) ...)
				   result-type attrs)
			    body1 body2 ...))))))

  (define-syntax define-static-simple-method
    (syntax-rules ()
      ((_ name (((arg-name arg-type) ...) result-type attrs)
	  body1 body2 ...)
       (begin
	 (declare-static-method name (:simple-proc (arg-type ...)
						   result-type attrs))
	 (add-static-method name (lambda (((arg-name arg-type) ...)
					  result-type attrs)
				   body1 body2 ...))))))

  (define-syntax define-param-method
    (syntax-rules ()
      ((_ name (param1 param2 ...) (((arg-name arg-type) ...)
				    result-type attrs)
	  body1 body2 ...)
       (begin
	 (declare-method name (:param-proc (param1 param2 ...)
					   (arg-type ...)
					   result-type attrs))
	 (add-method name (param-lambda (param1 param2 ...)
			      (((arg-name arg-type) ...)
			       result-type attrs)
			    body1 body2 ...))))))

  (define-syntax define-static-param-method
    (syntax-rules ()
      ((_ name (param1 param2 ...) (((arg-name arg-type) ...)
				    result-type attrs)
	  body1 body2 ...)
       (begin
	 (declare-static-method name (:param-proc (param1 param2 ...)
						  (arg-type ...)
						  result-type attrs))
	 (add-static-method name (param-lambda (param1 param2 ...)
				     (((arg-name arg-type) ...)
				      result-type attrs)
				   body1 body2 ...))))))

  (define-syntax define-normal-goops-class
    (syntax-rules ()
      ((_ name target-name superclass inh? imm? ebv?)
       (define-goops-class name target-name superclass
	 inh? imm? ebv? #f ()
	 eqv? equal?))))

  (define-syntax guard-general
    (syntax-rules ()
      ((_ variable handler body)
       (call/cc
        (lambda-automatic
         (((jump (:procedure
                  ((static-type-of
                    (let ((variable (static-cast <object> null)))
                      handler)))
                  <none> (pure never-returns))))
          (pure))
         (with-exception-handler
          (lambda (((variable <object>)) <none> (pure never-returns))
            (jump handler))
          (lambda-automatic (() pure)
                            body)))))))

  (define-syntax guard0
    (syntax-rules ()
      ((_ (variable cond-clause ...) body)
       (guard-general variable (cond cond-clause ...) body))
      ((_ (variable cond-clause ...) body1 ...)
       (guard-general variable (cond cond-clause ...) (begin body1 ...)))))

  (define-syntax guard
    (syntax-rules (else)
      ((_ (variable cond-clause ... . ((else else-clause ...)))
	  body1 ...)
       (guard0 (variable cond-clause ... (else else-clause ...))
	       body1 ...))
      ((_ (variable cond-clause ...) body1 ...)
       (guard0 (variable cond-clause ... (else (raise variable)))
	       body1 ...))))

  (define-syntax guard-general-nonpure
    (syntax-rules ()
      ((_ variable handler body)
       (call/cc-nonpure
        (lambda-automatic
         (((jump (:procedure
                  ((static-type-of
                    (let ((variable (static-cast <object> null)))
                      handler)))
                  <none> (pure never-returns))))
          (nonpure))
         (with-exception-handler-nonpure
          (lambda (((variable <object>)) <none> (nonpure never-returns))
            (jump handler))
          (lambda-automatic (() nonpure)
                            body)))))))

  (define-syntax guard0-nonpure
    (syntax-rules ()
      ((_ (variable cond-clause ...) body)
       (guard-general-nonpure variable (cond cond-clause ...) body))
      ((_ (variable cond-clause ...) body1 ...)
       (guard-general-nonpure variable (cond cond-clause ...)
			      (begin body1 ...)))))

  (define-syntax guard-nonpure
    (syntax-rules (else)
      ((_ (variable cond-clause ... . ((else else-clause ...)))
	  body1 ...)
       (guard0-nonpure (variable cond-clause ... (else else-clause ...))
	       body1 ...))
      ((_ (variable cond-clause ...) body1 ...)
       (guard0-nonpure (variable cond-clause ... (else (raise variable)))
	       body1 ...))))

  (define-syntax guard-general-without-result
    (syntax-rules ()
      ((_ variable handler body)
       (call/cc-without-result
        (lambda-automatic
         (((jump (:procedure () <none> (pure never-returns))))
          (nonpure))
         (with-exception-handler-nonpure
          (lambda (((variable <object>)) <none> (nonpure never-returns))
	    handler
	    (jump))
          (lambda (() <none> nonpure)
            body)))))))

  (define-syntax guard0-without-result
    (syntax-rules ()
      ((_ (variable cond-clause ...) body)
       (guard-general-without-result variable (cond cond-clause ...) body))
      ((_ (variable cond-clause ...) body1 ...)
       (guard-general-without-result variable (cond cond-clause ...)
			      (begin body1 ...)))))

  (define-syntax guard-without-result
    (syntax-rules (else)
      ((_ (variable cond-clause ... . ((else else-clause ...)))
	  body1 ...)
       (guard0-without-result (variable cond-clause ... (else else-clause ...))
	       body1 ...))
      ((_ (variable cond-clause ...) body1 ...)
       (guard0-without-result (variable cond-clause ... (else (raise variable)))
	       body1 ...))))

  (define-syntax exec/cc
    (syntax-rules ()
      ((_ jump-proc jump-type body)
       (call/cc
	(lambda-automatic
	 (((jump-proc
	    (:simple-proc (jump-type) <none> (pure never-returns))))
	  pure)
	 body)))))

  (define-syntax execute-with-current-continuation
    (identifier-syntax exec/cc))
  
  (define-syntax exec/cc-nonpure
    (syntax-rules ()
      ((_ jump-proc jump-type body)
       (call/cc-nonpure
	(lambda-automatic
	 (((jump-proc
	    (:simple-proc (jump-type) <none> (pure never-returns))))
	  nonpure)
	 body)))))

  (define-syntax execute-with-current-continuation-nonpure
    (identifier-syntax exec/cc-nonpure))

  (define-syntax exec/cc-without-result
    (syntax-rules ()
      ((_ jump-proc body)
       (call/cc-without-result
	(lambda
	 (((jump-proc
	    (:simple-proc () <none> (pure never-returns))))
	  <none> nonpure)
	 body)))))

  (define-syntax execute-with-current-continuation-without-result
    (identifier-syntax exec/cc-without-result))

  (define-syntax make
    (syntax-rules ()
      ((_ clas arg1 ...)
       ((constructor clas) arg1 ...)))))
