mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

Implement Optional arguments

Browse source
This commit is contained in:
Ian Price 2015-06-12 18:27:14 +01:00
parent f83c651f46
commit 941f8fac01
4 changed files with 61 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

15
module/language/cps/compile-js.scm
View file

@ -47,22 +47,21 @@
(define (extract-clauses self clause) (define (extract-clauses self clause)
(let loop ((clause clause) (specs '()) (clauses '())) (let loop ((clause clause) (specs '()) (clauses '()))
(match clause (match clause
(($ $cont k ($ $kclause ($ $arity req _ rest _ _) _ #f)) (($ $cont k ($ $kclause ($ $arity req opts rest _ _) _ #f))
(values (reverse (cons (cons (make-params self req rest) k) specs)) (values (reverse (cons (cons (make-params self req opts rest) k) specs))
(reverse (cons clause clauses)))) (reverse (cons clause clauses))))
(($ $cont k ($ $kclause ($ $arity req _ rest _ _) _ alternate)) (($ $cont k ($ $kclause ($ $arity req opts rest _ _) _ alternate))
(loop 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)))))) (cons clause clauses))))))
(define (compile-clause clause self tail) (define (compile-clause clause self tail)
(match clause (match clause
(($ $cont k ($ $kclause ($ $arity req _ rest _) body _)) (($ $cont k ($ $kclause ($ $arity req opt rest _) body _))
(make-var (make-var
k k
(make-continuation (make-continuation
(append (list self) (append (list self) req opt (if rest (list rest) '()))
req (if rest (list rest) '()))
(match body (match body
(($ $cont k ($ $kargs () () exp)) (($ $cont k ($ $kargs () () exp))
(compile-term exp)) (compile-term exp))
@ -70,7 +69,7 @@
(make-local (list (compile-cont body)) (make-local (list (compile-cont body))
(make-continue (make-continue
k 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) (define (not-supported msg clause)
(error 'not-supported msg clause)) (error 'not-supported msg clause))

6
module/language/js-il.scm
View file

@ -52,7 +52,7 @@
(define-js-type program entry body) (define-js-type program entry body)
(define-js-type function params body) (define-js-type function params body)
(define-js-type jump-table spec) (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 continuation params body)
(define-js-type local bindings body) ; local scope (define-js-type local bindings body) ; local scope
(define-js-type var id exp) (define-js-type var id exp)
@ -77,8 +77,8 @@
`(jump-table ,@(map (lambda (p) `(jump-table ,@(map (lambda (p)
`(,(unparse-js (car p)) . ,(cdr p))) `(,(unparse-js (car p)) . ,(cdr p)))
body))) body)))
(($ params self req rest) (($ params self req opt rest)
`(params ,self ,req ,rest)) `(params ,self ,req ,opt ,rest))
(($ local bindings body) (($ local bindings body)
`(local ,(map unparse-js bindings) ,(unparse-js body))) `(local ,(map unparse-js bindings) ,(unparse-js body)))
(($ var id exp) (($ var id exp)

54
module/language/js-il/compile-javascript.scm
View file

@ -4,8 +4,15 @@
#:use-module ((language js-il) #:renamer (symbol-prefix-proc 'il:)) #:use-module ((language js-il) #:renamer (symbol-prefix-proc 'il:))
#:use-module (language javascript) #:use-module (language javascript)
#:use-module (language js-il direct) #:use-module (language js-il direct)
#:use-module (system foreign)
#:export (compile-javascript)) #: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) (define (compile-javascript exp env opts)
(set! exp (remove-immediate-calls exp)) (set! exp (remove-immediate-calls exp))
(values (compile-exp exp) env env)) (values (compile-exp exp) env env))
@ -65,6 +72,17 @@
(make-call (ref (make-id "Array") (list "prototype" "slice" "call")) (make-call (ref (make-id "Array") (list "prototype" "slice" "call"))
(list (make-id "arguments") (make-const num-drop))))))) (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) (define (compile-exp exp)
;; TODO: handle ids for js ;; TODO: handle ids for js
(match exp (match exp
@ -128,19 +146,30 @@
(define offset 2) ; closure & continuation (define offset 2) ; closure & continuation
(define (compile-test params) (define (compile-test params)
(match params (match params
(($ il:params self req #f) (($ il:params self req '() #f)
(make-binop '= (make-binop '=
(make-refine (make-id "arguments") (make-refine (make-id "arguments")
(make-const "length")) (make-const "length"))
(make-const (+ offset (length req))))) (make-const (+ offset (length req)))))
(($ il:params self req rest) (($ il:params self req '() rest)
(make-binop '>= (make-binop '>=
(make-refine (make-id "arguments") (make-refine (make-id "arguments")
(make-const "length")) (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) (define (compile-jump params k)
(match params (match params
(($ il:params self req #f) (($ il:params self req '() #f)
(list (list
(make-return (make-return
(make-call (name->id k) (make-call (name->id k)
@ -149,7 +178,7 @@
(make-refine (make-id "arguments") (make-refine (make-id "arguments")
(make-const (+ offset idx)))) (make-const (+ offset idx))))
(iota (length req)))))))) (iota (length req))))))))
(($ il:params self req rest) (($ il:params self req '() rest)
(list (list
(bind-rest-args rest (+ offset (length req))) (bind-rest-args rest (+ offset (length req)))
(make-return (make-return
@ -159,7 +188,20 @@
(make-refine (make-id "arguments") (make-refine (make-id "arguments")
(make-const (+ offset idx)))) (make-const (+ offset idx))))
(iota (length req))) (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) (fold-right (lambda (a d)
(make-branch (compile-test (car a)) (make-branch (compile-test (car a))
(compile-jump (car a) (cdr a)) (compile-jump (car a) (cdr a))

4
module/language/js-il/runtime.js
View file

@ -9,7 +9,9 @@ var scheme = {
TRUE : true, TRUE : true,
NIL : false, NIL : false,
EMPTY : [], EMPTY : [],
UNSPECIFIED : [] UNSPECIFIED : [],
// FIXME: wingo says not to leak undefined to users
UNDEFINED: undefined
}; };
function not_implemented_yet() { function not_implemented_yet() {