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

Different types for Continuation and Variable identifiers

Browse source
This commit is contained in:
Ian Price 2015-06-18 11:02:05 +01:00
parent 78cacbe450
commit 2e10f55426
4 changed files with 127 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -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