;; add these to your user-funcs file sans the comments:
;;(log_10 10 swap log)
;;(log_2 2 swap log)
;;(squared dup *)
;;(frac dup trunc swap -)
;;(neg -1 *)
;;(quadratic-eqn swap rot dup rot 4 * * swap rot dup squared swap rot - sqrt swap neg dup rot dup rot swap + rot swap - rot 2 * dup rot swap / rot swap /)
;;(inc 1 +)

(define (pop stack)
  (if (null? stack)
	(error "pop: stack empty")
	(let ((var (car stack))
		  (ret-stack (cdr stack)))
	  (values var ret-stack))))

(define (push var stack)
  (append (list var) stack))

(define (dup stack dict)
  (let-values (((var stack) (pop stack)))
	(let ((stack (push var stack)))
	  (push var stack))))

(define (fact x)
  (define (fact-iter n current)
	(if (<= n 1)
	  current
	  (fact-iter (- n 1) (* n current))))
  (fact-iter x 1))

(define-syntax rpn-func
  (syntax-rules ()
	((rpn-func func 2)
	 (lambda (stack dict)
	   (let*-values (((var1 stack) (pop stack))
					 ((var2 stack) (pop stack)))
		 (push (func var2 var1) stack))))
	
	((rpn-func func 1)
	 (lambda (stack dict)
	   (let*-values (((var stack) (pop stack)))
		 (push (func var) stack))))))
	  
(define (insert-into-alist key val alist)
  (let ((mem? (assq key alist)))
	(if mem?
	  (update-alist key val alist)
	  (append alist (list (cons key val))))))

(define (index-in-alist key alist)
  (let loop ((list (list-copy alist))
			 (index 0))
	(if (= (length list) 0)
	  #f
	  (let ((list-head-key (car (car list))))
		(if (eq? list-head-key key)
		  index
		  (loop (cdr list) (+ index 1)))))))

(define (update-alist key new-val alist)
  (let ((index (index-in-alist key alist)))
	(list-set! alist index (cons key new-val))
	alist))

(define (run-func sym dict stack)
  (let ((func (assq sym dict)))
	(if func
	  ((cdr func) stack dict)
	  (begin
		(display "ERROR: symbol not in dictionary: ")
		(display sym)
		(newline)
		stack))))

(define (swap stack dict)
  (let*-values (((var1 stack) (pop stack))
				((var2 stack) (pop stack)))
	(let ((stack (push var1 stack)))
	  (push var2 stack))))

(define (print-top-of-stack stack dict)
  (let-values (((var stack) (pop stack)))
	(display var)
	(newline)
	stack))

(define (print-stack stack dict)
  (begin
	(display stack)
	(newline)
	stack))

(define (rotate-stack-3 stack dict)
  (let*-values (((var1 stack) (pop stack))
				((var2 stack) (pop stack))
				((var3 stack) (pop stack)))
	(let* ((stack (push var1 stack))
		   (stack (push var2 stack)))
	  (push var3 stack))))

(define (rotate-stack-4 stack dict)
  (let*-values (((var1 stack) (pop stack))
				((var2 stack) (pop stack))
				((var3 stack) (pop stack))
				((var4 stack) (pop stack)))
	(let* ((stack (push var1 stack))
		   (stack (push var2 stack))
		   (stack (push var3 stack)))
	  (push var4 stack))))

(define (rpn-if stack dict)
  (let-values (((var stack) (pop stack)))
	(if var
	  (let ((ret-stack (run-func (read) dict stack)))
		(read)
		ret-stack)
	  (begin
		(read)
		(run-func (read) dict stack)))))

(define (rpn-do stack dict)
  (let loop ((stack stack)
			 (func (read)))
	(let ((head (car stack))
		  (second (cadr stack)))
	  (if (= head second)
		(let*-values (((var stack) (pop stack))
					  ((var stack) (pop stack)))
		  stack)
		(let ((stack (run-func func dict stack)))
		  (loop (run-func 'inc dict stack) func))))))

(define-syntax generate-init-dict
  (syntax-rules ()
	((generate-init-dict () form . forms)
	 (list form . forms))

	((generate-init-dict ((name func args)) form . forms )
	 (generate-init-dict () (cons (quote name) (rpn-func func args)) form . forms))
	
	((generate-init-dict ((name func)) form . forms )
	 (generate-init-dict () (cons (quote name) func) form . forms))
	
	((generate-init-dict ((name func args) . variables) form . forms )
	 (generate-init-dict variables (cons (quote name) (rpn-func func args)) form . forms))
	
	((generate-init-dict ((name func) . variables) form . forms )
	 (generate-init-dict variables (cons (quote name) func) form . forms))
	
	((generate-init-dict ((name func args) . variables))
	 (generate-init-dict variables (cons (quote name) (rpn-func func args))))
	
	((generate-init-dict ((name func) . variables))
	 (generate-init-dict variables (cons (quote name) func)))))

(define init-dict (generate-init-dict ((+ + 2) (- - 2) (/ / 2) (* * 2) (% % 2) (! fact 1)
									   (sin sin 1) (cos cos 1) (tan tan 1) (trunc truncate 1)
									   (ceil ceiling 1) (floor floor 1) (pow expt 2) (log_2 log 1)
									   (log log 2) (sqrt sqrt 1) (= = 2) (dup dup) (swap swap)
									   ($ print-top-of-stack) (PS print-stack) (rot rotate-stack-3)
									   (rot4 rotate-stack-4) (IF rpn-if) (DO rpn-do))))

(define (user-func-from-list func)
  (lambda (stack dict)
	(let loop ((func func)
			   (stack stack))
	  (if (= (length func) 1)
		(if (number? (car func))
		  (push (car func) stack)
		  (run-func (car func) dict stack))
		(if (number? (car func))
		  (loop (cdr func) (push (car func) stack))
		  (loop (cdr func) (run-func (car func) dict stack)))))))

(define (new-func list dictionary)
  (insert-into-alist (car list) (user-func-from-list (cdr list)) dictionary))

(define funcs-file "your-funcs")

(define (list-as-string list)
  (parameterize ((current-output-port (open-output-string)))
	(write list)
	(get-output-string (current-output-port))))

(define (add-user-func list user-funcs file)
  (let ((func-to-add (list-as-string list)))
	(parameterize ((current-output-port (open-output-file file)))
	  (let ((new-user-funcs (string-append user-funcs func-to-add "\n")))
		(display new-user-funcs)
		(close-output-port (current-output-port))
		new-user-funcs))))

(define (load-funcs-from-file-dict file dict)
  (with-input-from-file file
	(lambda ()
	  (let loop ((input (read))
				 (dict dict))
		(if (eof-object? input)
		  dict
		  (loop (read) (new-func input dict)))))))

(define (load-funcs-from-file-str file)
  (with-input-from-file file
	(lambda ()
	  (let loop ((next-str (read-string 10))
				 (str ""))
		(if (eof-object? next-str)
		  str
		  (loop (read-string 10) (string-append str next-str)))))))

(let loop ((stack '())
		   (dict (load-funcs-from-file-dict funcs-file init-dict))
		   (user-funcs (load-funcs-from-file-str funcs-file)))
  (let ((input (read)))
	(cond
	 ((number? input) (loop (push input stack) dict user-funcs))
	 ((list? input) (let ((user-funcs (add-user-func input user-funcs funcs-file)))
					  (loop stack (new-func input dict) user-funcs)))
	 ((symbol? input) (loop (run-func input dict stack) dict user-funcs))
	 ((eof-object? input) (begin))
	 (else (begin
			 (error "not valid input: " input)
			 (loop stack dict user-funcs))))))