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

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

Solved a bug in invokeFunction (the symbol was not derived correctly from
the function name)

  • Property svn:eol-style set to LF
File size: 4.0 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(defconstant +global-scope+
22  (jfield "javax.script.ScriptContext" "GLOBAL_SCOPE"))
23
24(defconstant +engine-scope+
25  (jfield "javax.script.ScriptContext" "ENGINE_SCOPE"))
26
27(defconstant +put-binding+ (jmethod "javax.script.Bindings"
28            "put"
29            "java.lang.String"
30            "java.lang.Object"))
31
32(defconstant +get-bindings+ (jmethod "javax.script.ScriptContext"
33             "getBindings"
34             "int"))
35
36(defun generate-bindings (bindings)
37  (let ((*package* (find-package :abcl-script-user)))
38    (mapcar (lambda (binding) (list (read-from-string (car binding))
39            (cdr binding)))
40      bindings)))
41
42(defun generate-java-bindings (bindings-list actual-bindings java-bindings)
43  (loop :for binding  :in actual-bindings
44  :for jbinding :in bindings-list
45  :collect `(jcall +put-binding+
46       ,java-bindings ,(car jbinding) ,(car binding))))
47
48(defmacro with-script-context ((global-bindings engine-bindings stdin stdout script-context)
49             body)
50  (let ((actual-global-bindings (gensym))
51  (actual-engine-bindings (gensym)))
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 ,@,body)
64        (finish-output *standard-output*)
65        ,@(generate-java-bindings
66           ,global-bindings 
67           ,actual-global-bindings
68           (jcall +get-bindings+ ,script-context +global-scope+))
69        ,@(generate-java-bindings
70           ,engine-bindings 
71           ,actual-engine-bindings
72           (jcall +get-bindings+ ,script-context +engine-scope+))))))))))
73 
74(defun eval-script (global-bindings engine-bindings stdin stdout
75        code-string script-context)
76  (with-script-context (global-bindings engine-bindings stdin stdout script-context)
77    (read-from-string
78     (concatenate 'string "(" code-string ")"))))
79
80(defun eval-compiled-script (global-bindings engine-bindings stdin stdout
81           function script-context)
82  (with-script-context (global-bindings engine-bindings stdin stdout script-context)
83    `((funcall ,function))))
84
85(defun compile-script (code-string)
86  (eval 
87   `(compile
88     nil
89     (lambda ()
90       ,@(let ((*package* (find-package :abcl-script-user)))
91        (read-from-string (concatenate 'string "(" code-string ")")))))))
92
93
94;;Java interface implementation
95
96(defvar *interface-implementation-map* (make-hash-table :test #'equal))
97
98(defun find-java-interface-implementation (interface)
99  (gethash interface *interface-implementation-map*))
100
101(defun register-java-interface-implementation (interface impl)
102  (setf (gethash interface *interface-implementation-map*) impl))
103
104(defun remove-java-interface-implementation (interface)
105  (remhash interface *interface-implementation-map*))
106
107(defun define-java-interface-implementation (interface implementation &optional lisp-this)
108  (register-java-interface-implementation
109   interface
110   (jmake-proxy interface implementation lisp-this)))
Note: See TracBrowser for help on using the repository browser.