Added support for cl identifier pipe

1 files changed, 30 insertions, 19 deletions

diff --git a/cl-forth.lisp b/cl-forth.lisp
index ab3af1a..f816e33 100644
--- a/cl-forth.lisp
+++ b/cl-forth.lisp
@@ -25,17 +25,17 @@
                  (write-char #\Newline str))
                 (t (write-char ch str))))))
 
-(defun read-character (stream)
+(defun read-character (stream line-num line col)
   (let ((ch? (read-char stream)))
     (if (not (char-equal ch? #\\))
         (if (char-equal #\' (peek-char nil stream))
             (progn (read-char stream) ch?)
-            (error "Unterminated char."))
+            (error (handle-char-not-closed line-num line col)))
         (progn (case (read-char stream)
                  (#\n (setf ch? #\Newline)))
                (if (char-equal #\' (peek-char nil stream))
                    (progn (read-char stream) ch?)
-                   (error "Unterminated char."))))))
+                   (error (handle-char-not-closed line-num line col)))))))
 
 (defun lex-line (line &optional (line-num 0))
   (let ((*package* (find-package "KEYWORD")))
@@ -46,8 +46,12 @@
           (let ((flag t))
             (cond ((char= #\|  next-char)
                    (read-char line-stream)
-                   (collect (make-token :pipe line-num col :identifier)
-                     into tokens))
+                   (if (char-equal #\Space
+                                   (peek-char nil line-stream nil nil))
+                       (collect (make-token :pipe line-num col :identifier)
+                         into tokens)
+                       (progn (unread-char #\| line-stream)
+                              (setf flag nil))))
                   ((char= #\Space next-char) (read-char line-stream))
                   ((char= #\; next-char) ;; and not in string
                    (finish))
@@ -58,7 +62,8 @@
                      into tokens))
                   ((char= #\' next-char)
                    (read-char line-stream)
-                   (collect (make-token (read-character line-stream)
+                   (collect (make-token (read-character
+                                         line-stream line-num line col)
                                         line-num col :char)
                      into tokens))
                   (t (setf flag nil)))
@@ -114,6 +119,18 @@
 (defmethod read-token ((parser parser))
   (pop (tokens parser)))
 
+
+(defgeneric parse-token (parser type)
+  (:documentation "Parses the next token from TOKENS of parser depending on the TYPE."))
+
+(defgeneric parse-op (parser token identifier)
+  (:documentation "When the TYPE of token is :IDENTIFIER, PARSE-TOKEN parses depending on the identifier of the token.")
+  (:method ((parser parser) token id) ;; default parsing
+    (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 id) parser)))))
+
 (defmethod parse-token ((parser parser) (type (eql :number)))
   (add-op `(:push-int ,(car (read-token parser))) parser))
 
@@ -145,11 +162,11 @@
 ;;             (add-op makro-op ops))
 ;;   ())
 
-(defmethod parse-op ((parser parser) token (type (eql :ise)))
+(defmethod parse-op ((parser parser) token (id (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)))
+(defmethod parse-op ((parser parser) token (id (eql :yoksa)))
   (let ((top (pop (if-stack parser))))
     (assert (and (string= :ise (car top))
                  (string= :ise (car (aref (ops parser) (cadr top))))))
@@ -157,7 +174,7 @@
     (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)))
+(defmethod parse-op ((parser parser) token (id (eql :yap)))
   (let ((top (pop (if-stack parser))))
     (unless (and (find (car top) (list :yoksa :ise :iken))
                  (find (car (aref (ops parser) (cadr top)))
@@ -171,17 +188,17 @@
            (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ü)))
+(defmethod parse-op ((parser parser) token (id (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)))
+(defmethod parse-op ((parser parser) token (id (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)))
+(defmethod parse-op ((parser parser) token (id (eql :makro)))
   ;; makro name must be undefined before
   (let ((makro-name-tok (read-token parser)))
     (assert (eq :unknown (getf (cdr makro-name-tok) :type)))
@@ -197,13 +214,7 @@
               ((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))))
-
-(defmethod parse-op ((parser parser) token (type (eql :kütüphane)))
+(defmethod parse-op ((parser parser) token (id (eql :kütüphane)))
   (let ((file (car (read-token parser))))
     (setf (tokens parser) (append (lex-file file) (tokens parser)))))