gdb/testsuite/gdb.guile/scm-ports.exp

   1 # Copyright (C) 2014-2023 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
  19 load_lib gdb-guile.exp
  20
  21 standard_testfile
  22
  23 if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile}] } {
  24     return
  25 }
  26
  27 # Skip all tests if Guile scripting is not enabled.
  28 if { [skip_guile_tests] } { continue }
  29
  30 if ![gdb_guile_runto_main] {
  31    return
  32 }
  33
  34 gdb_reinitialize_dir $srcdir/$subdir
  35
  36 gdb_install_guile_utils
  37 gdb_install_guile_module
  38
  39 gdb_scm_test_silent_cmd "guile (use-modules (rnrs io ports) (rnrs bytevectors))" \
  40     "import (rnrs io ports) (rnrs bytevectors)"
  41
  42 gdb_test "guile (print (stdio-port? 42))" "= #f"
  43 gdb_test "guile (print (stdio-port? (%make-void-port \"r\")))" "= #f"
  44 gdb_test "guile (print (stdio-port? (input-port)))" "= #t"
  45 gdb_test "guile (print (stdio-port? (output-port)))" "= #t"
  46 gdb_test "guile (print (stdio-port? (error-port)))" "= #t"
  47
  48 # Test memory port open/close.
  49
  50 proc 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
  80 set port_variations { r w r+ rb wb r+b r0 w0 r+0 }
  81 foreach variation $port_variations {
  82     test_port $variation
  83 }
  84
  85 # Test read/write of memory ports.
  86
  87 proc 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
 152 test_mem_port_rw buffered
 153 test_mem_port_rw unbuffered
 154
 155 # Test zero-length memory ports.
 156
 157 gdb_test_no_output "guile (define zero-mem-port (open-memory #:start 0 #:size 0 #:mode \"r+\"))" \
 158     "create zero length memory port"
 159 gdb_test "guile (print (read-char zero-mem-port))" \
 160     "= #<eof>"
 161 gdb_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."
 163 gdb_test "guile (print (get-bytevector-n zero-mem-port 0))" \
 164     "= #vu8\\(\\)"
 165 gdb_test "guile (print (put-bytevector zero-mem-port (make-bytevector 0)))" \
 166     "= #<unspecified>"
 167 gdb_test "guile (print (close-port zero-mem-port))" "= #t"