[Guile-commits] 17/99: Implement Optional arguments

[Christopher Allan Webber]

cwebber pushed a commit to branch compile-to-js-merge
in repository guile.

commit 941f8fac015702221aa5245fc5d7f91ac27267ef
Author: Ian Price <ianprice90@googlemail.com>
AuthorDate: Fri Jun 12 18:27:14 2015 +0100

    Implement Optional arguments
---
 module/language/cps/compile-js.scm           | 15 ++++----
 module/language/js-il.scm                    |  6 ++--
 module/language/js-il/compile-javascript.scm | 54 ++++++++++++++++++++++++----
 module/language/js-il/runtime.js             |  4 ++-
 4 files changed, 61 insertions(+), 18 deletions(-)

diff --git a/module/language/cps/compile-js.scm 
b/module/language/cps/compile-js.scm
index dd7241d..1e36aec 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 943590e..acaeb5a 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 0952a86..7f814ff 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 ac2d4e3..1e51c6b 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() {