1# Copyright (C) 2014-2020 Free Software Foundation, Inc. 2 3# This program is free software; you can redistribute it and/or modify 4# it under the terms of the GNU General Public License as published by 5# the Free Software Foundation; either version 3 of the License, or 6# (at your option) any later version. 7# 8# This program is distributed in the hope that it will be useful, 9# but WITHOUT ANY WARRANTY; without even the implied warranty of 10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11# GNU General Public License for more details. 12# 13# You should have received a copy of the GNU General Public License 14# along with this program. If not, see <http://www.gnu.org/licenses/>. 15 16# This file is part of the GDB testsuite. 17# It tests GDB provided ports. 18 19load_lib gdb-guile.exp 20 21standard_testfile 22 23if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile}] } { 24 return 25} 26 27# Skip all tests if Guile scripting is not enabled. 28if { [skip_guile_tests] } { continue } 29 30if ![gdb_guile_runto_main] { 31 return 32} 33 34gdb_reinitialize_dir $srcdir/$subdir 35 36gdb_install_guile_utils 37gdb_install_guile_module 38 39gdb_scm_test_silent_cmd "guile (use-modules (rnrs io ports) (rnrs bytevectors))" \ 40 "import (rnrs io ports) (rnrs bytevectors)" 41 42gdb_test "guile (print (stdio-port? 42))" "= #f" 43gdb_test "guile (print (stdio-port? (%make-void-port \"r\")))" "= #f" 44gdb_test "guile (print (stdio-port? (input-port)))" "= #t" 45gdb_test "guile (print (stdio-port? (output-port)))" "= #t" 46gdb_test "guile (print (stdio-port? (error-port)))" "= #t" 47 48# Test memory port open/close. 49 50proc test_port { mode } { 51 with_test_prefix "basic $mode tests" { 52 gdb_test_no_output "guile (define my-port (open-memory #:mode \"$mode\"))" \ 53 "create memory port" 54 gdb_test "guile (print (memory-port? my-port))" "= #t" 55 switch -glob $mode { 56 "r+*" { 57 gdb_test "guile (print (input-port? my-port))" "= #t" 58 gdb_test "guile (print (output-port? my-port))" "= #t" 59 } 60 "r*" { 61 gdb_test "guile (print (input-port? my-port))" "= #t" 62 gdb_test "guile (print (output-port? my-port))" "= #f" 63 } 64 "w*" { 65 gdb_test "guile (print (input-port? my-port))" "= #f" 66 gdb_test "guile (print (output-port? my-port))" "= #t" 67 } 68 default { 69 error "bad test mode" 70 } 71 } 72 gdb_test "guile (print (port-closed? my-port))" "= #f" \ 73 "test port-closed? before it's closed" 74 gdb_test "guile (print (close-port my-port))" "= #t" 75 gdb_test "guile (print (port-closed? my-port))" "= #t" \ 76 "test port-closed? after it's closed" 77 } 78} 79 80set port_variations { r w r+ rb wb r+b r0 w0 r+0 } 81foreach variation $port_variations { 82 test_port $variation 83} 84 85# Test read/write of memory ports. 86 87proc test_mem_port_rw { kind } { 88 if { "$kind" == "buffered" } { 89 set buffered 1 90 } else { 91 set buffered 0 92 } 93 with_test_prefix $kind { 94 if $buffered { 95 set mode "r+" 96 } else { 97 set mode "r+0" 98 } 99 gdb_test_no_output "guile (define rw-mem-port (open-memory #:mode \"$mode\"))" \ 100 "create r/w memory port" 101 gdb_test "guile (print rw-mem-port)" \ 102 "#<input-output: gdb:memory-port 0x0-0xf+>" 103 gdb_test_no_output "guile (define sp-reg (parse-and-eval \"\$sp\"))" \ 104 "get sp reg" 105 # Note: Only use $sp_reg for gdb_test result matching, don't use it in 106 # gdb commands. Otherwise transcript.N becomes unusable. 107 set sp_reg [get_valueof /u "\$sp" 0] 108 gdb_test_no_output "guile (define byte-at-sp (parse-and-eval \"*(char*) \$sp\"))" \ 109 "save current value at sp" 110 # Pass the result of parse-and-eval through value-fetch-lazy!, 111 # otherwise the value gets left as a lazy reference to memory, which 112 # when re-evaluated after we flush the write will yield the newly 113 # written value. PR 18175 114 gdb_test_no_output "guile (value-fetch-lazy! byte-at-sp)" \ 115 "un-lazyify byte-at-sp" 116 gdb_test "guile (print (seek rw-mem-port (value->integer sp-reg) SEEK_SET))" \ 117 "= $sp_reg" \ 118 "seek to \$sp" 119 gdb_test_no_output "guile (define old-value (value->integer byte-at-sp))" \ 120 "define old-value" 121 gdb_test_no_output "guile (define new-value (logxor old-value 1))" \ 122 "define new-value" 123 gdb_test "guile (print (put-bytevector rw-mem-port (make-bytevector 1 new-value)))" \ 124 "= #<unspecified>" 125 if $buffered { 126 # Value shouldn't be in memory yet. 127 gdb_test "guile (print (value=? (parse-and-eval \"*(char*) \$sp\") byte-at-sp))" \ 128 "= #t" \ 129 "test byte at sp, before flush" 130 gdb_test_no_output "guile (force-output rw-mem-port)" \ 131 "flush port" 132 } 133 # Value should be in memory now. 134 gdb_test "guile (print (value=? (parse-and-eval \"*(char*) \$sp\") byte-at-sp))" \ 135 "= #f" \ 136 "test byte at sp, after flush" 137 # Restore the value for cleanliness sake, and to verify close-port 138 # flushes the buffer. 139 gdb_test "guile (print (seek rw-mem-port (value->integer sp-reg) SEEK_SET))" \ 140 "= $sp_reg" \ 141 "seek to \$sp for restore" 142 gdb_test "guile (print (put-bytevector rw-mem-port (make-bytevector 1 old-value)))" \ 143 "= #<unspecified>" 144 gdb_test "guile (print (close-port rw-mem-port))" \ 145 "= #t" 146 gdb_test "guile (print (value=? (parse-and-eval \"*(char*) \$sp\") byte-at-sp))" \ 147 "= #t" \ 148 "test byte at sp, after close" 149 } 150} 151 152test_mem_port_rw buffered 153test_mem_port_rw unbuffered 154 155# Test zero-length memory ports. 156 157gdb_test_no_output "guile (define zero-mem-port (open-memory #:start 0 #:size 0 #:mode \"r+\"))" \ 158 "create zero length memory port" 159gdb_test "guile (print (read-char zero-mem-port))" \ 160 "= #<eof>" 161gdb_test "guile (print (write-char #\\a zero-mem-port))" \ 162 "ERROR: .*Out of range: writing beyond end of memory range.*Error while executing Scheme code." 163gdb_test "guile (print (get-bytevector-n zero-mem-port 0))" \ 164 "= #vu8\\(\\)" 165gdb_test "guile (print (put-bytevector zero-mem-port (make-bytevector 0)))" \ 166 "= #<unspecified>" 167gdb_test "guile (print (close-port zero-mem-port))" "= #t" 168