diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/core.lisp | 206 | ||||
| -rw-r--r-- | src/eval.lisp | 13 | ||||
| -rw-r--r-- | src/parser.lisp | 25 | ||||
| -rw-r--r-- | src/types.lisp | 48 |
4 files changed, 195 insertions, 97 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) 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))) |