diff options
| -rw-r--r-- | cl-forth.lisp | 96 |
1 files changed, 16 insertions, 80 deletions
diff --git a/cl-forth.lisp b/cl-forth.lisp index adacdd1..7cee812 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -53,10 +53,12 @@ (when has-err (setf has-error t) (when report-errors - (format t "~a~%" line) (let ((err-token (find-if (lambda (tok) (find :error tok)) 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) :initial-element #\Space))))) (appending tokens)))) @@ -133,90 +135,24 @@ (error "Can't generate program due to error during lexing")) (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 (defun write-program (program out &key (mem-cap 640000)) (format out "~a~%" "segment .text") (gen-dump out) (format out "~{~a~%~}" '("global _start" "_start:")) - (iter (for op in-sequence program) - (gen-header op out) - (gen-code op out)) - (gen-header '(exit 0) out) - (gen-code '(exit 0) out) + (let ((strs nil)) + (iter (for op in-sequence program) + (let ((gen-val (gen-code op out))) + (when (and (consp gen-val) (eq :string (car gen-val))) + (push (cdr gen-val) strs)))) + (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 ~a~%" "bel: resb" mem-cap)) |