aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorThomas Albers Raviola <thomas@thomaslabs.org>2024-05-13 21:29:31 +0200
committerThomas Albers Raviola <thomas@thomaslabs.org>2024-05-13 21:29:31 +0200
commitf5cb35b87255ebbe2d322bcedde6bc7d5f6aebae (patch)
tree161ec305fb4bef388dee6f50ed1c3ed842d55a2b /src
* Initial commit
Diffstat (limited to 'src')
-rw-r--r--src/core.lisp76
-rw-r--r--src/eval.lisp44
-rw-r--r--src/package.lisp10
-rw-r--r--src/parser.lisp144
-rw-r--r--src/types.lisp85
5 files changed, 359 insertions, 0 deletions
diff --git a/src/core.lisp b/src/core.lisp
new file mode 100644
index 0000000..6c151ce
--- /dev/null
+++ b/src/core.lisp
@@ -0,0 +1,76 @@
+(in-package #:chains)
+
+(defun get-var (env key)
+ (if-let ((slot (assoc key env)))
+ (cdr slot)
+ (error "var ~A not found~% ~A~%" key env)))
+
+;; Built-in functions and variables used inside the interpreter use their own
+;; package. This allows the language to have keywords like lambda which
+;; otherwise would be reserved words from the cl package
+
+(defmacro define-function (name (&rest args) &body body)
+ (let ((siblings (gensym)))
+ `(make-closure #'(lambda (environment ,siblings ,@args)
+ (declare (ignore ,siblings))
+ ,@body)
+ ',args
+ nil
+ (complement #'identity))))
+
+(defmacro define-function* (name (&rest args) (siblings group-predicate)
+ &body body)
+ `(make-closure #'(lambda (environment ,siblings ,@args)
+ ,@body)
+ ',args
+ nil
+ ,group-predicate))
+
+(defmacro define-syntax (name (&rest args) &body body)
+ `(make-closure #'(lambda (environment siblings ,@args)
+ ,@body)
+ ',args
+ t
+ (complement #'identity)))
+
+(defmacro define-syntax* (name (&rest args) (siblings group-predicate)
+ &body body)
+ `(make-closure #'(lambda (environment ,siblings ,@args)
+ ,@body)
+ ',args
+ t
+ ,group-predicate))
+
+(defparameter *lambda*
+ (define-syntax lambda (arglist body)
+ (setf arglist (remove-if #'whitespace-text-p arglist))
+ (assert (every #'object-symbolp arglist))
+ (setf arglist (mapcar #'cdr arglist))
+ (let ((env environment))
+ (make-closure #'(lambda (environment siblings &rest args)
+ (tree-eval (append (pairlis arglist args)
+ env
+ environment)
+ body))
+ arglist nil (complement #'identity) env))))
+
+(defparameter *syntax*
+ (define-syntax syntax (arglist body)
+ (setf arglist (remove-if #'whitespace-text-p arglist))
+ (assert (every #'object-symbolp arglist))
+ (setf arglist (mapcar #'cdr arglist))
+ (let ((env environment))
+ (make-closure #'(lambda (environment siblings &rest args)
+ (tree-eval (append (pairlis arglist args)
+ env
+ environment)
+ body))
+ arglist t (complement #'identity) env))))
+
+(defparameter *define*
+ (define-syntax* define (name value) (siblings #'identity)
+ (assert (object-symbolp (first name)))
+ (setf name (cdr (first name)))
+ (setf value (first (tree-eval environment value)))
+ (tree-eval (acons name value environment)
+ siblings)))
diff --git a/src/eval.lisp b/src/eval.lisp
new file mode 100644
index 0000000..4962ade
--- /dev/null
+++ b/src/eval.lisp
@@ -0,0 +1,44 @@
+(in-package #:chains)
+
+(defun chainp (object)
+ (and (consp object) (eq (first object) 'chain)))
+
+(defun chain-links (chain)
+ (rest chain))
+
+(defun object-symbolp (object)
+ (and (consp object) (eq (first object) 'symbol)))
+
+(defun tree-eval (environment node)
+ (cond ((null node)
+ nil)
+ ((object-symbolp node)
+ (get-var environment (cdr node)))
+ ((not (consp node))
+ node)
+ ((chainp (first node))
+ (destructuring-bind (flink &rest rlinks) (chain-links (first node))
+ (setf flink (tree-eval environment flink))
+ (assert (and (consp flink)
+ (closurep (first flink))
+ (null (rest flink)))
+ (flink)
+ "~A ~A" flink (content (second flink)))
+ (let* ((closure (first flink))
+ (function (closure-function closure))
+ (group-predicate (closure-group-p closure)))
+ (multiple-value-bind (siblings rest)
+ (group-if group-predicate (rest node))
+ (append
+ ;; Evaluating a function returns a sublink, flatten all sublink
+ (flatten
+ (let ((eval-with-environment (curry #'tree-eval environment)))
+ (if (closure-special-p closure)
+ (ensure-list (apply function environment siblings rlinks))
+ (let ((args (mapcar eval-with-environment rlinks))
+ (siblings (funcall eval-with-environment siblings)))
+ (ensure-list (apply function environment siblings args))))))
+ (tree-eval environment rest))))))
+ (t
+ (cons (tree-eval environment (first node))
+ (tree-eval environment (rest node))))))
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..962ce17
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,10 @@
+(defpackage #:chains
+ (:use #:cl
+ #:split-sequence
+ #:alexandria
+ #:trivia)
+ (:export))
+
+(in-package #:chains)
+
+(defvar *interpreter-package* (make-package 'interpreter))
diff --git a/src/parser.lisp b/src/parser.lisp
new file mode 100644
index 0000000..60e7ac4
--- /dev/null
+++ b/src/parser.lisp
@@ -0,0 +1,144 @@
+(in-package #:chains)
+
+(defconstant +special-characters+
+ '(#\\ #\% #\# #\@ #\$ #\{ #\} #\[ #\] #\Newline)
+ "")
+
+(defconstant +whitespace+ '(#\Tab #\Newline #\Return #\Space)
+ "")
+
+;; TODO: (read-char stream nil)
+(defun read-if (predicate stream)
+ "Read characters from STREAM into a string as long as PREDICATE is true"
+ (let ((string (with-output-to-string (value)
+ (loop :for c = (read-char stream nil)
+ :while (and c (funcall predicate c))
+ :do (write-char c value)
+ :finally
+ (when c (unread-char c stream))))))
+ (if (emptyp string) nil string)))
+
+(defun read-if-not (predicate stream)
+ "Read characters from STREAM into a string as long as PREDICATE is false"
+ (read-if (complement predicate) stream))
+
+(defun read-text (stream start-of-line)
+ "Read text from STREAM"
+ (let* ((text (read-if-not #'special-char-p stream))
+ (peek (peek-char nil stream nil)))
+ (when text (setf start-of-line nil))
+ (cond ((and (null text) (null peek))
+ nil)
+ ((and (not start-of-line) (newlinep peek))
+ (read-char stream nil)
+ (let ((rest (read-text stream t)))
+ (when (eq rest 'empty-line)
+ (setf rest nil)
+ (unread-char #\Newline stream))
+ (list* text (string #\Newline) rest)))
+ ((newlinep peek)
+ (read-char stream nil)
+ 'empty-line)
+ (t
+ (ensure-list text)))))
+
+(defun atom-char-p (char)
+ (or (alphanumericp char) (eql char #\-)))
+
+(defun next-token (stream start-of-line &aux c)
+ "Read the next token inside STREAM"
+ (case (setf c (read-char stream nil))
+ ('nil nil)
+ (#\\
+ (concat-text (make-text (string (read-char stream nil)))
+ (make-text (read-if-not #'special-char-p stream))))
+ (#\%
+ (peek-char #\Newline stream)
+ (read-char stream nil)
+ ;;(next-token stream nil)
+ 'separator)
+ ((#\@ #\$)
+ (let* ((text (read-if #'atom-char-p stream))
+ (value (read-from-string text))
+ (type (cond ((symbolp value) 'symbol)
+ ((integerp value) 'integer)
+ (t (error "Unknown type of object @~A~%" text)))))
+ ;; (unless (or (symbolp value) (integerp value))
+ ;; (error "Unknown type of object @~A~%" text))
+ (cons type value)))
+ (#\#
+ (case (read-char stream nil)
+ (#\@ (cons 'raw-function (read-if #'alphanumericp stream)))
+ (#\$ (cons 'inline-raw-function (read-if #'alphanumericp stream)))))
+ (#\{ 'link-start)
+ (#\} 'link-end)
+ (#\[ 'raw-link-start)
+ (#\] 'raw-link-end)
+ (t
+ (unread-char c stream)
+ (let ((text (read-text stream start-of-line)))
+ (cond ((null text) nil)
+ ((symbolp text) text)
+ (t (make-text (apply #'concatenate 'string text))))))))
+
+(defun build-tree (tokens)
+ "Groups a list of tokens into a tree. Returns a subtree and a list of unused
+tokens."
+ (flet ((build-chain (tokens)
+ (loop :with tokens = tokens
+ :for (link rest) = (multiple-value-list (build-tree tokens))
+ :collect link :into links
+ :while (member (first rest) '(raw-link-start link-start))
+ :do (setf tokens (rest rest))
+ :finally
+ (setf tokens rest)
+ (return (values links tokens)))))
+ (destructuring-bind (&optional head &rest tail) tokens
+ (cond ((null head)
+ (values nil '()))
+ ((or (eq head 'link-end) (eq head 'raw-link-end))
+ (values '() (rest tokens)))
+ ((eq head 'separator)
+ (multiple-value-bind (tree rest) (build-tree tail)
+ (values tree rest)))
+ ((eq head 'link-start)
+ (multiple-value-bind (links rest) (build-chain tail)
+ (multiple-value-bind (tree rest) (build-tree rest)
+ (values (cons (cons 'chain links) tree) rest))))
+ (t
+ (multiple-value-bind (tree rest) (build-tree tail)
+ (values (cons head tree) rest)))))))
+
+(defun read-raw-link (stream)
+ "Read argument of a raw function"
+ (flet ((squarep (x) (member x '(#\]))))
+ ;; Text omits closing ], may therefore be nil, for example when reading ]]
+ (loop :for text = (read-if-not #'squarep stream)
+ :for c = (peek-char nil stream nil)
+ :when text :collect text :into text-list
+ :while (and c text (eql (last-elt text) #\\))
+ :collect (string (read-char stream nil)) :into text-list
+ :finally
+ ;; Keep ] inside stream
+ (return (list (make-text (apply #'concat text-list)))))))
+
+(defun start-of-line-p (last-token)
+ ;; Keep track if new line starts a paragraph
+ (or (eq last-token 'empty-line)
+ (and (textp last-token)
+ (newlinep (last-elt (content last-token))))))
+
+(defun read-tree (stream)
+ "Build a syntax tree from the contents of STREAM"
+ (loop :with start-of-line = t
+ :for token = (next-token stream start-of-line)
+ :while token
+ :if (eq token 'raw-link-start)
+ :append (cons 'raw-link-start (read-raw-link stream)) :into tokens
+ :and :do
+ (setf start-of-line nil)
+ :else
+ :collect token :into tokens :and :do
+ (setf start-of-line (start-of-line-p token))
+ :finally ;; (build-tree)
+ (return tokens)))
diff --git a/src/types.lisp b/src/types.lisp
new file mode 100644
index 0000000..09ede2b
--- /dev/null
+++ b/src/types.lisp
@@ -0,0 +1,85 @@
+(in-package #:chains)
+
+(defclass text ()
+ ((content :reader content
+ :initarg :content
+ :type string
+ :documentation "")))
+
+(defun textp (object)
+ (typep object 'text))
+
+(defun make-text (content)
+ (make-instance 'text :content content))
+
+(defun concat-text (&rest text)
+ (let ((strings (mapcar #'content text)))
+ (make-text (apply #'concatenate 'string strings))))
+
+(defmethod content ((object (eql 'empty-line)))
+ (list (make-text "")))
+
+(defclass closure ()
+ ((function :reader closure-function
+ :initarg :function
+ :type function
+ :documentation "")
+ (arg-list :reader closure-arg-list
+ :initarg :arg-list
+ :type list
+ :documentation "")
+ (environment :reader closure-environment
+ :initarg :environment
+ :type list
+ :documentation "")
+ (specialp :reader closure-special-p
+ :initarg :specialp
+ :type boolean
+ :documentation "")
+ (groupp :reader closure-group-p
+ :initarg :groupp
+ :type function
+ :documentation "")))
+
+(defun make-closure (function arg-list specialp groupp &optional environment)
+ (make-instance 'closure :function function :arg-list arg-list
+ :specialp specialp :groupp groupp
+ :environment environment))
+
+(defun closurep (object)
+ (typep object 'closure))
+
+(defun group (item sequence &key (test #'eql))
+ (group-if #'(lambda (x) (funcall test item x)) sequence))
+
+(defun group-if (predicate sequence)
+ (loop :for (head . tail) :on sequence
+ :while (funcall predicate head)
+ :collect head :into group
+ :finally
+ (return (values group (if (not (funcall predicate head))
+ (cons head tail)
+ tail)))))
+
+(defun group-if-not (predicate sequence)
+ (group-if (complement predicate) sequence))
+
+(defun whitespacep (char-or-string)
+ (if (stringp char-or-string)
+ (every #'whitespacep char-or-string)
+ (member char-or-string +whitespace+)))
+
+(defun whitespace-text-p (object)
+ (and (textp object) (whitespacep (content object))))
+
+(defun special-char-p (x)
+ (member x +special-characters+))
+
+(defun empty-line-p (x)
+ (or (emptyp x) (every #'whitespacep x)))
+
+(defun newlinep (x)
+ (eql x #\Newline))
+
+(defun concat (&rest strings)
+ (apply #'concatenate 'string strings))