[armedbear-devel] "Hardcoding" methods that funcall a symbol
Theam Yong Chew
senatorzergling at gmail.com
Mon Dec 16 23:49:44 UTC 2013
On 12/16/13, Pascal J. Bourguignon <pjb at informatimago.com> wrote:
> Theam Yong Chew <senatorzergling at gmail.com> writes:
>
>> I also updated java:jnew-runtime-class's docstring, but I'm not sure
>> if the wording "function designator" is accurate enough, since
>> (funcall '(lambda () 1)) => 1
>>
>> Would '(lambda () 1) be considered a FUNCTION DESIGNATOR?
>
> CLHS Glossary says:
>
> function designator n. a designator for a function; that is, an
> object that denotes a function and that is one of: a symbol
> (denoting the function named by that symbol in the global
> environment), or a function (denoting itself). The consequences are
> undefined if a symbol is used as a function designator but it does
> not have a global definition as a function, or it has a global
> definition as a macro or a special form. See also extended function
> designator.
>
> therefore:
>
> (defun function-designator-p (object)
> (or (symbolp object)
> (functionp object)))
>
> (function-designator-p '(lambda () 1))
> --> NIL
>
> So, the answer is no.
>
>
>
> --
> __Pascal Bourguignon__
> http://www.informatimago.com/
>
Ok, I did see that. I was momentarily confused by ABCL's behaviour, it
accepted this,
CL-USER(1): (funcall '(lambda (x) 1) 1)
==> 1
whereas in SBCL: (funcall '(lambda (x) 1) 1) leads to an error.
The value (LAMBDA (X) 1) is not of type (OR FUNCTION SYMBOL).
[Condition of type TYPE-ERROR]
Restarts:
0: [ABORT] Exit debugger, returning to top level.
...
After re-reading CLHS (glossary, FUNCALL, APPLY etc), this seems
expected. I'm also trying to remember, this seems to that conform to
my muscle memory more consistently as well.
I was going to modify my patch to change "FUNCTION designator" ->
"FUNCALLable Lisp object" instead, but perhaps ABCL's APPLY needs to
be modified instead? Is this non-compliant behaviour?
Yong
-------------- next part --------------
Index: src/org/armedbear/lisp/runtime-class.lisp
===================================================================
--- src/org/armedbear/lisp/runtime-class.lisp (revision 14590)
+++ src/org/armedbear/lisp/runtime-class.lisp (working copy)
@@ -30,7 +30,7 @@
Method definitions are lists of the form
(method-name return-type argument-types function &key modifiers annotations)
where method-name is a string, return-type and argument-types are strings or keywords for
- primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity
+ primitive types (:void, :int, etc.), and function is a FUNCALLable Lisp object of minimum arity
(1+ (length argument-types)); the instance (`this') is passed in as the first argument.
Field definitions are lists of the form (field-name type &key modifiers annotations)."
@@ -116,59 +116,104 @@
(t
(error "Unsupported return type: ~A" return-type))))
+(defun java::runtime-class-common-add-method-boxer (argument-types)
+ (let ((argc (length argument-types)))
+ ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
+ (dotimes (i (* 2 (1+ argc)))
+ (allocate-register nil))
+ ;;Box "this" (to be passed as the first argument to the Lisp function)
+ (aload 0)
+ (emit 'iconst_1) ;;true
+ (emit-invokestatic +abcl-java-object+ "getInstance"
+ (list +java-object+ :boolean) +lisp-object+)
+ (astore (1+ argc))
+ ;;Box each argument
+ (loop
+ :for arg-type :in argument-types
+ :for i :from 1
+ :do (progn
+ (cond
+ ((keywordp arg-type)
+ (error "Unsupported arg-type: ~A" arg-type))
+ ((eq arg-type :int) :todo)
+ (t (aload i)
+ (emit 'iconst_1) ;;true
+ (emit-invokestatic +abcl-java-object+ "getInstance"
+ (list +java-object+ :boolean) +lisp-object+)))
+ (astore (+ i (1+ argc)))))))
+
+(defun java::runtime-class-common-add-method-return (argument-types return-type)
+ (let ((argc (length argument-types)))
+ (if (<= (1+ argc) call-registers-limit)
+ (progn
+ ;;Load the boxed this
+ (aload (1+ argc))
+ ;;Load each boxed argument
+ (dotimes (i argc)
+ (aload (+ argc 2 i))))
+ (error "execute(LispObject[]) is currently not supported")))
+ (emit-call-execute (1+ (length argument-types)))
+ (java::emit-unbox-and-return return-type))
+
+(defun java::runtime-class-add-normal-method-body (function class-file field-name argument-types return-type)
+ (java::runtime-class-common-add-method-boxer argument-types)
+ ;;Load the Lisp function from its static field
+ (emit-getstatic (class-file-class class-file) field-name +lisp-object+)
+ (java::runtime-class-common-add-method-return argument-types return-type))
+
+(defun java::runtime-class-add-symbol-method-body (function class-file field-name argument-types return-type)
+ ;; symbol = org.armedbear.lisp.Packages.findPackage(<package>).findAccessibleSymbol(<symbol-name>)
+ (emit 'ldc (pool-add-string *pool* (package-name (symbol-package function))))
+ (emit-invokestatic +lisp-packages+
+ "findPackage"
+ (list +java-string+)
+ +lisp-package+)
+ (let* ((num-locals (* 2 (1+ (length argument-types))))
+ (local-var-1-index (+ 0 num-locals))
+ (local-var-2-index (+ 1 num-locals)))
+ (dotimes (i 2) (allocate-register nil))
+ (astore local-var-1-index)
+ (aload local-var-1-index)
+ (emit 'ldc (pool-add-string *pool* (symbol-name function)))
+ (emit-invokevirtual +lisp-package+
+ "findAccessibleSymbol"
+ (list +java-string+)
+ +lisp-symbol+)
+ (astore local-var-2-index)
+ (aload local-var-2-index))
+ (java::runtime-class-common-add-method-boxer argument-types)
+ (java::runtime-class-common-add-method-return argument-types return-type))
+
(defun java::runtime-class-add-methods (class-file methods)
+ "Lisp functions (lisp objects) are saved and referenced from
+ public static class fields, while symbols (function names) are
+ hardcoded into the method body to be funcalled. The user must
+ separately ensure the callee function is loaded/maintained within
+ the Lisp Interpreter. No additional handling is provided here for
+ serialising/deserialising the function definition. That means if
+ this class is loaded from a new Interpreter (for instance from a
+ class file), the method call will fail."
(let (method-implementation-fields)
(dolist (m methods)
(destructuring-bind (name return-type argument-types function
&key (modifiers '(:public)) annotations override) m
(let* ((argument-types (mapcar #'java::canonicalize-java-type argument-types))
- (argc (length argument-types))
(return-type (java::canonicalize-java-type return-type))
(jmethod (make-jvm-method name return-type argument-types :flags modifiers))
(field-name (string (gensym name))))
(class-add-method class-file jmethod)
- (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
- (class-add-field class-file field)
- (push (cons field-name function) method-implementation-fields))
+ (unless (symbolp function)
+ (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
+ (class-add-field class-file field)
+ (push (cons field-name function) method-implementation-fields)))
(when annotations
(method-add-attribute jmethod (make-runtime-visible-annotations-attribute
:list (mapcar #'parse-annotation annotations))))
(with-code-to-method (class-file jmethod)
- ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
- (dotimes (i (* 2 (1+ argc)))
- (allocate-register nil))
- ;;Box "this" (to be passed as the first argument to the Lisp function)
- (aload 0)
- (emit 'iconst_1) ;;true
- (emit-invokestatic +abcl-java-object+ "getInstance"
- (list +java-object+ :boolean) +lisp-object+)
- (astore (1+ argc))
- ;;Box each argument
- (loop
- :for arg-type :in argument-types
- :for i :from 1
- :do (progn
- (cond
- ((keywordp arg-type)
- (error "Unsupported arg-type: ~A" arg-type))
- ((eq arg-type :int) :todo)
- (t (aload i)
- (emit 'iconst_1) ;;true
- (emit-invokestatic +abcl-java-object+ "getInstance"
- (list +java-object+ :boolean) +lisp-object+)))
- (astore (+ i (1+ argc)))))
- ;;Load the Lisp function from its static field
- (emit-getstatic (class-file-class class-file) field-name +lisp-object+)
- (if (<= (1+ argc) call-registers-limit)
- (progn
- ;;Load the boxed this
- (aload (1+ argc))
- ;;Load each boxed argument
- (dotimes (i argc)
- (aload (+ argc 2 i))))
- (error "execute(LispObject[]) is currently not supported"))
- (emit-call-execute (1+ (length argument-types)))
- (java::emit-unbox-and-return return-type))
+ (funcall (if (symbolp function)
+ 'java::runtime-class-add-symbol-method-body
+ 'java::runtime-class-add-normal-method-body)
+ function class-file field-name argument-types return-type))
(cond
((eq override t)
(let ((super-method
Index: src/org/armedbear/lisp/jvm-class-file.lisp
===================================================================
--- src/org/armedbear/lisp/jvm-class-file.lisp (revision 14590)
+++ src/org/armedbear/lisp/jvm-class-file.lisp (working copy)
@@ -200,6 +200,7 @@
"org.armedbear.lisp.CompiledPrimitive")
(define-class-name +lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable")
(define-class-name +lisp-hash-table+ "org.armedbear.lisp.HashTable")
+(define-class-name +lisp-packages+ "org.armedbear.lisp.Packages")
(define-class-name +lisp-package+ "org.armedbear.lisp.Package")
(define-class-name +lisp-readtable+ "org.armedbear.lisp.Readtable")
(define-class-name +lisp-stream+ "org.armedbear.lisp.Stream")
@@ -1734,4 +1735,4 @@
|#
-(provide '#:jvm-class-file)
\ No newline at end of file
+(provide '#:jvm-class-file)
More information about the armedbear-devel
mailing list