Implement keyword argument parsing

module/language/cps/compile-js.scm

@@ -47,21 +47,21 @@
 (define (extract-clauses self clause)
   (let loop ((clause clause) (specs '()) (clauses '()))
     (match clause
-      (($ $cont k ($ $kclause ($ $arity req opts rest _ _) _ #f))
+      (($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ #f))
-       (values (reverse (cons (cons (make-params self req opts rest) k) specs))
+       (values (reverse (cons (cons (make-params self req opts rest kw allow-other-keys?) k) specs))
                (reverse (cons clause clauses))))
-      (($ $cont k ($ $kclause ($ $arity req opts rest _ _) _ alternate))
+      (($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ alternate))
        (loop alternate
-             (cons (cons (make-params self req opts rest) k) specs)
+             (cons (cons (make-params self req opts rest kw allow-other-keys?) k) specs)
              (cons clause clauses))))))
 
 (define (compile-clause clause self tail)
   (match clause
-    (($ $cont k ($ $kclause ($ $arity req opt rest _) body _))
+    (($ $cont k ($ $kclause ($ $arity req opt rest ((_ _ kw-syms) ...) _) body _))
      (make-var
       k
       (make-continuation
-       (append (list self) req opt (if rest (list rest) '()))
+       (append (list self) req opt kw-syms (if rest (list rest) '()))
        (match body
          (($ $cont k ($ $kargs () () exp))
           (compile-term exp))
@@ -69,7 +69,7 @@
           (make-local (list (compile-cont body))
                       (make-continue
                        k
-                       (map make-id (append req opt (if rest (list rest) '()))))))))))))
+                       (map make-id (append req opt kw-syms (if rest (list rest) '()))))))))))))
 
 (define (not-supported msg clause)
   (error 'not-supported msg clause))

module/language/js-il.scm

@@ -52,7 +52,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 opt rest)
+(define-js-type params self req opt rest kw allow-other-keys?)
 (define-js-type continuation params body)
 (define-js-type local bindings body) ; local scope
 (define-js-type var id exp)
@@ -77,8 +77,8 @@
      `(jump-table ,@(map (lambda (p)
                            `(,(unparse-js (car p)) . ,(cdr p)))
                          body)))
-    (($ params self req opt rest)
+    (($ params self req opt rest kw allow-other-keys?)
-     `(params ,self ,req ,opt ,rest))
+     `(params ,self ,req ,opt ,rest ,kw ,allow-other-keys?))
     (($ local bindings body)
      `(local ,(map unparse-js bindings) ,(unparse-js body)))
     (($ var id exp)

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

@@ -21,6 +21,7 @@
   (values exp env env))
 
 (define *scheme* (make-id "scheme"))
+(define *utils*  (make-refine *scheme* (make-const "utils")))
 
 (define (name->id name)
   (make-id (rename name)))
@@ -85,6 +86,18 @@
        opts
        (iota (length opts))))
 
+(define (bind-kw-args kws ids num-drop)
+  (define lookup (make-refine *utils* (make-const "keyword_ref")))
+  (map (lambda (kw id)
+         (make-var (rename id)
+                   (make-call lookup
+                              (list (compile-const kw)
+                                    (make-id "arguments")
+                                    (compile-const num-drop)
+                                    (make-refine *scheme* (make-const "UNDEFINED"))))))
+       kws
+       ids))
+
 
 (define (compile-exp exp)
   ;; TODO: handle ids for js
@@ -149,17 +162,17 @@
   (define offset 2) ; closure & continuation
   (define (compile-test params)
     (match params
-      (($ il:params self req '() #f)
+      (($ il:params self req '() #f '() #f)
        (make-binop '=
                    (make-refine (make-id "arguments")
                                 (make-const "length"))
                    (make-const (+ offset (length req)))))
-      (($ il:params self req '() rest)
+      (($ il:params self req '() rest '() #f)
        (make-binop '>=
                    (make-refine (make-id "arguments")
                                 (make-const "length"))
                    (make-const (+ offset (length req)))))
-      (($ il:params self req opts #f)
+      (($ il:params self req opts #f '() #f)
        (make-binop 'and
                    (make-binop '<=
                                (make-const (+ offset (length req)))
@@ -169,10 +182,16 @@
                                (make-refine (make-id "arguments")
                                             (make-const "length"))
                                (make-const (+ offset (length req) (length opts))))))
+      ;; FIXME: need to handle allow-other-keys? and testing for actual keywords
+      (($ il:params self req opts #f kwargs _)
+       (make-binop '<=
+                   (make-const (+ offset (length req)))
+                   (make-refine (make-id "arguments")
+                                (make-const "length"))))
       ))
   (define (compile-jump params k)
     (match params
-      (($ il:params self req '() #f)
+      (($ il:params self req '() #f '() #f)
        (list
         (make-return
          (make-call (name->id k)
@@ -181,7 +200,7 @@
                                  (make-refine (make-id "arguments")
                                               (make-const (+ offset idx))))
                                (iota (length req))))))))
-      (($ il:params self req '() rest)
+      (($ il:params self req '() rest '() #f)
        (list
         (bind-rest-args rest (+ offset (length req)))
         (make-return
@@ -192,7 +211,7 @@
                                                 (make-const (+ offset idx))))
                                  (iota (length req)))
                             (list (name->id rest)))))))
-      (($ il:params self req opts #f)
+      (($ il:params self req opts #f '() #f)
        (append
         (bind-opt-args opts (+ offset (length req)))
         (list
@@ -204,6 +223,20 @@
                                                  (make-const (+ offset idx))))
                                   (iota (length req)))
                              (map name->id opts)))))))
+      (($ il:params self req opts #f ((kws names ids) ...) _)
+       (append
+        (bind-opt-args opts (+ offset (length req)))
+        (bind-kw-args kws names (+ offset (length req)))
+        (list
+         (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)))
+                             (map name->id opts)
+                             (map name->id names)))))))
       ))
   (fold-right (lambda (a d)
                 (make-branch (compile-test (car a))

module/language/js-il/runtime.js

@@ -1,6 +1,7 @@
 var scheme = {
     obarray : {},
     primitives : {},
+    utils : {},
     env : {},
     cache: [],
     builtins: [],
@@ -117,6 +118,25 @@ scheme.Keyword = function(s) {
     return this;
 };
 
+scheme.utils.keyword_ref = function(kw, args, start, dflt) {
+    var l = args.length;
+
+    if ((l - start) % 2 == 1) {
+        // FIXME: should error
+        return undefined;
+    }
+    // Need to loop in reverse because last matching keyword wins
+    for (var i = l - 2; i >= start; i -= 2) {
+        if (!(args[i] instanceof scheme.Keyword)) {
+            return undefined;
+        }
+        if (args[i].name === kw.name) {
+            return args[i + 1];
+        }
+    }
+    return dflt;
+};
+
 // Vectors
 scheme.Vector = function () {
     this.array = Array.prototype.slice.call(arguments);