added macros, temporarily removed some error checks

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))))))
+          (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)))
 
-(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
+(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))