summaryrefslogtreecommitdiff
path: root/module/language/js-il/compile-javascript.scm
diff options
context:
space:
mode:
authorIan Price <ianprice90@googlemail.com>2015-06-12 18:27:14 +0100
committerIan Price <ianprice90@googlemail.com>2015-06-18 04:14:43 +0100
commit941f8fac015702221aa5245fc5d7f91ac27267ef (patch)
tree72baba2e6b62d724c29782a7434b83221a3cb3fa /module/language/js-il/compile-javascript.scm
parentf83c651f462c7c6c091fda1e6b4b3b39fc57b2f1 (diff)
downloadguile-941f8fac015702221aa5245fc5d7f91ac27267ef.tar.gz
Implement Optional arguments
Diffstat (limited to 'module/language/js-il/compile-javascript.scm')
-rw-r--r--module/language/js-il/compile-javascript.scm54
1 files changed, 48 insertions, 6 deletions
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))