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