From f19998f7fd9db2bd1ed4eb80ea1744a013b166fa Mon Sep 17 00:00:00 2001 From: Thomas Albers Raviola 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 ++++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 137 insertions(+), 69 deletions(-) (limited to 'src/core.lisp') 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) -- cgit v1.2.3