source: trunk/source/objc-bridge/name-translation.lisp @ 13537

Last change on this file since 13537 was 9592, checked in by gb, 11 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.