diff options
Diffstat (limited to 'cl-forth.lisp')
| -rw-r--r-- | cl-forth.lisp | 115 |
1 files changed, 58 insertions, 57 deletions
diff --git a/cl-forth.lisp b/cl-forth.lisp index 1026253..ec7927f 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -28,40 +28,41 @@ (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))))) + (let ((*package* (find-package "KEYWORD"))) + (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 :pipe 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)) @@ -119,39 +120,39 @@ (let ((op (token-op token)) (op-type (getf (cdr token) :type))) (cond ((eq :number op-type) - (vector-push-extend `(push-int ,op) ops)) + (vector-push-extend `(:push-int ,op) ops)) ((eq :string op-type) - (vector-push-extend `(push-str ,(length op) ,i ,op) + (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) + ((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))) + (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) + (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)) + (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)) + (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)) + (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) + ((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))) + (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))) + (vector-push-extend (list :syscall syscall-num) ops))) (t (vector-push-extend (list op) ops)))) (finally (return ops)))) @@ -173,7 +174,7 @@ (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) + (gen-code '(:exit 0) out) (unless (null strs) (format out "segment .data~%") (dolist (str strs) |