;;;
;;; S-expression OCaml
;;; Written by Uchizono (uchizono.com)
;;;

(define version "0.20130406")

(use gauche.collection)
(use gauche.parseopt)
(use srfi-1)
(use srfi-13)


(define expand-var (lambda (name)
		(if (list? name)
			(cond
				((and (not (null? name)) (eq? (car name) '|::|))
					(cons '|::| (map expand-var (cdr name))))
				((and (not (null? name)) (eq? (car name) '=))
					(cons '= (map expand-var (cdr name))))
				(#t
					(cons 'tuple (map expand-var name)))
				)
			name
			)
	))

(define gen-let (lambda (src rec-flag)
	(string-join (map
		(lambda (p)
			(string-append
				"let "
				(if rec-flag "rec " "")
				(if (list? (car p))
					(main-loop (expand-var (car p)) "")
					(symbol->string (car p))
					)
				(if (= (length p) 3)
					(string-append " : " (cadr p))
					""
					)
				" = "
				(main-loop (if (= (length p) 3) (caddr p) (cadr p)) "")
				" in"
				)
			)
		src) "\n")
	))


(define gen-let-t (lambda (src rec-flag)
	(string-append
		"let "
		(if rec-flag "rec " "")
		"("
		(string-join (map (lambda (p)
			(if (list? (car p))
				(main-loop (expand-var (car p)) "")
				(symbol->string (car p))
				)
			) src) ", ")
		" : "
		(string-join (map (lambda (p) (if (= (length p) 3) (cadr p) "_")) src) " * ")
		")"
		" = "
		"("
		(string-join
			(map (lambda (p)
				(main-loop (if (= (length p) 3) (caddr p) (cadr p)) "")
				) src)
			",\n")
		")"
		" in"
		)
	))



(define gen-ocaml (lambda (src)
	(string-join src "\n")
	))

(define gen-module (lambda (src)
	(string-append
		"module "
		(symbol->string (car src))
		" = "
		(cond
			((symbol? (cadr src))
				(symbol->string (cadr src))
				)
			((or
				(eq? (car (cadr src)) 'struct)
				(eq? (car (cadr src)) 'functor)
				)
				(main-loop (cadr src) "\n")
				)
			((hash-table-exists? macro-table (car (cadr src)))
				(main-loop (expand-syntax (cadr src)) "\n")
				)
			(#t
				(string-append
					(symbol->string (car (cadr src)))
					"("
					(main-loop (cadr (cadr src)) "\n")
					")"
					)
				)
			)
		)
	))

(define gen-struct (lambda (src)
	(string-append
		" struct "
(string-join
(map
		(lambda (src2)
			(main-loop src2 ";;\n")
			)
		src)
		"")
		" end "
		)
	))

(define gen-functor (lambda (src)
	(string-append
		"functor ("
		(symbol->string (car (car src)))
		" : "
		(symbol->string (cadr (car src)))
		" ) ->"
		(main-loop (cadr src) "\n")
		)
	))




(define gen-named-let (lambda (src)
(let ((tr-src
	(list 'letrec (list (list (car src)
			(append (list 'lambda (map (lambda (e) (car e)) (cadr src))) (cddr src))
			))
			(cons (car src) (map (lambda (e) (cadr e)) (cadr src)))
		)
	))
	(main-loop tr-src "")
	)
	))

(define __gen-named-let(lambda (src)
(error
(append (list 'lambda (map (lambda (e) (car e)) (cadr src))) (cddr src))
)
	(string-append
		"let rec "
		(symbol->string (car src))
		" = "
		(main-loop
			(append (list 'lambda (map (lambda (e) (car e)) (cadr src))) (cddr src))
			"")
		" in "
		(main-loop
			
			"")
		)

	))



(define gen-letopen (lambda (src)
	(string-append
		"let open "
		(symbol->string src)
		" in "
		)
	))




(define gen-define (lambda (src rec-flag)
	(string-append
		(if
			(and (list? (car src)) (not rec-flag))
			"let "
			"let rec "
			)
		(if (list? (car src))
			(main-loop (expand-var (car src)) "")
			(symbol->string (car src))
			)
		" = "
		(main-loop (cadr src) "")
		)
	))

(define gen-val (lambda (src)
	(string-append
		"val "
		(symbol->string (car src))
		" = "
		(main-loop (cadr src) "")
		)
	))




(define define-typed-type
	(lambda (t)
		(string-join (map
			(lambda
				(s)
				(string-join (map (lambda (s2)
					(if (pair? s2)
						(cond
							((eq? (car s2) 'quote)
								(string-append "'" (symbol->string (cadr s2))))
							((eq? (car s2) 'quasiquote)
								(string-append "`" (symbol->string (cadr s2))))
							(#t
								(error "unsupported"))
							)
						(begin
							(symbol->string s2)
							)
						)
					) s) " ")
				)
			t)
			" -> ")

		))

(define gen-define-typed (lambda (src)
	(string-append
		"let rec "
		(symbol->string (car src))
		" : "
		(cond
			((string? (cadr src)) (cadr src))
			((symbol? (cadr src)) (symbol->string (cadr src)))
			(#t (define-typed-type (cadr src))))
		" = "
		(main-loop (caddr src) "")
		)
	))

(define gen-val-typed (lambda (src)
	(string-append
		"val "
		(symbol->string (car src))
		" : "
		(cond
			((string? (cadr src)) (cadr src))
			((symbol? (cadr src)) (symbol->string (cadr src)))
			(#t (define-typed-type (cadr src))))
		" = "
		(main-loop (caddr src) "")
		)
	))






(define gen-open (lambda (src)
	(string-append
		"open "
		(symbol->string (car src))
		)
	))


(define gen-exception (lambda (src)
	(string-append
		"exception "
		(symbol->string (car src))
		(if (null? (cdr src)) "" (string-append " of "
			;;(define-typed-type (cadr src))
		(cond
			((string? (cadr src)) (cadr src))
			((symbol? (cadr src)) (symbol->string (cadr src)))
			(#t (define-typed-type (cadr src))))
			))
		)
	))


(define type-type (lambda (src)
	(let
		(
			(f (lambda (s) 
					(if (list? s)
					(string-append (symbol->string (car s)) " of " (define-typed-type (cadr s)))
					(symbol->string s)
					)
		
				)))
	(if (eq? (car src) 'or)
		(string-join (map
			(lambda (s)
				(f s)
				) (cdr src)) " | ")
		(f src)
		)
	)))


(define gen-type (lambda (src)
	(string-append
		"type "
		(symbol->string (car src))
		(if (null? (cdr src))
			""
			(string-append " = "
				(if (string? (cadr src))
					(cadr src)
					(type-type (cadr src))
					)
				))
		)
	))






(define gen-try (lambda (e src)
	(let
		((sym-name (symbol->string (etc-symbol-gen))))



	(string-append
		"try ("
		src
		") with "
		sym-name
		" -> "
		"("
		(main-loop
			(if (and (list? e) (eq? (car e) 'match))
				(list 'function-match (cdr e))
				e
				) "")
		" "
		sym-name
		")"
		)
	)))




(define gen-method-call (lambda (src)
	(string-append
		(symbol->string (car src))
		"#"
		(symbol->string (cadr src))
		" "
		(if (null? (cddr src))
			""
			(main-loop-core (list) (cddr src) "" 2)
			)
		)
	))



(define gen-class (lambda (src)
(let* (
		(pol-flag (if (> (length src) 3) #t #f))
		(pol-type (if pol-flag (car src) #f))
		(name (if pol-flag (cadr src) (car src)))
		(args (if pol-flag (caddr src) (cadr src)))
		(body (if pol-flag (cadddr src) (caddr src)))
		)
	(string-append
		"class "
		(if pol-flag pol-type "")
		" "
		(symbol->string name)
		" "
				(if (> (length args) 0)
					(string-join
						(map
							(lambda (x)
								(if (list? x)
									(main-loop (expand-var x) "")
									(symbol->string x)
									)
								)
							args) " ")
					""
					)
		" = \n"
		(main-loop body "")
		)
	)))

(define gen-object (lambda (src)
	(string-append
		"object "
		"(" (string-join (map symbol->string (car src)) " ") ")"
		"\n"
		(string-join (map (lambda (s) (main-loop s "")) (cdr src)) ";\n")
		" end"
		)
	))




(define gen-object-inherit (lambda (src)
	(string-append
		"object "
		"(" (string-join (map symbol->string (car src)) " ") ")"
		"\n"
		(string-join
			(map
				(lambda (s) (string-append "inherit"
					(string-join
						(map (lambda (s2) (if (string? s2) s2 (main-loop s2 ""))) s)
						" ")))
				(cadr src))
			"\n")
		"\n"
		(string-join (map (lambda (s) (main-loop s "")) (cddr src)) ";\n")
		" end"
		)
	))





(define gen-method (lambda (src)
	(string-append
		"method "
		(symbol->string (car src))
		" "
				(if (> (length (cadr src)) 0)
					(string-join
						(map
							(lambda (x)
								(if (list? x)
									(main-loop (expand-var x) "")
									(symbol->string x)
									)
								)
							(cadr src)) " ")
					""
					)
		" = "
		(if (= (length (cddr src)) 1)
			(main-loop (caddr src) "")
			(main-loop (cons 'begin (cddr src)) "")
			)
		)
	))


;;(define gen-module-ref (lambda (src)
;;	(string-append
;;		(symbol->string (car src))
;;		"."
;;		(symbol->string (cadr src))
;;		" "
;;		)
;;	))




(define gen-match (lambda (src)
	(string-append
		"match "
		(main-loop (car src) "")
		" with "
		(string-join
			(map
			(lambda (p)
				(string-append
					(main-loop (car p) "")
					(if (null? (cadr p))
						""
						(main-loop (cons 'tuple (cadr p)) "")
						)
;;	(if (pair? (car p))
;;		(if (null? (cdr (car p)))
;;			(main-loop (car (car p)) "")
;;			(string-append
;;				(main-loop (car (car p)) "") " "
;;				(main-loop (cons 'tuple (cadr (car p))) ""))
;;			)
;;		(main-loop (car p) "")
;;		)

					" -> "
					"begin "
					(main-loop-core
						(list (if (null? (cddr p)) "();" ""))
						(cddr p) ";" 1) 
					" end"
					))
			(cdr src))
			"\n| ")
		)

	))


(define gen-lambda (lambda (src)
			(string-append
				"fun "
				(if (> (length src) 0)
					(string-join
						(map
							(lambda (x)
								(if (list? x)
									(main-loop (expand-var x) "")
									(symbol->string x)
									)
								)
							src) " ")
					"()"
					)
				" -> "
				)
	))

(define gen-function (lambda (src)
		(main-loop-core (list
					(string-append
				"function "
				(if (list? (car src))
					(string-append
						"("
						(string-join (map symbol->string (car src)) " , ")
						")")
					(symbol->string (car src))
					)
				" -> "
				)

		) (cdr src) ";" 1)
	))

(define gen-function-match (lambda (src)
		(main-loop-core (cons
			(string-append
				"function | "
				(string-join
					(map
						(lambda (p)
;;(error
;;	(if (pair? (car p))
;;		(if (null? (cdr (car p)))
;;			(main-loop (car (car p)) "")
;;			(string-append
;;				(main-loop (car (car p)) "") " "
;;				(main-loop (cons 'tuple (cadr (car p))) ""))
;;			)
;;		(main-loop (car p) "")
;;		)
;;	)
							(string-append
					(main-loop (car p) "")
					(if (null? (cadr p))
						""
						(main-loop (cons 'tuple (cadr p)) "")
						)

;;	(if (pair? (car p))
;;		(if (null? (cdr (car p)))
;;			(main-loop (car (car p)) "")
;;			(string-append
;;				(main-loop (car (car p)) "") " "
;;				(main-loop (cons 'tuple (cadr (car p))) ""))
;;			)
;;		(main-loop (car p) "")
;;		)

								" -> "
								"begin "
								(main-loop-core
									(list (if (null? (cddr p)) "();" ""))
									(cddr p) ";" 1) 
								" end"
							))
						(car src))
					"\n| ")

				)

		'("")) (cdr src) ";" 1)
	))




(define gen-if (lambda (src)


			(string-append
				"if "
				(main-loop (car src) "")
				" then "
				(main-loop (cadr src) "")
				(if (> (length src) 2)
					(string-append " else " (main-loop (caddr src) ""))
					""
					)
				)
	))

(define gen-begin (lambda (src)
				(string-append
					"begin "
					(if
						(null? src)
						"();"
						(main-loop-core (list "") src ";" 1)
						)
					" end")
	))

(define gen-multi-expressions (lambda (src)
				(string-append
					(if
						(null? src)
						"();;"
						(main-loop-core (list "") src ";;" 0)
						)
					"()")
	))



(define gen-while (lambda (src)
				(string-append
					"while "
					(main-loop (car src) "")
					" do "
					(main-loop-core (list "();") (cdr src) ";" 1)
					" done ")
	))
(define gen-for (lambda (src down-flag)
				(string-append
					"for "
					(symbol->string (car (car src)))
					" = "
					(main-loop (cadr (car src)) "")
					(if down-flag " downto " " to ")
					(main-loop (caddr (car src)) "")
					" do "
					(main-loop-core (if (null? (cdr src)) (list "();") (list)) (cdr src) ";" 1)
					" done ")
	))


;;(define gen-compose (lambda (src)
;;		(letrec
;;			(
;;				(gen-compose-l (lambda (x n)
;;					(string-append
;;						"("
;;						"f"
;;						(number->string n)
;;						(if (null? (cdr x))
;;							" argv"
;;							(gen-compose-l (cdr x) (+ n 1))
;;							)
;;						")"
;;						))
;;					)
;;				(gen-compose-l2 (lambda (x n)
;;					(cons
;;						(string-append "f" (number->string n))
;;						(if (null? (cdr x))
;;							'()
;;							(gen-compose-l2 (cdr x) (+ n 1))
;;							)
;;						))
;;					)
;;
;;				)
;;			(string-append
;;			"(fun "
;;			(string-join (gen-compose-l2 src 0) " ")
;;			" -> "
;;				"(fun argv -> "
;;				(gen-compose-l src 0)
;;				")"
;;			")\n"
;;			(main-loop-core "" src "" 1)
;;				)
;;			)
;;	))










(define gen-op (lambda (op src)
	(string-join (map (lambda (s) (main-loop s "")) src) (string-append " " op " "))
	))

(define gen-list (lambda (src)
	(string-append "[" (string-join (map (lambda (s) (main-loop s "")) src) ";") "]")
	))

(define gen-array (lambda (src)
	(string-append "[|" (string-join (map (lambda (s) (main-loop s "")) src) ";") "|]")
	))

;;(define gen-load (lambda (src)
;;	(string-append "#load \"" (car src) "\";; 40")
;;	))

(define gen-record (lambda (src)
	(string-append "{"
		(string-join (map
			(lambda (s)
				(string-append (symbol->string (car s)) " = " (main-loop (cadr s) ""))
				)
				src)
			";")
		"}")
	))




(define atom->string (lambda (src)
	(cond
		((symbol? src)
			;;(string-append "(" (symbol->string src) ")"))
			(symbol->string src))
		((number? src)
			(string-append "(" (number->string src) ")"))
		((char? src)
			(if (char=? src #\')
				"'\\''"
				(string-append "'" (make-string 1 src) "'")
				))
		((string? src)
			(write-to-string src))
		((boolean? src)
			(if src "true" "false"))
		)
	))

(define op-table
	(hash-table 'eq?
		'(+ . "+")
		'(- . "-")
		'(* . "*")
		'(/ . "/")
		'(+. . "+.")
		'(-. . "-.")
		'(*. . "*.")
		'(/. . "/.")
		'(= . "=")
		'(<> . "<>")
		'(== . "==")
		'(!= . "!=")
		'(< . "<")
		'(> . ">")
		'(<= . "<=")
		'(>= . ">=")
		'(== . "==")
		'(!= . "!=")
		'(mod . "mod")
		'(and . "and")
		'(or . "or")
		'(&& . "&&")
		'(|| . "||")
;;		'(string-append . "^")
		'(^ . "^")
;;		'(cons . "::")
		'(|::| . "::")
;;		'(append . "@")
		'(@ . "@")
;;		'(call . "#")
		'(module-ref . ".")
;;		'(set! . ":=")
		'(<- . "<-")
		'(|:=| . ":=")
		'(tuple . ",")
		))


(define macro-table (make-hash-table 'eq?))
(define symbol-table (make-hash-table 'eq?))
(define hyg-symbol-table (make-hash-table 'eq?))

(define hyg-ignore-table
	(hash-table 'eq?
		'(+ . #t)
		'(- . #t)
		'(* . #t)
		'(/ . #t)
		'(+. . #t)
		'(-. . #t)
		'(*. . #t)
		'(/. . #t)
		'(= . #t)
		'(<> . #t)
		'(== . #t)
		'(!= . #t)
		'(< . #t)
		'(> . #t)
		'(<= . #t)
		'(>= . #t)
		'(== . #t)
		'(!= . #t)
		'(mod . #t)
		'(and . #t)
		'(or . #t)
		'(&& . #t)
		'(|| . #t)
;;		'(string-append . #t)
		'(^ . "^")
;;		'(cons . #t)
		'(|::| . #t)
;;		'(append . #t)
		'(@ . #t)
		'(method-call . #t)
		'(module-ref . #t)
		'(set! . #t)
		'(<- . #t)
		'(|:=| . #t)
		'(tuple . #t)

		'(if . #t)
		'(for . #t)
		'(let . #t)
		'(let* . #t)
		'(letrec . #t)
		'(define . #t)
		'(for-down . #t)
		'(while . #t)
		'(begin . #t)
		'(multi-expressions . #t)
		'(lambda . #t)
		'(fun . #t)
		'(function . #t)
		'(function-match . #t)
		'(_ . #t)
		'(syntax-rules . #t)
		'(syntax-case . #t)
		'(syntax-case-intern . #t)
		'(with-syntax . #t)
		'(polymorphic-variants . #t)
;;		'(__load . #t)
;;		'(type-variable . #t)
		'(er-macro-transformer . #t)
		
		'(define-syntax . #t)
		'(define-macro . #t)
		'(define . #t)
;;		'(define-rec . #t)
;;		'(define-typed . #t)
;;		'(define-type . #t)
		'(type . #t)
		'(exception . #t)
		'(val . #t)
;;		'(val-typed . #t)
		'(class . #t)
		'(object . #t)
		'(object-inherit . #t)
		;;'(inherit . #t)
		))





(define hyg-symbol-count 0)
(define symbol-gen 
(lambda (prefix)
	(set! hyg-symbol-count (+ hyg-symbol-count 1))
	(let
		(
			(sym-name
				(string->symbol
					(string-append
						;;(symbol->string sym)
						;;"macro_hygienic_symbol"
						prefix
						"__"
						(number->string hyg-symbol-count)
						))
				))
	(if (hash-table-exists? symbol-table sym-name)
		(symbol-gen prefix)
		(begin
			(hash-table-put! symbol-table sym-name sym-name)
			sym-name
			)
		)
	)))

(define rename-symbol-gen 
(lambda (sym-name rename-symbol-table)
	(if (hash-table-exists? rename-symbol-table sym-name)
		(hash-table-get rename-symbol-table sym-name)
		(begin
			(hash-table-put! rename-symbol-table sym-name (symbol-gen "macro_rename_symbol"))
			(hash-table-get rename-symbol-table sym-name)
			)
		)
	))









(define user-macro-module (make-module 'user-macro-module))
(define reader-macro-module (make-module 'reader-macro-module))
(define hyg-symbol-gen (lambda (sym) (symbol-gen "macro_hygienic_symbol")))
(define macro-symbol-gen (lambda () (symbol-gen "macro_gensym_symbol")))
(define etc-symbol-gen (lambda () (symbol-gen "etc_gensym_symbol")))

(define body-flag-list-gen (lambda (body)
	
	(cond
		((pair? body)
			(map (lambda (item) (if (pair? item) (body-flag-list-gen item) #f)) body))
		(#t
			#f)
		)
	
	))


(define count-dot (lambda (src)
	(cond
		((null? src)
			0)
		((eq? (car src) '...)
			(+ (count-dot (cdr src)) 1))
		((pair? (car src))
			(+ (count-dot (car src)) (count-dot (cdr src))))
		(#t
			(count-dot (cdr src)))
		)
	))

(define my-syntax-case-replace
	(lambda (src pattern body)
		(letrec (
			(body-proc
				(lambda (s p item item-flag)
				(if (pair? item-flag)
						(map (lambda (i i-f) (body-proc s p i i-f)) item item-flag)
						(if (and (symbol? item) (eq? item p) (not item-flag)) s item)
						)

					)
				)
			(body-flag-proc
				(lambda (s p item item-flag)
					(if (pair? item-flag)
						(map (lambda (i i-f) (body-flag-proc s p i i-f)) item item-flag)
						(if (and (symbol? item) (eq? item p)) #t item-flag)
						)
					)
				)
			(get-index (lambda (ls k)
				(let ((count 0) (flag #f))
					(for-each (lambda (elm)
						(if (not flag)
							(begin
								(set! count (+ count 1))
								(if (eq? elm k)
									(set! flag #t))
								)))
						ls)
					(if flag
						(- count 1)
						#f
						)
					)
				))
			(replace-dot
				(lambda (body src pattern tmp)
					(cond
						((null? body)
							(reverse tmp)
							)
						((and
								;;(= (length body) 2)
								(> (length body) 1)
								(eq? (cadr body) '...)
								(pair? (car pattern))
								(pair? (car body))
								)
;; case ((v1 v2) ...) -> ((v1 v2) ...) pattern
							(let (
								(ls-index-list
									(map (lambda (b) (get-index (car pattern) b)) (car body))
									)
								)
							;;(error ls-index)
								(replace-dot
									(cddr body)
									src
									pattern
									(append (reverse
										(map (lambda (e)
											(map (lambda (i b) (if (number? i) (list-ref e i) b)) ls-index-list (car body))
											) src)
										) tmp)
									)
								)
							)
						((and
								;;(= (length body) 2)
								(> (length body) 1)
								(eq? (cadr body) '...)
								(pair? (car pattern))
								)
;; case ((v1 v2) ...) -> (v1 ...) (v2 ...) pattern
							(let ((ls-index (get-index (car pattern) (car body))))
								(replace-dot
									(cddr body)
									src
									pattern
									(append (reverse (map (lambda (e) (list-ref e ls-index)) src)) tmp)
									)
								)
							)
						((and
							;;(= (length body) 2)
							(> (length body) 1)
							(eq? (car pattern) (car body))
							(eq? (cadr body) '...)
							)
;; case (v1 ...) -> (v1 ...) pattern
							;;(replace-dot (cdr body) src (append (reverse src) tmp))
							(replace-dot (cddr body) src pattern (append (reverse src) tmp))
							)
						((pair? (car body))
							(replace-dot (cdr body) src pattern (cons (replace-dot (car body) src pattern '()) tmp))
							)
						(#t
							(replace-dot (cdr body) src pattern (cons (car body) tmp)))
						)
					)
				)
			(loop (lambda (s p body body-flag)
				(cond
					((null? p)
						body)
					;;((and (= (length p) 2) (eq? (cadr p) '...))
					((and (> (length p) 1) (eq? (cadr p) '...))
						(replace-dot body s p '())
						)
					((pair? (car p))
;; TODO body-flag
						(loop (cdr s) (cdr p)
							(loop (car s) (car p) body body-flag)
							body-flag
							)
						)

					(#t
					(loop (cdr s) (cdr p)
						(map
							(lambda
								(item item-flag)
								(body-proc (car s) (car p) item item-flag)
								)
							body
							body-flag)
						(map
							(lambda
								(item item-flag)
								(body-flag-proc (car s) (car p) item item-flag)
								)
							body
							body-flag)
						))
					)
				)))

			(loop src pattern body (body-flag-list-gen body))
			)
		))


;;(define syntax-case-length
;;	(lambda (pat src)
;;		(if (eq? (car (reverse pat)) '...)
;;			(>= (length src) (- (length pat) 2))
;;			(eq? (length pat) (length src))
;;			)
;;		))

(define syntax-case-match
	(lambda (pat src keyword)
;;	(let
;;		((keyword-flag
;;			(if (null? (filter () keyword))
;;			))
;;(error pat ":" src)
		(cond
			((and (null? pat) (null? src))
				#t)
			;;((and (not (null? pat)) (eq? (car pat) '...))
			((and (= (length pat) 2) (pair? (car pat)) (eq? (cadr pat) '...))
				(if (syntax-case-match (car pat) (car src) keyword)
					#t
					#f
					)
				)
			((and (= (length pat) 2) (eq? (cadr pat) '...))
				#t)
			((or (null? pat) (null? src))
				#f)
			((and (pair? (car pat)) (pair? (car src)))
				(if (syntax-case-match (car pat) (car src) keyword)
					(syntax-case-match (cdr pat) (cdr src) keyword)
					#f
					)
				)
			((and (pair? (car pat)) (not (pair? (car src))))
				#f)
			((and
				(not (null? (filter (lambda (k) (eq? (car pat) k)) keyword)))
				(not (eq? (car pat) (car src))))
				#f)
			(#t
				(syntax-case-match (cdr pat) (cdr src) keyword))
			)
		))




(define my-syntax-case-loop
	(lambda (src keyword body)
;;(error (car (car body)) src)
		(if (syntax-case-match (car (car body)) src keyword)
			(begin
;;(error (length (car (car body))) (length src))
;;(error (count-dot (car (car body))) ":" (count-dot (cadr (car body))))
				(my-syntax-case-replace src (car (car body)) (cadr (car body))
					;;(if (> (count-dot (cadr (car body))) (count-dot (car (car body)))) #t #f)
					)
				)
			(my-syntax-case-loop src keyword (cdr body))
			)
		))

;;(define my-syntax-case (lambda (src keywords body)
;;		(error src body)
;;		(my-syntax-case-loop src body)
;;		))

(define my-syntax-case-core
	(lambda (src keyword body)
		(let* (
			(excode (expand-syntax-loop body 'syntax-case))
			(code (hyg-loop-syntax-case src keyword excode))
			;;(code (hyg-loop-syntax-case src keyword body))
			;;(code (cons src (cons keyword body)))
			)

;;		(let ((code (car (hyg-loop (list (append (list 'syntax-case src keyword) body))))))
		(my-syntax-case-loop (car code) (cadr code) (cddr code))
			)))


(define-syntax my-syntax-case
	(syntax-rules ()
		((_ src keyword body)
			(eval
				(my-syntax-case-core src (quote keyword) (quote (body)))
				user-macro-module)
			)
		((_ src keyword body1 body2 ...)
			(eval
				(my-syntax-case-core src (quote keyword) (quote (body1 body2 ...)))
				user-macro-module)
			)
		)
	)



(define-syntax my-syntax
	(syntax-rules ()
		((_)
			(quasiquote '()))
			;;(list loaded ""))
		((_ body)
			(quasiquote body))
		((_ b1 b2 ...)
			(quasiquote b1 b2 ...))
		))




(define-syntax syntax-case-var
	(syntax-rules ()
		((_ (v))
			(list v))
		((_ (v1 v2 ... ))
			(list v1 v2 ...))
		))

(define-syntax my-syntax-case-intern
	(syntax-rules ()
		((_ src keyword vars body)
			(apply (eval
				`(lambda vars
					,(my-syntax-case-core src (quote keyword) (quote (body)))
					)
				user-macro-module)
				(syntax-case-var vars))
			)
		((_ src keyword vars body1 body2 ...)
			(apply (eval
				`(lambda vars
					,(my-syntax-case-core src (quote keyword) (quote (body1 body2 ...)))
					)
					user-macro-module)
				(syntax-case-var vars))
			)
		)
	)



(define er-macro-transformer (lambda (name src)
	`(lambda
		form
		(,src (cons (quote ,name) form)
		(let ((table (make-hash-table 'eq?)))
			(lambda (sym-name) (rename-symbol-gen sym-name table))
			)
		eq?))
	))


(with-module
	user-macro-module
	(define gensym (global-variable-ref 'user 'macro-symbol-gen))
	(define fun (global-variable-ref 'user 'lambda))
	;;(define syntax-case (global-variable-ref 'user 'my-syntax-case))
	(define-syntax syntax-case (global-variable-ref 'user 'my-syntax-case))
	(define-syntax syntax-case-intern (global-variable-ref 'user 'my-syntax-case-intern))
	(define-syntax syntax (global-variable-ref 'user 'my-syntax))
	(define rename-symbol-gen (global-variable-ref 'user 'rename-symbol-gen))
	;;(define-syntax er-macro-transformer (global-variable-ref 'user 'my-er-macro-transformer))
	)



(define macro-prefix (lambda (sym)
	(string->symbol
		(string-append
;;			"_user-syntax-"
			(symbol->string sym)))
	))


(define make-ignore-table (lambda (src)
	(letrec
		(
			(ht (make-hash-table 'eq?))
			(it-loop
				(lambda (s ht)
					(if (null? s)
						ht
						(if (list? (car s))
						(begin
							(it-loop (car s) ht)
							(it-loop (cdr s) ht)
							)
						(begin
							(hash-table-put! ht (car s) #t)
							(it-loop (cdr s) ht)
							)
						))
				))
			)


		(it-loop src ht)
		(hash-table-put! ht 'unquote #t)
;;(error (hash-table-keys ht))
		ht
	)))


(define hyg-loop (lambda (src)
	(map
		(lambda (p)
			(cond
			((and (list? p) (eq? (car p) 'syntax-rules))
				(cons (car p) (cons (cadr p)
					(map
						(lambda (p2)
							(cons (car p2)
								(hyg-loop2 (cdr p2) (make-ignore-table (car p2)))
								)
							)
						(cddr p))
						))
					)
				(#t
					p)
				)
			)
		src)
	))

(define hyg-loop-syntax-case (lambda (src keyword body)
;;(error src keyword body)
			(cons src (cons keyword
					(map
						(lambda (p2)
;;(error p2)
							(cons (car p2)
								(hyg-loop2 (cdr p2) (make-ignore-table (car p2)))
								)
							)
						body)))
	))




(define with-syntax-unquote (lambda (vars body)
	(letrec (
		(body-loop (lambda (var body tmp)
				(cond
					((null? body)
						(reverse tmp))
					((pair? (car body))
						(body-loop var (cdr body) (cons (body-loop var (car body) '()) tmp)))
					(#t
						(body-loop var (cdr body) (cons (if (eq? (car body) var) (list 'unquote (car body)) (car body)) tmp)))
					)
				))
		(var-loop (lambda (vars body)
			(if (null? vars)
				body
				(var-loop (cdr vars) (body-loop (car (car vars)) body '()))
				)
			))
		)
		(var-loop vars body)
		)
	))




(define hyg-loop2 (lambda (src it)
			(map
				(lambda (p2)
					(cond
						((and (list? p2) (not (null? p2))
							(or
							(eq? (car p2) 'lambda)
							(eq? (car p2) 'fun)
							(eq? (car p2) 'function)
							(eq? (car p2) 'let)
							(eq? (car p2) 'let*)
							(eq? (car p2) 'letrec)
							))
							(let ((np2 (hyg-symbol p2 it)))
								(cons
									(car np2)
									(cons
										(if (or
												(eq? (car p2) 'lambda)
												(eq? (car p2) 'fun)
												(eq? (car p2) 'function))
											(cadr np2)
											(map
												;;(lambda (np2-bind) (list (car np2-bind) (cadr np2-bind)))
												(lambda
													(np2-bind)
													(cons (car np2-bind) (hyg-loop2 (cdr np2-bind) it)))
												(cadr np2))
											)
										(hyg-loop2 (cddr np2) it)
										))))
						((and (list? p2) (not (null? p2)) (eq? (car p2) 'with-syntax))
							(map
								(lambda (sym) (hash-table-put! it (car sym) #t))
								(cadr p2))
;;(error (list 'let (cadr p2) (caddr p2)))
							(hyg-loop2 (list 'let (cadr p2) (with-syntax-unquote (cadr p2) (caddr p2))) it)
							)
						((list? p2)
							(hyg-loop2 p2 it))
						(#t
							p2)
						))
				src)
	))


(define hyg-symbol-rep (lambda (src ht)
	(map
		(lambda (el)
			(cond
				((list? el)
					(hyg-symbol-rep el ht))
				((hash-table-exists? ht el)
					(hash-table-get ht el))
				(#t
					el)
				)
			)
		src)
	))

(define hyg-symbol (lambda (src it)

	(letrec
		(
			(ht (make-hash-table 'eq?))
			
			)
		(cond
			((or (eq? (car src) 'lambda) (eq? (car src) 'fun))
			(if (list? (cadr src))
				(for-each
					(lambda
						(s)
						(if (list? s)
							(for-each
								(lambda (s2) (if (not (hash-table-exists? it s2)) (hash-table-put! ht s2 (hyg-symbol-gen s2))))
								s)
							(if (not (hash-table-exists? it s)) (hash-table-put! ht s (hyg-symbol-gen s)))
							)
						)
					(cadr src)
					)
					(if (not (hash-table-exists? it (cadr src))) (hash-table-put! ht (cadr src) (hyg-symbol-gen (cadr src))))
					)
				)
			((eq? (car src) 'function)
						(if (list? (cadr src))
							(for-each
								(lambda (s2) (if (not (hash-table-exists? it s2)) (hash-table-put! ht s2 (hyg-symbol-gen s2))))
								(cadr src))
							(if (not (hash-table-exists? it (cadr src))) (hash-table-put! ht (cadr src) (hyg-symbol-gen (cadr src))))
							)
				)
			(#t
;;(error (hash-table-keys ht))
				(for-each
					(lambda
						(s)
;;(error (car s))
						(if (list? (car s))
							(for-each
								(lambda (s2)
								(if (not (hash-table-exists? it s2)) (hash-table-put! ht s2 (hyg-symbol-gen s2))))
								(car s))
							(if (not (hash-table-exists? it (car s))) (hash-table-put! ht (car s) (hyg-symbol-gen (car s))))
							)
						)
					(cadr src)
					)
				)
			)
(hyg-symbol-rep src ht)
		)
	))




;; (eq? (car p2) 'lambda)
;; (eq? (car p2) 'fun)
;; (eq? (car p2) 'function)
;; (eq? (car p2) 'let)
;; (eq? (car p2) 'let*)
;; (eq? (car p2) 'letrec)
;; TODO named let
(define expand-syntax-loop (lambda (src self)
	(cond
		((and
			(pair? src)
			(or
				(eq? (car src) 'lambda)
				(eq? (car src) 'fun)
				)
			)
			(cons (car src) (cons (cadr src)
				(map-dot (lambda (elm) (expand-syntax-loop elm self)) (cddr src))))
			)
		((and
			(pair? src)
			(or
				(eq? (car src) 'function)
				)
			)
			(cons (car src) (cons (cadr src)
				(map-dot (lambda (elm) (expand-syntax-loop elm self)) (cddr src))))
			)
		((and
			(pair? src)
			(or
				(eq? (car src) 'let)
				(eq? (car src) 'let*)
				(eq? (car src) 'letrec)
				)

			)
			(cons (car src)
				(cons (map
					(lambda (elm) (list (car elm) (expand-syntax-loop (cadr elm) self)))
					(cadr src))
				(map-dot (lambda (elm) (expand-syntax-loop elm self)) (cddr src))))
			)
		((and
			(pair? src)
			(not (eq? (car src) self))
			(hash-table-exists? macro-table (car src))
;; if hyg-flag is #t
			(hash-table-get macro-table (car src))
;;
			)
			(expand-syntax-loop (expand-syntax src) (car src))
			)
		((pair? src)
			(map-dot (lambda (elm) (expand-syntax-loop elm self)) src)
			)
		(#t
			src)
		)
	))


(define set-syntax (lambda (src hyg-flag) 
	(hash-table-put! macro-table
		(cadr src)
		hyg-flag
		)

;; #t is recursive expand syntax
	(let ((src2 (if hyg-flag
						(if #t
							(hyg-loop (expand-syntax-loop src (car src)))
							(hyg-loop src)
							)
						src
						)
						))

		(eval
			(cons
				(car src2)
				(cons
					(macro-prefix (cadr src2))
					(cddr src2)))
			user-macro-module
			)
		""
		)))

(define expand-syntax (lambda (src)	
	(let*
		(
			(hyg-flag (hash-table-get macro-table (car src)))
			(src1
				(cons
					(macro-prefix (car src))
					(cdr src))
				)
			(exp-src
				`(macroexpand-1 (quote ,src1)))
			(expand-rs
				(eval
					exp-src
					;;(interaction-environment)
					user-macro-module
					)
				))
		(unwrap-syntax expand-rs)
		)))

(define replaced-symbol-table (make-hash-table 'eq?))

(define symbol-char-rep
	(lambda (s)
	(let
		((rs
		((compose
			(lambda (str-s) (string-join (string-split str-s "-") "_hyphen_"))
			(lambda (str-s) (string-join (string-split str-s "?") "_question_"))
			(lambda (str-s) (string-join (string-split str-s ">") "_less_"))
			(lambda (str-s) (string-join (string-split str-s "->") "_arrow_"))
			)
			s)))
		rs
		)
	))


(define
	get-last-symbol
	(lambda (src)
	(letrec
		((_get_last
			(lambda (src mod)
			(if (null? (cdr src))
				(list
					(if (null? mod) #f (string->symbol (string-join (reverse mod) ".")))
					(string->symbol (car src))
					)
				(_get_last (cdr src) (cons (car src) mod))
				)
			)))
		
		(_get_last (string-split (symbol->string src) ".") '())
		)
	))



(define map-dot
	(lambda (f ls)
		(if
			(null? ls)
			'()
			(if
				(pair? ls)
				(cons (f (car ls)) (map-dot f (cdr ls)))
				(f ls)
				)
			)
		))

(define loaded '__***ocaml__laded__code***__)

(define get-symbol (lambda (src rep-flag)
(let ((proc
		(lambda (s)
			(cond
				((symbol? s)
					(let
						(
							(str-s (symbol->string s))
							(last-s (get-last-symbol s))
							)
					(hash-table-put! symbol-table s s)
					(if (and
						rep-flag
						(or
							(string-scan str-s ">")
							(string-scan str-s "?")
							(string-scan str-s "-")
							)
						(not (hash-table-exists? hyg-ignore-table s))
						)
						(begin
						(if
							;;(hash-table-exists? replaced-symbol-table s)
							(hash-table-exists? replaced-symbol-table (cadr last-s))
							(begin
								(if (car last-s)
									(string->symbol
										(string-append
											(symbol->string (car last-s))
											"."
											(symbol->string (hash-table-get replaced-symbol-table (cadr last-s)))
											))
									(hash-table-get replaced-symbol-table s)
									)
							)
						(let
							(
								(s2 (symbol-gen
									;;(symbol-char-rep str-s)
									(symbol-char-rep (symbol->string (cadr last-s)))
									)))
							(hash-table-put! symbol-table (cadr last-s) s2)
							(hash-table-put! replaced-symbol-table (cadr last-s) s2)

							(if (global-variable-bound? 'user s)
								(eval
									`(define ,s2 (global-variable-ref 'gauche (quote ,s)))
									user-macro-module))
							(if
								(car last-s)
									(string->symbol
										(string-append
											(symbol->string (car last-s))
											"."
											(symbol->string s2)
											))
								s2
								)
							)
							))
						(begin
							s
							)
					)))
;;				((and (list? s) (not (null? s)) (eq? (car s) 'load-scm))
;;					(list loaded (string-append (load-parse (cadr s)) "()"))
;;					)
				((pair? s)
					(get-symbol s rep-flag))
				(#t
					s)
				)
			)
))

	(map-dot
		proc
		src
		)
		)
	))


(define load-parse (lambda (input single-exp)
	(letrec
		(
			(input-loop
				(lambda (iport buff)
					(let
						(
							;;(src (read iport))
							(src
							;;	(proc-reader-macro
									(proc-load-scm (my-read iport))
							;;		)
									)
							)
						(if
							(eof-object? src)
							(reverse buff) 
							(if single-exp
								(reverse (cons src buff))
								(input-loop iport (cons src buff))
								)
							))))

				(iport (if (string? input) (open-input-file input) input))
							)

		(let
			(
			(rs (map
				(lambda (src)
					(main-loop src ";;\n")
					)
;;				(get-symbol
					(get-symbol (input-loop iport (list)) #f)
;;					#t)
					))
					)
			(if (string? input) (close-input-port iport))
			;;(string-join (cons (string-append "(* " filename " *)\n") rs) "")
			(string-join rs "")
			))
	))



(define main-loop (lambda (src delim)
	(if (list? src)
		(cond
			((null? src)
				(string-append "()" delim)
				)
			((or
				(eq? (car src) 'ocaml)
				(eq? (car src) 'module)
				(eq? (car src) 'struct)
				(eq? (car src) 'define)
;;				(eq? (car src) 'define-rec)
;;				(eq? (car src) 'define-typed)
				(eq? (car src) 'type)
				(eq? (car src) 'multi-expressions)
				(eq? (car src) loaded)
;;				(eq? (car src) 'define-type)
				(eq? (car src) 'open)
				(eq? (car src) 'exception)
				(eq? (car src) 'preprocess)
				(eq? (car src) 'polymorphic-variants)
;;				(eq? (car src) 'type-variable)
				(eq? (car src) 'class)
				(eq? (car src) 'object)
				(eq? (car src) 'object-inherit)
				(eq? (car src) 'method)
				(eq? (car src) 'val)
;;				(eq? (car src) 'val-typed)
;;				(eq? (car src) 'inherit)
;;				(eq? (car src) '__load)
				
;;				(eq? (car src) 'define-syntax) (eq? (car src) 'define-macro)

				(hash-table-exists? macro-table (car src))
				)
				(string-append (main-loop-core (list) src "" 0) delim)
				)
			((or (eq? (car src) 'define-syntax) (eq? (car src) 'define-macro))
				;;(main-loop-core (list) src "" 0)
				(string-append (main-loop-core (list) src "" 0) "()" delim)
				)
			(#t
				(string-append "(" (main-loop-core (list) src "" 0) ")" delim))
			)
		(string-append (atom->string src) delim)
		)

	))

(define main-loop-core (lambda (buf src delim count)
	(if (null? src)
		;;(if (null? (cdr buf))
		(if (and (null? (cdr buf)) (not (string-scan (car buf) "#")))
			(string-join (reverse (cons "()" buf)) "\n")
			(string-join (reverse buf) "\n")
			)
		(let
			((hd (car src)))
			(cond
				((and (= count 0) (or (eq? hd 'let*) (eq? hd 'letrec)) (list? (cadr src)))
					(main-loop-core (cons (gen-let (cadr src) (if (eq? hd 'letrec) #t #f)) buf) (cddr src) ";" (+ count 1)))
				((and (= count 0) (eq? hd 'let) (list? (cadr src)))
					(main-loop-core (cons (gen-let-t (cadr src) #f) buf) (cddr src) ";" (+ count 1)))
				((and (= count 0) (or (eq? hd 'let) (eq? hd 'let*) (eq? hd 'letrec)))
					(gen-named-let (cdr src)))

				((and (= count 0) (or (eq? hd 'lambda) (eq? hd 'fun)))
					(main-loop-core (cons (gen-lambda (cadr src)) buf) (cddr src) ";" (+ count 1)))
				((and (= count 0) (eq? hd 'function))
					(gen-function (cdr src)))
				((and (= count 0) (eq? hd 'function-match))
					(gen-function-match (cdr src)))
					;;(main-loop-core (cons (gen-function (cadr src)) buf) (cddr src) ";" (+ count 1)))
				((and (= count 0) (eq? hd 'letopen))
					(main-loop-core (cons (gen-letopen (cadr src)) buf) (cddr src) ";" (+ count 1)))
				((and (= count 0) (eq? hd 'try))
					(gen-try
						;;(main-loop (cadr src) "")
						(cadr src)
						(main-loop-core '("") (cddr src) ";" (+ count 1))
						)
					)
				((and (= count 0) (eq? hd 'define))
					(if (eq? (length (cdr src)) 3)
						(gen-define-typed (cdr src))
						(gen-define (cdr src) #f)
						)
					)
				((and (= count 0) (eq? hd 'val))
					(if (eq? (length (cdr src)) 3)
						(gen-val-typed (cdr src))
						(gen-val (cdr src))
						)
					)
				((and (= count 0) (eq? hd 'object-inherit))
					(gen-object-inherit (cdr src)))
;;				((and (= count 0) (eq? hd 'define-rec))
;;					(gen-define (cdr src) #t))
				((and (= count 0) (eq? hd 'ocaml))
					(gen-ocaml (cdr src)))
;;				((and (= count 0) (eq? hd 'define-typed))
;;					(gen-define-typed (cdr src)))
;;				((and (= count 0) (eq? hd 'val-typed))
;;					(gen-val-typed (cdr src)))
				((and (= count 0) (eq? hd 'module))
					(gen-module (cdr src)))
				((and (= count 0) (eq? hd 'struct))
					(gen-struct (cdr src)))
				((and (= count 0) (eq? hd 'functor))
					(gen-functor (cdr src)))
				((and (= count 0) (eq? hd 'open))
					(gen-open (cdr src)))
				((and (= count 0) (eq? hd 'exception))
					(gen-exception (cdr src)))
;;				((and (= count 0) (or (eq? hd 'type) (eq? hd 'define-type)))
				((and (= count 0) (eq? hd 'type))
					(gen-type (cdr src)))
;;				((and (= count 0) (eq? hd 'define-syntax))
				((and (= count 0) (eq? hd 'define-syntax) (eq? (car (caddr src)) 'syntax-rules))
					(set-syntax src #t))
				((and (= count 0) (eq? hd 'define-syntax)
					(or (eq? (car (caddr src)) 'lambda) (eq? (car (caddr src)) 'fun))
					)
					(set-syntax
						(list
							'define-macro
							(cadr src)
							(cons 'lambda
								(cons
									(car (cadr (caddr src)))
									(cons
										`(set! ,(car (cadr (caddr src)))
											(cons (quote ,(cadr src)) ,(car (cadr (caddr src)))))
									(cddr (caddr src))
	)
									))
							)
						#f)
					)
				((and (= count 0) (eq? hd 'define-syntax) (eq? (car (caddr src)) 'er-macro-transformer))
;;(error (list 'er-macro-transformer (cadr src) (cadr (caddr src))))

					(set-syntax
						(list
							'define-macro
							(cadr src)
							(er-macro-transformer (cadr src) (cadr (caddr src)))
							)
						#f)
					)
				((and (= count 0) (eq? hd 'define-macro))
					(set-syntax src #f))
				((and (= count 0) (eq? hd 'preprocess))
					(main-loop
						(eval (cons 'begin (cdr src)) user-macro-module)
						delim)
					)
				((and (= count 0) (eq? hd 'class))
					(gen-class (cdr src)))
				((and (= count 0) (eq? hd 'object))
					(gen-object (cdr src)))
				((and (= count 0) (eq? hd 'method))
					(gen-method (cdr src)))
				((and (= count 0) (eq? hd 'begin))
					(gen-begin (cdr src)))
				((and (= count 0) (eq? hd 'multi-expressions))
					(gen-multi-expressions (cdr src)))
				((and (= count 0) (eq? hd 'while))
					(gen-while (cdr src)))
				((and (= count 0) (eq? hd 'for))
					(gen-for (cdr src) #f))
				((and (= count 0) (eq? hd 'for-down))
					(gen-for (cdr src) #t))
				((and (= count 0) (eq? hd 'if))
					(gen-if (cdr src)))
				((and (= count 0) (eq? hd 'polymorphic-variants))
					(string-append "`" (symbol->string (cadr src)) "")
					)
;;				((and (= count 0) (eq? hd 'type-variable))
;;					(string-append "'" (symbol->string (cadr src)) "")
;;					)
				((and (= count 0) (eq? hd 'match))
					(gen-match (cdr src)))
;;				((and (= count 0) (eq? hd 'compose))
;;					(gen-compose (cdr src)))
				((and (= count 0) (eq? hd 'method-call))
					(gen-method-call (cdr src)))
;;				((and (= count 0) (eq? hd '__load))
;;					(gen-load (cdr src))
;;					)
				((and (= count 0) (eq? hd 'load-scm))
					(error "omitted")
					;;(load-parse (cadr src))
					)
				((and (= count 0) (eq? hd loaded))
					(cadr src)
					)
				((and (= count 0) (eq? hd 'quote) (vector? (cadr src)))
					(gen-array (cadr src)))
				((and (= count 0) (eq? hd 'quote))
					(gen-list (cadr src)))

				((and (= count 0) (hash-table-exists? macro-table hd))
;;					(main-loop (expand-syntax src) delim)
					(main-loop (expand-syntax src) delim)
					)

				((and (= count 0) (eq? hd 'array))
					(gen-array (cdr src)))
				((and (= count 0) (eq? hd 'list))
					(gen-list (cdr src)))
				((and (= count 0) (eq? hd 'record))
					(gen-record (cdr src)))
				((and (= count 0) (hash-table-exists? op-table hd))
					 (gen-op (hash-table-get op-table hd) (cdr src)))
				((hash-table-exists? op-table hd)
					 (main-loop-core
					 	(cons (string-append "( " (main-loop hd delim) " )") buf)
						(cdr src) delim (+ count 1)))
				((or (symbol? hd) (number? hd) (string? hd) (char? hd) (boolean? hd))
					 (main-loop-core
					 	(cons (main-loop hd delim) buf)
						(cdr src) delim (+ count 1)))
				((list? hd)
					(main-loop-core
						(cons (main-loop hd delim) buf)
						(cdr src) delim 0))
			)
		))))

(define main (lambda (args)
	(let*
		(
			(from-stdin #f)
			(ocaml-cmd "ocaml")
			(opt (parse-options
				(cdr args)
				(
					("from-stdin"
						()
						(set! from-stdin #t)
						)
					("ocaml=s"
						(cmd)
						(set! ocaml-cmd cmd)
						)
					)
				))
			)


		(if (and (null? opt) (not from-stdin))
			(repl-start ocaml-cmd)
			(display
				(if from-stdin
					(load-parse
						(open-input-string (port->string (current-input-port)))
						#f)
					(load-parse (car opt) #f)
					)
				)
			)
		)
(newline)
))








(use gauche.process)


(define display-response (lambda (p trim-flag)
	(if (char-ready? p)
		(if (eof-object? (peek-char p))
			(eof-object)
				

			(if
				(and trim-flag (char=? (peek-char p) #\space))
				(begin
					(read-char p)
					(display-response p #t)
					)
				(begin
					(display (read-char p))
					(display-response p #f)
					)
				)
				

				)
		)
	))

;;(define __display-response-trim (lambda (p)
;;		(display
;;			(string-trim
;;				(read-line p))
;;			)
;;		(newline)
;;		(display-response p #f)
;;		)
;;	)



(define repl-start (lambda (cmd)
;;	(display (load-parse #f))
(let ((pr (run-process (list cmd) :input :pipe :output :pipe)
			))

	(let (
		(pin (process-input pr))
		(pout (process-output pr))
		(st #t)
		(buff "")
		)

	(sys-nanosleep (* (expt 10 8) 1.0))
	(display "***   S-expression OCaml version ")
	(display version)
	(display "\n")
	(display "***   ")
	(display-response pout #t)
	;;(display "#   ")
	(flush)

	(letrec ((inner-loop (lambda (tmp-in line)
					(guard
						(exc
							((<read-unclosed-curry-error> exc) (string-append buff line))
							((<error> exc)
								(display "error: ")
								(display exc)
								(display "\n")
								;;(set! buff "")
								""
								)
							;;((<error> exc) (display "error\n") "")
							(else (display "error: unkown\n")
								;;(set! line "")
								buff)
							)
							;;(else (display "error\n") buff))
							(let
								((ocaml-code (load-parse tmp-in #t)))
								(display ocaml-code)
								(display "\n\n")
								(display ocaml-code pin)
								(display "\n" pin)
								(flush pin)
								
								(cond
									((> (string-length ocaml-code) 800)
										(sys-nanosleep (* (expt 10 8) 3.0)))
									((> (string-length ocaml-code) 200)
										(sys-nanosleep (* (expt 10 8) 1.5)))
									((> (string-length ocaml-code) 100)
										(sys-nanosleep (* (expt 10 8) 1.0)))
									(#t
										(sys-nanosleep (* (expt 10 8) 0.5)))
									)
								;;(if (eof-object? (display-response pout))
								(if (eof-object? (display-response pout #t))
									(begin
										(set! st #f)
										)
									))
							(flush)
							(if
								(eof-object? (my-peek-char tmp-in))
								""
								(let1 rest (port->string tmp-in)
									(inner-loop (open-input-string rest) rest)
									)
								))

	)))


	(while st
		(let1 line (read-line (current-input-port))
			(if (eof-object? line)
				(set! st #f)
				(let1 tmp-in (skip-space (open-input-string (string-append buff line)))
				(if (not (eof-object? (my-peek-char tmp-in)))
					(let* 
						(
							(tmp-in (open-input-string (string-append buff line)))
							)
							;;(set! buff (inner-loop tmp-in line))
							(set! buff (inner-loop tmp-in (string-append line " ")))
						)
					))
				))
		))
	(process-kill pr)
	))





	))







(define skip-space (lambda (p)
	(let ((ch (my-peek-char p)))
			(if
				(or
					(eq? ch #\space)
					(eq? ch #\newline)
					(eq? ch #\return)
					(eq? ch #\tab)
					)
				(begin
					(read-char p)
					(skip-space p))
				p
				)
			)
	))






(define reader-macro-table (make-hash-table 'eq?))
(define reader-macro2-table (make-hash-table 'string=?))

(define my-read (lambda (inp) (my-read-core inp '() 0 #f #f #f #f #f)))
(define my-read-for-delim (lambda (inp delim1 delmi2) (my-read-core inp '() 0 #f #f #f delim1 delmi2)))

(define my-read-delimited-list (lambda (p ch)
	(letrec ((loop (lambda (tmp)
			(skip-space p)
			(if (eq? (my-peek-char p) ch)
				(begin
					(read-char p)
					(reverse tmp))
				;;(loop (cons (my-read p) tmp))
				(loop (cons (my-read-for-delim p ch #f) tmp))
				)
			)))
		(loop '())
		)
	))

(define my-read-delimited-list2 (lambda (p ch ch2)
	(letrec (
		(str (list->string (list ch ch2)))
		(loop (lambda (tmp)
			(skip-space p)
		(let ((next (my-peek-char p)) (next2 (my-peek-char2 p)))
			(if (and (not (eof-object? next2)) (string=? next2 str))
				(begin
					(read-char p)
					(read-char p)
					(reverse tmp))
				;;(loop (cons (my-read p) tmp))
				(loop (cons (my-read-for-delim p ch ch2) tmp))
				)
			))))
		(loop '())
		)
	))


(define my-read-delimited-string (lambda (p ch)
	(letrec ((loop (lambda (tmp)
			(if (eq? (my-peek-char p) ch)
				(begin
					(read-char p)
					(list->string (reverse tmp)))
				(loop (cons (read-char p) tmp))
				)
			)))
		(loop '())
		)
	))

(define my-read-delimited-string2 (lambda (p ch ch2)
	(letrec (
		(str (list->string (list ch ch2)))
		(loop (lambda (tmp)
		(let ((next (my-peek-char p)) (next2 (my-peek-char2 p)))
			(if (and (not (eof-object? next2)) (string=? next2 str))
				(begin
					(read-char p)
					(read-char p)
					(list->string (reverse tmp)))
				(loop (cons (read-char p) tmp))
				)
			))))
		(loop '())
		)
	))






(define my-peek-char (lambda (p)
	(let ((ch (read-char p)))
	(if
		(eof-object? ch)
		ch
		(begin
			(port-seek p (* (string-size (list->string (list ch))) -1) SEEK_CUR)
			ch))
	)))

(define my-peek-char2 (lambda (p)
	(let* (
		(ch (read-char p))
		(ch2 (if (eof-object? ch) ch (read-char p)))
		)
	(if (not (eof-object? ch))
		(port-seek p (* (string-size (list->string (list ch))) -1) SEEK_CUR)
		)
	(if (not (eof-object? ch2))
		(port-seek p (* (string-size (list->string (list ch2))) -1) SEEK_CUR)
		)
	(if (and (not (eof-object? ch)) (not (eof-object? ch2)))
		(list->string (list ch ch2))
		ch2
		)
	)))


(with-module
	reader-macro-module
	(define read (global-variable-ref 'user 'my-read))
	(define read-delimited-list (global-variable-ref 'user 'my-read-delimited-list))
	(define read-delimited-list2 (global-variable-ref 'user 'my-read-delimited-list2))
	(define read-delimited-string (global-variable-ref 'user 'my-read-delimited-string))
	(define read-delimited-string2 (global-variable-ref 'user 'my-read-delimited-string2))
	(define peek-char (global-variable-ref 'user 'my-peek-char))
	(define peek-char2 (global-variable-ref 'user 'my-peek-char2))
	(define read-skip-space (global-variable-ref 'user 'skip-space))
	(define scm-read (global-variable-ref 'user 'read))
	)



(define proc-load-scm (lambda (src)
	(cond
		((and (pair? src) (eq? (car src) 'require))
			(list loaded (string-append (load-parse (cadr src) #f) "()"))
			)
		((and (pair? src) (eq? (car src) 'require-ocaml))
			(list loaded (string-append (call-with-input-file (cadr src) port->string) "()"))
			)
		(#t src)
		)
	))





;;(define proc-reader-macro (lambda (src)
;;	(cond
;;		((and (pair? src) (eq? (car src) 'set-macro-character))
;;		(if (eq? (caddr src) #f)
;;			(hash-table-delete! reader-macro-table (cadr src))
;;			(hash-table-put! reader-macro-table
;;				(cadr src)
;;				(eval
;;					(caddr src)
;;					reader-macro-module
;;					))
;;				)
;;			'())
;;		((and (pair? src) (eq? (car src) 'set-macro-character2))
;;		(if (eq? (cadddr src) #f)
;;			(hash-table-delete! reader-macro2-table (list->string (list (cadr src) (caddr src))))
;;			(hash-table-put! reader-macro2-table
;;				(list->string (list (cadr src) (caddr src)))
;;				(eval
;;					(cadddr src)
;;					reader-macro-module
;;					))
;;				)
;;			'())
;;		(#t src)
;;		)
;;	))
;;


(define
	quote-table
	(hash-table 'eq?
		'(#\' . quote)
		'(#\` . quasiquote)
		'(#\, . unquote)
		))


(define read-ml-comment (lambda (p dep)
	(let ((next (my-peek-char2 p)))
		(cond
			((string=? next "|#")
				(read-char p)
				(read-char p)
				(if (> dep 1)
					(read-ml-comment p (- dep 1))
					)
				)
			((string=? next "#|")
				(read-char p)
				(read-char p)
				(read-ml-comment p (+ dep 1))
				)
			(#t
				(read-char p)
				(read-ml-comment p dep)
				)
			)

		)
	))


(define proc-dot
	(lambda (p tmp)
		(let ((ch (my-peek-char p)))
			(if
				(not (or
					(eq? ch #\space)
					(eq? ch #\))
					(eq? ch #\()
					(eq? ch #\])
					(eq? ch #\[)
					(eq? ch #\newline)
					(eq? ch #\return)
					(eq? ch #\tab)
					))
					(proc-dot p (cons (read-char p) tmp))
				(list->string (reverse tmp))
				)
			)
		))

(define proc-unquote-splicing (lambda (src)
	(let ((has-unquote-splicing #f))
		(for-each (lambda (s)
			(if (and (pair? s) (eq? (car s) 'unquote-splicing))
				(set! has-unquote-splicing #t)
				)
			) src)
		
		(if has-unquote-splicing
			(list 'unquote (cons 'append
					(map (lambda (s)
;;						(if (and (pair? s) (eq? (car s) 'unquote-splicing))
;;							(cadr s)
;;							(if
;;								(and (pair? s) (eq? (car s) 'unquote))
;;								`(list ,(cadr s))
;;								`(list (quote ,s))
;;								)
;;							)

						(cond
							((and (pair? s) (eq? (car s) 'unquote-splicing))
								(cadr s)
								)
							((and (pair? s) (eq? (car s) 'unquote))
								`(list ,(cadr s))
								)
							((pair? s)
								`(list (,(quote quasiquote) ,s))
								)
							(#t
								`(list (quote ,s))
								)
							)

						) src)))
			src
			)
		)
	))

(define-condition-type <read-unclosed-curry-error> <error> #f)



(define symbol-char-set
	#[0-9\_a-zA-Z<>=!\+\-\*\/\.\$\|\&^?~\@\:%\#]
	)


(define my-read-sym-core (lambda (p buff delim-char delim-char2)
	(let (
		(next (my-peek-char p))
		(next2 (my-peek-char2 p))
		)
		(if
			(or
				(eof-object? next)
				(and (not (eof-object? next2)) (hash-table-exists? reader-macro2-table next2))
				(hash-table-exists? reader-macro-table next)
				(and delim-char (eq? next delim-char))
				(and delim-char delim-char2 (not (eof-object? next2)) (string=? next2 (list->string (list delim-char delim-char2))))
				(not (char-set-contains? symbol-char-set next))
				)
			(let ((sym (string->symbol (list->string (reverse buff)))))
				;;(display sym)
				;;(newline)

				sym
				)
			(my-read-sym-core p (cons (read-char p) buff) delim-char delim-char2)
			)
		)
	))

(define my-read-sym (lambda (p delim-char delim-char2)
	(my-read-sym-core p '() delim-char delim-char2)
	))


(define my-read-num-core (lambda (p buff)
	(let (
		(next (my-peek-char p))
		(next2 (my-peek-char2 p))
		)
		(if
			(or
				(eof-object? next)
				(and (not (eof-object? next2)) (hash-table-exists? reader-macro2-table next2))
				(hash-table-exists? reader-macro-table next)
				(not (char-set-contains? #[0-9\.] next))
				)
			(let ((sym (string->number (list->string (reverse buff)))))
				;;(display sym)
				;;(newline)

				sym
				)
			(my-read-num-core p (cons (read-char p) buff))
			)
		)
	))

(define my-read-num (lambda (p)
	(my-read-num-core p '())
	))




(define my-read-core (lambda (p ls dep dot dotf br delim-char delim-char2)
(cond
	((eof-object? (my-peek-char p))
		(if (= dep 0)
			;;(reverse ls)
			(read-char p)
			;;(read-char p)
			(error <read-unclosed-curry-error> "invalid bracket")
			)
		)
	(#t
	(let (
		(next (my-peek-char p))
		(next2 (my-peek-char2 p))
		)
		(cond
			((and (not (eof-object? next2)) (hash-table-exists? reader-macro2-table next2))
				(let* (
					(ch1 (read-char p))
					(ch2 (read-char p))
					(obj ((hash-table-get reader-macro2-table next2) p ch1 ch2))
					)
					(if (= dep 0)
						(if (undefined? obj) '() obj)
						(my-read-core p
							(if (undefined? obj)
								ls
								(cons obj ls)
								)
							dep #f #f br delim-char delim-char2)
						)
					)
				)
			((hash-table-exists? reader-macro-table next)
				(let ((obj ((hash-table-get reader-macro-table next) p (read-char p))))
					(if (= dep 0)
						(if (undefined? obj) '() obj)
						(my-read-core p
							(if (undefined? obj)
								ls
								(cons obj ls)
								)
							dep #f #f br delim-char delim-char2)
						)
					)
				)
			((or (eq? next #\() (eq? next #\[))
				(read-char p)
				(let* (
						(obj (my-read-core p '() (+ dep 1) #f #f next delim-char delim-char2))
						(reader-macro-p
							(cond
								((and (pair? obj) (eq? (car obj) 'set-macro-character))
								(if (eq? (caddr obj) #f)
									(hash-table-delete! reader-macro-table (cadr obj))
									(hash-table-put! reader-macro-table
										(cadr obj)
										(eval
											(caddr obj)
											reader-macro-module
											))
										)
									#t)
								((or
									(and (pair? obj) (eq? (car obj) 'set-dispatch-macro-character))
									(and (pair? obj) (eq? (car obj) 'set-macro-character2))
									)
								(if (eq? (cadddr obj) #f)
									(hash-table-delete!
										reader-macro2-table
										(list->string (list (cadr obj) (caddr obj))))
									(hash-table-put! reader-macro2-table
										(list->string (list (cadr obj) (caddr obj)))
										(eval
											(cadddr obj)
											reader-macro-module
											))
										)
									#t)
								(#t #f)
								)
							)
						)
					(if (= dep 0)
					(if reader-macro-p '() obj)
					(my-read-core p (if reader-macro-p ls (cons obj ls)) dep #f #f br delim-char delim-char2)
					)
					)
				)
			((eq? next #\.)
				(let ((dot-str (proc-dot p (list (read-char p)))))
					(if (string=? dot-str ".")
						(let ((obj (my-read-core p '() 0 #f #f br delim-char delim-char2)))
							(my-read-core p ls dep obj #t br delim-char delim-char2)
							)
						(if (= dep 0)
							(string->symbol dot-str)
							(my-read-core
								p
								(cons (string->symbol dot-str) ls)
								dep #f #f br delim-char delim-char2)
							)
						)
					)
				)
			((and (not (eof-object? next2)) (string=? next2 ",@"))
				(read-char p)
				(read-char p)
				(let ((obj (my-read-core p '() 0 #f #f br delim-char delim-char2)))
					(if (= dep 0)
						(error "invalid unquote-splicing")
						(my-read-core p
							(cons
								(list 'unquote-splicing obj)
								ls
								) dep #f #f br delim-char delim-char2)
						)
					)
				)
			((or
				(eq? next #\')
				(eq? next #\`)
				(eq? next #\,)
				)
				(read-char p)
				(let ((obj (my-read-core p '() 0 #f #f br delim-char delim-char2)))
					(if (= dep 0)
						(list (hash-table-get quote-table next) obj)
						(my-read-core p (cons
							(list (hash-table-get quote-table next)
								obj
								) ls) dep #f #f br delim-char delim-char2)
						)
					)
				)
			((or (eq? next #\)) (eq? next #\]))
				(read-char p)
				(if (or
					(and (eq? br #\() (eq? next #\)))
					(and (eq? br #\[) (eq? next #\]))
					)
					(if (>= dep 1)
						(if dotf
							(append (reverse ls) dot)
							(proc-unquote-splicing (reverse ls))
							)
						(error "invalid bracket")
						)
					(error "invalid bracket")
					)
				)
			((and (not (eof-object? next2)) (string=? next2 "#|"))
				(read-char p)
				(read-char p)
				(read-ml-comment p 1)
				(my-read-core p ls dep #f #f br delim-char delim-char2)
				)
			((and (not (eof-object? next2)) (string=? next2 "#;"))
				(read-char p)
				(read-char p)
				(read p)
				(my-read-core p ls dep #f #f br delim-char delim-char2)
				)
			((eq? next #\;)
				(read-line p)
				(my-read-core p ls dep #f #f br delim-char delim-char2)
				)
			((or
				(eq? next #\space)
				(eq? next #\newline)
				(eq? next #\return)
				(eq? next #\tab)
				)
				(read-char p)
				(my-read-core p ls dep dot dotf br delim-char delim-char2)
				)
			(dotf
				(error "invalid dot list"))
			((and
				(not (eof-object? next2))
				(or
					(string=? next2 "#(")
					(string=? next2 "#[")
					)
				)
				(read-char p)
				(let ((obj (my-read-core p '() 0 #f #f br delim-char delim-char2)))
					(list->vector obj)
					)
				)
			(#t
				(let* (
					(obj-src
						(if (or
							;;#t
							(eq? next #\')
							(eq? next #\")
							(eq? next #\:)
							(and
								(not (eof-object? next2))
								(or
									(string=? next2 "#t")
									(string=? next2 "#f")
									(string=? next2 "#\\")
									)
								)
							)
							(read p)
							(if
								(char-set-contains? #[0-9] next)
								(my-read-num p)
								(my-read-sym p delim-char delim-char2)
								)
							))
					(obj (if (keyword? obj-src)
						(string->symbol (string-append ":" (keyword->string obj-src)))
						obj-src))
						)
					(if (= dep 0)
						obj
						(my-read-core p (cons obj ls) dep #f #f br delim-char delim-char2)
						)
					))
			)
		
		
		)
		))
	))