From dbfa435e63abffac651890a198a5e5982d826a0b Mon Sep 17 00:00:00 2001
From: mRnea <akannemre@gmail.com>
Date: Fri, 16 Aug 2024 19:09:26 +0300
Subject: Added support for cl identifier pipe
---
cl-forth.lisp | 49 ++++++++++++++++++++++++++++++-------------------
1 file 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)))))
--
cgit v1.2.3