[Guile-commits] 03/07: Add (system base types internal).

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 38c6f6fabf7161de052d0784d5e347f984cff04a
Author: Andy Wingo <address@hidden>
Date:   Wed Oct 25 12:24:49 2017 +0200

    Add (system base types internal).
    
    * module/system/base/types/internal.scm: New file, extracted
      from (system base types).
    * module/system/base/types.scm: Use (system base types internal) and
      adapt to %tc1-pair, %tc2-inum, and %tc3-heap-object name changes.
    * module/Makefile.am (SOURCES):
    * am/bootstrap.am (SOURCES): Add new file.
---
 am/bootstrap.am                       |   3 +-
 module/Makefile.am                    |   3 +-
 module/system/base/types.scm          |  54 +------------
 module/system/base/types/internal.scm | 140 ++++++++++++++++++++++++++++++++++
 4 files changed, 148 insertions(+), 52 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index e0d4764..d848745 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -1,5 +1,5 @@
 ##     Copyright (C) 2009, 2010, 2011, 2012, 2013,
-##        2014, 2015 Free Software Foundation, Inc.
+##        2014, 2015, 2017 Free Software Foundation, Inc.
 ##
 ##   This file is part of GNU Guile.
 ##
@@ -121,6 +121,7 @@ SOURCES =                                   \
   system/base/message.scm                      \
   system/base/target.scm                       \
   system/base/types.scm                                \
+  system/base/types/internal.scm               \
   system/base/ck.scm                           \
                                                \
   ice-9/boot-9.scm                             \
diff --git a/module/Makefile.am b/module/Makefile.am
index 8a8eab5..ef8e7c1 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -1,7 +1,7 @@
 ## Process this file with automake to produce Makefile.in.
 ##
 ##     Copyright (C) 2009, 2010, 2011, 2012, 2013,
-##        2014, 2015 Free Software Foundation, Inc.
+##        2014, 2015, 2017 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -304,6 +304,7 @@ SOURCES =                                   \
   system/base/message.scm                      \
   system/base/target.scm                       \
   system/base/types.scm                                \
+  system/base/types/internal.scm               \
   system/base/ck.scm                           \
                                                \
   system/foreign.scm                           \
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index daf8bdf..e8f51ba 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -29,6 +29,7 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 vlist)
   #:use-module (system foreign)
+  #:use-module (system base types internal)
   #:export (%word-size
 
             memory-backend
@@ -225,53 +226,6 @@ the matching bits, possibly with bitwise operations to 
extract it from 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 #x01)
-(define %tc7-symbol #x05)
-(define %tc7-variable #x07)
-(define %tc7-vector #x0d)
-(define %tc7-wvect #x0f)
-(define %tc7-string #x15)
-(define %tc7-number #x17)
-(define %tc7-hashtable #x1d)
-(define %tc7-pointer #x1f)
-(define %tc7-fluid #x25)
-(define %tc7-stringbuf #x27)
-(define %tc7-dynamic-state #x2d)
-(define %tc7-frame #x2f)
-(define %tc7-keyword #x35)
-(define %tc7-syntax #x3d)
-(define %tc7-program #x45)
-(define %tc7-vm-continuation #x47)
-(define %tc7-bytevector #x4d)
-(define %tc7-weak-set #x55)
-(define %tc7-weak-table #x57)
-(define %tc7-array #x5d)
-(define %tc7-bitvector #x5f)
-(define %tc7-port #x7d)
-(define %tc7-smob #x77)
-
-(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)
@@ -489,11 +443,11 @@ using BACKEND."
   "Return the Scheme object corresponding to BITS, the bits of an 'SCM'
 object."
   (match-scm bits
-    (((integer << 2) || %tc2-int)
+    (((integer << 2) || %tc2-inum)
      integer)
-    ((address & 6 = %tc3-cons)
+    ((address & 7 = %tc3-heap-object)
      (let* ((type  (dereference-word backend address))
-            (pair? (not (bit-set? 0 type))))
+            (pair? (= (logand type #b1) %tc1-pair)))
        (if pair?
            (or (and=> (vhash-assv address (%visited-cells)) cdr)
                (let ((car    type)
diff --git a/module/system/base/types/internal.scm 
b/module/system/base/types/internal.scm
new file mode 100644
index 0000000..41d55ef
--- /dev/null
+++ b/module/system/base/types/internal.scm
@@ -0,0 +1,140 @@
+;;; Details on internal value representation.
+;;; Copyright (C) 2014, 2015, 2017 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 internal)
+  #:export (;; Immediate tags.
+            %tc2-inum
+            %tc3-imm24
+            %tc3-heap-object
+            %tc8-char
+            %tc8-flag
+            %tc16-false
+            %tc16-nil
+            %tc16-eol
+            %tc16-true
+            %tc16-unspecified
+            %tc16-undefined
+            %tc16-eof
+
+            ;; Heap object tags (cell types).
+            %tc1-pair
+            %tc3-struct
+            %tc7-symbol
+            %tc7-variable
+            %tc7-vector
+            %tc7-wvect
+            %tc7-string
+            %tc7-number
+            %tc7-hashtable
+            %tc7-pointer
+            %tc7-fluid
+            %tc7-stringbuf
+            %tc7-dynamic-state
+            %tc7-frame
+            %tc7-keyword
+            %tc7-syntax
+            %tc7-program
+            %tc7-vm-continuation
+            %tc7-bytevector
+            %tc7-weak-set
+            %tc7-weak-table
+            %tc7-array
+            %tc7-bitvector
+            %tc7-port
+            %tc7-smob
+            %tc16-bignum
+            %tc16-real
+            %tc16-complex
+            %tc16-fraction))
+
+;;; Commentary:
+;;;
+;;; Tag values used to represent Scheme values, internally to Guile.
+;;;
+;;; Code:
+
+
+;;;
+;;; Tags---keep in sync with libguile/tags.h!
+;;;
+
+;; Immediate tags.
+(eval-when (expand load eval)
+  (define %tc2-inum #b10)
+  (define %tc3-imm24 #b100)
+  (define %tc3-heap-object #b000)
+
+  (define %tc8-flag (+ %tc3-imm24 0))
+  (define %tc8-char (+ %tc3-imm24 8))
+
+  (define %tc16-false       (+ (ash #b0000 8) %tc8-flag))
+  (define %tc16-nil         (+ (ash #b0001 8) %tc8-flag))
+  (define %tc16-eol         (+ (ash #b0011 8) %tc8-flag))
+  (define %tc16-true        (+ (ash #b0100 8) %tc8-flag))
+  (define %tc16-unspecified (+ (ash #b1000 8) %tc8-flag))
+  (define %tc16-undefined   (+ (ash #b1001 8) %tc8-flag))
+  (define %tc16-eof         (+ (ash #b1010 8) %tc8-flag)))
+
+;; See discussion in tags.h and boolean.h.
+(eval-when (expand)
+  (let ()
+    (define (exactly-one-bit-set? x)
+      (and (not (zero? x)) (zero? (logand x (1- x)))))
+    (define (exactly-two-bits-set? x)
+      (exactly-one-bit-set? (logand x (1- x))))
+    (define (bits-differ-in-exactly-one-bit-position? a b)
+      (exactly-one-bit-set? (logxor a b)))
+    (define (bits-differ-in-exactly-two-bit-positions? a b)
+      (exactly-two-bits-set? (logxor a b)))
+
+    (unless (bits-differ-in-exactly-one-bit-position? %tc16-eol %tc16-nil)
+      (error "expected #nil and '() to differ in exactly one bit position"))
+    (unless (bits-differ-in-exactly-one-bit-position? %tc16-false %tc16-nil)
+      (error "expected #f and '() to differ in exactly one bit position"))
+    (unless (bits-differ-in-exactly-two-bit-positions? %tc16-false %tc16-eol)
+      (error "expected #f and '() to differ in exactly two bit positions"))))
+
+;; Heap object tags (cell types).
+(define %tc1-pair #b0)
+(define %tc3-struct #x01)
+(define %tc7-symbol #x05)
+(define %tc7-variable #x07)
+(define %tc7-vector #x0d)
+(define %tc7-wvect #x0f)
+(define %tc7-string #x15)
+(define %tc7-number #x17)
+(define %tc7-hashtable #x1d)
+(define %tc7-pointer #x1f)
+(define %tc7-fluid #x25)
+(define %tc7-stringbuf #x27)
+(define %tc7-dynamic-state #x2d)
+(define %tc7-frame #x2f)
+(define %tc7-keyword #x35)
+(define %tc7-syntax #x3d)
+(define %tc7-program #x45)
+(define %tc7-vm-continuation #x47)
+(define %tc7-bytevector #x4d)
+(define %tc7-weak-set #x55)
+(define %tc7-weak-table #x57)
+(define %tc7-array #x5d)
+(define %tc7-bitvector #x5f)
+(define %tc7-port #x7d)
+(define %tc7-smob #x77)
+
+(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)))