diff options
author | Andy Wingo <wingo@pobox.com> | 2017-10-25 12:24:49 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-10-25 12:55:30 +0200 |
commit | 38c6f6fabf7161de052d0784d5e347f984cff04a (patch) | |
tree | 02b3d137e6b7af3e373e1e09c150d007b40b7962 | |
parent | a7f9c32816f3569a60b088171a9a4313ed0dee70 (diff) | |
download | guile-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.
-rw-r--r-- | am/bootstrap.am | 3 | ||||
-rw-r--r-- | module/Makefile.am | 3 | ||||
-rw-r--r-- | module/system/base/types.scm | 54 | ||||
-rw-r--r-- | 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 e0d4764f5..d84874563 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 8a8eab583..ef8e7c117 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 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))) |