From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 28 Feb 2003 04:36:04 +0000 (+0000)
Subject: Change character representation to have 21 code bits and 4 bucky bits.
X-Git-Tag: 20090517-FFI~2014
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=653a36d70c088ff70f6fdfcd372244558dcaa68b;p=mit-scheme.git

Change character representation to have 21 code bits and 4 bucky bits.
This new representation allows all Unicode characters to be
represented.
---

diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h
index 4d000c57b..2d077446c 100644
--- a/v7/src/microcode/object.h
+++ b/v7/src/microcode/object.h
@@ -1,8 +1,10 @@
 /* -*-C-*-
 
-$Id: object.h,v 9.53 2003/02/14 18:28:21 cph Exp $
+$Id: object.h,v 9.54 2003/02/28 04:34:38 cph Exp $
 
-Copyright (c) 1987-2001 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1989,1990,1992 Massachusetts Institute of Technology
+Copyright 1993,1995,1997,1998,2000,2001 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -338,13 +340,13 @@ extern SCHEME_OBJECT * memory_base;
 /* Character Operations */
 
 #define ASCII_LENGTH CHAR_BIT	/* CHAR_BIT in config.h - 8 for unix  */
-#define CODE_LENGTH 16
-#define BITS_LENGTH 5
-#define MIT_ASCII_LENGTH 21
+#define CODE_LENGTH 21
+#define BITS_LENGTH 4
+#define MIT_ASCII_LENGTH 25
 
-#define CHAR_BITS_META 		01
-#define CHAR_BITS_CONTROL 	02
-#define CHAR_BITS_CONTROL_META	03
+#define CHAR_BITS_META 		0x1
+#define CHAR_BITS_CONTROL 	0x2
+#define CHAR_BITS_CONTROL_META	0x3
 
 #define MAX_ASCII (1L << ASCII_LENGTH)
 #define MAX_CODE (1L << CODE_LENGTH)
diff --git a/v7/src/runtime/char.scm b/v7/src/runtime/char.scm
index 14ceca619..8f87fd6bf 100644
--- a/v7/src/runtime/char.scm
+++ b/v7/src/runtime/char.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: char.scm,v 14.15 2003/02/14 18:28:32 cph Exp $
+$Id: char.scm,v 14.16 2003/02/28 04:36:04 cph Exp $
 
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1991,1995,1997 Massachusetts Institute of Technology
+Copyright 1998,2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -33,36 +34,31 @@ USA.
   char->integer
   integer->char)
 
-(define-integrable char-code-limit #x10000)
-(define-integrable char-bits-limit #x20)
-(define-integrable char-integer-limit #x200000)
+(define-integrable char-code-limit #x200000)
+(define-integrable char-bits-limit #x10)
+(define-integrable char-integer-limit #x2000000)
 
 (define-integrable (%make-char code bits)
-  (integer->char (fix:or (fix:lsh bits 16) code)))
+  (integer->char (fix:or (fix:lsh bits 21) code)))
 
 (define-integrable (%char-code char)
-  (fix:and (char->integer char) #xFFFF))
+  (fix:and (char->integer char) #x1FFFFF))
 
 (define-integrable (%char-bits char)
-  (fix:lsh (fix:and (char->integer char) #x1F0000) -16))
+  (fix:lsh (char->integer char) -21))
 
 (define-integrable (guarantee-char char procedure)
   (if (not (char? char))
       (error:wrong-type-argument char "character" procedure)))
 
 (define (make-char code bits)
-  (if (not (index-fixnum? code))
-      (error:wrong-type-argument code "index fixnum" 'MAKE-CHAR))
-  (if (not (fix:< code char-code-limit))
-      (error:bad-range-argument code 'MAKE-CHAR))
-  (if (not (index-fixnum? bits))
-      (error:wrong-type-argument bits "index fixnum" 'MAKE-CHAR))
-  (if (not (fix:< bits char-bits-limit))
-      (error:bad-range-argument bits 'MAKE-CHAR))
+  (guarantee-limited-index-fixnum code char-code-limit 'MAKE-CHAR)
+  (guarantee-limited-index-fixnum bits char-bits-limit 'MAKE-CHAR)
   (%make-char code bits))
 
 (define (code->char code)
-  (make-char code 0))
+  (guarantee-limited-index-fixnum code char-code-limit 'CODE->CHAR)
+  (%make-char code 0))
 
 (define (char-code char)
   (guarantee-char char 'CHAR-CODE)
@@ -85,12 +81,9 @@ USA.
 	(error:bad-range-argument char 'CHAR->ASCII))
     n))
 
-(define (ascii->char n)
-  (if (not (index-fixnum? n))
-      (error:wrong-type-argument n "index fixnum" 'ASCII->CHAR))
-  (if (not (fix:< n 256))
-      (error:bad-range-argument n 'ASCII->CHAR))
-  (%make-char n 0))
+(define (ascii->char code)
+  (guarantee-limited-index-fixnum code 256 'ASCII->CHAR)
+  (%make-char code 0))
 
 (define (chars->ascii chars)
   (map char->ascii chars))
@@ -203,19 +196,24 @@ USA.
   (set! lower-a-code (fix:- (char->integer #\a) 10))
   (initialize-case-conversions!))
 
+(define (radix? object)
+  (and (index-fixnum? object)
+       (fix:<= 2 object)
+       (fix:<= object 36)))
+
+(define (guarantee-radix object caller)
+  (if (not (radix? object))
+      (error:wrong-type-argument object "radix" caller)))
+
 (define (digit->char digit #!optional radix)
-  (if (not (index-fixnum? digit))
-      (error:wrong-type-argument digit "digit" 'DIGIT->CHAR))
-  (and (fix:<= 0 digit)
-       (fix:< digit
-	      (cond ((default-object? radix)
-		     10)
-		    ((and (fix:fixnum? radix)
-			  (fix:<= 2 radix) (fix:<= radix 36))
-		     radix)
-		    (else
-		     (error:wrong-type-argument radix "radix" 'DIGIT->CHAR))))
-       (string-ref "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" digit)))
+  (guarantee-limited-index-fixnum digit
+				  (if (default-object? radix)
+				      10
+				      (begin
+					(guarantee-radix radix 'DIGIT->CHAR)
+					radix))
+				  'DIGIT->CHAR)
+  (string-ref "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" digit))
 
 (define (char->digit char #!optional radix)
   (guarantee-char char 'CHAR->DIGIT)
@@ -391,7 +389,4 @@ USA.
     ("S" . #x04)
     ("Super" . #x04)
     ("H" . #x08)
-    ("Hyper" . #x08)
-    ("T" . #x10)
-    ("Top" . #x10)
-    ))
\ No newline at end of file
+    ("Hyper" . #x08)))
\ No newline at end of file