Initial commit for git.lain.church

cl-forth.asd

@@ -0,0 +1,18 @@
+;;;; cl-forth.asd
+
+(asdf:defsystem cl-forth
+  :description "FORTH interpreter written in Common Lisp"
+  :author ("Bubblegumdrop <staticsunn@gmail.com>")
+  :license  "GPLv3+"
+  :version "0.1.0"
+  :depends-on (:deploy)
+  :components ((:file "package")
+               (:file "utils")
+               (:file "stack")
+               (:file "interpreter")
+               (:file "methods")
+               (:file "cl-forth"))
+  :defsystem-depends-on (:deploy)
+  :build-operation "deploy-op"
+  :build-pathname "cl-forth.run"
+  :entry-point "cl-forth::main")

cl-forth.lisp

@@ -0,0 +1,26 @@
+(in-package #:cl-forth)
+
+;; For debugging purposes.
+(defparameter *interpreter*
+    (make-instance 'interpreter))
+
+(defun main ()
+  (let ((interp *interpreter*)
+        (input ""))
+    (format t "Welcome to CL-Forth! Type your commands below (type 'exit' to quit).~%")
+    (loop
+      (format t "CL-FORTH) ")
+      (finish-output)
+      (setf input (read-line))
+      (if (string= input "exit")
+          (progn
+            (format t "Exiting CL-Forth. Goodbye!~%")
+            (return))
+          (progn
+            (handler-case
+                (interpret interp input)
+              (unknown-word-error (e)
+                (format t "Error: Unknown word '~a'~%" (token-of e)))
+              (stack-underflow (e)
+                (declare (ignore e))
+                (format t "Error: Stack underflow - cannot pop from an empty stack.~%"))))))))

define.lisp

@@ -0,0 +1,60 @@
+(in-package #:cl-forth)
+
+(defun interpret (input)
+  (let ((tokens (split-sequence #\Space input))) ;; Assuming you have a tokenizing function
+    (dolist (token tokens)
+      (cond
+        ((equal token ":")
+         (setf *compile-mode* t))
+
+        ((equal token ";")
+         (setf *compile-mode* nil)
+         ;; Store the definition in the dictionary
+         (setf (gethash (car *current-definition*) *dictionary*)
+               (cdr *current-definition*))
+         (setf *current-definition* nil))
+
+        (*compile-mode*
+         (if (null *current-definition*)
+             ;; First token is the name of the new word
+             (setf *current-definition* (list token))
+             ;; Subsequent tokens are the body of the word
+             (push token (cdr *current-definition*))))
+        (t
+         (execute-word token))))))
+
+(defun execute-word (token)
+  (cond
+    ((digit-char-p (elt token 0))
+     ;; Push numbers onto the stack
+     (push (parse-integer token) *stack*))
+    ((gethash token *dictionary*)
+     ;; If token is in dictionary, execute it
+     (let ((definition (gethash token *dictionary*)))
+       (if (functionp definition)
+           ;; If it's a primitive word, just execute it
+           (funcall definition)
+           ;; If it's a user-defined word, interpret each token in it
+           (dolist (word definition)
+             (execute-word word)))))
+    (t
+     (error "Unknown word: ~A" token))))
+
+;; Please incorporate the above interpret and execute-word with evaluate-token and evaluate-line below:
+(defmethod evaluate-line ((obj interpreter))
+  (let ((tokens (split-string #\Space (line-of obj))))
+    (dolist (token tokens)
+      (setf (current-token-of obj) token)
+      (evaluate-token obj))))
+
+(defmethod evaluate-token ((obj interpreter))
+  (let* ((token (current-token-of obj))
+         (words (words-of (state-of obj)))
+         (dict-entry (gethash token words)))
+    (if dict-entry
+        (funcall dict-entry obj)
+        (let ((parsed (ignore-errors (parse-integer token))))
+          (if parsed
+              (push-to-stack (stack-of obj) parsed)
+              (signal 'unknown-word-error :token token))))))
+

interpreter.lisp

@@ -0,0 +1,81 @@
+(in-package #:cl-forth)
+
+(defparameter *compile-mode* nil)
+(defparameter *current-definition* nil)
+
+(define-condition unknown-word-error (error)
+  ((token :initarg :token
+          :accessor token-of))
+  (:report (lambda (condition stream)
+             (format stream "Unknown word: ~a.~&" (token-of condition)))))
+
+(defclass interpreter ()
+  ((current-token :accessor current-token-of)
+   (stack :initform (make-instance 'stack)
+          :accessor stack-of)
+   (words :initform (make-hash-table :test 'equal)
+          :accessor words-of)
+   (line :accessor line-of)))
+
+(defmethod initialize-instance :after ((interp interpreter) &key &allow-other-keys)
+  "Initialize a new interpreter with basic operations."
+  (setf (gethash "+" (words-of interp)) #'add
+        (gethash "-" (words-of interp)) #'subtract
+        (gethash "*" (words-of interp)) #'multiply
+        (gethash "/" (words-of interp)) #'divide
+        (gethash "mod" (words-of interp)) #'mod
+        (gethash "dup" (words-of interp)) #'dup
+        (gethash "swap" (words-of interp)) #'swap
+        (gethash "negate" (words-of interp)) #'negate
+        (gethash "drop" (words-of interp)) #'drop
+        (gethash "over" (words-of interp)) #'over
+        (gethash "rot" (words-of interp)) #'rot)
+    interp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defmethod evaluate-line ((obj interpreter))
+  (let ((tokens (split-string #\Space (line-of obj))))
+    (dolist (token tokens)
+      (cond
+        ((equal token ":")
+         (setf *compile-mode* t))
+        ((equal token ";")
+         (setf *compile-mode* nil)
+         ;; save the definition
+         (setf (gethash (car *current-definition*) (words-of obj))
+               (reverse (cdr *current-definition*))
+               *current-definition* nil))
+        (*compile-mode*
+         (if (null *current-definition*)
+             ;; First token is the name of the new word
+             (setf *current-definition* (list token))
+             ;; Subsequent tokens are the body of the word
+             (push token (cdr *current-definition*))))
+        (t
+         (setf (current-token-of obj) token)
+         (execute-word obj))))))
+
+(defmethod execute-word ((obj interpreter))
+  (let ((token (current-token-of obj)))
+    (cond
+      ((digit-char-p (elt token 0))
+       ;; Push numbers onto the stack
+       (push-to-stack (stack-of obj) (parse-integer token)))
+      ((gethash token (words-of obj))
+       ;; If token is in dictionary, execute it
+       (let ((definition (gethash token (words-of obj))))
+         (if (functionp definition)
+             ;; If it's a primitive word, just execute it
+             (funcall definition obj)
+             ;; If it's a user-defined word, interpret each token in it
+             (dolist (word definition)
+               (setf (current-token-of obj) word)
+               (execute-word obj)))))
+      (t
+       (error 'unknown-word-error :token token)))))
+
+(defmethod interpret ((obj interpreter) program)
+  "Interpret a PROGRAM using the INTERP."
+  (setf (line-of obj) program)
+  (evaluate-line obj)
+  (format t "Stack after execution: ~a~%" (stack-of obj)))

methods.lisp

@@ -0,0 +1,79 @@
+(in-package #:cl-forth)
+
+(defun with-stack-args (interpreter func)
+  "Pop two values from the stack and apply FUNC to them."
+  (let ((b (pop-from-stack (stack-of interpreter)))
+        (a (pop-from-stack (stack-of interpreter))))
+    (funcall func a b)))
+
+(defun dup (interpreter)
+  "Duplicate the top number on the stack."
+  (let ((top (peek-stack (stack-of interpreter))))
+    (push-to-stack (stack-of interpreter) top)))
+
+(defun swap (interpreter)
+  "Swap the top two numbers on the stack."
+  (let ((a (pop-from-stack (stack-of interpreter)))
+        (b (pop-from-stack (stack-of interpreter))))
+    (push-to-stack (stack-of interpreter) a)
+    (push-to-stack (stack-of interpreter) b)))
+
+(defun add (interpreter)
+  "Add the top two numbers on the stack."
+  (with-stack-args interpreter
+    (lambda (a b)
+      (push-to-stack (stack-of interpreter) (+ a b)))))
+
+(defun subtract (interpreter)
+  "Subtract the top two numbers on the stack."
+  (with-stack-args interpreter
+    (lambda (a b)
+      (push-to-stack (stack-of interpreter) (- a b)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun multiply (interpreter)
+  "Multiply the top two numbers on the stack."
+  (with-stack-args interpreter
+    (lambda (a b)
+      (push-to-stack (stack-of interpreter) (* a b)))))
+
+(defun divide (interpreter)
+  "Divide the second top number by the top number on the stack."
+  (with-stack-args interpreter
+    (lambda (a b)
+      (if (zerop a)
+          (error "Division by zero")
+          (push-to-stack (stack-of interpreter) (/ b a))))))
+
+(defun my-mod (interpreter)
+  "Compute the modulus of the second top number by the top number on the stack."
+  (with-stack-args interpreter
+    (lambda (a b)
+      (if (zerop a)
+          (error "Division by zero")
+          (push-to-stack (stack-of interpreter) (mod b a))))))
+
+(defun negate (interpreter)
+  "Negate the top number on the stack."
+  (let ((top (pop-from-stack (stack-of interpreter))))
+    (push-to-stack (stack-of interpreter) (- top))))
+
+(defun drop (interpreter)
+  "Remove the top number from the stack."
+  (pop-from-stack (stack-of interpreter)))
+
+(defun over (interpreter)
+  "Copy the second top number to the top of the stack."
+  (let ((a (pop-from-stack (stack-of interpreter)))
+        (b (peek-stack (stack-of interpreter))))
+    (push-to-stack (stack-of interpreter) a)
+    (push-to-stack (stack-of interpreter) b)))
+
+(defun rot (interpreter)
+  "Rotate the top three numbers on the stack."
+  (let ((a (pop-from-stack (stack-of interpreter)))
+        (b (pop-from-stack (stack-of interpreter)))
+        (c (pop-from-stack (stack-of interpreter))))
+    (push-to-stack (stack-of interpreter) b)
+    (push-to-stack (stack-of interpreter) a)
+    (push-to-stack (stack-of interpreter) c)))

package.lisp

@@ -0,0 +1,7 @@
+(in-package #:cl-user)
+
+(defpackage #:cl-forth
+  (:use #:cl)
+  (:export #:main))
+
+(in-package #:cl-forth)

readme.org

@@ -0,0 +1,12 @@
+* CL-FORTH
+
+I'm not sure what good another FORTH interpreter is. Why not.
+
+* License
+
+GPLv3+
+
+* TODO
+
+- Saving/Loading an image
+- Colon Definitions (WIP)

stack.lisp

@@ -0,0 +1,44 @@
+(in-package #:cl-forth)
+
+(define-condition stack-error (error)
+  ((message :initarg :message
+            :accessor error-message)))
+
+(define-condition stack-underflow (stack-error)
+  ((message :initarg :message
+            :accessor underflow-message)))
+
+(defclass stack ()
+  ((contents :initform '()
+             :initarg :initial-contents
+             :accessor contents)))
+
+(defmethod initialize-instance :after ((obj stack) &key initial-element &allow-other-keys)
+  (when initial-element
+    (setf (contents obj) (list initial-element))))
+
+(defmethod push-to-stack ((obj stack) value)
+  "Push VALUE onto the stack in the STACK."
+  (push value (contents obj)))
+
+(defmethod pop-from-stack ((obj stack))
+  "Pop a value from the stack in the STACK."
+  (pop (contents obj)))
+
+(defmethod peek-stack ((obj stack))
+  "Peek at the top value of the stack in the STACK."
+  (car (contents obj)))
+
+(defmethod print-object ((obj stack) stream)
+  (print-unreadable-object (obj stream :type t)
+    (format stream "(~{~a~^ ~})" (contents obj))))
+
+;; Example usage:
+(defun stack-test ()
+  (let ((my-stack (make-instance 'stack)))
+    (format t "Empty Stack: ~a~%" my-stack)
+    (push-to-stack my-stack 10)
+    (push-to-stack my-stack 20)
+    (format t "Top element: ~a~%" (peek-stack my-stack))
+    (format t "Popped element: ~a~%" (pop-from-stack my-stack))
+    (format t "Stack after pop: ~a~%" my-stack)))

utils.lisp

@@ -0,0 +1,16 @@
+(in-package #:cl-forth)
+
+(defun split-string (delimiter input-string)
+  "Splits INPUT-STRING into a list of tokens, using DELIMITER as the delimiter."
+  (let ((start 0)
+        (tokens '()))
+    (loop for i from 0 below (length input-string)  ; Keep it below
+          for char = (char input-string i)
+          do (if (eql char delimiter)
+                 (when (> i start)
+                   (push (subseq input-string start i) tokens)
+                   (setf start (1+ i)))))
+    ;; Handle the last token if there is any
+    (when (> (length input-string) start)
+      (push (subseq input-string start (length input-string)) tokens))
+    (nreverse tokens)))