[bpt/guile.git] / test-suite / tests / eval.test

;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2006, 2007, 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
;;;; 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

(define-module (test-suite test-eval)
  :use-module (test-suite lib)
  :use-module ((srfi srfi-1) :select (unfold count))
  :use-module ((system vm vm) :select (make-vm call-with-vm))
  :use-module (ice-9 documentation)
  :use-module (ice-9 local-eval))


(define exception:bad-expression
  (cons 'syntax-error "Bad expression"))

(define exception:failed-match
  (cons 'syntax-error "failed to match any pattern"))

(define exception:not-a-list
  (cons 'wrong-type-arg "Not a list"))

(define exception:wrong-length
  (cons 'wrong-type-arg "wrong length"))

;;;
;;; miscellaneous
;;;

(define (documented? object)
  (not (not (object-documentation object))))


;;;
;;; memoization
;;;

(with-test-prefix "memoization"

  (with-test-prefix "copy-tree"

    (pass-if "(#t . #(#t))"
      (let* ((foo (cons #t (vector #t)))
             (bar (copy-tree foo)))
        (vector-set! (cdr foo) 0 #f)
        (equal? bar '(#t . #(#t)))))

    (pass-if-exception "circular lists in forms"
      exception:wrong-type-arg
      (let ((foo (list #f)))
        (set-cdr! foo foo)
        (copy-tree foo))))

  (pass-if "transparency"
    (let ((x '(begin 1)))
      (eval x (current-module))
      (equal? '(begin 1) x))))


;;;
;;; eval
;;;

(with-test-prefix "evaluator"

  (pass-if "definitions return #<unspecified>"
    (eq? (primitive-eval '(define test-var 'foo))
         (if #f #f)))

  (with-test-prefix "symbol lookup"

    (with-test-prefix "top level"

      (with-test-prefix "unbound"

	(pass-if-exception "variable reference"
	  exception:unbound-var
	  x)

	(pass-if-exception "procedure"
	  exception:unbound-var
	  (x)))))

  (with-test-prefix "parameter error"

    ;; This is currently a bug in guile:
    ;; Macros are accepted as function parameters.
    ;; Functions that 'apply' macros are rewritten!!!

    (pass-if-exception "macro as argument"
      exception:failed-match
      (primitive-eval
       '(let ((f (lambda (p a b) (p a b))))
          (f and #t #t))))

    (pass-if-exception "passing macro as parameter"
      exception:failed-match
      (primitive-eval
       '(let* ((f (lambda (p a b) (p a b)))
               (foo (procedure-source f)))
          (f and #t #t)
          (equal? (procedure-source f) foo))))

    ))

;;;
;;; call
;;;

(with-test-prefix "call"

  (with-test-prefix "wrong number of arguments"

    (pass-if-exception "((lambda () #f) 1)"
      exception:wrong-num-args
      ((lambda () #f) 1))

    (pass-if-exception "((lambda (x) #f))"
      exception:wrong-num-args
      ((lambda (x) #f)))

    (pass-if-exception "((lambda (x) #f) 1 2)"
      exception:wrong-num-args
      ((lambda (x) #f) 1 2))

    (pass-if-exception "((lambda (x y) #f))"
      exception:wrong-num-args
      ((lambda (x y) #f)))

    (pass-if-exception "((lambda (x y) #f) 1)"
      exception:wrong-num-args
      ((lambda (x y) #f) 1))

    (pass-if-exception "((lambda (x y) #f) 1 2 3)"
      exception:wrong-num-args
      ((lambda (x y) #f) 1 2 3))

    (pass-if-exception "((lambda (x . rest) #f))"
      exception:wrong-num-args
      ((lambda (x . rest) #f)))

    (pass-if-exception "((lambda (x y . rest) #f))"
      exception:wrong-num-args
      ((lambda (x y . rest) #f)))

    (pass-if-exception "((lambda (x y . rest) #f) 1)"
      exception:wrong-num-args
      ((lambda (x y . rest) #f) 1))))

;;;
;;; apply
;;;

(with-test-prefix "apply"

  (with-test-prefix "scm_tc7_subr_2o"

    ;; prior to guile 1.6.9 and 1.8.1 this called the function with
    ;; SCM_UNDEFINED, which in the case of make-vector resulted in
    ;; wrong-type-arg, instead of the intended wrong-num-args
    (pass-if-exception "0 args" exception:wrong-num-args
      (apply make-vector '()))

    (pass-if "1 arg"
      (vector? (apply make-vector '(1))))

    (pass-if "2 args"
      (vector? (apply make-vector '(1 2))))

    ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected
    (pass-if-exception "3 args" exception:wrong-num-args
      (apply make-vector '(1 2 3)))))

;;;
;;; map
;;;

(with-test-prefix "map"

  ;; Is documentation available?

  (expect-fail "documented?"
    (documented? map))

  (with-test-prefix "argument error"

    (with-test-prefix "non list argument"
      #t)

    (with-test-prefix "different length lists"

      (pass-if-exception "first list empty"
        exception:wrong-length
	(map + '() '(1)))

      (pass-if-exception "second list empty"
        exception:wrong-length
	(map + '(1) '()))

      (pass-if-exception "first list shorter"
	exception:wrong-length
	(map + '(1) '(2 3)))

      (pass-if-exception "second list shorter"
	exception:wrong-length
	(map + '(1 2) '(3)))
    )))

;;;
;;; define with procedure-name
;;;

;; names are only set on top-level procedures (currently), so these can't be
;; hidden in a let
;;
(define foo-closure (lambda () "hello"))
(define bar-closure foo-closure)
;; make sure that make-procedure-with-setter returns an anonymous
;; procedure-with-setter by passing it an anonymous getter.
(define foo-pws (make-procedure-with-setter
                 (lambda (x) (car x))
                 (lambda (x y) (set-car! x y))))
(define bar-pws foo-pws)

(with-test-prefix "define set procedure-name"

  (pass-if "closure"
    (eq? 'foo-closure (procedure-name bar-closure)))

  (expect-fail "procedure-with-setter" ; FIXME: `pass-if' when it's supported
    (eq? 'foo-pws (procedure-name bar-pws))))

;;;
;;; promises
;;;

(with-test-prefix "promises"

  (with-test-prefix "basic promise behaviour"

    (pass-if "delay gives a promise"
      (promise? (delay 1)))

    (pass-if "force evaluates a promise"
      (eqv? (force (delay (+ 1 2))) 3))

    (pass-if "a forced promise is a promise"
      (let ((p (delay (+ 1 2))))
	(force p)
	(promise? p)))

    (pass-if "forcing a forced promise works"
      (let ((p (delay (+ 1 2))))
	(force p)
	(eqv? (force p) 3)))

    (pass-if "a promise is evaluated once"
      (let* ((x 1)
	     (p (delay (+ x 1))))
	(force p)
	(set! x (+ x 1))
	(eqv? (force p) 2)))

    (pass-if "a promise may call itself"
      (define p
	(let ((x 0))
	  (delay 
	    (begin 
	      (set! x (+ x 1))
	      (if (> x 1) x (force p))))))
      (eqv? (force p) 2))

    (pass-if "a promise carries its environment"
      (let* ((x 1) (p #f))
	(let* ((x 2))
	  (set! p (delay (+ x 1))))
	(eqv? (force p) 3)))

    (pass-if "a forced promise does not reference its environment"
      (let* ((g (make-guardian))
	     (p #f))
	(let* ((x (cons #f #f)))
	  (g x)
	  (set! p (delay (car x))))
	(force p)
	(gc)
	(if (not (equal? (g) (cons #f #f)))
	    (throw 'unresolved)
	    #t))))

  (with-test-prefix "extended promise behaviour"

    (pass-if-exception "forcing a non-promise object is not supported"
      exception:wrong-type-arg
      (force 1))

    (pass-if "unmemoizing a promise"
      (display-backtrace
       (let ((stack #f))
         (false-if-exception
          (with-throw-handler #t
                              (lambda ()
                                (let ((f (lambda (g) (delay (g)))))
                                  (force (f error))))
                              (lambda _
                                (set! stack (make-stack #t)))))
         stack)
       (%make-void-port "w"))
      #t)))


;;;
;;; stacks
;;;

(define (stack->frames stack)
  ;; Return the list of frames comprising STACK.
  (unfold (lambda (i)
            (>= i (stack-length stack)))
          (lambda (i)
            (stack-ref stack i))
          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.
    (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.
    (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
;;;

(with-test-prefix "letrec init evaluation"

  (pass-if "lots of inits calculated in correct order"
    (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
		     (e 'e) (f 'f) (g 'g) (h 'h)
		     (i 'i) (j 'j) (k 'k) (l 'l)
		     (m 'm) (n 'n) (o 'o) (p 'p)
		     (q 'q) (r 'r) (s 's) (t 't)
		     (u 'u) (v 'v) (w 'w) (x 'x)
		     (y 'y) (z 'z))
	      (list a b c d e f g h i j k l m
		    n o p q r s t u v w x y z))
	    '(a b c d e f g h i j k l m
	      n o p q r s t u v w x y z))))

;;;
;;; values
;;;

(with-test-prefix "values"

  (pass-if "single value"
    (equal? 1 (values 1)))

  (pass-if "call-with-values"
    (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
            '(1 2 3 4)))

  (pass-if "equal?"
    (equal? (values 1 2 3 4) (values 1 2 3 4))))

;;;
;;; stack overflow handling
;;;

(with-test-prefix "stack overflow"

  ;; FIXME: this test does not test what it is intending to test
  (pass-if-exception "exception raised"
    exception:vm-error
    (let ((vm    (make-vm))
          (thunk (let loop () (cons 's (loop)))))
      (call-with-vm vm thunk))))

;;;
;;; docstrings
;;;

(with-test-prefix "docstrings"

  (pass-if-equal "fixed closure"
      '("hello" "world")
    (map procedure-documentation
         (list (eval '(lambda (a b) "hello" (+ a b))
                     (current-module))
               (eval '(lambda (a b) "world" (- a b))
                     (current-module)))))

  (pass-if-equal "fixed closure with many args"
      "So many args."
    (procedure-documentation
     (eval '(lambda (a b c d e f g h i j k)
              "So many args."
              (+ a b))
           (current-module))))

  (pass-if-equal "general closure"
      "How general."
    (procedure-documentation
     (eval '(lambda* (a b #:key k #:rest r)
              "How general."
              (+ a b))
           (current-module)))))

;;;
;;; local-eval
;;;

(with-test-prefix "local evaluation"

  (pass-if "local-eval"

    (let* ((env1 (local-eval '(let ((x 1) (y 2) (z 3))
                                (define-syntax-rule (foo x) (quote x))
                                (the-environment))
                             (current-module)))
           (env2 (local-eval '(let ((x 111) (a 'a))
                                (define-syntax-rule (bar x) (quote x))
                                (the-environment))
                           env1)))
      (local-eval '(set! x 11) env1)
      (local-eval '(set! y 22) env1)
      (local-eval '(set! z 33) env2)
      (and (equal? (local-eval '(list x y z) env1)
                   '(11 22 33))
           (equal? (local-eval '(list x y z a) env2)
                   '(111 22 33 a)))))

  (pass-if "local-compile"

    (let* ((env1 (local-compile '(let ((x 1) (y 2) (z 3))
                                   (define-syntax-rule (foo x) (quote x))
                                   (the-environment))
                                (current-module)))
           (env2 (local-compile '(let ((x 111) (a 'a))
                                   (define-syntax-rule (bar x) (quote x))
                                   (the-environment))
                                env1)))
      (local-compile '(set! x 11) env1)
      (local-compile '(set! y 22) env1)
      (local-compile '(set! z 33) env2)
      (and (equal? (local-compile '(list x y z) env1)
                   '(11 22 33))
           (equal? (local-compile '(list x y z a) env2)
                   '(111 22 33 a)))))

  (pass-if "the-environment within a macro"
    (let ((module-a-name '(test module the-environment a))
          (module-b-name '(test module the-environment b)))
      (let ((module-a (resolve-module module-a-name))
            (module-b (resolve-module module-b-name)))
        (module-use! module-a (resolve-interface '(guile)))
        (module-use! module-a (resolve-interface '(ice-9 local-eval)))
        (eval '(begin
                 (define z 3)
                 (define-syntax-rule (test)
                   (let ((x 1) (y 2))
                     (the-environment))))
              module-a)
        (module-use! module-b (resolve-interface '(guile)))
        (let ((env (local-eval `(let ((x 111) (y 222))
                                  ((@@ ,module-a-name test)))
                               module-b)))
          (equal? (local-eval '(list x y z) env)
                  '(1 2 3))))))

  (pass-if "capture pattern variables"
    (let ((env (syntax-case #'(((a 1) (b 2) (c 3))
                               ((d 4) (e 5) (f 6))) ()
                 ((((k v) ...) ...) (the-environment)))))
      (equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env))
              '((a b c 1 2 3) (d e f 4 5 6)))))

  (pass-if "mixed primitive-eval, local-eval and local-compile"

    (let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3))
                                    (define-syntax-rule (foo x) (quote x))
                                    (the-environment))))
           (env2 (local-eval '(let ((x 111) (a 'a))
                                (define-syntax-rule (bar x) (quote x))
                                (the-environment))
                             env1))
           (env3 (local-compile '(let ((y 222) (b 'b))
                                   (the-environment))
                                env2)))
      (local-eval    '(set! x 11) env1)
      (local-compile '(set! y 22) env2)
      (local-eval    '(set! z 33) env2)
      (local-compile '(set! a (* y 2)) env3)
      (and (equal? (local-compile '(list x y z) env1)
                   '(11 22 33))
           (equal? (local-eval '(list x y z a) env2)
                   '(111 22 33 444))
           (equal? (local-eval '(list x y z a b) env3)
                   '(111 222 33 444 b))))))

;;; eval.test ends here
Commit	Line	Data
141443d7	1	;;;; eval.test --- tests guile's evaluator -- scheme --
d062a8c1	2	;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
141443d7	3	;;;;
73be1d9e MV	4	;;;; This library is free software; you can redistribute it and/or
	5	;;;; modify it under the terms of the GNU Lesser General Public
	6	;;;; License as published by the Free Software Foundation; either
53befeb7	7	;;;; version 3 of the License, or (at your option) any later version.
73be1d9e MV	8	;;;;
73be1d9e MV	9	;;;; This library is distributed in the hope that it will be useful,
141443d7	10	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	11	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;;;; Lesser General Public License for more details.
	13	;;;;
	14	;;;; You should have received a copy of the GNU Lesser General Public
	15	;;;; License along with this library; if not, write to the Free Software
92205699	16	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
141443d7	17
d6e04e7c DH	18	(define-module (test-suite test-eval)
d6e04e7c DH	19	:use-module (test-suite lib)
113e7c25	20	:use-module ((srfi srfi-1) :select (unfold count))
ea9f4f4b	21	:use-module ((system vm vm) :select (make-vm call-with-vm))
d062a8c1 AW	22	:use-module (ice-9 documentation)
d062a8c1 AW	23	:use-module (ice-9 local-eval))
141443d7 DH	24
141443d7 DH	25
62360b89 DH	26	(define exception:bad-expression
	27	(cons 'syntax-error "Bad expression"))
	28
8bb0b3cc AW	29	(define exception:failed-match
	30	(cons 'syntax-error "failed to match any pattern"))
	31
a2230b65 AW	32	(define exception:not-a-list
	33	(cons 'wrong-type-arg "Not a list"))
	34
	35	(define exception:wrong-length
	36	(cons 'wrong-type-arg "wrong length"))
62360b89	37
141443d7 DH	38	;;;
	39	;;; miscellaneous
	40	;;;
	41
141443d7	42	(define (documented? object)
5c96bc39	43	(not (not (object-documentation object))))
141443d7 DH	44
	45
	46	;;;
62360b89	47	;;; memoization
141443d7 DH	48	;;;
141443d7 DH	49
62360b89 DH	50	(with-test-prefix "memoization"
	51
	52	(with-test-prefix "copy-tree"
	53
	54	(pass-if "(#t . #(#t))"
	55	(let* ((foo (cons #t (vector #t)))
	56	(bar (copy-tree foo)))
	57	(vector-set! (cdr foo) 0 #f)
	58	(equal? bar '(#t . #(#t)))))
	59
	60	(pass-if-exception "circular lists in forms"
0f458a37	61	exception:wrong-type-arg
62360b89 DH	62	(let ((foo (list #f)))
	63	(set-cdr! foo foo)
	64	(copy-tree foo))))
141443d7	65
62360b89 DH	66	(pass-if "transparency"
	67	(let ((x '(begin 1)))
	68	(eval x (current-module))
	69	(equal? '(begin 1) x))))
414959ca	70
62360b89 DH	71
	72	;;;
	73	;;; eval
	74	;;;
	75
	76	(with-test-prefix "evaluator"
414959ca	77
adb8054c MW	78	(pass-if "definitions return #<unspecified>"
	79	(eq? (primitive-eval '(define test-var 'foo))
	80	(if #f #f)))
	81
08c608e1 DH	82	(with-test-prefix "symbol lookup"
	83
	84	(with-test-prefix "top level"
	85
	86	(with-test-prefix "unbound"
	87
	88	(pass-if-exception "variable reference"
	89	exception:unbound-var
	90	x)
	91
	92	(pass-if-exception "procedure"
	93	exception:unbound-var
	94	(x)))))
	95
141443d7 DH	96	(with-test-prefix "parameter error"
	97
	98	;; This is currently a bug in guile:
	99	;; Macros are accepted as function parameters.
	100	;; Functions that 'apply' macros are rewritten!!!
	101
8bb0b3cc AW	102	(pass-if-exception "macro as argument"
	103	exception:failed-match
	104	(primitive-eval
	105	'(let ((f (lambda (p a b) (p a b))))
	106	(f and #t #t))))
	107
	108	(pass-if-exception "passing macro as parameter"
	109	exception:failed-match
	110	(primitive-eval
	111	'(let* ((f (lambda (p a b) (p a b)))
	112	(foo (procedure-source f)))
	113	(f and #t #t)
	114	(equal? (procedure-source f) foo))))
141443d7 DH	115
	116	))
	117
08c608e1	118	;;;
8ab3d8a0	119	;;; call
08c608e1 DH	120	;;;
08c608e1 DH	121
8ab3d8a0	122	(with-test-prefix "call"
08c608e1 DH	123
	124	(with-test-prefix "wrong number of arguments"
	125
	126	(pass-if-exception "((lambda () #f) 1)"
	127	exception:wrong-num-args
	128	((lambda () #f) 1))
	129
	130	(pass-if-exception "((lambda (x) #f))"
	131	exception:wrong-num-args
	132	((lambda (x) #f)))
	133
	134	(pass-if-exception "((lambda (x) #f) 1 2)"
	135	exception:wrong-num-args
	136	((lambda (x) #f) 1 2))
	137
	138	(pass-if-exception "((lambda (x y) #f))"
	139	exception:wrong-num-args
	140	((lambda (x y) #f)))
	141
	142	(pass-if-exception "((lambda (x y) #f) 1)"
	143	exception:wrong-num-args
	144	((lambda (x y) #f) 1))
	145
	146	(pass-if-exception "((lambda (x y) #f) 1 2 3)"
	147	exception:wrong-num-args
	148	((lambda (x y) #f) 1 2 3))
	149
	150	(pass-if-exception "((lambda (x . rest) #f))"
	151	exception:wrong-num-args
	152	((lambda (x . rest) #f)))
	153
	154	(pass-if-exception "((lambda (x y . rest) #f))"
	155	exception:wrong-num-args
	156	((lambda (x y . rest) #f)))
	157
	158	(pass-if-exception "((lambda (x y . rest) #f) 1)"
	159	exception:wrong-num-args
	160	((lambda (x y . rest) #f) 1))))
	161
8ab3d8a0 KR	162	;;;
	163	;;; apply
	164	;;;
	165
	166	(with-test-prefix "apply"
	167
	168	(with-test-prefix "scm_tc7_subr_2o"
	169
	170	;; prior to guile 1.6.9 and 1.8.1 this called the function with
0f458a37	171	;; SCM_UNDEFINED, which in the case of make-vector resulted in
8ab3d8a0 KR	172	;; wrong-type-arg, instead of the intended wrong-num-args
	173	(pass-if-exception "0 args" exception:wrong-num-args
	174	(apply make-vector '()))
	175
	176	(pass-if "1 arg"
	177	(vector? (apply make-vector '(1))))
	178
	179	(pass-if "2 args"
	180	(vector? (apply make-vector '(1 2))))
	181
	182	;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected
	183	(pass-if-exception "3 args" exception:wrong-num-args
	184	(apply make-vector '(1 2 3)))))
	185
141443d7 DH	186	;;;
	187	;;; map
	188	;;;
	189
	190	(with-test-prefix "map"
	191
	192	;; Is documentation available?
	193
	194	(expect-fail "documented?"
6ad9007a	195	(documented? map))
141443d7 DH	196
	197	(with-test-prefix "argument error"
	198
	199	(with-test-prefix "non list argument"
	200	#t)
	201
	202	(with-test-prefix "different length lists"
	203
6b4113af	204	(pass-if-exception "first list empty"
a2230b65	205	exception:wrong-length
6b4113af DH	206	(map + '() '(1)))
	207
	208	(pass-if-exception "second list empty"
a2230b65	209	exception:wrong-length
6b4113af DH	210	(map + '(1) '()))
	211
	212	(pass-if-exception "first list shorter"
a2230b65	213	exception:wrong-length
6b4113af DH	214	(map + '(1) '(2 3)))
	215
	216	(pass-if-exception "second list shorter"
a2230b65	217	exception:wrong-length
6b4113af	218	(map + '(1 2) '(3)))
141443d7	219	)))
23d72566 KR	220
	221	;;;
	222	;;; define with procedure-name
	223	;;;
	224
23d72566 KR	225	;; names are only set on top-level procedures (currently), so these can't be
	226	;; hidden in a let
	227	;;
	228	(define foo-closure (lambda () "hello"))
	229	(define bar-closure foo-closure)
3fd8807e AW	230	;; make sure that make-procedure-with-setter returns an anonymous
	231	;; procedure-with-setter by passing it an anonymous getter.
	232	(define foo-pws (make-procedure-with-setter
	233	(lambda (x) (car x))
	234	(lambda (x y) (set-car! x y))))
23d72566 KR	235	(define bar-pws foo-pws)
	236
	237	(with-test-prefix "define set procedure-name"
	238
936d0bf3	239	(pass-if "closure"
23d72566 KR	240	(eq? 'foo-closure (procedure-name bar-closure)))
23d72566 KR	241
936d0bf3	242	(expect-fail "procedure-with-setter" ; FIXME: `pass-if' when it's supported
3fd8807e	243	(eq? 'foo-pws (procedure-name bar-pws))))
23d72566	244
2b6b5908 DH	245	;;;
	246	;;; promises
	247	;;;
	248
	249	(with-test-prefix "promises"
	250
	251	(with-test-prefix "basic promise behaviour"
	252
	253	(pass-if "delay gives a promise"
	254	(promise? (delay 1)))
	255
	256	(pass-if "force evaluates a promise"
	257	(eqv? (force (delay (+ 1 2))) 3))
	258
	259	(pass-if "a forced promise is a promise"
	260	(let ((p (delay (+ 1 2))))
	261	(force p)
	262	(promise? p)))
	263
	264	(pass-if "forcing a forced promise works"
	265	(let ((p (delay (+ 1 2))))
	266	(force p)
	267	(eqv? (force p) 3)))
	268
	269	(pass-if "a promise is evaluated once"
	270	(let* ((x 1)
	271	(p (delay (+ x 1))))
	272	(force p)
	273	(set! x (+ x 1))
	274	(eqv? (force p) 2)))
	275
	276	(pass-if "a promise may call itself"
	277	(define p
	278	(let ((x 0))
	279	(delay
	280	(begin
	281	(set! x (+ x 1))
	282	(if (> x 1) x (force p))))))
	283	(eqv? (force p) 2))
	284
	285	(pass-if "a promise carries its environment"
	286	(let* ((x 1) (p #f))
	287	(let* ((x 2))
	288	(set! p (delay (+ x 1))))
	289	(eqv? (force p) 3)))
	290
	291	(pass-if "a forced promise does not reference its environment"
	292	(let* ((g (make-guardian))
	293	(p #f))
	294	(let* ((x (cons #f #f)))
	295	(g x)
	296	(set! p (delay (car x))))
	297	(force p)
	298	(gc)
	299	(if (not (equal? (g) (cons #f #f)))
	300	(throw 'unresolved)
	301	#t))))
	302
	303	(with-test-prefix "extended promise behaviour"
	304
	305	(pass-if-exception "forcing a non-promise object is not supported"
	306	exception:wrong-type-arg
	307	(force 1))
	308
e10cf6b9 AW	309	(pass-if "unmemoizing a promise"
	310	(display-backtrace
	311	(let ((stack #f))
	312	(false-if-exception
	313	(with-throw-handler #t
	314	(lambda ()
	315	(let ((f (lambda (g) (delay (g)))))
	316	(force (f error))))
	317	(lambda _
	318	(set! stack (make-stack #t)))))
	319	stack)
	320	(%make-void-port "w"))
	321	#t)))
2b6b5908	322
113e7c25 LC	323
	324	;;;
	325	;;; stacks
	326	;;;
	327
	328	(define (stack->frames stack)
	329	;; Return the list of frames comprising STACK.
	330	(unfold (lambda (i)
	331	(>= i (stack-length stack)))
	332	(lambda (i)
	333	(stack-ref stack i))
	334	1+
	335	0))
	336
99d7688b NL	337	(define (make-tagged-trimmed-stack tag spec)
	338	(catch 'result
	339	(lambda ()
	340	(call-with-prompt
	341	tag
	342	(lambda ()
	343	(with-throw-handler 'wrong-type-arg
	344	(lambda () (substring 'wrong 'type 'arg))
	345	(lambda _ (throw 'result (apply make-stack spec)))))
	346	(lambda () (throw 'make-stack-failed))))
	347	(lambda (key result) result)))
	348
	349	(define tag (make-prompt-tag "foo"))
	350
649d3ea7 NL	351	(with-test-prefix "stacks"
	352	(pass-if "stack involving a primitive"
	353	;; The primitive involving the error must appear exactly once on the
	354	;; stack.
	355	(let* ((stack (make-tagged-trimmed-stack tag '(#t)))
	356	(frames (stack->frames stack))
	357	(num (count (lambda (frame) (eq? (frame-procedure frame)
	358	substring))
	359	frames)))
	360	(= num 1)))
	361
	362	(pass-if "arguments of a primitive stack frame"
	363	;; Create a stack with two primitive frames and make sure the
	364	;; arguments are correct.
	365	(let* ((stack (make-tagged-trimmed-stack tag '(#t)))
	366	(call-list (map (lambda (frame)
	367	(cons (frame-procedure frame)
	368	(frame-arguments frame)))
	369	(stack->frames stack))))
	370	(and (equal? (car call-list) `(,make-stack #t))
	371	(pair? (member `(,substring wrong type arg)
	372	(cdr call-list))))))
	373
99d7688b NL	374	(pass-if "inner trim with prompt tag"
	375	(let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag)))
	376	(frames (stack->frames stack)))
	377	;; the top frame on the stack is the lambda inside the 'catch, and the
	378	;; next frame is the (catch 'result ...)
	379	(and (eq? (frame-procedure (cadr frames))
	380	catch)
	381	(eq? (car (frame-arguments (cadr frames)))
	382	'result))))
	383
	384	(pass-if "outer trim with prompt tag"
	385	(let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag)))
	386	(frames (stack->frames stack)))
	387	;; the top frame on the stack is the make-stack call, and the last
	388	;; frame is the (with-throw-handler 'wrong-type-arg ...)
	389	(and (eq? (frame-procedure (car frames))
	390	make-stack)
	391	(eq? (frame-procedure (car (last-pair frames)))
	392	with-throw-handler)
	393	(eq? (car (frame-arguments (car (last-pair frames))))
	394	'wrong-type-arg)))))
	395
d2797644 NJ	396	;;;
	397	;;; letrec init evaluation
	398	;;;
	399
	400	(with-test-prefix "letrec init evaluation"
	401
	402	(pass-if "lots of inits calculated in correct order"
	403	(equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
	404	(e 'e) (f 'f) (g 'g) (h 'h)
	405	(i 'i) (j 'j) (k 'k) (l 'l)
	406	(m 'm) (n 'n) (o 'o) (p 'p)
	407	(q 'q) (r 'r) (s 's) (t 't)
	408	(u 'u) (v 'v) (w 'w) (x 'x)
	409	(y 'y) (z 'z))
	410	(list a b c d e f g h i j k l m
	411	n o p q r s t u v w x y z))
	412	'(a b c d e f g h i j k l m
	413	n o p q r s t u v w x y z))))
	414
42ddb3cb LC	415	;;;
	416	;;; values
	417	;;;
	418
	419	(with-test-prefix "values"
	420
	421	(pass-if "single value"
	422	(equal? 1 (values 1)))
	423
	424	(pass-if "call-with-values"
	425	(equal? (call-with-values (lambda () (values 1 2 3 4)) list)
	426	'(1 2 3 4)))
	427
	428	(pass-if "equal?"
	429	(equal? (values 1 2 3 4) (values 1 2 3 4))))
4f2ec3be	430
f1046e6b LC	431	;;;
	432	;;; stack overflow handling
	433	;;;
	434
	435	(with-test-prefix "stack overflow"
	436
ea9f4f4b	437	;; FIXME: this test does not test what it is intending to test
f1046e6b LC	438	(pass-if-exception "exception raised"
	439	exception:vm-error
	440	(let ((vm (make-vm))
	441	(thunk (let loop () (cons 's (loop)))))
ea9f4f4b	442	(call-with-vm vm thunk))))
f1046e6b	443
c438cd71 LC	444	;;;
	445	;;; docstrings
	446	;;;
	447
	448	(with-test-prefix "docstrings"
	449
	450	(pass-if-equal "fixed closure"
	451	'("hello" "world")
	452	(map procedure-documentation
	453	(list (eval '(lambda (a b) "hello" (+ a b))
	454	(current-module))
	455	(eval '(lambda (a b) "world" (- a b))
	456	(current-module)))))
	457
	458	(pass-if-equal "fixed closure with many args"
	459	"So many args."
	460	(procedure-documentation
	461	(eval '(lambda (a b c d e f g h i j k)
	462	"So many args."
	463	(+ a b))
	464	(current-module))))
	465
	466	(pass-if-equal "general closure"
	467	"How general."
	468	(procedure-documentation
	469	(eval '(lambda* (a b #:key k #:rest r)
	470	"How general."
	471	(+ a b))
	472	(current-module)))))
	473
d062a8c1 AW	474	;;;
	475	;;; local-eval
	476	;;;
	477
	478	(with-test-prefix "local evaluation"
	479
	480	(pass-if "local-eval"
	481
2f3e4364 MW	482	(let* ((env1 (local-eval '(let ((x 1) (y 2) (z 3))
	483	(define-syntax-rule (foo x) (quote x))
	484	(the-environment))
	485	(current-module)))
d062a8c1 AW	486	(env2 (local-eval '(let ((x 111) (a 'a))
	487	(define-syntax-rule (bar x) (quote x))
	488	(the-environment))
	489	env1)))
	490	(local-eval '(set! x 11) env1)
	491	(local-eval '(set! y 22) env1)
	492	(local-eval '(set! z 33) env2)
	493	(and (equal? (local-eval '(list x y z) env1)
	494	'(11 22 33))
	495	(equal? (local-eval '(list x y z a) env2)
	496	'(111 22 33 a)))))
	497
	498	(pass-if "local-compile"
	499
2f3e4364 MW	500	(let* ((env1 (local-compile '(let ((x 1) (y 2) (z 3))
	501	(define-syntax-rule (foo x) (quote x))
	502	(the-environment))
	503	(current-module)))
d062a8c1 AW	504	(env2 (local-compile '(let ((x 111) (a 'a))
	505	(define-syntax-rule (bar x) (quote x))
	506	(the-environment))
	507	env1)))
	508	(local-compile '(set! x 11) env1)
	509	(local-compile '(set! y 22) env1)
	510	(local-compile '(set! z 33) env2)
	511	(and (equal? (local-compile '(list x y z) env1)
	512	'(11 22 33))
	513	(equal? (local-compile '(list x y z a) env2)
	514	'(111 22 33 a)))))
	515
	516	(pass-if "the-environment within a macro"
	517	(let ((module-a-name '(test module the-environment a))
	518	(module-b-name '(test module the-environment b)))
	519	(let ((module-a (resolve-module module-a-name))
	520	(module-b (resolve-module module-b-name)))
	521	(module-use! module-a (resolve-interface '(guile)))
	522	(module-use! module-a (resolve-interface '(ice-9 local-eval)))
	523	(eval '(begin
	524	(define z 3)
	525	(define-syntax-rule (test)
	526	(let ((x 1) (y 2))
	527	(the-environment))))
	528	module-a)
	529	(module-use! module-b (resolve-interface '(guile)))
2f3e4364 MW	530	(let ((env (local-eval `(let ((x 111) (y 222))
	531	((@@ ,module-a-name test)))
	532	module-b)))
d062a8c1 AW	533	(equal? (local-eval '(list x y z) env)
	534	'(1 2 3))))))
	535
	536	(pass-if "capture pattern variables"
	537	(let ((env (syntax-case #'(((a 1) (b 2) (c 3))
	538	((d 4) (e 5) (f 6))) ()
	539	((((k v) ...) ...) (the-environment)))))
	540	(equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env))
	541	'((a b c 1 2 3) (d e f 4 5 6)))))
	542
	543	(pass-if "mixed primitive-eval, local-eval and local-compile"
	544
	545	(let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3))
	546	(define-syntax-rule (foo x) (quote x))
	547	(the-environment))))
	548	(env2 (local-eval '(let ((x 111) (a 'a))
	549	(define-syntax-rule (bar x) (quote x))
	550	(the-environment))
	551	env1))
	552	(env3 (local-compile '(let ((y 222) (b 'b))
	553	(the-environment))
	554	env2)))
	555	(local-eval '(set! x 11) env1)
	556	(local-compile '(set! y 22) env2)
	557	(local-eval '(set! z 33) env2)
	558	(local-compile '(set! a (* y 2)) env3)
	559	(and (equal? (local-compile '(list x y z) env1)
	560	'(11 22 33))
	561	(equal? (local-eval '(list x y z a) env2)
	562	'(111 22 33 444))
	563	(equal? (local-eval '(list x y z a b) env3)
	564	'(111 222 33 444 b))))))
	565
414959ca	566	;;; eval.test ends here