summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/cps/compile-js.scm15
-rw-r--r--module/language/js-il.scm6
-rw-r--r--module/language/js-il/compile-javascript.scm54
-rw-r--r--module/language/js-il/runtime.js4
4 files changed, 61 insertions, 18 deletions
diff --git a/module/language/cps/compile-js.scm b/module/language/cps/compile-js.scm
index dd7241d3d..1e36aec49 100644
--- a/module/language/cps/compile-js.scm
+++ b/module/language/cps/compile-js.scm
@@ -47,22 +47,21 @@
(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))
+ (($ $cont k ($ $kclause ($ $arity req opts rest _ _) _ #f))
+ (values (reverse (cons (cons (make-params self req opts rest) k) specs))
(reverse (cons clause clauses))))
- (($ $cont k ($ $kclause ($ $arity req _ rest _ _) _ alternate))
+ (($ $cont k ($ $kclause ($ $arity req opts rest _ _) _ alternate))
(loop alternate
- (cons (cons (make-params self req rest) k) specs)
+ (cons (cons (make-params self req opts rest) k) specs)
(cons clause clauses))))))
(define (compile-clause clause self tail)
(match clause
- (($ $cont k ($ $kclause ($ $arity req _ rest _) body _))
+ (($ $cont k ($ $kclause ($ $arity req opt rest _) body _))
(make-var
k
(make-continuation
- (append (list self)
- req (if rest (list rest) '()))
+ (append (list self) req opt (if rest (list rest) '()))
(match body
(($ $cont k ($ $kargs () () exp))
(compile-term exp))
@@ -70,7 +69,7 @@
(make-local (list (compile-cont body))
(make-continue
k
- (map make-id (append req (if rest (list rest) '()))))))))))))
+ (map make-id (append req opt (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 943590efc..acaeb5a78 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 rest)
+(define-js-type params self req opt rest)
(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 rest)
- `(params ,self ,req ,rest))
+ (($ params self req opt rest)
+ `(params ,self ,req ,opt ,rest))
(($ 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 0952a8679..7f814fff9 100644
--- a/module/language/js-il/compile-javascript.scm
+++ b/module/language/js-il/compile-javascript.scm
@@ -4,8 +4,15 @@
#:use-module ((language js-il) #:renamer (symbol-prefix-proc 'il:))
#:use-module (language javascript)
#:use-module (language js-il direct)
+ #:use-module (system foreign)
#:export (compile-javascript))
+(define (undefined? obj)
+ (define tc8-iflag 4)
+ (define unbound-val 9)
+ (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
+ (eqv? obj (pointer->scm (make-pointer unbound-bits))))
+
(define (compile-javascript exp env opts)
(set! exp (remove-immediate-calls exp))
(values (compile-exp exp) env env))
@@ -65,6 +72,17 @@
(make-call (ref (make-id "Array") (list "prototype" "slice" "call"))
(list (make-id "arguments") (make-const num-drop)))))))
+(define (bind-opt-args opts num-drop)
+ (map (lambda (opt idx)
+ (make-var (rename opt)
+ (make-binop 'or
+ (make-refine (make-id "arguments")
+ (make-const (+ num-drop idx)))
+ (make-refine *scheme* (make-const "UNDEFINED")))))
+ opts
+ (iota (length opts))))
+
+
(define (compile-exp exp)
;; TODO: handle ids for js
(match exp
@@ -128,19 +146,30 @@
(define offset 2) ; closure & continuation
(define (compile-test params)
(match params
- (($ il:params self req #f)
+ (($ 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)
+ (($ il:params self req '() rest)
(make-binop '>=
(make-refine (make-id "arguments")
(make-const "length"))
- (make-const (+ offset (length req)))))))
+ (make-const (+ offset (length req)))))
+ (($ il:params self req opts #f)
+ (make-binop 'and
+ (make-binop '<=
+ (make-const (+ offset (length req)))
+ (make-refine (make-id "arguments")
+ (make-const "length")))
+ (make-binop '<=
+ (make-refine (make-id "arguments")
+ (make-const "length"))
+ (make-const (+ offset (length req) (length opts))))))
+ ))
(define (compile-jump params k)
(match params
- (($ il:params self req #f)
+ (($ il:params self req '() #f)
(list
(make-return
(make-call (name->id k)
@@ -149,7 +178,7 @@
(make-refine (make-id "arguments")
(make-const (+ offset idx))))
(iota (length req))))))))
- (($ il:params self req rest)
+ (($ il:params self req '() rest)
(list
(bind-rest-args rest (+ offset (length req)))
(make-return
@@ -159,7 +188,20 @@
(make-refine (make-id "arguments")
(make-const (+ offset idx))))
(iota (length req)))
- (list (name->id rest)))))))))
+ (list (name->id rest)))))))
+ (($ il:params self req opts #f)
+ (append
+ (bind-opt-args opts (+ 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)))))))
+ ))
(fold-right (lambda (a d)
(make-branch (compile-test (car a))
(compile-jump (car a) (cdr a))
diff --git a/module/language/js-il/runtime.js b/module/language/js-il/runtime.js
index ac2d4e380..1e51c6bc5 100644
--- a/module/language/js-il/runtime.js
+++ b/module/language/js-il/runtime.js
@@ -9,7 +9,9 @@ var scheme = {
TRUE : true,
NIL : false,
EMPTY : [],
- UNSPECIFIED : []
+ UNSPECIFIED : [],
+ // FIXME: wingo says not to leak undefined to users
+ UNDEFINED: undefined
};
function not_implemented_yet() {