mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-28 14:00:31 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
This was a pretty big merge involving a fair amount of porting, especially to peval and its tests. I did not update psyntax-pp.scm, that comes in the next commit. Conflicts: module/ice-9/boot-9.scm module/ice-9/psyntax-pp.scm module/language/ecmascript/compile-tree-il.scm module/language/tree-il.scm module/language/tree-il/analyze.scm module/language/tree-il/inline.scm test-suite/tests/tree-il.test
This commit is contained in:
Andy Wingo
commit
ca12824581
60 changed files with 3173 additions and 957 deletions
|
|
@ -67,6 +67,7 @@ SCM_TESTS = tests/00-initial-env.test \
|
|||
tests/list.test \
|
||||
tests/load.test \
|
||||
tests/match.test \
|
||||
tests/match.test.upstream \
|
||||
tests/modules.test \
|
||||
tests/multilingual.nottest \
|
||||
tests/net-db.test \
|
||||
|
|
|
|||
|
|
@ -178,6 +178,13 @@ test_scm_take_u8vector_LDADD = $(LIBGUILE_LDADD)
|
|||
check_PROGRAMS += test-scm-take-u8vector
|
||||
TESTS += test-scm-take-u8vector
|
||||
|
||||
# test-scm-take-u8vector
|
||||
test_scm_to_latin1_string_SOURCES = test-scm-to-latin1-string.c
|
||||
test_scm_to_latin1_string_CFLAGS = ${test_cflags}
|
||||
test_scm_to_latin1_string_LDADD = $(LIBGUILE_LDADD)
|
||||
check_PROGRAMS += test-scm-to-latin1-string
|
||||
TESTS += test-scm-to-latin1-string
|
||||
|
||||
if HAVE_SHARED_LIBRARIES
|
||||
|
||||
# test-extensions
|
||||
|
|
|
|||
78
test-suite/standalone/test-scm-to-latin1-string.c
Normal file
78
test-suite/standalone/test-scm-to-latin1-string.c
Normal file
|
|
@ -0,0 +1,78 @@
|
|||
/* Copyright (C) 2011 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
* as published by the Free Software Foundation; either version 3 of
|
||||
* the License, or (at your option) any later version.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this library; if not, write to the Free Software
|
||||
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
* 02110-1301 USA
|
||||
*/
|
||||
|
||||
|
||||
#ifdef HAVE_CONFIG_H
|
||||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include <libguile.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
/*
|
||||
This outputs:
|
||||
|
||||
dhansen@localhorst ~/tmp $ ./a.out
|
||||
foo,bar
|
||||
bar
|
||||
|
||||
*/
|
||||
|
||||
#define TEST(x) \
|
||||
if (!(x)) abort()
|
||||
|
||||
static void
|
||||
inner_main (void *data, int argc, char **argv)
|
||||
{
|
||||
char *cstr;
|
||||
|
||||
SCM string, tokens, tok;
|
||||
|
||||
string = scm_from_latin1_string ("foo,bar");
|
||||
tokens = scm_string_split (string, SCM_MAKE_CHAR (','));
|
||||
|
||||
TEST (scm_is_pair (tokens));
|
||||
tok = scm_car (tokens);
|
||||
TEST (scm_is_string (tok));
|
||||
cstr = scm_to_latin1_string (tok);
|
||||
TEST (strcmp (cstr, "foo") == 0);
|
||||
free (cstr);
|
||||
tokens = scm_cdr (tokens);
|
||||
|
||||
TEST (scm_is_pair (tokens));
|
||||
tok = scm_car (tokens);
|
||||
TEST (scm_is_string (tok));
|
||||
cstr = scm_to_latin1_string (tok);
|
||||
TEST (strcmp (cstr, "bar") == 0);
|
||||
free (cstr);
|
||||
tokens = scm_cdr (tokens);
|
||||
|
||||
TEST (scm_is_null (tokens));
|
||||
}
|
||||
|
||||
int
|
||||
main (int argc, char **argv)
|
||||
{
|
||||
scm_boot_guile (argc, argv, inner_main, NULL);
|
||||
|
||||
return EXIT_SUCCESS;
|
||||
}
|
||||
|
||||
/* Local Variables: */
|
||||
/* compile-command: "gcc `pkg-config --cflags --libs guile-2.0` main.c" */
|
||||
/* End: */
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
;;;; gc.test --- test guile's garbage collection -*- scheme -*-
|
||||
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009,
|
||||
;;;; 2011 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -46,6 +47,13 @@
|
|||
;;;
|
||||
;;;
|
||||
|
||||
(define (stack-cleanup depth)
|
||||
;; Clean up stack space for DEPTH words. This is defined here so that
|
||||
;; `peval' doesn't inline it.
|
||||
(let cleanup ((i depth))
|
||||
(and (> i 0)
|
||||
(begin (cleanup (1- i)) i))))
|
||||
|
||||
(with-test-prefix "gc"
|
||||
|
||||
(pass-if "after-gc-hook gets called"
|
||||
|
|
@ -65,9 +73,7 @@
|
|||
(for-each (lambda (x) (guard (make-module))) (iota total))
|
||||
|
||||
;; Avoid false references to the modules on the stack.
|
||||
(let cleanup ((i 20))
|
||||
(and (> i 0)
|
||||
(begin (cleanup (1- i)) i)))
|
||||
(stack-cleanup 20)
|
||||
|
||||
(gc)
|
||||
(gc) ;; twice: have to kill the weak vectors.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; match.test --- (ice-9 match) -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -18,11 +18,25 @@
|
|||
|
||||
(define-module (test-match)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (test-suite lib))
|
||||
|
||||
(define exception:match-error
|
||||
(cons 'match-error "^.*$"))
|
||||
|
||||
(define-record-type rtd-2-slots
|
||||
(make-2-slot-record a b)
|
||||
two-slot-record?
|
||||
(a slot-first)
|
||||
(b slot-second))
|
||||
|
||||
(define-record-type rtd-3-slots
|
||||
(make-3-slot-record a b c)
|
||||
three-slot-record?
|
||||
(a slot-one)
|
||||
(b slot-two)
|
||||
(c slot-three))
|
||||
|
||||
|
||||
(with-test-prefix "matches"
|
||||
|
||||
|
|
@ -86,7 +100,61 @@
|
|||
(let ((tree '(one (two 2) (three 3 (and 4 (and 5))))))
|
||||
(match tree
|
||||
(('one ('two x) ('three y ('and z '(and 5))))
|
||||
(equal? (list x y z) '(2 3 4)))))))
|
||||
(equal? (list x y z) '(2 3 4))))))
|
||||
|
||||
(pass-if "and, unique names"
|
||||
(let ((tree '(1 2)))
|
||||
(match tree
|
||||
((and (a 2) (1 b))
|
||||
(equal? 3 (+ a b))))))
|
||||
|
||||
(pass-if "and, same names"
|
||||
(let ((a '(1 2)))
|
||||
(match a
|
||||
((and (a 2) (1 b))
|
||||
(equal? 3 (+ a b))))))
|
||||
|
||||
(with-test-prefix "records"
|
||||
|
||||
(pass-if "all slots, bind"
|
||||
(let ((r (make-3-slot-record 1 2 3)))
|
||||
(match r
|
||||
(($ rtd-3-slots a b c)
|
||||
(equal? (list a b c) '(1 2 3))))))
|
||||
|
||||
(pass-if "all slots, literals"
|
||||
(let ((r (make-3-slot-record 1 2 3)))
|
||||
(match r
|
||||
(($ rtd-3-slots 1 2 3)
|
||||
#t))))
|
||||
|
||||
(pass-if "2 slots"
|
||||
(let ((r (make-3-slot-record 1 2 3)))
|
||||
(match r
|
||||
(($ rtd-3-slots x y)
|
||||
(equal? (list x y) '(1 2))))))
|
||||
|
||||
(pass-if "RTD correctly checked"
|
||||
(let ((r (make-2-slot-record 1 2)))
|
||||
(match r
|
||||
(($ rtd-3-slots a b)
|
||||
#f)
|
||||
(($ rtd-2-slots a b)
|
||||
(equal? (list a b) '(1 2))))))
|
||||
|
||||
(pass-if "getter"
|
||||
(match (make-2-slot-record 1 2)
|
||||
(($ rtd-2-slots (get! first) (get! second))
|
||||
(equal? (list (first) (second)) '(1 2)))))
|
||||
|
||||
(pass-if "setter"
|
||||
(let ((r (make-2-slot-record 1 2)))
|
||||
(match r
|
||||
(($ rtd-2-slots (set! set-first!) (set! set-second!))
|
||||
(set-first! 'one)
|
||||
(set-second! 'two)
|
||||
(equal? (list (slot-first r) (slot-second r))
|
||||
'(one two))))))))
|
||||
|
||||
|
||||
(with-test-prefix "doesn't match"
|
||||
|
|
@ -105,4 +173,36 @@
|
|||
exception:match-error
|
||||
(match '(a 0)
|
||||
(((and x (? symbol?)) ..1)
|
||||
(equal? x '(a b c))))))
|
||||
(equal? x '(a b c)))))
|
||||
|
||||
(with-test-prefix "records"
|
||||
|
||||
(pass-if "not a record"
|
||||
(match "hello"
|
||||
(($ rtd-2-slots) #f)
|
||||
(_ #t)))
|
||||
|
||||
(pass-if-exception "too many slots"
|
||||
exception:out-of-range
|
||||
(let ((r (make-3-slot-record 1 2 3)))
|
||||
(match r
|
||||
(($ rtd-3-slots a b c d)
|
||||
#f))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Upstream tests, from Chibi-Scheme (3-clause BSD license).
|
||||
;;;
|
||||
|
||||
(let-syntax ((load (syntax-rules ()
|
||||
((_ file) #t)))
|
||||
(test (syntax-rules ()
|
||||
((_ name expected expr)
|
||||
(pass-if name
|
||||
(equal? expected expr)))))
|
||||
(test-begin (syntax-rules ()
|
||||
((_ name) #t)))
|
||||
(test-end (syntax-rules ()
|
||||
((_) #t))))
|
||||
(with-test-prefix "upstream tests"
|
||||
(include-from-path "test-suite/tests/match.test.upstream")))
|
||||
|
|
|
|||
168
test-suite/tests/match.test.upstream
Normal file
168
test-suite/tests/match.test.upstream
Normal file
|
|
@ -0,0 +1,168 @@
|
|||
|
||||
(cond-expand
|
||||
(modules (import (chibi match) (only (chibi test) test-begin test test-end)))
|
||||
(else (load "lib/chibi/match/match.scm")))
|
||||
|
||||
(test-begin "match")
|
||||
|
||||
(test "any" 'ok (match 'any (_ 'ok)))
|
||||
(test "symbol" 'ok (match 'ok (x x)))
|
||||
(test "number" 'ok (match 28 (28 'ok)))
|
||||
(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok)))
|
||||
(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok)))
|
||||
(test "null" 'ok (match '() (() 'ok)))
|
||||
(test "pair" 'ok (match '(ok) ((x) x)))
|
||||
(test "vector" 'ok (match '#(ok) (#(x) x)))
|
||||
(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok)))
|
||||
(test "and empty" 'ok (match '(o k) ((and) 'ok)))
|
||||
(test "and single" 'ok (match 'ok ((and x) x)))
|
||||
(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok)))
|
||||
(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
|
||||
(test "or single" 'ok (match 'ok ((or x) 'ok)))
|
||||
(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
|
||||
(test "not" 'ok (match 28 ((not (a . b)) 'ok)))
|
||||
(test "pred" 'ok (match 28 ((? number?) 'ok)))
|
||||
(test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
|
||||
|
||||
(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
|
||||
(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
|
||||
(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
|
||||
|
||||
(test "ellipses" '((a b c) (1 2 3))
|
||||
(match '((a . 1) (b . 2) (c . 3))
|
||||
(((x . y) ___) (list x y))))
|
||||
|
||||
(test "real ellipses" '((a b c) (1 2 3))
|
||||
(match '((a . 1) (b . 2) (c . 3))
|
||||
(((x . y) ...) (list x y))))
|
||||
|
||||
(test "vector ellipses" '(1 2 3 (a b c) (1 2 3))
|
||||
(match '#(1 2 3 (a . 1) (b . 2) (c . 3))
|
||||
(#(a b c (hd . tl) ...) (list a b c hd tl))))
|
||||
|
||||
(test "pred ellipses" '(1 2 3)
|
||||
(match '(1 2 3)
|
||||
(((? odd? n) ___) n)
|
||||
(((? number? n) ___) n)))
|
||||
|
||||
(test "failure continuation" 'ok
|
||||
(match '(1 2)
|
||||
((a . b) (=> next) (if (even? a) 'fail (next)))
|
||||
((a . b) 'ok)))
|
||||
|
||||
(test "let" '(o k)
|
||||
(match-let ((x 'ok) (y '(o k))) y))
|
||||
|
||||
(test "let*" '(f o o f)
|
||||
(match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w)))
|
||||
|
||||
(test "getter car" '(1 2)
|
||||
(match '(1 . 2) (((get! a) . b) (list (a) b))))
|
||||
|
||||
(test "getter cdr" '(1 2)
|
||||
(match '(1 . 2) ((a . (get! b)) (list a (b)))))
|
||||
|
||||
(test "getter vector" '(1 2 3)
|
||||
(match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
|
||||
|
||||
(test "setter car" '(3 . 2)
|
||||
(let ((x (cons 1 2)))
|
||||
(match x (((set! a) . b) (a 3)))
|
||||
x))
|
||||
|
||||
(test "setter cdr" '(1 . 3)
|
||||
(let ((x (cons 1 2)))
|
||||
(match x ((a . (set! b)) (b 3)))
|
||||
x))
|
||||
|
||||
(test "setter vector" '#(1 0 3)
|
||||
(let ((x (vector 1 2 3)))
|
||||
(match x (#(a (set! b) c) (b 0)))
|
||||
x))
|
||||
|
||||
(test "single tail" '((a b) (1 2) (c . 3))
|
||||
(match '((a . 1) (b . 2) (c . 3))
|
||||
(((x . y) ... last) (list x y last))))
|
||||
|
||||
(test "single tail 2" '((a b) (1 2) 3)
|
||||
(match '((a . 1) (b . 2) 3)
|
||||
(((x . y) ... last) (list x y last))))
|
||||
|
||||
(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
|
||||
(match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
|
||||
(((x . y) ... u v w) (list x y u v w))))
|
||||
|
||||
(test "tail against improper list" #f
|
||||
(match '(a b c d e f . g)
|
||||
((x ... y u v w) (list x y u v w))
|
||||
(else #f)))
|
||||
|
||||
(test "Riastradh quasiquote" '(2 3)
|
||||
(match '(1 2 3) (`(1 ,b ,c) (list b c))))
|
||||
|
||||
(test "trivial tree search" '(1 2 3)
|
||||
(match '(1 2 3) ((_ *** (a b c)) (list a b c))))
|
||||
|
||||
(test "simple tree search" '(1 2 3)
|
||||
(match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
|
||||
|
||||
(test "deep tree search" '(1 2 3)
|
||||
(match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
|
||||
|
||||
(test "non-tail tree search" '(1 2 3)
|
||||
(match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
|
||||
|
||||
(test "restricted tree search" '(1 2 3)
|
||||
(match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
|
||||
|
||||
(test "fail restricted tree search" #f
|
||||
(match '(x (y (x a b c (1 2 3) d e f)))
|
||||
(('x *** (a b c)) (list a b c))
|
||||
(else #f)))
|
||||
|
||||
(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
|
||||
(match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
|
||||
(((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
|
||||
(list attrs text))
|
||||
(else #f)))
|
||||
|
||||
(test "failed sxml tree search" #f
|
||||
(match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
|
||||
(((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
|
||||
(list attrs text))
|
||||
(else #f)))
|
||||
|
||||
(test "collect tree search"
|
||||
'((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
|
||||
(match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
|
||||
(((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...))
|
||||
(list tag attrs text))
|
||||
(else #f)))
|
||||
|
||||
(test "anded tail pattern" '(1 2)
|
||||
(match '(1 2 3) ((and (a ... b) x) a)))
|
||||
|
||||
(test "anded search pattern" '(a b c)
|
||||
(match '(a (b (c d))) ((and (p *** 'd) x) p)))
|
||||
|
||||
(test "joined tail" '(1 2)
|
||||
(match '(1 2 3) ((and (a ... b) x) a)))
|
||||
|
||||
(test "list ..1" '(a b c)
|
||||
(match '(a b c) ((x ..1) x)))
|
||||
|
||||
(test "list ..1 failed" #f
|
||||
(match '()
|
||||
((x ..1) x)
|
||||
(else #f)))
|
||||
|
||||
(test "list ..1 with predicate" '(a b c)
|
||||
(match '(a b c)
|
||||
(((and x (? symbol?)) ..1) x)))
|
||||
|
||||
(test "list ..1 with failed predicate" #f
|
||||
(match '(a b 3)
|
||||
(((and x (? symbol?)) ..1) x)
|
||||
(else #f)))
|
||||
|
||||
(test-end)
|
||||
|
|
@ -40,8 +40,11 @@
|
|||
|
||||
;; make sure these are compiled so we're not swamped in `eval'
|
||||
(define (make-func)
|
||||
;; Disable partial evaluation so that `(+ i i)' doesn't get
|
||||
;; stripped.
|
||||
(compile '(lambda (n)
|
||||
(do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))))
|
||||
(do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))
|
||||
#:opts '(#:partial-eval? #f)))
|
||||
(define run-test
|
||||
(compile '(lambda (num-calls funcs)
|
||||
(let loop ((x num-calls) (funcs funcs))
|
||||
|
|
@ -50,11 +53,11 @@
|
|||
((car funcs) x)
|
||||
(loop (- x 1) (cdr funcs))))))))
|
||||
|
||||
(let ((num-calls 40000)
|
||||
(let ((num-calls 80000)
|
||||
(funcs (circular-list (make-func) (make-func) (make-func))))
|
||||
|
||||
;; Run test. 10000 us == 100 Hz.
|
||||
(statprof-reset 0 10000 #f #f)
|
||||
;; Run test. 20000 us == 200 Hz.
|
||||
(statprof-reset 0 20000 #f #f)
|
||||
(statprof-start)
|
||||
(run-test num-calls funcs)
|
||||
(statprof-stop)
|
||||
|
|
|
|||
|
|
@ -36,6 +36,13 @@
|
|||
(equal? '(a b c) '(a b c))
|
||||
a))
|
||||
|
||||
(define (stack-cleanup depth)
|
||||
;; Clean up stack space for DEPTH words. This is defined here so that
|
||||
;; `peval' doesn't inline it.
|
||||
(let cleanup ((i depth))
|
||||
(and (> i 0)
|
||||
(begin (cleanup (1- i)) i))))
|
||||
|
||||
(if (provided? 'threads)
|
||||
(begin
|
||||
|
||||
|
|
@ -403,9 +410,7 @@
|
|||
(g (let ((m (make-mutex))) (lock-mutex m) m))
|
||||
|
||||
;; Avoid false references to M on the stack.
|
||||
(let cleanup ((i 20))
|
||||
(and (> i 0)
|
||||
(begin (cleanup (1- i)) i)))
|
||||
(stack-cleanup 20)
|
||||
|
||||
(gc) (gc)
|
||||
(let ((m (g)))
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
#:use-module (system base pmatch)
|
||||
#:use-module (system base message)
|
||||
#:use-module (language tree-il)
|
||||
#:use-module (language tree-il primitives)
|
||||
#:use-module (language glil)
|
||||
#:use-module (srfi srfi-13))
|
||||
|
||||
|
|
@ -34,26 +35,28 @@
|
|||
(post-order! (lambda (x) (set! (tree-il-src x) #f))
|
||||
x))
|
||||
|
||||
(define-syntax assert-scheme->glil
|
||||
(syntax-rules ()
|
||||
((_ in out)
|
||||
(let ((tree-il (strip-source
|
||||
(compile 'in #:from 'scheme #:to 'tree-il))))
|
||||
(pass-if 'in
|
||||
(equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
|
||||
'out))))))
|
||||
|
||||
(define-syntax assert-tree-il->glil
|
||||
(syntax-rules ()
|
||||
((_ in pat test ...)
|
||||
(syntax-rules (with-partial-evaluation without-partial-evaluation
|
||||
with-options)
|
||||
((_ with-partial-evaluation in pat test ...)
|
||||
(assert-tree-il->glil with-options (#:partial-eval? #t)
|
||||
in pat test ...))
|
||||
((_ without-partial-evaluation in pat test ...)
|
||||
(assert-tree-il->glil with-options (#:partial-eval? #f)
|
||||
in pat test ...))
|
||||
((_ with-options opts in pat test ...)
|
||||
(let ((exp 'in))
|
||||
(pass-if 'in
|
||||
(let ((glil (unparse-glil
|
||||
(compile (strip-source (parse-tree-il exp))
|
||||
#:from 'tree-il #:to 'glil))))
|
||||
#:from 'tree-il #:to 'glil
|
||||
#:opts 'opts))))
|
||||
(pmatch glil
|
||||
(pat (guard test ...) #t)
|
||||
(else #f))))))))
|
||||
(else #f))))))
|
||||
((_ in pat test ...)
|
||||
(assert-tree-il->glil with-partial-evaluation
|
||||
in pat test ...))))
|
||||
|
||||
(define-syntax pass-if-tree-il->scheme
|
||||
(syntax-rules ()
|
||||
|
|
@ -66,6 +69,39 @@
|
|||
(pat (guard guard-exp) #t)
|
||||
(_ #f))))))
|
||||
|
||||
(define peval
|
||||
;; The partial evaluator.
|
||||
(@@ (language tree-il optimize) peval))
|
||||
|
||||
(define-syntax pass-if-peval
|
||||
(syntax-rules (resolve-primitives)
|
||||
((_ in pat)
|
||||
(pass-if-peval in pat
|
||||
(compile 'in #:from 'scheme #:to 'tree-il)))
|
||||
((_ resolve-primitives in pat)
|
||||
(pass-if-peval in pat
|
||||
(expand-primitives!
|
||||
(resolve-primitives!
|
||||
(compile 'in #:from 'scheme #:to 'tree-il)
|
||||
(current-module)))))
|
||||
((_ in pat code)
|
||||
(pass-if 'in
|
||||
(let ((evaled (unparse-tree-il (peval code))))
|
||||
(pmatch evaled
|
||||
(pat #t)
|
||||
(_ (pk 'peval-mismatch)
|
||||
((@ (ice-9 pretty-print) pretty-print)
|
||||
'in)
|
||||
(newline)
|
||||
((@ (ice-9 pretty-print) pretty-print)
|
||||
evaled)
|
||||
(newline)
|
||||
((@ (ice-9 pretty-print) pretty-print)
|
||||
'pat)
|
||||
(newline)
|
||||
#f)))))))
|
||||
|
||||
|
||||
(with-test-prefix "tree-il->scheme"
|
||||
(pass-if-tree-il->scheme
|
||||
(case-lambda ((a) a) ((b c) (list b c)))
|
||||
|
|
@ -107,8 +143,8 @@
|
|||
(const 1) (call return 1)
|
||||
(label ,l2) (const 2) (call return 1))
|
||||
(eq? l1 l2))
|
||||
|
||||
(assert-tree-il->glil
|
||||
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(begin (if (toplevel foo) (const 1) (const 2)) (const #f))
|
||||
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
|
||||
(label ,l3) (label ,l4) (const #f) (call return 1))
|
||||
|
|
@ -137,21 +173,21 @@
|
|||
(call return 1))))
|
||||
|
||||
(with-test-prefix "lexical refs"
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(let (x) (y) ((const 1)) (lexical x y))
|
||||
(program () (std-prelude 0 1 #f) (label _)
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
|
||||
(program () (std-prelude 0 1 #f) (label _)
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(const #f) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(let (x) (y) ((const 1)) (primcall null? (lexical x y)))
|
||||
(program () (std-prelude 0 1 #f) (label _)
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
|
|
@ -270,7 +306,7 @@
|
|||
(toplevel ref bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(begin (toplevel bar) (const #f))
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(toplevel ref bar) (call drop 1)
|
||||
|
|
@ -332,13 +368,14 @@
|
|||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
;; This gets simplified by `peval'.
|
||||
(primcall null? (const 2))
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(const 2) (call null? 1) (call return 1))))
|
||||
(const #f) (call return 1))))
|
||||
|
||||
(with-test-prefix "letrec"
|
||||
;; simple bindings -> let
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(letrec (x y) (x1 y1) ((const 10) (const 20))
|
||||
(call (toplevel foo) (lexical x x1) (lexical y y1)))
|
||||
(program () (std-prelude 0 2 #f) (label _)
|
||||
|
|
@ -351,7 +388,7 @@
|
|||
(unbind)))
|
||||
|
||||
;; complex bindings -> box and set! within let
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
|
||||
(primcall + (lexical x x1) (lexical y y1)))
|
||||
(program () (std-prelude 0 4 #f) (label _)
|
||||
|
|
@ -367,7 +404,7 @@
|
|||
(call add 2) (call return 1) (unbind)))
|
||||
|
||||
;; complex bindings in letrec* -> box and set! in order
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
|
||||
(primcall + (lexical x x1) (lexical y y1)))
|
||||
(program () (std-prelude 0 2 #f) (label _)
|
||||
|
|
@ -383,7 +420,7 @@
|
|||
(call add 2) (call return 1) (unbind)))
|
||||
|
||||
;; simple bindings in letrec* -> equivalent to letrec
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(letrec* (x y) (xx yy) ((const 1) (const 2))
|
||||
(lexical y yy))
|
||||
(program () (std-prelude 0 1 #f) (label _)
|
||||
|
|
@ -487,9 +524,10 @@
|
|||
(const #t) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
;; This gets simplified by `peval'.
|
||||
(primcall null? (begin (const #f) (const 2)))
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(const 2) (call null? 1) (call return 1))))
|
||||
(const #f) (call return 1))))
|
||||
|
||||
(with-test-prefix "values"
|
||||
(assert-tree-il->glil
|
||||
|
|
@ -514,7 +552,7 @@
|
|||
;; FIXME: binding info for or-hacked locals might bork the disassembler,
|
||||
;; and could be tightened in any case
|
||||
(with-test-prefix "the or hack"
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(let (x) (y) ((const 1))
|
||||
(if (lexical x y)
|
||||
(lexical x y)
|
||||
|
|
@ -532,7 +570,7 @@
|
|||
(eq? l1 l2))
|
||||
|
||||
;; second bound var is unreferenced
|
||||
(assert-tree-il->glil
|
||||
(assert-tree-il->glil without-partial-evaluation
|
||||
(let (x) (y) ((const 1))
|
||||
(if (lexical x y)
|
||||
(lexical x y)
|
||||
|
|
@ -586,6 +624,693 @@
|
|||
(toplevel ref bar) (call call/cc 1)
|
||||
(call tail-call 1))))
|
||||
|
||||
|
||||
(with-test-prefix "partial evaluation"
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, primitive.
|
||||
(let ((x 1) (y 2)) (+ x y))
|
||||
(const 3))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, thunk.
|
||||
(let ((x 1) (y 2))
|
||||
(let ((f (lambda () (+ x y))))
|
||||
(f)))
|
||||
(const 3))
|
||||
|
||||
(pass-if-peval resolve-primitives
|
||||
;; First order, let-values (requires primitive expansion for
|
||||
;; `call-with-values'.)
|
||||
(let ((x 0))
|
||||
(call-with-values
|
||||
(lambda () (if (zero? x) (values 1 2) (values 3 4)))
|
||||
(lambda (a b)
|
||||
(+ a b))))
|
||||
(const 3))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, coalesced, mutability preserved.
|
||||
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
|
||||
(primcall list
|
||||
(const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, coalesced, mutability preserved.
|
||||
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
|
||||
;; This must not be a constant.
|
||||
(primcall list
|
||||
(const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, coalesced, immutability preserved.
|
||||
(cons 0 (cons 1 (cons 2 '(3 4 5))))
|
||||
(primcall cons (const 0)
|
||||
(primcall cons (const 1)
|
||||
(primcall cons (const 2)
|
||||
(const (3 4 5))))))
|
||||
|
||||
;; These two tests doesn't work any more because we changed the way we
|
||||
;; deal with constants -- now the algorithm will see a construction as
|
||||
;; being bound to the lexical, so it won't propagate it. It can't
|
||||
;; even propagate it in the case that it is only referenced once,
|
||||
;; because:
|
||||
;;
|
||||
;; (let ((x (cons 1 2))) (lambda () x))
|
||||
;;
|
||||
;; is not the same as
|
||||
;;
|
||||
;; (lambda () (cons 1 2))
|
||||
;;
|
||||
;; Perhaps if we determined that not only was it only referenced once,
|
||||
;; it was not closed over by a lambda, then we could propagate it, and
|
||||
;; re-enable these two tests.
|
||||
;;
|
||||
#;
|
||||
(pass-if-peval
|
||||
;; First order, mutability preserved.
|
||||
(let loop ((i 3) (r '()))
|
||||
(if (zero? i)
|
||||
r
|
||||
(loop (1- i) (cons (cons i i) r))))
|
||||
(primcall list
|
||||
(primcall cons (const 1) (const 1))
|
||||
(primcall cons (const 2) (const 2))
|
||||
(primcall cons (const 3) (const 3))))
|
||||
;;
|
||||
;; See above.
|
||||
#;
|
||||
(pass-if-peval
|
||||
;; First order, evaluated.
|
||||
(let loop ((i 7)
|
||||
(r '()))
|
||||
(if (<= i 0)
|
||||
(car r)
|
||||
(loop (1- i) (cons i r))))
|
||||
(const 1))
|
||||
|
||||
;; Instead here are tests for what happens for the above cases: they
|
||||
;; unroll but they don't fold.
|
||||
(pass-if-peval
|
||||
(let loop ((i 3) (r '()))
|
||||
(if (zero? i)
|
||||
r
|
||||
(loop (1- i) (cons (cons i i) r))))
|
||||
(letrec (loop) (_) (_)
|
||||
(let (r) (_)
|
||||
((primcall list
|
||||
(primcall cons (const 3) (const 3))))
|
||||
(let (r) (_)
|
||||
((primcall cons
|
||||
(primcall cons (const 2) (const 2))
|
||||
(lexical r _)))
|
||||
(primcall cons
|
||||
(primcall cons (const 1) (const 1))
|
||||
(lexical r _))))))
|
||||
|
||||
;; See above.
|
||||
(pass-if-peval
|
||||
(let loop ((i 4)
|
||||
(r '()))
|
||||
(if (<= i 0)
|
||||
(car r)
|
||||
(loop (1- i) (cons i r))))
|
||||
(letrec (loop) (_) (_)
|
||||
(let (r) (_)
|
||||
((primcall list (const 4)))
|
||||
(let (r) (_)
|
||||
((primcall cons
|
||||
(const 3)
|
||||
(lexical r _)))
|
||||
(let (r) (_)
|
||||
((primcall cons
|
||||
(const 2)
|
||||
(lexical r _)))
|
||||
(let (r) (_)
|
||||
((primcall cons
|
||||
(const 1)
|
||||
(lexical r _)))
|
||||
(primcall car
|
||||
(lexical r _))))))))
|
||||
|
||||
;; Static sums.
|
||||
(pass-if-peval
|
||||
(let loop ((l '(1 2 3 4)) (sum 0))
|
||||
(if (null? l)
|
||||
sum
|
||||
(loop (cdr l) (+ sum (car l)))))
|
||||
(const 10))
|
||||
|
||||
(pass-if-peval
|
||||
;; Mutability preserved.
|
||||
((lambda (x y z) (list x y z)) 1 2 3)
|
||||
(primcall list (const 1) (const 2) (const 3)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Don't propagate effect-free expressions that operate on mutable
|
||||
;; objects.
|
||||
(let* ((x (list 1))
|
||||
(y (car x)))
|
||||
(set-car! x 0)
|
||||
y)
|
||||
(let (x) (_) ((primcall list (const 1)))
|
||||
(let (y) (_) ((primcall car (lexical x _)))
|
||||
(seq
|
||||
(call (toplevel set-car!) (lexical x _) (const 0))
|
||||
(lexical y _)))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Don't propagate effect-free expressions that operate on objects we
|
||||
;; don't know about.
|
||||
(let ((y (car x)))
|
||||
(set-car! x 0)
|
||||
y)
|
||||
(let (y) (_) ((primcall car (toplevel x)))
|
||||
(seq
|
||||
(call (toplevel set-car!) (toplevel x) (const 0))
|
||||
(lexical y _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Infinite recursion
|
||||
((lambda (x) (x x)) (lambda (x) (x x)))
|
||||
(let (x) (_)
|
||||
((lambda _
|
||||
(lambda-case
|
||||
(((x) _ _ _ _ _)
|
||||
(call (lexical x _) (lexical x _))))))
|
||||
(call (lexical x _) (lexical x _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, aliased primitive.
|
||||
(let* ((x *) (y (x 1 2))) y)
|
||||
(const 2))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, shadowed primitive.
|
||||
(begin
|
||||
(define (+ x y) (pk x y))
|
||||
(+ 1 2))
|
||||
(seq
|
||||
(define +
|
||||
(lambda (_)
|
||||
(lambda-case
|
||||
(((x y) #f #f #f () (_ _))
|
||||
(call (toplevel pk) (lexical x _) (lexical y _))))))
|
||||
(call (toplevel +) (const 1) (const 2))))
|
||||
|
||||
(pass-if-peval
|
||||
;; First-order, effects preserved.
|
||||
(let ((x 2))
|
||||
(do-something!)
|
||||
x)
|
||||
(seq
|
||||
(call (toplevel do-something!))
|
||||
(const 2)))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, residual bindings removed.
|
||||
(let ((x 2) (y 3))
|
||||
(* (+ x y) z))
|
||||
(primcall * (const 5) (toplevel z)))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, with lambda.
|
||||
(define (foo x)
|
||||
(define (bar z) (* z z))
|
||||
(+ x (bar 3)))
|
||||
(define foo
|
||||
(lambda (_)
|
||||
(lambda-case
|
||||
(((x) #f #f #f () (_))
|
||||
(primcall + (lexical x _) (const 9)))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, with lambda inlined & specialized twice.
|
||||
(let ((f (lambda (x y)
|
||||
(+ (* x top) y)))
|
||||
(x 2)
|
||||
(y 3))
|
||||
(+ (* x (f x y))
|
||||
(f something x)))
|
||||
(primcall +
|
||||
(primcall *
|
||||
(const 2)
|
||||
(primcall + ; (f 2 3)
|
||||
(primcall *
|
||||
(const 2)
|
||||
(toplevel top))
|
||||
(const 3)))
|
||||
(let (x) (_) ((toplevel something)) ; (f something 2)
|
||||
;; `something' is not const, so preserve order of
|
||||
;; effects with a lexical binding.
|
||||
(primcall +
|
||||
(primcall *
|
||||
(lexical x _)
|
||||
(toplevel top))
|
||||
(const 2)))))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, with lambda inlined & specialized 3 times.
|
||||
(let ((f (lambda (x y) (if (> x 0) y x))))
|
||||
(+ (f -1 0)
|
||||
(f 1 0)
|
||||
(f -1 y)
|
||||
(f 2 y)
|
||||
(f z y)))
|
||||
(primcall +
|
||||
(const -1) ; (f -1 0)
|
||||
(const 0) ; (f 1 0)
|
||||
(seq (toplevel y) (const -1)) ; (f -1 y)
|
||||
(toplevel y) ; (f 2 y)
|
||||
(let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
|
||||
(if (primcall > (lexical x _) (const 0))
|
||||
(lexical y _)
|
||||
(lexical x _)))))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, conditional.
|
||||
(let ((y 2))
|
||||
(lambda (x)
|
||||
(if (> y 0)
|
||||
(display x)
|
||||
'never-reached)))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
(((x) #f #f #f () (_))
|
||||
(call (toplevel display) (lexical x _))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; First order, recursive procedure.
|
||||
(letrec ((fibo (lambda (n)
|
||||
(if (<= n 1)
|
||||
n
|
||||
(+ (fibo (- n 1))
|
||||
(fibo (- n 2)))))))
|
||||
(fibo 4))
|
||||
(const 3))
|
||||
|
||||
(pass-if-peval
|
||||
;; Don't propagate toplevel references, as intervening expressions
|
||||
;; could alter their bindings.
|
||||
(let ((x top))
|
||||
(foo)
|
||||
x)
|
||||
(let (x) (_) ((toplevel top))
|
||||
(seq
|
||||
(call (toplevel foo))
|
||||
(lexical x _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Higher order.
|
||||
((lambda (f x)
|
||||
(f (* (car x) (cadr x))))
|
||||
(lambda (x)
|
||||
(+ x 1))
|
||||
'(2 3))
|
||||
(const 7))
|
||||
|
||||
(pass-if-peval
|
||||
;; Higher order with optional argument (default value).
|
||||
((lambda* (f x #:optional (y 0))
|
||||
(+ y (f (* (car x) (cadr x)))))
|
||||
(lambda (x)
|
||||
(+ x 1))
|
||||
'(2 3))
|
||||
(const 7))
|
||||
|
||||
(pass-if-peval
|
||||
;; Higher order with optional argument (caller-supplied value).
|
||||
((lambda* (f x #:optional (y 0))
|
||||
(+ y (f (* (car x) (cadr x)))))
|
||||
(lambda (x)
|
||||
(+ x 1))
|
||||
'(2 3)
|
||||
35)
|
||||
(const 42))
|
||||
|
||||
(pass-if-peval
|
||||
;; Higher order with optional argument (side-effecting default
|
||||
;; value).
|
||||
((lambda* (f x #:optional (y (foo)))
|
||||
(+ y (f (* (car x) (cadr x)))))
|
||||
(lambda (x)
|
||||
(+ x 1))
|
||||
'(2 3))
|
||||
(let (y) (_) ((call (toplevel foo)))
|
||||
(primcall + (lexical y _) (const 7))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Higher order with optional argument (caller-supplied value).
|
||||
((lambda* (f x #:optional (y (foo)))
|
||||
(+ y (f (* (car x) (cadr x)))))
|
||||
(lambda (x)
|
||||
(+ x 1))
|
||||
'(2 3)
|
||||
35)
|
||||
(const 42))
|
||||
|
||||
(pass-if-peval
|
||||
;; Higher order.
|
||||
((lambda (f) (f x)) (lambda (x) x))
|
||||
(toplevel x))
|
||||
|
||||
(pass-if-peval
|
||||
;; Bug reported at
|
||||
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
|
||||
(let ((fold (lambda (f g) (f (g top)))))
|
||||
(fold 1+ (lambda (x) x)))
|
||||
(primcall 1+ (toplevel top)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Procedure not inlined when residual code contains recursive calls.
|
||||
;; <http://debbugs.gnu.org/9542>
|
||||
(letrec ((fold (lambda (f x3 b null? car cdr)
|
||||
(if (null? x3)
|
||||
b
|
||||
(f (car x3) (fold f (cdr x3) b null? car cdr))))))
|
||||
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
|
||||
(letrec (fold) (_) (_)
|
||||
(call (lexical fold _)
|
||||
(primitive *)
|
||||
(toplevel x)
|
||||
(const 1)
|
||||
(primitive zero?)
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
(((x1) #f #f #f () (_))
|
||||
(lexical x1 _))))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
(((x2) #f #f #f () (_))
|
||||
(primcall - (lexical x2 _) (const 1))))))))
|
||||
|
||||
(pass-if "inlined lambdas are alpha-renamed"
|
||||
;; In this example, `make-adder' is inlined more than once; thus,
|
||||
;; they should use different gensyms for their arguments, because
|
||||
;; the various optimization passes assume uniquely-named variables.
|
||||
;;
|
||||
;; Bug reported at
|
||||
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
|
||||
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
|
||||
(pmatch (unparse-tree-il
|
||||
(peval (compile
|
||||
'(let ((make-adder
|
||||
(lambda (x) (lambda (y) (+ x y)))))
|
||||
(cons (make-adder 1) (make-adder 2)))
|
||||
#:to 'tree-il)))
|
||||
((primcall cons
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
(((y) #f #f #f () (,gensym1))
|
||||
(primcall +
|
||||
(const 1)
|
||||
(lexical y ,ref1)))))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
(((y) #f #f #f () (,gensym2))
|
||||
(primcall +
|
||||
(const 2)
|
||||
(lexical y ,ref2))))))
|
||||
(and (eq? gensym1 ref1)
|
||||
(eq? gensym2 ref2)
|
||||
(not (eq? gensym1 gensym2))))
|
||||
(_ #f)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Higher order, mutually recursive procedures.
|
||||
(letrec ((even? (lambda (x)
|
||||
(or (= 0 x)
|
||||
(odd? (- x 1)))))
|
||||
(odd? (lambda (x)
|
||||
(not (even? (- x 1))))))
|
||||
(and (even? 4) (odd? 7)))
|
||||
(const #t))
|
||||
|
||||
;;
|
||||
;; Below are cases where constant propagation should bail out.
|
||||
;;
|
||||
|
||||
(pass-if-peval
|
||||
;; Non-constant lexical is not propagated.
|
||||
(let ((v (make-vector 6 #f)))
|
||||
(lambda (n)
|
||||
(vector-set! v n n)))
|
||||
(let (v) (_)
|
||||
((call (toplevel make-vector) (const 6) (const #f)))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
(((n) #f #f #f () (_))
|
||||
(call (toplevel vector-set!)
|
||||
(lexical v _) (lexical n _) (lexical n _)))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Mutable lexical is not propagated.
|
||||
(let ((v (vector 1 2 3)))
|
||||
(lambda ()
|
||||
v))
|
||||
(let (v) (_)
|
||||
((primcall vector (const 1) (const 2) (const 3)))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
((() #f #f #f () ())
|
||||
(lexical v _))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Lexical that is not provably pure is not inlined nor propagated.
|
||||
(let* ((x (if (> p q) (frob!) (display 'chbouib)))
|
||||
(y (* x 2)))
|
||||
(+ x x y))
|
||||
(let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
|
||||
(call (toplevel frob!))
|
||||
(call (toplevel display) (const chbouib))))
|
||||
(let (y) (_) ((primcall * (lexical x _) (const 2)))
|
||||
(primcall +
|
||||
(lexical x _) (lexical x _) (lexical y _)))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Non-constant arguments not propagated to lambdas.
|
||||
((lambda (x y z)
|
||||
(vector-set! x 0 0)
|
||||
(set-car! y 0)
|
||||
(set-cdr! z '()))
|
||||
(vector 1 2 3)
|
||||
(make-list 10)
|
||||
(list 1 2 3))
|
||||
(let (x y z) (_ _ _)
|
||||
((primcall vector (const 1) (const 2) (const 3))
|
||||
(call (toplevel make-list) (const 10))
|
||||
(primcall list (const 1) (const 2) (const 3)))
|
||||
(seq
|
||||
(call (toplevel vector-set!)
|
||||
(lexical x _) (const 0) (const 0))
|
||||
(seq (call (toplevel set-car!)
|
||||
(lexical y _) (const 0))
|
||||
(call (toplevel set-cdr!)
|
||||
(lexical z _) (const ()))))))
|
||||
|
||||
(pass-if-peval
|
||||
(let ((foo top-foo) (bar top-bar))
|
||||
(let* ((g (lambda (x y) (+ x y)))
|
||||
(f (lambda (g x) (g x x))))
|
||||
(+ (f g foo) (f g bar))))
|
||||
(let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
|
||||
(primcall +
|
||||
(primcall + (lexical foo _) (lexical foo _))
|
||||
(primcall + (lexical bar _) (lexical bar _)))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Fresh objects are not turned into constants, nor are constants
|
||||
;; turned into fresh objects.
|
||||
(let* ((c '(2 3))
|
||||
(x (cons 1 c))
|
||||
(y (cons 0 x)))
|
||||
y)
|
||||
(let (x) (_) ((primcall cons (const 1) (const (2 3))))
|
||||
(primcall cons (const 0) (lexical x _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Bindings mutated.
|
||||
(let ((x 2))
|
||||
(set! x 3)
|
||||
x)
|
||||
(let (x) (_) ((const 2))
|
||||
(seq
|
||||
(set! (lexical x _) (const 3))
|
||||
(lexical x _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Bindings mutated.
|
||||
(letrec ((x 0)
|
||||
(f (lambda ()
|
||||
(set! x (+ 1 x))
|
||||
x)))
|
||||
(frob f) ; may mutate `x'
|
||||
x)
|
||||
(letrec (x) (_) ((const 0))
|
||||
(seq
|
||||
(call (toplevel frob) (lambda _ _))
|
||||
(lexical x _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Bindings mutated.
|
||||
(letrec ((f (lambda (x)
|
||||
(set! f (lambda (_) x))
|
||||
x)))
|
||||
(f 2))
|
||||
(letrec _ . _))
|
||||
|
||||
(pass-if-peval
|
||||
;; Bindings possibly mutated.
|
||||
(let ((x (make-foo)))
|
||||
(frob! x) ; may mutate `x'
|
||||
x)
|
||||
(let (x) (_) ((call (toplevel make-foo)))
|
||||
(seq
|
||||
(call (toplevel frob!) (lexical x _))
|
||||
(lexical x _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Inlining stops at recursive calls with dynamic arguments.
|
||||
(let loop ((x x))
|
||||
(if (< x 0) x (loop (1- x))))
|
||||
(letrec (loop) (_) ((lambda (_)
|
||||
(lambda-case
|
||||
(((x) #f #f #f () (_))
|
||||
(if _ _
|
||||
(call (lexical loop _)
|
||||
(primcall 1-
|
||||
(lexical x _))))))))
|
||||
(call (lexical loop _) (toplevel x))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Recursion on the 2nd argument is fully evaluated.
|
||||
(let ((x (top)))
|
||||
(let loop ((x x) (y 10))
|
||||
(if (> y 0)
|
||||
(loop x (1- y))
|
||||
(foo x y))))
|
||||
(let (x) (_) ((call (toplevel top)))
|
||||
(letrec (loop) (_) (_)
|
||||
(call (toplevel foo) (lexical x _) (const 0)))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Inlining aborted when residual code contains recursive calls.
|
||||
;;
|
||||
;; <http://debbugs.gnu.org/9542>
|
||||
(let loop ((x x) (y 0))
|
||||
(if (> y 0)
|
||||
(loop (1- x) (1- y))
|
||||
(if (< x 0)
|
||||
x
|
||||
(loop (1+ x) (1+ y)))))
|
||||
(letrec (loop) (_) ((lambda (_)
|
||||
(lambda-case
|
||||
(((x y) #f #f #f () (_ _))
|
||||
(if (primcall >
|
||||
(lexical y _) (const 0))
|
||||
_ _)))))
|
||||
(call (lexical loop _) (toplevel x) (const 0))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Infinite recursion: `peval' gives up and leaves it as is.
|
||||
(letrec ((f (lambda (x) (g (1- x))))
|
||||
(g (lambda (x) (h (1+ x))))
|
||||
(h (lambda (x) (f x))))
|
||||
(f 0))
|
||||
(letrec _ . _))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cons
|
||||
(begin (cons 1 2) #f)
|
||||
(const #f))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cons
|
||||
(begin (cons (foo) 2) #f)
|
||||
(seq (call (toplevel foo)) (const #f)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cons
|
||||
(if (cons 0 0) 1 2)
|
||||
(const 1))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: car+cons
|
||||
(car (cons 1 0))
|
||||
(const 1))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cdr+cons
|
||||
(cdr (cons 1 0))
|
||||
(const 0))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: car+cons, impure
|
||||
(car (cons 1 (bar)))
|
||||
(seq (call (toplevel bar)) (const 1)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cdr+cons, impure
|
||||
(cdr (cons (bar) 0))
|
||||
(seq (call (toplevel bar)) (const 0)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: car+list
|
||||
(car (list 1 0))
|
||||
(const 1))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cdr+list
|
||||
(cdr (list 1 0))
|
||||
(primcall list (const 0)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: car+list, impure
|
||||
(car (list 1 (bar)))
|
||||
(seq (call (toplevel bar)) (const 1)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cdr+list, impure
|
||||
(cdr (list (bar) 0))
|
||||
(seq (call (toplevel bar)) (primcall list (const 0))))
|
||||
|
||||
(pass-if-peval
|
||||
resolve-primitives
|
||||
;; Prompt is removed if tag is unreferenced
|
||||
(let ((tag (make-prompt-tag)))
|
||||
(call-with-prompt tag
|
||||
(lambda () 1)
|
||||
(lambda args args)))
|
||||
(const 1))
|
||||
|
||||
(pass-if-peval
|
||||
resolve-primitives
|
||||
;; Prompt is removed if tag is unreferenced, with explicit stem
|
||||
(let ((tag (make-prompt-tag "foo")))
|
||||
(call-with-prompt tag
|
||||
(lambda () 1)
|
||||
(lambda args args)))
|
||||
(const 1))
|
||||
|
||||
(pass-if-peval
|
||||
resolve-primitives
|
||||
;; `while' without `break' or `continue' has no prompts and gets its
|
||||
;; condition folded. Unfortunately the outer `lp' does not yet get
|
||||
;; elided.
|
||||
(while #t #t)
|
||||
(letrec (lp) (_)
|
||||
((lambda _
|
||||
(lambda-case
|
||||
((() #f #f #f () ())
|
||||
(letrec (loop) (_)
|
||||
((lambda _
|
||||
(lambda-case
|
||||
((() #f #f #f () ())
|
||||
(call (lexical loop _))))))
|
||||
(call (lexical loop _)))))))
|
||||
(call (lexical lp _)))))
|
||||
|
||||
|
||||
|
||||
(with-test-prefix "tree-il-fold"
|
||||
|
||||
|
|
|
|||
|
|
@ -89,6 +89,9 @@
|
|||
(pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT"
|
||||
(string->date "Tue, 15 Nov 1994 08:12:31 +0000"
|
||||
"~a, ~d ~b ~Y ~H:~M:~S ~z"))
|
||||
(pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT"
|
||||
(string->date "Wed, 7 Sep 2011 11:25:00 +0000"
|
||||
"~a,~e ~b ~Y ~H:~M:~S ~z"))
|
||||
(pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date)
|
||||
(pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST")
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
(define (matches? obj)
|
||||
; (format #t "matches? ~a~%" obj)
|
||||
(match obj
|
||||
(($ stuff) #t)
|
||||
(($ <stuff>) #t)
|
||||
; (blurps #t)
|
||||
("hello" #t)
|
||||
(else #f)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue