blob: 1026253e0ed67148e81b7c5ffb0fa9ac249e9922 (
plain)
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
|
(in-package :cl-forth)
(defun make-token (sym? line col &optional (type nil))
(when (null type)
(setf type
(cond ((numberp sym?) :number)
((stringp sym?) :string)
((is-identifier sym?) :identifier)
(t
;; temporary hack...
(return-from make-token
(values (list sym? :line line :col col :error t) t))))))
(values (list sym? :line line :col col :type type) nil))
(defun token-op (token)
(car token))
;;; LEXER
(defun read-string (stream)
;; TODO: Handle unmatched " and give proper error message
(with-output-to-string (str)
(iter (for ch = (read-char stream))
(cond ((char= ch #\")
(finish))
((and (char= ch #\\) (char= (peek-char nil stream) #\n))
(read-char stream)
(write-char #\Newline str))
(t (write-char ch str))))))
(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= #\| next-char)
(read-char line-stream)
(collect (make-token "|" line-num col :identifier) into tokens))
((char= #\Space next-char) (read-char line-stream))
((char= #\; next-char) ;; and not in string
(finish))
((char= #\" next-char)
(read-char line-stream)
(collect (make-token (read-string line-stream)
line-num col)
into tokens))
(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 :external-format :utf-8)
(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
(let ((err-token (find-if (lambda (tok) (find :error tok))
tokens)))
(format t "~5@a ~a~%"
(format nil "~a:" (getf (cdr err-token) :line))
line)
(format t " ~a^~%"
(make-string (getf (cdr err-token) :col)
:initial-element #\Space)))))
(appending tokens))))
has-error)))
(defun lex-string (string &optional report-errors)
(let ((has-error nil))
(values
(let ((str (make-string-input-stream string)))
(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))
(op-type (getf (cdr token) :type)))
(cond ((eq :number op-type)
(vector-push-extend `(push-int ,op) ops))
((eq :string op-type)
(vector-push-extend `(push-str ,(length op) ,i ,op)
ops))
((string= 'ise op)
(push (list 'ise i) stack)
(vector-push-extend (list 'ise nil) ops))
((string= 'yoksa op)
(let ((top (pop stack)))
(assert (string= 'ise (car top)))
(setf (second (aref ops (cadr top))) i)
(push (list 'yoksa i) stack)
(vector-push-extend (list 'yoksa nil i) ops)))
((string= '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))
((string= '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))))))
((string= 'döngü op)
(push (list 'döngü i) stack)
(vector-push-extend (list 'döngü i) ops))
((string= 'iken op)
(let ((top (pop stack)))
(assert (string= '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)))
;;; COMPILER
(defun write-program (program out &key (mem-cap 640000))
(format out "~a~%" "segment .text")
(gen-dump out)
(format out "~{~a~%~}" '("global _start"
"_start:"))
(let ((strs nil))
(iter (for op in-sequence program)
(let ((gen-val (gen-code op out)))
(when (and (consp gen-val) (eq :string (car gen-val)))
(push (cdr gen-val) strs))))
(gen-code '(exit 0) out)
(unless (null strs)
(format out "segment .data~%")
(dolist (str strs)
(format out "str_~a: db ~{0x~x~^,~}~%"
(first str)
(map 'list #'char-code (second str))))))
(format out "~a~%" "segment .bss")
(format out "~a ~a~%" "bel: resb" mem-cap))
(defun generate-program (program &key (path "output.asm") (compile nil)
(mem-cap 640000) (silence nil))
(with-open-file (out path :direction :output
:if-exists :supersede)
(write-program program out :mem-cap mem-cap))
(when compile
(run `("nasm" "-felf64" ,path) :output t :silence silence)
(let ((name (first (uiop:split-string path :separator '(#\.)))))
(run `("ld" "-o" ,name ,(concatenate 'string name ".o"))
:output t :silence silence))))
(defun compile-program (path)
(generate-program (make-program path) :compile t))
|
