diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/core.lisp | 76 | ||||
| -rw-r--r-- | src/eval.lisp | 44 | ||||
| -rw-r--r-- | src/package.lisp | 10 | ||||
| -rw-r--r-- | src/parser.lisp | 144 | ||||
| -rw-r--r-- | src/types.lisp | 85 |
5 files changed, 359 insertions, 0 deletions
diff --git a/src/core.lisp b/src/core.lisp new file mode 100644 index 0000000..6c151ce --- /dev/null +++ b/src/core.lisp @@ -0,0 +1,76 @@ +(in-package #:chains) + +(defun get-var (env key) + (if-let ((slot (assoc key env))) + (cdr slot) + (error "var ~A not found~% ~A~%" key env))) + +;; Built-in functions and variables used inside the interpreter use their own +;; 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))) + `(make-closure #'(lambda (environment ,siblings ,@args) + (declare (ignore ,siblings)) + ,@body) + ',args + nil + (complement #'identity)))) + +(defmacro define-function* (name (&rest args) (siblings group-predicate) + &body body) + `(make-closure #'(lambda (environment ,siblings ,@args) + ,@body) + ',args + nil + ,group-predicate)) + +(defmacro define-syntax (name (&rest args) &body body) + `(make-closure #'(lambda (environment siblings ,@args) + ,@body) + ',args + t + (complement #'identity))) + +(defmacro define-syntax* (name (&rest args) (siblings group-predicate) + &body body) + `(make-closure #'(lambda (environment ,siblings ,@args) + ,@body) + ',args + t + ,group-predicate)) + +(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)))) + +(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) + (tree-eval (append (pairlis arglist args) + env + environment) + body)) + arglist t (complement #'identity) env)))) + +(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))) diff --git a/src/eval.lisp b/src/eval.lisp new file mode 100644 index 0000000..4962ade --- /dev/null +++ b/src/eval.lisp @@ -0,0 +1,44 @@ +(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))) + ((not (consp node)) + node) + ((chainp (first node)) + (destructuring-bind (flink &rest rlinks) (chain-links (first node)) + (setf flink (tree-eval environment flink)) + (assert (and (consp flink) + (closurep (first flink)) + (null (rest flink))) + (flink) + "~A ~A" flink (content (second flink))) + (let* ((closure (first flink)) + (function (closure-function closure)) + (group-predicate (closure-group-p closure))) + (multiple-value-bind (siblings rest) + (group-if group-predicate (rest node)) + (append + ;; Evaluating a function returns a sublink, flatten all sublink + (flatten + (let ((eval-with-environment (curry #'tree-eval environment))) + (if (closure-special-p closure) + (ensure-list (apply function environment siblings rlinks)) + (let ((args (mapcar eval-with-environment rlinks)) + (siblings (funcall eval-with-environment siblings))) + (ensure-list (apply function environment siblings args)))))) + (tree-eval environment rest)))))) + (t + (cons (tree-eval environment (first node)) + (tree-eval environment (rest node)))))) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..962ce17 --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,10 @@ +(defpackage #:chains + (:use #:cl + #:split-sequence + #:alexandria + #:trivia) + (:export)) + +(in-package #:chains) + +(defvar *interpreter-package* (make-package 'interpreter)) diff --git a/src/parser.lisp b/src/parser.lisp new file mode 100644 index 0000000..60e7ac4 --- /dev/null +++ b/src/parser.lisp @@ -0,0 +1,144 @@ +(in-package #:chains) + +(defconstant +special-characters+ + '(#\\ #\% #\# #\@ #\$ #\{ #\} #\[ #\] #\Newline) + "") + +(defconstant +whitespace+ '(#\Tab #\Newline #\Return #\Space) + "") + +;; TODO: (read-char stream nil) +(defun read-if (predicate stream) + "Read characters from STREAM into a string as long as PREDICATE is true" + (let ((string (with-output-to-string (value) + (loop :for c = (read-char stream nil) + :while (and c (funcall predicate c)) + :do (write-char c value) + :finally + (when c (unread-char c stream)))))) + (if (emptyp string) nil string))) + +(defun read-if-not (predicate stream) + "Read characters from STREAM into a string as long as PREDICATE is false" + (read-if (complement predicate) stream)) + +(defun read-text (stream start-of-line) + "Read text from STREAM" + (let* ((text (read-if-not #'special-char-p stream)) + (peek (peek-char nil stream nil))) + (when text (setf start-of-line nil)) + (cond ((and (null text) (null peek)) + nil) + ((and (not start-of-line) (newlinep peek)) + (read-char stream nil) + (let ((rest (read-text stream t))) + (when (eq rest 'empty-line) + (setf rest nil) + (unread-char #\Newline stream)) + (list* text (string #\Newline) rest))) + ((newlinep peek) + (read-char stream nil) + 'empty-line) + (t + (ensure-list text))))) + +(defun atom-char-p (char) + (or (alphanumericp char) (eql char #\-))) + +(defun next-token (stream start-of-line &aux c) + "Read the next token inside STREAM" + (case (setf c (read-char stream nil)) + ('nil nil) + (#\\ + (concat-text (make-text (string (read-char stream nil))) + (make-text (read-if-not #'special-char-p stream)))) + (#\% + (peek-char #\Newline stream) + (read-char stream nil) + ;;(next-token stream nil) + 'separator) + ((#\@ #\$) + (let* ((text (read-if #'atom-char-p stream)) + (value (read-from-string text)) + (type (cond ((symbolp value) '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))))) + (#\{ 'link-start) + (#\} 'link-end) + (#\[ 'raw-link-start) + (#\] 'raw-link-end) + (t + (unread-char c stream) + (let ((text (read-text stream start-of-line))) + (cond ((null text) nil) + ((symbolp text) text) + (t (make-text (apply #'concatenate 'string text)))))))) + +(defun build-tree (tokens) + "Groups a list of tokens into a tree. Returns a subtree and a list of unused +tokens." + (flet ((build-chain (tokens) + (loop :with tokens = tokens + :for (link rest) = (multiple-value-list (build-tree tokens)) + :collect link :into links + :while (member (first rest) '(raw-link-start link-start)) + :do (setf tokens (rest rest)) + :finally + (setf tokens rest) + (return (values links tokens))))) + (destructuring-bind (&optional head &rest tail) tokens + (cond ((null head) + (values nil '())) + ((or (eq head 'link-end) (eq head 'raw-link-end)) + (values '() (rest tokens))) + ((eq head 'separator) + (multiple-value-bind (tree rest) (build-tree tail) + (values 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)))) + (t + (multiple-value-bind (tree rest) (build-tree tail) + (values (cons head tree) rest))))))) + +(defun read-raw-link (stream) + "Read argument of a raw function" + (flet ((squarep (x) (member x '(#\])))) + ;; Text omits closing ], may therefore be nil, for example when reading ]] + (loop :for text = (read-if-not #'squarep stream) + :for c = (peek-char nil stream nil) + :when text :collect text :into text-list + :while (and c text (eql (last-elt text) #\\)) + :collect (string (read-char stream nil)) :into text-list + :finally + ;; Keep ] inside stream + (return (list (make-text (apply #'concat text-list))))))) + +(defun start-of-line-p (last-token) + ;; Keep track if new line starts a paragraph + (or (eq last-token 'empty-line) + (and (textp last-token) + (newlinep (last-elt (content last-token)))))) + +(defun read-tree (stream) + "Build a syntax tree from the contents of STREAM" + (loop :with start-of-line = t + :for token = (next-token stream start-of-line) + :while token + :if (eq token 'raw-link-start) + :append (cons 'raw-link-start (read-raw-link stream)) :into tokens + :and :do + (setf start-of-line nil) + :else + :collect token :into tokens :and :do + (setf start-of-line (start-of-line-p token)) + :finally ;; (build-tree) + (return tokens))) diff --git a/src/types.lisp b/src/types.lisp new file mode 100644 index 0000000..09ede2b --- /dev/null +++ b/src/types.lisp @@ -0,0 +1,85 @@ +(in-package #:chains) + +(defclass text () + ((content :reader content + :initarg :content + :type string + :documentation ""))) + +(defun textp (object) + (typep object 'text)) + +(defun make-text (content) + (make-instance 'text :content content)) + +(defun concat-text (&rest text) + (let ((strings (mapcar #'content text))) + (make-text (apply #'concatenate 'string strings)))) + +(defmethod content ((object (eql 'empty-line))) + (list (make-text ""))) + +(defclass closure () + ((function :reader closure-function + :initarg :function + :type function + :documentation "") + (arg-list :reader closure-arg-list + :initarg :arg-list + :type list + :documentation "") + (environment :reader closure-environment + :initarg :environment + :type list + :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 specialp groupp &optional environment) + (make-instance 'closure :function function :arg-list arg-list + :specialp specialp :groupp groupp + :environment environment)) + +(defun closurep (object) + (typep object 'closure)) + +(defun group (item sequence &key (test #'eql)) + (group-if #'(lambda (x) (funcall test item x)) sequence)) + +(defun group-if (predicate sequence) + (loop :for (head . tail) :on sequence + :while (funcall predicate head) + :collect head :into group + :finally + (return (values group (if (not (funcall predicate head)) + (cons head tail) + tail))))) + +(defun group-if-not (predicate sequence) + (group-if (complement predicate) sequence)) + +(defun whitespacep (char-or-string) + (if (stringp char-or-string) + (every #'whitespacep char-or-string) + (member char-or-string +whitespace+))) + +(defun whitespace-text-p (object) + (and (textp object) (whitespacep (content object)))) + +(defun special-char-p (x) + (member x +special-characters+)) + +(defun empty-line-p (x) + (or (emptyp x) (every #'whitespacep x))) + +(defun newlinep (x) + (eql x #\Newline)) + +(defun concat (&rest strings) + (apply #'concatenate 'string strings)) |