mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-17 17:20:29 +02:00
Change local type representation and remove var type
This commit is contained in:
parent
e9f37e6a31
commit
a680a4cb9d
4 changed files with 39 additions and 42 deletions
|
@ -74,36 +74,32 @@
|
||||||
(make-continuation
|
(make-continuation
|
||||||
(cons (make-id self) ids)
|
(cons (make-id self) ids)
|
||||||
(match body
|
(match body
|
||||||
(($ $cont k _)
|
(($ $cont k cont)
|
||||||
(make-local (list (compile-cont body))
|
(make-local `((,(make-kid k) . ,(compile-cont cont)))
|
||||||
(make-continue (make-kid k) ids)))))))))
|
(make-continue (make-kid k) ids)))))))))
|
||||||
|
|
||||||
(define (compile-term term)
|
(define (compile-term term)
|
||||||
(match term
|
(match term
|
||||||
(($ $letk conts body)
|
(($ $letk (($ $cont ks conts) ...) body)
|
||||||
(make-local (map compile-cont conts) (compile-term body)))
|
(make-local (map (lambda (k cont)
|
||||||
|
(cons (make-kid k)
|
||||||
|
(compile-cont cont)))
|
||||||
|
ks
|
||||||
|
conts)
|
||||||
|
(compile-term body)))
|
||||||
(($ $continue k src exp)
|
(($ $continue k src exp)
|
||||||
(compile-exp exp k))))
|
(compile-exp exp k))))
|
||||||
|
|
||||||
(define (compile-cont cont)
|
(define (compile-cont cont)
|
||||||
(match cont
|
(match cont
|
||||||
(($ $cont k ($ $kargs names syms body))
|
(($ $kargs names syms body)
|
||||||
;; use the name part?
|
(make-continuation (map make-id syms) (compile-term body)))
|
||||||
(make-var (make-kid k)
|
(($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)
|
||||||
(make-continuation (map make-id syms)
|
(let ((ids (map make-id (append req (list rest)))))
|
||||||
(compile-term body))))
|
(make-continuation ids (make-continue (make-kid k2) ids))))
|
||||||
(($ $cont k ($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2))
|
(($ $kreceive ($ $arity req _ #f _ _) k2)
|
||||||
(make-var
|
(let ((ids (map make-id req)))
|
||||||
(make-kid k)
|
(make-continuation ids (make-continue (make-kid k2) ids))))))
|
||||||
(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 (make-kid k)
|
|
||||||
(make-continuation (map make-id req)
|
|
||||||
(make-continue (make-kid k2)
|
|
||||||
(map make-id req)))))))
|
|
||||||
|
|
||||||
(define (compile-exp exp k)
|
(define (compile-exp exp k)
|
||||||
(match exp
|
(match exp
|
||||||
|
|
|
@ -7,7 +7,6 @@
|
||||||
make-params params
|
make-params params
|
||||||
make-continuation continuation
|
make-continuation continuation
|
||||||
make-local local
|
make-local local
|
||||||
make-var var
|
|
||||||
make-continue continue
|
make-continue continue
|
||||||
make-const const
|
make-const const
|
||||||
make-primcall primcall
|
make-primcall primcall
|
||||||
|
@ -55,7 +54,6 @@
|
||||||
(define-js-type params self req opt rest kw allow-other-keys?)
|
(define-js-type params self req opt rest kw allow-other-keys?)
|
||||||
(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 continue cont args)
|
(define-js-type continue cont args)
|
||||||
(define-js-type const value)
|
(define-js-type const value)
|
||||||
(define-js-type primcall name args)
|
(define-js-type primcall name args)
|
||||||
|
@ -96,9 +94,12 @@
|
||||||
kws)
|
kws)
|
||||||
,allow-other-keys?))
|
,allow-other-keys?))
|
||||||
(($ local bindings body)
|
(($ local bindings body)
|
||||||
`(local ,(map unparse-js bindings) ,(unparse-js body)))
|
`(local ,(map (match-lambda
|
||||||
(($ var id exp)
|
((a . d)
|
||||||
`(var ,id ,(unparse-js exp)))
|
(cons (unparse-js a)
|
||||||
|
(unparse-js d))))
|
||||||
|
bindings)
|
||||||
|
,(unparse-js body)))
|
||||||
(($ continue ($ kid k) args)
|
(($ continue ($ kid k) args)
|
||||||
`(continue ,k ,(map unparse-js args)))
|
`(continue ,k ,(map unparse-js args)))
|
||||||
(($ branch test then else)
|
(($ branch test then else)
|
||||||
|
|
|
@ -149,11 +149,13 @@
|
||||||
clauses)
|
clauses)
|
||||||
(list (compile-jump-table clauses)))))
|
(list (compile-jump-table clauses)))))
|
||||||
|
|
||||||
(($ il:local bindings body)
|
(($ il:local ((ids . bindings) ...) body)
|
||||||
(make-block (append (map compile-exp bindings) (list (compile-exp body)))))
|
(make-block
|
||||||
|
(append (map (lambda (id binding)
|
||||||
(($ il:var id exp)
|
(make-var (rename-id id) (compile-exp binding)))
|
||||||
(make-var (rename-id id) (compile-exp exp)))
|
ids
|
||||||
|
bindings)
|
||||||
|
(list (compile-exp body)))))
|
||||||
|
|
||||||
(($ il:continue k exps)
|
(($ il:continue k exps)
|
||||||
(make-return (make-call (compile-id k) (map compile-exp exps))))
|
(make-return (make-call (compile-id k) (map compile-exp exps))))
|
||||||
|
|
|
@ -31,12 +31,11 @@
|
||||||
(analyse body))
|
(analyse body))
|
||||||
|
|
||||||
(($ local bindings body)
|
(($ local bindings body)
|
||||||
(for-each analyse bindings)
|
(for-each (match-lambda
|
||||||
|
((i . b) (analyse b)))
|
||||||
|
bindings)
|
||||||
(analyse body))
|
(analyse body))
|
||||||
|
|
||||||
(($ var id exp)
|
|
||||||
(analyse exp))
|
|
||||||
|
|
||||||
(($ continue ($ kid cont) args)
|
(($ continue ($ kid cont) args)
|
||||||
(count-inc! cont)
|
(count-inc! cont)
|
||||||
(for-each analyse args))
|
(for-each analyse args))
|
||||||
|
@ -103,12 +102,12 @@
|
||||||
|
|
||||||
(define (split-inlinable bindings)
|
(define (split-inlinable bindings)
|
||||||
(partition (match-lambda
|
(partition (match-lambda
|
||||||
(($ var ($ kid id) _) (inlinable? id)))
|
((($ kid id) . _) (inlinable? id)))
|
||||||
bindings))
|
bindings))
|
||||||
|
|
||||||
(define (lookup kont substs)
|
(define (lookup kont substs)
|
||||||
(match substs
|
(match substs
|
||||||
((($ var ($ kid id) exp) . rest)
|
(((($ kid id) . exp) . rest)
|
||||||
(if (= id kont)
|
(if (= id kont)
|
||||||
exp
|
exp
|
||||||
(lookup kont rest)))
|
(lookup kont rest)))
|
||||||
|
@ -140,7 +139,7 @@
|
||||||
(($ continuation kargs body)
|
(($ continuation kargs body)
|
||||||
(if (not (= (length args) (length kargs)))
|
(if (not (= (length args) (length kargs)))
|
||||||
(throw 'args-dont-match cont args kargs)
|
(throw 'args-dont-match cont args kargs)
|
||||||
(make-local (map make-var kargs args)
|
(make-local (map cons kargs args)
|
||||||
;; gah, this doesn't work
|
;; gah, this doesn't work
|
||||||
;; identifiers need to be separated earlier
|
;; identifiers need to be separated earlier
|
||||||
;; not just as part of compilation
|
;; not just as part of compilation
|
||||||
|
@ -162,13 +161,12 @@
|
||||||
(split-inlinable bindings))
|
(split-inlinable bindings))
|
||||||
(lambda (new-substs uninlinable-bindings)
|
(lambda (new-substs uninlinable-bindings)
|
||||||
(define substs* (append new-substs substs))
|
(define substs* (append new-substs substs))
|
||||||
(make-local (map (lambda (x) (inline x substs*))
|
(make-local (map (match-lambda
|
||||||
|
((id . val)
|
||||||
|
`(,id . ,(inline val substs*))))
|
||||||
uninlinable-bindings)
|
uninlinable-bindings)
|
||||||
(inline body substs*)))))
|
(inline body substs*)))))
|
||||||
|
|
||||||
(($ var id exp)
|
|
||||||
(make-var id (inline exp substs)))
|
|
||||||
|
|
||||||
(($ seq body)
|
(($ seq body)
|
||||||
(make-seq (map (lambda (x) (inline x substs))
|
(make-seq (map (lambda (x) (inline x substs))
|
||||||
body)))
|
body)))
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue