From d917f41beca176b8f2b682ac3a2c25b148752b71 Mon Sep 17 00:00:00 2001
From: Thomas Albers Raviola <thomas@thomaslabs.org>
Date: Wed, 15 May 2024 16:21:29 +0200
Subject: Add syntax form for writing macros

* src/core.lisp (syntax): Change evaluation rules to replace arguments inside
macro expansion.
* src/eval.lisp (tree-eval): Add Evaluation route for chains with a syntax
closure.
* t/test4.chn: New file.
---
 src/core.lisp  | 32 ++++++++++++++++++++++----------
 src/eval.lisp  | 21 +++++++++++++++------
 src/types.lisp |  9 +++++++--
 3 files changed, 44 insertions(+), 18 deletions(-)

(limited to 'src')

diff --git a/src/core.lisp b/src/core.lisp
index 6c151ce..d3c396b 100644
--- a/src/core.lisp
+++ b/src/core.lisp
@@ -16,7 +16,9 @@
                        ,@body)
                    ',args
                    nil
-                   (complement #'identity))))
+                   (complement #'identity)
+                   nil
+                   :function)))
 
 (defmacro define-function* (name (&rest args) (siblings group-predicate)
                             &body body)
@@ -24,14 +26,18 @@
                      ,@body)
                  ',args
                  nil
-                 ,group-predicate))
+                 ,group-predicate
+                 nil
+                 :function))
 
 (defmacro define-syntax (name (&rest args) &body body)
   `(make-closure #'(lambda (environment siblings ,@args)
                      ,@body)
                  ',args
                  t
-                 (complement #'identity)))
+                 (complement #'identity)
+                 nil
+                 :special))
 
 (defmacro define-syntax* (name (&rest args) (siblings group-predicate)
                           &body body)
@@ -39,7 +45,9 @@
                      ,@body)
                  ',args
                  t
-                 ,group-predicate))
+                 ,group-predicate
+                 nil
+                 :special))
 
 (defparameter *lambda*
   (define-syntax lambda (arglist body)
@@ -52,8 +60,9 @@
                                             env
                                             environment)
                                     body))
-                     arglist nil (complement #'identity) env))))
+                     arglist nil (complement #'identity) env :function))))
 
+;; Is this basically quasiquote?
 (defparameter *syntax*
   (define-syntax syntax (arglist body)
     (setf arglist (remove-if #'whitespace-text-p arglist))
@@ -61,11 +70,14 @@
     (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))))
+                         (mapc #'(lambda (pair)
+                                   (setf body (nsubst (cdr pair)
+                                                      `((symbol . ,(car pair)))
+                                                      body
+                                                      :test #'equal)))
+                               (pairlis arglist args))
+                         body)
+                     arglist t (complement #'identity) env :syntax))))
 
 (defparameter *define*
   (define-syntax* define (name value) (siblings #'identity)
diff --git a/src/eval.lisp b/src/eval.lisp
index 4962ade..eede4ad 100644
--- a/src/eval.lisp
+++ b/src/eval.lisp
@@ -23,7 +23,7 @@
                         (closurep (first flink))
                         (null (rest flink)))
                    (flink)
-                   "~A ~A" flink (content (second flink)))
+                   "1~A ~A" flink (content (second flink)))
            (let* ((closure (first flink))
                   (function (closure-function closure))
                   (group-predicate (closure-group-p closure)))
@@ -33,11 +33,20 @@
                 ;; 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))))))
+                   (case (closure-type closure)
+                     (:syntax
+                      (let ((body (ensure-list (apply function environment siblings rlinks)))
+                            (ret nil))
+                        ;; (format t "~&Body: ~A~%" body)
+                        (setf ret (tree-eval environment (append body (rest node))))
+                        (setf rest nil)
+                        ret))
+                     (:special
+                      (ensure-list (apply function environment siblings rlinks)))
+                     (:function
+                      (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))
diff --git a/src/types.lisp b/src/types.lisp
index 09ede2b..06183b1 100644
--- a/src/types.lisp
+++ b/src/types.lisp
@@ -36,15 +36,20 @@
              :initarg :specialp
              :type boolean
              :documentation "")
+   (type :reader closure-type
+         :initarg :type
+         :type keyword
+         :documentation "")
    (groupp :reader closure-group-p
            :initarg :groupp
            :type function
            :documentation "")))
 
-(defun make-closure (function arg-list specialp groupp &optional environment)
+(defun make-closure (function arg-list specialp groupp &optional environment type)
   (make-instance 'closure :function function :arg-list arg-list
                           :specialp specialp :groupp groupp
-                          :environment environment))
+                          :environment environment
+                          :type type))
 
 (defun closurep (object)
   (typep object 'closure))
-- 
cgit v1.2.3