From f19998f7fd9db2bd1ed4eb80ea1744a013b166fa Mon Sep 17 00:00:00 2001
From: Thomas Albers Raviola <thomas@thomaslabs.org>
Date: Thu, 16 May 2024 18:31:28 +0200
Subject: Define types for primitives instead of using lists

* src/parser.lisp: Add alias for shorting chain calls. First symbol may be
outside chain.
* src/types.lisp: Remove specialp from closure class
---
 src/core.lisp   | 206 +++++++++++++++++++++++++++++++++++++-------------------
 src/eval.lisp   |  13 +---
 src/parser.lisp |  25 ++++---
 src/types.lisp  |  48 +++++++++++--
 4 files changed, 195 insertions(+), 97 deletions(-)

(limited to 'src')

diff --git a/src/core.lisp b/src/core.lisp
index d3c396b..1a1a3b8 100644
--- a/src/core.lisp
+++ b/src/core.lisp
@@ -1,5 +1,13 @@
 (in-package #:chains)
 
+(defparameter *default-environment* '()
+  "")
+
+(let ((true (make-object :symbol (intern "TRUE" *interpreter-package*)))
+      (false (make-object :symbol (intern "FALSE" *interpreter-package*))))
+  (push (cons (intern "TRUE" *interpreter-package*) true) *default-environment*)
+  (push (cons (intern "FALSE" *interpreter-package*) false) *default-environment*))
+
 (defun get-var (env key)
   (if-let ((slot (assoc key env)))
     (cdr slot)
@@ -11,78 +19,138 @@
 
 (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)
-                   nil
-                   :function)))
+    (setf name (intern (symbol-name name) *interpreter-package*))
+    `(push (cons ',name
+                 (make-closure #'(lambda (environment ,siblings ,@args)
+                                   (declare (ignore ,siblings))
+                                   ,@body)
+                               ',args
+                               (complement #'identity)
+                               nil
+                               :function))
+           *default-environment*)))
 
 (defmacro define-function* (name (&rest args) (siblings group-predicate)
                             &body body)
-  `(make-closure #'(lambda (environment ,siblings ,@args)
-                     ,@body)
-                 ',args
-                 nil
-                 ,group-predicate
-                 nil
-                 :function))
-
-(defmacro define-syntax (name (&rest args) &body body)
-  `(make-closure #'(lambda (environment siblings ,@args)
-                     ,@body)
-                 ',args
-                 t
-                 (complement #'identity)
-                 nil
-                 :special))
-
-(defmacro define-syntax* (name (&rest args) (siblings group-predicate)
+  `(acons ',name
+          (make-closure #'(lambda (environment ,siblings ,@args)
+                            ,@body)
+                        ',args
+                        ,group-predicate
+                        nil
+                        :function)
+          *default-environment*))
+
+(defmacro define-special (name (&rest args) &body body)
+  (setf name (intern (symbol-name name) *interpreter-package*))
+  `(push (cons ',name
+               (make-closure #'(lambda (environment siblings ,@args)
+                                 ,@body)
+                             ',args
+                             (complement #'identity)
+                             nil
+                             :special))
+         *default-environment*))
+
+(defmacro define-special* (name (&rest args) (siblings group-predicate)
                           &body body)
-  `(make-closure #'(lambda (environment ,siblings ,@args)
-                     ,@body)
-                 ',args
-                 t
-                 ,group-predicate
-                 nil
-                 :special))
-
-(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 :function))))
+  (setf name (intern (symbol-name name) *interpreter-package*))
+  `(push (cons ',name
+               (make-closure #'(lambda (environment ,siblings ,@args)
+                                 ,@body)
+                             ',args
+                             ,group-predicate
+                             nil
+                             :special))
+         *default-environment*))
+
+(define-special lambda (arglist body)
+  (setf arglist (remove-if #'whitespace-text-p arglist))
+  (assert (every #'object-symbol-p arglist))
+  (setf arglist (mapcar #'object-value arglist))
+  (let ((env environment))
+    (make-closure  #'(lambda (environment siblings &rest args)
+                       (tree-eval (append (pairlis arglist args)
+                                          env
+                                          environment)
+                                  body))
+                   arglist (complement #'identity) env :function)))
+
+(define-special lambda* (arglist group-predicate body)
+  (setf arglist (remove-if #'whitespace-text-p arglist))
+  (assert (every #'object-symbol-p arglist))
+  (setf arglist (mapcar #'object-value arglist))
+
+  (cond ((and (listp group-predicate))
+         ;; TODO: Check arglist of predicate
+         (setf group-predicate (first (tree-eval environment group-predicate)))
+
+         (assert (closurep group-predicate))
+         (let ((function (closure-function group-predicate)))
+           (setf group-predicate #'(lambda (object)
+                                     (funcall function nil nil (list object))))))
+        ((not (functionp group-predicate))
+         (error "~A" group-predicate)))
+
+  (let ((env environment))
+    (make-closure  #'(lambda (environment siblings &rest args)
+                       (tree-eval (append (pairlis arglist args)
+                                          (list (cons (intern "SIBLINGS" *interpreter-package*)
+                                                      siblings))
+                                          env
+                                          environment)
+                                  body))
+                   arglist group-predicate
+                   env :function)))
+
+(defun mapflatten (function list &rest more-lists)
+  (flatten (apply #'mapcar function list more-lists)))
+
+(defun syntax-expand (table body)
+  "Replace all instances inside BODY of symbols in the TABLE with their
+respectives values"
+  (cond ((listp body)
+         (mapflatten (curry #'syntax-expand table) body))
+        ((object-symbol-p body)
+         (if-let (entry (assoc (object-value body) table))
+           (cdr entry)
+           body))
+        ((chainp body)
+         (make-chain (mapcar (curry #'syntax-expand table) (chain-links body))))
+        (t
+         body)))
 
 ;; Is this basically quasiquote?
-(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)
-                         (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)
-    (assert (object-symbolp (first name)))
-    (setf name (cdr (first name)))
-    (setf value (first (tree-eval environment value)))
-    (tree-eval (acons name value environment)
-               siblings)))
+(define-special syntax (arglist body)
+  (setf arglist (remove-if #'whitespace-text-p arglist))
+  (assert (every #'object-symbol-p arglist))
+  (setf arglist (mapcar #'object-value arglist))
+  (make-closure  #'(lambda (environment siblings &rest args)
+                     (declare (ignorable environment siblings))
+                     (syntax-expand (pairlis arglist args) body))
+                 arglist (complement #'identity) environment :syntax))
+
+(define-special* define (name value) (siblings #'identity)
+  (assert (object-symbol-p (first name)))
+  (setf name (object-value (first name)))
+  (setf value (first (tree-eval environment value)))
+  (tree-eval (acons name value environment)
+             siblings))
+
+;; TODO: Restrict chain link's length to avoid so many asserts
+
+(define-function gp (symbol)
+  (assert (object-symbol-p (first symbol)) nil "a")
+  (setf symbol (first symbol))
+  (make-closure #'(lambda (environment siblings &rest args)
+                    (declare (ignorable environment siblings))
+                    (let ((object (caar args)))
+                      (not (and (chainp object)
+                                (let ((name (caar (chain-links object))))
+                                  (and (object-symbol-p name)
+                                       (eq (object-value name)
+                                           (object-value symbol))))))))
+                (list nil) (complement #'identity) nil :function))
+
+(define-special quote (object)
+  object)
diff --git a/src/eval.lisp b/src/eval.lisp
index eede4ad..e3e6617 100644
--- a/src/eval.lisp
+++ b/src/eval.lisp
@@ -1,19 +1,10 @@
 (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)))
+        ((object-symbol-p node)
+         (get-var environment (object-value node)))
         ((not (consp node))
          node)
         ((chainp (first node))
diff --git a/src/parser.lisp b/src/parser.lisp
index 60e7ac4..f0821fc 100644
--- a/src/parser.lisp
+++ b/src/parser.lisp
@@ -1,7 +1,7 @@
 (in-package #:chains)
 
 (defconstant +special-characters+
-  '(#\\ #\% #\# #\@ #\$ #\{ #\} #\[ #\] #\Newline)
+  '(#\\ #\% #\@ #\$ #\{ #\} #\[ #\] #\Newline)
   "")
 
 (defconstant +whitespace+ '(#\Tab #\Newline #\Return #\Space)
@@ -43,7 +43,8 @@
            (ensure-list text)))))
 
 (defun atom-char-p (char)
-  (or (alphanumericp char) (eql char #\-)))
+  "Is CHAR allowed as an atom char"
+  (or (alphanumericp char) (member char '(#\- #\*))))
 
 (defun next-token (stream start-of-line &aux c)
   "Read the next token inside STREAM"
@@ -60,16 +61,14 @@
     ((#\@ #\$)
      (let* ((text (read-if #'atom-char-p stream))
             (value (read-from-string text))
-            (type (cond ((symbolp value) 'symbol)
-                        ((integerp value) 'integer)
+            (type (cond ((symbolp value)
+                         (setf value (intern (symbol-name value) *interpreter-package*))
+                         :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)))))
+       (make-object type value)))
     (#\{ 'link-start)
     (#\} 'link-end)
     (#\[ 'raw-link-start)
@@ -101,10 +100,16 @@ tokens."
             ((eq head 'separator)
              (multiple-value-bind (tree rest) (build-tree tail)
                (values tree rest)))
+            ;; @a{...} <-> {@a}{...}
+            ((and (object-symbolp head)
+                  (eq (first tail) 'link-start))
+             (multiple-value-bind (links rest) (build-chain (rest tail))
+               (multiple-value-bind (tree rest) (build-tree rest)
+                 (values (cons (make-chain (cons (list head) links)) 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))))
+                 (values (cons (make-chain links) tree) rest))))
             (t
              (multiple-value-bind (tree rest) (build-tree tail)
                (values (cons head tree) rest)))))))
diff --git a/src/types.lisp b/src/types.lisp
index 06183b1..c845b2d 100644
--- a/src/types.lisp
+++ b/src/types.lisp
@@ -31,11 +31,7 @@
    (environment :reader closure-environment
                 :initarg :environment
                 :type list
-                :documentation "")
-   (specialp :reader closure-special-p
-             :initarg :specialp
-             :type boolean
-             :documentation "")
+                :documentation "Environment captured by the closure")
    (type :reader closure-type
          :initarg :type
          :type keyword
@@ -45,9 +41,9 @@
            :type function
            :documentation "")))
 
-(defun make-closure (function arg-list specialp groupp &optional environment type)
+(defun make-closure (function arg-list groupp &optional environment type)
   (make-instance 'closure :function function :arg-list arg-list
-                          :specialp specialp :groupp groupp
+                          :groupp groupp
                           :environment environment
                           :type type))
 
@@ -88,3 +84,41 @@
 
 (defun concat (&rest strings)
   (apply #'concatenate 'string strings))
+
+(defclass object ()
+  ((type :reader object-type
+         :initarg :type
+         :type keyword
+         :documentation "")
+   (value :reader object-value
+          :initarg :value
+          :type t
+          :documentation "")))
+
+(defun make-object (type value)
+  (make-instance 'object :type type :value value))
+
+(defun objectp (object)
+  (typep object 'object))
+
+(defun object-symbol-p (object)
+  (and (objectp object) (eq (object-type object) :symbol)))
+
+(defmethod print-object ((object object) stream)
+  (format stream "#<OBJECT :TYPE ~A :VALUE ~A>"
+          (object-type object) (object-value object)))
+
+(defclass chain ()
+  ((links :reader chain-links
+          :initarg :links
+          :type list
+          :documentation "")))
+
+(defun make-chain (links)
+  (make-instance 'chain :links links))
+
+(defun chainp (object)
+  (typep object 'chain))
+
+(defmethod print-object ((object chain) stream)
+  (format stream "#<CHAIN :LINKS ~A>" (chain-links object)))
-- 
cgit v1.2.3