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

Contents of /src/hemlock/charmacs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Fri Jun 19 13:27:30 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.4: +2 -2 lines
Change all references to char-code-limit to 256 when compiling on a
Unicode build.  This allows Hemlock to load and run but does not work
correctly with a Unicode build.  The display is wrong, among other
things.
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/charmacs.lisp,v 1.5 2009/06/19 13:27:30 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Implementation specific character-hacking macros and constants.
13 ;;;
14 (in-package "HEMLOCK-INTERNALS")
15 (export ' (syntax-char-code-limit search-char-code-limit do-alpha-chars))
16
17 ;;; This file contains various constants and macros which are implementation or
18 ;;; ASCII dependant. It contains some versions of CHAR-CODE which do not check
19 ;;; types and ignore the top bit so that various structures can be allocated
20 ;;; 128 long instead of 256, and we don't get errors if a loser visits a binary
21 ;;; file.
22 ;;;
23 ;;; There are so many different constants and macros implemented the same.
24 ;;; This is to separate various mechanisms; for example, in principle the
25 ;;; char-code-limit for the syntax functions is independant of that for the
26 ;;; searching functions
27 ;;;
28
29
30
31 ;;;; Stuff for the Syntax table functions (syntax)
32
33 (defconstant syntax-char-code-limit #-unicode char-code-limit #+unicode 256
34 "The highest char-code which a character argument to the syntax
35 table functions may have.")
36
37 (defmacro syntax-char-code (char)
38 `(char-code ,char))
39
40
41 ;;;; Stuff used by the searching primitives (search)
42 ;;;
43 (defconstant search-char-code-limit 128
44 "The exclusive upper bound on significant char-codes for searching.")
45 (defmacro search-char-code (ch)
46 `(logand (char-code ,ch) #x+7F))
47 ;;;
48 ;;; search-hash-code must be a function with the following properties:
49 ;;; given any character it returns a number between 0 and
50 ;;; search-char-code-limit, and the same hash code must be returned
51 ;;; for the upper and lower case forms of each character.
52 ;;; In ASCII this is can be done by ANDing out the 5'th bit.
53 ;;;
54 (defmacro search-hash-code (ch)
55 `(logand (char-code ,ch) #x+5F))
56
57 ;;; Doesn't do anything special, but it should fast and not waste any time
58 ;;; checking type and whatnot.
59 (defmacro search-char-upcase (ch)
60 `(char-upcase (the base-char ,ch)))
61
62
63
64 ;;;; DO-ALPHA-CHARS.
65
66 ;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var
67 ;;; to the alphabetic characters and executing body. Note that the manual
68 ;;; guarantees lower and upper case char codes to be separately in order,
69 ;;; but other characters may be interspersed within that ordering.
70 (defmacro alpha-chars-loop (var start-char end-char result body)
71 (let ((n (gensym))
72 (end-char-code (gensym)))
73 `(do ((,n (char-code ,start-char) (1+ ,n))
74 (,end-char-code (char-code ,end-char)))
75 ((> ,n ,end-char-code) ,result)
76 (let ((,var (code-char ,n)))
77 (when (alpha-char-p ,var)
78 ,@body)))))
79
80 (defmacro do-alpha-chars ((var kind &optional result) &rest forms)
81 "(do-alpha-chars (var kind [result]) . body). Kind is one of
82 :lower, :upper, or :both, and var is bound to each character in
83 order as specified under character relations in the manual. When
84 :both is specified, lowercase letters are processed first."
85 (case kind
86 (:both
87 `(progn (alpha-chars-loop ,var #\a #\z nil ,forms)
88 (alpha-chars-loop ,var #\A #\Z ,result ,forms)))
89 (:lower
90 `(alpha-chars-loop ,var #\a #\z ,result ,forms))
91 (:upper
92 `(alpha-chars-loop ,var #\A #\Z ,result ,forms))
93 (t (error "Kind argument not one of :lower, :upper, or :both -- ~S."
94 kind))))

  ViewVC Help
Powered by ViewVC 1.1.5