(define (pop stack)
(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 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 (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)
(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)
(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))
(input (delay (read))))
(let ((input (force input)))
(cond
((number? input) (loop (push input stack) dict user-funcs (delay (read))))
((list? input) (let ((user-funcs (add-user-func input user-funcs funcs-file)))
(loop stack (new-func input dict) user-funcs (delay (read)))))
((symbol? input) (loop (run-func input dict stack) dict user-funcs (delay (read))))
(else (begin
(display "ERROR not valid input: ")
(display input)
(newline)
(loop stack dict user-funcs (delay (read))))))))