API tools faq
paste
Advertisement
EWTD

Interpretator for OCHKO Lang

EWTD
Dec 19th, 2020 (edited)
3,011
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Scheme 15.46 KB | None | 0 0
raw download clone embed print report
  1. (define exit #f)
  2. (define (use-assertions)
  3.   (call-with-current-continuation
  4.    (lambda (cc)
  5.      (set! exit cc))))
  6. (use-assertions)
  7. (define-syntax assert-with-message
  8.   (syntax-rules ()
  9.     ((_ expression message)
  10.      (if (not expression)
  11.          (begin
  12.            (display message)
  13.            (newline)
  14.            (exit))))))
  15. (define (interpret commands stack)
  16.   (define exit-continuations '())
  17.   (define commands-length (vector-length commands))
  18.   ;returns index of end for current function/if
  19.   (define (find-end pos)
  20.     (define (find-pos plus_elem minus_elem counter index)
  21.       (if (and (not (= index pos)) (= counter 0))
  22.           index
  23.           (if (= index commands-length)
  24.               0
  25.               (if (equal? (vector-ref commands index) plus_elem)
  26.                   (find-pos plus_elem minus_elem (+ counter 1) (+ index 1))
  27.                   (if (equal? (vector-ref commands index) minus_elem)
  28.                       (find-pos plus_elem minus_elem (- counter 1) (+ index 1))
  29.                       (find-pos plus_elem minus_elem counter (+ index 1)))))))
  30.     (if (equal? (vector-ref commands pos) 'define)
  31.         (- (find-pos 'define 'end  0 pos) 1)
  32.         (if (equal? (vector-ref commands pos) 'if)
  33.             (- (find-pos 'if 'endif 0 pos) 1)
  34.             -1)))
  35.   ;returns index of else for current if
  36.   (define (find-else pos)
  37.     (define (find-pos counter index end-index)
  38.       (if (and (not (= index pos)) (= counter 0))
  39.           index
  40.           (if (= index end-index)
  41.               -1
  42.               (let ((current-command (vector-ref commands index)))
  43.                 (cond
  44.                   ((equal? current-command 'if) (find-pos (+ counter 1) (+ index 1) end-index))
  45.                   ((equal? current-command 'endif) (find-pos (- counter 1) (+ index 1) end-index))
  46.                   ((equal? current-command 'else) (if (= counter 1) index (find-pos counter (+ index 1) end-index)))
  47.                   (else (find-pos counter (+ index 1) end-index)))))))
  48.     (if (equal? (vector-ref commands pos) 'if)
  49.         (find-pos 0 pos (find-end pos))
  50.         -1))
  51.   ;returns dictionary of functions
  52.   (define (parse-scope begin_pos end_pos)
  53.     (define (_iter index result)
  54.       (if (= index end_pos)
  55.           result
  56.           (let ((current-command (vector-ref commands index)))
  57.             (cond
  58.               ((equal? current-command 'define) (let ((end-index (find-end index)))
  59.                                                   (if (= end-index -1)
  60.                                                       (assert-with-message #f "cant find <end> for <define>")
  61.                                                       (_iter (+ end-index 1) (cons (list (vector-ref commands (+ index 1)) (list (+ index 2) end-index)) result)))))
  62.               ((equal? current-command 'if) (let ((end-index (find-end index)))
  63.                                               (if (= end-index -1)
  64.                                                   (assert-with-message #f "can't find <endif> for <if>")
  65.                                                   (_iter (+ end-index 1) result))))
  66.               (else (_iter (+ index 1) result))))))
  67.     (_iter begin_pos '()))
  68.   ;merges scopes, if element found in both scopes rhs_scope overrides lhs_scope
  69.   (define (merge-scopes lhs_scope rhs_scope)
  70.     (define (_iter collectable result)
  71.       (if (null? collectable)
  72.           result
  73.           (if (equal? (assq (caar collectable) result) #f)
  74.               (_iter (cdr collectable) (cons (car collectable) result))
  75.               (_iter (cdr collectable) result))))
  76.     (_iter lhs_scope rhs_scope))
  77.   ;do stuff:)
  78.   (define (main index end-index stack scope)
  79.     (if (= index end-index)
  80.         stack
  81.         (let ((current-command (vector-ref commands index)))
  82.           (cond
  83.             ((number? current-command) (main (+ index 1) end-index (cons current-command stack) scope ))
  84.             ((equal? current-command '+) (let ((stack-length (length stack)))
  85.                                            (if (< stack-length 2)
  86.                                                (assert-with-message #f "+ cant be applied, cause stack length < 2")
  87.                                                (main (+ index 1) end-index (cons (+ (car stack) (cadr stack)) (cddr stack)) scope ))))
  88.             ((equal? current-command '-) (let ((stack-length (length stack)))
  89.                                            (if (< stack-length 2)
  90.                                                (assert-with-message #f "- cant be applied, cause stack length < 2")
  91.                                                (main (+ index 1) end-index (cons (- (cadr stack) (car stack)) (cddr stack)) scope ))))
  92.             ((equal? current-command '*) (let ((stack-length (length stack)))
  93.                                            (if (< stack-length 2)
  94.                                                (assert-with-message #f "* cant be applied, cause stack length < 2")
  95.                                                (main (+ index 1) end-index (cons (* (car stack) (cadr stack)) (cddr stack)) scope ))))
  96.             ((equal? current-command '/) (let ((stack-length (length stack)))
  97.                                            (if (< stack-length 2)
  98.                                                (assert-with-message #f "/ cant be applied, cause stack length < 2")
  99.                                                (main (+ index 1) end-index (cons (/ (cadr stack) (car stack)) (cddr stack)) scope ))))
  100.             ((equal? current-command 'mod) (let ((stack-length (length stack)))
  101.                                              (if (< stack-length 2)
  102.                                                  (assert-with-message #f "mod cant be applied, cause stack length < 2")
  103.                                                  (main (+ index 1) end-index (cons (remainder (cadr stack) (car stack)) (cddr stack)) scope ))))
  104.             ((equal? current-command 'and) (let ((stack-length (length stack)))
  105.                                              (if (< stack-length 2)
  106.                                                  (assert-with-message #f "and cant be applied, cause stack length < 2")
  107.                                                  (main (+ index 1) end-index (cons (and (car stack) (cadr stack)) (cddr stack)) scope))))
  108.             ((equal? current-command 'or) (let ((stack-length (length stack)))
  109.                                             (if (< stack-length 2)
  110.                                                 (assert-with-message #f "or cant be applied, cause stack length < 2")
  111.                                                 (main (+ index 1) end-index (cons (- (car stack) (cadr stack)) (cddr stack)) scope))))
  112.             ((equal? current-command '>) (let ((stack-length (length stack)))
  113.                                            (if (< stack-length 2)
  114.                                                (assert-with-message #f "> cant be applied, cause stack length < 2")
  115.                                                (main (+ index 1) end-index (cons (> (cadr stack) (car stack)) (cddr stack)) scope))))
  116.             ((equal? current-command '<) (let ((stack-length (length stack)))
  117.                                            (if (< stack-length 2)
  118.                                                (assert-with-message #f "< cant be applied, cause stack length < 2")
  119.                                                (main (+ index 1) end-index (cons (< (cadr stack) (car stack)) (cddr stack)) scope))))
  120.             ((equal? current-command '=) (let ((stack-length (length stack)))
  121.                                            (if (< stack-length 2)
  122.                                                (assert-with-message #f "= cant be applied, cause stack length < 2")
  123.                                                (main (+ index 1) end-index (cons (= (car stack) (cadr stack)) (cddr stack)) scope))))
  124.             ((equal? current-command 'swap) (let ((stack-length (length stack)))
  125.                                               (if (< stack-length 2)
  126.                                                   (assert-with-message #f "swap cant be applied, cause stack length < 2")
  127.                                                   (main (+ index 1) end-index (append (list (cadr stack) (car stack)) (cddr stack)) scope))))
  128.             ((equal? current-command 'over) (let ((stack-length (length stack)))
  129.                                               (if (< stack-length 2)
  130.                                                   (assert-with-message #f "over cant be applied, cause stack length < 2")
  131.                                                   (main (+ index 1) end-index (cons (cadr stack) stack) scope))))
  132.             ((equal? current-command 'rot) (let ((stack-length (length stack)))
  133.                                              (if (< stack-length 3)
  134.                                                  (assert-with-message #f "rot cant be applied, cause stack length < 3")
  135.                                                  (main (+ index 1) end-index (append (list (caddr stack) (cadr stack) (car stack)) (cdddr stack)) scope))))
  136.             ((equal? current-command 'depth) (let ((stack-length (length stack)))
  137.                                                (main (+ index 1) end-index (cons stack-length stack) scope)))
  138.             ((equal? current-command 'drop) (let ((stack-length (length stack)))
  139.                                               (if (< stack-length 1)
  140.                                                   (assert-with-message #f "drop cant be applied, cause stack length < 1")
  141.                                                   (main (+ index 1) end-index (cdr stack) scope))))
  142.             ((equal? current-command 'dup) (let ((stack-length (length stack)))
  143.                                              (if (< stack-length 1)
  144.                                                  (assert-with-message #f "dup cant be applied, cause stack length < 1")
  145.                                                  (main (+ index 1) end-index (append (list (car stack) (car stack)) (cdr stack)) scope))))
  146.             ((equal? current-command 'not) (let ((stack-length (length stack)))
  147.                                              (if (< stack-length 1)
  148.                                                  (assert-with-message #f "not cant be applied, cause stack length < 1")
  149.                                                  (main (+ index 1) end-index (cons (not (car stack)) (cdr stack)) scope))))
  150.             ((equal? current-command 'neg) (let ((stack-length (length stack)))
  151.                                              (if (< stack-length 1)
  152.                                                  (assert-with-message #f "neg cant be applied, cause stack length < 1")
  153.                                                  (main (+ index 1) end-index (cons (- (car stack)) (cdr stack)) scope))))
  154.             ((equal? current-command 'define) (let ((end-pos (find-end index)))
  155.                                                 (if (= end-pos -1)
  156.                                                     (assert-with-message #f "funciton hasn't got an <end>")
  157.                                                     (main (+ end-pos 1) end-index stack scope))))
  158.             ((equal? current-command 'if) (let ((end-pos (find-end index)) (else-index (find-else index)))
  159.                                             (if (= end-pos -1)
  160.                                                 (assert-with-message #f "<if> hasn't got an <end>")
  161.                                                 (if (car stack)
  162.                                                     (main (+ end-pos 1) end-index
  163.                                                           (main (+ 1 index) end-pos (cdr stack)
  164.                                                                 (merge-scopes scope (parse-scope (+ index 1) (if (= else-index -1) end-index else-index))))
  165.                                                           scope)
  166.                                                     (if (= else-index -1)
  167.                                                         (main (+ end-pos 1) end-index (cdr stack) scope)
  168.                                                         (main (+ end-pos 1) end-index
  169.                                                               (main (+ else-index 1) end-pos
  170.                                                                     (cdr stack)
  171.                                                                     (merge-scopes scope (parse-scope (+ index 1) end-pos)))
  172.                                                               scope))))))
  173.             ;exit on top context in stack
  174.             ((equal? current-command 'exit) ((car exit-continuations) stack))
  175.             ;function call will remembering of current context for possible exit
  176.             ((not (equal? (assq current-command scope) #f))
  177.              (let* ((pair (cadr (assq current-command scope)))
  178.                     (result (call-with-current-continuation (lambda (cc) (begin
  179.                                                                            (set! exit-continuations (cons cc exit-continuations))
  180.                                                                            (main (car pair) (cadr pair) stack (merge-scopes scope (parse-scope (car pair) (cadr pair)))))))))
  181.                (begin (set! exit-continuations (cdr exit-continuations)) (main (+ index 1) end-index result scope))))
  182.             (else (assert-with-message #f (string-append "cant interpret <" (symbol->string current-command) ">")))))))
  183.   (main 0  commands-length stack (parse-scope 0 commands-length )))
  184. (interpret #(2 3 * 4 5 * +) '())
  185. (interpret #(   define -- 1 - end
  186.                 5 -- --      ) '())
  187. (interpret #(   define abs
  188.                     dup 0 <
  189.                     if neg endif
  190.                 end
  191.                  9 abs
  192.                 -9 abs      ) (quote ()))
  193. (interpret #(   define =0? dup 0 = end
  194.                 define <0? dup 0 < end
  195.                 define signum
  196.                     =0? if exit endif
  197.                     <0? if drop -1 exit endif
  198.                     drop
  199.                     1
  200.                 end
  201.                  0 signum
  202.                 -5 signum
  203.                 10 signum       ) (quote ()))
  204. (interpret #(   define -- 1 - end
  205.                 define =0? dup 0 = end
  206.                 define =1? dup 1 = end
  207.                 define factorial
  208.                     =0? if drop 1 exit endif
  209.                     =1? if drop 1 exit endif
  210.                     dup --
  211.                     factorial
  212.                     *
  213.                 end
  214.                 0 factorial
  215.                 1 factorial
  216.                 2 factorial
  217.                 3 factorial
  218.                 4 factorial     ) (quote ()))
  219. (interpret #(   define =0? dup 0 = end
  220.                 define =1? dup 1 = end
  221.                 define -- 1 - end
  222.                 define fib
  223.                     =0? if drop 0 exit endif
  224.                     =1? if drop 1 exit endif
  225.                     -- dup
  226.                     -- fib
  227.                     swap fib
  228.                     +
  229.                 end
  230.                 define make-fib
  231.                     dup 0 < if drop exit endif
  232.                     dup fib
  233.                     swap --
  234.                     make-fib
  235.                 end
  236.                 10 make-fib     ) (quote ()))
  237. (interpret #(   define =0? dup 0 = end
  238.                 define gcd
  239.                     =0? if drop exit endif
  240.                     swap over mod
  241.                     gcd
  242.                 end
  243.                 90 99 gcd
  244.                 234 8100 gcd    ) '())
  245.  
  246.    
  247.  
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!