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.

2 files changed, 58 insertions, 9 deletions

diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index a3d8a66a3..2018dd85b 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -1,5 +1,5 @@
 ;;; 'SCM' type tag decoding.
-;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Lesser General Public License as published by
@@ -74,7 +74,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
@@ -132,6 +132,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."
@@ -350,12 +362,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
@@ -453,8 +477,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 446aff541..9a9cdf73d 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?