diff options
-rw-r--r-- | module/language/cps/compile-js.scm | 15 | ||||
-rw-r--r-- | module/language/js-il.scm | 6 | ||||
-rw-r--r-- | module/language/js-il/compile-javascript.scm | 54 | ||||
-rw-r--r-- | 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 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() { |