diff options
| -rw-r--r-- | cl-forth.lisp | 70 | ||||
| -rw-r--r-- | errors.lisp | 54 |
2 files changed, 94 insertions, 30 deletions
diff --git a/cl-forth.lisp b/cl-forth.lisp index b0bcdbd..5b50f2a 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -14,32 +14,51 @@ (car token)) ;;; LEXER -(defun read-string (stream) - ;; TODO: Handle unmatched " and give proper error message - (with-output-to-string (str) - (iter (for ch = (read-char stream)) - (cond ((char= ch #\") - (finish)) - ((char= ch #\\) - (case (peek-char nil stream) - (#\n (write-char #\Newline str)) - (#\0 (write-char (code-char 0) str)) - (#\\ (write-char #\\ str)) - (#\" (write-char #\" str))) - (read-char stream)) - (t (write-char ch str)))))) +(defun read-string (stream line-num line col) + "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 nil 'eof)) + (cond ((eq 'eof ch) + (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)) + (#\0 (write-char (code-char 0) str)) + (#\\ (write-char #\\ str)) + (#\" (write-char #\" str))) + (read-char stream)) + (t (write-char ch str))) + (incf i))) + i))) (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 (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 (handle-char-not-closed line-num line col))))))) + "This function is called when a #\' (single quote) is read from the STREAM." + (let ((ch? (read-char stream nil 'eof))) + (cond ((eq 'eof ch?) + (error (cond-char-not-closed line-num line col 'yok))) + ((char-equal ch? #\\) + (let ((escaped-ch (read-char stream nil 'eof))) + (case escaped-ch + (eof (error (cond-char-not-closed line-num line col 'yok))) + (#\n (setf ch? #\Newline)) + (#\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) diff --git a/errors.lisp b/errors.lisp index 2f955ca..efff1d5 100644 --- a/errors.lisp +++ b/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ü ' (tek tırnak) eksik.~%Okunan karakter: ~s~%" (char-num-pair (ch condition))) + (report-line (line-num condition) (line condition) (col condition) stream)))) + +(define-condition empty-char (char-error) () (:report (lambda (condition stream) - (format stream "Karakterin kapanış sembolü ' eksik.~%") + (format stream "Boş karakter oluşturulamaz.~%") (report-line (line-num condition) (line condition) (col condition) stream)))) -(defun handle-char-not-closed (line-num line token-or-col) - (make-condition 'char-not-closed :line-num line-num :line line :col token-or-col)) +(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)) |