← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to test-suite/tests/eval.test

  • Committer: Bazaar Package Importer
  • Author(s): أحمد المحمودي (Ahmed El-Mahmoudy)
  • Date: 2009-07-20 19:39:17 UTC
  • mfrom: (1.2.6 upstream)
  • Revision ID: james.westby@ubuntu.com-20090720193917-s0985l9wxihwoscl
Tags: 1.8.7+1-1ubuntu1
https://launchpad.net/bugs/401816
* Merge from Debian unstable, remaining changes: (LP: #401816)
  - Build with -Wno-error.
  - Build with thread support. Some guile-using programs like autogen need it.
  - Add debian/guile-1.8-libs.shlibs: Thread support breaks ABI, bump the soname.

Show diffs side-by-side

added added

removed removed

Lines of Context:
test-suite/tests/eval.test
1
1
;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
2
 
;;;; Copyright (C) 2000, 2001, 2006, 2007 Free Software Foundation, Inc.
 
2
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009 Free Software Foundation, Inc.
3
3
;;;;
4
4
;;;; This library is free software; you can redistribute it and/or
5
5
;;;; modify it under the terms of the GNU Lesser General Public
17
17
 
18
18
(define-module (test-suite test-eval)
19
19
  :use-module (test-suite lib)
 
20
  :use-module ((srfi srfi-1) :select (unfold count))
20
21
  :use-module (ice-9 documentation))
21
22
 
22
23
 
312
313
         (%make-void-port "w"))
313
314
        #t))))
314
315
 
 
316
 
 
317
;;;
 
318
;;; stacks
 
319
;;;
 
320
 
 
321
(define (stack->frames stack)
 
322
  ;; Return the list of frames comprising STACK.
 
323
  (unfold (lambda (i)
 
324
            (>= i (stack-length stack)))
 
325
          (lambda (i)
 
326
            (stack-ref stack i))
 
327
          1+
 
328
          0))
 
329
 
 
330
(with-test-prefix "stacks"
 
331
  (with-debugging-evaluator
 
332
 
 
333
    (pass-if "stack involving a subr"
 
334
      ;; The subr involving the error must appear exactly once on the stack.
 
335
      (catch 'result
 
336
        (lambda ()
 
337
          (start-stack 'foo
 
338
            (lazy-catch 'wrong-type-arg
 
339
              (lambda ()
 
340
                ;; Trigger a `wrong-type-arg' exception.
 
341
                (fluid-ref 'not-a-fluid))
 
342
              (lambda _
 
343
                (let* ((stack  (make-stack #t))
 
344
                       (frames (stack->frames stack)))
 
345
                  (throw 'result
 
346
                         (count (lambda (frame)
 
347
                                  (and (frame-procedure? frame)
 
348
                                       (eq? (frame-procedure frame)
 
349
                                            fluid-ref)))
 
350
                                frames)))))))
 
351
        (lambda (key result)
 
352
          (= 1 result))))
 
353
 
 
354
    (pass-if "stack involving a gsubr"
 
355
      ;; The gsubr involving the error must appear exactly once on the stack.
 
356
      ;; This is less obvious since gsubr application may require an
 
357
      ;; additional `SCM_APPLY ()' call, which should not be visible to the
 
358
      ;; application.
 
359
      (catch 'result
 
360
        (lambda ()
 
361
          (start-stack 'foo
 
362
            (lazy-catch 'wrong-type-arg
 
363
              (lambda ()
 
364
                ;; Trigger a `wrong-type-arg' exception.
 
365
                (hashq-ref 'wrong 'type 'arg))
 
366
              (lambda _
 
367
                (let* ((stack  (make-stack #t))
 
368
                       (frames (stack->frames stack)))
 
369
                  (throw 'result
 
370
                         (count (lambda (frame)
 
371
                                  (and (frame-procedure? frame)
 
372
                                       (eq? (frame-procedure frame)
 
373
                                            hashq-ref)))
 
374
                                frames)))))))
 
375
        (lambda (key result)
 
376
          (= 1 result))))))
 
377
 
315
378
;;;
316
379
;;; letrec init evaluation
317
380
;;;