interpreter

(define (evaluate expr xs)
  (cond ((eq? expr '+) (+ (cadr xs) (car xs)))
        ((eq? expr '-) (- (cadr xs) (car xs)))
        ((eq? expr '*) (* (cadr xs) (car xs)))
        ((eq? expr '/) (/ (cadr xs) (car xs)))
        ((eq? expr 'mod) (remainder (cadr xs) (car xs)))
        ((eq? expr 'neg) (- (car xs)))
        ((eq? expr '=) (if (= (car xs) (cadr xs)) -1 0))
        ((eq? expr '>) (if (> (cadr xs) (car xs)) -1 0))
        ((eq? expr '<) (if (< (cadr xs) (car xs)) -1 0))
        ((eq? expr 'not) (if (not (= (car xs) 0)) 0 -1))
        ((eq? expr 'and) (if (and (not (= (car xs) 0)) (not (= (cadr xs) 0))) -1 0))
        ((eq? expr 'or) (if (and (= (car xs) 0) (= (cadr xs) 0)) 0 -1))))

;evaluation изменений стэка данных-->
(define ev-list (list
                 (list 'drop (lambda (x) (cdr x)))
                 (list 'swap (lambda (x) (append (cons (cadr x) (cons (car x) '())) (cddr x))))
                 (list 'dup (lambda (x) (if (not (null? x)) (cons (car x) x))))
                 (list 'over (lambda (x) (cons (cadr x) x)))
                 (list 'rot (lambda (x) (append (cons (caddr x) (cons (cadr x) (car x))) (cdddr x))))
                 (list 'depth (lambda (x) (cons (length x) x)))))

(define (acons key x alist)
  (cons (list key x) alist))

(define (search prg count x)
  (if (equal? (vector-ref prg count) x)
      (+ count 1)
      (search prg (+ count 1) x)))

(define (endif-search prg wc if-count)
  (cond ((eq? (vector-ref prg wc) 'if) (endif-search prg (+ wc 1) (+ if-count 1)))
        ((and (<= if-count 0) (eq? (vector-ref prg wc) 'endif)) wc)
        ((eq? (vector-ref prg wc) 'endif) (endif-search prg (+ wc 1) (- if-count 1)))
        (else (endif-search prg (+ wc 1) if-count))))

;(trace endif-search)

(define (interpret code stack)
  (define (helper prg wc xs rs env) ;prg - код, xs - stack, rs - returnStack; env - список слов из define
    (if (= wc (vector-length prg))
        xs
        (cond ((number? (vector-ref prg wc)) (helper prg (+ wc 1) (cons (vector-ref prg wc) xs) rs env))
              ((eq? (vector-ref prg wc) '+) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))
              ((eq? (vector-ref prg wc) '-) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))
              ((eq? (vector-ref prg wc) '*) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))
              ((eq? (vector-ref prg wc) '/) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))
              ((eq? (vector-ref prg wc) 'mod) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))
              ((eq? (vector-ref prg wc) 'neg) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs))) (cdr xs)) rs env))

              ((eq? (vector-ref prg wc) '=) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))
              ((eq? (vector-ref prg wc) '>) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))
              ((eq? (vector-ref prg wc) '<) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))

              ((eq? (vector-ref prg wc) 'not) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs))) (cdr xs)) rs env))
              ((eq? (vector-ref prg wc) 'and) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))
              ((eq? (vector-ref prg wc) 'or) (helper prg (+ wc 1) (cons (evaluate (vector-ref prg wc) (list (car xs) (cadr xs))) (cddr xs)) rs env))

              ((eq? (vector-ref prg wc) 'drop) (helper prg (+ wc 1) ((cadr (assoc 'drop ev-list)) xs) rs env))
              ((eq? (vector-ref prg wc) 'swap) (helper prg (+ wc 1) ((cadr (assoc 'swap ev-list)) xs) rs env))
              ((eq? (vector-ref prg wc) 'dup) (helper prg (+ wc 1) ((cadr (assoc 'dup ev-list)) xs) rs env))
              ((eq? (vector-ref prg wc) 'over) (helper prg (+ wc 1) ((cadr (assoc 'over ev-list)) xs) rs env))
              ((eq? (vector-ref prg wc) 'rot) (helper prg (+ wc 1) ((cadr (assoc 'rot ev-list)) xs) rs env))
              ((eq? (vector-ref prg wc) 'depth) (helper prg (+ wc 1) ((cadr (assoc 'depth ev-list)) xs) rs env))
              ;define - добавление word в список env
              ((eq? (vector-ref prg wc) 'define) (helper prg (search prg wc 'end) xs rs (acons (vector-ref prg (+ wc 1)) (+ wc 2) env)))
              ((eq? (vector-ref prg wc) 'end) (helper prg (car rs) xs (cdr rs) env))
              ((eq? (vector-ref prg wc) 'exit) (helper prg (car rs) xs (cdr rs) env))
              ((eq? (vector-ref prg wc) 'if) (if (= (car xs) -1) (helper prg (+ wc 1) (cdr xs) rs env) (helper prg (endif-search prg (+ wc 1) 0) (cdr xs) rs env)))
              ((eq? (vector-ref prg wc) 'endif) (helper prg (+ wc 1) xs rs env))
              ((number? (cadr (assoc (vector-ref prg wc) env))) (helper prg (cadr (assoc (vector-ref prg wc) env)) xs (cons (+ wc 1) rs) env)))))
              ;((symbol? (cadr (assoc (vector-ref prg wc) env))) (helper prg (cadr (assoc (vector-ref prg wc) env)) xs (cons (+ 1 wc) rs) env)))))
        ;(append xs stack)))
  (helper code 0 '() '() ev-list))