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))))))))
134