aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorThomas Albers Raviola <thomas@thomaslabs.org>2024-05-16 18:31:28 +0200
committerThomas Albers Raviola <thomas@thomaslabs.org>2024-05-16 18:31:28 +0200
commitf19998f7fd9db2bd1ed4eb80ea1744a013b166fa (patch)
treef010bb2afd58bcddfc56b672b8f1532bfa1b446a /src
parentd917f41beca176b8f2b682ac3a2c25b148752b71 (diff)
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
Diffstat (limited to 'src')
-rw-r--r--src/core.lisp206
-rw-r--r--src/eval.lisp13
-rw-r--r--src/parser.lisp25
-rw-r--r--src/types.lisp48
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)))