concat support

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 3c6ce6e5828a1be2490b8cf34e84985d9b200718..ddebc295b4d1c3498bbba00de5c346b58d7722d1 100644 (file)
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -297,18 +297,21 @@ If the calle function is known to have a return type propagate it."
 
 (defun comp-limplify-lap-inst (inst)
   "Limplify LAP instruction INST accumulating in `comp-limple'."
-  (let ((op (car inst)))
+  (let ((op (car inst))
+        (arg (if (consp (cdr inst))
+                 (cadr inst)
+               (cdr inst))))
     (comp-op-case
       (byte-stack-ref
        (comp-copy-slot-n (- (comp-sp) (cdr inst) 1)))
       (byte-varref
        (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar
                                                   :const-vld t
-                                                  :constant (cadr inst)))))
+                                                  :constant arg))))
       (byte-varset
        (comp-emit `(call set_internal
                          ,(make-comp-mvar :const-vld t
-                                          :constant (cadr inst))
+                                          :constant arg)
                          ,(comp-slot))))
       (byte-varbind)
       (byte-call)
@@ -356,9 +359,12 @@ If the calle function is known to have a return type propagate it."
       (byte-fset)
       (byte-get)
       (byte-substring)
-      (byte-concat2)
-      (byte-concat3)
-      (byte-concat4)
+      (byte-concat2
+       (comp-emit-set-call `(callref Fconcat 2 ,(comp-sp))))
+      (byte-concat3
+       (comp-emit-set-call `(callref Fconcat 3 ,(comp-sp))))
+      (byte-concat4
+       (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp))))
       (byte-sub1)
       (byte-add1)
       (byte-eqlsign)
@@ -411,8 +417,7 @@ If the calle function is known to have a return type propagate it."
       (byte-goto-if-nil-else-pop)
       (byte-goto-if-not-nil-else-pop)
       (byte-return
-       (comp-emit (list 'return (comp-slot-next)))
-       `(return ,(comp-slot-next)))
+       (comp-emit (list 'return (comp-slot-next))))
       (byte-discard t)
       (byte-dup
        (comp-copy-slot-n (1- (comp-sp))))
@@ -450,14 +455,16 @@ If the calle function is known to have a return type propagate it."
       (byte-numberp)
       (byte-integerp)
       (byte-listN)
-      (byte-concatN)
+      (byte-concatN
+       (comp-stack-adjust (- (1- arg)))
+       (comp-emit-set-call `(callref Fconcat ,arg ,(comp-sp))))
       (byte-insertN)
       (byte-stack-set)
       (byte-stack-set2)
       (byte-discardN)
       (byte-switch)
       (byte-constant
-       (comp-set-const (cadr inst))))))
+       (comp-set-const arg)))))
 
 (defun comp-limplify (func)
   "Given FUNC and return compute its LIMPLE ir."

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 1030900752d24148d5650ba8cd442f13f3cca97b..d3b2929abfc4bdc9bd5d0bf5ba4b63a6a0542581 100644 (file)
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -132,14 +132,14 @@
 
   (should (= (comp-tests-symbol-value-f) 3)))
 
-;; (ert-deftest  comp-tests-concat ()
-;;   "Testing concatX opcodes."
-;;   (defun comp-tests-concat-f (x)
-;;     (concat "a" "b" "c" "d"
-;;             (concat "a" "b" "c" (concat "a" "b" (concat "foo" x)))))
-;;   (native-compile #'comp-tests-concat-f)
-
-;;   (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar")))
+(ert-deftest  comp-tests-concat ()
+  "Testing concatX opcodes."
+  (defun comp-tests-concat-f (x)
+    (concat "a" "b" "c" "d"
+            (concat "a" "b" "c" (concat "a" "b" (concat "foo" x)))))
+  (native-compile #'comp-tests-concat-f)
+
+  (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar")))
 
 ;; (ert-deftest  comp-tests-ffuncall ()
 ;;   "Test calling conventions."