Fix #667 equality tests in elisp and powershell

impls/elisp/Dockerfile

@@ -1,4 +1,4 @@
-FROM ubuntu:20.04
+FROM ubuntu:24.04
 MAINTAINER Joel Martin <[email protected]>
 
 ##########################################################

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)