diff options
| -rw-r--r-- | assembly.lisp | 4 | ||||
| -rw-r--r-- | cl-forth.lisp | 268 | ||||
| -rw-r--r-- | test/tests.lisp | 7 |
3 files changed, 148 insertions, 131 deletions
diff --git a/assembly.lisp b/assembly.lisp index fe07654..fc5f58a 100644 --- a/assembly.lisp +++ b/assembly.lisp @@ -1,8 +1,8 @@ (in-package :cl-forth) (defparameter *psuedo-identifiers* - '(syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6) - "These do not map to operations directly, but are valid to lexer") + '(syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6 makro son) + "These do not map to operations that generate code directly, but are valid to lexer and parser") (defparameter *identifiers* ()) ;; '(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < > diff --git a/cl-forth.lisp b/cl-forth.lisp index 88019ce..210b0ef 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -6,11 +6,8 @@ (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)) + (t :unknown)))) + (list sym? :line line :col col :type type)) (defun token-op (token) (car token)) @@ -35,133 +32,160 @@ (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))) + (cond ((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)) - (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))) + (collect (make-token next-sym line-num col) into tokens) + (incf col (length (princ-to-string next-sym))) + (finally (return tokens))))) + +(defun lex-stream (str) + (iter (for line = (read-line str nil nil)) + (until (null line)) + (for line-num from 1) + (appending (lex-line line line-num)))) + +(defun lex-file (file-name) + (with-open-file (str file-name :external-format :utf-8) + (lex-stream str))) + +(defun lex-string (string) + (lex-stream (make-string-input-stream string))) + + ;;; PARSER +(defmacro add-op (token parser) + `(progn (vector-push-extend ,token (ops ,parser)) + (incf (index ,parser)))) + +(defparameter *makro-defs* (make-hash-table)) + +(defclass parser () + ((if-stack :initform () + :accessor if-stack) + (ops :accessor ops) + (tokens :initarg :tokens + :accessor tokens) + (index :initform 0 + :accessor index))) + +(defun make-parser (tokens) + (let ((parser (make-instance 'parser :tokens tokens))) + (setf (ops parser) (make-array (length tokens) :fill-pointer 0 + :adjustable t)) + parser)) + +(defmethod peek-token ((parser parser)) + (car (tokens parser))) + +(defmethod read-token ((parser parser)) + (pop (tokens parser))) + +(defmethod parse-token ((parser parser) (type (eql :number))) + (add-op `(:push-int ,(car (read-token parser))) parser)) + +(defmethod parse-token ((parser parser) (type (eql :string))) + (let ((token (read-token parser))) + (add-op `(:push-str ,(length (car token)) + ,(index parser) + ,(car token)) + parser))) + +(defmethod parse-token ((parser parser) (type (eql :identifier))) + (let ((token (read-token parser))) + (parse-op parser token (car token)))) + +(defmethod parse-token ((parser parser) (type (eql :unknown))) + (let* ((token (read-token parser)) + (makrodef (gethash (car token) *makro-defs*))) + (if (not (null makrodef)) + ;; (parser-parse-tokens parser makrodef) + (setf (tokens parser) (append makrodef (tokens parser))) + (error "parse-token: token has unknown identifier: ~a" + (read-token parser))))) + +;; (defmethod parser-parse-tokens ((parser parser) tokens) +;; (iter (for makro-op in-vector) +;; (add-op makro-op ops)) +;; ()) + +(defmethod parse-op ((parser parser) token (type (eql :ise))) + (push (list :ise (index parser)) (if-stack parser)) + (add-op (list :ise nil) parser)) + +(defmethod parse-op ((parser parser) token (type (eql :yoksa))) + (let ((top (pop (if-stack parser)))) + (assert (and (string= :ise (car top)) + (string= :ise (car (aref (ops parser) (cadr top)))))) + (setf (second (aref (ops parser) (cadr top))) (index parser)) + (push (list :yoksa (index parser)) (if-stack parser)) + (add-op (list :yoksa nil (index parser)) parser))) + +(defmethod parse-op ((parser parser) token (type (eql :yap))) + (let ((top (pop (if-stack parser)))) + (unless (and (find (car top) (list :yoksa :ise :iken)) + (find (car (aref (ops parser) (cadr top))) + (list :yoksa :ise :iken))) + (error "yap cannot close ~a" (aref (ops parser) (cadr top)))) + (cond ((find (car top) (list :yoksa :ise)) + (setf (second (aref (ops parser) (cadr top))) (index parser)) + (add-op (list :yap (index parser)) parser)) + ((string= :iken (car top)) + (setf (second (aref (ops parser) (cadr top))) (index parser)) + (add-op (list :yap (index parser) (third top)) parser)) + (t (error "yap cannot reference: ~a" (car top)))))) + +(defmethod parse-op ((parser parser) token (type (eql :döngü))) + (push (list :döngü (index parser)) (if-stack parser)) + (add-op (list :döngü (index parser)) parser)) + +(defmethod parse-op ((parser parser) token (type (eql :iken))) + (let ((top (pop (if-stack parser)))) + (assert (string= :döngü (car top))) + (push (list :iken (index parser) (cadr top)) (if-stack parser)) + (add-op (list :iken nil) parser))) + +(defmethod parse-op ((parser parser) token (type (eql :makro))) + ;; makro name must be undefined before + (let ((makro-name-tok (read-token parser))) + (assert (eq :unknown (getf (cdr makro-name-tok) :type))) + (setf (gethash (car makro-name-tok) *makro-defs*) + (do ((tok (read-token parser) + (read-token parser)) + (makrodef ())) + ((eq :son (car tok)) (reverse makrodef)) + (push tok makrodef))))) + +(defmethod parse-op ((parser parser) token type) + (cond ((search "syscall" (string-downcase (string (car token)))) + (let ((syscall-num (parse-integer (subseq (string (car token)) 8)))) + (add-op (list :syscall syscall-num) parser))) + (t (add-op (list type) 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)))) + (let ((parser (make-parser tokens))) + (iter (while (not (null (tokens parser)))) + (parse-token parser (getf (cdr (peek-token parser)) :type))) + (ops parser))) (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))) + (parse-tokens (lex-file file-name))) ;;; COMPILER ;;(defgeneric write-program (target program stream)) diff --git a/test/tests.lisp b/test/tests.lisp index e51aad2..8b00817 100644 --- a/test/tests.lisp +++ b/test/tests.lisp @@ -16,13 +16,6 @@ (:string new-file) (:file (pathname new-file))))) -(defun lex-stream (str) - (iter outer - (for line = (read-line str nil nil)) - (until (null line)) - (for line-num from 1) - (appending (lex-line line line-num)))) - (defun read-form-comment (str) (read-from-string (format nil "~{~a~^~%~}" |