blob: 565e1f5ca2aef6d65c447727b763c958adfc2267 (
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
|
(in-package :cl-forth)
(defparameter *identifiers* '(+ - |.| =))
(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))
(defun lex-line (line-stream line-num)
(iter (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 (make-string-input-stream 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)))
;; (defun prog-from-tokens (tokens)
;; (iter (for token in tokens)
;; (let ((op (token-op token)))
;; (cond ((numberp op)
;; (collect `(push ,op) result-type 'vector))
;; (t (collect (list op) result-type 'vector))))))
(defun parse-tokens (tokens)
(iter (with ops = (make-array (length tokens) :fill-pointer 0
:adjustable t))
(for i from 0)
(for token in tokens)
(let ((op (token-op token)))
(cond ((numberp op)
(vector-push-extend `(push ,op) 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)))
;; (defun *ops* '(push pop minus dump))
(defun interpret-program (program)
(iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
(for op in-sequence program)
(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 (= (vector-pop stack)
(vector-pop stack))
stack))
(otherwise (error "op: ~a -- Not implemented yet" (first op))))))
(defun gen-header (op str)
(format str " ;; -- ~s --~%" op))
;; (defun not-implemented (str)
;; (format str " ;; -- TODO: not implemented --~%"))
(defun generate-program (program &key (path "output.asm") (compile nil))
(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)
(let ((op-fn (gethash (car op) *operations*)))
(if (null op-fn)
(format t "~s is not an op" (car op))
(apply op-fn out (cdr op)))))
(format out "~{~a~%~}" '(" mov rax, 60"
" mov rdi, 0"
" syscall")))
(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))
|
