-/* Emacs -*-C-*-an't tell the language */
-
-/****************************************************************
-* *
-* Copyright (c) 1986 *
-* Massachusetts Institute of Technology *
-* *
-* This material was developed by the Scheme project at the *
-* Massachusetts Institute of Technology, Department of *
-* Electrical Engineering and Computer Science. Permission to *
-* copy this software, to redistribute it, and to use it for any *
-* purpose is granted, subject to the following restrictions and *
-* understandings. *
-* *
-* 1. Any copy made of this software must include this copyright *
-* notice in full. *
-* *
-* 2. Users of this software agree to make their best efforts (a)*
-* to return to the MIT Scheme project any improvements or *
-* extensions that they make, so that these may be included in *
-* future releases; and (b) to inform MIT of noteworthy uses of *
-* this software. *
-* *
-* 3. All materials developed as a consequence of the use of *
-* this software shall duly acknowledge such use, in accordance *
-* with the usual standards of acknowledging credit in academic *
-* research. *
-* *
-* 4. MIT has made no warrantee or representation that the *
-* operation of this software will be error-free, and MIT is *
-* under no obligation to provide any services, by way of *
-* maintenance, update, or otherwise. *
-* *
-* 5. In conjunction with products arising from the use of this *
-* material, there shall be no use of the name of the *
-* Massachusetts Institute of Technology nor of any adaptation *
-* thereof in any advertising, promotional, or sales literature *
-* without prior written consent from MIT in each case. *
-* *
-****************************************************************/
-
-/* File: character.c
- *
- * This file contains the character primitives.
- */
-\f
-#include <ctype.h>
+/* -*-C-*-
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 5.2 1987/01/12 17:08:12 cph Exp $ */
+
+/* Character primitives. */
+
#include "scheme.h"
#include "primitive.h"
#include "character.h"
+\f
+#define define_ascii_character_guarantee(procedure_name, wta, bra) \
+long \
+procedure_name (argument) \
+ Pointer argument; \
+{ \
+ fast long ascii; \
+ \
+ if (! (character_p (argument))) \
+ wta (); \
+ ascii = (scheme_char_to_c_char (argument)); \
+ if (ascii == NOT_ASCII) \
+ bra (); \
+ return (ascii); \
+}
+
+define_ascii_character_guarantee (guarantee_ascii_character_arg_1,
+ error_wrong_type_arg_1,
+ error_bad_range_arg_1)
+
+define_ascii_character_guarantee (guarantee_ascii_character_arg_2,
+ error_wrong_type_arg_2,
+ error_bad_range_arg_2)
+
+define_ascii_character_guarantee (guarantee_ascii_character_arg_3,
+ error_wrong_type_arg_3,
+ error_bad_range_arg_3)
+
+define_ascii_character_guarantee (guarantee_ascii_character_arg_4,
+ error_wrong_type_arg_4,
+ error_bad_range_arg_4)
+
+define_ascii_character_guarantee (guarantee_ascii_character_arg_5,
+ error_wrong_type_arg_5,
+ error_bad_range_arg_5)
+
+define_ascii_character_guarantee (guarantee_ascii_character_arg_6,
+ error_wrong_type_arg_6,
+ error_bad_range_arg_6)
+
+define_ascii_character_guarantee (guarantee_ascii_character_arg_7,
+ error_wrong_type_arg_7,
+ error_bad_range_arg_7)
-/* pieces of characters primitives
-1. MAKE-CHAR Makes a char from its bits and its code.
- A char is a 32
- TC_CHARACTER typecode in the 8 bits near the
- msb, the next 12 bits unused, the next 5 bits
- for the bits (control, hyper, meta, etc.) and
- the last 7, including the lsb for the code
- field, i.e., what letter it is.
-2. CHAR-BITS Gets those 5 bits bits.
-3. CHAR-CODE Gets those 7 code bits.
-*/
-
-Built_In_Primitive(Prim_Make_Char, 2, "MAKE-CHAR")
+define_ascii_character_guarantee (guarantee_ascii_character_arg_8,
+ error_wrong_type_arg_8,
+ error_bad_range_arg_8)
+
+define_ascii_character_guarantee (guarantee_ascii_character_arg_9,
+ error_wrong_type_arg_9,
+ error_bad_range_arg_9)
+
+define_ascii_character_guarantee (guarantee_ascii_character_arg_10,
+ error_wrong_type_arg_10,
+ error_bad_range_arg_10)
+\f
+#define define_ascii_integer_guarantee(procedure_name, wta, bra) \
+long \
+procedure_name (argument) \
+ Pointer argument; \
+{ \
+ fast long ascii; \
+ \
+ if (! (fixnum_p (argument))) wta (); \
+ if (fixnum_negative_p (argument)) bra (); \
+ ascii = (pointer_datum (argument)); \
+ if (ascii >= MAX_ASCII) bra (); \
+ return (ascii); \
+}
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_1,
+ error_wrong_type_arg_1,
+ error_bad_range_arg_1)
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_2,
+ error_wrong_type_arg_2,
+ error_bad_range_arg_2)
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_3,
+ error_wrong_type_arg_3,
+ error_bad_range_arg_3)
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_4,
+ error_wrong_type_arg_4,
+ error_bad_range_arg_4)
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_5,
+ error_wrong_type_arg_5,
+ error_bad_range_arg_5)
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_6,
+ error_wrong_type_arg_6,
+ error_bad_range_arg_6)
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_7,
+ error_wrong_type_arg_7,
+ error_bad_range_arg_7)
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_8,
+ error_wrong_type_arg_8,
+ error_bad_range_arg_8)
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_9,
+ error_wrong_type_arg_9,
+ error_bad_range_arg_9)
+
+define_ascii_integer_guarantee (guarantee_ascii_integer_arg_10,
+ error_wrong_type_arg_10,
+ error_bad_range_arg_10)
+\f
+Built_In_Primitive (Prim_Make_Char, 2, "MAKE-CHAR")
{
long bucky_bits, code;
- Primitive_2_Args();
+ Primitive_2_Args ();
- Arg_1_Type( TC_FIXNUM);
- Arg_2_Type( TC_FIXNUM);
- Range_Check( code, Arg1, 0, (MAX_CODE - 1), ERR_ARG_1_BAD_RANGE);
- Range_Check( bucky_bits, Arg2, 0, (MAX_BITS - 1), ERR_ARG_2_BAD_RANGE);
- return (make_char( bucky_bits, code));
+ code = (guarantee_index_arg_1 (Arg1, MAX_CODE));
+ bucky_bits = (guarantee_index_arg_2 (Arg2, MAX_BITS));
+ return (make_char (bucky_bits, code));
}
-Built_In_Primitive( Prim_Char_Bits, 1, "CHAR-BITS")
+Built_In_Primitive (Prim_Char_Bits, 1, "CHAR-BITS")
{
- Primitive_1_Args();
+ Primitive_1_Arg ();
- Arg_1_Type( TC_CHARACTER);
- return (Make_Unsigned_Fixnum( char_bits( Arg1)));
+ guarantee_character_arg_1 ();
+ return (Make_Unsigned_Fixnum (char_bits (Arg1)));
}
-Built_In_Primitive( Prim_Char_Code, 1, "CHAR-CODE")
+Built_In_Primitive (Prim_Char_Code, 1, "CHAR-CODE")
{
- Primitive_1_Args();
+ Primitive_1_Arg ();
- Arg_1_Type( TC_CHARACTER);
- return (Make_Unsigned_Fixnum( char_code( Arg1)));
+ guarantee_character_arg_1 ();
+ return (Make_Unsigned_Fixnum (char_code (Arg1)));
}
-\f
-/* Primitives for converting characters:
-1. CHAR->INTEGER Converts a char to its 12 bit numerical
- value in extended ascii.
-2. INTEGER->CHAR Converts the other way.
-3. CHAR-UPCASE Converts a char to upcase.
-4. CHAR-DOWNCASE Converts a char to lowercase.
-5. ASCII->CHAR Converts an ascii value to a char, including
- doing bit twiddleing to make sure
- the control bit is set correctly.
-6. CHAR->ASCII Converts a char back to the ascii value,
- signalling an error if there are
- problems.
-7. CHAR-ASCII? Converts a char similarly, but signals false
- if there are problems.
-8. CHAR->JESSE-JACKSON Converts a char to a fundamentalist preacher
- who runs for President. Shouldn't
- be used in the Democratic Party.
-*/
-
-Built_In_Primitive( Prim_Char_To_Integer, 1, "CHAR->INTEGER")
+
+Built_In_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER")
{
- Primitive_1_Args();
+ Primitive_1_Arg ();
- Arg_1_Type( TC_CHARACTER);
- return (Make_Unsigned_Fixnum( (Arg1 & MASK_EXTNDD_CHAR)));
+ guarantee_character_arg_1 ();
+ return (Make_Unsigned_Fixnum (Arg1 & MASK_EXTNDD_CHAR));
}
-Built_In_Primitive( Prim_Integer_To_Char, 1, "INTEGER->CHAR")
+Built_In_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR")
{
- long integ;
- Primitive_1_Args();
+ Primitive_1_Arg ();
- Arg_1_Type( TC_FIXNUM);
- Sign_Extend_Range_Check( integ, Arg1, 0, (MAX_EXTNDD_CHAR - 1),
- ERR_ARG_1_BAD_RANGE);
- return (Make_Non_Pointer( TC_CHARACTER, integ));
+ return
+ (Make_Non_Pointer (TC_CHARACTER,
+ (guarantee_index_arg_1 (Arg1, MAX_EXTNDD_CHAR))));
}
\f
-Built_In_Primitive( Prim_Char_Downcase, 1, "CHAR-DOWNCASE")
+Built_In_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE")
{
- long ascii;
- Primitive_1_Args();
+ Primitive_1_Arg ();
- Arg_1_Type( TC_CHARACTER);
- return make_char( char_bits( Arg1), Real_To_Lower( char_code( Arg1)));
+ guarantee_character_arg_1 ();
+ return (make_char ((char_bits (Arg1)), (Real_To_Lower (char_code (Arg1)))));
}
-Built_In_Primitive( Prim_Char_Upcase, 1, "CHAR-UPCASE")
+Built_In_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE")
{
- Primitive_1_Args();
+ Primitive_1_Arg ();
- Arg_1_Type( TC_CHARACTER);
- return make_char( char_bits( Arg1), Real_To_Upper( char_code( Arg1)));
+ guarantee_character_arg_1 ();
+ return (make_char ((char_bits (Arg1)), (Real_To_Upper (char_code (Arg1)))));
}
-Built_In_Primitive( Prim_Ascii_To_Char, 1, "ASCII->CHAR")
+Built_In_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR")
{
- long ascii;
- Primitive_1_Args();
+ Primitive_1_Arg ();
- Arg_1_Type( TC_FIXNUM);
- Range_Check( ascii, Arg1, 0, (MAX_ASCII - 1), ERR_ARG_1_BAD_RANGE);
- return (c_char_to_scheme_char( ascii));
+ return (c_char_to_scheme_char (guarantee_ascii_integer_arg_1 (Arg1)));
}
-Built_In_Primitive( Prim_Char_Ascii_P, 1, "CHAR-ASCII?")
+Built_In_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII")
{
- long ascii;
- Primitive_1_Args();
+ Primitive_1_Arg ();
- Arg_1_Type( TC_CHARACTER);
- ascii = scheme_char_to_c_char( Arg1);
- return ((ascii == NOT_ASCII) ? NIL : Make_Unsigned_Fixnum( ascii));
+ return (Make_Unsigned_Fixnum (guarantee_ascii_character_arg_1 (Arg1)));
}
-Built_In_Primitive( Prim_Char_To_Ascii, 1, "CHAR->ASCII")
+Built_In_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?")
{
long ascii;
- Primitive_1_Args();
+ Primitive_1_Arg ();
- Arg_1_Type( TC_CHARACTER);
- ascii = scheme_char_to_c_char( Arg1);
- if (ascii == NOT_ASCII)
- Primitive_Error( ERR_ARG_1_BAD_RANGE);
- return (Make_Unsigned_Fixnum( ascii));
+ guarantee_character_arg_1 ();
+ ascii = (scheme_char_to_c_char (Arg1));
+ return ((ascii == NOT_ASCII) ? NIL : (Make_Unsigned_Fixnum (ascii)));
}
\f
forward Boolean ascii_control_p();
long
-ascii_to_mit_ascii( ascii)
+ascii_to_mit_ascii (ascii)
long ascii;
{
long bucky_bits, code;
bucky_bits = (((ascii & 0200) != 0) ? CHAR_BITS_META : 0);
code = (ascii & 0177);
- if (ascii_control_p( code))
+ if (ascii_control_p (code))
{
code |= 0100; /* Convert to non-control code. */
bucky_bits |= CHAR_BITS_CONTROL;
}
long
-mit_ascii_to_ascii( mit_ascii)
+mit_ascii_to_ascii (mit_ascii)
long mit_ascii;
{
long bucky_bits, code;
{
if ((bucky_bits & CHAR_BITS_CONTROL) != 0)
{
- code = (Real_To_Upper( code) & (~ 0100));
- if (!ascii_control_p( code))
+ code = (Real_To_Upper (code) & (~ 0100));
+ if (!ascii_control_p (code))
return (NOT_ASCII);
}
else
{
- if (ascii_control_p( code))
+ if (ascii_control_p (code))
return (NOT_ASCII);
}
return (((bucky_bits & CHAR_BITS_META) != 0) ? (code | 0200) : code);
}
\f
Boolean
-ascii_control_p( code)
+ascii_control_p (code)
int code;
{
switch (code)
projects / mit-scheme.git / commitdiff