(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))))))))

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.