From f5cb35b87255ebbe2d322bcedde6bc7d5f6aebae Mon Sep 17 00:00:00 2001
From: Thomas Albers Raviola <thomas@thomaslabs.org>
Date: Mon, 13 May 2024 21:29:31 +0200
Subject: * Initial commit

---
 src/core.lisp    |  76 +++++++++++++++++++++++++++++
 src/eval.lisp    |  44 +++++++++++++++++
 src/package.lisp |  10 ++++
 src/parser.lisp  | 144 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/types.lisp   |  85 ++++++++++++++++++++++++++++++++
 5 files changed, 359 insertions(+)
 create mode 100644 src/core.lisp
 create mode 100644 src/eval.lisp
 create mode 100644 src/package.lisp
 create mode 100644 src/parser.lisp
 create mode 100644 src/types.lisp

(limited to 'src')

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))
-- 
cgit v1.2.3