basic error reporting to character and string literals

cl-forth.lisp

@@ -14,12 +14,20 @@
   (car token))
 
 ;;; LEXER
-(defun read-string (stream)
+(defun read-string (stream line-num line col)
-  ;; TODO: Handle unmatched " and give proper error message
+  "This function is called when a #\" (double quote) is read from the STREAM."
+  (let ((i 0))
+    (values
      (with-output-to-string (str)
-    (iter (for ch = (read-char stream))
+       (iter (for ch = (read-char stream nil 'eof))
-          (cond ((char= ch #\")
+             (cond ((eq 'eof ch)
-                 (finish))
+                    (error (cond-string-not-closed
+                            line-num line col
+                            (get-output-stream-string str))))
+                   ((char= ch #\")
+                    (if (> i 0)
+                        (finish)
+                        (error (cond-empty-string line-num line col))))
                    ((char= ch #\\)
                     (case (peek-char nil stream)
                       (#\n (write-char #\Newline str))
@@ -27,19 +35,30 @@
                       (#\\ (write-char #\\ str))
                       (#\" (write-char #\" str)))
                     (read-char stream))
-                (t (write-char ch str))))))
+                   (t (write-char ch str)))
+             (incf i)))
+     i)))
 
 (defun read-character (stream line-num line col)
-  (let ((ch? (read-char stream)))
+  "This function is called when a #\' (single quote) is read from the STREAM."
-    (if (not (char-equal ch? #\\))
+  (let ((ch? (read-char stream nil 'eof)))
-        (if (char-equal #\' (peek-char nil stream))
+    (cond ((eq 'eof ch?)
-            (progn (read-char stream) ch?)
+           (error (cond-char-not-closed line-num line col 'yok)))
-            (error (handle-char-not-closed line-num line col)))
+          ((char-equal ch? #\\)
-        (progn (case (read-char stream)
+           (let ((escaped-ch (read-char stream nil 'eof)))
-                 (#\n (setf ch? #\Newline)))
+             (case escaped-ch
-               (if (char-equal #\' (peek-char nil stream))
+               (eof (error (cond-char-not-closed line-num line col 'yok)))
-                   (progn (read-char stream) ch?)
+               (#\n (setf ch? #\Newline))
-                   (error (handle-char-not-closed line-num line col)))))))
+               (#\0 (setf ch? (code-char 0)))
+               (otherwise (setf ch? escaped-ch)))))
+          ((char-equal ch? #\')
+           (error (cond-empty-char line-num line col)))
+          (t nil))
+    (let ((closing-ch (read-char stream nil 'eof)))
+      (if (or (eq 'eof closing-ch)
+              (not (char-equal #\' closing-ch)))
+          (error (cond-char-not-closed line-num line col ch?))
+          ch?))))
 
 (defun lex-line (line &optional (line-num 0))
   (let ((*package* (find-package "KEYWORD")))
@@ -61,7 +80,8 @@
                    (finish))
                   ((char= #\" next-char)
                    (read-char line-stream)
-                   (collect (make-token (read-string line-stream)
+                   (collect (make-token (read-string
+                                         line-stream line-num line col)
                                         line-num col :string)
                      into tokens))
                   ((char= #\' next-char)

errors.lisp

@@ -8,16 +8,60 @@
         (write-char #\Space stream))
   (format stream "^~%"))
 
-(define-condition char-not-closed ()
+(defun char-num-pair (ch?)
+  (if (characterp ch?)
+      (list ch? (char-code ch?))
+      ch?))
+
+(define-condition char-error ()
   ((line :initarg :line :reader line)
    (col :initarg :col :reader col)
-   (line-num :initarg :line-num :reader line-num))
+   (line-num :initarg :line-num :reader line-num)
+   (ch :initarg :ch :reader ch :initform 'yok)))
+
+(define-condition char-not-closed (char-error) ()
   (:report (lambda (condition stream)
-             (format stream "Karakterin kapanış sembolü ' eksik.~%")
+             (format stream "Karakterin kapanış sembolü ' (tek tırnak) eksik.~%Okunan karakter: ~s~%" (char-num-pair (ch condition)))
              (report-line (line-num condition) (line condition) (col condition) stream))))
 
-(defun handle-char-not-closed (line-num line token-or-col)
+(define-condition empty-char (char-error) ()
-  (make-condition 'char-not-closed :line-num line-num :line line :col token-or-col))
+  (:report (lambda (condition stream)
+             (format stream "Boş karakter oluşturulamaz.~%")
+             (report-line (line-num condition) (line condition) (col condition) stream))))
+
+(defun cond-char-not-closed (line-num line token-or-col ch)
+  (make-condition 'char-not-closed :line-num line-num :line line :col token-or-col :ch ch))
+
+(defun cond-empty-char (line-num line token-or-col)
+  (make-condition 'empty-char :line-num line-num :line line :col token-or-col))
+
+
+
+(define-condition string-error ()
+  ((line :initarg :line :reader line)
+   (col :initarg :col :reader col)
+   (line-num :initarg :line-num :reader line-num)
+   (content :initarg :content :reader content :initform 'yok)))
+
+(define-condition string-not-closed (string-error) ()
+  (:report (lambda (condition stream)
+             (format stream "Metnin kapanış sembolü \" (çift tırnak) eksik.~%Okunan metin: ~s~%"
+                     (list (content condition) (length (content condition))))
+             (report-line (line-num condition) (line condition) (col condition) stream))))
+
+(defun cond-string-not-closed (line-num line token-or-col &optional (content 'yok))
+  (make-condition 'string-not-closed :line-num line-num :line line
+                                     :col token-or-col :content content))
+
+(define-condition empty-string (string-error) ()
+  (:report (lambda (condition stream)
+             (format stream "Boş metin oluşturulamaz.~%")
+             (report-line (line-num condition) (line condition) (col condition) stream))))
+
+(defun cond-empty-string (line-num line token-or-col)
+  (make-condition 'empty-string :line-num line-num :line line :col token-or-col))
+
+
 
 ;; (define-condition op-not-implemented (style-warning)
 ;;   ((undef-ops :initarg :ops :reader undef-ops))