1 | ;;; chars.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003 Peter Graves |
---|
4 | ;;; $Id: chars.lisp,v 1.7 2003-08-07 15:12:26 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | (in-package "COMMON-LISP") |
---|
21 | |
---|
22 | ;;; From CMUCL. |
---|
23 | |
---|
24 | (defun digit-char-p (char &optional (radix 10)) |
---|
25 | (let ((m (- (char-code char) 48))) |
---|
26 | (cond ((<= radix 10) |
---|
27 | ;; Special-case decimal and smaller radices. |
---|
28 | (if (and (>= m 0) (< m radix)) m nil)) |
---|
29 | ;; Digits 0 - 9 are used as is, since radix is larger. |
---|
30 | ((and (>= m 0) (< m 10)) m) |
---|
31 | ;; Check for upper case A - Z. |
---|
32 | ((and (>= (setq m (- m 7)) 10) (< m radix)) m) |
---|
33 | ;; Also check lower case a - z. |
---|
34 | ((and (>= (setq m (- m 32)) 10) (< m radix)) m) |
---|
35 | ;; Else, fail. |
---|
36 | (t nil)))) |
---|
37 | |
---|
38 | |
---|
39 | (defun alphanumericp (char) |
---|
40 | (declare (character char)) |
---|
41 | (let ((m (char-code char))) |
---|
42 | (or (< 47 m 58) (< 64 m 91) (< 96 m 123)))) |
---|
43 | |
---|
44 | |
---|
45 | (defun char/= (character &rest more-characters) |
---|
46 | (do* ((head character (car list)) |
---|
47 | (list more-characters (cdr list))) |
---|
48 | ((atom list) T) |
---|
49 | (unless (do* ((l list (cdr l))) ;inner loop returns T |
---|
50 | ((atom l) T) ; iff head /= rest. |
---|
51 | (if (eql head (car l)) (return nil))) |
---|
52 | (return nil)))) |
---|
53 | |
---|
54 | |
---|
55 | (defun char< (character &rest more-characters) |
---|
56 | (do* ((c character (car list)) |
---|
57 | (list more-characters (cdr list))) |
---|
58 | ((atom list) T) |
---|
59 | (unless (< (char-int c) |
---|
60 | (char-int (car list))) |
---|
61 | (return nil)))) |
---|
62 | |
---|
63 | |
---|
64 | (defun char> (character &rest more-characters) |
---|
65 | (do* ((c character (car list)) |
---|
66 | (list more-characters (cdr list))) |
---|
67 | ((atom list) T) |
---|
68 | (unless (> (char-int c) |
---|
69 | (char-int (car list))) |
---|
70 | (return nil)))) |
---|
71 | |
---|
72 | |
---|
73 | (defun char<= (character &rest more-characters) |
---|
74 | (do* ((c character (car list)) |
---|
75 | (list more-characters (cdr list))) |
---|
76 | ((atom list) T) |
---|
77 | (unless (<= (char-int c) |
---|
78 | (char-int (car list))) |
---|
79 | (return nil)))) |
---|
80 | |
---|
81 | |
---|
82 | (defun char>= (character &rest more-characters) |
---|
83 | (do* ((c character (car list)) |
---|
84 | (list more-characters (cdr list))) |
---|
85 | ((atom list) T) |
---|
86 | (unless (>= (char-int c) |
---|
87 | (char-int (car list))) |
---|
88 | (return nil)))) |
---|
89 | |
---|
90 | |
---|
91 | (defmacro equal-char-code (character) |
---|
92 | `(let ((ch (char-code ,character))) |
---|
93 | (if (< 96 ch 123) (- ch 32) ch))) |
---|
94 | |
---|
95 | |
---|
96 | (defun char-not-equal (character &rest more-characters) |
---|
97 | (do* ((head character (car list)) |
---|
98 | (list more-characters (cdr list))) |
---|
99 | ((atom list) T) |
---|
100 | (unless (do* ((l list (cdr l))) |
---|
101 | ((atom l) T) |
---|
102 | (if (= (equal-char-code head) |
---|
103 | (equal-char-code (car l))) |
---|
104 | (return nil))) |
---|
105 | (return nil)))) |
---|
106 | |
---|
107 | (when (and (find-package "JVM") |
---|
108 | (fboundp 'jvm::jvm-compile)) |
---|
109 | (mapcar #'jvm::jvm-compile '(digit-char-p |
---|
110 | alphanumericp |
---|
111 | char/= |
---|
112 | char< |
---|
113 | char> |
---|
114 | char<= |
---|
115 | char>= |
---|
116 | char-not-equal))) |
---|