[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-212-gae8d8
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-212-gae8d8a8 |
|
Date: |
Thu, 20 Feb 2014 22:10:05 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ae8d8a84ef0187a3d732e43c459182ed15536dc1
The branch, stable-2.0 has been updated
via ae8d8a84ef0187a3d732e43c459182ed15536dc1 (commit)
via 8f5dbecb4bfe9862d3603b2848cd115d5a164a4f (commit)
via 359f46a41cd703fcec187459eb11aacf1b05d76a (commit)
via 5f4b817df92b30ae32f934f3c2cf83a5990e1895 (commit)
from f07fa851505c6f4e7040b10ca0e178901bd106ef (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit ae8d8a84ef0187a3d732e43c459182ed15536dc1
Author: Ludovic Courtès <address@hidden>
Date: Thu Feb 20 22:57:26 2014 +0100
Make sure 'ftw' allows directory traversal when running as root.
* module/ice-9/ftw.scm (stat-dir-readable?-proc): Return #t when UID is
zero. Reported Frank Terbeck <address@hidden>.
commit 8f5dbecb4bfe9862d3603b2848cd115d5a164a4f
Author: Ludovic Courtès <address@hidden>
Date: Thu Feb 20 22:56:17 2014 +0100
build: Bail out when 'PKG_CHECK_MODULES' is missing.
* configure.ac: Add 'm4_pattern_forbid' invocation.
commit 359f46a41cd703fcec187459eb11aacf1b05d76a
Author: Ludovic Courtès <address@hidden>
Date: Mon Feb 17 15:40:34 2014 +0100
Add GDB extension to support Guile.
* libguile/libguile-2.0-gdb.scm: New file.
* libguile/Makefile.am (install-data-local): New target. Based on code
from GNU libstdc++.
(EXTRA_DIST): Add 'libguile-2.0-gdb.scm'.
* doc/ref/api-debug.texi (GDB Support): New section.
commit 5f4b817df92b30ae32f934f3c2cf83a5990e1895
Author: Ludovic Courtès <address@hidden>
Date: Tue Feb 18 23:04:01 2014 +0100
Add (system base types).
* module/system/base/types.scm, test-suite/tests/types.test: New files.
* module/Makefile.am (SYSTEM_BASE_SOURCES): Add system/base/types.scm.
* test-suite/Makefile.am (SCM_TESTS): Add tests/types.test.
-----------------------------------------------------------------------
Summary of changes:
configure.ac | 6 +-
doc/ref/api-debug.texi | 42 ++++-
libguile/Makefile.am | 40 +++-
libguile/libguile-2.0-gdb.scm | 164 +++++++++++++
module/Makefile.am | 1 +
module/ice-9/ftw.scm | 5 +-
module/system/base/types.scm | 519 +++++++++++++++++++++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/types.test | 154 ++++++++++++
9 files changed, 920 insertions(+), 12 deletions(-)
create mode 100644 libguile/libguile-2.0-gdb.scm
create mode 100644 module/system/base/types.scm
create mode 100644 test-suite/tests/types.test
diff --git a/configure.ac b/configure.ac
index d0d9851..e99b272 100644
--- a/configure.ac
+++ b/configure.ac
@@ -5,7 +5,7 @@ dnl
define(GUILE_CONFIGURE_COPYRIGHT,[[
Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
This file is part of GUILE
@@ -51,6 +51,10 @@ GUILE_VERSION="$PACKAGE_VERSION"
AC_CONFIG_HEADERS([config.h])
AH_TOP(/*GUILE_CONFIGURE_COPYRIGHT*/)
+dnl We require the pkg.m4 set of macros from pkg-config.
+dnl Make sure it's available.
+m4_pattern_forbid([PKG_CHECK_MODULES])
+
#--------------------------------------------------------------------
AC_LANG([C])
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index f6c706c..619629b 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2010, 2011, 2012, 2013
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2010, 2011, 2012, 2013, 2014
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -17,8 +17,9 @@ infrastructure that builds on top of those calls.
@menu
* Evaluation Model:: Evaluation and the Scheme stack.
* Source Properties:: From expressions to source locations.
-* Programmatic Error Handling:: Debugging when an error occurs.
+* Programmatic Error Handling:: Debugging when an error occurs.
* Traps:: Breakpoints, tracepoints, oh my!
+* GDB Support:: C-level debugging with GDB.
@end menu
@node Evaluation Model
@@ -1351,6 +1352,43 @@ This is a stepping trap, used to implement the ``step'',
``next'',
``step-instruction'', and ``next-instruction'' REPL commands.
@end deffn
address@hidden GDB Support
address@hidden GDB Support
+
address@hidden GDB support
+
+Sometimes, you may find it necessary to debug Guile applications at the
+C level. Doing so can be tedious, in particular because the debugger is
+oblivious to Guile's @code{SCM} type, and thus unable to display
address@hidden values in any meaningful way:
+
address@hidden
+(gdb) frame
+#0 scm_display (obj=0xf04310, port=0x6f9f30) at print.c:1437
address@hidden example
+
+To address that, Guile comes with an extension of the GNU Debugger (GDB)
+that contains a ``pretty-printer'' for @code{SCM} values. With this GDB
+extension, the C frame in the example above shows up like this:
+
address@hidden
+(gdb) frame
+#0 scm_display (obj=("hello" GDB!), port=#<port file 6f9f30>) at print.c:1437
address@hidden example
+
address@hidden
+Here GDB was able to decode the list pointed to by @var{obj}, and to
+print it using Scheme's read syntax.
+
+That extension is a @code{.scm} file installed alongside the
address@hidden shared library. When GDB 7.8 or later is installed and
+compiled with support for extensions written in Guile, the extension is
+automatically loaded when debugging a program linked against
address@hidden (@pxref{Auto-loading,,, gdb, Debugging with GDB}). Note
+that the directory where @file{libguile} is installed must be among
+GDB's auto-loading ``safe directories'' (@pxref{Auto-loading safe
+path,,, gdb, Debugging with GDB}).
+
@c Local Variables:
@c TeX-master: "guile.texi"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index dcbdba1..c7ceb16 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with Automake to create Makefile.in
##
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
-## 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+## 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -448,6 +448,31 @@ address@hidden@_la_SOURCES = _scm.h \
install-exec-hook:
rm -f $(DESTDIR)$(bindir)/guile-snarf.awk
+install-data-local: libguile-2.0-gdb.scm
+ @$(MKDIR_P) $(DESTDIR)$(libdir)
+## We want to install libguile-2.0-gdb.scm as SOMETHING-gdb.scm.
+## SOMETHING is the full name of the final library. We want to ignore
+## symlinks, the .la file, and any previous -gdb.py file. This is
+## inherently fragile, but there does not seem to be a better option,
+## because libtool hides the real names from us. (Trick courtesy of
+## GNU libstdc++.)
+ @here=`pwd`; cd $(DESTDIR)$(libdir); \
+ for file in address@hidden@*; do \
+ case $$file in \
+ *-gdb.scm) ;; \
+ *.la) ;; \
+ *) if test -h $$file; then \
+ continue; \
+ fi; \
+ libname=$$file;; \
+ esac; \
+ done; \
+ cd $$here; \
+ echo " $(INSTALL_DATA) libguile-2.0-gdb.scm \
+$(DESTDIR)$(libdir)/$$libname-gdb.scm"; \
+ $(INSTALL_DATA) libguile-2.0-gdb.scm \
+ $(DESTDIR)$(libdir)/$$libname-gdb.scm
+
## This is kind of nasty... there are ".c" files that we don't want to
## compile, since they are #included. So instead we list them here.
## Perhaps we can deal with them normally once the merge seems to be
@@ -635,12 +660,13 @@ bin_SCRIPTS = guile-snarf
# and people feel like maintaining them. For now, this is not the case.
noinst_SCRIPTS = guile-snarf-docs
-EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
- ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \
- guile-func-name-check \
- cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \
- c-tokenize.lex \
- scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map
+EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
+ ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \
+ guile-func-name-check \
+ cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \
+ c-tokenize.lex \
+ scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map \
+ libguile-2.0-gdb.scm
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
# guile-procedures.txt guile.texi
diff --git a/libguile/libguile-2.0-gdb.scm b/libguile/libguile-2.0-gdb.scm
new file mode 100644
index 0000000..fdd5cd8
--- /dev/null
+++ b/libguile/libguile-2.0-gdb.scm
@@ -0,0 +1,164 @@
+;;; GDB debugging support for Guile.
+;;;
+;;; Copyright 2014 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guile-gdb)
+ #:use-module (system base types)
+ #:use-module ((gdb) #:hide (symbol?))
+ #:use-module (gdb printing)
+ #:use-module (srfi srfi-11)
+ #:export (%gdb-memory-backend
+ display-vm-frames))
+
+;;; Commentary:
+;;;
+;;; This file defines GDB extensions to pretty-print 'SCM' objects, and
+;;; to walk Guile's virtual machine stack.
+;;;
+;;; This file is installed under a name that follows the convention that
+;;; allows GDB to auto-load it anytime the user is debugging libguile
+;;; (info "(gdb) objfile-gdbdotext file").
+;;;
+;;; Code:
+
+(define (type-name-from-descriptor descriptor-array type-number)
+ "Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, or #f
+if the information is not available."
+ (let ((descriptors (lookup-global-symbol descriptor-array)))
+ (and descriptors
+ (let ((code (type-code (symbol-type descriptors))))
+ (or (= TYPE_CODE_ARRAY code)
+ (= TYPE_CODE_PTR code)))
+ (let* ((type-descr (value-subscript (symbol-value descriptors)
+ type-number))
+ (name (value-field type-descr "name")))
+ (value->string name)))))
+
+(define %gdb-memory-backend
+ ;; The GDB back-end to access the inferior's memory.
+ (let ((void* (type-pointer (lookup-type "void"))))
+ (define (dereference-word address)
+ ;; Return the word at ADDRESS.
+ (value->integer
+ (value-dereference (value-cast (make-value address)
+ (type-pointer void*)))))
+
+ (define (open address size)
+ ;; Return a port to the SIZE bytes starting at ADDRESS.
+ (if size
+ (open-memory #:start address #:size size)
+ (open-memory #:start address)))
+
+ (define (type-name kind number)
+ ;; Return the type name of KIND type NUMBER.
+ (type-name-from-descriptor (case kind
+ ((smob) "scm_smobs")
+ ((port) "scm_ptobs"))
+ number))
+
+ (memory-backend dereference-word open type-name)))
+
+
+;;;
+;;; GDB pretty-printer registration.
+;;;
+
+(define scm-value->string
+ (lambda* (value #:optional (backend %gdb-memory-backend))
+ "Return a representation of value VALUE as a string."
+ (object->string (scm->object (value->integer value) backend))))
+
+(define %scm-pretty-printer
+ (make-pretty-printer "SCM"
+ (lambda (pp value)
+ (let ((name (type-name (value-type value))))
+ (and (and name (string=? name "SCM"))
+ (make-pretty-printer-worker
+ #f ; display hint
+ (lambda (printer)
+ (scm-value->string value
%gdb-memory-backend))
+ #f))))))
+
+(define* (register-pretty-printer #:optional objfile)
+ (prepend-pretty-printer! objfile %scm-pretty-printer))
+
+(register-pretty-printer)
+
+
+;;;
+;;; VM stack walking.
+;;;
+
+(define (find-vm-engine-frame)
+ "Return the bottom-most frame containing a call to the VM engine."
+ (define (vm-engine-frame? frame)
+ (let ((sym (frame-function frame)))
+ (and sym
+ (member (symbol-name sym)
+ '("vm_debug_engine" "vm_regular_engine")))))
+
+ (let loop ((frame (newest-frame)))
+ (and frame
+ (if (vm-engine-frame? frame)
+ frame
+ (loop (frame-older frame))))))
+
+(define (vm-stack-pointer)
+ "Return the current value of the VM stack pointer or #f."
+ (let ((frame (find-vm-engine-frame)))
+ (and frame
+ (frame-read-var frame "sp"))))
+
+(define (vm-frame-pointer)
+ "Return the current value of the VM frame pointer or #f."
+ (let ((frame (find-vm-engine-frame)))
+ (and frame
+ (frame-read-var frame "fp"))))
+
+(define* (display-vm-frames #:optional (port (current-output-port)))
+ "Display the VM frames on PORT."
+ (define (display-objects start end)
+ ;; Display all the objects (arguments and local variables) located
+ ;; between START and END.
+ (let loop ((number 0)
+ (address start))
+ (when (and (> start 0) (<= address end))
+ (let ((object (dereference-word %gdb-memory-backend address)))
+ ;; TODO: Push onto GDB's value history.
+ (format port " slot ~a -> ~s~%"
+ number (scm->object object %gdb-memory-backend)))
+ (loop (+ 1 number) (+ address %word-size)))))
+
+ (let loop ((number 0)
+ (sp (value->integer (vm-stack-pointer)))
+ (fp (value->integer (vm-frame-pointer))))
+ (unless (zero? fp)
+ (let-values (((ra mvra link proc)
+ (vm-frame fp %gdb-memory-backend)))
+ (format port "#~a ~s~%" number (scm->object proc %gdb-memory-backend))
+ (display-objects fp sp)
+ (loop (+ 1 number) (- fp (* 5 %word-size)) link)))))
+
+;; See libguile/frames.h.
+(define* (vm-frame fp #:optional (backend %gdb-memory-backend))
+ "Return the components of the stack frame at FP."
+ (let ((caller (dereference-word backend (- fp %word-size)))
+ (ra (dereference-word backend (- fp (* 2 %word-size))))
+ (mvra (dereference-word backend (- fp (* 3 %word-size))))
+ (link (dereference-word backend (- fp (* 4 %word-size)))))
+ (values ra mvra link caller)))
+
+;;; libguile-2.0-gdb.scm ends here
diff --git a/module/Makefile.am b/module/Makefile.am
index 5f777b6..fb9174b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -188,6 +188,7 @@ SYSTEM_BASE_SOURCES = \
system/base/lalr.scm \
system/base/message.scm \
system/base/target.scm \
+ system/base/types.scm \
system/base/ck.scm
ICE_9_SOURCES = \
diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm
index 9c9694f..133e9c9 100644
--- a/module/ice-9/ftw.scm
+++ b/module/ice-9/ftw.scm
@@ -1,6 +1,6 @@
;;;; ftw.scm --- file system tree walk
-;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012 Free Software Foundation,
Inc.
+;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014 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
@@ -259,7 +259,8 @@
(let* ((perms (stat:perms s))
(perms-bit-set? (lambda (mask)
(not (= 0 (logand mask perms))))))
- (or (and (= uid (stat:uid s))
+ (or (zero? uid)
+ (and (= uid (stat:uid s))
(perms-bit-set? #o400))
(and (= gid (stat:gid s))
(perms-bit-set? #o040))
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
new file mode 100644
index 0000000..ed95347
--- /dev/null
+++ b/module/system/base/types.scm
@@ -0,0 +1,519 @@
+;;; 'SCM' type tag decoding.
+;;; Copyright (C) 2014 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
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (system base types)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-60)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 vlist)
+ #:use-module (system foreign)
+ #:export (%word-size
+
+ memory-backend
+ memory-backend?
+ %ffi-memory-backend
+ dereference-word
+ memory-port
+ type-number->name
+
+ inferior-object?
+ inferior-object-kind
+ inferior-object-sub-kind
+ inferior-object-address
+
+ inferior-fluid?
+ inferior-fluid-number
+
+ inferior-struct?
+ inferior-struct-name
+ inferior-struct-fields
+
+ scm->object))
+
+;;; Commentary:
+;;;
+;;; 'SCM' type tag decoding, primarily to support Guile debugging in GDB.
+;;;
+;;; Code:
+
+
+;;;
+;;; Memory back-ends.
+;;;
+
+(define %word-size
+ ;; The pointer size.
+ (sizeof '*))
+
+(define-record-type <memory-backend>
+ (memory-backend peek open type-name)
+ memory-backend?
+ (peek memory-backend-peek)
+ (open memory-backend-open)
+ (type-name memory-backend-type-name)) ; for SMOBs and ports
+
+(define %ffi-memory-backend
+ ;; The FFI back-end to access the current process's memory. The main
+ ;; purpose of this back-end is to allow testing.
+ (let ()
+ (define (dereference-word address)
+ (let* ((ptr (make-pointer address))
+ (bv (pointer->bytevector ptr %word-size)))
+ (bytevector-uint-ref bv 0 (native-endianness) %word-size)))
+
+ (define (open address size)
+ (define current-address address)
+
+ (define (read-memory! bv index count)
+ (let* ((ptr (make-pointer current-address))
+ (mem (pointer->bytevector ptr count)))
+ (bytevector-copy! mem 0 bv index count)
+ (set! current-address (+ current-address count))
+ count))
+
+ (if size
+ (let* ((ptr (make-pointer address))
+ (bv (pointer->bytevector ptr size)))
+ (open-bytevector-input-port bv))
+ (let ((port (make-custom-binary-input-port "ffi-memory"
+ read-memory!
+ #f #f #f)))
+ (setvbuf port _IONBF)
+ port)))
+
+ (memory-backend dereference-word open #f)))
+
+(define-inlinable (dereference-word backend address)
+ "Return the word at ADDRESS, using BACKEND."
+ (let ((peek (memory-backend-peek backend)))
+ (peek address)))
+
+(define-syntax memory-port
+ (syntax-rules ()
+ "Return an input port to the SIZE bytes at ADDRESS, using BACKEND. When
+SIZE is omitted, return an unbounded port to the memory at ADDRESS."
+ ((_ backend address)
+ (let ((open (memory-backend-open backend)))
+ (open address #f)))
+ ((_ backend address size)
+ (let ((open (memory-backend-open backend)))
+ (open address size)))))
+
+(define (get-word port)
+ "Read a word from PORT and return it as an integer."
+ (let ((bv (get-bytevector-n port %word-size)))
+ (bytevector-uint-ref bv 0 (native-endianness) %word-size)))
+
+(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."
+ (let ((proc (memory-backend-type-name backend)))
+ (and proc (proc kind number))))
+
+
+;;;
+;;; Matching bit patterns and cells.
+;;;
+
+(define-syntax match-cell-words
+ (syntax-rules (bytevector)
+ ((_ port ((bytevector name len) rest ...) body)
+ (let ((name (get-bytevector-n port len))
+ (remainder (modulo len %word-size)))
+ (unless (zero? remainder)
+ (get-bytevector-n port (- %word-size remainder)))
+ (match-cell-words port (rest ...) body)))
+ ((_ port (name rest ...) body)
+ (let ((name (get-word port)))
+ (match-cell-words port (rest ...) body)))
+ ((_ port () body)
+ body)))
+
+(define-syntax match-bit-pattern
+ (syntax-rules (& || = _)
+ ((match-bit-pattern bits ((a || b) & n = c) consequent alternate)
+ (let ((tag (logand bits n)))
+ (if (= tag c)
+ (let ((b tag)
+ (a (logand bits (bitwise-not n))))
+ consequent)
+ alternate)))
+ ((match-bit-pattern bits (x & n = c) consequent alternate)
+ (let ((tag (logand bits n)))
+ (if (= tag c)
+ (let ((x bits))
+ consequent)
+ alternate)))
+ ((match-bit-pattern bits (_ & n = c) consequent alternate)
+ (let ((tag (logand bits n)))
+ (if (= tag c)
+ consequent
+ alternate)))
+ ((match-bit-pattern bits ((a << n) || c) consequent alternate)
+ (let ((tag (bitwise-and bits (- (expt 2 n) 1))))
+ (if (= tag c)
+ (let ((a (arithmetic-shift bits (- n))))
+ consequent)
+ alternate)))))
+
+(define-syntax match-cell-clauses
+ (syntax-rules ()
+ ((_ port tag (((tag-pattern thing ...) body) rest ...))
+ (match-bit-pattern tag tag-pattern
+ (match-cell-words port (thing ...) body)
+ (match-cell-clauses port tag (rest ...))))
+ ((_ port tag ())
+ (inferior-object 'unmatched-tag tag))))
+
+(define-syntax match-cell
+ (syntax-rules ()
+ "Match a cell---i.e., a non-immediate value other than a pair. The
+cell's contents are read from PORT."
+ ((_ port (pattern body ...) ...)
+ (let ((port* port)
+ (tag (get-word port)))
+ (match-cell-clauses port* tag
+ ((pattern (begin body ...))
+ ...))))))
+
+(define-syntax match-scm-clauses
+ (syntax-rules ()
+ ((_ bits
+ (bit-pattern body ...)
+ rest ...)
+ (match-bit-pattern bits bit-pattern
+ (begin body ...)
+ (match-scm-clauses bits rest ...)))
+ ((_ bits)
+ 'unmatched-scm)))
+
+(define-syntax match-scm
+ (syntax-rules ()
+ "Match BITS, an integer representation of an 'SCM' value, against
+CLAUSES. Each clause must have the form:
+
+ (PATTERN BODY ...)
+
+PATTERN is a bit pattern that may specify bitwise operations on BITS to
+determine if it matches. TEMPLATE specify the name of the variable to bind
+the matching bits, possibly with bitwise operations to extract it from BITS."
+ ((_ bits clauses ...)
+ (let ((bits* bits))
+ (match-scm-clauses bits* clauses ...)))))
+
+
+;;;
+;;; Tags---keep in sync with libguile/tags.h!
+;;;
+
+;; Immediate values.
+(define %tc2-int 2)
+(define %tc3-imm24 4)
+
+(define %tc3-cons 0)
+(define %tc3-int1 %tc2-int)
+(define %tc3-int2 (+ %tc2-int 4))
+
+(define %tc8-char (+ 8 %tc3-imm24))
+(define %tc8-flag (+ %tc3-imm24 0))
+
+;; Cell types.
+(define %tc3-struct 1)
+(define %tc7-symbol 5)
+(define %tc7-vector 13)
+(define %tc7-string 21)
+(define %tc7-number 23)
+(define %tc7-hashtable 29)
+(define %tc7-pointer 31)
+(define %tc7-fluid 37)
+(define %tc7-stringbuf 39)
+(define %tc7-dynamic-state 45)
+(define %tc7-frame 47)
+(define %tc7-objcode 53)
+(define %tc7-vm 55)
+(define %tc7-vm-continuation 71)
+(define %tc7-bytevector 77)
+(define %tc7-program 79)
+(define %tc7-port 125)
+(define %tc7-smob 127)
+
+(define %tc16-bignum (+ %tc7-number (* 1 256)))
+(define %tc16-real (+ %tc7-number (* 2 256)))
+(define %tc16-complex (+ %tc7-number (* 3 256)))
+(define %tc16-fraction (+ %tc7-number (* 4 256)))
+
+
+;; "Stringbufs".
+(define-record-type <stringbuf>
+ (stringbuf string)
+ stringbuf?
+ (string stringbuf-contents))
+
+(set-record-type-printer! <stringbuf>
+ (lambda (stringbuf port)
+ (display "#<stringbuf " port)
+ (write (stringbuf-contents stringbuf) port)
+ (display "#>" port)))
+
+;; Structs.
+(define-record-type <inferior-struct>
+ (inferior-struct name fields)
+ inferior-struct?
+ (name inferior-struct-name)
+ (fields inferior-struct-fields set-inferior-struct-fields!))
+
+(define print-inferior-struct
+ (let ((%printed-struct (make-parameter vlist-null)))
+ (lambda (struct port)
+ (if (vhash-assq struct (%printed-struct))
+ (format port "#-1#")
+ (begin
+ (format port "#<struct ~a"
+ (inferior-struct-name struct))
+ (parameterize ((%printed-struct
+ (vhash-consq struct #t (%printed-struct))))
+ (for-each (lambda (field)
+ (if (eq? field struct)
+ (display " #0#" port)
+ (format port " ~s" field)))
+ (inferior-struct-fields struct)))
+ (format port " ~x>" (object-address struct)))))))
+
+(set-record-type-printer! <inferior-struct> print-inferior-struct)
+
+;; Fluids.
+(define-record-type <inferior-fluid>
+ (inferior-fluid number value)
+ inferior-fluid?
+ (number inferior-fluid-number)
+ (value inferior-fluid-value))
+
+(set-record-type-printer! <inferior-fluid>
+ (lambda (fluid port)
+ (match fluid
+ (($ <inferior-fluid> number)
+ (format port "#<fluid ~a ~x>"
+ number
+ (object-address fluid))))))
+
+;; Object type to represent complex objects from the inferior process that
+;; cannot be really converted to usable Scheme objects in the current
+;; process.
+(define-record-type <inferior-object>
+ (%inferior-object kind sub-kind address)
+ inferior-object?
+ (kind inferior-object-kind)
+ (sub-kind inferior-object-sub-kind)
+ (address inferior-object-address))
+
+(define inferior-object
+ (case-lambda
+ "Return an object representing an inferior object at ADDRESS, of type
+KIND/SUB-KIND."
+ ((kind address)
+ (%inferior-object kind #f address))
+ ((kind sub-kind address)
+ (%inferior-object kind sub-kind address))))
+
+(set-record-type-printer! <inferior-object>
+ (lambda (io port)
+ (match io
+ (($ <inferior-object> kind sub-kind address)
+ (format port "#<~a ~:[~*~;~a ~]~x>"
+ kind sub-kind sub-kind
+ address)))))
+
+(define (inferior-smob backend type-number address)
+ "Return an object representing the SMOB at ADDRESS whose type is
+TYPE-NUMBER."
+ (inferior-object 'smob
+ (or (type-number->name backend 'smob type-number)
+ type-number)
+ 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)
+ address))
+
+(define %visited-cells
+ ;; Vhash of mapping addresses of already visited cells to the
+ ;; corresponding inferior object. This is used to detect and represent
+ ;; cycles.
+ (make-parameter vlist-null))
+
+(define-syntax visited
+ (syntax-rules (->)
+ ((_ (address -> object) body ...)
+ (parameterize ((%visited-cells (vhash-consv address object
+ (%visited-cells))))
+ body ...))))
+
+(define (address->inferior-struct address vtable-data-address backend)
+ "Read the struct at ADDRESS using BACKEND. Return an 'inferior-struct'
+object representing it."
+ (define %vtable-layout-index 0)
+ (define %vtable-name-index 5)
+
+ (let* ((layout-address (+ vtable-data-address
+ (* %vtable-layout-index %word-size)))
+ (layout-bits (dereference-word backend layout-address))
+ (layout (scm->object layout-bits backend))
+ (name-address (+ vtable-data-address
+ (* %vtable-name-index %word-size)))
+ (name-bits (dereference-word backend name-address))
+ (name (scm->object name-bits backend)))
+ (if (symbol? layout)
+ (let* ((layout (symbol->string layout))
+ (len (/ (string-length layout) 2))
+ (slots (dereference-word backend (+ address %word-size)))
+ (port (memory-port backend slots (* len %word-size)))
+ (fields (get-bytevector-n port (* len %word-size)))
+ (result (inferior-struct name #f)))
+
+ ;; Keep track of RESULT so callees can refer to it if we are
+ ;; decoding a circular struct.
+ (visited (address -> result)
+ (let ((values (map (cut scm->object <> backend)
+ (bytevector->uint-list fields
+ (native-endianness)
+ %word-size))))
+ (set-inferior-struct-fields! result values)
+ result)))
+ (inferior-object 'invalid-struct address))))
+
+(define* (cell->object address #:optional (backend %ffi-memory-backend))
+ "Return an object representing the object at ADDRESS, reading from memory
+using BACKEND."
+ (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object
+ (let ((port (memory-port backend address)))
+ (match-cell port
+ (((vtable-data-address & 7 = %tc3-struct))
+ (address->inferior-struct address
+ (- vtable-data-address %tc3-struct)
+ backend))
+ (((_ & #x7f = %tc7-symbol) buf hash props)
+ (match (cell->object buf backend)
+ (($ <stringbuf> string)
+ (string->symbol string))))
+ (((_ & #x7f = %tc7-string) buf start len)
+ (match (cell->object buf backend)
+ (($ <stringbuf> string)
+ (substring string start (+ start len)))))
+ (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len))
+ (stringbuf (bytevector->string buf "ISO-8859-1")))
+ (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf))
+ len (bytevector buf (* 4 len)))
+ (stringbuf (bytevector->string buf "UTF-32LE")))
+ (((_ & #x7f = %tc7-bytevector) len address)
+ (let ((bv-port (memory-port backend address len)))
+ (get-bytevector-all bv-port)))
+ ((((len << 7) || %tc7-vector) weakv-data)
+ (let* ((len (arithmetic-shift len -1))
+ (words (get-bytevector-n port (* len %word-size)))
+ (vector (make-vector len)))
+ (visited (address -> vector)
+ (fold (lambda (element index)
+ (vector-set! vector index element)
+ (+ 1 index))
+ 0
+ (map (cut scm->object <> backend)
+ (bytevector->uint-list words (native-endianness)
+ %word-size)))
+ vector)))
+ ((((n << 8) || %tc7-fluid) init-value)
+ (inferior-fluid n #f)) ; TODO: show current value
+ (((_ & #x7f = %tc7-dynamic-state))
+ (inferior-object 'dynamic-state address))
+ ((((flags+type << 8) || %tc7-port))
+ (inferior-port backend (logand flags+type #xff) address))
+ (((_ & #x7f = %tc7-program))
+ (inferior-object 'program address))
+ (((_ & #xffff = %tc16-bignum))
+ (inferior-object 'bignum address))
+ (((_ & #xffff = %tc16-real) pad)
+ (let* ((address (+ address (* 2 %word-size)))
+ (port (memory-port backend address (sizeof double)))
+ (words (get-bytevector-n port (sizeof double))))
+ (bytevector-ieee-double-ref words 0 (native-endianness))))
+ (((_ & #x7f = %tc7-number) mpi)
+ (inferior-object 'number address))
+ (((_ & #x7f = %tc7-hashtable) buckets meta-data unused)
+ (inferior-object 'hash-table address))
+ (((_ & #x7f = %tc7-pointer) address)
+ (make-pointer address))
+ (((_ & #x7f = %tc7-objcode))
+ (inferior-object 'objcode address))
+ (((_ & #x7f = %tc7-vm))
+ (inferior-object 'vm address))
+ (((_ & #x7f = %tc7-vm-continuation))
+ (inferior-object 'vm-continuation address))
+ ((((smob-type << 8) || %tc7-smob) word1)
+ (inferior-smob backend smob-type address))))))
+
+
+(define* (scm->object bits #:optional (backend %ffi-memory-backend))
+ "Return the Scheme object corresponding to BITS, the bits of an 'SCM'
+object."
+ (match-scm bits
+ (((integer << 2) || %tc2-int)
+ integer)
+ ((address & 6 = %tc3-cons)
+ (let* ((type (dereference-word backend address))
+ (pair? (not (bit-set? 0 type))))
+ (if pair?
+ (or (and=> (vhash-assv address (%visited-cells)) cdr)
+ (let ((car type)
+ (cdrloc (+ address %word-size))
+ (pair (cons *unspecified* *unspecified*)))
+ (visited (address -> pair)
+ (set-car! pair (scm->object car backend))
+ (set-cdr! pair
+ (scm->object (dereference-word backend cdrloc)
+ backend))
+ pair)))
+ (cell->object address backend))))
+ (((char << 8) || %tc8-char)
+ (integer->char char))
+ (((flag << 8) || %tc8-flag)
+ (case flag
+ ((0) #f)
+ ((1) #nil)
+ ((3) '())
+ ((4) #t)
+ ((8) (if #f #f))
+ ((9) (inferior-object 'undefined bits))
+ ((10) (eof-object))
+ ((11) (inferior-object 'unbound bits))))))
+
+;;; Local Variables:
+;;; eval: (put 'match-scm 'scheme-indent-function 1)
+;;; eval: (put 'match-cell 'scheme-indent-function 1)
+;;; eval: (put 'visited 'scheme-indent-function 1)
+;;; End:
+
+;;; types.scm ends here
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 7578bf5..41feb15 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -163,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/threads.test \
tests/time.test \
tests/tree-il.test \
+ tests/types.test \
tests/version.test \
tests/vlist.test \
tests/weaks.test \
diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test
new file mode 100644
index 0000000..e05ab11
--- /dev/null
+++ b/test-suite/tests/types.test
@@ -0,0 +1,154 @@
+;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8;
-*-
+;;;;
+;;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;;
+;;;; This file is part of GNU Guile.
+;;;;
+;;;; GNU Guile is free software; you can redistribute it and/or modify it
+;;;; under the terms of the GNU Lesser General Public License as published by
+;;;; the Free Software Foundation; either version 3 of the License, or (at
+;;;; your option) any later version.
+;;;;
+;;;; GNU Guile is distributed in the hope that it will be useful, but
+;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public License
+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-types)
+ #:use-module (test-suite lib)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (system foreign)
+ #:use-module (system vm vm)
+ #:use-module (system base types))
+
+(define-syntax test-cloneable
+ (syntax-rules ()
+ "Test whether each simple OBJECT is properly decoded."
+ ((_ object rest ...)
+ (begin
+ (let ((obj object))
+ (pass-if-equal (object->string obj) obj
+ (scm->object (object-address obj))))
+ (test-cloneable rest ...)))
+ ((_)
+ *unspecified*)))
+
+;; Test objects that can be directly cloned.
+(with-test-prefix "clonable objects"
+ (test-cloneable
+ #t #f #nil (if #f #f) (eof-object)
+ 42 (expt 2 28) 3.14
+ "narrow string" "wide ÏÏÏινγ"
+ 'symbol 'λ
+ ;; NB: keywords are SMOBs.
+ '(2 . 3) (iota 123) '(1 (two ("three")))
+ #(1 2 3) #(foo bar baz)
+ #vu8(255 254 253)
+ (make-pointer 123) (make-pointer #xdeadbeef)))
+
+;; Circular objects cannot be compared with 'equal?', so here's their
+;; home.
+(with-test-prefix "clonable circular objects"
+
+ (pass-if "list"
+ (let* ((lst (circular-list 0 1))
+ (result (scm->object (object-address lst))))
+ (match result
+ ((0 1 . self)
+ (eq? self result)))))
+
+ (pass-if "vector"
+ (define (circular-vector)
+ (let ((v (make-vector 3 'hey)))
+ (vector-set! v 2 v)
+ v))
+
+ (let* ((vec (circular-vector))
+ (result (scm->object (object-address vec))))
+ (match result
+ (#('hey 'hey self)
+ (eq? self result))))))
+
+(define-syntax test-inferior-objects
+ (syntax-rules ()
+ "Test whether each OBJECT is recognized and wrapped as an
+'inferior-object'."
+ ((_ (object kind sub-kind-pattern) rest ...)
+ (begin
+ (let ((obj object))
+ (pass-if (object->string obj)
+ (let ((result (scm->object (object-address obj))))
+ (and (inferior-object? result)
+ (eq? 'kind (inferior-object-kind result))
+ (match (inferior-object-sub-kind result)
+ (sub-kind-pattern #t)
+ (_ #f))))))
+ (test-inferior-objects rest ...)))
+ ((_)
+ *unspecified*)))
+
+(with-test-prefix "opaque objects"
+ (test-inferior-objects
+ ((make-guardian) smob (? integer?))
+ (#:keyword smob (? integer?))
+ ((%make-void-port "w") port (? integer?))
+ ((open-input-string "hello") port (? integer?))
+ ((lambda () #t) program _)
+ ((the-vm) vm _)
+ ((expt 2 70) bignum _))
+
+ (pass-if "fluid"
+ (let ((fluid (make-fluid)))
+ (inferior-fluid? (scm->object (object-address fluid))))))
+
+(define-record-type <some-struct>
+ (some-struct x y z)
+ some-struct?
+ (x struct-x set-struct-x!)
+ (y struct-y)
+ (z struct-z))
+
+(with-test-prefix "structs"
+
+ (pass-if-equal "simple struct"
+ '(<some-struct> a b c)
+ (let* ((struct (some-struct 'a 'b 'c))
+ (result (scm->object (object-address struct))))
+ (and (inferior-struct? result)
+ (cons (inferior-struct-name result)
+ (inferior-struct-fields result)))))
+
+ (pass-if "circular struct"
+ (let ((struct (some-struct #f 'b 'c)))
+ (set-struct-x! struct struct)
+ (let ((result (scm->object (object-address struct))))
+ (and (inferior-struct? result)
+ (eq? (inferior-struct-name result) '<some-struct>)
+ (match (inferior-struct-fields result)
+ ((self 'b 'c)
+ (eq? self result)))))))
+
+ (pass-if "printed circular struct"
+ (->bool
+ (string-match "#<struct <some-struct> #0# b c [[:xdigit:]]+>"
+ (let ((struct (some-struct #f 'b 'c)))
+ (set-struct-x! struct struct)
+ (object->string (scm->object (object-address struct)))))))
+
+ (pass-if "printed deep circular struct"
+ (->bool
+ (string-match
+ "#<struct <some-struct> \
+#<struct <some-struct> #-1# 3 4 [[:xdigit:]]+> \
+1 2 [[:xdigit:]]+>"
+ (let* ((a (some-struct #f 1 2))
+ (b (some-struct a 3 4)))
+ (set-struct-x! a b)
+ (object->string (scm->object (object-address a))))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-212-gae8d8a8,
Ludovic Courtès <=