elisp: fix new tests, byte-compile, various improvements

The original motivation is to fix the new (= nil ()) and
core_apply_accepts_macros tests.
Improve speed and warnings with byte compilation.

mal/core.el:
Wrap core functions during the loop in main, instead of writing the
conversion in each line of core-ns.
Use apply built-in concatenation of last argument.
Move handling of metadata to types.el.

mal/env.el:
Represent environments as cons cells instead of vectors.

mal/func.el:
Merged into types.el, it is not a special case anymore.

mal/printer.el:
Add macro case.
Define a pr-join helper for sequences and core.el.

mal/reader.el:
Rename the tokens local variable in reader.el (compiler warning).

mal/types.el:
Use type-specific accessors returning nil for the wrong type
(structural pattern matching would be better, but is too slow).
Represent native types directly when possible, and inline some trivial
accessors.
Use dedicated records instead of vectors.
Implement metadata only when required.
Represent keywords as strings (easyer, no counterpart).

run:
Run byte-compiled version.

steps:
Backport good ideas from stepA to step1, reducing the diff between
steps for future maintenance.
Implement 'do with a simple iteration (without map and butlast).
Make the repl-env local to main (compiler warning).

Make the code more idiomatic
 * prefer loop over recursion (search in environments)
 * declare variable and reassign them when convenient (exit of the TCO loop)
 * car cdr cadr and so on instead of nth
 * remove various vector <-> list conversions.

impls/elisp/Makefile

@@ -1,3 +1,9 @@
 all:
+	emacs -Q --batch -L . --eval '(byte-recompile-directory "." 0)'
+
+# For debugging, it is sometimes useful to attempt a run without byte compation.
+nocompile: clean
+	exec emacs -Q --batch -L . --eval "(setq text-quoting-style 'straight)" --load stepA_mal.el
 
 clean:
+	rm -f *.elc *~ mal/*.elc mal/*~

impls/elisp/mal/env.el

@@ -1,28 +1,27 @@
+(require 'mal/types)
+
+;; An env is represented by an elisp list of hash-tables. In other words
+;;  * car: a hash-table
+;;  * cdr: the outer environment or ()
+;; Keys are elisp symbols.
+
 (defun mal-env (&optional outer binds exprs)
-  (let ((env (vector 'env (vector (make-hash-table :test 'eq) outer))))
-    (while binds
-      (let ((key (pop binds)))
-        (if (eq key '&)
-            (let ((key (pop binds))
-                  (value (mal-list exprs)))
-              (mal-env-set env key value)
-              (setq binds nil
-                    exprs nil))
-          (let ((value (pop exprs)))
-            (mal-env-set env key value)))))
+  (let ((env (cons (make-hash-table :test 'eq) outer))
+        key)
+    (while (setq key (pop binds))
+      (if (eq key '&)
+          (mal-env-set env (pop binds) (mal-list exprs))
+        (mal-env-set env key (pop exprs))))
     env))
 
 (defun mal-env-set (env key value)
-  (let ((data (aref (aref env 1) 0)))
+  (let ((data (car env)))
     (puthash key value data)))
 
 (defun mal-env-get (env key)
-  (let* ((data (aref (aref env 1) 0))
-         (value (gethash key data)))
-    (or value
-        (let ((outer (aref (aref env 1) 1)))
-          (if outer
-            (mal-env-get outer key)
-            nil)))))
+  (let (value)
+    (while (and (not (setq value (gethash key (pop env))))
+                env))
+    value))
 
 (provide 'mal/env)

impls/elisp/mal/printer.el

@@ -1,59 +1,60 @@
-(require 'cl-lib)
+(require 'mal/types)
 
-(defun pr-str (form &optional print-readably)
-  (let ((value (mal-value form)))
-    (cl-ecase (mal-type form)
-     ('nil
+(defun pr-str (form print-readably)
+  (let (value)
+    (cond
+     ((eq mal-nil form)
       "nil")
-     (true
+     ((eq mal-true form)
       "true")
-     (false
+     ((eq mal-false form)
       "false")
-     (number
+     ((setq value (mal-number-value form))
       (number-to-string value))
-     (string
+     ((setq value (mal-string-value form))
       (if print-readably
           (let ((print-escape-newlines t))
             (prin1-to-string value))
         value))
-     ((symbol keyword)
+     ((setq value (mal-symbol-value form))
       (symbol-name value))
-     (list
+     ((setq value (mal-keyword-value form))
+      value)
+     ((setq value (mal-list-value form))
       (pr-list value print-readably))
-     (vector
+     ((mal-list-p form)
+      "()")
+     ((setq value (mal-vector-value form))
       (pr-vector value print-readably))
-     (map
+     ((setq value (mal-map-value form))
       (pr-map value print-readably))
-     (fn
-      "#<fn>")
-     (func
-      "#<func>")
-     (atom
-      (format "(atom %s)" (pr-str value print-readably))))))
+     ((or (mal-fn-core-value form) (mal-func-value form))
+      "#<function>")
+     ((mal-macro-value form)
+      "#<macro>")
+     ((setq value (mal-atom-value form))
+      (format "(atom %s)" (pr-str value print-readably)))
+     (t (error "pr-str: unknown type: %s" form)))))
 
 (defun pr-list (form print-readably)
-  (let ((items (mapconcat
-                (lambda (item) (pr-str item print-readably))
-                form " ")))
+  (let ((items (pr-join form print-readably " ")))
     (concat "(" items ")")))
 
 (defun pr-vector (form print-readably)
-  (let ((items (mapconcat
-                (lambda (item) (pr-str item print-readably))
-                (append form nil) " ")))
+  (let ((items (pr-join form print-readably " ")))
     (concat "[" items "]")))
 
 (defun pr-map (form print-readably)
   (let (pairs)
     (maphash
      (lambda (key value)
-       (push (cons (pr-str key print-readably)
-                   (pr-str value print-readably))
-             pairs))
+       (push value pairs)
+       (push key pairs))
      form)
-    (let ((items (mapconcat
-                  (lambda (item) (concat (car item) " " (cdr item)))
-                  (nreverse pairs) " ")))
+    (let ((items (pr-join pairs print-readably " ")))
       (concat "{" items "}"))))
 
+(defun pr-join (forms print-readably separator)
+  (mapconcat (lambda (item) (pr-str item print-readably)) forms separator))
+
 (provide 'mal/printer)

impls/elisp/mal/reader.el

@@ -1,20 +1,20 @@
-(require 'cl-lib)
+(require 'mal/types)
 
 ;; HACK: `text-quoting-style' prettifies quotes in error messages on
 ;; Emacs 25, but no longer does from 26 upwards...
 (when (= emacs-major-version 25)
   (setq text-quoting-style 'grave))
 
-(defvar tokens nil)
+(defvar reader--tokens nil)
 
 (defun peek ()
-  (car tokens))
+  (car reader--tokens))
 
 (defun next ()
-  (pop tokens))
+  (pop reader--tokens))
 
 (defun read-str (input)
-  (setq tokens (tokenizer input))
+  (setq reader--tokens (tokenizer input))
   (read-form))
 
 (defun tokenizer (input)
@@ -149,7 +149,7 @@
               (mal-string (read token))
             (signal 'unterminated-sequence '(string))))
          ((= (aref token 0) ?:)
-          (mal-keyword (intern token)))
+          (mal-keyword token))
          (t
           ;; assume anything else is a symbol
           (mal-symbol (intern token))))

impls/elisp/mal/types.el

@@ -1,45 +1,95 @@
-;;; general accessors
+;; Structural pattern matching is ideal, but too slow for MAL.
 
-(defun mal-type (mal-object)
-  (aref mal-object 0))
-
-(defun mal-value (mal-object)
-  (aref mal-object 1))
-
-(defun mal-meta (mal-object)
-  (aref mal-object 2))
-
-;;; objects
+;; So we use a mal-foo-value getter that returns nil in case of bad
+;; type (or if a list is empty, unfortunately).
 
 (defmacro mal-object (name)
   (let ((constructor (intern (format "mal-%s" name)))
-        (predicate (intern (format "mal-%s-p" name))))
+        (accessor (intern (format "mal-%s-value" name))))
     `(progn
-       (defun ,constructor (&optional value meta)
-         (vector ',name value meta))
-       (defun ,predicate (arg)
-         (and (vectorp arg) (eq (aref arg 0) ',name))))))
-
-(mal-object nil)
-(mal-object true)
-(mal-object false)
-
-(defvar mal-nil (mal-nil))
-(defvar mal-true (mal-true 'true))
-(defvar mal-false (mal-false 'false))
-
-(mal-object number)
-(mal-object string)
-(mal-object symbol)
+       (defsubst ,constructor (value)
+         (record ',name value))
+       (defun ,accessor (arg)
+         (and (recordp arg)
+              (eq (aref arg 0) ',name)
+              (aref arg 1))))))
+
+(defconst mal-nil   #&8"n")
+(defconst mal-false #&8"f")
+(defconst mal-true  #&8"t")
+
+(defsubst mal-number (elisp-number) elisp-number)
+(defsubst mal-number-value (obj) (and (numberp obj) obj))
+
+(defsubst mal-symbol (elisp-symbol) elisp-symbol)
+;; A nil result means either 'not a symbol' or 'the nil symbol'.
+(defsubst mal-symbol-value (obj) (and (symbolp obj)obj))
+
+(defsubst mal-string (elisp-string) elisp-string)
+(defsubst mal-string-value (obj) (and (stringp obj) obj))
+
+;; In elisp, keywords are symbols.  Using them would cause confusion,
+;; or at least make mal-symbol-value more complex, for little benefit.
+;; The wrapped value is an elisp string including the initial colon.
 (mal-object keyword)
 
-(mal-object list)
-(mal-object vector)
-(mal-object map)
+;; Use the native type when possible, but #s(type value meta ...) for
+;; the empty list or when metadata is present.
+
+(defsubst mal-vector (elisp-vector) elisp-vector)
+(defun mal-vector-value (obj)
+  (if (vectorp obj)
+      obj
+    (and (recordp obj) (eq (aref obj 0) 'vector) (aref obj 1))))
+
+(defsubst mal-map (elisp-hash-table) elisp-hash-table)
+(defun mal-map-value (obj)
+  (if (hash-table-p obj)
+      obj
+    (and (recordp obj) (eq (aref obj 0) 'map) (aref obj 1))))
+
+(defconst mal-empty-list #s(list nil))
+(defsubst mal-list (elisp-list) (or elisp-list mal-empty-list))
+;; A nil result means either 'not a list' or 'empty list'.
+(defun mal-list-value (obj)
+  (if (listp obj) obj
+    (and (recordp obj) (eq (aref obj 0) 'list) (aref obj 1))))
+(defun mal-list-p (obj)
+  (or (listp obj)
+      (and (recordp obj) (eq (aref obj 0) 'list))))
+
+;; A nil result means either 'not a list' or 'empty list'.
+(defun mal-seq-value (arg) (or (mal-vector-value arg) (mal-list-value arg)))
 
 (mal-object atom)
-(mal-object fn)
-(mal-object func)
+(defun mal-reset (atom value) (setf (aref atom 1) value))
+
+(mal-object fn-core)
+(mal-object macro)
+
+;; Function created by fn*.
+(defsubst mal-func (value body params env)
+  (record 'func value body params env))
+(defun mal-func-value ( obj)
+  (and (recordp obj) (eq (aref obj 0) 'func) (aref obj 1)))
+(defsubst mal-func-body   (obj) (aref obj 2))
+(defsubst mal-func-params (obj) (aref obj 3))
+(defsubst mal-func-env    (obj) (aref obj 4))
+
+(defun with-meta (obj meta)
+  (cond
+   ((vectorp      obj)  (record 'vector obj meta))
+   ((hash-table-p obj)  (record 'map    obj meta))
+   ((listp        obj)  (record 'list   obj meta))
+   ((< (length obj) 4)  (record (aref obj 0) (aref obj 1) meta))
+   (t                   (record (aref obj 0) (aref obj 1)
+                                (aref obj 2) (aref obj 3)
+                                (aref obj 4) meta))))
+
+(defun mal-meta (obj)
+  (if (and (recordp obj) (member (length obj) '(3 6)))
+      (aref obj (1- (length obj)))
+    mal-nil))
 
 ;;; regex
 

impls/elisp/run

@@ -1,2 +1,3 @@
-#!/bin/bash
-exec emacs -Q --batch -L $(dirname $0) --eval "(setq text-quoting-style 'straight)" --load $(dirname $0)/${STEP:-stepA_mal}.el "${@}"
+#!/bin/sh
+dir=$(dirname $0)
+exec emacs -Q --batch -L $dir --eval "(setq text-quoting-style 'straight)" --load $dir/${STEP:-stepA_mal}.elc "${@}"

impls/elisp/step0_repl.el

@@ -7,24 +7,24 @@
 (defun PRINT (input)
   input)
 
+(defun rep (input)
+  (PRINT (EVAL (READ input))))
+
 (defun readln (prompt)
   ;; C-d throws an error
   (ignore-errors (read-from-minibuffer prompt)))
 
 (defun println (format-string &rest args)
-  (if (not args)
-      (princ format-string)
-    (princ (apply 'format format-string args)))
+  (princ (if args
+             (apply 'format format-string args)
+           format-string))
   (terpri))
 
 (defun main ()
-  (let (eof)
-    (while (not eof)
-      (let ((input (readln "user> ")))
-        (if input
-            (println input)
-          (setq eof t)
-          ;; print final newline
-          (terpri))))))
+  (let (input)
+    (while (setq input (readln "user> "))
+      (println (rep input)))
+    ;; print final newline
+    (terpri)))
 
 (main)