mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
Different types for Continuation and Variable identifiers
This commit is contained in:
Ian Price
parent
78cacbe450
commit
2e10f55426
4 changed files with 127 additions and 72 deletions
|
|
@ -37,39 +37,54 @@
|
|||
(extract-clauses self clause))
|
||||
(lambda (jump-table clauses)
|
||||
(make-var
|
||||
k
|
||||
(make-kid k)
|
||||
(make-function
|
||||
(list self tail)
|
||||
(make-id self) (make-kid tail)
|
||||
(make-local (map (lambda (clause)
|
||||
(compile-clause clause self tail))
|
||||
clauses)
|
||||
(make-jump-table jump-table)))))))))
|
||||
|
||||
(define (extract-clauses self clause)
|
||||
(define (make-params* self req opts rest kw allow-other-keys?)
|
||||
(make-params (make-id self)
|
||||
(map make-id req)
|
||||
(map make-id opts)
|
||||
(and rest (make-id rest))
|
||||
(map make-id kw)
|
||||
allow-other-keys?))
|
||||
(let loop ((clause clause) (specs '()) (clauses '()))
|
||||
(match clause
|
||||
(($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ #f))
|
||||
(values (reverse (cons (cons (make-params self req opts rest kw allow-other-keys?) k) specs))
|
||||
(values (reverse (acons (make-params* self req opts rest kw allow-other-keys?)
|
||||
(make-kid k)
|
||||
specs))
|
||||
(reverse (cons clause clauses))))
|
||||
(($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ alternate))
|
||||
(loop alternate
|
||||
(cons (cons (make-params self req opts rest kw allow-other-keys?) k) specs)
|
||||
(acons (make-params* self req opts rest kw allow-other-keys?)
|
||||
(make-kid k)
|
||||
specs)
|
||||
(cons clause clauses))))))
|
||||
|
||||
(define (compile-clause clause self tail)
|
||||
(match clause
|
||||
(($ $cont k ($ $kclause ($ $arity req opt rest ((_ _ kw-syms) ...) _) body _))
|
||||
(make-var
|
||||
k
|
||||
(make-kid k)
|
||||
(make-continuation
|
||||
(append (list self) req opt kw-syms (if rest (list rest) '()))
|
||||
(append (list (make-id self))
|
||||
(map make-id req)
|
||||
(map make-id opt)
|
||||
(map make-id kw-syms)
|
||||
(if rest (list (make-id rest)) '()))
|
||||
(match body
|
||||
(($ $cont k ($ $kargs () () exp))
|
||||
(compile-term exp))
|
||||
(($ $cont k _)
|
||||
(make-local (list (compile-cont body))
|
||||
(make-continue
|
||||
k
|
||||
(make-kid k)
|
||||
(map make-id (append req opt kw-syms (if rest (list rest) '()))))))))))))
|
||||
|
||||
(define (not-supported msg clause)
|
||||
|
|
@ -86,43 +101,53 @@
|
|||
(match cont
|
||||
(($ $cont k ($ $kargs names syms body))
|
||||
;; use the name part?
|
||||
(make-var k (make-continuation syms (compile-term body))))
|
||||
(make-var (make-kid k)
|
||||
(make-continuation (map make-id syms)
|
||||
(compile-term body))))
|
||||
(($ $cont k ($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2))
|
||||
(make-var k
|
||||
(make-continuation (append req (list rest))
|
||||
(make-continue k2
|
||||
(append (map make-id req) (list (make-id rest)))))))
|
||||
(make-var
|
||||
(make-kid k)
|
||||
(make-continuation (append (map make-id req) (list (make-id rest)))
|
||||
(make-continue (make-kid k2)
|
||||
(append (map make-id req)
|
||||
(list (make-id rest)))))))
|
||||
(($ $cont k ($ $kreceive ($ $arity req _ #f _ _) k2))
|
||||
(make-var k (make-continuation req (make-continue k2 (map make-id req)))))))
|
||||
(make-var (make-kid k)
|
||||
(make-continuation (map make-id req)
|
||||
(make-continue (make-kid k2)
|
||||
(map make-id req)))))))
|
||||
|
||||
(define (compile-exp exp k)
|
||||
(match exp
|
||||
(($ $branch kt exp)
|
||||
(compile-test exp kt k))
|
||||
(compile-test exp (make-kid kt) (make-kid k)))
|
||||
(($ $primcall 'return (arg))
|
||||
(make-continue k (list (make-id arg))))
|
||||
(make-continue (make-kid k) (list (make-id arg))))
|
||||
(($ $call name args)
|
||||
(make-call name (cons k args)))
|
||||
(make-call (make-id name) (make-kid k) (map make-id args)))
|
||||
(($ $callk label proc args)
|
||||
(make-continue label (map make-id (cons* proc k args))))
|
||||
(make-continue (make-kid label)
|
||||
(cons* (make-id proc)
|
||||
(make-kid k)
|
||||
(map make-id args))))
|
||||
(($ $values values)
|
||||
(make-continue k (map make-id values)))
|
||||
(make-continue (make-kid k) (map make-id values)))
|
||||
(($ $prompt escape? tag handler)
|
||||
(make-seq
|
||||
(list
|
||||
(make-prompt* escape? tag handler)
|
||||
(make-continue k '()))))
|
||||
(make-prompt* escape? (make-id tag) (make-kid handler))
|
||||
(make-continue (make-kid k) '()))))
|
||||
(_
|
||||
(make-continue k (list (compile-exp* exp))))))
|
||||
(make-continue (make-kid k) (list (compile-exp* exp))))))
|
||||
|
||||
(define (compile-exp* exp)
|
||||
(match exp
|
||||
(($ $const val)
|
||||
(make-const val))
|
||||
(($ $primcall name args)
|
||||
(make-primcall name args))
|
||||
(make-primcall name (map make-id args)))
|
||||
(($ $closure label nfree)
|
||||
(make-closure label nfree))
|
||||
(make-closure (make-kid label) nfree))
|
||||
(($ $values (val))
|
||||
;; FIXME:
|
||||
;; may happen if a test branch of a conditional compiles to values
|
||||
|
|
|
|||
|
|
@ -15,8 +15,8 @@
|
|||
make-call call
|
||||
make-closure closure
|
||||
make-branch branch
|
||||
make-return return
|
||||
make-id id
|
||||
make-kid kid
|
||||
make-seq seq
|
||||
make-prompt prompt
|
||||
))
|
||||
|
|
@ -52,7 +52,7 @@
|
|||
(format port "#<js-il ~S>" (unparse-js exp)))
|
||||
|
||||
(define-js-type program entry body)
|
||||
(define-js-type function params body)
|
||||
(define-js-type function self tail body)
|
||||
(define-js-type jump-table spec)
|
||||
(define-js-type params self req opt rest kw allow-other-keys?)
|
||||
(define-js-type continuation params body)
|
||||
|
|
@ -61,11 +61,11 @@
|
|||
(define-js-type continue cont args)
|
||||
(define-js-type const value)
|
||||
(define-js-type primcall name args)
|
||||
(define-js-type call name args)
|
||||
(define-js-type call name k args)
|
||||
(define-js-type closure label num-free)
|
||||
(define-js-type branch test consequence alternate)
|
||||
(define-js-type id name)
|
||||
(define-js-type return val)
|
||||
(define-js-type kid name)
|
||||
(define-js-type seq body)
|
||||
(define-js-type prompt escape? tag handler)
|
||||
|
||||
|
|
@ -74,32 +74,40 @@
|
|||
(($ program entry body)
|
||||
`(program ,(unparse-js entry) . ,(map unparse-js body)))
|
||||
(($ continuation params body)
|
||||
`(continuation ,params ,(unparse-js body)))
|
||||
(($ function args body)
|
||||
`(function ,args ,(unparse-js body)))
|
||||
`(continuation ,(map unparse-js params) ,(unparse-js body)))
|
||||
(($ function self tail body)
|
||||
`(function ,self ,tail ,(unparse-js body)))
|
||||
(($ jump-table body)
|
||||
`(jump-table ,@(map (lambda (p)
|
||||
`(,(unparse-js (car p)) . ,(cdr p)))
|
||||
body)))
|
||||
(($ params self req opt rest kw allow-other-keys?)
|
||||
`(params ,self ,req ,opt ,rest ,kw ,allow-other-keys?))
|
||||
(($ params ($ id self) req opt rest kws allow-other-keys?)
|
||||
`(params ,self
|
||||
,(map unparse-js req)
|
||||
,(map unparse-js opt)
|
||||
,(and rest (unparse-js rest))
|
||||
,(map (match-lambda
|
||||
((kw ($ id name) ($ id sym))
|
||||
(list kw name sym)))
|
||||
kws)
|
||||
,allow-other-keys?))
|
||||
(($ local bindings body)
|
||||
`(local ,(map unparse-js bindings) ,(unparse-js body)))
|
||||
(($ var id exp)
|
||||
`(var ,id ,(unparse-js exp)))
|
||||
(($ continue k args)
|
||||
(($ continue ($ kid k) args)
|
||||
`(continue ,k ,(map unparse-js args)))
|
||||
(($ branch test then else)
|
||||
`(if ,(unparse-js test) ,(unparse-js then) ,(unparse-js else)))
|
||||
(($ const c)
|
||||
`(const ,c))
|
||||
(($ primcall name args)
|
||||
`(primcall ,name , args))
|
||||
(($ call name args)
|
||||
`(call ,name , args))
|
||||
(($ closure label nfree)
|
||||
`(primcall ,name ,(map unparse-js args)))
|
||||
(($ call ($ id name) ($ kid k) args)
|
||||
`(call ,name ,k ,(map unparse-js args)))
|
||||
(($ closure ($ kid label) nfree)
|
||||
`(closure ,label ,nfree))
|
||||
(($ return val)
|
||||
`(return . ,(unparse-js val)))
|
||||
(($ id name)
|
||||
`(id . ,name))))
|
||||
`(id . ,name))
|
||||
(($ kid name)
|
||||
`(kid . ,name))))
|
||||
|
|
|
|||
|
|
@ -23,12 +23,28 @@
|
|||
(define *scheme* (make-id "scheme"))
|
||||
(define *utils* (make-refine *scheme* (make-const "utils")))
|
||||
|
||||
(define (rename-id i)
|
||||
(match i
|
||||
(($ il:id i)
|
||||
(rename i))
|
||||
(($ il:kid i)
|
||||
(rename-kont i))))
|
||||
|
||||
(define (compile-id i)
|
||||
(make-id (rename-id i)))
|
||||
|
||||
(define (kont->id name)
|
||||
(make-id (rename-kont name)))
|
||||
|
||||
(define (rename-kont name)
|
||||
(format #f "k_~a" name))
|
||||
|
||||
(define (name->id name)
|
||||
(make-id (rename name)))
|
||||
|
||||
(define (rename id)
|
||||
(cond ((and (integer? id) (>= id 0))
|
||||
(format #f "k_~a" id))
|
||||
(format #f "v_~a" id))
|
||||
((symbol? id)
|
||||
(js-id (symbol->string id)))
|
||||
((string? id)
|
||||
|
|
@ -39,7 +55,7 @@
|
|||
(define (js-id name)
|
||||
(call-with-output-string
|
||||
(lambda (port)
|
||||
(display "k_" port)
|
||||
(display "v_" port)
|
||||
(string-for-each
|
||||
(lambda (c)
|
||||
(if (or (and (char<=? #\a c) (char<=? c #\z))
|
||||
|
|
@ -68,7 +84,7 @@
|
|||
i
|
||||
(ref (make-refine i (make-const (car l)))
|
||||
(cdr l))))
|
||||
(define this (rename rest))
|
||||
(define this (rename-id rest))
|
||||
(make-var this
|
||||
(make-call (ref *scheme* (list "list" "apply"))
|
||||
(list
|
||||
|
|
@ -78,7 +94,7 @@
|
|||
|
||||
(define (bind-opt-args opts num-drop)
|
||||
(map (lambda (opt idx)
|
||||
(make-var (rename opt)
|
||||
(make-var (rename-id opt)
|
||||
(make-binop 'or
|
||||
(make-refine (make-id "arguments")
|
||||
(make-const (+ num-drop idx)))
|
||||
|
|
@ -89,7 +105,7 @@
|
|||
(define (bind-kw-args kws ids num-drop)
|
||||
(define lookup (make-refine *utils* (make-const "keyword_ref")))
|
||||
(map (lambda (kw id)
|
||||
(make-var (rename id)
|
||||
(make-var (rename-id id)
|
||||
(make-call lookup
|
||||
(list (compile-const kw)
|
||||
(make-id "arguments")
|
||||
|
|
@ -105,7 +121,7 @@
|
|||
(($ il:program (and entry ($ il:var name _)) body)
|
||||
(let ((entry-call
|
||||
(make-return
|
||||
(make-call (name->id name)
|
||||
(make-call (compile-id name)
|
||||
(list
|
||||
(make-id "undefined")
|
||||
(make-refine *scheme* (make-const "initial_cont")))))))
|
||||
|
|
@ -114,10 +130,11 @@
|
|||
'())))
|
||||
|
||||
(($ il:continuation params body)
|
||||
(make-function (map rename params) (list (compile-exp body))))
|
||||
(make-function (map rename-id params) (list (compile-exp body))))
|
||||
|
||||
(($ il:function params body)
|
||||
(make-function (map rename params) (list (compile-exp body))))
|
||||
(($ il:function self tail body)
|
||||
(make-function (list (rename-id self) (rename-id tail))
|
||||
(list (compile-exp body))))
|
||||
|
||||
(($ il:jump-table specs)
|
||||
(compile-jump-table specs))
|
||||
|
|
@ -126,10 +143,10 @@
|
|||
(make-block (append (map compile-exp bindings) (list (compile-exp body)))))
|
||||
|
||||
(($ il:var id exp)
|
||||
(make-var (rename id) (compile-exp exp)))
|
||||
(make-var (rename-id id) (compile-exp exp)))
|
||||
|
||||
(($ il:continue k exps)
|
||||
(make-return (make-call (name->id k) (map compile-exp exps))))
|
||||
(make-return (make-call (compile-id k) (map compile-exp exps))))
|
||||
|
||||
(($ il:branch test then else)
|
||||
(make-branch (make-call (make-refine *scheme* (make-const "is_true"))
|
||||
|
|
@ -143,29 +160,34 @@
|
|||
(($ il:primcall name args)
|
||||
(make-call (make-refine (make-refine *scheme* (make-const "primitives"))
|
||||
(make-const (symbol->string name)))
|
||||
(map name->id args)))
|
||||
(map compile-id args)))
|
||||
|
||||
(($ il:call name args)
|
||||
(($ il:call name k args)
|
||||
(make-return
|
||||
(make-call (make-refine (name->id name) (make-const "fun"))
|
||||
(map name->id (cons name args)))))
|
||||
(make-call (make-refine (compile-id name) (make-const "fun"))
|
||||
(cons* (compile-id name)
|
||||
(compile-id k)
|
||||
(map compile-id args)))))
|
||||
|
||||
(($ il:closure label nfree)
|
||||
(make-new
|
||||
(make-call (make-refine *scheme* (make-const "Closure"))
|
||||
(list (name->id label) (make-const nfree)))))
|
||||
(list (compile-id label) (make-const nfree)))))
|
||||
|
||||
(($ il:prompt escape? tag handler)
|
||||
;; never a tailcall
|
||||
(make-call (make-refine (make-refine *scheme* (make-const "primitives"))
|
||||
(make-const "prompt"))
|
||||
(list (compile-const escape?) (name->id tag) (name->id handler))))
|
||||
(list (compile-const escape?) (compile-id tag) (compile-id handler))))
|
||||
|
||||
(($ il:seq body)
|
||||
(make-block (map compile-exp body)))
|
||||
|
||||
(($ il:id name)
|
||||
(name->id name))))
|
||||
(name->id name))
|
||||
|
||||
(($ il:kid name)
|
||||
(kont->id name))))
|
||||
|
||||
(define (compile-jump-table specs)
|
||||
(define offset 2) ; closure & continuation
|
||||
|
|
@ -203,8 +225,8 @@
|
|||
(($ il:params self req '() #f '() #f)
|
||||
(list
|
||||
(make-return
|
||||
(make-call (name->id k)
|
||||
(cons (name->id self)
|
||||
(make-call (compile-id k)
|
||||
(cons (compile-id self)
|
||||
(map (lambda (idx)
|
||||
(make-refine (make-id "arguments")
|
||||
(make-const (+ offset idx))))
|
||||
|
|
@ -213,39 +235,39 @@
|
|||
(list
|
||||
(bind-rest-args rest (+ offset (length req)))
|
||||
(make-return
|
||||
(make-call (name->id k)
|
||||
(append (list (name->id self))
|
||||
(make-call (compile-id k)
|
||||
(append (list (compile-id self))
|
||||
(map (lambda (idx)
|
||||
(make-refine (make-id "arguments")
|
||||
(make-const (+ offset idx))))
|
||||
(iota (length req)))
|
||||
(list (name->id rest)))))))
|
||||
(list (compile-id rest)))))))
|
||||
(($ il:params self req opts #f '() #f)
|
||||
(append
|
||||
(bind-opt-args opts (+ offset (length req)))
|
||||
(list
|
||||
(make-return
|
||||
(make-call (name->id k)
|
||||
(append (list (name->id self))
|
||||
(make-call (compile-id k)
|
||||
(append (list (compile-id self))
|
||||
(map (lambda (idx)
|
||||
(make-refine (make-id "arguments")
|
||||
(make-const (+ offset idx))))
|
||||
(iota (length req)))
|
||||
(map name->id opts)))))))
|
||||
(map compile-id opts)))))))
|
||||
(($ il:params self req opts #f ((kws names ids) ...) _)
|
||||
(append
|
||||
(bind-opt-args opts (+ offset (length req)))
|
||||
(bind-kw-args kws names (+ offset (length req)))
|
||||
(list
|
||||
(make-return
|
||||
(make-call (name->id k)
|
||||
(append (list (name->id self))
|
||||
(make-call (compile-id k)
|
||||
(append (list (compile-id self))
|
||||
(map (lambda (idx)
|
||||
(make-refine (make-id "arguments")
|
||||
(make-const (+ offset idx))))
|
||||
(iota (length req)))
|
||||
(map name->id opts)
|
||||
(map name->id names)))))))
|
||||
(map compile-id opts)
|
||||
(map compile-id names)))))))
|
||||
))
|
||||
(fold-right (lambda (a d)
|
||||
(make-branch (compile-test (car a))
|
||||
|
|
|
|||
|
|
@ -12,8 +12,8 @@
|
|||
(($ continuation params body)
|
||||
(make-continuation params (remove-immediate-calls body)))
|
||||
|
||||
(($ function params body)
|
||||
(make-function params (remove-immediate-calls body)))
|
||||
(($ function self tail body)
|
||||
(make-function self tail (remove-immediate-calls body)))
|
||||
|
||||
(($ local
|
||||
(($ var id ($ continuation () body)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue