(define-package
"shen-elisp"
"19.2-0.0.1"
"Shen implementation in Elisp"
'((emacs "24.4"))
:url "http://github.com/deech/shen-elisp"
:keywords '("shen" "elisp"));; -*- lexical-binding: t -*-
;; Copyright (c) 2015-2018 Aditya Siram. All Rights Reserved.
;; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-ClauseThis emacs-distributed macro library is required for cl-flet, which is used for lexically-bound functions:
(require 'cl-macs)(defconst shen/prefix "shen/")Symbols in KLambda (and Shen) are very much like symbols in Elisp :
(defsubst shen/symbol-p (X)
(not (or (consp X) (bufferp X) (vectorp X) (numberp X) (stringp X))))except for a few important differences:
- In KLambda (and Shen) symbols don’t need to be quoted:
> some-symbol some-symbolwhereras in Elisp they do:
> some-symbol *** Eval error *** Symbol's value as variable is void: some-symbol > 'some-symbol some-symbol - When calling a symbol function in Shen you can
simply apply the arguments:
(defun call-f (f a b c) (f a b c))But in Elisp we need to use
funcall:(defun call-f (f a b c) (funcall f a b c))
To deal with these differences a pass is taken over the KLambda ast (before macroexpansion) that identifies symbols that requires quoting and function calls that need to be applied correctly.
Interning a Shen symbol delegates to Elisp’s intern:
(defsubst shen/intern (String)
(intern String))as does shen/symbol->string:
(defsubst shen/symbol->string (X)
(symbol-name X))Elisp does not have namespaces so to insulate the rest of the user’s Emacs image
the primitive functions, user-defined functions and variables are prefixed with shen/.
Raw symbols are not touched since they can’t harm existing Elisp code.
When decompiling Klambda to Elisp we need functions that prefix the appropriate
symbol with shen/:
(defun shen/internal/prefix-symbol (X)
(if (shen/symbol-p X)
(intern (concat shen/prefix (symbol-name X)))
X)), detect if it has already has a prefixed:
(defun shen/internal/symbol-prefixed-p (X)
(and (shen/symbol-p X) (string-prefix-p shen/prefix (symbol-name X)))), and removes the prefix it for consumption by Shen:
(defun shen/internal/unprefix-symbol (X)
(if (shen/internal/symbol-prefixed-p X)
(intern (substring (symbol-name X) (length shen/prefix)))
X))When setting and getting a variable, the name is prefixed to prevent the user from stomping over one that already exists in the Emacs image. See Prefixing Utilities for more on how this works.
(defun shen/set (X Y)
(set (intern (concat shen/prefix (symbol-name X)))
(let ((prefixed))
(or (and (symbolp Y)
(not (shen/internal/symbol-prefixed-p Y))
(progn
(setq prefixed (shen/internal/prefix-symbol Y))
(or (boundp prefixed)
(fboundp prefixed)))
prefixed)
Y))))
(defun shen/value (X)
(condition-case ex
(symbol-value (intern (concat shen/prefix (symbol-name X))))
('error (error (format "%s has not been assigned" X)))))Once the assigning mechanism is in place the spec requires some global variables:
(shen/set '*home-directory* "")
(shen/set '*stoutput* standard-output)
(shen/set '*stinput* [()])
(shen/set '*language* "Elisp")
(shen/set '*implementation* system-configuration)
(shen/set '*porters* "Aditya Siram")
(shen/set '*release* emacs-version)
(shen/set '*port* 1.7)
(shen/set '*os* (symbol-name system-type))Unlike Elisp in KLambda booleans are false and true, distinct symbols which
are not synonymous with nil and (not nil) so wrappers are required:
(defsubst shen/internal/shen->predicate (X)
(eq X 'true))
(defsubst shen/internal/predicate->shen (X)
(if X (quote true) (quote false)))Since if , and and or are special forms they are defined as macros to
preserve evaluation order.
(defmacro shen/if (X Y Z)
`(if (eq ,X 'true) ,Y ,Z))
(defmacro shen/and (X Y) `(shen/internal/predicate->shen (and (eq ,X 'true) (eq ,Y 'true))))
(defmacro shen/or (X Y) `(shen/internal/predicate->shen (or (eq ,X 'true) (eq ,Y 'true))))KLambda’s cond, unlike Elisp’s forbids a fallthrough case - one of the
predicates must be true.
(defmacro shen/cond (&rest CASES)
(let* ((predicates-quoted-cases
(mapcar (lambda (predicate-result-pair)
(list (if (shen/symbol-p (nth 0 predicate-result-pair))
(list 'quote (nth 0 predicate-result-pair))
(list 'shen/internal/shen->predicate (nth 0 predicate-result-pair)))
(nth 1 predicate-result-pair)))
CASES))
(fallthrough-added (append predicates-quoted-cases (list '(t (error "One of the cond predicates must be true."))))))
`(cond ,@fallthrough-added)))Since Shen supports currying by default KLambda’s lambda form is stripped down to only accept one
argument.
(lambda X (...))Multiple arguments are supported via nesting:
(lambda X (lambda Y (...)))The implementation delegates to Elisp’s lambda form:
(defmacro shen/lambda (X Y)
(if (eq X nil)
`(lambda () ,Y)
`(lambda (,X) ,Y)))KLambda’s let in a similar way only takes one assignment:
(let X Y ...)Similarly multiple assignments are supported via nested lets:
(let W X (let Y Z ...))
The implementation delegates to Elisp’s let:
(defmacro shen/let (X Y Z)
`(let ((,X ,Y)) ,Z))The structure of defun in KLambda is identical to Elisp’s so a straight
translation works.
Functions are required to be tail-call optimized but that is done below before the body is spliced in.
(defmacro shen/defun (F Args Body) `(defun ,F ,Args ,Body))Using hash-tables for tuples and vectors complicates equality. It also slows down equality tests across the board but using hash-tables still results in a substantial net-gain.
In the case of strings and numbers using built-in functions suffices but for
compound structures which might contain hash-tables simply using (equal ...)
will not work because two hash-tables containing the same keys and values are not
equal.
While (equal ...) isn’t sufficient, it does have the nice property of being
right when it returns true. Two structures which are (equal ...) are equal but
(equal ...) returning nil does not mean they are unequal. So we first try the
obvious equality test and only perform the expensive tests when that fails.
If both arguments are cons lists and the equality check has failed it might be
that they contain hash tables so we need to check for that. First ensure they
are the same length. Note that we use safe-length and not length. Only the
former is robust to lists that end in dotted pairs, eg. '(a b c . d) which are
sometimes generated from KLambda code.
Then we loop through the elements of the list ensuring that the elements are of the same type , or storing inner lists as we encounter then or recursing to (compare the elements). Note that even though we recur there is no risk of blowing stack because only list comparison recurses and by this point we have ensured that the elements are not lists.
One might wonder why we’re using (string= ...) to (compare hash tables). The
unsatisfying answer is that it was about 30% faster than whatever I could cook
up in Elisp.
(defun shen/internal/= (X Y)
(cond ((and (stringp X) (stringp Y)) (string-equal X Y)) ;;; (ref:strings-and-numbers)
((and (numberp X) (numberp Y)) (= X Y))
((and (symbolp X) (symbolp Y)) (eq X Y))
(t
(or (equal X Y) ;;; (ref:obvious-equality-test)
(cond
((and (consp X) (consp Y))
(let ((LengthX (safe-length X))
(LengthY (safe-length Y)))
(and
(= LengthX LengthY)
(let ((SoFar 't)
(InnerListsX (list X))
(InnerListsY (list Y))
(FirstTime 't)
(CurrentIndex 0))
(while (and SoFar InnerListsX InnerListsY)
(let* ((CurrentListX (pop InnerListsX))
(CurrentListY (pop InnerListsY))
(Iterate
(lambda ()
(let ((I 0))
(while (and SoFar (< I LengthX))
(let* ((CurrentX (nth I CurrentListX))
(CurrentY (nth I CurrentListY)))
(cond
((not (equal (type-of CurrentX) (type-of CurrentY))) ;;; (ref:elements are of the same type)
(setq SoFar nil))
((and (consp CurrentX) (consp CurrentY)) ;;; (ref:store the inner list)
(progn
(push CurrentX InnerListsX)
(push CurrentY InnerListsY)))
(t (setq SoFar (shen/internal/= CurrentX CurrentY)))) ;;; (ref:compare the elements)
(setq I (1+ I))))))))
(if (not FirstTime)
(progn
(setq FirstTime nil)
(setq LengthX (safe-length CurrentListX))
(setq LengthY (safe-length CurrentListY))
(setq SoFar (= LengthX LengthY))
(funcall Iterate))
(funcall Iterate))))
SoFar))))
((and (hash-table-p X) (hash-table-p Y)) ;;; (ref:compare hash tables)
(and (= (hash-table-count X) (hash-table-count Y))
(string= ;;; (ref:hash table comparison)
(prin1-to-string X)
(prin1-to-string Y))))
(t nil))))))
(defsubst shen/= (X Y)
(shen/internal/predicate->shen (shen/internal/= X Y)))(defmacro shen/freeze (X)
`(function (lambda nil ,X)))
(defsubst shen/type (X MyType) (declare (ignore MyType)) X)List construction in KLambda is done with cons exclusively. The KLambda list
[ a b c ] for example is constructed:
(cons a (cons b (cons c ())))
Elisp also provides a cons so a straightforward translation is possible but
it blows the recursion stack after a certain number of elements. They are rewritten to
list calls below but a cons is provided to adhere to the standard:
(defsubst shen/cons (A Rest)
(cons A Rest))The rest of the list operations function as expected:
(defsubst shen/hd (List) (car List))
(defsubst shen/tl (List) (cdr List))
(defsubst shen/cons? (List) (shen/internal/predicate->shen (consp List)))- Printing KLambda datatypes.
The only weirdness here is why we print the
buffer-nameof a stream. That is explained in the Streams and I/O.:
(defun shen/str (X)
(cond ((null X) (error "null is not an atom in Shen; str cannot convert it to a string.~%"))
((or (symbolp X) (functionp X)) (symbol-name X))
((numberp X) (number-to-string X))
((stringp X) X)
((and (bufferp X) (buffer-file-name X)) (buffer-name X))
((eq X standard-input) "standard-input")
((eq X standard-output) "standard-output")
(t
(error (format "%s is not an atom, stream or closure; str cannot convert it to a string." X)))))- Given string
Sget the character at indexN:
(defsubst shen/pos (S N) (string (aref S N)))- Get the rest of a non-empty string:
(defsubst shen/tlstr (X) (substring X 1))- Test for a string, join them and convert between characters and strings:
(defsubst shen/string? (S) (shen/internal/predicate->shen (stringp S)))
(defsubst shen/cn (Str1 Str2) (concat Str1 Str2))
(defsubst shen/n->string (N) (string N))
(defsubst shen/string->n (S) (string-to-char S))NOTE: If a non-empty string is converted to a character only the first character of the string is considered.
Elisp’s error and condition-case covers the primitive error handling
required by the spec:
(define-error 'shen/error "Shen error" 'error)
(defsubst shen/simple-error (E)
(signal 'shen/error
(if (stringp E)
(list E)
E)))
(defmacro shen/trap-error (X F)
`(condition-case ex ,X ('error (funcall ,F ex))))
(defsubst shen/error-to-string (E) (format "%s" E))Hash tables are used to represent Klambda vectors. This is counter-intuitive since Elisp does have native vectors but unfortunately they are not resizable. Since KLambda code tends to allocate huge vectors and resize often, switching from vectors to hash-tables where resizing is natively supported led to 4-5x speed-ups across the board.
(defsubst shen/absvector (N) (make-hash-table :size N :rehash-size 3.0 :test 'shen/internal/hash-table-test))
(defsubst shen/address-> (Vector N Value) (progn (puthash N Value Vector) Vector))
(defsubst shen/<-address (Vector N) (gethash N Vector))
(defsubst shen/absvector? (X) (shen/internal/predicate->shen (hash-table-p X)))While using hash-tables for Shen vectors, tuples and property lists do offer a
significant speed-ups there is an ugly downside: if any of those structures are
used as keys, lookups will fail because in Elisp two hash-tables do not hash to
the same number and so using (make-hash-table ... :test 'equal) does not work.
So we roll our own test which delegates to shen/internal/= for testing equality
and only generates a hash for these structures using only their keys and values.
(define-hash-table-test
'shen/internal/hash-table-test
(lambda (X Y)
(shen/internal/= X Y))
(lambda (X)
(cond
((numberp X) X)
((consp X) (sxhash (prin1-to-string X)))
((hash-table-p X)
(sxhash (prin1-to-string X)))
(t (sxhash X)))))In KLambda there is only number so we have to take care to coerce to between float and
integer as necessary.
Most of this code is heavily borrowed from emacs-cl but simplified since Shen does not have the zoo of numeric types supported by CL.
First a couple of limits to detect when a multiplication or addition might exceed the bounds
of an integer,
(defconst shen/multiplication-limit (floor (sqrt most-positive-fixnum)))
(defconst shen/addition-limit (floor (/ most-positive-fixnum 2)))a generic function to coerce to a float if necessary,
(defun shen/number-op (X Y max op)
(cond
((and (integerp X) (integerp Y))
(if (and (< X max)
(> X (- max))
(< Y max)
(> Y (- max)))
(apply op (list X Y))
(apply op (list (float X) (float Y)))))
((and (floatp X) (numberp Y)) (apply op (list X (float Y))))
((and (numberp X) (floatp Y)) (apply op (list (float X) Y)))
(t (error (format "Trying to %s. Both %s and %s must be numbers" op X Y)))))and the standard arithmetic functions.
(defsubst shen/* (X Y) (shen/number-op X Y shen/multiplication-limit #'*))
(defsubst shen/+ (X Y) (shen/number-op X Y shen/addition-limit #'+))
(defsubst shen/- (X Y) (shen/number-op X Y shen/addition-limit #'-))When we divide we leave the result an integer if we can:
(defsubst shen// (X Y)
(cond
((or (not (numberp X)) (not (numberp Y)))
(error (format "Both %s and %s must be numbers." X Y)))
((and (integerp X) (integerp Y))
(let* ((Div (/ (float X) (float Y)))
(Truncated (floor Div)))
(if (= Truncated Div)
Truncated
Div)))
(t (/ (float X) (float Y)))))And finally the standard number predicates are pretty compatible with Elisp so we just wrap the Elisp functions:
(defsubst shen/> (X Y) (shen/internal/predicate->shen (> X Y)))
(defsubst shen/< (X Y) (shen/internal/predicate->shen (< X Y)))
(defsubst shen/>= (X Y) (shen/internal/predicate->shen (>= X Y)))
(defsubst shen/<= (X Y) (shen/internal/predicate->shen (<= X Y)))
(defsubst shen/number? (N) (shen/internal/predicate->shen (numberp N)))The get-time primitive given real or unix returns the current Unix time
(seconds since Jan 1st 1970) and given run returns the CPU time according to
Emacs.
Both Emacs functions get-internal-run-time and current-time return a 32-bit
number as a tuple where the first is the 16 high bits and the second is the 16
lower bits. To put them together we normalize the high bits by multiplying them
with 2^16 and add the result to the lower bits.
(defconst shen/2^16 65536)
(defun shen/get-time (Time)
(cl-flet
((timespec-to-number (spec)
(let* ((high (nth 0 spec))
(low (nth 1 spec)))
(+ (* high shen/2^16) low))))
(cond ((eq Time 'run) (timespec-to-number (get-internal-run-time)))
((eq Time 'real)(timespec-to-number (current-time)))
((eq Time 'unix)(timespec-to-number (current-time)))
(t (error (format "get-time does not understand parameter %s." Time))))))Streams at the KLambda level are just an abstraction over file I/O. At the Elisp
level X is a stream if it is a buffer with an associated file. That last bit
is important, because per the spec, buffers that aren’t tied to the underlying
filesystem are not streams.
(defsubst shen/streamp (X) (and (bufferp X) (buffer-file-name X)))Opening a stream takes a path Path and, per the spec, makes it relative to the
global *home-directory* variable. It also takes a Direction which is either
in or out meaning we are either reading or writing.
A file opened with Direction in, as in (open some-file.txt in) is
considered read-only. It must be opened with Direction out, as in (open
some-file.txt out) in order to be able to write to it. A read-only
file stream must be close -ed and re-opened out before it can be written.
Additionally buffers open -ed by Shen are “marked” with a buffer local variable
shen/shen-buffer to ensure that only Shen code can read / write / close
them. Buffers that are already open are left alone:
(defun shen/open (Path Direction)
(let* ((Path (concat (file-name-as-directory (shen/value '*home-directory*))
(file-relative-name Path)))
(Buffer (find-buffer-visiting Path)))
(if Buffer
(progn
(with-current-buffer Buffer
(goto-char (point-min)))
Buffer)
(cond
((equal Direction 'in)
(if (not (file-exists-p Path))
(error (format "Path does not exist: %s" Path))
(progn
(setq Buffer (find-file-noselect Path))
(with-current-buffer
Buffer
(progn
(setq buffer-read-only 't)
(setq-local shen/shen-buffer 't)
(goto-char (point-min))))
Buffer)))
((equal Direction 'out)
(progn
(setq Buffer (find-buffer-visiting Path))
(if (bufferp Buffer)
(if (and (buffer-local-value 'buffer-read-only Buffer) (buffer-local-value 'shen/shen-buffer Buffer))
(error (format "A stream to %s already open read-only. Call (close \"%s\") followed by (open \"%s\" 'out). " Path Path Path))
Buffer)
(progn
(setq Buffer (find-file-noselect Path))
(with-current-buffer Buffer
(progn
(goto-char (point-max))
(setq-local shen/shen-buffer 't)))))))))))- Before closing, reading or writing to a buffer first check that it was opened by a Shen program.
A further bit of weirdness is that write-byte switches on a function. This is because
when writing out to the Shen REPL requires calling a function with the character.
(defun shen/close (Stream)
(if (not Stream)
(error "Stream is nil.")
(if (and (local-variable-p 'shen/shen-buffer Stream)
(buffer-local-value 'shen/shen-buffer Stream))
(cond ((buffer-local-value 'buffer-read-only Stream) (kill-buffer Stream))
(t (with-current-buffer
Stream
(progn
(write-file (buffer-file-name Stream))
(kill-buffer Stream)
'())))))))
(defun shen/write-byte (Byte &optional S)
(if S
(cond
((bufferp S)
(if (not (local-variable-p 'buffer-read-only S))
(error (format "Buffer %s is read-only." S))
(if (buffer-local-value 'shen/shen-buffer S)
(write-char Byte S)
(error (format "Buffer %s was not opened by Shen." S)))))
((functionp S) ;; (ref:write-byte-function)
(funcall S Byte))
(t (write-char (shen/stoutput) Byte)))
(funcall (shen/stoutput) Byte)))
(defun shen/read-byte (&optional S)
(cond
((and (bufferp S) (buffer-file-name S))
(with-current-buffer S
(let ((current-byte))
(if (eq (point) (point-max))
-1
(progn
(setq current-byte (get-byte))
(forward-char)
current-byte)))))
((vectorp S) (if (not (aref S 0))
-1
(pop (aref S 0))))
(t (error (format "Unrecognized stream format %s" S)))))(defun shen/internal/lookup-with-default (KEY ALIST DEFAULT)
(car (or (assoc-default KEY ALIST) (list DEFAULT))))The next few sections are about transforming the KLambda AST so we need a few utilites to make the job easier.
Paths are a way of getting or setting deep inside some tree. For the most part
they are a list of numbers . A getter to the path '(0 4 3) given an ast
simply folds over the list into (nth 0 (nth 4 (nth 3 ast))).
Unfortunately the presence of dotted pairs makes the representation less
uniform. Using nth does not get and set the cdr of a dotted pair. For example,
(nth 1 '(a . b)) will throw an error about b not being a list. In that case
we need to use (nthcdr 1 '(a . b)). The cdr of a dotted pair is represented
as a single number 1 inside a list, like '(1).
(defun shen/internal/get-element-at (path ast)
(let ((res ast))
(dolist (current-index (reverse path) res)
(if (listp current-index)
(setq res (nthcdr (car current-index) res))
(setq res (nth current-index res))))))For the setter we use Elisp’s setf which takes a PLACE expression and a
value. Given the previous example path (0 4 3) , (setf (nth 0 (nth 4 (nth
3 ast))) 'x) changes the 1st element of the 3rd element of the 2nd element to
'x. This function is more complex because unlike the getter we can’t just
iterate down the tree, we have to build the PLACE expression completely
before handing it off to setf.
(defun shen/internal/nset-element-at (path ast new-element)
(if (not path)
(setf ast new-element)
(let ((place-fn)
(path (reverse path))
(make-place-fn
(lambda (path target)
(if (listp path)
`(nthcdr ,path ,target)
`(nth ,path ,target)))))
(progn
(dotimes (current-index (length path) nil)
(setq place-fn
(funcall make-place-fn
(nth current-index path)
(if (= current-index 0)
'ast
place-fn))))
(if (or (consp new-element) (shen/symbol-p new-element))
(eval `(setf ,place-fn (quote ,new-element)) 't)
(eval `(setf ,place-fn ,new-element)) 't)
ast))))Search the tree and return paths to all the elements that are equal to the given X.
(defun shen/internal/find-all (X ast)
(if (not (consp ast))
'shen/not-found
(let ((lists-left-to-search `((() ,ast)))
(found 'shen/not-found))
(while lists-left-to-search
(let* ((search-candidate (car lists-left-to-search))
(search-candidate-path (nth 0 search-candidate))
(current-list (nth 1 search-candidate)))
(progn
(setq lists-left-to-search (cdr lists-left-to-search))
(dotimes (current-index (length current-list) nil)
(let ((current-element (nth current-index current-list))
(current-path (cons current-index search-candidate-path)))
(if (equal X current-element)
(if (consp found)
(push current-path found)
(setq found (list current-path)))
(if (consp current-element)
(push `(,current-path ,current-element)
lists-left-to-search))))))))
found)))In addition to accessing and modifying an element given a path we also need
a function that finds the list that contains an element. This following function,
given an element X, a predicate function that takes a list that might contain
the element and an ast, returns a path to the list containing that element
not a path to the element itself.
(defun shen/internal/list-containing-first-occurrence-of (list-pred ast)
(if (not (consp ast))
'shen/not-found
(let ((lists-left-to-search `((() ,ast)))
(found 'shen/not-found))
(progn
(while (and lists-left-to-search (eq found 'shen/not-found))
(let* ((search-candidate (car lists-left-to-search))
(search-candidate-path (nth 0 search-candidate))
(current-list (nth 1 search-candidate))
(current-list-length (length current-list)))
(if (funcall list-pred current-list)
(setq found search-candidate-path)
(progn
(setq lists-left-to-search
(append
(let ((reversed-lists-in-current-list))
(dotimes (current-index current-list-length (reverse reversed-lists-in-current-list))
(if (consp (nth current-index current-list))
(setq reversed-lists-in-current-list
(cons (list (cons current-index search-candidate-path)
(nth current-index current-list))
reversed-lists-in-current-list)))))
(cdr lists-left-to-search)))))))
found))))(defun shen/internal/get-path-relative-to (parent-path path)
(and (shen/internal/starts-with-path parent-path path)
(shen/internal/path-slice path 0 (- (length path) (length parent-path)))))
(defun shen/internal/starts-with-path (parent-path path)
(and (<= (length parent-path) (length path))
(equal parent-path
(shen/internal/path-slice path
(- (length path)
(length parent-path))))))
(defun shen/internal/get-path-parent (path) (cdr path))
(defun shen/internal/path-slice (path start &optional end)
(let ((start-to-end (nthcdr start path))
(res))
(if end
(dotimes (i (- (if (< end (length path))
end
(length path))
start)
(nreverse res))
(push (nth i start-to-end) res))
start-to-end)))Given an ast, some paths, destructively modify the ast with tx-fn. Note
that it starts with the deepest path first so as not to invalidate paths further
up the code tree.
(defun shen/internal/modify-ast (ast paths tx-fn)
(let ((deepest-first (sort paths (lambda (A B) (> (length A) (length B)))))
(current-ast ast))
(dolist (path deepest-first current-ast)
(setq current-ast
(shen/internal/nset-element-at path ast (funcall tx-fn path ast))))))Note this only detects dotted pairs that look like '(a . b), not ones
that look like '(a b c . d)
(defun shen/internal/dotted-pair? (X)
(and (consp X) (not (consp (cdr X)))))A partition function that returns a pair of lists where the first holds elements that pass and the second holds those that fail:
(defun shen/internal/partition (pred Xs)
(let ((a)
(b))
(dotimes (i (length Xs) (list a b))
(push (nth i Xs)
(if (funcall pred (nth i Xs)) a b)))))A filter function that returns the elements of Xs for which
pred holds but also optionally includes their index:
(defun shen/internal/filter (pred Xs &optional include-index)
(let ((accum))
(dotimes (i (length Xs) accum)
(if (funcall pred (nth i Xs))
(push (if include-index
(list (nth i Xs) i)
(nth i Xs))
accum)))))A list search function that returns the index of the first
element for which pred holds:
(defun shen/internal/index-of (pred Xs)
(let ((found)
(index 0))
(while (and (not found) (< index (length Xs)))
(progn
(if (funcall pred (nth index Xs))
(setq found index))
(setq index (+ index 1))))
found))A function that deletes the first occurrences of X
(defun shen/internal/delete-first-eq (needle Xs)
(let ((index (shen/internal/index-of (lambda (X) (eq X needle)) Xs)))
(if index
(let ((current-index 0)
(copy))
(while (< current-index (length Xs))
(progn
(if (not (= current-index index))
(push (nth current-index Xs) copy))
(setq current-index (1+ current-index))))
(nreverse copy))
Xs)))Before evaluating we walk the tree and return locations that require:
- (namespace-only) : paths that need prefixing with
shen/, - (quote-only) : paths that need quoting only (since KLambda symbols do not need it but Elisp does)
- (possibly-apply-function) : a list of pairs consisting of a path to the function at
the head of the call and a list of symbols that have been passed in or bound via
let.
Internal to the walker, as each sublist is processed the following are tracked:
- (current-path) The path from root to the current point in the tree
- (current-list) The list currently being walked.
- (current-list-length) The length of the current list
- (current-index) The index of the current element in the current list.
- (locally-scoped-symbols) A list of symbols local to the current list
that, when encountered, should remain unchanged since they were either passed
in or bound via
let. - (inner-lists) If a list is encountered when iterating over the current one, a path to that list and the set of symbols currently in scope are stored. Each inner list is processed in turn (possibly adding more). Iteration of the AST is over when there are no more inner lists left.
While iterating over a list the following cases are encountered:
- At the head of the list non-
nilsymbols need prefixing and quoting. Additionally:- if it is a (lambda form), the argument is added to the list of locally scoped variables and iteration moves to the body.
- if we’re looking at a (defun form), the second element of the form does not get quoted since it is the name of the function, and the arguments are added to local scope. before moving on to the body.
- if it is a (let form), the name of the assignment is added to local scope and iteration moves to the assignment body.
- any forms seen inside a (cond form) have to be treated differently. Specifically
a symbol at the head of a predicate action pair is not function application so
a special flag is required to indicate that when iterating over the rest of a
condform. - otherwise it is a function call, and the path is stored along with the symbols in scope thus far.
Symbols occuring anywhere else in the list are only quoted, not namespaced since they are not functions calls. They might be variables, but
shen/getandshen/settake care of prefixing them so there’s no need to worry about them here. - All sublists encountered are stored for further processing. If they are at the head of the list
and not part of
cond, they are also possible function calls.
(defun shen/internal/get-function-symbol-and-funcall-paths (ast)
(let ((namespace-only) ;; (ref:namespace-only)
(quote-only) ;; (ref:quote-only)
(possibly-apply-function)) ;; (ref:possibly-apply-function)
(if (not (consp ast))
(if (shen/symbol-p ast)
(list nil '(nil) '(nil) nil nil)
(list nil nil nil nil nil))
(let ((current-path) ;; (ref:current-path)
(current-list ast) ;; (ref:current-list)
(current-list-length (length ast)) ;; (ref:current-list-length)
(current-index 0) ;; (ref:current-index)
(locally-scoped-symbols) ;; (ref:locally-scoped-symbols)
(inner-lists) ;; (ref:inner-lists)
(cond-predicate-action-p)
(inner-lists-in-cond-form)) ;; (ref:inner-lists-in-cond-form)
(while (or (< current-index current-list-length) ;; (ref:continue iterating)
inner-lists)
(cond
((and (= current-index current-list-length) inner-lists) ;; (ref:sublists left)
(progn
(setq locally-scoped-symbols (nth 0 (car inner-lists)))
(setq current-path (nth 1 (car inner-lists)))
(setq cond-predicate-action-p (nth 2 (car inner-lists)))
(setq inner-lists-in-cond-form nil)
(setq inner-lists (cdr inner-lists))
(setq current-list (shen/internal/get-element-at current-path ast))
(setq current-index 0)
(setq current-list-length (length current-list))))
((and (< current-index current-list-length) ;; (ref:not a list)
(not (consp (nth current-index current-list))))
(let ((current-token (nth current-index current-list)))
(if (= 0 current-index)
(if (and (not (eq current-token 'nil))
(shen/symbol-p current-token))
(progn
(if (and (not (memq current-token locally-scoped-symbols))
(not (eq current-token 'defun)))
(push (cons 0 current-path)
namespace-only))
(cond
((or (eq current-token 'lambda)
(eq current-token 'shen/lambda)) ;; (ref:lambda form)
(progn
(push (nth 1 current-list) locally-scoped-symbols)
(setq current-index 2)))
((eq current-token 'defun) ;; (ref:defun form)
(progn
(push (cons 1 current-path) namespace-only)
(setq locally-scoped-symbols
(append (nth 2 current-list) locally-scoped-symbols))
(setq current-index 3)))
((or (eq current-token 'let)
(eq current-token 'shen/let)) ;; (ref:let form)
(progn
(push (nth 1 current-list) locally-scoped-symbols)
(setq current-index 2)))
((or (eq current-token 'cond)
(eq current-token 'shen/cond)) ;; (ref:cond form)
(progn
(setq inner-lists-in-cond-form 't)
(setq current-index 1)))
(t
(progn
(if (not cond-predicate-action-p)
(push (list (cons 0 current-path)
(memq current-token locally-scoped-symbols))
possibly-apply-function))
(setq current-index 1)))))
(setq current-index (1+ current-index)))
(if (and (not (eq current-token 'nil))
(shen/symbol-p current-token))
(progn
(if (not (memq current-token locally-scoped-symbols))
(push (cons current-index current-path)
quote-only))
(setq current-index (1+ current-index)))
(setq current-index (1+ current-index))))))
((and (< current-index current-list-length) ;; (ref:a sublist)
(consp (nth current-index current-list)))
(progn
(if (and (= 0 current-index) (not cond-predicate-action-p))
(push (list (cons current-index current-path)
nil)
possibly-apply-function))
(push (list locally-scoped-symbols
(cons current-index current-path)
inner-lists-in-cond-form)
inner-lists)
(setq current-index (+ current-index 1))))
(t nil)))
(list namespace-only quote-only possibly-apply-function))))) ;; (ref:returns)Since KLambda supports partial application and Elisp does not function application is tricky.
First we enumerate forms that may never be partially applied:
(setq shen/*primitive-macros*
'(shen/if
shen/and
shen/or
shen/cond
shen/lambda
shen/let
defun
shen/freeze
shen/trap-error))The general strategy to rewriting KLambda function application to Elisp is to first blindly apply the function as though all of its arguments are present and only deal with errors if they occur.
In the case of a (higher-order function) if normal application fails because the
function cannot be found try again with the shen/ prefix. If the function has
known arity, build curried version and apply incrementally and barring that just
feed the function arguments one-by-one and hope for the best.
If it is (a list) (which presumably evaluates to a function) since there is no hope of knowing the arity only the incremental fallback is tried.
If the function has a (known arity) but is undersupplied with arguments a <a href=”(curried
lambda)”>curried
lambda expression and the subsequent funcalls are constructed. No
fallback is required this time.
In the interests of efficiency when constructing the lambda expression as many
arguments as possible are applied in one fell swoop to cut down on the overhead
of incremental application. For example if a function f takes 3 arguments but
only 2 are supplied, the constructed expresssion looks like:
(lambda (A0 A1) (lambda (A2) (apply f (list A0 A1 A2))))
instead of:
(lambda (A0) (lambda (A1) (lambda (A2) (apply f (list A0 A1 A2)))))
(defun shen/internal/apply-function (f args locally-scoped)
(cond
(locally-scoped ;;(ref:higher-order function)
`(shen/internal/apply-higher-order-function ,f (list ,@args)))
((consp f) ;;(ref:a list)
`(shen/internal/apply-function-expression ,f (list ,@args)))
(t
(if (fboundp 'shen/arity)
(let ((arity (shen/internal/check-partial-application f (length args)))) ;; (ref:known arity)
(if (= arity -1)
`(,f ,@args)
`(shen/internal/apply-partially (function ,f) (list ,@args))))
`(,f ,@args)))))
(defun shen/internal/apply-higher-order-function (f args)
(condition-case apply-ex (apply f args)
('void-function
(shen/internal/apply-higher-order-function (shen/internal/prefix-symbol f) args))
('wrong-number-of-arguments
(condition-case ex
(let ((arity (shen/internal/check-partial-application f (length args))))
(if (= arity -1)
(signal (car apply-ex) (cdr apply-ex))
(apply (eval (shen/internal/make-lambda-expression f arity (length args)) 't) args)))
('wrong-number-of-arguments
(shen/internal/apply-incrementally f args))))))
(defun shen/internal/apply-function-expression (exp args)
(condition-case ex (apply exp args)
('wrong-number-of-arguments (shen/internal/apply-incrementally exp args))))
(defun shen/internal/apply-partially (f args)
(let ((arity (shen/internal/check-partial-application f (length args))))
(if (= arity -1)
(apply f args)
(apply (eval (shen/internal/make-lambda-expression f arity (length args)) 't) args))))
(defun shen/internal/make-lambda-expression (f arity num-args) ;; (ref:curried lambda)
(let* ((all-args (let ((single-apply-args)
(blast-apply-args))
(dotimes (i arity (list (reverse blast-apply-args)
(reverse single-apply-args)))
(push (intern (concat "A" (number-to-string i)))
(if (and num-args (< i num-args))
blast-apply-args
single-apply-args)))))
(blast-apply-args (nth 0 all-args))
(single-apply-args (nth 1 all-args))
(expression `(apply (function ,f) (list ,@(append blast-apply-args single-apply-args)))))
(dolist (arg (reverse single-apply-args) expression)
(setq expression `(shen/lambda ,arg ,expression)))
(if blast-apply-args
`(lambda ,blast-apply-args ,expression)
expression)))
(defun shen/internal/apply-incrementally (f args) ;; (ref:incremental application)
(let ((result f)
(current-args args))
(while current-args
(setq result (funcall result (car current-args)))
(setq current-args (cdr current-args)))
result))
(defun shen/internal/check-partial-application (f num-args)
(let ((arity (condition-case ex (shen/arity (shen/internal/unprefix-symbol f)) ('error -1))))
(cond
((eq -1 arity) -1)
((= arity num-args) -1)
((> num-args arity) -1)
(t arity))))Finding tail calls in a form is complex because:
- Not all self references in the tail position of a form
are tail calls, for instance:
(defun f (a) (map (lambda X (f "blah")) a)) ifandcondforms may contain multiple tail calls:(defun f (a b) (if true (f a) (f b)) (defun f (a b c) (cond (a (f a)) (b (f b)) (c (f c))))
The function follows the same basic template as searching for the first occurrence of something in the AST but instead of stopping at the first encounter keeps a tally of paths to all tail calls.
In the case where a cond is encountered all the predicate action pairs where
the action can’t be a function call are filtered out and the index of each
action is added to the list of forms that might contain a tail call.
In an if since the 2nd element is the predicate only the 3rd and possibly the
4th elements (if it exists) of the list are checked. In trap-error both the
action and the fallback may contain a tail call. In a lambda, let and
defun forms only the bodies may contain a tail call. In all other cases jump
to the end of the list and continue searching.
(defun shen/internal/find-recursive-call-paths (function-name args ast)
(if (not (consp ast))
'shen/not-found
(let ((lists-left-to-search `((() ,ast))) ;; (ref:lists-left-to-search)
(found 'shen/not-found)) ;; (ref:tail-calls-found)
(while lists-left-to-search
(let* ((search-candidate (car lists-left-to-search))
(search-candidate-path (nth 0 search-candidate))
(current-list (nth 1 search-candidate))
(current-list-length (length current-list))
(current-head (car current-list))
(push-if-list ;; (ref:push-if-list)
(lambda (indexes)
(mapc
(lambda (index)
(if (consp (nth index current-list))
(setq lists-left-to-search
(append lists-left-to-search
(list
(list (cons index search-candidate-path)
(nth index current-list)))))))
indexes))))
(progn
(setq lists-left-to-search (cdr lists-left-to-search))
(cond ((and (eq current-head function-name)
(= (length (cdr current-list)) (length args)))
(if (not (consp found))
(setq found (list search-candidate-path))
(push search-candidate-path found)))
((eq current-head 'shen/cond)
(progn
(mapc
(lambda (action-index-pair)
(setq lists-left-to-search
(let ((path-to-action
(append (list 1 (1+ (nth 1 action-index-pair)))
search-candidate-path)))
(append lists-left-to-search
(list
(list path-to-action
(nth 0 action-index-pair)))))))
(mapcar
(lambda (predicate-action-index)
(list (nth 1 (nth 0 predicate-action-index))
(nth 1 predicate-action-index)))
(shen/internal/filter ;; (ref:cond-filter)
(lambda (predicate-action-pair)
(consp (nth 1 predicate-action-pair)))
(cdr current-list)
't)))))
((eq current-head 'shen/if)
(if (= 4 current-list-length)
(funcall push-if-list '(2 3))
(funcall push-if-list '(2))))
((eq current-head 'shen/trap-error)
(funcall push-if-list '(1 2)))
((or (eq current-head 'shen/let)
(eq current-head 'defun))
(funcall push-if-list '(3)))
((eq current-head 'shen/lambda)
(funcall push-if-list '(2)))
(t (funcall push-if-list (list (- current-list-length 1))))))))
found)))This function captures the surrounding function application context around a tail call. For instance in the function:
(defun factorial (x) (if (= 0 x) 0 (+ 1 (factorial (- x 1)))))
(+ 1 ...) is the context.
Given a path to a tail call tail-call-path it works its way from the top of
the form to that location. Since Elisp does not support lexical binding as
locally scoped variables (function arguments, let assignments) are also captured
as they are encountered in the path. When it encounters a function application
it starts “recording” that context into an accumulator.
Some forms stop the recording because they should not be captured. In the case of if’s just stop recording and move on, with let’s or lambda’s and defun’s skip but also capture the assignments or arguments. In the case of cond’s skip twice to move into the list containing the predicate action pair. If it is a do just skip it.
(defun shen/start-of-function-chain (tail-call-path ast)
(let* ((from-the-top (reverse tail-call-path))
(current-from-top-path)
(path-left-to-tail-call (reverse tail-call-path))
(start tail-call-path) ;; (ref:start-accumulator)
(locally-scoped))
(cl-flet ((append-and-advance
(X &optional reset-start)
(progn
(setq start
(if reset-start ;; (ref:reset-start)
tail-call-path
current-from-top-path))
(setq current-from-top-path
(append (reverse (shen/internal/path-slice path-left-to-tail-call 0 X))
current-from-top-path)
path-left-to-tail-call (shen/internal/path-slice path-left-to-tail-call X))
)))
(while (not (equal current-from-top-path tail-call-path))
(let* ((current-list (shen/internal/get-element-at current-from-top-path ast))
(current-head (car current-list)))
(cond
((or (not (shen/symbol-p current-head))
(eq 'shen/if current-head)) ;; (ref:if-stop-recording)
(append-and-advance 1 't))
((eq 'defun current-head) ;; (ref:defun-stop-recording)
(progn
(setq locally-scoped (append (nth 2 current-list) locally-scoped))
(append-and-advance 1 't)))
((or
(eq 'shen/let current-head)
(eq 'shen/lambda current-head)) ;;; (ref:let-or-lambda-stop-recording)
(progn
(setq locally-scoped (append (list (nth 1 current-list)) locally-scoped))
(append-and-advance 1 't)))
((eq 'shen/cond current-head) ;;; (ref:cond-stop-recording)
(append-and-advance 2 't))
((eq 'shen/do current-head) ;;; (ref:do-stop-recording)
(append-and-advance 1 't))
(t (append-and-advance 1)))))
start)))Now that we can get a list of recursive calls and their surrounding context a proper tail call is simply one without any context, i.e it is the last thing left to do.
(defun shen/internal/get-tail-call-paths (ast)
(let* ((function-name (nth 1 ast))
(args (nth 2 ast))
(body (nth 3 ast))
(recursive-call-paths (shen/internal/find-recursive-call-paths function-name args body)))
(if (eq recursive-call-paths 'shen/not-found)
'shen/not-found
(let ((accum))
(dolist (tail-call-path recursive-call-paths (if accum (reverse accum) 'shen/not-found))
(let* ((context (shen/start-of-function-chain tail-call-path body)))
(if (equal context tail-call-path)
(push (append tail-call-path (list 3)) accum))))))))Finally we can optimize tail calls into trampolines. The body of the trampoline matches the body of unoptimized function except that tail calls are replaced by vector that holds the arguments to the recursive call fully evaluated:
An Elisp vector is chosen because KLambda code can never return one and so uniquely identifies an intermediate return value from a recursive function. KLambda vectors are represented by hash-tables
A while loop extracts the arguments from the struct and passes them back into the trampoline until it returns something other than the struct. This is the return value.
(defun shen/trampoline-body (ast)
(let* ((args (nth 2 ast))
(body (nth 3 ast))
(tail-trampoline (make-symbol "tail-trampoline")))
`(cl-flet ((,tail-trampoline ,args ,body))
(let ((result (funcall (function ,tail-trampoline) ,@args)))
(while (vectorp result)
(setq result (apply (function ,tail-trampoline) (aref result 0))))
result))))This overall approach owes a lot to Wilfred Hughes’ excellent tco.el. The essential difference is that he returns a function instead of a vector. Since vectors will never appear in the generated Elisp (KLambda vectors are hash-tables underneath), latter approach uniquely identifies a trampolined value and guards against the possibility that if the final return value is a function there would be no way to tell when recursion terminated.
Now that we have mechanisms for
- identifying the parts of the AST that need changing
- applying functions calls in the face of partial application and
- optimizing tail calls
we are ready to transform incoming KLambda code into Elisp.
The overall flow goes like this:
- walk the KLambda code and get a list of locations that need to be transformed
- (quote and namespace) as required but hold off on function application
- Sift through the function application locations and remove ones that point to special forms since they cannot be curried.
- If the KLambda is a (defun form)
- Isolate function application that occurs (inside the recursive call), curry accordingly and (package up the arguments) into tue struct that marks a tail call return.
- (Sub in the recurs marker) throughout the body of the form.
- Sub in the (rest of the function applications)
- Add the trampolines and (write out the defun).
- Otherwise just sub in function applications across the form without regard for tail calls.
(defun shen/internal/parse-ast (ast)
(if (not (consp ast))
(if (shen/symbol-p ast) (list 'quote ast) ast)
(let* ((function-and-symbol-paths (shen/internal/get-function-symbol-and-funcall-paths ast)) ;;; (ref:paths)
(namespace-only (nth 0 function-and-symbol-paths))
(quote-only (nth 1 function-and-symbol-paths))
(possibly-apply-function (nth 2 function-and-symbol-paths))
(current-ast ast))
(progn
(shen/internal/namespace-and-quote current-ast namespace-only quote-only) ;;; (ref:quote and namespace)
(let ((apply-function (shen/internal/filter
(lambda (path-local)
(let ((token (shen/internal/get-element-at (nth 0 path-local) ast)))
(not (memq token shen/*primitive-macros*))))
possibly-apply-function)))
(if (eq (car current-ast) 'defun) ;;; (ref:defun form)
(let* ((tail-call-paths (shen/internal/get-tail-call-paths ast)))
(if (not (eq tail-call-paths 'shen/not-found))
(let ((not-in-tail-call apply-function)
(in-tail-call))
(progn
(dolist (path tail-call-paths nil)
(let* ((tco-non-tco-pair ;;; (ref:inside the recursive call)
(shen/internal/partition
(lambda (apply-function-path-local)
(shen/internal/starts-with-path path (nth 0 apply-function-path-local)))
not-in-tail-call))
(funcalled-tco
(let* ((normalized-paths
(shen/internal/filter
(lambda (path-local) (not (equal (nth 0 path-local) '(0))))
(mapcar
(lambda (in-tco-path-local)
(list
(shen/internal/get-path-relative-to path (nth 0 in-tco-path-local))
(nth 1 in-tco-path-local)))
(nth 0 tco-non-tco-pair))))
(tail-call (shen/internal/get-element-at path current-ast)))
(list
path
`(vector (list ,@(cdr (shen/internal/add-funcalls tail-call normalized-paths)))))))) ;;; (ref:package up the arguments)
(progn
(setq not-in-tail-call (nth 1 tco-non-tco-pair))
(push funcalled-tco in-tail-call))))
(dolist (path-tail-call in-tail-call nil) ;;; (ref:Sub in the recurs marker)
(shen/internal/modify-ast current-ast (list (nth 0 path-tail-call))
(lambda (path current-ast) (nth 1 path-tail-call))))
(setq current-ast (shen/internal/add-funcalls current-ast not-in-tail-call)) ;;; (ref:rest of the function applications)
(setq current-ast `(defun ,(nth 1 current-ast) ,(nth 2 current-ast) ,(shen/trampoline-body current-ast))))) ;;; (ref:write out the defun)
(setq current-ast (shen/internal/add-funcalls current-ast apply-function)))
current-ast)
(progn
(setq current-ast (shen/internal/add-funcalls current-ast apply-function))
current-ast)))))))To support the above transformation we need functions the namespace and quote the AST:
(defun shen/internal/namespace-and-quote (ast namespace-only-paths quote-only-paths)
(progn
(shen/internal/modify-ast ast namespace-only-paths
(lambda (path ast)
(let ((element (shen/internal/get-element-at path ast)))
(if (not (shen/internal/symbol-prefixed-p element))
(shen/internal/prefix-symbol (shen/internal/get-element-at path ast))
element))))
(shen/internal/modify-ast ast quote-only-paths
(lambda (path ast)
(list 'quote (shen/internal/get-element-at path ast))))
ast)), and run function application in the right places:
(defun shen/internal/add-funcalls (ast apply-function)
(let ((paths-only (mapcar (lambda (path-local) (nth 0 path-local)) apply-function)))
(shen/internal/modify-ast ast (mapcar #'shen/internal/get-path-parent paths-only)
(lambda (path ast)
(let* ((current-funcalled-list (shen/internal/get-element-at path ast))
(function-name (car current-funcalled-list))
(function-arguments (cdr current-funcalled-list)))
(shen/internal/apply-function
function-name
function-arguments
(shen/internal/lookup-with-default (cons 0 path) apply-function nil)))))))I was going to do something clever with the function application context but that didn’t work so these functions are unused for now.
(defun shen/make-holed-context (tail-call-path function-chain-path ast)
(let* ((function-chain (shen/internal/get-element-at function-chain-path ast))
(tail-call (shen/internal/get-element-at tail-call-path ast))
(tail-call-relative-path
(shen/internal/path-slice tail-call-path 0
(- (length tail-call-path)
(length function-chain-path)))))
(shen/internal/nset-element-at tail-call-relative-path function-chain 'shen/__hole__)))
(defun shen/used-in-context (context locally-scoped)
(mapcar (lambda (symbol-index-pair)
(nth 1 symbol-index-pair))
(shen/internal/filter
(lambda (v)
(not (eq 'shen/not-found (shen/internal/find-all v context))))
locally-scoped
't)))
(defun shen/substitute-in-context (context locally-scoped-alist)
(let ((current-context context))
(dolist (locally-scoped-pair locally-scoped-alist current-context)
(let* ((name (nth 0 locally-scoped-pair))
(value (nth 1 locally-scoped-pair))
(all-matching-paths (shen/internal/find-all name current-context)))
(if (not (eq all-matching-paths 'shen/not-found))
(dolist (path all-matching-paths nil)
(shen/internal/nset-element-at path current-context value)))))))KLambda code is rife with argument chains such as (cons x (cons y
nil)) for list building and (@s "x" (@s "y" "")) for string concatenation
which can easily be rewritten to more efficient variadic Elisp functions.
A generic function that takes matcher-fn which finds these chains, a
collector-fn that accumulates them and tx-fn which rewrites:
(defun shen/internal/consolidate (ast matcher-fn collector-fn tx-fn)
(let* ((current-ast ast)
(location-containing-chain
(shen/internal/list-containing-first-occurrence-of matcher-fn ast)))
(while (not (eq location-containing-chain 'shen/not-found))
(let ((current-chain (shen/internal/get-element-at location-containing-chain current-ast))
(accum))
(progn
(while (funcall matcher-fn current-chain)
(let ((collected (funcall collector-fn accum current-chain)))
(setq accum (nth 0 collected))
(setq current-chain (nth 1 collected))))
(setq current-ast
(shen/internal/nset-element-at
location-containing-chain
current-ast
(funcall tx-fn accum current-chain)))
(setq location-containing-chain
(shen/internal/list-containing-first-occurrence-of matcher-fn current-ast)))))
current-ast))Convert (cons a (cons b (blah))) into (append (list 'a 'b) (blah))
(defun shen/internal/consolidate-cons (ast)
(shen/internal/consolidate
ast
(lambda (current-list)
(and current-list
(consp current-list)
(eq 3 (length current-list))
(eq (nth 0 current-list) 'shen/cons)))
(lambda (accum current-chain)
(list (cons (nth 1 current-chain) accum)
(nth 2 current-chain)))
(lambda (accum remaining-chain)
(if (eq remaining-chain 'nil)
`(list ,@(reverse accum))
`(append (list ,@(reverse accum)) ,remaining-chain)))))Convert (@s "a" (@s "b" (blah))) into (concat (concat "a" "b") (blah))
(defun shen/internal/consolidate-@s (ast)
(shen/internal/consolidate
ast
(lambda (current-list)
(and current-list
(consp current-list)
(eq 3 (length current-list))
(eq (nth 0 current-list) 'shen/@s)))
(lambda (accum current-chain)
(list (cons (nth 1 current-chain) accum)
(nth 2 current-chain)))
(lambda (accum remaining-chain)
(list 'concat (cons 'concat (reverse accum)) remaining-chain))))Convert (tl (tl (tl Xs))) to (nthcdr 3 Xs)
(defun shen/internal/consolidate-tl (ast)
(shen/internal/consolidate
ast
(lambda (current-list)
(and current-list
(consp current-list)
(eq 2 (length current-list))
(eq (nth 0 current-list) 'shen/tl)))
(lambda (accum current-chain)
(list (if (not accum) 1 (+ accum 1))
(nth 1 current-chain)))
(lambda (accum remaining-chain)
(list 'nthcdr accum remaining-chain))))Convert (+ X 1) or (+ 1 X) to (1+ X)
(defun shen/internal/add-1+ (ast)
(shen/internal/consolidate
ast
(lambda (current-list)
(and current-list
(consp current-list)
(eq 3 (length current-list))
(and (eq (nth 0 current-list) 'shen/+)
(or (eq (nth 1 current-list) 1)
(eq (nth 2 current-list) 1)))))
(lambda (accum current-list)
(if (eq (nth 1 current-list) 1)
(list (nth 2 current-list) nil)
(list (nth 1 current-list) nil)))
(lambda (accum remaining-chain)
(list '1+ accum))))(defun shen/internal/nil-to-null (ast)
(shen/internal/consolidate
ast
(lambda (current-list)
(and current-list
(consp current-list)
(eq 3 (length current-list))
(and (eq (nth 0 current-list) 'shen/=)
(or (eq (nth 1 current-list) 'nil)
(eq (nth 2 current-list) 'nil)))))
(lambda (accum current-list)
(if (eq (nth 1 current-list) 'nil)
(list (nth 2 current-list) nil)
(list (nth 1 current-list) nil)))
(lambda (accum remaining-chain)
`(shen/internal/predicate->shen (null ,accum)))))There are four types of overrides, those which:
- boost performance
- are necessary because Klambda functions are prefixed.
- fix klambda bugs.
They are represented as a dotted pair alists where the car of the list is a
function name or form which when found in Klambda code is replaces with the
cdr of the form.
Peephole optimizations that provide native implementations of commonly used functions and the dictionary API.
(setq shen/internal/*performance-overrides*
'((map . (defun shen/map (F Xs)
(mapcar (lambda (X)
(shen/internal/apply-higher-order-function F (list X)))
Xs)))
(shen.lazyderef . (defun shen/shen\.lazyderef
(X ProcessN)
(let ((Current X)
(KeepLooking t))
(while KeepLooking
(shen/if
(shen/shen.pvar? Current)
(shen/let Value (shen/shen.valvector Current ProcessN)
(shen/if (shen/= Value 'shen.-null-)
(setq KeepLooking nil)
(setq Current Value)))
(setq KeepLooking nil)))
Current)))
(append . (defun shen/append (Xs Ys) (append Xs Ys)))
(shen.string->bytes . (defun shen/shen.string->bytes (S)
(string-to-list S)))
(sum . (defun shen/sum (Xs) (apply #'+ Xs)))
(hash . (defun shen/hash (N Div) (sxhash N)))
(shen.mod . (defun shen/shen.mod (N Div) (mod N Div)))
(integer? . (defun shen/integer? (N) (shen/internal/predicate->shen (integerp N))))
(abs . (defun shen/shen.abs (N) (abs N)))
(nth . (defun shen/nth (I Xs) (nth I Xs)))
(element? . (defun shen/element? (Element Xs)
(let ((SearchList Xs)
(Found nil)
(Length (length Xs))
(Current 0))
(while (and (not Found) SearchList)
(setq Found (shen/internal/= Element (pop SearchList))))
(shen/internal/predicate->shen Found))))
(shen.compose . (defun shen/shen.compose
(Fs X)
(let ((Result X))
(dolist (F Fs Result)
(setq Result (funcall F Result))))))))(setq shen/internal/*dict-overrides*
'((shen.dict . (defun shen/shen\.dict
(Size)
(let ((Dict (shen/absvector 4))
(Contents (shen/absvector Size)))
(progn
(shen/address-> Dict 0 'dictionary)
(shen/address-> Dict 1 Size)
(shen/address-> Dict 2 0)
(shen/address-> Dict 3 Contents)
Dict))))
(shen.dict-> . (defun shen/shen\.dict->
(Dict Key Value)
(let* ((Count (shen/shen\.dict-count Dict))
(Contents (shen/<-address Dict 3))
(Exists (shen/<-address Contents Key)))
(progn
(if (not Exists)
(shen/address-> Dict 2 (1+ Count)))
(shen/address-> Contents Key Value)))))
(shen.<-dict . (defun shen/shen\.<-dict
(Dict Key)
(let* ((Contents (shen/<-address Dict 3))
(Existing (shen/<-address Contents Key)))
(if (not Existing)
(shen/freeze (shen/simple-error "value not found"))
Existing))))
(shen.dict-rm . (defun shen/shen\.dict-rm
(Dict Key)
(let* ((Count (shen/shen\.dict-count Dict))
(Contents (shen/<-address Dict 3))
(Exists (shen/<-address Contents Key)))
(if (not Exists)
Key
(progn
(remhash Key Contents)
(shen/address-> Dict 2 (1- Count))
Key)))))
(shen.dict-keys . (defun shen/shen\.dict-keys
(Dict)
(let* ((Contents (shen/<-address Dict 3)))
(hash-table-keys Contents))))
(shen.dict-values . (defun shen/shen\.dict-values
(Dict)
(let* ((Contents (shen/<-address Dict 3)))
(hash-table-values Contents))))
(shen.dict-fold . (defun shen/shen\.dict-fold
(F Dict Acc)
(let ((Contents (shen/<-address Dict 3)))
(progn
(setq NewAcc Acc)
(maphash
(lambda (Key Value)
(setq NewAcc (shen/internal/apply-higher-order-function F (list Key Value NewAcc))))
Contents)
NewAcc))))
(put . (defun shen/put
(X Pointer Y Dict)
(let* ((Contents (shen/<-address Dict 3))
(X-Contents (shen/<-address Contents X)))
(if X-Contents
(progn
(puthash Pointer Y X-Contents)
Y)
(progn
(setq X-Contents (shen/absvector 100))
(puthash X X-Contents Contents)
(puthash Pointer Y X-Contents)
Y)))))
(unput . (defun shen/unput
(X Pointer Dict)
(let* ((Contents (shen/<-address Dict 3))
(X-Contents (shen/<-address Contents X)))
(progn
(if X-Contents
(remhash Pointer X-Contents))
X))))
(get . (defun shen/get
(X Pointer Dict)
(let* ((Contents (shen/<-address Dict 3))
(X-Contents (shen/<-address Contents X))
(Pointer-Contents (if X-Contents (shen/<-address X-Contents Pointer))))
(if (not Pointer-Contents)
(shen/simple-error "value not found")
Pointer-Contents))))))(setq shen/internal/*namespacing-overrides*
'((function . (defun shen/function (S)
(shen/shen\.lookup-func
(shen/internal/unprefix-symbol S))))))(setq shen/internal/*bugfix-overrides*
'((untrack . (defun shen/untrack (F)
(progn
(shen/set shen.*tracking*
(shen/internal/delete-first-eq
F
(shen/value shen.*tracking*)))
(shen/eval (shen/ps F)))))))Now that the mechanisms for applying functions, and quoting/namespacing are in place converting KLambda to Elisp is just a couple of function calls.
(defun shen/internal/kl-to-elisp (Kl)
(shen/internal/nil-to-null
(shen/internal/add-1+
(shen/internal/consolidate-tl
(shen/internal/consolidate-@s
(shen/internal/consolidate-cons (shen/internal/parse-ast Kl)))))))Evaluating KLambda to Elisp is straight forward except that a copy of the AST is
made when evaluating a defun. This is important because the AST is
destructively modified when compiled to Elisp and Shen requires the original
source for introspecting, profiling and tracking.
(defun shen/eval-kl (X)
(if (and (consp X) (eq (car X) 'defun))
(progn
(byte-compile (eval (shen/internal/kl-to-elisp (copy-tree X)) 't))
(nth 1 X))
(eval (shen/internal/kl-to-elisp X) 't)))Generating shen-elisp.el, the file that contains the Elisp compiled from the
bootstrap KLambda files, requires a slightly different approach because we
override the default generated Elisp with custom implementations. The overrides
from above are read into a hash table and will be spliced in below.
(defun shen/internal/add-overrides (overrides table)
(mapc
(lambda (override)
(puthash (car override)
(cdr override)
table))
overrides))
(setq shen/*overrides*
(let ((table (make-hash-table :test 'equal)))
(shen/internal/add-overrides
(append
shen/internal/*performance-overrides*
shen/internal/*dict-overrides*
shen/internal/*namespacing-overrides*
shen/internal/*bugfix-overrides*)
table)
table))When bootstrapping from the seed KLambda files we first need to patch the incoming code with overrides before parsing the AST:
(defun shen/patch-klambda (ast)
(if (eq (car ast) 'defun)
(let ((override (gethash (nth 1 ast) shen/*overrides*)))
(or override
(shen/internal/parse-ast ast)))
(let ((patched (gethash ast shen/*overrides* )))
(or patched
(shen/internal/parse-ast ast)))))When saving the seed KLambda code to a file, first patch, then optimize and then append to the end of the buffer.
(defun shen/kl-to-buffer (X B)
(with-current-buffer B
(save-excursion
(goto-char (point-max))
(insert (pp-to-string
(shen/internal/nil-to-null
(shen/internal/add-1+
(shen/internal/consolidate-tl
(shen/internal/consolidate-@s
(shen/internal/consolidate-cons
(shen/patch-klambda X)))))))))))(provide 'shen-primitives)Override of some of Shen’s default implementations.
;; Copyright (c) 2015-2018 Aditya Siram. All Rights Reserved.
;; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-ClauseOverlay the routines that take input from the user in the REPL session to use the mini-buffer
(defun shen/y-or-n? (S)
(progn
(shen/shen.prhush (shen/shen.proc-nl S) (shen/stoutput))
(let ((Input (format "%s" (read-from-minibuffer " (y/n) " ))))
(cond
((string-equal Input "y") 'true)
((string-equal Input "n") 'false)
(t (progn
(shen/shen.prhush "please answer y or n~%" (shen/stoutput))
(shen/y-or-n? S)))))))
(defun shen/shen.pause-for-user nil
(let ((Byte (read-from-minibuffer "")))
(if (and (= 1 (length Byte)) (= (string-to-char Byte) ?^))
(shen/simple-error "input aborted\n")
(shen/nl 1))))When changing directories in the REPL, for convenience, also change Emacs’ working directory.
(defun shen/cd (Path)
(if (shen/internal/shen->predicate (shen/= Path ""))
(shen/set '*home-directory* "")
(let ((PathString (concat Path "/")))
(progn
(setq default-directory PathString)
(shen/set '*home-directory* PathString))
PathString)))(provide 'shen-overlays);; -*- lexical-binding: t -*-
;; Copyright (c) 2015-2018 Aditya Siram. All Rights Reserved.
;; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause(require 'comint)
(require 'shen-primitives)
(require 'shen-elisp)
(require 'shen-overlays)The credits that appear at the top of each REPL session.
(defconst shen/shen.credits
(format "%s\n%s\n%s\n%s\n\n"
"Shen, copyright (C) 2010-2015 Mark Tarver"
(format "www.shenlanguage.org, %s" (shen/value '*version*))
(format "running under %s, implementation: %s" (shen/value '*language*) (shen/value '*implementation*))
(format "port %s ported by %s" (shen/value '*port*) (shen/value '*porters*))))The Shen REPL prompt looks like (0-) and (100+) where the number is a
counter of the number of REPL interactions so far and the - and + indicate
whether typechecking is currently enabled.
First we tell the REPL how to recognize prompts:
(defconst shen/repl-prompt-regex
(rx line-start
(char ?( )
(1+ digit)
(or (char ?-) (char ?+))
(char ?))
(char ? )))and make them:
(defun shen/make-prompt nil
(format "(%d%s) "
(shen/length (shen/value 'shen.*history*))
(if (shen/internal/shen->predicate (shen/value 'shen.*tc*))
"+"
"-")))In addition to evaluating input, the REPL also provides some rudimentary
completion support. Hitting TAB when inside a string tries to complete a
filename using comint-filename-completion. shen/repl-complete-filename is a
copy of ielm-complete-filename.
‘TAB’ after an open paren presents a list of Shen functions in scope. Since Shen
functions are just Elisp functions prefixed with “shen/” we use mapatoms to
iterate over all the symbols and functions and keep only the prefixed functions
as completion candidates. Other that shen/repl-completion-at-point pretty much
copies elisp-completion-at-point.
(defvar shen/repl-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-j" 'shen/repl-send-input)
(define-key map "\C-m" 'shen/repl-return)
(define-key map "\t" 'shen/repl-tab)
map))
(defvaralias 'shen/repl-mode-map 'shen/repl-map)
(defun shen/repl-return nil
(interactive)
(shen/repl-send-input))
(defun shen/repl-tab nil
(interactive)
(completion-at-point))
(defun shen/repl-complete-filename nil
(when (nth 3 (parse-partial-sexp comint-last-input-start (point)))
(comint-filename-completion)))
(defun shen/repl-completion-at-point nil
(let* ((pos (point))
(beg (condition-case nil
(save-excursion
(backward-sexp 1)
(point))
(scan-error pos)))
(end
(unless (or (eq beg (point-max))
(member (char-syntax (char-after beg))
'(?\s ?\" ?\( ?\))))
(condition-case nil
(save-excursion
(goto-char beg)
(forward-sexp 1)
(when (>= (point) pos)
(point)))
(scan-error pos))))
(shen-functions
(let ((res (make-vector 100 0)))
(mapatoms
(lambda (S)
(if (and (fboundp S) (string-prefix-p shen/prefix (symbol-name S)))
(intern (substring (symbol-name S) (length shen/prefix))
res))))
res)))
(list beg end shen-functions
:annotation-function #'shen/repl-annotate-type-or-arity)))
(defun shen/repl-annotate-type-or-arity (S)
(let ((signature (member-if (lambda (F) (string-equal (symbol-name (car F)) S)) shen/shen.*signedfuncs*)))
(if signature
(format " : %s" (cdr (car signature)))
(let ((arity (condition-case ex (shen/arity S) ('error -1))))
(if (not (eq arity -1))
(format "%d" arity)
"")))))(defvar shen/repl-input)
(defun shen/repl-send-input nil
(interactive)
(progn
(comint-send-input)
(condition-case ex
(progn
(shen/shen.initialise_environment)
(shen/repl-eval (string-to-list shen/repl-input)))
('error
(comint-output-filter (shen/repl-process) (format "%s\n%s" ex (shen/make-prompt)))
(signal (car ex) (cdr ex))))
(with-current-buffer *shen-repl*
(goto-char (point-max)))))The following is a cut-and-paste of ielm-standard-output-impl which apparently
does not exist in older versions of Emacs (a user reported a bug on 24.4.1).
It periodically writes to the REPL.
(defun shen/repl-standard-output-impl (process)
(let* ((output-buffer nil)
(flush-timer nil)
(flush-buffer
(lambda ()
(comint-output-filter
process
(apply #'string (nreverse output-buffer)))
(redisplay)
(setf output-buffer nil)
(when flush-timer
(cancel-timer flush-timer)
(setf flush-timer nil)))))
(lambda (char)
(let (flush-now)
(cond ((and (eq char t) output-buffer)
(setf flush-now t))
((characterp char)
(push char output-buffer)))
(if flush-now
(funcall flush-buffer)
(unless flush-timer
(setf flush-timer (run-with-timer 0.1 nil flush-buffer))))))))(defun shen/repl-process nil
;; Return the current buffer's process.
(get-buffer-process (current-buffer)))
(defun shen/repl-eval (input-string)
(let* ((active-process (shen/repl-process))
(shen/repl-temp-buffer)
(clean-up (lambda (active-process &optional ex)
(progn
(funcall (shen/value '*stoutput*) t)
(comint-output-filter active-process
(if ex
(format "\n%s\n\n%s" (nth 1 ex) (shen/make-prompt))
(format "\n%s" (shen/make-prompt))))
(shen/set '*stoutput* standard-output)))))
(condition-case ex
(progn
(shen/set '*stoutput* (shen/repl-standard-output-impl active-process))
(set-buffer (get-buffer *shen-repl*))
(let* ((Lineread
(shen/compile #'shen/shen.<st_input> input-string
(lambda (Err) (signal (car Err) (cdr Err)))))
(It (shen/shen.record-it input-string))
(History (shen/value 'shen.*history*))
(NewLineread (shen/shen.retrieve-from-history-if-needed
(shen/@p Lineread input-string)
History))
(NewHistory (shen/shen.update_history NewLineread History))
(Parsed (shen/fst NewLineread)))
(if (not Parsed)
(funcall clean-up active-process)
(progn
(shen/shen.toplevel Parsed)
(funcall (shen/value '*stoutput*) t)
(comint-output-filter active-process (format "\n%s" (shen/make-prompt)))))))
('shen/error (funcall clean-up active-process ex)))))(defconst shen/syntax-table
(let ((table (make-syntax-table lisp-mode-syntax-table)))
(modify-syntax-entry 59 "_") ;; semi-colon
(modify-syntax-entry ?, "_")
(modify-syntax-entry ?# "_")
(modify-syntax-entry ?' "_")
(modify-syntax-entry ?` "_")
table))
(defun shen/repl-input-sender (_proc input)
(setq shen/repl-input input))
(defun shen/repl-pm nil
;; Return the process mark of the current buffer.
(process-mark (get-buffer-process (current-buffer))))
(defun shen/repl-set-pm (pos)
;; Set the process mark in the current buffer to POS.
(set-marker (process-mark (get-buffer-process (current-buffer))) pos))
(define-derived-mode shen/repl-mode comint-mode "shen-repl-mode"
:syntax-table shen/syntax-table
(setq comint-prompt-regexp shen/repl-prompt-regex)
(setq comint-use-prompt-regexp t)
(setq comint-prompt-read-only t)
(setq comint-input-sender 'shen/repl-input-sender)
(setq-local comment-use-syntax 'undecided)
(set (make-local-variable 'completion-at-point-functions)
'(comint-replace-by-expanded-history
shen/repl-complete-filename
shen/repl-completion-at-point))
(unless (comint-check-proc (current-buffer))
(condition-case nil
(start-process "shen/repl" (current-buffer) "cat")
(file-error (start-process "shen/repl" (current-buffer) "hexl")))
(set-process-query-on-exit-flag (shen/repl-process) nil)
(goto-char (point-max))
(set (make-local-variable 'comint-inhibit-carriage-motion) t)
(insert shen/shen.credits)
(shen/repl-set-pm (point-max))
(comint-output-filter (shen/repl-process) "(0-) ")
(set-marker comint-last-input-start (shen/repl-pm))
(set-process-filter (get-buffer-process (current-buffer)) 'comint-output-filter)))
(defconst *shen-repl* "*shen-repl*");;;###autoload
(defun shen/repl nil
(interactive)
(let (old-point)
(unless (get-buffer *shen-repl*)
(with-current-buffer (get-buffer-create *shen-repl*)
(make-local-variable 'lexical-binding)
(load "shen-primitives")
(load "shen-elisp")
(load "shen-overlays")
(setq lexical-binding 't)
(shen/set 'shen.*history* '())
(shen/set '*home-directory* "")
(shen/set 'shen.*tc* 'false)
(unless (zerop (buffer-size)) (setq old-point (point)))
(shen/repl-mode)))
(switch-to-buffer *shen-repl*)
(when old-point (push-mark old-point))))(provide 'shen-repl)Bootstrapping a Shen environment involves
- collecting all the KLambda files in the “KLambda” directory in this package into a variable
- modifying the Elisp reader so it doesn’t choke on what it would consider illegal symbols in KLambda
- iterating over the KLambda files, parse out and evaluate KLambda s-expressions
- providing a runner that kicks off the process
In order to bootstrap the environment we specify the location of all the KLambda files
that need to be read in and compiled. They are located in the KLambda directory of this
package.
(require 'shen-primitives)
(setq *klambda-directory-name* "KLambda")
(setq *klambda-directory* (file-name-as-directory (concat (file-name-directory load-file-name) *klambda-directory-name*)))
(setq *klambda-files*
(mapcar (lambda (klFile) (concat *klambda-directory* klFile))
'("toplevel.kl" "core.kl" "sys.kl" "dict.kl" "sequent.kl"
"yacc.kl" "reader.kl" "prolog.kl" "track.kl" "load.kl"
"writer.kl" "macros.kl" "declarations.kl" "t-star.kl" "types.kl")))In order to read in the KLambda s-expressions using the Elisp reader we need to make some adjustments due to the differences between KLambda and Elisp.
In KLambda semicolons, colons, commas, ticks and backquotes are valid symbols. Since they have
different meanings in Elisp they will be rejected by the reader by default so we
need to insert them as regular symbols into a temporary syntax-table and then
parse out the s-expressions.
(setq shen/*klambda-syntax-table*
(let ((table (make-syntax-table lisp-mode-syntax-table)))
(modify-syntax-entry 59 "_" table) ;; semi-colon
(modify-syntax-entry ?, "_" table)
(modify-syntax-entry ?# "_" table)
(modify-syntax-entry ?' "_" table)
(modify-syntax-entry ?` "_" table)
table))
(defun shen/get-klambda-sexp-strings (klambda-file)
(with-temp-buffer
(insert-file-contents klambda-file)
(with-syntax-table shen/*klambda-syntax-table*
(let* ((klambda-code (buffer-string))
(current-sexp-end (scan-lists 0 1 0))
(groups nil))
(progn
(while current-sexp-end
(let ((current-sexp-start (scan-lists current-sexp-end -1 0)))
(progn
(setq groups (nconc groups (list (buffer-substring current-sexp-start current-sexp-end))))
(setq current-sexp-end (scan-lists current-sexp-end 1 0)))))
groups)))))Even though simply changing the syntax table works for parsing the s-expressions as strings, the Elisp reader will still choke on illegal characters.
Each of those forbidden characters is encoded as a string that is unlikely to
occur in the normal course of events (hopefully). The name of the character is
interleaved with its reverse and prefixed an _. So, for example, # , spelled
“hash” becomes “_hhassahh” which is the interleaving of “hash” and “hsah” with a
leading underscore.
The mappings are stored in an alist and forward and reverse lookup functions are provided
(setq shen/*illegal-character->spelling*
'((59 "_sneomlioccoilmoens") ;; semicolon
(?, "_caommmmoac")
(35 "_hhassshh") ;; hash
(?' "_tkiccikt")
(?` "_beatcokuqqukoctaeb")))
(setq shen/*spelling->illegal-character*
(mapcar #'reverse shen/*illegal-character->spelling*))With the mapping in place the klambda s-expressions can be sanitized for the Elisp reader:
(defun shen/remove-reserved-elisp-characters (klambda-sexp-string)
(let ((InString nil)
(illegal-characters
(mapcar
(lambda (char->spelling) (nth 0 char->spelling))
shen/*illegal-character->spelling*))
(res)
(curr klambda-sexp-string))
(cl-flet ((append-and-advance
(&optional X)
(progn
(if X (setq res (concat res X))
(setq res (concat res (substring curr 0 1))))
(setq curr (substring curr 1)))))
(while (not (= 0 (length curr)))
(cond
((char-equal (string-to-char curr) ?\")
(if InString
(progn
(setq InString nil)
(append-and-advance))
(progn
(setq InString 't)
(append-and-advance))))
((memq (string-to-char curr) illegal-characters)
(if InString
(append-and-advance)
(append-and-advance
(car (assoc-default
(string-to-char curr)
shen/*illegal-character->spelling*)))))
(t (append-and-advance))))
res)))Once the reader has accepted the s-expression, the symbols need to be switched back to their original spellings:
(defun shen/put-reserved-elisp-chars-back (sexp)
(let ((symbols (shen/find-symbols sexp)))
(shen/internal/modify-ast sexp
symbols
(lambda (path ast)
(shen/change-back (shen/internal/get-element-at path ast))))))To do so we need a function that iterates over a symbols and replaces the sanitized spelling with the original character:
(defun shen/change-back (symbol)
(let* ((original-length (length (symbol-name symbol)))
(string-left (symbol-name symbol))
(spelling->character
(let ((hash (make-hash-table)))
(mapc (lambda (spelling-character)
(puthash (nth 0 spelling-character) (nth 1 spelling-character) hash))
shen/*spelling->illegal-character*)
hash))
(spellings (hash-table-keys spelling->character))
(get-character-and-remaining
(lambda (S)
(let ((found-at-index (shen/internal/index-of (lambda (spelling) (string-prefix-p spelling S)) spellings)))
(if found-at-index
(let ((spelling (nth found-at-index spellings)))
(list (string (gethash spelling spelling->character))
(substring S (length spelling))))
(list (string (aref S 0))
(substring S 1))))))
(reversed-result))
(while (> (length string-left) 0)
(let ((character-and-remaining (funcall get-character-and-remaining string-left)))
(push (nth 0 character-and-remaining) reversed-result)
(setq string-left (nth 1 character-and-remaining))))
(intern (apply #'concat (reverse reversed-result)))))And a function that collects paths to all symbols in an s-expression:
(defun shen/find-symbols (sexp)
(let ((symbols)
(current-path)
(current-list sexp)
(current-list-length (length sexp))
(current-index 0)
(locally-scoped-symbols)
(inner-lists))
(while (or (< current-index current-list-length)
inner-lists)
(cond
((and (= current-index current-list-length) inner-lists)
(progn
(setq current-path (car inner-lists))
(setq inner-lists (cdr inner-lists))
(setq current-list (shen/internal/get-element-at current-path sexp))
(setq current-index 0)
(setq current-list-length (length current-list))))
((< current-index current-list-length)
(let ((current-token (nth current-index current-list)))
(cond
((symbolp current-token)
(push (cons current-index current-path) symbols))
((consp current-token)
(push (cons current-index current-path)
inner-lists))
(t nil))
(setq current-index (+ current-index 1))))
(t nil)))
symbols))Now we can finally collect, and parse all the s-expressions in the
KLambda files and then pass the result to shen/eval-kl to transform
KLambda code into Elisp.
(setq *temp-shen-buffer*
(find-file-noselect
(concat (file-name-as-directory default-directory)
(file-relative-name "shen-elisp.el"))))
(defun eval-klambda-files (klambda-files)
(with-current-buffer *temp-shen-buffer*
(progn
(erase-buffer)
(insert "\
;;; shen-elisp.el --- An implementation of the Shen programming language -*- lexical-binding: t -*-
;; Copyright (C) 2015-2018 Aditya Siram
;; Author: Aditya Siram <aditya.siram@gmail.com>
;; Homepage: https://github.com/deech/shen-elisp
;; License: BSD 3-Clause License
;; http://opensource.org/licenses/BSD-3-Clause
;;; Commentary:
;; This is an implemenatation of the Shen programming language in
;; Elisp. The end goal is to provide:
;;
;; 1. An easy way to play with Shen with no other installation
;; hassle (assuming you use Emacs).
;; 2. A first-class development experience when writing Shen.
;; The idea is that an editor that understands the code can
;; be much more helpful than one that does not. To this end
;; the roadmap involves a full gamut of source code
;; introspection and debugging tools.
;;; Code:
(require 'shen-primitives)
(setq max-lisp-eval-depth 60000)
(setq max-specpdl-size 13000)\n\n")
(goto-char (point-max))
(dolist (klambda-file klambda-files nil)
(eval-klambda-file klambda-file))
(goto-char (point-max))
(insert (format "%s\n" "(provide 'shen-elisp)"))
(save-buffer))))
(defun eval-klambda-file (klambda-file)
(dolist (klambda-sexp-string (shen/get-klambda-sexp-strings klambda-file) nil)
(eval-klambda-sexp-string klambda-sexp-string)))
(defun eval-klambda-sexp-string (klambda-sexp-string)
(let ((ast (shen/put-reserved-elisp-chars-back
(read
(shen/remove-reserved-elisp-characters
klambda-sexp-string)))))
(shen/kl-to-buffer ast *temp-shen-buffer*)))(defun compile-and-load (F)
(byte-compile-file
(concat (file-name-as-directory default-directory)
(file-relative-name F))
't))
(defun load-klambda () (eval-klambda-files *klambda-files*))
(defun load-only ()
(progn
(compile-and-load "shen-primitives.el")
(compile-and-load "install.el")))
(defun runner ()
(progn
(compile-and-load "shen-primitives.el")
(compile-and-load "install.el")
(eval-klambda-files *klambda-files*)
(compile-and-load "shen-elisp.el")
(compile-and-load "shen-overlays.el")
(compile-and-load "shen-repl.el")
(add-to-list 'load-path default-directory)
(shen/repl)))