diff options
Diffstat (limited to 'Lisp')
| -rw-r--r-- | Lisp/libobjcl.lisp | 15 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 44 | ||||
| -rw-r--r-- | Lisp/name-conversion.lisp | 42 |
3 files changed, 57 insertions, 44 deletions
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index e4b64f0..4f420b9 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -90,21 +90,6 @@ objects or classes, let alone send messages to them. (class obj-data)) -(defun symbol->objc-class-name (symbol) - (let ((components (split-sequence #\- (symbol-name symbol) - :remove-empty-subseqs t))) - (reduce #'(lambda (x y) (concatenate 'string x y)) - (mapcar #'(lambda (x) - (concatenate 'string - (string (char x 0)) - (string-downcase (subseq x 1)))) - (subseq components 1)) - :initial-value (concatenate 'string - (string (char (first components) 0)) - (string-upcase - (subseq (first components) 1)))))) - - (defun find-objc-class (class-name) "Retrieve an Objective C class by name. diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index 6461743..b446015 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -65,35 +65,21 @@ if as the second **argument** to __invoke-by-name__. __invoke-by-name__" - (flet ((message-component->string (symbol) - (let* ((components (split-sequence #\- (symbol-name symbol) - :remove-empty-subseqs t)) - (acc-string - (reduce #'(lambda (x y) (concatenate 'string x y)) - (mapcar #'(lambda (x) - (concatenate 'string - (string (char x 0)) - (string-downcase (subseq x 1)))) - (subseq components 1)) - :initial-value (string-downcase (first components))))) - (if (eql (find-package '#:keyword) - (symbol-package symbol)) - (concatenate 'string acc-string ":") - acc-string)))) - (do* ((components-left (cons message-start message-components) - (cddr components-left)) - (message-string (message-component->string message-start) - (concatenate 'string - message-string - (message-component->string (first components-left)))) - (arglist (if (null (rest components-left)) - nil - (list (second components-left))) - (if (null (rest components-left)) - arglist - (cons (second components-left) arglist)))) - ((null (cddr components-left)) - (apply #'invoke-by-name receiver message-string (nreverse arglist)))))) + (do* ((components-left (cons message-start message-components) + (cddr components-left)) + (message-list (list message-start) + (cons (first components-left) message-list)) + (arglist (if (null (rest components-left)) + nil + (list (second components-left))) + (if (null (rest components-left)) + arglist + (cons (second components-left) arglist)))) + ((null (cddr components-left)) + (apply #'invoke-by-name + receiver + (symbol-list->message-name (nreverse message-list)) + (nreverse arglist))))) (defun invoke-by-name (receiver method-name &rest args) diff --git a/Lisp/name-conversion.lisp b/Lisp/name-conversion.lisp new file mode 100644 index 0000000..900e4d0 --- /dev/null +++ b/Lisp/name-conversion.lisp @@ -0,0 +1,42 @@ +(in-package #:mulk.objective-cl) + + +;;; (@* "Message and selector names") +(defun message-component->string (symbol) + (let* ((components (split-sequence #\- (symbol-name symbol) + :remove-empty-subseqs t)) + (acc-string + (reduce #'(lambda (x y) (concatenate 'string x y)) + (mapcar #'(lambda (x) + (concatenate 'string + (string (char x 0)) + (string-downcase (subseq x 1)))) + (subseq components 1)) + :initial-value (string-downcase (first components))))) + (if (eql (find-package '#:keyword) + (symbol-package symbol)) + (concatenate 'string acc-string ":") + acc-string))) + + +(defun symbol-list->message-name (symbol-list) + (reduce #'(lambda (acc symbol) + (concatenate 'string acc (message-component->string symbol))) + symbol-list + :initial-value "")) + + +;;; (@* "Class names") +(defun symbol->objc-class-name (symbol) + (let ((components (split-sequence #\- (symbol-name symbol) + :remove-empty-subseqs t))) + (reduce #'(lambda (x y) (concatenate 'string x y)) + (mapcar #'(lambda (x) + (concatenate 'string + (string (char x 0)) + (string-downcase (subseq x 1)))) + (subseq components 1)) + :initial-value (concatenate 'string + (string (char (first components) 0)) + (string-upcase + (subseq (first components) 1)))))) |