-
Notifications
You must be signed in to change notification settings - Fork 0
/
sumterForth.scm
103 lines (101 loc) · 4.51 KB
/
sumterForth.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
(define forth
(let ((stack '()) (words '()) (stat '(() . ())))
;;Ugly code, clean someday
(define (def-word!)
(let ((ctx (read)))
(cond
((eq? ctx 'df) '())
(#t (cons ctx (def-word!))))))
(define (word? input words)
(cond ((eq? words '()) #f)
((eq? (caar words) input) #t)
(#t (word? input (cdr words)))))
(define (find-word word words)
(cond ((eq? (caar words) word) (cdar words))
(#t (find-word word (cdr words)))))
(define (call-word input)
(let ((stuff (find-word input words)))
(eval-stuff stuff)))
(define (eval-stuff stuff)
(feval (car stuff))
(if (pair? (cdr stuff)) (eval-stuff (cdr stuff))))
(define (feval input)
(if (eq? stat '()) (set! stat '(() . ())))
(cond
((eq? input 'else)
(cond
((eq? (car stat) #t)
(set! stat (cons 'nop (cdr stat))))
((eq? (car stat) #f)
(set! stat (cons #t (cdr stat))))))
((eq? input 'then)
(if (pair? (cdr stat)) (set! stat (cdr stat)))))
(if (and (not (eq? (car stat) 'nop))
(not (eq? (car stat) #f)))
(cond
((eq? input 'if) (begin
(if (eq? (car stack) 0)
(set! stat (cons #f stat))
(set! stat (cons #t stat)))
(set! stack (cdr stack))))
((eq? input 'else))
((eq? input 'then))
((number? input) (set! stack (cons input stack)))
((eq? input ':) (set! words (cons (def-word!) words)))
((eq? input 'drop) (if (pair? stack)
(set! stack (cdr stack))
(begin
(display "STACK EMPTY!")
(newline))))
((eq? input 'dup) (set! stack (cons (car stack) stack)))
((eq? input 'swap) (set! stack (cons (cadr stack)
(cons (car stack)
(cddr stack)))))
((eq? input 'rot) (set! stack `(,(caddr stack) .
(,(car stack) .
(,(cadr stack) .
,(cdddr stack))))))
((eq? input '>) (if (> (cadr stack) (car stack))
(set! stack (cons -1 (cddr stack)))
(set! stack (cons 0 (cddr stack)))))
((eq? input '<) (if (< (cadr stack) (car stack))
(set! stack (cons -1 (cddr stack)))
(set! stack (cons 0 (cddr stack)))))
((eq? input '>=) (if (>= (cadr stack) (car stack))
(set! stack (cons -1 (cddr stack)))
(set! stack (cons 0 (cddr stack)))))
((eq? input '<=) (if (<= (cadr stack) (car stack))
(set! stack (cons -1 (cddr stack)))
(set! stack (cons 0 (cddr stack)))))
((eq? input '=) (if (= (cadr stack) (car stack))
(set! stack (cons -1 (cddr stack)))
(set! stack (cons 0 (cddr stack)))))
((eq? input '-) (set! stack (cons (- (cadr stack)
(car stack))
(cddr stack))))
((eq? input '+) (set! stack (cons (+ (car stack)
(cadr stack))
(cddr stack))))
((string? input) (begin (display input) (newline)))
((eq? input '.s) (display stack) (newline))
((eq? input '.) (if (pair? stack)
(begin
(display (car stack))
(newline)))
(feval 'drop))
((word? input words) (call-word input))
((eq? input 'exit)) ;;Please clean me!
((eq? input 'pause))
(#t (begin (display "ERROR, UNDEFINED") (newline))))))
(lambda ()
(let ((input (read)))
(feval input)
(cond ((eq? input 'exit)
(set! stack '())
(set! words '())
(set! stat '(() . ()))
(display "Elveda Mahzun Pazartesi!")
(newline))
((eq? input 'pause)
(display "Paused") (newline))
(#t (forth)))))))