From 8ede88b745aacfce9763d8bf02e366ba79ae827a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 24 Oct 2006 04:08:58 +0000
Subject: [PATCH] Store bucky bits in variables, and provide operations to test
and set them. This should provide a little more abstraction than at present.
---
v7/src/runtime/char.scm | 33 ++++++++++++++++++++++++++++++---
v7/src/runtime/runtime.pkg | 12 ++++++++++--
2 files changed, 40 insertions(+), 5 deletions(-)
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
--
2.25.1