summaryrefslogtreecommitdiff
path: root/module/system/base
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-10-25 12:24:49 +0200
committerAndy Wingo <wingo@pobox.com>2017-10-25 12:55:30 +0200
commit38c6f6fabf7161de052d0784d5e347f984cff04a (patch)
tree02b3d137e6b7af3e373e1e09c150d007b40b7962 /module/system/base
parenta7f9c32816f3569a60b088171a9a4313ed0dee70 (diff)
downloadguile-38c6f6fabf7161de052d0784d5e347f984cff04a.tar.gz
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.
Diffstat (limited to 'module/system/base')
-rw-r--r--module/system/base/types.scm54
-rw-r--r--module/system/base/types/internal.scm140
2 files changed, 144 insertions, 50 deletions
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index daf8bdfe2..e8f51ba9a 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 000000000..41d55efb7
--- /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)))