Changeset 15086 for trunk/abcl/contrib/jss/invoke.lisp

Timestamp:

06/17/17 06:52:37 (6 years ago)

Author:

Mark Evenson

Message:

jss: new macro WITH-CLASS-LOOKUP-DISAMBIGUATED
(Alan Ruttenberg)

(with-class-lookup-disambiguated (lang.object) (find-java-class 'object))

-> success (otherwise error: ambiguous)

From <​https://github.com/armedbear/abcl/pull/57>.

Merges
<​https://github.com/armedbear/abcl/pull/57/commits/5103d57822691d74c66b80c754f8438df6806bba>.

File:

• trunk/abcl/contrib/jss/invoke.lisp (modified) (1 diff)

trunk/abcl/contrib/jss/invoke.lisp

@@ -246 +246 @@
                  ,@body)))))))
 
+(defvar *class-lookup-overrides*)
+
+(defmacro with-class-lookup-disambiguated (overrides &body body)
+  "Suppose you have code that references class using the symbol 'object, and this is ambiguous. E.g. in my system java.lang.Object, org.omg.CORBA.Object. Use (with-class-lookup-disambiguated (lang.object) ...). Within dynamic scope, find-java-class first sees if any of these match, and if so uses them to lookup the class."
+  `(let ((*class-lookup-overrides* ',overrides))
+     ,@body))
+
+(defun maybe-found-in-overridden (name)
+  (when (boundp '*class-lookup-overrides*)
+      (let ((found (find-if (lambda(el) (#"matches" (string el) (concatenate 'string "(?i).*" (string name) "$")))
+          *class-lookup-overrides*)))
+  (if found
+      (let ((*class-lookup-overrides* nil))
+        (lookup-class-name found))))))
+
+
 (defun lookup-class-name (name &key
                                  (table *class-name-to-full-case-insensitive*)
                                  (muffle-warning nil)
                                  (return-ambiguous nil))
+  (let ((overridden (maybe-found-in-overridden name)))
+    (when overridden (return-from lookup-class-name overridden)))
   (setq name (string name))
   (let* (;; cant (last-name-pattern (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$"))