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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
|
(in-package :cl-forth)
(eval-always
(defparameter *identifiers*
'(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < >
syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6
bel oku yaz))
(defun is-identifier (sym)
(find sym *identifiers*)))
(defun make-token (sym? line col)
(if (or (is-identifier sym?) (numberp sym?))
(values (list sym? :line line :col col) nil)
(values (list sym? :line line :col col :error t) t)))
(defun token-op (token)
(car token))
;;; LEXER
(defun lex-line (line &optional (line-num 0))
(iter (with line-stream = (make-string-input-stream line))
(with col = 0)
(with has-err = nil)
(for next-char = (peek-char nil line-stream nil nil))
(until (null next-char))
(let ((flag t))
(cond ;; ((char= #\. next-char)
;; (collect (make-token '|.| line-num col) into tokens)
;; (read-char line-stream))
((char= #\Space next-char) (read-char line-stream))
((char= #\; next-char) ;; and not in string
(finish))
(t (setf flag nil)))
(when flag
(incf col)
(next-iteration)))
(for next-sym in-stream line-stream
using #'read-preserving-whitespace)
(multiple-value-bind (token err)
(make-token next-sym line-num col)
(collect token into tokens)
(when err ;; skip line on error and continue lexing
(setf has-err t)
(finish))
(incf col (length (princ-to-string next-sym))))
(finally (return (values tokens has-err)))))
(defun lex-file (file-name &optional report-errors)
(let ((has-error nil))
(values
(with-open-file (str file-name)
(iter outer
(for line = (read-line str nil nil))
(until (null line))
(for line-num from 1)
(multiple-value-bind (tokens has-err)
(lex-line line line-num)
(when has-err
(setf has-error t)
(when report-errors
(format t "~a~%" line)
(let ((err-token (find-if (lambda (tok) (find :error tok))
tokens)))
(format t "~a^"
(make-string (getf (cdr err-token) :col)
:initial-element #\Space)))))
(appending tokens))))
has-error)))
;;; PARSER
(defun parse-tokens (tokens)
(iter (with ops = (make-array (length tokens) :fill-pointer 0
:adjustable t))
(with stack = ())
(for i from 0)
(for token in tokens)
(let ((op (token-op token)))
(cond ((numberp op)
(vector-push-extend `(push ,op) ops))
((eq 'ise op)
(push (list 'ise i) stack)
(vector-push-extend (list 'ise nil) ops))
((eq 'yoksa op)
(let ((top (pop stack)))
(assert (eq 'ise (car top)))
(setf (second (aref ops (cadr top))) i)
(push (list 'yoksa i) stack)
(vector-push-extend (list 'yoksa nil i) ops)))
((eq 'yap op)
(let ((top (pop stack)))
(cond ((find (car top) (list 'yoksa 'ise))
(setf (second (aref ops (cadr top))) i)
(vector-push-extend (list 'yap i) ops))
((eq 'iken (car top))
(setf (second (aref ops (cadr top))) i)
(vector-push-extend (list 'yap i (third top)) ops))
(t (error "yap cannot reference: ~a" (car top))))))
((eq 'döngü op)
(push (list 'döngü i) stack)
(vector-push-extend (list 'döngü i) ops))
((eq 'iken op)
(let ((top (pop stack)))
(assert (eq 'döngü (car top)))
(push (list 'iken i (cadr top)) stack)
(vector-push-extend (list 'iken nil) ops)))
((search "syscall" (string-downcase (string op)))
(let ((syscall-num (parse-integer (subseq (string op) 8))))
(vector-push-extend (list 'syscall syscall-num) ops)))
(t (vector-push-extend (list op) ops))))
(finally (return ops))))
(defun make-program (file-name)
(multiple-value-bind (tokens has-error)
(lex-file file-name t)
(when has-error
(error "Can't generate program due to error during lexing"))
(parse-tokens tokens)))
;;; INTERPRETER
(eval-always
(define-condition op-not-implemented (style-warning)
((undef-ops :initarg :ops :reader undef-ops))
(:report (lambda (condition stream)
(format stream "These ops are not defined in op-case: ~s"
(undef-ops condition)))))
(defun identifier-coverage (defined-ops)
(let ((undef-ops (set-difference *identifiers* defined-ops)))
(unless (null undef-ops)
(warn (make-condition 'op-not-implemented :ops undef-ops))))))
(defmacro op-case (case-form &body body)
(iter (for (op-id) in body)
(when (not (is-identifier op-id))
(error "op-case: ~a is not an identifier" op-id))
(collect op-id into defined-ops)
(finally (identifier-coverage defined-ops)))
(let ((case-sym (gensym)))
`(let ((,case-sym ,case-form))
(case ,case-sym
,@body
(otherwise (if (is-identifier (first ,case-sym))
(error "op: ~a -- Not implemented yet"
(first ,case-sym))
(error "op: ~a -- Does not exist"
(first ,case-sym))))))))
(defun interpret-program (program)
(iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
;; (for op in-sequence program)
(for i from 0 below (length program))
(let ((op (aref program i)))
(op-case (first op)
(push (vector-push-extend (second op) stack))
(+ (vector-push-extend (+ (vector-pop stack)
(vector-pop stack))
stack))
(- (vector-push-extend (let ((top (vector-pop stack)))
(- (vector-pop stack) top))
stack))
(|.| (print (vector-pop stack)))
(= (vector-push-extend (if (= (vector-pop stack)
(vector-pop stack))
1 0)
stack))
(yap (next-iteration))
(yoksa (setf i (second op)))
(ise (if (= (vector-pop stack) 1)
nil
(setf i (second op))))
(eş (let ((top (vector-pop stack)))
(vector-push-extend top stack)
(vector-push-extend top stack)))
(değiş (let* ((fst (vector-pop stack))
(snd (vector-pop stack)))
(vector-push-extend fst stack)
(vector-push-extend snd stack)))
(düş (vector-pop stack))
(üst (let* ((fst (vector-pop stack))
(snd (vector-pop stack)))
(vector-push-extend snd stack)
(vector-push-extend fst stack)
(vector-push-extend snd stack)))
(rot (let* ((fst (vector-pop stack))
(snd (vector-pop stack))
(trd (vector-pop stack)))
(vector-push-extend snd stack)
(vector-push-extend fst stack)
(vector-push-extend trd stack)))))))
;; swap, değiş
;; dup, eş
;; over, üst
;; rot, rot
;; drop, düşür
;;; COMPILER
(defun generate-program (program &key (path "output.asm") (compile nil)
(mem-cap 640000))
(with-open-file (out path :direction :output
:if-exists :supersede)
(format out "~a~%" "segment .text")
(gen-dump out)
(format out "~{~a~%~}" '("global _start"
"_start:"))
(iter (for op in-sequence program)
(gen-header op out)
(gen-code op out))
(gen-header '(exit 0) out)
(gen-code '(exit 0) out)
(format out "~a~%" "segment .bss")
(format out "~a ~a~%" "bel: resb" mem-cap))
(when compile
(run `("nasm" "-felf64" ,path))
(let ((name (first (uiop:split-string path :separator '(#\.)))))
(run `("ld" "-o" ,name ,(concatenate 'string name ".o"))))))
(defun compile-program (path)
(generate-program (make-program path) :compile t))
(defun assembly-undefined-ops ()
(iter (for (k) in-hashtable *operations*)
(collect k into defops)
(finally (return (set-difference *identifiers* defops)))))
|
