[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 37/58: types: Recognize 'scm_t_port_type' and decode por
From: |
Andy Wingo |
Subject: |
[Guile-commits] 37/58: types: Recognize 'scm_t_port_type' and decode port type name. |
Date: |
Tue, 7 Aug 2018 06:58:36 -0400 (EDT) |
wingo pushed a commit to branch lightning
in repository guile.
commit 5f75df03c60098bb1da0f91f39575e5801d26281
Author: Ludovic Courtès <address@hidden>
Date: Sun Jun 24 15:31:05 2018 +0200
types: Recognize 'scm_t_port_type' and decode port type name.
* module/system/base/types.scm (read-c-string, inferior-port-type): New
procedures.
(inferior-port): Use 'inferior-port-type' to determine the port type.
(cell->object): Rename 'flags+type' to 'flags' in the '%tc7-port' case.
* test-suite/tests/types.test ("opaque objects"): Adjust port testse.
(test-inferior-ports): New macro.
("ports"): New test prefix.
---
module/system/base/types.scm | 34 +++++++++++++++++++++++++++++-----
test-suite/tests/types.test | 31 ++++++++++++++++++++++++++++---
2 files changed, 57 insertions(+), 8 deletions(-)
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 834fa5f..418c9fe 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -75,7 +75,7 @@
memory-backend?
(peek memory-backend-peek)
(open memory-backend-open)
- (type-name memory-backend-type-name)) ; for SMOBs and ports
+ (type-name memory-backend-type-name)) ;for SMOBs
(define %ffi-memory-backend
;; The FFI back-end to access the current process's memory. The main
@@ -133,6 +133,18 @@ SIZE is omitted, return an unbounded port to the memory at
ADDRESS."
(let ((bv (get-bytevector-n port %word-size)))
(bytevector-uint-ref bv 0 (native-endianness) %word-size)))
+(define (read-c-string backend address)
+ "Read a NUL-terminated string from ADDRESS, decode it as UTF-8, and
+return the corresponding string."
+ (define port
+ (memory-port backend address))
+
+ (let loop ((bytes '()))
+ (let ((byte (get-u8 port)))
+ (if (zero? byte)
+ (utf8->string (u8-list->bytevector (reverse bytes)))
+ (loop (cons byte bytes))))))
+
(define-inlinable (type-number->name backend kind number)
"Return the name of the type NUMBER of KIND, where KIND is one of
'smob or 'port, or #f if the information is unavailable."
@@ -308,12 +320,24 @@ TYPE-NUMBER."
type-number)
address))
+(define (inferior-port-type backend address)
+ "Return an object representing the 'scm_t_port_type' structure at
+ADDRESS."
+ (inferior-object 'port-type
+ ;; The 'name' field lives at offset 0.
+ (let ((name (dereference-word backend address)))
+ (if (zero? name)
+ "(nameless)"
+ (read-c-string backend name)))
+ address))
+
(define (inferior-port backend type-number address)
"Return an object representing the port at ADDRESS whose type is
TYPE-NUMBER."
(inferior-object 'port
- (or (type-number->name backend 'port type-number)
- type-number)
+ (let ((address (+ address (* 3 %word-size))))
+ (inferior-port-type backend
+ (dereference-word backend address)))
address))
(define %visited-cells
@@ -412,8 +436,8 @@ using BACKEND."
(inferior-object 'fluid address))
(((_ & #x7f = %tc7-dynamic-state))
(inferior-object 'dynamic-state address))
- ((((flags+type << 8) || %tc7-port))
- (inferior-port backend (logand flags+type #xff) address))
+ ((((flags << 8) || %tc7-port))
+ (inferior-port backend (logand flags #xff) address))
(((_ & #x7f = %tc7-program))
(inferior-object 'program address))
(((_ & #xffff = %tc16-bignum))
diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test
index 446aff5..9a9cdf7 100644
--- a/test-suite/tests/types.test
+++ b/test-suite/tests/types.test
@@ -1,6 +1,6 @@
;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8;
-*-
;;;;
-;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 2014, 2015, 2018 Free Software Foundation, Inc.
;;;;
;;;; This file is part of GNU Guile.
;;;;
@@ -98,8 +98,8 @@
(with-test-prefix "opaque objects"
(test-inferior-objects
((make-guardian) smob (? integer?))
- ((%make-void-port "w") port (? integer?))
- ((open-input-string "hello") port (? integer?))
+ ((%make-void-port "w") port (? inferior-object?))
+ ((open-input-string "hello") port (? inferior-object?))
((lambda () #t) program _)
((make-variable 'foo) variable _)
((make-weak-vector 3 #t) weak-vector _)
@@ -111,6 +111,31 @@
((expt 2 70) bignum _)
((make-fluid) fluid _)))
+(define-syntax test-inferior-ports
+ (syntax-rules ()
+ "Test whether each OBJECT is a port with the given TYPE-NAME."
+ ((_ (object type-name) rest ...)
+ (begin
+ (pass-if-equal (object->string object)
+ type-name
+ (let ((result (scm->object (object-address object))))
+ (and (eq? 'port (inferior-object-kind result))
+ (let ((type (inferior-object-sub-kind result)))
+ (and (eq? 'port-type (inferior-object-kind type))
+ (inferior-object-sub-kind type))))))
+ (test-inferior-ports rest ...)))
+ ((_)
+ *unspecified*)))
+
+(with-test-prefix "ports"
+ (test-inferior-ports
+ ((open-input-file "/dev/null") "file")
+ ((open-output-file "/dev/null") "file")
+ ((open-input-string "the string") "string")
+ ((open-output-string) "string")
+ ((open-bytevector-input-port #vu8(1 2 3 4 5)) "r6rs-bytevector-input-port")
+ ((open-bytevector-output-port) "r6rs-bytevector-output-port")))
+
(define-record-type <some-struct>
(some-struct x y z)
some-struct?
- [Guile-commits] 39/58: GDB support: Add note about (gdb frame-filters)., (continued)
- [Guile-commits] 39/58: GDB support: Add note about (gdb frame-filters)., Andy Wingo, 2018/08/07
- [Guile-commits] 31/58: doc: Document (ice-9 match) macros., Andy Wingo, 2018/08/07
- [Guile-commits] 49/58: r6rs-ports: Accept 'port-position' values greater than 2^32., Andy Wingo, 2018/08/07
- [Guile-commits] 45/58: Update NEWS., Andy Wingo, 2018/08/07
- [Guile-commits] 58/58: Add missing include to adapt to recent merge from master, Andy Wingo, 2018/08/07
- [Guile-commits] 53/58: r6rs-ports: 'put-bytevector' accepts 64-bit integers., Andy Wingo, 2018/08/07
- [Guile-commits] 47/58: Update release docs., Andy Wingo, 2018/08/07
- [Guile-commits] 42/58: vm: Fix stack-marking bug in multi-threaded programs., Andy Wingo, 2018/08/07
- [Guile-commits] 52/58: compile: Update copyright year., Andy Wingo, 2018/08/07
- [Guile-commits] 25/58: Add SRFI 71: Extended LET-syntax for multiple values., Andy Wingo, 2018/08/07
- [Guile-commits] 37/58: types: Recognize 'scm_t_port_type' and decode port type name.,
Andy Wingo <=
- [Guile-commits] 48/58: Make srfi-71 visible through 'cond-expand'., Andy Wingo, 2018/08/07
- [Guile-commits] 46/58: build: Really build srfi/srfi-71.scm., Andy Wingo, 2018/08/07
- [Guile-commits] 43/58: Serialize accesses to submodule hash tables., Andy Wingo, 2018/08/07
- [Guile-commits] 50/58: compile: Add '-x' flag., Andy Wingo, 2018/08/07
- [Guile-commits] 57/58: Merge branch 'master' into lightning, Andy Wingo, 2018/08/07
- [Guile-commits] 44/58: Update copyright years in '--version' and the manual., Andy Wingo, 2018/08/07
- [Guile-commits] 55/58: srfi-19: Remove unused procedure., Andy Wingo, 2018/08/07
- [Guile-commits] 35/58: web: Export http-request., Andy Wingo, 2018/08/07
- [Guile-commits] 56/58: Fix R6RS call-with-{input, output}-file to open textual ports., Andy Wingo, 2018/08/07
- [Guile-commits] 54/58: Add -Wshadowed-toplevel., Andy Wingo, 2018/08/07