..jar', 'maven-embedder-3...jar' etc.")
(defun normalize-mvn-libs ()
"Ensure that any *mvn-libs-directory* is a both directory and a pathname"
(unless *mvn-libs-directory*
(return-from normalize-mvn-libs nil))
(when (not (pathnamep *mvn-libs-directory*))
(setf *mvn-libs-directory* (pathname *mvn-libs-directory*)))
(when (not (#"endsWith" (namestring *mvn-libs-directory*) "/"))
(setf *mvn-libs-directory*
(pathname (concatenate 'string *mvn-libs-directory* "/"))))
*mvn-libs-directory*)
(defun mvn-version ()
"Return the version of Maven libaries in use"
(unless (normalize-mvn-libs)
(error "Need to specify a value of *mvn-libs-directory*"))
(let* ((pattern
"maven-core*.jar")
(maven-core-jars
(directory (merge-pathnames pattern
*mvn-libs-directory*)))
(maven-core-jar
(cond
((= (length maven-core-jars) 0)
(error "No file matching '~a' found in '~a'." pattern *mvn-libs-directory*))
((> (length maven-core-jars) 1)
(warn "More than one file matching '~a' found in '~a'."
pattern *mvn-libs-directory*)
(first maven-core-jars))
(t
(first maven-core-jars)))))
(let* ((manifest
(#"getManifest" (jss:new 'java.util.jar.JarFile (namestring maven-core-jar))))
(attributes
(#"getMainAttributes" manifest))
(version
(#"getValue" attributes "Implementation-Version")))
(if version
(parse-mvn-version
version)
(mvn-version-from-mvn-executable)))))
;;; deprecated, unused: we now get the version directly from the JAR manifest
(defun mvn-version-from-mvn-executable ()
"Return the Maven version used by the Aether connector located by
FIND-MVN as a list of (MAJOR MINOR PATHLEVEL) integers.
Signals a simple-error with additional information if this attempt fails."
(handler-case
(let* ((mvn
(truename (find-mvn)))
(pattern (#"compile"
'regex.Pattern
"^Apache Maven ([0-9]+\\.[0-9]+\\.[0-9]+)")))
(multiple-value-bind (output error)
(uiop:run-program
(format nil "~a --version" mvn)
:output :string :error :string)
(let ((matcher (#"matcher" pattern output)))
(when (#"find" matcher)
(return-from mvn-version-from-mvn-executable
(parse-mvn-version (#"group" matcher 1)))))
(when output
(signal "No parseable Maven version found in ~a" output))
(signal "Invocation of Maven returned the error ~{~& ~A~}" error)))
(t (e)
(error "Failed to determine Maven version: ~A." e))))
(defun parse-mvn-version (version-string)
(let* ((pattern (#"compile"
'regex.Pattern
"([0-9]+)\\.([0-9]+)\\.([0-9]+)"))
(matcher (#"matcher" pattern version-string)))
(if (#"find" matcher)
(mapcar #'parse-integer
`(,(#"group" matcher 1)
,(#"group" matcher 2)
,(#"group" matcher 3)))
(error "Failed to parse a MAJOR.MINOR.PATCHLEVEL version from '~a'" version-string))))
(defun mvn-home ()
"If the Maven executable can be invoked, introspect the value
reported as Maven home."
(handler-case
(multiple-value-bind (output error-output status)
(uiop:run-program
(format nil "~a --version" (truename (find-mvn)))
:output :string
:error-output :string)
(unless (zerop status)
(error "Failed to invoke Maven executable to introspect library locations: ~a." error-output))
(let ((pattern (#"compile"
'regex.Pattern
"Maven home: (.+)$")))
(with-input-from-string (s output)
(do ((line (read-line s nil :eof)
(read-line s nil :eof)))
((or (not line) (eq line :eof)) nil)
(let ((matcher (#"matcher" pattern line)))
(when (#"find" matcher)
(return-from mvn-home
(uiop/pathname:ensure-directory-pathname (#"group" matcher 1)))))))))
(subprocess-error (e)
(error "Failed to invoke Maven executable to introspect library locations: ~a." e))))
(defun ensure-mvn-version ()
"Return t if Maven version is 3.0.3 or greater."
(let* ((version (mvn-version))
(major (first version))
(minor (second version))
(patch (third version)))
(values
(or
(and (>= major 3)
(>= minor 1))
(and (>= major 3)
(>= minor 0)
(>= patch 3)))
(list major minor patch))))
(define-condition no-aether-maven-libs (error)
((locations :initarg :locations
:initform nil
:reader locations))
(:report (lambda (condition stream)
(format stream "No Maven Aether libraries found locally in '~a'."
(locations condition)))))
(defparameter *init-p* nil
"Whether we have successfully located the necessary Maven libraries")
(defun init (&optional &key (force nil))
(restart-case
(if force
(%init :force t)
(%init))
(no-aether-maven-libs ()
:report "Install and use Maven libraries under local XDG hierarchy"
(make-local-maven))))
(defun %init (&optional &key (force nil))
"Run the initialization strategy to bootstrap a Maven dependency node
Set *MVN-LIBS-DIRECTORY* to an explicit value before running this
function in order to bypass the dynamic introspection of the location
of the mvn executable with an explicit value."
(when force
(setf *session* nil
*repository-system* nil))
(unless (or force *mvn-libs-directory*)
(setf *mvn-libs-directory* (find-mvn-libs)))
(unless (and *mvn-libs-directory*
(probe-file *mvn-libs-directory*))
(error (make-condition 'abcl-asdf::no-aether-maven-libs
:locations (list *mvn-libs-directory*))))
(unless (ensure-mvn-version)
(error "We need maven-3.0.3 or later."))
(add-directory-jars-to-class-path *mvn-libs-directory* nil)
(setf *init-p* t))
;;; The AETHER-DIRECTORY parameter is conceptually a little broken:
;;; because we can't "unload" jar files, we can't easily switch
;;; between Maven implementation at runtime. Maybe this would be
;;; possible with some sort of classloader chaining, but such effort
;;; is not currently deemed as worthwhile. Instead, to change Aether
;;; libraries, you'll have to restart ABCL.
(defmacro with-aether ((&optional aether-directory) &body body)
"Ensure that the code in BODY is executed with the Maven Aether libraries on the classpath"
(if aether-directory
`(let ((*mvn-libs-directory* ,aether-directory))
(init :force t)
,@body)
`(progn (unless *init-p*
(init))
,@body)))
(defun find-http-wagon ()
"Find an implementation of the object that provides access to http and https resources.
Supposedly configurable with the java.net.protocols (c.f. reference
maso2000 in the Manual.)"
(handler-case
;; maven-3.0.4
(java:jnew "org.apache.maven.wagon.providers.http.HttpWagon")
(error ()
;; maven-3.0.3 reported as not working with all needed functionality
(java:jnew "org.apache.maven.wagon.providers.http.LightweightHttpWagon"))))
(defun make-wagon-provider ()
"Returns an implementation of the org.sonatype.aether.connector.wagon.WagonProvider contract
The implementation is specified as Lisp closures. Currently, it only
specializes the lookup() method if passed an 'http' or an 'https' role
hint."
(unless *init-p* (init))
(java:jinterface-implementation
(#"getName"
(or
(ignore-errors ;; Maven 3.2.5+
(jss:find-java-class 'aether.transport.wagon.WagonProvider))
(ignore-errors ;; Maven 3.1.0+
(jss:find-java-class 'aether.connector.wagon.WagonProvider))
(ignore-errors ;; Maven 3.0.x
(jss:find-java-class 'org.sonatype.aether.connector.wagon.WagonProvider))))
"lookup"
(lambda (role-hint)
(cond
((find role-hint '("http" "https") :test #'string-equal)
(find-http-wagon))
(t
(progn
(format cl:*load-verbose*
"~&; abcl-asdf; WagonProvider stub passed '~A' as a hint it couldn't satisfy.~%"
role-hint)
java:+null+))))
"release"
(lambda (wagon)
(declare (ignore wagon)))))
(defun find-service-locator ()
(or
(ignore-errors
;; maven-3.0.4
(jss:new "org.apache.maven.repository.internal.MavenServiceLocator"))
(ignore-errors
;; maven-3.1.0 using org.eclipse.aether...
(jss:new "aether.impl.DefaultServiceLocator"))
(ignore-errors
(jss:new "org.apache.maven.repository.internal.DefaultServiceLocator"))
(ignore-errors
;; maven-3.1.0
(#"newServiceLocator" 'org.apache.maven.repository.internal.MavenRepositorySystemUtils))))
(defun make-repository-system ()
(unless *init-p* (init))
(let ((locator
(find-service-locator))
(wagon-provider-class
(or
(ignore-errors
(java:jclass "org.sonatype.aether.connector.wagon.WagonProvider"))
(ignore-errors ;; Maven-3.3.x
(jss:find-java-class 'connector.transport.TransporterFactory))
(ignore-errors ;; Maven-3.2.5
(jss:find-java-class 'org.eclipse.aether.transport.wagon.WagonProvider))
(ignore-errors ;; Maven-3.1.x
(jss:find-java-class 'aether.connector.wagon.WagonProvider))))
(wagon-repository-connector-factory-class
(or
(ignore-errors
(jss:find-java-class 'org.sonatype.aether.connector.wagon.WagonRepositoryConnectorFactory))
(ignore-errors
(jss:find-java-class 'org.eclipse.aether.connector.basic.BasicRepositoryConnectorFactory))
(ignore-errors
(java:jclass "org.sonatype.aether.connector.wagon.WagonRepositoryConnectorFactory"))))
(repository-connector-factory-class
(or
(ignore-errors
(jss:find-java-class 'aether.spi.connector.RepositoryConnectorFactory))
(ignore-errors
(jss:find-java-class 'org.eclipse.aether.spi.connector.RepositoryConnectorFactory))
(ignore-errors
(java:jclass "org.sonatype.aether.spi.connector.RepositoryConnectorFactory"))))
(repository-system-class
(or
(ignore-errors
(java:jclass "org.sonatype.aether.RepositorySystem"))
(ignore-errors
(jss:find-java-class 'org.eclipse.aether.RepositorySystem))
(ignore-errors
(jss:find-java-class 'aether.RepositorySystem)))))
(if (equal wagon-provider-class (ignore-errors (jss:find-java-class 'TransporterFactory)))
;;; Maven-3.3.3
(let ((wagon-transporter-factory (jss:new 'WagonTransporterFactory)))
(#"setWagonProvider" wagon-transporter-factory (make-wagon-provider))
(#"setServices" locator
wagon-provider-class
(java:jarray-from-list (list wagon-transporter-factory))))
(#"setServices" locator
wagon-provider-class
(java:jarray-from-list
(list (make-wagon-provider)))))
(#"addService" locator
repository-connector-factory-class
wagon-repository-connector-factory-class)
(values (#"getService" locator
repository-system-class)
locator)))
(defun make-session (repository-system)
"Construct a new aether.RepositorySystemSession from the specified REPOSITORY-SYSTEM."
(with-aether ()
(let ((session
(or
(ignore-errors
(java:jnew
(jss:find-java-class "MavenRepositorySystemSession")))
(ignore-errors
(#"newSession"
'org.apache.maven.repository.internal.MavenRepositorySystemUtils))))
(local-repository
(make-local-repository)))
(#"setLocalRepositoryManager"
session
(make-local-repository-manager repository-system local-repository session)))))
(defun make-local-repository-manager (repository-system local-repository session)
(or
(ignore-errors
(#"newLocalRepositoryManager"
repository-system local-repository))
(ignore-errors ;; maven-3.1.0
(#"newLocalRepositoryManager"
repository-system session local-repository))))
(defun make-local-repository ()
(java:jnew
(or
(ignore-errors
(jss:find-java-class "org.sonatype.aether.repository.LocalRepository"))
(ignore-errors
(jss:find-java-class "org.eclipse.aether.repository.LocalRepository")))
(namestring (merge-pathnames ".m2/repository/"
(user-homedir-pathname)))))
(defparameter *maven-http-proxy* nil
"A string containing the URI of an http proxy for Maven to use.")
(defun make-proxy ()
"Return an aether.repository.Proxy instance initialized from *MAVEN-HTTP-PROXY*."
(unless *maven-http-proxy*
(warn "No proxy specified in *MAVEN-HTTP-PROXY*")
(return-from make-proxy nil))
(let* ((p (pathname *maven-http-proxy*))
(scheme (ext:url-pathname-scheme p))
(authority (ext:url-pathname-authority p))
(host (if (search ":" authority)
(subseq authority 0 (search ":" authority))
authority))
(port (when (search ":" authority)
(parse-integer (subseq authority (1+ (search ":" authority))))))
;; TODO allow specification of authentication
(authentication java:+null+))
(or
(ignore-errors
(jss:new 'org.eclipse.aether.repository.Proxy
scheme host port authentication))
(ignore-errors
(jss:new 'org.sonatype.aether.repository.Proxy
scheme host port authentication)))))
(defparameter *repository-system* nil
"The aether.RepositorySystem used by the Maeven Aether connector.")
(defun ensure-repository-system (&key (force nil))
(when (or force (not *repository-system*))
(setf *repository-system* (make-repository-system)))
*repository-system*)
(defparameter *session* nil
"Reference to the Maven RepositorySystemSession")
(defun ensure-session (&key (force nil))
"Ensure that the RepositorySystemSession has been created.
If *MAVEN-HTTP-PROXY* is non-nil, parse its value as the http proxy."
(when (or force (not *session*))
(ensure-repository-system :force force)
(setf *session* (make-session *repository-system*))
(#"setRepositoryListener" *session* (make-repository-listener))
(when *maven-http-proxy*
(let ((proxy (make-proxy)))
(#"add" (#"getProxySelector" *session*)
proxy
;; A string specifying non proxy hosts, or null
java:+null+))))
*session*)
(defun make-artifact (artifact-string)
"Return an instance of aether.artifact.DefaultArtifact initialized from ARTIFACT-STRING"
(or
(ignore-errors
(jss:new "org.sonatype.aether.util.artifact.DefaultArtifact" artifact-string))
(ignore-errors
(jss:new 'aether.artifact.DefaultArtifact artifact-string))))
(defun make-artifact-request ()
"Construct a new aether.resolution.ArtifactRequest."
(or
(ignore-errors
(java:jnew (jss:find-java-class 'aether.resolution.ArtifactRequest)))
(ignore-errors
(java:jnew "org.sonatype.aether.resolution.ArtifactRequest"))))
;;; TODO change this to work on artifact strings like log4j:log4j:jar:1.2.16
(defun resolve-artifact (group-id artifact-id &key (version "LATEST" versionp))
"Resolve artifact to location on the local filesystem.
Declared dependencies are not attempted to be located.
If unspecified, the string \"LATEST\" will be used for the VERSION.
Returns the Maven specific string for the artifact "
(unless versionp
(warn "Using LATEST for unspecified version."))
(unless *init-p* (init))
(let* ((artifact-string
(format nil "~A:~A:~A" group-id artifact-id version))
(artifact
(make-artifact artifact-string))
(artifact-request
(make-artifact-request)))
(#"setArtifact" artifact-request artifact)
(#"addRepository" artifact-request (ensure-remote-repository))
(#"toString" (#"getFile"
(#"getArtifact" (#"resolveArtifact" (ensure-repository-system)
(ensure-session) artifact-request))))))
(defun make-remote-repository (id type url)
(or
(ignore-errors
(jss:new 'org.sonatype.aether.repository.RemoteRepository id type url))
(ignore-errors
(#"build" (jss:new "org.eclipse.aether.repository.RemoteRepository$Builder" id type url)))))
(defvar *default-repository*
"https://repo1.maven.org/maven2/"
"URI of default remote Maven repository")
(defun add-repository (repository)
(ensure-remote-repository :repository repository))
(defparameter *maven-remote-repository* nil
"Reference to remote repository used by the Maven Aether
embedder.")
(defun ensure-remote-repository (&key
(force nil)
(repository *default-repository* repository-p))
(unless *init-p* (init))
(when (or force
repository-p
(not *maven-remote-repository*))
(let ((r (make-remote-repository "central" "default" repository)))
(when *maven-http-proxy*
(#"setProxy" r (make-proxy)))
(setf *maven-remote-repository* r)))
*maven-remote-repository*)
(defun resolve-dependencies (group-id artifact-id
&key
(version "LATEST" versionp)
(repository *maven-remote-repository* repository-p)
(repositories NIL repositories-p))
"Dynamically resolve Maven dependencies for item with GROUP-ID and ARTIFACT-ID
optionally with a VERSION and a REPOSITORY.
All recursive dependencies will be visited before resolution is successful.
If unspecified, the string \"LATEST\" will be used for the VERSION.
Returns a string containing the necessary jvm classpath entries packed
in Java CLASSPATH representation."
(unless *init-p* (init))
(unless versionp
(warn "Using LATEST for unspecified version."))
(let* ((coords
(format nil "~A:~A:~A" group-id artifact-id (if versionp version "LATEST")))
(artifact
(make-artifact coords))
(dependency
(make-dependency artifact))
(collect-request
(or
(ignore-errors
(java:jnew (jss:find-java-class "org.sonatype.aether.collection.CollectRequest")))
(ignore-errors
(java:jnew (jss:find-java-class "org.eclipse.aether.collection.CollectRequest"))))))
(#"setRoot" collect-request dependency)
(setf repositories-p (or repository-p repositories-p))
;; Don't call addRepository if we explicitly specify a NIL repository
(cond
((not repositories-p)
(#"addRepository" collect-request (ensure-remote-repository)))
(repository
(if (stringp repository)
(push repository repositories)
(#"addRepository" collect-request repository))))
(dolist (repository repositories)
(#"addRepository" collect-request
(let ((r (make-remote-repository "central" "default" repository)))
(when *maven-http-proxy*
(#"setProxy" r (make-proxy)))
r)))
(let* ((collect-result (#"collectDependencies" (ensure-repository-system)
(ensure-session) collect-request))
(node
(#"getRoot" collect-result))
(dependency-request
(or
(ignore-errors
;;; pre Maven-3.3.x
(java:jnew (jss:find-java-class "DependencyRequest")
node java:+null+))
(ignore-errors
(jss:new 'DependencyRequest))))
(nlg
(java:jnew (jss:find-java-class "PreorderNodeListGenerator"))))
(#"setRoot" dependency-request node)
(#"resolveDependencies" (ensure-repository-system) (ensure-session) dependency-request)
(#"accept" node nlg)
(#"getClassPath" nlg))))
(defun make-dependency (artifact)
(or
(ignore-errors
(java:jnew (jss:find-java-class 'org.sonatype.aether.graph.Dependency)
artifact
(java:jfield
(jss:find-java-class "org.sonatype.aether.util.artifact.JavaScopes")
"COMPILE")))
(ignore-errors
(java:jnew (jss:find-java-class 'org.eclipse.aether.graph.Dependency)
artifact
(java:jfield
(jss:find-java-class "org.eclipse.aether.util.artifact.JavaScopes")
"COMPILE")))))
(defun make-repository-listener ()
(flet ((log (e)
(format cl:*load-verbose* "~&; abcl-asdf; ~A~%" (#"toString" e))))
(java:jinterface-implementation
(#"getName" (jss:find-java-class 'aether.RepositoryListener))
"artifactDeployed"
#'log
"artifactDeploying"
#'log
"artifactDescriptorInvalid"
#'log
"artifactDescriptorMissing"
#'log
"artifactDownloaded"
#'log
"artifactDownloading"
#'log
"artifactInstalled"
#'log
"artifactInstalling"
#'log
"artifactResolved"
#'log
"artifactResolving"
#'log
"metadataDeployed"
#'log
"metadataDeploying"
#'log
"metadataDownloaded"
#'log
"metadataDownloading"
#'log
"metadataInstalled"
#'log
"metadataInstalling"
#'log
"metadataInvalid"
#'log
"metadataResolved"
#'log
"metadataResolving"
#'log)))
(defmethod resolve ((string string))
"Resolve a colon separated GROUP-ID:ARTIFACT-ID[:VERSION] reference to a Maven artifact.
Examples of artifact references: \"log4j:log4j:1.2.14\" for
'log4j-1.2.14.jar'. Resolving \"log4j:log4j\" would return the latest
version of the artifact known to the distributed Maven pom.xml graph.
Returns a string containing the necessary classpath entries for this
artifact and all of its transitive dependencies."
(let ((result (split-string string ":")))
(cond
((= (length result) 3)
(resolve-dependencies
(first result) (second result) :version (third result)))
((string= string "com.sun.jna:jna")
(warn "Replacing request for no longer available com.sun.jna:jna with net.java.dev.jna:jna")
(resolve-dependencies "net.java.dev.jna" "jna" :version "LATEST"))
((= (length result) 2)
(resolve-dependencies
(first result) (second result)))
(t
(destructuring-bind (group-id artifact-id &optional version repository)
(abcl-build:split-string string "/")
(setf result
(apply #'resolve-dependencies group-id artifact-id
(append (when version
`(:version ,version))
(when repository
`(:repository ,repository))))))))))
(defun make-local-maven ()
"Use ABCL-BUILD to install a local Maven, configuring it for subsequent use"
;; TODO: use this in an interactive restart if Maven can't be found
(setf abcl-asdf:*mvn-libs-directory*
(multiple-value-bind (mvn entries)
(abcl-build:mvn/install)
(let* ((root
(first (last entries)))
(lib
(merge-pathnames "./lib/" root )))
(abcl-asdf:with-aether (lib)
(values
(and
;; for good measure
(when (asdf:clear-system :jna)
(asdf:make :jna))
lib)
(abcl-asdf:ensure-mvn-version)
(abcl-build:ensure-maven)))))))
;;; Currently the last file listed in ASDF
(provide 'abcl-asdf)
abcl-src-1.9.2/contrib/abcl-asdf/mvn-module.lisp 0100644 0000000 0000000 00000006567 14343623723 020215 0 ustar 00 0000000 0000000 (in-package :abcl-asdf)
;;;
;;; If a artifact is root then its optional dependencies are
;; collected. If the same artifact is not root, then the optional
;;; dependencies are not collected. We don't need optionals since from
;;; our point of view we are the top pom and everything specified are
;;; dependencies
;;; Used by asdf-mvn-module.
(defun resolve-multiple-maven-dependencies
(dependencies &optional managed-dependencies exclusions (first-is-root nil))
"Return a list of jar file paths that satisfy dependencies
dependencies: a list of maven artifacts. color or slash separated
components groupid:artifactid:versionid
managed-dependencies: a list of maven artifacts. If an dependency
with same groupid and artifactid are encountered, the version
specified here overrides.
exclusions: a list of partial maven artifacts
groupid:artifactid. Dependencies with same groupid and artifactid are
exluded
first-is-root: If the first dependency should include optional
dependencies, set this to t. Usually not.
"
(with-aether (nil)
(let ((collect-request (java:jnew (jss:find-java-class "CollectRequest")))
(exclusions-collection (jss:new 'java.util.HashSet))
(compile-scope (java:jfield (jss:find-java-class "JavaScopes") "COMPILE")))
(#"addRepository" collect-request (ensure-remote-repository))
(loop for e in exclusions
for (groupid artifactid) = (abcl-build:split-string e #\:)
;; If i have scope be compile-scope it doesn't get excluded!!
for exclusion = (jss:new 'aether.graph.Exclusion groupid artifactid "" "jar")
do (#"add" exclusions-collection exclusion))
(loop for a in dependencies
for artifact = (make-artifact (#"replaceAll" a "/" ":"))
for dependency = (jss:new 'aether.graph.Dependency artifact compile-scope)
do
;; setExclusions returns a new dependency. We have to use
;; that. That passed dependency i not modified!
;; http://grepcode.com/file/repo1.maven.org/maven2/org.eclipse.aether/aether-api/1.0.2.v0150114/org/eclipse/aether/graph/Dependency.java#Dependency.getOptional%28%29
;; Nice of them to clearly document that :-/
(setq dependency (#"setExclusions" dependency exclusions-collection))
(if first-is-root
(#"setRoot" collect-request dependency)
(#"addDependency" collect-request dependency))
(setq first-is-root nil))
(loop for a in managed-dependencies
for artifact = (make-artifact (#"replaceAll" a "/" ":"))
for dependency = (jss:new 'aether.graph.Dependency artifact compile-scope)
do (setq dependency (#"setExclusions" dependency exclusions-collection))
(#"addManagedDependency" collect-request dependency))
(let ((dependencies (#"collectDependencies" (ensure-repository-system) (ensure-session) collect-request))
(nodelist-generator (jss:new 'PreorderNodeListGenerator))
(dependency-request (jss:new 'DependencyRequest)))
(#"setRoot" dependency-request (#"getRoot" dependencies))
(#"resolveDependencies" (ensure-repository-system) (ensure-session) dependency-request)
(#"accept" (#"getRoot" dependencies) nodelist-generator)
(abcl-build:split-string (#"getClassPath" nodelist-generator) #\:)))))
abcl-src-1.9.2/contrib/abcl-asdf/package.lisp 0100644 0000000 0000000 00000001416 14377053644 017517 0 ustar 00 0000000 0000000 (in-package :cl-user)
(defpackage abcl-asdf
(:use cl)
(:import-from :abcl/build
#:split-string)
(:export
;;; Public API
#:resolve
;; Configuring Maven
#:with-aether
#:ensure-mvn-version
#:find-mvn
#:mvn-version
#:*mvn-directory*
#:init
#:make-local-maven
;; condition
#:no-aether-maven-libs
;;; "Internal" API
#:resolve-dependencies
#:resolve-artifact
;;;; Maven
#:*mvn-libs-directory*
#:*maven-http-proxy*
#:*default-repository*
#:make-remote-repository
#:*maven-remote-repository*
#:resolve-multiple-maven-dependencies
#:as-classpath
#:add-directory-jars-to-class-path
#:need-to-add-directory-jar?
#:*added-to-classpath*
#:*inhibit-add-to-classpath*))
abcl-src-1.9.2/contrib/abcl-asdf/t/eg/soot-mixed-repositories.asd 0100644 0000000 0000000 00000000554 14343623723 023373 0 ustar 00 0000000 0000000 (defsystem #:soot-mixed-repositories
:defsystem-depends-on (#:jss #:abcl-asdf)
:components ((:mvn "ca.mcgill.sable/soot/3.0.0-20170622.230711-112"
:repository "http://repo1.maven.org/maven2/"
:repositories ("https://soot-build.cs.uni-paderborn.de/nexus/repository/soot-snapshot/")
:classname "soot.SootClass")))
abcl-src-1.9.2/contrib/abcl-asdf/t/eg/soot-only-repositories.asd 0100644 0000000 0000000 00000000556 14343623723 023250 0 ustar 00 0000000 0000000 (defsystem #:soot-only-repositories
:defsystem-depends-on (#:jss #:abcl-asdf)
:components ((:mvn "ca.mcgill.sable/soot/3.0.0-20170622.230711-112"
:repositories ("https://soot-build.cs.uni-paderborn.de/nexus/repository/soot-snapshot/"
"http://repo1.maven.org/maven2/")
:classname "soot.SootClass")))
abcl-src-1.9.2/contrib/abcl-asdf/t/eg/test-mvn-module.asd 0100644 0000000 0000000 00000002433 14343623723 021614 0 ustar 00 0000000 0000000 ;;; From https://github.com/alanruttenberg/lsw2/blob/owlapiv4/owl2/owl2libs-mvn2.asd
(defsystem test-mvn-module
:description "Non-Lisp dependencies necessary for OWL to function."
:defsystem-depends-on (asdf-mvn-module)
:components
((:mvn-module maven
:dependencies
("net.sourceforge.owlapi/pellet-cli-ignazio1977/2.4.0-ignazio1977"
"org.semanticweb.elk/elk-owlapi/0.4.3"
"net.sourceforge.owlapi/org.semanticweb.hermit/1.3.8.413"
"net.sourceforge.owlapi/owlapi-distribution/4.2.6"
"net.sourceforge.owlapi/owlexplanation/2.0.0"
"de.sciss/prefuse-core/1.0.1"
"de.sciss/prefuse-demos/1.0.1")
:managed-dependencies
("org.slf4j/slf4j-api/1.7.21"
"net.sourceforge.owlapi:owlapi-distribution:4.2.6")
:exclusions
("net.sourceforge.owlapi:owlapi-osgidistribution"
"edu.stanford.protege:org.protege.editor.owl"))
#+(or)
(:module rest :pathname "lib" :components
((:bundle "uk.ac.manchester.cs.owl.factplusplus-1.6.5")
(:jar-file "LSWTreeview-1.0.0")
(:jar-file "QuotedStringAnnotationVisitor-1.0.0")))
(:module lib :pathname "lib"
:depends-on (maven #+(or) rest)))
:perform (load-op :after (o c)
(progn
(#"configure" 'org.apache.log4j.BasicConfigurator (jss::new 'NullAppender))
(print "configured log4j"))))
abcl-src-1.9.2/contrib/abcl-asdf/t/log4j.lisp 0100644 0000000 0000000 00000001222 14343623723 017373 0 ustar 00 0000000 0000000 (in-package :cl-user)
(prove:diag
"Output a message to the Console.
Note: for users of SLIME, this will appear in the associated *inferior-lisp* buffer.")
(prove:plan 2)
(progn
(when (find "log4j" (asdf:already-loaded-systems) :test 'equal)
(prove:diag "Log4j was already loaded. Explicitly clearing it from ASDF.")
(asdf:clear-system :log4j))
(prove:ok (asdf:load-system :log4j)
"Testing loading the log4j systemâŠ")
(#"configure" 'log4j.BasicConfigurator)
(#"info" (#"getRootLogger" 'log4j.Logger) "Kilroy wuz here.")
(prove:pass "No error occured while testing logging to *standard-output*"))
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-asdf/t/maven.lisp 0100644 0000000 0000000 00000000626 14343623723 017471 0 ustar 00 0000000 0000000 (in-package :cl-user)
(prove:plan 5)
(prove:diag "Testing local bootable Maven version.")
(multiple-value-bind (good version)
(abcl-asdf:ensure-mvn-version)
(prove:ok good)
(prove:is-type version 'list)
(prove:ok (every #'fixnump version)))
(prove:is-type (abcl-asdf:resolve-dependencies "log4j" "log4j") 'string)
(prove:is-type (abcl-asdf:resolve "org.abcl/abcl") 'string)
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-asdf/t/mvn-module.lisp 0100644 0000000 0000000 00000001370 14343623723 020443 0 ustar 00 0000000 0000000 (in-package :cl-user)
;;; TODO: restore original ASDF configuration after running test
(defun asdf-add-test-mvn-module ()
(asdf:initialize-source-registry
`(:source-registry
(:directory ,(asdf:system-relative-pathname :asdf-mvn-module "t/eg/"))
:inherit-configuration)))
(unless (ignore-errors (asdf:find-system :test-mvn-module))
(asdf-add-test-mvn-module))
(prove:plan 3)
(prove:ok (asdf:load-system :test-mvn-module)
"Testing loading of ASDF:MVN-MODULE definitionâŠ")
(prove:ok (asdf:load-system :soot-only-repositories)
"Testing loading with only repositories listâŠ")
(prove:ok (asdf:load-system :soot-mixed-repositories)
"Testing loading with both single and list of repositoriesâŠ")
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-asdf/t/resolve-multiple-maven-dependencies.lisp 0100644 0000000 0000000 00000001447 14343623723 025425 0 ustar 00 0000000 0000000 (in-package :cl-user)
(prove:plan 3)
(let ((deps (abcl-asdf:resolve-multiple-maven-dependencies
'("net.sourceforge.owlapi:org.semanticweb.hermit:1.3.8.413"
"net.sourceforge.owlapi:owlapi-distribution:4.2.6"
"net.sourceforge.owlapi/pellet-cli-ignazio1977/2.4.0-ignazio1977"
"org.semanticweb.elk/elk-reasoner/0.4.3"
"net.sourceforge.owlapi/owlexplanation/2.0.0")
'("net.sourceforge.owlapi:owlapi-distribution:4.2.6")
'("net.sourceforge.owlapi:owlapi-osgidistribution"
"edu.stanford.protege:org.protege.editor.owl"))))
(prove:is (length deps) 87)
(prove:ok (not (find "owlapi-osgidistribution" deps :test 'search)))
(prove:ok (not (find "protege" deps :test 'search))))
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-asdf/t/resolve.lisp 0100644 0000000 0000000 00000000304 14343623723 020033 0 ustar 00 0000000 0000000 (in-package :cl-user)
(prove:plan 1)
(prove:is-type
(abcl-asdf:resolve-dependencies "org.armedbear.lisp" "abcl")
'string
"Resolving ABCL from distributed Maven POM graph.")
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-build/README.markdown 0100644 0000000 0000000 00000000233 14343623723 020104 0 ustar 00 0000000 0000000 ABCL-BUILD
==========
Installing and executing the necessary toolchain to build ABCL.
Utility functions to download needed artifacts from the network.
abcl-src-1.9.2/contrib/abcl-build/abcl-build-tests.asd 0100644 0000000 0000000 00000001250 14343623723 021232 0 ustar 00 0000000 0000000 (defsystem abcl-build-tests
:version "2.0.1"
:description "Test ABCL build system."
:defsystem-depends-on (prove-asdf)
:depends-on (abcl-build
prove)
:perform (test-op (op c)
(symbol-call :prove-asdf 'run-test-system c))
:components ((:module build
:pathname "build/t/"
:components ((:test-file "util")
(:test-file "install")
(:test-file "ant")
(:test-file "maven")
(:test-file "abcl-build")))))
abcl-src-1.9.2/contrib/abcl-build/abcl-build.asd 0100644 0000000 0000000 00000002672 14343623723 020103 0 ustar 00 0000000 0000000 ;;; aka the "Lisp-hosted build system" which doesn't share build
;;; instructions with the canonical build system in
;;; Works for: abcl, sbcl, clisp, cmu, lispworks, allegro, openmcl
(defsystem abcl-build
:version "2.1.0"
:description "Build ABCL from a Lisp. Downloads necessary build-time tools to local cache if not available on system."
:in-order-to ((test-op (test-op abcl-build-tests)))
:components ((:module package
:pathname "build/"
:components ((:file "package")))
(:module util
:pathname "build/"
:depends-on (package)
:components ((:file "util")
(:file "report")))
(:module build
:pathname "build/"
:depends-on (util)
:serial t
:components (;;; TODO optionally parse a local configuration for customization
(:file "customizations-default")
(:file "install")
(:file "maven")
(:file "ant")
(:file "abcl-build") ;; TODO: support API
(:file "build")
(:file "deprecated")))))
abcl-src-1.9.2/contrib/abcl-build/build/abcl-build.lisp 0100644 0000000 0000000 00000001425 14343623723 021375 0 ustar 00 0000000 0000000 (in-package :abcl/build)
(defun make-dist (version-string)
(warn "Unimplemented"))
(defun build-abcl (&key
force ;; DEPRECATED: not sure of meaning in new underlying API
(batch t) ;; DEPRECATED: lack of meaning
compile-system ;; DEPRECATED: COMPILE-SYSTEM is always invoked
jar ;; DEPRECATED: a jar archive is always built
clean
full) ;; DEPRECATED: a full build is always performed
(unless (ignore-errors (asdf:find-system :abcl))
(return-from build-abcl
nil))
(let ((targets '("abcl")))
(when clean
(push "abcl.clean" targets))
(ant/call (asdf:system-relative-pathname :abcl "build.xml")
(nreverse targets))))
abcl-src-1.9.2/contrib/abcl-build/build/ant.lisp 0100644 0000000 0000000 00000006023 14343623723 020160 0 ustar 00 0000000 0000000 (in-package :abcl/build)
;; TODO function to deal with looking up a locally preferred mirrors
(defun ant-zip-uri ()
#p"https://archive.apache.org/dist/ant/binaries/apache-ant-1.9.16-bin.zip"
#+(or) ;; need apache-ant-1.9 for JVM version 49.0
#p"https://www-eu.apache.org/dist/ant/binaries/apache-ant-1.10.12-bin.zip")
(defun xdg/ant-executable ()
(xdg/executable (ant-zip-uri) "bin/ant"))
#+(or)
(defun xdg/ant-executable ()
(let* ((uri (ant-zip-uri))
(directory (xdg/abcl-install-root uri))
(ant-root-name (let ((name (pathname-name uri)))
(subseq name 0 (- (length name) (length "-bin")))))
(ant-home (merge-pathnames (make-pathname :directory `(:relative ,ant-root-name))
directory))
(ant (merge-pathnames #p"bin/ant" ant-home))
result)
(dolist (p (possible-executable-names ant))
(when (probe-file p)
(return-from xdg/ant-executable
(values
(probe-file p)
ant))))
;; failure
(values
nil
ant)))
(defun ant/install ()
(unless (xdg/ant-executable)
(xdg/install (ant-zip-uri) :type :unzip))
(values
(xdg/ant-executable)
(directory (merge-pathnames "**/*"
(xdg/abcl-install-root (ant-zip-uri))))))
(defparameter *ant-home* nil)
(define-condition no-installed-ant (error)
((searched))
(:report (lambda (condition stream)
(declare (ignore condition))
(format stream "Unable to introspect Apache Ant installation."))))
;; TODO after this routines executes *ANT-EXECUTABLE-DIRECTORY* and XDG/ANT-EXECUTABLE will work
(defun ensure-ant (&key (ant-home nil ant-home-p))
"Ensure that Apache Ant may be invoked, installing one if necessary"
(cond
((and (null ant-home) ant-home-p)
(warn "Unimplemented explicit auto-configuration run."))
((and ant-home ant-home-p)
(warn "Unimplemented explicit configuration with specified directory directory."))
(t
(if *ant-home*
*ant-home*
(restart-case
(let ((ant-home (some-directory-containing "ant")))
(unless ant-home
(signal 'no-installed-ant))
(setf *ant-home ant-home))
(install-ant ()
(ant/install)))))))
(defmacro with-ensured-ant ((ant) &body body)
`(progn
(unless ,ant
(setf ,ant (ensure-ant)))
,@body))
(defun ant/call (ant-file target-or-targets)
"Synchronously invoke external Apache Ant on ANT-FILE with TARGET-OR-TARGETS"
(let ((ant-file-pathname (if (typep ant-file 'pathname)
ant-file
(merge-pathnames ant-file)))
ant)
(with-ensured-ant (ant)
(warn "About to invoke synchronous call to run external proccessâŠ")
(uiop:run-program
`(,ant "-buildfile"
,(stringify ant-file-pathname)
,@(listify target-or-targets))
:ignore-error-status t
:error-output :string
:output :string))))
abcl-src-1.9.2/contrib/abcl-build/build/build.lisp 0100644 0000000 0000000 00000000637 14343623723 020502 0 ustar 00 0000000 0000000 (in-package :abcl/build)
(defun abcl/build ()
(abcl-build:ant/call (asdf:system-relative-pathname :abcl "build.xml")
"abcl"))
(defun abcl/dist ()
(abcl-build:ant/call (asdf:system-relative-pathname :abcl "build.xml")
"abcl.release"))
(defun abcl/test ()
(abcl-build:ant/call (asdf:system-relative-pathname :abcl "build.xml")
"abcl.test"))
abcl-src-1.9.2/contrib/abcl-build/build/customizations-default.lisp 0100644 0000000 0000000 00000001764 14343623723 024122 0 ustar 00 0000000 0000000 ;;; Copy this file to "customizations.lisp"
;;; User customizations for the build.
;;; This file is LOADed by INITIALIZE-BUILD (in build-abcl.lisp).
;;; The variable *PLATFORM-IS-WINDOWS* should be true on Windows platforms. You
;;; can, of course, substitute your own test for this in the code below, or add
;;; a section for OS X, or Solaris, or whatever...
;;; You MUST set *JDK* to the location of the JDK you want to use. Remove or
;;; comment out settings that don't apply to your situation.
;;; You don't really need to specify anything but *JDK*. *JAVA-COMPILER* and
;;; *JAR* default to javac and jar, respectively, from the configured JDK.
;;; Directories should be specified with a trailing slash (or, on Windows, a
;;; trailing backslash).
(in-package :abcl/build)
;; Standard compiler options.
(defparameter *javac-options*
"-g")
(defparameter *jikes-options*
"+D -g")
(defparameter *jdk*
(cond
((uiop:os-macosx-p)
"/usr/")
(t
(introspect-path-for "javac"))))
abcl-src-1.9.2/contrib/abcl-build/build/deprecated.lisp 0100644 0000000 0000000 00000045627 14343623723 021513 0 ustar 00 0000000 0000000 ;;;; Historic cross platform build infrastructure
;;;; N.b. currently unused in favor of canonicalizing build.xml
(in-package :abcl/build)
(defun chop-end-from-char (string char)
"Chops off the character at the end of `string' if it matches char"
(let ((len (length string)))
(if (eql char (char string (1- len)))
(subseq string 0 (1- len))
string)))
(defun safe-namestring (pathname)
(let ((string (namestring pathname)))
(when (position #\space string)
(setf string (concatenate 'string "\""
(chop-end-from-char string #\\)
"\"")))
string))
(defun child-pathname (pathname parent)
"Returns `pathname' relative to `parent', assuming that it
is infact a child of it while being rooted at the same root as `parent'."
(let ((path-dir (pathname-directory pathname))
(parent-dir (pathname-directory parent)))
(do ((p1 path-dir (cdr p1))
(p2 parent-dir (cdr p2)))
((or (endp p2) (not (equal (car p1) (car p2))))
(when (endp p2)
(make-pathname :directory (cons :relative p1)
:defaults pathname))))))
(defun file-newer (orig artifact)
"Compares file date/time of `orig' and `artifact', returning
`NIL' if `orig' is newer than `artifact'."
(or (null (probe-file artifact))
(> (file-write-date orig)
(file-write-date artifact))))
(defparameter *file-separator-char*
(if (uiop:os-windows-p) #\\ #\/))
(defparameter *path-separator-char*
(if (uiop:os-windows-p) #\; #\:))
(defparameter *tree-root*
(make-pathname :device (pathname-device *load-truename*)
:directory (pathname-directory *load-truename*)))
(defparameter *build-root*
(merge-pathnames "build/classes/" *tree-root*))
(defparameter *source-root*
(merge-pathnames "src/" *tree-root*))
(defparameter *dist-root*
(merge-pathnames "dist/" *tree-root*))
(defparameter *customizations-file*
(merge-pathnames "customizations.lisp" *tree-root*))
(defparameter *abcl-dir*
(merge-pathnames "src/org/armedbear/lisp/" *tree-root*))
(defparameter *jdk* nil)
(defparameter *java-compiler* nil)
(defparameter *javac-options* nil)
(defparameter *jikes-options* nil)
(defparameter *jar* nil)
(defvar *classpath*)
(defvar *java*)
(defvar *java-compiler-options*)
(defvar *java-compiler-command-line-prefix*)
(defun initialize-build ()
;;; FIXME: highly breakable; user shouldn't be reading
(load (asdf:system-relative-pathname :build-abcl
"src/org/abcl/lisp/build/customizations-default.lisp"))
(setf *java*
(introspect-path-for "java"))
(unless *java*
(error "Can't find Java executable."))
(unless *java-compiler*
(setf *java-compiler* (introspect-path-for "java")))
(unless *jar*
(setf *jar* (introspect-path-for "jar")))
(let ((classpath-components (list *source-root*
(if (uiop:os-macosx-p)
#p"/System/Library/Frameworks/JavaVM.framework/Classes/classes.jar"
(merge-pathnames "jre/lib/rt.jar" *jdk*)))))
(setf *classpath*
(with-output-to-string (s)
(do* ((components classpath-components (cdr components))
(component (car components) (car components)))
((null components))
(princ (safe-namestring component) s)
(unless (null (cdr components))
(write-char *path-separator-char* s))))))
(let ((prefix (concatenate 'string
(safe-namestring *java-compiler*)
" -classpath " *classpath*)))
(setf *java-compiler-options*
(if (string-equal (pathname-name (pathname *java-compiler*)) "jikes")
*jikes-options*
*javac-options*))
(setf prefix
(if *java-compiler-options*
(concatenate 'string prefix " " *java-compiler-options* " ")
(concatenate 'string prefix " ")))
(setf *java-compiler-command-line-prefix* prefix)))
(defun substitute-in-string (string substitutions-alist)
(dolist (entry substitutions-alist)
(loop named replace
for index = (search (car entry) string :test #'string=)
do
(unless index
(return-from replace))
(setf string (concatenate 'string
(subseq string 0 index)
(cdr entry)
(subseq string (+ index (length (car entry))))))))
string)
(defun copy-with-substitutions (source-file target-file substitutions-alist)
(with-open-file (in source-file :direction :input)
(with-open-file (out target-file :direction :output :if-exists :supersede)
(loop
(let ((string (read-line in nil)))
(when (null string)
(return))
(write-line (substitute-in-string string substitutions-alist) out))))))
(defun build-javac-command-line (source-file)
(concatenate 'string
*java-compiler-command-line-prefix*
" -d "
(safe-namestring *build-root*)
" "
(namestring source-file)))
(defun java-compile-file (source-file)
(let ((command-line (build-javac-command-line source-file)))
;; TODO: detect failure of invocation
(values
(uiop:run-program command-line
:directory *abcl-dir*
:output :string))
command-line))
(defun do-compile-classes (force batch)
(let* ((source-files
(remove-if-not
#'(lambda (name)
(let ((output-name
(merge-pathnames
(make-pathname :type "class"
:defaults (child-pathname name
*source-root*))
*build-root*)))
(or force
(file-newer name output-name))))
(directory (merge-pathnames "**/*.java" *source-root*)))))
(format t "~&JDK: ~A~%" *jdk*)
(format t "Java compiler: ~A~%" *java-compiler*)
(format t "Compiler options: ~A~%~%" (if *java-compiler-options* *java-compiler-options* ""))
(format t "~&Compiling Java sources...")
(finish-output)
(cond ((null source-files)
(format t "Classes are up to date.~%")
(finish-output)
t)
(t
(cond (batch
(ensure-directories-exist *build-root*)
(let* ((cmdline (with-output-to-string (s)
(princ *java-compiler-command-line-prefix* s)
(princ " -d " s)
(princ (safe-namestring *build-root*) s)
(princ #\Space s)
(dolist (source-file source-files)
(princ (safe-namestring (namestring source-file)) s)
(princ #\space s))))
(status (run-shell-command cmdline :directory *tree-root*)))
(format t " done.~%")
(equal 0 status)))
(t
(ensure-directories-exist *build-root*)
(dolist (source-file source-files t)
(unless (java-compile-file (safe-namestring source-file))
(format t "Build failed.~%")
(return nil)))))))))
(defun make-jar ()
(let ((*default-pathname-defaults* *tree-root*)
(jar-namestring (namestring *jar*)))
(when (position #\space jar-namestring)
(setf jar-namestring (concatenate 'string "\"" jar-namestring "\"")))
(let ((substitutions-alist (acons "@JAR@" jar-namestring nil))
(source-file (if (uiop:os-windows-p) "make-jar.bat.in" "make-jar.in"))
(target-file (if (uiop:os-windows-p) "make-jar.bat" "make-jar"))
(command (if (uiop:os-windows-p) "make-jar.bat" "sh make-jar")))
(copy-with-substitutions source-file target-file substitutions-alist)
(ensure-directories-exist *dist-root*)
(let ((status (run-shell-command command :directory *tree-root*)))
(unless (equal 0 status)
(format t "~A returned ~S~%" command status))
status))))
(defun do-compile-system (&key (zip t))
(format t "~&Compiling Lisp sources...")
(terpri)
(finish-output)
(let* ((java-namestring (safe-namestring *java*))
status
(abcl-home (substitute-in-string
(namestring *abcl-dir*)
(when (uiop:os-windows-p)
'(("\\" . "/")
("/" . "\\\\")))))
(output-path (substitute-in-string
(namestring
(merge-pathnames "build/classes/org/armedbear/lisp/"
*tree-root*))
(when (uiop:os-windows-p)
'(("\\" . "/")))))
(cmdline (format nil
"~A -cp build/classes -Dabcl.home=\"~A\" ~
org.armedbear.lisp.Main --noinit --nosystem ~
--eval \"(compile-system :zip ~A :quit t :output-path \\\"~A\\\")\"~%"
java-namestring
abcl-home
(not (not zip)) ;; because that ensures T or NIL
output-path)))
(ensure-directories-exist output-path)
(setf status (run-shell-command cmdline :directory *tree-root*))
(format t " done.~%")
status))
;; abcl/abcl.bat
(defun make-launch-script ()
;; Use the -Xss4M and -Xmx256M flags so that the default launch script can be
;; used to build sbcl.
(cond ((uiop:os-windows-p)
(with-open-file (s
(merge-pathnames "abcl.bat" *tree-root*)
:direction :output
:if-exists :supersede)
(format s "~A -Xss4M -Xmx256M -cp \"~A\" org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9~%"
(safe-namestring *java*)
(namestring (merge-pathnames "dist\\abcl.jar" *tree-root*)))))
(t
(let ((pathname (merge-pathnames "abcl" *tree-root*)))
(with-open-file (s pathname :direction :output :if-exists :supersede)
(format s "#!/bin/sh~%exec ~A -Xss4M -Xmx256M -cp ~A org.armedbear.lisp.Main \"$@\"~%"
(safe-namestring *java*)
(safe-namestring (merge-pathnames "abcl.jar" *dist-root*))))
(run-shell-command (format nil "chmod +x ~A" (safe-namestring pathname))
:directory *tree-root*)))))
(defun build-stamp ()
(multiple-value-bind
(second minute hour date month year day daylight-p zone)
(decode-universal-time (get-universal-time))
(declare (ignore daylight-p))
(setf day (nth day '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")))
(setf month (nth (1- month) '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
(setf zone (* zone 100)) ;; FIXME
(format nil "~A ~A ~D ~D ~2,'0D:~2,'0D:~2,'0D -~4,'0D"
day month date year hour minute second zone)))
(defun make-build-stamp ()
(with-open-file (s
(merge-pathnames (make-pathname :name "build"
:defaults *abcl-dir*))
:direction :output
:if-exists :supersede)
(format s "~A" (build-stamp))))
(defun delete-files (pathnames)
(dolist (pathname pathnames)
(let ((truename (probe-file pathname)))
(when truename
(delete-file truename)))))
(defun clean ()
(format t "~&Cleaning compilation results.")
(dolist (f (list (list *tree-root* "abcl.jar" "abcl.bat" "make-jar.bat"
"compile-system.bat")
;; as of 0.14 'compile-system.bat' isn't created anymore
;; as of 0.14 'abcl.jar' is always created in dist/
(list *abcl-dir* "*.class" "*.abcl" "*.cls"
"native.h" "libabcl.so" "build")
;; as of 0.14, native.h and libabcl.so have been removed
(list (merge-pathnames "util/" *abcl-dir*) "*.class")
(list (merge-pathnames "build/classes/org/armedbear/lisp/"
*tree-root*)
"*.class" "*.abcl" "*.cls"
"native.h" "libabcl.so" "build")
(list (merge-pathnames
"build/classes/org/armedbear/lisp/util/"
*tree-root*)
"*.class" "*.abcl" "*.cls")
(list *dist-root* "*.jar" "*.class" "*.abcl" "*.cls")
(list (merge-pathnames "java/awt/" *abcl-dir*)
"*.class")))
(let ((default (car f)))
(when (probe-directory default)
(delete-files (mapcan #'(lambda (name)
(directory (merge-pathnames name default)))
(cdr f)))))))
#+(or)
(defun build-abcl (&key force
(batch t)
compile-system
jar
clean
full)
(let ((start (get-internal-real-time)))
#+lispworks
(when (uiop:os-windows-p)
(setf batch nil))
(initialize-build)
(format t "~&Platform: ~A~%" (software-type))
(finish-output)
;; clean
(when clean
(clean))
;; Compile Java source into classes
(unless (do-compile-classes force batch)
(format t "Build failed.~%")
(return-from build-abcl nil))
;; COMPILE-SYSTEM
(when (or full compile-system)
(let* ((zip (if (or full jar) nil t))
(status (do-compile-system :zip zip)))
(unless (equal 0 status)
(format t "Build failed.~%")
(return-from build-abcl nil))))
;; abcl.jar
(when (or full jar)
(let ((status (make-jar)))
(unless (equal 0 status)
(format t "Build failed.~%")
(return-from build-abcl nil))))
;; abcl/abcl.bat
(make-launch-script)
(make-build-stamp)
(let ((end (get-internal-real-time)))
(format t "Build completed successfully in ~A seconds.~%"
(/ (float (- end start)) internal-time-units-per-second)))
t))
(defun build-abcl-executable ()
(let* ((*default-pathname-defaults* *abcl-dir*)
(source-files (directory "*.java"))
(cmdline (with-output-to-string (s)
(princ "gcj -g -O0 " s)
(dolist (source-file source-files)
(unless (string= (pathname-name source-file) "Native")
(princ (pathname-name source-file) s)
(princ ".java" s)
(princ #\space s)))
(princ "--main=org.armedbear.lisp.Main -o lisp" s)))
(result (run-shell-command cmdline :directory *abcl-dir*)))
(equal 0 result)))
(defvar *copy-verbose* nil)
(defun copy-file (source target)
(when *copy-verbose*
(format t "~A -> ~A~%" source target))
(let ((buffer (make-array 4096 :element-type '(unsigned-byte 8))))
(with-open-file (in source :direction :input :element-type '(unsigned-byte 8))
(with-open-file (out target :direction :output :element-type '(unsigned-byte 8)
:if-exists :supersede)
(loop
(let ((end (read-sequence buffer in)))
(when (zerop end)
(return))
(write-sequence buffer out :end end)))))))
(defun copy-files (files source-dir target-dir)
(ensure-directories-exist target-dir)
(dolist (file files)
(copy-file (merge-pathnames file source-dir)
(merge-pathnames file target-dir))))
(defun make-dist-dir (version-string)
(unless (uiop:os-unix-p)
(error "MAKE-DIST is only supported on Unices."))
(let ((target-root (pathname (concatenate 'string "/var/tmp/" version-string "/"))))
(when (probe-directory target-root)
(error "Target directory ~S already exists." target-root))
(let* ((source-dir *tree-root*)
(target-dir target-root)
(files (list "README"
"COPYING"
"build-abcl.lisp"
"customizations.lisp"
"make-jar.bat.in"
"make-jar.in")))
(copy-files files source-dir target-dir))
(let* ((source-dir (merge-pathnames "examples/" *tree-root*))
(target-dir (merge-pathnames "examples/" target-root))
(files '("hello.java")))
(copy-files files source-dir target-dir))
(let* ((target-dir (merge-pathnames "src/" target-root))
(files '("manifest-abcl")))
(copy-files files *source-root* target-dir))
(let* ((source-dir *abcl-dir*)
(target-dir (merge-pathnames "src/org/armedbear/lisp/" target-root))
(*default-pathname-defaults* source-dir)
(files (mapcar #'file-namestring (append (directory "*.java")
(directory "*.lisp")
(list "LICENSE" "native.c")))))
(copy-files files source-dir target-dir))
(let* ((source-dir (merge-pathnames "tests/" *abcl-dir*))
(target-dir (merge-pathnames "src/org/armedbear/lisp/tests/" target-root))
(*default-pathname-defaults* source-dir)
(files (append (mapcar #'file-namestring (directory "*.lisp"))
(list "jl-config.cl"))))
(copy-files files source-dir target-dir))
(let* ((source-dir (merge-pathnames "java/awt/" *abcl-dir*))
(target-dir (merge-pathnames "src/org/armedbear/lisp/java/awt/" target-root))
(*default-pathname-defaults* source-dir)
(files (mapcar #'file-namestring (directory "*.java"))))
(copy-files files source-dir target-dir))
target-root))
#+(or)
(defun make-dist (version-string)
(let* ((dist-dir (make-dist-dir version-string))
(parent-dir (merge-pathnames (make-pathname :directory '(:relative :back))
dist-dir)))
(let* ((command (format nil "tar czf ~A~A.tar.gz ~A"
(namestring parent-dir)
version-string version-string))
(status (run-shell-command command :directory parent-dir)))
(unless (equal 0 status)
(format t "~A returned ~S~%" command status)))
(let* ((command (format nil "zip -q -r ~A~A.zip ~A"
(namestring parent-dir)
version-string version-string))
(status (run-shell-command command :directory parent-dir)))
(unless (equal 0 status)
(format t "~A returned ~S~%" command status)))))
abcl-src-1.9.2/contrib/abcl-build/build/install.lisp 0100644 0000000 0000000 00000004620 14343623723 021045 0 ustar 00 0000000 0000000 #-abcl (error "Sorry, but this only currently works with the Bear.")
(in-package :abcl/build)
(defun xdg/abcl-install-root (uri)
"Return the private xdg rooted installation location for URI."
(merge-pathnames
(make-pathname :directory `(:relative "abcl" "install" ,(pathname-name uri)))
(uiop/configuration:xdg-data-home)))
(defun xdg/abcl-download-root (&key (for-uri nil for-uri-p))
(declare (ignore for-uri-p))
(let ((root (merge-pathnames
(make-pathname :directory '(:relative "abcl" "dist"))
(uiop/configuration:xdg-data-home)))) ;; TODO move to proper XDG cache hierarchy
(unless for-uri
(return-from xdg/abcl-download-root root))
(let* ((uri (if (pathnamep for-uri)
for-uri
(pathname for-uri)))
(name (pathname-name uri)))
(merge-pathnames
(make-pathname :directory `(:relative ,name))
root))))
(defgeneric xdg/install ((uri pathname) &key type)
(:method ((uri pathname) &key (type :unzip))
(declare (ignore type))
(download-and-unzip uri)))
(defun download-and-unzip (uri)
(let ((archive
(download uri))
(root
(xdg/abcl-install-root uri)))
(ensure-directories-exist root)
(sys:unzip archive root)
(values
root
(directory (merge-pathnames "**/*" root)))))
(defun download (uri &key (destination
(merge-pathnames
(make-pathname :defaults uri :host nil :device nil :directory nil)
(xdg/abcl-download-root))))
"Download the contents of URI to DESTINATION.
Returns the local pathname of the download artifact."
(ensure-directories-exist destination)
(uiop:copy-file
(open uri :direction :input)
destination)
destination)
(defun xdg/executable (uri relative-path)
(let* ((directory (xdg/abcl-install-root uri))
(root (let ((name (pathname-name uri)))
(subseq name 0 (- (length name) (length "-bin")))))
(home (merge-pathnames (make-pathname :directory `(:relative ,root))
directory))
(path (merge-pathnames relative-path home)))
(dolist (p (possible-executable-names path))
(when (probe-file p)
(return-from xdg/executable
(values
(probe-file p)
path))))
;; failure
(values
nil
path)))
abcl-src-1.9.2/contrib/abcl-build/build/maven.lisp 0100644 0000000 0000000 00000004105 14343623723 020503 0 ustar 00 0000000 0000000 (in-package :abcl/build)
(defun maven-zip-uri ()
#p"https://archive.apache.org/dist/maven/maven-3/3.6.3/binaries/apache-maven-3.6.3-bin.zip")
(defun xdg/mvn-executable ()
(xdg/executable (maven-zip-uri) "bin/mvn"))
(defparameter *maven-install-root* nil)
(defun mvn/install ()
"Unless (XDG/MVN-EXECUTABLE) install a version of Maven in the XDG hierarchy
Returns the local path of the resulting mvn executable."
(unless (xdg/mvn-executable)
(xdg/install (maven-zip-uri) :type :unzip))
(values
(xdg/mvn-executable)
(directory (merge-pathnames
"**/*" (xdg/abcl-install-root (maven-zip-uri))))))
(defparameter *mvn-home* nil)
(define-condition no-installed-maven (error)
((searched :initarg :searched))
(:report (lambda (condition stream)
(declare (ignore condition))
(format stream "Unable to introspect local Apache Maven installation."))))
(defun ensure-maven (&key (mvn-home *mvn-home* mvn-home-p)
(use-xdg-mvn nil use-xdg-mvn-p))
"Ensure that the implementation can find and execute the Maven build tool
If MVN-HOME is specified, attempt to configure use of that directory."
(declare (ignore use-xdg-mvn use-xdg-mvn-p))
(cond
((and (null mvn-home) mvn-home-p)
(warn "Unimplemented explicit auto-configuration run."))
((and mvn-home mvn-home-p)
(warn "Unimplemented explicit configuration with specified directory directory."))
(t
(if *mvn-home*
*mvn-home*
(restart-case
(let ((mvn-home (some-directory-containing "mvn")))
(unless mvn-home
(signal 'no-installed-maven))
(setf *mvn-home* mvn-home))
(install-maven ()
(mvn/install)))))))
(defmacro with-ensured-mvn ((maven) &body body)
`(progn
(unless ,maven
(setf ,maven (ensure-maven))
,@body)))
(defun mvn/call (pom-file target-or-targets)
(let (mvn)
(with-ensured-mvn (mvn)
(uiop:run-program
`(,mvn "--file" ,(stringify pom-file)
,@(listify target-or-targets))
:output :string))))
abcl-src-1.9.2/contrib/abcl-build/build/package.lisp 0100644 0000000 0000000 00000002206 14343623723 020770 0 ustar 00 0000000 0000000 (in-package :cl-user)
(defpackage build-abcl
(:use :cl)
(:nicknames :build-abcl :abcl-build :abcl/build)
(:export
#:abcl/build
#:abcl/dist
#:abcl/test
;; deprecated TODO: hook into new interfaces
#:build-abcl
#:make-dist
;; utility functions that should be moved into utility package
#:introspect-path-for
#:split-string
#:possible-executable-names
#:probe-for-executable
#:stringify
#:listify
#:some-directory
#:copy-directory-recursively
;;; lower-level
#:xdg/abcl-install-root
#:xdg/abcl-download-root
#:xdg/install
#:locally-install-and-unzip
#:download-and-unzip
#:download
#:xdg/ant-executable
#:with-ensured-ant
#:ant/install
#:ant/call
#:with-ensured-maven
#:ensure-maven
#:mvn/install
#:mvn/call
#:directory-hashes
#:hashes-report
#:install-zip
#:download-artifact)
;;; TODO: use UIOP, currently only used for deprecated, old build system
#+abcl
(:import-from #:extensions #:run-shell-command #:probe-directory)
#+allegro
(:import-from #:excl #:probe-directory)
#+clisp
(:import-from #:ext #:probe-directory))
abcl-src-1.9.2/contrib/abcl-build/build/report.lisp 0100644 0000000 0000000 00000002034 14343623723 020707 0 ustar 00 0000000 0000000 (in-package :abcl/build)
;;; FIXME: will not work if DIRECTORY contains subdirectories
(defun directory-hashes (directory)
"Return the size and sha256 hash of every direct entry of DIRECTORY."
(let ((d (if (typep directory 'pathname)
directory
(pathname (concatenate 'string directory "/")))))
(let ((result
(loop :for file
:in (directory (merge-pathnames "*.*" d))
:collecting (list
file
(with-open-file (s file :direction :input)
(when s
(file-length s)))
(sys:sha256 file)))))
(values
result
(hashes-report result)))))
(defun hashes-report (report)
(format nil "~{~a~}~%"
(loop :for (file size hash) :in report
:collecting (format nil "~%~%~t:size ~a ;~%~t:sha256 ~a ."
file size hash))))
abcl-src-1.9.2/contrib/abcl-build/build/t/abcl-build.lisp 0100644 0000000 0000000 00000001375 14343623723 021644 0 ustar 00 0000000 0000000 (in-package :cl-user)
(if (not (ignore-errors (asdf:find-system :abcl)))
(prove:diag "Unable to find 'abcl.asd'.~&Enable ASDF to find 'abcl.asd' by adding symlink to ~~/common-lisp/ to ABCL source directory.")
(prove:subtest "Testing BUILD-ABCL."
(prove:plan 2)
(prove:ok
(abcl-build:build-abcl)
"Testing BUILD-ABCLâŠ")
(prove:ok
(abcl-build:make-dist (format nil "test-" (random (expt 2 32))))
"Testing MAKE-DISTâŠ")
#+abcl-build-test-more
(progn
(prove:ok
(abcl-build:build-abcl :clean t)
"Testing BUILD:ABCL cleanâŠ"))
#+abcl-build-test-more
(prove:ok
(abcl-build:build-abcl :force t)
"Testing BUILD-ABCL forceâŠ")))
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-build/build/t/ant.lisp 0100644 0000000 0000000 00000001205 14343623723 020420 0 ustar 00 0000000 0000000 (in-package :cl-user)
(prove:plan 1)
(prove:ok
(build-abcl:ant/install)
"Testing ABCL-specific Ant installation of Ant into XDG hierarchyâŠ")
(if (not (ignore-errors (asdf:find-system :abcl)))
(prove:diag "Unable to find 'abcl.asd'.~&Enable ASDF to find 'abcl.asd' by adding symlink to ~~/common-lisp/ to ABCL source directory.")
(let ((ant-file (asdf:system-relative-pathname :abcl "build.xml")))
(prove:plan 1)
(prove:ok
(abcl-build:ant/call ant-file "abcl.diagnostic")
(format nil "Testing invocation of private Ant on main ABCL build artifact at ~&~2,t~aâŠ" ant-file))))
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-build/build/t/install.lisp 0100644 0000000 0000000 00000001314 14343623723 021305 0 ustar 00 0000000 0000000 (in-package :cl-user)
(let ((uri #p"https://downloads.apache.org/ant/binaries/apache-ant-1.10.12-bin.zip"))
(prove:plan 1)
(prove:ok
(abcl/build:xdg/abcl-install-root uri)
(format nil "Suitable install root for <~a>" uri))
(prove:plan 2)
(let ((path (ext:make-temp-directory)))
(prove:diag
(format nil "Testing binary unzip installation of~%~,2t<~a>~%to~%~,2t '~a'." uri path))
(multiple-value-bind (root contents)
(abcl/build:xdg/install uri)
(prove:ok (and root
(probe-file root)))
(prove:ok (and
(consp contents)
(> (length contents) 0))))))
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-build/build/t/maven.lisp 0100644 0000000 0000000 00000001135 14343623723 020746 0 ustar 00 0000000 0000000 (in-package :cl-user)
(prove:plan 1)
(prove:ok
(abcl/build:mvn/install)
"Testing ABCL-specific Ant installation of Maven into XDG hierarchyâŠ")
(if (not (ignore-errors (asdf:find-system :abcl)))
(prove:diag "Unable to find 'abcl.asd'.~&Enable ASDF to find 'abcl.asd' by adding symlink to ~~/common-lisp/ to ABCL source directory.")
(let ((pom (asdf:system-relative-pathname :abcl "pom.xml")))
(prove:ok (abcl/build:mvn/call pom "install")
(format nil "Testing invocation of private Maven on root ABCL POM at~&~2,t~aâŠ"
pom))))
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-build/build/t/util.lisp 0100644 0000000 0000000 00000000356 14343623723 020621 0 ustar 00 0000000 0000000 (in-package :cl-user)
(prove:plan 1)
(prove:is-type (abcl/build:possible-executable-names "java")
'cons)
(prove:plan 1)
(prove:is (length (abcl/build:split-string "one.two.three." #\.))
4)
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-build/build/util.lisp 0100644 0000000 0000000 00000007646 14343623723 020367 0 ustar 00 0000000 0000000 ;;;; TODO: move to a utility package
(in-package :abcl/build)
;;; TODO remove
(defun localize-executable-name (name)
(let* ((p (if (pathnamep name)
name
(pathname name)))
(type (pathname-type p)))
(make-pathname :defaults p
:type
(if (uiop:os-windows-p)
(when (null type)
"exe")
type))))
(defun possible-executable-names (name
&key (suffixes '("exe" "cmd" "bat") suffixes-p))
(let* ((p (if (pathnamep name)
name
(pathname name)))
(type (pathname-type p)))
(declare (ignore type))
(unless (or (uiop:os-windows-p) suffixes-p)
(return-from possible-executable-names
(listify name)))
(loop
:for suffix :in suffixes
:with result = (list p)
:doing (push (make-pathname :defaults p :type suffix)
result)
:finally (return (nreverse result)))))
(defun introspect-path-for (executable)
(let ((which-command (if (uiop:os-windows-p)
"where"
"which")))
(when (ignore-errors
(uiop:run-program (list which-command which-command) :output :string))
(dolist (p (possible-executable-names executable))
(let ((raw-result
(ignore-errors (uiop:run-program
(list which-command
(namestring p))
:output :string))))
(when raw-result
(let ((result (first (split-string raw-result #\Newline))))
(return-from introspect-path-for
(values
result
(pathname result))))))))))
(defun probe-for-executable (directory executable)
(dolist (executable (possible-executable-names executable))
(let ((pathname
(probe-file
(merge-pathnames executable directory))))
(when pathname
(return-from probe-for-executable
pathname)))))
(defun split-string (string split-char)
(loop :for i = 0 :then (1+ j)
:as j = (position split-char string :test #'string-equal :start i)
:collect (subseq string i j)
:while j))
(defun stringify (thing)
(cond
((pathnamep thing)
(namestring thing))
((stringp thing)
thing)
(t
(error "Don't know how stringify ~a." thing))))
(defun listify (thing)
(if (consp thing)
thing
(list thing)))
(defun some-directory-containing (executable)
;; search path
(let ((in-path (introspect-path-for executable)))
(when in-path
(return-from some-directory-containing
in-path))
(dolist (d (if (uiop:os-windows-p)
'(#p"c:/Program Files/") ;; TODO localize me!
'(#p"/usr/local/bin/" #p"/opt/local/bin/" #p"/usr/bin/")))
(let* ((e (localize-executable-name
(merge-pathnames executable d)))
(p (probe-file e)))
(when p
(return-from some-directory-containing p))))))
(defun copy-directory-recursively (from to)
(flet ((normalize-to-directory (p)
(when (or (not (pathnamep p))
(not (and (null (pathname-name p))
(null (pathname-type p)))))
(setf p (make-pathname :defaults p
:name nil :type nil)))
p))
(normalize-to-directory from)
(normalize-to-directory to)
(let ((wildcard (merge-pathnames "**/*" from)))
(loop :for source :in (directory wildcard)
:for relative = (enough-namestring source from)
:for destination = (merge-pathnames relative to)
:doing
(progn
(ensure-directories-exist destination)
(when (or (pathname-name destination)
(pathname-type destination))
(uiop:copy-file source destination)))))))
abcl-src-1.9.2/contrib/abcl-introspect/README.org 0100644 0000000 0000000 00000016631 14343623723 020155 0 ustar 00 0000000 0000000 * ABCL-INTROSPECT
** Introduction
ABCL-INTROSPECT offers more extensive systems for inspecting the state
of the implementation, most notably in integration with SLIME, where
the back-trace mechanism is augmented to the point that local
variables are inspectable.
Version of SLIME 2.25 dramatically increases the utility of the
available inspectors under ABCL. Unfortunately, this version of SLIME
is unreleased, so please use something post
.
** CL:DISASSEMBLE
ABCL-INTROSPECT also contains a number of ASDF systems which provide
modules to install as implementations for the JVM code analysis
provided by CL:DISASSEMBLE.
#+TABLE: Currently available decompilers as ASDF systems
|------------+--------------------------+-----------------------------------------------------------------------------|
| ASDF | status | URI |
|------------+--------------------------+-----------------------------------------------------------------------------|
| objectweb | working | |
| javap | working | < |
| cfr | working | |
| jad | fails ABCL-BUILD/install | |
| procyon | loading | |
| fernflower | loading | |
These systems may be used by first loading the appropiate ASDF
definition then using the SYS:CHOOSE-DISASSEMBLER function to select
the loaded system. Currently available disassemblers are contained in
the SYS:*DISASSEMBLERS* variable.
#+caption: Using the ~javap~ Tool to Disassemble a Function
#+begin_src lisp
(require :abcl-contrib)
(asdf:load-system :javap)
(sys:choose-disassembler :javap)
(cl:disassemble #'cons)
; Classfile /var/folders/yb/xlwjwjfs3l73n3vrcjwqwqs40000gn/T/abcl3108750031103632433.class
; Last modified May 11, 2020; size 910 bytes
; MD5 checksum fec1c72a76ccbb35e17be8c2de9b315e
; Compiled from "Primitives.java"
; final class org.armedbear.lisp.Primitives$pf_cons extends org.armedbear.lisp.Primitive
; minor version: 0
; major version: 52
; flags: ACC_FINAL, ACC_SUPER
; Constant pool:
; #1 = Fieldref #24.#25 // org/armedbear/lisp/Symbol.CONS:Lorg/armedbear/lisp/Symbol;
; #2 = String #26 // object-1 object-2
; #3 = Methodref #7.#27 // org/armedbear/lisp/Primitive."":(Lorg/armedbear/lisp/Symbol;Ljava/lang/String;)V
; #4 = Class #28 // org/armedbear/lisp/Cons
; #5 = Methodref #4.#29 // org/armedbear/lisp/Cons."":(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V
; #6 = Class #31 // org/armedbear/lisp/Primitives$pf_cons
; #7 = Class #32 // org/armedbear/lisp/Primitive
; #8 = Utf8
; #9 = Utf8 ()V
; #10 = Utf8 Code
; #11 = Utf8 LineNumberTable
; #12 = Utf8 LocalVariableTable
; #13 = Utf8 this
; #14 = Utf8 pf_cons
; #15 = Utf8 InnerClasses
; #16 = Utf8 Lorg/armedbear/lisp/Primitives$pf_cons;
; #17 = Utf8 execute
; #18 = Utf8 (Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;
; #19 = Utf8 first
; #20 = Utf8 Lorg/armedbear/lisp/LispObject;
; #21 = Utf8 second
; #22 = Utf8 SourceFile
; #23 = Utf8 Primitives.java
; #24 = Class #33 // org/armedbear/lisp/Symbol
; #25 = NameAndType #34:#35 // CONS:Lorg/armedbear/lisp/Symbol;
; #26 = Utf8 object-1 object-2
; #27 = NameAndType #8:#36 // "":(Lorg/armedbear/lisp/Symbol;Ljava/lang/String;)V
; #28 = Utf8 org/armedbear/lisp/Cons
; #29 = NameAndType #8:#37 // "":(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V
; #30 = Class #38 // org/armedbear/lisp/Primitives
; #31 = Utf8 org/armedbear/lisp/Primitives$pf_cons
; #32 = Utf8 org/armedbear/lisp/Primitive
; #33 = Utf8 org/armedbear/lisp/Symbol
; #34 = Utf8 CONS
; #35 = Utf8 Lorg/armedbear/lisp/Symbol;
; #36 = Utf8 (Lorg/armedbear/lisp/Symbol;Ljava/lang/String;)V
; #37 = Utf8 (Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V
; #38 = Utf8 org/armedbear/lisp/Primitives
; {
; org.armedbear.lisp.Primitives$pf_cons();
; descriptor: ()V
; flags:
; Code:
; stack=3, locals=1, args_size=1
; 0: aload_0
; 1: getstatic #1 // Field org/armedbear/lisp/Symbol.CONS:Lorg/armedbear/lisp/Symbol;
; 4: ldc #2 // String object-1 object-2
; 6: invokespecial #3 // Method org/armedbear/lisp/Primitive."":(Lorg/armedbear/lisp/Symbol;Ljava/lang/String;)V
; 9: return
; LineNumberTable:
; line 467: 0
; line 468: 9
; LocalVariableTable:
; Start Length Slot Name Signature
; 0 10 0 this Lorg/armedbear/lisp/Primitives$pf_cons;
;
; public org.armedbear.lisp.LispObject execute(org.armedbear.lisp.LispObject, org.armedbear.lisp.LispObject);
; descriptor: (Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;
; flags: ACC_PUBLIC
; Code:
; stack=4, locals=3, args_size=3
; 0: new #4 // class org/armedbear/lisp/Cons
; 3: dup
; 4: aload_1
; 5: aload_2
; 6: invokespecial #5 // Method org/armedbear/lisp/Cons."":(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V
; 9: areturn
; LineNumberTable:
; line 474: 0
; LocalVariableTable:
; Start Length Slot Name Signature
; 0 10 0 this Lorg/armedbear/lisp/Primitives$pf_cons;
; 0 10 1 first Lorg/armedbear/lisp/LispObject;
; 0 10 2 second Lorg/armedbear/lisp/LispObject;
; }
; SourceFile: "Primitives.java"
#+end_src
* Colophon
#+caption: Metadata Colophon
#+begin_src n3
<> dc:source ;
dc:replaces ;
dc:modified "<2020-05-12 Tue 10:21>" .
#+end_src
abcl-src-1.9.2/contrib/abcl-introspect/abcl-introspect-test.asd 0100644 0000000 0000000 00000001141 14444524627 023241 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(defsystem abcl-introspect-test
:author "Mark Evenson"
:long-description ""
:version "2.1.0"
:defsystem-depends-on (prove-asdf)
:depends-on (abcl-asdf ;; locate various testing dependencies via ABCL-ASDF
prove)
:components ((:module tests
:pathname "t/"
:components ((:test-file "disassemble")
(:test-file "environments"))))
:perform (asdf:test-op (op c)
(uiop:symbol-call :prove-asdf 'run-test-system c)))
abcl-src-1.9.2/contrib/abcl-introspect/abcl-introspect.asd 0100644 0000000 0000000 00000001275 14444524627 022274 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(defsystem abcl-introspect
:author ("Alan Ruttenberg" "Mark Evenson")
:description "Introspection on compiled function to aid source location and other debugging functions."
:long-description ""
:version "2.1.0"
:depends-on (jss)
:components ((:module package
:pathname #p"./"
:components ((:file "packages")))
(:module source
:pathname #p"./"
:components ((:file "abcl-introspect")
(:file "stacktrace")
(:file "util"))))
:in-order-to ((test-op (test-op abcl-introspect-test))))
abcl-src-1.9.2/contrib/abcl-introspect/abcl-introspect.lisp 0100644 0000000 0000000 00000066013 14343623723 022470 0 ustar 00 0000000 0000000 (in-package :system)
;; Author: Alan Ruttenberg December 2016
;; This code is released under Creative Common CC0 declaration
;; (https://wiki.creativecommons.org/wiki/CC0) and as such is intended
;; to be in the public domain.
;; A compiled function is an instance of a class - This class has
;; multiple instances if it represents a closure, or a single instance if
;; it represents a non-closed-over function.
;; The ABCL compiler stores constants that are used in function execution
;; as private java fields. This includes symbols used to invoke function,
;; locally-defined functions (such as via labels or flet) and string and
;; other literal constants.
;; This file provides access to those internal values, and uses them in
;; at least two ways. First, to annotate locally defined functions with
;; the top-level function they are defined within, and second to search
;; for callers of a give function(*). This may yield some false
;; positives, such as when a symbol that names a function is also used
;; for some other purpose. It can also have false negatives, as when a
;; function is inlined. Still, it's pretty useful. The second use to to
;; find source locations for frames in the debugger. If the source
;; location for a local function is asked for the location of its 'owner'
;; is instead returns.
;; (*) Since java functions are strings, local fields also have these
;; strings. In the context of looking for callers of a function you can
;; also give a string that names a java method. Same caveat re: false
;; positives.
;; In order to record information about local functions, ABCL defines a
;; function-plist, which is for the most part unused, but is used here
;; with set of keys indicating where the local function was defined and
;; in what manner, i.e. as normal local function, as a method function,
;; or as an initarg function. There may be other places functions are
;; stashed away (defstructs come to mind) and this file should be added
;; to to take them into account as they are discovered.
;; This file does not depend on jss, but provides a bit of
;; jss-specific functionality if jss *is* loaded.
(defun function-internal-fields (f)
"return a list of values of fields declared in the class implementing the function"
(if (symbolp f)
(setq f (symbol-function f)))
;; think about other fields
(let ((fields (java:jcall "getDeclaredFields" (java:jcall "getClass" f))))
(loop for field across fields
do (java:jcall "setAccessible" field t)
collect
(java:jcall "get" field f))))
(defun function-internals (f)
"internal fields + closed-over values"
(append (function-internal-fields f)
(and (java:jcall "isInstance" (java::jclass "org.armedbear.lisp.CompiledClosure") f)
(compiled-closure-context f))))
(defun compiled-closure-context (f)
"For compiled closures, the values closed over"
(let ((context (java:jcall "get" (load-time-value (java::jclass-field "org.armedbear.lisp.CompiledClosure" "ctx")) f)))
(loop for binding across context
collect
(java:jcall "get" (load-time-value (java::jclass-field "org.armedbear.lisp.ClosureBinding" "value")) binding))))
(defun foreach-internal-field (fn-fn not-fn-fn &optional (fns :all) (definer nil))
"fn-n gets called with top, internal function, not-fn-fn gets called with top anything-but"
(declare (optimize (speed 3) (safety 0)))
(macrolet ((fields (c) `(java:jcall ,(java::jmethod "java.lang.Class" "getDeclaredFields") ,c))
(get (f i) `(java:jcall ,(java::jmethod "java.lang.reflect.Field" "get" "java.lang.Object") ,f ,i))
(access (f b) `(java:jcall ,(java::jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean") ,f ,b))
(getclass (o) `(java:jcall ,(java::jmethod "java.lang.Object" "getClass") ,o)))
(labels ((function-internal-fields (f)
(if (symbolp f)
(setq f (symbol-function f)))
(let ((fields (fields (getclass f))))
(loop for field across fields
do (access field t)
collect
(get field f))))
(check (f top seen)
(declare (optimize (speed 3) (safety 0)))
(dolist (el (function-internal-fields f))
(if (functionp el)
(let ((name? (third (multiple-value-list (function-lambda-expression el)))))
(if (or (consp name?) (and name? (fboundp name?) (eq el (symbol-function name?))) )
(progn
(when not-fn-fn (funcall not-fn-fn top name?))
(when (not (member el seen :test #'eq))
(push el seen)
(check el top seen)))
(when (not (member el seen :test #'eq))
(when fn-fn (funcall fn-fn top el))
(push el seen)
(check el top seen))))
(when not-fn-fn
(funcall not-fn-fn top el)
)))))
(if (eq fns :all)
(progn
(dolist (p (list-all-packages))
(do-symbols (s p)
(when (fboundp s)
(check (symbol-function s) s nil))))
(each-non-symbol-compiled-function (lambda (definer f) (check f definer nil))))
(dolist (f fns)
(check (if (not (symbolp f)) f (symbol-function f)) (or definer f) nil))
))))
(defun callers (thing &aux them)
(foreach-internal-field
nil
(lambda(top el)
(when (equal el thing)
(pushnew top them)
)))
them)
(defun annotate-internal-functions (&optional (fns :all) definer)
"Iterate over functions reachable from arg fns (all functions
if :all). When not a top-level function add
key: :internal-to-function value top-level thing in which the
function is defined. definers are the top-level functions, This
gets called after fset"
(foreach-internal-field
(lambda(top internal)
(unless (eq (if (symbolp top) (symbol-function top) top) internal)
(setf (getf (sys:function-plist internal) :internal-to-function) (or definer top))
))
nil
fns
definer))
(defvar *function-class-names* (make-hash-table :test 'equalp :weakness :value)
"Table mapping java class names of function classes to their function. Value is either symbol or (:in symbol) if an internal function")
(defun index-function-class-names (&optional (fns :all))
"Create a table mapping class names to function, for cases where the class name appears in backtrace (although perhaps that's a bug?)"
(if (eq fns :all)
(dolist (p (list-all-packages))
(do-symbols (s p)
(when (and (eq (symbol-package s) p) (fboundp s)
;; system is touchy about #'autoload
(not (eq (symbol-function s) #'autoload)))
(unless (#"matches" (#"getName" (#"getClass" (symbol-function s))) ".*Closure$")
(setf (gethash (#"getName" (#"getClass" (symbol-function s))) *function-class-names*) (symbol-function s))))))
(dolist (s fns)
(setf (gethash (#"getName" (#"getClass" (if (symbolp s) (symbol-function s) s))) *function-class-names*) s)))
(foreach-internal-field
(lambda(top internal)
(let ((fn (if (symbolp top) (symbol-function top) top)))
(unless (or (eq fn internal) (#"matches" (#"getName" (#"getClass" fn)) ".*Closure$"))
(setf (gethash (#"getName" (#"getClass" internal)) *function-class-names*)
internal))))
nil
fns
nil))
(defun java-class-lisp-function (class-name)
"Return either function-name or (:in function-name) or nil if class isn't that of lisp function"
(gethash class-name *function-class-names* ))
(defun annotate-clos-methods (&optional (which :all))
"Iterate over all clos methods, marking method-functions and
method-fast-functions with the function plist
indicator :method-function or :method-fast-function, value the method
object. This gets called once."
(flet ((annotate (method)
(let ((method-function (mop::std-method-function method))
(fast-function (mop::std-method-fast-function method)))
(when (and method-function (compiled-function-p method-function))
(setf (getf (sys:function-plist method-function) :method-function) method)
(annotate-internal-functions (list method-function) method)
(index-function-class-names (list method-function)))
(when (and fast-function (compiled-function-p fast-function))
(setf (getf (sys:function-plist fast-function) :method-fast-function) method)
(annotate-internal-functions (list fast-function) method)
(index-function-class-names (list method-function))))))
(if (eq which :all)
(loop for q = (list (find-class t)) then q
for focus = (pop q)
while focus
do (setq q (append q (mop::class-direct-subclasses focus)))
(loop for method in (mop::class-direct-methods focus)
do (annotate method)))
(dolist (f which)
(annotate f)
))))
(defun annotate-clos-slots (&optional (which :all))
"Iterate over all clos slots, marking compile-initarg functions as :initfunction value slot"
(flet ((annotate (slot)
(let ((initfunction (and (slot-boundp slot 'initfunction)
(slot-value slot 'initfunction))))
(when initfunction
(setf (getf (function-plist initfunction) :initfunction) slot)
(annotate-internal-functions (list initfunction) slot)))))
(if (eq which :all)
(loop for q = (list (find-class t)) then q
for focus = (pop q)
while focus
do (setq q (append q (mop::class-direct-subclasses focus)))
(loop for slot in (mop::class-direct-slots focus)
do (annotate slot)))
(dolist (f which)
(annotate f)
))))
(defun method-spec-list (method)
"Given a method object, translate it into specification (name qualifiers specializers)"
`(,(mop::generic-function-name (mop::method-generic-function method))
,(mop::method-qualifiers method)
,(mapcar #'(lambda (c)
(if (typep c 'mop:eql-specializer)
`(eql ,(mop:eql-specializer-object c))
(class-name c)))
(mop:method-specializers method))))
;; function names for printing, inspection and in the debugger
(defun any-function-name (function &aux it)
"Compute function name based on the actual function name, if it is a
named function or the values on the function-plist that functions
above have used annotate local functions"
(cond ((typep function 'generic-function)
(mop::generic-function-name function))
((typep function 'mop::method)
(mop::generic-function-name (mop::method-generic-function function)))
(t
(maybe-jss-function function)
(let ((interpreted (not (compiled-function-p function))))
(let ((plist (sys::function-plist function)))
(cond ((setq it (getf plist :internal-to-function))
`(:local-function ,@(if (java:jcall "getLambdaName" function)
(list (java:jcall "getLambdaName" function))
(if (getf plist :jss-function)
(list (concatenate 'string "#\"" (getf plist :jss-function) "\"")))
)
,@(if interpreted '((interpreted)))
:in ,@(if (typep it 'mop::standard-method)
(cons :method (method-spec-list it))
(list it))))
((setq it (getf plist :method-function))
`(:method-function ,@(if interpreted '((interpreted))) ,@(sys::method-spec-list it)))
((setq it (getf plist :method-fast-function))
`(:method-fast-function ,@(if interpreted '("(interpreted)")) ,@(sys::method-spec-list it)))
((setq it (getf plist :initfunction))
(let ((class (and (slot-boundp it 'allocation-class) (slot-value it 'allocation-class))))
`(:slot-initfunction ,(slot-value it 'name ) ,@(if interpreted '((interpreted))) :for ,(if class (class-name class) '??))))
((#"equals" function (symbol-function 'lambda))
'(:macro-function lambda))
((equal (#"getName" (#"getClass" function)) "org.armedbear.lisp.MacroObject")
`(:macro-object ,@(any-function-name #"{function}.expander")))
(t (or (and (nth-value 2 (function-lambda-expression function))
(if interpreted
`(,(nth-value 2 (function-lambda-expression function)) ,'(interpreted))
(let ((name (nth-value 2 (function-lambda-expression function))))
(if (macro-function-p function)
`(:macro ,name)
name))))
(and (not (compiled-function-p function))
(let ((body (#"getBody" function)))
(if (and (consp body) (consp (car body)) (eq (caar body) 'jss::invoke-restargs))
`(:interpreted-function ,(concatenate 'string "#\"" (cadar body) "\""))
`(:anonymous-interpreted-function))))
(function-name-by-where-loaded-from function)))))))))
(defun function-name-by-where-loaded-from (function)
"name of last resource - used the loaded-from field from the function to construct the name"
(let* ((class (java:jcall "getClass" function))
(loaded-from (sys::get-loaded-from function))
(name (java:jcall "replace" (java:jcall "getName" class) "org.armedbear.lisp." ""))
(where (and loaded-from (concatenate 'string (pathname-name loaded-from) "." (pathname-type loaded-from)))))
`(:anonymous-function ,name ,@(if (sys::arglist function) (sys::arglist function))
,@(if where (list (list :from where))))))
(defun maybe-jss-function (f)
"Determing if function is something list #\"foo\" called as a
function. If so add to function internal plist :jss-function and the
name of the java methods"
(and (find-package :jss)
(compiled-function-p f)
(or (getf (sys::function-plist f) :jss-function)
(let ((internals (function-internal-fields f)))
(and (= (length internals) 2)
(eq (second internals) (intern "INVOKE-RESTARGS" :jss))
(stringp (first internals))
(setf (getf (sys:function-plist f) :jss-function) (first internals)))))))
(defun local-function-p (function)
"Helper function. Tests whether a function wasn't defined at top
level based on function-plist annotations"
(and (and (functionp function) (not (typep function 'generic-function)))
(let ((plist (sys:function-plist function)))
(or (getf plist :internal-to-function)
(getf plist :method-function)
(getf plist :method-fast-function)
(getf plist :slot-initfunction)))))
(defun local-function-owner (function)
"For local function, return the 'owner' typically the top-level function or clos method"
(local-function-p function))
(defvar *function-print-object-prefix* "function ")
(defmethod print-object ((f function) stream)
"Print a function using any-function-name. Requires a patch to
system::output-ugly-object in order to prevent the function being
printed by a java primitive"
(if (or (typep f 'mop::generic-function)
(typep f 'mop::method))
(call-next-method)
(print-unreadable-object (f stream :identity t)
(let ((name (any-function-name f)))
(if (consp name)
(format stream "~{~a~^ ~}" name)
(format stream "~a~a" *function-print-object-prefix* name))))))
(defun each-non-symbol-compiled-function (f)
(loop for q = (list (find-class t)) then q
for focus = (pop q)
while focus
do (setq q (append q (mop::class-direct-subclasses focus)))
(loop for method in (mop::class-direct-methods focus)
do (when (compiled-function-p (mop::method-function method)) (funcall f method (mop::method-function method))))
(loop for slot in (mop::class-direct-slots focus)
for initfunction = (and (slot-boundp slot 'initfunction) (slot-value slot 'initfunction))
do (and initfunction (compiled-function-p initfunction) (funcall f slot initfunction)))))
;; hooks into defining
(defvar *fset-hooks* nil "functions on this list get called with name and function *after* the symbol-function is set")
(defvar *annotate-function-backlog?* t "true before this file has been loaded and function annotations are placed")
(defun fset-hook-annotate-internal-function (name function)
"Called at the end of fset. If function annotations have not yet
been added, add local function annotations to all functions. If not,
just add annotations to function specified in the arglist"
(when *annotate-function-backlog?*
(setq *annotate-function-backlog?* nil)
(annotate-internal-functions)
(annotate-clos-methods)
(annotate-clos-slots)
(index-function-class-names) ;; still missing some cases e.g. generic functions and method functions
)
(index-function-class-names (list function))
(annotate-internal-functions (list name)))
;; Here we hook into clos in order to have method and slot functions
;; annotated when they are defined.
(defmethod mop::add-direct-method :after (class method)
(annotate-clos-methods (list method)))
(defmethod mop::ensure-class-using-class :after (class name
&key direct-slots
direct-default-initargs
&allow-other-keys)
(declare (ignore direct-slots direct-default-initargs))
(annotate-clos-slots (mop::class-direct-slots (find-class name))))
;; Environments
;; Return a list of the variables and functions in an environment. The form of the list is
;; (kind name value)
;; where kind is either :lexical-variable or :lexical-function :special-variable
(defun environment-parts (env)
(append
(loop for binding = (jss:get-java-field env "vars" t) then (jss:get-java-field binding "next" t)
while binding
for symbol = (jss:get-java-field binding "symbol" t)
for value = (jss:get-java-field binding "value" t)
for special = (jss:get-java-field binding "specialp" t)
if (member symbol '(:catch))
collect `(,symbol ,value) into them
else
unless (find symbol them :key 'second)
collect (list (if special
:special-variable
(if (jss:jtypep value 'lisp.SymbolMacro)
:symbol-macro
:lexical-variable))
symbol
(if (jss:jtypep value 'lisp.SymbolMacro)
(#"getExpansion" value)
value))
into them
finally (return them))
(loop for binding = (jss:get-java-field env "lastFunctionBinding" t)
then (jss:get-java-field binding "next" t)
while binding
for name = (jss:get-java-field binding "name" t)
for value = (jss:get-java-field binding "value" t)
unless (find name them :key 'second)
collect (list :lexical-function name value) into them
finally (return them))
(loop for binding = (jss::get-java-field env "blocks" t)
then (jss::get-java-field binding "next" t)
while binding
for name = (jss::get-java-field binding "symbol" t)
for value = (jss::get-java-field binding "value" t)
unless (find name them :key 'second)
collect (list :block name value) into them
finally (return them))))
;; Locals
;; Locals are retrived from envStack, a stack of environments and
;; function call markers distinct from the call stack, one per
;; thread. Locals are only available for interpreted functions. The
;; envStack is distinct from the call stance because there are function
;; calls which create environments, for instance to special operators
;; like sf_let, that are not in the lisp call stack.
;; A function call marker in this context is an environment with a variable binding
;; whose symbol is nil. Implementing the markers this way means we don't have
;; to deal with different sorts of things on the envStack, which makes the
;; java side of things easier.
;; Environments are chained. So a binding of a new local, by e.g. let, will
;; have a new environment created which has the new binding and a pointer
;; to the environment with the previous binding.
;; Since all environments created are on the envStack, we have to figure
;; out which environment is the one that is the most current for a given
;; function being executed when we land in the debugger.
;; collapse-locals is responsible for filtering out the environments
;; that aren't the most current for each function being executed. It
;; returns a list whose head is the function being executed and whose
;; tail is a list of bindings from environment-parts.
;; have to get the stack contents using this instead of j2list as in
;; that case we get a concurrent modification exception as we iterate
;; through the iterator, when some other function call is made.
;; BEGIN use :abcl-introspect/system
(in-package :abcl-introspect/system)
(defun collapse-locals (thread)
(flet ((stack-to-list (stack)
(coerce (#"toArray" stack) 'list)))
(loop for bindings in (mapcar 'sys::environment-parts
(stack-to-list (jss:get-java-field thread "envStack" t)))
with last-locals
with last-function
for binding = (car bindings)
if (eq (second binding) nil)
collect (prog1
(list last-function last-locals)
(setq last-locals nil)
(setq last-function (third binding)))
else
do (setq last-locals bindings))))
;; Now that we have the pairings of function-executing and lexicals we need
;; to associate each such function with the stack frame for it being
;; called. To do that, for each function and locals we find and record the
;; first occurrence of the function in the backtrace. Functions may appear
;; more than once in the envStack because they have been called more than
;; once. In addition the envStack will have more functions than there are
;; frames.
;; In order for our envstack association to be an alignment with the stack,
;; the associations must be in ascending order. That is, if we start at
;; the top of the collapsed envstack, then the frame number each function
;; is associated with must be in ascending order.
;; So, first walk through the associations and remove any frame numbers
;; above that are greater than the index of this association. e.g. if we
;; have
;; (f1 frame#3 locals)
;; (f2 frame#2 locals)
;; then frame#3 must be a wrong pairing since it is out of order. So we
;; erase those to get
;; (f1 nil locals)
;; (f2 frame#2 locals)
;; Also, since there may be more than one call to a function we might have
;; something like
;; (f1 frame#2 locals)
;; (f2 frame#3 locals)
;; (f1 frame#2 locals)
;; Only the first one is right, so we erases subsequent ones, yielding
;; (f1 frame#2 locals)
;; (f2 frame#3 locals)
;; (f1 nil locals)
;; At this point we now have a some-to-one mapping of functions to frames
;; find-locals takes a backtrace and an index of a frame in that backtrace
;; and returns the locals for the frame. To get it we just search for the
;; first entry that has the required frame number.
;; find-locals still has debugging code in it which will be removed after
;; there has been sufficient testing.
;;; ME: presumably *debugging-locals-p* can go away now?
(defvar *debugging-locals-p* nil
"Whether SYS:FIND-LOCALS should be looking for local variables")
(defun find-locals (index backtrace)
"Return local variable bindings at INDEX in BACKTRACE
Added by ABCL-INTROSPECT."
(let ((thread (jss:get-java-field (nth index backtrace) "thread" t)))
(and *debugging-locals-p* (print `(:collapse ,thread ,index)))
(let ((collapsed (collapse-locals thread)))
(and *debugging-locals-p* (map nil 'print collapsed))
(let ((alignment
(loop for function-local-association in (reverse collapsed)
with backtrace = (map 'list (if *debugging-locals-p* 'print 'identity) backtrace)
for pos = (position (car function-local-association) backtrace
:key (lambda(frame)
(if (typep frame 'sys::lisp-stack-frame)
(#"getOperator" frame)
(jss:get-java-field frame "METHOD" t))))
collect (list (car function-local-association)
pos
(cdr function-local-association)))))
(and *debugging-locals-p* (print :erase) (map nil 'print alignment))
;; first erasure of out of order frames
(loop for (nil pos) in alignment
for i from 0
when pos do
(loop for pair in (subseq alignment 0 i)
for (nil pos2) = pair
unless (null pos2)
if (> pos2 pos)
do (setf (second pair) nil)))
(and *debugging-locals-p* (print :align) (map nil 'print alignment))
;; second erasure of duplicate frame numbers
(loop for (nil pos) in alignment
for i from 0
do
(loop for pair in (subseq alignment (1+ i))
for (nil pos2) = pair
unless (null pos2)
if (eql pos2 pos)
do (setf (second pair) nil)))
(and *debugging-locals-p* (map nil 'print alignment))
(if *debugging-locals-p*
(print `(:find ,(cddr (find index alignment :key 'second :test 'eql)))))
;; finally, look up the locals for the given frame index
(cddr (find index alignment :key 'second :test 'eql))))))
;; END use :abcl-introspect/system
(in-package :system)
;; needs to be the last thing. Some interaction with the fasl loader
(pushnew 'fset-hook-annotate-internal-function sys::*fset-hooks*)
(provide :abcl-introspect)
abcl-src-1.9.2/contrib/abcl-introspect/byte-code.lisp 0100644 0000000 0000000 00000000152 14343623723 021242 0 ustar 00 0000000 0000000 (in-package :abcl-introspect)
(defun choose-disassemble ()
(warn "Unimplemented choose dissambler."))
abcl-src-1.9.2/contrib/abcl-introspect/cfr.asd 0100644 0000000 0000000 00000000463 14343623723 017746 0 ustar 00 0000000 0000000 (defsystem cfr
:homepage "https://www.benf.org/other/cfr"
:description "CFR - a Class File Reader decompiler" :components
((:module mvn-libs :components
((:mvn "org.benf/cfr/0.149")))
(:module source
:depends-on (mvn-libs)
:pathname "" :components
((:file "cfr")))))
abcl-src-1.9.2/contrib/abcl-introspect/cfr.lisp 0100644 0000000 0000000 00000001466 14343623723 020152 0 ustar 00 0000000 0000000 (defpackage :abcl-introspect/jvm/tools/cfr
(:use :cl)
(:export
#:disassemble-class-bytes))
(in-package :abcl-introspect/jvm/tools/cfr)
(defun cfr-jar-pathname ()
;; Very ugly. How to make more intelligble?
(slot-value (first (asdf:component-children (asdf:find-component :cfr "mvn-libs")))
'asdf/interface::resolved-classpath))
(defun disassemble-class-bytes (object)
(let ((sys::*disassembler*
;; FIXME: use same java that is hosting ABCL
(format nil "java -jar ~a" (cfr-jar-pathname))))
(sys:disassemble-class-bytes object)))
(eval-when (:load-toplevel :execute)
(pushnew `(:cfr . abcl-introspect/jvm/tools/cfr::disassemble-class-bytes)
sys::*disassemblers*)
(format cl:*load-verbose* "~&; ~a: Successfully added cfr disassembler.~%" *package*))
abcl-src-1.9.2/contrib/abcl-introspect/fernflower.asd 0100644 0000000 0000000 00000000664 14343623723 021350 0 ustar 00 0000000 0000000 (defsystem fernflower
:depends-on (alexandria abcl-introspect)
:homepage "https://github.com/fesh0r/fernflower"
:version "1.0.0.20271018"
:description "An analytical decompiler for Java" :components
((:module mvn-libs :components
((:mvn "org.jboss.windup.decompiler.fernflower/windup-fernflower/1.0.0.20171018")))
(:module source
:depends-on (mvn-libs)
:pathname "" :components
((:file "fernflower")))))
abcl-src-1.9.2/contrib/abcl-introspect/fernflower.lisp 0100644 0000000 0000000 00000002507 14343623723 021546 0 ustar 00 0000000 0000000 (defpackage :abcl-introspect/jvm/tools/fernflower
(:use :cl)
(:export
#:disassemble-class-bytes))
(in-package :abcl-introspect/jvm/tools/fernflower)
(defun fernflower-classpath ()
;; Very ugly. How to make more intelligble?
(slot-value (first (asdf:component-children (asdf:find-component :fernflower "mvn-libs")))
'asdf/interface::resolved-classpath))
(defun disassemble-class-bytes (object)
(uiop/stream::with-temporary-file (:pathname p :type "class")
(ext::write-class object p)
(let* ((directory
(namestring (truename (make-pathname :directory (pathname-directory p)))))
(path
(namestring (truename p)))
(command
(format nil "java -cp ~a org.jetbrains.java.decompiler.main.decompiler.ConsoleDecompiler ~a ~a"
(fernflower-classpath) p directory))
(output
(namestring (make-pathname :defaults p :type "java"))))
(uiop:run-program command)
(let ((result (alexandria:read-file-into-string output)))
(sys::print-lines-with-prefix result)))))
(eval-when (:load-toplevel :execute)
(pushnew `(:fernflower . abcl-introspect/jvm/tools/fernflower::disassemble-class-bytes)
sys::*disassemblers*)
(format cl:*load-verbose* "~&; ~a: Successfully added fernflower decompiler.~%" *package*))
abcl-src-1.9.2/contrib/abcl-introspect/jad.asd 0100644 0000000 0000000 00000000325 14343623723 017727 0 ustar 00 0000000 0000000 (defsystem jad
:homepage "http://www.javadecompilers.com/jad/"
:description "Introspect runtime architecture, install appropiate JAD binary, use it."
:depends-on (abcl-build)
:components ((:file "jad")))
abcl-src-1.9.2/contrib/abcl-introspect/jad.lisp 0100644 0000000 0000000 00000003062 14343623723 020130 0 ustar 00 0000000 0000000 (defpackage :abcl-introspect/jvm/tools/jad
(:use #:cl)
(:nicknames #:jvm/tools/jad #:jad)
(:export
#:disassemble-class-bytes))
#|
|#
(in-package :abcl-introspect/jvm/tools/jad)
(defun introspect-jad-uri ()
(uiop:os-cond
((uiop/os:os-macosx-p)
"http://www.javadecompilers.com/jad/Jad%201.5.8g%20for%20Mac%20OS%20X%2010.4.6%20on%20Intel%20platform.zip")))
(defvar *working-jad-executable* nil)
(defun ensure-jad ()
(flet
((install-jad-returning-path (uri)
(abcl-build:xdg/install (pathname uri) :type :unzip))
(working-jad-p (jad-path)
(handler-case
(uiop:run-program jad-path)
(uiop/run-program:subprocess-error (e) nil))))
(if (null *working-jad-executable*)
(let ((jad-path (abcl-build:introspect-path-for "jad")))
(if (and jad-path
(working-jad-p jad-path))
(setf *working-jad-executable* jad-path)
(progn
(install-jad-returning-path (introspect-jad-uri))
(setf *working-jad-executable* jad-path))))
(unless (working-jad-p *working-jad-executable*)
(setf *working-jad-executable*
(install-jad-returning-path (introspect-jad-uri)))))))
(defun disassemble-class-bytes (object)
(ensure-jad)
(let ((sys::*disassembler*
(format nil "~s -a -p" *working-jad-executable*)))
(sys:disassemble-class-bytes object)))
abcl-src-1.9.2/contrib/abcl-introspect/javap.asd 0100644 0000000 0000000 00000000332 14343623723 020270 0 ustar 00 0000000 0000000 (defsystem javap
:homepage "" ;; FIXME
:description "Utilization of the javap command line dissassembler"
:components ((:file "javap")))
abcl-src-1.9.2/contrib/abcl-introspect/javap.lisp 0100644 0000000 0000000 00000001276 14343623723 020500 0 ustar 00 0000000 0000000 (defpackage :abcl-introspect/jvm/tools/javap
(:use #:cl)
(:export
#:disassemble-class-bytes))
;;;; JDK javap
#|
(let ((sys::*disassembler* "javap -c -verbose"))
(disassemble 'cons))
|#
(in-package :abcl-introspect/jvm/tools/javap)
(defun disassemble-class-bytes (object)
(let ((sys::*disassembler* "javap -c -verbose"))
(sys:disassemble-class-bytes object)))
(eval-when (:load-toplevel :execute)
(pushnew `(:javap . abcl-introspect/jvm/tools/javap::disassemble-class-bytes)
sys::*disassemblers*)
(format cl:*load-verbose* "~&; ~a ; Successfully added javap disassembler.~%" *package*))
abcl-src-1.9.2/contrib/abcl-introspect/objectweb.asd 0100644 0000000 0000000 00000000612 14343623723 021134 0 ustar 00 0000000 0000000 (defsystem objectweb
:homepage "https://asm.ow2.org"
:description "Disassembly to JVM byte code via Objectweb"
:version "8.0.1"
:defsystem-depends-on (abcl-asdf) :components
((:module maven :components
((:mvn "org.ow2.asm/asm-util/8.0.1")))
(:module source
:depends-on (maven)
:pathname "" :components
((:file "objectweb")))))
abcl-src-1.9.2/contrib/abcl-introspect/objectweb.lisp 0100644 0000000 0000000 00000001740 14343623723 021337 0 ustar 00 0000000 0000000 (defpackage :abcl-introspect/jvm/tools/objectweb
(:use :cl)
(:export
#:disassemble-class-bytes))
(in-package :abcl-introspect/jvm/tools/objectweb)
(defun disassemble-class-bytes (object)
(let* ((reader (java:jnew "org.objectweb.asm.ClassReader" object))
(writer (java:jnew "java.io.StringWriter"))
(printer (java:jnew "java.io.PrintWriter" writer))
(tracer (java:jnew "org.objectweb.asm.util.TraceClassVisitor" java:+null+ printer))
;; this is to support both the 1.X and subsequent releases
(flags (ignore-errors (java:jfield "org.objectweb.asm.ClassReader" "SKIP_DEBUG"))))
(java:jcall-raw "accept" reader tracer (or flags java:+false+))
(java:jcall "toString" writer)))
(eval-when (:load-toplevel :execute)
(pushnew `(:objectweb . abcl-introspect/jvm/tools/objectweb::disassemble-class-bytes)
sys::*disassemblers*)
(format cl:*load-verbose* "~&; ~a ; Successfully added Objectweb disassembler.~%" *package*))
abcl-src-1.9.2/contrib/abcl-introspect/packages.lisp 0100644 0000000 0000000 00000001227 14343623723 021151 0 ustar 00 0000000 0000000 (defpackage abcl-introspect/system
(:nicknames #:abcl-introspect/sys)
(:use :common-lisp)
(:export
#:*debugging-locals-p*
#:find-locals))
;;; Import and externalize all external symbols of
;;; ABCL-INTROSPECT/SYSTEM from the SYSTEM package. Following this
;;; discipline will allow us to sanely determine what symbols
;;; ABCL-INTROSPECT adds to SYSTEM.
;;;
;;; TODO: do this for the rest of abcl-introspect.lisp and
;;; stacktrace.lisp
(eval-when (:compile-toplevel :load-toplevel)
(loop :for symbol :being :the :external-symbols :of :abcl-introspect/system
:doing
(import symbol :system)
(export symbol :system)))
abcl-src-1.9.2/contrib/abcl-introspect/procyon.asd 0100644 0000000 0000000 00000000646 14343623723 020670 0 ustar 00 0000000 0000000 (defsystem procyon
:homepage "https://bitbucket.org/mstrobel/procyon/wiki/Java%20Decompiler"
:description "A Java decompiler by Mike Strobel"
:version "0.5.36"
:depends-on (alexandria) :components
((:module mvn-libs :components
((:mvn "org.bitbucket.mstrobel/procyon-compilertools/0.5.36")))
(:module source
:depends-on (mvn-libs)
:pathname "" :components
((:file "procyon")))))
abcl-src-1.9.2/contrib/abcl-introspect/procyon.lisp 0100644 0000000 0000000 00000002734 14343623723 021070 0 ustar 00 0000000 0000000 (defpackage :abcl-introspect/jvm/tools/procyon
(:use :cl)
(:export
#:disassemble-class-bytes))
(in-package :abcl-introspect/jvm/tools/procyon)
(defun disassemble-class-bytes (object)
#|
final DecompilerSettings settings = DecompilerSettings.javaDefaults();
try (final FileOutputStream stream = new FileOutputStream("path/to/file");
final OutputStreamWriter writer = new OutputStreamWriter(stream)) {
Decompiler.decompile(
"java/lang/String",
new PlainTextOutput(writer),
settings
);
}
catch (final IOException e) {
// handle error
}
|#
(let* ((settings
(#"javaDefaults" 'DecompilerSettings))
(writer
(jss:new 'java.io.StringWriter)))
(#"decompile" 'Decompiler
;;; !!! need to reference as a type in the current VM
;;; c.f.
object
(jss:new 'PlainTextOutput writer)
settings)
(write (#"toString writer"))))
(eval-when (:load-toplevel :execute)
(pushnew `(:procyon . abcl-introspect/jvm/tools/procyon::disassemble-class-bytes)
sys::*disassemblers*)
(format cl:*load-verbose* "~&; ~a: Successfully added procyon disassembler.~%" *package*))
abcl-src-1.9.2/contrib/abcl-introspect/stacktrace.lisp 0100644 0000000 0000000 00000040462 14375342634 021527 0 ustar 00 0000000 0000000 (in-package :system)
(require :jss) ;; for now
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; I don't understand the algorithm that sys:backtrace uses, which seems
;; broken, so here's an alternative.
;; The lisp portion of the stack backtrace is computed as it is now. It
;; will have invoke-debugger at the top then some java stack frames that
;; abcl pushes (the "i don't understand") and then the rest of the
;; backtrace. We trim that by popping off the invoke-debugger and java
;; stack frames, leaving just lisp frames.
;; If there's a java exception. In that case we compare the stacktrace of
;; the exception to the java stack trace and grab the top part of it
;; that's unique to the exception. We prepend this to the lisp stack
;; trace.
;; The result will be that we will *not* see the call to invoke debugger,
;; or any of the swank handling, just what (I think) is relative.
;; What still needs to be investigated is how this plays in cases where
;; there are callbacks to lisp from java.
;; A good test to see the difference would be
;; (#"replaceAll" "" "(?o" "")
;; which should now show the calls within the regex code leading to
;; the exception.
(defvar *use-old-backtrace* nil "set to t to fall back to the standard backtrace")
(defvar *hide-swank-frames* t "set to nil if you want to see debugger internal frames")
(defvar *unwelcome-java-frames*
'("sun.reflect.Native.*AccessorImpl\\..*"
"sun.reflect.Delegating.*AccessorImpl\\..*"
"sun.reflect.Generated.*Accessor\\d+\\.invoke")
"if a java frame matches any of these patterns, don't show it"
)
(defvar *caught-frames* nil "When backtrace is called, it sets this to
the java stack frames that are unique to the java exception, which is
then subsequently used by slime to mark them")
(defun swankish-frame (frame)
"hackish test for whether a frame is some internal function from swank"
(let ((el (car (sys::frame-to-list frame))))
(let ((package
(cond ((and (symbolp el)
(symbol-package el))
(package-name (symbol-package el)))
;; hack! really I mean anything with a function plist
((eq (type-of el) 'compiled-function)
(let ((owner (getf (function-plist el) :internal-to-function)))
(if (and (symbolp owner)
(symbol-package owner))
(package-name
(symbol-package owner))
"")))
(t ""))))
(and package (#"matches" package "SWANK.*")))))
(defun javaframe (java-stack-frame)
"Return the java StackFrame instance"
(if (java::java-object-p java-stack-frame)
java-stack-frame
(#"get" (load-time-value (java::jclass-field "org.armedbear.lisp.JavaStackFrame" "javaFrame")) java-stack-frame)))
(defun stackframe-head (frame &optional with-method)
"If a lisp frame, the function (symbol or function). In a java frame the class name, with method if with-method is t"
(if (null frame)
nil
(if (typep frame 'lisp-stack-frame)
(#"getOperator" frame)
(let ((frame (if (typep frame 'java-stack-frame) (javaframe frame) frame)))
(if with-method
(concatenate 'string (#"getClassName" frame) "." (#"getMethodName" frame))
(#"getClassName" frame))))))
(defun backtrace-invoke-debugger-position (stacktrace)
"Position of the call to invoke-debugger"
(let ((looking-for `(invoke-debugger ,#'invoke-debugger)))
(position-if (lambda(e) (memq (#"getOperator" e) looking-for)) stacktrace)))
(defun swank-p ()
"are we running with slime/swank? This should work without swank too"
(find-package 'swank))
(defun repl-loop-position (stacktrace start)
"Position of the frame starting the repl at this level"
(if (swank-p)
(position-if (lambda(e) (eq (stackframe-head e) (intern "SLDB-LOOP" 'swank))) stacktrace :start start)
(position-if (lambda(e) (eq (stackframe-head e) 'debug-loop)) stacktrace :start start)
))
(defun last-internal-calls-position (stacktrace)
"Some java frames are replicates of the lisp stack frame. This gets
the position of the closest to top non-user lisp call. It should leave
intact frames corresponding to cases where a piece of lisp implemented
in java calls another lisp function"
(let ((pos (position-if (lambda(e)
(and (not (typep e 'lisp-stack-frame))
(not (member (#"getMethodName" (javaframe e)) '("execute" "evalCall" "eval" "funcall" "apply") :test 'equal))))
stacktrace :from-end t)))
pos))
(defun java-frame-segment (stacktrace)
"Returns the bounds of the section of the backtrace that have been added with pushJavaStackFrame"
(let ((start (position-if (lambda(e) (typep e 'java-stack-frame)) stacktrace)))
(and start (list start (position-if (lambda(e) (typep e 'lisp-stack-frame)) stacktrace :start start)))))
(defun splice-out (sequence from to)
"remove elements from->to from sequence"
(append (subseq sequence 0 from) (subseq sequence to)))
(defun splice-out-java-stack-duplicating-lisp-stack (stacktrace)
"cut out a section of java frames, maximally ending at the first lisp stack frame hit"
(let ((extra-java-frames-pos (last-internal-calls-position stacktrace)))
(let ((spliced
(if extra-java-frames-pos
(append (subseq stacktrace 0 extra-java-frames-pos)
(let ((lisp-frame-pos (position 'lisp-stack-frame stacktrace :key 'type-of :start extra-java-frames-pos)))
(and lisp-frame-pos
(subseq stacktrace
(position 'lisp-stack-frame stacktrace :key 'type-of :start extra-java-frames-pos)))))
stacktrace)))
spliced)))
(defun difference-between-exception-stacktrace-and-after-caught-stacktrace (condition)
"When there's a java exception, the condition has the stack trace as
it was when the exception was thrown. Our backtrace is after it is
caught. This function gets the difference - the frames unique to the
exception"
(let* ((exception-stack-trace (coerce (#"getStackTrace" (java::java-exception-cause condition)) 'list))
(debugger-stack-trace
(coerce (subseq exception-stack-trace
(position (#"getName" (#"getClass" #'invoke-debugger))
(#"getStackTrace" (#"currentThread" 'Thread))
:key #"getClassName"
:test 'string-equal))
'list)))
(subseq exception-stack-trace
0 (position-if (lambda(frame) (find frame debugger-stack-trace :test (lambda(a b ) (eql (#"hashCode" a) (#"hashCode" b)))))
exception-stack-trace))))
(defun remove-unsightly-java-frames (stacktrace)
"Remove uninformative java frames, typically bits of the internals of the java implementation"
(remove-if (lambda(frame)
(member (stackframe-head frame t) *unwelcome-java-frames* :test #"matches"))
stacktrace))
;; 3: (invoke-debugger #)
;; 4: org.armedbear.lisp.Lisp.error(Lisp.java:385)
;; 5: (invoke-debugger #)
;; 6: (error #)
;; 7: (# #)
;; 8: (signal #)
;; 9: org.armedbear.lisp.Lisp.error(Lisp.java:385)
(defun lisp-stack-exception-catching-frames (stacktrace)
"The frames corresponding to ABCL's internal handling of an exception"
(and (eq (stackframe-head (car stacktrace)) 'invoke-debugger)
(let ((error-position (position "org.armedbear.lisp.Lisp.error" stacktrace
:key (lambda(e) (stackframe-head e t))
:test 'equal)))
(if error-position
(subseq stacktrace 0 (1+ error-position))
(list (car stacktrace))
))))
(defun splice-out-spurious-error-frames (stacktrace)
"if there are nested exceptions sometimes there are extra (error),
, (signal) frames. we only want the first error. Remove
repeated ones. Illiustrated by first getting an errors with an
inconsistent ontology and then calling (read-from-string \"#<\") to
generate a reader error. Get rid of these. Finally, if the next
next frame after error is signal of the same condition, those two
frames are also removed"
(let ((error-position (position 'error stacktrace :key 'stackframe-head)))
(if (and error-position (> (length stacktrace) (+ error-position 3)))
(loop with trash = 0
for pos = error-position then next
for next = (+ pos 3)
until (not (eq (stackframe-head (nth next stacktrace)) 'error))
do (incf trash 3)
finally (return
(let ((spliced (if (> trash 1)
(splice-out stacktrace (1+ error-position) (+ error-position trash 1))
stacktrace)))
(if (and (eq (stackframe-head (nth (+ error-position 2) spliced)) 'signal)
(eq (second (frame-to-list (nth error-position spliced)))
(second (frame-to-list (nth (+ error-position 2) spliced)))))
(splice-out spliced (1+ error-position) (+ error-position 3))
stacktrace))))
stacktrace)))
(defun new-backtrace (condition)
"New implementation of backtrace that tries to clean up the stack
trace shown when an error occurs. There are a bunch of
idiosyncrasies of what sys:backtrace generates which land up
obscuring what the problem is, or at least making it more of a hunt
than one would want. This backtrace tries to show only stuff I think
matters - user function calls and, when there's an exception, calls
inside the lisp implementation leading to the error"
(if *use-old-backtrace*
(backtrace)
(let* ((lisp-stacktrace (#"backtrace" (threads:current-thread) 0))
(invoke-pos (backtrace-invoke-debugger-position lisp-stacktrace))
(repl-loop-pos (repl-loop-position lisp-stacktrace invoke-pos)))
(let ((narrowed-lisp-stacktrace
(splice-out-java-stack-duplicating-lisp-stack
(subseq lisp-stacktrace invoke-pos (and repl-loop-pos (1+ repl-loop-pos))))))
(when *hide-swank-frames*
(let ((swank-start (position-if 'swankish-frame narrowed-lisp-stacktrace)))
(and swank-start
(setq narrowed-lisp-stacktrace
(append
(subseq narrowed-lisp-stacktrace 0 swank-start)
(if repl-loop-pos (last narrowed-lisp-stacktrace) nil))))))
(setq narrowed-lisp-stacktrace (splice-out-spurious-error-frames narrowed-lisp-stacktrace))
(if (typep condition 'java:java-exception)
(progn
(let* ((delta (difference-between-exception-stacktrace-and-after-caught-stacktrace condition))
(cleaned (splice-out-java-stack-duplicating-lisp-stack (remove-unsightly-java-frames delta)))
(exception-frames (lisp-stack-exception-catching-frames narrowed-lisp-stacktrace)))
(setq *caught-frames* delta)
(let ((result (append exception-frames
(mapcar
(lambda (frame) (java:jnew "org.armedbear.lisp.JavaStackFrame"
frame))
cleaned)
(subseq narrowed-lisp-stacktrace (length exception-frames)))))
result
)))
narrowed-lisp-stacktrace)))))
#|
(defmethod ho ((a t)) (read-from-string "(#\"setLambdaName\" # '(flet a))"))
(defmethod no ((a t)) (read-from-string "(#\"setLambdaName\" # '(flet a))"))
(defmethod fo () (ho 1) (no 1))
(defun bar () (fo))
(defun foo () (funcall #'bar))
(defun baz () (foo))
caused by reader-error
Checking for execute isn't enough.
Symbol.execute might be good
So maybe modify:
Find invoke-debugger position
go down stack until you reach a symbol.execute, then skip rest of string of java frames.
Right now I skip from invoke-debugger to next list but because signal is there it gets stuck.
5: (invoke-debugger #)
below here ok
6: (error #)
7: (# #)
8: (signal #)
9: org.armedbear.lisp.Lisp.error(Lisp.java:385)
10: org.armedbear.lisp.LispReader$22.execute(LispReader.java:350)
11: org.armedbear.lisp.Stream.readDispatchChar(Stream.java:813)
12: org.armedbear.lisp.LispReader$6.execute(LispReader.java:130)
13: org.armedbear.lisp.Stream.processChar(Stream.java:588)
14: org.armedbear.lisp.Stream.readList(Stream.java:755)
15: org.armedbear.lisp.LispReader$3.execute(LispReader.java:88)
16: org.armedbear.lisp.Stream.processChar(Stream.java:588)
17: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:557)
18: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:566)
19: org.armedbear.lisp.Stream.read(Stream.java:501)
above here is ok
below here junk
20: org.armedbear.lisp.Stream$16.execute(Stream.java:2436)
21: org.armedbear.lisp.Symbol.execute(Symbol.java:826)
22: org.armedbear.lisp.LispThread.execute(LispThread.java:851)
23: org.armedbear.lisp.swank_528.execute(swank.lisp:1732)
24: org.armedbear.lisp.Symbol.execute(Symbol.java:803)
25: org.armedbear.lisp.LispThread.execute(LispThread.java:814)
26: org.armedbear.lisp.swank_repl_47.execute(swank-repl.lisp:270)
27: org.armedbear.lisp.LispThread.execute(LispThread.java:798)
28: org.armedbear.lisp.swank_repl_48.execute(swank-repl.lisp:283)
29: org.armedbear.lisp.Symbol.execute(Symbol.java:803)
30: org.armedbear.lisp.LispThread.execute(LispThread.java:814)
31: org.armedbear.lisp.swank_repl_46.execute(swank-repl.lisp:270)
32: org.armedbear.lisp.LispThread.execute(LispThread.java:798)
33: org.armedbear.lisp.swank_272.execute(swank.lisp:490)
34: org.armedbear.lisp.Symbol.execute(Symbol.java:814)
35: org.armedbear.lisp.LispThread.execute(LispThread.java:832)
36: org.armedbear.lisp.swank_repl_45.execute(swank-repl.lisp:270)
37: org.armedbear.lisp.LispThread.execute(LispThread.java:798)
38: abcl_fcbf3596_211f_4d83_bc8b_e11e207b8d21.execute(Unknown Source)
39: org.armedbear.lisp.LispThread.execute(LispThread.java:814)
40: org.armedbear.lisp.Lisp.funcall(Lisp.java:172)
41: org.armedbear.lisp.Primitives$pf_apply.execute(Primitives.java:2827)
end junk
42: (read #S(system::string-input-stream) nil #S(system::string-input-stream))
43: (swank::eval-region "(#\"setLambdaName\" # '(flet a))\n")
44: (#)
From a compiled function looks different
0: (error #)
1: (# #)
2: (signal #)
3: org.armedbear.lisp.Lisp.error(Lisp.java:385)
4: org.armedbear.lisp.LispReader$22.execute(LispReader.java:350)
5: org.armedbear.lisp.Stream.readDispatchChar(Stream.java:813)
6: org.armedbear.lisp.LispReader$6.execute(LispReader.java:130)
7: org.armedbear.lisp.Stream.processChar(Stream.java:588)
8: org.armedbear.lisp.Stream.readList(Stream.java:755)
9: org.armedbear.lisp.LispReader$3.execute(LispReader.java:88)
10: org.armedbear.lisp.Stream.processChar(Stream.java:588)
11: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:557)
12: org.armedbear.lisp.Stream.readPreservingWhitespace(Stream.java:566)
13: org.armedbear.lisp.Stream.read(Stream.java:501) <- this is probably where we want the stack to stop.
Looks like symbol.execute
14: org.armedbear.lisp.Stream$15.execute(Stream.java:2387) <= %read from string
15: org.armedbear.lisp.Symbol.execute(Symbol.java:867)
16: org.armedbear.lisp.LispThread.execute(LispThread.java:918)
17: org.armedbear.lisp.read_from_string_1.execute(read-from-string.lisp:33)
18: org.armedbear.lisp.CompiledClosure.execute(CompiledClosure.java:98)
19: org.armedbear.lisp.Symbol.execute(Symbol.java:803)
20: org.armedbear.lisp.LispThread.execute(LispThread.java:814)
21: abcl_2ad63c53_52f1_460b_91c2_1b153251d9f3.execute(Unknown Source)
22: org.armedbear.lisp.LispThread.execute(LispThread.java:798)
23: org.armedbear.lisp.Lisp.evalCall(Lisp.java:572)
24: org.armedbear.lisp.Lisp.eval(Lisp.java:543)
25: org.armedbear.lisp.Primitives$pf__eval.execute(Primitives.java:345)
26: (system::%read-from-string "(#\"setLambdaName\" # '(flet a))" t nil 0 nil nil)
27: (read-from-string "(#\"setLambdaName\" # '(flet a))")
28: (system::bar)
|#
#|
Don't really want 456. Ban them outright? No - make a list
4: sun.reflect.NativeMethodAccessorImpl.invoke0(Native Method)
5: sun.reflect.NativeMethodAccessorImpl.invoke(NativeMethodAccessorImpl.java:62)
6: sun.reflect.DelegatingMethodAccessorImpl.invoke(DelegatingMethodAccessorImpl.java:43)
7: java.lang.reflect.Method.invoke(Method.java:497)
|#
;; (#"setLambdaName" # '(flet a))
;; reader error is still ugly. Maybe anything that calls signal.
(provide :stacktrace)
abcl-src-1.9.2/contrib/abcl-introspect/t/disassemble.lisp 0100644 0000000 0000000 00000003351 14343623723 022131 0 ustar 00 0000000 0000000 (in-package :cl-user)
(let ((disassembler (first (abcl-build:split-string
ext:*disassembler* #\Space))))
(prove:plan 1)
(prove:ok
(abcl-build:introspect-path-for disassembler)
(format nil
"Testing invocation of ~a specified by EXT:*DISASSEMBLER*âŠ" disassembler)))
(let ((disassemblers '(:objectweb :javap :jad :fernflower :cfr :procyon)))
(prove:plan (* 2 (length disassemblers)))
(dolist (disassembler disassemblers)
(prove:ok
(asdf:load-system disassembler)
(format nil "Loading ~a" disassembler))
(prove:ok
(handler-case
(let ((expected (intern :disassemble-class-bytes
(format nil "ABCL-INTROSPECT/JVM/TOOLS/~a" (symbol-name disassembler)))))
(equal
(sys:choose-disassembler disassembler)
expected))
(t (e)
(progn
(prove:diag (format nil "Choosing ~a failed: ~a" disassembler e))
nil)))
(format nil "Able to choose ~a disassembler" disassembler)))
(prove:plan (length disassemblers))
(dolist (disassembler disassemblers)
(let ((output (make-string-output-stream)))
(prove:ok
(handler-case
(let ((*standard-output* output))
(sys:choose-disassembler disassembler)
(cl:disassemble #'cons)
(let ((result (get-output-stream-string output)))
(not (null (and result
(stringp result)
(> (length result) 0))))))
(t (e)
(progn
(prove:diag (format nil "Invocation failed: ~a" e))
nil)))
(format nil "Invocation of ~a disassembler" disassembler)))))
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-introspect/t/environments.lisp 0100644 0000000 0000000 00000002030 14343623723 022356 0 ustar 00 0000000 0000000 (in-package :cl-user)
(defmacro env-parts (&environment env)
`(sys::environment-parts ,env))
(prove:plan 1)
(prove:is
(eval
'(let ((a 10))
(env-parts)))
'((:lexical-variable a 10))
"Lexical let binding captures local")
(prove:plan 1)
(prove:ok
(let ((env-parts-information
(eval '(let ((b 20))
(defun bar ()
(let ((a 10)) (env-parts)))
(bar))))
(expected-clauses
#| Testing envionment actually contains:
((:LEXICAL-VARIABLE A 10) (:LEXICAL-VARIABLE B 20)
(:BLOCK BAR #))
|#
'((:LEXICAL-VARIABLE A 10) (:LEXICAL-VARIABLE B 20))))
;;; FIXME find a more idiomatic way to do this that also reports
;;; what fails. Use CL:INTERSECTION
(reduce
(lambda (a b) (and a b))
(mapcar
(lambda (item)
(member item env-parts-information :test #'equalp))
expected-clauses)))
"Nested lexical bindings captures locals")
(prove:finalize)
abcl-src-1.9.2/contrib/abcl-introspect/util.lisp 0100644 0000000 0000000 00000004547 14343623723 020360 0 ustar 00 0000000 0000000 (in-package :extensions)
;;; TODO: submit upstream patch to for removal
(defun write-class (class-bytes pathname)
"Write the Java byte[] array CLASS-BYTES to PATHNAME."
(with-open-file (stream pathname
:direction :output
:element-type '(unsigned-byte 8))
(dotimes (i (java:jarray-length class-bytes))
(write-byte (java:jarray-ref class-bytes i) stream))))
(defun read-class (pathname)
"Read the file at PATHNAME as a Java byte[] array"
(with-open-file (stream pathname
:direction :input
:element-type '(unsigned-byte 8))
(let* ((length
(file-length stream))
(array
(make-array length :element-type '(unsigned-byte 8))))
(read-sequence array stream :end length)
(java:jnew-array-from-array "byte" array))))
(export '(write-class
read-class)
:extensions)
;;; Determining the underlying unix file descriptor depends on
;;; navigating private member structures dependent on the hosting
;;; JVMs wrapping of native socket. The JAVA package currently does
;;; not have a means for such aggressive intropsection, so we add it
;;; as a utility here
;;;
;;; TODO test under :msdog
;;; TODO Should be in socket.lisp
(defun stream-unix-fd (stream)
"Return the integer of the underlying unix file descriptor for STREAM
Added by ABCL-INTROSPECT."
(check-type stream 'system::socket-stream)
(flet ((get-java-fields (object fields) ;; Thanks to Cyrus Harmon
(reduce (lambda (x y)
(jss:get-java-field x y t))
fields
:initial-value object))
(jvm-version ()
(read
(make-string-input-stream
(java:jstatic "getProperty" "java.lang.System"
"java.specification.version")))))
(ignore-errors
(get-java-fields (java:jcall "getWrappedInputStream" ;; TODO: define this as a constant
(two-way-stream-input-stream stream))
(if (< (jvm-version) 14)
'("in" "ch" "fdVal")
'("in" "this$0" "sc" "fd" "fd"))))))
(export '(stream-unix-fd) :extensions)
abcl-src-1.9.2/contrib/abcl-stepper/README.markdown 0100644 0000000 0000000 00000053373 14444524627 020511 0 ustar 00 0000000 0000000 ABCL-STEPPER
============
ABCL-STEPPER provides a working implementation of an stepper as a replacement for the empty cl:step, you can get more documentation in the related paper presented in the European Lisp Symposium (ELS) 2023, see https://zenodo.org/record/7815887
Some characteristics:
- For intepreted code, it won't step into compiled functions
- It is ready to use from a plain REPL and from SLIME.
- In general it doesn't handle unexpected conditions in the code to step, if the the code to step fails the stepper will fail too
':?' will print a minimal help (you can type :help)
':i' can inspect variables and symbols (case-insensitive when inspecting, you can also type :inspect)
':c' will resume the evaluation until the end without the stepper (you can type :continue)
':s' will resume the evaluation until the next form to be analyzed (you can type :step)
':sn' will to step to the next form
':l' will show the local bindings for variables and functions
in the current environment passed to the current form to evaluate (you can type :locals)
':b' will add a breakpoint to a symbol to use with next (n) (you can type :br+ or :add-breakpoint)
':r' will remove an existent symbol breakpoint to use with next (n) (you can type :br- or :remove-breakpoint)
':d' will remove all existent symbol breakpoints to use with next (n) (you can type :br! or :delete-breakpoints)
':w' (or :watch) allows to pin binding to see in all steps
':u' (or :unwatch) allows to remove the bindings established by :watch
':bt' (or :backtrace) shows the current backtrace
':q': The quit q feature will abort the evaluation in the stepper
and return NIL. This is useful to avoid running the remaining (you can type :quit)
forms in the code when the user wants to leave the
stepper, specially if the rest of the program is doing costly
operations.
:'n' allows to jump the next (n) symbol:
The next n feature allow to stop the stepper only when the
interpreter is analyzing one of the symbols specified in the
list of stepper::*stepper-stop-symbols* or any of the exported
symbols presented in any of the list of packages specified in
stepper::*stepper-stop-packages*. These variables will have
initially the value NIL and if they are not modified, next will
behave exactly as continue. It is useful when we want to
step large or complex code and avoid stepping every form in
order to jump only to the interested ones.
Usage:
Attaching a sample session to illustrate the use of the stepper
```
CL-USER(1): (require :asdf)
NIL
CL-USER(2): (require :abcl-contrib)
NIL
CL-USER(3): (require :abcl-stepper)
NIL
CL-USER(4): (defparameter *some-var* 1)
*SOME-VAR*
CL-USER(5): (defun test ()
(let ((*some-var* nil)
(x 3))
(list *some-var* 3)))
TEST
CL-USER(6): (stepper:step (test))
We are in the stepper mode
Evaluating step 1 -->
(TEST)
Type ':?' for a list of options
:i
Type the name of the symbol: *some-var*
1
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 2 -->
(BLOCK TEST
(LET ((*SOME-VAR* NIL) (X 3))
(LIST *SOME-VAR* 3)))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 3 -->
(LET ((*SOME-VAR* NIL) (X 3))
(LIST *SOME-VAR* 3))
Type ':?' for a list of options
:?
Type ':l' to see the values of bindings on the local environment
Type ':c' to resume the evaluation until the end without the stepper
Type ':n' to resume the evaluation until the next form previously selected to step in
Type ':s' to step into the form
Type ':i' to inspect the current value of a variable or symbol
Type ':b' to add a symbol as a breakpoint to use with next (n)
Type ':r' to remove a symbol used as a breakpoint with next (n)
Type ':d' to remove all breakpoints used with next (n)
Type ':w' to print the value of a binding in all the steps (watch)
Type ':u' to remove a watched binding (unwatch)
Type ':bt' to show the backtrace
Type ':q' to quit the evaluation and return NIL
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 4 -->
(LIST *SOME-VAR* 3)
Type ':?' for a list of options
:l
Showing the values of variable bindings.
From inner to outer scopes:
X=3
*SOME-VAR*=NIL
Showing the values of function bindings.
From inner to outer scopes:
Type ':?' for a list of options
:i
Type the name of the symbol: x
3
Type ':?' for a list of options
:i
Type the name of the symbol: *some-var*
NIL
Type ':?' for a list of options
:s
step 4 ==> value: (NIL 3)
step 3 ==> value: (NIL 3)
step 2 ==> value: (NIL 3)
step 1 ==> value: (NIL 3)
(NIL 3)
CL-USER(7): (stepper:step (flet ((flet1 (n) (+ n n)))
(flet ((flet2 (n) (+ 2 (flet1 n))))
(flet2 2))))
We are in the stepper mode
Evaluating step 1 -->
(FLET ((FLET1 (N) (+ N N)))
(FLET ((FLET2 (N) (+ 2 (FLET1 N)))) (FLET2 2)))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 2 -->
(FLET ((FLET2 (N) (+ 2 (FLET1 N)))) (FLET2 2))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 3 -->
((FLET FLET2) 2)
Type ':?' for a list of options
:l
Showing the values of variable bindings.
From inner to outer scopes:
Showing the values of function bindings.
From inner to outer scopes:
FLET2=# {152C83E7}>
FLET1=# {7AA67C0B}>
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 4 -->
(BLOCK FLET2 (+ 2 (FLET1 N)))
Type ':?' for a list of options
:l
Showing the values of variable bindings.
From inner to outer scopes:
N=2
Showing the values of function bindings.
From inner to outer scopes:
FLET1=# {7AA67C0B}>
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 5 -->
(+ 2 (FLET1 N))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 6 -->
((FLET FLET1) N)
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 7 -->
(BLOCK FLET1 (+ N N))
Type ':?' for a list of options
:c
step 7 ==> value: 4
step 6 ==> value: 4
step 5 ==> value: 6
step 4 ==> value: 6
step 3 ==> value: 6
step 2 ==> value: 6
step 1 ==> value: 6
6
CL-USER(8): (stepper:step (progn
((lambda (c d) (list c d)) 3 7)))
We are in the stepper mode
Evaluating step 1 -->
(PROGN ((LAMBDA (C D) (LIST C D)) 3 7))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 2 -->
(# {22A1D243}> 3 7)
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 3 -->
(LIST C D)
Type ':?' for a list of options
:i
Type the name of the symbol: c
3
Type ':?' for a list of options
:i
Type the name of the symbol: d
7
Type ':?' for a list of options
:l
Showing the values of variable bindings.
From inner to outer scopes:
D=7
C=3
Showing the values of function bindings.
From inner to outer scopes:
Type ':?' for a list of options
:s
step 3 ==> value: (3 7)
step 2 ==> value: (3 7)
step 1 ==> value: (3 7)
(3 7)
CL-USER(9): (stepper:step (let ((a 1)) ;; for skip(q) feature, it should return NIl anyhow
(block whatever (list 1 2))
a))
We are in the stepper mode
Evaluating step 1 -->
(LET ((A 1))
(BLOCK WHATEVER (LIST 1 2))
A)
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 2 -->
(BLOCK WHATEVER (LIST 1 2))
Type ':?' for a list of options
:l
Showing the values of variable bindings.
From inner to outer scopes:
A=1
Showing the values of function bindings.
From inner to outer scopes:
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 3 -->
(LIST 1 2)
Type ':?' for a list of options
:q
NIL
CL-USER(10): (stepper:step (let ((a 1)) ;; for skip(q) feature, it should return NIl anyhow
(block whatever (list 1 2))
a))
We are in the stepper mode
Evaluating step 1 -->
(LET ((A 1))
(BLOCK WHATEVER (LIST 1 2))
A)
Type ':?' for a list of options
:c
step 1 ==> value: 1
1
CL-USER(11): (stepper:step (let ((a 1))
(let ((a 2) (b 1))
(- a b)) ;; <-- list locals
(+ a 3 7)))
We are in the stepper mode
Evaluating step 1 -->
(LET ((A 1))
(LET ((A 2) (B 1))
(- A B))
(+ A 3 7))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 2 -->
(LET ((A 2) (B 1))
(- A B))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 3 -->
(- A B)
Type ':?' for a list of options
:l
Showing the values of variable bindings.
From inner to outer scopes:
B=1
A=2
A=1
Showing the values of function bindings.
From inner to outer scopes:
Type ':?' for a list of options
:s
step 3 ==> value: 1
step 2 ==> value: 1
We are in the stepper mode
Evaluating step 4 -->
(+ A 3 7)
Type ':?' for a list of options
:l
Showing the values of variable bindings.
From inner to outer scopes:
A=1
Showing the values of function bindings.
From inner to outer scopes:
Type ':?' for a list of options
:s
step 4 ==> value: 11
step 1 ==> value: 11
11
CL-USER(12): (stepper:step (progn (defparameter *azf* 1)))
We are in the stepper mode
Evaluating step 1 -->
(PROGN (DEFPARAMETER *AZF* 1))
Type ':?' for a list of options
:c
step 1 ==> value: *AZF*
*AZF*
CL-USER(13): (assert (= *azf* 1))
NIL
CL-USER(14): (defpackage step-next (:use :cl))
#
CL-USER(15): (in-package :step-next)
#
STEP-NEXT(16): (defun loop-1 (a b)
(loop :for i :below a
:collect (list a b)))
LOOP-1
STEP-NEXT(17): (defun loop-2 (a)
(loop :for i :below a
:collect i))
LOOP-2
STEP-NEXT(18): (defun loop-3 (n &optional (times 1))
(loop :for i :below times
:collect times))
LOOP-3
STEP-NEXT(19): (defun test-next (n)
(loop-1 (1+ n) n)
(loop-2 (1- n))
(loop-3 n 3)
;; quit (q) here
(defparameter *test-next-var*
(loop :for i :below (expt 10 6)
:collect i)))
TEST-NEXT
STEP-NEXT(20): (push 'loop-1 stepper::*stepper-stop-symbols*)
(LOOP-1)
STEP-NEXT(21): (export 'loop-3)
T
STEP-NEXT(22): (push 'step-next stepper::*stepper-stop-packages*)
(STEP-NEXT)
STEP-NEXT(23): (stepper:step (test-next 7))
We are in the stepper mode
Evaluating step 1 -->
(TEST-NEXT 7)
Type ':?' for a list of options
:n
We are in the stepper mode
Evaluating step 2 -->
(LOOP-1 (1+ N) N)
Type ':?' for a list of options
:n
step 2 ==> value: ((8 7) (8 7) (8 7) (8 7) (8 7) (8 7) (8 7) (8 7))
We are in the stepper mode
Evaluating step 3 -->
(LOOP-3 N 3)
Type ':?' for a list of options
:q
NIL
STEP-NEXT(24): (assert (not (boundp '*test-next-var*)))
NIL
STEP-NEXT(25): (stepper:step (test-next 7))
We are in the stepper mode
Evaluating step 1 -->
(TEST-NEXT 7)
Type ':?' for a list of options
:r
Type the name of the breakpoint symbol to remove: loop-1
Type ':?' for a list of options
:b
Type the name of the symbol to use as a breakpoint with next (n): loop-2
Type ':?' for a list of options
:n
We are in the stepper mode
Evaluating step 2 -->
(LOOP-2 (1- N))
Type ':?' for a list of options
:n
step 2 ==> value: (0 1 2 3 4 5)
We are in the stepper mode
Evaluating step 3 -->
(LOOP-3 N 3)
Type ':?' for a list of options
:c
step 3 ==> value: (3 3 3)
step 1 ==> value: *TEST-NEXT-VAR*
*TEST-NEXT-VAR*
STEP-NEXT(26): (defun test-watch ()
(let ((x 1))
(dotimes (i 7)
(incf x))
x))
TEST-WATCH
STEP-NEXT(27): (stepper:step (test-watch))
We are in the stepper mode
Evaluating step 1 -->
(TEST-WATCH)
Type ':?' for a list of options
:w
Type the name of the symbol to watch: x
Type ':?' for a list of options
Watched bindings:
Couldn't find a value for symbol X
:s
We are in the stepper mode
Evaluating step 2 -->
(BLOCK TEST-WATCH
(LET ((X 1))
(DOTIMES (I 7) (SETQ X (+ X 1)))
X))
Type ':?' for a list of options
Watched bindings:
Couldn't find a value for symbol X
:s
We are in the stepper mode
Evaluating step 3 -->
(LET ((X 1))
(DOTIMES (I 7) (SETQ X (+ X 1)))
X)
Type ':?' for a list of options
Watched bindings:
Couldn't find a value for symbol X
:s
We are in the stepper mode
Evaluating step 4 -->
(DOTIMES (I 7) (SETQ X (+ X 1)))
Type ':?' for a list of options
Watched bindings:
X=1
:s
We are in the stepper mode
Evaluating step 5 -->
(SETQ X (+ X 1))
Type ':?' for a list of options
Watched bindings:
X=1
:s
We are in the stepper mode
Evaluating step 6 -->
(+ X 1)
Type ':?' for a list of options
Watched bindings:
X=1
:s
step 6 ==> value: 2
step 5 ==> value: 2
We are in the stepper mode
Evaluating step 7 -->
(SETQ X (+ X 1))
Type ':?' for a list of options
Watched bindings:
X=2
:s
We are in the stepper mode
Evaluating step 8 -->
(+ X 1)
Type ':?' for a list of options
Watched bindings:
X=2
:s
step 8 ==> value: 3
step 7 ==> value: 3
We are in the stepper mode
Evaluating step 9 -->
(SETQ X (+ X 1))
Type ':?' for a list of options
Watched bindings:
X=3
:s
We are in the stepper mode
Evaluating step 10 -->
(+ X 1)
Type ':?' for a list of options
Watched bindings:
X=3
:s
step 10 ==> value: 4
step 9 ==> value: 4
We are in the stepper mode
Evaluating step 11 -->
(SETQ X (+ X 1))
Type ':?' for a list of options
Watched bindings:
X=4
:s
We are in the stepper mode
Evaluating step 12 -->
(+ X 1)
Type ':?' for a list of options
Watched bindings:
X=4
:s
step 12 ==> value: 5
step 11 ==> value: 5
We are in the stepper mode
Evaluating step 13 -->
(SETQ X (+ X 1))
Type ':?' for a list of options
Watched bindings:
X=5
:u
Type the name of the symbol to (un)watch : x
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 14 -->
(+ X 1)
Type ':?' for a list of options
:s
step 14 ==> value: 6
step 13 ==> value: 6
We are in the stepper mode
Evaluating step 15 -->
(SETQ X (+ X 1))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 16 -->
(+ X 1)
Type ':?' for a list of options
:s
step 16 ==> value: 7
step 15 ==> value: 7
We are in the stepper mode
Evaluating step 17 -->
(SETQ X (+ X 1))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 18 -->
(+ X 1)
Type ':?' for a list of options
:s
step 18 ==> value: 8
step 17 ==> value: 8
step 4 ==> value: NIL
step 3 ==> value: 8
step 2 ==> value: 8
step 1 ==> value: 8
8
STEP-NEXT(28): (defun test-backtrace (x)
(labels ((f1 (x) (f2 (1+ x)))
(f2 (x) (f3 (* x 3)))
(f3 (x) (+ x 10)))
(f1 x)))
TEST-BACKTRACE
STEP-NEXT(29): (stepper:step (test-backtrace 3))
We are in the stepper mode
Evaluating step 1 -->
(TEST-BACKTRACE 3)
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 2 -->
(BLOCK TEST-BACKTRACE
(LABELS ((F1 (X) (F2 (1+ X)))
(F2 (X) (F3 (* X 3)))
(F3 (X) (+ X 10)))
(F1 X)))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 3 -->
(LABELS ((F1 (X) (F2 (1+ X)))
(F2 (X) (F3 (* X 3)))
(F3 (X) (+ X 10)))
(F1 X))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 4 -->
((LABELS F1) X)
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 5 -->
(BLOCK F1 (F2 (1+ X)))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 6 -->
((LABELS F2) (1+ X))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 7 -->
(1+ X)
Type ':?' for a list of options
:s
step 7 ==> value: 4
We are in the stepper mode
Evaluating step 8 -->
(BLOCK F2 (F3 (* X 3)))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 9 -->
((LABELS F3) (* X 3))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 10 -->
(* X 3)
Type ':?' for a list of options
:s
step 10 ==> value: 12
We are in the stepper mode
Evaluating step 11 -->
(BLOCK F3 (+ X 10))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 12 -->
(+ X 10)
Type ':?' for a list of options
:bt
(#
#
#
#
#
#
#
#
#)
Type ':?' for a list of options
:c
step 12 ==> value: 22
step 11 ==> value: 22
step 9 ==> value: 22
step 8 ==> value: 22
step 6 ==> value: 22
step 5 ==> value: 22
step 4 ==> value: 22
step 3 ==> value: 22
step 2 ==> value: 22
step 1 ==> value: 22
22
STEP-NEXT(30): (stepper:step (values (list (cons 1 3) (cons 1 7))
(list (cons 2 4) (cons 2 8))))
We are in the stepper mode
Evaluating step 1 -->
(VALUES (LIST (CONS 1 3) (CONS 1 7)) (LIST (CONS 2 4) (CONS 2 8)))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 2 -->
(LIST (CONS 1 3) (CONS 1 7))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 3 -->
(CONS 1 3)
Type ':?' for a list of options
:s
step 3 ==> value: (1 . 3)
We are in the stepper mode
Evaluating step 4 -->
(CONS 1 7)
Type ':?' for a list of options
:s
step 4 ==> value: (1 . 7)
step 2 ==> value: ((1 . 3) (1 . 7))
We are in the stepper mode
Evaluating step 5 -->
(LIST (CONS 2 4) (CONS 2 8))
Type ':?' for a list of options
:sn
step 5 ==> value: ((2 . 4) (2 . 8))
step 1 ==> value: ((1 . 3) (1 . 7))
step 1 ==> value: ((2 . 4) (2 . 8))
((1 . 3) (1 . 7))
((2 . 4) (2 . 8))
STEP-NEXT(31):
```
For steps with ASDF systems we can use asdf:load-source-op
```
CL-USER(1): (require :asdf)
NIL
CL-USER(2): (require :abcl-contrib)
NIL
CL-USER(3): (require :abcl-stepper)
NIL
CL-USER(4): (asdf:load-system :quicklisp-abcl)
T
CL-USER(5): (ql:quickload :alexandria)
To load "alexandria":
Load 1 ASDF system:
alexandria
; Loading "alexandria"
(:ALEXANDRIA)
CL-USER(6): (asdf:operate 'asdf:load-source-op :alexandria)
#
#
CL-USER(7): (stepper:step (alexandria:plist-hash-table '(:a 1 :b 2 :c 3)))
We are in the stepper mode
Evaluating step 1 -->
(ALEXANDRIA:PLIST-HASH-TABLE '(:A 1 :B 2 :C 3))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 2 -->
'(:A 1 :B 2 :C 3)
Type ':?' for a list of options
:s
step 2 ==> value: (:A 1 :B 2 :C 3)
We are in the stepper mode
Evaluating step 3 -->
(BLOCK ALEXANDRIA:PLIST-HASH-TABLE
(LET ((ALEXANDRIA::TABLE
(APPLY #'MAKE-HASH-TABLE ALEXANDRIA::HASH-TABLE-INITARGS)))
(DO ((ALEXANDRIA::TAIL ALEXANDRIA::PLIST
(CDDR ALEXANDRIA::TAIL)))
((NOT ALEXANDRIA::TAIL))
(LET ((#:KEY29386 (CAR ALEXANDRIA::TAIL))
(#:HASH-TABLE29387 ALEXANDRIA::TABLE))
(MULTIPLE-VALUE-BIND (#:VALUE29388 #:PRESENTP29389)
(GETHASH #:KEY29386 #:HASH-TABLE29387)
(IF #:PRESENTP29389
(VALUES #:VALUE29388 #:PRESENTP29389)
(VALUES (SYSTEM:PUTHASH #:KEY29386
#:HASH-TABLE29387
(CADR ALEXANDRIA::TAIL))
NIL)))))
ALEXANDRIA::TABLE))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 4 -->
(LET ((ALEXANDRIA::TABLE
(APPLY #'MAKE-HASH-TABLE ALEXANDRIA::HASH-TABLE-INITARGS)))
(DO ((ALEXANDRIA::TAIL ALEXANDRIA::PLIST (CDDR ALEXANDRIA::TAIL)))
((NOT ALEXANDRIA::TAIL))
(LET ((#:KEY29386 (CAR ALEXANDRIA::TAIL))
(#:HASH-TABLE29387 ALEXANDRIA::TABLE))
(MULTIPLE-VALUE-BIND (#:VALUE29388 #:PRESENTP29389)
(GETHASH #:KEY29386 #:HASH-TABLE29387)
(IF #:PRESENTP29389
(VALUES #:VALUE29388 #:PRESENTP29389)
(VALUES (SYSTEM:PUTHASH #:KEY29386
#:HASH-TABLE29387
(CADR ALEXANDRIA::TAIL))
NIL)))))
ALEXANDRIA::TABLE)
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 5 -->
(APPLY #'MAKE-HASH-TABLE ALEXANDRIA::HASH-TABLE-INITARGS)
Type ':?' for a list of options
:l
Showing the values of variable bindings.
From inner to outer scopes:
HASH-TABLE-INITARGS=NIL
PLIST=(A 1 B 2 C 3)
HASH-TABLE-INITARGS=NIL
PLIST=(A 1 B 2 C 3)
Showing the values of function bindings.
From inner to outer scopes:
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 6 -->
#'MAKE-HASH-TABLE
Type ':?' for a list of options
:s
step 6 ==> value: #
step 5 ==> value: #
We are in the stepper mode
Evaluating step 7 -->
(DO ((ALEXANDRIA::TAIL ALEXANDRIA::PLIST (CDDR ALEXANDRIA::TAIL)))
((NOT ALEXANDRIA::TAIL))
(LET ((#:KEY29386 (CAR ALEXANDRIA::TAIL))
(#:HASH-TABLE29387 ALEXANDRIA::TABLE))
(MULTIPLE-VALUE-BIND (#:VALUE29388 #:PRESENTP29389)
(GETHASH #:KEY29386 #:HASH-TABLE29387)
(IF #:PRESENTP29389
(VALUES #:VALUE29388 #:PRESENTP29389)
(VALUES (SYSTEM:PUTHASH #:KEY29386
#:HASH-TABLE29387
(CADR ALEXANDRIA::TAIL))
NIL)))))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 8 -->
(NOT ALEXANDRIA::TAIL)
Type ':?' for a list of options
:s
step 8 ==> value: NIL
We are in the stepper mode
Evaluating step 9 -->
(LET ((#:KEY29386 (CAR ALEXANDRIA::TAIL))
(#:HASH-TABLE29387 ALEXANDRIA::TABLE))
(MULTIPLE-VALUE-BIND (#:VALUE29388 #:PRESENTP29389)
(GETHASH #:KEY29386 #:HASH-TABLE29387)
(IF #:PRESENTP29389
(VALUES #:VALUE29388 #:PRESENTP29389)
(VALUES (SYSTEM:PUTHASH #:KEY29386
#:HASH-TABLE29387
(CADR ALEXANDRIA::TAIL))
NIL))))
Type ':?' for a list of options
:s
We are in the stepper mode
Evaluating step 10 -->
(CAR ALEXANDRIA::TAIL)
Type ':?' for a list of options
:c
step 10 ==> value: :A
step 9 ==> value: 1
step 7 ==> value: NIL
step 4 ==> value: #
step 3 ==> value: #
step 1 ==> value: #
#
CL-USER(8):
```
abcl-src-1.9.2/contrib/abcl-stepper/abcl-stepper.asd 0100644 0000000 0000000 00000000652 14444524627 021052 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(defsystem abcl-stepper
:author "Alejandro Zamora Fonseca"
:description "An operational stepper for ABCL"
:long-description ""
:version "0.0.1"
:components ((:module base
:pathname ""
:components ((:file "abcl-stepper")
(:static-file "README.markdown")))))
abcl-src-1.9.2/contrib/abcl-stepper/abcl-stepper.lisp 0100644 0000000 0000000 00000033510 14444524627 021251 0 ustar 00 0000000 0000000 ;;; This file is part of ABCL contrib
;;;
;;; Copyright (C) 2023 Alejandro Zamora Fonseca
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module. An independent module is a module which is not derived from
;;; or based on this library. If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
(defpackage #:abcl-stepper
(:use :cl)
(:nicknames #:stepper)
(:shadow #:step)
(:export #:step
#:start
#:stop
#:*stepper-stop-packages*
#:*stepper-stop-symbols*))
(in-package #:abcl-stepper)
(defparameter *stepper-stop-packages* nil
"List of packages in which the stepper will stop in its external symbols")
(defparameter *stepper-stop-symbols* nil
"List of symbols in which the stepper will stop")
(defparameter *stepper-watch-symbols* nil
"List of symbols in which will be printed in every step")
(defparameter *step-next-table* (make-hash-table)
"Used for the feature step-next, show the number of steps that have been completed")
(defparameter *step-next-counter* -1
"Indicates if the feature step-next is active by showing the current step to be completed")
(defun clear-step-next ()
(setf *step-next-counter* -1)
(setf *step-next-table* (make-hash-table)))
(defun set-step-counter-completed (current-step-counter)
;; mark the counter for steps as completed
;; and force the printing of pending output
(setf (gethash current-step-counter *step-next-table*) t))
(defmacro without-active-stepping (&body body)
`(progn (sys:%set-stepping-task-on)
(multiple-value-prog1 (progn ,@body)
(sys:%set-stepping-task-off))))
(defun print-stepper-str (string newline)
"Prints a line using the java method 'System.out.println'"
(without-active-stepping
(princ string)
(if newline (terpri))
(unless (in-slime-repl-p)
(finish-output))))
(defun pprint-stepper-str (string)
"Pretty prints a line using the java method 'System.out.println'"
(print-stepper-str (with-output-to-string (s)
(pprint string s))
t))
(defun pprint-form-to-step (symbol args step-count)
(print-stepper-str "" t)
(print-stepper-str "We are in the stepper mode" t)
(print-stepper-str (format nil "Evaluating step ~a -->" step-count) nil)
(print-stepper-str
(with-output-to-string (s)
(pprint `(,symbol ,@args) s))
t))
(defun add-breakpoint ()
(print-stepper-str "Type the name of the symbol to use as a breakpoint with next (n): " nil)
(let* ((symbol-str (without-active-stepping (read-line)))
(symbol (ignore-errors (without-active-stepping (read-from-string symbol-str)))))
;; ensure we found the symbol
(unless symbol
(print-stepper-str (format nil "Couldn't find the symbol ~a" symbol-str) t))
(pushnew symbol *stepper-stop-symbols*)))
(defun remove-breakpoint ()
(print-stepper-str "Type the name of the breakpoint symbol to remove: " nil)
(let* ((symbol-str (without-active-stepping (read-line)))
(symbol (ignore-errors (without-active-stepping (read-from-string symbol-str)))))
;; ensure we found the symbol
(unless symbol
(print-stepper-str (format nil "Couldn't find the symbol ~a" symbol-str) t))
(setf *stepper-stop-symbols* (remove symbol *stepper-stop-symbols*))))
(defun remove-all-breakpoints ()
(setf *stepper-stop-symbols* nil)
(print-stepper-str "Removed all symbol breakpoints" t))
(defun lookup-symbol (symbol env &optional var-description)
(let* ((lookup-method (java:jmethod "org.armedbear.lisp.Environment" "lookup" "org.armedbear.lisp.LispObject"))
(symbol-lookup (java:jcall-raw lookup-method env symbol)))
(cond ((or (not (java:java-object-p symbol-lookup))
(not (java:jnull-ref-p symbol-lookup)))
(print-stepper-str
(if var-description
(format nil "~a=~a" symbol symbol-lookup)
(format nil "~a" symbol-lookup))
t))
((boundp symbol)
(print-stepper-str
(if var-description
(format nil "~a=~a" symbol (symbol-value symbol))
(format nil "~a" (symbol-value symbol)))
t))
(t
(print-stepper-str (format nil "Couldn't find a value for symbol ~a" symbol) t)))))
(defun inspect-variable (env)
(print-stepper-str "Type the name of the symbol: " nil)
(let* ((symbol-str (without-active-stepping (read-line)))
(symbol (ignore-errors (without-active-stepping (read-from-string symbol-str)))))
;; ensure we found the symbol
(unless symbol
(print-stepper-str (format nil "Couldn't find the symbol ~a" symbol-str) t)
(return-from inspect-variable))
;; let's try to retrieve the value from the symbol
(lookup-symbol symbol env)))
(defun print-stepper-help ()
(print-stepper-str "Type ':l' to see the values of bindings on the local environment" t)
(print-stepper-str "Type ':c' to resume the evaluation until the end without the stepper" t)
(print-stepper-str "Type ':n' to resume the evaluation until the next form previously selected to step in" t)
(print-stepper-str "Type ':s' to step into the form" t)
(print-stepper-str "Type ':sn' to step to the next form" t)
(print-stepper-str "Type ':i' to inspect the current value of a variable or symbol" t)
(print-stepper-str "Type ':b' to add a symbol as a breakpoint to use with next (n)" t)
(print-stepper-str "Type ':r' to remove a symbol used as a breakpoint with next (n)" t)
(print-stepper-str "Type ':d' to remove all breakpoints used with next (n)" t)
(print-stepper-str "Type ':w' to print the value of a binding in all the steps (watch)" t)
(print-stepper-str "Type ':u' to remove a watched binding (unwatch)" t)
(print-stepper-str "Type ':bt' to show the backtrace" t)
(print-stepper-str "Type ':q' to quit the evaluation and return NIL" t))
(defun pprint-list-locals (locals)
(loop :for pair :in locals
:do (print-stepper-str (format nil "~a=~a" (car pair) (cdr pair)) t)))
(defun insert-watch-symbol ()
(print-stepper-str "Type the name of the symbol to watch: " nil)
(let* ((symbol-str (without-active-stepping (read-line)))
(symbol (ignore-errors (without-active-stepping (read-from-string symbol-str)))))
;; ensure we found the symbol
(unless symbol
(print-stepper-str (format nil "Couldn't find the symbol ~a" symbol-str) t)
(return-from insert-watch-symbol))
(pushnew symbol *stepper-watch-symbols*)))
(defun remove-watch-symbol ()
(print-stepper-str "Type the name of the symbol to (un)watch : " nil)
(let* ((symbol-str (without-active-stepping (read-line)))
(symbol (ignore-errors (without-active-stepping (read-from-string symbol-str)))))
;; ensure we found the symbol
(unless symbol
(print-stepper-str (format nil "Couldn't find the symbol ~a" symbol-str) t)
(return-from remove-watch-symbol))
(setf *stepper-watch-symbols* (remove symbol *stepper-watch-symbols*))))
(defun step-in-symbol-p (fun object delimited-stepping)
"Decides if the stepper will be applied to the OBJECT being evaluated and manages the internal
states of the stepper"
(cond
((or
(and (consp object)
(or (eq fun #'system::%subseq)
(equal object '(BLOCK SUBSEQ (SYSTEM::%SUBSEQ SEQUENCE SYSTEM::START SYSTEM::END)))
(equal object '(BLOCK LENGTH (SYSTEM::%LENGTH SEQUENCE)))
(eq fun #'system::%length)))
(and (consp object)
(eq (car object)
'CL:MULTIPLE-VALUE-PROG1)
(equal (car (last object))
'(system:%set-delimited-stepping-off)))
(equal fun #'sys:%set-stepper-off))
;; we don't step the expansion of 'step' macro
nil)
((and (/= *step-next-counter* -1)
(gethash *step-next-counter* *step-next-table*))
(clear-step-next)
t)
((and (/= *step-next-counter* -1)
(not (gethash *step-next-counter* *step-next-table*)))
nil)
(delimited-stepping
;; Analyze next symbols
(sys:%set-stepper-off)
(let* ((function-name
(or (ignore-errors (nth-value 2 (function-lambda-expression fun)))
(ignore-errors (car object))))
(stop-at-symbol-p-value
(and function-name (stop-at-symbol-p function-name))))
(sys:%set-stepper-on)
(when stop-at-symbol-p-value
(sys:%set-delimited-stepping-off)
t)))
(t t)))
(defun stop-at-symbol-p (symbol)
"Indicates if the stepper need to stop at the current symbol"
(or (find symbol *stepper-stop-symbols* :test 'eq)
(some (lambda (package)
(do-external-symbols (s (find-package package))
(if (eq s symbol)
(return t))))
*stepper-stop-packages*)))
(defun list-locals (env)
(print-stepper-str "Showing the values of variable bindings." t)
(print-stepper-str "From inner to outer scopes:" t)
(pprint-list-locals (sys:environment-all-variables env))
(print-stepper-str "Showing the values of function bindings." t)
(print-stepper-str "From inner to outer scopes:" t)
(pprint-list-locals (sys:environment-all-functions env)))
(defun print-watched-symbols (env)
(when *stepper-watch-symbols*
(print-stepper-str "Watched bindings:" t)
(loop :for watch-symbol :in *stepper-watch-symbols*
:do (lookup-symbol watch-symbol env t))))
(defun handle-user-interaction (env)
(let ((leave-prompt nil)
(unexpected-input-user nil)
(char-input-user nil))
(loop :until leave-prompt
:do (unless unexpected-input-user
(print-stepper-str "Type ':?' for a list of options" t)
(without-active-stepping (print-watched-symbols env)))
(without-active-stepping
(setf char-input-user (read))
(clear-input))
(case char-input-user
((:? :help)
(without-active-stepping (print-stepper-help)))
((:l :locals)
(without-active-stepping (list-locals env)))
((:c :continue)
(sys:%set-stepper-off)
(setf leave-prompt t))
((:sn :step-next)
(setf *step-next-counter* (sys:%get-step-counter))
(setf leave-prompt t))
((:n :next)
(sys:%set-delimited-stepping-on)
(setf leave-prompt t))
((:s :step) (setf leave-prompt t))
((:q :quit)
(sys:%set-stepper-off)
(sys:%set-delimited-stepping-off)
(sys:%return-from-stepper))
((:i :inspect)
(without-active-stepping (inspect-variable env)))
((:b :br+ :add-breakpoint)
(without-active-stepping (add-breakpoint)))
((:r :br- :remove-breakpoint)
(without-active-stepping (remove-breakpoint)))
((:d :br! :delete-breakpoints)
(without-active-stepping (remove-all-breakpoints)))
((:w :watch)
(without-active-stepping (insert-watch-symbol)))
((:u :unwatch)
(without-active-stepping (remove-watch-symbol)))
((:bt :backtrace)
(without-active-stepping
;; we avoid the first 2 entries of the backtrace
;; because they are constant and unrelated to the code
;; being stepped
(pprint-stepper-str (subseq (sys:backtrace) 2))))
(otherwise (setf unexpected-input-user t))))))
(defun in-slime-repl-p ()
"Determines if we are in Slime/Sly connection"
(some (lambda (c)
(and (find-package c)
(symbol-value (find-symbol "*EMACS-CONNECTION*" c))))
'(:swank :slynk)))
(defun start ()
(print-stepper-str "This function activates the stepper." t)
(print-stepper-str "Remember to deactivate it after the end of the execution using (stepper:stop)." t)
(print-stepper-str "To clean its internal flags" t)
(sys:%initialize-step-counter)
(sys:%initialize-step-block)
(sys:%set-stepper-on))
(defun stop ()
"Stops the stepper"
(sys:%set-stepper-off)
(clear-step-next)
(sys:%set-delimited-stepping-off)
(sys:%set-stepping-task-off))
(defmacro step (form)
(let ((stepper-block (gensym)))
`(let ()
(block ,stepper-block
(sys:%initialize-step-counter)
(sys:%initialize-step-block)
(sys:%set-stepper-on)
(multiple-value-prog1 ,form
(sys:%set-stepper-off)
(clear-step-next)
(sys:%set-delimited-stepping-off))))))
(provide :abcl-stepper)
abcl-src-1.9.2/contrib/asdf-jar/README.markdown 0100644 0000000 0000000 00000006266 14437653062 017614 0 ustar 00 0000000 0000000 ASDF-JAR
========
ASDF-JAR provides a system for packaging ASDF systems into jar
archives for ABCL. Given a running ABCL image with loadable ASDF
systems the code in this package will recursively package all the
required source and fasls in a jar archive .
To install ASDF systems, [Quicklisp]() is probably the best
contemporary solution. The QUICKLISP-ABCL
may be used to install Quicklisp at runtime from within ABCL.
[Quicklisp]: http://www.quicklisp.org
Once the requisite ASDF systems have been installed, ensure that this
contrib is loaded via
CL-USER) (require :abcl-contrib)
CL-USER> (asdf:make :asdf-jar)
Then, one may package any locally loadable ASDF system via
ASDF-JAR:PACKAGE as follows:
CL-USER> (asdf-jar:package :chunga :verbose t)
Packaging ASDF definition of #
Performing unforced compilation of /var/tmp/chunga-all-1.1.7.jar.
Packaging contents in '/var/tmp/chunga-all-1.1.7.jar'.
Packaging with recursive dependencies #.
/Users/evenson/quicklisp/dists/quicklisp/software/chunga-20221106-git/streams.lisp
=>chunga/streams.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/chunga-20221106-git/input.lisp
=>chunga/input.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/chunga-20221106-git/specials.lisp
=>chunga/specials.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/chunga-20221106-git/known-words.lisp
=>chunga/known-words.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/chunga-20221106-git/util.lisp
=>chunga/util.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/chunga-20221106-git/read.lisp
=>chunga/read.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/chunga-20221106-git/output.lisp
=>chunga/output.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/chunga-20221106-git/conditions.lisp
=>chunga/conditions.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/chunga-20221106-git/packages.lisp
=>chunga/packages.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/trivial-gray-streams-20210124-git/streams.lisp
=>trivial-gray-streams/streams.lisp
/Users/evenson/quicklisp/dists/quicklisp/software/trivial-gray-streams-20210124-git/package.lisp
=>trivial-gray-streams/package.lisp
#P"/var/tmp/chunga-all-1.1.7.jar"
#
The resulting jar contains the source required to run the ASDF system
including any transitive ASDF dependencies. Each such system is
packaged under its own top level directory within the jar archive.
To load the system from the jar one needs to add the ASDF file
locations to the ASDF source registry, conveniently abstracted as the
ASDF-JAR:ADD-TO-JAR function:
CL-USER> (asdf-jar:add-to-asdf "/var/tmp/chunga-all-1.1.7.jar)
a subsequent
CL-USER> (asdf:load-system :chunga)
should load the ASDF system from the jar.
Setting CL:*LOAD-VERBOSE* will allow one to verify that the subsequent
load is indeed coming from the jar.
# Colophon
Mark Evenson
Created: 20-JUN-2011
Revised: 01-APR-2023
abcl-src-1.9.2/contrib/asdf-jar/asdf-jar-test.asd 0100644 0000000 0000000 00000000515 14437653062 020237 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(defsystem asdf-jar-test
:defsystem-depends-on (prove-asdf)
:depends-on (prove hunchentoot)
:perform (test-op (o c)
(uiop:symbol-call :prove-asdf 'run-test-system c))
:components ((:module test
:pathname "t/"
:components ((:test-file "package-asdf")))))
abcl-src-1.9.2/contrib/asdf-jar/asdf-jar.asd 0100644 0000000 0000000 00000001115 14444524627 017261 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(defsystem asdf-jar
:author "Mark Evenson"
:description "Packaging ASDF systems into jar files"
:long-description ""
:version "0.4.0"
:in-order-to ((test-op (test-op :asdf-jar-test)))
:components ((:module package
:pathname "./"
:components ((:file "package")))
(:module base
:depends-on (package)
:pathname "./"
:components ((:file "asdf-jar")
(:static-file "README.markdown")))))
abcl-src-1.9.2/contrib/asdf-jar/asdf-jar.lisp 0100644 0000000 0000000 00000026223 14437653062 017466 0 ustar 00 0000000 0000000 ;;; This file is part of ABCL contrib
;;;
;;; Copyright 2011 Mark
(in-package #:asdf-jar)
(defun add-system-files-to-mapping! (system
mapping
system-base
system-name
root
&key
(fasls t)
(verbose nil))
"Add all the files of a SYSTEM to the MAPPING with a given
SYSTEM-BASE and SYSTEM-NAME.
This function destructively modifies MAPPING returning nil."
(let ((abcl-file-type "abcl"))
(loop
:for component :in (all-files system)
:for source = (asdf/component:component-pathname component)
:for source-entry = (merge-pathnames
(archive-relative-path system-base system-name source)
(make-pathname :directory root))
:do (setf (gethash source mapping)
source-entry)
:do (format verbose "~&~A~%~T=>~A~%" source source-entry)
:when (and fasls
(typep component 'asdf/component:source-file)
(not (typep component 'asdf/component:static-file)))
:do (let ((output
(make-pathname
:defaults (asdf:apply-output-translations source)
:type abcl-file-type))
(output-entry
(make-pathname :defaults source-entry
:type abcl-file-type)))
(format verbose "~&~A~% => ~A~%" output output-entry)
(setf (gethash output mapping)
output-entry)))))
(defun systems->hash-table (systems root &key (fasls t) (verbose nil))
"Build a hash table from a list of SYSTEMS mapping absolute file
names to of these systems into relative path names under the pathname
directory component ROOT.
This mapping will be used to zip the files of the system
into a jar file."
(let ((mapping (make-hash-table :test 'equal)))
(dolist (system systems)
(let ((base (slot-value system 'asdf/component:absolute-pathname))
(name (slot-value system 'asdf/component:name))
(asdf (slot-value system 'asdf/component:source-file)))
;; For the purposes of locating their ASDF file, subsystems
;; use the name of their parent.
(let ((position (position #\/ name)))
(when position
(setf name
(subseq name 0 position)))
(setf (gethash asdf mapping)
(let ((relative-path (archive-relative-path base name asdf)))
(merge-pathnames
relative-path
(make-pathname :directory root))))
(let ((additional
(slot-value system 'asdf/component::additional-input-files)))
(when additional
(loop
:for (op file) :in additional
:when (and
op ;; TODO: tighten allowed ops?
(probe-file file))
:do (setf (gethash file mapping)
(let ((relative-path (archive-relative-path base name file)))
(merge-pathnames
relative-path
(make-pathname :directory root))))))
(add-system-files-to-mapping! system mapping base name root
:fasls fasls
:verbose verbose)))))
mapping))
(defun package (system &key
(out #p"/var/tmp/")
(recursive t) ; whether to package dependencies
(force nil) ; whether to force ASDF compilation
(fasls nil)
(root '(:relative))
(verbose nil))
"Compile and package the asdf SYSTEM in a jar.
When RECURSIVE is true (the default), recursively add all asdf
dependencies into the same jar.
Place the resulting packaged jar in the OUT directory.
If FORCE is true, force asdf to recompile all the necessary fasls.
VERBOSE controls how many messages will be logged to
*standard-output*.
ROOT controls if the relative pathnames will be appended to something
before being added to the mapping. The purpose of having this option
is to add the paths to an internal directory, such as (list :relative
\"META-INF\" \"resources\") for generating WAR files.
Returns the pathname of the packaged jar archive as the first value,
and the hash of its members source to destination locations as the
second.
"
(when (not (typep system 'asdf:system))
(setf system (asdf:find-system system)))
(let* ((name
(slot-value system 'asdf/component:name))
(version (let ((v (slot-value system 'asdf:version)))
(when v
v)))
(package-jar-name
(format nil "~A~A~A" name (if recursive "-all" "")
(if version
(format nil "-~A" version)
"")))
(package-jar
(make-pathname :name package-jar-name
:type "jar"
:defaults out)))
(when verbose
(format verbose "~&Packaging ASDF definition of ~A~%" system))
(when verbose
(format verbose "~&Performing ~a compilation of ~A.~%"
(if force
"forced"
"unforced")
package-jar))
(asdf:compile-system system :force force)
(when verbose
(format verbose "~&Packaging contents in '~A'.~%" package-jar))
(let ((hash-table
(systems->hash-table
(append (list system)
(when recursive
(let* ((dependencies
(dependent-systems system))
(washed-dependencies
(remove-if-not
(lambda (s)
(if (asdf/component:component-pathname s)
t
(progn
(when verbose
(format verbose
"~&Ignoring dependency ~a without associated pathname.~%"
s))
nil)))
dependencies)))
(when (and verbose washed-dependencies)
(format verbose
"~&Packaging with recursive dependencies~{ ~A~^, ~}.~%"
washed-dependencies))
(mapcar #'asdf:find-system washed-dependencies))))
root
:fasls fasls :verbose verbose)))
(values
(system:zip package-jar hash-table)
hash-table))))
(defun all-files (component)
(loop
:for c
:being :each :hash-value :of (slot-value component 'asdf/component:children-by-name)
:when (typep c 'asdf:module)
:append (all-files c)
:when (typep c 'asdf/component:source-file)
:append (list c)))
(defun resolve-system-or-feature (system-or-feature)
"Resolve SYSTEM-OR-FEATURE to an asdf system"
(cond
((null system-or-feature)
nil)
((and (consp system-or-feature)
(= (length system-or-feature) 1))
(asdf:find-system (first system-or-feature)))
((and (consp system-or-feature)
(= (length system-or-feature) 3))
(destructuring-bind (keyword expression system)
system-or-feature
(unless (equalp keyword :feature)
(error "~a is not a feature expression" system-or-feature))
(when (uiop/os:featurep expression)
(asdf:find-system system))))
((typep system-or-feature 'asdf:system)
system-or-feature)
(t
(asdf:find-system system-or-feature))))
(defun dependent-systems (system-or-feature)
(let ((system
(resolve-system-or-feature system-or-feature)))
(when system
(remove-duplicates
(loop :for dependency
:in (asdf/component:component-sideway-dependencies system)
:for resolved-dependency = (resolve-system-or-feature dependency)
:for dependents = (dependent-systems resolved-dependency)
:when resolved-dependency
:collect resolved-dependency
:when dependents
:append dependents)))))
(defun archive-relative-path (base dir file)
(let* ((relative
(nthcdr (length (pathname-directory base)) (pathname-directory file)))
(entry-dir `(:relative ,dir ,@relative)))
(make-pathname :device nil
:directory entry-dir
:defaults file)))
(defun tmpdir (name)
"Return temporary directory."
(let* ((temp-file (java:jcall "getAbsolutePath"
(java:jstatic "createTempFile" "java.io.File"
(symbol-name (gensym)) "tmp")))
(temp-path (pathname temp-file)))
(make-pathname
:directory (nconc (pathname-directory temp-path)
(list name)))))
(defun add-to-asdf (jar &key (use-jar-fasls nil) (verbose *standard-output*))
"Make a given JAR output by the package mechanism loadable by asdf.
NOTICE: the use of fasls from the jar does not currently seem to work.
The parameter passed to :USE-JAR-FASLS determines whether to instruct
asdf to use the fasls packaged in the jar. If this is nil, the
default, the fasls will be compiled with respect to the usual asdf
output translation conventions."
(when (not (typep jar 'pathname))
(setf jar (pathname jar)))
(when (null (pathname-device jar))
(setf jar (make-pathname :device (list jar))))
;;; Inform ASDF of all the system definitions in the jar
(let ((asdf-files
(directory (merge-pathnames "*/*.asd" jar))))
(format verbose "~&Adding to ASDF: ~{~%~t<~a>~}~%" asdf-files)
(ext:register-asdf asdf-files))
;;; Load the FASLs directly from the jar
(when use-jar-fasls
(let* ((source
(make-pathname :defaults jar
:directory '(:ABSOLUTE :WILD-INFERIORS) :name :wild :type :wild))
(destination
source))
(asdf:initialize-output-translations
`(:output-translations (,source ,destination) :inherit-configuration)))))
(defun prepare-for-war (system &key
(out #p"/var/tmp/")
(recursive nil) ; whether to package dependencies
(force nil) ; whether to force ASDF compilation
(root (list :relative "META-INF" "resources"))
(verbose t))
"Package named asdf SYSTEM for deployment in a Java Servlet container war file.
c.f. PACKAGE for further options."
(package system :out out :recursive recursive :force force :verbose verbose
:root root))
(provide :asdf-jar)
abcl-src-1.9.2/contrib/asdf-jar/asdf-jar.org 0100644 0000000 0000000 00000010644 14437653062 017306 0 ustar 00 0000000 0000000 #+TITLE: clearing the bitrot out of ASDF-JAR
* @selwynsimsek GitHub issue
* Development
** DONE package from system located in JAR
CLOSED: [2023-03-28 Tue 09:54]
- CLOSING NOTE [2023-03-28 Tue 09:54] \\
Implemented with new method in zip.java that uses a =java.io.InputStream= as well as an explicit lastModified parameter.
Try to get a =java.io.File= reference to an entry in a jar file, so
the current code path in =system-jar= works.
#+caption: stuck at
#+begin_example
Caught java.lang.UnsupportedOperationException.
[Condition of type ERROR]
#+end_example
** DONE don't package fasls by default
CLOSED: [2023-03-21 Tue 08:47]
- CLOSING NOTE [2023-03-21 Tue 08:47] \\
Add :fasls keyword to various routines, with NIL as default
** DONE add separate package file source unit, a test or two
CLOSED: [2023-03-21 Tue 08:12]
- CLOSING NOTE [2023-03-21 Tue 08:12] \\
Test present: JSS still not working.
** DONE eval IF-FEATURE for individual source files
CLOSED: [2023-03-31 Fri 14:19]
- CLOSING NOTE [2023-03-31 Fri 14:19] \\
Implemented as a semi-hacky thing that tries to interpret its arg as a system if it can't parse it as a feature.
<[[file:asdf-jar.lisp::defun resolve-system-or-feature (system-or-feature]]>
** DONE configure ASDF to find a contrib on the filesystem
CLOSED: [2023-03-20 Mon 21:20]
- CLOSING NOTE [2023-03-20 Mon 21:20]
<[[info:asdf.info#Configuration DSL][asdf.info#Configuration DSL]]>
#+begin_src lisp
(asdf:initialize-source-registry
'(:source-registry :ignore-inherited-configuration
(:directory #p"~/work/abcl/contrib/jss/")))
#+end_src
#+RESULTS:
#+begin_src lisp
(asdf:locate-system :jss)
#+end_src
#+begin_src lisp
(mapcar
(lambda (p) (when (not (pathname-jar-p p)) p))
asdf:*central-registry*)
#+end_src
#+caption: save central registry
#+begin_src lisp
(setf xx asdf:*central-registry*)
#+end_src
#+begin_src lisp
(defun collect-abcl-contrib-directories ()
(let* ((all-asd
(directory
(asdf:system-relative-pathname :abcl "contrib/**/*.asd")))
(unique-directories
(loop :for asd :in all-asd
:with result = nil
:doing
(pushnew (make-pathname :directory (pathname-directory asd)
:name nil :type nil)
result :test #'equalp)
:finally
(return result))))
(values
unique-directories
all-asd)))
#+end_src
#+RESULTS:
: COLLECT-ABCL-CONTRIB-DIRECTORIES
#+name: rig-asdf #
#+caption: Rig ASDF to use the ASDF location of ABCL contrib source on filesystem
#+begin_src lisp
(defun rig-asdf ()
(let* ((not-jars
(mapcar
(lambda (p) (when (not (pathname-jar-p p)) p))
asdf:*central-registry*))
(directories
(remove-if #'not not-jars))
(initial-without-jar
(loop :for d :in directories
:collecting `(:directory ,d)))
(abcl-contrib-directories
(loop :for d :in (collect-abcl-contrib-directories)
:collecting `(:directory ,d))))
(asdf:initialize-source-registry
`(:source-registry
,#+nil
:ignore-inherited-configuration
,@abcl-contrib-directories
,@initial-without-jar
:inherit-configuration))))
#+end_src
#+caption: Transitioning away from use of ASDF:*CENTRAL-REGISTRY*
#+begin_src lisp
(setf asdf:*central-registry* nil)
(rig-asdf)
#+end_src
** DONE Refactored rig-asdf as EXT:REGISTER-ASDF
CLOSED: [2023-03-31 Fri 14:20]
- CLOSING NOTE [2023-03-31 Fri 14:20] \\
TODO: add an equivalent API to fiddle with asdf output-translations? The current plan is to include that machinery in the ASDF-JAR contrib
<[[file:~/work/abcl/src/org/armedbear/lisp/abcl-contrib.lisp::defun register-asdf (asdf-file-or-files]]>
** TODO Use fasls from jar
* Fragments
** use EXT:ADD-TO-ASDF
#+begin_src lisp
(ext:register-asdf '("/Users/evenson/easye/work/illithid/illithid.asd"
"/Users/evenson/net/slack.net/home/mevenson/work/etch/etch.asd"))
#+end_src
#+RESULTS:
* References
**
* Colophon
#+begin_example
Mark
Created: 2023-03-06
Revised: <2023-03-31 Fri 14:41>
#+end_example
abcl-src-1.9.2/contrib/asdf-jar/package.lisp 0100644 0000000 0000000 00000000301 14437653062 017357 0 ustar 00 0000000 0000000 (defpackage #:asdf-jar
(:use :cl)
(:export #:package
;; "Si vis pacem, para bellum" -- Publius Flavius Vegetius Renatus
#:prepare-for-war
#:add-to-asdf))
abcl-src-1.9.2/contrib/asdf-jar/t/package-asdf.lisp 0100644 0000000 0000000 00000001021 14437653062 020535 0 ustar 00 0000000 0000000 (asdf:make :asdf-jar)
(prove:plan 1)
;;;; Systems like JSS are part of the ABCL-CONTRIB, therefore usually
;;;; reside in jar files, for which copying fasls is currently broken
;;;;
(asdf:clear-system :jss)
(asdf:make :jss)
(prove:ok
(asdf-jar:package :jss :verbose t :fasls nil)
"Able to package JSS")
(asdf:make :quicklisp-abcl)
(prove:plan 1)
(prove:ok
(asdf-jar:package :hunchentoot :verbose t :fasls nil)
(format nil "Able to package HUNCHENTOOT"))
(prove:finalize)
abcl-src-1.9.2/contrib/jfli/README 0100644 0000000 0000000 00000002631 14444524627 015222 0 ustar 00 0000000 0000000 JFLI
====
The Java Foreign Linker Interface (JFLI) provides an abstraction to
manipulate Java classes from Armed Bear Common Lisp that has been
ported to other Lisp implementations.
Incorporated into ABCL from .
README
------
jfli (http://jfli.sf.net) is a library that provides access to Java
from Lisp. jfli-abcl is jfli modified to work with ABCL
(http://armedbear-j.sf.net); it provides the same interface to Java,
but, since ABCL lives on the JVM, it doesn't need jni.
jfli-abcl has an experimental NEW-CLASS macro that writes and loads a
Java class at runtime, and defines the usual jfli-like Lisp interface
to it. See the documentation of NEW-CLASS and the examples for the
syntax. If you want to use it, make sure that (1) asm.jar
(http://asm.objectweb.org) is in your classpath, and (2) the runtime
generated Java classes are in the Java package of the same name as the
Lisp package in which they're defined, like this:
(in-package "FOO")
(new-class "FOO.MyClass" ...)
Caveats: jfli-abcl inherits all the bugs from jfli; see the archives
of the jfli-users mailing list for a partial list. It probably also
adds some of its own. I'm particularly interested in the latter type.
Please send (ABCL-specific) bug reports, suggestions, examples,
and whatever else you can think of, to asimon@math.bme.hu.
# Colophon
<> abcl:documents .
abcl-src-1.9.2/contrib/jfli/examples/swing/README 0100644 0000000 0000000 00000000471 14343623723 020162 0 ustar 00 0000000 0000000 This is a swing/jdbc example.
To try it, (compile and) load table-gen.lisp and table.lisp
(you need to modify it a bit first if you're not using PostgreSQL), in
this order, then do
(table:create-and-show-gui "select * from ")
The cells are editable, so don't try it on an important db table.
abcl-src-1.9.2/contrib/jfli/examples/swt/README 0100644 0000000 0000000 00000002510 14343623723 017644 0 ustar 00 0000000 0000000 This example is a Lisp version of Explorer v9 from
http://www-106.ibm.com/developerworks/opensource/library/os-ecgui3/
The gifs are from
ftp://www6.software.ibm.com/software/developer/library/os-ecgui3/examples.zip
To use it, (optionally compile) and load swt9jfli-gen.lisp first, and
then swt9jfli.lisp. Start it with (swt0:main).
But make sure first that besides asm.jar (http:/asm.objectweb.org),
the various swt-related jars are in your classpath. I start abcl like
this:
/usr/java/jdk1.5.0/bin/java -cp /home/simon/java/j2/j/src/\
:/usr/share/java/pg74.215.jdbc3.jar\
:/home/simon/java/asm-1.5.1/lib/asm-1.5.1.jar\
:/opt/home/simon/java/eclipse/plugins/org.eclipse.core.boot_2.1.3/boot.jar\
:/opt/home/simon/java/eclipse/plugins/org.eclipse.core.runtime_2.1.1/runtime.jar\
:/opt/home/simon/java/eclipse/plugins/org.eclipse.jface_2.1.3/jface.jar\
:/opt/home/simon/java/eclipse/plugins/org.eclipse.jface.text_2.1.0/jfacetext.jar\
:/opt/home/simon/java/eclipse/plugins/org.eclipse.swt.gtk_2.1.3/ws/gtk/swt.jar\
:/opt/home/simon/java/eclipse/plugins/org.eclipse.swt.gtk_2.1.3/ws/gtk/swt-pi.jar\
-Djava.library.path=/opt/home/simon/java/eclipse/plugins/org.eclipse.swt.gtk_2.1.3/os/linux/x86/\
:/home/simon/java/jogl/\
org.armedbear.lisp.Main "$@"
If everything goes well, a window like
http://www.math.bme.hu/~asimon/lisp/swt.png should appear.
abcl-src-1.9.2/contrib/jfli/examples/swt/file.gif 0100644 0000000 0000000 00000000377 14343623723 020403 0 ustar 00 0000000 0000000 GIF89a ïżœ ïżœïżœ_ïżœïżœïżœïżœïżœïżœßżïżœßïżœïżœïżœïżœïżœïżœïżœïżœïżœ___ïżœïżœïżœ !ïżœ , E0ïżœI+=8c+) x ïżœïżœ Yïżœ@Ćïżœïżœyïżœïżœïżœïżœïżœïżœ
ïżœKïżœ|ïżœïżœeRïżœxHïżœsÇïżœïżœïżœïżœïżœïżœvïżœïżœïżœïżœÈ±D ;
abcl-src-1.9.2/contrib/jfli/examples/swt/folder.gif 0100644 0000000 0000000 00000000407 14343623723 020731 0 ustar 00 0000000 0000000 GIF89a ïżœ ïżœïżœïżœïżœ ïżœïżœ?ïżœïżœïżœ__?ßż?ïżœïżœ_ïżœïżœ?ßż_ïżœßïżœïżœïżœ___ïżœïżœïżœ !ïżœ , MïżœïżœIïżœïżœ8ïżœïżœïżœfK2ïżœïżœ iïżœ Sïżœ ïżœïżœ(F^ïżœR@ïżœDïżœP ïżœbïżœïżœXhïżœ>%ïżœïżœIïżœïżœj/8ïżœfïżœïżœïżœpx
èŽ ïżœïżœ3 ;
abcl-src-1.9.2/contrib/jfli/jfli.asd 0100644 0000000 0000000 00000000600 14444524627 015751 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(defsystem jfli
:long-description ""
:version "0.2.0"
:components ((:file "jfli")))
;;; Requires integration with IntelliJ IDEA editor (free download)
(defsystem jfli/intellij-tests
:version "0.2.0"
:depends-on (jfli)
:components ((:module test
:components ((:file "yanking")))))
abcl-src-1.9.2/contrib/jfli/jfli.lisp 0100644 0000000 0000000 00000153161 14343623723 016157 0 ustar 00 0000000 0000000 ; 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 distribution.
; 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.
; Ported to ABCL by asimon@math.bme.hu.
; Minor ABCL fixes by:
; A. Vodonosov (avodonosov@yandex.ru).
; Alex Mizrahi (alex.mizrahi@gmail.com)
(defpackage :jfli
(:use :common-lisp :java)
(:export
: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
:*null*
:new-class
:super
))
(in-package :jfli)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun string-append (&rest strings)
(apply #'concatenate 'string (mapcar #'(lambda (s) (if (symbolp s) (symbol-name s) s)) strings)))
(defun intern-and-unexport (string package)
(multiple-value-bind (symbol status)
(find-symbol string package)
(when (and *compile-file-pathname* (eq status :external)) (unexport symbol package))
(intern string package)))
)
(defun is-assignable-from (class-1 class-2)
(jcall (jmethod "java.lang.Class" "isAssignableFrom" "java.lang.Class")
class-2 class-1)) ;;not a typo
#+abcl_not_used
(defun new-object-array (len element-type initial-element)
(jnew-array-from-array element-type (make-array (list len) :initial-element initial-element)))
(defun java-ref-p (x)
(java-object-p x))
(deftype java-ref ()
'(satisfies java-ref-p))
(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 is-name-of-primitive (s)
(member s '("boolean" "byte" "char" "short" "int" "long" "float" "double" "void")
:test #'string-equal))
(defun is-primitive-class (class)
(is-name-of-primitive (jclass-name class)))
(defun convert-to-java-string (s)
(jnew (jconstructor "java.lang.String" "java.lang.String") s))
(define-symbol-macro boolean.type (jfield "java.lang.Boolean" "TYPE"))
(define-symbol-macro byte.type (jfield "java.lang.Byte" "TYPE"))
(define-symbol-macro character.type (jfield "java.lang.Character" "TYPE"))
(define-symbol-macro short.type (jfield "java.lang.Short" "TYPE"))
(define-symbol-macro integer.type (jfield "java.lang.Integer" "TYPE"))
(define-symbol-macro long.type (jfield "java.lang.Long" "TYPE"))
(define-symbol-macro float.type (jfield "java.lang.Float" "TYPE"))
(define-symbol-macro double.type (jfield "java.lang.Double" "TYPE"))
(define-symbol-macro void.type (jfield "java.lang.Void" "TYPE"))
#|
(defconstant boolean.type (jfield "java.lang.Boolean" "TYPE"))
(defconstant byte.type (jfield "java.lang.Byte" "TYPE"))
(defconstant character.type (jfield "java.lang.Character" "TYPE"))
(defconstant short.type (jfield "java.lang.Short" "TYPE"))
(defconstant integer.type (jfield "java.lang.Integer" "TYPE"))
(defconstant long.type (jfield "java.lang.Long" "TYPE"))
(defconstant float.type (jfield "java.lang.Float" "TYPE"))
(defconstant double.type (jfield "java.lang.Double" "TYPE"))
|#
(defconstant *null* java:+null+)
(defun identity-or-nil (obj)
(unless (equal obj *null*) obj))
;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(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")))
(defun enumeration.hasmoreelements (enum)
(jcall (jmethod "java.util.Enumeration" "hasMoreElements") enum))
(defun enumeration.nextelement (enum)
(jcall (jmethod "java.util.Enumeration" "nextElement") enum))
(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)))
,@body)))))
;probably insufficiently general, works as used here
(defmacro get-or-init (place init-form)
`(or ,place
(setf ,place ,init-form)))
(eval-when (:compile-toplevel)
(intern-and-unexport "OBJECT." "java.lang"))
;create object. to bootstrap the hierarchy
(defclass |java.lang|::object. ()
((ref :reader ref :initarg :ref)
(lisp-allocated :reader lisp-allocated-p :initarg :lisp-allocated :initform 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 typed reference instance.
Will also convert strings for use as objects"
;; avodonosov:
;; typecase instead of etypecase
;; to allow not only jfli-wrapped objects
;; as a parameters of NEW-CLASS, but also native
;; Lisp objects too (in case of ABCL they are java
;; instances anyway).
;; For example that may be org.armedbear.lisp.Function.
(typecase x
(java-ref x)
(|java.lang|::object. (ref x))
(string (convert-to-java-string x))
(null nil)
((or number character) x)
;; avodonosov: otherwise clause
(otherwise x)))
(defun is-same-object (obj1 obj2)
(equal obj1 obj2))
(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/names:
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, which can either be
the full class name as a string, the class-symbol, or one of :boolean, :int 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 package))))
(defun unexported-class-symbol (full-class-name)
"(\"java.lang.Object\") -> '|java.lang|::object."
(multiple-value-bind (package class) (split-package-and-class full-class-name)
(intern-and-unexport (string-upcase (string-append class ".")) (ensure-package package))))
(defun java-class-name (class-sym)
"inverse of class-symbol, only valid on class-syms created by def-java-class"
(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 unexported-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-and-unexport (string-upcase (string-append class "." member-name)) (ensure-package package))))
(defun constructor-symbol (full-class-name)
(member-symbol full-class-name "new"))
(defun unexported-constructor-symbol (full-class-name)
(unexported-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-class-symbol))
"."
canonic-class-symbol)))
(jclass 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)
(:void void.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 (jclass-superclass class))
(interfaces (jclass-interfaces class))
(supers ()))
(loop for i across interfaces
do (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 (jclass "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 #'jclass-name 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
#+abcl
(mop::ensure-class class-sym :direct-superclasses (mapcar #'(lambda (c) (find-class (class-symbol c))) 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 (jobject-class java-ref)))
(if (jclass-array-p class)
(error "typed refs not supported for arrays (yet)")
(make-instance (%ensure-java-class (jclass-name class)) :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 runtime,
complete the work of building thunking closures, so very little code is generated 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 generate
wrapper functions for its contructors, fields and methods."
(multiple-value-bind (pacakge class) (split-package-and-class full-class-name)
(declare (ignore class))
(let* ((class-sym (unexported-class-symbol full-class-name))
(defs
(list*
#+nil `(format t "!!!!!!!!!!~a~%" ,full-class-name)
`(ensure-package ,pacakge)
;build a path from the simple class symbol to the canonic
`(defconstant ,class-sym ',(canonic-class-symbol full-class-name))
`(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= full-class-name "java.lang.Object")
(let* ((supers (mapcar #'unexported-class-symbol (get-superclass-names full-class-name)))
(super-exports
(mapcar #'(lambda (class-sym) `(export ',class-sym (symbol-package ',class-sym)))
supers)))
(append (mapcar
(lambda (p) `(ensure-package ,(package-name p)))
(remove (symbol-package class-sym)
(remove-duplicates (mapcar #'symbol-package supers))))
super-exports
(list
`(defclass ,(class-symbol full-class-name)
,supers ()))))))))
`(locally ,@defs))))
(defun jarfile.new (fn)
(jnew (jconstructor "java.util.jar.JarFile" "java.lang.String") fn))
(defun jarfile.entries (jar)
(jcall (jmethod "java.util.jar.JarFile" "entries") jar))
(defun zipentry.isdirectory (e)
(jcall (jmethod "java.util.zip.ZipEntry" "isDirectory") e))
(defun zipentry.getname (e)
(jcall (jmethod "java.util.zip.ZipEntry" "getName") e))
(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 package))))) ;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 (jconstructor-params 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 (unexported-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 (jclass-constructors 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 (jconstructor-params ctor))))
(lambda (&rest args)
(let ((arglist (build-arglist args arg-boxers)))
(ensure-java-hierarchy class-sym)
(make-instance class-sym
:ref (apply #'jnew ctor arglist)
:lisp-allocated t)))))
(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 (length (jconstructor-params ctor))))
(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 class-sym)
;only one ctor with this number of args
(make-non-overloaded-ctor-thunk (first ctors) 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 class-sym)
(jarray-to-list (jconstructor-params 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 functions
If this-name is supplied it will be bound to the newly-allocated object and 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) (split-package-and-class class-atom)
(find-symbol (string-append (string-upcase class) ".") package))))
(class-name (subseq (symbol-name class-sym) 0 (1- (length (symbol-name class-sym)))))
(gthis (gensym)))
(flet ((expand-init (x)
(if (keywordp (first x)) ;setf field or property
`(setf (,(find-symbol (string-append class-name "." (symbol-name (first x))))
,gthis ,@(butlast (rest x)))
,@(last (rest x)))
;.memfunc
`(,(find-symbol (string-append class-name (symbol-name (first x))))
,gthis
,@(rest x)))))
`(let* ((,gthis (make-new ,class-sym ,@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 setter - (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 - (setf 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 (jclass-fields class)))
(defs nil))
(dolist (field fields)
(let* ((field-name (jfield-name field))
(field-sym (unexported-member-symbol full-class-name field-name))
(is-static (jmember-static-p field)))
(if is-static
(let ((macsym (intern-and-unexport (string-append "*" (symbol-name field-sym) "*")
(symbol-package field-sym))))
(push `(defun ,field-sym ()
(install-static-field-and-get ,full-class-name ,field-name))
defs)
(push `(defun (setf ,field-sym) (val)
(install-static-field-and-set ,full-class-name ,field-name val))
defs)
(push `(export ',field-sym (symbol-package ',field-sym)) defs)
(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 obj))
defs)
(push `(defun (setf ,field-sym) (val obj)
(install-field-and-set ,full-class-name ,field-name val 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 (jclass-field class field-name))
(field-sym (member-symbol full-class-name field-name))
(is-static (jmember-static-p field))
(field-type-name (jclass-name (jfield-type 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 (jfield-raw class field-name) #+nil (field.get field nil))))
(setf (fdefinition `(setf ,field-sym))
(lambda (arg)
(jfield field-name nil
(get-ref (if (and boxer (not (boxed? arg)))
(funcall boxer arg)
arg)))
arg)))
(progn
(setf (fdefinition field-sym)
(lambda (obj)
(funcall unboxer (jfield-raw class field-name (get-ref obj)) #+nil(field.get field (get-ref obj)))))
(setf (fdefinition `(setf ,field-sym))
(lambda (arg obj)
(jfield field-name (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 getSomething or isSomething
and there is a corresponding setSomething, then a (setf classname.methodname) will be defined
that calls the latter
|#
(defun class-name-for-doc (class)
(let ((name (jclass-name class)))
(if (jclass-array-p 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 (jmember-static-p m)
"static "
"")
(jclass-name (jmethod-return-type m))
name
(mapcar #'class-name-for-doc (jarray-to-list (jmethod-params 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 (unexported-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-name ,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 name (length prefix)))))
(when (gethash setname methods-by-name)
(push `(defun (setf ,method-sym) (val &rest args)
(progn
(apply #',(member-symbol full-class-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 be 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 (= 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)
(coerce array 'list))
(defun jmethod-made-accessible (method)
"Return a method made accessible"
(jcall (jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean")
method
java:+true+)
method)
(defun jclass-relevant-methods (class)
"Return all public methods, and all protected declared methods"
(append (jarray-to-list (jclass-methods class))
(map 'list #'jmethod-made-accessible
(remove-if-not #'jmember-protected-p (jclass-methods class :declared t)))))
(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))
(methods (jclass-relevant-methods class))
(methods-by-name (make-hash-table :test #'equal)))
(loop for method in methods
do
(push method (gethash (jmethod-name 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 (jclass-name (jmethod-return-type method))))
(arg-boxers (get-arg-boxers (jmethod-params method)))
(is-static (jmember-static-p method))
(caller (if is-static #'jstatic-raw #'jcall-raw)))
(lambda (&rest args)
(let ((arglist (build-arglist (if is-static args (rest args)) arg-boxers)))
(funcall unboxer-fn
(apply caller method
(if is-static nil (get-ref (first args)))
arglist))))))
(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 (jmember-static-p method))
(params-len (length (jmethod-params 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)
(jmember-static-p method)
(jarray-to-list (jmethod-params 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)
(apply #'jarray-ref-raw array subscripts))
(defun (setf jref) (val array &rest subscripts)
(apply #'jarray-set array val subscripts))
(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))
(apply #'jarray-ref array subscripts))
`(defun (setf ,ref-sym) (val array &rest subscripts)
(assert (every #'integerp subscripts))
(apply #'jarray-set array ,(if (eql type 'boolean) '(box-boolean val) 'val) subscripts)
))))
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"
(jarray-length array)) ;(get-ref array)?
(defgeneric make-new-array (type &rest dimensions)
(:documentation "generic function, with methods for all Java class designators")
(:method (type &rest dims)
(assert (every #'integerp dims))
(apply #'jnew-array type 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"
(loop for param-type across param-types
collecting (get-boxer-fn (jclass-name param-type))))
(defun build-arglist (args arg-boxers)
(when args
(loop for arg in args
for boxer in arg-boxers
collecting
(get-ref (if (and boxer (not (boxed? arg)))
(funcall boxer arg)
arg)))))
(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 type
(or (not (is-primitive-class param-type))
(jclass-superclass-p 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"
(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)
(if (string= class-name "boolean")
#'box-boolean
nil))
(defun get-boxer-fn-sym (class-name)
(if (string= class-name "boolean")
'box-boolean
'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) (jobject-class (get-ref x)))
((typep x '(integer -2147483648 +2147483647)) integer.type)
((typep x '(integer -9223372036854775808 +9223372036854775807)) long.type)
((numberp x) double.type)
; ((characterp x) character.type) ;;;FIXME!!
((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)
(if (string= class-name "void")
#'unbox-void
(if (or (is-name-of-primitive class-name) (string= class-name "java.lang.String"))
#'jobject-lisp-value
#'identity-or-nil)))
(defun get-unboxer-fn-sym (class-name)
(if (string= class-name "void")
'unbox-void
(if (or (is-name-of-primitive class-name) (string= class-name "java.lang.String"))
'jobject-lisp-value
'identity-or-nil)))
(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)
(if x java:+true+ java:+false+))
;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun enable-java-proxies ()
t)
(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"
(let (defined-method-names)
(labels ((process-idefs (idefs)
(when (rest idefs)
(error "Sorry, only one interface def at a time"))
(process-idef (first idefs)))
(process-idef (idef)
(destructuring-bind (interface-name &rest method-defs) idef
(let* ((methods (jclass-methods (find-java-class-in-macro interface-name)))
(ret `((find-java-class ,interface-name)
,@(loop for method-def in method-defs appending (process-method-def method-def methods)))))
;;check to make sure every function is defined
(loop for method across methods
for mname = (jmethod-name method)
unless (member mname defined-method-names :test #'string-equal)
do
(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
(push method-name defined-method-names)
(let ((method (matching-method method-name arg-defs methods))
(gargs (gensym)))
`(,(jmethod-name method)
(lambda (&rest ,gargs)
(,(get-boxer-fn-sym (jclass-name (jmethod-return-type method)))
(let ,(arg-lets arg-defs
(jarray-to-list (jmethod-params method))
gargs
0)
,@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 (jclass-name param))
(nth ,idx ,gargs)))
(arg-lets (rest arg-defs) (rest params) gargs (1+ idx))))))
(matching-method (method-name arg-defs methods)
(let (match)
(loop for method across methods
when (method-matches method-name arg-defs method)
do
(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 (jmethod-name method))
(let ((params (jmethod-params method)))
(when (= (length arg-defs) (length 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)) param)))
arg-defs (jarray-to-list params))))
`(java::%jnew-proxy ,@(process-idefs interface-defs)))))
#+nil
(defun jrc (class-name super-name interfaces constructors methods fields &optional filename)
"A friendlier version of jnew-runtime-class."
#+nil (format t "~s~%~s~%~s~%~s~%~s~%~s~%" class-name super-name interfaces constructors methods fields filename)
(if (java:jruntime-class-exists-p class-name)
(progn
(warn "Java class ~a already exists. Redefining methods." class-name)
(loop for
(argument-types function super-invocation-args) in constructors
do
(java:jredefine-method class-name nil argument-types function))
(loop for
(method-name return-type argument-types function &rest modifiers)
in methods
do
(java:jredefine-method class-name method-name argument-types function)))
(java:jnew-runtime-class class-name super-name interfaces constructors methods fields filename)))
(defun get-modifiers (member)
(jcall (jmethod "java.lang.reflect.Member" "getModifiers") member))
(defun get-modifier-list (member)
(let ((mods (get-modifiers member)))
(loop for (mod . mod-call) in
'(("public" . "isPublic")
("protected" . "isProtected")
("private" . "isPrivate")
("static" . "isStatic")
;("abstract" . "isAbstract")
("final" . "isFinal")
("transient" . "isTransient")
("volatile" . "isVolatile")
("synchronized" . "isSynchronized"))
when
(jstatic (jmethod "java.lang.reflect.Modifier" mod-call "int")
"java.lang.reflect.Modifier"
mods)
collect mod)))
(defun get-java-object (x)
(typecase x
(|java.lang|::object. (ref x))
(t x)))
(defun find-java-class-name-in-macro (c)
(etypecase c
(symbol (jclass-name (find-java-class (symbol-value c))))
(string c)))
#+nil
(defmacro new-class (class-name super-and-interface-names constructor-defs method-defs field-defs)
"class-name -> string
super-and-interface-names -> class-name | (class-name interface-name*)
constructor-defs -> (constructor-def*)
constructor-def -> (ctr-arg-defs body)
/the first form in body may be (super arg-name+); this will call the constructor of the superclass
with the listed arguments/
ctr-arg-def -> (arg-name arg-type)
method-def -> (method-name return-type access-modifiers arg-defs* body)
/access-modifiers may be nil (to get the modifiers from the superclass), a keyword, or
a list of keywords/
method-name -> string
arg-def -> arg-name | (arg-name arg-type)
arg-type -> \"package.qualified.ClassName\" | classname. | :primitive
class-name -> \"package.qualified.ClassName\" | classname.
interface-name -> \"package.qualified.InterfaceName\" | interfacename.
Creates, registers and returns a Java object that implements the supplied interfaces"
(let ((this (intern "THIS" *package*))
(defined-method-names))
(labels ((process-ctr-def (ctr-def ctrs)
(destructuring-bind ((&rest arg-defs) &body body)
ctr-def
(let ((ctr-param-names
(mapcar
#'(lambda (arg-def) (find-java-class-name-in-macro (cadr arg-def)))
arg-defs))
;(ctr-param-names (mapcar #'cadr arg-defs))
(gargs (gensym))
(head (car body))
(sia))
(when (and (consp head) (eq (car head) 'super))
(setq sia (mapcar
#'(lambda (arg-name)
(1+ (position arg-name arg-defs :key #'car)))
(cdr head))
body (cdr body)))
`(,ctr-param-names
(lambda (&rest ,gargs)
(let ,(arg-lets (append arg-defs (list this))
(append
ctr-param-names
(list class-name))
gargs
0)
,@body))
,sia))))
(process-method-def (method-def methods)
(destructuring-bind (method-name return-type modifiers (&rest arg-defs) &body body)
method-def
(push method-name defined-method-names)
(let* ((method (matching-method method-name arg-defs methods))
(method-params
(if method
(jarray-to-list (jmethod-params method))
(mapcar #'(lambda (arg-def) (find-java-class-in-macro (cadr arg-def))) arg-defs)))
(method-param-names
#+nil
(if method
(mapcar #'jclass-name (jarray-to-list method-params))
(mapcar #'cadr arg-defs))
(mapcar #'jclass-name method-params))
(return-type-name
(jclass-name
(if method (jmethod-return-type method) (find-java-class-in-macro return-type))))
(modifiers
#+nil
(if method (get-modifier-list method) '("public"))
(cond ((and (null modifiers) method) (get-modifier-list method))
((symbolp modifiers) (list (string-downcase (symbol-name modifiers))))
((consp modifiers) (mapcar #'(lambda (m) (string-downcase (symbol-name m))) modifiers))
(t (error (format t "Need to provide modifiers for method ~A" method-name)))))
(gargs (gensym)))
`(,method-name ,return-type-name ,method-param-names
(lambda (&rest ,gargs)
;;(,(get-boxer-fn-sym return-type-name)
(get-java-object ;;check!
(let ,(arg-lets (append arg-defs (list this))
(append
method-param-names
#+nil (map 'list #'(lambda (p) (jclass-name p)) method-params)
(list class-name))
gargs
0)
,@body))
)
,@modifiers))))
(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 param)
(nth ,idx ,gargs)))
(arg-lets (rest arg-defs) (rest params) gargs (1+ idx))))))
(matching-method (method-name arg-defs methods)
(let (match)
(loop for method across methods
when (method-matches method-name arg-defs method)
do
(if match
(error (format nil "more than one method matches ~A" method-name))
(setf match method)))
match))
(method-matches (method-name arg-defs method)
(when (string-equal method-name (jmethod-name method))
(let ((params (jmethod-params method)))
(when (= (length arg-defs) (length 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)) param)))
arg-defs (jarray-to-list params))))
(unless (consp super-and-interface-names)
(setq super-and-interface-names (list super-and-interface-names)))
(let* ((super-name (find-java-class-name-in-macro (car super-and-interface-names)))
(interfaces (mapcar #'find-java-class-name-in-macro (cdr super-and-interface-names)))
(super (jclass super-name))
(super-ctrs (jclass-constructors super))
(ctrs-ret (loop for ctr-def in constructor-defs collecting
(process-ctr-def ctr-def super-ctrs)))
(super-methods (jclass-methods super))
(iface-methods
(apply #'concatenate 'vector
(mapcar #'(lambda (ifn)
(jclass-methods (jclass ifn)))
interfaces)))
(methods-ret (loop for method-def in method-defs collecting
(process-method-def
method-def
(concatenate 'vector super-methods iface-methods)))))
;;check to make sure every function is defined
(loop for method across iface-methods
for mname = (jmethod-name method)
unless (member mname defined-method-names :test #'string-equal)
do
(warn (format nil "class doesn't define:~%~A" mname)))
`(progn
(jrc ,class-name ,super-name ,interfaces
',ctrs-ret
',methods-ret
(loop for (fn type . mods) in ',field-defs
collecting `(,fn ,(find-java-class-name-in-macro type)
,@(mapcar #'(lambda (mod) (string-downcase (symbol-name mod))) mods)))
#+nil ,(namestring (merge-pathnames class-name "/tmp/")))
(eval '(def-java-class ,class-name)))))))
abcl-src-1.9.2/contrib/jfli/test/yanking.lisp 0100644 0000000 0000000 00000035453 14343623723 017655 0 ustar 00 0000000 0000000 (defpackage :my (:use :cl))
(in-package :my)
;; runtime-class.lisp is a part of ABCL, but it is excluded from ABCL build,
;; because it requires asm.jar to be present in classpath during the build.
;;
;; The functionality it provides is necessary for dynamic creation of
;; new java classes from Lisp (in particular for the
;; NEW-CLASS macro of jfli ABCL port)
(load (concatenate 'string abclidea:*lisp-dir* "org/armedbear/lisp/runtime-class.lisp"))
;; Load jfli
(load (concatenate 'string abclidea:*lisp-dir* "jfli-abcl/jfli-abcl.lisp"))
(use-package :jfli)
;; "Import" java classes we use.
;;
;; You may produce DEF-JAVA-CLASS forms for all the IDEA API classes automatically:
;;
;; (jfli:dump-wrapper-defs-to-file (concatenate 'string abclidea:*lisp-dir* "idea-api.lisp")
;; (jfli:get-jar-classnames "path/to/idea/openapi.jar"
;; "com/intellij"))
;;
;;
;; In result they will be stored in idea-api.lisp file.
;;
;; But we do it manually, because there are not so many classes we use.
(def-java-class "com.intellij.openapi.ui.Messages")
(use-package "com.intellij.openapi.ui")
(def-java-class "com.intellij.openapi.application.ModalityState")
(def-java-class "com.intellij.openapi.application.Application")
(def-java-class "com.intellij.openapi.application.ApplicationManager")
(use-package "com.intellij.openapi.application")
(def-java-class "com.intellij.openapi.actionSystem.AnAction")
(def-java-class "com.intellij.openapi.actionSystem.AnActionEvent")
(def-java-class "com.intellij.openapi.actionSystem.ActionManager")
(def-java-class "com.intellij.openapi.actionSystem.DefaultActionGroup")
(def-java-class "com.intellij.openapi.actionSystem.CustomShortcutSet")
(def-java-class "com.intellij.openapi.actionSystem.Shortcut")
(def-java-class "com.intellij.openapi.actionSystem.KeyboardShortcut")
(def-java-class "com.intellij.openapi.actionSystem.CustomShortcutSet")
(use-package "com.intellij.openapi.actionSystem")
(def-java-class "com.intellij.openapi.ide.CopyPasteManager")
(use-package "com.intellij.openapi.ide")
(def-java-class "com.intellij.openapi.keymap.KeymapManager")
(def-java-class "com.intellij.openapi.keymap.Keymap")
(use-package "com.intellij.openapi.keymap")
(def-java-class "com.intellij.openapi.project.ProjectManager")
(use-package "com.intellij.openapi.project")
(def-java-class "com.intellij.openapi.editor.Editor")
(def-java-class "com.intellij.openapi.editor.Document")
(def-java-class "com.intellij.openapi.editor.SelectionModel")
(use-package "com.intellij.openapi.editor")
(def-java-class "com.intellij.openapi.fileEditor.FileEditorManager")
(def-java-class "com.intellij.openapi.fileEditor.FileEditor")
(def-java-class "com.intellij.openapi.fileEditor.TextEditor")
(use-package "com.intellij.openapi.fileEditor")
(def-java-class "com.intellij.openapi.command.CommandProcessor")
(def-java-class "com.intellij.openapi.command.CommandAdapter")
(def-java-class "com.intellij.openapi.command.CommandEvent")
(use-package "com.intellij.openapi.command")
(def-java-class "com.intellij.openapi.wm.WindowManager")
(def-java-class "com.intellij.openapi.wm.StatusBar")
(use-package "com.intellij.openapi.wm")
(def-java-class "java.lang.Runnable")
(def-java-class "java.lang.Thread")
(def-java-class "java.lang.Object")
(def-java-class "java.lang.Class")
(def-java-class "java.lang.String")
(use-package "java.lang")
(def-java-class "java.awt.datatransfer.Transferable")
(def-java-class "java.awt.datatransfer.DataFlavor")
(use-package "java.awt.datatransfer")
(def-java-class "javax.swing.KeyStroke")
(use-package "javax.swing")
(define-condition action-is-not-applicable ()
((why :initarg :why :reader why))
(:report (lambda (condition stream)
(format stream "Action is not applicable: ~A" (why condition)))))
(defun cur-prj ()
(let ((all-prjs (projectmanager.getopenprojects (projectmanager.getinstance))))
(when (> (jlength all-prjs) 0)
(jref all-prjs 0))))
(defun cur-prj-safe ()
(or (cur-prj) (error 'action-is-not-applicable :why "no current project")))
(defun cur-editor (prj)
(fileeditormanager.getselectedtexteditor (fileeditormanager.getinstance prj)))
(defun cur-editor-safe (prj)
(or (cur-editor prj)
(error 'action-is-not-applicable
:why "no text editor is selected")))
;; region object
(defun make-region (start end)
(cons start end))
(defun region-start (region)
(car region))
(defun region-end (region)
(cdr region))
(defun get-sel-region()
"Selection in the currently active editor"
(let* ((cur-prj (cur-prj-safe))
(cur-editor (cur-editor-safe cur-prj))
(sel-model (editor.getselectionmodel cur-editor)))
(make-region
(selectionmodel.getselectionstart sel-model)
(selectionmodel.getselectionend sel-model))))
(defun replace-region (replacement-text region)
"Replace text in the curently active editor"
(let* ((cur-prj (cur-prj-safe))
(cur-editor (cur-editor-safe cur-prj))
(cur-doc (editor.getdocument cur-editor)))
(document.replacestring cur-doc
(region-start region)
(region-end region)
replacement-text)))
(defvar *yank-index* 0
"Index of clipboard item that will be pasted by the next yank or
yank-pop operation \(similar to kill-ring-yank-pointer in Emacs\).")
(defvar *yank-region* nil
"Region of text that was inserted by previous yank or yank-pop command,
and that must be replaced by next yank-pop.")
(defvar *yank-undo-id* 0
"Yank following by a sequence of yank-pop must be considered as a
single action by undo mechanism. This variable is unique identifier
of such an compound action.")
(defun get-yank-text (&optional (index 0))
(let ((all-contents (copypastemanager.getallcontents (copypastemanager.getinstance)))
content)
(when (zerop (jlength all-contents))
(RETURN-FROM get-yank-tex nil))
(setf content (jref all-contents (mod index (jlength all-contents))))
(transferable.gettransferdata content (dataflavor.stringflavor))))
(defun get-yank-text-safe (&optional (index 0))
(or (get-yank-text index)
(error 'action-is-not-applicable :why "clipboard is empty")))
(defun next-yank-region (cur-selection-region replacement-text)
(make-region (region-start cur-selection-region)
(+ (region-start cur-selection-region)
(length (java:jobject-lisp-value replacement-text)))))
(defun yank()
(let ((sel-region (get-sel-region))
(yank-text (get-yank-text-safe)))
(replace-region yank-text
sel-region)
(setf *yank-region* (next-yank-region sel-region
yank-text))
(setf *yank-index* 1)))
(defun make-runnable (fun)
(java:jinterface-implementation
"java.lang.Runnable"
"run"
;; wrap FUN into lambda to allow it to be
;; not only function objects, but also symbols
;; (java:jinterface-implementation supports
;; only function objects)
(lambda () (funcall fun))))
(defmacro runnable (&body body)
`(make-runnable (lambda () ,@body)))
(defun run-write-action (fun)
(let ((app (applicationmanager.getapplication))
(runnable (make-runnable fun)))
(application.runwriteaction app runnable)))
(defun exec-cmd (fun name group-id)
(commandprocessor.executecommand (commandprocessor.getinstance)
(cur-prj)
(make-runnable fun)
name
group-id))
;; set status bar text
(defun set-status (status-text)
(statusbar.setinfo (windowmanager.getstatusbar
(windowmanager.getinstance)
(cur-prj))
status-text))
(new-class
"MY.MyAction" ;; class name
anaction. ;; super class
;; constructors
(
(((text "java.lang.String") (func "java.lang.Object"))
(super text)
(setf (myaction.func this) func))
)
;; methods
(
("actionPerformed" :void :public (action-event)
;; It's usefull to setup a restart before
;; calling FUNC.
;;
;; It helps when slime is connected to
;; the IDEA and error happens
;; during action execution.
;;
;; Slime debugger hooks the error,
;; but as actions are invoked from
;; idea UI event dispatching thread,
;; no slime restarts are set
;; and our restart is the only
;; way to leave SLIME debugger.
(restart-case
(handler-case
(funcall (myaction.func this) action-event)
(action-is-not-applicable ()
;; NOTE: it is not guaranteed
;; that execution will be passed to this
;; handler, even if your code signals
;; ACTION-IS-NOT-APPLICABLE.
;;
;; It's so because ABCL impements
;; non local exits using java exceptions
;; (org.armedbear.lisp.Go); if somewhere
;; in the call stack below our HANDLER-CASE
;; and above the SIGNAL there is a
;;
;; catch (Throwable)
;;
;; then ABCL's Go exception will be catched.
;;
;; catch (Throwable) is in partiular
;; used by IDEA methods that accept Runnable
;; (like CommandProcessor.executeCommand,
;; Application.runWriteAction)
;;
;; But even despite that, HANDLER-CASE
;; is useful, because ACTION-IS-NOT-APPLICABLE
;; is not trapped by Slime debugger.
))
(continue ()
:report "Return from IDEA action"
nil)))
)
;; fields
(
("func" "java.lang.Object" :public))
)
(setf act-yank (myaction.new "yank" nil))
(setf (myaction.func act-yank)
#'(lambda (action-event)
(declare (ignore action-event))
(incf *yank-undo-id*)
(exec-cmd (lambda ()
(run-write-action 'yank))
"yank"
(format nil "yank-~A" *yank-undo-id*))))
(setf edit-menu (actionmanager.getaction (actionmanager.getinstance) "EditMenu"))
(actionmanager.registeraction (actionmanager.getinstance) "yank" act-yank)
(defaultactiongroup.add edit-menu act-yank)
;;(actionmanager.unregisteraction (actionmanager.getinstance) "yank")
;;(defaultactiongroup.remove edit-menu act-yank)
;; assign keyboard shortcut Ctrl-Y to our action
;; (by default Ctrl-Y is used for delete-line operation in IDEA;
;; override this by unregistering Ctrl-Y from delete-line)
(defun action-shortcut (anaction)
"The first element of AnAction.getShorcuts()"
(jref (customshortcutset.getshortcuts (anaction.getshortcutset anaction)) 0))
(defun remove-shortcut (keystroke-str)
"Unregister all the shortcuts specified by KEYSTROKE-STR
for all the actions in the active keymap.
Example \(REMOVE-SHORTCUT \"control Y\"\)"
(let* ((keymap (keymapmanager.getactivekeymap (keymapmanager.getinstance)))
(keystroke (keystroke.getkeystroke keystroke-str))
(act-ids (keymap.getactionids keymap keystroke)))
(dotimes (i (jlength act-ids))
(let ((shortcuts (keymap.getshortcuts keymap (jref act-ids i))))
(dotimes (j (jlength shortcuts))
(let ((shortcut (jref shortcuts j)))
(when (class.isinstance (class.forname "com.intellij.openapi.actionSystem.KeyboardShortcut")
shortcut)
(when (jeq (keyboardshortcut.getfirstkeystroke shortcut)
keystroke)
(keymap.removeshortcut keymap (jref act-ids i) shortcut)))))))))
;; this is to display shortcut correctly in the menu
(anaction.setshortcutset act-yank
(customshortcutset.new (keystroke.getkeystroke "control Y")))
;; this is to make it actually fired when user presses the key combination
(remove-shortcut "control Y")
(keymap.addshortcut (keymapmanager.getactivekeymap (keymapmanager.getinstance))
"yank"
(action-shortcut act-yank))
;; yank-pop is allowed only if previous command was yank or yank-pop.
;; Add a command listentener that clears *yank-region* when any
;; other command is executed, and thus makes yank-pop impossible.
(new-class
"MY.MyCommandListener" ;; class name
commandadapter. ;; super class
;; constructors
()
;; methods
(
("commandFinished" :void :public (command-event)
(unless (member (java:jobject-lisp-value (commandevent.getcommandname
command-event))
'("yank" "yank-pop")
:test #'string=)
(setf *yank-region* nil)))
)
;; fields
()
)
(setf my-cmd-listener (mycommandlistener.new))
(commandprocessor.addcommandlistener (commandprocessor.getinstance)
my-cmd-listener)
;; (actionmanager.unregisteraction (actionmanager.getinstance) "yank-pop")
;; (defaultactiongroup.remove edit-menu act-yank-pop)
(defun yank-pop ()
(let ((yank-text (get-yank-text *yank-index*)))
(replace-region yank-text *yank-region*)
(setf *yank-region* (make-region (region-start *yank-region*)
(+ (region-start *yank-region*)
(string.length yank-text)))))
(incf *yank-index*))
(setf act-yank-pop (myaction.new "yank-pop" nil))
(setf (myaction.func act-yank-pop)
#'(lambda (action-event)
(if *yank-region*
(exec-cmd (lambda ()
(run-write-action 'yank-pop))
"yank-pop"
(format nil "yank-~A" *yank-undo-id*))
(set-status "Previous command was not a yank"))))
(actionmanager.registeraction (actionmanager.getinstance) "yank-pop" act-yank-pop)
(defaultactiongroup.add edit-menu act-yank-pop)
(anaction.setshortcutset act-yank-pop
(customshortcutset.new (keystroke.getkeystroke "alt Y")))
(keymap.addshortcut (keymapmanager.getactivekeymap (keymapmanager.getinstance))
"yank-pop"
(action-shortcut act-yank-pop))
abcl-src-1.9.2/contrib/jss/README.markdown 0100644 0000000 0000000 00000011331 14343623723 016706 0 ustar 00 0000000 0000000 JSS
===
Created by Alan Ruttenberg
JSS stands for either "Java Simple Syntax" or "Java Syntax Sucks",
depending on your mood.
The dynamic dispatch of the java.lang.reflect package is used to make
it real easy, if perhaps less efficient, to write Java code since you
don't need to be bothered with imports, or with figuring out which
method to call. The only time that you need to know a class name is
when you want to call a static method, or a constructor, and in those
cases, you only need to know enough of the class name that is unique
wrt to the classes on your classpath.
Java methods look like this: #"toString". Java classes are represented
as symbols, which are resolved to the appropriate java class
name. When ambiguous, you need to be more specific. A simple example
from CL-USER:
(require :jss)
(let ((sw (new 'StringWriter)))
(#"write" sw "Hello ")
(#"write" sw "World")
(print (#"toString" sw)))
What's happened here? First, all the classes in all the jars in the
classpath have been collected. For each class a.b.C.d, we have
recorded that b.c.d, b.C.d, C.d, c.d, and d potentially refer to this
class. In your call to new, as long as the symbol can refer to only
one class, we use that class. In this case, it is
java.io.StringWriter. You could also have written
(new 'io.stringwriter)
or
(new '|io.StringWriter|)
or
(new 'java.io.StringWriter)
The call
(#"write" sw "Hello ")
uses the code in invoke.java to call the method named "write" with
the arguments sw and "Hello ". JSS figures out the right java method
to call, and calls it.
An interactive restart is available to resolve class ambiguity.
Static calls are possible as well with the SHARPSIGN-QUOTATION_MARK
macro, but the first argument *must* be a symbol to distinguish
(#"getProperties" "java.lang.System")
from
(#"getProperties" 'java.lang.System)
The first attempts to call a method on the java.lang.String object
with the contents "java.lang.System", which results in an error, while
the second invokes the static java.lang.System.getProperties() method.
If you want to do a raw java call, use #0"toString". Raw calls
return their results as Java objects, avoiding doing the usual Java
object to Lisp object conversions that ABCL does.
(with-constant-signature ((name jname raw?)*) &body body)
binds a macro which expands to a jcall, promising that the same method
will be called every time. Use this if you are making a lot of calls and
want to avoid the overhead of a the dynamic dispatch.
e.g.
(with-constant-signature ((tostring "toString"))
(time (dotimes (i 10000) (tostring "foo"))))
runs about three times faster than
(time (dotimes (i 10000) (#"toString" "foo")))
So, something like
(with-constant-signature
((tostring "toString" t)) ...)
will cause the toString to be a raw java call. See
JSS::GET-ALL-JAR-CLASSNAMES for an example.
Implementation is that the first time the function is called, the
method is looked up based on the arguments passed, and thereafter
that method is called directly. Doesn't work for static methods at
the moment (lazy)
(japropos string)
finds all class names matching STRING.
(jcmn class-name)
lists the names of all methods for the CLASS-NAME.
Java static fields may be addressed via the SHARPSIGN-QUOTATION_MARK macro as
(#"java.lang.System.out")
Java fields can by dynamically accessed with
(let ((class 'java.lang.system)
(field "out"))
#"{class}.{field}")
### Javaparser
Use #1"" to use JAVAPARSER to parse an expression. JAVAPARSER will be loaded on first use.
(#1"new ByteBuddy()
.subclass(Object.class,t)
.method(ElementMatchers.named("toString"))
.intercept(FixedValue.value("Hello World!"))
.make()
.load(getClass().getClassLoader())
.getLoaded()"
# Compatibility
The function ENSURE-COMPATIBILITY attempts to provide a compatibility
mode to existing users of JSS by importing the necessary symbols into
CL-USER.
Some notes on other compatibility issues:
*classpath-manager*
Since we are no longer using Beanshell, this is no longer present.
For obtaining the current classloader use JAVA:*CLASSLOADER*.
# API
1.0
Equivalent to Alan Ruttenberg's version included with the original
[lsw2]().
[lsw]: http://mumble.net:8080/svn/lsw/trunk/
[lsw2]: https://github.com/alanruttenberg/lsw2
3.0
The results the of having JSS package loaded from [abcl-contrib][]
[abcl-contrib]: http://abcl.org/svn/trunk/abcl/contrib/
# Colophon
<> dc:created "2005" ;
dc:author "Mark ";
dc:revised "11-JUN-2017" .
abcl-src-1.9.2/contrib/jss/classpath.lisp 0100644 0000000 0000000 00000001003 14343623723 017053 0 ustar 00 0000000 0000000 (in-package :java)
(defmethod add-to-classpath :after ((uri-or-uris t) &optional classloader)
(declare (ignore classloader))
(let ((paths (if (listp uri-or-uris)
uri-or-uris
(list uri-or-uris))))
(dolist (path paths)
(let ((absolute (namestring (truename path))))
(cond ((equal (pathname-type absolute) "jar")
(jss:jar-import absolute))
((ext:file-directory-p absolute)
(jss:classfiles-import absolute)))))))
abcl-src-1.9.2/contrib/jss/collections.lisp 0100644 0000000 0000000 00000024132 14343623723 017417 0 ustar 00 0000000 0000000 (in-package :jss)
(defun set-to-list (set)
"Convert the java.util.Set named in SET to a Lisp list."
(declare (optimize (speed 3) (safety 0)))
(with-constant-signature ((iterator "iterator" t) (hasnext "hasNext") (next "next"))
(loop with iterator = (iterator set)
while (hasNext iterator)
for item = (next iterator)
collect item)))
(defun jlist-to-list (list)
"Convert a LIST implementing java.util.List to a Lisp list."
(declare (optimize (speed 3) (safety 0)))
(loop :for i :from 0 :below (jcall "size" list)
:collecting (jcall "get" list i)))
(defun jarray-to-list (jarray)
"Convert the Java array named by JARRARY into a Lisp list."
(declare (optimize (speed 3) (safety 0)))
(loop :for i :from 0 :below (jarray-length jarray)
:collecting (jarray-ref jarray i)))
;;; Deprecated
;;;
;;; XXX unclear what sort of list this would actually work on, as it
;;; certainly doesn't seem to be any of the Java collection types
;;; (what implements getNext())?
(defun list-to-list (list)
(declare (optimize (speed 3) (safety 0)))
(with-constant-signature ((isEmpty "isEmpty") (getfirst "getFirst")
(getNext "getNext"))
(loop until (isEmpty list)
collect (getFirst list)
do (setq list (getNext list)))))
;; Contribution of Luke Hope. (Thanks!)
(defun iterable-to-list (iterable)
"Return the items contained the java.lang.Iterable ITERABLE as a list."
(declare (optimize (speed 3) (safety 0)))
(let ((it (#"iterator" iterable)))
(with-constant-signature ((has-next "hasNext")
(next "next"))
(loop :while (has-next it)
:collect (next it)))))
(defun vector-to-list (vector)
"Return the elements of java.lang.Vector VECTOR as a list."
(declare (optimize (speed 3) (safety 0)))
(with-constant-signature ((has-more "hasMoreElements")
(next "nextElement"))
(let ((elements (#"elements" vector)))
(loop :while (has-more elements)
:collect (next elements)))))
(defun hashmap-to-hashtable (hashmap &rest rest &key (keyfun #'identity) (valfun #'identity) (invert? nil)
table
&allow-other-keys )
"Converts the a HASHMAP reference to a java.util.HashMap object to a Lisp hashtable.
The REST paramter specifies arguments to the underlying MAKE-HASH-TABLE call.
KEYFUN and VALFUN specifies functions to be run on the keys and values
of the HASHMAP right before they are placed in the hashtable.
If INVERT? is non-nil than reverse the keys and values in the resulting hashtable."
(let ((keyset (#"keySet" hashmap))
(table (or table (apply 'make-hash-table
(loop for (key value) on rest by #'cddr
unless (member key '(:invert? :valfun :keyfun :table))
collect key and collect value)))))
(with-constant-signature ((iterator "iterator" t) (hasnext "hasNext") (next "next"))
(loop with iterator = (iterator keyset)
while (hasNext iterator)
for item = (next iterator)
do (if invert?
(setf (gethash (funcall valfun (#"get" hashmap item)) table) (funcall keyfun item))
(setf (gethash (funcall keyfun item) table) (funcall valfun (#"get" hashmap item)))))
table)))
;; ****************************************************************
;; But needing to remember is annoying
;; Here's a summary I gleaned:
;; java.util.Dictionary -> #"elements" yields java.util.Collections$3
;; java.util.AbstractCollection -> #"iterator" yields java.util.Iterator?
;; org.apache.felix.framework.util.CompoundEnumeration -> implements java.util.Enumeration
;; java.util.Collections -> doc says #"iterator" yields java.util.Iterator
;; java.util.Collections$1) -> implements java.util.Iterator
;; java.util.Collections$2) -> implements java.util.Spliterator (#"iterator" (#"stream" 'StreamSupport )) -> java.util.Iterator
;; java.util.Collections$3) -> implements java.util.Enumeration
;; java.util.Iterator
;; ("next" "hasNext")
;; java.util.Enumeration)
;; ("nextElement" "hasMoreElements")
;; TODO: maybe do it even more MAPC-style and accept multiple sequences too?
(defun jmap (function thing)
"Call FUNCTION for every element in the THING. Returns NIL.
THING may be a wide range of Java collection types, their common iterators or
a Java array.
In case the THING is a map-like object, FUNCTION will be called with two
arguments, key and value."
(flet ((iterator-run (iterator)
(with-constant-signature ((has-next "hasNext")
(next "next"))
(loop :while (has-next iterator)
:do (funcall function (next iterator)))))
(enumeration-run (enumeration)
(with-constant-signature ((has-next "hasMoreElements")
(next "nextElement"))
(loop :while (has-next enumeration)
:do (funcall function (next enumeration)))))
(map-run (map)
(with-constant-signature ((has-next "hasMoreElements")
(next "nextElement"))
(let ((keyiterator (#"iterator" (#"keyset" map))))
(loop :while (has-next keyiterator)
:for key = (next keyiterator)
:do (funcall function key (#"get" map key)))))))
(let ((isinstance
(load-time-value (jmethod "java.lang.Class" "isInstance" "java.lang.Object"))))
(cond
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.AbstractCollection"))) thing)
(iterator-run (#"iterator" thing)))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Iterator"))) thing)
(iterator-run thing))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.lang.Iterable"))) thing)
(iterator-run (#"iterator" thing)))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Enumeration"))) thing)
(enumeration-run thing))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.AbstractMap"))) thing)
(map-run thing))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Collections"))) thing)
(iterator-run (#"iterator" thing)))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Spliterator"))) thing)
(iterator-run (#"iterator" (#"stream" 'StreamSupport thing))))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Dictionary"))) thing)
(iterator-run (#"elements" thing)))
(t
(let ((jarray (ignore-errors
(or (and (jclass-array-p (jclass-of thing))
thing)
(#"toArray" thing)))))
(if jarray
(loop :for i :from 0 :below (jarray-length jarray)
:do (funcall function (jarray-ref jarray i)))
(error "yet another iteration type - fix it: ~a" (jclass-name (jobject-class thing)))))))))
NIL)
(defun j2list (thing)
"Attempt to construct a Lisp list out of a Java THING.
THING may be a wide range of Java collection types, their common
iterators or a Java array."
(declare (optimize (speed 3) (safety 0)))
(flet ((iterator-collect (iterator)
(with-constant-signature ((has-next "hasNext")
(next "next"))
(loop :while (has-next iterator)
:collect (next iterator))))
(enumeration-collect (enumeration)
(with-constant-signature ((has-next "hasMoreElements")
(next "nextElement"))
(loop :while (has-next enumeration)
:collect (next enumeration))))
(map-collect (map)
(with-constant-signature ((has-next "hasMoreElements")
(next "nextElement"))
(let ((keyiterator (#"iterator" (#"keyset" map))))
(loop :while (has-next keyiterator)
:for key = (next keyiterator)
:collect (cons key (#"get" map key)))))))
(let ((isinstance
(load-time-value (jmethod "java.lang.Class" "isInstance" "java.lang.Object"))))
(cond
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.AbstractCollection"))) thing)
(iterator-collect (#"iterator" thing)))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Iterator"))) thing)
(iterator-collect thing))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.lang.Iterable"))) thing)
(iterator-collect (#"iterator" thing)))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Enumeration"))) thing)
(enumeration-collect thing))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.AbstractMap"))) thing)
(map-collect thing))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Collections"))) thing)
(iterator-collect (#"iterator" thing)))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Spliterator"))) thing)
(iterator-collect (#"iterator" (#"stream" 'StreamSupport thing))))
((jcall isinstance (load-time-value (ignore-errors (jclass "java.util.Dictionary"))) thing)
(iterator-collect (#"elements" thing)))
(t
(let ((jarray (ignore-errors
(or (and (jclass-array-p (jclass-of thing))
thing)
(#"toArray" thing)))))
(if jarray
(loop :for i :from 0 :below (jarray-length jarray)
:collect (jarray-ref jarray i))
(error "yet another iteration type - fix it: ~a" (jclass-name (jobject-class thing))))))))))
(defun to-hashset (list)
"Convert LIST to the java.util.HashSet contract"
(let ((set (new 'java.util.hashset)))
(loop for l in list do (#"add" set l))
set))
abcl-src-1.9.2/contrib/jss/compat.lisp 0100644 0000000 0000000 00000001630 14343623723 016362 0 ustar 00 0000000 0000000 (in-package :jss)
(defparameter *cl-user-compatibility* nil
"Whether backwards compatibility with JSS's use of CL-USER has been enabled.")
(defun ensure-compatibility ()
"Ensure backwards compatibility with JSS's use of CL-USER."
(require 'abcl-asdf)
(loop :for symbol :in '("add-directory-jars-to-class-path"
"need-to-add-directory-jar?")
:do
(unintern (intern symbol "CL-USER") :cl-user)
:do
(import (intern symbol "ABCL-ASDF") :cl-user))
(let ((dont-export '(*cl-user-compatibility* add-to-classpath)))
(loop :for symbol :being :each :external-symbol :in :jss
:when (not (find symbol dont-export))
:do
(unintern symbol :cl-user)
:and :do
(import symbol :cl-user)))
(setf *cl-user-compatibility* t))
;;; Because we're the last file in the ASDF system at the moment
(provide 'jss)
abcl-src-1.9.2/contrib/jss/invoke.lisp 0100644 0000000 0000000 00000077052 14343623723 016405 0 ustar 00 0000000 0000000 ;; Copyright (C) 2005 Alan Ruttenberg
;; Copyright (C) 2011-2 Mark Evenson
;;
;; Since JSS 1.0 was largely derivative of the Jscheme System, the
;; current system is licensed under the same terms, namely:
;; This software is provided 'as-is', without any express or
;; implied warranty.
;; In no event will the author be held liable for any damages
;; arising from the use of this software.
;; Permission is granted to anyone to use this software for any
;; purpose, including commercial applications, and to alter it
;; and redistribute it freely, subject to the following
;; restrictions:
;; 1. The origin of this software must not be misrepresented; you
;; must not claim that you wrote the original software. If you
;; use this software in a product, an acknowledgment in the
;; product documentation would be appreciated but is not
;; required.
;; 2. Altered source versions must be plainly marked as such, and
;; must not be misrepresented as being the original software.
;; 3. This notice may not be removed or altered from any source
;; distribution.
;; The dynamic dispatch of the java.lang.reflect package is used to
;; make it real easy, if perhaps less efficient, to write Java code
;; since you don't need to be bothered with imports, or with figuring
;; out which method to call. The only time that you need to know a
;; class name is when you want to call a static method, or a
;; constructor, and in those cases, you only need to know enough of
;; the class name that is unique wrt to the classes on your classpath.
;;
;; Java methods look like this: #"toString". Java classes are
;; represented as symbols, which are resolved to the appropriate java
;; class name. When ambiguous, you need to be more specific. A simple example:
;; (let ((sw (new 'StringWriter)))
;; (#"write" sw "Hello ")
;; (#"write" sw "World")
;; (print (#"toString" sw)))
;; What's happened here? First, all the classes in all the jars in the
;; classpath have been collected. For each class a.b.C.d, we have
;; recorded that b.c.d, b.C.d, C.d, c.d, and d potentially refer to
;; this class. In your call to new, as long as the symbol can refer to
;; only one class, we use that class. In this case, it is
;; java.io.StringWriter. You could also have written (new
;; 'io.stringwriter), (new '|io.StringWriter|), (new
;; 'java.io.StringWriter)...
;; the call (#"write" sw "Hello "), uses the code in invoke.java to
;; call the method named "write" with the arguments sw and "Hello ".
;; JSS figures out the right java method to call, and calls it.
;; If you want to do a raw java call, use #0"toString". Raw calls
;; return their results as Java objects, avoiding doing the usual Java
;; object to Lisp object conversions that ABCL does.
;; (with-constant-signature ((name jname raw?)*) &body body)
;; binds a macro which expands to a jcall, promising that the same method
;; will be called every time. Use this if you are making a lot of calls and
;; want to avoid the overhead of a the dynamic dispatch.
;; e.g. (with-constant-signature ((tostring "toString"))
;; (time (dotimes (i 10000) (tostring "foo"))))
;; runs about 3x faster than (time (dotimes (i 10000) (#"toString" "foo")))
;;
;; (with-constant-signature ((tostring "toString" t)) ...) will cause the
;; toString to be a raw java call. see get-all-jar-classnames below for an example.
;;
;; Implementation is that the first time the function is called, the
;; method is looked up based on the arguments passed, and thereafter
;; that method is called directly. Doesn't work for static methods at
;; the moment (lazy)
;;
;; (japropos string) finds all class names matching string
;; (jcmn class-name) lists the names of all methods for the class
;;
;; TODO
;; - Make with-constant-signature work for static methods too.
;; - #2"toString" to work like function scoped (with-constant-signature ((tostring "toString")) ...)
;; - #3"toString" to work like runtime scoped (with-constant-signature ((tostring "toString")) ...)
;; (both probably need compiler support to work)
;; - Maybe get rid of second " in reader macro. #"toString looks nicer, but might
;; confuse lisp mode.
;; - write jmap, analogous to map, but can take java collections, java arrays etc.
;; In progress with jss-3.5.0's JSS:MAP
;; - write loop clauses for java collections.
;; - Register classes in .class files below classpath directories (when :wild-inferiors works)
;; - Make documentation like Edi Weitz
;;
;; Thanks: Peter Graves, Jscheme developers, Mike Travers for skij,
;; Andras Simon for jfli-abcl which bootstrapped me and taught me how to do
;; get-all-jar-classnames
;;
;; changelog
;; Sat January 28, 2006, alanr:
;; Change imports strategy. Only index by last part of class name,
;; case insensitive. Make the lookup-class-name logic be a bit more
;; complicated. This substantially reduces the time it takes to do the
;; auto imports and since class name lookup is relatively infrequent,
;; and in any case cached, this doesn't effect run time speed. (did
;; try caching, but didn't pay - more time was spent reading and
;; populating large hash table)
;;
;; Split class path by ";" in addition to ":" for windows.
;;
;; Tested on windows, linux.
;; 2011-05-21 Mark Evenson
;; "ported" to native ABCL without needing the jscheme.jar or bsh-2.0b4.jar
(in-package :jss)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *do-auto-imports* t
"Whether to automatically introspect all Java classes on the classpath when JSS is loaded.")
(defvar *muffle-warnings* t
"Attempt to make JSS less chatting about how things are going.")
(defvar *imports-resolved-classes* (make-hash-table :test 'equalp)
"Hashtable of all resolved imports by the current process."))
(defun find-java-class (name)
"Returns the java.lang.Class representation of NAME.
NAME can either string or a symbol according to the usual JSS conventions."
(jclass (maybe-resolve-class-against-imports name)))
(defmacro invoke-add-imports (&rest imports)
"Push these imports onto the search path. If multiple, earlier in list take precedence"
`(eval-when (:compile-toplevel :load-toplevel :execute)
(clrhash *imports-resolved-classes*)
(dolist (i (reverse ',imports))
(setq *imports-resolved-classes* (delete i *imports-resolved-classes* :test 'equal))
)))
(defun clear-invoke-imports ()
(clrhash *imports-resolved-classes*))
(defun maybe-resolve-class-against-imports (classname)
(or (gethash (string classname) *imports-resolved-classes*)
(let ((found (lookup-class-name classname)))
(if found
(progn
(setf (gethash classname *imports-resolved-classes*) found)
found)
(string classname)))))
(defvar *class-name-to-full-case-insensitive* (make-hash-table :test 'equalp))
;; This is the function that calls invoke to call your java
;; method. The first argument is the method name or 'new. The second
;; is the object you are calling it on, followed by the rest of the
;; arguments. If the "object" is a symbol, then that symbol is assumed
;; to be a java class, and a static method on the class is called,
;; otherwise a regular method is called.
(defun invoke (method object &rest args)
(invoke-restargs method object args))
(defun invoke-restargs (method object args &optional (raw? nil))
(let* ((object-as-class-name
(if (symbolp object) (maybe-resolve-class-against-imports object)))
(object-as-class
(if object-as-class-name (find-java-class object-as-class-name))))
(if (eq method 'new)
(apply #'jnew (or object-as-class-name object) args)
(if raw?
(if (symbolp object)
(apply #'jstatic-raw method object-as-class args)
(apply #'jcall-raw method object args))
(if (symbolp object)
(apply #'jstatic method object-as-class args)
(apply #'jcall method object args))))))
(defconstant +set-accessible+
(jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean"))
(defun invoke-find-method (method object args)
(let ((result
(if (symbolp object)
;;; static method
(apply #'jmethod (lookup-class-name object)
method (mapcar #'jobject-class args))
;;; instance method
(apply #'jresolve-method
method object args))))
(jcall +set-accessible+ result +true+)
result))
;; This is the reader macro for java methods. it translates the method
;; into a lambda form that calls invoke. Which is nice because you
;; can, e.g. do this: (mapcar #"toString" list-of-java-objects). The reader
;; macro takes one arg. If 0, then jstatic-raw is called, so that abcl doesn't
;; automagically convert the returned java object into a lisp object. So
;; #0"toString" returns a java.lang.String object, where as #"toString" returns
;; a regular Lisp string as ABCL converts the Java string to a Lisp string.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun read-invoke (stream char arg)
(if (eql arg 1)
(progn (asdf:make 'javaparser)
(read-sharp-java-expression stream))
(progn
(unread-char char stream)
(let ((name (read stream)))
(if (or (find #\. name) (find #\{ name))
(jss-transform-to-field name arg)
(let ((object-var (gensym))
(args-var (gensym)))
`(lambda (,object-var &rest ,args-var)
(invoke-restargs ,name ,object-var ,args-var ,(eql arg 0)))))))))
(set-dispatch-macro-character #\# #\" 'read-invoke))
(defmacro with-constant-signature (fname-jname-pairs &body body)
"Expand all references to FNAME-JNAME-PAIRS in BODY into static function calls promising that the same function bound in the FNAME-JNAME-PAIRS will be invoked with the same argument signature.
FNAME-JNAME-PAIRS is a list of (symbol function &optional raw)
elements where symbol will be the symbol bound to the method named by
the string function. If the optional parameter raw is non-nil, the
result will be the raw JVM object, uncoerced by the usual conventions.
Use this macro if you are making a lot of calls and
want to avoid the overhead of the dynamic dispatch."
(if (null fname-jname-pairs)
`(progn ,@body)
(destructuring-bind ((fname jname &optional raw) &rest ignore) fname-jname-pairs
(declare (ignore ignore))
(let ((varname (gensym)))
`(let ((,varname nil))
(macrolet ((,fname (&rest args)
`(if ,',varname
(if ,',raw
(jcall-raw ,',varname ,@args)
(jcall ,',varname ,@args))
(progn
(setq ,',varname (invoke-find-method ,',jname ,(car args) (list ,@(rest args))))
(if ,',raw
(jcall-raw ,',varname ,@args)
(jcall ,',varname ,@args))))))
(with-constant-signature ,(cdr fname-jname-pairs)
,@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 *muffle-warnings*)
(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| ".*?([^.]*)$"))
;; reason: bootstrap - the class name would have to be looked up...
(last-name-pattern (load-time-value (jstatic (jmethod "java.util.regex.Pattern" "compile"
(jclass "java.lang.String"))
(jclass "java.util.regex.Pattern")
".*?([^.]*)$")))
(last-name
(let ((matcher (#0"matcher" last-name-pattern name)))
(#"matches" matcher)
(#"group" matcher 1))))
(let* ((bucket (gethash last-name *class-name-to-full-case-insensitive*))
(bucket-length (length bucket)))
(or (find name bucket :test 'equalp)
(flet ((matches-end (end full test)
(= (+ (or (search end full :from-end t :test test) -10)
(length end))
(length full)))
(ambiguous (choices)
(if return-ambiguous
(return-from lookup-class-name choices)
(error "Ambiguous class name: ~a can be ~{~a~^, ~}" name choices))))
(if (zerop bucket-length)
(progn (unless muffle-warning (warn "can't find class named ~a" name)) nil)
(let ((matches (loop for el in bucket when (matches-end name el 'char=) collect el)))
(if (= (length matches) 1)
(car matches)
(if (= (length matches) 0)
(let ((matches (loop for el in bucket when (matches-end name el 'char-equal) collect el)))
(if (= (length matches) 1)
(car matches)
(if (= (length matches) 0)
(progn (unless muffle-warning (warn "can't find class named ~a" name)) nil)
(ambiguous matches))))
(ambiguous matches))))))))))
#+(or)
(defun get-all-jar-classnames (jar-file-name)
(let* ((jar (jnew (jconstructor "java.util.jar.JarFile" (jclass "java.lang.String")) (namestring (truename jar-file-name))))
(entries (#"entries" jar)))
(with-constant-signature ((matcher "matcher" t) (substring "substring")
(jreplace "replace" t) (jlength "length")
(matches "matches") (getname "getName" t)
(next "nextElement" t) (hasmore "hasMoreElements")
(group "group"))
(loop while (hasmore entries)
for name = (getname (next entries))
with class-pattern = (jstatic "compile" "java.util.regex.Pattern" ".*\\.class$")
with name-pattern = (jstatic "compile" "java.util.regex.Pattern" ".*?([^.]*)$")
when (matches (matcher class-pattern name))
collect
(let* ((fullname (substring (jreplace name #\/ #\.) 0 (- (jlength name) 6)))
(matcher (matcher name-pattern fullname))
(name (progn (matches matcher) (group matcher 1))))
(cons name fullname))
))))
#|
Under openjdk11 this is around 10x slower than
(list (time (jss::get-all-jar-classnames "/Users/evenson/work/abcl-jdk11/dist/abcl.jar"))
(time (jss::%get-all-jar-classnames "/Users/evenson/work/abcl-jdk11/dist/abcl.jar")))
0.034 seconds real time
2268 cons cells
0.12 seconds real time
209164 cons cells
|#
(defun get-all-jar-classnames (jar-pathname-or-string)
(let* ((jar
(if (ext:pathname-jar-p jar-pathname-or-string)
jar-pathname-or-string
;; better be a string
(ext:as-jar-pathname-archive jar-pathname-or-string)))
(entries
(directory (merge-pathnames "**/*" jar))))
(loop :for entry :in entries
:for name = (pathname-name entry)
:for type = (pathname-type entry)
:when (equal type "class")
:collect
(cons
name
;;; Fully qualified classname be like 'org.armedbear.lisp.ArgumentListProcessor$ArgumentMatcher'
(format nil "~{~a.~}~a" (rest (pathname-directory entry)) name)))))
(defun jar-import (file)
"Import all the Java classes contained in the pathname FILE into the JSS dynamic lookup cache."
(when (probe-file file)
(loop for (name . full-class-name) in (get-all-jar-classnames file)
do
(pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*)
:test 'equal))))
(defun new (class-name &rest args)
"Invoke the Java constructor for CLASS-NAME with ARGS.
CLASS-NAME may either be a symbol or a string according to the usual JSS conventions."
(invoke-restargs 'new class-name args))
(defvar *running-in-osgi* (ignore-errors (jclass "org.osgi.framework.BundleActivator")))
(define-condition no-such-java-field (error)
((field-name
:initarg :field-name
:reader field-name
)
(object
:initarg :object
:reader object
))
(:report (lambda (c stream)
(format stream "Unable to find a FIELD named ~a for ~a"
(field-name c) (object c))))
)
(defun get-java-field (object field &optional (try-harder *running-in-osgi*))
"Get the value of the FIELD contained in OBJECT.
If OBJECT is a symbol it names a dot qualified static FIELD."
(if try-harder
(let* ((class (if (symbolp object)
(setq object (find-java-class object))
(if (equal "java.lang.Class" (jclass-name (jobject-class object)))
object
(jobject-class object))))
(jfield (if (java-object-p field)
field
(or (find-declared-field field class)
(error 'no-such-java-field :field-name field :object object)))))
(#"setAccessible" jfield +true+)
(values (#"get" jfield object) jfield))
(if (symbolp object)
(let ((class (find-java-class object)))
(jfield class field))
(jfield field object))))
(defun find-declared-field (field class)
"Return a FIELD object corresponding to the definition of FIELD
\(a string\) visible at CLASS. *Not* restricted to public classes, and checks
all superclasses of CLASS.
Returns NIL if no field object is found."
(loop while class
for field-obj = (get-declared-field class field)
if field-obj
do (return-from find-declared-field field-obj)
else
do (setf class (jclass-superclass class)))
nil)
(defun get-declared-field (class fieldname)
(find fieldname (#"getDeclaredFields" class)
:key 'jfield-name :test 'equal))
;; TODO use #"getSuperclass" and #"getInterfaces" to see whether there
;; are fields in superclasses that we might set
(defun set-java-field (object field value &optional (try-harder *running-in-osgi*))
"Set the FIELD of OBJECT to VALUE.
If OBJECT is a symbol, it names a dot qualified Java class to look for
a static FIELD. If OBJECT is an instance of java:java-object, the
associated is used to look up the static FIELD."
(if try-harder
(let* ((class (if (symbolp object)
(setq object (find-java-class object))
(if (equal "java.lang.Class" (jclass-name (jobject-class object)) )
object
(jobject-class object))))
(jfield (if (java-object-p field)
field
(or (find-declared-field field class)
(error 'no-such-java-field :field-name field :object object)))))
(#"setAccessible" jfield +true+)
(values (#"set" jfield object value) jfield))
(if (symbolp object)
(let ((class (find-java-class object)))
(setf (jfield (#"getName" class) field) value))
(if (typep object 'java-object)
(setf (jfield (jclass-of object) field) value)
(setf (jfield object field) value)))))
(defun (setf get-java-field) (value object field &optional (try-harder *running-in-osgi*))
(set-java-field object field value try-harder))
(defconstant +for-name+
(jmethod "java.lang.Class" "forName" "java.lang.String" "boolean" "java.lang.ClassLoader"))
(defun find-java-class (name)
(or (jstatic +for-name+ "java.lang.Class"
(maybe-resolve-class-against-imports name) +true+ java::*classloader*)
(ignore-errors (jclass (maybe-resolve-class-against-imports name)))))
(defmethod print-object ((obj (jclass "java.lang.Class")) stream)
(print-unreadable-object (obj stream :identity nil)
(format stream "java class ~a" (jclass-name obj))))
(defmethod print-object ((obj (jclass "java.lang.reflect.Method")) stream)
(print-unreadable-object (obj stream :identity nil)
(format stream "method ~a" (#"toString" obj))))
(defun do-auto-imports ()
(if (sys::system-artifacts-are-jars-p)
(do-auto-imports-from-jars)
(progn
;;; First, import all the classes available from the module system
(do-auto-imports-from-modules)
;;; Then, introspect any jars that appear on the classpath
(loop :for entry :in (second (multiple-value-list (sys::java.class.path)))
:doing (let ((p (pathname entry)))
(when (string-equal (pathname-type p) "jar")
(jar-import p)))))))
(defun do-auto-imports-from-modules ()
(loop :for (name . full-class-name) :in (all-class-names-from-modules)
:doing
(pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*)
:test 'equal)))
(defun all-class-names-from-modules ()
(let ((class-pattern (jstatic "compile" "java.util.regex.Pattern" ".*\\.class$"))
(name-pattern (jstatic "compile" "java.util.regex.Pattern" ".*?([^.]*)$")))
(loop
:for module :across (chain (jstatic "boot" "java.lang.ModuleLayer")
"configuration" "modules" "stream" "toArray")
:appending
(loop
:for class-as-path :across (chain module "reference" "open" "list" "toArray")
:when
(jcall "matches" (jcall "matcher" class-pattern class-as-path))
:collect
(let* ((full-name (jcall "substring" (jcall "replace" class-as-path #\/ #\.)
0
(- (jcall "length" class-as-path) (jcall "length" ".class"))))
(matcher (jcall "matcher" name-pattern full-name))
(name (progn
(jcall "matches" matcher)
(jcall "group" matcher 1))))
(cons name full-name))))))
(defun do-auto-imports-from-jars ()
(labels ((expand-paths (cp)
(loop :for s :in cp
:appending (loop :for entry
:in (let ((p (pathname s)))
(if (wild-pathname-p p)
(directory p)
(list p)))
:collecting entry)))
(import-classpath (cp)
(mapcar
(lambda (p)
(when *load-verbose*
(format t ";; Importing ~A~%" p))
(cond
((file-directory-p p) )
((equal (pathname-type p) "jar")
(jar-import (merge-pathnames p
(format nil "~a/" (jstatic "getProperty" "java.lang.System" "user.dir")))))))
cp))
(split-classpath (cp)
(coerce
(jcall "split" cp
(string (jfield (jclass "java.io.File") "pathSeparatorChar")))
'cons))
(do-imports (cp)
(import-classpath (expand-paths (split-classpath cp)))))
(let ((mx-bean (jstatic "getRuntimeMXBean"
'|java.lang.management.ManagementFactory|)))
(do-imports (jcall "getClassPath" mx-bean))
(do-imports (jcall "getBootClassPath" mx-bean)))))
(eval-when (:load-toplevel :execute)
(when *do-auto-imports*
(do-auto-imports)))
(defun japropos (string)
"Output the names of all Java class names loaded in the current process which match STRING.."
(setq string (string string))
(let ((matches nil))
(maphash (lambda(key value)
(declare (ignore key))
(loop for class in value
when (search string class :test 'string-equal)
do (pushnew (list class "Java Class") matches :test 'equal)))
*class-name-to-full-case-insensitive*)
(loop for (match type) in (sort matches 'string-lessp :key 'car)
do (format t "~a: ~a~%" match type))
))
(defun jclass-method-names (class &optional full)
(if (java-object-p class)
(if (equal (jclass-name (jobject-class class)) "java.lang.Class")
(setq class (jclass-name class))
(setq class (jclass-name (jobject-class class)))))
(union
(remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getMethods" (find-java-class class))) :test 'equal)
(ignore-errors (remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getConstructors" (find-java-class class))) :test 'equal))))
(defun java-class-method-names (class &optional stream)
"Return a list of the public methods encapsulated by the JVM CLASS.
If STREAM non-nil, output a verbose description to the named output stream.
CLASS may either be a string naming a fully qualified JVM class in dot
notation, or a symbol resolved against all class entries in the
current classpath."
(if stream
(dolist (method (jclass-method-names class t))
(format stream "~a~%" method))
(jclass-method-names class)))
(setf (symbol-function 'jcmn) #'java-class-method-names)
(defun path-to-class (classname)
(let ((full (lookup-class-name classname)))
(#"toString"
(#"getResource"
(find-java-class full)
(concatenate 'string "/" (substitute #\/ #\. full) ".class")))))
;; http://www.javaworld.com/javaworld/javaqa/2003-07/02-qa-0725-classsrc2.html
(defun all-loaded-classes ()
(let ((classes-field
(find "classes" (#"getDeclaredFields" (jclass "java.lang.ClassLoader"))
:key #"getName" :test 'equal)))
(#"setAccessible" classes-field +true+)
(loop for classloader in (mapcar #'first (dump-classpath))
append
(loop with classesv = (#"get" classes-field classloader)
for i below (#"size" classesv)
collect (#"getName" (#"elementAt" classesv i)))
append
(loop with classesv = (#"get" classes-field (#"getParent" classloader))
for i below (#"size" classesv)
collect (#"getName" (#"elementAt" classesv i))))))
(defun get-dynamic-class-path ()
(rest
(find-if (lambda (loader)
(string= "org.armedbear.lisp.JavaClassLoader"
(jclass-name (jobject-class loader))))
(dump-classpath)
:key #'car)))
(defun java-gc ()
(#"gc" (#"getRuntime" 'java.lang.runtime))
(#"runFinalization" (#"getRuntime" 'java.lang.runtime))
(#"gc" (#"getRuntime" 'java.lang.runtime))
(java-room))
(defun java-room ()
(let ((rt (#"getRuntime" 'java.lang.runtime)))
(values (- (#"totalMemory" rt) (#"freeMemory" rt))
(#"totalMemory" rt)
(#"freeMemory" rt)
(list :used :total :free))))
(defun verbose-gc (&optional (new-value nil new-value-supplied))
(if new-value-supplied
(progn (#"setVerbose" (#"getMemoryMXBean" 'java.lang.management.ManagementFactory) new-value) new-value)
(#"isVerbose" (#"getMemoryMXBean" 'java.lang.management.ManagementFactory))))
(defun all-jars-below (directory)
(loop with q = (system:list-directory directory)
while q for top = (pop q)
if (null (pathname-name top)) do (setq q (append q (all-jars-below top)))
if (equal (pathname-type top) "jar") collect top))
(defun all-classfiles-below (directory)
(loop with q = (system:list-directory directory)
while q for top = (pop q)
if (null (pathname-name top)) do (setq q (append q (all-classfiles-below top )))
if (equal (pathname-type top) "class")
collect top
))
(defun all-classes-below-directory (directory)
(loop for file in (all-classfiles-below directory) collect
(format nil "~{~a.~}~a"
(subseq (pathname-directory file) (length (pathname-directory directory)))
(pathname-name file))
))
(defun classfiles-import (directory)
"Load all Java classes recursively contained under DIRECTORY in the current process."
(setq directory (truename directory))
(loop for full-class-name in (all-classes-below-directory directory)
for name = (#"replaceAll" full-class-name "^.*\\." "")
do
(pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*)
:test 'equal)))
(defun jclass-all-interfaces (class)
"Return a list of interfaces the class implements"
(unless (java-object-p class)
(setq class (find-java-class class)))
(loop for aclass = class then (#"getSuperclass" aclass)
while aclass
append (coerce (#"getInterfaces" aclass) 'list)))
(defun safely (f name)
(let ((fname (gensym)))
(compile fname
`(lambda(&rest args)
(with-simple-restart (top-level
"Return from lisp method implementation for ~a." ,name)
(apply ,f args))))
(symbol-function fname)))
(defun jdelegating-interface-implementation (interface dispatch-to &rest method-names-and-defs)
"Creates and returns an implementation of a Java interface with
methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS.
INTERFACE is an interface
DISPATCH-TO is an existing Java object
METHOD-NAMES-AND-DEFS is an alternating list of method names
(strings) and method definitions (closures).
For missing methods, a dummy implementation is provided that
calls the method on DISPATCH-TO."
(let ((implemented-methods
(loop for m in method-names-and-defs
for i from 0
if (evenp i)
do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m
else
do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m))))
(let ((safe-method-names-and-defs
(loop for (name function) on method-names-and-defs by #'cddr
collect name collect (safely function name))))
(loop for method across
(jclass-methods interface :declared nil :public t)
for method-name = (jmethod-name method)
when (not (member method-name implemented-methods :test #'string=))
do
(let* ((def `(lambda
(&rest args)
(invoke-restargs ,(jmethod-name method) ,dispatch-to args t)
)))
(push (coerce def 'function) safe-method-names-and-defs)
(push method-name safe-method-names-and-defs)))
(apply #'java::%jnew-proxy interface safe-method-names-and-defs))))
abcl-src-1.9.2/contrib/jss/javaparser-tests.asd 0100644 0000000 0000000 00000000570 14343623723 020177 0 ustar 00 0000000 0000000 (in-package :asdf)
(defsystem javaparser-tests
:defsystem-depends-on (prove-asdf)
:depends-on (javaparser
prove)
:components ((:module tests
:pathname "t"
:components ((:test-file "javaparser"))))
:perform (asdf:test-op (op c)
(uiop:symbol-call :prove-asdf 'run-test-system c)))
abcl-src-1.9.2/contrib/jss/javaparser.asd 0100644 0000000 0000000 00000001011 14343623723 017026 0 ustar 00 0000000 0000000 (defsystem javaparser
:description "https://github.com/javaparser/javaparser"
:defsystem-depends-on (abcl-asdf)
:components
((:module jar
:components ((:mvn "com.github.javaparser/javaparser-core/3.24.2")))
(:module source :depends-on (jar)
:pathname ""
:serial t
:components ((:file "javaparser")
(:file "read-sharp-quote-expression"))))
:perform (asdf:test-op (op c)
(asdf:test-system :javaparser-tests)))
abcl-src-1.9.2/contrib/jss/javaparser.lisp 0100644 0000000 0000000 00000006047 14343623723 017244 0 ustar 00 0000000 0000000 (in-package :jss)
(defvar *class-to-last-component* (make-hash-table :test 'equalp))
(defclass javaparser () ((parser :accessor parser)))
(defmethod initialize-instance ((p javaparser)&key)
(call-next-method)
(setf (parser p) (new 'javaparser)))
(defmacro def-java-read (ast-class class fields &body body)
(let ((jclass (find-java-class (concatenate 'string "com.github.javaparser.ast.expr." (string ast-class)))))
`(progn
(setf (gethash ,jclass *class-to-last-component*) ',ast-class)
(defmethod ,ast-class ((obj ,class) node &optional
,@(loop for field in fields
collect `(,(intern (string-upcase field)) (get-java-field node ,field t))))
,@body))))
(defvar *object-for-this* (new 'lang.object))
(defmethod get-optional ((r javaparser) node)
(if (equal node (load-time-value (#"empty" 'java.util.Optional ))) nil (#"get" node)))
(defmethod process-node ((r javaparser) node)
(when (jinstance-of-p node "java.util.Optional")
(setq node (get-optional r node)))
(when (null node)
(return-from process-node nil))
(if (java-object-p node)
(funcall (gethash (jobject-class node) *class-to-last-component*) r node)
node))
(defmethod read-java-expression ((r javaparser) expression)
`(let ((this *object-for-this*))
(declare (ignorable this))
,(process-node r (#"getResult" (#"parseExpression" (parser r) expression)))))
(def-java-read LongLiteralExpr javaparser ()
(read-from-string (#"replaceFirst" (#"getValue" node) "L" "")))
(def-java-read BooleanLiteralExpr javaparser ()
(if (equal (#"getValue" node) "true") t nil))
(def-java-read IntegerLiteralExpr javaparser nil
(parse-integer (#"getValue" node)))
(def-java-read DoubleLiteralExpr javaparser nil
(let ((raw (#"getValue" node)))
(setq raw (#"replaceAll" raw "_" ""))
(if (#"matches" raw ".*[dD]$")
(read-from-string (#"replaceFirst" (subseq raw 0 (1- (length raw))) "e" "d"))
(if (#"matches" raw ".*[fF]$")
(read-from-string (subseq raw 0 (1- (length raw))))
(read-from-string raw)))))
(def-java-read CharLiteralExpr javaparser nil
(#"getValue" node))
(def-java-read StringLiteralExpr javaparser nil
(#"getValue" node))
(def-java-read NullLiteralExpr javaparser nil
+null+)
(def-java-read SimpleName javaparser ()
(let ((symbol (intern (#"getIdentifier" node))))
symbol))
(def-java-read NameExpr javaparser ()
(let ((symbol (intern (#"getIdentifier" (#"getName" node)))))
symbol))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun read-invoke/javaparser (stream char arg)
(if (eql arg 1)
(if (ignore-errors
(jclass "com.github.javaparser.ParseStart")) ;; chosen randomly, TODO memoize
(read-sharp-java-expression stream)
;; Deal with possiblity of not loading jar
(error "Cannot load javaparser code needed for the #1 macro"))
(read-invoke stream char arg)))
(set-dispatch-macro-character #\# #\" 'read-invoke/javaparser))
abcl-src-1.9.2/contrib/jss/jss-tests.asd 0100644 0000000 0000000 00000000751 14343623723 016641 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(in-package :asdf)
(defsystem jss-tests
:defsystem-depends-on (quicklisp-abcl
prove-asdf)
:depends-on (jss
prove)
:components ((:module tests
:pathname "t"
:components ((:test-file "jss-tests")
(:test-file "collections"))))
:perform (asdf:test-op (op c)
(uiop:symbol-call :prove-asdf 'run-test-system c)))
abcl-src-1.9.2/contrib/jss/jss.asd 0100644 0000000 0000000 00000001531 14444524627 015503 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(defsystem jss
:author "Alan Ruttenberg, Mark Evenson"
:long-description ""
:version "3.7.0"
:components ((:module base
:pathname "" :serial t
:components ((:file "packages")
(:file "invoke")
(:file "collections")
(:file "optimize-java-call")
(:file "classpath")
(:file "transform-to-field")
(:file "compat")
(:file "jtypecase")
(:file "util"))))
:perform (asdf:test-op (op c)
(asdf:test-system :jss-tests)))
abcl-src-1.9.2/contrib/jss/jtypecase.lisp 0100644 0000000 0000000 00000001272 14343623723 017070 0 ustar 00 0000000 0000000 (in-package :jss)
(defvar *jtypecache* (make-hash-table :test 'eq))
(defun jtypep (object type)
(declare (optimize (speed 3) (safety 0)))
(let ((class (or (gethash type *jtypecache*)
(ignore-errors (setf (gethash type *jtypecache*) (find-java-class type)))))
(method (load-time-value (jmethod "java.lang.Class" "isInstance" "java.lang.Object"))))
(and class
(jcall method class object))))
(defmacro jtypecase (keyform &body cases)
"JTYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which Type names a class that Keyform isInstance of
is true."
(sys::case-body 'jtypecase keyform cases t 'jtypep nil nil nil))
abcl-src-1.9.2/contrib/jss/optimize-java-call.lisp 0100644 0000000 0000000 00000002763 14343623723 020577 0 ustar 00 0000000 0000000 (in-package :jss)
(defvar *inhibit-jss-optimization* nil)
;; https://mailman.common-lisp.net/pipermail/armedbear-devel/2016-October/003726.html
(precompiler::define-function-position-lambda-transform jss::invoke-restargs (arglist form args)
(declare (ignore arglist))
(unless *inhibit-jss-optimization*
(precompiler::precompile-function-call
`(jss::invoke-restargs-macro
,(second form)
,(car args) (list ,@(cdr args)) ,(fifth form)))))
(defmacro invoke-restargs-macro ( method object args &optional (raw? nil))
(assert (eq (car args) 'list))
(setq args (cdr args))
(if (and (consp object) (eq (car object) 'quote))
(let ((object (eval object)))
(let* ((object-as-class
(or (ignore-errors (let ((*muffle-warnings* t)) (find-java-class object)))
`(find-java-class ',object))))
(if raw?
`(jstatic-raw ,method ,object-as-class ,@args)
`(jstatic ,method ,object-as-class ,@args))))
(let ((objectvar (make-symbol "INVOKE-RESTARGS-ARG1")))
(if raw?
`(let ((,objectvar ,object))
(if (symbolp ,objectvar)
(jstatic-raw ,method (find-java-class ,objectvar) ,@args)
(jcall-raw ,method ,objectvar ,@args)))
`(let ((,objectvar ,object))
(if (symbolp ,objectvar)
(jstatic ,method (find-java-class ,objectvar) ,@args)
(jcall ,method ,objectvar ,@args)))))))
abcl-src-1.9.2/contrib/jss/packages.lisp 0100644 0000000 0000000 00000001764 14343623723 016665 0 ustar 00 0000000 0000000 (defpackage :jss
(:nicknames "java-simple-syntax" "java-syntax-sucks")
(:use :common-lisp :extensions :java)
(:export
#:*inhibit-add-to-classpath*
#:*added-to-classpath*
#:*do-auto-imports*
#:*muffle-warnings*
#:invoke-restargs
#:with-constant-signature
#:invoke-add-imports
#:find-java-class
#:jcmn #:java-class-method-names
#:japropos
#:new
#:jar-import
#:classfiles-import
;;; Useful utilities to convert common Java items to Lisp counterparts
#:hashmap-to-hashtable
#:iterable-to-list
#:jlist-to-list
#:set-to-list
#:vector-to-list
#:jarray-to-list
#:to-hashset
#:j2list
#:jmap
#:jtypep
#:jtypecase
;;; XXX Necessary to work in OSGi?
#:get-java-field ; use JAVA:JFIELD
#:set-java-field ; use JAVA-JFIELD
;;; deprecated
#:list-to-list
;;; Move to JAVA?
#:jclass-all-interfaces
;;; Enable compatibility with jss-1.0 by placing symbols in CL-USER
#:ensure-compatibility #:*cl-user-compatibility*))
abcl-src-1.9.2/contrib/jss/read-sharp-quote-expression.lisp 0100644 0000000 0000000 00000011046 14343623723 022457 0 ustar 00 0000000 0000000 (in-package :jss)
(defclass sharp-quote-expression-reader (javaparser) ())
(defun read-sharp-java-expression (stream)
(read-sharp-quote-expression
(with-output-to-string (s)
(loop with embedded-string = nil
for last = #\space then char
for char = (read-char stream)
until (and (char= char #\")
;; really end if: we've established embedded string and the peek is a space
;; we're not about to start embedded string. We're about to start embedded string if next character isn't #\).
;; we're not embedded-string and not about to start one
(cond ((null (peek-char nil stream nil)) t) ;; eof
(embedded-string (system:whitespacep (peek-char nil stream))) ; embedded " needs "" to end
((find last ",(+=" :test 'char=)
(setq embedded-string t)
nil)
(t t)))
do
(write-char char s)))))
(defun read-sharp-quote-expression (string)
(multiple-value-bind (bindings de-lisped) (extract-lisp-expressions string)
(let ((read (read-java-expression (make-instance 'sharp-quote-expression-reader) de-lisped)))
(loop for (var nil) in bindings
do (setq read (tree-replace (lambda(e) (if (equalp e (string var)) var e)) read )))
(if bindings
`(let ,bindings ,read)
read))))
(defun extract-lisp-expressions (string)
(let ((bindings nil))
(let ((de-lisped
(replace-all string "\\{(.*?)\\}"
(lambda(match)
(let ((replacevar (find-symbol-not-matching string (mapcar 'car bindings))))
(push (list replacevar (read-from-string match)) bindings)
(string replacevar)))
1)))
(values bindings de-lisped))))
(defun find-symbol-not-matching (string already)
(loop for candidate = (format nil "JSS_~a" (random 10000))
until (and (not (member candidate already :test 'equalp :key 'string))
(not (search string already)))
finally (return-from find-symbol-not-matching (intern candidate :jss))))
(defun maybe-class (el)
(if (and (symbolp el) (upper-case-p (char (string el) 0)) (not (eql (search "JSS_" (string el)) 0)))
`(find-java-class ',el)
(if (symbolp el)
(intern (string-upcase el))
el)))
(def-java-read ObjectCreationExpr sharp-quote-expression-reader ()
`(new ',(process-node obj (#"getName" (#"getType" node))) ,@(mapcar (lambda(e) (process-node obj e)) (j2list (#"getArguments" node))))
)
(def-java-read MethodCallExpr sharp-quote-expression-reader ()
(let* ((scope1 (process-node obj (process-node obj (#"getScope" node))))
(how (if (and (symbolp scope1) (not (null scope1)) (upper-case-p (char (string scope1) 0)))
'jstatic
'jcall)))
(if (and (symbolp scope1) (not (null scope1)) (upper-case-p (char (string scope1) 0)))
(setq scope1 `(find-java-class ',scope1)))
`(,how ,(#"getIdentifier" (#"getName" node)) ,(or scope1 'this) ,@(mapcar 'maybe-class
(mapcar (lambda(el) (process-node obj el))
(j2list (#"getArguments" node)))))
))
(def-java-read FieldAccessExpr sharp-quote-expression-reader ()
(let ((scope (process-node obj (#"getScope" node))))
(if (and (symbolp scope) (upper-case-p (char (string scope) 0)))
`(get-java-field ',(process-node obj (#"getScope" node)) ,(#"getIdentifier" (#"getName" node)) t)
`(get-java-field ,(maybe-class (process-node obj (#"getScope" node))) ,(#"getIdentifier" (#"getName" node)) t))))
(def-java-read ArrayAccessExpr sharp-quote-expression-reader ()
(let ((index (process-node obj (#"getIndex" node))))
(if (symbolp index) (setq index (intern (string-upcase index))))
`(aref ,(process-node obj (#"getName" node)) ,index)))
(def-java-read ClassExpr sharp-quote-expression-reader ()
(let ((name (process-node obj (#"getName" (#"getType" node)))))
(if (eql (search "JSS_" (string name) :test 'equalp) 0)
name
`(find-java-class ',name))))
(def-java-read NameExpr sharp-quote-expression-reader ()
(process-node obj (#"getName" node)))
abcl-src-1.9.2/contrib/jss/t/collections.lisp 0100644 0000000 0000000 00000002356 14343623723 017666 0 ustar 00 0000000 0000000 (in-package :cl-user)
(prove:plan 5)
(let ((set (list 2 3 5 7 11)))
(prove:is-type (jss:to-hashset set)
'java:java-object
"Checking whether JSS:TO-HASHSET produces a Java objectâŠ")
(let ((result 0))
(jss:jmap (lambda (x)
(incf result))
(java:jnew-array "java.lang.Integer" 10))
(prove:is result 10 "Checking JSS:JMAP on Java array of java.lang.IntegerâŠ"))
(prove:ok (jss:j2list (java:jnew-array "java.lang.Integer" 10))
"Checking JSS:J2LIST on Java array of java.langIntegerâŠ")
(prove:is (let (list)
(jss:jmap (lambda (x) (push x list))
(let ((jarray (java:jnew-array "int" 3)))
(jarray-set jarray 1 1)
(jarray-set jarray 2 2)
jarray))
(nreverse list))
'(0 1 2)
"Checking JSS:JMAP on Java array of intâŠ")
(prove:is (jss:j2list (let ((jarray (java:jnew-array "int" 3)))
(jarray-set jarray 1 1)
(jarray-set jarray 2 2)
jarray))
'(0 1 2)
"Checking JSS:J2LIST on Java array of intâŠ"))
(prove:finalize)
abcl-src-1.9.2/contrib/jss/t/javaparser.lisp 0100644 0000000 0000000 00000002400 14343623723 017474 0 ustar 00 0000000 0000000 (in-package :cl-user)
(defparameter expanded '(let ((jss::this jss::*object-for-this*))
(declare (ignorable jss::this))
(jcall "getLoaded"
(jcall "load"
(jcall "make"
(jcall "intercept"
(jcall "method"
(jcall "subclass"
(new '|ByteBuddy|)
(find-java-class '|Object|)
t)
(jstatic "named"
(find-java-class '|ElementMatchers|)
"toString"))
(jstatic "value"
(find-java-class '|FixedValue|)
"Hello World!")))
(jcall "getClassLoader"
(jcall "getClass" jss::this))))))
(defparameter source '#1"new ByteBuddy().subclass(Object.class,t)
.method(ElementMatchers.named("toString"))
.intercept(FixedValue.value("Hello World!"))
.make()
.load(getClass().getClassLoader())
.getLoaded()" )
(prove:plan 1)
(prove:is source expanded)
(prove:finalize)
abcl-src-1.9.2/contrib/jss/t/jss-tests.lisp 0100644 0000000 0000000 00000005056 14343623723 017307 0 ustar 00 0000000 0000000 (in-package :cl-user)
(prove:plan 8)
(prove:is
(read-from-string "#\"{bar}.{foo}\"")
'(jss:get-java-field bar foo t))
(prove:is
(read-from-string "#\"q.bar.{foo}\"")
'(jss:get-java-field (load-time-value (jss:find-java-class "q.bar")) foo t))
(prove:is
(read-from-string "#\"{bar}.foo\"")
'(jss:get-java-field bar "foo" t))
(prove:is-error
(read-from-string "#\".bar.foo\"")
'simple-error)
;;; http://abcl.org/trac/ticket/205
(prove:is
(jss:with-constant-signature ((substring "substring"))
(substring "01234" 2)) "234")
;;; http://abcl.org/trac/ticket/229 - note: version of test for this ticket was broken in tests.lisp
(prove:is (#"toString"
(find "size" (#"getMethods" (jss:find-java-class "java.util.Collections$UnmodifiableMap"))
:test 'string-equal :key #"getName"))
(#"toString" (java::jmethod "java.util.Collections$UnmodifiableMap" "size" )))
(prove:is
(jss::with-class-lookup-disambiguated (lang.object) (jss:find-java-class 'object))
(jss:find-java-class 'java.lang.object))
;; Object is ambiguous in default java
(prove:is-error
(jss:find-java-class 'object)
'simple-error)
;; test that optimized jss is much faster than unoptimized
(let ()
(defun optimized-jss (count)
(loop repeat count do (#"compile" 'regex.Pattern ".*")))
(let ((jss::*inhibit-jss-optimization* t))
(defun unoptimized-jss (count)
(loop repeat count do (#"compile" 'regex.Pattern ".*"))))
(defun just-loop (count)
(loop repeat count))
(let ((jss::*inhibit-jss-optimization* nil))
(compile 'just-loop)
(compile 'optimized-jss))
(let ((jss::*inhibit-jss-optimization* t))
(compile 'unoptimized-jss))
(defmacro timeit (&body body)
`(let ((start (#"currentTimeMillis" 'system)))
,@body
(- (#"currentTimeMillis" 'system) start)))
(prove:plan 1)
(prove:is-type (let ((just-loop (timeit (just-loop 10000))))
(+ 0.0
(/ (- (timeit (optimized-jss 10000)) just-loop)
(- (timeit (unoptimized-jss 10000)) just-loop))))
'(float 0 0.1)
"Testing JSS compiler optimizationâŠ"))
(prove:plan 2)
(let* ((jss::*inhibit-jss-optimization* nil)
(optimized-jss
(macroexpand (precompiler::precompile-form
'(#"compile" 'regex.Pattern ".*") t))))
(let* ((jss::*inhibit-jss-optimization* t)
(unoptimized-jss
(macroexpand (precompiler::precompile-form '(#"compile" 'regex.Pattern ".*") t))))
(prove:is (car optimized-jss) 'java:jstatic)
(prove:is (caar unoptimized-jss) 'lambda)))
(prove:finalize)
abcl-src-1.9.2/contrib/jss/transform-to-field.lisp 0100644 0000000 0000000 00000011440 14343623723 020613 0 ustar 00 0000000 0000000 (in-package :jss)
;; JSS syntax for fields
;; #"[]