From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 24 Oct 2006 04:08:58 +0000 (+0000)
Subject: Store bucky bits in variables, and provide operations to test and set
X-Git-Tag: 20090517-FFI~881
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ede88b745aacfce9763d8bf02e366ba79ae827a;p=mit-scheme.git

Store bucky bits in variables, and provide operations to test and set
them.  This should provide a little more abstraction than at present.
---

diff --git a/v7/src/runtime/char.scm b/v7/src/runtime/char.scm
index 245b33feb..c61fb8f4e 100644
--- a/v7/src/runtime/char.scm
+++ b/v7/src/runtime/char.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: char.scm,v 14.26 2005/06/03 13:32:16 cph Exp $
+$Id: char.scm,v 14.27 2006/10/24 04:08:46 cph Exp $
 
 Copyright 1986,1987,1988,1991,1995,1997 Massachusetts Institute of Technology
-Copyright 1998,2001,2003,2004,2005 Massachusetts Institute of Technology
+Copyright 1998,2001,2003,2004,2005,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -66,6 +66,28 @@ USA.
   (guarantee-char char 'CHAR-BITS)
   (%char-bits char))
 
+(define (char-bits-set? bits char)
+  (guarantee-limited-index-fixnum bits char-bits-limit 'CHAR-BITS-SET?)
+  (guarantee-char char 'CHAR-BITS-SET?)
+  (fix:= bits (fix:and (%char-bits char) bits)))
+
+(define (char-bits-clear? bits char)
+  (guarantee-limited-index-fixnum bits char-bits-limit 'CHAR-BITS-CLEAR?)
+  (guarantee-char char 'CHAR-BITS-CLEAR?)
+  (fix:= 0 (fix:and (%char-bits char) bits)))
+
+(define (set-char-bits bits char)
+  (guarantee-limited-index-fixnum bits char-bits-limit 'SET-CHAR-BITS)
+  (guarantee-char char 'SET-CHAR-BITS)
+  (%make-char (%char-code char)
+	      (fix:or (%char-bits char) bits)))
+
+(define (clear-char-bits bits char)
+  (guarantee-limited-index-fixnum bits char-bits-limit 'CLEAR-CHAR-BITS)
+  (guarantee-char char 'CLEAR-CHAR-BITS)
+  (%make-char (%char-code char)
+	      (fix:andc (%char-bits char) bits)))
+
 (define (char-ascii? char)
   (guarantee-char char 'CHAR-ASCII?)
   (let ((n (char->integer char)))
@@ -353,4 +375,9 @@ USA.
   '((#x01 "M" "meta")
     (#x02 "C" "control" "ctrl")
     (#x04 "S" "super")
-    (#x08 "H" "hyper")))
\ No newline at end of file
+    (#x08 "H" "hyper")))
+
+(define char-bit:meta #x01)
+(define char-bit:control #x02)
+(define char-bit:super #x04)
+(define char-bit:hyper #x08)
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 3c1123312..95183d3ef 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.598 2006/10/04 19:02:26 cph Exp $
+$Id: runtime.pkg,v 14.599 2006/10/24 04:08:58 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -973,8 +973,14 @@ USA.
 	  char->integer
 	  char->name
 	  char-ascii?
+	  char-bit:control
+	  char-bit:hyper
+	  char-bit:meta
+	  char-bit:super
 	  char-bits
+	  char-bits-clear?
 	  char-bits-limit
+	  char-bits-set?
 	  char-ci<=?
 	  char-ci<?
 	  char-ci=?
@@ -992,6 +998,7 @@ USA.
 	  char>?
 	  char?
 	  chars->ascii
+	  clear-char-bits
 	  code->char
 	  digit->char
 	  error:not-char
@@ -1001,7 +1008,8 @@ USA.
 	  integer->char
 	  make-char
 	  name->char
-	  radix?)
+	  radix?
+	  set-char-bits)
   (export (runtime string)
 	  %char<?
 	  downcase-table