Context Navigation

source: branches/rme-fpe/objc-bridge/name-translation.lisp @ 13933

Visit:

Last change on this file since 13933 was 9592, checked in by gb, 13 years ago
There's no module named SPLIT-IF; there is one named SEQUENCE-UTILS.
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 15.4 KB

Line
1	;;;; -- Mode: Lisp; Package: CCL --
2	;;;; name-translation.lisp
3	;;;;
4	;;;; Handles the translation between ObjC and Lisp names
5	;;;;
6	;;;; Copyright (c) 2003 Randall D. Beer
7	;;;;
8	;;;; This software is licensed under the terms of the Lisp Lesser GNU Public
9	;;;; License , known as the LLGPL. The LLGPL consists of a preamble and
10	;;;; the LGPL. Where these conflict, the preamble takes precedence. The
11	;;;; LLGPL is available online at http://opensource.franz.com/preamble.html.
12	;;;;
13	;;;; Please send comments and bug reports to <beer@eecs.cwru.edu>
14
15	;;; Temporary package stuff
16
17	(in-package "CCL")
18
19	(require "SEQUENCE-UTILS")
20
21	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22	;;;; Special ObjC Words ;;;;
23	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24
25	;;; Special character sequences that should be treated as words in ObjC
26	;;; names even though they do not follow the normal naming conventions
27
28	(defvar special-objc-words nil)
29
30
31	;;; Add a special word to SPECIAL-OBJC-WORDS, keeping the words sorted
32	;;; from longest to shortest
33
34	(defmacro define-special-objc-word (str)
35	`(setf special-objc-words
36	(sort (pushnew ,str special-objc-words :test #'equal)
37	#'>
38	:key #'length)))
39
40
41	;;; Known special words used in Cocoa names
42
43	(define-special-objc-word "AB")
44	(define-special-objc-word "AE")
45	(define-special-objc-word "ATS")
46	(define-special-objc-word "BMP")
47	(define-special-objc-word "CA")
48	(define-special-objc-word "CF")
49	(define-special-objc-word "CG")
50	(define-special-objc-word "CMYK")
51	(define-special-objc-word "MIME")
52	(define-special-objc-word "DR")
53	(define-special-objc-word "EPS")
54	(define-special-objc-word "FTP")
55	(define-special-objc-word "GMT")
56	(define-special-objc-word "objC")
57	(define-special-objc-word "OpenGL")
58	(define-special-objc-word "HTML")
59	(define-special-objc-word "HTTP")
60	(define-special-objc-word "HTTPS")
61	(define-special-objc-word "IB")
62	(define-special-objc-word "ID")
63	(define-special-objc-word "INT64")
64	(define-special-objc-word "NS")
65	(define-special-objc-word "MIME")
66	(define-special-objc-word "PDF")
67	(define-special-objc-word "PICT")
68	(define-special-objc-word "PNG")
69	(define-special-objc-word "QD")
70	(define-special-objc-word "RGB")
71	(define-special-objc-word "RTFD")
72	(define-special-objc-word "RTF")
73	(define-special-objc-word "TCP")
74	(define-special-objc-word "TIFF")
75	(define-special-objc-word "UI")
76	(define-special-objc-word "UID")
77	(define-special-objc-word "UTF8")
78	(define-special-objc-word "URL")
79	(define-special-objc-word "XOR")
80	(define-special-objc-word "XML")
81	(define-special-objc-word "1970")
82	#+gnu-objc
83	(define-special-objc-word "GS")
84
85	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86	;;;; Utilities ;;;;
87	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
88
89	;;; Concatenate all of the simple strings STRS
90
91	(defun string-cat (&rest strs)
92	(apply #'concatenate 'simple-string strs))
93
94	;;; Collapse all prefixes of L that correspond to known special ObjC words
95
96	(defun collapse-prefix (l)
97	(unless (null l)
98	(multiple-value-bind (newpre skip) (check-prefix l)
99	(cons newpre (collapse-prefix (nthcdr skip l))))))
100
101	(defun check-prefix (l)
102	(let ((pl (prefix-list l)))
103	(loop for w in special-objc-words
104	for p = (position-if #'(lambda (s) (string= s w)) pl)
105	when p do (return-from check-prefix (values (nth p pl) (1+ p))))
106	(values (first l) 1)))
107
108	(defun prefix-list (l)
109	(loop for i from (1- (length l)) downto 0
110	collect (apply #'string-cat (butlast l i))))
111
112
113	;;; Concatenate a list of strings with optional separator into a symbol
114
115	(defun symbol-concatenate (slist &optional (sep "") (package package))
116	(values
117	(intern
118	(reduce #'(lambda (s1 s2) (string-cat s1 sep s2))
119	(mapcar #'string-upcase slist))
120	package)))
121
122
123	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
124	;;;; Implementation ;;;;
125	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
126
127	;;; Convert an ObjC name to a corresponding Lisp name
128	;;; Example: "NSURLHandleClient" ==> ns-url-handle-client
129	;;;
130	;;; 1) Break the string at each uppercase letter
131	;;; e.g., "NSWindow" ==> ("N" "S" "Window")
132	;;; 2) Collapse known sequences of letters
133	;;; e.g., ("N" "S" "Window") ==> ("NS" "Window")
134	;;; 3) Uppercase and concatenate with hyphens into a symbol
135	;;; e.g., ("NS" "Window") ==> NS-WINDOW
136
137	(defun compute-lisp-name (str &optional (package package))
138	(symbol-concatenate
139	(collapse-prefix
140	(split-if #'(lambda (ch) (or (upper-case-p ch) (digit-char-p ch))) str))
141	"-"
142	package))
143
144
145	;;; Convert a Lisp classname into a corresponding ObjC classname
146	;;; Example: ns-url-handle-client ==> "NSURLHandleClient"
147
148	(defun compute-objc-classname (sym)
149	(apply #'string-cat
150	(loop for str in (split-if-char #\- (string sym) :elide)
151	for e = (member str special-objc-words
152	:test #'equal
153	:key #'string-upcase)
154	collect (if e (first e) (string-capitalize str)))))
155
156
157	;;; Convert an ObjC method selector to a set of Lisp keywords
158	;;; Example: "nextEventMatchingMask:untilDate:inMode:dequeue:" ==>
159	;;; (:next-event-matching-mask :until-date :in-mode :dequeue)
160
161	(defun compute-objc-to-lisp-message (str)
162	(mapcar #'(lambda (s) (compute-lisp-name s (find-package "KEYWORD")))
163	(split-if-char #\: str :elide)))
164
165
166	(defparameter objc-colon-replacement-character #\.)
167
168
169	(defun compute-objc-to-lisp-function-name (str &optional (package "NSFUN"))
170	#-nil
171	(intern str package)
172	#+nil
173	(let* ((n (length str))
174	(i 0)
175	(trailing t))
176	(let* ((subs (if (not (position #\: str))
177	(progn (setq trailing nil)
178	(list str))
179	(collect ((substrings))
180	(do* ()
181	((= i n) (substrings))
182	(let* ((pos (position #\: str :start i)))
183	(unless pos
184	(break "Huh?"))
185	(substrings (subseq str i pos))
186	(setq i (1+ pos)))))))
187	(split
188	(mapcar #'(lambda (s)
189	(collapse-prefix
190	(split-if #'(lambda (ch)
191	(or (upper-case-p ch) (digit-char-p ch)))
192	s)))
193
194	subs))
195	(namelen (+ (if trailing (length split) 0)
196	(let* ((c 0))
197	(dolist (s split c)
198	(if s (incf c (1- (length s))))))
199	(let* ((c 0))
200	(dolist (s split c)
201	(dolist (sub s)
202	(incf c (length sub)))))))
203	(name (make-string namelen)))
204	(declare (dynamic-extent name))
205	(let* ((p 0))
206	(flet ((out-ch (ch)
207	(setf (schar name p) ch)
208	(incf p)))
209	(dolist (sub split)
210	(when sub
211	(do* ((string (pop sub) (pop sub)))
212	((null string))
213	(dotimes (i (length string))
214	(out-ch (char-upcase (schar string i))))
215	(when sub
216	(out-ch #\-))))
217	(when trailing (out-ch objc-colon-replacement-character)))))
218	(values
219	(or (find-symbol name package)
220	(intern (copy-seq name) package))))))
221
222
223	;;; Convert a Lisp list of keywords into an ObjC method selector string
224	;;; Example: (:next-event-matching-mask :until-date :in-mode :dequeue) ==>
225	;;; "nextEventMatchingMask:untilDate:inMode:dequeue:"
226
227	(defun compute-lisp-to-objc-message (klist)
228	(flet ((objcify (sym)
229	(apply
230	#'string-cat
231	(loop for str in (split-if-char #\- (string sym) :elide)
232	for first-word-flag = t then nil
233	for e = (member str special-objc-words
234	:test #'equal
235	:key #'string-upcase)
236	collect
237	(cond (e (first e))
238	(first-word-flag (string-downcase str))
239	(t (string-capitalize str)))))))
240	(if (and (= (length klist) 1)
241	(neq (symbol-package (first klist)) (find-package :keyword)))
242	(objcify (first klist))
243	(apply #'string-cat
244	(mapcar #'(lambda (sym) (string-cat (objcify sym) ":")) klist)))))
245
246
247	;;; Convert an ObjC initializer to a list of corresponding initargs,
248	;;; stripping off any initial "init"
249	;;; Example: "initWithCString:length:" ==> (:with-c-string :length)
250
251	(defun compute-objc-to-lisp-init (init)
252	(cond
253	((= (length init) 0) nil)
254	((and (> (length init) 3) (string= init "init" :start1 0 :end1 4))
255	(mapcar #'(lambda (s) (compute-lisp-name s (find-package "KEYWORD")))
256	(split-if-char #\: (subseq init 4 (length init)) :elide)))
257	(t (error "~S is not a valid initializer" init))))
258
259
260	;;; Convert a list of initargs into an ObjC initilizer, adding an "init"
261	;;; prefix if necessary
262	;;; Example: (:with-c-string :length) ==> "initWithCString:length:"
263
264	(defun compute-lisp-to-objc-init (initargs)
265	(if (null initargs)
266	"init"
267	(let ((str (compute-lisp-to-objc-message initargs)))
268	(if (string/= (first (split-if-char #\- (string (first initargs))))
269	"INIT")
270	(string-cat "init" (nstring-upcase str :start 0 :end 1))
271	str))))
272
273
274	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
275	;;;; Class Name Translation ;;;;
276	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
277
278	;;; Hash tables for caching class name translations
279
280	(defvar lisp-classname-table (make-hash-table :test #'equal))
281	(defvar objc-classname-table (make-hash-table :test #'eq))
282
283
284	;;; Define a hard-wired ObjC class name translation (if the automatic
285	;;; translation doesn't apply)
286
287	(defmacro define-classname-translation (str sym)
288	(let ((str-temp (gensym))
289	(sym-temp (gensym))
290	(old-str-temp (gensym))
291	(old-sym-temp (gensym)))
292	`(let* ((,str-temp ',str)
293	(,sym-temp ',sym)
294	(,old-sym-temp (gethash ,str-temp lisp-classname-table))
295	(,old-str-temp (gethash ,sym-temp objc-classname-table)))
296	(remhash ,old-str-temp lisp-classname-table)
297	(remhash ,old-sym-temp objc-classname-table)
298	(setf (gethash ,str-temp lisp-classname-table) ,sym-temp)
299	(setf (gethash ,sym-temp objc-classname-table) ,str-temp)
300	(values))))
301
302
303	;;; Translate an ObjC class name to a Lisp class name
304
305	(defun objc-to-lisp-classname (str &optional (package package))
306	(let ((sym
307	(or (gethash str lisp-classname-table)
308	(compute-lisp-name str package))))
309	(setf (gethash sym objc-classname-table) str)
310	(setf (gethash str lisp-classname-table) sym)))
311
312
313	;;; Translate a Lisp class name to an ObjC class name
314
315	(defun lisp-to-objc-classname (sym)
316	(let ((str
317	(or (gethash sym objc-classname-table)
318	(compute-objc-classname sym))))
319	(setf (gethash str lisp-classname-table) sym)
320	(setf (gethash sym objc-classname-table) str)))
321
322
323	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
324	;;;; Message Keyword Translation ;;;;
325	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
326
327	;;; Hash tables for caching initializer translations
328
329	(defvar lisp-message-table (make-hash-table :test #'equal))
330	(defvar objc-message-table (make-hash-table :test #'equal))
331
332
333	;;; Define a hard-wired message-keyword translation (if the automatic
334	;;; translation doesn't apply)
335
336	(defmacro define-message-translation (message msg-keywords)
337	(let ((message-temp (gensym))
338	(msg-keywords-temp (gensym))
339	(old-message-temp (gensym))
340	(old-msg-keywords-temp (gensym)))
341	`(let* ((,message-temp ',message)
342	(,msg-keywords-temp ',msg-keywords)
343	(,old-message-temp
344	(gethash ,message-temp lisp-message-table))
345	(,old-msg-keywords-temp
346	(gethash ,msg-keywords-temp objc-message-table)))
347	(remhash ,old-message-temp lisp-message-table)
348	(remhash ,old-msg-keywords-temp objc-message-table)
349	(setf (gethash ,message-temp lisp-message-table) ,msg-keywords-temp)
350	(setf (gethash ,msg-keywords-temp objc-message-table) ,message-temp)
351	(values))))
352
353
354	;;; Translate an ObjC message to a list of Lisp message keywords
355
356	(defun objc-to-lisp-message (message)
357	(let ((msg-keywords
358	(or (gethash message lisp-message-table)
359	(compute-objc-to-lisp-message message))))
360	(setf (gethash msg-keywords objc-message-table) message)
361	(setf (gethash message lisp-message-table) msg-keywords)))
362
363
364	;;; Translate a set of Lisp message keywords to an ObjC message
365
366	(defun lisp-to-objc-message (msg-keywords)
367	(let ((message
368	(or (gethash msg-keywords objc-message-table)
369	(compute-lisp-to-objc-message msg-keywords))))
370	(setf (gethash message lisp-message-table) msg-keywords)
371	(setf (gethash msg-keywords objc-message-table) message)))
372
373
374	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
375	;;;; Initializer Translation ;;;;
376	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
377
378	;;; Hash tables for caching initializer translations
379
380	(defvar lisp-initializer-table (make-hash-table :test #'equal))
381	(defvar objc-initializer-table (make-hash-table :test #'equal))
382
383
384	;;; Define a hard-wired init-keyword translation (if the automatic
385	;;; translation doesn't apply)
386
387	(defmacro define-init-translation (initmsg initargs)
388	(let ((initmsg-temp (gensym))
389	(initargs-temp (gensym))
390	(old-initmsg-temp (gensym))
391	(old-initargs-temp (gensym)))
392	`(let* ((,initmsg-temp ',initmsg)
393	(,initargs-temp ',initargs)
394	(,old-initmsg-temp
395	(gethash ,initmsg-temp lisp-initializer-table))
396	(,old-initargs-temp
397	(gethash ,initargs-temp objc-initializer-table)))
398	(remhash ,old-initmsg-temp lisp-initializer-table)
399	(remhash ,old-initargs-temp objc-initializer-table)
400	(setf (gethash ,initmsg-temp lisp-initializer-table) ,initargs-temp)
401	(setf (gethash ,initargs-temp objc-initializer-table) ,initmsg-temp)
402	(values))))
403
404
405	;;; Translate an ObjC initializer to a list of Lisp initargs
406
407	(defun objc-to-lisp-init (initmsg)
408	(let ((initargs
409	(or (gethash initmsg lisp-initializer-table)
410	(compute-objc-to-lisp-init initmsg))))
411	(setf (gethash initargs objc-initializer-table) initmsg)
412	(setf (gethash initmsg lisp-initializer-table) initargs)))
413
414
415	;;; Translate a set of Lisp initargs to an ObjC initializer
416
417	(defun lisp-to-objc-init (initargs)
418	(let ((initmsg
419	(or (gethash initargs objc-initializer-table)
420	(compute-lisp-to-objc-init initargs))))
421	(setf (gethash initmsg lisp-initializer-table) initargs)
422	(setf (gethash initargs objc-initializer-table) initmsg)))

Note: See TracBrowser for help on using the repository browser.

Download in other formats: