Use stored lambda-list instead of lambda argumentsHEADmaster

5 files changed, 93 insertions, 146 deletions

diff --git a/src/core.lisp b/src/core.lisp
index 87d9755..6fc2242 100644
--- a/src/core.lisp
+++ b/src/core.lisp
@@ -17,142 +17,88 @@
 ;; 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)))
-    (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)
-  `(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)
+(defmacro define (name arguments
+                  (environment &key specialp siblings group-predicate)
+                  &body body)
   (setf name (intern (symbol-name name) *interpreter-package*))
   `(push (cons ',name
-               (make-closure #'(lambda (environment ,siblings ,@args)
-                                 ,@body)
-                             ',args
-                             ,group-predicate
+               (make-closure #'(lambda (,environment ,siblings)
+                                 (declare (ignorable ,siblings))
+                                 (let ,(mapcar #'(lambda (x)
+                                                   `(,x (get-var ,environment (find-symbol (symbol-name ',x) *interpreter-package*))))
+                                        arguments)
+                                   ,@body))
+                             ',(mapcar #'(lambda (x) (intern (symbol-name x) *interpreter-package*))
+                                       arguments)
+                             ,(if group-predicate
+                                  group-predicate
+                                  '(complement #'identity))
                              nil
-                             :special))
+                             ,specialp))
          *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)
-                       ;; Splice arguments into resulting link
-                       (flatten
-                        (eval-tree (append (pairlis arglist args)
-                                           env
-                                           environment)
-                                   body)))
-                   arglist (complement #'identity) env :function)))
+(defmacro define-function (name arguments &body body)
+  (let ((environment (gensym)))
+    `(define ,name ,arguments (,environment) ,@body)))
 
-(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))
+(defmacro define-special (name arguments &body body)
+  (let ((environment (gensym)))
+    `(define ,name ,arguments (,environment :specialp t) ,@body)))
 
-  (cond ((and (listp group-predicate))
-         ;; TODO: Check arglist of predicate
-         (setf group-predicate (first (eval-tree 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)
-                       (eval-tree (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?
-;; (define-special syntax (arglist body)
+(defmacro clambda ((environment lambda-list) &body body)
+  (let ((siblings (gensym)))
+    `(make-instance 'closure :function #'(lambda (,environment ,siblings)
+                                           (declare (ignorable ,siblings))
+                                           ,@body)
+                             :lambda-list ,lambda-list
+                             :groupp (complement #'identity)
+                             :environment nil
+                             :specialp nil)))
+
+(define lambda (lambda-list body)
+    (captured-environment :siblings siblings :specialp t)
+  (setf lambda-list (remove-if #'whitespace-text-p lambda-list))
+  (assert (every #'object-symbol-p lambda-list))
+  (setf lambda-list (mapcar #'object-value lambda-list))
+  (clambda (environment lambda-list)
+    ;; Splice arguments into resulting link
+    (flatten (eval-tree (append environment captured-environment) body))))
+
+;; (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))
-;;   (make-closure  #'(lambda (environment siblings &rest args)
-;;                      (declare (ignorable environment siblings))
-;;                      (syntax-expand (pairlis arglist args) body))
-;;                  arglist (complement #'identity) environment :syntax))
 
-;;; TODO: require single element list
-(define-special* define (name value) (siblings #'identity)
+;;   (cond ((and (listp group-predicate))
+;;          ;; TODO: Check arglist of predicate
+;;          (setf group-predicate (first (eval-tree 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)
+;;                        (eval-tree (append (pairlis arglist args)
+;;                                           (list (cons (intern "SIBLINGS" *interpreter-package*)
+;;                                                       siblings))
+;;                                           env
+;;                                           environment)
+;;                                   body))
+;;                    arglist group-predicate
+;;                    env nil)))
+
+(define define (name value)
+    (environment :siblings siblings :group-predicate #'identity :specialp t)
   (assert (object-symbol-p (first name)))
   (setf name (object-value (first name)))
   (setf value (first (eval-tree environment value)))
   (eval-tree (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)
+;;; TODO: Macro for checking arguments types, eliminate whitespace and so on
+;;; TODO: Docstrings for functions
+;;; TODO: More advance lambda-lists (optional values, etc)
diff --git a/src/eval.lisp b/src/eval.lisp
index b2c399c..bc1d1c8 100644
--- a/src/eval.lisp
+++ b/src/eval.lisp
@@ -25,27 +25,29 @@
           "Link is not callable: ~A" link)
   (first link))
 
+(defun bind-arguments (environment lambda-list arguments specialp)
+  (unless specialp
+    (map-into arguments (curry #'eval-tree environment) arguments))
+  (append (mapcar #'cons lambda-list arguments)
+          environment))
+
 (defun eval-chain (environment chain siblings)
   "Evaluate CHAIN inside ENVIRONMENT and possibly consume SIBLINGS. Returns a
 link with the evaluated body of the function under the ENVIRONMENT"
   (destructuring-bind (head &rest arguments)
       (chain-links chain)
     (with-accessors ((function closure-function)
-                     (type closure-type)
+                     (special closure-special-p)
+                     (lambda-list closure-lambda-list)
                      (group-predicate closure-group-p))
         ;; Evaluate all elements of first link and get closure object
         (link-closure (eval-tree environment head))
       (multiple-value-bind (consumed-siblings rest)
           (group-if group-predicate siblings)
         (values
-         (apply function
-                environment
-                consumed-siblings
-                (ecase type
-                  (:special
-                   arguments)
-                  (:function
-                   (mapcar (curry #'eval-tree environment) arguments))))
+         (funcall function
+                  (bind-arguments environment lambda-list arguments special)
+                  consumed-siblings)
          rest)))))
 
 (defun eval-tree (environment node)
diff --git a/src/parser.lisp b/src/parser.lisp
index 2d3c673..3615844 100644
--- a/src/parser.lisp
+++ b/src/parser.lisp
@@ -148,5 +148,5 @@ tokens."
         :else
           :collect token :into tokens :and :do
             (setf start-of-line (start-of-line-p token))
-        :finally ;; (build-tree)
+        :finally
            (return tokens)))
diff --git a/src/types.lisp b/src/types.lisp
index 4b24219..4e4633c 100644
--- a/src/types.lisp
+++ b/src/types.lisp
@@ -27,28 +27,29 @@
              :initarg :function
              :type function
              :documentation "")
-   (arg-list :reader closure-arg-list
-             :initarg :arg-list
-             :type list
+   (lambda-list :reader closure-lambda-list
+                :initarg :lambda-list
+                :type list
              :documentation "")
    (environment :reader closure-environment
                 :initarg :environment
                 :type list
                 :documentation "Environment captured by the closure")
-   (type :reader closure-type
-         :initarg :type
-         :type keyword
-         :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 groupp &optional environment type)
-  (make-instance 'closure :function function :arg-list arg-list
+(defun make-closure (function lambda-list groupp &optional environment specialp)
+  (make-instance 'closure :function function
+                          :lambda-list lambda-list
                           :groupp groupp
                           :environment environment
-                          :type type))
+                          :specialp specialp))
 
 (defun closurep (object)
   (typep object 'closure))
diff --git a/tests/test5.chn b/tests/test5.chn
index eb0b88b..d1176b1 100644
--- a/tests/test5.chn
+++ b/tests/test5.chn
@@ -1,4 +1,2 @@
-@define{@a}{@lambda{@x}{A<@x>}}%
-@define{@b}{@lambda{@x}{B<@x>}}%
-%@define{@c}{@b @a @b}%
-@a{a @b{b}}
+@define{@a}{@lambda{@x}{@lambda{@y}{@x}}}%
+{@a{1}}{2}