Handle case-lambda via a jump table

module/language/cps/compile-js.scm

@@ -30,29 +30,47 @@
 
 (define (compile-fun fun)
   (match fun
-    (($ $cont k ($ $kfun src meta self ($ $cont tail ($ $ktail)) clause))
+    (($ $cont k ($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause))
-     (make-var k (compile-clause clause self tail)))))
+     (call-with-values
+         (lambda ()
+           (extract-clauses self clause))
+       (lambda (jump-table clauses)
+         (make-var
+          k
+          (make-function
+           (list self tail)
+           (make-local (map (lambda (clause)
+                              (compile-clause clause self tail))
+                            clauses)
+                       (make-jump-table jump-table)))))))))
+
+(define (extract-clauses self clause)
+  (let loop ((clause clause) (specs '()) (clauses '()))
+    (match clause
+      (($ $cont k ($ $kclause ($ $arity req _ rest _ _) _ #f))
+       (values (reverse (cons (cons (make-params self req rest) k) specs))
+               (reverse (cons clause clauses))))
+      (($ $cont k ($ $kclause ($ $arity req _ rest _ _) _ alternate))
+       (loop alternate
+             (cons (cons (make-params self req rest) k) specs)
+             (cons clause clauses))))))
 
 (define (compile-clause clause self tail)
   (match clause
-    (($ $cont k ($ $kclause ($ $arity req opt rest kw allow-other-keys?)
+    (($ $cont k ($ $kclause ($ $arity req _ rest _) body _))
-         body alternate))
+     (make-var
-     ;; add function argument prelude
+      k
-     (unless (null? opt)
+      (make-continuation
-       (not-supported "optional arguments are not supported" clause))
+       (append (list self)
-     (unless (or (null? kw) allow-other-keys?)
+               req (if rest (list rest) '()))
-       (not-supported "keyword arguments are not supported" clause))
+       (match body
-     (when alternate
+         (($ $cont k ($ $kargs () () exp))
-       (not-supported "alternate continuations are not supported" clause))
+          (compile-term exp))
-     (make-function (make-params self (cons tail req) rest)
+         (($ $cont k _)
-                    (match body
+          (make-local (list (compile-cont body))
-                      (($ $cont k ($ $kargs () () exp))
+                      (make-continue
-                       (compile-term exp))
+                       k
-                      (($ $cont k _)
+                       (map make-id (append req (if rest (list rest) '()))))))))))))
-                       (make-local (list (compile-cont body))
-                                   (make-continue
-                                    k
-                                    (map make-id (append req (if rest (list rest) '())))))))))))
 
 (define (not-supported msg clause)
   (error 'not-supported msg clause))

module/language/js-il.scm

@@ -4,6 +4,7 @@
   #:use-module (ice-9 match)
   #:export (make-program program
             make-function function
+            make-jump-table jump-table
             make-params params
             make-continuation continuation
             make-local local
@@ -50,6 +51,7 @@
 
 (define-js-type program entry body)
 (define-js-type function params body)
+(define-js-type jump-table spec)
 (define-js-type params self req rest)
 (define-js-type continuation params body)
 (define-js-type local bindings body) ; local scope
@@ -69,8 +71,14 @@
      `(program ,(unparse-js entry) . ,(map unparse-js body)))
     (($ continuation params body)
      `(continuation ,params ,(unparse-js body)))
-    (($ function ($ params self req opt) body)
+    (($ function args body)
-     `(function ,(append (list self) req (if opt (list opt) '())) ,(unparse-js body)))
+     `(function ,args ,(unparse-js body)))
+    (($ jump-table body)
+     `(jump-table ,@(map (lambda (p)
+                           `(,(unparse-js (car p)) . ,(cdr p)))
+                         body)))
+    (($ params self req rest)
+     `(params ,self ,req ,rest))
     (($ local bindings body)
      `(local ,(map unparse-js bindings) ,(unparse-js body)))
     (($ var id exp)

module/language/js-il/compile-javascript.scm

@@ -1,4 +1,5 @@
 (define-module (language js-il compile-javascript)
+  #:use-module ((srfi srfi-1) #:select (fold-right))
   #:use-module (ice-9 match)
   #:use-module ((language js-il) #:renamer (symbol-prefix-proc 'il:))
   #:use-module (language javascript)
@@ -81,13 +82,11 @@
     (($ il:continuation params body)
      (make-function (map rename params) (list (compile-exp body))))
 
-    (($ il:function ($ il:params self req #f) body)
+    (($ il:function params body)
-     (make-function (map rename (cons self req)) (list (compile-exp body))))
+     (make-function (map rename params) (list (compile-exp body))))
 
-    (($ il:function ($ il:params self req rest) body)
+    (($ il:jump-table specs)
-     (make-function (map rename (cons self req))
+     (compile-jump-table specs))
-                    (list (bind-rest-args rest (length (cons self req)))
-                          (compile-exp body))))
 
     (($ il:local bindings body)
      (make-block (append (map compile-exp bindings) (list (compile-exp body)))))
@@ -125,6 +124,50 @@
     (($ il:id name)
      (name->id name))))
 
+(define (compile-jump-table specs)
+  (define offset 2) ; closure & continuation
+  (define (compile-test params)
+    (match params
+      (($ il:params self req #f)
+       (make-binop '=
+                   (make-refine (make-id "arguments")
+                                (make-const "length"))
+                   (make-const (+ offset (length req)))))
+      (($ il:params self req rest)
+       (make-binop '>=
+                   (make-refine (make-id "arguments")
+                                (make-const "length"))
+                   (make-const (+ offset (length req)))))))
+  (define (compile-jump params k)
+    (match params
+      (($ il:params self req #f)
+       (list
+        (make-return
+         (make-call (name->id k)
+                    (cons (name->id self)
+                          (map (lambda (idx)
+                                 (make-refine (make-id "arguments")
+                                              (make-const (+ offset idx))))
+                               (iota (length req))))))))
+      (($ il:params self req rest)
+       (list
+        (bind-rest-args rest (+ offset (length req)))
+        (make-return
+         (make-call (name->id k)
+                    (append (list (name->id self))
+                            (map (lambda (idx)
+                                   (make-refine (make-id "arguments")
+                                                (make-const (+ offset idx))))
+                                 (iota (length req)))
+                            (list (name->id rest)))))))))
+  (fold-right (lambda (a d)
+                (make-branch (compile-test (car a))
+                             (compile-jump (car a) (cdr a))
+                             (list d)))
+              ;; FIXME: should throw an error
+              (make-return (make-id "undefined"))
+              specs))
+
 (define (compile-const c)
   (cond ((number? c)
          (make-const c))