mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-16 16:50:21 +02:00
finish support for optional & keyword args; update ecmascript compiler
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump. * libguile/vm-i-system.c (br-if-nargs-ne, br-if-args-lt) (br-if-nargs-gt): New instructions, for use by different lambda cases. (bind-optionals, bind-optionals/shuffle, bind-kwargs): New instructions, for binding optional and keyword arguments. Renumber other ops. * module/language/ecmascript/compile-tree-il.scm (comp, comp-body): Update for new tree-il. Use the new optional argument mechanism instead of emulating it with rest arguments. * module/language/glil/compile-assembly.scm (glil->assembly): Tweaks for optional and keyword argument compilation. * module/language/tree-il.scm (parse-tree-il, unparse-tree-il): Make the else case optional, in the s-expression serialization of tree-il. * module/language/tree-il/compile-glil.scm (flatten): Handle all of the lambda-case capabilities.
This commit is contained in:
Andy Wingo
parent
8753fd537c
commit
7e01997e88
7 changed files with 318 additions and 133 deletions
|
|
@ -326,14 +326,20 @@
|
|||
((begin . ,forms)
|
||||
`(begin ,@(map (lambda (x) (comp x e)) forms)))
|
||||
((lambda ,formals ,body)
|
||||
(let ((%args (gensym "%args ")))
|
||||
(-> (lambda '%args %args '()
|
||||
(comp-body (econs '%args %args e) body formals '%args)))))
|
||||
(let ((syms (map (lambda (x)
|
||||
(gensym (string-append (symbol->string x) " ")))
|
||||
formals)))
|
||||
(-> (lambda '()
|
||||
(-> (lambda-case
|
||||
`((() ,formals #f #f ,syms #f)
|
||||
,(comp-body e body formals syms))))))))
|
||||
((call/this ,obj ,prop . ,args)
|
||||
(@impl call/this*
|
||||
obj
|
||||
(-> (lambda '() '() '()
|
||||
`(apply ,(@impl pget obj prop) ,@args)))))
|
||||
(-> (lambda '()
|
||||
(-> (lambda-case
|
||||
`((() #f #f #f () #f)
|
||||
(apply ,(@impl pget obj prop) ,@args))))))))
|
||||
((call (pref ,obj ,prop) ,args)
|
||||
(comp `(call/this ,(comp obj e)
|
||||
,(-> (const prop))
|
||||
|
|
@ -433,40 +439,46 @@
|
|||
(%continue (gensym "%continue ")))
|
||||
(let ((e (econs '%loop %loop (econs '%continue %continue e))))
|
||||
(-> (letrec '(%loop %continue) (list %loop %continue)
|
||||
(list (-> (lambda '() '() '()
|
||||
(-> (begin
|
||||
(comp statement e)
|
||||
(-> (apply (-> (lexical '%continue %continue)))
|
||||
)))))
|
||||
|
||||
(-> (lambda '() '() '()
|
||||
(-> (if (@impl ->boolean (comp test e))
|
||||
(-> (apply (-> (lexical '%loop %loop))))
|
||||
(@implv *undefined*))))))
|
||||
(list (-> (lambda '()
|
||||
(-> (lambda-case
|
||||
`((() #f #f #f () #f)
|
||||
,(-> (begin
|
||||
(comp statement e)
|
||||
(-> (apply (-> (lexical '%continue %continue)))))))))))
|
||||
(-> (lambda '()
|
||||
(-> (lambda-case
|
||||
`((() #f #f #f () #f)
|
||||
,(-> (if (@impl ->boolean (comp test e))
|
||||
(-> (apply (-> (lexical '%loop %loop))))
|
||||
(@implv *undefined*)))))))))
|
||||
(-> (apply (-> (lexical '%loop %loop)))))))))
|
||||
((while ,test ,statement)
|
||||
(let ((%continue (gensym "%continue ")))
|
||||
(let ((e (econs '%continue %continue e)))
|
||||
(-> (letrec '(%continue) (list %continue)
|
||||
(list (-> (lambda '() '() '()
|
||||
(-> (if (@impl ->boolean (comp test e))
|
||||
(-> (begin (comp statement e)
|
||||
(-> (apply (-> (lexical '%continue %continue))))))
|
||||
(@implv *undefined*))))))
|
||||
(list (-> (lambda '()
|
||||
(-> (lambda-case
|
||||
`((() #f #f #f () #f)
|
||||
,(-> (if (@impl ->boolean (comp test e))
|
||||
(-> (begin (comp statement e)
|
||||
(-> (apply (-> (lexical '%continue %continue))))))
|
||||
(@implv *undefined*)))))))))
|
||||
(-> (apply (-> (lexical '%continue %continue)))))))))
|
||||
|
||||
((for ,init ,test ,inc ,statement)
|
||||
(let ((%continue (gensym "%continue ")))
|
||||
(let ((e (econs '%continue %continue e)))
|
||||
(-> (letrec '(%continue) (list %continue)
|
||||
(list (-> (lambda '() '() '()
|
||||
(-> (if (if test
|
||||
(@impl ->boolean (comp test e))
|
||||
(comp 'true e))
|
||||
(-> (begin (comp statement e)
|
||||
(comp (or inc '(begin)) e)
|
||||
(-> (apply (-> (lexical '%continue %continue))))))
|
||||
(@implv *undefined*))))))
|
||||
(list (-> (lambda '()
|
||||
(-> (lambda-case
|
||||
`((() #f #f #f () #f)
|
||||
,(-> (if (if test
|
||||
(@impl ->boolean (comp test e))
|
||||
(comp 'true e))
|
||||
(-> (begin (comp statement e)
|
||||
(comp (or inc '(begin)) e)
|
||||
(-> (apply (-> (lexical '%continue %continue))))))
|
||||
(@implv *undefined*)))))))))
|
||||
(-> (begin (comp (or init '(begin)) e)
|
||||
(-> (apply (-> (lexical '%continue %continue)))))))))))
|
||||
|
||||
|
|
@ -476,18 +488,20 @@
|
|||
(let ((e (econs '%enum %enum (econs '%continue %continue e))))
|
||||
(-> (letrec '(%enum %continue) (list %enum %continue)
|
||||
(list (@impl make-enumerator (comp object e))
|
||||
(-> (lambda '() '() '()
|
||||
(-> (if (@impl ->boolean
|
||||
(@impl pget
|
||||
(-> (lexical '%enum %enum))
|
||||
(-> (const 'length))))
|
||||
(-> (begin
|
||||
(comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
|
||||
,(-> (const 'pop))))
|
||||
e)
|
||||
(comp statement e)
|
||||
(-> (apply (-> (lexical '%continue %continue))))))
|
||||
(@implv *undefined*))))))
|
||||
(-> (lambda '()
|
||||
(-> (lambda-case
|
||||
`((() #f #f #f () #f)
|
||||
(-> (if (@impl ->boolean
|
||||
(@impl pget
|
||||
(-> (lexical '%enum %enum))
|
||||
(-> (const 'length))))
|
||||
(-> (begin
|
||||
(comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
|
||||
,(-> (const 'pop))))
|
||||
e)
|
||||
(comp statement e)
|
||||
(-> (apply (-> (lexical '%continue %continue))))))
|
||||
(@implv *undefined*)))))))))
|
||||
(-> (apply (-> (lexical '%continue %continue)))))))))
|
||||
|
||||
((block ,x)
|
||||
|
|
@ -495,18 +509,22 @@
|
|||
(else
|
||||
(error "compilation not yet implemented:" x)))))
|
||||
|
||||
(define (comp-body e body formals %args)
|
||||
(define (comp-body e body formals formal-syms)
|
||||
(define (process)
|
||||
(let lp ((in body) (out '()) (rvars (reverse formals)))
|
||||
(let lp ((in body) (out '()) (rvars '()))
|
||||
(pmatch in
|
||||
(((var (,x) . ,morevars) . ,rest)
|
||||
(lp `((var . ,morevars) . ,rest)
|
||||
out
|
||||
(if (memq x rvars) rvars (cons x rvars))))
|
||||
(if (or (memq x rvars) (memq x formals))
|
||||
rvars
|
||||
(cons x rvars))))
|
||||
(((var (,x ,y) . ,morevars) . ,rest)
|
||||
(lp `((var . ,morevars) . ,rest)
|
||||
`((= (ref ,x) ,y) . ,out)
|
||||
(if (memq x rvars) rvars (cons x rvars))))
|
||||
(if (or (memq x rvars) (memq x formals))
|
||||
rvars
|
||||
(cons x rvars))))
|
||||
(((var) . ,rest)
|
||||
(lp rest out rvars))
|
||||
((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
|
||||
|
|
@ -532,18 +550,6 @@
|
|||
(syms (map (lambda (x)
|
||||
(gensym (string-append (symbol->string x) " ")))
|
||||
names))
|
||||
(e (fold acons e names syms)))
|
||||
(let ((%argv (lookup %args e)))
|
||||
(let lp ((names names) (syms syms))
|
||||
(if (null? names)
|
||||
;; fixme: here check for too many args
|
||||
(comp out e)
|
||||
(-> (let (list (car names)) (list (car syms))
|
||||
(list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
|
||||
(-> (@implv *undefined*))
|
||||
(-> (let1 (-> (apply (-> (primitive 'car)) %argv))
|
||||
(lambda (v)
|
||||
(-> (set! %argv
|
||||
(-> (apply (-> (primitive 'cdr)) %argv))))
|
||||
(-> (lexical v v))))))))
|
||||
(lp (cdr names) (cdr syms))))))))))
|
||||
(e (fold econs (fold econs e formals formal-syms) names syms)))
|
||||
(-> (let names syms (map (lambda (x) (->@implv *undefined*)) names)
|
||||
(comp out e))))))
|
||||
|
|
|
|||
|
|
@ -250,7 +250,7 @@
|
|||
,(modulo (+ nreq nopt) 256))))
|
||||
(else
|
||||
(if else-label
|
||||
`((br-if-nargs-ge ,(quotient (+ nreq nopt) 256)
|
||||
`((br-if-nargs-gt ,(quotient (+ nreq nopt) 256)
|
||||
,(modulo (+ nreq nopt) 256)
|
||||
,else-label))
|
||||
`((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
|
||||
|
|
@ -274,7 +274,9 @@
|
|||
`((assert-nargs-ge ,(quotient nreq 256)
|
||||
,(modulo nreq 256)))))
|
||||
(bind-optionals-and-shuffle
|
||||
`((bind-optionals-and-shuffle-kwargs
|
||||
`((bind-optionals/shuffle
|
||||
,(quotient nreq 256)
|
||||
,(modulo nreq 256)
|
||||
,(quotient (+ nreq nopt) 256)
|
||||
,(modulo (+ nreq nopt) 256)
|
||||
,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
|
|
@ -284,13 +286,12 @@
|
|||
;; in, space has been made for kwargs, and the kwargs
|
||||
;; themselves have been shuffled above the slots for all
|
||||
;; req/opt/kwargs locals.
|
||||
`((,(if allow-other-keys? 'bind-kwargs/aok 'bind-kwargs/no-aok)
|
||||
`((bind-kwargs
|
||||
,(quotient kw-idx 256)
|
||||
,(modulo kw-idx 256)
|
||||
,(quotient (+ nreq nopt) 256)
|
||||
,(modulo (+ nreq nopt) 256)
|
||||
,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256))))
|
||||
,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
,(if allow-other-keys? 1 0))))
|
||||
(bind-rest
|
||||
(if rest?
|
||||
`((bind-rest ,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
|
|
|
|||
|
|
@ -140,6 +140,12 @@
|
|||
(retrans body)
|
||||
(and=> else retrans)))
|
||||
|
||||
((lambda-case ((,req ,opt ,rest ,kw ,vars ,predicate) ,body))
|
||||
(make-lambda-case loc req opt rest kw vars
|
||||
(and=> predicate retrans)
|
||||
(retrans body)
|
||||
#f))
|
||||
|
||||
((const ,exp)
|
||||
(make-const loc exp))
|
||||
|
||||
|
|
@ -202,7 +208,7 @@
|
|||
((<lambda-case> req opt rest kw vars predicate body else)
|
||||
`(lambda-case ((,req ,opt ,rest ,kw ,vars ,(and=> predicate unparse-tree-il))
|
||||
,(unparse-tree-il body))
|
||||
,(and=> else unparse-tree-il)))
|
||||
. ,(if else (list (unparse-tree-il else)) '())))
|
||||
|
||||
((<const> exp)
|
||||
`(const ,exp))
|
||||
|
|
@ -268,19 +274,19 @@
|
|||
|
||||
((<lambda-case> req opt rest kw vars predicate body else)
|
||||
;; FIXME
|
||||
#; `(((,@req
|
||||
,@(if (not opt)
|
||||
'()
|
||||
(cons #:optional opt))
|
||||
,@(if (not kw)
|
||||
'()
|
||||
(cons #:key (cdr kw)))
|
||||
,@(if predicate
|
||||
(list #:predicate (tree-il->scheme predicate))
|
||||
'())
|
||||
. ,(or rest '()))
|
||||
,(tree-il->scheme body))
|
||||
,@(if else (tree-il->scheme else) '()))
|
||||
;; `(((,@req
|
||||
;; ,@(if (not opt)
|
||||
;; '()
|
||||
;; (cons #:optional opt))
|
||||
;; ,@(if (not kw)
|
||||
;; '()
|
||||
;; (cons #:key (cdr kw)))
|
||||
;; ,@(if predicate
|
||||
;; (list #:predicate (tree-il->scheme predicate))
|
||||
;; '())
|
||||
;; . ,(or rest '()))
|
||||
;; ,(tree-il->scheme body))
|
||||
;; ,@(if else (tree-il->scheme else) '()))
|
||||
`((,(if rest (apply cons* vars) vars)
|
||||
,(tree-il->scheme body))
|
||||
,@(if else (tree-il->scheme else) '())))
|
||||
|
|
|
|||
|
|
@ -599,28 +599,61 @@
|
|||
(emit-code #f (make-glil-call 'make-closure 2)))))))
|
||||
(maybe-emit-return))
|
||||
|
||||
((<lambda-case> req opt kw rest vars predicate else body)
|
||||
;; the prelude, to check args & reset the stack pointer,
|
||||
;; allowing room for locals
|
||||
(let ((nlocs (cdr (hashq-ref allocation x))))
|
||||
(if rest
|
||||
(emit-code #f (make-glil-opt-prelude (length req) 0 #t nlocs #f))
|
||||
(emit-code #f (make-glil-std-prelude (length req) nlocs #f))))
|
||||
;; box args if necessary
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(pmatch (hashq-ref (hashq-ref allocation v) self)
|
||||
((#t #t . ,n)
|
||||
(emit-code #f (make-glil-lexical #t #f 'ref n))
|
||||
(emit-code #f (make-glil-lexical #t #t 'box n)))))
|
||||
vars)
|
||||
;; write bindings info -- FIXME deal with opt/kw
|
||||
(if (not (null? vars))
|
||||
(emit-bindings #f (append req (if rest (list rest) '()))
|
||||
vars allocation self emit-code))
|
||||
;; post-prelude case label for label calls
|
||||
(emit-label (car (hashq-ref allocation x)))
|
||||
(let ((else-label (and else (make-label))))
|
||||
((<lambda-case> src req opt rest kw vars predicate else body)
|
||||
(let ((nlocs (cdr (hashq-ref allocation x)))
|
||||
(else-label (and else (make-label))))
|
||||
;; the prelude, to check args & reset the stack pointer,
|
||||
;; allowing room for locals
|
||||
(emit-code
|
||||
src
|
||||
(cond
|
||||
;; kw := (allow-other-keys? (#:key name var) ...)
|
||||
(kw
|
||||
(make-glil-kw-prelude
|
||||
(length req) (length (or opt '())) (and rest #t)
|
||||
(map (lambda (x)
|
||||
(pmatch x
|
||||
((,key ,name ,var)
|
||||
(cons key
|
||||
(pmatch (hashq-ref (hashq-ref allocation var) self)
|
||||
((#t ,boxed . ,n) n)
|
||||
(,a (error "bad keyword allocation" x a)))))
|
||||
(,x (error "bad keyword" x))))
|
||||
(cdr kw))
|
||||
(car kw) nlocs else-label))
|
||||
((or rest opt)
|
||||
(make-glil-opt-prelude
|
||||
(length req) (length (or opt '())) (and rest #t) nlocs else-label))
|
||||
(#t
|
||||
(make-glil-std-prelude (length req) nlocs else-label))))
|
||||
;; box args if necessary
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(pmatch (hashq-ref (hashq-ref allocation v) self)
|
||||
((#t #t . ,n)
|
||||
(emit-code #f (make-glil-lexical #t #f 'ref n))
|
||||
(emit-code #f (make-glil-lexical #t #t 'box n)))))
|
||||
vars)
|
||||
;; write bindings info
|
||||
(if (not (null? vars))
|
||||
(emit-bindings
|
||||
#f
|
||||
(let lp ((kw (if kw (cdr kw) '()))
|
||||
(names (append (if opt (reverse opt) '())
|
||||
(reverse req)))
|
||||
(vars (list-tail vars (+ (length req)
|
||||
(if opt (length opt) 0)
|
||||
(if rest 1 0)))))
|
||||
(pmatch kw
|
||||
(() (reverse (if rest (cons rest names) names)))
|
||||
(((,key ,name ,var) . ,kw)
|
||||
(if (memq var vars)
|
||||
(lp kw (cons name names) (delq var vars))
|
||||
(lp kw names vars)))
|
||||
(,kw (error "bad keywords, yo" kw))))
|
||||
vars allocation self emit-code))
|
||||
;; post-prelude case label for label calls
|
||||
(emit-label (car (hashq-ref allocation x)))
|
||||
(if predicate
|
||||
(begin
|
||||
(comp-push predicate)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue