test-suite/tests/srcprop.test

   1 ;;;; srcprop.test --- test Guile source properties    -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2003, 2006, 2009 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-srcprop)
  20   :use-module (test-suite lib))
  21
  22
  23 ;;;
  24 ;;; source-properties
  25 ;;;
  26
  27 (with-test-prefix "source-properties"
  28
  29   (pass-if "no props"
  30     (null? (source-properties (list 1 2 3))))
  31
  32   (read-enable 'positions)
  33   (with-test-prefix "read properties"
  34     (define (reads-with-srcprops? str)
  35       (let ((x (read (open-input-string str))))
  36         (not (null? (source-properties x)))))
  37
  38     (pass-if "pairs"           (reads-with-srcprops? "(1 . 2)"))
  39     (pass-if "vectors"         (reads-with-srcprops? "#(1 2 3)"))
  40     (pass-if "bytevectors"     (reads-with-srcprops? "#vu8(1 2 3)"))
  41     (pass-if "bitvectors"      (reads-with-srcprops? "#*101011"))
  42     (pass-if "srfi4 vectors"   (reads-with-srcprops? "#f64(3.1415 2.71)"))
  43     (pass-if "arrays"          (reads-with-srcprops? "#2u32@2@3((1 2) (2 3))"))
  44     (pass-if "strings"         (reads-with-srcprops? "\"hello\""))
  45     (pass-if "null string"     (reads-with-srcprops? "\"\""))
  46
  47     (pass-if "floats"          (reads-with-srcprops? "3.1415"))
  48     (pass-if "fractions"       (reads-with-srcprops? "1/2"))
  49     (pass-if "complex numbers" (reads-with-srcprops? "1+1i"))
  50     (pass-if "bignums"
  51       (and (reads-with-srcprops? (number->string (1+ most-positive-fixnum)))
  52            (reads-with-srcprops? (number->string (1- most-negative-fixnum)))))
  53
  54     (pass-if "fixnums (should have none)"
  55       (not (or (reads-with-srcprops? "0")
  56                (reads-with-srcprops? "1")
  57                (reads-with-srcprops? "-1")
  58                (reads-with-srcprops? (number->string most-positive-fixnum))
  59                (reads-with-srcprops? (number->string most-negative-fixnum)))))
  60
  61     (pass-if "symbols (should have none)"
  62       (not (reads-with-srcprops? "foo")))
  63
  64     (pass-if "keywords (should have none)"
  65       (not (reads-with-srcprops? "#:foo")))
  66
  67     (pass-if "characters (should have none)"
  68       (not (reads-with-srcprops? "#\\c")))
  69
  70     (pass-if "booleans (should have none)"
  71       (not (or (reads-with-srcprops? "#t")
  72                (reads-with-srcprops? "#f"))))))
  73
  74 ;;;
  75 ;;; set-source-property!
  76 ;;;
  77
  78 (with-test-prefix "set-source-property!"
  79   (read-enable 'positions)
  80
  81   (pass-if "setting the breakpoint property works"
  82     (let ((s (read (open-input-string "(+ 3 4)"))))
  83       (throw 'unresolved)
  84       (set-source-property! s 'breakpoint #t)
  85       (let ((current-trap-opts (evaluator-traps-interface))
  86             (current-debug-opts (debug-options-interface))
  87             (trap-called #f))
  88         (trap-set! enter-frame-handler (lambda _ (set! trap-called #t)))
  89         (trap-enable 'traps)
  90         (debug-enable 'debug)
  91         (debug-enable 'breakpoints)
  92         (with-traps (lambda ()
  93                       (primitive-eval s)))
  94         (evaluator-traps-interface current-trap-opts)
  95         (debug-options-interface current-debug-opts)
  96         trap-called))))
  97
  98 ;;;
  99 ;;; set-source-properties!
 100 ;;;
 101
 102 (with-test-prefix "set-source-properties!"
 103   (read-enable 'positions)
 104
 105   (pass-if "setting the breakpoint property works"
 106     (let ((s (read (open-input-string "(+ 3 4)"))))
 107       (throw 'unresolved)
 108       (set-source-properties! s '((breakpoint #t)))
 109       (let ((current-trap-opts (evaluator-traps-interface))
 110             (current-debug-opts (debug-options-interface))
 111             (trap-called #f))
 112         (trap-set! enter-frame-handler (lambda _ (set! trap-called #t)))
 113         (trap-enable 'traps)
 114         (debug-enable 'debug)
 115         (debug-enable 'breakpoints)
 116         (with-traps (lambda ()
 117                       (primitive-eval s)))
 118         (evaluator-traps-interface current-trap-opts)
 119         (debug-options-interface current-debug-opts)
 120         trap-called)))
 121
 122   (let ((s (read (open-input-string "(1 . 2)"))))
 123
 124     (with-test-prefix "copied props"
 125       (pass-if "visible to source-property"
 126         (let ((t (cons 3 4)))
 127           (set-source-properties! t (source-properties s))
 128           (number? (source-property t 'line))))
 129
 130       (pass-if "visible to source-properties"
 131         (let ((t (cons 3 4)))
 132           (set-source-properties! t (source-properties s))
 133           (not (null? (source-properties t))))))))