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

Contents of /src/hemlock/charmacs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Wed May 9 13:03:13 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice Lisp project at
5     ;;; Carnegie-Mellon University, and has been placed in the public domain.
6     ;;; Spice Lisp is currently incomplete and under active development.
7     ;;; If you want to use this code or any part of Spice Lisp, please contact
8     ;;; Scott Fahlman (FAHLMAN@CMUC).
9     ;;; **********************************************************************
10     ;;;
11     ;;; Implementation specific character-hacking macros and constants.
12     ;;;
13     (in-package 'hemlock-internals)
14     (export ' (syntax-char-code-limit command-char-bits-limit
15     command-char-code-limit search-char-code-limit
16     do-alpha-chars))
17    
18     ;;; This file contains various constants and macros which are
19     ;;; implementation or ASCII dependant. In particular it contains
20     ;;; all the character implementation parameters such as
21     ;;; Command-Char-Bits-Limit, and contains various versions
22     ;;; of char-code which don't check types and omit the top bit
23     ;;; so that various structures can be allocated 128 long instead
24     ;;; of 256, and we don't get errors if a loser visits a binary file.
25    
26     ;;; There are so many different constants and macros that do the same
27     ;;; thing because in principle the char-code-limit for the syntax
28     ;;; functions is independant of that for the searching functions, etc.
29    
30     ;;; This file also contains code which adds any implementation specific
31     ;;; character names to the char file's Char-Name-Alist so that there
32     ;;; is a reasonable read-syntax and print-representation for all
33     ;;; characters a user might run across.
34    
35    
36     ;;; All the meaningful bit names in this implementation.
37     ;;;
38     (defconstant all-bit-names '(:control :meta :super :hyper))
39    
40    
41     ;;;; Stuff for the Syntax table functions (syntax)
42     ;;;
43     (defconstant syntax-char-code-limit 128
44     "The highest char-code which a character argument to the syntax
45     table functions may have.")
46     (defconstant syntax-char-code-mask #x+7f
47     "Mask we AND with characters given to syntax table functions to blow away
48     bits we don't want.")
49     (defmacro syntax-char-code (char)
50     `(logand syntax-char-code-mask (lisp::%sp-make-fixnum ,char)))
51    
52     ;;;; Stuff for the command interpreter (interp)
53     ;;;
54     ;;; On the Perq we have bits for command bindings, on the VAX there
55     ;;; aren't. The code to interpret them is conditionally compiled
56     ;;; so that the VAX isnt't slowed down.
57     ;;;
58     ;;; Make command-char-code-limit 256 instead of 128 for X keyboard scan-codes.
59     (defconstant command-char-code-limit 256
60     "The upper bound on character codes supported for key bindings.")
61     (defconstant command-char-bits-limit 16
62     "The maximum value of character bits supported for key bindings.")
63     (defmacro key-char-bits (char)
64     `(ash (logand #x+F00 (lisp::%sp-make-fixnum ,char)) -8))
65     (defmacro key-char-code (char)
66     `(char-code ,char))
67     ;;; `(logand #x+7f (lisp::%sp-make-fixnum ,char))) can't use with X scan-codes.
68    
69    
70     ;;;; Stuff used by the searching primitives (search)
71     ;;;
72     (defconstant search-char-code-limit 128
73     "The exclusive upper bound on significant char-codes for searching.")
74     (defmacro search-char-code (ch)
75     `(logand (lisp::%sp-make-fixnum ,ch) #x+7F))
76     ;;;
77     ;;; search-hash-code must be a function with the following properties:
78     ;;; given any character it returns a number between 0 and
79     ;;; search-char-code-limit, and the same hash code must be returned
80     ;;; for the upper and lower case forms of each character.
81     ;;; In ASCII this is can be done by ANDing out the 5'th bit.
82     ;;;
83     (defmacro search-hash-code (ch)
84     `(logand (lisp::%sp-make-fixnum ,ch) #x+5F))
85    
86     ;;; Doesn't do anything special, but it should fast and not waste any time
87     ;;; checking type and whatnot.
88     (defmacro search-char-upcase (ch)
89     `(lisp::fast-char-upcase ,ch))
90    
91    
92     ;;; Specal RT and Sun keys:
93    
94     (eval-when (compile load eval)
95    
96     (push (cons "DELETE" #\delete) lisp::char-name-alist)
97     (push (cons "ESCAPE" #\escape) lisp::char-name-alist)
98     (push (cons "F1" (code-char 1)) lisp::char-name-alist)
99     (push (cons "F2" (code-char 2)) lisp::char-name-alist)
100     (push (cons "F3" (code-char 3)) lisp::char-name-alist)
101     (push (cons "F4" (code-char 4)) lisp::char-name-alist)
102     (push (cons "F5" (code-char 5)) lisp::char-name-alist)
103     (push (cons "F6" (code-char 6)) lisp::char-name-alist)
104     (push (cons "F7" (code-char 7)) lisp::char-name-alist)
105     (push (cons "F8" (code-char 11)) lisp::char-name-alist)
106     (push (cons "F9" (code-char 12)) lisp::char-name-alist)
107     (push (cons "F10" (code-char 14)) lisp::char-name-alist)
108     (push (cons "F11" (code-char 17)) lisp::char-name-alist)
109     (push (cons "F12" (code-char 18)) lisp::char-name-alist)
110     (push (cons "LEFTARROW" (code-char 19)) lisp::char-name-alist)
111     (push (cons "RIGHTARROW" (code-char 20)) lisp::char-name-alist)
112     (push (cons "UPARROW" (code-char 22)) lisp::char-name-alist)
113     (push (cons "DOWNARROW" (code-char 23)) lisp::char-name-alist)
114     (push (cons "LEFTDOWN" (code-char 24)) lisp::char-name-alist)
115     (push (cons "MIDDLEDOWN" (code-char 25)) lisp::char-name-alist)
116     (push (cons "RIGHTDOWN" (code-char 128)) lisp::char-name-alist)
117     (push (cons "LEFTUP" (code-char 129)) lisp::char-name-alist)
118     (push (cons "MIDDLEUP" (code-char 130)) lisp::char-name-alist)
119     (push (cons "RIGHTUP" (code-char 131)) lisp::char-name-alist)
120     (push (cons "INSERT" (code-char 132)) lisp::char-name-alist)
121     (push (cons "PRINTSCREEN" (code-char 133)) lisp::char-name-alist)
122     (push (cons "PAUSE" (code-char 134)) lisp::char-name-alist)
123     (push (cons "HOME" (code-char 135)) lisp::char-name-alist)
124     (push (cons "END" (code-char 136)) lisp::char-name-alist)
125     (push (cons "PAGEUP" (code-char 137)) lisp::char-name-alist)
126     (push (cons "PAGEDOWN" (code-char 138)) lisp::char-name-alist)
127     (push (cons "NUMLOCK" (code-char 139)) lisp::char-name-alist)
128     (push (cons "F13" (code-char 140)) lisp::char-name-alist)
129     (push (cons "F14" (code-char 141)) lisp::char-name-alist)
130     (push (cons "F15" (code-char 142)) lisp::char-name-alist)
131     (push (cons "F16" (code-char 143)) lisp::char-name-alist)
132     (push (cons "F17" (code-char 144)) lisp::char-name-alist)
133     (push (cons "F18" (code-char 145)) lisp::char-name-alist)
134     (push (cons "F19" (code-char 146)) lisp::char-name-alist)
135     (push (cons "F20" (code-char 147)) lisp::char-name-alist)
136     (push (cons "F21" (code-char 148)) lisp::char-name-alist)
137     (push (cons "F22" (code-char 149)) lisp::char-name-alist)
138     (push (cons "F23" (code-char 150)) lisp::char-name-alist)
139     (push (cons "F24" (code-char 151)) lisp::char-name-alist)
140     (push (cons "F25" (code-char 152)) lisp::char-name-alist)
141     (push (cons "F26" (code-char 153)) lisp::char-name-alist)
142     (push (cons "F27" (code-char 154)) lisp::char-name-alist)
143     (push (cons "F28" (code-char 155)) lisp::char-name-alist)
144     (push (cons "F29" (code-char 156)) lisp::char-name-alist)
145     (push (cons "F30" (code-char 157)) lisp::char-name-alist)
146     (push (cons "F31" (code-char 158)) lisp::char-name-alist)
147     (push (cons "F32" (code-char 159)) lisp::char-name-alist)
148     (push (cons "F33" (code-char 160)) lisp::char-name-alist)
149     (push (cons "F34" (code-char 161)) lisp::char-name-alist)
150     (push (cons "F35" (code-char 162)) lisp::char-name-alist)
151     ;; ALTERNATE key on Sun keyboard.
152     (push (cons "BREAK" (code-char 163)) lisp::char-name-alist)
153    
154     ) ;eval-when (compile load eval)
155    
156     ;;; Stick them on the end so that they don't print this way.
157     ;;; Use two separate EVAL-WHEN forms, so the #\f<13-35> characters can be
158     ;;; read at this point.
159     ;;;
160     (eval-when (compile load eval)
161     (setq lisp::char-name-alist
162     (append lisp::char-name-alist
163     '(("ENTER" . #\return) ("ACTION" . #\linefeed)
164    
165     ("L1" . #\F11) ("L2" . #\F12) ("L3" . #\F13) ("L4" . #\F14)
166     ("L5" . #\F15) ("L6" . #\F16) ("L7" . #\F17) ("L8" . #\F18)
167     ("L9" . #\F19) ("L10" . #\F20)
168    
169     ("R1" . #\F21) ("R2" . #\F22) ("R3" . #\F23) ("R4" . #\F24)
170     ("R5" . #\F25) ("R6" . #\F26) ("R7" . #\F27) ("R8" . #\F28)
171     ("R9" . #\F29) ("R10" . #\F30) ("R11" . #\F31) ("R12" . #\F32)
172     ("R13" . #\F33) ("R14" . #\F34) ("R15" . #\F35))))
173     ) ;eval-when
174    
175    
176     ;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var
177     ;;; to the alphabetic characters and executing body. Note that the manual
178     ;;; guarantees lower and upper case char codes to be separately in order,
179     ;;; but other characters may be interspersed within that ordering.
180     (defmacro alpha-chars-loop (var start-char end-char result body)
181     (let ((n (gensym))
182     (end-char-code (gensym)))
183     `(do ((,n (char-code ,start-char) (1+ ,n))
184     (,end-char-code (char-code ,end-char)))
185     ((> ,n ,end-char-code) ,result)
186     (let ((,var (code-char ,n)))
187     (when (alpha-char-p ,var)
188     ,@body)))))
189    
190     (defmacro do-alpha-chars ((var kind &optional result) &rest forms)
191     "(do-alpha-chars (var kind [result]) . body). Kind is one of
192     :lower, :upper, or :both, and var is bound to each character in
193     order as specified under character relations in the manual. When
194     :both is specified, lowercase letters are processed first."
195     (case kind
196     (:both
197     `(progn (alpha-chars-loop ,var #\a #\z nil ,forms)
198     (alpha-chars-loop ,var #\A #\Z ,result ,forms)))
199     (:lower
200     `(alpha-chars-loop ,var #\a #\z ,result ,forms))
201     (:upper
202     `(alpha-chars-loop ,var #\A #\Z ,result ,forms))
203     (t (error "Kind argument not one of :lower, :upper, or :both -- ~S."
204     kind))))

  ViewVC Help
Powered by ViewVC 1.1.5