;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: pjb-objc-genel
;;;;LANGUAGE: emacs lisp
;;;;SYSTEM: POSIX
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Generate some Objective-C code.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal Bourguignon <pbourguignon@dxo.com>
;;;;MODIFICATIONS
;;;; 2012-11-12 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal Bourguignon 2012 - 2012
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(require 'pjb-cl)
(defun ensure-string (object)
(typecase object
(string object)
(symbol (symbol-name object))
(list (apply 'string object))
(t (prin1-to-string object))))
(defun make-set-selector (selector)
"Return a setSelector: selector."
(let ((name (ensure-string selector)))
(intern (if (and (< 2 (length name))
(string= "is" (substring name 0 2))
(upper-case-p (aref name 2)))
(format "set%s:" (subseq name 2))
(format "set%c%s:" (char-upcase (aref name 0)) (subseq name 1))))))
(defun split-selector (selector)
(let* ((parts (reverse (split-string (ensure-string selector) ":")))
(parts-with-args (mapcar (lambda (part) (format "%s:" part)) (rest parts))))
(mapcar (function intern)
(nreverse (if (string= "" (first parts))
parts-with-args
(cons (first parts)parts-with-args))))))
(defun test/split-selector ()
(assert (equal (split-selector 'isObscure) '(isObscure)))
(assert (equal (split-selector 'setObscure:) '(setObscure:)))
(assert (equal (split-selector 'initWithCoordinates::) '(initWithCoordinates: :)))
(assert (equal (split-selector 'initWithFrame:andObject:) '(initWithFrame: andObject:)))
:success)
(defmacro* with-parens (parens &body body)
`(progn
(insert ,(elt parens 0))
(prog1 (progn ,@body)
(insert ,(elt parens 1)))))
(defclass c-node ()
())
(defun generate (node)
(if (typep node 'c-node)
(generate-node node)
(insert (format "%S" node))))
(defmacro* defclass/c (class-name (&rest superclasses) (&rest slots) &rest options)
`(progn
(defclass ,class-name ,superclasses ,slots ,@options)
(defun* ,(intern (format "make-%s" class-name)) (&rest arguments &key &allow-other-keys)
(apply 'make-instance ',class-name arguments))
',class-name))
(defmacro* with-parens (parens &body body)
`(progn
(insert ,(elt parens 0))
(prog1 (progn ,@body)
(insert ,(elt parens 1)))))
(defmethod generate-node ((node c-node))
(with-parens ("/*" "*/\n")
(insert (format "ERROR: Missing generate-node method for %S" node))))
(defclass c-declaration (c-node)
())
(defclass c-definition (c-node)
())
(defclass c-statement (c-node)
())
(defclass c-expression (c-node)
())
(defclass/c c-dot (c-expression)
((object :initarg :object :accessor c-dot-object)
(slot :initarg :slot :accessor c-dot-slot)))
(defmethod generate-node ((node c-dot))
(insert (format "%s.%s" (c-dot-object node) (c-dot-slot node))))
(defclass/c c-assign (c-expression)
((lval :initarg :lval :accessor c-assign-lval)
(rval :initarg :rval :accessor c-assign-rval)))
(defmethod generate-node ((node c-assign))
(generate (c-assign-lval node))
(insert " = ")
(generate (c-assign-rval node)))
(defclass/c c-cond (c-statement)
((clauses :initarg :clauses :accessor c-cond-clauses
:documentation "A list, the first element is the condition expression, the rest is a list of statement body.")))
(defmethod generate-node ((node c-cond))
(loop
for insert-else = nil then t
for (condition . body) in (c-cond-clauses node)
do (progn
(when insert-else
(insert "else "))
(with-parens ("if(" ")\n")
(generate condition))
(generate (make-c-block :statements body)))))
(defclass/c c-return (c-statement)
((result :initarg :result :accessor c-return-result)))
(defmethod generate-node ((node c-return))
(with-parens ("return " "")
(generate (c-return-result node))))
(defclass/c c-block (c-statement)
((statements :initarg :statements :accessor c-block-statements)))
(defmethod generate-node ((node c-block))
(with-parens ("{\n" "}\n")
(dolist (statement (c-block-statements node))
(generate statement)
(insert ";\n"))))
(defclass objc-definition (c-definition)
())
(defclass objc-declaration (c-declaration)
())
(defclass objc-expression (c-expression)
())
(defmacro generate-constructor (&rest class-names)
`(progn
,@(mapcar (lambda (class-name)
`(defun* ,(intern (format "make-%s" class-name)) (&rest arguments &key &allow-other-keys)
(apply 'make-instance ',class-name arguments)))
class-names)
',class-names))
(defun generate-intermingled-selector-and-things (selector things)
"Inserts a method signature, or a message sending.
`selector': an Objective-C selector designator.
`things': a list of objc-parameter or objc-argument.
"
(loop
with selector-parts = (split-selector selector)
with arguments = things
for sep = "" then " "
while selector-parts
do (progn
(insert sep)
(generate (pop selector-parts))
(when arguments
(generate (pop arguments))))
finally (loop while arguments
do (insert "," (pop arguments)))))
(defclass/c objc-string (objc-expression)
((string :initarg :string :accessor objc-string-string)))
(defmethod generate-node ((node objc-string))
(let ((string (objc-string-string node)))
(insert (format "@%S" (typecase string
(string string)
(symbol (symbol-name string))
(t (prin1-to-string string)))))))
(defclass/c objc-method (objc-definition)
((instance-method :initform t :reader objc-method-instance-method-p)
(result-type :initform 'void :initarg :result-type :accessor objc-method-result-type)
(selector :initarg :selector :accessor objc-method-selector)
(parameters :initform '() :initarg :parameters :accessor objc-method-parameters)
(body :initform '() :initarg :body :accessor objc-method-body)))
(defclass/c objc-class-method (objc-method)
((instance-method :initform nil :reader objc-method-instance-method-p)))
(defmethod objc-method-sign ((node objc-method)) "-")
(defmethod objc-method-sign ((node objc-class-method)) "+")
(defmethod generate-node ((node objc-method))
(insert (format "\n\n%s " (objc-method-sign node)))
(with-parens ("(" ")")
(insert (ensure-string (objc-method-result-type node))))
(generate-intermingled-selector-and-things (objc-method-selector node) (objc-method-parameters node))
(insert "\n")
(generate (make-c-block :statements (objc-method-body node))))
(defclass/c objc-send (objc-expression)
((recipient :initarg :recipient :accessor objc-send-recipient)
(selector :initarg :selector :accessor objc-send-selector)
(arguments :initform '() :initarg :arguments :accessor objc-send-arguments)))
(defmethod generate-node ((node objc-send))
(with-parens ("[" "]")
(generate (objc-send-recipient node))
(insert " ")
(generate-intermingled-selector-and-things (objc-send-selector node) (objc-send-arguments node))))
(defclass/c objc-parameter (objc-declaration)
((type :initarg :type :accessor objc-parameter-type)
(name :initarg :name :accessor objc-parameter-name)))
(defmethod generate-node ((node objc-parameter))
(insert (format "(%s)%s " (objc-parameter-type node) (objc-parameter-name node))))
(defun generate-forward-methods (properties target)
"Inserts methods for the given properties that forward to the give target.
`properties': a list of property descriptor. Each one is a list
containing a type, and a property name or a list (getter setter).
`target': a target object to which the messages are forwarded.
"
(loop
for (type prop-name) in properties
do (let ((getter (if (atom prop-name)
prop-name
(first prop-name)))
(setter (if (atom prop-name)
(make-set-selector prop-name)
(second prop-name))))
(generate (make-objc-method :result-type type
:selector getter
:parameters '()
:body (list (make-c-return :result (make-objc-send :recipient target
:selector getter)))))
(generate (make-objc-method :result-type 'void
:selector setter
:parameters (list (make-objc-parameter :type type :name 'value))
:body (list (make-objc-send :recipient target
:selector setter
:arguments '(value))))))))
(defun test/pjb-objc-gen ()
(test/split-selector))
(test/pjb-objc-gen)
(provide 'pjb-objc-gen)
;;;; THE END ;;;;