Bug fix: eval order in href/@ compiler macros

Make the compiler macros for href and @ preserve left-to-right
argument order evaluation.

Also, redefine the expansion of @ in terms of href.

Author: ruricolist

hash-tables.lisp

@@ -192,8 +192,15 @@ As soon as one of KEYS fails to match, DEFAULT is returned."
    keys
    :initial-value table))
 
-(define-compiler-macro href (table &rest keys)
-    (expand-href table keys))
+(define-compiler-macro href (table key &rest keys)
+  (let* ((keys (cons key keys))
+         (table-tmp (gensym (string 'table)))
+         (key-tmps
+           (make-gensym-list (length keys)
+                             (string 'key))))
+    `(let ((,table-tmp ,table)
+           ,@(mapcar #'list key-tmps keys))
+       ,(expand-href table-tmp key-tmps))))
 
 (define-compiler-macro (setf href) (value table &rest keys)
   `(setf ,(expand-href table keys) ,value))
@@ -212,16 +219,11 @@ As soon as one of KEYS fails to match, DEFAULT is returned."
         (rec (gethash (car keys) table) (cdr keys))
         (setf (gethash (car keys) table) value))))
 
-(flet ((expand-@ (table keys)
-         (reduce
-          (lambda (table key)
-            `(gethash ,key ,table))
-          keys
-          :initial-value table)))
-  (define-compiler-macro @ (table key &rest keys)
-      (expand-@ table (cons key keys)))
-  (define-compiler-macro (setf @) (value table key &rest keys)
-    `(setf ,(expand-@ table (cons key keys)) ,value)))
+(define-compiler-macro @ (table key &rest keys)
+    `(href ,table ,key ,@keys))
+
+(define-compiler-macro (setf @) (value table key &rest keys)
+  `(setf (href ,table ,key ,@keys) ,value))
 
 (-> pophash (t hash-table) (values t boolean &optional))
 (defun pophash (key hash-table)

tests/hash-tables.lisp

@@ -137,3 +137,17 @@
   (dolist (test '(eq eql equal equalp))
     (is (hash-table-test-p (symbol-function test))))
   (is (not (hash-table-test-p #'car))))
+
+(test href-eval-order
+  (let ((table (dict))
+        (list '())
+        (y 0))
+    (href (progn (push 2 list) table)
+          (push 1 list))
+    (is (equal list '(1 2))))
+  (let ((table (dict))
+        (list '())
+        (y 0))
+    (@ (progn (push 2 list) table)
+       (push 1 list))
+    (is (equal list '(1 2)))))