diff options
Diffstat (limited to 'test-suite/tests')
-rw-r--r-- | test-suite/tests/00-socket.test | 7 | ||||
-rw-r--r-- | test-suite/tests/asm-to-bytecode.test | 27 | ||||
-rw-r--r-- | test-suite/tests/cse.test | 129 | ||||
-rw-r--r-- | test-suite/tests/ecmascript.test | 6 | ||||
-rw-r--r-- | test-suite/tests/elisp-compiler.test | 136 | ||||
-rw-r--r-- | test-suite/tests/eval.test | 86 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 4 | ||||
-rw-r--r-- | test-suite/tests/iconv.test | 5 | ||||
-rw-r--r-- | test-suite/tests/peg.bench | 173 | ||||
-rw-r--r-- | test-suite/tests/peg.test | 278 | ||||
-rw-r--r-- | test-suite/tests/peval.test | 617 | ||||
-rw-r--r-- | test-suite/tests/procprop.test | 8 | ||||
-rw-r--r-- | test-suite/tests/r6rs-ports.test | 3 | ||||
-rw-r--r-- | test-suite/tests/r6rs-records-syntactic.test | 14 | ||||
-rw-r--r-- | test-suite/tests/regexp.test | 2 | ||||
-rw-r--r-- | test-suite/tests/syncase.test | 25 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 68 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 152 | ||||
-rw-r--r-- | test-suite/tests/vlist.test | 4 | ||||
-rw-r--r-- | test-suite/tests/weaks.test | 34 | ||||
-rw-r--r-- | test-suite/tests/web-response.test | 4 |
21 files changed, 1150 insertions, 632 deletions
diff --git a/test-suite/tests/00-socket.test b/test-suite/tests/00-socket.test index 8079cf548..7b13c5f8c 100644 --- a/test-suite/tests/00-socket.test +++ b/test-suite/tests/00-socket.test @@ -1,7 +1,7 @@ -;;;; socket.test --- test socket functions -*- scheme -*- +;;;; 00-socket.test --- test socket functions -*- scheme -*- ;;;; ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, -;;;; 2011 Free Software Foundation, Inc. +;;;; 2011, 2012 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 @@ -17,6 +17,9 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;; This test runs early, so that we can fork before any threads are +;; created in other tests. + (define-module (test-suite test-socket) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-26) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 6d2f20e02..688e7524a 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -22,7 +22,9 @@ #:use-module (test-suite lib) #:use-module (system vm instruction) #:use-module (system vm objcode) + #:use-module (system vm elf) #:use-module (system base target) + #:use-module (language objcode elf) #:use-module (language assembly) #:use-module (language assembly compile-bytecode)) @@ -139,7 +141,7 @@ ((@ (system foreign) sizeof) '*)) (define %objcode-cookie-size - (string-length "GOOF----LE-8-2.0")) + (string-length "GOOF----LE-8")) (define (test-target triplet endian word-size) (pass-if (format #f "target `~a' honored" triplet) @@ -171,21 +173,12 @@ (nop) (nop) (nop) (nop) (nop)) #f))) - (write-objcode (bytecode->objcode b) p) - (let ((cookie (make-bytevector %objcode-cookie-size)) - (expected (format #f "GOOF----~a-~a-~a" - (cond ((eq? endian (endianness little)) - "LE") - ((eq? endian (endianness big)) - "BE") - (else - (error "unknown endianness" - endian))) - word-size - (effective-version)))) - (bytevector-copy! (get-objcode) 0 cookie 0 - %objcode-cookie-size) - (string=? (utf8->string cookie) expected))))))))) + (write-objcode (bytecode->objcode b (target-endianness)) p) + (let* ((bv (get-objcode))) + (and=> (parse-elf bv) + (lambda (elf) + (and (equal? (elf-byte-order elf) endian) + (equal? (elf-word-size elf) word-size)))))))))))) (with-test-prefix "cross-compilation" @@ -214,7 +207,7 @@ (make-int8 77) (return)) #f)) - (o (bytecode->objcode b))) + (o (bytecode->objcode b (target-endianness)))) (with-target "fcpu-unknown-gnu1.0" (lambda () (write-objcode o p)))))))) diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test index e0219e84d..f9b85d495 100644 --- a/test-suite/tests/cse.test +++ b/test-suite/tests/cse.test @@ -70,7 +70,7 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (apply (primitive eq?) (lexical x _) (lexical y _)))))) + (primcall eq? (lexical x _) (lexical y _)))))) ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST). (pass-if-cse @@ -79,8 +79,8 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (apply (primitive not) - (apply (primitive eq?) (lexical x _) (lexical y _))))))) + (primcall not + (primcall eq? (lexical x _) (lexical y _))))))) ;; (if TEST (not TEST) #f) ;; => (if TEST #f #f) @@ -110,13 +110,13 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (if (apply (primitive set-car!) - (lexical x _) - (lexical y _)) - (apply (primitive not) - (apply (primitive set-car!) - (lexical x _) - (lexical y _))) + (if (primcall set-car! + (lexical x _) + (lexical y _)) + (primcall not + (primcall set-car! + (lexical x _) + (lexical y _))) (const #f)))))) ;; Primitives that access mutable memory can propagate, as long as @@ -130,11 +130,10 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (begin - (apply (primitive string-ref) - (lexical x _) - (lexical y _)) - (const #f)))))) + (seq (primcall string-ref + (lexical x _) + (lexical y _)) + (const #f)))))) ;; However, expressions with dependencies on effects do not propagate ;; through a lambda. @@ -146,15 +145,15 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (if (apply (primitive string-ref) - (lexical x _) - (lexical y _)) + (if (primcall string-ref + (lexical x _) + (lexical y _)) (lambda _ (lambda-case ((() #f #f #f () ()) - (if (apply (primitive string-ref) - (lexical x _) - (lexical y _)) + (if (primcall string-ref + (lexical x _) + (lexical y _)) (const #t) (const #f))))) (const #f)))))) @@ -169,17 +168,16 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (if (apply (primitive string-ref) - (lexical x _) - (lexical y _)) - (begin - (apply (primitive string-set!) - (lexical x _) - (const #\!)) - (apply (primitive not) - (apply (primitive string-ref) - (lexical x _) - (lexical y _)))) + (if (primcall string-ref + (lexical x _) + (lexical y _)) + (seq (primcall string-set! + (lexical x _) + (const #\!)) + (primcall not + (primcall string-ref + (lexical x _) + (lexical y _)))) (const #f)))))) ;; Predicates are only added to the database if they are in a @@ -190,7 +188,7 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (apply (primitive eq?) (lexical x _) (lexical y _)))))) + (primcall eq? (lexical x _) (lexical y _)))))) ;; Conditional bailouts do cause primitives to be added to the DB. (pass-if-cse @@ -199,12 +197,11 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (begin - (if (apply (primitive eq?) - (lexical x _) (lexical y _)) - (void) - (apply (primitive 'throw) (const 'foo))) - (const #t)))))) + (seq (if (primcall eq? + (lexical x _) (lexical y _)) + (void) + (primcall throw (const foo))) + (const #t)))))) ;; A chain of tests in a conditional bailout add data to the DB ;; correctly. @@ -219,21 +216,20 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (begin + (seq (fix (failure) (_) ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (primitive throw) (const foo)))))) - (if (apply (primitive struct?) (lexical x _)) - (if (apply (primitive eq?) - (apply (primitive struct-vtable) - (lexical x _)) - (toplevel x-vtable)) + (primcall throw (const foo)))))) + (if (primcall struct? (lexical x _)) + (if (primcall eq? + (primcall struct-vtable (lexical x _)) + (toplevel x-vtable)) (void) - (apply (lexical failure _))) - (apply (lexical failure _)))) - (apply (primitive struct-ref) (lexical x _) (lexical y _))))))) + (call (lexical failure _))) + (call (lexical failure _)))) + (primcall struct-ref (lexical x _) (lexical y _))))))) ;; Strict argument evaluation also adds info to the DB. (pass-if-cse @@ -254,24 +250,23 @@ ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (primitive throw) (const foo)))))) - (if (apply (primitive struct?) (lexical x _)) - (if (apply (primitive eq?) - (apply (primitive struct-vtable) - (lexical x _)) - (toplevel x-vtable)) - (apply (primitive struct-ref) (lexical x _) (const 1)) - (apply (lexical failure _))) - (apply (lexical failure _))))) - (apply (primitive +) (lexical z _) - (apply (primitive struct-ref) (lexical x _) (const 2)))))))) + (primcall throw (const foo)))))) + (if (primcall struct? (lexical x _)) + (if (primcall eq? + (primcall struct-vtable (lexical x _)) + (toplevel x-vtable)) + (primcall struct-ref (lexical x _) (const 1)) + (call (lexical failure _))) + (call (lexical failure _))))) + (primcall + (lexical z _) + (primcall struct-ref (lexical x _) (const 2)))))))) ;; Replacing named expressions with lexicals. (pass-if-cse (let ((x (car y))) (cons x (car y))) - (let (x) (_) ((apply (primitive car) (toplevel y))) - (apply (primitive cons) (lexical x _) (lexical x _)))) + (let (x) (_) ((primcall car (toplevel y))) + (primcall cons (lexical x _) (lexical x _)))) ;; Dominating expressions only provide predicates when evaluated in ;; test context. @@ -282,16 +277,16 @@ 'two)) ;; Actually this one should reduce in other ways, but this is the ;; current reduction: - (begin - (apply (primitive car) (toplevel x)) - (if (apply (primitive car) (toplevel x)) + (seq + (primcall car (toplevel x)) + (if (primcall car (toplevel x)) (const one) (const two)))) (pass-if-cse (begin (cons 1 2 3) 4) - (begin - (apply (primitive cons) (const 1) (const 2) (const 3)) + (seq + (primcall cons (const 1) (const 2) (const 3)) (const 4))) (pass-if "http://bugs.gnu.org/12883" diff --git a/test-suite/tests/ecmascript.test b/test-suite/tests/ecmascript.test index 96b1d6666..17036f93d 100644 --- a/test-suite/tests/ecmascript.test +++ b/test-suite/tests/ecmascript.test @@ -23,9 +23,11 @@ (define (eread str) - (call-with-input-string str read-ecmascript)) + (with-fluids ((%default-port-encoding "utf-8")) + (call-with-input-string str read-ecmascript))) (define (eread/1 str) - (call-with-input-string str read-ecmascript/1)) + (with-fluids ((%default-port-encoding "utf-8")) + (call-with-input-string str read-ecmascript/1))) (define-syntax parse (syntax-rules () diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test index 230dc772d..ddfa80a9a 100644 --- a/test-suite/tests/elisp-compiler.test +++ b/test-suite/tests/elisp-compiler.test @@ -47,6 +47,8 @@ ; Test control structures. ; ======================== +(compile '(%set-lexical-binding-mode #nil) #:from 'elisp #:to 'value) + (with-test-prefix/compile "Sequencing" (pass-if-equal "progn" 1 @@ -54,6 +56,9 @@ (setq a (1+ a)) a)) + (pass-if-equal "empty progn" #nil + (progn)) + (pass-if "prog1" (progn (setq a 0) (setq b (prog1 a (setq a (1+ a)))) @@ -77,17 +82,8 @@ 3) (equal (if nil 1) nil))) - (pass-if-equal "failing when" nil-value - (when nil 1 2 3)) - (pass-if-equal "succeeding when" 42 - (progn (setq a 0) - (when t (setq a 42) a))) - - (pass-if-equal "failing unless" nil-value - (unless t 1 2 3)) - (pass-if-equal "succeeding unless" 42 - (progn (setq a 0) - (unless nil (setq a 42) a))) + (pass-if-equal "if with no else" #nil + (if nil t)) (pass-if-equal "empty cond" nil-value (cond)) @@ -127,27 +123,7 @@ (while (<= i 5) (setq prod (* i prod)) (setq i (1+ i))) - prod)) - - (pass-if "dotimes" - (progn (setq a 0) - (setq count 100) - (setq b (dotimes (i count) - (setq j (1+ i)) - (setq a (+ a j)))) - (setq c (dotimes (i 10 42) nil)) - (and (= a 5050) (equal b nil) (= c 42)))) - - (pass-if "dolist" - (let ((mylist '(7 2 5))) - (setq sum 0) - (setq a (dolist (i mylist) - (setq sum (+ sum i)))) - (setq b (dolist (i mylist 5) 0)) - (and (= sum (+ 7 2 5)) - (equal a nil) - (equal mylist '(7 2 5)) - (equal b 5))))) + prod))) (with-test-prefix/compile "Exceptions" @@ -169,7 +145,7 @@ (= (catch 'abc (throw 'abc 2) 1) 2) (= (catch 'abc (catch 'def (throw 'abc (1+ 0)) 2) 3) 1) (= (catch 'abc (catch 'def (throw 'def 1) 2) 3) 3) - (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1))) + (= (catch mylist (catch (list 1 2) (throw mylist 1) 2) 3) 1))) (pass-if "unwind-protect" (progn (setq a 0 b 1 c 1) @@ -246,6 +222,8 @@ (b a)) b))) + (pass-if-equal "empty let" #nil (let ())) + (pass-if "let*" (progn (setq a 0) (and (let* ((a 1) @@ -257,6 +235,9 @@ (= a 0) (not (boundp 'b))))) + (pass-if-equal "empty let*" #nil + (let* ())) + (pass-if "local scope" (progn (setq a 0) (setq b (let (a) @@ -303,9 +284,11 @@ (lexical-let ((a 2)) (and (= a 2) (equal (dynvals) '(1 . 1)) (let ((a 3) (b a)) + (declare (lexical a)) (and (= a 3) (= b 2) (equal (dynvals) '(1 . 2)))) (let* ((a 4) (b a)) + (declare (lexical a)) (and (= a 4) (= b 4) (equal (dynvals) '(1 . 4)))) (= a 2))) @@ -316,8 +299,11 @@ (defun dyna () a) (lexical-let ((a 2) (b 42)) (and (= a 2) (= (dyna) 1) - ((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3) + ((lambda (a) + (declare (lexical a)) + (and (= a 3) (= b 42) (= (dyna) 1))) 3) ((lambda () (let ((a 3)) + (declare (lexical a)) (and (= a 3) (= (dyna) 1))))) (= a 2) (= (dyna) 1))) (= a 1))) @@ -336,34 +322,13 @@ (= (funcall c1) 4) (= (funcall c2) 3))) - (pass-if "always lexical option (all)" - (progn (setq a 0) - (defun dyna () a) - (let ((a 1)) - (and (= a 1) (= (dyna) 0)))) - #:opts '(#:always-lexical all)) - (pass-if "always lexical option (list)" - (progn (setq a 0 b 0) - (defun dyna () a) - (defun dynb () b) - (let ((a 1) - (b 1)) - (and (= a 1) (= (dyna) 0) - (= b 1) (= (dynb) 1)))) - #:opts '(#:always-lexical (a))) - (pass-if "with-always-lexical" - (progn (setq a 0) - (defun dyna () a) - (with-always-lexical (a) - (let ((a 1)) - (and (= a 1) (= (dyna) 0)))))) - (pass-if "lexical lambda args" (progn (setq a 1 b 1) (defun dyna () a) (defun dynb () b) - (with-always-lexical (a c) + (lexical-let (a c) ((lambda (a b &optional c) + (declare (lexical a c)) (and (= a 3) (= (dyna) 1) (= b 2) (= (dynb) 2) (= c 1))) @@ -373,9 +338,10 @@ ; is tail-optimized by doing a deep recursion that would otherwise overflow ; the stack. (pass-if "lexical lambda tail-recursion" - (with-always-lexical (i) + (lexical-let (i) (setq to 1000000) (defun iteration-1 (i) + (declare (lexical i)) (if (< i to) (iteration-1 (1+ i)))) (iteration-1 0) @@ -422,14 +388,17 @@ ((lambda (a b c) c) 1 2 3)) (pass-if-equal "optional argument" 3 - ((function (lambda (a &optional b c) c)) 1 2 3)) + ((lambda (a &optional b c) c) 1 2 3)) (pass-if-equal "optional missing" nil-value ((lambda (&optional a) a))) (pass-if-equal "rest argument" '(3 4 5) ((lambda (a b &rest c) c) 1 2 3 4 5)) - (pass-if-equal "rest missing" nil-value - ((lambda (a b &rest c) c) 1 2))) + (pass-if "rest missing" + (null ((lambda (a b &rest c) c) 1 2))) + + (pass-if-equal "empty lambda" #nil + ((lambda ())))) (with-test-prefix/compile "Function Definitions" @@ -453,18 +422,16 @@ (not (fboundp 'a)) (= a 1)))) - (pass-if "flet and flet*" + (pass-if "flet" (progn (defun foobar () 42) (defun test () (foobar)) (and (= (test) 42) - (flet ((foobar (lambda () 0)) - (myfoo (symbol-function 'foobar))) + (flet ((foobar () 0) + (myfoo () + (funcall (symbol-function 'foobar)))) (and (= (myfoo) 42) (= (test) 42))) - (flet* ((foobar (lambda () 0)) - (myfoo (symbol-function 'foobar))) - (= (myfoo) 42)) - (flet (foobar) + (flet ((foobar () nil)) (defun foobar () 0) (= (test) 42)) (= (test) 42))))) @@ -563,8 +530,8 @@ (setq some-string "abc") (and (eq 2 2) (not (eq 1 2)) (eq 'abc 'abc) (not (eq 'abc 'def)) - (eq some-string some-string) (not (eq some-string "abc")) - (eq some-list some-list) (not (eq some-list '(1 2))))))) + (eq some-string some-string) (not (eq some-string (string 97 98 99))) + (eq some-list some-list) (not (eq some-list (list 1 2))))))) (with-test-prefix/compile "Number Built-Ins" @@ -607,11 +574,11 @@ (with-test-prefix/compile "List Built-Ins" - (pass-if "consp and atomp" + (pass-if "consp and atom" (and (consp '(1 2 3)) (consp '(1 2 . 3)) (consp '(a . b)) (not (consp '())) (not (consp 1)) (not (consp "abc")) - (atomp 'a) (atomp '()) (atomp -1.5) (atomp "abc") - (not (atomp '(1 . 2))) (not (atomp '(1))))) + (atom 'a) (atom '()) (atom -1.5) (atom "abc") + (not (atom '(1 . 2))) (not (atom '(1))))) (pass-if "listp and nlistp" (and (listp '(1 2 3)) (listp '(1)) (listp '()) (listp '(1 . 2)) (not (listp 'a)) (not (listp 42)) (nlistp 42) @@ -628,15 +595,6 @@ (and (equal (car-safe '(1 2)) 1) (equal (cdr-safe '(1 2)) '(2)) (equal (car-safe 5) nil) (equal (cdr-safe 5) nil))) - (pass-if "pop" - (progn (setq mylist '(a b c)) - (setq value (pop mylist)) - (and (equal value 'a) - (equal mylist '(b c))))) - (pass-if-equal "push" '(a b c) - (progn (setq mylist '(b c)) - (push 'a mylist))) - (pass-if "nth and nthcdr" (and (equal (nth -5 '(1 2 3)) 1) (equal (nth 3 '(1 2 3)) nil) (equal (nth 0 '(1 2 3)) 1) (equal (nth 2 '(1 2 3)) 3) @@ -662,20 +620,6 @@ (pass-if "reverse" (and (equal (reverse '(5 4 3 2 1)) '(1 2 3 4 5)) (equal (reverse '()) '()))) - (pass-if "copy-tree" - (progn (setq mylist '(1 2 (3 4))) - (and (not (eq mylist (copy-tree mylist))) - (equal mylist (copy-tree mylist))))) - - (pass-if "number-sequence" - (and (equal (number-sequence 5) '(5)) - (equal (number-sequence 5 9) '(5 6 7 8 9)) - (equal (number-sequence 5 9 3) '(5 8)) - (equal (number-sequence 5 1 -2) '(5 3 1)) - (equal (number-sequence 5 8 -1) '()) - (equal (number-sequence 5 1) '()) - (equal (number-sequence 5 5 0) '(5)))) - (pass-if "setcar and setcdr" (progn (setq pair '(1 . 2)) (setq copy pair) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 6ab3b8ac8..24afe2da0 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -334,50 +334,64 @@ 1+ 0)) +(define (make-tagged-trimmed-stack tag spec) + (catch 'result + (lambda () + (call-with-prompt + tag + (lambda () + (with-throw-handler 'wrong-type-arg + (lambda () (substring 'wrong 'type 'arg)) + (lambda _ (throw 'result (apply make-stack spec))))) + (lambda () (throw 'make-stack-failed)))) + (lambda (key result) result))) + +(define tag (make-prompt-tag "foo")) + (with-test-prefix "stacks" (pass-if "stack involving a primitive" ;; The primitive involving the error must appear exactly once on the ;; stack. - (catch 'result - (lambda () - (start-stack 'foo - (with-throw-handler 'wrong-type-arg - (lambda () - ;; Trigger a `wrong-type-arg' exception. - (hashq-ref 'wrong 'type 'arg)) - (lambda _ - (let* ((stack (make-stack #t)) - (frames (stack->frames stack))) - (throw 'result - (count (lambda (frame) - (eq? (frame-procedure frame) - hashq-ref)) - frames))))))) - (lambda (key result) - (= 1 result)))) + (let* ((stack (make-tagged-trimmed-stack tag '(#t))) + (frames (stack->frames stack)) + (num (count (lambda (frame) (eq? (frame-procedure frame) + substring)) + frames))) + (= num 1))) (pass-if "arguments of a primitive stack frame" ;; Create a stack with two primitive frames and make sure the ;; arguments are correct. - (catch 'result - (lambda () - (start-stack 'foo - (with-throw-handler 'wrong-type-arg - (lambda () - ;; Trigger a `wrong-type-arg' exception. - (substring 'wrong 'type 'arg)) - (lambda _ - (let* ((stack (make-stack #t)) - (frames (stack->frames stack))) - (throw 'result - (map (lambda (frame) - (cons (frame-procedure frame) - (frame-arguments frame))) - frames))))))) - (lambda (key result) - (and (equal? (car result) `(,make-stack #t)) - (pair? (member `(,substring wrong type arg) - (cdr result)))))))) + (let* ((stack (make-tagged-trimmed-stack tag '(#t))) + (call-list (map (lambda (frame) + (cons (frame-procedure frame) + (frame-arguments frame))) + (stack->frames stack)))) + (and (equal? (car call-list) `(,make-stack #t)) + (pair? (member `(,substring wrong type arg) + (cdr call-list)))))) + + (pass-if "inner trim with prompt tag" + (let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag))) + (frames (stack->frames stack))) + ;; the top frame on the stack is the lambda inside the 'catch, and the + ;; next frame is the (catch 'result ...) + (and (eq? (frame-procedure (cadr frames)) + catch) + (eq? (car (frame-arguments (cadr frames))) + 'result)))) + + (pass-if "outer trim with prompt tag" + (let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag))) + (frames (stack->frames stack))) + ;; the top frame on the stack is the make-stack call, and the last + ;; frame is the (with-throw-handler 'wrong-type-arg ...) + (and (eq? (frame-procedure (car frames)) + make-stack) + (eq? (frame-procedure (car (last-pair frames))) + with-throw-handler) + (eq? (car (frame-arguments (car (last-pair frames)))) + 'wrong-type-arg))))) ;;; ;;; letrec init evaluation diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 540effb26..204fde7c9 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -332,6 +332,10 @@ (= (sizeof (list int8 double)) (+ (alignof double) (sizeof double)))) + (pass-if "sizeof { double, int8 }" + (= (sizeof (list double int8)) + (+ (alignof double) (sizeof double)))) + (pass-if "sizeof { short, int, long, pointer }" (let ((layout (list short int long '*))) (>= (sizeof layout) diff --git a/test-suite/tests/iconv.test b/test-suite/tests/iconv.test index 9083cd256..be36336f3 100644 --- a/test-suite/tests/iconv.test +++ b/test-suite/tests/iconv.test @@ -94,6 +94,11 @@ (pass-if-exception "misparse latin1 as utf8" exception:decoding-error (bytevector->string (string->bytevector s "latin1") "utf-8")) + (pass-if "misparse latin1 as utf8 with substitutions" + (equal? (bytevector->string (string->bytevector s "latin1") + "utf-8" 'substitute) + "?t?")) + (pass-if-exception "misparse latin1 as ascii" exception:decoding-error (bytevector->string (string->bytevector s "latin1") "ascii")))) diff --git a/test-suite/tests/peg.bench b/test-suite/tests/peg.bench new file mode 100644 index 000000000..7baad5c73 --- /dev/null +++ b/test-suite/tests/peg.bench @@ -0,0 +1,173 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; PEG benchmark suite (minimal right now). +;; Parses very long equations several times; outputs the average time +;; it took and the standard deviation of times. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(use-modules (ice-9 pretty-print)) +(use-modules (srfi srfi-1)) +(use-modules (ice-9 peg)) +(use-modules (ice-9 popen)) + +;; Generate random equations. +(define (gen-rand-eq len) + (if (= len 0) + (random 1000) + (let ((len (if (even? len) (+ len 1) len))) + (map (lambda (x) + (if (odd? x) + (gen-rand len 'op) + (gen-rand len 'number))) + (iota len))))) +(define (gen-rand len type) + (cond ((eq? type 'number) + (cond + ((= (random 5) 0) (gen-rand-eq (floor (/ len 5)))) + (#t (random 1000)))) + (#t (list-ref '(+ - * /) (random 4))))) + +;; Generates a random equation string (len is a rough indicator of the +;; resulting length). +(define (gen-str len) + (with-output-to-string (lambda () (write (gen-rand-eq len))))) + +;; Generates a left-associative parser (see tutorial). +(define (make-left-parser next-func) + (lambda (sum first . rest) + (if (null? rest) + (apply next-func first) + (if (string? (cadr first)) + (list (string->symbol (cadr first)) + (apply next-func (car first)) + (apply next-func (car rest))) + (car + (reduce + (lambda (l r) + (list (list (cadr r) (car r) (apply next-func (car l))) + (string->symbol (cadr l)))) + 'ignore + (append + (list (list (apply next-func (caar first)) + (string->symbol (cadar first)))) + (cdr first) + (list (append rest '("done")))))))))) + +;; Functions for parsing equations (see tutorial). +(define (parse-value value first . rest) + (if (null? rest) + (string->number (cadr first)) + (apply parse-sum (car rest)))) +(define parse-product (make-left-parser parse-value)) +(define parse-sum (make-left-parser parse-product)) +(define parse-expr parse-sum) +(define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str)))) + +;; PEG for parsing equations (see tutorial). +(define-peg-string-patterns + "expr <- sum +sum <-- (product ('+' / '-'))* product +product <-- (value ('*' / '/'))* value +value <-- sp number sp / sp '(' expr ')' sp +number <-- [0-9]+ +sp < [ \t\n]*") + +;; gets the time in seconds (with a fractional part) +(define (canon-time) + (let ((pair (gettimeofday))) + (+ (+ (car pair) (* (cdr pair) (expt 10 -6))) 0.0))) + +;; Times how long it takes for FUNC to complete when called on ARGS. +;; **SIDE EFFECT** Writes the time FUNC took to stdout. +;; Returns the return value of FUNC. +(define (time-func func . args) + (let ((start (canon-time))) + (let ((res (apply func args))) + (pretty-print `(took ,(- (canon-time) start) seconds)) + res))) +;; Times how long it takes for FUNC to complete when called on ARGS. +;; Returns the time FUNC took to complete. +(define (time-ret-func func . args) + (let ((start (canon-time))) + (let ((res (apply func args))) + (- (canon-time) start)))) + +;; test string (randomly generated) +(define tst1 "(621 - 746 * 945 - 194 * (204 * (965 - 738 + (846)) - 450 / (116 * 293 * 543) + 858 / 693 - (890 * (260) - 855) + 875 - 684 / (749 - (846) + 127) / 670) - 293 - 815 - 628 * 93 - 662 + 561 / 645 + 112 - 71 - (286 - ((324) / 424 + 956) / 190 + ((848) / 132 * 602) + 5 + 765 * 220 - ((801) / 191 - 299) * 708 + 151 * 682) + (943 + 847 - 145 - 816 / 550 - 217 / 9 / 969 * 524 * 447 / 323) * 991 - 283 * 915 / 733 / 478 / (680 + 343 * 186 / 341 * ((571) * 848 - 47) - (492 + 398 * (616)) + 270 - 539 * 34 / 47 / 458) * 417 / 406 / 354 * 678 + 524 + 40 / 282 - 792 * 570 - 305 * 14 + (248 - 678 * 8 - 53 - 215 / 677 - 665 / 216 - 275 - 462 / 502) - 24 - 780 + (967 / (636 / 400 * 823) + 933 - 361 - 620 - 255 / 372 + 394 * 869 / 839 * 727) + (436 + 993 - 668 + 772 - 33 + 64 - 252 * 957 * 320 + 540 / (23 * 74 / (422))) + (516 / (348 * 219 * 986) * 85 * 149 * 957 * 602 / 141 / 80 / 456 / 92 / (443 * 468 * 466)) * 568 / (271 - 42 + 271 + 592 + 71 * (766 + (11) * 946) / 728 / 137 / 111 + 557 / 962) * 179 - 936 / 821 * 101 - 206 / (267 - (11 / 906 * 290) / 722 / 98 - 987 / 989 - 470 * 833 - (720 / 34 - 280) + 638 / 940) - 889 * 84 * 630 + ((214 - 888 + (46)) / 540 + 941 * 724 / 759 * (679 / 527 - 764) * 413 + 831 / 559 - (308 / 796 / 737) / 20))") + +;; appends two equations (adds them together) +(define (eq-append . eqs) + (if (null? eqs) + "0" + (if (null? (cdr eqs)) + (car eqs) + (string-append + (car eqs) + " + " + (apply eq-append (cdr eqs)))))) + +;; concatenates an equation onto itself n times using eq-append +(define (string-n str n) + (if (<= n 0) + "0" + (if (= n 1) + str + (eq-append str (string-n str (- n 1)))))) + +;; standard deviation (no bias-correction) +;; (also called population standard deviation) +(define (stddev . lst) + (let ((llen (length lst))) + (if (<= llen 0) + 0 + (let* ((avg (/ (reduce + 0 lst) llen)) + (mapfun (lambda (x) (real-part (expt (- x avg) 2))))) + (sqrt (/ (reduce + 0 (map mapfun lst)) llen)))))) + +;; average +(define (avg . lst) + (if (null? lst) + 0 + (/ (reduce + 0 lst) (length lst)))) + +(pretty-print "Parsing equations (see PEG in tutorial). Sample size of 10 for each test.") +(pretty-print + (let ((lst + (map + (lambda (ignore) + (reduce-right + append + 0 + (map + (lambda (x) + (let* ((mstr (string-n tst1 x)) + (strlen (string-length mstr))) + (let ((func (lambda () (begin (match-pattern expr mstr) + 'done)))) + `(((string of length ,strlen first pass) + ,(time-ret-func func)) + ((string of length ,strlen second pass) + ,(time-ret-func func)))))) + (filter (lambda (x) (= (modulo x 25) 0)) (iota 100))))) + (iota 10)))) + (let ((compacted + (reduce-right + (lambda (accum conc) + (map (lambda (l r) (append l (cdr r))) accum conc)) + 0 + lst))) + (map + (lambda (els) + `(,(car els) + (average time in seconds ,(apply avg (cdr els))) + (standard deviation ,(apply stddev (cdr els))))) + compacted)))) + +(define (sys-calc str) + (let* ((pipe (open-input-pipe (string-append "echo \"" str "\" | bc -l"))) + (str (read pipe))) + (close-pipe pipe) + str)) +(define (lisp-calc str) + (+ (eval (eq-parse str) (interaction-environment)) 0.0)) + +;; (pretty-print `(,(sys-calc tst1) ,(lisp-calc tst1))) diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test new file mode 100644 index 000000000..f516571e8 --- /dev/null +++ b/test-suite/tests/peg.test @@ -0,0 +1,278 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; PEG test suite. +;; Tests the parsing capabilities of (ice-9 peg). Could use more +;; tests for edge cases. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-module (test-suite test-peg) + :use-module (test-suite lib) + :use-module (ice-9 peg) + :use-module (ice-9 pretty-print) + :use-module (srfi srfi-1)) + +;; Doubled up for pasting into REPL. +(use-modules (test-suite lib)) +(use-modules (ice-9 peg)) +(use-modules (ice-9 pretty-print)) +(use-modules (srfi srfi-1)) + +;; Evaluates an expression at the toplevel. Not the prettiest +;; solution to runtime issues ever, but m3h. Runs at toplevel so that +;; symbols are bound globally instead of in the scope of the pass-if +;; expression. +(define (eeval exp) + (eval exp (interaction-environment))) +(define make-prec (@@ (ice-9 peg) make-prec)) + +;; Maps the nonterminals defined in the PEG parser written as a PEG to +;; the nonterminals defined in the PEG parser written with +;; S-expressions. +(define grammar-mapping + '((grammar peg-grammar) + (pattern peg-pattern) + (alternative peg-alternative) + (suffix peg-suffix) + (primary peg-primary) + (literal peg-literal) + (charclass peg-charclass) + (CCrange charclass-range) + (CCsingle charclass-single) + (nonterminal peg-nonterminal) + (sp peg-sp))) + +;; Transforms the nonterminals defined in the PEG parser written as a PEG to the nonterminals defined in the PEG parser written with S-expressions. +(define (grammar-transform x) + (let ((res (assoc x grammar-mapping))) + (if res (cadr res) x))) + +;; Maps a function onto a tree (recurses until it finds atoms, then calls the function on the atoms). +(define (tree-map fn lst) + (if (list? lst) + (if (null? lst) + lst + (cons (tree-map fn (car lst)) + (tree-map fn (cdr lst)))) + (fn lst))) + +;; Tests to make sure that we can parse a PEG defining a grammar for +;; PEGs, then uses that grammar to parse the same PEG again to make +;; sure we get the same result (i.e. make sure our PEG grammar +;; expressed as a PEG is equivalent to our PEG grammar expressed with +;; S-expressions). +(with-test-prefix "PEG Grammar" + (pass-if + "defining PEGs with PEG" + (and (eeval `(define-peg-string-patterns ,(@@ (ice-9 peg) peg-as-peg))) #t)) + (pass-if + "equivalence of definitions" + (equal? + (peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg))) + (tree-map + grammar-transform + (peg:tree (match-pattern grammar (@@ (ice-9 peg) peg-as-peg))))))) + +;; A grammar for pascal-style comments from Wikipedia. +(define comment-grammar + "Begin <-- '(*' +End <-- '*)' +C <- Begin N* End +N <- C / (!Begin !End Z) +Z <- .") + +;; A short /etc/passwd file. +(define *etc-passwd* + "root:x:0:0:root:/root:/bin/bash +daemon:x:1:1:daemon:/usr/sbin:/bin/sh +bin:x:2:2:bin:/bin:/bin/sh +sys:x:3:3:sys:/dev:/bin/sh +nobody:x:65534:65534:nobody:/nonexistent:/bin/sh +messagebus:x:103:107::/var/run/dbus:/bin/false +") + +;; A grammar for parsing /etc/passwd files. +(define-peg-string-patterns + "passwd <-- entry* !. +entry <-- login CO pass CO uid CO gid CO nameORcomment CO homedir CO shell NL* +login <-- text +pass <-- text +uid <-- [0-9]* +gid <-- [0-9]* +nameORcomment <-- text +homedir <-- path +shell <-- path +path <-- (SLASH pathELEMENT)* +pathELEMENT <-- (!NL !CO !'/' .)* +text <- (!NL !CO .)* +CO < ':' +NL < '\n' +SLASH < '/'") + +;; Tests some actual parsing using PEGs. +(with-test-prefix "Parsing" + (eeval `(define-peg-string-patterns ,comment-grammar)) + (pass-if + ;; Pascal-style comment parsing + "simple comment" + (equal? + (match-pattern C "(*blah*)") + (make-prec 0 8 "(*blah*)" + '((Begin "(*") "blah" (End "*)"))))) + (pass-if + "simple comment padded" + (equal? + (match-pattern C "(*blah*)abc") + (make-prec 0 8 "(*blah*)abc" + '((Begin "(*") "blah" (End "*)"))))) + (pass-if + "nested comment" + (equal? + (match-pattern C "(*1(*2*)*)") + (make-prec 0 10 "(*1(*2*)*)" + '((Begin "(*") ("1" ((Begin "(*") "2" (End "*)"))) (End "*)"))))) + (pass-if + "early termination" + (not (match-pattern C "(*blah"))) + (pass-if + "never starts" + (not (match-pattern C "blah"))) + ;; /etc/passwd parsing + (pass-if + "/etc/passwd" + (equal? + (match-pattern passwd *etc-passwd*) + (make-prec 0 220 *etc-passwd* + '(passwd (entry (login "root") (pass "x") (uid "0") (gid "0") (nameORcomment "root") (homedir (path (pathELEMENT "root"))) (shell (path (pathELEMENT "bin") (pathELEMENT "bash")))) (entry (login "daemon") (pass "x") (uid "1") (gid "1") (nameORcomment "daemon") (homedir (path (pathELEMENT "usr") (pathELEMENT "sbin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "bin") (pass "x") (uid "2") (gid "2") (nameORcomment "bin") (homedir (path (pathELEMENT "bin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "sys") (pass "x") (uid "3") (gid "3") (nameORcomment "sys") (homedir (path (pathELEMENT "dev"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "nobody") (pass "x") (uid "65534") (gid "65534") (nameORcomment "nobody") (homedir (path (pathELEMENT "nonexistent"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "messagebus") (pass "x") (uid "103") (gid "107") nameORcomment (homedir (path (pathELEMENT "var") (pathELEMENT "run") (pathELEMENT "dbus"))) (shell (path (pathELEMENT "bin") (pathELEMENT "false"))))))))) + +;; Tests the functions for pulling data out of PEG Match Records. +(with-test-prefix "PEG Match Records" + (define-peg-pattern bs all (peg "'b'+")) + (pass-if + "basic parameter extraction" + (equal? + (let ((pm (search-for-pattern bs "aabbcc"))) + `((string ,(peg:string pm)) + (start ,(peg:start pm)) + (end ,(peg:end pm)) + (substring ,(peg:substring pm)) + (tree ,(peg:tree pm)) + (record? ,(peg-record? pm)))) + '((string "aabbcc") + (start 2) + (end 4) + (substring "bb") + (tree (bs "bb")) + (record? #t))))) + +;; PEG for parsing right-associative equations. +(define-peg-string-patterns + "expr <- sum +sum <-- (product ('+' / '-') sum) / product +product <-- (value ('*' / '/') product) / value +value <-- number / '(' expr ')' +number <-- [0-9]+") + +;; Functions to actually evaluate the equations parsed with the PEG. +(define (parse-sum sum left . rest) + (if (null? rest) + (apply parse-product left) + (list (string->symbol (car rest)) + (apply parse-product left) + (apply parse-sum (cadr rest))))) + +(define (parse-product product left . rest) + (if (null? rest) + (apply parse-value left) + (list (string->symbol (car rest)) + (apply parse-value left) + (apply parse-product (cadr rest))))) + +(define (parse-value value first . rest) + (if (null? rest) + (string->number (cadr first)) + (apply parse-sum (car rest)))) + +(define parse-expr parse-sum) +(define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str)))) + +(with-test-prefix "Parsing right-associative equations" + (pass-if + "1" + (equal? (eq-parse "1") 1)) + (pass-if + "1+2" + (equal? (eq-parse "1+2") '(+ 1 2))) + (pass-if + "1+2+3" + (equal? (eq-parse "1+2+3") '(+ 1 (+ 2 3)))) + (pass-if + "1+2*3+4" + (equal? (eq-parse "1+2*3+4") '(+ 1 (+ (* 2 3) 4)))) + (pass-if + "1+2/3*(4+5)/6-7-8" + (equal? (eq-parse "1+2/3*(4+5)/6-7-8") + '(+ 1 (- (/ 2 (* 3 (/ (+ 4 5) 6))) (- 7 8))))) + (pass-if + "1+1/2*3+(1+1)/2" + (equal? (eq-parse "1+1/2*3+(1+1)/2") + '(+ 1 (+ (/ 1 (* 2 3)) (/ (+ 1 1) 2)))))) + +;; PEG for parsing left-associative equations (normal ones). +(define-peg-string-patterns + "expr <- sum +sum <-- (product ('+' / '-'))* product +product <-- (value ('*' / '/'))* value +value <-- number / '(' expr ')' +number <-- [0-9]+") + +;; Functions to actually evaluate the equations parsed with the PEG. +(define (make-left-parser next-func) + (lambda (sum first . rest) + (if (null? rest) + (apply next-func first) + (if (string? (cadr first)) + (list (string->symbol (cadr first)) + (apply next-func (car first)) + (apply next-func (car rest))) + (car + (reduce + (lambda (l r) + (list (list (cadr r) (car r) (apply next-func (car l))) + (string->symbol (cadr l)))) + 'ignore + (append + (list (list (apply next-func (caar first)) + (string->symbol (cadar first)))) + (cdr first) + (list (append rest '("done")))))))))) + +(define (parse-value value first . rest) + (if (null? rest) + (string->number (cadr first)) + (apply parse-sum (car rest)))) +(define parse-product (make-left-parser parse-value)) +(define parse-sum (make-left-parser parse-product)) +(define parse-expr parse-sum) +(define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str)))) + +(with-test-prefix "Parsing left-associative equations" + (pass-if + "1" + (equal? (eq-parse "1") 1)) + (pass-if + "1+2" + (equal? (eq-parse "1+2") '(+ 1 2))) + (pass-if + "1+2+3" + (equal? (eq-parse "1+2+3") '(+ (+ 1 2) 3))) + (pass-if + "1+2*3+4" + (equal? (eq-parse "1+2*3+4") '(+ (+ 1 (* 2 3)) 4))) + (pass-if + "1+2/3*(4+5)/6-7-8" + (equal? (eq-parse "1+2/3*(4+5)/6-7-8") + '(- (- (+ 1 (/ (* (/ 2 3) (+ 4 5)) 6)) 7) 8))) + (pass-if + "1+1/2*3+(1+1)/2" + (equal? (eq-parse "1+1/2*3+(1+1)/2") + '(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2))))) + diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 923b0d16a..ecc5dd187 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -33,12 +33,9 @@ (@@ (language tree-il optimize) peval)) (define-syntax pass-if-peval - (syntax-rules (resolve-primitives) + (syntax-rules () ((_ 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) @@ -75,7 +72,7 @@ (f))) (const 3)) - (pass-if-peval resolve-primitives + (pass-if-peval ;; First order, let-values (requires primitive expansion for ;; `call-with-values'.) (let ((x 0)) @@ -85,19 +82,19 @@ (+ a b)))) (const 3)) - (pass-if-peval resolve-primitives + (pass-if-peval ;; First order, multiple values. (let ((x 1) (y 2)) (values x y)) - (apply (primitive values) (const 1) (const 2))) + (primcall values (const 1) (const 2))) - (pass-if-peval resolve-primitives + (pass-if-peval ;; First order, multiple values truncated. (let ((x (values 1 'a)) (y 2)) (values x y)) - (apply (primitive values) (const 1) (const 2))) + (primcall values (const 1) (const 2))) - (pass-if-peval resolve-primitives + (pass-if-peval ;; First order, multiple values truncated. (or (values 1 2) 3) (const 1)) @@ -105,16 +102,16 @@ (pass-if-peval ;; First order, coalesced, mutability preserved. (cons 0 (cons 1 (cons 2 (list 3 4 5)))) - (apply (primitive list) - (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))) + (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)))) - (apply (primitive cons) (const 0) - (apply (primitive cons) (const 1) - (apply (primitive cons) (const 2) - (const (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 @@ -139,10 +136,10 @@ (if (zero? i) r (loop (1- i) (cons (cons i i) r)))) - (apply (primitive list) - (apply (primitive cons) (const 1) (const 1)) - (apply (primitive cons) (const 2) (const 2)) - (apply (primitive cons) (const 3) (const 3)))) + (primcall list + (primcall cons (const 1) (const 1)) + (primcall cons (const 2) (const 2)) + (primcall cons (const 3) (const 3)))) ;; ;; See above. #; @@ -163,15 +160,15 @@ r (loop (1- i) (cons (cons i i) r)))) (let (r) (_) - ((apply (primitive list) - (apply (primitive cons) (const 3) (const 3)))) + ((primcall list + (primcall cons (const 3) (const 3)))) (let (r) (_) - ((apply (primitive cons) - (apply (primitive cons) (const 2) (const 2)) - (lexical r _))) - (apply (primitive cons) - (apply (primitive cons) (const 1) (const 1)) - (lexical 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 @@ -181,21 +178,21 @@ (car r) (loop (1- i) (cons i r)))) (let (r) (_) - ((apply (primitive list) (const 4))) + ((primcall list (const 4))) (let (r) (_) - ((apply (primitive cons) - (const 3) - (lexical r _))) + ((primcall cons + (const 3) + (lexical r _))) (let (r) (_) - ((apply (primitive cons) - (const 2) - (lexical r _))) + ((primcall cons + (const 2) + (lexical r _))) (let (r) (_) - ((apply (primitive cons) - (const 1) - (lexical r _))) - (apply (primitive car) - (lexical r _))))))) + ((primcall cons + (const 1) + (lexical r _))) + (primcall car + (lexical r _))))))) ;; Static sums. (pass-if-peval @@ -205,7 +202,7 @@ (loop (cdr l) (+ sum (car l))))) (const 10)) - (pass-if-peval resolve-primitives + (pass-if-peval (let ((string->chars (lambda (s) (define (char-at n) @@ -218,7 +215,7 @@ (loop (1+ i))) '()))))) (string->chars "yo")) - (apply (primitive list) (const #\y) (const #\o))) + (primcall list (const #\y) (const #\o))) (pass-if-peval ;; Primitives in module-refs are resolved (the expansion of `pmatch' @@ -229,14 +226,13 @@ (pmatch '(a b c d) ((a b . _) #t))) - (begin - (apply . _) - (const #t))) + (seq (call . _) + (const #t))) (pass-if-peval ;; Mutability preserved. ((lambda (x y z) (list x y z)) 1 2 3) - (apply (primitive list) (const 1) (const 2) (const 3))) + (primcall list (const 1) (const 2) (const 3))) (pass-if-peval ;; Don't propagate effect-free expressions that operate on mutable @@ -245,10 +241,10 @@ (y (car x))) (set-car! x 0) y) - (let (x) (_) ((apply (primitive list) (const 1))) - (let (y) (_) ((apply (primitive car) (lexical x _))) - (begin - (apply (toplevel set-car!) (lexical x _) (const 0)) + (let (x) (_) ((primcall list (const 1))) + (let (y) (_) ((primcall car (lexical x _))) + (seq + (primcall set-car! (lexical x _) (const 0)) (lexical y _))))) (pass-if-peval @@ -257,9 +253,9 @@ (let ((y (car x))) (set-car! x 0) y) - (let (y) (_) ((apply (primitive car) (toplevel x))) - (begin - (apply (toplevel set-car!) (toplevel x) (const 0)) + (let (y) (_) ((primcall car (toplevel x))) + (seq + (primcall set-car! (toplevel x) (const 0)) (lexical y _)))) (pass-if-peval @@ -269,8 +265,8 @@ ((lambda _ (lambda-case (((x) _ _ _ _ _) - (apply (lexical x _) (lexical x _)))))) - (apply (lexical x _) (lexical x _)))) + (call (lexical x _) (lexical x _)))))) + (call (lexical x _) (lexical x _)))) (pass-if-peval ;; First order, aliased primitive. @@ -282,28 +278,28 @@ (begin (define (+ x y) (pk x y)) (+ 1 2)) - (begin + (seq (define + (lambda (_) (lambda-case (((x y) #f #f #f () (_ _)) - (apply (toplevel pk) (lexical x _) (lexical y _)))))) - (apply (toplevel +) (const 1) (const 2)))) + (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) - (begin - (apply (toplevel do-something!)) + (seq + (call (toplevel do-something!)) (const 2))) (pass-if-peval ;; First order, residual bindings removed. (let ((x 2) (y 3)) (* (+ x y) z)) - (apply (primitive *) (const 5) (toplevel z))) + (primcall * (const 5) (toplevel z))) (pass-if-peval ;; First order, with lambda. @@ -314,7 +310,7 @@ (lambda (_) (lambda-case (((x) #f #f #f () (_)) - (apply (primitive +) (lexical x _) (const 9))))))) + (primcall + (lexical x _) (const 9))))))) (pass-if-peval ;; First order, with lambda inlined & specialized twice. @@ -324,22 +320,22 @@ (y 3)) (+ (* x (f x y)) (f something x))) - (apply (primitive +) - (apply (primitive *) - (const 2) - (apply (primitive +) ; (f 2 3) - (apply (primitive *) - (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. - (apply (primitive +) - (apply (primitive *) - (lexical x _) - (toplevel top)) - (const 2))))) + (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. @@ -349,15 +345,22 @@ (f -1 y) (f 2 y) (f z y))) - (apply (primitive +) - (const -1) ; (f -1 0) - (const 0) ; (f 1 0) - (begin (toplevel y) (const -1)) ; (f -1 y) - (toplevel y) ; (f 2 y) - (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y) - (if (apply (primitive >) (lexical x _) (const 0)) - (lexical y _) - (lexical x _))))) + (primcall + + + (const -1) ; (f -1 0) + (primcall + + + (const 0) ; (f 1 0) + (primcall + + + (seq (toplevel y) (const -1)) ; (f -1 y) + (primcall + + + (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. @@ -369,7 +372,7 @@ (lambda () (lambda-case (((x) #f #f #f () (_)) - (apply (toplevel display) (lexical x _)))))) + (call (toplevel display) (lexical x _)))))) (pass-if-peval ;; First order, recursive procedure. @@ -388,8 +391,8 @@ (foo) x) (let (x) (_) ((toplevel top)) - (begin - (apply (toplevel foo)) + (seq + (call (toplevel foo)) (lexical x _)))) (pass-if-peval @@ -428,8 +431,8 @@ (lambda (x) (+ x 1)) '(2 3)) - (let (y) (_) ((apply (toplevel foo))) - (apply (primitive +) (lexical y _) (const 7)))) + (let (y) (_) ((call (toplevel foo))) + (primcall + (lexical y _) (const 7)))) (pass-if-peval ;; Higher order with optional argument (caller-supplied value). @@ -451,7 +454,7 @@ ;; <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))) - (apply (primitive 1+) (toplevel top))) + (primcall 1+ (toplevel top))) (pass-if-peval ;; Procedure not inlined when residual code contains recursive calls. @@ -462,7 +465,7 @@ (f (car x3) (fold f (cdr x3) b null? car cdr)))))) (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1)))) (letrec (fold) (_) (_) - (apply (lexical fold _) + (call (lexical fold _) (primitive *) (toplevel x) (const 1) @@ -474,7 +477,7 @@ (lambda () (lambda-case (((x2) #f #f #f () (_)) - (apply (primitive -) (lexical x2 _) (const 1)))))))) + (primcall 1- (lexical x2 _)))))))) (pass-if "inlined lambdas are alpha-renamed" ;; In this example, `make-adder' is inlined more than once; thus, @@ -485,24 +488,27 @@ ;; <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))) - ((apply (primitive cons) - (lambda () - (lambda-case - (((y) #f #f #f () (,gensym1)) - (apply (primitive +) - (const 1) - (lexical y ,ref1))))) - (lambda () - (lambda-case - (((y) #f #f #f () (,gensym2)) - (apply (primitive +) - (const 2) - (lexical y ,ref2)))))) + (peval (expand-primitives! + (resolve-primitives! + (compile + '(let ((make-adder + (lambda (x) (lambda (y) (+ x y))))) + (cons (make-adder 1) (make-adder 2))) + #:to 'tree-il) + (current-module))))) + ((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)))) @@ -522,8 +528,8 @@ (b (lambda () (a))) (c (lambda (x) x))) (c 10)) - (begin (apply (toplevel foo!)) - (const 10))) + (seq (call (toplevel foo!)) + (const 10))) (pass-if-peval ;; Higher order, mutually recursive procedures. @@ -544,9 +550,9 @@ ;; Memv with non-constant list. It could fold but doesn't ;; currently. (memv 1 (list 3 2 1)) - (apply (primitive memv) - (const 1) - (apply (primitive list) (const 3) (const 2) (const 1)))) + (primcall memv + (const 1) + (primcall list (const 3) (const 2) (const 1)))) (pass-if-peval ;; Memv with non-constant key, constant list, test context @@ -554,21 +560,20 @@ ((3 2 1) 'a) (else 'b)) (let (key) (_) ((toplevel foo)) - (if (if (apply (primitive eqv?) (lexical key _) (const 3)) + (if (if (primcall eqv? (lexical key _) (const 3)) (const #t) - (if (apply (primitive eqv?) (lexical key _) (const 2)) + (if (primcall eqv? (lexical key _) (const 2)) (const #t) - (apply (primitive eqv?) (lexical key _) (const 1)))) + (primcall eqv? (lexical key _) (const 1)))) (const a) (const b)))) (pass-if-peval - ;; Memv with non-constant key, empty list, test context. Currently - ;; doesn't fold entirely. + ;; Memv with non-constant key, empty list, test context. (case foo (() 'a) (else 'b)) - (begin (toplevel foo) (const b))) + (seq (toplevel foo) (const 'b))) ;; ;; Below are cases where constant propagation should bail out. @@ -580,12 +585,12 @@ (lambda (n) (vector-set! v n n))) (let (v) (_) - ((apply (toplevel make-vector) (const 6) (const #f))) + ((call (toplevel make-vector) (const 6) (const #f))) (lambda () (lambda-case (((n) #f #f #f () (_)) - (apply (toplevel vector-set!) - (lexical v _) (lexical n _) (lexical n _))))))) + (primcall vector-set! + (lexical v _) (lexical n _) (lexical n _))))))) (pass-if-peval ;; Mutable lexical is not propagated. @@ -593,7 +598,7 @@ (lambda () v)) (let (v) (_) - ((apply (primitive vector) (const 1) (const 2) (const 3))) + ((primcall vector (const 1) (const 2) (const 3))) (lambda () (lambda-case ((() #f #f #f () ()) @@ -604,12 +609,13 @@ (let* ((x (if (> p q) (frob!) (display 'chbouib))) (y (* x 2))) (+ x x y)) - (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q)) - (apply (toplevel frob!)) - (apply (toplevel display) (const chbouib)))) - (let (y) (_) ((apply (primitive *) (lexical x _) (const 2))) - (apply (primitive +) - (lexical x _) (lexical x _) (lexical 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 _) + (primcall + (lexical x _) (lexical y _)))))) (pass-if-peval ;; Non-constant arguments not propagated to lambdas. @@ -621,16 +627,16 @@ (make-list 10) (list 1 2 3)) (let (x y z) (_ _ _) - ((apply (primitive vector) (const 1) (const 2) (const 3)) - (apply (toplevel make-list) (const 10)) - (apply (primitive list) (const 1) (const 2) (const 3))) - (begin - (apply (toplevel vector-set!) - (lexical x _) (const 0) (const 0)) - (apply (toplevel set-car!) - (lexical y _) (const 0)) - (apply (toplevel set-cdr!) - (lexical z _) (const ()))))) + ((primcall vector (const 1) (const 2) (const 3)) + (call (toplevel make-list) (const 10)) + (primcall list (const 1) (const 2) (const 3))) + (seq + (primcall vector-set! + (lexical x _) (const 0) (const 0)) + (seq (primcall set-car! + (lexical y _) (const 0)) + (primcall set-cdr! + (lexical z _) (const ())))))) (pass-if-peval (let ((foo top-foo) (bar top-bar)) @@ -638,9 +644,9 @@ (f (lambda (g x) (g x x)))) (+ (f g foo) (f g bar)))) (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar)) - (apply (primitive +) - (apply (primitive +) (lexical foo _) (lexical foo _)) - (apply (primitive +) (lexical bar _) (lexical 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 @@ -649,8 +655,8 @@ (x (cons 1 c)) (y (cons 0 x))) y) - (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3)))) - (apply (primitive cons) (const 0) (lexical x _)))) + (let (x) (_) ((primcall cons (const 1) (const (2 3)))) + (primcall cons (const 0) (lexical x _)))) (pass-if-peval ;; Bindings mutated. @@ -658,7 +664,7 @@ (set! x 3) x) (let (x) (_) ((const 2)) - (begin + (seq (set! (lexical x _) (const 3)) (lexical x _)))) @@ -671,8 +677,8 @@ (frob f) ; may mutate `x' x) (letrec (x) (_) ((const 0)) - (begin - (apply (toplevel frob) (lambda _ _)) + (seq + (call (toplevel frob) (lambda _ _)) (lexical x _)))) (pass-if-peval @@ -688,9 +694,9 @@ (let ((x (make-foo))) (frob! x) ; may mutate `x' x) - (let (x) (_) ((apply (toplevel make-foo))) - (begin - (apply (toplevel frob!) (lexical x _)) + (let (x) (_) ((call (toplevel make-foo))) + (seq + (call (toplevel frob!) (lexical x _)) (lexical x _)))) (pass-if-peval @@ -701,10 +707,10 @@ (lambda-case (((x) #f #f #f () (_)) (if _ _ - (apply (lexical loop _) - (apply (primitive 1-) - (lexical x _)))))))) - (apply (lexical loop _) (toplevel x)))) + (call (lexical loop _) + (primcall 1- + (lexical x _)))))))) + (call (lexical loop _) (toplevel x)))) (pass-if-peval ;; Recursion on the 2nd argument is fully evaluated. @@ -713,8 +719,8 @@ (if (> y 0) (loop x (1- y)) (foo x y)))) - (let (x) (_) ((apply (toplevel top))) - (apply (toplevel foo) (lexical x _) (const 0)))) + (let (x) (_) ((call (toplevel top))) + (call (toplevel foo) (lexical x _) (const 0)))) (pass-if-peval ;; Inlining aborted when residual code contains recursive calls. @@ -729,10 +735,10 @@ (letrec (loop) (_) ((lambda (_) (lambda-case (((x y) #f #f #f () (_ _)) - (if (apply (primitive >) - (lexical y _) (const 0)) + (if (primcall > + (lexical y _) (const 0)) _ _))))) - (apply (lexical loop _) (toplevel x) (const 0)))) + (call (lexical loop _) (toplevel x) (const 0)))) (pass-if-peval ;; Infinite recursion: `peval' gives up and leaves it as is. @@ -749,7 +755,7 @@ (and (< x top) (loop (1+ x)))) (letrec (loop) (_) ((lambda . _)) - (apply (lexical loop _) (const 0)))) + (call (lexical loop _) (const 0)))) (pass-if-peval ;; This test checks that the `start' binding is indeed residualized. @@ -760,10 +766,10 @@ (here))) (let (pos) (_) ((const 0)) (let (here) (_) (_) - (begin - (set! (lexical pos _) (const 1)) - (apply (lexical here _)))))) - + (seq + (set! (lexical pos _) (const 1)) + (call (lexical here _)))))) + (pass-if-peval ;; FIXME: should this one residualize the binding? (letrec ((a a)) @@ -799,7 +805,7 @@ ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (lexical a _))))) + (call (lexical a _))))) (lambda _ (lambda-case (((x) #f #f #f () (_)) @@ -807,12 +813,11 @@ (lambda _ (lambda-case ((() #f #f #f () ()) - (apply (lexical a _)))))) + (call (lexical a _)))))) (let (d) (_) - ((apply (toplevel foo) (lexical b _))) - (apply (lexical c _) - (lexical d _))))) + ((call (toplevel foo) (lexical b _))) + (call (lexical c _) (lexical d _))))) (pass-if-peval ;; In this case, we can prune the bindings. `a' ends up being copied @@ -821,17 +826,17 @@ (letrec* ((a (lambda (x) (top x))) (b (lambda () a))) (foo (b) (b))) - (apply (toplevel foo) - (lambda _ - (lambda-case - (((x) #f #f #f () (_)) - (apply (toplevel top) (lexical x _))))) - (lambda _ - (lambda-case - (((x) #f #f #f () (_)) - (apply (toplevel top) (lexical x _))))))) + (call (toplevel foo) + (lambda _ + (lambda-case + (((x) #f #f #f () (_)) + (call (toplevel top) (lexical x _))))) + (lambda _ + (lambda-case + (((x) #f #f #f () (_)) + (call (toplevel top) (lexical x _))))))) - (pass-if-peval resolve-primitives + (pass-if-peval ;; The inliner sees through a `let'. ((let ((a 10)) (lambda (b) (* b 2))) 30) (const 60)) @@ -848,39 +853,39 @@ ((lambda (x y . z) (list x y z)) 1 2 3 4) - (let (z) (_) ((apply (primitive list) (const 3) (const 4))) - (apply (primitive list) (const 1) (const 2) (lexical z _)))) + (let (z) (_) ((primcall list (const 3) (const 4))) + (primcall list (const 1) (const 2) (lexical z _)))) - (pass-if-peval resolve-primitives + (pass-if-peval ;; Unmutated lists can get inlined. (let ((args (list 2 3))) (apply (lambda (x y z w) (list x y z w)) 0 1 args)) - (apply (primitive list) (const 0) (const 1) (const 2) (const 3))) + (primcall list (const 0) (const 1) (const 2) (const 3))) - (pass-if-peval resolve-primitives + (pass-if-peval ;; However if the list might have been mutated, it doesn't propagate. (let ((args (list 2 3))) (foo! args) (apply (lambda (x y z w) (list x y z w)) 0 1 args)) - (let (args) (_) ((apply (primitive list) (const 2) (const 3))) - (begin - (apply (toplevel foo!) (lexical args _)) - (apply (primitive @apply) - (lambda () - (lambda-case - (((x y z w) #f #f #f () (_ _ _ _)) - (apply (primitive list) - (lexical x _) (lexical y _) - (lexical z _) (lexical w _))))) - (const 0) - (const 1) - (lexical args _))))) - - (pass-if-peval resolve-primitives + (let (args) (_) ((primcall list (const 2) (const 3))) + (seq + (call (toplevel foo!) (lexical args _)) + (primcall @apply + (lambda () + (lambda-case + (((x y z w) #f #f #f () (_ _ _ _)) + (primcall list + (lexical x _) (lexical y _) + (lexical z _) (lexical w _))))) + (const 0) + (const 1) + (lexical args _))))) + + (pass-if-peval ;; Here the `args' that gets built by the application of the lambda ;; takes more than effort "10" to visit. Test that we fall back to ;; the source expression of the operand, which is still a call to @@ -909,27 +914,27 @@ (lambda () (lambda-case (((bv offset n) #f #f #f () (_ _ _)) - (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref) - (lexical bv _) - (apply (primitive +) - (lexical offset _) (const 0))) - (apply (primitive bytevector-ieee-single-native-ref) - (lexical bv _) - (apply (primitive +) - (lexical offset _) (const 4)))) - (begin - (apply (primitive bytevector-ieee-single-native-set!) - (lexical bv _) - (apply (primitive +) - (lexical offset _) (const 0)) - (lexical x _)) - (apply (primitive bytevector-ieee-single-native-set!) - (lexical bv _) - (apply (primitive +) - (lexical offset _) (const 4)) - (lexical y _)))))))) - - (pass-if-peval resolve-primitives + (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref + (lexical bv _) + (primcall + + (lexical offset _) (const 0))) + (primcall bytevector-ieee-single-native-ref + (lexical bv _) + (primcall + + (lexical offset _) (const 4)))) + (seq + (primcall bytevector-ieee-single-native-set! + (lexical bv _) + (primcall + + (lexical offset _) (const 0)) + (lexical x _)) + (primcall bytevector-ieee-single-native-set! + (lexical bv _) + (primcall + + (lexical offset _) (const 4)) + (lexical y _)))))))) + + (pass-if-peval ;; Here we ensure that non-constant expressions are not copied. (lambda () (let ((args (list (foo!)))) @@ -943,13 +948,13 @@ (lambda () (lambda-case ((() #f #f #f () ()) - (let (_) (_) ((apply (toplevel foo!))) + (let (_) (_) ((call (toplevel foo!))) (let (z) (_) ((toplevel z)) - (apply (primitive 'list) - (lexical z _) - (lexical _ _)))))))) + (primcall 'list + (lexical z _) + (lexical _ _)))))))) - (pass-if-peval resolve-primitives + (pass-if-peval ;; Rest args referenced more than once are not destructured. (lambda () (let ((args (list 'foo))) @@ -963,25 +968,25 @@ (lambda-case ((() #f #f #f () ()) (let (args) (_) - ((apply (primitive list) (const foo))) - (begin - (apply (primitive set-car!) (lexical args _) (const bar)) - (apply (primitive @apply) - (lambda . _) - (toplevel z) - (lexical args _)))))))) - - (pass-if-peval resolve-primitives + ((primcall list (const foo))) + (seq + (primcall set-car! (lexical args _) (const bar)) + (primcall @apply + (lambda . _) + (toplevel z) + (lexical args _)))))))) + + (pass-if-peval ;; Let-values inlining, even with consumers with rest args. (call-with-values (lambda () (values 1 2)) (lambda args (apply list args))) - (apply (primitive list) (const 1) (const 2))) + (primcall list (const 1) (const 2))) (pass-if-peval ;; Constant folding: cons of #nil does not make list (cons 1 #nil) - (apply (primitive cons) (const 1) (const '#nil))) + (primcall cons (const 1) (const '#nil))) (pass-if-peval ;; Constant folding: cons @@ -991,7 +996,7 @@ (pass-if-peval ;; Constant folding: cons (begin (cons (foo) 2) #f) - (begin (apply (toplevel foo)) (const #f))) + (seq (call (toplevel foo)) (const #f))) (pass-if-peval ;; Constant folding: cons @@ -1011,12 +1016,12 @@ (pass-if-peval ;; Constant folding: car+cons, impure (car (cons 1 (bar))) - (begin (apply (toplevel bar)) (const 1))) + (seq (call (toplevel bar)) (const 1))) (pass-if-peval ;; Constant folding: cdr+cons, impure (cdr (cons (bar) 0)) - (begin (apply (toplevel bar)) (const 0))) + (seq (call (toplevel bar)) (const 0))) (pass-if-peval ;; Constant folding: car+list @@ -1026,40 +1031,53 @@ (pass-if-peval ;; Constant folding: cdr+list (cdr (list 1 0)) - (apply (primitive list) (const 0))) + (primcall list (const 0))) (pass-if-peval ;; Constant folding: car+list, impure (car (list 1 (bar))) - (begin (apply (toplevel bar)) (const 1))) + (seq (call (toplevel bar)) (const 1))) (pass-if-peval ;; Constant folding: cdr+list, impure (cdr (list (bar) 0)) - (begin (apply (toplevel bar)) (apply (primitive list) (const 0)))) + (seq (call (toplevel bar)) (primcall list (const 0)))) + + (pass-if-peval + ;; Equality primitive: same lexical + (let ((x (random))) (eq? x x)) + (seq (call (toplevel random)) (const #t))) + + (pass-if-peval + ;; Equality primitive: merge lexical identities + (let* ((x (random)) (y x)) (eq? x y)) + (seq (call (toplevel random)) (const #t))) (pass-if-peval - resolve-primitives ;; 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 _)))) + (let (w u) (_ _) ((toplevel foo) (toplevel baz)) + (dynwind (lexical w _) + (call (lexical w _)) + (toplevel bar) + (call (lexical u _)) + (lexical u _)))) (pass-if-peval - resolve-primitives ;; 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 foo) (toplevel bar) + (toplevel baz) (lambda () (lambda-case ((() #f #f #f () ()) (toplevel baz)))))) (pass-if-peval - resolve-primitives ;; Prompt is removed if tag is unreferenced (let ((tag (make-prompt-tag))) (call-with-prompt tag @@ -1068,7 +1086,6 @@ (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 @@ -1078,7 +1095,6 @@ ;; Handler lambda inlined (pass-if-peval - resolve-primitives (call-with-prompt tag (lambda () 1) (lambda (k x) x)) @@ -1090,7 +1106,6 @@ ;; Handler toplevel not inlined (pass-if-peval - resolve-primitives (call-with-prompt tag (lambda () 1) handler) @@ -1099,12 +1114,11 @@ (const 1) (lambda-case ((() #f args #f () (_)) - (apply (primitive @apply) - (lexical handler _) - (lexical args _))))))) + (primcall @apply + (lexical handler _) + (lexical args _))))))) (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, and the continuation tag stays around. (The continue tag @@ -1113,7 +1127,7 @@ ;; twice before aborting. The abort doesn't unroll the recursive ;; reference.) (while #t #t) - (let (_) (_) ((apply (primitive make-prompt-tag) . _)) + (let (_) (_) ((primcall make-prompt-tag . _)) (letrec (lp) (_) ((lambda _ (lambda-case @@ -1122,12 +1136,11 @@ ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (lexical loop _)))))) - (apply (lexical loop _))))))) - (apply (lexical lp _))))) + (call (lexical loop _)))))) + (call (lexical loop _))))))) + (call (lexical lp _))))) (pass-if-peval - resolve-primitives (lambda (a . rest) (apply (lambda (x y) (+ x y)) a rest)) @@ -1136,7 +1149,7 @@ (((x y) #f #f #f () (_ _)) _)))) - (pass-if-peval resolve-primitives + (pass-if-peval (car '(1 2)) (const 1)) @@ -1145,17 +1158,17 @@ ;; residualizing a reference to the leaf identifier. The bailout is ;; driven by the recursive-effort-limit, which is currently 100. We ;; make sure to trip it with this recursive sum thing. - (pass-if-peval resolve-primitives + (pass-if-peval (let ((x (let sum ((n 0) (out 0)) (if (< n 10000) (sum (1+ n) (+ out n)) out)))) ((lambda (y) (list y)) x)) (let (x) (_) (_) - (apply (primitive list) (lexical x _)))) + (primcall list (lexical x _)))) ;; Here we test that a common test in a chain of ifs gets lifted. - (pass-if-peval resolve-primitives + (pass-if-peval (if (and (struct? x) (eq? (struct-vtable x) A)) (foo x) (if (and (struct? x) (eq? (struct-vtable x) B)) @@ -1166,25 +1179,25 @@ (let (failure) (_) ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (toplevel qux) (toplevel x)))))) - (if (apply (primitive struct?) (toplevel x)) - (if (apply (primitive eq?) - (apply (primitive struct-vtable) (toplevel x)) - (toplevel A)) - (apply (toplevel foo) (toplevel x)) - (if (apply (primitive eq?) - (apply (primitive struct-vtable) (toplevel x)) - (toplevel B)) - (apply (toplevel bar) (toplevel x)) - (if (apply (primitive eq?) - (apply (primitive struct-vtable) (toplevel x)) - (toplevel C)) - (apply (toplevel baz) (toplevel x)) - (apply (lexical failure _))))) - (apply (lexical failure _))))) + (call (toplevel qux) (toplevel x)))))) + (if (primcall struct? (toplevel x)) + (if (primcall eq? + (primcall struct-vtable (toplevel x)) + (toplevel A)) + (call (toplevel foo) (toplevel x)) + (if (primcall eq? + (primcall struct-vtable (toplevel x)) + (toplevel B)) + (call (toplevel bar) (toplevel x)) + (if (primcall eq? + (primcall struct-vtable (toplevel x)) + (toplevel C)) + (call (toplevel baz) (toplevel x)) + (call (lexical failure _))))) + (call (lexical failure _))))) ;; Multiple common tests should get lifted as well. - (pass-if-peval resolve-primitives + (pass-if-peval (if (and (struct? x) (eq? (struct-vtable x) A) B) (foo x) (if (and (struct? x) (eq? (struct-vtable x) A) C) @@ -1195,32 +1208,32 @@ (let (failure) (_) ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (toplevel qux) (toplevel x)))))) - (if (apply (primitive struct?) (toplevel x)) - (if (apply (primitive eq?) - (apply (primitive struct-vtable) (toplevel x)) - (toplevel A)) + (call (toplevel qux) (toplevel x)))))) + (if (primcall struct? (toplevel x)) + (if (primcall eq? + (primcall struct-vtable (toplevel x)) + (toplevel A)) (if (toplevel B) - (apply (toplevel foo) (toplevel x)) + (call (toplevel foo) (toplevel x)) (if (toplevel C) - (apply (toplevel bar) (toplevel x)) + (call (toplevel bar) (toplevel x)) (if (toplevel D) - (apply (toplevel baz) (toplevel x)) - (apply (lexical failure _))))) - (apply (lexical failure _))) - (apply (lexical failure _))))) + (call (toplevel baz) (toplevel x)) + (call (lexical failure _))))) + (call (lexical failure _))) + (call (lexical failure _))))) - (pass-if-peval resolve-primitives + (pass-if-peval (apply (lambda (x y) (cons x y)) '(1 2)) - (apply (primitive cons) (const 1) (const 2))) + (primcall cons (const 1) (const 2))) - (pass-if-peval resolve-primitives + (pass-if-peval (apply (lambda (x y) (cons x y)) (list 1 2)) - (apply (primitive cons) (const 1) (const 2))) + (primcall cons (const 1) (const 2))) - (pass-if-peval resolve-primitives + (pass-if-peval (let ((t (make-prompt-tag))) (call-with-prompt t (lambda () (abort-to-prompt t 1 2 3)) (lambda (k x y z) (list x y z)))) - (apply (primitive 'list) (const 1) (const 2) (const 3)))) + (primcall list (const 1) (const 2) (const 3)))) diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test index ceb6e562b..9407791f7 100644 --- a/test-suite/tests/procprop.test +++ b/test-suite/tests/procprop.test @@ -72,10 +72,4 @@ (pass-if "opt, eval" (equal? (procedure-minimum-arity (eval '(lambda* (a b #:optional c) #t) (current-module))) - '(2 1 #f))) - - (if (include-deprecated-features) - (pass-if-exception "set-procedure-properties! arity" - '(misc-error . "arity is a read-only property") - (set-procedure-properties! (lambda x x) '((arity . 3)))) - #t)) + '(2 1 #f)))) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index ed4959826..3e36cca57 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -693,9 +693,6 @@ (put-string tp "The letter λ cannot be represented in Latin-1.") #f)))) - (pass-if "port-transcoder [binary port]" - (not (port-transcoder (open-bytevector-input-port #vu8())))) - (pass-if "port-transcoder [transcoded port]" (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo")) (make-transcoder (utf-8-codec)))) diff --git a/test-suite/tests/r6rs-records-syntactic.test b/test-suite/tests/r6rs-records-syntactic.test index 9f9d37368..edc88aa72 100644 --- a/test-suite/tests/r6rs-records-syntactic.test +++ b/test-suite/tests/r6rs-records-syntactic.test @@ -30,12 +30,14 @@ (define-record-type simple-rtd) (define-record-type (specified-rtd specified-rtd-constructor specified-rtd-predicate)) -(define-record-type parent-rtd (fields x y)) +;; Can't be named as `parent-rtd', as that shadows the `parent-rtd' +;; literal. +(define-record-type *parent-rtd (fields x y)) (define-record-type child-parent-rtd-rtd - (parent-rtd (record-type-descriptor parent-rtd) - (record-constructor-descriptor parent-rtd)) + (parent-rtd (record-type-descriptor *parent-rtd) + (record-constructor-descriptor *parent-rtd)) (fields z)) -(define-record-type child-parent-rtd (parent parent-rtd) (fields z)) +(define-record-type child-parent-rtd (parent *parent-rtd) (fields z)) (define-record-type mutable-fields-rtd (fields (mutable mutable-bar) (mutable mutable-baz mutable-baz-accessor mutable-baz-mutator))) @@ -69,10 +71,10 @@ (defined? 'specified-rtd-constructor))) (pass-if "parent-rtd clause includes specified parent" - (eq? (record-type-parent child-parent-rtd-rtd) parent-rtd)) + (eq? (record-type-parent child-parent-rtd-rtd) *parent-rtd)) (pass-if "parent clause includes specified parent" - (eq? (record-type-parent child-parent-rtd) parent-rtd)) + (eq? (record-type-parent child-parent-rtd) *parent-rtd)) (pass-if "protocol clause includes specified protocol" (let ((protocol-record (make-protocol-rtd 1 2))) diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index b5c59f030..6799423fc 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -153,6 +153,8 @@ (with-latin1-locale body ...) (begin body ...))))) +(define char-code-limit 256) + ;; Since `regexp-quote' uses string ports, and since it is used below ;; with non-ASCII characters, these ports must be Unicode-capable. (define-syntax with-unicode diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index b1b29227f..ee6446773 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -249,3 +249,28 @@ (parameterize ((current-warning-port (%make-void-port "w"))) (eval '(if #f (baz) #t) (resolve-module '(test-suite test-syncase-3))))) + +(use-modules (system syntax)) + +(with-test-prefix "syntax-local-binding" + (define-syntax syntax-type + (lambda (x) + (syntax-case x () + ((_ id resolve?) + (call-with-values + (lambda () + (syntax-local-binding + #'id + #:resolve-syntax-parameters? (syntax->datum #'resolve?))) + (lambda (type value) + (with-syntax ((type (datum->syntax #'id type))) + #''type))))))) + + (define-syntax-parameter foo + (syntax-rules ())) + + (pass-if "syntax-parameters (resolved)" + (equal? (syntax-type foo #t) 'macro)) + + (pass-if "syntax-parameters (unresolved)" + (equal? (syntax-type foo #f) 'syntax-parameter))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index cdaee716b..e55cba11e 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -842,7 +842,73 @@ (pass-if-syntax-error "(define)" exception:generic-syncase-error (eval '(define) - (interaction-environment))))) + (interaction-environment)))) + + (pass-if "module scoping" + (equal? + (eval + '(begin + (define-module (top-level-define/module-scoping-1) + #:export (define-10)) + (define-syntax-rule (define-10 name) + (begin + (define t 10) + (define (name) t))) + (define-module (top-level-define/module-scoping-2) + #:use-module (top-level-define/module-scoping-1)) + (define-10 foo) + (foo)) + (current-module)) + 10)) + + (pass-if "module scoping, same symbolic name" + (equal? + (eval + '(begin + (define-module (top-level-define/module-scoping-3)) + (define a 10) + (define-module (top-level-define/module-scoping-4) + #:use-module (top-level-define/module-scoping-3)) + (define a (@@ (top-level-define/module-scoping-3) a)) + a) + (current-module)) + 10)) + + (pass-if "module scoping, introduced names" + (equal? + (eval + '(begin + (define-module (top-level-define/module-scoping-5) + #:export (define-constant)) + (define-syntax-rule (define-constant name val) + (begin + (define t val) + (define (name) t))) + (define-module (top-level-define/module-scoping-6) + #:use-module (top-level-define/module-scoping-5)) + (define-constant foo 10) + (define-constant bar 20) + (foo)) + (current-module)) + 10)) + + (pass-if "module scoping, duplicate introduced name" + (equal? + (eval + '(begin + (define-module (top-level-define/module-scoping-7) + #:export (define-constant)) + (define-syntax-rule (define-constant name val) + (begin + (define t val) + (define (name) t))) + (define-module (top-level-define/module-scoping-8) + #:use-module (top-level-define/module-scoping-7)) + (define-constant foo 10) + (define-constant foo 20) + (foo)) + (current-module)) + 20))) (with-test-prefix "internal define" diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index ddc3e7633..2ed15c7a9 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -89,62 +89,62 @@ (with-test-prefix "eqv?" (pass-if-primitives-resolved - (apply (primitive eqv?) (const #f) (toplevel x)) - (apply (primitive eq?) (const #f) (toplevel x))) + (primcall eqv? (toplevel x) (const #f)) + (primcall eq? (const #f) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive eqv?) (const ()) (toplevel x)) - (apply (primitive eq?) (const ()) (toplevel x))) + (primcall eqv? (toplevel x) (const ())) + (primcall eq? (const ()) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive eqv?) (const #t) (lexical x y)) - (apply (primitive eq?) (const #t) (lexical x y))) + (primcall eqv? (const #t) (lexical x y)) + (primcall eq? (const #t) (lexical x y))) (pass-if-primitives-resolved - (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x)) - (apply (primitive eq?) (const this-is-a-symbol) (toplevel x))) + (primcall eqv? (const this-is-a-symbol) (toplevel x)) + (primcall eq? (const this-is-a-symbol) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive eqv?) (const 42) (toplevel x)) - (apply (primitive eq?) (const 42) (toplevel x))) + (primcall eqv? (const 42) (toplevel x)) + (primcall eq? (const 42) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive eqv?) (const 42.0) (toplevel x)) - (apply (primitive eqv?) (const 42.0) (toplevel x))) + (primcall eqv? (const 42.0) (toplevel x)) + (primcall eqv? (const 42.0) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive eqv?) (const #nil) (toplevel x)) - (apply (primitive eq?) (const #nil) (toplevel x)))) + (primcall eqv? (const #nil) (toplevel x)) + (primcall eq? (const #nil) (toplevel x)))) (with-test-prefix "equal?" (pass-if-primitives-resolved - (apply (primitive equal?) (const #f) (toplevel x)) - (apply (primitive eq?) (const #f) (toplevel x))) + (primcall equal? (toplevel x) (const #f)) + (primcall eq? (const #f) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive equal?) (const ()) (toplevel x)) - (apply (primitive eq?) (const ()) (toplevel x))) + (primcall equal? (toplevel x) (const ())) + (primcall eq? (const ()) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive equal?) (const #t) (lexical x y)) - (apply (primitive eq?) (const #t) (lexical x y))) + (primcall equal? (const #t) (lexical x y)) + (primcall eq? (const #t) (lexical x y))) (pass-if-primitives-resolved - (apply (primitive equal?) (const this-is-a-symbol) (toplevel x)) - (apply (primitive eq?) (const this-is-a-symbol) (toplevel x))) + (primcall equal? (const this-is-a-symbol) (toplevel x)) + (primcall eq? (const this-is-a-symbol) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive equal?) (const 42) (toplevel x)) - (apply (primitive eq?) (const 42) (toplevel x))) + (primcall equal? (const 42) (toplevel x)) + (primcall eq? (const 42) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive equal?) (const 42.0) (toplevel x)) - (apply (primitive equal?) (const 42.0) (toplevel x))) + (primcall equal? (const 42.0) (toplevel x)) + (primcall equal? (const 42.0) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive equal?) (const #nil) (toplevel x)) - (apply (primitive eq?) (const #nil) (toplevel x))))) + (primcall equal? (const #nil) (toplevel x)) + (primcall eq? (const #nil) (toplevel x))))) (with-test-prefix "tree-il->scheme" @@ -161,15 +161,15 @@ (begin (void) (const 1)) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) (assert-tree-il->glil - (apply (primitive +) (void) (const 1)) + (primcall + (void) (const 1)) (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1)))) (with-test-prefix "application" (assert-tree-il->glil - (apply (toplevel foo) (const 1)) + (call (toplevel foo) (const 1)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1))) (assert-tree-il->glil - (begin (apply (toplevel foo) (const 1)) (void)) + (begin (call (toplevel foo) (const 1)) (void)) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) @@ -177,7 +177,7 @@ (void) (call return 1)) (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil - (apply (toplevel foo) (apply (toplevel bar))) + (call (toplevel foo) (call (toplevel bar))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) (call tail-call 1)))) @@ -196,7 +196,7 @@ (eq? l1 l3) (eq? l2 l4)) (assert-tree-il->glil - (apply (primitive null?) (if (toplevel foo) (const 1) (const 2))) + (primcall null? (if (toplevel foo) (const 1) (const 2))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (const 1) (branch br ,l2) (label ,l3) (const 2) (label ,l4) @@ -213,7 +213,7 @@ (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (primitive +)) + (primcall null? (primitive +)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1) (call return 1)))) @@ -233,7 +233,7 @@ (unbind))) (assert-tree-il->glil without-partial-evaluation - (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) + (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) (lexical #t #f ref 0) (call null? 1) (call return 1) @@ -243,7 +243,7 @@ (assert-tree-il->glil ;; unreferenced sets may be optimized away -- make sure they are ref'd (let (x) (y) ((const 1)) - (set! (lexical x y) (apply (primitive 1+) (lexical x y)))) + (set! (lexical x y) (primcall 1+ (lexical x y)))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) @@ -252,7 +252,7 @@ (assert-tree-il->glil (let (x) (y) ((const 1)) - (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) + (begin (set! (lexical x y) (primcall 1+ (lexical x y))) (lexical x y))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #t 0)) (lexical #t #t box 0) @@ -262,8 +262,8 @@ (assert-tree-il->glil (let (x) (y) ((const 1)) - (apply (primitive null?) - (set! (lexical x y) (apply (primitive 1+) (lexical x y))))) + (primcall null? + (set! (lexical x y) (primcall 1+ (lexical x y))))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) @@ -284,7 +284,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (@ (foo) bar)) + (primcall null? (@ (foo) bar)) (program () (std-prelude 0 0 #f) (label _) (module public ref (foo) bar) (call null? 1) (call return 1))) @@ -302,7 +302,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (@@ (foo) bar)) + (primcall null? (@@ (foo) bar)) (program () (std-prelude 0 0 #f) (label _) (module private ref (foo) bar) (call null? 1) (call return 1)))) @@ -321,7 +321,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (set! (@ (foo) bar) (const 2))) + (primcall null? (set! (@ (foo) bar) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (module public set (foo) bar) (void) (call null? 1) (call return 1))) @@ -339,7 +339,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) + (primcall null? (set! (@@ (foo) bar) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (module private set (foo) bar) (void) (call null? 1) (call return 1)))) @@ -358,7 +358,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (toplevel bar)) + (primcall null? (toplevel bar)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref bar) (call null? 1) (call return 1)))) @@ -377,7 +377,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (set! (toplevel bar) (const 2))) + (primcall null? (set! (toplevel bar) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel set bar) (void) (call null? 1) (call return 1)))) @@ -396,7 +396,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (define bar (const 2))) + (primcall null? (define bar (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel define bar) (void) (call null? 1) (call return 1)))) @@ -414,7 +414,7 @@ (assert-tree-il->glil ;; This gets simplified by `peval'. - (apply (primitive null?) (const 2)) + (primcall null? (const 2)) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))) @@ -422,7 +422,7 @@ ;; simple bindings -> let (assert-tree-il->glil without-partial-evaluation (letrec (x y) (x1 y1) ((const 10) (const 20)) - (apply (toplevel foo) (lexical x x1) (lexical y y1))) + (call (toplevel foo) (lexical x x1) (lexical y y1))) (program () (std-prelude 0 2 #f) (label _) (const 10) (const 20) (bind (x #f 0) (y #f 1)) @@ -434,8 +434,8 @@ ;; complex bindings -> box and set! within let (assert-tree-il->glil without-partial-evaluation - (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) - (apply (primitive +) (lexical x x1) (lexical y y1))) + (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 _) (void) (void) ;; what are these? (bind (x #t 0) (y #t 1)) @@ -452,8 +452,8 @@ ;; complex bindings in letrec* -> box and set! in order (assert-tree-il->glil without-partial-evaluation - (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) - (apply (primitive +) (lexical x x1) (lexical y y1))) + (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 _) (void) (void) ;; what are these? (bind (x #t 0) (y #t 1)) @@ -572,38 +572,38 @@ (assert-tree-il->glil ;; This gets simplified by `peval'. - (apply (primitive null?) (begin (const #f) (const 2))) + (primcall null? (begin (const #f) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))) (with-test-prefix "values" (assert-tree-il->glil - (apply (primitive values) - (apply (primitive values) (const 1) (const 2))) + (primcall values + (primcall values (const 1) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) (assert-tree-il->glil - (apply (primitive values) - (apply (primitive values) (const 1) (const 2)) - (const 3)) + (primcall values + (primcall values (const 1) (const 2)) + (const 3)) (program () (std-prelude 0 0 #f) (label _) (const 1) (const 3) (call return/values 2))) (assert-tree-il->glil - (apply (primitive +) - (apply (primitive values) (const 1) (const 2))) + (primcall + + (primcall values (const 1) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) ;; Testing `(values foo)' in push context with RA. (assert-tree-il->glil without-partial-evaluation - (apply (primitive cdr) - (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#) - ((lambda ((name . lp)) - (lambda-case ((() #f #f #f () ()) - (apply (toplevel values) (const (one two))))))) - (apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#)))) + (primcall cdr + (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#) + ((lambda ((name . lp)) + (lambda-case ((() #f #f #f () ()) + (primcall values (const (one two))))))) + (call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#)))) (program () (std-prelude 0 0 #f) (label _) (branch br _) ;; entering the fix, jump to :2 ;; :1 body of lp, jump to :3 @@ -651,10 +651,10 @@ (with-test-prefix "apply" (assert-tree-il->glil - (apply (primitive @apply) (toplevel foo) (toplevel bar)) + (primcall @apply (toplevel foo) (toplevel bar)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2))) (assert-tree-il->glil - (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) + (begin (primcall @apply (toplevel foo) (toplevel bar)) (void)) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) @@ -662,7 +662,7 @@ (void) (call return 1)) (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil - (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) + (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) @@ -670,10 +670,10 @@ (with-test-prefix "call/cc" (assert-tree-il->glil - (apply (primitive @call-with-current-continuation) (toplevel foo)) + (primcall @call-with-current-continuation (toplevel foo)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1))) (assert-tree-il->glil - (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) + (begin (primcall @call-with-current-continuation (toplevel foo)) (void)) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) @@ -681,8 +681,8 @@ (void) (call return 1)) (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil - (apply (toplevel foo) - (apply (toplevel @call-with-current-continuation) (toplevel bar))) + (call (toplevel foo) + (call (toplevel @call-with-current-continuation) (toplevel bar))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call call/cc 1) @@ -748,9 +748,9 @@ '(lambda () (lambda-case (((x y) #f #f #f () (x1 y1)) - (apply (toplevel +) - (lexical x x1) - (lexical y y1))) + (call (toplevel +) + (lexical x x1) + (lexical y y1))) #f)))))) (and (equal? (map strip-source leaves) (list (make-lexical-ref #f 'y 'y1) diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test index a37be5e46..dc54ffa50 100644 --- a/test-suite/tests/vlist.test +++ b/test-suite/tests/vlist.test @@ -220,11 +220,11 @@ (and (fold (lambda (k v result) (and result (equal? (cons k v) - (vhash-assq k vh)))) + (vhash-assoc k vh)))) #t keys values) - (not (vhash-assq 'x vh))))) + (not (vhash-assoc 'x vh))))) (pass-if "vhash as vlist" (let* ((keys '(a b c d e f g h i)) diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test index d0f6c5ef5..1d53fc422 100644 --- a/test-suite/tests/weaks.test +++ b/test-suite/tests/weaks.test @@ -1,5 +1,5 @@ ;;;; weaks.test --- tests guile's weaks -*- scheme -*- -;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012 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 @@ -68,28 +68,28 @@ exception:wrong-type-arg (list->weak-vector 32))) - (with-test-prefix "make-weak-key-alist-vector" + (with-test-prefix "make-weak-key-hash-table" (pass-if "create" - (make-weak-key-alist-vector 17) + (make-weak-key-hash-table 17) #t) (pass-if-exception "bad-args" exception:wrong-type-arg - (make-weak-key-alist-vector '(bad arg)))) - (with-test-prefix "make-weak-value-alist-vector" + (make-weak-key-hash-table '(bad arg)))) + (with-test-prefix "make-weak-value-hash-table" (pass-if "create" - (make-weak-value-alist-vector 17) + (make-weak-value-hash-table 17) #t) (pass-if-exception "bad-args" exception:wrong-type-arg - (make-weak-value-alist-vector '(bad arg)))) + (make-weak-value-hash-table '(bad arg)))) - (with-test-prefix "make-doubly-weak-alist-vector" + (with-test-prefix "make-doubly-weak-hash-table" (pass-if "create" - (make-doubly-weak-alist-vector 17) + (make-doubly-weak-hash-table 17) #t) (pass-if-exception "bad-args" exception:wrong-type-arg - (make-doubly-weak-alist-vector '(bad arg))))) + (make-doubly-weak-hash-table '(bad arg))))) @@ -138,9 +138,9 @@ (or (not value) (equal? value initial-value))) - (let ((x (make-weak-key-alist-vector 17)) - (y (make-weak-value-alist-vector 17)) - (z (make-doubly-weak-alist-vector 17)) + (let ((x (make-weak-key-hash-table 17)) + (y (make-weak-value-hash-table 17)) + (z (make-doubly-weak-hash-table 17)) (test-key "foo") (test-value "bar")) (with-test-prefix @@ -232,6 +232,14 @@ (hash-set! t "foo" 1) (equal? (hash-ref t "foo") 1))) + (pass-if "hash-set!, weak key, returns value" + (let ((t (make-weak-value-hash-table)) + (val (string #\f #\o #\o))) + (eq? (hashq-set! t "bar" val) + (hashv-set! t "bar" val) + (hash-set! t "bar" val) + val))) + (pass-if "assoc can do anything" ;; Until 1.9.12, as hash table's custom ASSOC procedure was ;; called with the GC lock alloc held, which imposed severe diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test index f9679f5e2..4f88aa67e 100644 --- a/test-suite/tests/web-response.test +++ b/test-suite/tests/web-response.test @@ -1,6 +1,6 @@ ;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2013 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 @@ -113,7 +113,7 @@ consectetur adipisicing elit,\r (response-content-encoding r)) (pass-if-equal "response-body-port" - `("utf-8" ,body) + `("UTF-8" ,body) (with-fluids ((%default-port-encoding #f)) (let* ((r (read-response (open-input-string example-1))) (p (response-body-port r))) |