cwebber pushed a commit to branch compile-to-js-merge
in repository guile.
commit e84f8394633339284953d7e54fe3cd5018d2e160
Author: Ian Price <[email protected]>
AuthorDate: Sat Jun 13 22:41:37 2015 +0100
Implement keyword argument parsing
---
module/language/cps/compile-js.scm | 14 ++++-----
module/language/js-il.scm | 6 ++--
module/language/js-il/compile-javascript.scm | 45 ++++++++++++++++++++++++----
module/language/js-il/runtime.js | 20 +++++++++++++
4 files changed, 69 insertions(+), 16 deletions(-)
diff --git a/module/language/cps/compile-js.scm
b/module/language/cps/compile-js.scm
index 1e36aec..8bffa97 100644
--- a/module/language/cps/compile-js.scm
+++ b/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))
- (values (reverse (cons (cons (make-params self req opts rest) k) specs))
+ (($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _
#f))
+ (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))
diff --git a/module/language/js-il.scm b/module/language/js-il.scm
index acaeb5a..3415cd9 100644
--- a/module/language/js-il.scm
+++ b/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))
+ (($ params self req opt rest kw allow-other-keys?)
+ `(params ,self ,req ,opt ,rest ,kw ,allow-other-keys?))
(($ local bindings body)
`(local ,(map unparse-js bindings) ,(unparse-js body)))
(($ var id exp)
diff --git a/module/language/js-il/compile-javascript.scm
b/module/language/js-il/compile-javascript.scm
index ca7cca5..27f91ad 100644
--- a/module/language/js-il/compile-javascript.scm
+++ b/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))
diff --git a/module/language/js-il/runtime.js b/module/language/js-il/runtime.js
index 6569cbe..688974e 100644
--- a/module/language/js-il/runtime.js
+++ b/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);
