summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/defpackage.lisp1
-rw-r--r--Lisp/method-definition.lisp41
-rw-r--r--Lisp/method-invocation.lisp11
-rw-r--r--Lisp/name-conversion.lisp4
4 files changed, 47 insertions, 10 deletions
diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
index c14fca9..074e8ab 100644
--- a/Lisp/defpackage.lisp
+++ b/Lisp/defpackage.lisp
@@ -40,6 +40,7 @@
#:undefine-returns-boolean-exception
#:collect-classes
#:collect-methods
+ #:super
;; Generic functions
#:objc-eql
diff --git a/Lisp/method-definition.lisp b/Lisp/method-definition.lisp
index edba760..b83570e 100644
--- a/Lisp/method-definition.lisp
+++ b/Lisp/method-definition.lisp
@@ -78,9 +78,13 @@ undefined."))
*name* --- a *symbol*.
-*lambda-list* --- a **generic function lambda list**.
+*qualifier* --- a **method qualifier**.
-*options* --- a *list* (not evaluated).
+*return-type* --- a *typespec*.
+
+*lambda-list* --- a **modified lambda list**.
+
+*body* --- an **implicit progn**.
## Description:
@@ -100,6 +104,9 @@ following aspects:
_define-objective-c-generic-function_ recognises the same *options* as
__defgeneric__, including _:generic-function-class_ and _:method-class_.
+The **lexical environment** of *body* is augmented to include the
+function __super__.
+
## Example:
@@ -160,7 +167,8 @@ __define-objective-c-generic-function__.
## See also:
- __define-objective-c-generic-function__, __define-objective-c-class__"
+ __define-objective-c-generic-function__, __define-objective-c-class__,
+__super__"
(let ((qualifiers (list)))
(loop until (listp (first args))
do (push (pop args) qualifiers))
@@ -173,6 +181,7 @@ __define-objective-c-generic-function__.
if (listp arg)
if (typep (second arg) 'objective-c-type-keyword)
collect (second arg) into type-specifiers
+ and collect (first arg) into arg-names
and do (setf (car arg-cons) (first arg))
else
;; We simply map all non-OBJECTIVE-C-TYPE-KEYWORD
@@ -184,14 +193,28 @@ __define-objective-c-generic-function__.
;; kind to the method, whose type specifier is :ID as
;; well.
collect :id into type-specifiers
+ and collect (first arg) into arg-names
else
collect :id into type-specifiers
- finally (return
- `(defmethod ,(intern (symbol-name name)
- '#:objective-c-methods)
- argtypes-start ,@type-specifiers argtypes-end
- ,@qualifiers ,lambda-list
- ,@body)))))))
+ and collect arg into arg-names
+ finally (let ((super-args-sym (gensym))
+ (super-real-args-sym (gensym)))
+ (return
+ `(defmethod ,(intern (symbol-name name)
+ '#:objective-c-methods)
+ argtypes-start ,@type-specifiers argtypes-end
+ ,@qualifiers ,lambda-list
+ (flet ((super (&rest ,super-args-sym)
+ (let ((,super-real-args-sym
+ (or ,super-args-sym
+ (list ,@(rest arg-names)))))
+ (invoke-by-name-super-v
+ ,(first arg-names)
+ ,(generic-function-name->method-name
+ name)
+ (find-objc-class ',(cadar lambda-list))
+ ,super-real-args-sym))))
+ ,@body)))))))))
(defmacro defobjcgeneric (name lambda-list &body options)
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 8f1c9c0..ab520df 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -207,6 +207,11 @@ easier to use with __apply__.
__invoke__"
+ (invoke-by-name-super-v receiver method-name nil args))
+
+
+(defun invoke-by-name-super-v (receiver method-name superclass-for-send-super
+ args)
;; TODO: Support varargs.
(let* ((selector (if (typep method-name 'selector)
method-name
@@ -227,7 +232,11 @@ easier to use with __apply__.
argc (+ 2 (length args)))
(low-level-invoke receiver
selector
- (null-pointer)
+ (if (and superclass-for-send-super
+ (not (and (pointerp superclass-for-send-super)
+ (null-pointer-p superclass-for-send-super))))
+ (pointer-to superclass-for-send-super)
+ (null-pointer))
method-return-typestring
method-return-type
method-arg-typestrings
diff --git a/Lisp/name-conversion.lisp b/Lisp/name-conversion.lisp
index 1596d84..028d722 100644
--- a/Lisp/name-conversion.lisp
+++ b/Lisp/name-conversion.lisp
@@ -35,6 +35,10 @@
:initial-value ""))
+(defun generic-function-name->method-name (gf-name)
+ (symbol-name gf-name))
+
+
(defun generic-function-name->selector (gf-name)
(selector (symbol-name gf-name)))