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

1 files changed, 137 insertions, 69 deletions

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)