source: trunk/abcl/contrib/jss/read-sharp-quote-expression.lisp

Last change on this file was 15576, checked in by Mark Evenson, 2 years ago

getField->getName Must be a change from updated javaparser. No idea how this worked with the patch I submitted

File size: 4.5 KB
Line 
1(in-package :jss)
2
3(defclass sharp-quote-expression-reader (javaparser) ())
4
5(defun read-sharp-java-expression (stream)
6  (read-sharp-quote-expression
7     (with-output-to-string (s)
8       (loop with embedded-string = nil
9             for last = #\space then char
10             for char = (read-char stream)
11             until (and (char= char #\") 
12                        ;; really end if: we've established embedded string and the peek is a space
13                        ;; we're not about to start embedded string. We're about to start embedded string if next character isn't #\).
14                        ;; we're not embedded-string and not about to start one
15                        (cond ((null (peek-char nil stream nil)) t) ;; eof
16                              (embedded-string (system:whitespacep (peek-char nil stream))) ; embedded " needs "<space>" to end
17                              ((find last ",(+=" :test 'char=)
18                               (setq embedded-string t)
19                               nil)
20                              (t t)))
21             do
22                (write-char char s)))))
23
24
25(defun read-sharp-quote-expression (string)
26  (multiple-value-bind (bindings de-lisped) (extract-lisp-expressions string)
27    (let ((read (read-java-expression (make-instance 'sharp-quote-expression-reader) de-lisped)))
28      (loop for (var nil) in bindings
29            do (setq read (tree-replace (lambda(e) (if (equalp e (string var)) var e)) read )))
30      (if bindings
31          `(let ,bindings ,read)
32          read))))
33
34(defun extract-lisp-expressions (string)
35  (let ((bindings nil))
36    (let ((de-lisped
37            (replace-all string "\\{(.*?)\\}" 
38                                  (lambda(match) 
39                                    (let ((replacevar (find-symbol-not-matching string (mapcar 'car bindings))))
40                                      (push (list replacevar (read-from-string match)) bindings)
41                                      (string replacevar)))
42                                  1)))
43    (values bindings de-lisped))))
44
45(defun find-symbol-not-matching (string already)
46  (loop for candidate = (format nil "JSS_~a" (random 10000))
47        until (and (not (member candidate already :test 'equalp :key 'string))
48                   (not (search string already)))
49        finally (return-from find-symbol-not-matching (intern candidate :jss))))
50                           
51(defun maybe-class (el)
52  (if (and (symbolp el) (upper-case-p (char (string el) 0)) (not (eql (search "JSS_" (string el)) 0)))
53      `(find-java-class ',el)
54      (if (symbolp el)
55          (intern (string-upcase el))
56          el)))
57
58(def-java-read ObjectCreationExpr sharp-quote-expression-reader ()
59  `(new ',(process-node obj (#"getName" (#"getType" node))) ,@(mapcar (lambda(e) (process-node obj e)) (j2list (#"getArguments" node))))
60  )
61
62(def-java-read MethodCallExpr sharp-quote-expression-reader ()
63  (let* ((scope1 (process-node obj (process-node obj (#"getScope" node))))
64         (how  (if (and (symbolp scope1) (not (null scope1)) (upper-case-p (char (string scope1) 0))) 
65                   'jstatic
66                   'jcall)))
67    (if (and (symbolp scope1) (not (null scope1)) (upper-case-p (char (string scope1) 0)))
68        (setq scope1 `(find-java-class ',scope1)))
69    `(,how ,(#"getIdentifier" (#"getName" node)) ,(or scope1 'this) ,@(mapcar 'maybe-class 
70                                                                              (mapcar (lambda(el) (process-node obj el))
71                                                                                      (j2list (#"getArguments" node)))))
72    ))
73
74(def-java-read FieldAccessExpr sharp-quote-expression-reader ()
75  (let ((scope (process-node obj (#"getScope" node))))
76    (if (and (symbolp scope) (upper-case-p (char (string scope) 0)))
77        `(get-java-field ',(process-node obj (#"getScope" node)) ,(#"getIdentifier" (#"getName" node)) t)
78        `(get-java-field ,(maybe-class (process-node obj (#"getScope" node))) ,(#"getIdentifier" (#"getName" node)) t))))
79
80(def-java-read ArrayAccessExpr sharp-quote-expression-reader ()
81  (let ((index (process-node obj (#"getIndex" node))))
82    (if (symbolp index) (setq index (intern (string-upcase index))))
83    `(aref ,(process-node obj (#"getName" node)) ,index)))
84
85(def-java-read ClassExpr sharp-quote-expression-reader ()
86  (let ((name (process-node obj (#"getName" (#"getType" node)))))
87    (if (eql (search "JSS_" (string name) :test 'equalp) 0)
88        name
89        `(find-java-class ',name))))
90
91(def-java-read NameExpr sharp-quote-expression-reader ()
92  (process-node obj (#"getName" node)))
93
Note: See TracBrowser for help on using the repository browser.