[Openmcl-cvs-notifications] r11436 - in /trunk/source/examples/jfli: CPL.TXT docs/jfli.css docs/jfli.html examples/session.lisp examples/swtdemo.lisp jfli.lisp jni.lisp
gb at clozure.com
gb at clozure.com
Thu Nov 27 12:40:41 EST 2008
Author: gb
Date: Thu Nov 27 12:40:41 2008
New Revision: 11436
Log:
svn didn't fix line termination. M-% did.
Modified:
trunk/source/examples/jfli/CPL.TXT
trunk/source/examples/jfli/docs/jfli.css
trunk/source/examples/jfli/docs/jfli.html
trunk/source/examples/jfli/examples/session.lisp
trunk/source/examples/jfli/examples/swtdemo.lisp
trunk/source/examples/jfli/jfli.lisp
trunk/source/examples/jfli/jni.lisp
Modified: trunk/source/examples/jfli/CPL.TXT
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/jfli/CPL.TXT (original)
+++ trunk/source/examples/jfli/CPL.TXT Thu Nov 27 12:40:41 2008
@@ -1,94 +1,94 @@
-Common Public License Version 1.0
-
-THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS COMMON PUBLIC=
LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRA=
M CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
-
-
-1. DEFINITIONS =
-
-"Contribution" means:
-
-a) in the case of the initial Contributor, the initial code and documentat=
ion distributed under this Agreement, and =
-
-b) in the case of each subsequent Contributor:
-
-i) changes to the Program, and
-
-ii) additions to the Program;
-
-where such changes and/or additions to the Program originate from and are =
distributed by that particular Contributor. A Contribution 'originates' fro=
m a Contributor if it was added to the Program by such Contributor itself o=
r anyone acting on such Contributor's behalf. Contributions do not include =
additions to the Program which: (i) are separate modules of software distri=
buted in conjunction with the Program under their own license agreement, an=
d (ii) are not derivative works of the Program.
-
-"Contributor" means any person or entity that distributes the Program. =
-
-"Licensed Patents " mean patent claims licensable by a Contributor which a=
re necessarily infringed by the use or sale of its Contribution alone or wh=
en combined with the Program.
-
-"Program" means the Contributions distributed in accordance with this Agre=
ement. =
-
-"Recipient" means anyone who receives the Program under this Agreement, in=
cluding all Contributors. =
-
-
-2. GRANT OF RIGHTS
-
-a) Subject to the terms of this Agreement, each Contributor hereby grants =
Recipient a non-exclusive, worldwide, royalty-free copyright license to rep=
roduce, prepare derivative works of, publicly display, publicly perform, di=
stribute and sublicense the Contribution of such Contributor, if any, and s=
uch derivative works, in source code and object code form.
-
-b) Subject to the terms of this Agreement, each Contributor hereby grants =
Recipient a non-exclusive, worldwide, royalty-free patent license under Lic=
ensed Patents to make, use, sell, offer to sell, import and otherwise trans=
fer the Contribution of such Contributor, if any, in source code and object=
code form. This patent license shall apply to the combination of the Contr=
ibution and the Program if, at the time the Contribution is added by the Co=
ntributor, such addition of the Contribution causes such combination to be =
covered by the Licensed Patents. The patent license shall not apply to any =
other combinations which include the Contribution. No hardware per se is li=
censed hereunder.
-
-c) Recipient understands that although each Contributor grants the license=
s to its Contributions set forth herein, no assurances are provided by any =
Contributor that the Program does not infringe the patent or other intellec=
tual property rights of any other entity. Each Contributor disclaims any li=
ability to Recipient for claims brought by any other entity based on infrin=
gement of intellectual property rights or otherwise. As a condition to exer=
cising the rights and licenses granted hereunder, each Recipient hereby ass=
umes sole responsibility to secure any other intellectual property rights n=
eeded, if any. For example, if a third party patent license is required to =
allow Recipient to distribute the Program, it is Recipient's responsibility=
to acquire that license before distributing the Program.
-
-d) Each Contributor represents that to its knowledge it has sufficient cop=
yright rights in its Contribution, if any, to grant the copyright license s=
et forth in this Agreement.
-
-
-3. REQUIREMENTS =
-
-A Contributor may choose to distribute the Program in object code form und=
er its own license agreement, provided that: =
-
-a) it complies with the terms and conditions of this Agreement; and
-
-b) its license agreement:
-
-i) effectively disclaims on behalf of all Contributors all warranties and =
conditions, express and implied, including warranties or conditions of titl=
e and non-infringement, and implied warranties or conditions of merchantabi=
lity and fitness for a particular purpose; =
-
-ii) effectively excludes on behalf of all Contributors all liability for d=
amages, including direct, indirect, special, incidental and consequential d=
amages, such as lost profits; =
-
-iii) states that any provisions which differ from this Agreement are offer=
ed by that Contributor alone and not by any other party; and =
-
-iv) states that source code for the Program is available from such Contrib=
utor, and informs licensees how to obtain it in a reasonable manner on or t=
hrough a medium customarily used for software exchange. =
-
-When the Program is made available in source code form:
-
-a) it must be made available under this Agreement; and
-
-b) a copy of this Agreement must be included with each copy of the Program=
. =
-
-Contributors may not remove or alter any copyright notices contained withi=
n the Program.
-
-Each Contributor must identify itself as the originator of its Contributio=
n, if any, in a manner that reasonably allows subsequent Recipients to iden=
tify the originator of the Contribution. =
-
-
-4. COMMERCIAL DISTRIBUTION =
-
-Commercial distributors of software may accept certain responsibilities wi=
th respect to end users, business partners and the like. While this license=
is intended to facilitate the commercial use of the Program, the Contribut=
or who includes the Program in a commercial product offering should do so i=
n a manner which does not create potential liability for other Contributors=
. Therefore, if a Contributor includes the Program in a commercial product =
offering, such Contributor ("Commercial Contributor") hereby agrees to defe=
nd and indemnify every other Contributor ("Indemnified Contributor") agains=
t any losses, damages and costs (collectively "Losses") arising from claims=
, lawsuits and other legal actions brought by a third party against the Ind=
emnified Contributor to the extent caused by the acts or omissions of such =
Commercial Contributor in connection with its distribution of the Program i=
n a commercial product offering. The obligations in this section do not app=
ly to any claims or Losses relating to any actual or alleged intellectual p=
roperty infringement. In order to qualify, an Indemnified Contributor must:=
a) promptly notify the Commercial Contributor in writing of such claim, an=
d b) allow the Commercial Contributor to control, and cooperate with the Co=
mmercial Contributor in, the defense and any related settlement negotiation=
s. The Indemnified Contributor may participate in any such claim at its own=
expense. =
-
-For example, a Contributor might include the Program in a commercial produ=
ct offering, Product X. That Contributor is then a Commercial Contributor. =
If that Commercial Contributor then makes performance claims, or offers war=
ranties related to Product X, those performance claims and warranties are s=
uch Commercial Contributor's responsibility alone. Under this section, the =
Commercial Contributor would have to defend claims against the other Contri=
butors related to those performance claims and warranties, and if a court r=
equires any other Contributor to pay any damages as a result, the Commercia=
l Contributor must pay those damages. =
-
-
-5. NO WARRANTY
-
-EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED O=
N AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EX=
PRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITION=
S OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR P=
URPOSE. Each Recipient is solely responsible for determining the appropriat=
eness of using and distributing the Program and assumes all risks associate=
d with its exercise of rights under this Agreement, including but not limit=
ed to the risks and costs of program errors, compliance with applicable law=
s, damage to or loss of data, programs or equipment, and unavailability or =
interruption of operations. =
-
-
-6. DISCLAIMER OF LIABILITY =
-
-EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY=
CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL=
, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATIO=
N LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN =
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARI=
SING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE EXERCI=
SE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF S=
UCH DAMAGES. =
-
-
-7. GENERAL
-
-If any provision of this Agreement is invalid or unenforceable under appli=
cable law, it shall not affect the validity or enforceability of the remain=
der of the terms of this Agreement, and without further action by the parti=
es hereto, such provision shall be reformed to the minimum extent necessary=
to make such provision valid and enforceable. =
-
-If Recipient institutes patent litigation against a Contributor with respe=
ct to a patent applicable to software (including a cross-claim or countercl=
aim in a lawsuit), then any patent licenses granted by that Contributor to =
such Recipient under this Agreement shall terminate as of the date such lit=
igation is filed. In addition, if Recipient institutes patent litigation ag=
ainst any entity (including a cross-claim or counterclaim in a lawsuit) all=
eging that the Program itself (excluding combinations of the Program with o=
ther software or hardware) infringes such Recipient's patent(s), then such =
Recipient's rights granted under Section 2(b) shall terminate as of the dat=
e such litigation is filed.
-
-All Recipient's rights under this Agreement shall terminate if it fails to=
comply with any of the material terms or conditions of this Agreement and =
does not cure such failure in a reasonable period of time after becoming aw=
are of such noncompliance. If all Recipient's rights under this Agreement t=
erminate, Recipient agrees to cease use and distribution of the Program as =
soon as reasonably practicable. However, Recipient's obligations under this=
Agreement and any licenses granted by Recipient relating to the Program sh=
all continue and survive. =
-
-Everyone is permitted to copy and distribute copies of this Agreement, but=
in order to avoid inconsistency the Agreement is copyrighted and may only =
be modified in the following manner. The Agreement Steward reserves the rig=
ht to publish new versions (including revisions) of this Agreement from tim=
e to time. No one other than the Agreement Steward has the right to modify =
this Agreement. IBM is the initial Agreement Steward. IBM may assign the re=
sponsibility to serve as the Agreement Steward to a suitable separate entit=
y. Each new version of the Agreement will be given a distinguishing version=
number. The Program (including Contributions) may always be distributed su=
bject to the version of the Agreement under which it was received. In addit=
ion, after a new version of the Agreement is published, Contributor may ele=
ct to distribute the Program (including its Contributions) under the new ve=
rsion. Except as expressly stated in Sections 2(a) and 2(b) above, Recipien=
t receives no rights or licenses to the intellectual property of any Contri=
butor under this Agreement, whether expressly, by implication, estoppel or =
otherwise. All rights in the Program not expressly granted under this Agree=
ment are reserved. =
-
-This Agreement is governed by the laws of the State of New York and the in=
tellectual property laws of the United States of America. No party to this =
Agreement will bring a legal action under this Agreement more than one year=
after the cause of action arose. Each party waives its rights to a jury tr=
ial in any resulting litigation.
+Common Public License Version 1.0
+
+THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS COMMON PUBLIC=
LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRA=
M CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
+
+
+1. DEFINITIONS =
+
+"Contribution" means:
+
+a) in the case of the initial Contributor, the initial code and documentat=
ion distributed under this Agreement, and =
+
+b) in the case of each subsequent Contributor:
+
+i) changes to the Program, and
+
+ii) additions to the Program;
+
+where such changes and/or additions to the Program originate from and are =
distributed by that particular Contributor. A Contribution 'originates' fro=
m a Contributor if it was added to the Program by such Contributor itself o=
r anyone acting on such Contributor's behalf. Contributions do not include =
additions to the Program which: (i) are separate modules of software distri=
buted in conjunction with the Program under their own license agreement, an=
d (ii) are not derivative works of the Program.
+
+"Contributor" means any person or entity that distributes the Program. =
+
+"Licensed Patents " mean patent claims licensable by a Contributor which a=
re necessarily infringed by the use or sale of its Contribution alone or wh=
en combined with the Program.
+
+"Program" means the Contributions distributed in accordance with this Agre=
ement. =
+
+"Recipient" means anyone who receives the Program under this Agreement, in=
cluding all Contributors. =
+
+
+2. GRANT OF RIGHTS
+
+a) Subject to the terms of this Agreement, each Contributor hereby grants =
Recipient a non-exclusive, worldwide, royalty-free copyright license to rep=
roduce, prepare derivative works of, publicly display, publicly perform, di=
stribute and sublicense the Contribution of such Contributor, if any, and s=
uch derivative works, in source code and object code form.
+
+b) Subject to the terms of this Agreement, each Contributor hereby grants =
Recipient a non-exclusive, worldwide, royalty-free patent license under Lic=
ensed Patents to make, use, sell, offer to sell, import and otherwise trans=
fer the Contribution of such Contributor, if any, in source code and object=
code form. This patent license shall apply to the combination of the Contr=
ibution and the Program if, at the time the Contribution is added by the Co=
ntributor, such addition of the Contribution causes such combination to be =
covered by the Licensed Patents. The patent license shall not apply to any =
other combinations which include the Contribution. No hardware per se is li=
censed hereunder.
+
+c) Recipient understands that although each Contributor grants the license=
s to its Contributions set forth herein, no assurances are provided by any =
Contributor that the Program does not infringe the patent or other intellec=
tual property rights of any other entity. Each Contributor disclaims any li=
ability to Recipient for claims brought by any other entity based on infrin=
gement of intellectual property rights or otherwise. As a condition to exer=
cising the rights and licenses granted hereunder, each Recipient hereby ass=
umes sole responsibility to secure any other intellectual property rights n=
eeded, if any. For example, if a third party patent license is required to =
allow Recipient to distribute the Program, it is Recipient's responsibility=
to acquire that license before distributing the Program.
+
+d) Each Contributor represents that to its knowledge it has sufficient cop=
yright rights in its Contribution, if any, to grant the copyright license s=
et forth in this Agreement.
+
+
+3. REQUIREMENTS =
+
+A Contributor may choose to distribute the Program in object code form und=
er its own license agreement, provided that: =
+
+a) it complies with the terms and conditions of this Agreement; and
+
+b) its license agreement:
+
+i) effectively disclaims on behalf of all Contributors all warranties and =
conditions, express and implied, including warranties or conditions of titl=
e and non-infringement, and implied warranties or conditions of merchantabi=
lity and fitness for a particular purpose; =
+
+ii) effectively excludes on behalf of all Contributors all liability for d=
amages, including direct, indirect, special, incidental and consequential d=
amages, such as lost profits; =
+
+iii) states that any provisions which differ from this Agreement are offer=
ed by that Contributor alone and not by any other party; and =
+
+iv) states that source code for the Program is available from such Contrib=
utor, and informs licensees how to obtain it in a reasonable manner on or t=
hrough a medium customarily used for software exchange. =
+
+When the Program is made available in source code form:
+
+a) it must be made available under this Agreement; and
+
+b) a copy of this Agreement must be included with each copy of the Program=
. =
+
+Contributors may not remove or alter any copyright notices contained withi=
n the Program.
+
+Each Contributor must identify itself as the originator of its Contributio=
n, if any, in a manner that reasonably allows subsequent Recipients to iden=
tify the originator of the Contribution. =
+
+
+4. COMMERCIAL DISTRIBUTION =
+
+Commercial distributors of software may accept certain responsibilities wi=
th respect to end users, business partners and the like. While this license=
is intended to facilitate the commercial use of the Program, the Contribut=
or who includes the Program in a commercial product offering should do so i=
n a manner which does not create potential liability for other Contributors=
. Therefore, if a Contributor includes the Program in a commercial product =
offering, such Contributor ("Commercial Contributor") hereby agrees to defe=
nd and indemnify every other Contributor ("Indemnified Contributor") agains=
t any losses, damages and costs (collectively "Losses") arising from claims=
, lawsuits and other legal actions brought by a third party against the Ind=
emnified Contributor to the extent caused by the acts or omissions of such =
Commercial Contributor in connection with its distribution of the Program i=
n a commercial product offering. The obligations in this section do not app=
ly to any claims or Losses relating to any actual or alleged intellectual p=
roperty infringement. In order to qualify, an Indemnified Contributor must:=
a) promptly notify the Commercial Contributor in writing of such claim, an=
d b) allow the Commercial Contributor to control, and cooperate with the Co=
mmercial Contributor in, the defense and any related settlement negotiation=
s. The Indemnified Contributor may participate in any such claim at its own=
expense. =
+
+For example, a Contributor might include the Program in a commercial produ=
ct offering, Product X. That Contributor is then a Commercial Contributor. =
If that Commercial Contributor then makes performance claims, or offers war=
ranties related to Product X, those performance claims and warranties are s=
uch Commercial Contributor's responsibility alone. Under this section, the =
Commercial Contributor would have to defend claims against the other Contri=
butors related to those performance claims and warranties, and if a court r=
equires any other Contributor to pay any damages as a result, the Commercia=
l Contributor must pay those damages. =
+
+
+5. NO WARRANTY
+
+EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED O=
N AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EX=
PRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITION=
S OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR P=
URPOSE. Each Recipient is solely responsible for determining the appropriat=
eness of using and distributing the Program and assumes all risks associate=
d with its exercise of rights under this Agreement, including but not limit=
ed to the risks and costs of program errors, compliance with applicable law=
s, damage to or loss of data, programs or equipment, and unavailability or =
interruption of operations. =
+
+
+6. DISCLAIMER OF LIABILITY =
+
+EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY=
CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL=
, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATIO=
N LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN =
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARI=
SING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE EXERCI=
SE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF S=
UCH DAMAGES. =
+
+
+7. GENERAL
+
+If any provision of this Agreement is invalid or unenforceable under appli=
cable law, it shall not affect the validity or enforceability of the remain=
der of the terms of this Agreement, and without further action by the parti=
es hereto, such provision shall be reformed to the minimum extent necessary=
to make such provision valid and enforceable. =
+
+If Recipient institutes patent litigation against a Contributor with respe=
ct to a patent applicable to software (including a cross-claim or countercl=
aim in a lawsuit), then any patent licenses granted by that Contributor to =
such Recipient under this Agreement shall terminate as of the date such lit=
igation is filed. In addition, if Recipient institutes patent litigation ag=
ainst any entity (including a cross-claim or counterclaim in a lawsuit) all=
eging that the Program itself (excluding combinations of the Program with o=
ther software or hardware) infringes such Recipient's patent(s), then such =
Recipient's rights granted under Section 2(b) shall terminate as of the dat=
e such litigation is filed.
+
+All Recipient's rights under this Agreement shall terminate if it fails to=
comply with any of the material terms or conditions of this Agreement and =
does not cure such failure in a reasonable period of time after becoming aw=
are of such noncompliance. If all Recipient's rights under this Agreement t=
erminate, Recipient agrees to cease use and distribution of the Program as =
soon as reasonably practicable. However, Recipient's obligations under this=
Agreement and any licenses granted by Recipient relating to the Program sh=
all continue and survive. =
+
+Everyone is permitted to copy and distribute copies of this Agreement, but=
in order to avoid inconsistency the Agreement is copyrighted and may only =
be modified in the following manner. The Agreement Steward reserves the rig=
ht to publish new versions (including revisions) of this Agreement from tim=
e to time. No one other than the Agreement Steward has the right to modify =
this Agreement. IBM is the initial Agreement Steward. IBM may assign the re=
sponsibility to serve as the Agreement Steward to a suitable separate entit=
y. Each new version of the Agreement will be given a distinguishing version=
number. The Program (including Contributions) may always be distributed su=
bject to the version of the Agreement under which it was received. In addit=
ion, after a new version of the Agreement is published, Contributor may ele=
ct to distribute the Program (including its Contributions) under the new ve=
rsion. Except as expressly stated in Sections 2(a) and 2(b) above, Recipien=
t receives no rights or licenses to the intellectual property of any Contri=
butor under this Agreement, whether expressly, by implication, estoppel or =
otherwise. All rights in the Program not expressly granted under this Agree=
ment are reserved. =
+
+This Agreement is governed by the laws of the State of New York and the in=
tellectual property laws of the United States of America. No party to this =
Agreement will bring a legal action under this Agreement more than one year=
after the cause of action arose. Each party waives its rights to a jury tr=
ial in any resulting litigation.
Modified: trunk/source/examples/jfli/docs/jfli.css
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/jfli/docs/jfli.css (original)
+++ trunk/source/examples/jfli/docs/jfli.css Thu Nov 27 12:40:41 2008
@@ -1,126 +1,126 @@
-img {
- border: 0;
-}
-body {
- margin: 5px 10% 5px 55px;
- padding: 5px;
- border: 0;
- background: #fff url(jfli_bkgrnd.gif) top left repeat-y;
- color: #222;
- font: small/1.6em "Lucida Grande", "Trebuchet MS", "Bitstream Vera Sans"=
, Verdana, Helvetica, sans-serif;
-}
-
-
-a:link {
- color: #339;
- text-decoration: none;
- border-bottom: 2px solid #ccf;
-}
-a:visited {
- color: #339;
- text-decoration: none;
- border-bottom: 2px solid #ddd;
-}
-a:hover {
- color: #66c;
- text-decoration: none;
- border-bottom: 2px solid #ccf;
-}
-a:active {
- color: #339;
- text-decoration: none;
- border-bottom: 2px solid #ccf;
-}
-
-p {
- margin: 0 0 1em 0;
- line-height: 140%;
-}
-
-
-h1 {
- text-indent: -9999px;
- margin: 0;
- padding: 0;
- border: 0;
-}
- =
-h1 a:link, h1 a:visited {
- display: block; =
- width: 539px;
- height: 86px;
- background: #fff url(jfli_new.gif) top left no-repeat;
- margin: 0;
- padding: 0;
- border: 0;
- text-decoration: none;
-}
- =
-h1 a:hover {
- background: #fff url(jfli_new.gif) top left no-repeat;
- border: 0;
-}
-
-h2 {
- margin: .75em 0 .25em;
- font: 170%/1.7em Georgia, serif;
- color: #66c;
-}
-h3 {
- margin: 1em 0 .25em;
- font: 130%/1.4em Georgia, serif;
- color: #339;
-}
-h4 {
- margin: 1em 0 .25em;
- font: 120%/1.3em Georgia, serif;
- color: #888;
-}
-
-pre, code {
- color: #404;
- /*
- font-family: monaco, "Bitstream Vera Sans Mono", "Courier New", courier,=
monospace;
- font-weight: normal;
- font-size: small;
- */
- font: small/1.6em monaco, "Bitstream Vera Sans Mono", "Courier New", cou=
rier, monospace;
- line-height: 1.4em;
-}
-pre {
- margin: 1em 0 1.4em;
- margin-left: 3%;
- width: 77%;
- border-left: 4px solid #eee;
- padding: 2px;
- padding-left: 10px;
-}
-
-ol li {
- list-style: decimal outside;
- line-height: 150%;
- margin: 0 5px 5px 0;
- padding: 0 0 0 5px;
-}
-
-ul {
- margin: 3px 0;
- padding: 0 0 5px 0;
-}
- =
-ul li {
- line-height: 150%;
- margin-bottom: 5px;
- padding-bottom: 0;
- padding-left: 18px;
- padding-top: 2px;
- margin-left: 5px;
- list-style: none;
- background:url("bullet.gif") no-repeat 0px .5em;
-}
- =
-ul ul li {
- margin-top: 4px;
- list-style: none;
- background:url("bullet2.gif") no-repeat 0px .5em;
-}
+img {
+ border: 0;
+}
+body {
+ margin: 5px 10% 5px 55px;
+ padding: 5px;
+ border: 0;
+ background: #fff url(jfli_bkgrnd.gif) top left repeat-y;
+ color: #222;
+ font: small/1.6em "Lucida Grande", "Trebuchet MS", "Bitstream Vera Sans"=
, Verdana, Helvetica, sans-serif;
+}
+
+
+a:link {
+ color: #339;
+ text-decoration: none;
+ border-bottom: 2px solid #ccf;
+}
+a:visited {
+ color: #339;
+ text-decoration: none;
+ border-bottom: 2px solid #ddd;
+}
+a:hover {
+ color: #66c;
+ text-decoration: none;
+ border-bottom: 2px solid #ccf;
+}
+a:active {
+ color: #339;
+ text-decoration: none;
+ border-bottom: 2px solid #ccf;
+}
+
+p {
+ margin: 0 0 1em 0;
+ line-height: 140%;
+}
+
+
+h1 {
+ text-indent: -9999px;
+ margin: 0;
+ padding: 0;
+ border: 0;
+}
+ =
+h1 a:link, h1 a:visited {
+ display: block; =
+ width: 539px;
+ height: 86px;
+ background: #fff url(jfli_new.gif) top left no-repeat;
+ margin: 0;
+ padding: 0;
+ border: 0;
+ text-decoration: none;
+}
+ =
+h1 a:hover {
+ background: #fff url(jfli_new.gif) top left no-repeat;
+ border: 0;
+}
+
+h2 {
+ margin: .75em 0 .25em;
+ font: 170%/1.7em Georgia, serif;
+ color: #66c;
+}
+h3 {
+ margin: 1em 0 .25em;
+ font: 130%/1.4em Georgia, serif;
+ color: #339;
+}
+h4 {
+ margin: 1em 0 .25em;
+ font: 120%/1.3em Georgia, serif;
+ color: #888;
+}
+
+pre, code {
+ color: #404;
+ /*
+ font-family: monaco, "Bitstream Vera Sans Mono", "Courier New", courier,=
monospace;
+ font-weight: normal;
+ font-size: small;
+ */
+ font: small/1.6em monaco, "Bitstream Vera Sans Mono", "Courier New", cou=
rier, monospace;
+ line-height: 1.4em;
+}
+pre {
+ margin: 1em 0 1.4em;
+ margin-left: 3%;
+ width: 77%;
+ border-left: 4px solid #eee;
+ padding: 2px;
+ padding-left: 10px;
+}
+
+ol li {
+ list-style: decimal outside;
+ line-height: 150%;
+ margin: 0 5px 5px 0;
+ padding: 0 0 0 5px;
+}
+
+ul {
+ margin: 3px 0;
+ padding: 0 0 5px 0;
+}
+ =
+ul li {
+ line-height: 150%;
+ margin-bottom: 5px;
+ padding-bottom: 0;
+ padding-left: 18px;
+ padding-top: 2px;
+ margin-left: 5px;
+ list-style: none;
+ background:url("bullet.gif") no-repeat 0px .5em;
+}
+ =
+ul ul li {
+ margin-top: 4px;
+ list-style: none;
+ background:url("bullet2.gif") no-repeat 0px .5em;
+}
Modified: trunk/source/examples/jfli/docs/jfli.html
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/jfli/docs/jfli.html (original)
+++ trunk/source/examples/jfli/docs/jfli.html Thu Nov 27 12:40:41 2008
@@ -1,620 +1,620 @@
-<html>
-<head>
- <link rel=3D"stylesheet" type=3D"text/css" media=3D"screen" href=3D"jfli.=
css">
-</head>
- <body>
- <h1><a href=3D"/" title=3D"Rich Hickey's jfli - a Java Foreign Language I=
nterface for Common Lisp">jfli =
- - a Java Foreign Language Interface for Common Lisp</a></h1>
-
- <h5>Copyright (c) Rich Hickey. All rights reserved.</h5>
-
- <p>
- The use and distribution terms for this software are covered by the <a hr=
ef=3D"http://opensource.org/licenses/cpl.php">Common =
- Public License 1.0</a>, which can be found in the file CPL.TXT at the roo=
t of =
- this distribution. By using this software in any fashion, you are agreein=
g to be =
- bound by the terms of this license. You must not remove this notice, or a=
ny =
- other, from this software.
- </p>
-
- <h2>Contents</h2>
-
- <ul>
- <li>
- <a href=3D"#intro">Introduction</a>
- </li>
- <li>
- <a href=3D"#download">Download</a>
- </li>
- <li>
- <a href=3D"#setup">Setup and Configuration</a>
- </li>
- <li>
- <a href=3D"#quickstart">Quick Start</a>
- </li>
- <li>
- <a href=3D"#api">API Reference</a>
- <ul>
- <li>
- <a href=3D"#jvmcreation">JVM Creation and Initialization</a>
- </li>
- <li>
- <a href=3D"#wrappergen">Wrapper Generation</a>
- </li>
- <li>
- <a href=3D"#objects">Object Creation</a>
- </li>
- <li>
- <a href=3D"#arrays">Arrays</a>
- </li>
- <li>
- <a href=3D"#proxies">Proxies - Java calling back to Lisp</a>
- </li>
- <li>
- <a href=3D"#utilities">Utilities</a>
- </li>
- </ul>
- </li>
- <li>
- <a href=3D"#summary">Summary</a>
- </li>
- </ul>
-
-
- <a name=3D"intro"></a> <h3>Introduction</h3>
-
- <p>
- My objective was to provide comprehensive, safe, dynamic and Lisp-y acces=
s to =
- Java and Java libraries as if they were Lisp libraries, for use in Lisp p=
rograms, =
- i.e. with an emphasis on working in Lisp rather than in Java.
- </p>
-
- <p>
- The approach I took was to embed a JVM instance in the Lisp process using=
JNI. I =
- was able to do this using LispWorks' own FLI and no C (or Java! *) code, =
which =
- is a tribute to the LW FLI. On top of the JNI layer (essentially a wrapp=
er =
- around the entire JNI API), I built this user-level API using Java Reflec=
tion. =
- This first version was built with, and contains code specific to, Xanalys=
<a
- href=3D"http://www.lispworks.com/">LispWorks</a>.
- </p>
-
-
- <p>
- <em>jfli</em> ("jay fly") provides:
- </p>
-
- <ul>
-
- <li>
- Automatic function generation for constructors, fields and methods, eit=
her by =
- named class, or entire package (sub)trees given a jar file.
- </li>
-
- <li>
- Java -> Lisp package and name mapping with an eye towards lack of surpr=
ise, lack =
- of conflict, and useful editor completion.
- </li>
-
- <li>
- setf-able setter generation for fields as well as for methods that foll=
ow the =
- JavaBeans property protocol.
- </li>
-
- <li>
- Java array creation and aref-like access to Java arrays.
- </li>
-
- <li>
- A 'new' macro that allows for keyword-style field and property initiali=
zation.
- </li>
-
- <li>
- Typed references to Java objects with an inheritance hierarchy on the L=
isp side =
- mirroring that on the Java side - allowing for Lisp methods specialized=
on Java =
- class and interface types.
- </li>
-
- <li>
- Implementation of arbitrary Java interfaces in Lisp, and callbacks from=
Java to =
- Lisp via those interfaces. (* this required a single 5-line dummy Java=
proxy =
- stub, provided with jfli)
- </li>
-
- <li>
- Automatic lifetime maintenance of Lisp-referenced Java objects, boxing/=
unboxing =
- of primitive args/returns, string conversions, Java exception handling,=
overload =
- resolution etc.
- </li>
- </ul>
-
- <p>
- I built jfli using LWM and LWW (using Apple's and Sun's JVMs respectively=
), and =
- it works fine on both. Should be a trivial port to other LispWorks, and =
a =
- possible port to any Common Lisp with a robust FLI. Should also work with=
any =
- JVM with a conformant JNI implementation.
- </p>
-
- <a name=3D"download"></a> <h3>Download</h3>
-
- <p>
- jfli is hosted on <a href=3D"http://sourceforge.net/projects/jfli/">Sourc=
eForge</a>
- </p>
-
- <a name=3D"setup"></a> <h3>Setup and Configuration</h3>
-
- <p>
- jfli is supplied in 2 Lisp files and an optional Java .jar file. The fir=
st Lisp =
- file, jni.lisp, defines a low-level API to the Java Native Interface, and=
is not =
- documented here. The second, jfli.lisp, depends upon jni.lisp, and provid=
es the =
- user API documented here. Simply compile and load jni.lisp, then compile =
and =
- load jfli.lisp. <code>(use-package :jfli)</code> and you are ready to use=
the =
- API. Note that prior to creating the JVM you must tell the library how to=
find =
- the Java JNI library by setting <a
- href=3D"#jnilibpath"><code>*jni-lib-path*</code></a>.
- </p>
- <p>
- If you wish to allow for callbacks from Java to Lisp, you must place jfli=
.jar in =
- your classpath when <a href=3D"#jvmcreation">creating the JVM</a>.
- </p>
-
-
- <a name=3D"quickstart"></a> <h3>Quick Start</h3>
- <p>
- This sample session presumes you have already compiled jni.lisp and jfli.=
lisp into fasl files.
- </p>
- <pre>
-CL-USER 4 > (load "/lisp/jni")
-; Loading fasl file C:\lisp\jni.fsl
-#P"C:/lisp/jni.fsl"
-
-CL-USER 5 > (load "/lisp/jfli")
-; Loading fasl file C:\lisp\jfli.fsl
-#P"C:/lisp/jfli.fsl"
-
-;The user API is entirely in the jfli package
-CL-USER 6 > (use-package :jfli)
-T
-
-;tell the library where Java is located
-CL-USER 7 > (setf *jni-lib-path* "/j2sdk1.4.2_01/jre/bin/client/jvm.dll")
-"/j2sdk1.4.2_01/jre/bin/client/jvm.dll"
-
-;this starts the VM - note how you can set the classpath
-CL-USER 8 > (create-jvm "-Djava.class.path=3D/lisp/jfli.jar")
-0
-#<Pointer: JNI:PVM =3D #x081022A0>
-#<Pointer: JNI:PENV =3D #x0086A858>
-
-;define wrappers for the members of Object
-CL-USER 9 > (def-java-class "java.lang.Object")
-NIL
-
-;and of Properties, a Hashtable-like class
-CL-USER 10 > (def-java-class "java.util.Properties")
-#<STANDARD-CLASS |java.util|:PROPERTIES. 2066B964>
-
-;the above will create these packages if they do not already exist
-;use the packages for easy name access
-
-CL-USER 11 > (use-package "java.lang")
-T
-
-CL-USER 12 > (use-package "java.util")
-T
-
-;create a Properties instance, note keyword-style member inits, string con=
version etc
-;also note typed return value
-CL-USER 13 > (setf p (new properties. :getproperty "fred" "ethel"))
-#<PROPERTIES. 20664A94>
-
-;virtual functions work as normal
-CL-USER 14 > (object.tostring p)
-"{fred=3Dethel}"
-
-;setter was generated for member function because it follows the JavaBeans=
property protocol
-CL-USER 15 > (setf (properties.getproperty p "ricky") "lucy")
-"lucy"
-
-CL-USER 16 > (object.tostring p)
-"{ricky=3Dlucy, fred=3Dethel}"
-
-CL-USER 17 > (properties.size p)
-2
-
-;totally dynamic access, create wrappers as you need
-CL-USER 18 > (def-java-class "java.lang.Class")
-#<STANDARD-CLASS CLASS. 20680EC4>
-
-CL-USER 19 > (class.getname (object.getclass p))
-"java.util.Properties"
-
-CL-USER 20 > (def-java-class "java.util.Enumeration")
-#<STANDARD-CLASS ENUMERATION. 20669274>
-
-;no need to wait for the vendor to enhance the language - you use Lisp!
-CL-USER 21 > (defmacro doenum ((e enum) &body body)
- (let ((genum (gensym)))
- `(let ((,genum ,enum))
- (do ()
- ((not (enumeration.hasmoreelements ,genum)))
- (let ((,e (enumeration.nextelement ,genum)))
- , at body)))))
-DOENUM
-
-;can't do this in Java yet
-CL-USER 22 > (doenum (prop (properties.elements p)) (print (object.tostrin=
g prop)))
-
-"lucy"
-"ethel"
-NIL
-
-;doc strings are created giving original Java signatures and indicating
-overloads
-CL-USER 23 > (documentation 'properties.getproperty 'function)
-"java.lang.String getProperty(java.lang.String,java.lang.String)
-java.lang.String getProperty(java.lang.String)
-"
-
-CL-USER 24 > (documentation 'properties.new 'function)
-"java.util.Properties()
-java.util.Properties(java.util.Properties)
-"
- </pre>
-
- <a name=3D"api"></a> <h2>API Reference</h2>
-
- <a name=3D"jvmcreation"></a> <h3>JVM Creation and Initialization</h3>
- <ul>
-
- <li>
- <a name=3D"jnilibpath"></a><code>*jni-lib-path*</code>
- <p>
- Set this to point to your jvm dll prior to calling create-jvm.
- </p>
- </li>
-
- <li>
- <strong>Function</strong> <code>(create-jvm &rest option-strings) -> un=
specified</code>
- <p>
- Creates/starts the JVM. This can only be done once (a Java limitation).=
<em>You =
- must call this prior to calling any other jfli function.</em> The optio=
n strings =
- can be used to control the JVM, esp. the classpath:
- </p>
- <p>
- <pre>(create-jvm "-Djava.class.path=3D/Lisp/jfli.jar")</pre>
- </p>
- <p>
- See the JNI documentation for other initialization options.
- </p>
- </li>
-
- <li>
- <a name=3D"enableproxies"></a> <strong>Function</strong> <code>(enable-=
java-proxies) =
- -> unspecified</code>
- <p>
- Sets up the Java->Lisp callback support. Must be called (once) before a=
ny calls =
- to new-proxy, and requires jfli.jar be in the classpath.
- </p>
- </li>
- </ul>
-
- <a name=3D"wrappergen"></a> <h3>Wrapper Generation</h3>
-
- <ul>
- <li>
- <strong>Macro</strong> <code>(def-java-class full-class-name) -> unspec=
ified</code>
- <p>
- Given the package-qualified, case-correct name of a Java class as a str=
ing, will =
- generate wrapper functions for its public constructors, fields and meth=
ods.
- </p>
- <p>
- The core API for generation interfaces to Java is the def-java-class ma=
cro. This =
- macro will, at expansion time, use Java reflection to find all of the p=
ublic =
- constructors, fields and methods of the given class and generate functi=
ons to =
- access them.
- </p>
- <h4>The Generated API</h4> When you e.g. <code>(def-java-class "java.la=
ng.ClassName =
- ")</code> you get several symbols/functions:
- <ul>
- <li>
- A package named <code>|java.lang|</code> (note case)<br>
- from which the following are exported:
- </li>
- <li>
- A class-symbol: <code>classname.</code> (note the dot is part of the =
name)<br>
- which can usually be used where a typename is required. It also serve=
s as the =
- name of the Lisp typed reference class.
- </li>
- <li>
- Every non-interface class with a public constructor will get;
- <ul>
- <li>
- A constructor, <code>(classname.new &rest args) -> typed-reference<=
/code>, which =
- returns a typed reference to the newly created object
- </li>
- <li>
- A method defined on <a href=3D#makenew><code>make-new</code></a>, u=
ltimately =
- calling <code>classname.new</code>, specialized on (the value of) t=
he class-symbol
- </li>
- </ul>
- Note that if the constructor is overloaded, there is just one functio=
n generated, =
- which handles overload resolution. The function documentation string =
describes =
- the constructor signature(s) from the Java perspective. The same argu=
ment =
- conversions are performed as are for fields (see below).
- </li>
- <li>
- All public fields will get a getter function:<br>
- <code>(classname.fieldname [instance]) -> field value</code><br>
- and a setter:<br>
- <code>(setf classname.fieldname [instance])</code><br>
- Instance field wrappers take a first arg which is the instance. Stati=
c fields =
- get a symbol-macro <code>*classname.fieldname*</code>
- <p>
- If the type of the field is primitive, the field value will be conver=
ted to a =
- native Lisp value. If it is a Java String, it will be converted to a =
Lisp string. =
- Otherwise, a generic reference to the Java object is returned. Simila=
rly, when =
- setting, Lisp values will be accepted for primitives, Lisp strings fo=
r Strings, =
- or (generic or typed) references for reference types.
- </p>
- </li>
- <li>
- Every public method will get a wrapper function:<br>
- <code>(classname.methodname &rest args) -> return-value</code><br>
- As with constructors, if a method is overloaded a single wrapper is c=
reated that =
- handles overload resolution. If a method follows the JavaBeans proper=
ty protocol =
- (i.e. it is called <code>getSomething</code> or <code>isSomething</co=
de> and =
- there is a corresponding <code>setSomething</code>), then a <code>(se=
tf =
- classname.methodname)</code> will be defined that calls the latter.
- <p>
- The same argument and return value conversions are performed as are f=
or fields. =
- The function documentation string describes the method signature(s) f=
rom the =
- Java perspective.
- </p>
-
- </li>
- <li>
- A Lisp class with the class-symbol as its name. It will have as its s=
uperclasses =
- other Lisp classes corresponding to the Java superclass/superinterfac=
es, some of =
- which may be forward-referenced-classes. An instance of this class w=
ill be =
- returned by classname.new/make-new/new, at which point the entire hie=
rarchy will =
- consist of finalized standard-classes.
- </li>
- <li>
- Note that, due to the need to reference other Java types during the d=
efinition =
- of a class wrapper, symbols, classes, and packages relating to those =
other types =
- may also be created. In all cases they will be created with names and =
- packages as described above.
- </li>
- </ul>
- </li>
-
- <li>
- <strong>Function</strong> <code>(get-jar-classnames jar-file-name &rest=
packages) =
- -> list-of-strings</code>
- <p>
- Returns a list of class name strings. Packages should be strings of the=
form "java/lang =
- " for recursive lookup and "java/util/" (note trailing slash) for non-=
recursive.
- </p>
- </li>
- <li>
- <strong>Function</strong> <code>(dump-wrapper-defs-to-file filename cla=
ssnames) -> =
- unspecified</code>
- <p>
- Given a list of classnames (say from <code>get-jar-classnames</code>), =
writes =
- calls to <code>def-java-class</code> to a file:
- </p>
- <pre>
-(dump-wrapper-defs-to-file "/lisp/java-lang.lisp"
- (get-jar-classnames "/j2sdk1.4.2_01/jre/lib/rt.jar " "java/lang/"))
-(compile-file "/lisp/java-lang")
-(load "/lisp/java-lang")
-(use-package "java.lang")
-;Wrappers for all of java.lang are now available
-</pre>
- </li>
- </ul>
-
- <a name=3D"objects"></a> <h3>Object Creation</h3>
- <ul>
- <li>
- <strong><a name=3D"makenew"></a>Generic Function</strong> <code>(make-n=
ew class-symbol =
- &rest args) -> typed-reference</code>
- <p>
- Allows for definition of before/after methods on constructors. Calls <c=
ode>classname.new</code>. =
- The new macro expands into a call to this.
- </p>
- </li>
- <li>
- <strong>Macro</strong> <code>(new class-spec &rest args) -> typed-refer=
ence</code>
- <br>
- <p>
- class-spec -> class-name | (class-name this-name)<br>
- class-name -> "package.qualified.ClassName" | classname.<br>
- args -> [actual-arg]* [init-arg-spec]*<br>
- init-arg-spec -> init-arg | (init-arg)<br>
- init-arg -> :settable-field-or-method [params]* value (note keyword)<br>
- | .method-name [args]* (note leading dot)<br>
- </p>
-
- <p>
- Creates a new instance of class-name, by expanding into a call to the m=
ake-new =
- generic function, then initializes it by setting fields or accessors an=
d/or =
- calling member functions. If this-name is supplied, it will be bound to=
the =
- newly-allocated object and available to the init-args:
- </p>
- <pre>
-(new (button. this) shell *SWT.CENTER* ;the actual args
- :gettext "Call Lisp" ;a javabean property
- (.addlistener *swt.selection* ;a method call
- (new-proxy (listener.
- (handleevent (event)
- (declare (ignore event))
- (setf (button.gettext this) ;this is bound to new=
instance
- (format nil "~A ~A"
- (lisp-implementation-type)
- (lisp-implementation-version)))
- nil))))
- .setsize 200 100 ;can omit parens
- (.setlocation 40 40))
- </pre>
- Expands into:
- <pre>
-(LET* ((#:G598 (MAKE-NEW BUTTON. SHELL *SWT.CENTER*)) (THIS #:G598))
- (SETF (BUTTON.GETTEXT #:G598) "Call Lisp")
- (BUTTON.ADDLISTENER #:G598
- *SWT.SELECTION*
- (NEW-PROXY (LISTENER.
- (HANDLEEVENT
- (EVENT)
- (DECLARE (IGNORE EVENT))
- (SETF (BUTTON.GETTEXT THIS)
- (FORMAT NIL
- "~A ~A"
- (LISP-IMPLEMENTATION-TYPE)
- (LISP-IMPLEMENTATION-VERS=
ION)))
- NIL))))
- (BUTTON.SETSIZE #:G598 200 100)
- (BUTTON.SETLOCATION #:G598 40 40)
- #:G598)
- </pre>
-
- </li>
- </ul>
- <a name=3D"arrays"></a> <h3>Array Support</h3>
- <ul>
- <li>
- <strong>Generic Function</strong> <code>(make-new-array type &rest dime=
nsions) -> =
- reference to new array</code>
- <p>
- Generic function with methods defined for all Java class designators:
- <ul>
- <li>
- A "package.qualified.ClassName" string
- </li>
- <li>
- (the value of) A class-symbol - classname.
- </li>
- <li>
- A primitive designator keyword - :boolean|:byte|:char|:double|:float|=
:int|:long|:short
- </li>
- </ul>
- </p>
- <p>
- Creates a Java array of the requested type with the requested dimension=
s.
- </p>
- </li>
- <li>
- <strong>Function</strong> <code>(jlength array) -> integer</code>
- <p>
- Like length, for Java arrays
- </p>
- </li>
-
- <li>
- <strong>Function</strong> <code>(jref array &rest subscripts) -> refere=
nce</code>
- <p>
- Like aref, for Java arrays of non-primitive (reference) types, settable.
- </p>
- </li>
- <li>
- <strong>Function</strong> <code>(jref-xxx array &rest subscripts) -> va=
lue</code>
- <p>
- Where xxx =3D boolean|byte|char|double|float|int|long|short. Like jref,=
for Java =
- arrays of primitive types, settable.
- </p>
- </li>
-
- </ul>
-
- <a name=3D"proxies"></a> <h3>Proxies - Java calling back to Lisp</h3>
- <ul>
- <p>
- Proxies allow the creation of Java objects that implement one or more in=
terfaces =
- in Lisp, and thus callbacks from Java to Lisp. You must call <a href=3D#=
enableproxies>
- <code>enable-java-proxies</code></a> before using this proxy API. A sign=
ificant =
- limitation is that LispWorks appears to not support calls back into Lisp=
other =
- than from threads initiated by Lisp, so you must ensure that the proxy w=
ill not =
- be called from an arbitrary Java thread!
- </p>
- <li>
- <strong>Macro</strong> <code>(new-proxy &rest interface-defs) -> refere=
nce</code>
- <p>
- interface-def -> (interface-name method-defs+)<br>
- interface-name -> "package.qualified.ClassName" | classname. (must name=
a Java =
- interface type)<br>
- method-def -> (method-name arg-defs* body) <br>
- arg-def -> arg-name | (arg-name arg-type) arg-type -> "package.qualifie=
d.ClassName =
- " | classname. | :primitive <br>
- method-name -> symbol | string (matched case-insensitively)
- </p>
-
- <p>
- Creates, registers and returns a Java object that implements the suppli=
ed =
- interfaces
- </p>
- </li>
- <li>
- <strong>Function</strong> <code>(unregister-proxy proxy) -> unspecified=
</code>
- <p>
- Stops handling for the proxy (which must have been created by <code>new=
-proxy</code>) =
- and removes references from the Lisp side. Make sure it is no longer re=
ferenced =
- from Java first!
- </p>
- </li>
- </ul>
-
- <a name=3D"utilities"></a> <h3>Utilities</h3>
- <ul>
-
- <li>
- <strong>Function</strong> <code>(jeq obj1 obj2) -> boolean</code>
- <p>
- Are the 2 java objects the same object? Note that this is not the same =
as Object.equals()
- <p>
- </li>
- <li>
- <strong>Function</strong> <code>(find-java-class class-sym-or-string) -=
> =
- reference to Java Class object</code>
- <p>
- Given a Java class designator, returns the Java Class object. Use this =
in =
- preference to Class.forName() when using jfli.
- </p>
- </li>
-
- <li>
- <strong>Function</strong> <code>(make-typed-ref java-ref) -> typed-refe=
rence</code>
- <p>
- Given a generic Java reference, determines the full type of the object =
and =
- returns an instance of a typed reference wrapper. classname.new/make-ne=
w/new always return typed =
- references, but since Java methods might return Object or some interfac=
e type, =
- and we don't want to always incur the cost of type determination, field=
and =
- method wrapper functions return generic references. Use this function t=
o create =
- a typed reference corresponding to the full actual type of the object w=
hen =
- desired.
- </p>
- </li>
- <li>
- <strong>Function</strong> <code>(box-xxx value) -> reference to Java pr=
imitive wrapper class</code>
- <p>Where xxx =3D boolean|byte|char|double|float|int|long|short|string. =
- Given a compatible Lisp value, creates an instance of the corresponding=
Java primitive wrapper class,
- e.g. Integer. This should rarely be needed, but can be used to force ov=
erloading resolution</p>
- </li>
- <li>
- <strong>Function</strong> <code>(unbox-xxx ref) -> Lisp value</code>
- <p>Where xxx =3D boolean|byte|char|double|float|int|long|short|string. =
- Given an instance of a Java primitive wrapper class, creates an instanc=
e of the corresponding =
- compatible Lisp value. This should rarely be needed, but can be used to=
unbox values returned by Java
- Object-based APIs.</p>
- </li>
- </ul>
- =
- <a name=3D"summary"></a> <h3>Summary</h3>
-<p>
-I hope you find jfli useful. It is my sincere intent that it enhance the u=
tility and interoperability of Common Lisp,
-a language with which I am still becoming familiar, and grow to appreciate=
more every day. I welcome comments
-and code contributions.
-</p>
-<p>
-Rich Hickey, July 2004
-</p>
- </body>
-</html>
+<html>
+<head>
+ <link rel=3D"stylesheet" type=3D"text/css" media=3D"screen" href=3D"jfli.=
css">
+</head>
+ <body>
+ <h1><a href=3D"/" title=3D"Rich Hickey's jfli - a Java Foreign Language I=
nterface for Common Lisp">jfli =
+ - a Java Foreign Language Interface for Common Lisp</a></h1>
+
+ <h5>Copyright (c) Rich Hickey. All rights reserved.</h5>
+
+ <p>
+ The use and distribution terms for this software are covered by the <a hr=
ef=3D"http://opensource.org/licenses/cpl.php">Common =
+ Public License 1.0</a>, which can be found in the file CPL.TXT at the roo=
t of =
+ this distribution. By using this software in any fashion, you are agreein=
g to be =
+ bound by the terms of this license. You must not remove this notice, or a=
ny =
+ other, from this software.
+ </p>
+
+ <h2>Contents</h2>
+
+ <ul>
+ <li>
+ <a href=3D"#intro">Introduction</a>
+ </li>
+ <li>
+ <a href=3D"#download">Download</a>
+ </li>
+ <li>
+ <a href=3D"#setup">Setup and Configuration</a>
+ </li>
+ <li>
+ <a href=3D"#quickstart">Quick Start</a>
+ </li>
+ <li>
+ <a href=3D"#api">API Reference</a>
+ <ul>
+ <li>
+ <a href=3D"#jvmcreation">JVM Creation and Initialization</a>
+ </li>
+ <li>
+ <a href=3D"#wrappergen">Wrapper Generation</a>
+ </li>
+ <li>
+ <a href=3D"#objects">Object Creation</a>
+ </li>
+ <li>
+ <a href=3D"#arrays">Arrays</a>
+ </li>
+ <li>
+ <a href=3D"#proxies">Proxies - Java calling back to Lisp</a>
+ </li>
+ <li>
+ <a href=3D"#utilities">Utilities</a>
+ </li>
+ </ul>
+ </li>
+ <li>
+ <a href=3D"#summary">Summary</a>
+ </li>
+ </ul>
+
+
+ <a name=3D"intro"></a> <h3>Introduction</h3>
+
+ <p>
+ My objective was to provide comprehensive, safe, dynamic and Lisp-y acces=
s to =
+ Java and Java libraries as if they were Lisp libraries, for use in Lisp p=
rograms, =
+ i.e. with an emphasis on working in Lisp rather than in Java.
+ </p>
+
+ <p>
+ The approach I took was to embed a JVM instance in the Lisp process using=
JNI. I =
+ was able to do this using LispWorks' own FLI and no C (or Java! *) code, =
which =
+ is a tribute to the LW FLI. On top of the JNI layer (essentially a wrapp=
er =
+ around the entire JNI API), I built this user-level API using Java Reflec=
tion. =
+ This first version was built with, and contains code specific to, Xanalys=
<a
+ href=3D"http://www.lispworks.com/">LispWorks</a>.
+ </p>
+
+
+ <p>
+ <em>jfli</em> ("jay fly") provides:
+ </p>
+
+ <ul>
+
+ <li>
+ Automatic function generation for constructors, fields and methods, eit=
her by =
+ named class, or entire package (sub)trees given a jar file.
+ </li>
+
+ <li>
+ Java -> Lisp package and name mapping with an eye towards lack of surpr=
ise, lack =
+ of conflict, and useful editor completion.
+ </li>
+
+ <li>
+ setf-able setter generation for fields as well as for methods that foll=
ow the =
+ JavaBeans property protocol.
+ </li>
+
+ <li>
+ Java array creation and aref-like access to Java arrays.
+ </li>
+
+ <li>
+ A 'new' macro that allows for keyword-style field and property initiali=
zation.
+ </li>
+
+ <li>
+ Typed references to Java objects with an inheritance hierarchy on the L=
isp side =
+ mirroring that on the Java side - allowing for Lisp methods specialized=
on Java =
+ class and interface types.
+ </li>
+
+ <li>
+ Implementation of arbitrary Java interfaces in Lisp, and callbacks from=
Java to =
+ Lisp via those interfaces. (* this required a single 5-line dummy Java=
proxy =
+ stub, provided with jfli)
+ </li>
+
+ <li>
+ Automatic lifetime maintenance of Lisp-referenced Java objects, boxing/=
unboxing =
+ of primitive args/returns, string conversions, Java exception handling,=
overload =
+ resolution etc.
+ </li>
+ </ul>
+
+ <p>
+ I built jfli using LWM and LWW (using Apple's and Sun's JVMs respectively=
), and =
+ it works fine on both. Should be a trivial port to other LispWorks, and =
a =
+ possible port to any Common Lisp with a robust FLI. Should also work with=
any =
+ JVM with a conformant JNI implementation.
+ </p>
+
+ <a name=3D"download"></a> <h3>Download</h3>
+
+ <p>
+ jfli is hosted on <a href=3D"http://sourceforge.net/projects/jfli/">Sourc=
eForge</a>
+ </p>
+
+ <a name=3D"setup"></a> <h3>Setup and Configuration</h3>
+
+ <p>
+ jfli is supplied in 2 Lisp files and an optional Java .jar file. The fir=
st Lisp =
+ file, jni.lisp, defines a low-level API to the Java Native Interface, and=
is not =
+ documented here. The second, jfli.lisp, depends upon jni.lisp, and provid=
es the =
+ user API documented here. Simply compile and load jni.lisp, then compile =
and =
+ load jfli.lisp. <code>(use-package :jfli)</code> and you are ready to use=
the =
+ API. Note that prior to creating the JVM you must tell the library how to=
find =
+ the Java JNI library by setting <a
+ href=3D"#jnilibpath"><code>*jni-lib-path*</code></a>.
+ </p>
+ <p>
+ If you wish to allow for callbacks from Java to Lisp, you must place jfli=
.jar in =
+ your classpath when <a href=3D"#jvmcreation">creating the JVM</a>.
+ </p>
+
+
+ <a name=3D"quickstart"></a> <h3>Quick Start</h3>
+ <p>
+ This sample session presumes you have already compiled jni.lisp and jfli.=
lisp into fasl files.
+ </p>
+ <pre>
+CL-USER 4 > (load "/lisp/jni")
+; Loading fasl file C:\lisp\jni.fsl
+#P"C:/lisp/jni.fsl"
+
+CL-USER 5 > (load "/lisp/jfli")
+; Loading fasl file C:\lisp\jfli.fsl
+#P"C:/lisp/jfli.fsl"
+
+;The user API is entirely in the jfli package
+CL-USER 6 > (use-package :jfli)
+T
+
+;tell the library where Java is located
+CL-USER 7 > (setf *jni-lib-path* "/j2sdk1.4.2_01/jre/bin/client/jvm.dll")
+"/j2sdk1.4.2_01/jre/bin/client/jvm.dll"
+
+;this starts the VM - note how you can set the classpath
+CL-USER 8 > (create-jvm "-Djava.class.path=3D/lisp/jfli.jar")
+0
+#<Pointer: JNI:PVM =3D #x081022A0>
+#<Pointer: JNI:PENV =3D #x0086A858>
+
+;define wrappers for the members of Object
+CL-USER 9 > (def-java-class "java.lang.Object")
+NIL
+
+;and of Properties, a Hashtable-like class
+CL-USER 10 > (def-java-class "java.util.Properties")
+#<STANDARD-CLASS |java.util|:PROPERTIES. 2066B964>
+
+;the above will create these packages if they do not already exist
+;use the packages for easy name access
+
+CL-USER 11 > (use-package "java.lang")
+T
+
+CL-USER 12 > (use-package "java.util")
+T
+
+;create a Properties instance, note keyword-style member inits, string con=
version etc
+;also note typed return value
+CL-USER 13 > (setf p (new properties. :getproperty "fred" "ethel"))
+#<PROPERTIES. 20664A94>
+
+;virtual functions work as normal
+CL-USER 14 > (object.tostring p)
+"{fred=3Dethel}"
+
+;setter was generated for member function because it follows the JavaBeans=
property protocol
+CL-USER 15 > (setf (properties.getproperty p "ricky") "lucy")
+"lucy"
+
+CL-USER 16 > (object.tostring p)
+"{ricky=3Dlucy, fred=3Dethel}"
+
+CL-USER 17 > (properties.size p)
+2
+
+;totally dynamic access, create wrappers as you need
+CL-USER 18 > (def-java-class "java.lang.Class")
+#<STANDARD-CLASS CLASS. 20680EC4>
+
+CL-USER 19 > (class.getname (object.getclass p))
+"java.util.Properties"
+
+CL-USER 20 > (def-java-class "java.util.Enumeration")
+#<STANDARD-CLASS ENUMERATION. 20669274>
+
+;no need to wait for the vendor to enhance the language - you use Lisp!
+CL-USER 21 > (defmacro doenum ((e enum) &body body)
+ (let ((genum (gensym)))
+ `(let ((,genum ,enum))
+ (do ()
+ ((not (enumeration.hasmoreelements ,genum)))
+ (let ((,e (enumeration.nextelement ,genum)))
+ , at body)))))
+DOENUM
+
+;can't do this in Java yet
+CL-USER 22 > (doenum (prop (properties.elements p)) (print (object.tostrin=
g prop)))
+
+"lucy"
+"ethel"
+NIL
+
+;doc strings are created giving original Java signatures and indicating
+overloads
+CL-USER 23 > (documentation 'properties.getproperty 'function)
+"java.lang.String getProperty(java.lang.String,java.lang.String)
+java.lang.String getProperty(java.lang.String)
+"
+
+CL-USER 24 > (documentation 'properties.new 'function)
+"java.util.Properties()
+java.util.Properties(java.util.Properties)
+"
+ </pre>
+
+ <a name=3D"api"></a> <h2>API Reference</h2>
+
+ <a name=3D"jvmcreation"></a> <h3>JVM Creation and Initialization</h3>
+ <ul>
+
+ <li>
+ <a name=3D"jnilibpath"></a><code>*jni-lib-path*</code>
+ <p>
+ Set this to point to your jvm dll prior to calling create-jvm.
+ </p>
+ </li>
+
+ <li>
+ <strong>Function</strong> <code>(create-jvm &rest option-strings) -> un=
specified</code>
+ <p>
+ Creates/starts the JVM. This can only be done once (a Java limitation).=
<em>You =
+ must call this prior to calling any other jfli function.</em> The optio=
n strings =
+ can be used to control the JVM, esp. the classpath:
+ </p>
+ <p>
+ <pre>(create-jvm "-Djava.class.path=3D/Lisp/jfli.jar")</pre>
+ </p>
+ <p>
+ See the JNI documentation for other initialization options.
+ </p>
+ </li>
+
+ <li>
+ <a name=3D"enableproxies"></a> <strong>Function</strong> <code>(enable-=
java-proxies) =
+ -> unspecified</code>
+ <p>
+ Sets up the Java->Lisp callback support. Must be called (once) before a=
ny calls =
+ to new-proxy, and requires jfli.jar be in the classpath.
+ </p>
+ </li>
+ </ul>
+
+ <a name=3D"wrappergen"></a> <h3>Wrapper Generation</h3>
+
+ <ul>
+ <li>
+ <strong>Macro</strong> <code>(def-java-class full-class-name) -> unspec=
ified</code>
+ <p>
+ Given the package-qualified, case-correct name of a Java class as a str=
ing, will =
+ generate wrapper functions for its public constructors, fields and meth=
ods.
+ </p>
+ <p>
+ The core API for generation interfaces to Java is the def-java-class ma=
cro. This =
+ macro will, at expansion time, use Java reflection to find all of the p=
ublic =
+ constructors, fields and methods of the given class and generate functi=
ons to =
+ access them.
+ </p>
+ <h4>The Generated API</h4> When you e.g. <code>(def-java-class "java.la=
ng.ClassName =
+ ")</code> you get several symbols/functions:
+ <ul>
+ <li>
+ A package named <code>|java.lang|</code> (note case)<br>
+ from which the following are exported:
+ </li>
+ <li>
+ A class-symbol: <code>classname.</code> (note the dot is part of the =
name)<br>
+ which can usually be used where a typename is required. It also serve=
s as the =
+ name of the Lisp typed reference class.
+ </li>
+ <li>
+ Every non-interface class with a public constructor will get;
+ <ul>
+ <li>
+ A constructor, <code>(classname.new &rest args) -> typed-reference<=
/code>, which =
+ returns a typed reference to the newly created object
+ </li>
+ <li>
+ A method defined on <a href=3D#makenew><code>make-new</code></a>, u=
ltimately =
+ calling <code>classname.new</code>, specialized on (the value of) t=
he class-symbol
+ </li>
+ </ul>
+ Note that if the constructor is overloaded, there is just one functio=
n generated, =
+ which handles overload resolution. The function documentation string =
describes =
+ the constructor signature(s) from the Java perspective. The same argu=
ment =
+ conversions are performed as are for fields (see below).
+ </li>
+ <li>
+ All public fields will get a getter function:<br>
+ <code>(classname.fieldname [instance]) -> field value</code><br>
+ and a setter:<br>
+ <code>(setf classname.fieldname [instance])</code><br>
+ Instance field wrappers take a first arg which is the instance. Stati=
c fields =
+ get a symbol-macro <code>*classname.fieldname*</code>
+ <p>
+ If the type of the field is primitive, the field value will be conver=
ted to a =
+ native Lisp value. If it is a Java String, it will be converted to a =
Lisp string. =
+ Otherwise, a generic reference to the Java object is returned. Simila=
rly, when =
+ setting, Lisp values will be accepted for primitives, Lisp strings fo=
r Strings, =
+ or (generic or typed) references for reference types.
+ </p>
+ </li>
+ <li>
+ Every public method will get a wrapper function:<br>
+ <code>(classname.methodname &rest args) -> return-value</code><br>
+ As with constructors, if a method is overloaded a single wrapper is c=
reated that =
+ handles overload resolution. If a method follows the JavaBeans proper=
ty protocol =
+ (i.e. it is called <code>getSomething</code> or <code>isSomething</co=
de> and =
+ there is a corresponding <code>setSomething</code>), then a <code>(se=
tf =
+ classname.methodname)</code> will be defined that calls the latter.
+ <p>
+ The same argument and return value conversions are performed as are f=
or fields. =
+ The function documentation string describes the method signature(s) f=
rom the =
+ Java perspective.
+ </p>
+
+ </li>
+ <li>
+ A Lisp class with the class-symbol as its name. It will have as its s=
uperclasses =
+ other Lisp classes corresponding to the Java superclass/superinterfac=
es, some of =
+ which may be forward-referenced-classes. An instance of this class w=
ill be =
+ returned by classname.new/make-new/new, at which point the entire hie=
rarchy will =
+ consist of finalized standard-classes.
+ </li>
+ <li>
+ Note that, due to the need to reference other Java types during the d=
efinition =
+ of a class wrapper, symbols, classes, and packages relating to those =
other types =
+ may also be created. In all cases they will be created with names and =
+ packages as described above.
+ </li>
+ </ul>
+ </li>
+
+ <li>
+ <strong>Function</strong> <code>(get-jar-classnames jar-file-name &rest=
packages) =
+ -> list-of-strings</code>
+ <p>
+ Returns a list of class name strings. Packages should be strings of the=
form "java/lang =
+ " for recursive lookup and "java/util/" (note trailing slash) for non-=
recursive.
+ </p>
+ </li>
+ <li>
+ <strong>Function</strong> <code>(dump-wrapper-defs-to-file filename cla=
ssnames) -> =
+ unspecified</code>
+ <p>
+ Given a list of classnames (say from <code>get-jar-classnames</code>), =
writes =
+ calls to <code>def-java-class</code> to a file:
+ </p>
+ <pre>
+(dump-wrapper-defs-to-file "/lisp/java-lang.lisp"
+ (get-jar-classnames "/j2sdk1.4.2_01/jre/lib/rt.jar " "java/lang/"))
+(compile-file "/lisp/java-lang")
+(load "/lisp/java-lang")
+(use-package "java.lang")
+;Wrappers for all of java.lang are now available
+</pre>
+ </li>
+ </ul>
+
+ <a name=3D"objects"></a> <h3>Object Creation</h3>
+ <ul>
+ <li>
+ <strong><a name=3D"makenew"></a>Generic Function</strong> <code>(make-n=
ew class-symbol =
+ &rest args) -> typed-reference</code>
+ <p>
+ Allows for definition of before/after methods on constructors. Calls <c=
ode>classname.new</code>. =
+ The new macro expands into a call to this.
+ </p>
+ </li>
+ <li>
+ <strong>Macro</strong> <code>(new class-spec &rest args) -> typed-refer=
ence</code>
+ <br>
+ <p>
+ class-spec -> class-name | (class-name this-name)<br>
+ class-name -> "package.qualified.ClassName" | classname.<br>
+ args -> [actual-arg]* [init-arg-spec]*<br>
+ init-arg-spec -> init-arg | (init-arg)<br>
+ init-arg -> :settable-field-or-method [params]* value (note keyword)<br>
+ | .method-name [args]* (note leading dot)<br>
+ </p>
+
+ <p>
+ Creates a new instance of class-name, by expanding into a call to the m=
ake-new =
+ generic function, then initializes it by setting fields or accessors an=
d/or =
+ calling member functions. If this-name is supplied, it will be bound to=
the =
+ newly-allocated object and available to the init-args:
+ </p>
+ <pre>
+(new (button. this) shell *SWT.CENTER* ;the actual args
+ :gettext "Call Lisp" ;a javabean property
+ (.addlistener *swt.selection* ;a method call
+ (new-proxy (listener.
+ (handleevent (event)
+ (declare (ignore event))
+ (setf (button.gettext this) ;this is bound to new=
instance
+ (format nil "~A ~A"
+ (lisp-implementation-type)
+ (lisp-implementation-version)))
+ nil))))
+ .setsize 200 100 ;can omit parens
+ (.setlocation 40 40))
+ </pre>
+ Expands into:
+ <pre>
+(LET* ((#:G598 (MAKE-NEW BUTTON. SHELL *SWT.CENTER*)) (THIS #:G598))
+ (SETF (BUTTON.GETTEXT #:G598) "Call Lisp")
+ (BUTTON.ADDLISTENER #:G598
+ *SWT.SELECTION*
+ (NEW-PROXY (LISTENER.
+ (HANDLEEVENT
+ (EVENT)
+ (DECLARE (IGNORE EVENT))
+ (SETF (BUTTON.GETTEXT THIS)
+ (FORMAT NIL
+ "~A ~A"
+ (LISP-IMPLEMENTATION-TYPE)
+ (LISP-IMPLEMENTATION-VERS=
ION)))
+ NIL))))
+ (BUTTON.SETSIZE #:G598 200 100)
+ (BUTTON.SETLOCATION #:G598 40 40)
+ #:G598)
+ </pre>
+
+ </li>
+ </ul>
+ <a name=3D"arrays"></a> <h3>Array Support</h3>
+ <ul>
+ <li>
+ <strong>Generic Function</strong> <code>(make-new-array type &rest dime=
nsions) -> =
+ reference to new array</code>
+ <p>
+ Generic function with methods defined for all Java class designators:
+ <ul>
+ <li>
+ A "package.qualified.ClassName" string
+ </li>
+ <li>
+ (the value of) A class-symbol - classname.
+ </li>
+ <li>
+ A primitive designator keyword - :boolean|:byte|:char|:double|:float|=
:int|:long|:short
+ </li>
+ </ul>
+ </p>
+ <p>
+ Creates a Java array of the requested type with the requested dimension=
s.
+ </p>
+ </li>
+ <li>
+ <strong>Function</strong> <code>(jlength array) -> integer</code>
+ <p>
+ Like length, for Java arrays
+ </p>
+ </li>
+
+ <li>
+ <strong>Function</strong> <code>(jref array &rest subscripts) -> refere=
nce</code>
+ <p>
+ Like aref, for Java arrays of non-primitive (reference) types, settable.
+ </p>
+ </li>
+ <li>
+ <strong>Function</strong> <code>(jref-xxx array &rest subscripts) -> va=
lue</code>
+ <p>
+ Where xxx =3D boolean|byte|char|double|float|int|long|short. Like jref,=
for Java =
+ arrays of primitive types, settable.
+ </p>
+ </li>
+
+ </ul>
+
+ <a name=3D"proxies"></a> <h3>Proxies - Java calling back to Lisp</h3>
+ <ul>
+ <p>
+ Proxies allow the creation of Java objects that implement one or more in=
terfaces =
+ in Lisp, and thus callbacks from Java to Lisp. You must call <a href=3D#=
enableproxies>
+ <code>enable-java-proxies</code></a> before using this proxy API. A sign=
ificant =
+ limitation is that LispWorks appears to not support calls back into Lisp=
other =
+ than from threads initiated by Lisp, so you must ensure that the proxy w=
ill not =
+ be called from an arbitrary Java thread!
+ </p>
+ <li>
+ <strong>Macro</strong> <code>(new-proxy &rest interface-defs) -> refere=
nce</code>
+ <p>
+ interface-def -> (interface-name method-defs+)<br>
+ interface-name -> "package.qualified.ClassName" | classname. (must name=
a Java =
+ interface type)<br>
+ method-def -> (method-name arg-defs* body) <br>
+ arg-def -> arg-name | (arg-name arg-type) arg-type -> "package.qualifie=
d.ClassName =
+ " | classname. | :primitive <br>
+ method-name -> symbol | string (matched case-insensitively)
+ </p>
+
+ <p>
+ Creates, registers and returns a Java object that implements the suppli=
ed =
+ interfaces
+ </p>
+ </li>
+ <li>
+ <strong>Function</strong> <code>(unregister-proxy proxy) -> unspecified=
</code>
+ <p>
+ Stops handling for the proxy (which must have been created by <code>new=
-proxy</code>) =
+ and removes references from the Lisp side. Make sure it is no longer re=
ferenced =
+ from Java first!
+ </p>
+ </li>
+ </ul>
+
+ <a name=3D"utilities"></a> <h3>Utilities</h3>
+ <ul>
+
+ <li>
+ <strong>Function</strong> <code>(jeq obj1 obj2) -> boolean</code>
+ <p>
+ Are the 2 java objects the same object? Note that this is not the same =
as Object.equals()
+ <p>
+ </li>
+ <li>
+ <strong>Function</strong> <code>(find-java-class class-sym-or-string) -=
> =
+ reference to Java Class object</code>
+ <p>
+ Given a Java class designator, returns the Java Class object. Use this =
in =
+ preference to Class.forName() when using jfli.
+ </p>
+ </li>
+
+ <li>
+ <strong>Function</strong> <code>(make-typed-ref java-ref) -> typed-refe=
rence</code>
+ <p>
+ Given a generic Java reference, determines the full type of the object =
and =
+ returns an instance of a typed reference wrapper. classname.new/make-ne=
w/new always return typed =
+ references, but since Java methods might return Object or some interfac=
e type, =
+ and we don't want to always incur the cost of type determination, field=
and =
+ method wrapper functions return generic references. Use this function t=
o create =
+ a typed reference corresponding to the full actual type of the object w=
hen =
+ desired.
+ </p>
+ </li>
+ <li>
+ <strong>Function</strong> <code>(box-xxx value) -> reference to Java pr=
imitive wrapper class</code>
+ <p>Where xxx =3D boolean|byte|char|double|float|int|long|short|string. =
+ Given a compatible Lisp value, creates an instance of the corresponding=
Java primitive wrapper class,
+ e.g. Integer. This should rarely be needed, but can be used to force ov=
erloading resolution</p>
+ </li>
+ <li>
+ <strong>Function</strong> <code>(unbox-xxx ref) -> Lisp value</code>
+ <p>Where xxx =3D boolean|byte|char|double|float|int|long|short|string. =
+ Given an instance of a Java primitive wrapper class, creates an instanc=
e of the corresponding =
+ compatible Lisp value. This should rarely be needed, but can be used to=
unbox values returned by Java
+ Object-based APIs.</p>
+ </li>
+ </ul>
+ =
+ <a name=3D"summary"></a> <h3>Summary</h3>
+<p>
+I hope you find jfli useful. It is my sincere intent that it enhance the u=
tility and interoperability of Common Lisp,
+a language with which I am still becoming familiar, and grow to appreciate=
more every day. I welcome comments
+and code contributions.
+</p>
+<p>
+Rich Hickey, July 2004
+</p>
+ </body>
+</html>
Modified: trunk/source/examples/jfli/examples/session.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/jfli/examples/session.lisp (original)
+++ trunk/source/examples/jfli/examples/session.lisp Thu Nov 27 12:40:41 20=
08
@@ -1,104 +1,104 @@
-;this presumes you have already compiled jni.lisp and jfli.lisp into fasl =
files
-
-CL-USER 4 > (load "/lisp/jni")
-; Loading fasl file C:\lisp\jni.fsl
-#P"C:/lisp/jni.fsl"
-
-CL-USER 5 > (load "/lisp/jfli")
-; Loading fasl file C:\lisp\jfli.fsl
-#P"C:/lisp/jfli.fsl"
-
-;The user API is entirely in the jfli package
-CL-USER 6 > (use-package :jfli)
-T
-
-;tell the library where Java is located
-CL-USER 7 > (setf *jni-lib-path* "/j2sdk1.4.2_01/jre/bin/client/jvm.dll")
-"/j2sdk1.4.2_01/jre/bin/client/jvm.dll"
-
-;this starts the VM - note how you can set the classpath
-CL-USER 8 > (create-jvm "-Djava.class.path=3D/lisp/jfli.jar")
-0
-#<Pointer: JNI:PVM =3D #x081022A0>
-#<Pointer: JNI:PENV =3D #x0086A858>
-
-;define wrappers for the members of Object
-CL-USER 9 > (def-java-class "java.lang.Object")
-NIL
-
-;and of Properties, a Hashtable-like class
-CL-USER 10 > (def-java-class "java.util.Properties")
-#<STANDARD-CLASS |java.util|:PROPERTIES. 2066B964>
-
-;the above will create these packages if they do not already exist
-;use the packages for easy name access
-
-CL-USER 11 > (use-package "java.lang")
-T
-
-CL-USER 12 > (use-package "java.util")
-T
-
-;create a Properties instance, note keyword-style member inits, string con=
version etc
-;also note typed return value
-CL-USER 13 > (setf p (new properties. :getproperty "fred" "ethel"))
-#<PROPERTIES. 20664A94>
-
-;virtual functions work as normal
-CL-USER 14 > (object.tostring p)
-"{fred=3Dethel}"
-
-;setter was generated for member function because it follows the JavaBeans=
property protocol
-CL-USER 15 > (setf (properties.getproperty p "ricky") "lucy")
-"lucy"
-
-CL-USER 16 > (object.tostring p)
-"{ricky=3Dlucy, fred=3Dethel}"
-
-CL-USER 17 > (properties.size p)
-2
-
-;totally dynamic access, create wrappers as you need
-CL-USER 18 > (def-java-class "java.lang.Class")
-#<STANDARD-CLASS CLASS. 20680EC4>
-
-CL-USER 19 > (class.getname (object.getclass p))
-"java.util.Properties"
-
-CL-USER 20 > (def-java-class "java.util.Enumeration")
-#<STANDARD-CLASS ENUMERATION. 20669274>
-
-;no need to wait for the vendor to enhance the language - you use Lisp!
-CL-USER 21 > (defmacro doenum ((e enum) &body body)
- (let ((genum (gensym)))
- `(let ((,genum ,enum))
- (do ()
- ((not (enumeration.hasmoreelements ,genum)))
- (let ((,e (enumeration.nextelement ,genum)))
- , at body)))))(defmacro doenum ((e enum) &body body)
- (let ((genum (gensym)))
- `(let ((,genum ,enum))
- (do ()
- ((not (enumeration.hasmoreelements ,genum)))
- (let ((,e (enumeration.nextelement ,genum)))
- , at body)))))
-DOENUM
-
-;can't do this in Java yet can in Lisp
-CL-USER 22 > (doenum (prop (properties.elements p)) (print (object.tostrin=
g prop)))
-
-"lucy" =
-"ethel" =
-NIL
-
-;doc strings are created giving original Java signatures and indicating ov=
erloads
-CL-USER 23 > (documentation 'properties.getproperty 'function)
-"java.lang.String getProperty(java.lang.String,java.lang.String)
-java.lang.String getProperty(java.lang.String)
-"
-
-CL-USER 24 > (documentation 'properties.new 'function)
-"java.util.Properties()
-java.util.Properties(java.util.Properties)
-"
-
+;this presumes you have already compiled jni.lisp and jfli.lisp into fasl =
files
+
+CL-USER 4 > (load "/lisp/jni")
+; Loading fasl file C:\lisp\jni.fsl
+#P"C:/lisp/jni.fsl"
+
+CL-USER 5 > (load "/lisp/jfli")
+; Loading fasl file C:\lisp\jfli.fsl
+#P"C:/lisp/jfli.fsl"
+
+;The user API is entirely in the jfli package
+CL-USER 6 > (use-package :jfli)
+T
+
+;tell the library where Java is located
+CL-USER 7 > (setf *jni-lib-path* "/j2sdk1.4.2_01/jre/bin/client/jvm.dll")
+"/j2sdk1.4.2_01/jre/bin/client/jvm.dll"
+
+;this starts the VM - note how you can set the classpath
+CL-USER 8 > (create-jvm "-Djava.class.path=3D/lisp/jfli.jar")
+0
+#<Pointer: JNI:PVM =3D #x081022A0>
+#<Pointer: JNI:PENV =3D #x0086A858>
+
+;define wrappers for the members of Object
+CL-USER 9 > (def-java-class "java.lang.Object")
+NIL
+
+;and of Properties, a Hashtable-like class
+CL-USER 10 > (def-java-class "java.util.Properties")
+#<STANDARD-CLASS |java.util|:PROPERTIES. 2066B964>
+
+;the above will create these packages if they do not already exist
+;use the packages for easy name access
+
+CL-USER 11 > (use-package "java.lang")
+T
+
+CL-USER 12 > (use-package "java.util")
+T
+
+;create a Properties instance, note keyword-style member inits, string con=
version etc
+;also note typed return value
+CL-USER 13 > (setf p (new properties. :getproperty "fred" "ethel"))
+#<PROPERTIES. 20664A94>
+
+;virtual functions work as normal
+CL-USER 14 > (object.tostring p)
+"{fred=3Dethel}"
+
+;setter was generated for member function because it follows the JavaBeans=
property protocol
+CL-USER 15 > (setf (properties.getproperty p "ricky") "lucy")
+"lucy"
+
+CL-USER 16 > (object.tostring p)
+"{ricky=3Dlucy, fred=3Dethel}"
+
+CL-USER 17 > (properties.size p)
+2
+
+;totally dynamic access, create wrappers as you need
+CL-USER 18 > (def-java-class "java.lang.Class")
+#<STANDARD-CLASS CLASS. 20680EC4>
+
+CL-USER 19 > (class.getname (object.getclass p))
+"java.util.Properties"
+
+CL-USER 20 > (def-java-class "java.util.Enumeration")
+#<STANDARD-CLASS ENUMERATION. 20669274>
+
+;no need to wait for the vendor to enhance the language - you use Lisp!
+CL-USER 21 > (defmacro doenum ((e enum) &body body)
+ (let ((genum (gensym)))
+ `(let ((,genum ,enum))
+ (do ()
+ ((not (enumeration.hasmoreelements ,genum)))
+ (let ((,e (enumeration.nextelement ,genum)))
+ , at body)))))(defmacro doenum ((e enum) &body body)
+ (let ((genum (gensym)))
+ `(let ((,genum ,enum))
+ (do ()
+ ((not (enumeration.hasmoreelements ,genum)))
+ (let ((,e (enumeration.nextelement ,genum)))
+ , at body)))))
+DOENUM
+
+;can't do this in Java yet can in Lisp
+CL-USER 22 > (doenum (prop (properties.elements p)) (print (object.tostrin=
g prop)))
+
+"lucy" =
+"ethel" =
+NIL
+
+;doc strings are created giving original Java signatures and indicating ov=
erloads
+CL-USER 23 > (documentation 'properties.getproperty 'function)
+"java.lang.String getProperty(java.lang.String,java.lang.String)
+java.lang.String getProperty(java.lang.String)
+"
+
+CL-USER 24 > (documentation 'properties.new 'function)
+"java.util.Properties()
+java.util.Properties(java.util.Properties)
+"
+
Modified: trunk/source/examples/jfli/examples/swtdemo.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/jfli/examples/swtdemo.lisp (original)
+++ trunk/source/examples/jfli/examples/swtdemo.lisp Thu Nov 27 12:40:41 20=
08
@@ -1,54 +1,54 @@
-;Just load this from LispWorks menu
-;note works on Windows, some issues on OS X due to windowing conflict w/IDE
-(load "~/jfli/jni")
-(load "~/jfli/jfli")
-(use-package :jfli)
-(create-jvm =
-#+:macosx "-Djava.class.path=3D/Users/rich/swt/swt.jar:/Users/rich/swt/swt=
-pi.jar:User/rich/jfli/jfli.jar"
- #+:macosx "-Djava.library.path=3D/Users/rich/swt"
- #+:win32 "-Djava.class.path=3D/swt/swt.jar;/lisp/jfli.jar"
- #+:win32 "-Djava.library.path=3D/swt"
- )
-(enable-java-proxies)
-
-
-
-(def-java-class "org.eclipse.swt.widgets.Display")
-(def-java-class "org.eclipse.swt.widgets.Button")
-(def-java-class "org.eclipse.swt.widgets.Shell")
-(def-java-class "org.eclipse.swt.widgets.Listener")
-(def-java-class "org.eclipse.swt.SWT")
-
-(use-package "org.eclipse.swt")
-(use-package "org.eclipse.swt.widgets")
-
-
-(defun swt-demo ()
- (let* ((display (new display.))
- (shell (new shell. display
- :gettext "Using SWT from Lisp"
- (.setsize 300 200)
- (.setlocation 100 100)))
- (button (new (button. this) shell *SWT.CENTER*
- :gettext "Call Lisp"
- (.addlistener *swt.selection*
- (new-proxy (listener.
- (handleevent (event)
- (declare (ignore event))
- (setf (button.gettext this)
- (format nil "~A ~A"
- (lisp-implementation-ty=
pe)
- (lisp-implementation-ve=
rsion)))
- nil))))
- (.setsize 200 100)
- (.setlocation 40 40))))
- (declare (ignore button))
- (shell.open shell)
- (do ()
- ((shell.isdisposed shell))
- (unless (display.readanddispatch display)
- (display.sleep display)))
- (display.dispose display)))
-
-(mp:process-run-function "swt-proc" '() #'swt-demo)
-
+;Just load this from LispWorks menu
+;note works on Windows, some issues on OS X due to windowing conflict w/IDE
+(load "~/jfli/jni")
+(load "~/jfli/jfli")
+(use-package :jfli)
+(create-jvm =
+#+:macosx "-Djava.class.path=3D/Users/rich/swt/swt.jar:/Users/rich/swt/swt=
-pi.jar:User/rich/jfli/jfli.jar"
+ #+:macosx "-Djava.library.path=3D/Users/rich/swt"
+ #+:win32 "-Djava.class.path=3D/swt/swt.jar;/lisp/jfli.jar"
+ #+:win32 "-Djava.library.path=3D/swt"
+ )
+(enable-java-proxies)
+
+
+
+(def-java-class "org.eclipse.swt.widgets.Display")
+(def-java-class "org.eclipse.swt.widgets.Button")
+(def-java-class "org.eclipse.swt.widgets.Shell")
+(def-java-class "org.eclipse.swt.widgets.Listener")
+(def-java-class "org.eclipse.swt.SWT")
+
+(use-package "org.eclipse.swt")
+(use-package "org.eclipse.swt.widgets")
+
+
+(defun swt-demo ()
+ (let* ((display (new display.))
+ (shell (new shell. display
+ :gettext "Using SWT from Lisp"
+ (.setsize 300 200)
+ (.setlocation 100 100)))
+ (button (new (button. this) shell *SWT.CENTER*
+ :gettext "Call Lisp"
+ (.addlistener *swt.selection*
+ (new-proxy (listener.
+ (handleevent (event)
+ (declare (ignore event))
+ (setf (button.gettext this)
+ (format nil "~A ~A"
+ (lisp-implementation-ty=
pe)
+ (lisp-implementation-ve=
rsion)))
+ nil))))
+ (.setsize 200 100)
+ (.setlocation 40 40))))
+ (declare (ignore button))
+ (shell.open shell)
+ (do ()
+ ((shell.isdisposed shell))
+ (unless (display.readanddispatch display)
+ (display.sleep display)))
+ (display.dispose display)))
+
+(mp:process-run-function "swt-proc" '() #'swt-demo)
+
Modified: trunk/source/examples/jfli/jfli.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/jfli/jfli.lisp (original)
+++ trunk/source/examples/jfli/jfli.lisp Thu Nov 27 12:40:41 2008
@@ -1,1390 +1,1390 @@
-; Copyright (c) Rich Hickey. All rights reserved.
-; The use and distribution terms for this software are covered by the
-; Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
-; which can be found in the file CPL.TXT at the root of this distributi=
on.
-; By using this software in any fashion, you are agreeing to be bound by
-; the terms of this license.
-; You must not remove this notice, or any other, from this software.
-
-#|
-
-jfli is a library that provides access to Java from Lisp
-It depends on the jni package (included)
-Callbacks from Java to Lisp also require jfli.jar (included)
-
-|#
-
-(defpackage :jfli
- (:use :common-lisp :lispworks :jni)
- (:export
-
- ;jvm creation
- :*jni-lib-path* ;exposed from jni
- :create-jvm ;exposed from jni, you must call this prior to calling=
any other jfli function
- :enable-java-proxies
-
- ;wrapper generation
- :def-java-class
- :get-jar-classnames
- :dump-wrapper-defs-to-file
-
- ;object creation etc
- :find-java-class
- :new
- :make-new
- :make-typed-ref
- :jeq
-
- ;array support
- :make-new-array
- :jlength
- :jref
- :jref-boolean
- :jref-byte
- :jref-char
- :jref-double
- :jref-float
- :jref-int
- :jref-short
- :jref-long
-
- ;proxy support
- :new-proxy
- :unregister-proxy
-
- ;conversions
- :box-boolean
- :box-byte
- :box-char
- :box-double
- :box-float
- :box-integer
- :box-long
- :box-short
- :box-string
- :unbox-boolean
- :unbox-byte
- :unbox-char
- :unbox-double
- :unbox-float
- :unbox-integer
- :unbox-long
- :unbox-short
- :unbox-string
-
-; :ensure-package
-; :member-symbol
-; :class-symbol
-; :constructor-symbol
- ))
-
-(in-package :jfli)
-
-#|
-bootstrap the implementation of reflection wrappers with =
-a few (primitive, less safe and maybe faster) jni wrappers
-|#
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (def-jni-functions "java.lang.Object"
- ("getClass" () "Class")
- ("hashCode" () "int")
- ("toString" () "String")
- ("equals" ((obj "Object")) "boolean"))
-
- (def-jni-functions "java.lang.Class"
- ;should be :overloaded t, but we only use this version
- ("forName" ((className "String")) "Class" :static t)
- ("getConstructors" () "java.lang.reflect.Constructor<=
>")
- ("getFields" () "java.lang.reflect.Field<>")
- ("getMethods" () "java.lang.reflect.Method<>")
-
- ("getConstructor" ((parameter-types "Class<>")) "java=
.lang.reflect.Constructor")
- ("getField" ((name "String"))
- "java.lang.reflect.Field")
- ("getMethod" ((name "String") (parameter-types "Class=
<>"))
- "java.lang.reflect.Method")
-
- ("getSuperclass" () "Class")
- ("getInterfaces" () "Class<>")
-
- ("getName" () "String")
- ("isArray" () "boolean")
- ("isPrimitive" () "boolean"))
-
- (def-jni-functions "java.lang.reflect.Field"
- ("getName" () "java.lang.String")
- ("getType" () "java.lang.Class")
- ("getModifiers" () "int")
-
- ("get" ((obj "java.lang.Object")) "java.lang.Object" =
:raw-return t)
- ("getBoolean" ((obj "java.lang.Object")) "boolean")
- ("getByte" ((obj "java.lang.Object")) "byte")
- ("getChar" ((obj "java.lang.Object")) "char")
- ("getDouble" ((obj "java.lang.Object")) "double")
- ("getFloat" ((obj "java.lang.Object")) "float")
- ("getInt" ((obj "java.lang.Object")) "int")
- ("getLong" ((obj "java.lang.Object")) "long")
- ("getShort" ((obj "java.lang.Object")) "short")
-
- ("set" ((obj "java.lang.Object") (value "java.lang.Ob=
ject")) "void")
- ("setBoolean" ((obj "java.lang.Object") (b "boolean")=
) "void")
- ("setByte" ((obj "java.lang.Object") (b "byte")) "voi=
d")
- ("setChar" ((obj "java.lang.Object") (c "char")) "voi=
d")
- ("setDouble" ((obj "java.lang.Object") (d "double")) =
"void")
- ("setFloat" ((obj "java.lang.Object") (f "float")) "v=
oid")
- ("setInt" ((obj "java.lang.Object") ( i "int")) "void=
")
- ("setLong" ((obj "java.lang.Object") (l "long")) "voi=
d")
- ("setShort" ((obj "java.lang.Object") (s "short")) "v=
oid"))
-
- (def-jni-functions "java.lang.reflect.Constructor"
- ("getParameterTypes" () "java.lang.Class<>")
- ("newInstance" ((initargs "java.lang.Object<>")) "jav=
a.lang.Object"))
-
- (def-jni-functions "java.lang.reflect.Method"
- ("getName" () "java.lang.String")
- ("getParameterTypes" () "java.lang.Class<>")
- ("getReturnType" () "java.lang.Class")
- ("getModifiers" () "int")
- ("invoke" ((object "java.lang.Object")
- (args "java.lang.Object<>")) "java.lang.Ob=
ject"
- :raw-return t))
-
- (def-jni-functions "java.lang.reflect.Array"
- ("get" ((array "java.lang.Object") (index "int")) "ja=
va.lang.Object" :static t)
- ("getBoolean"
- ((array "java.lang.Object") (index "int")) "boolean"=
:static t)
- ("getByte"
- ((array "java.lang.Object") (index "int")) "byte" :s=
tatic t)
- ("getChar"
- ((array "java.lang.Object") (index "int")) "char" :s=
tatic t)
- ("getDouble"
- ((array "java.lang.Object") (index "int")) "double" =
:static t)
- ("getFloat"
- ((array "java.lang.Object") (index "int")) "float" :=
static t)
- ("getInt"
- ((array "java.lang.Object") (index "int")) "int" :st=
atic t)
- ("getShort"
- ((array "java.lang.Object") (index "int")) "short" :=
static t)
- ("getLong"
- ((array "java.lang.Object") (index "int")) "long" :s=
tatic t)
- ("getLength" ((array "java.lang.Object")) "int" :stat=
ic t)
- ("newInstance" ((componentType "java.lang.Class")
- (length "int")) "java.lang.Object" :s=
tatic t :overloaded t)
- ("newInstance" ((componentType "java.lang.Class")
- (dimensions "int<>")) "java.lang.Obje=
ct" :static t :overloaded t)
- ("set" ((array "java.lang.Object") (index "int") (val=
ue "java.lang.Object"))
- "void" :static t))
-
-
- (def-jni-function "java.lang.reflect.Modifier"
- "isStatic" ((mod "int")) "boolean" :static t)
-
- (def-jni-constructor "java.lang.Boolean" ((value "boolean")))
- (def-jni-constructor "java.lang.Byte" ((value "byte")))
- (def-jni-constructor "java.lang.Character" ((value "char")))
- (def-jni-constructor "java.lang.Double" ((value "double")))
- (def-jni-constructor "java.lang.Float" ((value "float")))
- (def-jni-constructor "java.lang.Integer" ((value "int")))
- (def-jni-constructor "java.lang.Short" ((value "short")))
-
- (def-jni-function "java.lang.Boolean" "booleanValue" () "boolean")
- (def-jni-function "java.lang.Byte" "byteValue" () "byte")
- (def-jni-function "java.lang.Character" "charValue" () "char")
- (def-jni-function "java.lang.Double" "doubleValue" () "double")
- (def-jni-function "java.lang.Float" "floatValue" () "float")
- (def-jni-function "java.lang.Integer" "intValue" () "int")
- (def-jni-function "java.lang.Short" "shortValue" () "short")
-
- (def-jni-constructor "java.util.jar.JarFile" ((filename "java.lang.Strin=
g")))
- (def-jni-function "java.util.jar.JarFile"
- "entries" () "java.util.Enumeration")
- (def-jni-functions "java.util.Enumeration"
- ("hasMoreElements" () "boolean")
- ("nextElement" () "java.lang.Object"))
- (def-jni-functions "java.util.zip.ZipEntry"
- ("isDirectory" () "boolean")
- ("getName" () "java.lang.String"))
-
-
- (def-jni-functions "java.lang.Long"
- ("valueOf" ((s "String")) "java.lang.Long" :static t)
- ("intValue" () "int"))
-
- (def-jni-field "java.lang.Boolean" "TYPE" "Class" :static t)
- (def-jni-field "java.lang.Byte" "TYPE" "Class" :static t)
- (def-jni-field "java.lang.Character" "TYPE" "Class" :static t)
- (def-jni-field "java.lang.Float" "TYPE" "Class" :static t)
- (def-jni-field "java.lang.Integer" "TYPE" "Class" :static t)
- (def-jni-field "java.lang.Double" "TYPE" "Class" :static t)
- (def-jni-field "java.lang.Short" "TYPE" "Class" :static t)
- (def-jni-field "java.lang.Long" "TYPE" "Class" :static t)
-
- (def-jni-constructor "com.richhickey.jfli.LispInvocationHandler" ())
- (def-jni-function "java.lang.reflect.Proxy"
- "newProxyInstance" ((loader "java.lang.ClassLoader")
- (interfaces "java.lang.Class<>")
- (h "InvocationHandler")) "java.lan=
g.Object" :static t)
-
- (def-jni-function "java.lang.ClassLoader"
- "getSystemClassLoader" () "ClassLoader" :static t)
-
- ) ;eval-when
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;
-
-(eval-when (:compile-toplevel :load-toplevel)
- (defun ensure-package (name)
- "find the package or create it if it doesn't exist"
- (or (find-package name)
- (make-package name :use '())))
- (intern "Object" (ensure-package "java.lang"))
- (intern "String" (ensure-package "java.lang")))
-
-(defmacro do-jarray ((x array) &body body)
- "jni-based, so not safe and not exported, but used by the implementation"
- (let ((gcount (gensym))
- (gi (gensym))
- (garray (gensym)))
- `(let* ((,garray ,array)
- (,gcount (jni:get-array-length ,garray)))
- (dotimes (,gi ,gcount)
- (let ((,x (jaref ,garray ,gi)))
- , at body)))))
-
-
-(defmacro doenum ((e enum) &body body)
- "jni-based, so not safe and not exported, but used by the implementation"
- (let ((genum (gensym)))
- `(let ((,genum ,enum))
- (do ()
- ((not (enumeration.hasmoreelements ,genum)))
- (let ((,e (enumeration.nextelement ,genum)))
- , at body)))))
-
-;probably insufficiently general, works as used here
-(defmacro get-or-init (place init-form)
- `(or ,place
- (setf ,place ,init-form)))
-
-;from c.l.l.
-(defmacro case-equal (exp &body clauses)
- (let ((temp (gensym)))
- `(let ((,temp ,exp))
- (cond ,@(mapcar #'(lambda (clause)
- (destructuring-bind (keys . clause-forms) clause
- (cond ((eq keys 'otherwise)
- `(t , at clause-forms))
- (t
- (if (atom keys) (setq keys (list keys)=
))
- `((member ,temp ',keys :test #'equal)
- , at clause-forms)))))
- clauses)))))
-
-;create object. to bootstrap the hierarchy
-(defclass |java.lang|::object. ()
- ((ref :reader ref :initarg :ref)
- (lisp-allocated :reader lisp-allocated-p :initarg :lisp-allocated :init=
form nil))
- (:documentation "the superclass of all Java typed reference classes"))
-
-(defun get-ref (x)
- "any function taking an object can be passed a raw java-ref ptr or a typ=
ed reference instance.
-Will also convert strings for use as objects"
- (etypecase x
- (java-ref x)
- (|java.lang|::object. (ref x))
- (string (convert-to-java-string x))
- (null nil)))
-
-(defun jeq (obj1 obj2)
- "are these 2 java objects the same object? Note that is not the same as =
Object.equals()"
- (is-same-object (get-ref obj1) (get-ref obj2)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;; names and symbols ;;;;;;;;;;;;;;;;;;;;;;;
-#|
-The library does a lot with names and symbols, needing at various times to:
- - find stuff in Java - full names w/case required
- - create hopefully non-conflicting packages and member names
-
-When you (def-java-class "java.lang.String") you get a bunch of symbols/na=
mes:
-a package named '|java.lang|
-a class-symbol '|java.lang|:STRING. (note the dot and case), =
- which can usually be used where a typename is required
- it also serves as the name of the Lisp typed reference class for string
- its symbol-value is the canonic-class-symbol (see below)
-a canonic-class-symbol '|java.lang|::|String|
- can be used to reconstitute the full class name
-
-I've started trying to flesh out the notion of a Java class designator, wh=
ich can either be
-the full class name as a string, the class-symbol, or one of :boolean, :in=
t etc
-|#
-
-(defun canonic-class-symbol (full-class-name)
- "(\"java.lang.Object\") -> '|java.lang|:|Object|"
- (multiple-value-bind (package class) (split-package-and-class full-class=
-name)
- (intern class (ensure-package package))))
-
-(defun class-symbol (full-class-name)
- "(\"java.lang.Object\") -> '|java.lang|:object."
- (multiple-value-bind (package class) (split-package-and-class full-class=
-name)
- (intern (string-upcase (string-append class ".")) (ensure-package pack=
age))))
-
-(defun java-class-name (class-sym)
- "inverse of class-symbol, only valid on class-syms created by def-java-c=
lass"
- (let ((canonic-class-symbol (symbol-value class-sym)))
- (string-append (package-name (symbol-package canonic-class-symbol))
- "."
- canonic-class-symbol)))
-
-(defun member-symbol (full-class-name member-name)
- "members are defined case-insensitively in case-sensitive packages,
-prefixed by 'classname.' -
-(member-symbol \"java.lang.Object\" \"toString\") -> '|java.lang|::OBJECT.=
TOSTRING"
- (multiple-value-bind (package class) (split-package-and-class full-class=
-name)
- (intern (string-upcase (string-append class "." member-name)) (ensure-=
package package))))
-
-(defun constructor-symbol (full-class-name)
- (member-symbol full-class-name "new"))
-
-(defun get-java-class-ref (canonic-class-symbol)
- "class-ref is cached on the plist of the canonic class symbol"
- (get-or-init (get canonic-class-symbol :class-ref)
- (let ((class-name (string-append (package-name
- (symbol-package canonic-c=
lass-symbol))
- "."
- canonic-class-symbol)))
- (try-null (jni-find-class (nsubstitute #\/ #\. class-name=
))))))
-
-(defun find-java-class (class-sym-or-string)
- "Given a Java class designator, returns the Java Class object."
- (ctypecase class-sym-or-string
- (symbol (case class-sym-or-string
- (:int integer.type)
- (:char character.type)
- (:long long.type)
- (:float float.type)
- (:boolean boolean.type)
- (:short short.type)
- (:double double.type)
- (:byte byte.type)
- (otherwise (get-java-class-ref class-sym-or-string))))
- (string (get-java-class-ref (canonic-class-symbol class-sym-or-string)=
))))
-
-;;;;;;;;;;;;;;;;;;;;;; typed reference support ;;;;;;;;;;;;;;;;;;;;;;;;
-#|
-The library maintains a hierarchy of typed reference classes that parallel=
the
-class hierarchy on the Java side
-new returns a typed reference, but other functions that return objects
-return raw references (for efficiency) =
-make-typed-ref can create fully-typed wrappers when desired
-|#
-
-(defun get-superclass-names (full-class-name)
- (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name)=
))
- (super (class.getsuperclass class))
- (interfaces (class.getinterfaces class))
- (supers ()))
- (do-jarray (i interfaces)
- (push i supers))
- ;hmmm - where should the base class go in the precedence list?
- ;is it more important than the interfaces? this says no
- (if super
- (push super supers)
- (push (find-java-class "java.lang.Object") supers))
- (setf supers (nreverse supers))
- ;now we need to fix up order so more derived classes are first
- ;but don't have a total ordering, so merge one at a time
- (let (result)
- (dolist (s supers)
- (setf result (merge 'list result (list s)
- (lambda (x y)
- (is-assignable-from x y)))))
- (mapcar #'class.getname result))))
-#|
-(defun get-superclass-names (full-class-name)
- (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name)=
))
- (super (class.getsuperclass class))
- (interfaces (class.getinterfaces class))
- (supers ()))
- (do-jarray (i interfaces)
- (push (class.getname i) supers))
- ;hmmm - where should the base class go in the precedence list?
- ;is it more important than the interfaces? this says no
- (if super
- (push (class.getname super) supers)
- (push "java.lang.Object" supers))
- (nreverse supers)))
-|#
-
-(defun ensure-java-class (full-class-name)
- "walks the superclass hierarchy and makes sure all the classes are fully=
defined
-(they may be undefined or just forward-referenced-class)
-caches this has been done on the class-symbol's plist"
- (let* ((class-sym (class-symbol full-class-name))
- (class (find-class class-sym nil)))
- (if (or (eql class-sym '|java.lang|::object.)
- (get class-sym :ensured))
- class
- (let ((supers (get-superclass-names full-class-name)))
- (dolist (super supers)
- (ensure-java-class super))
- (unless (and class (subtypep class 'standard-object))
- (setf class
- (clos:ensure-class class-sym :direct-superclasses (mapcar =
#'class-symbol supers))))
- (setf (get class-sym :ensured) t)
- class))))
-
-(defun ensure-java-hierarchy (class-sym)
- "Works off class-sym for efficient use in new
-This will only work on class-syms created by def-java-class,
-as it depends upon symbol-value being the canonic class symbol"
- (unless (get class-sym :ensured)
- (ensure-java-class (java-class-name class-sym))))
-
-(defun make-typed-ref (java-ref)
- "Given a raw java-ref, determines the full type of the object
-and returns an instance of a typed reference wrapper"
- (when java-ref
- (let ((class (object.getclass (get-ref java-ref))))
- (if (class.isarray class)
- (error "typed refs not supported for arrays (yet)")
- (make-instance (ensure-java-class (class.getname class)) :ref (get=
-ref java-ref) )))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;
-#|
-In an effort to reduce the volume of stuff generated when wrapping entire =
libraries,
-the wrappers just generate minimal stubs, which, if and when invoked at ru=
ntime,
-complete the work of building thunking closures, so very little code is ge=
nerated for
-things never called (Java libraries have huge numbers of symbols).
-Not sure if this approach matters, but that's how it works
-|#
-
-(defmacro def-java-class (full-class-name)
- "Given the package-qualified, case-correct name of a java class, will ge=
nerate
-wrapper functions for its constructors, fields and methods."
- (multiple-value-bind (package class) (split-package-and-class full-class=
-name)
- (declare (ignore class))
- (let* ((class-sym (class-symbol full-class-name))
- (defs
- (list*
- `(ensure-package ,package)
- ;build a path from the simple class symbol to the canonic
- `(defconstant ,class-sym ',(canonic-class-symbol full-class-n=
ame))
- `(export ',class-sym (symbol-package ',class-sym))
- `(def-java-constructors ,full-class-name)
- `(def-java-methods ,full-class-name)
- `(def-java-fields ,full-class-name)
- (unless (string=3D full-class-name "java.lang.Object")
- (let ((supers (mapcar #'class-symbol (get-superclass-names =
full-class-name))))
- (append (mapcar (lambda (p)
- `(ensure-package ,(package-name p)))
- (remove (symbol-package class-sym)
- (remove-duplicates (mapcar #'symb=
ol-package supers))))
- (list `(defclass ,(class-symbol full-class-name)
- ,supers ()))))))))
- `(locally , at defs))))
-
-(defun get-jar-classnames (jar-file-name &rest packages)
- "returns a list of strings, packages should be of the form \"java/lang\"
- for recursive lookup and \"java/util/\" for non-recursive"
- (let* ((jar (jarfile.new jar-file-name))
- (entries (jarfile.entries jar))
- (names ()))
- (doenum (e entries)
- (unless (zipentry.isdirectory e)
- (let ((ename (zipentry.getname e)))
- (flet ((matches (package)
- (and (eql 0 (search package ename))
- (or (not (eql #\/ (schar package (1- (length packa=
ge))))) ;recursive
- (not (find #\/ ename :start (length package)))=
)))) ;non-subdirectory
- (when (and (eql (search ".class" ename)
- (- (length ename) 6)) ;classname
- ;don't grab anonymous inner classes
- (not (and (find #\$ ename)
- (digit-char-p (schar ename (1+ (position =
#\$ ename))))))
- (some #'matches packages))
- (push (nsubstitute #\. #\/ (subseq ename 0 (- (length ename)=
6)))
- names))))))
- names))
-
-(defun dump-wrapper-defs-to-file (filename classnames)
- "given a list of classnames (say from get-jar-classnames), writes
-calls to def-java-class to a file"
- (with-open-file (s filename :direction :output :if-exists :supersede)
- (dolist (name (sort classnames #'string-lessp))
- (format s "(def-java-class ~S)~%" name))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;; constructors and new ;;;;;;;;;;;;;;;;;;;;;;;;;;
-#|
-
-Every non-interface class with a public ctor will get;
- a constructor, classname.new
- a method defined on make-new, ultimately calling classname.new,
- specialized on (the value of) it's class-symbol (e.g. canonic sym)
-
-Note that if the ctor is overloaded, there is just one function (taking a =
rest arg), =
-which handles overload resolution
-
-The new macro expands into a call to make-new
-|#
-
-(defgeneric make-new (class-sym &rest args)
- (:documentation "Allows for definition of before/after methods on ctors.
-The new macro expands into call to this"))
-
-(defun build-ctor-doc-string (name ctors)
- (with-output-to-string (s)
- (dolist (c ctors)
- (format s "~A(~{~#[~;~A~:;~A,~]~})~%"
- name
- (mapcar #'class-name-for-doc (jarray-to-list (constructor.ge=
tparametertypes c)))))))
-
-(defmacro def-java-constructors (full-class-name)
-"creates and exports a ctor func classname.new, defines a method of =
-make-new specialized on the class-symbol"
- (let ((ctor-list (get-ctor-list full-class-name)))
- (when ctor-list
- (let ((ctor-sym (constructor-symbol full-class-name))
- (class-sym (class-symbol full-class-name)))
- `(locally
- (defun ,ctor-sym (&rest args)
- ,(build-ctor-doc-string full-class-name ctor-list)
- (apply #'install-constructors-and-call ,full-class-name args))
- (export ',ctor-sym (symbol-package ',ctor-sym))
- (defmethod make-new ((class-sym (eql ,class-sym)) &rest args)
- (apply (function ,ctor-sym) args)))))))
-
-(defun get-ctor-list (full-class-name)
- (let* ((class-sym (canonic-class-symbol full-class-name))
- (class (get-java-class-ref class-sym))
- (ctor-array (class.getconstructors class))
- (ctor-list (jarray-to-list ctor-array)))
- ctor-list))
-
-(defun install-constructors-and-call (full-class-name &rest args)
- "initially the constructor symbol for a class is bound to this function,
-when first called it will replace itself with the appropriate direct thunk,
-then call the requested ctor - subsequent calls will be direct"
- (install-constructors full-class-name)
- (apply (constructor-symbol full-class-name) args))
-
-(defun install-constructors (full-class-name)
- (let* ((ctor-list (get-ctor-list full-class-name)))
- (when ctor-list
- (setf (fdefinition (constructor-symbol full-class-name))
- (make-ctor-thunk ctor-list (class-symbol full-class-name))))))
-
-(defun make-ctor-thunk (ctors class-sym)
- (if (rest ctors) ;overloaded
- (make-overloaded-ctor-thunk ctors class-sym)
- (make-non-overloaded-ctor-thunk (first ctors) class-sym)))
-
-(defun make-non-overloaded-ctor-thunk (ctor class-sym)
- (let ((arg-boxers (get-arg-boxers (constructor.getparametertypes ctor))))
- (lambda (&rest args)
- (let ((arg-array (build-arg-array args arg-boxers)))
- (ensure-java-hierarchy class-sym)
- (prog1
- (make-instance class-sym
- :ref (constructor.newinstance ctor arg-array)
- :lisp-allocated t)
- ;(constructor.newinstance ctor arg-array)
- (when arg-array
- (delete-local-ref arg-array)))))))
-
-(defun make-overloaded-ctor-thunk (ctors class-sym)
- (let ((thunks (make-ctor-thunks-by-args-length ctors class-sym)))
- (lambda (&rest args)
- (let ((fn (cdr (assoc (length args) thunks))))
- (if fn
- (apply fn
- args)
- (error "invalid arity"))))))
-
-(defun make-ctor-thunks-by-args-length (ctors class-sym)
- "returns an alist of thunks keyed by number of args"
- (let ((ctors-by-args-length (make-hash-table))
- (thunks-by-args-length nil))
- (dolist (ctor ctors)
- (let ((params-len (get-array-length (constructor.getparametertypes c=
tor))))
- (push ctor (gethash params-len ctors-by-args-length))))
- (maphash #'(lambda (args-len ctors)
- (push (cons args-len
- (if (rest ctors);truly overloaded
- (make-type-overloaded-ctor-thunk ctors cl=
ass-sym)
- ;only one ctor with this number of args
- (make-non-overloaded-ctor-thunk (first ctor=
s) class-sym)))
- thunks-by-args-length))
- ctors-by-args-length)
- thunks-by-args-length))
-
-(defun make-type-overloaded-ctor-thunk (ctors class-sym)
- "these methods have the same number of args and must be distinguished by=
type"
- (let ((thunks (mapcar #'(lambda (ctor)
- (list (make-non-overloaded-ctor-thunk ctor cla=
ss-sym)
- (jarray-to-list (constructor.getparamete=
rtypes ctor))))
- ctors)))
- (lambda (&rest args)
- (block fn
- (let ((arg-types (get-types-of-args args)))
- (dolist (thunk-info thunks)
- (destructuring-bind (thunk param-types) thunk-info
- (when (is-congruent-type-list param-types arg-types)
- (return-from fn (apply thunk args)))))
- (error "No matching constructor"))))))
-
-(defmacro new (class-spec &rest args)
-"new class-spec args
-class-spec -> class-name | (class-name this-name)
-class-name -> \"package.qualified.ClassName\" | classname.
-args -> [actual-arg]* [init-arg-spec]*
-init-arg-spec -> init-arg | (init-arg)
-init-arg -> :settable-field-or-method [params]* value ;note keyword
- | =
- .method-name [args]* ;note dot
-
-Creates a new instance of class-name, using make-new generic function,
-then initializes it by setting fields or accessors and/or calling member f=
unctions
-If this-name is supplied it will be bound to the newly-allocated object an=
d available
-to the init-args"
- (labels ((mem-sym? (x)
- (or (keywordp x)
- (and (symbolp x) (eql 0 (position #\. (symbol-name x))))))
- (mem-form? (x)
- (and (listp x) (mem-sym? (first x))))
- (mem-init? (x)
- (or (mem-sym? x) (mem-form? x)))
- (init-forms (x)
- (if x
- (if (mem-form? (first x))
- (cons (first x) (init-forms (rest x)))
- (let ((more (member-if #'mem-init? (rest x))))
- (cons (ldiff x more) (init-forms more)))))))
- (let* ((inits (member-if #'mem-init? args))
- (real-args (ldiff args inits))
- (class-atom (if (atom class-spec)
- class-spec
- (first class-spec)))
- (class-sym (if (symbolp class-atom)
- ;(find-symbol (string-append (symbol-name class-=
atom) "."))
- class-atom
- (multiple-value-bind (package class) (jni::split-p=
ackage-and-class class-atom)
- (find-symbol (string-append (string-upcase class=
) ".") package))))
- (class-name (subseq (symbol-name class-sym) 0 (1- (length (symb=
ol-name class-sym)))))
- (gthis (gensym)))
- (flet ((expand-init (x)
- (if (keywordp (first x)) ;setf field or property
- `(setf (,(find-symbol (string-append class-name "." (sy=
mbol-name (first x))))
- ,gthis ,@(butlast (rest x)))
- ,@(last (rest x)))
- ;.memfunc
- `(,(find-symbol (string-append class-name (symbol-name (f=
irst x))))
- ,gthis
- ,@(rest x)))))
- `(let* ((,gthis (make-new ,class-sym , at real-args))
- ,@(when (listp class-spec)
- `((,(second class-spec) ,gthis))))
- ,@(mapcar #'expand-init (init-forms inits))
- ,gthis)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Fields ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-#|
-all public fields will get a getter function classname.fieldname and a set=
ter - (setf classname.fieldname)
-instance fields take an first arg which is the instance
-static fields also get a symbol-macro *classname.fieldname*
-|#
-
-(defmacro def-java-fields (full-class-name)
-"fields will get a getter function classname.fieldname and a setter - (set=
f classname.fieldname)
-instance fields take an first arg which is the instance
-static fields also get a symbol-macro *classname.fieldname*"
- (let* ((class-sym (canonic-class-symbol full-class-name))
- (class (get-java-class-ref class-sym))
- (fields (jarray-to-list (class.getfields class)))
- (defs nil))
- (dolist (field fields)
- (let* ((field-name (field.getname field))
- (field-sym (member-symbol full-class-name field-name))
- (is-static (modifier.isstatic (field.getmodifiers field))))
- (if is-static
- (let ((macsym (intern (string-append "*" (symbol-name field-sy=
m) "*")
- (symbol-package field-sym))))
- (push `(defun ,field-sym ()
- (install-static-field-and-get ,full-class-name ,fie=
ld-name))
- defs)
- (push `(defun (setf ,field-sym) (val)
- (install-static-field-and-set ,full-class-name ,fie=
ld-name val))
- defs)
- (push `(export ',field-sym (symbol-package ',field-sym)) def=
s)
- (push `(define-symbol-macro ,macsym (,field-sym)) defs)
- (push `(export ',macsym (symbol-package ',macsym)) defs))
- (progn
- (push `(defun ,field-sym (obj)
- (install-field-and-get ,full-class-name ,field-name o=
bj))
- defs)
- (push `(defun (setf ,field-sym) (val obj)
- (install-field-and-set ,full-class-name ,field-name v=
al obj))
- defs)
- (push `(export ',field-sym (symbol-package ',field-sym)) defs)=
))))
- `(locally ,@(nreverse defs))))
-
-(defun install-field-and-get (full-class-name field-name obj)
- (install-field full-class-name field-name)
- (funcall (member-symbol full-class-name field-name) obj))
-
-(defun install-field-and-set (full-class-name field-name val obj)
- (install-field full-class-name field-name)
- (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name)=
)) val obj))
-
-(defun install-static-field-and-get (full-class-name field-name)
- (install-field full-class-name field-name)
- (funcall (member-symbol full-class-name field-name)))
-
-(defun install-static-field-and-set (full-class-name field-name val)
- (install-field full-class-name field-name)
- (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name)=
)) val))
-
-(defun install-field (full-class-name field-name)
- (let* ((class-sym (canonic-class-symbol full-class-name))
- (class (get-java-class-ref class-sym))
- (field (class.getfield class field-name))
- (field-sym (member-symbol full-class-name field-name))
- (is-static (modifier.isstatic (field.getmodifiers field)))
- (field-type-name (class.getname (field.gettype field)))
- (boxer (get-boxer-fn field-type-name))
- (unboxer (get-unboxer-fn field-type-name)))
- (if is-static
- (progn
- (setf (fdefinition field-sym)
- (lambda ()
- (funcall unboxer (field.get field nil) t)))
- (setf (fdefinition `(setf ,field-sym))
- (lambda (arg)
- (field.set field nil
- (get-ref (if (and boxer (not (boxed? arg)))
- (funcall boxer arg)
- arg)))
- arg)))
- (progn
- (setf (fdefinition field-sym)
- (lambda (obj)
- (funcall unboxer (field.get field (get-ref obj)) t)))
- (setf (fdefinition `(setf ,field-sym))
- (lambda (arg obj)
- (field.set field (get-ref obj)
- (get-ref (if (and boxer (not (boxed? arg)))
- (funcall boxer arg)
- arg)))
- arg))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-#|
-defines wrappers for all public methods of the class
-As with ctors, if a method is overloaded a single wrapper is created that =
handles
-overload resolution.
-The wrappers have the name classname.methodname
-If a method follows the JavaBeans property protocol (i.e. it is called get=
Something or isSomething
-and there is a corresponding setSomething, then a (setf classname.methodna=
me) will be defined
-that calls the latter
-|#
-
-(defun class-name-for-doc (class)
- (let ((name (class.getname class)))
- (if (class.isarray class)
- (decode-array-name name)
- name)))
-
-(defun build-method-doc-string (name methods)
- (with-output-to-string (s)
- (dolist (m methods)
- (format s "~A~A ~A(~{~#[~;~A~:;~A,~]~})~%"
- (if (modifier.isstatic (method.getmodifiers m))
- "static "
- "")
- (class.getname (method.getreturntype m))
- name
- (mapcar #'class-name-for-doc (jarray-to-list (method.getpara=
metertypes m)))))))
-
-(defmacro def-java-methods (full-class-name)
- (let ((methods-by-name (get-methods-by-name full-class-name))
- (defs nil))
- (maphash (lambda (name methods)
- (let ((method-sym (member-symbol full-class-name name)))
- (push `(defun ,method-sym (&rest args)
- ,(build-method-doc-string name methods)
- (apply #'install-methods-and-call ,full-class-na=
me ,name args))
- defs)
- (push `(export ',method-sym (symbol-package ',method-sym))
- defs)
- ;build setters when finding beans property protocol
- (flet ((add-setter-if (prefix)
- (when (eql 0 (search prefix name))
- (let ((setname (string-append "set" (subseq na=
me (length prefix)))))
- (when (gethash setname methods-by-name)
- (push `(defun (setf ,method-sym) (val &res=
t args)
- (progn
- (apply #',(member-symbol full-c=
lass-name setname)
- (append args (list val)))
- val))
- defs))))))
- (add-setter-if "get")
- (add-setter-if "is"))))
- methods-by-name)
- `(locally ,@(nreverse defs))))
-
-(defun install-methods-and-call (full-class-name method &rest args)
- "initially all the member function symbols for a class are bound to this=
function,
-when first called it will replace them with the appropriate direct thunks,
-then call the requested method - subsequent calls via those symbols will b=
e direct"
- (install-methods full-class-name)
- (apply (member-symbol full-class-name method) args))
-
-(defun decode-array-name (tn)
- (let ((prim (assoc tn
- '(("Z" . "boolean")
- ("B" . "byte")
- ("C" . "char")
- ("S" . "short")
- ("I" . "int")
- ("J" . "long")
- ("F" . "float")
- ("D" . "double")
- ("V" . "void"))
- :test #'string-equal)))
- (if prim
- (rest prim)
- (let ((array-depth (count #\[ tn)))
- (if (=3D 0 array-depth)
- (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ;
- (with-output-to-string (s)
- (write-string (decode-array-name (subseq tn array-depth)) s)
- (dotimes (x array-depth)
- (write-string "[]" s))))))))
-
-(defun jarray-to-list (array)
- (let (ret)
- (do-jarray (x array)
- (push x ret))
- (nreverse ret)))
-
-(defun get-methods-by-name (full-class-name)
- "returns an #'equal hashtable of lists of java.lang.Method refs keyed by=
name"
- (let* ((class-sym (canonic-class-symbol full-class-name))
- (class (get-java-class-ref class-sym))
- (method-array (class.getmethods class))
- (methods-by-name (make-hash-table :test #'equal)))
- (do-jarray (method method-array)
- (push method (gethash (method.getName method) methods-by-name)))
- methods-by-name))
-
-(defun install-methods (full-class-name)
- (let ((methods-by-name (get-methods-by-name full-class-name)))
- (maphash
- (lambda (name methods)
- (setf (fdefinition (member-symbol full-class-name name))
- (make-method-thunk methods)))
- methods-by-name)))
-
-(defun make-method-thunk (methods)
- (if (rest methods) ;overloaded
- (make-overloaded-thunk methods)
- (make-non-overloaded-thunk (first methods))))
-
-(defun make-non-overloaded-thunk (method)
- (let ((unboxer-fn (get-unboxer-fn (class.getname (method.getreturntype m=
ethod))))
- (arg-boxers (get-arg-boxers (method.getparametertypes method)))
- (is-static (modifier.isstatic (method.getmodifiers method))))
- (lambda (&rest args)
- (let ((arg-array (build-arg-array (if is-static args (rest args)) ar=
g-boxers)))
- (prog1
- (funcall unboxer-fn
- (method.invoke method
- (if is-static nil (get-ref (first args=
)))
- arg-array) t)
- (when arg-array
- (delete-local-ref arg-array)))))))
-
-(defun make-overloaded-thunk (methods)
- (let ((thunks (make-thunks-by-args-length methods)))
- (lambda (&rest args)
- (let ((fn (cdr (assoc (length args) thunks))))
- (if fn
- (apply fn
- args)
- (error "invalid arity"))))))
-
-(defun make-thunks-by-args-length (methods)
- "returns an alist of thunks keyed by number of args"
- (let ((methods-by-args-length (make-hash-table))
- (thunks-by-args-length nil))
- (dolist (method methods)
- (let ((is-static (modifier.isstatic (method.getmodifiers method)))
- (params-len (get-array-length (method.getparametertypes method=
))))
- (push method (gethash (if is-static params-len (1+ params-len))
- methods-by-args-length))))
- (maphash #'(lambda (args-len methods)
- (push (cons args-len
- (if (rest methods);truly overloaded
- (make-type-overloaded-thunk methods)
- ;only one method with this number of args
- (make-non-overloaded-thunk (first methods))=
))
- thunks-by-args-length))
- methods-by-args-length)
- thunks-by-args-length))
-
-(defun make-type-overloaded-thunk (methods)
- "these methods have the same number of args and must be distinguished by=
type"
- (let ((thunks (mapcar #'(lambda (method)
- (list (make-non-overloaded-thunk method)
- (modifier.isstatic (method.getmodifiers =
method))
- (jarray-to-list (method.getparametertype=
s method))))
- methods)))
- (lambda (&rest args)
- (block fn
- (let ((arg-types (get-types-of-args args)))
- (dolist (thunk-info thunks)
- (destructuring-bind (thunk is-static param-types) thunk-info
- (when (is-congruent-type-list param-types (if is-static arg-=
types (rest arg-types)))
- (return-from fn (apply thunk args)))))
- (error "No matching method"))))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;; array support ;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun jref (array &rest subscripts)
- "like aref, for Java arrays of non-primitive/reference types, settable"
- (assert (every #'integerp subscripts))
- (do*
- ((sub subscripts (rest sub))
- (a (get-ref array) (get-ref (array.get a (first sub)))))
- ((null (rest sub))
- (array.get a (first sub)))))
-
-(defun (setf jref) (val array &rest subscripts)
- (assert (every #'integerp subscripts))
- (do*
- ((sub subscripts (rest sub))
- (a (get-ref array) (get-ref (array.get a (first sub)))))
- ((null (rest sub))
- (array.set a (first sub) (get-ref val))
- val)))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defmacro def-refs (&rest types)
- `(locally
- ,@(mapcan
- (lambda (type)
- (let ((ref-sym (intern (string-upcase (string-append "jref-" (=
symbol-name type))))))
- (list =
- `(defun ,ref-sym (array &rest subscripts)
- ,(format nil "like aref, for Java arrays of ~A, settable=
" (symbol-name type))
- (assert (every #'integerp subscripts))
- (do*
- ((sub subscripts (rest sub))
- (a (get-ref array) (get-ref (array.get a (first su=
b)))))
- ((null (rest sub))
- (,(intern (string-upcase (string-append "array.get=
" (symbol-name type))))
- a (first sub)))))
-
- `(defun (setf ,ref-sym) (val array &rest subscripts)
- (assert (every #'integerp subscripts))
- (do*
- ((sub subscripts (rest sub))
- (a (get-ref array) (get-ref (array.get a (first su=
b)))))
- ((null (rest sub))
- (array.set a (first sub)
- (,(intern (string-upcase (string-append=
"box-"
- =
(symbol-name type))))
- val))
- val))))))
- types))))
-
-;arrays of primitives have their own accessors
-(def-refs boolean byte char double float int short long)
-
-(defun jlength (array)
- "like length, for Java arrays"
- (array.getlength (get-ref array)))
-
-(defgeneric make-new-array (type &rest dimensions)
- (:documentation "generic function, with methods for all Java class desig=
nators")
- (:method (type &rest dims)
- (assert (every #'integerp dims))
- (if (rest dims)
- (let* ((ndim (length dims))
- (dim-array (new-int-array ndim)))
- (dotimes (i ndim)
- (array.set dim-array i (box-int (nth i dims))))
- (array.newinstance<java.lang.class-int<>> type dim-array))
- (array.newinstance<java.lang.class-int> type (first dims)))))
-
-(defmethod make-new-array ((type symbol) &rest dimensions)
- (apply #'make-new-array (get-java-class-ref type) dimensions))
-
-(defmethod make-new-array ((type string) &rest dimensions)
- (apply #'make-new-array (find-java-class type) dimensions))
-
-(defmethod make-new-array ((type (eql :char)) &rest dimensions)
- (apply #'make-new-array character.type dimensions))
-
-(defmethod make-new-array ((type (eql :int)) &rest dimensions)
- (apply #'make-new-array integer.type dimensions))
-
-(defmethod make-new-array ((type (eql :boolean)) &rest dimensions)
- (apply #'make-new-array boolean.type dimensions))
-
-(defmethod make-new-array ((type (eql :double)) &rest dimensions)
- (apply #'make-new-array double.type dimensions))
-
-(defmethod make-new-array ((type (eql :byte)) &rest dimensions)
- (apply #'make-new-array byte.type dimensions))
-
-(defmethod make-new-array ((type (eql :float)) &rest dimensions)
- (apply #'make-new-array float.type dimensions))
-
-(defmethod make-new-array ((type (eql :short)) &rest dimensions)
- (apply #'make-new-array short.type dimensions))
-
-(defmethod make-new-array ((type (eql :long)) &rest dimensions)
- (apply #'make-new-array long.type dimensions))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;; arg/param helpers ;;;;;;;;;;;;;;;;;;;;;;
-
-(defun get-arg-boxers (param-types)
- "returns a list with one entry per param, either nil or a function that =
boxes the arg"
- (let (ret)
- (do-jarray (param-type param-types)
- (push (get-boxer-fn (class.getname param-type))
- ret))
- (nreverse ret)))
-
-(defun build-arg-array (args arg-boxers)
- (when args
- (let* ((arg-array (new-object-array (length args)
- ;duplication of class-symbol logic
- ;but must be fast
- (get-java-class-ref '|java.lang|::=
|Object|)
- nil)))
- (do ((i 0 (incf i))
- (args args (rest args))
- (boxers arg-boxers (rest boxers)))
- ((null args))
- (let ((arg (first args))
- (boxer (first boxers)))
- (setf (jaref arg-array i)
- (get-ref (if (and boxer (not (boxed? arg)))
- (funcall boxer arg)
- arg)))))
- arg-array)))
-
-(defun get-types-of-args (args)
- (let (ret)
- (dolist (arg args)
- (push (infer-box-type arg)
- ret))
- (nreverse ret)))
-
-(defun is-congruent-type-list (param-types arg-types)
- (every #'(lambda (arg-type param-type)
- (if arg-type
- (is-assignable-from arg-type param-type)
- ;nil was passed - must be boolean or non-primitive target t=
ype
- (or (not (class.isprimitive param-type))
- (is-assignable-from boolean.type param-type))))
- arg-types param-types))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;; argument conversion and boxing ;;;;;;;;;;;;;;;;;;=
;;;;;;;;
-(defun box-string (s)
-"Given a string or symbol, returns reference to a Java string"
- (local-ref-to-global-ref (convert-to-java-string s)))
-
-(defun unbox-string (ref &optional delete-local)
- "Given a reference to a Java string, returns a Lisp string" =
- (declare (ignore delete-local))
- (convert-from-java-string (get-ref ref)))
-
-(defun get-boxer-fn (class-name)
- (case-equal class-name
- ("int" #'box-int)
- ("boolean" #'box-boolean)
- ("double" #'box-double)
- ("java.lang.String" #'convert-to-java-string)
- ("char" #'box-char)
- ("byte" #'box-byte)
- ("float" #'box-float)
- ("long" #'box-long)
- ("short" #'box-short)
- (otherwise nil)))
-
-(defun get-boxer-fn-sym (class-name)
- (case-equal class-name
- ("int" 'box-int)
- ("boolean" 'box-boolean)
- ("double" 'box-double)
- ("java.lang.String" 'convert-to-java-string)
- ("char" 'box-char)
- ("byte" 'box-byte)
- ("float" 'box-float)
- ("long" 'box-long)
- ("short" 'box-short)
- ("void" 'box-void)
- (otherwise 'identity)))
-
-(defun boxed? (x)
- (or (java-ref-p x)
- (typep x '|java.lang|::object.)))
-
-(defun infer-box-type (x)
- (cond
- ((null x) nil)
- ((boxed? x) (object.getclass (get-ref x)))
- ((integerp x) integer.type)
- ((numberp x) double.type)
- ((eq x t) boolean.type)
- ((or (stringp x) (symbolp x))
- (get-java-class-ref '|java.lang|::|String|))
- (t (error "can't infer box type"))))
-
-(defun get-unboxer-fn (class-name)
- (case-equal class-name
- ("int" #'unbox-int)
- ("boolean" #'unbox-boolean)
- ("double" #'unbox-double)
- ("java.lang.String" #'unbox-string)
- ("void" #'unbox-void)
- ("char" #'unbox-char)
- ("byte" #'unbox-byte)
- ("float" #'unbox-float)
- ("long" #'unbox-long)
- ("short" #'unbox-short)
- (otherwise #'unbox-ref)))
-
-(defun get-unboxer-fn-sym (class-name)
- (case-equal class-name
- ("int" 'unbox-int)
- ("boolean" 'unbox-boolean)
- ("double" 'unbox-double)
- ("java.lang.String" 'unbox-string)
- ("void" 'unbox-void)
- ("char" 'unbox-char)
- ("byte" 'unbox-byte)
- ("float" 'unbox-float)
- ("long" 'unbox-long)
- ("short" 'unbox-short)
- (otherwise 'unbox-ref)))
-
-(defun unbox-ref (x &optional delete-local)
- (declare (ignore delete-local))
- (local-ref-to-global-ref x))
-
-(defun unbox-void (x &optional delete-local)
- (declare (ignore x delete-local))
- nil)
-
-(defun box-void (x)
- (declare (ignore x))
- nil)
-
-(defun box-boolean (x)
- (boolean.new x))
-
-(defun unbox-boolean (obj &optional delete-local)
- (prog1
- (boolean.booleanvalue (get-ref obj))
- (when delete-local (delete-local-ref obj))))
-
-(defun box-byte (x)
- (assert (integerp x))
- (byte.new x))
-
-(defun unbox-byte (x &optional delete-local)
- (prog1
- (byte.bytevalue (get-ref x))
- (when delete-local (delete-local-ref x))))
-
-(defun box-char (x)
- (character.new x))
-
-(defun unbox-char (x &optional delete-local)
- (prog1
- (character.charvalue (get-ref x))
- (when delete-local (delete-local-ref x))))
-
-(defun box-double (x)
- (assert (floatp x))
- (double.new (coerce x 'double-float)))
-
-(defun unbox-double (x &optional delete-local)
- (prog1
- (double.doublevalue (get-ref x))
- (when delete-local (delete-local-ref x))))
-
-(defun box-float (x)
- (assert (floatp x))
- (float.new x))
-
-(defun unbox-float (x &optional delete-local)
- (prog1
- (float.floatvalue (get-ref x))
- (when delete-local (delete-local-ref x))))
-
-(defun box-int (x)
- (assert (integerp x))
- (integer.new x))
-
-(defun unbox-int (x &optional delete-local)
- (prog1
- (integer.intvalue (get-ref x))
- (when delete-local (delete-local-ref x))))
-
-;can't directly construct Long because LW doesn't support long long fli on=
32 bit platforms
-(defun box-long (x)
- (assert (integerp x))
- (long.valueof (princ-to-string x)))
-
-;here too, can only get an ints worth - aargh
-(defun unbox-long (obj &optional delete-local)
- (prog1
- (parse-integer (object.tostring (get-ref obj)))
- (when delete-local (delete-local-ref obj))))
-
-(defun box-short (x)
- (assert (integerp x))
- (short.new x))
-
-(defun unbox-short (x &optional delete-local)
- (prog1
- (short.shortvalue (get-ref x))
- (when delete-local (delete-local-ref x))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun proxy-hashcode (proxy)
- ;use the hashcode of the proxy's class, =
- ;because hashcode() on the proxy flows through to the invocation handler
- ;is this rem guaranteed to be a fixnum?
- (rem (object.hashcode (object.getclass proxy)) most-positive-fixnum))
-
-(defvar *proxy-table* (make-hash-table :test #'jeq :hash-function #'proxy-=
hashcode))
-
-;(defvar *proxy-list* nil)
-
-(defun store-proxy (proxy method-fn-alist)
- ;(push (cons proxy method-fn-alist) *proxy-list*)
- (setf (gethash proxy *proxy-table*) method-fn-alist))
-
-(defun recall-proxy (proxy)
- ;(cdr (assoc proxy *proxy-list* :test #'jeq))
- (gethash proxy *proxy-table*))
-
-(defun unregister-proxy (proxy)
-"Stops handling for the proxy and removes references from the Lisp side.
-Make sure it is no longer referenced from Java first!"
- (remhash proxy *proxy-table*))
-
-(defun invocation-handler (proxy method args)
- (let* ((method-fn-alist (recall-proxy proxy))
- (fn (and method-fn-alist (second (assoc (object.tostring method) =
method-fn-alist
- :test #'equal)))))
- (if fn
- (funcall fn args)
- (progn
- ;(throw-new (find-java-class "java.lang.UnsupportedOperationExcep=
tion")
- ; "No function registered in Lisp proxy object")
- nil))))
-
-(defun enable-java-proxies ()
- "must be called before any call to new-proxy, and requires jfli.jar be i=
n the classpath"
- (jni:register-invocation-handler #'invocation-handler))
-
-(defun make-proxy-instance (&rest interface-defs)
- (let* ((interfaces (mapcar #'first interface-defs))
- (method-fn-alist (mapcan #'second interface-defs))
- (len (length interfaces))
- (iarray (array.newinstance<java.lang.class-int> (get-java-class-r=
ef '|java.lang|::|Class|)
- len)))
- (dotimes (x len)
- (setf (jref iarray x) (nth x interfaces)))
- (let ((proxy (proxy.newproxyinstance (classloader.getsystemclassloader)
- iarray
- (lispinvocationhandler.new))))
- (store-proxy proxy method-fn-alist)
- proxy)))
-
-(defun find-java-class-in-macro (name)
- (find-java-class
- (if (symbolp name)
- (symbol-value name)
- name)))
-
-(defmacro new-proxy (&rest interface-defs)
-"interface-def -> (interface-name method-defs+)
-interface-name -> \"package.qualified.ClassName\" | classname. (must name =
a Java interface type)
-method-def -> (method-name arg-defs* body)
-arg-def -> arg-name | (arg-name arg-type)
-arg-type -> \"package.qualified.ClassName\" | classname. | :primitive
-method-name -> symbol | string (matched case-insensitively)
-
-Creates, registers and returns a Java object that implements the supplied =
interfaces"
-
- (labels ((process-idefs (idefs)
- (when idefs
- (cons (process-idef (first idefs))
- (process-idefs (rest idefs)))))
- (process-idef (idef)
- (destructuring-bind (interface-name &rest method-defs) idef
- (let* ((methods (class.getmethods (find-java-class-in-macro=
interface-name)))
- (ret `(list (find-java-class ,interface-name)
- (list ,@(mapcar (lambda (method-def)
- (process-method-def me=
thod-def methods))
- method-defs)))))
- ;check to make sure every function is defined
- (do-jarray (method methods)
- (let ((mname (object.tostring method)))
- (unless (member mname (rest (third ret)) :key #'secon=
d :test #'equal)
- (warn (format nil "proxy doesn't define:~%~A" mname=
)))))
- ret)))
- (process-method-def (method-def methods)
- (destructuring-bind (method-name (&rest arg-defs) &body body)=
method-def
- (let ((method (matching-method method-name arg-defs methods=
))
- (gargs (gensym)))
- `(list ,(object.tostring method)
- (lambda (,gargs)
- (,(get-boxer-fn-sym (class.getname (method.getre=
turntype method)))
- (let ,(arg-lets arg-defs
- (jarray-to-list (method.getpara=
metertypes method))
- gargs
- 0)
- , at body)))))))
- (arg-lets (arg-defs params gargs idx)
- (when arg-defs
- (let ((arg (first arg-defs))
- (param (first params)))
- (cons `(,(if (atom arg) arg (first arg))
- (,(get-unboxer-fn-sym (class.getname param))
- (jref ,gargs ,idx) t))
- (arg-lets (rest arg-defs) (rest params) gargs (1+ i=
dx))))))
- (matching-method (method-name arg-defs methods)
- (let (match)
- (do-jarray (method methods)
- (when (method-matches method-name arg-defs method)
- (if match
- (error (format nil "more than one method matches ~A=
" method-name))
- (setf match method))))
- (or match (error (format nil "no method matches ~A" method-=
name)))))
- (method-matches (method-name arg-defs method)
- (when (string-equal method-name (method.getname method))
- (let ((params (method.getparametertypes method)))
- (when (=3D (length arg-defs) (jlength params))
- (is-congruent arg-defs params)))))
- (is-congruent (arg-defs params)
- (every (lambda (arg param)
- (or (atom arg) ;no type spec matches anything
- (jeq (find-java-class-in-macro (second arg)) par=
am)))
- arg-defs (jarray-to-list params))))
- `(make-proxy-instance ,@(process-idefs interface-defs))))
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
+; which can be found in the file CPL.TXT at the root of this distributi=
on.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+#|
+
+jfli is a library that provides access to Java from Lisp
+It depends on the jni package (included)
+Callbacks from Java to Lisp also require jfli.jar (included)
+
+|#
+
+(defpackage :jfli
+ (:use :common-lisp :lispworks :jni)
+ (:export
+
+ ;jvm creation
+ :*jni-lib-path* ;exposed from jni
+ :create-jvm ;exposed from jni, you must call this prior to calling=
any other jfli function
+ :enable-java-proxies
+
+ ;wrapper generation
+ :def-java-class
+ :get-jar-classnames
+ :dump-wrapper-defs-to-file
+
+ ;object creation etc
+ :find-java-class
+ :new
+ :make-new
+ :make-typed-ref
+ :jeq
+
+ ;array support
+ :make-new-array
+ :jlength
+ :jref
+ :jref-boolean
+ :jref-byte
+ :jref-char
+ :jref-double
+ :jref-float
+ :jref-int
+ :jref-short
+ :jref-long
+
+ ;proxy support
+ :new-proxy
+ :unregister-proxy
+
+ ;conversions
+ :box-boolean
+ :box-byte
+ :box-char
+ :box-double
+ :box-float
+ :box-integer
+ :box-long
+ :box-short
+ :box-string
+ :unbox-boolean
+ :unbox-byte
+ :unbox-char
+ :unbox-double
+ :unbox-float
+ :unbox-integer
+ :unbox-long
+ :unbox-short
+ :unbox-string
+
+; :ensure-package
+; :member-symbol
+; :class-symbol
+; :constructor-symbol
+ ))
+
+(in-package :jfli)
+
+#|
+bootstrap the implementation of reflection wrappers with =
+a few (primitive, less safe and maybe faster) jni wrappers
+|#
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-jni-functions "java.lang.Object"
+ ("getClass" () "Class")
+ ("hashCode" () "int")
+ ("toString" () "String")
+ ("equals" ((obj "Object")) "boolean"))
+
+ (def-jni-functions "java.lang.Class"
+ ;should be :overloaded t, but we only use this version
+ ("forName" ((className "String")) "Class" :static t)
+ ("getConstructors" () "java.lang.reflect.Constructor<=
>")
+ ("getFields" () "java.lang.reflect.Field<>")
+ ("getMethods" () "java.lang.reflect.Method<>")
+
+ ("getConstructor" ((parameter-types "Class<>")) "java=
.lang.reflect.Constructor")
+ ("getField" ((name "String"))
+ "java.lang.reflect.Field")
+ ("getMethod" ((name "String") (parameter-types "Class=
<>"))
+ "java.lang.reflect.Method")
+
+ ("getSuperclass" () "Class")
+ ("getInterfaces" () "Class<>")
+
+ ("getName" () "String")
+ ("isArray" () "boolean")
+ ("isPrimitive" () "boolean"))
+
+ (def-jni-functions "java.lang.reflect.Field"
+ ("getName" () "java.lang.String")
+ ("getType" () "java.lang.Class")
+ ("getModifiers" () "int")
+
+ ("get" ((obj "java.lang.Object")) "java.lang.Object" =
:raw-return t)
+ ("getBoolean" ((obj "java.lang.Object")) "boolean")
+ ("getByte" ((obj "java.lang.Object")) "byte")
+ ("getChar" ((obj "java.lang.Object")) "char")
+ ("getDouble" ((obj "java.lang.Object")) "double")
+ ("getFloat" ((obj "java.lang.Object")) "float")
+ ("getInt" ((obj "java.lang.Object")) "int")
+ ("getLong" ((obj "java.lang.Object")) "long")
+ ("getShort" ((obj "java.lang.Object")) "short")
+
+ ("set" ((obj "java.lang.Object") (value "java.lang.Ob=
ject")) "void")
+ ("setBoolean" ((obj "java.lang.Object") (b "boolean")=
) "void")
+ ("setByte" ((obj "java.lang.Object") (b "byte")) "voi=
d")
+ ("setChar" ((obj "java.lang.Object") (c "char")) "voi=
d")
+ ("setDouble" ((obj "java.lang.Object") (d "double")) =
"void")
+ ("setFloat" ((obj "java.lang.Object") (f "float")) "v=
oid")
+ ("setInt" ((obj "java.lang.Object") ( i "int")) "void=
")
+ ("setLong" ((obj "java.lang.Object") (l "long")) "voi=
d")
+ ("setShort" ((obj "java.lang.Object") (s "short")) "v=
oid"))
+
+ (def-jni-functions "java.lang.reflect.Constructor"
+ ("getParameterTypes" () "java.lang.Class<>")
+ ("newInstance" ((initargs "java.lang.Object<>")) "jav=
a.lang.Object"))
+
+ (def-jni-functions "java.lang.reflect.Method"
+ ("getName" () "java.lang.String")
+ ("getParameterTypes" () "java.lang.Class<>")
+ ("getReturnType" () "java.lang.Class")
+ ("getModifiers" () "int")
+ ("invoke" ((object "java.lang.Object")
+ (args "java.lang.Object<>")) "java.lang.Ob=
ject"
+ :raw-return t))
+
+ (def-jni-functions "java.lang.reflect.Array"
+ ("get" ((array "java.lang.Object") (index "int")) "ja=
va.lang.Object" :static t)
+ ("getBoolean"
+ ((array "java.lang.Object") (index "int")) "boolean"=
:static t)
+ ("getByte"
+ ((array "java.lang.Object") (index "int")) "byte" :s=
tatic t)
+ ("getChar"
+ ((array "java.lang.Object") (index "int")) "char" :s=
tatic t)
+ ("getDouble"
+ ((array "java.lang.Object") (index "int")) "double" =
:static t)
+ ("getFloat"
+ ((array "java.lang.Object") (index "int")) "float" :=
static t)
+ ("getInt"
+ ((array "java.lang.Object") (index "int")) "int" :st=
atic t)
+ ("getShort"
+ ((array "java.lang.Object") (index "int")) "short" :=
static t)
+ ("getLong"
+ ((array "java.lang.Object") (index "int")) "long" :s=
tatic t)
+ ("getLength" ((array "java.lang.Object")) "int" :stat=
ic t)
+ ("newInstance" ((componentType "java.lang.Class")
+ (length "int")) "java.lang.Object" :s=
tatic t :overloaded t)
+ ("newInstance" ((componentType "java.lang.Class")
+ (dimensions "int<>")) "java.lang.Obje=
ct" :static t :overloaded t)
+ ("set" ((array "java.lang.Object") (index "int") (val=
ue "java.lang.Object"))
+ "void" :static t))
+
+
+ (def-jni-function "java.lang.reflect.Modifier"
+ "isStatic" ((mod "int")) "boolean" :static t)
+
+ (def-jni-constructor "java.lang.Boolean" ((value "boolean")))
+ (def-jni-constructor "java.lang.Byte" ((value "byte")))
+ (def-jni-constructor "java.lang.Character" ((value "char")))
+ (def-jni-constructor "java.lang.Double" ((value "double")))
+ (def-jni-constructor "java.lang.Float" ((value "float")))
+ (def-jni-constructor "java.lang.Integer" ((value "int")))
+ (def-jni-constructor "java.lang.Short" ((value "short")))
+
+ (def-jni-function "java.lang.Boolean" "booleanValue" () "boolean")
+ (def-jni-function "java.lang.Byte" "byteValue" () "byte")
+ (def-jni-function "java.lang.Character" "charValue" () "char")
+ (def-jni-function "java.lang.Double" "doubleValue" () "double")
+ (def-jni-function "java.lang.Float" "floatValue" () "float")
+ (def-jni-function "java.lang.Integer" "intValue" () "int")
+ (def-jni-function "java.lang.Short" "shortValue" () "short")
+
+ (def-jni-constructor "java.util.jar.JarFile" ((filename "java.lang.Strin=
g")))
+ (def-jni-function "java.util.jar.JarFile"
+ "entries" () "java.util.Enumeration")
+ (def-jni-functions "java.util.Enumeration"
+ ("hasMoreElements" () "boolean")
+ ("nextElement" () "java.lang.Object"))
+ (def-jni-functions "java.util.zip.ZipEntry"
+ ("isDirectory" () "boolean")
+ ("getName" () "java.lang.String"))
+
+
+ (def-jni-functions "java.lang.Long"
+ ("valueOf" ((s "String")) "java.lang.Long" :static t)
+ ("intValue" () "int"))
+
+ (def-jni-field "java.lang.Boolean" "TYPE" "Class" :static t)
+ (def-jni-field "java.lang.Byte" "TYPE" "Class" :static t)
+ (def-jni-field "java.lang.Character" "TYPE" "Class" :static t)
+ (def-jni-field "java.lang.Float" "TYPE" "Class" :static t)
+ (def-jni-field "java.lang.Integer" "TYPE" "Class" :static t)
+ (def-jni-field "java.lang.Double" "TYPE" "Class" :static t)
+ (def-jni-field "java.lang.Short" "TYPE" "Class" :static t)
+ (def-jni-field "java.lang.Long" "TYPE" "Class" :static t)
+
+ (def-jni-constructor "com.richhickey.jfli.LispInvocationHandler" ())
+ (def-jni-function "java.lang.reflect.Proxy"
+ "newProxyInstance" ((loader "java.lang.ClassLoader")
+ (interfaces "java.lang.Class<>")
+ (h "InvocationHandler")) "java.lan=
g.Object" :static t)
+
+ (def-jni-function "java.lang.ClassLoader"
+ "getSystemClassLoader" () "ClassLoader" :static t)
+
+ ) ;eval-when
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (defun ensure-package (name)
+ "find the package or create it if it doesn't exist"
+ (or (find-package name)
+ (make-package name :use '())))
+ (intern "Object" (ensure-package "java.lang"))
+ (intern "String" (ensure-package "java.lang")))
+
+(defmacro do-jarray ((x array) &body body)
+ "jni-based, so not safe and not exported, but used by the implementation"
+ (let ((gcount (gensym))
+ (gi (gensym))
+ (garray (gensym)))
+ `(let* ((,garray ,array)
+ (,gcount (jni:get-array-length ,garray)))
+ (dotimes (,gi ,gcount)
+ (let ((,x (jaref ,garray ,gi)))
+ , at body)))))
+
+
+(defmacro doenum ((e enum) &body body)
+ "jni-based, so not safe and not exported, but used by the implementation"
+ (let ((genum (gensym)))
+ `(let ((,genum ,enum))
+ (do ()
+ ((not (enumeration.hasmoreelements ,genum)))
+ (let ((,e (enumeration.nextelement ,genum)))
+ , at body)))))
+
+;probably insufficiently general, works as used here
+(defmacro get-or-init (place init-form)
+ `(or ,place
+ (setf ,place ,init-form)))
+
+;from c.l.l.
+(defmacro case-equal (exp &body clauses)
+ (let ((temp (gensym)))
+ `(let ((,temp ,exp))
+ (cond ,@(mapcar #'(lambda (clause)
+ (destructuring-bind (keys . clause-forms) clause
+ (cond ((eq keys 'otherwise)
+ `(t , at clause-forms))
+ (t
+ (if (atom keys) (setq keys (list keys)=
))
+ `((member ,temp ',keys :test #'equal)
+ , at clause-forms)))))
+ clauses)))))
+
+;create object. to bootstrap the hierarchy
+(defclass |java.lang|::object. ()
+ ((ref :reader ref :initarg :ref)
+ (lisp-allocated :reader lisp-allocated-p :initarg :lisp-allocated :init=
form nil))
+ (:documentation "the superclass of all Java typed reference classes"))
+
+(defun get-ref (x)
+ "any function taking an object can be passed a raw java-ref ptr or a typ=
ed reference instance.
+Will also convert strings for use as objects"
+ (etypecase x
+ (java-ref x)
+ (|java.lang|::object. (ref x))
+ (string (convert-to-java-string x))
+ (null nil)))
+
+(defun jeq (obj1 obj2)
+ "are these 2 java objects the same object? Note that is not the same as =
Object.equals()"
+ (is-same-object (get-ref obj1) (get-ref obj2)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;; names and symbols ;;;;;;;;;;;;;;;;;;;;;;;
+#|
+The library does a lot with names and symbols, needing at various times to:
+ - find stuff in Java - full names w/case required
+ - create hopefully non-conflicting packages and member names
+
+When you (def-java-class "java.lang.String") you get a bunch of symbols/na=
mes:
+a package named '|java.lang|
+a class-symbol '|java.lang|:STRING. (note the dot and case), =
+ which can usually be used where a typename is required
+ it also serves as the name of the Lisp typed reference class for string
+ its symbol-value is the canonic-class-symbol (see below)
+a canonic-class-symbol '|java.lang|::|String|
+ can be used to reconstitute the full class name
+
+I've started trying to flesh out the notion of a Java class designator, wh=
ich can either be
+the full class name as a string, the class-symbol, or one of :boolean, :in=
t etc
+|#
+
+(defun canonic-class-symbol (full-class-name)
+ "(\"java.lang.Object\") -> '|java.lang|:|Object|"
+ (multiple-value-bind (package class) (split-package-and-class full-class=
-name)
+ (intern class (ensure-package package))))
+
+(defun class-symbol (full-class-name)
+ "(\"java.lang.Object\") -> '|java.lang|:object."
+ (multiple-value-bind (package class) (split-package-and-class full-class=
-name)
+ (intern (string-upcase (string-append class ".")) (ensure-package pack=
age))))
+
+(defun java-class-name (class-sym)
+ "inverse of class-symbol, only valid on class-syms created by def-java-c=
lass"
+ (let ((canonic-class-symbol (symbol-value class-sym)))
+ (string-append (package-name (symbol-package canonic-class-symbol))
+ "."
+ canonic-class-symbol)))
+
+(defun member-symbol (full-class-name member-name)
+ "members are defined case-insensitively in case-sensitive packages,
+prefixed by 'classname.' -
+(member-symbol \"java.lang.Object\" \"toString\") -> '|java.lang|::OBJECT.=
TOSTRING"
+ (multiple-value-bind (package class) (split-package-and-class full-class=
-name)
+ (intern (string-upcase (string-append class "." member-name)) (ensure-=
package package))))
+
+(defun constructor-symbol (full-class-name)
+ (member-symbol full-class-name "new"))
+
+(defun get-java-class-ref (canonic-class-symbol)
+ "class-ref is cached on the plist of the canonic class symbol"
+ (get-or-init (get canonic-class-symbol :class-ref)
+ (let ((class-name (string-append (package-name
+ (symbol-package canonic-c=
lass-symbol))
+ "."
+ canonic-class-symbol)))
+ (try-null (jni-find-class (nsubstitute #\/ #\. class-name=
))))))
+
+(defun find-java-class (class-sym-or-string)
+ "Given a Java class designator, returns the Java Class object."
+ (ctypecase class-sym-or-string
+ (symbol (case class-sym-or-string
+ (:int integer.type)
+ (:char character.type)
+ (:long long.type)
+ (:float float.type)
+ (:boolean boolean.type)
+ (:short short.type)
+ (:double double.type)
+ (:byte byte.type)
+ (otherwise (get-java-class-ref class-sym-or-string))))
+ (string (get-java-class-ref (canonic-class-symbol class-sym-or-string)=
))))
+
+;;;;;;;;;;;;;;;;;;;;;; typed reference support ;;;;;;;;;;;;;;;;;;;;;;;;
+#|
+The library maintains a hierarchy of typed reference classes that parallel=
the
+class hierarchy on the Java side
+new returns a typed reference, but other functions that return objects
+return raw references (for efficiency) =
+make-typed-ref can create fully-typed wrappers when desired
+|#
+
+(defun get-superclass-names (full-class-name)
+ (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name)=
))
+ (super (class.getsuperclass class))
+ (interfaces (class.getinterfaces class))
+ (supers ()))
+ (do-jarray (i interfaces)
+ (push i supers))
+ ;hmmm - where should the base class go in the precedence list?
+ ;is it more important than the interfaces? this says no
+ (if super
+ (push super supers)
+ (push (find-java-class "java.lang.Object") supers))
+ (setf supers (nreverse supers))
+ ;now we need to fix up order so more derived classes are first
+ ;but don't have a total ordering, so merge one at a time
+ (let (result)
+ (dolist (s supers)
+ (setf result (merge 'list result (list s)
+ (lambda (x y)
+ (is-assignable-from x y)))))
+ (mapcar #'class.getname result))))
+#|
+(defun get-superclass-names (full-class-name)
+ (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name)=
))
+ (super (class.getsuperclass class))
+ (interfaces (class.getinterfaces class))
+ (supers ()))
+ (do-jarray (i interfaces)
+ (push (class.getname i) supers))
+ ;hmmm - where should the base class go in the precedence list?
+ ;is it more important than the interfaces? this says no
+ (if super
+ (push (class.getname super) supers)
+ (push "java.lang.Object" supers))
+ (nreverse supers)))
+|#
+
+(defun ensure-java-class (full-class-name)
+ "walks the superclass hierarchy and makes sure all the classes are fully=
defined
+(they may be undefined or just forward-referenced-class)
+caches this has been done on the class-symbol's plist"
+ (let* ((class-sym (class-symbol full-class-name))
+ (class (find-class class-sym nil)))
+ (if (or (eql class-sym '|java.lang|::object.)
+ (get class-sym :ensured))
+ class
+ (let ((supers (get-superclass-names full-class-name)))
+ (dolist (super supers)
+ (ensure-java-class super))
+ (unless (and class (subtypep class 'standard-object))
+ (setf class
+ (clos:ensure-class class-sym :direct-superclasses (mapcar =
#'class-symbol supers))))
+ (setf (get class-sym :ensured) t)
+ class))))
+
+(defun ensure-java-hierarchy (class-sym)
+ "Works off class-sym for efficient use in new
+This will only work on class-syms created by def-java-class,
+as it depends upon symbol-value being the canonic class symbol"
+ (unless (get class-sym :ensured)
+ (ensure-java-class (java-class-name class-sym))))
+
+(defun make-typed-ref (java-ref)
+ "Given a raw java-ref, determines the full type of the object
+and returns an instance of a typed reference wrapper"
+ (when java-ref
+ (let ((class (object.getclass (get-ref java-ref))))
+ (if (class.isarray class)
+ (error "typed refs not supported for arrays (yet)")
+ (make-instance (ensure-java-class (class.getname class)) :ref (get=
-ref java-ref) )))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;
+#|
+In an effort to reduce the volume of stuff generated when wrapping entire =
libraries,
+the wrappers just generate minimal stubs, which, if and when invoked at ru=
ntime,
+complete the work of building thunking closures, so very little code is ge=
nerated for
+things never called (Java libraries have huge numbers of symbols).
+Not sure if this approach matters, but that's how it works
+|#
+
+(defmacro def-java-class (full-class-name)
+ "Given the package-qualified, case-correct name of a java class, will ge=
nerate
+wrapper functions for its constructors, fields and methods."
+ (multiple-value-bind (package class) (split-package-and-class full-class=
-name)
+ (declare (ignore class))
+ (let* ((class-sym (class-symbol full-class-name))
+ (defs
+ (list*
+ `(ensure-package ,package)
+ ;build a path from the simple class symbol to the canonic
+ `(defconstant ,class-sym ',(canonic-class-symbol full-class-n=
ame))
+ `(export ',class-sym (symbol-package ',class-sym))
+ `(def-java-constructors ,full-class-name)
+ `(def-java-methods ,full-class-name)
+ `(def-java-fields ,full-class-name)
+ (unless (string=3D full-class-name "java.lang.Object")
+ (let ((supers (mapcar #'class-symbol (get-superclass-names =
full-class-name))))
+ (append (mapcar (lambda (p)
+ `(ensure-package ,(package-name p)))
+ (remove (symbol-package class-sym)
+ (remove-duplicates (mapcar #'symb=
ol-package supers))))
+ (list `(defclass ,(class-symbol full-class-name)
+ ,supers ()))))))))
+ `(locally , at defs))))
+
+(defun get-jar-classnames (jar-file-name &rest packages)
+ "returns a list of strings, packages should be of the form \"java/lang\"
+ for recursive lookup and \"java/util/\" for non-recursive"
+ (let* ((jar (jarfile.new jar-file-name))
+ (entries (jarfile.entries jar))
+ (names ()))
+ (doenum (e entries)
+ (unless (zipentry.isdirectory e)
+ (let ((ename (zipentry.getname e)))
+ (flet ((matches (package)
+ (and (eql 0 (search package ename))
+ (or (not (eql #\/ (schar package (1- (length packa=
ge))))) ;recursive
+ (not (find #\/ ename :start (length package)))=
)))) ;non-subdirectory
+ (when (and (eql (search ".class" ename)
+ (- (length ename) 6)) ;classname
+ ;don't grab anonymous inner classes
+ (not (and (find #\$ ename)
+ (digit-char-p (schar ename (1+ (position =
#\$ ename))))))
+ (some #'matches packages))
+ (push (nsubstitute #\. #\/ (subseq ename 0 (- (length ename)=
6)))
+ names))))))
+ names))
+
+(defun dump-wrapper-defs-to-file (filename classnames)
+ "given a list of classnames (say from get-jar-classnames), writes
+calls to def-java-class to a file"
+ (with-open-file (s filename :direction :output :if-exists :supersede)
+ (dolist (name (sort classnames #'string-lessp))
+ (format s "(def-java-class ~S)~%" name))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;; constructors and new ;;;;;;;;;;;;;;;;;;;;;;;;;;
+#|
+
+Every non-interface class with a public ctor will get;
+ a constructor, classname.new
+ a method defined on make-new, ultimately calling classname.new,
+ specialized on (the value of) it's class-symbol (e.g. canonic sym)
+
+Note that if the ctor is overloaded, there is just one function (taking a =
rest arg), =
+which handles overload resolution
+
+The new macro expands into a call to make-new
+|#
+
+(defgeneric make-new (class-sym &rest args)
+ (:documentation "Allows for definition of before/after methods on ctors.
+The new macro expands into call to this"))
+
+(defun build-ctor-doc-string (name ctors)
+ (with-output-to-string (s)
+ (dolist (c ctors)
+ (format s "~A(~{~#[~;~A~:;~A,~]~})~%"
+ name
+ (mapcar #'class-name-for-doc (jarray-to-list (constructor.ge=
tparametertypes c)))))))
+
+(defmacro def-java-constructors (full-class-name)
+"creates and exports a ctor func classname.new, defines a method of =
+make-new specialized on the class-symbol"
+ (let ((ctor-list (get-ctor-list full-class-name)))
+ (when ctor-list
+ (let ((ctor-sym (constructor-symbol full-class-name))
+ (class-sym (class-symbol full-class-name)))
+ `(locally
+ (defun ,ctor-sym (&rest args)
+ ,(build-ctor-doc-string full-class-name ctor-list)
+ (apply #'install-constructors-and-call ,full-class-name args))
+ (export ',ctor-sym (symbol-package ',ctor-sym))
+ (defmethod make-new ((class-sym (eql ,class-sym)) &rest args)
+ (apply (function ,ctor-sym) args)))))))
+
+(defun get-ctor-list (full-class-name)
+ (let* ((class-sym (canonic-class-symbol full-class-name))
+ (class (get-java-class-ref class-sym))
+ (ctor-array (class.getconstructors class))
+ (ctor-list (jarray-to-list ctor-array)))
+ ctor-list))
+
+(defun install-constructors-and-call (full-class-name &rest args)
+ "initially the constructor symbol for a class is bound to this function,
+when first called it will replace itself with the appropriate direct thunk,
+then call the requested ctor - subsequent calls will be direct"
+ (install-constructors full-class-name)
+ (apply (constructor-symbol full-class-name) args))
+
+(defun install-constructors (full-class-name)
+ (let* ((ctor-list (get-ctor-list full-class-name)))
+ (when ctor-list
+ (setf (fdefinition (constructor-symbol full-class-name))
+ (make-ctor-thunk ctor-list (class-symbol full-class-name))))))
+
+(defun make-ctor-thunk (ctors class-sym)
+ (if (rest ctors) ;overloaded
+ (make-overloaded-ctor-thunk ctors class-sym)
+ (make-non-overloaded-ctor-thunk (first ctors) class-sym)))
+
+(defun make-non-overloaded-ctor-thunk (ctor class-sym)
+ (let ((arg-boxers (get-arg-boxers (constructor.getparametertypes ctor))))
+ (lambda (&rest args)
+ (let ((arg-array (build-arg-array args arg-boxers)))
+ (ensure-java-hierarchy class-sym)
+ (prog1
+ (make-instance class-sym
+ :ref (constructor.newinstance ctor arg-array)
+ :lisp-allocated t)
+ ;(constructor.newinstance ctor arg-array)
+ (when arg-array
+ (delete-local-ref arg-array)))))))
+
+(defun make-overloaded-ctor-thunk (ctors class-sym)
+ (let ((thunks (make-ctor-thunks-by-args-length ctors class-sym)))
+ (lambda (&rest args)
+ (let ((fn (cdr (assoc (length args) thunks))))
+ (if fn
+ (apply fn
+ args)
+ (error "invalid arity"))))))
+
+(defun make-ctor-thunks-by-args-length (ctors class-sym)
+ "returns an alist of thunks keyed by number of args"
+ (let ((ctors-by-args-length (make-hash-table))
+ (thunks-by-args-length nil))
+ (dolist (ctor ctors)
+ (let ((params-len (get-array-length (constructor.getparametertypes c=
tor))))
+ (push ctor (gethash params-len ctors-by-args-length))))
+ (maphash #'(lambda (args-len ctors)
+ (push (cons args-len
+ (if (rest ctors);truly overloaded
+ (make-type-overloaded-ctor-thunk ctors cl=
ass-sym)
+ ;only one ctor with this number of args
+ (make-non-overloaded-ctor-thunk (first ctor=
s) class-sym)))
+ thunks-by-args-length))
+ ctors-by-args-length)
+ thunks-by-args-length))
+
+(defun make-type-overloaded-ctor-thunk (ctors class-sym)
+ "these methods have the same number of args and must be distinguished by=
type"
+ (let ((thunks (mapcar #'(lambda (ctor)
+ (list (make-non-overloaded-ctor-thunk ctor cla=
ss-sym)
+ (jarray-to-list (constructor.getparamete=
rtypes ctor))))
+ ctors)))
+ (lambda (&rest args)
+ (block fn
+ (let ((arg-types (get-types-of-args args)))
+ (dolist (thunk-info thunks)
+ (destructuring-bind (thunk param-types) thunk-info
+ (when (is-congruent-type-list param-types arg-types)
+ (return-from fn (apply thunk args)))))
+ (error "No matching constructor"))))))
+
+(defmacro new (class-spec &rest args)
+"new class-spec args
+class-spec -> class-name | (class-name this-name)
+class-name -> \"package.qualified.ClassName\" | classname.
+args -> [actual-arg]* [init-arg-spec]*
+init-arg-spec -> init-arg | (init-arg)
+init-arg -> :settable-field-or-method [params]* value ;note keyword
+ | =
+ .method-name [args]* ;note dot
+
+Creates a new instance of class-name, using make-new generic function,
+then initializes it by setting fields or accessors and/or calling member f=
unctions
+If this-name is supplied it will be bound to the newly-allocated object an=
d available
+to the init-args"
+ (labels ((mem-sym? (x)
+ (or (keywordp x)
+ (and (symbolp x) (eql 0 (position #\. (symbol-name x))))))
+ (mem-form? (x)
+ (and (listp x) (mem-sym? (first x))))
+ (mem-init? (x)
+ (or (mem-sym? x) (mem-form? x)))
+ (init-forms (x)
+ (if x
+ (if (mem-form? (first x))
+ (cons (first x) (init-forms (rest x)))
+ (let ((more (member-if #'mem-init? (rest x))))
+ (cons (ldiff x more) (init-forms more)))))))
+ (let* ((inits (member-if #'mem-init? args))
+ (real-args (ldiff args inits))
+ (class-atom (if (atom class-spec)
+ class-spec
+ (first class-spec)))
+ (class-sym (if (symbolp class-atom)
+ ;(find-symbol (string-append (symbol-name class-=
atom) "."))
+ class-atom
+ (multiple-value-bind (package class) (jni::split-p=
ackage-and-class class-atom)
+ (find-symbol (string-append (string-upcase class=
) ".") package))))
+ (class-name (subseq (symbol-name class-sym) 0 (1- (length (symb=
ol-name class-sym)))))
+ (gthis (gensym)))
+ (flet ((expand-init (x)
+ (if (keywordp (first x)) ;setf field or property
+ `(setf (,(find-symbol (string-append class-name "." (sy=
mbol-name (first x))))
+ ,gthis ,@(butlast (rest x)))
+ ,@(last (rest x)))
+ ;.memfunc
+ `(,(find-symbol (string-append class-name (symbol-name (f=
irst x))))
+ ,gthis
+ ,@(rest x)))))
+ `(let* ((,gthis (make-new ,class-sym , at real-args))
+ ,@(when (listp class-spec)
+ `((,(second class-spec) ,gthis))))
+ ,@(mapcar #'expand-init (init-forms inits))
+ ,gthis)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Fields ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#|
+all public fields will get a getter function classname.fieldname and a set=
ter - (setf classname.fieldname)
+instance fields take an first arg which is the instance
+static fields also get a symbol-macro *classname.fieldname*
+|#
+
+(defmacro def-java-fields (full-class-name)
+"fields will get a getter function classname.fieldname and a setter - (set=
f classname.fieldname)
+instance fields take an first arg which is the instance
+static fields also get a symbol-macro *classname.fieldname*"
+ (let* ((class-sym (canonic-class-symbol full-class-name))
+ (class (get-java-class-ref class-sym))
+ (fields (jarray-to-list (class.getfields class)))
+ (defs nil))
+ (dolist (field fields)
+ (let* ((field-name (field.getname field))
+ (field-sym (member-symbol full-class-name field-name))
+ (is-static (modifier.isstatic (field.getmodifiers field))))
+ (if is-static
+ (let ((macsym (intern (string-append "*" (symbol-name field-sy=
m) "*")
+ (symbol-package field-sym))))
+ (push `(defun ,field-sym ()
+ (install-static-field-and-get ,full-class-name ,fie=
ld-name))
+ defs)
+ (push `(defun (setf ,field-sym) (val)
+ (install-static-field-and-set ,full-class-name ,fie=
ld-name val))
+ defs)
+ (push `(export ',field-sym (symbol-package ',field-sym)) def=
s)
+ (push `(define-symbol-macro ,macsym (,field-sym)) defs)
+ (push `(export ',macsym (symbol-package ',macsym)) defs))
+ (progn
+ (push `(defun ,field-sym (obj)
+ (install-field-and-get ,full-class-name ,field-name o=
bj))
+ defs)
+ (push `(defun (setf ,field-sym) (val obj)
+ (install-field-and-set ,full-class-name ,field-name v=
al obj))
+ defs)
+ (push `(export ',field-sym (symbol-package ',field-sym)) defs)=
))))
+ `(locally ,@(nreverse defs))))
+
+(defun install-field-and-get (full-class-name field-name obj)
+ (install-field full-class-name field-name)
+ (funcall (member-symbol full-class-name field-name) obj))
+
+(defun install-field-and-set (full-class-name field-name val obj)
+ (install-field full-class-name field-name)
+ (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name)=
)) val obj))
+
+(defun install-static-field-and-get (full-class-name field-name)
+ (install-field full-class-name field-name)
+ (funcall (member-symbol full-class-name field-name)))
+
+(defun install-static-field-and-set (full-class-name field-name val)
+ (install-field full-class-name field-name)
+ (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name)=
)) val))
+
+(defun install-field (full-class-name field-name)
+ (let* ((class-sym (canonic-class-symbol full-class-name))
+ (class (get-java-class-ref class-sym))
+ (field (class.getfield class field-name))
+ (field-sym (member-symbol full-class-name field-name))
+ (is-static (modifier.isstatic (field.getmodifiers field)))
+ (field-type-name (class.getname (field.gettype field)))
+ (boxer (get-boxer-fn field-type-name))
+ (unboxer (get-unboxer-fn field-type-name)))
+ (if is-static
+ (progn
+ (setf (fdefinition field-sym)
+ (lambda ()
+ (funcall unboxer (field.get field nil) t)))
+ (setf (fdefinition `(setf ,field-sym))
+ (lambda (arg)
+ (field.set field nil
+ (get-ref (if (and boxer (not (boxed? arg)))
+ (funcall boxer arg)
+ arg)))
+ arg)))
+ (progn
+ (setf (fdefinition field-sym)
+ (lambda (obj)
+ (funcall unboxer (field.get field (get-ref obj)) t)))
+ (setf (fdefinition `(setf ,field-sym))
+ (lambda (arg obj)
+ (field.set field (get-ref obj)
+ (get-ref (if (and boxer (not (boxed? arg)))
+ (funcall boxer arg)
+ arg)))
+ arg))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+#|
+defines wrappers for all public methods of the class
+As with ctors, if a method is overloaded a single wrapper is created that =
handles
+overload resolution.
+The wrappers have the name classname.methodname
+If a method follows the JavaBeans property protocol (i.e. it is called get=
Something or isSomething
+and there is a corresponding setSomething, then a (setf classname.methodna=
me) will be defined
+that calls the latter
+|#
+
+(defun class-name-for-doc (class)
+ (let ((name (class.getname class)))
+ (if (class.isarray class)
+ (decode-array-name name)
+ name)))
+
+(defun build-method-doc-string (name methods)
+ (with-output-to-string (s)
+ (dolist (m methods)
+ (format s "~A~A ~A(~{~#[~;~A~:;~A,~]~})~%"
+ (if (modifier.isstatic (method.getmodifiers m))
+ "static "
+ "")
+ (class.getname (method.getreturntype m))
+ name
+ (mapcar #'class-name-for-doc (jarray-to-list (method.getpara=
metertypes m)))))))
+
+(defmacro def-java-methods (full-class-name)
+ (let ((methods-by-name (get-methods-by-name full-class-name))
+ (defs nil))
+ (maphash (lambda (name methods)
+ (let ((method-sym (member-symbol full-class-name name)))
+ (push `(defun ,method-sym (&rest args)
+ ,(build-method-doc-string name methods)
+ (apply #'install-methods-and-call ,full-class-na=
me ,name args))
+ defs)
+ (push `(export ',method-sym (symbol-package ',method-sym))
+ defs)
+ ;build setters when finding beans property protocol
+ (flet ((add-setter-if (prefix)
+ (when (eql 0 (search prefix name))
+ (let ((setname (string-append "set" (subseq na=
me (length prefix)))))
+ (when (gethash setname methods-by-name)
+ (push `(defun (setf ,method-sym) (val &res=
t args)
+ (progn
+ (apply #',(member-symbol full-c=
lass-name setname)
+ (append args (list val)))
+ val))
+ defs))))))
+ (add-setter-if "get")
+ (add-setter-if "is"))))
+ methods-by-name)
+ `(locally ,@(nreverse defs))))
+
+(defun install-methods-and-call (full-class-name method &rest args)
+ "initially all the member function symbols for a class are bound to this=
function,
+when first called it will replace them with the appropriate direct thunks,
+then call the requested method - subsequent calls via those symbols will b=
e direct"
+ (install-methods full-class-name)
+ (apply (member-symbol full-class-name method) args))
+
+(defun decode-array-name (tn)
+ (let ((prim (assoc tn
+ '(("Z" . "boolean")
+ ("B" . "byte")
+ ("C" . "char")
+ ("S" . "short")
+ ("I" . "int")
+ ("J" . "long")
+ ("F" . "float")
+ ("D" . "double")
+ ("V" . "void"))
+ :test #'string-equal)))
+ (if prim
+ (rest prim)
+ (let ((array-depth (count #\[ tn)))
+ (if (=3D 0 array-depth)
+ (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ;
+ (with-output-to-string (s)
+ (write-string (decode-array-name (subseq tn array-depth)) s)
+ (dotimes (x array-depth)
+ (write-string "[]" s))))))))
+
+(defun jarray-to-list (array)
+ (let (ret)
+ (do-jarray (x array)
+ (push x ret))
+ (nreverse ret)))
+
+(defun get-methods-by-name (full-class-name)
+ "returns an #'equal hashtable of lists of java.lang.Method refs keyed by=
name"
+ (let* ((class-sym (canonic-class-symbol full-class-name))
+ (class (get-java-class-ref class-sym))
+ (method-array (class.getmethods class))
+ (methods-by-name (make-hash-table :test #'equal)))
+ (do-jarray (method method-array)
+ (push method (gethash (method.getName method) methods-by-name)))
+ methods-by-name))
+
+(defun install-methods (full-class-name)
+ (let ((methods-by-name (get-methods-by-name full-class-name)))
+ (maphash
+ (lambda (name methods)
+ (setf (fdefinition (member-symbol full-class-name name))
+ (make-method-thunk methods)))
+ methods-by-name)))
+
+(defun make-method-thunk (methods)
+ (if (rest methods) ;overloaded
+ (make-overloaded-thunk methods)
+ (make-non-overloaded-thunk (first methods))))
+
+(defun make-non-overloaded-thunk (method)
+ (let ((unboxer-fn (get-unboxer-fn (class.getname (method.getreturntype m=
ethod))))
+ (arg-boxers (get-arg-boxers (method.getparametertypes method)))
+ (is-static (modifier.isstatic (method.getmodifiers method))))
+ (lambda (&rest args)
+ (let ((arg-array (build-arg-array (if is-static args (rest args)) ar=
g-boxers)))
+ (prog1
+ (funcall unboxer-fn
+ (method.invoke method
+ (if is-static nil (get-ref (first args=
)))
+ arg-array) t)
+ (when arg-array
+ (delete-local-ref arg-array)))))))
+
+(defun make-overloaded-thunk (methods)
+ (let ((thunks (make-thunks-by-args-length methods)))
+ (lambda (&rest args)
+ (let ((fn (cdr (assoc (length args) thunks))))
+ (if fn
+ (apply fn
+ args)
+ (error "invalid arity"))))))
+
+(defun make-thunks-by-args-length (methods)
+ "returns an alist of thunks keyed by number of args"
+ (let ((methods-by-args-length (make-hash-table))
+ (thunks-by-args-length nil))
+ (dolist (method methods)
+ (let ((is-static (modifier.isstatic (method.getmodifiers method)))
+ (params-len (get-array-length (method.getparametertypes method=
))))
+ (push method (gethash (if is-static params-len (1+ params-len))
+ methods-by-args-length))))
+ (maphash #'(lambda (args-len methods)
+ (push (cons args-len
+ (if (rest methods);truly overloaded
+ (make-type-overloaded-thunk methods)
+ ;only one method with this number of args
+ (make-non-overloaded-thunk (first methods))=
))
+ thunks-by-args-length))
+ methods-by-args-length)
+ thunks-by-args-length))
+
+(defun make-type-overloaded-thunk (methods)
+ "these methods have the same number of args and must be distinguished by=
type"
+ (let ((thunks (mapcar #'(lambda (method)
+ (list (make-non-overloaded-thunk method)
+ (modifier.isstatic (method.getmodifiers =
method))
+ (jarray-to-list (method.getparametertype=
s method))))
+ methods)))
+ (lambda (&rest args)
+ (block fn
+ (let ((arg-types (get-types-of-args args)))
+ (dolist (thunk-info thunks)
+ (destructuring-bind (thunk is-static param-types) thunk-info
+ (when (is-congruent-type-list param-types (if is-static arg-=
types (rest arg-types)))
+ (return-from fn (apply thunk args)))))
+ (error "No matching method"))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;; array support ;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun jref (array &rest subscripts)
+ "like aref, for Java arrays of non-primitive/reference types, settable"
+ (assert (every #'integerp subscripts))
+ (do*
+ ((sub subscripts (rest sub))
+ (a (get-ref array) (get-ref (array.get a (first sub)))))
+ ((null (rest sub))
+ (array.get a (first sub)))))
+
+(defun (setf jref) (val array &rest subscripts)
+ (assert (every #'integerp subscripts))
+ (do*
+ ((sub subscripts (rest sub))
+ (a (get-ref array) (get-ref (array.get a (first sub)))))
+ ((null (rest sub))
+ (array.set a (first sub) (get-ref val))
+ val)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro def-refs (&rest types)
+ `(locally
+ ,@(mapcan
+ (lambda (type)
+ (let ((ref-sym (intern (string-upcase (string-append "jref-" (=
symbol-name type))))))
+ (list =
+ `(defun ,ref-sym (array &rest subscripts)
+ ,(format nil "like aref, for Java arrays of ~A, settable=
" (symbol-name type))
+ (assert (every #'integerp subscripts))
+ (do*
+ ((sub subscripts (rest sub))
+ (a (get-ref array) (get-ref (array.get a (first su=
b)))))
+ ((null (rest sub))
+ (,(intern (string-upcase (string-append "array.get=
" (symbol-name type))))
+ a (first sub)))))
+
+ `(defun (setf ,ref-sym) (val array &rest subscripts)
+ (assert (every #'integerp subscripts))
+ (do*
+ ((sub subscripts (rest sub))
+ (a (get-ref array) (get-ref (array.get a (first su=
b)))))
+ ((null (rest sub))
+ (array.set a (first sub)
+ (,(intern (string-upcase (string-append=
"box-"
+ =
(symbol-name type))))
+ val))
+ val))))))
+ types))))
+
+;arrays of primitives have their own accessors
+(def-refs boolean byte char double float int short long)
+
+(defun jlength (array)
+ "like length, for Java arrays"
+ (array.getlength (get-ref array)))
+
+(defgeneric make-new-array (type &rest dimensions)
+ (:documentation "generic function, with methods for all Java class desig=
nators")
+ (:method (type &rest dims)
+ (assert (every #'integerp dims))
+ (if (rest dims)
+ (let* ((ndim (length dims))
+ (dim-array (new-int-array ndim)))
+ (dotimes (i ndim)
+ (array.set dim-array i (box-int (nth i dims))))
+ (array.newinstance<java.lang.class-int<>> type dim-array))
+ (array.newinstance<java.lang.class-int> type (first dims)))))
+
+(defmethod make-new-array ((type symbol) &rest dimensions)
+ (apply #'make-new-array (get-java-class-ref type) dimensions))
+
+(defmethod make-new-array ((type string) &rest dimensions)
+ (apply #'make-new-array (find-java-class type) dimensions))
+
+(defmethod make-new-array ((type (eql :char)) &rest dimensions)
+ (apply #'make-new-array character.type dimensions))
+
+(defmethod make-new-array ((type (eql :int)) &rest dimensions)
+ (apply #'make-new-array integer.type dimensions))
+
+(defmethod make-new-array ((type (eql :boolean)) &rest dimensions)
+ (apply #'make-new-array boolean.type dimensions))
+
+(defmethod make-new-array ((type (eql :double)) &rest dimensions)
+ (apply #'make-new-array double.type dimensions))
+
+(defmethod make-new-array ((type (eql :byte)) &rest dimensions)
+ (apply #'make-new-array byte.type dimensions))
+
+(defmethod make-new-array ((type (eql :float)) &rest dimensions)
+ (apply #'make-new-array float.type dimensions))
+
+(defmethod make-new-array ((type (eql :short)) &rest dimensions)
+ (apply #'make-new-array short.type dimensions))
+
+(defmethod make-new-array ((type (eql :long)) &rest dimensions)
+ (apply #'make-new-array long.type dimensions))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;; arg/param helpers ;;;;;;;;;;;;;;;;;;;;;;
+
+(defun get-arg-boxers (param-types)
+ "returns a list with one entry per param, either nil or a function that =
boxes the arg"
+ (let (ret)
+ (do-jarray (param-type param-types)
+ (push (get-boxer-fn (class.getname param-type))
+ ret))
+ (nreverse ret)))
+
+(defun build-arg-array (args arg-boxers)
+ (when args
+ (let* ((arg-array (new-object-array (length args)
+ ;duplication of class-symbol logic
+ ;but must be fast
+ (get-java-class-ref '|java.lang|::=
|Object|)
+ nil)))
+ (do ((i 0 (incf i))
+ (args args (rest args))
+ (boxers arg-boxers (rest boxers)))
+ ((null args))
+ (let ((arg (first args))
+ (boxer (first boxers)))
+ (setf (jaref arg-array i)
+ (get-ref (if (and boxer (not (boxed? arg)))
+ (funcall boxer arg)
+ arg)))))
+ arg-array)))
+
+(defun get-types-of-args (args)
+ (let (ret)
+ (dolist (arg args)
+ (push (infer-box-type arg)
+ ret))
+ (nreverse ret)))
+
+(defun is-congruent-type-list (param-types arg-types)
+ (every #'(lambda (arg-type param-type)
+ (if arg-type
+ (is-assignable-from arg-type param-type)
+ ;nil was passed - must be boolean or non-primitive target t=
ype
+ (or (not (class.isprimitive param-type))
+ (is-assignable-from boolean.type param-type))))
+ arg-types param-types))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;; argument conversion and boxing ;;;;;;;;;;;;;;;;;;=
;;;;;;;;
+(defun box-string (s)
+"Given a string or symbol, returns reference to a Java string"
+ (local-ref-to-global-ref (convert-to-java-string s)))
+
+(defun unbox-string (ref &optional delete-local)
+ "Given a reference to a Java string, returns a Lisp string" =
+ (declare (ignore delete-local))
+ (convert-from-java-string (get-ref ref)))
+
+(defun get-boxer-fn (class-name)
+ (case-equal class-name
+ ("int" #'box-int)
+ ("boolean" #'box-boolean)
+ ("double" #'box-double)
+ ("java.lang.String" #'convert-to-java-string)
+ ("char" #'box-char)
+ ("byte" #'box-byte)
+ ("float" #'box-float)
+ ("long" #'box-long)
+ ("short" #'box-short)
+ (otherwise nil)))
+
+(defun get-boxer-fn-sym (class-name)
+ (case-equal class-name
+ ("int" 'box-int)
+ ("boolean" 'box-boolean)
+ ("double" 'box-double)
+ ("java.lang.String" 'convert-to-java-string)
+ ("char" 'box-char)
+ ("byte" 'box-byte)
+ ("float" 'box-float)
+ ("long" 'box-long)
+ ("short" 'box-short)
+ ("void" 'box-void)
+ (otherwise 'identity)))
+
+(defun boxed? (x)
+ (or (java-ref-p x)
+ (typep x '|java.lang|::object.)))
+
+(defun infer-box-type (x)
+ (cond
+ ((null x) nil)
+ ((boxed? x) (object.getclass (get-ref x)))
+ ((integerp x) integer.type)
+ ((numberp x) double.type)
+ ((eq x t) boolean.type)
+ ((or (stringp x) (symbolp x))
+ (get-java-class-ref '|java.lang|::|String|))
+ (t (error "can't infer box type"))))
+
+(defun get-unboxer-fn (class-name)
+ (case-equal class-name
+ ("int" #'unbox-int)
+ ("boolean" #'unbox-boolean)
+ ("double" #'unbox-double)
+ ("java.lang.String" #'unbox-string)
+ ("void" #'unbox-void)
+ ("char" #'unbox-char)
+ ("byte" #'unbox-byte)
+ ("float" #'unbox-float)
+ ("long" #'unbox-long)
+ ("short" #'unbox-short)
+ (otherwise #'unbox-ref)))
+
+(defun get-unboxer-fn-sym (class-name)
+ (case-equal class-name
+ ("int" 'unbox-int)
+ ("boolean" 'unbox-boolean)
+ ("double" 'unbox-double)
+ ("java.lang.String" 'unbox-string)
+ ("void" 'unbox-void)
+ ("char" 'unbox-char)
+ ("byte" 'unbox-byte)
+ ("float" 'unbox-float)
+ ("long" 'unbox-long)
+ ("short" 'unbox-short)
+ (otherwise 'unbox-ref)))
+
+(defun unbox-ref (x &optional delete-local)
+ (declare (ignore delete-local))
+ (local-ref-to-global-ref x))
+
+(defun unbox-void (x &optional delete-local)
+ (declare (ignore x delete-local))
+ nil)
+
+(defun box-void (x)
+ (declare (ignore x))
+ nil)
+
+(defun box-boolean (x)
+ (boolean.new x))
+
+(defun unbox-boolean (obj &optional delete-local)
+ (prog1
+ (boolean.booleanvalue (get-ref obj))
+ (when delete-local (delete-local-ref obj))))
+
+(defun box-byte (x)
+ (assert (integerp x))
+ (byte.new x))
+
+(defun unbox-byte (x &optional delete-local)
+ (prog1
+ (byte.bytevalue (get-ref x))
+ (when delete-local (delete-local-ref x))))
+
+(defun box-char (x)
+ (character.new x))
+
+(defun unbox-char (x &optional delete-local)
+ (prog1
+ (character.charvalue (get-ref x))
+ (when delete-local (delete-local-ref x))))
+
+(defun box-double (x)
+ (assert (floatp x))
+ (double.new (coerce x 'double-float)))
+
+(defun unbox-double (x &optional delete-local)
+ (prog1
+ (double.doublevalue (get-ref x))
+ (when delete-local (delete-local-ref x))))
+
+(defun box-float (x)
+ (assert (floatp x))
+ (float.new x))
+
+(defun unbox-float (x &optional delete-local)
+ (prog1
+ (float.floatvalue (get-ref x))
+ (when delete-local (delete-local-ref x))))
+
+(defun box-int (x)
+ (assert (integerp x))
+ (integer.new x))
+
+(defun unbox-int (x &optional delete-local)
+ (prog1
+ (integer.intvalue (get-ref x))
+ (when delete-local (delete-local-ref x))))
+
+;can't directly construct Long because LW doesn't support long long fli on=
32 bit platforms
+(defun box-long (x)
+ (assert (integerp x))
+ (long.valueof (princ-to-string x)))
+
+;here too, can only get an ints worth - aargh
+(defun unbox-long (obj &optional delete-local)
+ (prog1
+ (parse-integer (object.tostring (get-ref obj)))
+ (when delete-local (delete-local-ref obj))))
+
+(defun box-short (x)
+ (assert (integerp x))
+ (short.new x))
+
+(defun unbox-short (x &optional delete-local)
+ (prog1
+ (short.shortvalue (get-ref x))
+ (when delete-local (delete-local-ref x))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun proxy-hashcode (proxy)
+ ;use the hashcode of the proxy's class, =
+ ;because hashcode() on the proxy flows through to the invocation handler
+ ;is this rem guaranteed to be a fixnum?
+ (rem (object.hashcode (object.getclass proxy)) most-positive-fixnum))
+
+(defvar *proxy-table* (make-hash-table :test #'jeq :hash-function #'proxy-=
hashcode))
+
+;(defvar *proxy-list* nil)
+
+(defun store-proxy (proxy method-fn-alist)
+ ;(push (cons proxy method-fn-alist) *proxy-list*)
+ (setf (gethash proxy *proxy-table*) method-fn-alist))
+
+(defun recall-proxy (proxy)
+ ;(cdr (assoc proxy *proxy-list* :test #'jeq))
+ (gethash proxy *proxy-table*))
+
+(defun unregister-proxy (proxy)
+"Stops handling for the proxy and removes references from the Lisp side.
+Make sure it is no longer referenced from Java first!"
+ (remhash proxy *proxy-table*))
+
+(defun invocation-handler (proxy method args)
+ (let* ((method-fn-alist (recall-proxy proxy))
+ (fn (and method-fn-alist (second (assoc (object.tostring method) =
method-fn-alist
+ :test #'equal)))))
+ (if fn
+ (funcall fn args)
+ (progn
+ ;(throw-new (find-java-class "java.lang.UnsupportedOperationExcep=
tion")
+ ; "No function registered in Lisp proxy object")
+ nil))))
+
+(defun enable-java-proxies ()
+ "must be called before any call to new-proxy, and requires jfli.jar be i=
n the classpath"
+ (jni:register-invocation-handler #'invocation-handler))
+
+(defun make-proxy-instance (&rest interface-defs)
+ (let* ((interfaces (mapcar #'first interface-defs))
+ (method-fn-alist (mapcan #'second interface-defs))
+ (len (length interfaces))
+ (iarray (array.newinstance<java.lang.class-int> (get-java-class-r=
ef '|java.lang|::|Class|)
+ len)))
+ (dotimes (x len)
+ (setf (jref iarray x) (nth x interfaces)))
+ (let ((proxy (proxy.newproxyinstance (classloader.getsystemclassloader)
+ iarray
+ (lispinvocationhandler.new))))
+ (store-proxy proxy method-fn-alist)
+ proxy)))
+
+(defun find-java-class-in-macro (name)
+ (find-java-class
+ (if (symbolp name)
+ (symbol-value name)
+ name)))
+
+(defmacro new-proxy (&rest interface-defs)
+"interface-def -> (interface-name method-defs+)
+interface-name -> \"package.qualified.ClassName\" | classname. (must name =
a Java interface type)
+method-def -> (method-name arg-defs* body)
+arg-def -> arg-name | (arg-name arg-type)
+arg-type -> \"package.qualified.ClassName\" | classname. | :primitive
+method-name -> symbol | string (matched case-insensitively)
+
+Creates, registers and returns a Java object that implements the supplied =
interfaces"
+
+ (labels ((process-idefs (idefs)
+ (when idefs
+ (cons (process-idef (first idefs))
+ (process-idefs (rest idefs)))))
+ (process-idef (idef)
+ (destructuring-bind (interface-name &rest method-defs) idef
+ (let* ((methods (class.getmethods (find-java-class-in-macro=
interface-name)))
+ (ret `(list (find-java-class ,interface-name)
+ (list ,@(mapcar (lambda (method-def)
+ (process-method-def me=
thod-def methods))
+ method-defs)))))
+ ;check to make sure every function is defined
+ (do-jarray (method methods)
+ (let ((mname (object.tostring method)))
+ (unless (member mname (rest (third ret)) :key #'secon=
d :test #'equal)
+ (warn (format nil "proxy doesn't define:~%~A" mname=
)))))
+ ret)))
+ (process-method-def (method-def methods)
+ (destructuring-bind (method-name (&rest arg-defs) &body body)=
method-def
+ (let ((method (matching-method method-name arg-defs methods=
))
+ (gargs (gensym)))
+ `(list ,(object.tostring method)
+ (lambda (,gargs)
+ (,(get-boxer-fn-sym (class.getname (method.getre=
turntype method)))
+ (let ,(arg-lets arg-defs
+ (jarray-to-list (method.getpara=
metertypes method))
+ gargs
+ 0)
+ , at body)))))))
+ (arg-lets (arg-defs params gargs idx)
+ (when arg-defs
+ (let ((arg (first arg-defs))
+ (param (first params)))
+ (cons `(,(if (atom arg) arg (first arg))
+ (,(get-unboxer-fn-sym (class.getname param))
+ (jref ,gargs ,idx) t))
+ (arg-lets (rest arg-defs) (rest params) gargs (1+ i=
dx))))))
+ (matching-method (method-name arg-defs methods)
+ (let (match)
+ (do-jarray (method methods)
+ (when (method-matches method-name arg-defs method)
+ (if match
+ (error (format nil "more than one method matches ~A=
" method-name))
+ (setf match method))))
+ (or match (error (format nil "no method matches ~A" method-=
name)))))
+ (method-matches (method-name arg-defs method)
+ (when (string-equal method-name (method.getname method))
+ (let ((params (method.getparametertypes method)))
+ (when (=3D (length arg-defs) (jlength params))
+ (is-congruent arg-defs params)))))
+ (is-congruent (arg-defs params)
+ (every (lambda (arg param)
+ (or (atom arg) ;no type spec matches anything
+ (jeq (find-java-class-in-macro (second arg)) par=
am)))
+ arg-defs (jarray-to-list params))))
+ `(make-proxy-instance ,@(process-idefs interface-defs))))
Modified: trunk/source/examples/jfli/jni.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/jfli/jni.lisp (original)
+++ trunk/source/examples/jfli/jni.lisp Thu Nov 27 12:40:41 2008
@@ -1,1239 +1,1239 @@
-; Copyright (c) Rich Hickey. All rights reserved.
-; The use and distribution terms for this software are covered by the
-; Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
-; which can be found in the file CPL.TXT at the root of this distributi=
on.
-; By using this software in any fashion, you are agreeing to be bound by
-; the terms of this license.
-; You must not remove this notice, or any other, from this software.
-
-#|
-This is a straight wrapper around the JNI API
-Originally I intended to expose this API directly, but it turns out
-that JNI is very sensitive to errors, and, given bad args, wrong types etc
-causes the JVM (and Lisp) to crash, not very much in the spirit of safe, r=
obust,
-interactive development offered by Lisp
-
-So, now this just forms the substrate under jfli, which uses the Reflectio=
n API, and is much
-more robust and error tolerant, at some cost in speed I guess.
-
-Bottom line is you shouldn't be using this API directly unless you are ext=
ending jfli,
-and then you must take care not to allow bad end-user data to pass through=
to JNI. =
-
-Caveat emptor.
-
-I have tried to limit LispWorks FLI code to this file.
-|#
-
-(defpackage :jni
- (:export
- :*jni-lib-path*
- :*pvm*
- :*penv*
- :register-invocation-handler
- :create-jvm
- :JNI-VERSION-1-2
- :JNI-VERSION-1-4
- :JNI-OK
- :java-ref
- :jvoid :jboolean :jbyte :jchar :jshort :jint :jlong :jfloat :jdouble :j=
size
- :jobject :jclass :jthrowable :jstring :jarray
- :jboolean-array :jbyte-array :jchar-array :jshort-array :jint-array :jl=
ong-array
- :jfloat-array :jdouble-array :jobject-array
- :jfield-id :jmethod-id :jweak
- :pvm :penv
- :jvalue
- :arg-array
- :jni-native-method :jni-env
- :java-vm :java-vm-option :jdk-1-1-init-args
- :jni-get-default-java-vm-init-args :java-vm-inits-args
- :jni-create-java-vm :jni-get-created-java-vms
- :try :try-null :try-neg
- :local-ref-to-global-ref :local-ref-to-string
- :def-jni-function :def-jni-functions :def-jni-constructor :def-jni-field
- :jaref :convert-to-java-string :convert-from-java-string :java-ref-p
- :is-name-of-primitive :split-package-and-class))
-
-(in-package :jni)
-
-(defvar *jni-lib-path*
-#+:MACOSX "/System/Library/Frameworks/JavaVM.framework/JavaVM"
-#+:WIN32 "C:/j2sdk1.4.2_01/jre/bin/client/jvm.dll"
-"Set this to point to your jvm dll prior to calling create-jvm")
-
-(defparameter *pvm* nil)
-(defparameter *penv* nil)
-
-(defparameter *process-envs* nil)
-
-(defconstant JNI-VERSION-1-2 #X10002)
-(defconstant JNI-VERSION-1-4 #X10004)
-(defconstant JNI-OK 0)
-
-(defun load-jni-lib (&optional (libpath *jni-lib-path*))
- (fli:register-module :jni-lib
- :real-name libpath
- :connection-style :immediate))
-
-(fli:define-c-typedef pvoid (:ptr :void))
-(fli:define-c-typedef const-char-* (:reference-pass :ef-mb-string))
-(fli:define-c-typedef const-jchar-* (:reference-pass :ef-wc-string))
-(fli:define-foreign-pointer (java-ref (:allow-null t) (:predicate java-ref=
-p)) pvoid)
-
-(fli:define-c-typedef jvoid :void)
-(fli:define-c-typedef jboolean (:boolean (:unsigned :byte)))
-(fli:define-c-typedef jbyte :byte)
-(fli:define-c-typedef jchar :wchar-t)
-(fli:define-c-typedef jshort :short)
-(fli:define-c-typedef jint :int)
-(fli:define-c-typedef jlong :long-long)
-(fli:define-c-typedef jfloat :float)
-(fli:define-c-typedef jdouble :double)
-(fli:define-c-typedef jsize jint)
-(fli:define-c-typedef jobject java-ref)
-(fli:define-c-typedef jclass java-ref)
-(fli:define-c-typedef jthrowable java-ref)
-(fli:define-c-typedef jstring java-ref)
-(fli:define-c-typedef jarray java-ref)
-(fli:define-c-typedef jboolean-array java-ref)
-(fli:define-c-typedef jbyte-array java-ref)
-(fli:define-c-typedef jchar-array java-ref)
-(fli:define-c-typedef jshort-array java-ref)
-(fli:define-c-typedef jint-array java-ref)
-(fli:define-c-typedef jlong-array java-ref)
-(fli:define-c-typedef jfloat-array java-ref)
-(fli:define-c-typedef jdouble-array java-ref)
-(fli:define-c-typedef jobject-array java-ref)
-(fli:define-c-typedef jfield-id pvoid)
-(fli:define-c-typedef jmethod-id pvoid)
-(fli:define-c-typedef jweak java-ref)
-
-(fli:define-c-typedef pvm (:ptr (:ptr java-vm)))
-(fli:define-c-typedef penv (:ptr (:ptr jni-env)))
-(fli:define-foreign-type pfunc (&rest fargs)
- `(:ptr (:function , at fargs)))
-
-(fli:define-c-union jvalue
- (:z jboolean)
- (:b jbyte)
- (:c jchar)
- (:s jshort)
- (:i jint)
- (:j jlong)
- (:f jfloat)
- (:d jdouble)
- (:l jobject))
-
-(fli:define-c-typedef arg-array (:c-array jvalue))
-
-(eval-when (:compile-toplevel)
- (defun build-struct-entries (name members)
- (mapcar #'(lambda (member)
- (if (=3D 2 (length member)) ;padding or other non-function=
entry
- member
- (destructuring-bind (func args ret &key lambda-list) mem=
ber
- (declare (ignore lambda-list))
- `(,func (pfunc ,(cons `(:ptr (:ptr ,name))
- (mapcar #'second args))
- ,ret)))))
- members)))
-
-(eval-when (:compile-toplevel)
- (defun build-access-functions (name global members)
- (mapcar #'(lambda (member)
- (if (=3D 2 (length member)) ;padding or other non-function=
entry
- ()
- (destructuring-bind (func args ret &key lambda-list) mem=
ber
- (let ((thunk (intern (concatenate 'string (symbol-name=
func) "-thunk")))
- (genv (gensym))
- ;(func (intern (symbol-name f)))
- )
- `(locally
- (fli:define-foreign-funcallable
- ,thunk
- ,(cons `(this (:ptr (:ptr ,name))) args)
- :result-type ,ret)
- (defun ,func ,(if lambda-list
- lambda-list
- (mapcar #'first args))
- (let ((,genv ,global))
- (,thunk
- (fli:foreign-slot-value (fli:dereference ,ge=
nv) ',func)
- ,genv
- ,@(mapcar #'first args))))
- (export ',func))))))
- members)))
-
-(defmacro defvtable (name global &rest members)
- `(locally
- (fli:define-c-struct ,name ,@(build-struct-entries name members))
- ,@(build-access-functions name global members)))
-
-(fli:define-c-struct jni-native-method
- (name (:ptr :char))
- (signature (:ptr :char))
- (fn-ptr pvoid)
- )
-
-(defun current-env ()
- "memoizes attach-current-thread per process"
- (or
- *penv*
- (cdr (assoc mp:*current-process* *process-envs*))
- (multiple-value-bind (ret env) (attach-current-thread)
- (declare (ignore ret))
- (push (cons mp:*current-process* env) *process-envs*)
- env)))
-
-(defvtable jni-env (current-env)
- (reserved-0 pvoid) =
;0
- (reserved-1 pvoid) =
;1
- (reserved-2 pvoid) =
;2
- (reserved-3 pvoid) =
;3
- ;some mac nonsense requires this non-portable padding, so much for a bin=
ary spec
- #+:MACOSX (cfm-padding (:foreign-array pvoid (225)))
- (get-version () jint) =
;4
- (define-class ((name const-char-*) =
;5
- (loader jobject)
- (buf (:ptr jbyte))
- (len jsize)) jclass) =
- (jni-find-class ((name const-char-*)) jclass) =
;6
- (from-reflected-method ((method jobject)) jmethod-id) =
;7
- (from-reflected-field ((field jobject)) jfield-id) =
;8
- (to-reflected-method ((cls jclass) =
;9
- (method-id jmethod-id)
- (is-static jboolean)) jobject)
- (get-superclass ((clazz jclass)) jclass) =
;10
- (is-assignable-from ((sub jclass) =
;11
- (sup jclass)) jboolean)
- (to-reflected-field ((cls jclass) =
;12
- (field-id jfield-id)
- (is-static jboolean)) jobject)
- (jni-throw ((obj jthrowable)) jint) =
;13
- (throw-new ((clazz jclass) =
;14
- (msg const-char-*)) jint)
- (exception-occurred () jthrowable) =
;15
- (exception-describe () :void) =
;16
- (exception-clear () :void) =
;17
- (fatal-error ((msg const-char-*)) :void) =
;18
- (push-local-frame ((capacity jint)) jint) =
;19
- (pop-local-frame ((result jobject)) jobject) =
;20
- (new-global-ref ((lobj jobject)) jobject) =
;21
- (delete-global-ref ((gref jobject)) :void) =
;22
- (delete-local-ref ((lref jobject)) :void) =
;23
- (is-same-object ((obj1 jobject) =
;24
- (obj2 jobject)) jboolean)
- (new-local-ref ((ref jobject)) jobject) =
;25
- (ensure-local-capacity ((capacity jint)) jint) =
;26
- (alloc-object ((clazz jclass)) jobject) =
;27
- (new-object pvoid) =
;28
- (new-object-v pvoid) =
;29
- (new-object-a ((clazz jclass) =
;30
- (method-id jmethod-id)
- (args arg-array)) jobject)
- (get-object-class ((obj jobject)) jclass) =
;31
- (is-instance-of ((obj jobject) =
;32
- (clazz jclass)) jboolean)
- (get-method-id ((clazz jclass) =
;33
- (name const-char-*)
- (sig const-char-*)) jmethod-id)
-
- (call-object-method pvoid) =
;34
- (call-object-method-v pvoid) =
;35
- (call-object-method-a ((obj jobject) =
;36
- (method-id jmethod-id)
- (args arg-array)) jobject)
- (call-boolean-method pvoid) =
;37
- (call-boolean-method-v pvoid) =
;38
- (call-boolean-method-a ((obj jobject) =
;39
- (method-id jmethod-id) =
- (args arg-array)) jboolean)
- (call-byte-method pvoid) =
;40
- (call-byte-method-v pvoid) =
;41
- (call-byte-method-a ((obj jobject) =
;42
- (method-id jmethod-id)
- (args arg-array)) jbyte)
- (call-char-method pvoid) =
;43
- (call-char-method-v pvoid) =
;44
- (call-char-method-a ((obj jobject) =
;45
- (method-id jmethod-id)
- (args arg-array)) jchar)
- (call-short-method pvoid) =
;46
- (call-short-method-v pvoid) =
;47
- (call-short-method-a ((obj jobject) =
;48
- (method-id jmethod-id)
- (args arg-array)) jshort)
- (call-int-method pvoid) =
;49
- (call-int-method-v pvoid) =
;50
- (call-int-method-a ((obj jobject) =
;51
- (method-id jmethod-id)
- (args arg-array)) jint)
- (call-long-method pvoid) =
;52
- (call-long-method-v pvoid) =
;53
- (call-long-method-a ((obj jobject) =
;54
- (method-id jmethod-id)
- (args arg-array)) jlong)
- (call-float-method pvoid) =
;55
- (call-float-method-v pvoid) =
;56
- (call-float-method-a ((obj jobject) =
;57
- (method-id jmethod-id)
- (args arg-array)) jfloat)
- (call-double-method pvoid) =
;58
- (call-double-method-v pvoid) =
;59
- (call-double-method-a ((obj jobject) =
;60
- (method-id jmethod-id)
- (args arg-array)) jdouble)
- (call-void-method pvoid) =
;61
- (call-void-method-v pvoid) =
;62
- (call-void-method-a ((obj jobject) =
;63
- (method-id jmethod-id)
- (args arg-array)) jvoid)
-
- (call-nonvirtual-object-method pvoid) =
;64
- (call-nonvirtual-object-method-v pvoid) =
;65
- (call-nonvirtual-object-method-a ((obj jobject) =
;66
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jobject)
- (call-nonvirtual-boolean-method pvoid) =
;67
- (call-nonvirtual-boolean-method-v pvoid) =
;68
- (call-nonvirtual-boolean-method-a ((obj jobject) =
;69
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jboolean)
- (call-nonvirtual-byte-method pvoid) =
;70
- (call-nonvirtual-byte-method-v pvoid) =
;71
- (call-nonvirtual-byte-method-a ((obj jobject) =
;72
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jbyte)
- (call-nonvirtual-char-method pvoid) =
;73
- (call-nonvirtual-char-method-v pvoid) =
;74
- (call-nonvirtual-char-method-a ((obj jobject) =
;75
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jchar)
- (call-nonvirtual-short-method pvoid) =
;76
- (call-nonvirtual-short-method-v pvoid) =
;77
- (call-nonvirtual-short-method-a ((obj jobject) =
;78
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jshort)
- (call-nonvirtual-int-method pvoid) =
;79
- (call-nonvirtual-int-method-v pvoid) =
;80
- (call-nonvirtual-int-method-a ((obj jobject) =
;81
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jint)
- (call-nonvirtual-long-method pvoid) =
;82
- (call-nonvirtual-long-method-v pvoid) =
;83
- (call-nonvirtual-long-method-a ((obj jobject) =
;84
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jlong)
- (call-nonvirtual-float-method pvoid) =
;85
- (call-nonvirtual-float-method-v pvoid) =
;86
- (call-nonvirtual-float-method-a ((obj jobject) =
;87
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jfloat)
- (call-nonvirtual-double-method pvoid) =
;88
- (call-nonvirtual-double-method-v pvoid) =
;89
- (call-nonvirtual-double-method-a ((obj jobject) =
;90
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jdouble)
- (call-nonvirtual-void-method pvoid) =
;91
- (call-nonvirtual-void-method-v pvoid) =
;92
- (call-nonvirtual-void-method-a ((obj jobject) =
;93
- (clazz jclass)
- (method-id jmethod-id)
- (args arg-array)) jvoid)
- (get-field-id ((clazz jclass) =
;94
- (name const-char-*)
- (sig const-char-*)) jfield-id)
-
- (get-object-field ((obj jobject) =
;95
- (field-id jfield-id)) jobject)
- (get-boolean-field ((obj jobject) =
;96
- (field-id jfield-id)) jboolean) =
- (get-byte-field ((obj jobject) =
;97
- (field-id jfield-id)) jbyte) =
- (get-char-field ((obj jobject) =
;98
- (field-id jfield-id)) jchar) =
- (get-short-field ((obj jobject) =
;99
- (field-id jfield-id)) jshort) =
- (get-int-field ((obj jobject) =
;100
- (field-id jfield-id)) jint) =
- (get-long-field ((obj jobject) =
;101
- (field-id jfield-id)) jlong) =
- (get-float-field ((obj jobject) =
;102
- (field-id jfield-id)) jfloat) =
- (get-double-field ((obj jobject) =
;103
- (field-id jfield-id)) jdouble) =
-
- (set-object-field ((obj jobject) =
;104
- (field-id jfield-id)
- (val jobject)) jvoid)
- (set-boolean-field ((obj jobject) =
;105
- (field-id jfield-id)
- (val jboolean)) jvoid)
- (set-byte-field ((obj jobject) =
;106
- (field-id jfield-id)
- (val jbyte)) jvoid)
- (set-char-field ((obj jobject) =
;107
- (field-id jfield-id)
- (val jchar)) jvoid)
- (set-short-field ((obj jobject) =
;108
- (field-id jfield-id)
- (val jshort)) jvoid)
- (set-int-field ((obj jobject) =
;109
- (field-id jfield-id)
- (val jint)) jvoid)
- (set-long-field ((obj jobject) =
;110
- (field-id jfield-id)
- (val jlong)) jvoid)
- (set-float-field ((obj jobject) =
;111
- (field-id jfield-id)
- (val jfloat)) jvoid)
- (set-double-field ((obj jobject) =
;112
- (field-id jfield-id)
- (val jdouble)) jvoid)
-
- (get-static-method-id ((clazz jclass) =
;113
- (name const-char-*)
- (sig const-char-*)) jmethod-id)
-
- (call-static-object-method pvoid) =
;114
- (call-static-object-method-v pvoid) =
;115
- (call-static-object-method-a ((clazz jclass) =
;116
- (method-id jmethod-id)
- (args arg-array)) jobject)
- (call-static-boolean-method pvoid) =
;117
- (call-static-boolean-method-v pvoid) =
;118
- (call-static-boolean-method-a ((clazz jclass) =
;119
- (method-id jmethod-id)
- (args arg-array)) jboolean)
- (call-static-byte-method pvoid) =
;120
- (call-static-byte-method-v pvoid) =
;121
- (call-static-byte-method-a ((clazz jclass) =
;122
- (method-id jmethod-id)
- (args arg-array)) jbyte)
- (call-static-char-method pvoid) =
;123
- (call-static-char-method-v pvoid) =
;124
- (call-static-char-method-a ((clazz jclass) =
;125
- (method-id jmethod-id)
- (args arg-array)) jchar)
- (call-static-short-method pvoid) =
;126
- (call-static-short-method-v pvoid) =
;127
- (call-static-short-method-a ((clazz jclass) =
;128
- (method-id jmethod-id)
- (args arg-array)) jshort)
- (call-static-int-method pvoid) =
;129
- (call-static-int-method-v pvoid) =
;130
- (call-static-int-method-a ((clazz jclass) =
;131
- (method-id jmethod-id)
- (args arg-array)) jint)
- (call-static-long-method pvoid) =
;132
- (call-static-long-method-v pvoid) =
;133
- (call-static-long-method-a ((clazz jclass) =
;134
- (method-id jmethod-id)
- (args arg-array)) jlong)
- (call-static-float-method pvoid) =
;135
- (call-static-float-method-v pvoid) =
;136
- (call-static-float-method-a ((clazz jclass) =
;137
- (method-id jmethod-id)
- (args arg-array)) jfloat)
- (call-static-double-method pvoid) =
;138
- (call-static-double-method-v pvoid) =
;139
- (call-static-double-method-a ((clazz jclass) =
;140
- (method-id jmethod-id)
- (args arg-array)) jdouble)
- (call-static-void-method pvoid) =
;141
- (call-static-void-method-v pvoid) =
;142
- (call-static-void-method-a ((clazz jclass) =
;143
- (method-id jmethod-id)
- (args arg-array)) jvoid)
-
- (get-static-field-id ((clazz jclass) =
;144
- (name const-char-*)
- (sig const-char-*)) jfield-id)
-
- (get-static-object-field ((clazz jclass) =
;145
- (field-id jfield-id)) jobject)
- (get-static-boolean-field ((clazz jclass) =
;146
- (field-id jfield-id)) jboolean)
- (get-static-byte-field ((clazz jclass) =
;147
- (field-id jfield-id)) jbyte)
- (get-static-char-field ((clazz jclass) =
;148
- (field-id jfield-id)) jchar)
- (get-static-short-field ((clazz jclass) =
;149
- (field-id jfield-id)) jshort)
- (get-static-int-field ((clazz jclass) =
;150
- (field-id jfield-id)) jint)
- (get-static-long-field ((clazz jclass) =
;151
- (field-id jfield-id)) jlong)
- (get-static-float-field ((clazz jclass) =
;152
- (field-id jfield-id)) jfloat)
- (get-static-double-field ((clazz jclass) =
;153
- (field-id jfield-id)) jdouble)
-
- (set-static-object-field ((clazz jclass) =
;154
- (field-id jfield-id)
- (val jobject)) jvoid)
- (set-static-boolean-field ((clazz jclass) =
;155
- (field-id jfield-id)
- (val jboolean)) jvoid)
- (set-static-byte-field ((clazz jclass) =
;156
- (field-id jfield-id)
- (val jbyte)) jvoid)
- (set-static-char-field ((clazz jclass) =
;157
- (field-id jfield-id)
- (val jchar)) jvoid)
- (set-static-short-field ((clazz jclass) =
;158
- (field-id jfield-id)
- (val jshort)) jvoid)
- (set-static-int-field ((clazz jclass) =
;159
- (field-id jfield-id)
- (val jint)) jvoid)
- (set-static-long-field ((clazz jclass) =
;160
- (field-id jfield-id)
- (val jlong)) jvoid)
- (set-static-float-field ((clazz jclass) =
;161
- (field-id jfield-id)
- (val jfloat)) jvoid)
- (set-static-double-field ((clazz jclass) =
;162
- (field-id jfield-id)
- (val jdouble)) jvoid)
-
- (new-string ((uchars (:reference-pass :ef-wc-string)) =
;163
- (len jsize)) jstring)
- (get-string-length ((str jstring)) jsize) =
;164
- (get-string-chars ((str jstring) =
;165
- (is-copy (:reference-return jboolean)))
- ;(:c-array jchar 1000)
- (:ptr :wchar-t)
- ;(:ef-wc-string :external-format :unicode)
- :lambda-list (str &optional is-copy))
- (release-string-chars ((str jstring) =
;166
- (chars (:ptr jchar))) jvoid)
-
- (new-string-utf ((chars const-char-*)) jstring) =
;167
- (get-string-utf-length ((str jstring)) jsize) =
;168
- (get-string-utf-chars ((str jstring) =
;169
- (is-copy (:reference-return jboolean)))
- ;(:c-array :char 1000)
- (:ptr :char)
- :lambda-list (str &optional is-copy))
- (release-string-utf-chars ((str jstring) =
;170
- (chars (:ptr :char))) jvoid)
-
- (get-array-length ((array jarray)) jsize) =
;171
- =
- (new-object-array ((len jsize) =
;172
- (element-type jclass)
- (initial-element jobject)) jarray)
- (get-object-array-element ((array jobject-array) =
;173
- (index jsize)) jobject)
- (set-object-array-element ((array jobject-array) =
;174
- (index jsize)
- (val jobject)) jvoid)
-
- (new-boolean-array ((len jsize)) jboolean-array) =
;175
- (new-byte-array ((len jsize)) jbyte-array) =
;176
- (new-char-array ((len jsize)) jchar-array) =
;177
- (new-short-array ((len jsize)) jshort-array) =
;178
- (new-int-array ((len jsize)) jint-array) =
;179
- (new-long-array ((len jsize)) jlong-array) =
;180
- (new-float-array ((len jsize)) jfloat-array) =
;181
- (new-double-array ((len jsize)) jdouble-array) =
;182
-
- (get-boolean-array-elements ((array jboolean-array) =
;183
- (is-copy (:reference-return jboole=
an)))
- (:ptr jboolean)
- :lambda-list (array &optional is-co=
py))
- (get-byte-array-elements ((array jbyte-array) =
;184
- (is-copy (:reference-return jboolean)=
))
- (:ptr jbyte)
- :lambda-list (array &optional is-copy))
- (get-char-array-elements ((array jchar-array) =
;185
- (is-copy (:reference-return jboolean)=
))
- (:ptr jchar)
- :lambda-list (array &optional is-copy))
- (get-short-array-elements ((array jshort-array) =
;186
- (is-copy (:reference-return jboolean=
)))
- (:ptr jshort)
- :lambda-list (array &optional is-copy=
))
- (get-int-array-elements ((array jint-array) =
;187
- (is-copy (:reference-return jboolean)))
- (:ptr jint)
- :lambda-list (array &optional is-copy))
- (get-long-array-elements ((array jlong-array) =
;188
- (is-copy (:reference-return jboolean)=
))
- (:ptr jlong)
- :lambda-list (array &optional is-copy))
- (get-float-array-elements ((array jfloat-array) =
;189
- (is-copy (:reference-return jboolean=
)))
- (:ptr jfloat)
- :lambda-list (array &optional is-copy=
))
- (get-double-array-elements ((array jdouble-array) =
;190
- (is-copy (:reference-return jboolea=
n)))
- (:ptr jdouble)
- :lambda-list (array &optional is-cop=
y))
-
- (release-boolean-array-elements ((array jboolean-array) =
;191
- (elems (:ptr jboolean))
- (mode jint)) jvoid
- :lambda-list (array elems &opti=
onal (mode 0)))
- (release-byte-array-elements ((array jbyte-array) =
;192
- (elems (:ptr jbyte))
- (mode jint)) jvoid
- :lambda-list (array elems &optiona=
l (mode 0)))
- (release-char-array-elements ((array jchar-array) =
;193
- (elems (:ptr jchar))
- (mode jint)) jvoid
- :lambda-list (array elems &optiona=
l (mode 0)))
- (release-short-array-elements ((array jshort-array) =
;194
- (elems (:ptr jshort))
- (mode jint)) jvoid
- :lambda-list (array elems &option=
al (mode 0)))
- (release-int-array-elements ((array jint-array) =
;195
- (elems (:ptr jint))
- (mode jint)) jvoid
- :lambda-list (array elems &optional=
(mode 0)))
- (release-long-array-elements ((array jlong-array) =
;196
- (elems (:ptr jlong))
- (mode jint)) jvoid
- :lambda-list (array elems &optiona=
l (mode 0)))
- (release-float-array-elements ((array jfloat-array) =
;197
- (elems (:ptr jfloat))
- (mode jint)) jvoid
- :lambda-list (array elems &option=
al (mode 0)))
- (release-double-array-elements ((array jdouble-array) =
;198
- (elems (:ptr jdouble))
- (mode jint)) jvoid
- :lambda-list (array elems &optio=
nal (mode 0)))
-
- (get-boolean-array-region ((array jboolean-array) =
;199
- (start jsize)
- (len jsize)
- (buf (:ptr jboolean))) jvoid)
- (get-byte-array-region ((array jbyte-array) =
;200
- (start jsize)
- (len jsize)
- (buf (:ptr jbyte))) jvoid)
- (get-char-array-region ((array jchar-array) =
;201
- (start jsize)
- (len jsize)
- (buf (:ptr jchar))) jvoid)
- (get-short-array-region ((array jshort-array) =
;202
- (start jsize)
- (len jsize)
- (buf (:ptr jshort))) jvoid)
- (get-int-array-region ((array jint-array) =
;203
- (start jsize)
- (len jsize)
- (buf (:ptr jint))) jvoid)
- (get-long-array-region ((array jlong-array) =
;204
- (start jsize)
- (len jsize)
- (buf (:ptr jlong))) jvoid)
- (get-float-array-region ((array jfloat-array) =
;205
- (start jsize)
- (len jsize)
- (buf (:ptr jfloat))) jvoid)
- (get-double-array-region ((array jdouble-array) =
;206
- (start jsize)
- (len jsize)
- (buf (:ptr jdouble))) jvoid)
-
- (set-boolean-array-region ((array jboolean-array) =
;207
- (start jsize)
- (len jsize)
- (buf (:ptr jboolean))) jvoid)
- (set-byte-array-region ((array jbyte-array) =
;208
- (start jsize)
- (len jsize)
- (buf (:ptr jbyte))) jvoid)
- (set-char-array-region ((array jchar-array) =
;209
- (start jsize)
- (len jsize)
- (buf (:ptr jchar))) jvoid)
- (set-short-array-region ((array jshort-array) =
;210
- (start jsize)
- (len jsize)
- (buf (:ptr jshort))) jvoid)
- (set-int-array-region ((array jint-array) =
;211
- (start jsize)
- (len jsize)
- (buf (:ptr jint))) jvoid)
- (set-long-array-region ((array jlong-array) =
;212
- (start jsize)
- (len jsize)
- (buf (:ptr jlong))) jvoid)
- (set-float-array-region ((array jfloat-array) =
;213
- (start jsize)
- (len jsize)
- (buf (:ptr jfloat))) jvoid)
- (set-double-array-region ((array jdouble-array) =
;214
- (start jsize)
- (len jsize)
- (buf (:ptr jdouble))) jvoid)
-
- (register-natives ((clazz jclass) =
;215
- (methods (:ptr jni-native-method))
- (n-methods jsize)) jint)
- (unregister-natives ((clazz jclass)) jint) =
;216
- (monitor-enter ((obj jobject)) jint) =
;217
- (monitor-exit ((obj jobject)) jint) =
;218
-
- (get-java-vm ((vm (:reference-return pvm))) jint =
;219
- :lambda-list (&optional (vm t)))
-
- (get-string-region ((str jstring) =
;220
- (start jsize)
- (len jsize)
- (buf (:ptr jchar))) jvoid)
- (get-string-utf-region ((str jstring) =
;221
- (start jsize)
- (len jsize)
- (buf (:ptr :char))) jvoid)
-
- (get-primitive-array-critical ((array jarray) =
;222
- (is-copy (:reference-return jboo=
lean))) pvoid
- :lambda-list (array &optional is-=
copy))
- (release-primitive-array-critical ((array jarray) =
;223
- (carray pvoid)
- (mode jint)) jvoid
- :lambda-list (array carray &opt=
ional (mode 0)))
- =
- (get-string-critical ((str jstring) =
;224
- (is-copy (:reference-return jboolean)))
- (:ptr jchar)
- :lambda-list (str &optional is-copy))
- (release-string-critical ((str jstring) =
;225
- (cstring (:ptr jchar))) jvoid)
- (new-weak-global-ref ((obj jobject)) jweak) =
;226
- (delete-weak-global-ref ((ref jweak)) jvoid) =
;227
- (exception-check () jboolean) =
;228
- )
-
-(defun get-pvm ()
- (or *pvm*
- (error "JVM not loaded")))
-
-(defvtable java-vm (get-pvm)
- (reserved-0 pvoid)
- (reserved-1 pvoid)
- (reserved-2 pvoid)
-#+:MACOSX (cfm-padding (:foreign-array pvoid (4)))
- (destroy-java-vm () jint)
- (attach-current-thread ((penv (:reference-return penv)) (args pvoid)) ji=
nt
- :lambda-list (&optional args (penv t)))
- (detach-current-thread () jint)
- (get-env ((penv (:reference-return penv)) (interface-id jint)) jint
- :lambda-list (interface-id &optional (penv t))))
- =
-(fli:define-c-struct java-vm-option
- (option-string (:ptr :char))
- (extra-info pvoid))
-
-(fli:define-c-struct jdk-1-1-init-args
- (version jint)
- (properties (:ptr (:ptr char)))
- (check-source jint)
- (native-stack-size jint)
- (java-stack-size jint)
- (min-heap-size jint)
- (max-heap-size jint)
- (verify-mode jint)
- (class-path (:ptr :char))
- (vprintf pvoid)
- (exit pvoid)
- (abort pvoid)
- (enable-class-gc jint)
- (enable-verbose-gc jint)
- (disable-async-gc jint)
- (reserved-0 jint)
- (reserved-1 jint)
- (reserved-2 jint))
- =
-(fli:define-foreign-function (jni-get-default-java-vm-init-args "JNI_GetDe=
faultJavaVMInitArgs")
- ((init-args (:ptr jdk-1-1-init-args)))
- :result-type jint)
-
-(fli:define-c-struct java-vm-init-args
- (version jint)
- (n-options jint)
- (options (:ptr java-vm-option))
- (ignore-unrecognized jboolean))
-
-(fli:define-foreign-function (jni-create-java-vm "JNI_CreateJavaVM" :sourc=
e)
- ((pvm (:reference-return pvm))
- (penv (:reference-return penv))
- (vm-args (:ptr java-vm-init-args)))
- :result-type jint
- :lambda-list (vm-args &optional (pvm t) (penv t))
-; :module :jni-lib ;refused on Mac OSX, even though register-module is su=
pported
- )
-
-(fli:define-foreign-function (jni-get-created-java-vms "JNI_GetCreatedJava=
VMs" :source)
- ((vm-buf (:c-array pvm))
- (buf-len jsize)
- (n-vms (:reference-return jsize)))
- :result-type jint)
-
-(defun cleanup-jni-gref (gref)
- "set as a special free action to free java classes when no longer used b=
y Lisp"
- (when (java-ref-p gref)
- (delete-global-ref gref)))
-
-(defun create-jvm (&rest option-strings)
- "Creates the JVM, this can only be done once.
-The option strings can be used to control the JVM, esp. the classpath:
-\"-Djava.class.path=3D/Users/rich/Lisp/jfli.jar\""
- (when *pvm*
- (error "JVM already created, can only be started once"))
- (load-jni-lib)
- (let ((nopts (length option-strings))
- (option-array nil))
- (fli:with-dynamic-foreign-objects ((ia java-vm-init-args))
- (when option-strings
- (setf option-array (fli:allocate-dynamic-foreign-object :type 'jav=
a-vm-option :nelems nopts))
- (dotimes (n nopts)
- (setf (fli:foreign-slot-value (fli:dereference option-array
- :index n
- :copy-foreign-obj=
ect nil) 'option-string)
- (fli:convert-to-dynamic-foreign-string (nth n option-strin=
gs)))))
- (fli:with-foreign-slots (VERSION N-OPTIONS OPTIONS IGNORE-UNRECOGNIZ=
ED) ia
- (setf version JNI-VERSION-1-4
- n-options nopts
- OPTIONS option-array
- IGNORE-UNRECOGNIZED nil)
- (multiple-value-bind (ret vm env)
- (jni-create-java-vm ia)
- (setf *pvm* vm)
- (add-special-free-action #'cleanup-jni-gref)
- (values ret vm env))))))
-
-;this is the FLI side of proxy support
-
-(defvar *invocation-handler* nil
- "this will be set by jfli:enable-java-proxies to a function of 3 args")
-
-;this will be set as the implementation of a native java function
-(fli:define-foreign-callable ("LispInvocationHandler_invoke" :result-type =
jobject)
- ((env penv) (obj jobject) (proxy jobject) (method jobject) (args jobje=
ct))
- (do-invoke env obj proxy method args))
-
-(defun do-invoke (env obj proxy method args)
- ;(declare (ignore env))
- (when *invocation-handler*
- (let ((*penv* env))
- (prog1
- (funcall *invocation-handler* proxy method args)
- ;(jfli::invocation-handler proxy method args)
- (delete-local-ref obj)))))
-
-(defun register-invocation-handler (invocation-handler)
- "sets up the Lisp handler and binds the native function - jfli.jar must =
be in the classpath"
- (setf *invocation-handler* invocation-handler)
- (fli:with-dynamic-foreign-objects ((method jni-native-method))
- (let ((lih (try-null (jni-find-class "com/richhickey/jfli/LispInvocati=
onHandler"))))
- (fli:with-foreign-slots (name signature fn-ptr) method
- (setf name (fli:convert-to-dynamic-foreign-string "invoke")
- signature (fli:convert-to-dynamic-foreign-string "(Ljava/lan=
g/Object;Ljava/lang/reflect/Method;[Ljava/lang/Object;)Ljava/lang/Object;")
- fn-ptr (fli:make-pointer :symbol-name "LispInvocationHandler=
_invoke")))
- (register-natives lih method 1))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;the code below provides for the generation of wrapper functions that use =
JNI to access
-;methods and fields. This low-level interface is unsafe, in that JNI will =
not =
-;check arg types etc on calls, and therefore should only be used to build =
safer high-level interfaces
-;i.e. use jfli!
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;found on c.l.l
-(eval-when (:compile-toplevel :load-toplevel)
-(defun replace-substrings (string substring replacement)
- (declare (optimize (speed 3))
- (type simple-string string substring replacement))
- (assert (> (length substring) 0) (substring)
- "Substring ~A must be of length ~D > 0"
- substring (length substring))
- (with-output-to-string (stream)
- (loop with substring-length =3D (length substring)
- for index =3D 0 then (+ match-index substring-length)
- for match-index =3D (search substring string :start2 index)
- do
- (write-string string stream :start index :end match-index)
- (when match-index
- (write-string replacement stream))
- while match-index)))
-
-
-(defun local-ref-to-global-ref (lref)
- (when lref
- (let ((gref (new-global-ref lref)))
- (flag-special-free-action gref)
- (delete-local-ref lref)
- gref)))
-
-(defun local-ref-to-string (lref)
- (prog1
- (convert-from-java-string lref)
- (delete-local-ref lref)))
-
-(defun convert-to-java-string (s)
- (when s
- (try-null (new-string-utf (string s)))))
-
-(defun convert-from-java-string (s)
- (when s
- (let ((chars (try-null (get-string-utf-chars s))))
- (prog1
- (fli:convert-from-foreign-string chars :external-format :utf-8)
- (release-string-utf-chars s chars)))))
-
-(defun jaref (array index)
- (try (get-object-array-element array index)))
-
-(defun (setf jaref) (val array index)
- (try (set-object-array-element array index val)))
-
-(defun convert-string-arg (s)
- "if s is stringp, make into java string, else presume it is a java strin=
g and return it"
- ;presumably faster than checking if s is a foreign pointer?
- (if (or (stringp s) (symbolp s))
- (convert-to-java-string s)
- s))
-
-(defun process-arg (val type)
- (if (string-equal "java.lang.String" type)
- `(convert-string-arg ,val)
- val))
-
-(defmacro set-arg (args i val type)
- `(setf (fli:foreign-slot-value (fli:dereference (fli:foreign-array-point=
er ,args ,i)
- :copy-foreign-object =
nil)
- ',(slot-from-typename type))
- ,(process-arg val type)))
-
-(defmacro with-arg-array (arg-array-name args &body body)
- (let ((i -1))
- `(fli:with-dynamic-foreign-objects ()
- (let ((,arg-array-name
- (fli:allocate-dynamic-foreign-object :type
- '(:c-array jvalue ,(lengt=
h args)))))
- ,@(mapcar #'(lambda (arg)
- (list 'set-arg arg-array-name (incf i) (first arg) (s=
econd arg))) =
- args)
-
- , at body))))
-
-(defun build-descriptor (params return-type)
- (string-append
- "("
- (apply #'string-append (mapcar #'(lambda (p)
- (type-descriptor-from-typename (seco=
nd p)))
- params))
- ")"
- (type-descriptor-from-typename return-type)))
-
-(defun get-class-and-method-id (class-name method-name descriptor is-stati=
c)
- (let ((class (local-ref-to-global-ref
- (try-null (jni-find-class class-name)))))
- (values class
- (if is-static
- (try-null (get-static-method-id class method-name descript=
or))
- (try-null (get-method-id class method-name descriptor))))))
-
-
-(defun get-class-and-field-id (class-name field-name descriptor is-static)
- (let ((class (local-ref-to-global-ref
- (try-null (jni-find-class class-name)))))
- (values class
- (if is-static
- (try-null (get-static-field-id class field-name descriptor=
))
- (try-null (get-field-id class field-name descriptor))))))
-
-(defun is-name-of-primitive (s)
- (member s '("boolean" "byte" "char" "short" "int" "long" "float" "double=
" "void")
- :test #'string-equal))
-
-(defun package-qualified-name (classname packagename)
- (cond
- ((is-name-of-primitive (subseq classname 0 (position #\< classname))) c=
lassname)
- ((find #\. classname) classname) ;already qualified, presumably by =
another package
- (t (string-append packagename "." classname)))) =
-
-(defun split-package-and-class (name)
- (let ((p (position #\. name :from-end t)))
- (unless p (error "must supply package-qualified classname"))
- (values (subseq name 0 p)
- (subseq name (1+ p)))))
-
-(defun slot-from-typename (tn)
- (let ((prim (assoc tn
- '(("boolean" . :z)
- ("byte" . :b)
- ("char" . :c)
- ("short" . :s)
- ("int" . :i)
- ("long" . :j)
- ("float" . :f)
- ("double" . :d))
- :test #'string-equal)))
- (if prim
- (rest prim)
- :l)))
-
-(defun name-component-from-typename (tn)
- (if (is-name-of-primitive tn)
- tn
- "object"))
-
-(defun type-descriptor-from-typename (tn)
- (let ((prim (assoc tn
- '(("boolean" . "Z")
- ("byte" . "B")
- ("char" . "C")
- ("short" . "S")
- ("int" . "I")
- ("long" . "J")
- ("float" . "F")
- ("double" . "D")
- ("void" . "V"))
- :test #'string-equal)))
- (if prim
- (rest prim)
- (let ((array-depth (count #\< tn))
- (tn-with-slashes (replace-substrings tn "." "/")))
- (if (=3D 0 array-depth)
- (string-append "L" tn-with-slashes ";")
- (with-output-to-string (s)
- (dotimes (x array-depth)
- (write-string "[" s))
- (write-string (type-descriptor-from-typename
- (subseq tn-with-slashes 0 (position #\< tn-with=
-slashes))) s)))))))
-
-;not an exact reciprocal of type-descriptor-from-typename since reflection=
uses . not / as separator
-(defun typename-from-reflection-type-descriptor (tn)
- (let ((prim (assoc tn
- '(("Z" . "boolean")
- ("B" . "byte")
- ("C" . "char")
- ("S" . "short")
- ("I" . "int")
- ("J" . "long")
- ("F" . "float")
- ("D" . "double")
- ("V" . "void"))
- :test #'string-equal)))
- (if prim
- (rest prim)
- (let ((array-depth (count #\[ tn)))
- (if (=3D 0 array-depth)
- (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ;
- (with-output-to-string (s)
- (write-string (typename-from-reflection-type-descriptor (subse=
q tn array-depth)) s)
- (dotimes (x array-depth)
- (write-string "<>" s))))))))
-
-(defun method-name-from-typename (tn static)
- (find-symbol (string-upcase (string-append "call-"
- (if static "static-" "")
- (name-component-from-typename=
tn)
- "-method-a")) :jni))
-
-(defun field-get-name-from-typename (tn static)
- (find-symbol (string-upcase (string-append "get-"
- (if static "static-" "")
- (name-component-from-typename=
tn)
- "-field")) :jni))
-
-(defun field-set-name-from-typename (tn static)
- (find-symbol (string-upcase (string-append "set-"
- (if static "static-" "")
- (name-component-from-typename=
tn)
- "-field")) :jni))
-(defun process-return (return-type f &key raw-return)
- (cond
- ((or raw-return (is-name-of-primitive return-type)) f)
- ((string-equal "java.lang.String" return-type) `(local-ref-to-string ,f=
))
- (t `(local-ref-to-global-ref ,f))))
-
-;JNI wrapper generators - will create functions in current package
-;this needs more docs
-(defmacro define-java-function (fname class-name return-type method-name p=
arams &key static raw-return)
- (let ((this (gensym))
- (class (gensym))
- (id (gensym))
- (args (gensym)))
- `(let (,class ,id)
- (defun ,fname ,(if static (mapcar #'first params)
- (cons this (mapcar #'first params)))
- (when (null ,class)
- (multiple-value-setq (,class ,id)
- (get-class-and-method-id ,(replace-substrings class-name ".=
" "/")
- ,method-name ,(build-descriptor pa=
rams return-type) ,static)))
- (with-arg-array ,args ,(mapcar #'(lambda (param)
- (list (first param) (second par=
am)))
- params)
- ,(process-return return-type
- `(try (,(method-name-from-typename return-type=
static)
- ,(if static class this) ,id ,args))
- :raw-return raw-return))))))
-
-(defmacro define-java-field (getname class-name field-type field-name &key=
static)
- (let ((this (gensym))
- (class (gensym))
- (id (gensym))
- (val (gensym)))
- `(let (,class ,id)
- (flet ((load-ids ()
- (when (null ,class)
- (multiple-value-setq (,class ,id)
- (get-class-and-field-id ,(replace-substrings class-n=
ame "." "/")
- ,field-name ,(type-descripto=
r-from-typename field-type)
- ,static)))))
- (defun ,getname ,(if static () (list this))
- (load-ids)
- ,(process-return field-type
- `(try (,(field-get-name-from-typename field-ty=
pe static)
- ,(if static class this) ,id))))
- (defun (setf ,getname) ,(if static (list val) (list this val))
- (load-ids)
- (try (,(field-set-name-from-typename field-type static)
- ,(if static class this) ,id ,(process-arg val field-type)=
))
- ,val)))))
-
-(defmacro define-java-constructor (fname class-name params)
- (let ((class (gensym))
- (id (gensym))
- (args (gensym)))
- `(let (,class ,id)
- (defun ,fname ,(mapcar #'first params)
- (when (null ,class)
- (multiple-value-setq (,class ,id)
- (get-class-and-method-id ,(replace-substrings class-name ".=
" "/")
- "<init>" ,(build-descriptor params=
"void") nil)))
- (with-arg-array ,args ,(mapcar #'(lambda (param)
- (list (first param) (second par=
am)))
- params)
- (local-ref-to-global-ref (try-null (new-object-a ,class ,id ,ar=
gs))))))))
-
-(defun make-func-name (class method params append-param-types)
- ;probably a format one-liner that can do this
- (let ((base (string-append class "." method)))
- (if append-param-types
- (string-append base
- (let ((param-types (mapcar #'second params)))
- (if param-types
- (string-append "<"
- (reduce #'(lambda (x y)
- (string-append x=
"-" y)) param-types)
- ">")
- "<>")))
- base)))
-
-;these just do some name twiddling before calling define-java-xxx above
-(defmacro def-jni-function (package-and-class method params return-typename
- &key static overloaded raw-=
return)
- (multiple-value-bind (package class) (split-package-and-class package-an=
d-class)
- (let* ((fname (make-func-name class method params overloaded))
- (fsym (read-from-string fname)))
- `(locally ,(list 'define-java-function
- fsym
- package-and-class
- (package-qualified-name return-typename package)
- method
- (mapcar #'(lambda (p)
- (list (first p) (package-qualified-name (=
second p) package)))
- params)
- :static static :raw-return raw-return)))))
-
-(defmacro def-jni-functions (package-and-class &rest decls)
- `(locally ,@(mapcar #'(lambda (decl)
- (list* 'def-jni-function package-and-class decl))
- decls)))
-
-(defmacro def-jni-constructor (package-and-class params &key overloaded)
- (multiple-value-bind (package class) (split-package-and-class package-an=
d-class)
- (let* ((fname (make-func-name class "new" params overloaded))
- (fsym (read-from-string fname)))
- `(locally ,(list 'define-java-constructor
- fsym =
- package-and-class =
- (mapcar #'(lambda (p)
- (list (first p) (package-qualified-name (=
second p) package)))
- params))))))
-
-(defmacro def-jni-field (package-and-class field typename &key static)
- (multiple-value-bind (package class) (split-package-and-class package-an=
d-class)
- (let ((getsym (read-from-string (string-append class "." field
- (if static "-accessor" =
""))))
- (macsym (read-from-string (string-append class "." field))))
- `(locally =
- ,(list 'define-java-field getsym package-and-class
- (package-qualified-name typename package) field :static st=
atic)
- ,(when static
- `(define-symbol-macro ,macsym (,getsym)))))))
-
-;we're going to use a little Java to do exception handling below
-(def-jni-function "java.lang.Object"
- "toString" () "String")
-
-(def-jni-function "java.lang.reflect.InvocationTargetException"
- "getTargetException" () "java.lang.Throwable")
-
-(def-jni-functions "java.lang.Throwable"
- ("getMessage" () "String")
- ("getStackTrace" () "StackTraceElement<>"))
-
-(defmacro do-jarray ((x array) &body body)
- (let ((gcount (gensym))
- (gi (gensym))
- (garray (gensym)))
- `(let* ((,garray ,array)
- (,gcount (get-array-length ,garray)))
- (dotimes (,gi ,gcount)
- (let ((,x (jaref ,garray ,gi)))
- , at body)))))
-
-#|
-It is critical that if you call a JNI function that might throw an excepti=
on that you clear it,
-otherwise the next Java call you make will cause a crash
-|#
-(defun handle-exception ()
- (let ((e (exception-occurred)))
- (when (not (fli:null-pointer-p e)) ;allow for safe calling in non-exce=
ptional state
- (exception-clear)
- ;if the exception occurs in the reflection target, we really want th=
at
- (when (is-instance-of e (jni-find-class "java/lang/reflect/Invocatio=
nTargetException"))
- (setf e (invocationtargetexception.gettargetexception e)))
- (error "~A" (with-output-to-string (s)
- (format s "~A~%" (object.tostring e))
- (do-jarray (x (throwable.getstacktrace e))
- (format s "~A~%" (object.tostring x))))))))
-
-(defun try (result)
- (if (exception-check)
- (handle-exception)
- result))
-
-;JNI will sometimes indicate theere is an exception via a return value
-;so take advantage of that when possible vs. the call back to exception-ch=
eck
-(defun try-null (result)
- (if (fli:null-pointer-p result)
- (handle-exception)
- result))
-
-(defun try-neg (result)
- (if (minusp result)
- (handle-exception)
- result))
-
-
-)
-
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
+; which can be found in the file CPL.TXT at the root of this distributi=
on.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+#|
+This is a straight wrapper around the JNI API
+Originally I intended to expose this API directly, but it turns out
+that JNI is very sensitive to errors, and, given bad args, wrong types etc
+causes the JVM (and Lisp) to crash, not very much in the spirit of safe, r=
obust,
+interactive development offered by Lisp
+
+So, now this just forms the substrate under jfli, which uses the Reflectio=
n API, and is much
+more robust and error tolerant, at some cost in speed I guess.
+
+Bottom line is you shouldn't be using this API directly unless you are ext=
ending jfli,
+and then you must take care not to allow bad end-user data to pass through=
to JNI. =
+
+Caveat emptor.
+
+I have tried to limit LispWorks FLI code to this file.
+|#
+
+(defpackage :jni
+ (:export
+ :*jni-lib-path*
+ :*pvm*
+ :*penv*
+ :register-invocation-handler
+ :create-jvm
+ :JNI-VERSION-1-2
+ :JNI-VERSION-1-4
+ :JNI-OK
+ :java-ref
+ :jvoid :jboolean :jbyte :jchar :jshort :jint :jlong :jfloat :jdouble :j=
size
+ :jobject :jclass :jthrowable :jstring :jarray
+ :jboolean-array :jbyte-array :jchar-array :jshort-array :jint-array :jl=
ong-array
+ :jfloat-array :jdouble-array :jobject-array
+ :jfield-id :jmethod-id :jweak
+ :pvm :penv
+ :jvalue
+ :arg-array
+ :jni-native-method :jni-env
+ :java-vm :java-vm-option :jdk-1-1-init-args
+ :jni-get-default-java-vm-init-args :java-vm-inits-args
+ :jni-create-java-vm :jni-get-created-java-vms
+ :try :try-null :try-neg
+ :local-ref-to-global-ref :local-ref-to-string
+ :def-jni-function :def-jni-functions :def-jni-constructor :def-jni-field
+ :jaref :convert-to-java-string :convert-from-java-string :java-ref-p
+ :is-name-of-primitive :split-package-and-class))
+
+(in-package :jni)
+
+(defvar *jni-lib-path*
+#+:MACOSX "/System/Library/Frameworks/JavaVM.framework/JavaVM"
+#+:WIN32 "C:/j2sdk1.4.2_01/jre/bin/client/jvm.dll"
+"Set this to point to your jvm dll prior to calling create-jvm")
+
+(defparameter *pvm* nil)
+(defparameter *penv* nil)
+
+(defparameter *process-envs* nil)
+
+(defconstant JNI-VERSION-1-2 #X10002)
+(defconstant JNI-VERSION-1-4 #X10004)
+(defconstant JNI-OK 0)
+
+(defun load-jni-lib (&optional (libpath *jni-lib-path*))
+ (fli:register-module :jni-lib
+ :real-name libpath
+ :connection-style :immediate))
+
+(fli:define-c-typedef pvoid (:ptr :void))
+(fli:define-c-typedef const-char-* (:reference-pass :ef-mb-string))
+(fli:define-c-typedef const-jchar-* (:reference-pass :ef-wc-string))
+(fli:define-foreign-pointer (java-ref (:allow-null t) (:predicate java-ref=
-p)) pvoid)
+
+(fli:define-c-typedef jvoid :void)
+(fli:define-c-typedef jboolean (:boolean (:unsigned :byte)))
+(fli:define-c-typedef jbyte :byte)
+(fli:define-c-typedef jchar :wchar-t)
+(fli:define-c-typedef jshort :short)
+(fli:define-c-typedef jint :int)
+(fli:define-c-typedef jlong :long-long)
+(fli:define-c-typedef jfloat :float)
+(fli:define-c-typedef jdouble :double)
+(fli:define-c-typedef jsize jint)
+(fli:define-c-typedef jobject java-ref)
+(fli:define-c-typedef jclass java-ref)
+(fli:define-c-typedef jthrowable java-ref)
+(fli:define-c-typedef jstring java-ref)
+(fli:define-c-typedef jarray java-ref)
+(fli:define-c-typedef jboolean-array java-ref)
+(fli:define-c-typedef jbyte-array java-ref)
+(fli:define-c-typedef jchar-array java-ref)
+(fli:define-c-typedef jshort-array java-ref)
+(fli:define-c-typedef jint-array java-ref)
+(fli:define-c-typedef jlong-array java-ref)
+(fli:define-c-typedef jfloat-array java-ref)
+(fli:define-c-typedef jdouble-array java-ref)
+(fli:define-c-typedef jobject-array java-ref)
+(fli:define-c-typedef jfield-id pvoid)
+(fli:define-c-typedef jmethod-id pvoid)
+(fli:define-c-typedef jweak java-ref)
+
+(fli:define-c-typedef pvm (:ptr (:ptr java-vm)))
+(fli:define-c-typedef penv (:ptr (:ptr jni-env)))
+(fli:define-foreign-type pfunc (&rest fargs)
+ `(:ptr (:function , at fargs)))
+
+(fli:define-c-union jvalue
+ (:z jboolean)
+ (:b jbyte)
+ (:c jchar)
+ (:s jshort)
+ (:i jint)
+ (:j jlong)
+ (:f jfloat)
+ (:d jdouble)
+ (:l jobject))
+
+(fli:define-c-typedef arg-array (:c-array jvalue))
+
+(eval-when (:compile-toplevel)
+ (defun build-struct-entries (name members)
+ (mapcar #'(lambda (member)
+ (if (=3D 2 (length member)) ;padding or other non-function=
entry
+ member
+ (destructuring-bind (func args ret &key lambda-list) mem=
ber
+ (declare (ignore lambda-list))
+ `(,func (pfunc ,(cons `(:ptr (:ptr ,name))
+ (mapcar #'second args))
+ ,ret)))))
+ members)))
+
+(eval-when (:compile-toplevel)
+ (defun build-access-functions (name global members)
+ (mapcar #'(lambda (member)
+ (if (=3D 2 (length member)) ;padding or other non-function=
entry
+ ()
+ (destructuring-bind (func args ret &key lambda-list) mem=
ber
+ (let ((thunk (intern (concatenate 'string (symbol-name=
func) "-thunk")))
+ (genv (gensym))
+ ;(func (intern (symbol-name f)))
+ )
+ `(locally
+ (fli:define-foreign-funcallable
+ ,thunk
+ ,(cons `(this (:ptr (:ptr ,name))) args)
+ :result-type ,ret)
+ (defun ,func ,(if lambda-list
+ lambda-list
+ (mapcar #'first args))
+ (let ((,genv ,global))
+ (,thunk
+ (fli:foreign-slot-value (fli:dereference ,ge=
nv) ',func)
+ ,genv
+ ,@(mapcar #'first args))))
+ (export ',func))))))
+ members)))
+
+(defmacro defvtable (name global &rest members)
+ `(locally
+ (fli:define-c-struct ,name ,@(build-struct-entries name members))
+ ,@(build-access-functions name global members)))
+
+(fli:define-c-struct jni-native-method
+ (name (:ptr :char))
+ (signature (:ptr :char))
+ (fn-ptr pvoid)
+ )
+
+(defun current-env ()
+ "memoizes attach-current-thread per process"
+ (or
+ *penv*
+ (cdr (assoc mp:*current-process* *process-envs*))
+ (multiple-value-bind (ret env) (attach-current-thread)
+ (declare (ignore ret))
+ (push (cons mp:*current-process* env) *process-envs*)
+ env)))
+
+(defvtable jni-env (current-env)
+ (reserved-0 pvoid) =
;0
+ (reserved-1 pvoid) =
;1
+ (reserved-2 pvoid) =
;2
+ (reserved-3 pvoid) =
;3
+ ;some mac nonsense requires this non-portable padding, so much for a bin=
ary spec
+ #+:MACOSX (cfm-padding (:foreign-array pvoid (225)))
+ (get-version () jint) =
;4
+ (define-class ((name const-char-*) =
;5
+ (loader jobject)
+ (buf (:ptr jbyte))
+ (len jsize)) jclass) =
+ (jni-find-class ((name const-char-*)) jclass) =
;6
+ (from-reflected-method ((method jobject)) jmethod-id) =
;7
+ (from-reflected-field ((field jobject)) jfield-id) =
;8
+ (to-reflected-method ((cls jclass) =
;9
+ (method-id jmethod-id)
+ (is-static jboolean)) jobject)
+ (get-superclass ((clazz jclass)) jclass) =
;10
+ (is-assignable-from ((sub jclass) =
;11
+ (sup jclass)) jboolean)
+ (to-reflected-field ((cls jclass) =
;12
+ (field-id jfield-id)
+ (is-static jboolean)) jobject)
+ (jni-throw ((obj jthrowable)) jint) =
;13
+ (throw-new ((clazz jclass) =
;14
+ (msg const-char-*)) jint)
+ (exception-occurred () jthrowable) =
;15
+ (exception-describe () :void) =
;16
+ (exception-clear () :void) =
;17
+ (fatal-error ((msg const-char-*)) :void) =
;18
+ (push-local-frame ((capacity jint)) jint) =
;19
+ (pop-local-frame ((result jobject)) jobject) =
;20
+ (new-global-ref ((lobj jobject)) jobject) =
;21
+ (delete-global-ref ((gref jobject)) :void) =
;22
+ (delete-local-ref ((lref jobject)) :void) =
;23
+ (is-same-object ((obj1 jobject) =
;24
+ (obj2 jobject)) jboolean)
+ (new-local-ref ((ref jobject)) jobject) =
;25
+ (ensure-local-capacity ((capacity jint)) jint) =
;26
+ (alloc-object ((clazz jclass)) jobject) =
;27
+ (new-object pvoid) =
;28
+ (new-object-v pvoid) =
;29
+ (new-object-a ((clazz jclass) =
;30
+ (method-id jmethod-id)
+ (args arg-array)) jobject)
+ (get-object-class ((obj jobject)) jclass) =
;31
+ (is-instance-of ((obj jobject) =
;32
+ (clazz jclass)) jboolean)
+ (get-method-id ((clazz jclass) =
;33
+ (name const-char-*)
+ (sig const-char-*)) jmethod-id)
+
+ (call-object-method pvoid) =
;34
+ (call-object-method-v pvoid) =
;35
+ (call-object-method-a ((obj jobject) =
;36
+ (method-id jmethod-id)
+ (args arg-array)) jobject)
+ (call-boolean-method pvoid) =
;37
+ (call-boolean-method-v pvoid) =
;38
+ (call-boolean-method-a ((obj jobject) =
;39
+ (method-id jmethod-id) =
+ (args arg-array)) jboolean)
+ (call-byte-method pvoid) =
;40
+ (call-byte-method-v pvoid) =
;41
+ (call-byte-method-a ((obj jobject) =
;42
+ (method-id jmethod-id)
+ (args arg-array)) jbyte)
+ (call-char-method pvoid) =
;43
+ (call-char-method-v pvoid) =
;44
+ (call-char-method-a ((obj jobject) =
;45
+ (method-id jmethod-id)
+ (args arg-array)) jchar)
+ (call-short-method pvoid) =
;46
+ (call-short-method-v pvoid) =
;47
+ (call-short-method-a ((obj jobject) =
;48
+ (method-id jmethod-id)
+ (args arg-array)) jshort)
+ (call-int-method pvoid) =
;49
+ (call-int-method-v pvoid) =
;50
+ (call-int-method-a ((obj jobject) =
;51
+ (method-id jmethod-id)
+ (args arg-array)) jint)
+ (call-long-method pvoid) =
;52
+ (call-long-method-v pvoid) =
;53
+ (call-long-method-a ((obj jobject) =
;54
+ (method-id jmethod-id)
+ (args arg-array)) jlong)
+ (call-float-method pvoid) =
;55
+ (call-float-method-v pvoid) =
;56
+ (call-float-method-a ((obj jobject) =
;57
+ (method-id jmethod-id)
+ (args arg-array)) jfloat)
+ (call-double-method pvoid) =
;58
+ (call-double-method-v pvoid) =
;59
+ (call-double-method-a ((obj jobject) =
;60
+ (method-id jmethod-id)
+ (args arg-array)) jdouble)
+ (call-void-method pvoid) =
;61
+ (call-void-method-v pvoid) =
;62
+ (call-void-method-a ((obj jobject) =
;63
+ (method-id jmethod-id)
+ (args arg-array)) jvoid)
+
+ (call-nonvirtual-object-method pvoid) =
;64
+ (call-nonvirtual-object-method-v pvoid) =
;65
+ (call-nonvirtual-object-method-a ((obj jobject) =
;66
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jobject)
+ (call-nonvirtual-boolean-method pvoid) =
;67
+ (call-nonvirtual-boolean-method-v pvoid) =
;68
+ (call-nonvirtual-boolean-method-a ((obj jobject) =
;69
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jboolean)
+ (call-nonvirtual-byte-method pvoid) =
;70
+ (call-nonvirtual-byte-method-v pvoid) =
;71
+ (call-nonvirtual-byte-method-a ((obj jobject) =
;72
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jbyte)
+ (call-nonvirtual-char-method pvoid) =
;73
+ (call-nonvirtual-char-method-v pvoid) =
;74
+ (call-nonvirtual-char-method-a ((obj jobject) =
;75
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jchar)
+ (call-nonvirtual-short-method pvoid) =
;76
+ (call-nonvirtual-short-method-v pvoid) =
;77
+ (call-nonvirtual-short-method-a ((obj jobject) =
;78
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jshort)
+ (call-nonvirtual-int-method pvoid) =
;79
+ (call-nonvirtual-int-method-v pvoid) =
;80
+ (call-nonvirtual-int-method-a ((obj jobject) =
;81
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jint)
+ (call-nonvirtual-long-method pvoid) =
;82
+ (call-nonvirtual-long-method-v pvoid) =
;83
+ (call-nonvirtual-long-method-a ((obj jobject) =
;84
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jlong)
+ (call-nonvirtual-float-method pvoid) =
;85
+ (call-nonvirtual-float-method-v pvoid) =
;86
+ (call-nonvirtual-float-method-a ((obj jobject) =
;87
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jfloat)
+ (call-nonvirtual-double-method pvoid) =
;88
+ (call-nonvirtual-double-method-v pvoid) =
;89
+ (call-nonvirtual-double-method-a ((obj jobject) =
;90
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jdouble)
+ (call-nonvirtual-void-method pvoid) =
;91
+ (call-nonvirtual-void-method-v pvoid) =
;92
+ (call-nonvirtual-void-method-a ((obj jobject) =
;93
+ (clazz jclass)
+ (method-id jmethod-id)
+ (args arg-array)) jvoid)
+ (get-field-id ((clazz jclass) =
;94
+ (name const-char-*)
+ (sig const-char-*)) jfield-id)
+
+ (get-object-field ((obj jobject) =
;95
+ (field-id jfield-id)) jobject)
+ (get-boolean-field ((obj jobject) =
;96
+ (field-id jfield-id)) jboolean) =
+ (get-byte-field ((obj jobject) =
;97
+ (field-id jfield-id)) jbyte) =
+ (get-char-field ((obj jobject) =
;98
+ (field-id jfield-id)) jchar) =
+ (get-short-field ((obj jobject) =
;99
+ (field-id jfield-id)) jshort) =
+ (get-int-field ((obj jobject) =
;100
+ (field-id jfield-id)) jint) =
+ (get-long-field ((obj jobject) =
;101
+ (field-id jfield-id)) jlong) =
+ (get-float-field ((obj jobject) =
;102
+ (field-id jfield-id)) jfloat) =
+ (get-double-field ((obj jobject) =
;103
+ (field-id jfield-id)) jdouble) =
+
+ (set-object-field ((obj jobject) =
;104
+ (field-id jfield-id)
+ (val jobject)) jvoid)
+ (set-boolean-field ((obj jobject) =
;105
+ (field-id jfield-id)
+ (val jboolean)) jvoid)
+ (set-byte-field ((obj jobject) =
;106
+ (field-id jfield-id)
+ (val jbyte)) jvoid)
+ (set-char-field ((obj jobject) =
;107
+ (field-id jfield-id)
+ (val jchar)) jvoid)
+ (set-short-field ((obj jobject) =
;108
+ (field-id jfield-id)
+ (val jshort)) jvoid)
+ (set-int-field ((obj jobject) =
;109
+ (field-id jfield-id)
+ (val jint)) jvoid)
+ (set-long-field ((obj jobject) =
;110
+ (field-id jfield-id)
+ (val jlong)) jvoid)
+ (set-float-field ((obj jobject) =
;111
+ (field-id jfield-id)
+ (val jfloat)) jvoid)
+ (set-double-field ((obj jobject) =
;112
+ (field-id jfield-id)
+ (val jdouble)) jvoid)
+
+ (get-static-method-id ((clazz jclass) =
;113
+ (name const-char-*)
+ (sig const-char-*)) jmethod-id)
+
+ (call-static-object-method pvoid) =
;114
+ (call-static-object-method-v pvoid) =
;115
+ (call-static-object-method-a ((clazz jclass) =
;116
+ (method-id jmethod-id)
+ (args arg-array)) jobject)
+ (call-static-boolean-method pvoid) =
;117
+ (call-static-boolean-method-v pvoid) =
;118
+ (call-static-boolean-method-a ((clazz jclass) =
;119
+ (method-id jmethod-id)
+ (args arg-array)) jboolean)
+ (call-static-byte-method pvoid) =
;120
+ (call-static-byte-method-v pvoid) =
;121
+ (call-static-byte-method-a ((clazz jclass) =
;122
+ (method-id jmethod-id)
+ (args arg-array)) jbyte)
+ (call-static-char-method pvoid) =
;123
+ (call-static-char-method-v pvoid) =
;124
+ (call-static-char-method-a ((clazz jclass) =
;125
+ (method-id jmethod-id)
+ (args arg-array)) jchar)
+ (call-static-short-method pvoid) =
;126
+ (call-static-short-method-v pvoid) =
;127
+ (call-static-short-method-a ((clazz jclass) =
;128
+ (method-id jmethod-id)
+ (args arg-array)) jshort)
+ (call-static-int-method pvoid) =
;129
+ (call-static-int-method-v pvoid) =
;130
+ (call-static-int-method-a ((clazz jclass) =
;131
+ (method-id jmethod-id)
+ (args arg-array)) jint)
+ (call-static-long-method pvoid) =
;132
+ (call-static-long-method-v pvoid) =
;133
+ (call-static-long-method-a ((clazz jclass) =
;134
+ (method-id jmethod-id)
+ (args arg-array)) jlong)
+ (call-static-float-method pvoid) =
;135
+ (call-static-float-method-v pvoid) =
;136
+ (call-static-float-method-a ((clazz jclass) =
;137
+ (method-id jmethod-id)
+ (args arg-array)) jfloat)
+ (call-static-double-method pvoid) =
;138
+ (call-static-double-method-v pvoid) =
;139
+ (call-static-double-method-a ((clazz jclass) =
;140
+ (method-id jmethod-id)
+ (args arg-array)) jdouble)
+ (call-static-void-method pvoid) =
;141
+ (call-static-void-method-v pvoid) =
;142
+ (call-static-void-method-a ((clazz jclass) =
;143
+ (method-id jmethod-id)
+ (args arg-array)) jvoid)
+
+ (get-static-field-id ((clazz jclass) =
;144
+ (name const-char-*)
+ (sig const-char-*)) jfield-id)
+
+ (get-static-object-field ((clazz jclass) =
;145
+ (field-id jfield-id)) jobject)
+ (get-static-boolean-field ((clazz jclass) =
;146
+ (field-id jfield-id)) jboolean)
+ (get-static-byte-field ((clazz jclass) =
;147
+ (field-id jfield-id)) jbyte)
+ (get-static-char-field ((clazz jclass) =
;148
+ (field-id jfield-id)) jchar)
+ (get-static-short-field ((clazz jclass) =
;149
+ (field-id jfield-id)) jshort)
+ (get-static-int-field ((clazz jclass) =
;150
+ (field-id jfield-id)) jint)
+ (get-static-long-field ((clazz jclass) =
;151
+ (field-id jfield-id)) jlong)
+ (get-static-float-field ((clazz jclass) =
;152
+ (field-id jfield-id)) jfloat)
+ (get-static-double-field ((clazz jclass) =
;153
+ (field-id jfield-id)) jdouble)
+
+ (set-static-object-field ((clazz jclass) =
;154
+ (field-id jfield-id)
+ (val jobject)) jvoid)
+ (set-static-boolean-field ((clazz jclass) =
;155
+ (field-id jfield-id)
+ (val jboolean)) jvoid)
+ (set-static-byte-field ((clazz jclass) =
;156
+ (field-id jfield-id)
+ (val jbyte)) jvoid)
+ (set-static-char-field ((clazz jclass) =
;157
+ (field-id jfield-id)
+ (val jchar)) jvoid)
+ (set-static-short-field ((clazz jclass) =
;158
+ (field-id jfield-id)
+ (val jshort)) jvoid)
+ (set-static-int-field ((clazz jclass) =
;159
+ (field-id jfield-id)
+ (val jint)) jvoid)
+ (set-static-long-field ((clazz jclass) =
;160
+ (field-id jfield-id)
+ (val jlong)) jvoid)
+ (set-static-float-field ((clazz jclass) =
;161
+ (field-id jfield-id)
+ (val jfloat)) jvoid)
+ (set-static-double-field ((clazz jclass) =
;162
+ (field-id jfield-id)
+ (val jdouble)) jvoid)
+
+ (new-string ((uchars (:reference-pass :ef-wc-string)) =
;163
+ (len jsize)) jstring)
+ (get-string-length ((str jstring)) jsize) =
;164
+ (get-string-chars ((str jstring) =
;165
+ (is-copy (:reference-return jboolean)))
+ ;(:c-array jchar 1000)
+ (:ptr :wchar-t)
+ ;(:ef-wc-string :external-format :unicode)
+ :lambda-list (str &optional is-copy))
+ (release-string-chars ((str jstring) =
;166
+ (chars (:ptr jchar))) jvoid)
+
+ (new-string-utf ((chars const-char-*)) jstring) =
;167
+ (get-string-utf-length ((str jstring)) jsize) =
;168
+ (get-string-utf-chars ((str jstring) =
;169
+ (is-copy (:reference-return jboolean)))
+ ;(:c-array :char 1000)
+ (:ptr :char)
+ :lambda-list (str &optional is-copy))
+ (release-string-utf-chars ((str jstring) =
;170
+ (chars (:ptr :char))) jvoid)
+
+ (get-array-length ((array jarray)) jsize) =
;171
+ =
+ (new-object-array ((len jsize) =
;172
+ (element-type jclass)
+ (initial-element jobject)) jarray)
+ (get-object-array-element ((array jobject-array) =
;173
+ (index jsize)) jobject)
+ (set-object-array-element ((array jobject-array) =
;174
+ (index jsize)
+ (val jobject)) jvoid)
+
+ (new-boolean-array ((len jsize)) jboolean-array) =
;175
+ (new-byte-array ((len jsize)) jbyte-array) =
;176
+ (new-char-array ((len jsize)) jchar-array) =
;177
+ (new-short-array ((len jsize)) jshort-array) =
;178
+ (new-int-array ((len jsize)) jint-array) =
;179
+ (new-long-array ((len jsize)) jlong-array) =
;180
+ (new-float-array ((len jsize)) jfloat-array) =
;181
+ (new-double-array ((len jsize)) jdouble-array) =
;182
+
+ (get-boolean-array-elements ((array jboolean-array) =
;183
+ (is-copy (:reference-return jboole=
an)))
+ (:ptr jboolean)
+ :lambda-list (array &optional is-co=
py))
+ (get-byte-array-elements ((array jbyte-array) =
;184
+ (is-copy (:reference-return jboolean)=
))
+ (:ptr jbyte)
+ :lambda-list (array &optional is-copy))
+ (get-char-array-elements ((array jchar-array) =
;185
+ (is-copy (:reference-return jboolean)=
))
+ (:ptr jchar)
+ :lambda-list (array &optional is-copy))
+ (get-short-array-elements ((array jshort-array) =
;186
+ (is-copy (:reference-return jboolean=
)))
+ (:ptr jshort)
+ :lambda-list (array &optional is-copy=
))
+ (get-int-array-elements ((array jint-array) =
;187
+ (is-copy (:reference-return jboolean)))
+ (:ptr jint)
+ :lambda-list (array &optional is-copy))
+ (get-long-array-elements ((array jlong-array) =
;188
+ (is-copy (:reference-return jboolean)=
))
+ (:ptr jlong)
+ :lambda-list (array &optional is-copy))
+ (get-float-array-elements ((array jfloat-array) =
;189
+ (is-copy (:reference-return jboolean=
)))
+ (:ptr jfloat)
+ :lambda-list (array &optional is-copy=
))
+ (get-double-array-elements ((array jdouble-array) =
;190
+ (is-copy (:reference-return jboolea=
n)))
+ (:ptr jdouble)
+ :lambda-list (array &optional is-cop=
y))
+
+ (release-boolean-array-elements ((array jboolean-array) =
;191
+ (elems (:ptr jboolean))
+ (mode jint)) jvoid
+ :lambda-list (array elems &opti=
onal (mode 0)))
+ (release-byte-array-elements ((array jbyte-array) =
;192
+ (elems (:ptr jbyte))
+ (mode jint)) jvoid
+ :lambda-list (array elems &optiona=
l (mode 0)))
+ (release-char-array-elements ((array jchar-array) =
;193
+ (elems (:ptr jchar))
+ (mode jint)) jvoid
+ :lambda-list (array elems &optiona=
l (mode 0)))
+ (release-short-array-elements ((array jshort-array) =
;194
+ (elems (:ptr jshort))
+ (mode jint)) jvoid
+ :lambda-list (array elems &option=
al (mode 0)))
+ (release-int-array-elements ((array jint-array) =
;195
+ (elems (:ptr jint))
+ (mode jint)) jvoid
+ :lambda-list (array elems &optional=
(mode 0)))
+ (release-long-array-elements ((array jlong-array) =
;196
+ (elems (:ptr jlong))
+ (mode jint)) jvoid
+ :lambda-list (array elems &optiona=
l (mode 0)))
+ (release-float-array-elements ((array jfloat-array) =
;197
+ (elems (:ptr jfloat))
+ (mode jint)) jvoid
+ :lambda-list (array elems &option=
al (mode 0)))
+ (release-double-array-elements ((array jdouble-array) =
;198
+ (elems (:ptr jdouble))
+ (mode jint)) jvoid
+ :lambda-list (array elems &optio=
nal (mode 0)))
+
+ (get-boolean-array-region ((array jboolean-array) =
;199
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jboolean))) jvoid)
+ (get-byte-array-region ((array jbyte-array) =
;200
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jbyte))) jvoid)
+ (get-char-array-region ((array jchar-array) =
;201
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jchar))) jvoid)
+ (get-short-array-region ((array jshort-array) =
;202
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jshort))) jvoid)
+ (get-int-array-region ((array jint-array) =
;203
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jint))) jvoid)
+ (get-long-array-region ((array jlong-array) =
;204
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jlong))) jvoid)
+ (get-float-array-region ((array jfloat-array) =
;205
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jfloat))) jvoid)
+ (get-double-array-region ((array jdouble-array) =
;206
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jdouble))) jvoid)
+
+ (set-boolean-array-region ((array jboolean-array) =
;207
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jboolean))) jvoid)
+ (set-byte-array-region ((array jbyte-array) =
;208
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jbyte))) jvoid)
+ (set-char-array-region ((array jchar-array) =
;209
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jchar))) jvoid)
+ (set-short-array-region ((array jshort-array) =
;210
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jshort))) jvoid)
+ (set-int-array-region ((array jint-array) =
;211
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jint))) jvoid)
+ (set-long-array-region ((array jlong-array) =
;212
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jlong))) jvoid)
+ (set-float-array-region ((array jfloat-array) =
;213
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jfloat))) jvoid)
+ (set-double-array-region ((array jdouble-array) =
;214
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jdouble))) jvoid)
+
+ (register-natives ((clazz jclass) =
;215
+ (methods (:ptr jni-native-method))
+ (n-methods jsize)) jint)
+ (unregister-natives ((clazz jclass)) jint) =
;216
+ (monitor-enter ((obj jobject)) jint) =
;217
+ (monitor-exit ((obj jobject)) jint) =
;218
+
+ (get-java-vm ((vm (:reference-return pvm))) jint =
;219
+ :lambda-list (&optional (vm t)))
+
+ (get-string-region ((str jstring) =
;220
+ (start jsize)
+ (len jsize)
+ (buf (:ptr jchar))) jvoid)
+ (get-string-utf-region ((str jstring) =
;221
+ (start jsize)
+ (len jsize)
+ (buf (:ptr :char))) jvoid)
+
+ (get-primitive-array-critical ((array jarray) =
;222
+ (is-copy (:reference-return jboo=
lean))) pvoid
+ :lambda-list (array &optional is-=
copy))
+ (release-primitive-array-critical ((array jarray) =
;223
+ (carray pvoid)
+ (mode jint)) jvoid
+ :lambda-list (array carray &opt=
ional (mode 0)))
+ =
+ (get-string-critical ((str jstring) =
;224
+ (is-copy (:reference-return jboolean)))
+ (:ptr jchar)
+ :lambda-list (str &optional is-copy))
+ (release-string-critical ((str jstring) =
;225
+ (cstring (:ptr jchar))) jvoid)
+ (new-weak-global-ref ((obj jobject)) jweak) =
;226
+ (delete-weak-global-ref ((ref jweak)) jvoid) =
;227
+ (exception-check () jboolean) =
;228
+ )
+
+(defun get-pvm ()
+ (or *pvm*
+ (error "JVM not loaded")))
+
+(defvtable java-vm (get-pvm)
+ (reserved-0 pvoid)
+ (reserved-1 pvoid)
+ (reserved-2 pvoid)
+#+:MACOSX (cfm-padding (:foreign-array pvoid (4)))
+ (destroy-java-vm () jint)
+ (attach-current-thread ((penv (:reference-return penv)) (args pvoid)) ji=
nt
+ :lambda-list (&optional args (penv t)))
+ (detach-current-thread () jint)
+ (get-env ((penv (:reference-return penv)) (interface-id jint)) jint
+ :lambda-list (interface-id &optional (penv t))))
+ =
+(fli:define-c-struct java-vm-option
+ (option-string (:ptr :char))
+ (extra-info pvoid))
+
+(fli:define-c-struct jdk-1-1-init-args
+ (version jint)
+ (properties (:ptr (:ptr char)))
+ (check-source jint)
+ (native-stack-size jint)
+ (java-stack-size jint)
+ (min-heap-size jint)
+ (max-heap-size jint)
+ (verify-mode jint)
+ (class-path (:ptr :char))
+ (vprintf pvoid)
+ (exit pvoid)
+ (abort pvoid)
+ (enable-class-gc jint)
+ (enable-verbose-gc jint)
+ (disable-async-gc jint)
+ (reserved-0 jint)
+ (reserved-1 jint)
+ (reserved-2 jint))
+ =
+(fli:define-foreign-function (jni-get-default-java-vm-init-args "JNI_GetDe=
faultJavaVMInitArgs")
+ ((init-args (:ptr jdk-1-1-init-args)))
+ :result-type jint)
+
+(fli:define-c-struct java-vm-init-args
+ (version jint)
+ (n-options jint)
+ (options (:ptr java-vm-option))
+ (ignore-unrecognized jboolean))
+
+(fli:define-foreign-function (jni-create-java-vm "JNI_CreateJavaVM" :sourc=
e)
+ ((pvm (:reference-return pvm))
+ (penv (:reference-return penv))
+ (vm-args (:ptr java-vm-init-args)))
+ :result-type jint
+ :lambda-list (vm-args &optional (pvm t) (penv t))
+; :module :jni-lib ;refused on Mac OSX, even though register-module is su=
pported
+ )
+
+(fli:define-foreign-function (jni-get-created-java-vms "JNI_GetCreatedJava=
VMs" :source)
+ ((vm-buf (:c-array pvm))
+ (buf-len jsize)
+ (n-vms (:reference-return jsize)))
+ :result-type jint)
+
+(defun cleanup-jni-gref (gref)
+ "set as a special free action to free java classes when no longer used b=
y Lisp"
+ (when (java-ref-p gref)
+ (delete-global-ref gref)))
+
+(defun create-jvm (&rest option-strings)
+ "Creates the JVM, this can only be done once.
+The option strings can be used to control the JVM, esp. the classpath:
+\"-Djava.class.path=3D/Users/rich/Lisp/jfli.jar\""
+ (when *pvm*
+ (error "JVM already created, can only be started once"))
+ (load-jni-lib)
+ (let ((nopts (length option-strings))
+ (option-array nil))
+ (fli:with-dynamic-foreign-objects ((ia java-vm-init-args))
+ (when option-strings
+ (setf option-array (fli:allocate-dynamic-foreign-object :type 'jav=
a-vm-option :nelems nopts))
+ (dotimes (n nopts)
+ (setf (fli:foreign-slot-value (fli:dereference option-array
+ :index n
+ :copy-foreign-obj=
ect nil) 'option-string)
+ (fli:convert-to-dynamic-foreign-string (nth n option-strin=
gs)))))
+ (fli:with-foreign-slots (VERSION N-OPTIONS OPTIONS IGNORE-UNRECOGNIZ=
ED) ia
+ (setf version JNI-VERSION-1-4
+ n-options nopts
+ OPTIONS option-array
+ IGNORE-UNRECOGNIZED nil)
+ (multiple-value-bind (ret vm env)
+ (jni-create-java-vm ia)
+ (setf *pvm* vm)
+ (add-special-free-action #'cleanup-jni-gref)
+ (values ret vm env))))))
+
+;this is the FLI side of proxy support
+
+(defvar *invocation-handler* nil
+ "this will be set by jfli:enable-java-proxies to a function of 3 args")
+
+;this will be set as the implementation of a native java function
+(fli:define-foreign-callable ("LispInvocationHandler_invoke" :result-type =
jobject)
+ ((env penv) (obj jobject) (proxy jobject) (method jobject) (args jobje=
ct))
+ (do-invoke env obj proxy method args))
+
+(defun do-invoke (env obj proxy method args)
+ ;(declare (ignore env))
+ (when *invocation-handler*
+ (let ((*penv* env))
+ (prog1
+ (funcall *invocation-handler* proxy method args)
+ ;(jfli::invocation-handler proxy method args)
+ (delete-local-ref obj)))))
+
+(defun register-invocation-handler (invocation-handler)
+ "sets up the Lisp handler and binds the native function - jfli.jar must =
be in the classpath"
+ (setf *invocation-handler* invocation-handler)
+ (fli:with-dynamic-foreign-objects ((method jni-native-method))
+ (let ((lih (try-null (jni-find-class "com/richhickey/jfli/LispInvocati=
onHandler"))))
+ (fli:with-foreign-slots (name signature fn-ptr) method
+ (setf name (fli:convert-to-dynamic-foreign-string "invoke")
+ signature (fli:convert-to-dynamic-foreign-string "(Ljava/lan=
g/Object;Ljava/lang/reflect/Method;[Ljava/lang/Object;)Ljava/lang/Object;")
+ fn-ptr (fli:make-pointer :symbol-name "LispInvocationHandler=
_invoke")))
+ (register-natives lih method 1))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;the code below provides for the generation of wrapper functions that use =
JNI to access
+;methods and fields. This low-level interface is unsafe, in that JNI will =
not =
+;check arg types etc on calls, and therefore should only be used to build =
safer high-level interfaces
+;i.e. use jfli!
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;found on c.l.l
+(eval-when (:compile-toplevel :load-toplevel)
+(defun replace-substrings (string substring replacement)
+ (declare (optimize (speed 3))
+ (type simple-string string substring replacement))
+ (assert (> (length substring) 0) (substring)
+ "Substring ~A must be of length ~D > 0"
+ substring (length substring))
+ (with-output-to-string (stream)
+ (loop with substring-length =3D (length substring)
+ for index =3D 0 then (+ match-index substring-length)
+ for match-index =3D (search substring string :start2 index)
+ do
+ (write-string string stream :start index :end match-index)
+ (when match-index
+ (write-string replacement stream))
+ while match-index)))
+
+
+(defun local-ref-to-global-ref (lref)
+ (when lref
+ (let ((gref (new-global-ref lref)))
+ (flag-special-free-action gref)
+ (delete-local-ref lref)
+ gref)))
+
+(defun local-ref-to-string (lref)
+ (prog1
+ (convert-from-java-string lref)
+ (delete-local-ref lref)))
+
+(defun convert-to-java-string (s)
+ (when s
+ (try-null (new-string-utf (string s)))))
+
+(defun convert-from-java-string (s)
+ (when s
+ (let ((chars (try-null (get-string-utf-chars s))))
+ (prog1
+ (fli:convert-from-foreign-string chars :external-format :utf-8)
+ (release-string-utf-chars s chars)))))
+
+(defun jaref (array index)
+ (try (get-object-array-element array index)))
+
+(defun (setf jaref) (val array index)
+ (try (set-object-array-element array index val)))
+
+(defun convert-string-arg (s)
+ "if s is stringp, make into java string, else presume it is a java strin=
g and return it"
+ ;presumably faster than checking if s is a foreign pointer?
+ (if (or (stringp s) (symbolp s))
+ (convert-to-java-string s)
+ s))
+
+(defun process-arg (val type)
+ (if (string-equal "java.lang.String" type)
+ `(convert-string-arg ,val)
+ val))
+
+(defmacro set-arg (args i val type)
+ `(setf (fli:foreign-slot-value (fli:dereference (fli:foreign-array-point=
er ,args ,i)
+ :copy-foreign-object =
nil)
+ ',(slot-from-typename type))
+ ,(process-arg val type)))
+
+(defmacro with-arg-array (arg-array-name args &body body)
+ (let ((i -1))
+ `(fli:with-dynamic-foreign-objects ()
+ (let ((,arg-array-name
+ (fli:allocate-dynamic-foreign-object :type
+ '(:c-array jvalue ,(lengt=
h args)))))
+ ,@(mapcar #'(lambda (arg)
+ (list 'set-arg arg-array-name (incf i) (first arg) (s=
econd arg))) =
+ args)
+
+ , at body))))
+
+(defun build-descriptor (params return-type)
+ (string-append
+ "("
+ (apply #'string-append (mapcar #'(lambda (p)
+ (type-descriptor-from-typename (seco=
nd p)))
+ params))
+ ")"
+ (type-descriptor-from-typename return-type)))
+
+(defun get-class-and-method-id (class-name method-name descriptor is-stati=
c)
+ (let ((class (local-ref-to-global-ref
+ (try-null (jni-find-class class-name)))))
+ (values class
+ (if is-static
+ (try-null (get-static-method-id class method-name descript=
or))
+ (try-null (get-method-id class method-name descriptor))))))
+
+
+(defun get-class-and-field-id (class-name field-name descriptor is-static)
+ (let ((class (local-ref-to-global-ref
+ (try-null (jni-find-class class-name)))))
+ (values class
+ (if is-static
+ (try-null (get-static-field-id class field-name descriptor=
))
+ (try-null (get-field-id class field-name descriptor))))))
+
+(defun is-name-of-primitive (s)
+ (member s '("boolean" "byte" "char" "short" "int" "long" "float" "double=
" "void")
+ :test #'string-equal))
+
+(defun package-qualified-name (classname packagename)
+ (cond
+ ((is-name-of-primitive (subseq classname 0 (position #\< classname))) c=
lassname)
+ ((find #\. classname) classname) ;already qualified, presumably by =
another package
+ (t (string-append packagename "." classname)))) =
+
+(defun split-package-and-class (name)
+ (let ((p (position #\. name :from-end t)))
+ (unless p (error "must supply package-qualified classname"))
+ (values (subseq name 0 p)
+ (subseq name (1+ p)))))
+
+(defun slot-from-typename (tn)
+ (let ((prim (assoc tn
+ '(("boolean" . :z)
+ ("byte" . :b)
+ ("char" . :c)
+ ("short" . :s)
+ ("int" . :i)
+ ("long" . :j)
+ ("float" . :f)
+ ("double" . :d))
+ :test #'string-equal)))
+ (if prim
+ (rest prim)
+ :l)))
+
+(defun name-component-from-typename (tn)
+ (if (is-name-of-primitive tn)
+ tn
+ "object"))
+
+(defun type-descriptor-from-typename (tn)
+ (let ((prim (assoc tn
+ '(("boolean" . "Z")
+ ("byte" . "B")
+ ("char" . "C")
+ ("short" . "S")
+ ("int" . "I")
+ ("long" . "J")
+ ("float" . "F")
+ ("double" . "D")
+ ("void" . "V"))
+ :test #'string-equal)))
+ (if prim
+ (rest prim)
+ (let ((array-depth (count #\< tn))
+ (tn-with-slashes (replace-substrings tn "." "/")))
+ (if (=3D 0 array-depth)
+ (string-append "L" tn-with-slashes ";")
+ (with-output-to-string (s)
+ (dotimes (x array-depth)
+ (write-string "[" s))
+ (write-string (type-descriptor-from-typename
+ (subseq tn-with-slashes 0 (position #\< tn-with=
-slashes))) s)))))))
+
+;not an exact reciprocal of type-descriptor-from-typename since reflection=
uses . not / as separator
+(defun typename-from-reflection-type-descriptor (tn)
+ (let ((prim (assoc tn
+ '(("Z" . "boolean")
+ ("B" . "byte")
+ ("C" . "char")
+ ("S" . "short")
+ ("I" . "int")
+ ("J" . "long")
+ ("F" . "float")
+ ("D" . "double")
+ ("V" . "void"))
+ :test #'string-equal)))
+ (if prim
+ (rest prim)
+ (let ((array-depth (count #\[ tn)))
+ (if (=3D 0 array-depth)
+ (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ;
+ (with-output-to-string (s)
+ (write-string (typename-from-reflection-type-descriptor (subse=
q tn array-depth)) s)
+ (dotimes (x array-depth)
+ (write-string "<>" s))))))))
+
+(defun method-name-from-typename (tn static)
+ (find-symbol (string-upcase (string-append "call-"
+ (if static "static-" "")
+ (name-component-from-typename=
tn)
+ "-method-a")) :jni))
+
+(defun field-get-name-from-typename (tn static)
+ (find-symbol (string-upcase (string-append "get-"
+ (if static "static-" "")
+ (name-component-from-typename=
tn)
+ "-field")) :jni))
+
+(defun field-set-name-from-typename (tn static)
+ (find-symbol (string-upcase (string-append "set-"
+ (if static "static-" "")
+ (name-component-from-typename=
tn)
+ "-field")) :jni))
+(defun process-return (return-type f &key raw-return)
+ (cond
+ ((or raw-return (is-name-of-primitive return-type)) f)
+ ((string-equal "java.lang.String" return-type) `(local-ref-to-string ,f=
))
+ (t `(local-ref-to-global-ref ,f))))
+
+;JNI wrapper generators - will create functions in current package
+;this needs more docs
+(defmacro define-java-function (fname class-name return-type method-name p=
arams &key static raw-return)
+ (let ((this (gensym))
+ (class (gensym))
+ (id (gensym))
+ (args (gensym)))
+ `(let (,class ,id)
+ (defun ,fname ,(if static (mapcar #'first params)
+ (cons this (mapcar #'first params)))
+ (when (null ,class)
+ (multiple-value-setq (,class ,id)
+ (get-class-and-method-id ,(replace-substrings class-name ".=
" "/")
+ ,method-name ,(build-descriptor pa=
rams return-type) ,static)))
+ (with-arg-array ,args ,(mapcar #'(lambda (param)
+ (list (first param) (second par=
am)))
+ params)
+ ,(process-return return-type
+ `(try (,(method-name-from-typename return-type=
static)
+ ,(if static class this) ,id ,args))
+ :raw-return raw-return))))))
+
+(defmacro define-java-field (getname class-name field-type field-name &key=
static)
+ (let ((this (gensym))
+ (class (gensym))
+ (id (gensym))
+ (val (gensym)))
+ `(let (,class ,id)
+ (flet ((load-ids ()
+ (when (null ,class)
+ (multiple-value-setq (,class ,id)
+ (get-class-and-field-id ,(replace-substrings class-n=
ame "." "/")
+ ,field-name ,(type-descripto=
r-from-typename field-type)
+ ,static)))))
+ (defun ,getname ,(if static () (list this))
+ (load-ids)
+ ,(process-return field-type
+ `(try (,(field-get-name-from-typename field-ty=
pe static)
+ ,(if static class this) ,id))))
+ (defun (setf ,getname) ,(if static (list val) (list this val))
+ (load-ids)
+ (try (,(field-set-name-from-typename field-type static)
+ ,(if static class this) ,id ,(process-arg val field-type)=
))
+ ,val)))))
+
+(defmacro define-java-constructor (fname class-name params)
+ (let ((class (gensym))
+ (id (gensym))
+ (args (gensym)))
+ `(let (,class ,id)
+ (defun ,fname ,(mapcar #'first params)
+ (when (null ,class)
+ (multiple-value-setq (,class ,id)
+ (get-class-and-method-id ,(replace-substrings class-name ".=
" "/")
+ "<init>" ,(build-descriptor params=
"void") nil)))
+ (with-arg-array ,args ,(mapcar #'(lambda (param)
+ (list (first param) (second par=
am)))
+ params)
+ (local-ref-to-global-ref (try-null (new-object-a ,class ,id ,ar=
gs))))))))
+
+(defun make-func-name (class method params append-param-types)
+ ;probably a format one-liner that can do this
+ (let ((base (string-append class "." method)))
+ (if append-param-types
+ (string-append base
+ (let ((param-types (mapcar #'second params)))
+ (if param-types
+ (string-append "<"
+ (reduce #'(lambda (x y)
+ (string-append x=
"-" y)) param-types)
+ ">")
+ "<>")))
+ base)))
+
+;these just do some name twiddling before calling define-java-xxx above
+(defmacro def-jni-function (package-and-class method params return-typename
+ &key static overloaded raw-=
return)
+ (multiple-value-bind (package class) (split-package-and-class package-an=
d-class)
+ (let* ((fname (make-func-name class method params overloaded))
+ (fsym (read-from-string fname)))
+ `(locally ,(list 'define-java-function
+ fsym
+ package-and-class
+ (package-qualified-name return-typename package)
+ method
+ (mapcar #'(lambda (p)
+ (list (first p) (package-qualified-name (=
second p) package)))
+ params)
+ :static static :raw-return raw-return)))))
+
+(defmacro def-jni-functions (package-and-class &rest decls)
+ `(locally ,@(mapcar #'(lambda (decl)
+ (list* 'def-jni-function package-and-class decl))
+ decls)))
+
+(defmacro def-jni-constructor (package-and-class params &key overloaded)
+ (multiple-value-bind (package class) (split-package-and-class package-an=
d-class)
+ (let* ((fname (make-func-name class "new" params overloaded))
+ (fsym (read-from-string fname)))
+ `(locally ,(list 'define-java-constructor
+ fsym =
+ package-and-class =
+ (mapcar #'(lambda (p)
+ (list (first p) (package-qualified-name (=
second p) package)))
+ params))))))
+
+(defmacro def-jni-field (package-and-class field typename &key static)
+ (multiple-value-bind (package class) (split-package-and-class package-an=
d-class)
+ (let ((getsym (read-from-string (string-append class "." field
+ (if static "-accessor" =
""))))
+ (macsym (read-from-string (string-append class "." field))))
+ `(locally =
+ ,(list 'define-java-field getsym package-and-class
+ (package-qualified-name typename package) field :static st=
atic)
+ ,(when static
+ `(define-symbol-macro ,macsym (,getsym)))))))
+
+;we're going to use a little Java to do exception handling below
+(def-jni-function "java.lang.Object"
+ "toString" () "String")
+
+(def-jni-function "java.lang.reflect.InvocationTargetException"
+ "getTargetException" () "java.lang.Throwable")
+
+(def-jni-functions "java.lang.Throwable"
+ ("getMessage" () "String")
+ ("getStackTrace" () "StackTraceElement<>"))
+
+(defmacro do-jarray ((x array) &body body)
+ (let ((gcount (gensym))
+ (gi (gensym))
+ (garray (gensym)))
+ `(let* ((,garray ,array)
+ (,gcount (get-array-length ,garray)))
+ (dotimes (,gi ,gcount)
+ (let ((,x (jaref ,garray ,gi)))
+ , at body)))))
+
+#|
+It is critical that if you call a JNI function that might throw an excepti=
on that you clear it,
+otherwise the next Java call you make will cause a crash
+|#
+(defun handle-exception ()
+ (let ((e (exception-occurred)))
+ (when (not (fli:null-pointer-p e)) ;allow for safe calling in non-exce=
ptional state
+ (exception-clear)
+ ;if the exception occurs in the reflection target, we really want th=
at
+ (when (is-instance-of e (jni-find-class "java/lang/reflect/Invocatio=
nTargetException"))
+ (setf e (invocationtargetexception.gettargetexception e)))
+ (error "~A" (with-output-to-string (s)
+ (format s "~A~%" (object.tostring e))
+ (do-jarray (x (throwable.getstacktrace e))
+ (format s "~A~%" (object.tostring x))))))))
+
+(defun try (result)
+ (if (exception-check)
+ (handle-exception)
+ result))
+
+;JNI will sometimes indicate theere is an exception via a return value
+;so take advantage of that when possible vs. the call back to exception-ch=
eck
+(defun try-null (result)
+ (if (fli:null-pointer-p result)
+ (handle-exception)
+ result))
+
+(defun try-neg (result)
+ (if (minusp result)
+ (handle-exception)
+ result))
+
+
+)
+
More information about the Openmcl-cvs-notifications
mailing list