diff options
author | Ian Price <ianprice90@googlemail.com> | 2015-06-12 18:27:14 +0100 |
---|---|---|
committer | Ian Price <ianprice90@googlemail.com> | 2015-06-18 04:14:43 +0100 |
commit | 941f8fac015702221aa5245fc5d7f91ac27267ef (patch) | |
tree | 72baba2e6b62d724c29782a7434b83221a3cb3fa /module/language/js-il/compile-javascript.scm | |
parent | f83c651f462c7c6c091fda1e6b4b3b39fc57b2f1 (diff) | |
download | guile-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.scm | 54 |
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)) |