compiler: rearrange handling of calls

* share/txr/stdlib/compiler.tl (compiler compile): Open up the
main caseq statement for handling symbols other than just
special operators. Now we handle the compiler-only special
operator sys:ift here, as well as the special casing for call
and apply. Function calls are handled as the fallback case
here now.
(compiler call-fun-form): Remove the checking for ift, and for
call, apply and usr:apply. Only regular case function calls
are handled here now.
(compiler comp-apply-call): New method dedicated for compiling
calls to the call, apply or usr:apply functions, dispatched
directly out of compiler compile.

1 files changed, 37 insertions, 33 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 108c75b4..75ecdef0 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -287,7 +287,7 @@
     ((atom form) me.(comp-atom oreg form))
     (t (let ((sym (car form)))
          (cond
-           ((special-operator-p sym)
+           ((bindable sym)
             (caseq sym
               (quote me.(comp-atom oreg (cadr form)))
               (sys:setq me.(comp-setq oreg env form))
@@ -327,6 +327,11 @@
               (sys:upenv me.(compile oreg env.up (cadr form)))
               (sys:dvbind me.(compile oreg env (caddr form)))
               (sys:load-time-lit me.(comp-load-time-lit oreg env form))
+              ;; compiler-only special operators:
+              (ift me.(comp-ift oreg env form))
+              ;; specially treated functions
+              ((call apply usr:apply) me.(comp-apply-call oreg env form))
+              ;; error cases
               ((macrolet symacrolet macro-time)
                (compile-error form "unexpanded ~s encountered" sym))
               ((sys:var sys:expr)
@@ -334,9 +339,8 @@
               ((usr:qquote usr:unquote usr:splice
                            sys:qquote sys:unquote sys:splice)
                (compile-error form "unexpanded quasiquote encountered"))
-              (t
-                (compile-error form "unrecognized special operator ~s" sym))))
-           ((bindable sym) me.(comp-fun-form oreg env form))
+              ;; function call
+              (t me.(comp-fun-form oreg env form))))
            ((and (consp sym)
                  (eq (car sym) 'lambda)) me.(compile oreg env ^(call ,*form)))
            (t (compile-error form "invalid operator")))))))
@@ -1027,35 +1031,35 @@
                  form (cons sym args)))
          ((identity + * min max) (return-from comp-fun-form
                                    me.(compile oreg env (car args)))))))
-    (caseql sym
-      ((call apply usr:apply)
-       (let ((gopcode [%gcall-op% sym])
-             (opcode [%call-op% sym]))
-         (tree-case (car args)
-           ((op arg . more)
-            (caseq op
-              (fun (cond
-                     (more (compile-error form "excess args in fun form"))
-                     ((bindable arg)
-                      (let ((fbind env.(lookup-fun arg t)))
-                        me.(comp-call-impl oreg env (if fbind opcode gopcode)
-                                           (if fbind fbind.loc me.(get-sidx arg))
-                                           (cdr args))))
-                     ((and (consp arg) (eq (car arg) 'lambda))
-                      me.(comp-fun-form oreg env ^(,sym ,arg ,*(cdr args))))
-                     (t :)))
-              (lambda me.(comp-inline-lambda oreg env opcode
-                                             (car args) (cdr args)))
-              (t :)))
-           (arg me.(comp-call oreg env
-                              (if (eq sym 'usr:apply) 'apply sym) args)))))
-      (ift me.(comp-ift oreg env form))
-      (t (let* ((fbind env.(lookup-fun sym t))
-                (cfrag me.(comp-call-impl oreg env (if fbind 'call 'gcall)
-                                          (if fbind fbind.loc me.(get-sidx sym))
-                                          args)))
-           (pushnew sym cfrag.ffuns)
-           cfrag)))))
+    (let* ((fbind env.(lookup-fun sym t))
+           (cfrag me.(comp-call-impl oreg env (if fbind 'call 'gcall)
+                                     (if fbind fbind.loc me.(get-sidx sym))
+                                     args)))
+      (pushnew sym cfrag.ffuns)
+      cfrag)))
+
+(defmeth compiler comp-apply-call (me oreg env form)
+  (tree-bind (sym . args) form
+    (let ((gopcode [%gcall-op% sym])
+          (opcode [%call-op% sym]))
+      (tree-case (car args)
+        ((op arg . more)
+         (caseq op
+           (fun (cond
+                  (more (compile-error form "excess args in fun form"))
+                  ((bindable arg)
+                   (let ((fbind env.(lookup-fun arg t)))
+                     me.(comp-call-impl oreg env (if fbind opcode gopcode)
+                                        (if fbind fbind.loc me.(get-sidx arg))
+                                        (cdr args))))
+                  ((and (consp arg) (eq (car arg) 'lambda))
+                   me.(comp-fun-form oreg env ^(,sym ,arg ,*(cdr args))))
+                  (t :)))
+           (lambda me.(comp-inline-lambda oreg env opcode
+                                          (car args) (cdr args)))
+           (t :)))
+        (arg me.(comp-call oreg env
+                           (if (eq sym 'usr:apply) 'apply sym) args))))))
 
 (defmeth compiler comp-call (me oreg env opcode args)
   (tree-bind (fform . fargs) args