/[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.6 - (hide annotations) (vendor branch)
Fri Jun 21 19:42:58 1991 UTC (22 years, 10 months ago) by chiles
Changes since 1.1.1.5: +13 -35 lines
Removed the definitions of command-char-bits-limit, command-char-code-limit,
KEY-CHAR-BITS, and KEY-CHAR-CODE.  These are no longer used anywhere in the
system.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.1.1.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 chiles 1.1.1.6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/charmacs.lisp,v 1.1.1.6 1991/06/21 19:42:58 chiles Exp $")
11 ram 1.1.1.4 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; Implementation specific character-hacking macros and constants.
15     ;;;
16     (in-package 'hemlock-internals)
17 chiles 1.1.1.6 (export ' (syntax-char-code-limit search-char-code-limit do-alpha-chars))
18 ram 1.1
19 chiles 1.1.1.6 ;;; 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 ram 1.1
31    
32 ram 1.1.1.2
33 ram 1.1 ;;;; Stuff for the Syntax table functions (syntax)
34 ram 1.1.1.2
35 chiles 1.1.1.5 (defconstant syntax-char-code-limit char-code-limit
36 ram 1.1 "The highest char-code which a character argument to the syntax
37     table functions may have.")
38 chiles 1.1.1.5
39 ram 1.1 (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 ram 1.1.1.1 `(logand (char-code ,ch) #x+7F))
49 ram 1.1 ;;;
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 ram 1.1.1.1 `(logand (char-code ,ch) #x+5F))
58 ram 1.1
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 wlott 1.1.1.3 `(char-upcase (the base-character ,ch)))
63 ram 1.1
64    
65 ram 1.1.1.2
66     ;;;; DO-ALPHA-CHARS.
67 ram 1.1
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