home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / char.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  4KB  |  143 lines
  1. /* -*-C-*-
  2.  
  3. $Id: char.c,v 9.33 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1987-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Character primitives. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include <ctype.h>
  27.  
  28. long
  29. DEFUN (arg_ascii_char, (n), int n)
  30. {
  31.   CHECK_ARG (n, CHARACTER_P);
  32.   {
  33.     fast SCHEME_OBJECT object = (ARG_REF (n));
  34.     if (! (CHAR_TO_ASCII_P (object)))
  35.       error_bad_range_arg (n);
  36.     return (CHAR_TO_ASCII (object));
  37.   }
  38. }
  39.  
  40. long
  41. DEFUN (arg_ascii_integer, (n), int n)
  42. {
  43.   return (arg_index_integer (n, MAX_ASCII));
  44. }
  45.  
  46. DEFINE_PRIMITIVE ("CHAR?", Prim_char_p, 1, 1, 0)
  47. {
  48.   PRIMITIVE_HEADER (1);
  49.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (CHARACTER_P (ARG_REF (1))));
  50. }
  51.  
  52. DEFINE_PRIMITIVE ("MAKE-CHAR", Prim_make_char, 2, 2, 0)
  53. {
  54.   PRIMITIVE_HEADER (2);
  55.   PRIMITIVE_RETURN
  56.     (MAKE_CHAR ((arg_index_integer (2, MAX_BITS)),
  57.         (arg_index_integer (1, MAX_CODE))));
  58. }
  59.  
  60. DEFINE_PRIMITIVE ("CHAR-BITS", Prim_char_bits, 1, 1, 0)
  61. {
  62.   PRIMITIVE_HEADER (1);
  63.   CHECK_ARG (1, CHARACTER_P);
  64.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (CHAR_BITS (ARG_REF (1))));
  65. }
  66.  
  67. DEFINE_PRIMITIVE ("CHAR-CODE", Prim_char_code, 1, 1, 0)
  68. {
  69.   PRIMITIVE_HEADER (1);
  70.   CHECK_ARG (1, CHARACTER_P);
  71.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (CHAR_CODE (ARG_REF (1))));
  72. }
  73.  
  74. DEFINE_PRIMITIVE ("CHAR->INTEGER", Prim_char_to_integer, 1, 1, 0)
  75. {
  76.   PRIMITIVE_HEADER (1);
  77.   CHECK_ARG (1, CHARACTER_P);
  78.   PRIMITIVE_RETURN
  79.     (LONG_TO_UNSIGNED_FIXNUM ((ARG_REF (1)) & MASK_MIT_ASCII));
  80. }
  81.  
  82. DEFINE_PRIMITIVE ("INTEGER->CHAR", Prim_integer_to_char, 1, 1, 0)
  83. {
  84.   PRIMITIVE_HEADER (1);
  85.   PRIMITIVE_RETURN
  86.     (MAKE_OBJECT (TC_CHARACTER, (arg_index_integer (1, MAX_MIT_ASCII))));
  87. }
  88.  
  89. long
  90. DEFUN (char_downcase, (c), fast long c)
  91. {
  92.   return ((isupper (c)) ? ((c - 'A') + 'a') : c);
  93. }
  94.  
  95. long
  96. DEFUN (char_upcase, (c), fast long c)
  97. {
  98.   return ((islower (c)) ? ((c - 'a') + 'A') : c);
  99. }
  100.  
  101. DEFINE_PRIMITIVE ("CHAR-DOWNCASE", Prim_char_downcase, 1, 1, 0)
  102. {
  103.   PRIMITIVE_HEADER (1);
  104.   CHECK_ARG (1, CHARACTER_P);
  105.   PRIMITIVE_RETURN
  106.     (MAKE_CHAR ((CHAR_BITS (ARG_REF (1))),
  107.         (char_downcase (CHAR_CODE (ARG_REF (1))))));
  108. }
  109.  
  110. DEFINE_PRIMITIVE ("CHAR-UPCASE", Prim_char_upcase, 1, 1, 0)
  111. {
  112.   PRIMITIVE_HEADER (1);
  113.   CHECK_ARG (1, CHARACTER_P);
  114.   PRIMITIVE_RETURN
  115.     (MAKE_CHAR ((CHAR_BITS (ARG_REF (1))),
  116.         (char_upcase (CHAR_CODE (ARG_REF (1))))));
  117. }
  118.  
  119. DEFINE_PRIMITIVE ("ASCII->CHAR", Prim_ascii_to_char, 1, 1, 0)
  120. {
  121.   PRIMITIVE_HEADER (1);
  122.   PRIMITIVE_RETURN (ASCII_TO_CHAR (arg_index_integer (1, MAX_ASCII)));
  123. }
  124.  
  125. DEFINE_PRIMITIVE ("CHAR->ASCII", Prim_char_to_ascii, 1, 1, 0)
  126. {
  127.   PRIMITIVE_HEADER (1);
  128.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (arg_ascii_char (1)));
  129. }
  130.  
  131. DEFINE_PRIMITIVE ("CHAR-ASCII?", Prim_char_ascii_p, 1, 1, 0)
  132. {
  133.   PRIMITIVE_HEADER (1);
  134.   CHECK_ARG (1, CHARACTER_P);
  135.   {
  136.     fast SCHEME_OBJECT character = ARG_REF (1);
  137.     PRIMITIVE_RETURN
  138.       (((OBJECT_DATUM (character)) >= MAX_ASCII) ?
  139.        SHARP_F :
  140.        (LONG_TO_UNSIGNED_FIXNUM (CHAR_TO_ASCII (character))));
  141.   }
  142. }
  143.