From 781d5ea7eaab4640d012f307662c07ba7953f2b7 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 12 Jan 1987 17:08:12 +0000 Subject: [PATCH] Moby rewrite, which started out as some simple bug fixes. Interesting points: * New alternative names for some basic macros: Type_Code --> pointer_type Datum --> pointer_datum * New predicates for certain types: fixnum_p character_p string_p * `Primitive_Error' and `Primitive_Interrupt' close-coded to save space. For extra savings, the following new procedures are available (where N ranges from 1 to 10): void error_wrong_type_arg_N () void error_bad_range_arg_N () void error_external_return () * M --- v7/src/microcode/char.c | 334 +++++++++++++++++++++++----------------- 1 file changed, 194 insertions(+), 140 deletions(-) diff --git a/v7/src/microcode/char.c b/v7/src/microcode/char.c index 6ea786af1..34cd6c6ab 100644 --- a/v7/src/microcode/char.c +++ b/v7/src/microcode/char.c @@ -1,192 +1,246 @@ -/* 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. - */ - -#include +/* -*-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" + +#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) + +#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) + +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))); } - -/* 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)))); } -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))); } 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; @@ -195,7 +249,7 @@ ascii_to_mit_ascii( ascii) } long -mit_ascii_to_ascii( mit_ascii) +mit_ascii_to_ascii (mit_ascii) long mit_ascii; { long bucky_bits, code; @@ -208,13 +262,13 @@ mit_ascii_to_ascii( mit_ascii) { 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); @@ -222,7 +276,7 @@ mit_ascii_to_ascii( mit_ascii) } Boolean -ascii_control_p( code) +ascii_control_p (code) int code; { switch (code) -- 2.25.1