simyager/kurt
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve lex error reporting, removed old interpreter comments

Browse Source
This commit is contained in:
mRnea
2024-08-03 19:29:57 +03:00
parent 57204470df
commit 724519dad1
1 changed files with 16 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files

92
cl-forth.lisp
View File

@@ -53,10 +53,12 @@
(when has-err (when has-err
(setf has-error t) (setf has-error t)
(when report-errors (when report-errors
(format t "~a~%" line)
(let ((err-token (find-if (lambda (tok) (find :error tok)) (let ((err-token (find-if (lambda (tok) (find :error tok))
tokens))) tokens)))
(format t "~a^~%" (format t "~5@a ~a~%"
(format nil "~a:" (getf (cdr err-token) :line))
line)
(format t " ~a^~%"
(make-string (getf (cdr err-token) :col) (make-string (getf (cdr err-token) :col)
:initial-element #\Space))))) :initial-element #\Space)))))
(appending tokens)))) (appending tokens))))
@@ -133,90 +135,24 @@
(error "Can't generate program due to error during lexing")) (error "Can't generate program due to error during lexing"))
(parse-tokens tokens))) (parse-tokens tokens)))
;;; INTERPRETER
;; (eval-always
;; (define-condition op-not-implemented (style-warning)
;; ((undef-ops :initarg :ops :reader undef-ops))
;; (:report (lambda (condition stream)
;; (format stream "These ops are not defined in op-case: ~s"
;; (undef-ops condition)))))
;; (defun identifier-coverage (defined-ops)
;; (let ((undef-ops (set-difference *identifiers* defined-ops)))
;; (unless (null undef-ops)
;; (warn (make-condition 'op-not-implemented :ops undef-ops))))))
;; (defmacro op-case (case-form &body body)
;; (iter (for (op-id) in body)
;; (when (not (is-identifier op-id))
;; (error "op-case: ~a is not an identifier" op-id))
;; (collect op-id into defined-ops)
;; (finally (identifier-coverage defined-ops)))
;; (let ((case-sym (gensym)))
;; `(let ((,case-sym ,case-form))
;; (case ,case-sym
;; ,@body
;; (otherwise (if (is-identifier (first ,case-sym))
;; (error "op: ~a -- Not implemented yet"
;; (first ,case-sym))
;; (error "op: ~a -- Does not exist"
;; (first ,case-sym))))))))
;; (defun interpret-program (program)
;; (iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
;; ;; (for op in-sequence program)
;; (for i from 0 below (length program))
;; (let ((op (aref program i)))
;; (op-case (first op)
;; (push (vector-push-extend (second op) stack))
;; (+ (vector-push-extend (+ (vector-pop stack)
;; (vector-pop stack))
;; stack))
;; (- (vector-push-extend (let ((top (vector-pop stack)))
;; (- (vector-pop stack) top))
;; stack))
;; (dump (print (vector-pop stack)))
;; (= (vector-push-extend (if (= (vector-pop stack)
;; (vector-pop stack))
;; 1 0)
;; stack))
;; (yap (next-iteration))
;; (yoksa (setf i (second op)))
;; (ise (if (= (vector-pop stack) 1)
;; nil
;; (setf i (second op))))
;; (eş (let ((top (vector-pop stack)))
;; (vector-push-extend top stack)
;; (vector-push-extend top stack)))
;; (değiş (let* ((fst (vector-pop stack))
;; (snd (vector-pop stack)))
;; (vector-push-extend fst stack)
;; (vector-push-extend snd stack)))
;; (düş (vector-pop stack))
;; (üst (let* ((fst (vector-pop stack))
;; (snd (vector-pop stack)))
;; (vector-push-extend snd stack)
;; (vector-push-extend fst stack)
;; (vector-push-extend snd stack)))
;; (rot (let* ((fst (vector-pop stack))
;; (snd (vector-pop stack))
;; (trd (vector-pop stack)))
;; (vector-push-extend snd stack)
;; (vector-push-extend fst stack)
;; (vector-push-extend trd stack)))))))
;;; COMPILER ;;; COMPILER
(defun write-program (program out &key (mem-cap 640000)) (defun write-program (program out &key (mem-cap 640000))
(format out "~a~%" "segment .text") (format out "~a~%" "segment .text")
(gen-dump out) (gen-dump out)
(format out "~{~a~%~}" '("global _start" (format out "~{~a~%~}" '("global _start"
"_start:")) "_start:"))
(let ((strs nil))
(iter (for op in-sequence program) (iter (for op in-sequence program)
(gen-header op out) (let ((gen-val (gen-code op out)))
(gen-code op out)) (when (and (consp gen-val) (eq :string (car gen-val)))
(gen-header '(exit 0) out) (push (cdr gen-val) strs))))
(gen-code '(exit 0) out) (gen-code '(exit 0) out)
(unless (null strs)
(format out "segment .data~%")
(dolist (str strs)
(format out "str_~a: db ~{0x~x~^,~}~%"
(first str)
(map 'list #'char-code (second str))))))
(format out "~a~%" "segment .bss") (format out "~a~%" "segment .bss")
(format out "~a ~a~%" "bel: resb" mem-cap)) (format out "~a ~a~%" "bel: resb" mem-cap))