/[cmucl]/src/hemlock/charmacs.lisp
ViewVC logotype

Contents of /src/hemlock/charmacs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.8 - (show annotations) (vendor branch)
Wed Aug 25 02:07:59 1993 UTC (20 years, 7 months ago) by ram
Changes since 1.1.1.7: +2 -2 lines
Fix compiler warnings.
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/charmacs.lisp,v 1.1.1.8 1993/08/25 02:07:59 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Implementation specific character-hacking macros and constants.
15 ;;;
16 (in-package "HEMLOCK"-internals)
17 (export ' (syntax-char-code-limit search-char-code-limit do-alpha-chars))
18
19 ;;; This file contains various constants and macros which are implementation or
20 ;;; ASCII dependant. It contains some versions of CHAR-CODE which do not check
21 ;;; types and ignore the top bit so that various structures can be allocated
22 ;;; 128 long instead of 256, and we don't get errors if a loser visits a binary
23 ;;; file.
24 ;;;
25 ;;; There are so many different constants and macros implemented the same.
26 ;;; This is to separate various mechanisms; for example, in principle the
27 ;;; char-code-limit for the syntax functions is independant of that for the
28 ;;; searching functions
29 ;;;
30
31
32
33 ;;;; Stuff for the Syntax table functions (syntax)
34
35 (defconstant syntax-char-code-limit char-code-limit
36 "The highest char-code which a character argument to the syntax
37 table functions may have.")
38
39 (defmacro syntax-char-code (char)
40 `(char-code ,char))
41
42
43 ;;;; Stuff used by the searching primitives (search)
44 ;;;
45 (defconstant search-char-code-limit 128
46 "The exclusive upper bound on significant char-codes for searching.")
47 (defmacro search-char-code (ch)
48 `(logand (char-code ,ch) #x+7F))
49 ;;;
50 ;;; search-hash-code must be a function with the following properties:
51 ;;; given any character it returns a number between 0 and
52 ;;; search-char-code-limit, and the same hash code must be returned
53 ;;; for the upper and lower case forms of each character.
54 ;;; In ASCII this is can be done by ANDing out the 5'th bit.
55 ;;;
56 (defmacro search-hash-code (ch)
57 `(logand (char-code ,ch) #x+5F))
58
59 ;;; Doesn't do anything special, but it should fast and not waste any time
60 ;;; checking type and whatnot.
61 (defmacro search-char-upcase (ch)
62 `(char-upcase (the base-char ,ch)))
63
64
65
66 ;;;; DO-ALPHA-CHARS.
67
68 ;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var
69 ;;; to the alphabetic characters and executing body. Note that the manual
70 ;;; guarantees lower and upper case char codes to be separately in order,
71 ;;; but other characters may be interspersed within that ordering.
72 (defmacro alpha-chars-loop (var start-char end-char result body)
73 (let ((n (gensym))
74 (end-char-code (gensym)))
75 `(do ((,n (char-code ,start-char) (1+ ,n))
76 (,end-char-code (char-code ,end-char)))
77 ((> ,n ,end-char-code) ,result)
78 (let ((,var (code-char ,n)))
79 (when (alpha-char-p ,var)
80 ,@body)))))
81
82 (defmacro do-alpha-chars ((var kind &optional result) &rest forms)
83 "(do-alpha-chars (var kind [result]) . body). Kind is one of
84 :lower, :upper, or :both, and var is bound to each character in
85 order as specified under character relations in the manual. When
86 :both is specified, lowercase letters are processed first."
87 (case kind
88 (:both
89 `(progn (alpha-chars-loop ,var #\a #\z nil ,forms)
90 (alpha-chars-loop ,var #\A #\Z ,result ,forms)))
91 (:lower
92 `(alpha-chars-loop ,var #\a #\z ,result ,forms))
93 (:upper
94 `(alpha-chars-loop ,var #\A #\Z ,result ,forms))
95 (t (error "Kind argument not one of :lower, :upper, or :both -- ~S."
96 kind))))

  ViewVC Help
Powered by ViewVC 1.1.5