mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 05:50:26 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: module/language/tree-il/peval.scm module/language/tree-il/primitives.scm test-suite/tests/tree-il.test
This commit is contained in:
commit
2f4aae6bce
6 changed files with 108 additions and 21 deletions
|
@ -332,9 +332,9 @@
|
|||
((<let-values> exp body)
|
||||
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
|
||||
|
||||
((<dynwind> body winder unwinder)
|
||||
`(dynwind ,(unparse-tree-il body)
|
||||
,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))
|
||||
((<dynwind> winder body unwinder)
|
||||
`(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
|
||||
,(unparse-tree-il unwinder)))
|
||||
|
||||
((<dynlet> fluids vals body)
|
||||
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
|
||||
|
|
|
@ -523,16 +523,18 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(and tail (make-seq src head tail)))))))
|
||||
|
||||
(define (constant-expression? x)
|
||||
;; Return true if X is constant---i.e., if it is known to have no
|
||||
;; effects, does not allocate storage for a mutable object, and does
|
||||
;; not access mutable data (like `car' or toplevel references).
|
||||
;; Return true if X is constant, for the purposes of copying or
|
||||
;; elision---i.e., if it is known to have no effects, does not
|
||||
;; allocate storage for a mutable object, and does not access
|
||||
;; mutable data (like `car' or toplevel references).
|
||||
(let loop ((x x))
|
||||
(match x
|
||||
(($ <void>) #t)
|
||||
(($ <const>) #t)
|
||||
(($ <lambda>) #t)
|
||||
(($ <lambda-case> _ req opt rest kw inits _ body alternate)
|
||||
(and (every loop inits) (loop body)
|
||||
(($ <lambda-case> _ req opt rest kw inits syms body alternate)
|
||||
(and (not (any assigned-lexical? syms))
|
||||
(every loop inits) (loop body)
|
||||
(or (not alternate) (loop alternate))))
|
||||
(($ <lexical-ref> _ _ gensym)
|
||||
(not (assigned-lexical? gensym)))
|
||||
|
@ -550,10 +552,12 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(and (loop body) (every loop args)))
|
||||
(($ <seq> _ head tail)
|
||||
(and (loop head) (loop tail)))
|
||||
(($ <let> _ _ _ vals body)
|
||||
(and (every loop vals) (loop body)))
|
||||
(($ <letrec> _ _ _ _ vals body)
|
||||
(and (every loop vals) (loop body)))
|
||||
(($ <let> _ _ syms vals body)
|
||||
(and (not (any assigned-lexical? syms))
|
||||
(every loop vals) (loop body)))
|
||||
(($ <letrec> _ _ _ syms vals body)
|
||||
(and (not (any assigned-lexical? syms))
|
||||
(every loop vals) (loop body)))
|
||||
(($ <fix> _ _ _ vals body)
|
||||
(and (every loop vals) (loop body)))
|
||||
(($ <let-values> _ exp body)
|
||||
|
@ -824,8 +828,10 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(ops (make-bound-operands vars new vals visit))
|
||||
(env* (fold extend-env env gensyms ops))
|
||||
(body* (visit body counter ctx)))
|
||||
(if (and (const? body*)
|
||||
(every constant-expression? vals))
|
||||
(if (and (const? body*) (every constant-expression? vals))
|
||||
;; We may have folded a loop completely, even though there
|
||||
;; might be cyclical references between the bound values.
|
||||
;; Handle this degenerate case specially.
|
||||
body*
|
||||
(prune-bindings ops in-order? body* counter ctx
|
||||
(lambda (names gensyms vals body)
|
||||
|
@ -858,8 +864,39 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(_ #f))
|
||||
(make-let-values lv-src producer (for-tail consumer)))))
|
||||
(($ <dynwind> src winder body unwinder)
|
||||
(make-dynwind src (for-value winder) (for-tail body)
|
||||
(for-value unwinder)))
|
||||
(let ((pre (for-value winder))
|
||||
(body (for-tail body))
|
||||
(post (for-value unwinder)))
|
||||
(cond
|
||||
((not (constant-expression? pre))
|
||||
(cond
|
||||
((not (constant-expression? post))
|
||||
(let ((pre-sym (gensym "pre ")) (post-sym (gensym "post ")))
|
||||
(record-new-temporary! 'pre pre-sym 1)
|
||||
(record-new-temporary! 'post post-sym 1)
|
||||
(make-let src '(pre post) (list pre-sym post-sym) (list pre post)
|
||||
(make-dynwind src
|
||||
(make-lexical-ref #f 'pre pre-sym)
|
||||
body
|
||||
(make-lexical-ref #f 'post post-sym)))))
|
||||
(else
|
||||
(let ((pre-sym (gensym "pre ")))
|
||||
(record-new-temporary! 'pre pre-sym 1)
|
||||
(make-let src '(pre) (list pre-sym) (list pre)
|
||||
(make-dynwind src
|
||||
(make-lexical-ref #f 'pre pre-sym)
|
||||
body
|
||||
post))))))
|
||||
((not (constant-expression? post))
|
||||
(let ((post-sym (gensym "post ")))
|
||||
(record-new-temporary! 'post post-sym 1)
|
||||
(make-let src '(post) (list post-sym) (list post)
|
||||
(make-dynwind src
|
||||
pre
|
||||
body
|
||||
(make-lexical-ref #f 'post post-sym)))))
|
||||
(else
|
||||
(make-dynwind src pre body post)))))
|
||||
(($ <dynlet> src fluids vals body)
|
||||
(make-dynlet src (map for-value fluids) (map for-value vals)
|
||||
(for-tail body)))
|
||||
|
|
|
@ -22,8 +22,7 @@
|
|||
remv remq memp member memv memq assp assoc assv assq cons*)
|
||||
(import (rnrs base (6))
|
||||
(only (guile) filter member memv memq assoc assv assq cons*)
|
||||
(rename (only (srfi srfi-1) fold
|
||||
any
|
||||
(rename (only (srfi srfi-1) any
|
||||
every
|
||||
remove
|
||||
member
|
||||
|
@ -32,7 +31,6 @@
|
|||
partition
|
||||
fold-right
|
||||
filter-map)
|
||||
(fold fold-left)
|
||||
(any exists)
|
||||
(every for-all)
|
||||
(remove remp)
|
||||
|
@ -40,6 +38,14 @@
|
|||
(member memp-internal)
|
||||
(assoc assp-internal)))
|
||||
|
||||
(define (fold-left combine nil list . lists)
|
||||
(define (fold nil lists)
|
||||
(if (exists null? lists)
|
||||
nil
|
||||
(fold (apply combine nil (map car lists))
|
||||
(map cdr lists))))
|
||||
(fold nil (cons list lists)))
|
||||
|
||||
(define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list))
|
||||
(define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
|
||||
(define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))
|
||||
|
|
|
@ -134,13 +134,13 @@
|
|||
(let* ((fields (if (unspecified? _fields) '() _fields))
|
||||
(field-names (list->vector (map car fields)))
|
||||
(field-accessors
|
||||
(fold-left (lambda (x c lst)
|
||||
(fold-left (lambda (lst x c)
|
||||
(cons #`(define #,(cadr x)
|
||||
(record-accessor record-name #,c))
|
||||
lst))
|
||||
'() fields (sequence (length fields))))
|
||||
(field-mutators
|
||||
(fold-left (lambda (x c lst)
|
||||
(fold-left (lambda (lst x c)
|
||||
(if (caddr x)
|
||||
(cons #`(define #,(caddr x)
|
||||
(record-mutator record-name
|
||||
|
|
|
@ -30,3 +30,29 @@
|
|||
(let ((d '((3 a) (1 b) (4 c))))
|
||||
(equal? (assp even? d) '(4 c)))))
|
||||
|
||||
(with-test-prefix "fold-left"
|
||||
(pass-if "fold-left sum"
|
||||
(equal? (fold-left + 0 '(1 2 3 4 5))
|
||||
15))
|
||||
(pass-if "fold-left reverse"
|
||||
(equal? (fold-left (lambda (a e) (cons e a)) '() '(1 2 3 4 5))
|
||||
'(5 4 3 2 1)))
|
||||
(pass-if "fold-left max-length"
|
||||
(equal? (fold-left (lambda (max-len s)
|
||||
(max max-len (string-length s)))
|
||||
0
|
||||
'("longest" "long" "longer"))
|
||||
7))
|
||||
(pass-if "fold-left with-cons"
|
||||
(equal? (fold-left cons '(q) '(a b c))
|
||||
'((((q) . a) . b) . c)))
|
||||
(pass-if "fold-left sum-multiple"
|
||||
(equal? (fold-left + 0 '(1 2 3) '(4 5 6))
|
||||
21))
|
||||
(pass-if "fold-left pairlis"
|
||||
(equal? (fold-left (lambda (accum e1 e2)
|
||||
(cons (cons e1 e2) accum))
|
||||
'((d . 4))
|
||||
'(a b c)
|
||||
'(1 2 3))
|
||||
'((c . 3) (b . 2) (a . 1) (d . 4)))))
|
||||
|
|
|
@ -1461,6 +1461,24 @@
|
|||
(cdr (list (bar) 0))
|
||||
(seq (call (toplevel bar)) (primcall list (const 0))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Non-constant guards get lexical bindings.
|
||||
(dynamic-wind foo (lambda () bar) baz)
|
||||
(let (pre post) (_ _) ((toplevel foo) (toplevel baz))
|
||||
(dynwind (lexical pre _) (toplevel bar) (lexical post _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant guards don't need lexical bindings.
|
||||
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
|
||||
(dynwind
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
((() #f #f #f () ()) (toplevel foo))))
|
||||
(toplevel bar)
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
((() #f #f #f () ()) (toplevel baz))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Prompt is removed if tag is unreferenced
|
||||
(let ((tag (make-prompt-tag)))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue