diff options
Diffstat (limited to 'src/core.lisp')
| -rw-r--r-- | src/core.lisp | 190 |
1 files changed, 68 insertions, 122 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) |