source: branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp @ 11368

Last change on this file since 11368 was 11368, checked in by astalla, 13 years ago

New jimplement-interface functionality allowing some sort of limited single-dispatch OO. Changed LispObject.javaObject() to return this instead of signaling an error.

  • Property svn:eol-style set to LF
File size: 3.7 KB
Line 
1;;; abcl-script.lisp
2;;;
3;;; Copyright (C) 2008 Alessio Stalla
4;;;
5;;; This program is free software; you can redistribute it and/or
6;;; modify it under the terms of the GNU General Public License
7;;; as published by the Free Software Foundation; either version 2
8;;; of the License, or (at your option) any later version.
9;;;
10;;; This program is distributed in the hope that it will be useful,
11;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13;;; GNU General Public License for more details.
14;;;
15;;; You should have received a copy of the GNU General Public License
16;;; along with this program; if not, write to the Free Software
17;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
18
19(in-package :abcl-script)
20
21(defvar *java-interface-implementations* (make-hash-table :test #'equal))
22
23(defconstant +global-scope+
24  (jfield "javax.script.ScriptContext" "GLOBAL_SCOPE"))
25
26(defconstant +engine-scope+
27  (jfield "javax.script.ScriptContext" "ENGINE_SCOPE"))
28
29(defconstant +put-binding+ (jmethod "javax.script.Bindings"
30            "put"
31            "java.lang.String"
32            "java.lang.Object"))
33
34(defconstant +get-bindings+ (jmethod "javax.script.ScriptContext"
35             "getBindings"
36             "int"))
37
38(defun generate-bindings (bindings)
39  (let ((*package* (find-package :abcl-script-user)))
40    (mapcar (lambda (binding) (list (read-from-string (car binding))
41            (cdr binding)))
42      bindings)))
43
44(defun generate-java-bindings (bindings-list actual-bindings java-bindings)
45  (loop :for binding  :in actual-bindings
46  :for jbinding :in bindings-list
47  :collect `(jcall +put-binding+
48       ,java-bindings ,(car jbinding) ,(car binding))))
49
50(defun eval-script (global-bindings engine-bindings stdin stdout
51        code-string script-context)
52  (let ((*package* (find-package :abcl-script-user))
53  (*standard-input* stdin)
54  (*standard-output* stdout)
55  (actual-global-bindings (generate-bindings global-bindings))
56  (actual-engine-bindings (generate-bindings engine-bindings)))
57    (eval `(let ((*standard-input* ,stdin)
58     (*standard-output* ,stdout)
59     (*package* (find-package :abcl-script-user)))
60      (let (,@actual-global-bindings)
61        (let (,@actual-engine-bindings)
62    (prog1
63        (progn
64          ,@(read-from-string
65       (concatenate 'string "(" code-string ")")))
66      (finish-output *standard-output*)
67      ,@(generate-java-bindings
68         global-bindings 
69         actual-global-bindings
70         (jcall +get-bindings+ script-context +global-scope+))
71      ,@(generate-java-bindings
72         engine-bindings 
73         actual-engine-bindings
74         (jcall +get-bindings+ script-context +engine-scope+)))))))))
75
76(defstruct (java-interface-implementation (:type list))
77  (method-definitions (list) :type list))
78
79(defun define-java-interface-implementation (interface &rest method-definitions)
80  (register-java-interface-implementation
81   (canonicalize-interface interface)
82   (make-java-interface-implementation :method-definitions method-definitions)))
83
84(defun canonicalize-interface (interface)
85  (cond
86    ((stringp interface) interface)
87    ((jclass-interface-p interface) (jclass-name interface))
88    (t (error "not an interface: ~A" interface))))
89
90(defun register-java-interface-implementation (interface implementation)
91  (setf (gethash (canonicalize-interface interface)
92     *java-interface-implementations*)
93  (implement-java-interface interface implementation)))
94
95(defun find-java-interface-implementation (interface)
96  (gethash (canonicalize-interface interface)
97     *java-interface-implementations*))
98
99(defun implement-java-interface (interface implementation)
100  (apply #'jimplement-interface
101   `(,interface
102     ,@(java-interface-implementation-method-definitions implementation))))
Note: See TracBrowser for help on using the repository browser.