..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))
"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*))
;; FIXME Remove warning; put message in restart
(warn "Please obtain and install maven-3.0.3 or later locally from , then set ABCL-ASDF:*MVN-LIBS-DIRECTORY* to the directory containing maven-core-3.*.jar et. al.")
(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))))))))))
;;; Currently the last file listed in ASDF
(provide 'abcl-asdf)
abcl-src-1.9.0/contrib/abcl-asdf/mvn-module.lisp 0100644 0000000 0000000 00000006567 14202767264 020216 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.0/contrib/abcl-asdf/package.lisp 0100644 0000000 0000000 00000001310 14202767264 017503 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
;;; "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.0/contrib/abcl-asdf/t/eg/soot-mixed-repositories.asd 0100644 0000000 0000000 00000000554 14202767264 023374 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.0/contrib/abcl-asdf/t/eg/soot-only-repositories.asd 0100644 0000000 0000000 00000000556 14202767264 023251 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.0/contrib/abcl-asdf/t/eg/test-mvn-module.asd 0100644 0000000 0000000 00000002433 14202767264 021615 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.0/contrib/abcl-asdf/t/log4j.lisp 0100644 0000000 0000000 00000001222 14202767264 017374 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.0/contrib/abcl-asdf/t/maven.lisp 0100644 0000000 0000000 00000000626 14202767264 017472 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.0/contrib/abcl-asdf/t/mvn-module.lisp 0100644 0000000 0000000 00000001370 14202767264 020444 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.0/contrib/abcl-asdf/t/resolve-multiple-maven-dependencies.lisp 0100644 0000000 0000000 00000001447 14202767264 025426 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.0/contrib/abcl-asdf/t/resolve.lisp 0100644 0000000 0000000 00000000304 14202767264 020034 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.0/contrib/abcl-build/README.markdown 0100644 0000000 0000000 00000000233 14202767264 020105 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.0/contrib/abcl-build/abcl-build-tests.asd 0100644 0000000 0000000 00000001250 14202767264 021233 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.0/contrib/abcl-build/abcl-build.asd 0100644 0000000 0000000 00000002672 14202767264 020104 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.0/contrib/abcl-build/build/abcl-build.lisp 0100644 0000000 0000000 00000001425 14202767264 021376 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.0/contrib/abcl-build/build/ant.lisp 0100644 0000000 0000000 00000006023 14202767264 020161 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.0/contrib/abcl-build/build/build.lisp 0100644 0000000 0000000 00000000637 14202767264 020503 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.0/contrib/abcl-build/build/customizations-default.lisp 0100644 0000000 0000000 00000001764 14202767264 024123 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.0/contrib/abcl-build/build/deprecated.lisp 0100644 0000000 0000000 00000045627 14202767264 021514 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.0/contrib/abcl-build/build/install.lisp 0100644 0000000 0000000 00000004620 14202767264 021046 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.0/contrib/abcl-build/build/maven.lisp 0100644 0000000 0000000 00000004105 14202767264 020504 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.0/contrib/abcl-build/build/package.lisp 0100644 0000000 0000000 00000002206 14202767264 020771 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.0/contrib/abcl-build/build/report.lisp 0100644 0000000 0000000 00000002034 14202767264 020710 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.0/contrib/abcl-build/build/t/abcl-build.lisp 0100644 0000000 0000000 00000001375 14202767264 021645 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.0/contrib/abcl-build/build/t/ant.lisp 0100644 0000000 0000000 00000001205 14202767264 020421 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.0/contrib/abcl-build/build/t/install.lisp 0100644 0000000 0000000 00000001314 14202767264 021306 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.0/contrib/abcl-build/build/t/maven.lisp 0100644 0000000 0000000 00000001135 14202767264 020747 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.0/contrib/abcl-build/build/t/util.lisp 0100644 0000000 0000000 00000000356 14202767264 020622 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.0/contrib/abcl-build/build/util.lisp 0100644 0000000 0000000 00000007646 14202767264 020370 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.0/contrib/abcl-introspect/README.org 0100644 0000000 0000000 00000016631 14202767264 020156 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.0/contrib/abcl-introspect/abcl-introspect-test.asd 0100644 0000000 0000000 00000001141 14242627550 023232 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.0/contrib/abcl-introspect/abcl-introspect.asd 0100644 0000000 0000000 00000001275 14242627550 022265 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.0/contrib/abcl-introspect/abcl-introspect.lisp 0100644 0000000 0000000 00000066013 14212332540 022453 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.0/contrib/abcl-introspect/byte-code.lisp 0100644 0000000 0000000 00000000152 14202767264 021243 0 ustar 00 0000000 0000000 (in-package :abcl-introspect)
(defun choose-disassemble ()
(warn "Unimplemented choose dissambler."))
abcl-src-1.9.0/contrib/abcl-introspect/cfr.asd 0100644 0000000 0000000 00000000463 14202767264 017747 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.0/contrib/abcl-introspect/cfr.lisp 0100644 0000000 0000000 00000001466 14202767264 020153 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.0/contrib/abcl-introspect/fernflower.asd 0100644 0000000 0000000 00000000664 14202767264 021351 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.0/contrib/abcl-introspect/fernflower.lisp 0100644 0000000 0000000 00000002507 14202767264 021547 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.0/contrib/abcl-introspect/jad.asd 0100644 0000000 0000000 00000000325 14202767264 017730 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.0/contrib/abcl-introspect/jad.lisp 0100644 0000000 0000000 00000003062 14202767264 020131 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.0/contrib/abcl-introspect/javap.asd 0100644 0000000 0000000 00000000332 14202767264 020271 0 ustar 00 0000000 0000000 (defsystem javap
:homepage "" ;; FIXME
:description "Utilization of the javap command line dissassembler"
:components ((:file "javap")))
abcl-src-1.9.0/contrib/abcl-introspect/javap.lisp 0100644 0000000 0000000 00000001276 14202767264 020501 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.0/contrib/abcl-introspect/objectweb.asd 0100644 0000000 0000000 00000000612 14202767264 021135 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.0/contrib/abcl-introspect/objectweb.lisp 0100644 0000000 0000000 00000001740 14202767264 021340 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.0/contrib/abcl-introspect/packages.lisp 0100644 0000000 0000000 00000001227 14212332540 021134 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.0/contrib/abcl-introspect/procyon.asd 0100644 0000000 0000000 00000000646 14202767264 020671 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.0/contrib/abcl-introspect/procyon.lisp 0100644 0000000 0000000 00000002734 14202767264 021071 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.0/contrib/abcl-introspect/stacktrace.lisp 0100644 0000000 0000000 00000040167 14202767264 021526 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) (jss::new '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.0/contrib/abcl-introspect/t/disassemble.lisp 0100644 0000000 0000000 00000003351 14202767264 022132 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.0/contrib/abcl-introspect/t/environments.lisp 0100644 0000000 0000000 00000002030 14212332540 022341 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.0/contrib/abcl-introspect/util.lisp 0100644 0000000 0000000 00000004547 14202767264 020361 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.0/contrib/asdf-jar/README.markdown 0100644 0000000 0000000 00000004422 14202767264 017602 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> (require :asdf-jar)
Then, to say package the Perl regular expression system ("CL-PPCRE"),
one uses the ASDF-JAR:PACKAGE as follows:
CL-USER> (asdf-jar:package :cl-ppcre)
; Loading #P"/home/evenson/quicklisp/dists/quicklisp/software/cl-ppcre-2.0.3/cl-ppcre.asd" ...
; Loaded #P"/home/evenson/quicklisp/dists/quicklisp/software/cl-ppcre-2.0.3/cl-ppcre.asd" (0.029 seconds)
Packaging ASDF definition of #
as /var/tmp/cl-ppcre-all-2.0.3.jar.
Packaging contents in /var/tmp/cl-ppcre-all-2.0.3.jar
with recursive dependencies.
#P"/var/tmp/cl-ppcre-all-2.0.3.jar"
The resulting jar contains all source and fasls required to run the
ASDF system including any transitive ASDF dependencies. Each asdf
system is packaged under its own top level directory within the jar
archive. The jar archive itself is numbered with the version of the
system that was specified in the packaging.
To load the system from the jar one needs to add the ASDF file
locations to the ASDF *CENTRAL-REGISTRY*. If one wishes to load the
fasls from the jar alone, one needs to tell ASDF not to override its
output translation rules. The function ASDF-JAR:ADD-TO-JAR does both
of these options serving as the basis for customized load strategies
tailored to end-user deployment needs. So, after
CL-USER> (asdf-jar:add-to-asdf "/var/tmp/cl-ppcre-all-2.0.3.jar")
a subsequent
CL-USER> (asdf:load-system :cl-ppcre)
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: 11-JUN-2017
abcl-src-1.9.0/contrib/asdf-jar/asdf-jar.asd 0100644 0000000 0000000 00000000630 14242627550 017253 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(defsystem asdf-jar
:author "Mark Evenson"
:description "Packaging ASDF systems into jar files"
:long-description ""
:version "0.3.2"
:components ((:module base
:pathname ""
:components ((:file "asdf-jar")
(:static-file "README.markdown")))))
abcl-src-1.9.0/contrib/asdf-jar/asdf-jar.lisp 0100644 0000000 0000000 00000020115 14202767264 017456 0 ustar 00 0000000 0000000 ;;; This file is part of ABCL contrib
;;;
;;; Copyright 2011 Mark
(defpackage #:asdf-jar
(:use :cl)
(:export #:package
;; "Si vis pacem, para bellum" -- Publius Flavius Vegetius Renatus
#:prepare-for-war
#:add-to-asdf))
(in-package #:asdf-jar)
(defvar *debug* nil)
(defun add-system-files-to-mapping! (system
mapping
system-base
system-name
root
&key (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 = (slot-value component 'asdf::absolute-pathname)
: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~& => ~A" source source-entry)
:when (and (typep component 'asdf::source-file)
(not (typep component 'asdf::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 (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::absolute-pathname))
(name (slot-value system 'asdf::name))
(asdf (slot-value system 'asdf::source-file)))
(setf (gethash asdf mapping)
(let ((relative-path (archive-relative-path base name asdf)))
(merge-pathnames
relative-path
(make-pathname :directory root))))
(add-system-files-to-mapping! system mapping base name root
:verbose verbose)))
mapping))
(defun package (system &key
(out #p"/var/tmp/")
(recursive t) ; whether to package dependencies
(force nil) ; whether to force ASDF compilation
(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.
"
(when (not (typep system 'asdf:system))
(setf system (asdf:find-system system)))
(let* ((name
(slot-value system 'asdf::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 (and verbose force)
(format verbose "~&Forcing recursive compilation of ~A." package-jar))
(asdf:compile-system system :force force)
(when verbose
(format verbose "~&Packaging contents in ~A" package-jar))
(system:zip package-jar
(systems->hash-table
(append (list system)
(when recursive
(let ((dependencies (dependent-systems system)))
(when (and verbose dependencies)
(format verbose
"~& with recursive dependencies~{ ~A~^, ~}."
dependencies))
(mapcar #'asdf:find-system dependencies))))
root
:verbose verbose))))
(defun all-files (component)
(loop :for c
:being :each :hash-value :of (slot-value component 'asdf::children-by-name)
:when (typep c 'asdf:module)
:append (all-files c)
:when (typep c 'asdf:source-file)
:append (list c)))
(defun dependent-systems (system)
(when (not (typep system 'asdf:system))
(setf system (asdf:find-system system)))
(let* ((dependencies (asdf::component-load-dependencies system))
(sub-depends
(loop :for dependency :in dependencies
:for sub = (dependent-systems dependency)
:when sub :append sub)))
(remove-duplicates `(,@dependencies ,@sub-depends))))
(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" "foo" "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 t))
"Make a given JAR output by the package mechanism loadable by asdf.
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 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
(loop :for asd
:in (directory (merge-pathnames "*/*.asd" jar))
:do (pushnew (make-pathname :defaults asd
:name nil :type nil)
asdf:*central-registry*))
;;; Load the FASLs directly from the jar
(when use-jar-fasls
(asdf:initialize-output-translations
`(:output-translations (,(merge-pathnames "/**/*.*" jar))
: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.0/contrib/jfli/README 0100644 0000000 0000000 00000002631 14242627550 015213 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.0/contrib/jfli/examples/swing/README 0100644 0000000 0000000 00000000471 14202767264 020163 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.0/contrib/jfli/examples/swt/README 0100644 0000000 0000000 00000002510 14202767264 017645 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.0/contrib/jfli/examples/swt/file.gif 0100644 0000000 0000000 00000000377 14202767264 020404 0 ustar 00 0000000 0000000 GIF89a � ��_������߿�ߟ���������___��� !� , E0�I+=8c+) x �� Y�@ň��y������
�K�|��eR�xH�sǜ������v����ȱD ;
abcl-src-1.9.0/contrib/jfli/examples/swt/folder.gif 0100644 0000000 0000000 00000000407 14202767264 020732 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.0/contrib/jfli/jfli.asd 0100644 0000000 0000000 00000000600 14242627550 015742 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.0/contrib/jfli/jfli.lisp 0100644 0000000 0000000 00000153161 14202767264 016160 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.0/contrib/jfli/test/yanking.lisp 0100644 0000000 0000000 00000035453 14202767264 017656 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.0/contrib/jss/README.markdown 0100644 0000000 0000000 00000011331 14223403213 016667 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.0/contrib/jss/classpath.lisp 0100644 0000000 0000000 00000001003 14202767264 017054 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.0/contrib/jss/collections.lisp 0100644 0000000 0000000 00000024132 14202767264 017420 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.0/contrib/jss/compat.lisp 0100644 0000000 0000000 00000001630 14202767264 016363 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.0/contrib/jss/invoke.lisp 0100644 0000000 0000000 00000077052 14223403213 016366 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.0/contrib/jss/javaparser-tests.asd 0100644 0000000 0000000 00000000570 14223403213 020160 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.0/contrib/jss/javaparser.asd 0100644 0000000 0000000 00000001011 14223403213 017007 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.0/contrib/jss/javaparser.lisp 0100644 0000000 0000000 00000006047 14233147074 017240 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.0/contrib/jss/jss-tests.asd 0100644 0000000 0000000 00000000751 14223403213 016622 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.0/contrib/jss/jss.asd 0100644 0000000 0000000 00000001531 14242627550 015474 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.0/contrib/jss/jtypecase.lisp 0100644 0000000 0000000 00000001272 14202767264 017071 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.0/contrib/jss/optimize-java-call.lisp 0100644 0000000 0000000 00000002763 14202767264 020600 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.0/contrib/jss/packages.lisp 0100644 0000000 0000000 00000001764 14206360343 016655 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.0/contrib/jss/read-sharp-quote-expression.lisp 0100644 0000000 0000000 00000011046 14233147074 022453 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.0/contrib/jss/t/collections.lisp 0100644 0000000 0000000 00000002356 14202767264 017667 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.0/contrib/jss/t/javaparser.lisp 0100644 0000000 0000000 00000002400 14223403213 017455 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.0/contrib/jss/t/jss-tests.lisp 0100644 0000000 0000000 00000005056 14202767264 017310 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.0/contrib/jss/transform-to-field.lisp 0100644 0000000 0000000 00000011440 14202767264 020614 0 ustar 00 0000000 0000000 (in-package :jss)
;; JSS syntax for fields
;; #"[]."
;;
;; is empty or "==". scope is only paid attention to when is a literal string
;;
;; is either {} or a class name or abbreviation that find-java-class can use
;; If is a lisp expression, then it is evaluated (in the lexical environment) and used as an instance
;; when is "==" you promise that instance will always be of the same class, and so field lookup
;; is done once and cached.
;; If is a class name the result of find-java-class is used and a static field access is done.
;; when is "==" you promise the static field is final and so the result is wrapped in (load-time-value ...)
;;
;; is either { is a lisp expression it should evaluate to a string that names a field
;; If is a string (no quotes) it is used as the field name
;;
;; eg. #"foo.bar.baz" -> (get-java-field (find-java-class 'foo.bar) "baz" t)
;; #"{foo}.baz" -> (get-java-field (find-java-class foo) "baz" t)
;; #"==foo.baz" -> (load-time-value (get-java-field (find-java-class "foo") "bar" t))
;; #"=={foo}.baz" -> TL;DR (only look up baz field once based on class of foo, and cache)
(defun jss-transform-to-field (string sharp-arg)
(let* ((pattern (#"compile" 'java.util.regex.Pattern "((==){0,1})(.*)\\.([^.]+)$"))
(matcher (#"matcher" pattern string)))
(#"find" matcher)
(let ((parts (list (#"group" matcher 3) (#"group" matcher 4)))
(scope (#"group" matcher 1)))
(check-class-or-eval (first parts))
(check-field-or-eval (second parts))
(apply 'field-access-expression sharp-arg scope parts ))))
;; http://stackoverflow.com/questions/5205339/regular-expression-matching-fully-qualified-class-names
(defun check-class-or-eval (string)
(assert
(or (#"matches" string "^((\\p{javaJavaIdentifierStart}(\\p{javaJavaIdentifierPart})*)+)(\\.\\p{javaJavaIdentifierStart}(\\p{javaJavaIdentifierPart})*)*$")
(#"matches" string "^\\{.+}$")) (string)
"inside #\"..\" expected either an abbreviated class name or an expression surrounded by {}. Found: #~s" string))
(defun check-field-or-eval (string)
(assert (or (#"matches" string "^(\\p{javaJavaIdentifierStart}(\\p{javaJavaIdentifierPart})*)+$")
(#"matches" string "^\\{.+\\}$"))
(string)
"inside #\"..\" expected either a field name or an expression surrounded by {}. Found: #~s" string))
(defun field-access-expression (sharp-arg scope thing field )
(if (and (not (char= (char thing 0) #\{)) (not (char= (char field 0) #\{)))
(static-field-ref-transform thing field sharp-arg scope)
(if (and (equal scope "==") (char= (char thing 0) #\{) (not (char= (char field 0) #\{)))
(always-same-signature-field-ref-transform sharp-arg thing field)
`(get-java-field ,(if (char= (char thing 0) #\{)
(read-from-string (subseq thing 1 (- (length thing) 1)))
`(load-time-value (find-java-class ,thing)))
,(if (char= (char field 0) #\{)
(read-from-string (subseq field 1 (- (length field) 1)))
field)
t))))
;; If a class name and explicit field name we can look everything up at load time
(defun static-field-ref-transform (class field sharp-arg scope)
(if (equal scope "==")
`(load-time-value (get-java-field (find-java-class ,class) ,field t))
`(,(if (eql sharp-arg 0) 'jcall-raw 'jcall)
(load-time-value (jmethod "java.lang.reflect.Field" "get" "java.lang.Object"))
(load-time-value
(let ((jfield (find-declared-field ,field (find-java-class ,class))))
(#"setAccessible" jfield t)
jfield))
(load-time-value (find-java-class ',class)))))
;; 1 case: =={var}.foo
;; Globally cache the field accessor for the first value of {var}. Subsequent calls ignore the class of var.
(defun always-same-signature-field-ref-transform (sharp-arg object field)
(let ((cached (make-symbol (format nil "CACHED-FIELD-field")))
(object (intern (string-upcase (subseq object 1 (- (length object) 1))))))
`(,(if (eql sharp-arg 0) 'jcall-raw 'jcall)
(load-time-value (jmethod "java.lang.reflect.Field" "get" "java.lang.Object"))
(locally (declare (special ,cached))
(if (boundp ',cached)
,cached
(progn (setq ,cached
(find-declared-field ,field (jcall (load-time-value (jmethod "java.lang.Object" "getClass")) ,object)))
(jcall (load-time-value (jmethod "java.lang.reflect.Field" "setAccessible" "boolean")) ,cached t)
,cached)))
,object)))
abcl-src-1.9.0/contrib/jss/util.lisp 0100644 0000000 0000000 00000002165 14202767264 016061 0 ustar 00 0000000 0000000 (in-package :jss)
(defun tree-replace (replace-fn tree)
"create new tree replacing each element with the result of calling replace-fn on it"
(labels ((tr-internal (tree)
(cond ((atom tree) (funcall replace-fn tree))
(t (let ((replacement (funcall replace-fn tree)))
(if (eq replacement tree)
(mapcar #'tr-internal tree)
replacement))))))
(tr-internal tree)))
(defun replace-all (string regex function &rest which)
(let ((matcher (#"matcher" (if (java-object-p regex) regex (#"compile" 'java.util.regex.pattern regex)) string))
(sb (new 'stringbuffer)))
(with-constant-signature ((append "appendReplacement"))
(loop for found = (#"find" matcher)
while found
do
(#"appendReplacement" matcher sb (apply function
(loop for g in which collect
(#"group" matcher g)))))
)
(#"appendTail" matcher sb)
(#"toString" sb)))
abcl-src-1.9.0/contrib/mvn/jna-asdf.lisp 0100644 0000000 0000000 00000000370 14202767264 016564 0 ustar 00 0000000 0000000 (in-package :cl-user)
(defpackage jna
(:nicknames :jna)
(:use :cl))
(in-package :jna)
(defmethod asdf:perform :after ((o asdf:load-op) (c (eql (asdf:find-system :jna))))
(when (jss:find-java-class "com.sun.jna.Native")
(provide :jna)))
abcl-src-1.9.0/contrib/mvn/jna.asd 0100644 0000000 0000000 00000000707 14242627550 015452 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
;;;; Need to have jna.jar present for CFFI to work.
(defsystem jna
:long-description ""
:version "5.9.0"
:defsystem-depends-on (jss abcl-asdf)
:components ((:mvn "net.java.dev.jna/jna/5.9.0"
:alternate-uri "https://repo1.maven.org/maven2/net/java/dev/jna/jna/5.9.0/jna-5.9.0.jar"
:classname "com.sun.jna.Native")))
abcl-src-1.9.0/contrib/mvn/log4j.asd 0100644 0000000 0000000 00000000257 14202767264 015724 0 ustar 00 0000000 0000000 ;;;; -*- Mode: LISP -*-
(defsystem log4j
:defsystem-depends-on (abcl-asdf)
:components ((:module log4j.jar
:components ((:mvn "log4j/log4j")))))
abcl-src-1.9.0/contrib/named-readtables/LICENSE 0100644 0000000 0000000 00000003252 14202767264 017607 0 ustar 00 0000000 0000000
Copyright (c) 2007 - 2009 Tobias C. Rittweiler
Copyright (c) 2007, Robert P. Goldman and SIFT, LLC
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the names of Tobias C. Rittweiler, Robert P. Goldman,
SIFT, LLC nor the names of its contributors may be used to
endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert
P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert
P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
abcl-src-1.9.0/contrib/named-readtables/README 0100644 0000000 0000000 00000030000 14202767264 017451 0 ustar 00 0000000 0000000 # Named Readtables Manual
###### \[in package EDITOR-HINTS.NAMED-READTABLES\]
## named-readtables ASDF System Details
- Version: 0.9
- Description: Library that creates a namespace for named readtable
akin to the namespace of packages.
- Licence: BSD, see LICENSE
- Author: Tobias C. Rittweiler
- Maintainer: Gábor Melis
- Mailto: [mega@retes.hu](mailto:mega@retes.hu)
## Introduction
Named-Readtables is a library that provides a namespace for
readtables akin to the already-existing namespace of packages. In
particular:
- you can associate readtables with names, and retrieve
readtables by names;
- you can associate source files with readtable names, and be
sure that the right readtable is active when compiling/loading
the file;
- similiarly, your development environment now has a chance to
automatically determine what readtable should be active while
processing source forms on interactive commands. (E.g. think of
`C-c C-c` in Slime (yet to be done))
It follows that Named-Readtables is a facility for using readtables in
a localized way.
Additionally, it also attempts to become a facility for using
readtables in a *modular* way. In particular:
- it provides a macro to specify the content of a readtable at a
glance;
- it makes it possible to use multiple inheritance between readtables.
### Links
Here is the [official repository][named-readtables-repo] and the
[HTML documentation][named-readtables-doc] for the latest version.
[named-readtables-repo]: https://github.com/melisgl/named-readtables
[named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html
### Acknowledgements
Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
Botta, David Crawford, and Pascal Costanza for being early adopters,
providing comments and bugfixes.
## Overview
### Notes on the API
The API heavily imitates the API of packages. This has the nice
property that any experienced Common Lisper will take it up without
effort.
DEFREADTABLE - DEFPACKAGE
IN-READTABLE - IN-PACKAGE
MERGE-READTABLES-INTO - USE-PACKAGE
MAKE-READTABLE - MAKE-PACKAGE
UNREGISTER-READTABLE - DELETE-PACKAGE
RENAME-READTABLE - RENAME-PACKAGE
FIND-READTABLE - FIND-PACKAGE
READTABLE-NAME - PACKAGE-NAME
LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES
### Important API idiosyncrasies
There are three major differences between the API of Named-Readtables,
and the API of packages.
1. Readtable names are symbols not strings.
Time has shown that the fact that packages are named by strings
causes severe headache because of the potential of package names
colliding with each other.
Hence, readtables are named by symbols lest to make the
situation worse than it already is. Consequently, readtables
named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can
happily coexist next to each other. Or, taken to an extreme,
`SCHEME:SYNTAX` and `ELISP:SYNTAX`.
If, for example to duly signify the importance of your cool
readtable hack, you really think it deserves a global name, you
can always resort to keywords.
2. The inheritance is resolved statically, not dynamically.
A package that uses another package will have access to all the
other package's exported symbols, even to those that will be
added after its definition. I.e. the inheritance is resolved at
run-time, that is dynamically.
Unfortunately, we cannot do the same for readtables in a
portable manner.
Therefore, we do not talk about "using" another readtable but
about "merging" the other readtable's definition into the
readtable we are going to define. I.e. the inheritance is
resolved once at definition time, that is statically.
(Such merging can more or less be implemented portably albeit at
a certain cost. Most of the time, this cost manifests itself at
the time a readtable is defined, i.e. once at compile-time, so
it may not bother you. Nonetheless, we provide extra support for
Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your
implementation of choice are welcome, of course.)
3. DEFREADTABLE does not have compile-time effects.
If you define a package via DEFPACKAGE, you can make that
package the currently active package for the subsequent
compilation of the same file via IN-PACKAGE. The same is,
however, not true for DEFREADTABLE and IN-READTABLE for the
following reason:
It's unlikely that the need for special reader-macros arises for
a problem which can be solved in just one file. Most often,
you're going to define the reader macro functions, and set up
the corresponding readtable in an extra file.
If DEFREADTABLE had compile-time effects, you'd have to wrap
each definition of a reader-macro function in an EVAL-WHEN to
make its definition available at compile-time. Because that's
simply not the common case, DEFREADTABLE does not have a
compile-time effect.
If you want to use a readtable within the same file as its
definition, wrap the DEFREADTABLE and the reader-macro function
definitions in an explicit EVAL-WHEN.
### Preregistered Readtables
- NIL, :STANDARD, and :COMMON-LISP designate the
*standard readtable*.
- :MODERN designates a *case-preserving* *standard-readtable*.
- :CURRENT designates the *current readtable*.
### Examples
```commonlisp
(defreadtable elisp:syntax
(:merge :standard)
(:macro-char #\? #'elisp::read-character-literal t)
(:macro-char #\[ #'elisp::read-vector-literal t)
...
(:case :preserve))
(defreadtable scheme:syntax
(:merge :standard)
(:macro-char #\[ #'(lambda (stream char)
(read-delimited-list #\] stream)))
(:macro-char #\# :dispatch)
(:dispatch-macro-char #\# #\t #'scheme::read-#t)
(:dispatch-macro-char #\# #\f #'scheme::read-#f)
...
(:case :preserve))
(in-readtable elisp:syntax)
...
(in-readtable scheme:syntax)
...
```
## Reference
- [macro] DEFREADTABLE NAME &BODY OPTIONS
Define a new named readtable, whose name is given by the symbol NAME.
Or, if a readtable is already registered under that name, redefine
that one.
The readtable can be populated using the following OPTIONS:
- `(:MERGE READTABLE-DESIGNATORS+)`
Merge the readtables designated into the new readtable being
defined as per MERGE-READTABLES-INTO.
If no :MERGE clause is given, an empty readtable is used. See
MAKE-READTABLE.
- `(:FUSE READTABLE-DESIGNATORS+)`
Like :MERGE except:
Error conditions of type READER-MACRO-CONFLICT that are signaled
during the merge operation will be silently *continued*. It
follows that reader macros in earlier entries will be
overwritten by later ones. For backward compatibility, :FUZE is
accepted as an alias of :FUSE.
- `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)`
Define a new sub character `SUB-CHAR` for the dispatching macro
character `MACRO-CHAR`, per SET-DISPATCH-MACRO-CHARACTER. You
probably have to define `MACRO-CHAR` as a dispatching macro
character by the following option first.
- `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])`
Define a new macro character in the readtable, per
SET-MACRO-CHARACTER. If `FUNCTION` is the keyword :DISPATCH,
`MACRO-CHAR` is made a dispatching macro character, per
MAKE-DISPATCH-MACRO-CHARACTER.
- `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)`
Set the character syntax of TO-CHAR in the readtable being
defined to the same syntax as FROM-CHAR as per
SET-SYNTAX-FROM-CHAR.
- `(:CASE CASE-MODE)`
Defines the *case sensitivity mode* of the resulting readtable.
Any number of option clauses may appear. The options are grouped by
their type, but in each group the order the options appeared
textually is preserved. The following groups exist and are executed
in the following order: :MERGE and :FUSE (one
group), :CASE, :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group),
finally :SYNTAX-FROM.
Notes:
The readtable is defined at load-time. If you want to have it
available at compilation time -- say to use its reader-macros in the
same file as its definition -- you have to wrap the DEFREADTABLE
form in an explicit EVAL-WHEN.
On redefinition, the target readtable is made empty first before
it's refilled according to the clauses.
NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are
preregistered readtable names.
- [macro] IN-READTABLE NAME
Set *READTABLE* to the readtable referred to by the symbol NAME.
- [function] MAKE-READTABLE &OPTIONAL (NAME NIL NAME-SUPPLIED-P) &KEY MERGE
Creates and returns a new readtable under the specified
NAME.
MERGE takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
readtables the new readtable is created from. (See the :MERGE clause
of DEFREADTABLE for details.)
If MERGE is NIL, an empty readtable is used instead.
If NAME is not given, an anonymous empty readtable is returned.
Notes:
An empty readtable is a readtable where each character's syntax is
the same as in the *standard readtable* except that each macro
character has been made a constituent. Basically: whitespace stays
whitespace, everything else is constituent.
- [function] MERGE-READTABLES-INTO RESULT-READTABLE &REST NAMED-READTABLES
Copy the contents of each readtable in NAMED-READTABLES into
RESULT-READTABLE.
If a macro character appears in more than one of the readtables,
i.e. if a conflict is discovered during the merge, an error of type
READER-MACRO-CONFLICT is signaled.
- [function] FIND-READTABLE NAME
Looks for the readtable specified by NAME and returns it if it is
found. Returns NIL otherwise.
- [function] ENSURE-READTABLE NAME &OPTIONAL (DEFAULT NIL DEFAULT-P)
Looks up the readtable specified by NAME and returns it if it's found.
If it is not found, it registers the readtable designated by DEFAULT
under the name represented by NAME; or if no default argument is
given, it signals an error of type READTABLE-DOES-NOT-EXIST
instead.
- [function] RENAME-READTABLE OLD-NAME NEW-NAME
Replaces the associated name of the readtable designated by
OLD-NAME with NEW-NAME. If a readtable is already registered under
NEW-NAME, an error of type READTABLE-DOES-ALREADY-EXIST is
signaled.
- [function] READTABLE-NAME NAMED-READTABLE
Returns the name of the readtable designated by NAMED-READTABLE,
or NIL.
- [function] REGISTER-READTABLE NAME READTABLE
Associate READTABLE with NAME. Returns the readtable.
- [function] UNREGISTER-READTABLE NAMED-READTABLE
Remove the association of NAMED-READTABLE. Returns T if successfull,
NIL otherwise.
- [function] COPY-NAMED-READTABLE NAMED-READTABLE
Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument.
- [function] LIST-ALL-NAMED-READTABLES
Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates.
- [type] NAMED-READTABLE-DESIGNATOR
Either a symbol or a readtable itself.
- [condition] READER-MACRO-CONFLICT READTABLE-ERROR
Continuable.
This condition is signaled during the merge process if a reader
macro (be it a macro character or the sub character of a dispatch
macro character) is present in the both source and the target
readtable and the two respective reader macro functions differ.
- [condition] READTABLE-DOES-ALREADY-EXIST READTABLE-ERROR
Continuable.
- [condition] READTABLE-DOES-NOT-EXIST READTABLE-ERROR
* * *
###### \[generated by [MGL-PAX](https://github.com/melisgl/mgl-pax)\]
abcl-src-1.9.0/contrib/named-readtables/README.md 0100644 0000000 0000000 00000044312 14202767264 020063 0 ustar 00 0000000 0000000
# Named Readtables Manual
## Table of Contents
- [1 named-readtables ASDF System Details][9b5b]
- [2 Introduction][6faf]
- [2.1 Links][8688]
- [2.2 Acknowledgements][059d]
- [3 Overview][0bc2]
- [3.1 Notes on the API][e4cd]
- [3.2 Important API idiosyncrasies][62b8]
- [3.3 Preregistered Readtables][58c6]
- [3.4 Examples][cf94]
- [4 Reference][373d]
###### \[in package EDITOR-HINTS.NAMED-READTABLES\]
## 1 named-readtables ASDF System Details
- Version: 0.9
- Description: Library that creates a namespace for named readtable
akin to the namespace of packages.
- Licence: BSD, see LICENSE
- Author: Tobias C. Rittweiler
- Maintainer: Gábor Melis
- Mailto: [mega@retes.hu](mailto:mega@retes.hu)
## 2 Introduction
Named-Readtables is a library that provides a namespace for
readtables akin to the already-existing namespace of packages. In
particular:
- you can associate readtables with names, and retrieve
readtables by names;
- you can associate source files with readtable names, and be
sure that the right readtable is active when compiling/loading
the file;
- similiarly, your development environment now has a chance to
automatically determine what readtable should be active while
processing source forms on interactive commands. (E.g. think of
`C-c C-c` in Slime (yet to be done))
It follows that Named-Readtables is a facility for using readtables in
a localized way.
Additionally, it also attempts to become a facility for using
readtables in a *modular* way. In particular:
- it provides a macro to specify the content of a readtable at a
glance;
- it makes it possible to use multiple inheritance between readtables.
### 2.1 Links
Here is the [official repository][named-readtables-repo] and the
[HTML documentation][named-readtables-doc] for the latest version.
[named-readtables-repo]: https://github.com/melisgl/named-readtables
[named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html
### 2.2 Acknowledgements
Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
Botta, David Crawford, and Pascal Costanza for being early adopters,
providing comments and bugfixes.
## 3 Overview
### 3.1 Notes on the API
The API heavily imitates the API of packages. This has the nice
property that any experienced Common Lisper will take it up without
effort.
DEFREADTABLE - DEFPACKAGE
IN-READTABLE - IN-PACKAGE
MERGE-READTABLES-INTO - USE-PACKAGE
MAKE-READTABLE - MAKE-PACKAGE
UNREGISTER-READTABLE - DELETE-PACKAGE
RENAME-READTABLE - RENAME-PACKAGE
FIND-READTABLE - FIND-PACKAGE
READTABLE-NAME - PACKAGE-NAME
LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES
### 3.2 Important API idiosyncrasies
There are three major differences between the API of Named-Readtables,
and the API of packages.
1. Readtable names are symbols not strings.
Time has shown that the fact that packages are named by strings
causes severe headache because of the potential of package names
colliding with each other.
Hence, readtables are named by symbols lest to make the
situation worse than it already is. Consequently, readtables
named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can
happily coexist next to each other. Or, taken to an extreme,
`SCHEME:SYNTAX` and `ELISP:SYNTAX`.
If, for example to duly signify the importance of your cool
readtable hack, you really think it deserves a global name, you
can always resort to keywords.
2. The inheritance is resolved statically, not dynamically.
A package that uses another package will have access to all the
other package's exported symbols, even to those that will be
added after its definition. I.e. the inheritance is resolved at
run-time, that is dynamically.
Unfortunately, we cannot do the same for readtables in a
portable manner.
Therefore, we do not talk about "using" another readtable but
about "merging" the other readtable's definition into the
readtable we are going to define. I.e. the inheritance is
resolved once at definition time, that is statically.
(Such merging can more or less be implemented portably albeit at
a certain cost. Most of the time, this cost manifests itself at
the time a readtable is defined, i.e. once at compile-time, so
it may not bother you. Nonetheless, we provide extra support for
Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your
implementation of choice are welcome, of course.)
3. [`DEFREADTABLE`][8b94] does not have compile-time effects.
If you define a package via `DEFPACKAGE`, you can make that
package the currently active package for the subsequent
compilation of the same file via `IN-PACKAGE`. The same is,
however, not true for [`DEFREADTABLE`][8b94] and [`IN-READTABLE`][de3b] for the
following reason:
It's unlikely that the need for special reader-macros arises for
a problem which can be solved in just one file. Most often,
you're going to define the reader macro functions, and set up
the corresponding readtable in an extra file.
If [`DEFREADTABLE`][8b94] had compile-time effects, you'd have to wrap
each definition of a reader-macro function in an `EVAL-WHEN` to
make its definition available at compile-time. Because that's
simply not the common case, [`DEFREADTABLE`][8b94] does not have a
compile-time effect.
If you want to use a readtable within the same file as its
definition, wrap the [`DEFREADTABLE`][8b94] and the reader-macro function
definitions in an explicit `EVAL-WHEN`.
### 3.3 Preregistered Readtables
- `NIL`, `:STANDARD`, and `:COMMON-LISP` designate the
*standard readtable*.
- `:MODERN` designates a *case-preserving* *standard-readtable*.
- `:CURRENT` designates the *current readtable*.
### 3.4 Examples
```commonlisp
(defreadtable elisp:syntax
(:merge :standard)
(:macro-char #\? #'elisp::read-character-literal t)
(:macro-char #\[ #'elisp::read-vector-literal t)
...
(:case :preserve))
(defreadtable scheme:syntax
(:merge :standard)
(:macro-char #\[ #'(lambda (stream char)
(read-delimited-list #\] stream)))
(:macro-char #\# :dispatch)
(:dispatch-macro-char #\# #\t #'scheme::read-#t)
(:dispatch-macro-char #\# #\f #'scheme::read-#f)
...
(:case :preserve))
(in-readtable elisp:syntax)
...
(in-readtable scheme:syntax)
...
```
## 4 Reference
- [macro] **DEFREADTABLE** *NAME &BODY OPTIONS*
Define a new named readtable, whose name is given by the symbol `NAME`.
Or, if a readtable is already registered under that name, redefine
that one.
The readtable can be populated using the following `OPTIONS`:
- `(:MERGE READTABLE-DESIGNATORS+)`
Merge the readtables designated into the new readtable being
defined as per [`MERGE-READTABLES-INTO`][77fa].
If no `:MERGE` clause is given, an empty readtable is used. See
[`MAKE-READTABLE`][958e].
- `(:FUSE READTABLE-DESIGNATORS+)`
Like `:MERGE` except:
Error conditions of type [`READER-MACRO-CONFLICT`][acb7] that are signaled
during the merge operation will be silently *continued*. It
follows that reader macros in earlier entries will be
overwritten by later ones. For backward compatibility, `:FUZE` is
accepted as an alias of `:FUSE`.
- `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)`
Define a new sub character `SUB-CHAR` for the dispatching macro
character `MACRO-CHAR`, per `SET-DISPATCH-MACRO-CHARACTER`. You
probably have to define `MACRO-CHAR` as a dispatching macro
character by the following option first.
- `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])`
Define a new macro character in the readtable, per
`SET-MACRO-CHARACTER`. If `FUNCTION` is the keyword `:DISPATCH`,
`MACRO-CHAR` is made a dispatching macro character, per
`MAKE-DISPATCH-MACRO-CHARACTER`.
- `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)`
Set the character syntax of `TO-CHAR` in the readtable being
defined to the same syntax as `FROM-CHAR` as per
`SET-SYNTAX-FROM-CHAR`.
- `(:CASE CASE-MODE)`
Defines the *case sensitivity mode* of the resulting readtable.
Any number of option clauses may appear. The options are grouped by
their type, but in each group the order the options appeared
textually is preserved. The following groups exist and are executed
in the following order: `:MERGE` and `:FUSE` (one
group), `:CASE`, `:MACRO-CHAR` and `:DISPATCH-MACRO-CHAR` (one group),
finally `:SYNTAX-FROM`.
Notes:
The readtable is defined at load-time. If you want to have it
available at compilation time -- say to use its reader-macros in the
same file as its definition -- you have to wrap the [`DEFREADTABLE`][8b94]
form in an explicit `EVAL-WHEN`.
On redefinition, the target readtable is made empty first before
it's refilled according to the clauses.
`NIL`, `:STANDARD`, `:COMMON-LISP`, `:MODERN`, and `:CURRENT` are
preregistered readtable names.
- [macro] **IN-READTABLE** *NAME*
Set `*READTABLE*` to the readtable referred to by the symbol `NAME`.
- [function] **MAKE-READTABLE** *&OPTIONAL (NAME NIL NAME-SUPPLIED-P) &KEY MERGE*
Creates and returns a new readtable under the specified
`NAME`.
`MERGE` takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
readtables the new readtable is created from. (See the `:MERGE` clause
of [`DEFREADTABLE`][8b94] for details.)
If `MERGE` is `NIL`, an empty readtable is used instead.
If `NAME` is not given, an anonymous empty readtable is returned.
Notes:
An empty readtable is a readtable where each character's syntax is
the same as in the *standard readtable* except that each macro
character has been made a constituent. Basically: whitespace stays
whitespace, everything else is constituent.
- [function] **MERGE-READTABLES-INTO** *RESULT-READTABLE &REST NAMED-READTABLES*
Copy the contents of each readtable in `NAMED-READTABLES`([`0`][] [`1`][9b5b]) into
`RESULT-READTABLE`.
If a macro character appears in more than one of the readtables,
i.e. if a conflict is discovered during the merge, an error of type
[`READER-MACRO-CONFLICT`][acb7] is signaled.
- [function] **FIND-READTABLE** *NAME*
Looks for the readtable specified by `NAME` and returns it if it is
found. Returns `NIL` otherwise.
- [function] **ENSURE-READTABLE** *NAME &OPTIONAL (DEFAULT NIL DEFAULT-P)*
Looks up the readtable specified by `NAME` and returns it if it's found.
If it is not found, it registers the readtable designated by `DEFAULT`
under the name represented by NAME; or if no default argument is
given, it signals an error of type [`READTABLE-DOES-NOT-EXIST`][437a]
instead.
- [function] **RENAME-READTABLE** *OLD-NAME NEW-NAME*
Replaces the associated name of the readtable designated by
`OLD-NAME` with `NEW-NAME`. If a readtable is already registered under
`NEW-NAME`, an error of type [`READTABLE-DOES-ALREADY-EXIST`][4b51] is
signaled.
- [function] **READTABLE-NAME** *NAMED-READTABLE*
Returns the name of the readtable designated by `NAMED-READTABLE`,
or `NIL`.
- [function] **REGISTER-READTABLE** *NAME READTABLE*
Associate `READTABLE` with `NAME`. Returns the readtable.
- [function] **UNREGISTER-READTABLE** *NAMED-READTABLE*
Remove the association of `NAMED-READTABLE`. Returns `T` if successfull,
`NIL` otherwise.
- [function] **COPY-NAMED-READTABLE** *NAMED-READTABLE*
Like `COPY-READTABLE` but takes a [`NAMED-READTABLE-DESIGNATOR`][fa0c] as argument.
- [function] **LIST-ALL-NAMED-READTABLES**
Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates.
- [type] **NAMED-READTABLE-DESIGNATOR**
Either a symbol or a readtable itself.
- [condition] **READER-MACRO-CONFLICT** *READTABLE-ERROR*
Continuable.
This condition is signaled during the merge process if a reader
macro (be it a macro character or the sub character of a dispatch
macro character) is present in the both source and the target
readtable and the two respective reader macro functions differ.
- [condition] **READTABLE-DOES-ALREADY-EXIST** *READTABLE-ERROR*
Continuable.
- [condition] **READTABLE-DOES-NOT-EXIST** *READTABLE-ERROR*
[059d]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-ACKNOWLEDGEMENTS-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-ACKNOWLEDGEMENTS MGL-PAX:SECTION)"
[0bc2]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-OVERVIEW-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-OVERVIEW MGL-PAX:SECTION)"
[373d]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-REFERENCE-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-REFERENCE MGL-PAX:SECTION)"
[437a]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AREADTABLE-DOES-NOT-EXIST-20CONDITION-29 "(EDITOR-HINTS.NAMED-READTABLES:READTABLE-DOES-NOT-EXIST CONDITION)"
[4b51]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AREADTABLE-DOES-ALREADY-EXIST-20CONDITION-29 "(EDITOR-HINTS.NAMED-READTABLES:READTABLE-DOES-ALREADY-EXIST CONDITION)"
[58c6]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-PREREGISTERED-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-PREREGISTERED MGL-PAX:SECTION)"
[62b8]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-API-IDIOSYNCRASIES-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-API-IDIOSYNCRASIES MGL-PAX:SECTION)"
[6faf]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-INTRODUCTION-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-INTRODUCTION MGL-PAX:SECTION)"
[77fa]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AMERGE-READTABLES-INTO-20FUNCTION-29 "(EDITOR-HINTS.NAMED-READTABLES:MERGE-READTABLES-INTO FUNCTION)"
[8688]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-LINKS-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-LINKS MGL-PAX:SECTION)"
[8b94]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3ADEFREADTABLE-20-28MGL-PAX-3AMACRO-29-29 "(EDITOR-HINTS.NAMED-READTABLES:DEFREADTABLE (MGL-PAX:MACRO))"
[958e]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AMAKE-READTABLE-20FUNCTION-29 "(EDITOR-HINTS.NAMED-READTABLES:MAKE-READTABLE FUNCTION)"
[9b5b]: #x-28-22named-readtables-22-20ASDF-2FSYSTEM-3ASYSTEM-29 "(\"named-readtables\" ASDF/SYSTEM:SYSTEM)"
[acb7]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AREADER-MACRO-CONFLICT-20CONDITION-29 "(EDITOR-HINTS.NAMED-READTABLES:READER-MACRO-CONFLICT CONDITION)"
[cf94]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-EXAMPLES-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-EXAMPLES MGL-PAX:SECTION)"
[de3b]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AIN-READTABLE-20-28MGL-PAX-3AMACRO-29-29 "(EDITOR-HINTS.NAMED-READTABLES:IN-READTABLE (MGL-PAX:MACRO))"
[e4cd]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-API-NOTES-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-API-NOTES MGL-PAX:SECTION)"
[fa0c]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3ANAMED-READTABLE-DESIGNATOR-20-28TYPE-29-29 "(EDITOR-HINTS.NAMED-READTABLES:NAMED-READTABLE-DESIGNATOR (TYPE))"
* * *
###### \[generated by [MGL-PAX](https://github.com/melisgl/mgl-pax)\]
abcl-src-1.9.0/contrib/named-readtables/doc/named-readtables.html 0100644 0000000 0000000 00000105067 14202767264 023434 0 ustar 00 0000000 0000000
EDITOR-HINTS.NAMED-READTABLES - 0.9
EDITOR-HINTS.NAMED-READTABLES - 0.9
by Tobias C Rittweiler
Repository:
darcs get http://common-lisp.net/project/editor-hints/darcs/named-readtables/
Download:
editor-hints.named-readtables-0.9.tar.gz
- What are Named-Readtables?
- Notes on the API
- Important API idiosyncrasies
- Preregistered Readtables
- Examples
- Acknowledgements
- Dictionary
COPY-NAMED-READTABLE
DEFREADTABLE
ENSURE-READTABLE
FIND-READTABLE
IN-READTABLE
LIST-ALL-NAMED-READTABLES
MAKE-READTABLE
MERGE-READTABLES-INTO
NAMED-READTABLE-DESIGNATOR
READER-MACRO-CONFLICT
READTABLE-DOES-ALREADY-EXIST
READTABLE-DOES-NOT-EXIST
READTABLE-NAME
REGISTER-READTABLE
RENAME-READTABLE
UNREGISTER-READTABLE
Named-Readtables is a library that provides a namespace for readtables akin to the
already-existing namespace of packages. In particular:
- you can associate readtables with names, and retrieve readtables by names;
- you can associate source files with readtable names, and be sure that the right readtable is
active when compiling/loading the file;
- similiarly, your development environment now has a chance to automatically determine what
readtable should be active while processing source forms on interactive commands. (E.g. think
of `C-c C-c' in Slime [yet to be done])
Additionally, it also attempts to become a facility for using readtables in a modular way. In
particular:
- it provides a macro to specify the content of a readtable at a glance;
- it makes it possible to use multiple inheritance between readtables.
The API heavily imitates the API of packages. This has the nice property that any experienced
Common Lisper will take it up without effort.
DEFREADTABLEDEFPACKAGE
IN-READTABLEIN-PACKAGE
MERGE-READTABLES-INTOUSE-PACKAGE
MAKE-READTABLEMAKE-PACKAGE
UNREGISTER-READTABLEDELETE-PACKAGE
RENAME-READTABLERENAME-PACKAGE
FIND-READTABLEFIND-PACKAGE
READTABLE-NAMEPACKAGE-NAME
LIST-ALL-NAMED-READTABLESLIST-ALL-PACKAGES
There are three major differences between the API of Named-Readtables, and the API of packages.
1. Readtable names are symbols not strings.
Time has shown that the fact that packages are named by strings causes severe headache because of
the potential of package names colliding with each other.
Hence, readtables are named by symbols lest to make the situation worse than it already is.
Consequently, readtables named CL-ORACLE:SQL-SYNTAX and CL-MYSQL:SQL-SYNTAX can happily coexist
next to each other. Or, taken to an extreme, SCHEME:SYNTAX and ELISP:SYNTAX.
If, for example to duly signify the importance of your cool readtable hack, you really think it
deserves a global name, you can always resort to keywords.
2. The inheritance is resolved statically, not dynamically.
A package that uses another package will have access to all the other package's exported
symbols, even to those that will be added after its definition. I.e. the inheritance is resolved at
run-time, that is dynamically.
Unfortunately, we cannot do the same for readtables in a portable manner.
Therefore, we do not talk about "using" another readtable but about "merging"
the other readtable's definition into the readtable we are going to define. I.e. the
inheritance is resolved once at definition time, that is statically.
(Such merging can more or less be implemented portably albeit at a certain cost. Most of the time,
this cost manifests itself at the time a readtable is defined, i.e. once at compile-time, so it may
not bother you. Nonetheless, we provide extra support for Sbcl, ClozureCL, and AllegroCL at the
moment. Patches for your implementation of choice are welcome, of course.)
3. DEFREADTABLE
If you define a package via DEFPACKAGE,
the subsequent compilation of the same file via IN-PACKAGE.
DEFREADTABLEIN-READTABLE
It's unlikely that the need for special reader-macros arises for a problem which can be
solved in just one file. Most often, you're going to define the reader macro functions, and
set up the corresponding readtable in an extra file.
If DEFREADTABLE
reader-macro function in an EVAL-WHEN
that's simply not the common case, DEFREADTABLE
If you want to use a readtable within the same file as its definition, wrap the DEFREADTABLE
the reader-macro function definitions in an explicit EVAL-WHEN.
- NIL, :STANDARD, and :COMMON-LISP designate the standard readtable.
- :MODERN designates a case-preserving standard-readtable.
- :CURRENT designates the current readtable.
(defreadtable elisp:syntax
(:merge :standard)
(:macro-char #\? #'elisp::read-character-literal t)
(:macro-char #\[ #'elisp::read-vector-literal t)
...
(:case :preserve))
(defreadtable scheme:syntax
(:merge :standard)
(:macro-char #\[ #'(lambda (stream char)
(read-delimited-list #\] stream)))
(:macro-char #\# :dispatch)
(:dispatch-macro-char #\# #\t #'scheme::read-#t)
(:dispatch-macro-char #\# #\f #'scheme::read-#f)
...
(:case :preserve))
(in-readtable elisp:syntax)
...
(in-readtable scheme:syntax)
...
Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart Botta, David Crawford, and Pascal
Costanza for being early adopters, providing comments and bugfixes.
[Function]
copy-named-readtable named-readtable => result
Argument and Values:
named-readtable: (OR
READTABLE
SYMBOL)
result: READTABLE
Description:
Like COPY-READTABLENAMED-READTABLE-DESIGNATOR
[Macro]
defreadtable name &body options => result
Description:
Define a new named readtable, whose name is given by the symbol name. Or, if a readtable is
already registered under that name, redefine that one.
The readtable can be populated using the following options:
(:MERGE readtable-designators+)
Merge the readtables designated into the new readtable being defined as per MERGE-READTABLES-INTO.
If no :MERGE clause is given, an empty readtable is used. See MAKE-READTABLE.
(:FUZE readtable-designators+)
Like :MERGE except:
Error conditions of type READER-MACRO-CONFLICT
be silently continued. It follows that reader macros in earlier entries will be overwritten by
later ones.
(:DISPATCH-MACRO-CHAR macro-char sub-char function)
Define a new sub character sub-char for the dispatching macro character macro-char,
per SET-DISPATCH-MACRO-CHARACTER.
macro character by the following option first.
(:MACRO-CHAR macro-char function [non-terminating-p])
Define a new macro character in the readtable, per SET-MACRO-CHARACTER.
keyword :DISPATCH, macro-char is made a dispatching macro character, per
MAKE-DISPATCH-MACRO-CHARACTER.
(:SYNTAX-FROM from-readtable-designator from-char to-char)
Set the character syntax of to-char in the readtable being defined to the same syntax as
from-char as per SET-SYNTAX-FROM-CHAR.
(:CASE case-mode)
Defines the case sensitivity mode of the resulting readtable.
Any number of option clauses may appear. The options are grouped by their type, but in each group
the order the options appeared textually is preserved. The following groups exist and are executed
in the following order: :MERGE and :FUZE (one group), :CASE, :MACRO-CHAR and :DISPATCH-MACRO-CHAR
(one group), finally :SYNTAX-FROM.
Notes:
The readtable is defined at load-time. If you want to have it available at compilation time --
to use its reader-macros in the same file as its definition --DEFREADTABLE
form in an explicit EVAL-WHEN.
On redefinition, the target readtable is made empty first before it's refilled according to
the clauses.
NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are preregistered readtable names.
[Function]
ensure-readtable name &optional default => result
Argument and Values:
name: (OR
READTABLE
SYMBOL)
default: (OR
READTABLE
SYMBOL)
result: READTABLE
Description:
Looks up the readtable specified by name and returns it if it's found. If it is not
found, it registers the readtable designated by default under the name represented by
name; or if no default argument is given, it signals an error of type
READTABLE-DOES-NOT-EXIST
[Function]
find-readtable name => result
Argument and Values:
name: (OR
READTABLE
SYMBOL)
result: (OR
READTABLE
NULL)
Description:
Looks for the readtable specified by name and returns it if it is found. Returns NIL
otherwise.
[Macro]
in-readtable name => result
Description:
Set *READTABLE*
[Function]
list-all-named-readtables => result
Argument and Values:
result: LIST
Description:
Returns a list of all registered readtables. The returned list is guaranteed to be fresh, but may
contain duplicates.
[Function]
make-readtable &optional name &key merge => result
Argument and Values:
name: (OR
READTABLE
SYMBOL)
merge: LIST
result: READTABLE
Description:
Creates and returns a new readtable under the specified name.
merge takes a list of NAMED-READTABLE-DESIGNATORS
readtable is created from. (See the :MERGE clause of DEFREADTABLE
If merge is NIL, an empty readtable is used instead.
If name is not given, an anonymous empty readtable is returned.
Notes:
An empty readtable is a readtable where each character's syntax is the same as in the
standard readtable except that each macro character has been made a constituent. Basically:
whitespace stays whitespace, everything else is constituent.
[Function]
merge-readtables-into result-readtable &rest named-readtables => result
Argument and Values:
result-readtable: (OR
READTABLE
SYMBOL)
named-readtables: (OR
READTABLE
SYMBOL)
result: READTABLE
Description:
Copy the contents of each readtable in named-readtables into result-table.
If a macro character appears in more than one of the readtables, i.e. if a conflict is discovered
during the merge, an error of type READER-MACRO-CONFLICT
[Type]
named-readtable-designator
Description:
Either a symbol or a readtable itself.
[Condition type]
reader-macro-conflict
Description:
Continuable.
This condition is signaled during the merge process if a) a reader macro (be it a macro character
or the sub character of a dispatch macro character) is both present in the source as well as the
target readtable, and b) if and only if the two respective reader macro functions differ.
[Condition type]
readtable-does-already-exist
Description:
Continuable.
[Condition type]
readtable-does-not-exist
[Function]
readtable-name named-readtable => result
Argument and Values:
named-readtable: (OR
READTABLE
SYMBOL)
result: SYMBOL
Description:
Returns the name of the readtable designated by named-readtable, or NIL.
[Function]
register-readtable name readtable => result
Argument and Values:
name: SYMBOL
readtable: READTABLE
result: READTABLE
Description:
Associate readtable with name. Returns the readtable.
[Function]
rename-readtable old-name new-name => result
Argument and Values:
old-name: (OR
READTABLE
SYMBOL)
new-name: SYMBOL
result: READTABLE
Description:
Replaces the associated name of the readtable designated by old-name with new-name.
If a readtable is already registered under new-name, an error of type
READTABLE-DOES-ALREADY-EXIST
[Function]
unregister-readtable named-readtable => result
Argument and Values:
named-readtable: (OR
READTABLE
SYMBOL)
result: (MEMBER
T
NIL)
Description:
Remove the association of named-readtable. Returns TNIL otherwise.
This documentation was generated on 2009-11-5 from a Lisp image using some home-brewn,
duct-taped,
evolutionary hacked extension of Edi Weitz'
DOCUMENTATION-TEMPLATE.
abcl-src-1.9.0/contrib/named-readtables/named-readtables.asd 0100644 0000000 0000000 00000003172 14202767264 022464 0 ustar 00 0000000 0000000 ;;;; -*- mode: Lisp -*-
(in-package :asdf)
(defclass named-readtables-source-file (cl-source-file) ())
#+sbcl
(defmethod perform :around ((o compile-op)
(c named-readtables-source-file))
(let ((sb-ext:*derive-function-types* t))
(call-next-method)))
(defsystem "named-readtables"
:description "Library that creates a namespace for named readtable
akin to the namespace of packages."
:author "Tobias C. Rittweiler "
:maintainer "Gábor Melis"
:mailto "mega@retes.hu"
:version "0.9"
:licence "BSD, see LICENSE"
:default-component-class named-readtables-source-file
:pathname "src"
:serial t
:components ((:file "package")
(:file "utils")
(:file "define-api")
(:file "cruft")
(:file "named-readtables"))
:in-order-to ((test-op (test-op "named-readtables/test"))))
(defsystem "named-readtables/test"
:description "Test suite for the Named-Readtables library."
:author "Tobias C. Rittweiler "
:maintainer "Gábor Melis"
:mailto "mega@retes.hu"
:depends-on ("named-readtables")
:pathname "test"
:serial t
:default-component-class named-readtables-source-file
:components
((:file "package")
(:file "rt")
(:file "tests"))
:perform (test-op (o c) (symbol-call :named-readtables-test '#:do-tests)))
;;; MGL-PAX depends on NAMED-READTABLES so we must put documentation
;;; in a separate system in order to be able to use MGL-PAX.
(defsystem "named-readtables/doc"
:depends-on ("named-readtables" "mgl-pax")
:pathname "src"
:components ((:file "doc")))
abcl-src-1.9.0/contrib/named-readtables/src/cruft.lisp 0100644 0000000 0000000 00000042037 14202767264 021411 0 ustar 00 0000000 0000000 ;;;;
;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler
;;;;
;;;; All rights reserved.
;;;;
;;;; See LICENSE for details.
;;;;
(in-package :editor-hints.named-readtables)
(defmacro define-cruft (name lambda-list &body (docstring . alternatives))
(assert (typep docstring 'string) (docstring) "Docstring missing!")
(assert (not (null alternatives)))
`(progn
(declaim (inline ,name))
(defun ,name ,lambda-list ,docstring ,(first alternatives))))
(eval-when (:compile-toplevel :execute)
#+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"
(find-package "SB-IMPL"))
(pushnew :sbcl+safe-standard-readtable *features*)))
;;;;; Implementation-dependent cruft
;;;; Mapping between a readtable object and its readtable-name.
(defvar *readtable-names* (make-hash-table :test 'eq))
(define-cruft %associate-readtable-with-name (name readtable)
"Associate READTABLE with NAME for READTABLE-NAME to work."
#+ :common-lisp (setf (gethash readtable *readtable-names*) name))
(define-cruft %unassociate-readtable-from-name (name readtable)
"Remove the association between READTABLE and NAME."
#+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*)))
(remhash readtable *readtable-names*)))
(define-cruft %readtable-name (readtable)
"Return the name associated with READTABLE."
#+ :common-lisp (values (gethash readtable *readtable-names*)))
(define-cruft %list-all-readtable-names ()
"Return a list of all available readtable names."
#+ :common-lisp (list* :standard :current
(loop for name being each hash-value of *readtable-names*
collect name)))
;;;; Mapping between a readtable-name and the actual readtable object.
;;; On Allegro we reuse their named-readtable support so we work
;;; nicely on their infrastructure.
#-allegro
(defvar *named-readtables* (make-hash-table :test 'eq))
#+allegro
(defun readtable-name-for-allegro (symbol)
(multiple-value-bind (kwd status)
(if (keywordp symbol)
(values symbol nil)
;; Kludge: ACL uses keywords to name readtables, we allow
;; arbitrary symbols.
(intern (format nil "~A.~A"
(package-name (symbol-package symbol))
(symbol-name symbol))
:keyword))
(prog1 kwd
(assert (or (not status) (get kwd 'named-readtable-designator)))
(setf (get kwd 'named-readtable-designator) t))))
(define-cruft %associate-name-with-readtable (name readtable)
"Associate NAME with READTABLE for FIND-READTABLE to work."
#+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable)
#+ :common-lisp (setf (gethash name *named-readtables*) readtable))
(define-cruft %unassociate-name-from-readtable (name readtable)
"Remove the association between NAME and READTABLE"
#+ :allegro (let ((n (readtable-name-for-allegro name)))
(assert (eq readtable (excl:named-readtable n)))
(setf (excl:named-readtable n) nil))
#+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*)))
(remhash name *named-readtables*)))
(define-cruft %find-readtable (name)
"Return the readtable named NAME."
#+ :allegro (excl:named-readtable (readtable-name-for-allegro name) nil)
#+ :common-lisp (values (gethash name *named-readtables* nil)))
;;;; Reader-macro related predicates
;;; CLISP creates new function objects for standard reader macros on
;;; each readtable copy.
(define-cruft function= (fn1 fn2)
"Are reader-macro function-designators FN1 and FN2 the same?"
#+ :clisp
(let* ((fn1 (ensure-function fn1))
(fn2 (ensure-function fn2))
(n1 (system::function-name fn1))
(n2 (system::function-name fn2)))
(if (and (eq n1 :lambda) (eq n2 :lambda))
(eq fn1 fn2)
(equal n1 n2)))
#+ :sbcl
(let ((fn1 (ensure-function fn1))
(fn2 (ensure-function fn2)))
(or (eq fn1 fn2)
;; After SBCL 1.1.18, for dispatch macro characters
;; GET-MACRO-CHARACTER returns closures whose name is:
;;
;; (LAMBDA (STREAM CHAR) :IN SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR)
;;
;; Treat all these closures equivalent.
(flet ((internal-dispatch-macro-closure-name-p (name)
(find "SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR" name
:key #'prin1-to-string :test #'string-equal)))
(let ((n1 (sb-impl::%fun-name fn1))
(n2 (sb-impl::%fun-name fn2)))
(and (listp n1) (listp n2)
(internal-dispatch-macro-closure-name-p n1)
(internal-dispatch-macro-closure-name-p n2))))))
#+ :common-lisp
(eq (ensure-function fn1) (ensure-function fn2)))
;;; CLISP will incorrectly fold the call to G-D-M-C away
;;; if not declared inline.
(define-cruft dispatch-macro-char-p (char rt)
"Is CHAR a dispatch macro character in RT?"
#+ :common-lisp
(handler-case (locally
#+clisp (declare (notinline get-dispatch-macro-character))
(get-dispatch-macro-character char #\x rt)
t)
(error () nil)))
;; (defun macro-char-p (char rt)
;; (let ((reader-fn (%get-macro-character char rt)))
;; (and reader-fn t)))
;; (defun standard-macro-char-p (char rt)
;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)
;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*)
;; (and (eq rt-fn std-fn)
;; (eq rt-flag std-flag)))))
;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt)
;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt))))
;; (and (eq (non-terminating-p disp-char rt)
;; (non-terminating-p disp-char *standard-readtable*))
;; (eq (get-dispatch-macro-character disp-char sub-char rt)
;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))
;;;; Readtables Iterators
(defmacro with-readtable-iterator ((name readtable) &body body)
(let ((it (gensym)))
`(let ((,it (%make-readtable-iterator ,readtable)))
(macrolet ((,name () `(funcall ,',it)))
,@body))))
#+sbcl
(defun %make-readtable-iterator (readtable)
(let ((char-macro-array (sb-impl::character-macro-array readtable))
(char-macro-ht (sb-impl::character-macro-hash-table readtable))
(dispatch-tables (sb-impl::dispatch-tables readtable))
(char-code 0))
(with-hash-table-iterator (ht-iterator char-macro-ht)
(labels ((grovel-base-chars ()
(if (>= char-code sb-int:base-char-code-limit)
(grovel-unicode-chars)
(let ((reader-fn (svref char-macro-array char-code))
(char (code-char (shiftf char-code (1+ char-code)))))
(if reader-fn
(yield char)
(grovel-base-chars)))))
(grovel-unicode-chars ()
(multiple-value-bind (more? char) (ht-iterator)
(if (not more?)
(values nil nil nil nil nil)
(yield char))))
(yield (char)
(let ((disp-fn (get-macro-character char readtable))
(disp-ht))
(cond
((setq disp-ht (cdr (assoc char dispatch-tables)))
(let ((sub-char-alist))
(maphash (lambda (k v)
(push (cons k v) sub-char-alist))
disp-ht)
(values t char disp-fn t sub-char-alist)))
(t
(values t char disp-fn nil nil))))))
#'grovel-base-chars))))
#+clozure
(defun %make-readtable-iterator (readtable)
(flet ((ensure-alist (x)
#.`(etypecase x
(list x)
,@(uiop:if-let (sv (uiop:find-symbol* '#:sparse-vector :ccl nil))
`((,sv
(let ((table (uiop:symbol-call :ccl '#:sparse-vector-table x)))
(uiop:while-collecting (c)
(loop for i below (length table) do
(uiop:if-let ((v (svref table i)))
(loop with i8 = (ash i 8)
for j below (length v) do
(uiop:if-let ((datum (svref v j)))
(c (cons (code-char (+ i8 j)) datum))))))))))))))
(let ((char-macros
(ensure-alist
(#.(or (uiop:find-symbol* '#:rdtab.macros :ccl nil) (uiop:find-symbol* '#:rdtab.alist :ccl)) readtable))))
(lambda ()
(if char-macros
(destructuring-bind (char . defn) (pop char-macros)
(if (consp defn)
(values t char (car defn) t (ensure-alist (cdr defn)))
(values t char defn nil nil)))
(values nil nil nil nil nil))))))
;;; Written on ACL 8.0.
#+allegro
(defun %make-readtable-iterator (readtable)
(declare (optimize speed)) ; for TCO
(check-type readtable readtable)
(let* ((macro-table (first (excl::readtable-macro-table readtable)))
(dispatch-tables (excl::readtable-dispatch-tables readtable))
(table-length (length macro-table))
(idx 0))
(labels ((grovel-macro-chars ()
(if (>= idx table-length)
(grovel-dispatch-chars)
(let ((read-fn (svref macro-table idx))
(oidx idx))
(incf idx)
(if (or (eq read-fn #'excl::read-token)
(eq read-fn #'excl::read-dispatch-char)
(eq read-fn #'excl::undefined-macro-char))
(grovel-macro-chars)
(values t (code-char oidx) read-fn nil nil)))))
(grovel-dispatch-chars ()
(if (null dispatch-tables)
(values nil nil nil nil nil)
(destructuring-bind (disp-char sub-char-table)
(first dispatch-tables)
(setf dispatch-tables (rest dispatch-tables))
;;; Kludge. We can't fully clear dispatch tables
;;; in %CLEAR-READTABLE.
(when (eq (svref macro-table (char-code disp-char))
#'excl::read-dispatch-char)
(values t
disp-char
(svref macro-table (char-code disp-char))
t
(loop for subch-fn across sub-char-table
for subch-code from 0
when subch-fn
collect (cons (code-char subch-code)
subch-fn))))))))
#'grovel-macro-chars)))
#-(or sbcl clozure allegro)
(eval-when (:compile-toplevel)
(let ((*print-pretty* t))
(simple-style-warn
"~&~@< ~@;~A has not been ported to ~A. ~
We fall back to a portable implementation of readtable iterators. ~
This implementation has to grovel through all available characters. ~
On Unicode-aware implementations this may come with some costs.~@:>"
(package-name '#.*package*) (lisp-implementation-type))))
#-(or sbcl clozure allegro)
(defun %make-readtable-iterator (readtable)
(check-type readtable readtable)
(let ((char-code 0))
#'(lambda ()
(prog ()
:GROVEL
(when (< char-code char-code-limit)
(let ((char (code-char char-code)))
(incf char-code)
(when (not char) (go :GROVEL))
(let ((fn (get-macro-character char readtable)))
(when (not fn) (go :GROVEL))
(multiple-value-bind (disp? alist)
(handler-case ; grovel dispatch macro characters.
(values
t
;; Only grovel upper case characters to
;; avoid duplicates.
(loop for code from 0 below char-code-limit
for subchar = (non-lowercase-code-char code)
for disp-fn = (and subchar
(get-dispatch-macro-character
char subchar readtable))
when disp-fn
collect (cons subchar disp-fn)))
(error () nil))
(return (values t char fn disp? alist))))))))))
#-(or sbcl clozure allegro)
(defun non-lowercase-code-char (code)
(let ((ch (code-char code)))
(when (and ch (or (not (alpha-char-p ch))
(upper-case-p ch)))
ch)))
(defmacro do-readtable ((entry-designator readtable &optional result)
&body body)
"Iterate through a readtable's macro characters, and dispatch macro characters."
(destructuring-bind (char &optional reader-fn non-terminating-p disp? table)
(if (symbolp entry-designator)
(list entry-designator)
entry-designator)
(let ((iter (gensym "ITER+"))
(more? (gensym "MORE?+"))
(rt (gensym "READTABLE+")))
`(let ((,rt ,readtable))
(with-readtable-iterator (,iter ,rt)
(loop
(multiple-value-bind (,more?
,char
,@(when reader-fn (list reader-fn))
,@(when disp? (list disp?))
,@(when table (list table)))
(,iter)
(unless ,more? (return ,result))
(let ,(when non-terminating-p
;; FIXME: N-T-P should be incorporated in iterators.
`((,non-terminating-p
(nth-value 1 (get-macro-character ,char ,rt)))))
,@body))))))))
;;;; Misc
;;; This should return an implementation's actual standard readtable
;;; object only if the implementation makes the effort to guard against
;;; modification of that object. Otherwise it should better return a
;;; copy.
(define-cruft %standard-readtable ()
"Return the standard readtable."
#+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
#+ :common-lisp (copy-readtable nil))
;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;;; readtable's dispatch table properly.
;;; Same goes for Allegro but that does not seem to provide a
;;; setter for their readtable's dispatch tables. Hence this ugly
;;; workaround.
(define-cruft %clear-readtable (readtable)
"Make all macro characters in READTABLE be constituents."
#+ :sbcl
(prog1 readtable
(do-readtable (char readtable)
(set-syntax-from-char char #\A readtable))
(setf (sb-impl::dispatch-tables readtable) nil))
#+ :allegro
(prog1 readtable
(do-readtable (char readtable)
(set-syntax-from-char char #\A readtable))
(let ((dispatch-tables (excl::readtable-dispatch-tables readtable)))
(setf (cdr dispatch-tables) nil)
(setf (caar dispatch-tables) #\Backspace)
(setf (cadar dispatch-tables) (fill (cadar dispatch-tables) nil))))
#+ :common-lisp
(do-readtable (char readtable readtable)
(set-syntax-from-char char #\A readtable)))
;;; See Clozure Trac Ticket 601. This is supposed to be removed at
;;; some point in the future.
(define-cruft %get-dispatch-macro-character (char subchar rt)
"Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER."
#+ :ccl (ignore-errors
(get-dispatch-macro-character char subchar rt))
#+ :common-lisp (get-dispatch-macro-character char subchar rt))
;;; Allegro stores READ-TOKEN as reader macro function of each
;;; constituent character.
(define-cruft %get-macro-character (char rt)
"Ensure ANSI behaviour for GET-MACRO-CHARACTER."
#+ :allegro (let ((fn (get-macro-character char rt)))
(cond ((not fn) nil)
((function= fn #'excl::read-token) nil)
(t fn)))
#+ :common-lisp (get-macro-character char rt))
;;;; Specialized PRINT-OBJECT for named readtables.
;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT
;;; that specializes on READTABLE is actually forbidden. It's quite
;;; likely to work (modulo package-locks) on most implementations,
;;; though.
;;; We don't need this on Allegro CL's as we hook into their
;;; named-readtable facility, and they provide such a method already.
#-allegro
(without-package-lock (:common-lisp #+lispworks :implementation)
(defmethod print-object :around ((rt readtable) stream)
(let ((name (readtable-name rt)))
(if name
(print-unreadable-object (rt stream :type nil :identity t)
(format stream "~A ~S" :named-readtable name))
(call-next-method)))))
abcl-src-1.9.0/contrib/named-readtables/src/define-api.lisp 0100644 0000000 0000000 00000005543 14202767264 022270 0 ustar 00 0000000 0000000 (in-package :named-readtables)
(defmacro define-api (name lambda-list type-list &body body)
(flet ((parse-type-list (type-list)
(let ((pos (position '=> type-list)))
(assert pos () "You forgot to specify return type (`=>' missing.)")
(values (subseq type-list 0 pos)
`(values ,@(nthcdr (1+ pos) type-list) &optional)))))
(multiple-value-bind (body decls docstring)
(parse-body body :documentation t :whole `(define-api ,name))
(multiple-value-bind (arg-typespec value-typespec)
(parse-type-list type-list)
(multiple-value-bind (reqs opts rest keys)
(parse-ordinary-lambda-list lambda-list)
(declare (ignorable reqs opts rest keys))
`(progn
(declaim (ftype (function ,arg-typespec ,value-typespec) ,name))
(locally
;;; Muffle the annoying "&OPTIONAL and &KEY found in
;;; the same lambda list" style-warning
#+sbcl (declare (sb-ext:muffle-conditions style-warning))
(defun ,name ,lambda-list
,docstring
#+sbcl (declare (sb-ext:unmuffle-conditions style-warning))
,@decls
;; SBCL will interpret the ftype declaration as
;; assertion and will insert type checks for us.
#-sbcl
(progn
;; CHECK-TYPE required parameters
,@(loop for req-arg in reqs
for req-type = (pop type-list)
do (assert req-type)
collect `(check-type ,req-arg ,req-type))
;; CHECK-TYPE optional parameters
,@(loop initially (assert (or (null opts)
(eq (pop type-list) '&optional)))
for (opt-arg . nil) in opts
for opt-type = (pop type-list)
do (assert opt-type)
collect `(check-type ,opt-arg ,opt-type))
;; CHECK-TYPE rest parameter
,@(when rest
(assert (eq (pop type-list) '&rest))
(let ((rest-type (pop type-list)))
(assert rest-type)
`((dolist (x ,rest)
(check-type x ,rest-type)))))
;; CHECK-TYPE key parameters
,@(loop initially (assert (or (null keys)
(eq (pop type-list) '&key)))
for ((keyword key-arg) . nil) in keys
for (nil key-type) = (find keyword type-list :key #'car)
collect `(check-type ,key-arg ,key-type)))
,@body))))))))
abcl-src-1.9.0/contrib/named-readtables/src/doc.lisp 0100644 0000000 0000000 00000021117 14202767264 021027 0 ustar 00 0000000 0000000 (in-package :named-readtables)
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :mgl-pax))
(defsection @named-readtables-manual (:title "Named Readtables Manual")
(named-readtables asdf:system)
(@named-readtables-introduction section)
(@named-readtables-overview section)
(@named-readtables-reference section))
(defsection @named-readtables-introduction (:title "Introduction")
"Named-Readtables is a library that provides a namespace for
readtables akin to the already-existing namespace of packages. In
particular:
* you can associate readtables with names, and retrieve
readtables by names;
* you can associate source files with readtable names, and be
sure that the right readtable is active when compiling/loading
the file;
* similiarly, your development environment now has a chance to
automatically determine what readtable should be active while
processing source forms on interactive commands. (E.g. think of
`C-c C-c` in Slime (yet to be done))
It follows that Named-Readtables is a facility for using readtables in
a localized way.
Additionally, it also attempts to become a facility for using
readtables in a _modular_ way. In particular:
* it provides a macro to specify the content of a readtable at a
glance;
* it makes it possible to use multiple inheritance between readtables."
(@named-readtables-links section)
(@named-readtables-acknowledgements section))
(defsection @named-readtables-links (:title "Links")
"Here is the [official repository][named-readtables-repo] and the
[HTML documentation][named-readtables-doc] for the latest version.
[named-readtables-repo]: https://github.com/melisgl/named-readtables
[named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html")
(defsection @named-readtables-acknowledgements (:title "Acknowledgements")
"Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
Botta, David Crawford, and Pascal Costanza for being early adopters,
providing comments and bugfixes.")
(defsection @named-readtables-overview (:title "Overview")
(@named-readtables-api-notes section)
(@named-readtables-api-idiosyncrasies section)
(@named-readtables-preregistered section)
(@named-readtables-examples section))
(defsection @named-readtables-api-notes (:title "Notes on the API" :export nil)
"The API heavily imitates the API of packages. This has the nice
property that any experienced Common Lisper will take it up without
effort.
DEFREADTABLE - DEFPACKAGE
IN-READTABLE - IN-PACKAGE
MERGE-READTABLES-INTO - USE-PACKAGE
MAKE-READTABLE - MAKE-PACKAGE
UNREGISTER-READTABLE - DELETE-PACKAGE
RENAME-READTABLE - RENAME-PACKAGE
FIND-READTABLE - FIND-PACKAGE
READTABLE-NAME - PACKAGE-NAME
LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES")
(defsection @named-readtables-api-idiosyncrasies
(:title "Important API idiosyncrasies" :export nil)
"There are three major differences between the API of Named-Readtables,
and the API of packages.
1. Readtable names are symbols not strings.
Time has shown that the fact that packages are named by strings
causes severe headache because of the potential of package names
colliding with each other.
Hence, readtables are named by symbols lest to make the
situation worse than it already is. Consequently, readtables
named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can
happily coexist next to each other. Or, taken to an extreme,
`SCHEME:SYNTAX` and `ELISP:SYNTAX`.
If, for example to duly signify the importance of your cool
readtable hack, you really think it deserves a global name, you
can always resort to keywords.
2. The inheritance is resolved statically, not dynamically.
A package that uses another package will have access to all the
other package's exported symbols, even to those that will be
added after its definition. I.e. the inheritance is resolved at
run-time, that is dynamically.
Unfortunately, we cannot do the same for readtables in a
portable manner.
Therefore, we do not talk about \"using\" another readtable but
about \"merging\" the other readtable's definition into the
readtable we are going to define. I.e. the inheritance is
resolved once at definition time, that is statically.
(Such merging can more or less be implemented portably albeit at
a certain cost. Most of the time, this cost manifests itself at
the time a readtable is defined, i.e. once at compile-time, so
it may not bother you. Nonetheless, we provide extra support for
Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your
implementation of choice are welcome, of course.)
3. DEFREADTABLE does not have compile-time effects.
If you define a package via DEFPACKAGE, you can make that
package the currently active package for the subsequent
compilation of the same file via IN-PACKAGE. The same is,
however, not true for DEFREADTABLE and IN-READTABLE for the
following reason:
It's unlikely that the need for special reader-macros arises for
a problem which can be solved in just one file. Most often,
you're going to define the reader macro functions, and set up
the corresponding readtable in an extra file.
If DEFREADTABLE had compile-time effects, you'd have to wrap
each definition of a reader-macro function in an EVAL-WHEN to
make its definition available at compile-time. Because that's
simply not the common case, DEFREADTABLE does not have a
compile-time effect.
If you want to use a readtable within the same file as its
definition, wrap the DEFREADTABLE and the reader-macro function
definitions in an explicit EVAL-WHEN.")
(defsection @named-readtables-preregistered (:title "Preregistered Readtables"
:export nil)
"- NIL, :STANDARD, and :COMMON-LISP designate the
_standard readtable_.
- :MODERN designates a _case-preserving_ _standard-readtable_.
- :CURRENT designates the _current readtable_.")
(defsection @named-readtables-examples (:title "Examples" :export nil)
"```commonlisp
(defreadtable elisp:syntax
(:merge :standard)
(:macro-char #\\? #'elisp::read-character-literal t)
(:macro-char #\\[ #'elisp::read-vector-literal t)
...
(:case :preserve))
(defreadtable scheme:syntax
(:merge :standard)
(:macro-char #\\[ #'(lambda (stream char)
(read-delimited-list #\\] stream)))
(:macro-char #\\# :dispatch)
(:dispatch-macro-char #\\# #\\t #'scheme::read-#t)
(:dispatch-macro-char #\\# #\\f #'scheme::read-#f)
...
(:case :preserve))
(in-readtable elisp:syntax)
...
(in-readtable scheme:syntax)
...
```")
(defsection @named-readtables-reference (:title "Reference")
(defreadtable macro)
(in-readtable macro)
(make-readtable function)
(merge-readtables-into function)
(find-readtable function)
(ensure-readtable function)
(rename-readtable function)
(readtable-name function)
(register-readtable function)
(unregister-readtable function)
(copy-named-readtable function)
(list-all-named-readtables function)
(named-readtable-designator type)
(reader-macro-conflict condition)
(readtable-does-already-exist condition)
(readtable-does-not-exist condition))
;;;; Generating own docs
(defun update-readmes ()
(with-open-file (stream (asdf:system-relative-pathname :named-readtables
"README.md")
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(document @named-readtables-manual :stream stream)
(print-markdown-footer stream))
(with-open-file (stream (asdf:system-relative-pathname :named-readtables
"README")
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(describe @named-readtables-manual stream)
(print-markdown-footer stream)))
(defun print-markdown-footer (stream)
(format stream "~%* * *~%")
(format stream "###### \\[generated by ~
[MGL-PAX](https://github.com/melisgl/mgl-pax)\\]~%"))
#|
(update-readmes)
|#
abcl-src-1.9.0/contrib/named-readtables/src/named-readtables.lisp 0100644 0000000 0000000 00000053675 14202767264 023470 0 ustar 00 0000000 0000000 ;;;; -*- Mode:Lisp -*-
;;;;
;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler
;;;; Copyright (c) 2007, Robert P. Goldman and SIFT, LLC
;;;;
;;;; All rights reserved.
;;;;
;;;; See LICENSE for details.
;;;;
(in-package :editor-hints.named-readtables)
;;;
;;; ``This is enough of a foothold to implement a more elaborate
;;; facility for using readtables in a localized way.''
;;;
;;; (X3J13 Cleanup Issue IN-SYNTAX)
;;;
;;;;;; DEFREADTABLE &c.
(defmacro defreadtable (name &body options)
"Define a new named readtable, whose name is given by the symbol NAME.
Or, if a readtable is already registered under that name, redefine
that one.
The readtable can be populated using the following OPTIONS:
- `(:MERGE READTABLE-DESIGNATORS+)`
Merge the readtables designated into the new readtable being
defined as per MERGE-READTABLES-INTO.
If no :MERGE clause is given, an empty readtable is used. See
MAKE-READTABLE.
- `(:FUSE READTABLE-DESIGNATORS+)`
Like :MERGE except:
Error conditions of type READER-MACRO-CONFLICT that are signaled
during the merge operation will be silently _continued_. It
follows that reader macros in earlier entries will be
overwritten by later ones. For backward compatibility, :FUZE is
accepted as an alias of :FUSE.
- `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)`
Define a new sub character `SUB-CHAR` for the dispatching macro
character `MACRO-CHAR`, per SET-DISPATCH-MACRO-CHARACTER. You
probably have to define `MACRO-CHAR` as a dispatching macro
character by the following option first.
- `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])`
Define a new macro character in the readtable, per
SET-MACRO-CHARACTER. If `FUNCTION` is the keyword :DISPATCH,
`MACRO-CHAR` is made a dispatching macro character, per
MAKE-DISPATCH-MACRO-CHARACTER.
- `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)`
Set the character syntax of TO-CHAR in the readtable being
defined to the same syntax as FROM-CHAR as per
SET-SYNTAX-FROM-CHAR.
- `(:CASE CASE-MODE)`
Defines the _case sensitivity mode_ of the resulting readtable.
Any number of option clauses may appear. The options are grouped by
their type, but in each group the order the options appeared
textually is preserved. The following groups exist and are executed
in the following order: :MERGE and :FUSE (one
group), :CASE, :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group),
finally :SYNTAX-FROM.
Notes:
The readtable is defined at load-time. If you want to have it
available at compilation time -- say to use its reader-macros in the
same file as its definition -- you have to wrap the DEFREADTABLE
form in an explicit EVAL-WHEN.
On redefinition, the target readtable is made empty first before
it's refilled according to the clauses.
NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are
preregistered readtable names."
(check-type name symbol)
(when (reserved-readtable-name-p name)
(error "~A is the designator for a predefined readtable. ~
Not acceptable as a user-specified readtable name." name))
(flet ((process-option (option var)
(destructure-case option
((:merge &rest readtable-designators)
`(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)
readtable-designators)))
((:fuse &rest readtable-designators)
`(handler-bind ((reader-macro-conflict #'continue))
(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)
readtable-designators))))
;; alias for :FUSE
((:fuze &rest readtable-designators)
`(handler-bind ((reader-macro-conflict #'continue))
(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)
readtable-designators))))
((:dispatch-macro-char disp-char sub-char function)
`(set-dispatch-macro-character ,disp-char ,sub-char
,function ,var))
((:macro-char char function &optional non-terminating-p)
(if (eq function :dispatch)
`(make-dispatch-macro-character ,char ,non-terminating-p ,var)
`(set-macro-character ,char ,function
,non-terminating-p ,var)))
((:syntax-from from-rt-designator from-char to-char)
`(set-syntax-from-char ,to-char ,from-char
,var (find-readtable ,from-rt-designator)))
((:case mode)
`(setf (readtable-case ,var) ,mode))))
(remove-clauses (clauses options)
(setq clauses (if (listp clauses) clauses (list clauses)))
(remove-if-not #'(lambda (x) (member x clauses))
options :key #'first)))
(let* ((merge-clauses (remove-clauses '(:merge :fuze :fuse) options))
(case-clauses (remove-clauses :case options))
(macro-clauses (remove-clauses '(:macro-char :dispatch-macro-char)
options))
(syntax-clauses (remove-clauses :syntax-from options))
(other-clauses
(set-difference options
(append merge-clauses case-clauses
macro-clauses syntax-clauses))))
(cond
((not (null other-clauses))
(error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))
(t
`(eval-when (:load-toplevel :execute)
;; The (FIND-READTABLE ...) isqrt important for proper
;; redefinition semantics, as redefining has to modify the
;; already existing readtable object.
(let ((readtable (find-readtable ',name)))
(cond ((not readtable)
(setq readtable (make-readtable ',name)))
(t
(setq readtable (%clear-readtable readtable))
(simple-style-warn
"Overwriting already existing readtable ~S."
readtable)))
,@(loop for option in merge-clauses
collect (process-option option 'readtable))
,@(loop for option in case-clauses
collect (process-option option 'readtable))
,@(loop for option in macro-clauses
collect (process-option option 'readtable))
,@(loop for option in syntax-clauses
collect (process-option option 'readtable))
readtable)))))))
(defmacro in-readtable (name)
"Set *READTABLE* to the readtable referred to by the symbol NAME."
(check-type name symbol)
`(eval-when (:compile-toplevel :load-toplevel :execute)
;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO*
;; (GET-MACRO-CHARACTER #\"))
(setf *readtable* (ensure-readtable ',name))
(when (find-package :swank)
(%frob-swank-readtable-alist *package* *readtable*))))
;;; KLUDGE: [interim solution]
;;;
;;; We need support for this in Slime itself, because we want IN-READTABLE
;;; to work on a per-file basis, and not on a per-package basis.
;;;
(defun %frob-swank-readtable-alist (package readtable)
(let ((readtable-alist (find-symbol (string '#:*readtable-alist*)
(find-package :swank))))
(when (boundp readtable-alist)
(pushnew (cons (package-name package) readtable)
(symbol-value readtable-alist)
:test #'(lambda (entry1 entry2)
(destructuring-bind (pkg-name1 . rt1) entry1
(destructuring-bind (pkg-name2 . rt2) entry2
(and (string= pkg-name1 pkg-name2)
(eq rt1 rt2)))))))))
(deftype readtable-designator ()
`(or null readtable))
(deftype named-readtable-designator ()
"Either a symbol or a readtable itself."
`(or readtable-designator symbol))
;;;;; Compiler macros
;;; Since the :STANDARD readtable is interned, and we can't enforce
;;; its immutability, we signal a style-warning for suspicious uses
;;; that may result in strange behaviour:
;;; Modifying the standard readtable would, obviously, lead to a
;;; propagation of this change to all places which use the :STANDARD
;;; readtable (and thus rendering this readtable to be non-standard,
;;; in fact.)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun constant-standard-readtable-expression-p (thing)
(or (null thing)
(eq thing :standard)
(and (consp thing)
(find thing
'((find-readtable nil)
(find-readtable :standard)
(ensure-readtable nil)
(ensure-readtable :standard))
:test #'equal))))
(defun signal-suspicious-registration-warning (name-expr readtable-expr)
(when (constant-standard-readtable-expression-p readtable-expr)
(simple-style-warn
"Caution: ~~% ~S"
(list name-expr name-expr) readtable-expr))))
(define-compiler-macro register-readtable (&whole form name readtable)
(signal-suspicious-registration-warning name readtable)
form)
(define-compiler-macro ensure-readtable (&whole form name &optional
(default nil default-p))
(when default-p
(signal-suspicious-registration-warning name default))
form)
(declaim (special *standard-readtable* *empty-readtable*))
(define-api make-readtable
(&optional (name nil name-supplied-p) &key merge)
(&optional named-readtable-designator &key (:merge list) => readtable)
"Creates and returns a new readtable under the specified
NAME.
MERGE takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
readtables the new readtable is created from. (See the :MERGE clause
of DEFREADTABLE for details.)
If MERGE is NIL, an empty readtable is used instead.
If NAME is not given, an anonymous empty readtable is returned.
Notes:
An empty readtable is a readtable where each character's syntax is
the same as in the _standard readtable_ except that each macro
character has been made a constituent. Basically: whitespace stays
whitespace, everything else is constituent."
(cond ((not name-supplied-p)
(copy-readtable *empty-readtable*))
((reserved-readtable-name-p name)
(error "~A is the designator for a predefined readtable. ~
Not acceptable as a user-specified readtable name." name))
((let ((rt (find-readtable name)))
(and rt (prog1 nil
(cerror "Overwrite existing entry."
'readtable-does-already-exist :readtable-name name)
;; Explicitly unregister to make sure that we do
;; not hold on of any reference to RT.
(unregister-readtable rt)))))
(t (let ((result (apply #'merge-readtables-into
;; The first readtable specified in
;; the :merge list is taken as the
;; basis for all subsequent
;; (destructive!) modifications (and
;; hence it's copied.)
(copy-readtable (if merge
(ensure-readtable
(first merge))
*empty-readtable*))
(rest merge))))
(register-readtable name result)))))
(define-api rename-readtable
(old-name new-name)
(named-readtable-designator symbol => readtable)
"Replaces the associated name of the readtable designated by
OLD-NAME with NEW-NAME. If a readtable is already registered under
NEW-NAME, an error of type READTABLE-DOES-ALREADY-EXIST is
signaled."
(when (find-readtable new-name)
(cerror "Overwrite existing entry."
'readtable-does-already-exist :readtable-name new-name))
(let* ((readtable (ensure-readtable old-name))
(readtable-name (readtable-name readtable)))
;; We use the internal functions directly to omit repeated
;; type-checking.
(%unassociate-name-from-readtable readtable-name readtable)
(%unassociate-readtable-from-name readtable-name readtable)
(%associate-name-with-readtable new-name readtable)
(%associate-readtable-with-name new-name readtable)
readtable))
(define-api merge-readtables-into
(result-readtable &rest named-readtables)
(named-readtable-designator &rest named-readtable-designator => readtable)
"Copy the contents of each readtable in NAMED-READTABLES into
RESULT-READTABLE.
If a macro character appears in more than one of the readtables,
i.e. if a conflict is discovered during the merge, an error of type
READER-MACRO-CONFLICT is signaled."
(flet ((merge-into (to from)
(do-readtable ((char reader-fn non-terminating-p disp? table) from)
(check-reader-macro-conflict from to char)
(cond ((not disp?)
(set-macro-character char reader-fn non-terminating-p to))
(t
(ensure-dispatch-macro-character char non-terminating-p to)
(loop for (subchar . subfn) in table do
(check-reader-macro-conflict from to char subchar)
(set-dispatch-macro-character char subchar
subfn to)))))
to))
(let ((result-table (ensure-readtable result-readtable)))
(dolist (table (mapcar #'ensure-readtable named-readtables))
(merge-into result-table table))
result-table)))
(defun ensure-dispatch-macro-character (char &optional non-terminating-p
(readtable *readtable*))
(if (dispatch-macro-char-p char readtable)
t
(make-dispatch-macro-character char non-terminating-p readtable)))
(define-api copy-named-readtable
(named-readtable)
(named-readtable-designator => readtable)
"Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."
(copy-readtable (ensure-readtable named-readtable)))
(define-api list-all-named-readtables () (=> list)
"Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates."
(mapcar #'ensure-readtable (%list-all-readtable-names)))
(define-condition readtable-error (error) ())
(define-condition readtable-does-not-exist (readtable-error)
((readtable-name :initarg :readtable-name
:initform (required-argument)
:accessor missing-readtable-name
:type named-readtable-designator))
(:report (lambda (condition stream)
(format stream "A readtable named ~S does not exist."
(missing-readtable-name condition)))))
(define-condition readtable-does-already-exist (readtable-error)
((readtable-name :initarg :readtable-name
:initform (required-argument)
:accessor existing-readtable-name
:type named-readtable-designator))
(:report (lambda (condition stream)
(format stream "A readtable named ~S already exists."
(existing-readtable-name condition))))
(:documentation "Continuable."))
(define-condition reader-macro-conflict (readtable-error)
((macro-char
:initarg :macro-char
:initform (required-argument)
:accessor conflicting-macro-char
:type character)
(sub-char
:initarg :sub-char
:initform nil
:accessor conflicting-dispatch-sub-char
:type (or null character))
(from-readtable
:initarg :from-readtable
:initform (required-argument)
:accessor from-readtable
:type readtable)
(to-readtable
:initarg :to-readtable
:initform (required-argument)
:accessor to-readtable
:type readtable))
(:report
(lambda (condition stream)
(format stream "~@"
(conflicting-dispatch-sub-char condition)
(conflicting-macro-char condition)
(conflicting-dispatch-sub-char condition)
(from-readtable condition)
(to-readtable condition))))
(:documentation "Continuable.
This condition is signaled during the merge process if a reader
macro (be it a macro character or the sub character of a dispatch
macro character) is present in the both source and the target
readtable and the two respective reader macro functions differ."))
(defun check-reader-macro-conflict (from to char &optional subchar)
(flet ((conflictp (from-fn to-fn)
(assert from-fn ()
"Bug in readtable iterators or concurrent access?")
(and to-fn (not (function= to-fn from-fn)))))
(when (if subchar
(conflictp (%get-dispatch-macro-character char subchar from)
(%get-dispatch-macro-character char subchar to))
(conflictp (%get-macro-character char from)
(%get-macro-character char to)))
(cerror (format nil "Overwrite ~@C in ~A." char to)
'reader-macro-conflict
:from-readtable from
:to-readtable to
:macro-char char
:sub-char subchar))))
;;; Although there is no way to get at the standard readtable in
;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
;;; up the perception of its existence by interning a copy of it.
;;;
;;; We do this for reverse lookup (cf. READTABLE-NAME), i.e. for
;;;
;;; (equal (readtable-name (find-readtable :standard)) "STANDARD")
;;;
;;; holding true.
;;;
;;; We, however, inherit the restriction that the :STANDARD
;;; readtable _must not be modified_ (cf. CLHS 2.1.1.2), although it'd
;;; technically be feasible (as *STANDARD-READTABLE* will contain a
;;; mutable copy of the implementation-internal standard readtable.)
;;; We cannot enforce this restriction without shadowing
;;; CL:SET-MACRO-CHARACTER and CL:SET-DISPATCH-MACRO-FUNCTION which
;;; is out of scope of this library, though. So we just threaten
;;; with nasal demons.
;;;
(defvar *standard-readtable*
(%standard-readtable))
(defvar *empty-readtable*
(%clear-readtable (copy-readtable nil)))
(defvar *case-preserving-standard-readtable*
(let ((readtable (copy-readtable nil)))
(setf (readtable-case readtable) :preserve)
readtable))
(defparameter *reserved-readtable-names*
'(nil :standard :common-lisp :modern :current))
(defun reserved-readtable-name-p (name)
(and (member name *reserved-readtable-names*) t))
;;; In principle, we could DEFREADTABLE some of these. But we do
;;; reserved readtable lookup seperately, since we can't register a
;;; readtable for :CURRENT anyway.
(defun find-reserved-readtable (reserved-name)
(cond ((eq reserved-name nil) *standard-readtable*)
((eq reserved-name :standard) *standard-readtable*)
((eq reserved-name :common-lisp) *standard-readtable*)
((eq reserved-name :modern) *case-preserving-standard-readtable*)
((eq reserved-name :current) *readtable*)
(t (error "Bug: no such reserved readtable: ~S" reserved-name))))
(define-api find-readtable
(name)
(named-readtable-designator => (or readtable null))
"Looks for the readtable specified by NAME and returns it if it is
found. Returns NIL otherwise."
(cond ((readtablep name) name)
((reserved-readtable-name-p name)
(find-reserved-readtable name))
((%find-readtable name))))
;;; FIXME: This doesn't take a NAMED-READTABLE-DESIGNATOR, but only a
;;; STRING-DESIGNATOR. (When fixing, heed interplay with compiler
;;; macros below.)
(defsetf find-readtable register-readtable)
(define-api ensure-readtable
(name &optional (default nil default-p))
(named-readtable-designator &optional (or named-readtable-designator null)
=> readtable)
"Looks up the readtable specified by NAME and returns it if it's found.
If it is not found, it registers the readtable designated by DEFAULT
under the name represented by NAME; or if no default argument is
given, it signals an error of type READTABLE-DOES-NOT-EXIST
instead."
(cond ((find-readtable name))
((not default-p)
(error 'readtable-does-not-exist :readtable-name name))
(t (setf (find-readtable name) (ensure-readtable default)))))
(define-api register-readtable
(name readtable)
(symbol readtable => readtable)
"Associate READTABLE with NAME. Returns the readtable."
(assert (typep name '(not (satisfies reserved-readtable-name-p))))
(%associate-readtable-with-name name readtable)
(%associate-name-with-readtable name readtable)
readtable)
(define-api unregister-readtable
(named-readtable)
(named-readtable-designator => boolean)
"Remove the association of NAMED-READTABLE. Returns T if successfull,
NIL otherwise."
(let* ((readtable (find-readtable named-readtable))
(readtable-name (and readtable (readtable-name readtable))))
(if (not readtable-name)
nil
(prog1 t
(check-type readtable-name
(not (satisfies reserved-readtable-name-p)))
(%unassociate-readtable-from-name readtable-name readtable)
(%unassociate-name-from-readtable readtable-name readtable)))))
(define-api readtable-name
(named-readtable)
(named-readtable-designator => symbol)
"Returns the name of the readtable designated by NAMED-READTABLE,
or NIL."
(let ((readtable (ensure-readtable named-readtable)))
(cond ((%readtable-name readtable))
((eq readtable *readtable*) :current)
((eq readtable *standard-readtable*) :common-lisp)
((eq readtable *case-preserving-standard-readtable*) :modern)
(t nil))))
abcl-src-1.9.0/contrib/named-readtables/src/package.lisp 0100644 0000000 0000000 00000002347 14202767264 021661 0 ustar 00 0000000 0000000 (in-package :common-lisp-user)
;;; This is is basically MGL-PAX:DEFINE-PACKAGE but we don't have it
;;; defined yet. The package variance stuff is because we export
;;; documentation from the NAMED-READTABLES-DOC system.
(eval-when (:compile-toplevel :load-toplevel :execute)
(locally
(declare #+sbcl
(sb-ext:muffle-conditions sb-kernel::package-at-variance))
(handler-bind
(#+sbcl (sb-kernel::package-at-variance #'muffle-warning))
(defpackage :editor-hints.named-readtables
(:use :common-lisp)
(:nicknames :named-readtables)
(:export
#:defreadtable
#:in-readtable
#:make-readtable
#:merge-readtables-into
#:find-readtable
#:ensure-readtable
#:rename-readtable
#:readtable-name
#:register-readtable
#:unregister-readtable
#:copy-named-readtable
#:list-all-named-readtables
;; Types
#:named-readtable-designator
;; Conditions
#:reader-macro-conflict
#:readtable-does-already-exist
#:readtable-does-not-exist)
(:documentation "See NAMED-READTABLES:@NAMED-READTABLES-MANUAL.")))))
(pushnew :named-readtables *features*)
abcl-src-1.9.0/contrib/named-readtables/src/utils.lisp 0100644 0000000 0000000 00000023445 14202767264 021430 0 ustar 00 0000000 0000000 ;;;;
;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler
;;;;
;;;; All rights reserved.
;;;;
;;;; See LICENSE for details.
;;;;
(in-package :editor-hints.named-readtables)
(defmacro without-package-lock ((&rest package-names) &body body)
(declare (ignorable package-names))
#+clisp
(return-from without-package-lock
`(ext:without-package-lock (,@package-names) ,@body))
#+lispworks
(return-from without-package-lock
`(let ((hcl:*packages-for-warn-on-redefinition*
(set-difference hcl:*packages-for-warn-on-redefinition*
'(,@package-names)
:key (lambda (package-designator)
(if (packagep package-designator)
(package-name package-designator)
package-designator))
:test #'string=)))
,@body))
`(progn ,@body))
;;; Taken from SWANK (which is Public Domain.)
(defmacro destructure-case (value &body patterns)
"Dispatch VALUE to one of PATTERNS.
A cross between `case' and `destructuring-bind'.
The pattern syntax is:
((HEAD . ARGS) . BODY)
The list of patterns is searched for a HEAD `eq' to the car of
VALUE. If one is found, the BODY is executed with ARGS bound to the
corresponding values in the CDR of VALUE."
(let ((operator (gensym "op-"))
(operands (gensym "rand-"))
(tmp (gensym "tmp-")))
`(let* ((,tmp ,value)
(,operator (car ,tmp))
(,operands (cdr ,tmp)))
(case ,operator
,@(loop for (pattern . body) in patterns collect
(if (eq pattern t)
`(t ,@body)
(destructuring-bind (op &rest rands) pattern
`(,op (destructuring-bind ,rands ,operands
,@body)))))
,@(if (eq (caar (last patterns)) t)
'()
`((t (error "destructure-case failed: ~S" ,tmp))))))))
;;; Taken from Alexandria (which is Public Domain, or BSD.)
(define-condition simple-style-warning (simple-warning style-warning)
())
(defun simple-style-warn (format-control &rest format-args)
(warn 'simple-style-warning
:format-control format-control
:format-arguments format-args))
(define-condition simple-program-error (simple-error program-error)
())
(defun simple-program-error (message &rest args)
(error 'simple-program-error
:format-control message
:format-arguments args))
(defun required-argument (&optional name)
"Signals an error for a missing argument of NAME. Intended for
use as an initialization form for structure and class-slots, and
a default value for required keyword arguments."
(error "Required argument ~@[~S ~]missing." name))
(defun ensure-list (list)
"If LIST is a list, it is returned. Otherwise returns the list
designated by LIST."
(if (listp list)
list
(list list)))
(declaim (inline ensure-function)) ; to propagate return type.
(declaim (ftype (function (t) (values function &optional))
ensure-function))
(defun ensure-function (function-designator)
"Returns the function designated by FUNCTION-DESIGNATOR:
if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
it must be a function name and its FDEFINITION is returned."
(if (functionp function-designator)
function-designator
(fdefinition function-designator)))
(defun parse-body (body &key documentation whole)
"Parses BODY into (values remaining-forms declarations doc-string).
Documentation strings are recognized only if DOCUMENTATION is true.
Syntax errors in body are signalled and WHOLE is used in the signal
arguments when given."
(let ((doc nil)
(decls nil)
(current nil))
(tagbody
:declarations
(setf current (car body))
(when (and documentation (stringp current) (cdr body))
(if doc
(error "Too many documentation strings in ~S." (or whole body))
(setf doc (pop body)))
(go :declarations))
(when (and (listp current) (eql (first current) 'declare))
(push (pop body) decls)
(go :declarations)))
(values body (nreverse decls) doc)))
(defun parse-ordinary-lambda-list (lambda-list)
"Parses an ordinary lambda-list, returning as multiple values:
1. Required parameters.
2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)
where SUPPLIEDP is NIL if not present.
3. Name of the rest parameter, or NIL.
4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)
where SUPPLIEDP is NIL if not present.
5. Boolean indicating &ALLOW-OTHER-KEYS presence.
6. &AUX parameter specifications, normalized into form (NAME INIT).
Signals a PROGRAM-ERROR is the lambda-list is malformed."
(let ((state :required)
(allow-other-keys nil)
(auxp nil)
(required nil)
(optional nil)
(rest nil)
(keys nil)
(aux nil))
(labels ((simple-program-error (format-string &rest format-args)
(error 'simple-program-error
:format-control format-string
:format-arguments format-args))
(fail (elt)
(simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(check-variable (elt what)
(unless (and (symbolp elt) (not (constantp elt)))
(simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
what elt lambda-list)))
(check-spec (spec what)
(destructuring-bind (init suppliedp) spec
(declare (ignore init))
(check-variable suppliedp what)))
(make-keyword (name)
"Interns the string designated by NAME in the KEYWORD package."
(intern (string name) :keyword)))
(dolist (elt lambda-list)
(case elt
(&optional
(if (eq state :required)
(setf state elt)
(fail elt)))
(&rest
(if (member state '(:required &optional))
(setf state elt)
(progn
(break "state=~S" state)
(fail elt))))
(&key
(if (member state '(:required &optional :after-rest))
(setf state elt)
(fail elt)))
(&allow-other-keys
(if (eq state '&key)
(setf allow-other-keys t
state elt)
(fail elt)))
(&aux
(cond ((eq state '&rest)
(fail elt))
(auxp
(simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(t
(setf auxp t
state elt))
))
(otherwise
(when (member elt '#.(set-difference lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux)))
(simple-program-error
"Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(case state
(:required
(check-variable elt "required parameter")
(push elt required))
(&optional
(cond ((consp elt)
(destructuring-bind (name &rest tail) elt
(check-variable name "optional parameter")
(if (cdr tail)
(check-spec tail "optional-supplied-p parameter")
(setf elt (append elt '(nil))))))
(t
(check-variable elt "optional parameter")
(setf elt (cons elt '(nil nil)))))
(push elt optional))
(&rest
(check-variable elt "rest parameter")
(setf rest elt
state :after-rest))
(&key
(cond ((consp elt)
(destructuring-bind (var-or-kv &rest tail) elt
(cond ((consp var-or-kv)
(destructuring-bind (keyword var) var-or-kv
(unless (symbolp keyword)
(simple-program-error "Invalid keyword name ~S in ordinary ~
lambda-list:~% ~S"
keyword lambda-list))
(check-variable var "keyword parameter")))
(t
(check-variable var-or-kv "keyword parameter")
(setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))
(if (cdr tail)
(check-spec tail "keyword-supplied-p parameter")
(setf tail (append tail '(nil))))
(setf elt (cons var-or-kv tail))))
(t
(check-variable elt "keyword parameter")
(setf elt (list (list (make-keyword elt) elt) nil nil))))
(push elt keys))
(&aux
(if (consp elt)
(destructuring-bind (var &optional init) elt
(declare (ignore init))
(check-variable var "&aux parameter"))
(check-variable elt "&aux parameter"))
(push elt aux))
(t
(simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
(values (nreverse required) (nreverse optional) rest (nreverse keys)
allow-other-keys (nreverse aux))))
abcl-src-1.9.0/contrib/named-readtables/test/LICENSE 0100644 0000000 0000000 00000003252 14202767264 020566 0 ustar 00 0000000 0000000
Copyright (c) 2007 - 2009 Tobias C. Rittweiler
Copyright (c) 2007, Robert P. Goldman and SIFT, LLC
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the names of Tobias C. Rittweiler, Robert P. Goldman,
SIFT, LLC nor the names of its contributors may be used to
endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert
P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert
P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
abcl-src-1.9.0/contrib/named-readtables/test/README 0100644 0000000 0000000 00000030000 14202767264 020430 0 ustar 00 0000000 0000000 # Named Readtables Manual
###### \[in package EDITOR-HINTS.NAMED-READTABLES\]
## named-readtables ASDF System Details
- Version: 0.9
- Description: Library that creates a namespace for named readtable
akin to the namespace of packages.
- Licence: BSD, see LICENSE
- Author: Tobias C. Rittweiler
- Maintainer: Gábor Melis
- Mailto: [mega@retes.hu](mailto:mega@retes.hu)
## Introduction
Named-Readtables is a library that provides a namespace for
readtables akin to the already-existing namespace of packages. In
particular:
- you can associate readtables with names, and retrieve
readtables by names;
- you can associate source files with readtable names, and be
sure that the right readtable is active when compiling/loading
the file;
- similiarly, your development environment now has a chance to
automatically determine what readtable should be active while
processing source forms on interactive commands. (E.g. think of
`C-c C-c` in Slime (yet to be done))
It follows that Named-Readtables is a facility for using readtables in
a localized way.
Additionally, it also attempts to become a facility for using
readtables in a *modular* way. In particular:
- it provides a macro to specify the content of a readtable at a
glance;
- it makes it possible to use multiple inheritance between readtables.
### Links
Here is the [official repository][named-readtables-repo] and the
[HTML documentation][named-readtables-doc] for the latest version.
[named-readtables-repo]: https://github.com/melisgl/named-readtables
[named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html
### Acknowledgements
Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
Botta, David Crawford, and Pascal Costanza for being early adopters,
providing comments and bugfixes.
## Overview
### Notes on the API
The API heavily imitates the API of packages. This has the nice
property that any experienced Common Lisper will take it up without
effort.
DEFREADTABLE - DEFPACKAGE
IN-READTABLE - IN-PACKAGE
MERGE-READTABLES-INTO - USE-PACKAGE
MAKE-READTABLE - MAKE-PACKAGE
UNREGISTER-READTABLE - DELETE-PACKAGE
RENAME-READTABLE - RENAME-PACKAGE
FIND-READTABLE - FIND-PACKAGE
READTABLE-NAME - PACKAGE-NAME
LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES
### Important API idiosyncrasies
There are three major differences between the API of Named-Readtables,
and the API of packages.
1. Readtable names are symbols not strings.
Time has shown that the fact that packages are named by strings
causes severe headache because of the potential of package names
colliding with each other.
Hence, readtables are named by symbols lest to make the
situation worse than it already is. Consequently, readtables
named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can
happily coexist next to each other. Or, taken to an extreme,
`SCHEME:SYNTAX` and `ELISP:SYNTAX`.
If, for example to duly signify the importance of your cool
readtable hack, you really think it deserves a global name, you
can always resort to keywords.
2. The inheritance is resolved statically, not dynamically.
A package that uses another package will have access to all the
other package's exported symbols, even to those that will be
added after its definition. I.e. the inheritance is resolved at
run-time, that is dynamically.
Unfortunately, we cannot do the same for readtables in a
portable manner.
Therefore, we do not talk about "using" another readtable but
about "merging" the other readtable's definition into the
readtable we are going to define. I.e. the inheritance is
resolved once at definition time, that is statically.
(Such merging can more or less be implemented portably albeit at
a certain cost. Most of the time, this cost manifests itself at
the time a readtable is defined, i.e. once at compile-time, so
it may not bother you. Nonetheless, we provide extra support for
Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your
implementation of choice are welcome, of course.)
3. DEFREADTABLE does not have compile-time effects.
If you define a package via DEFPACKAGE, you can make that
package the currently active package for the subsequent
compilation of the same file via IN-PACKAGE. The same is,
however, not true for DEFREADTABLE and IN-READTABLE for the
following reason:
It's unlikely that the need for special reader-macros arises for
a problem which can be solved in just one file. Most often,
you're going to define the reader macro functions, and set up
the corresponding readtable in an extra file.
If DEFREADTABLE had compile-time effects, you'd have to wrap
each definition of a reader-macro function in an EVAL-WHEN to
make its definition available at compile-time. Because that's
simply not the common case, DEFREADTABLE does not have a
compile-time effect.
If you want to use a readtable within the same file as its
definition, wrap the DEFREADTABLE and the reader-macro function
definitions in an explicit EVAL-WHEN.
### Preregistered Readtables
- NIL, :STANDARD, and :COMMON-LISP designate the
*standard readtable*.
- :MODERN designates a *case-preserving* *standard-readtable*.
- :CURRENT designates the *current readtable*.
### Examples
```commonlisp
(defreadtable elisp:syntax
(:merge :standard)
(:macro-char #\? #'elisp::read-character-literal t)
(:macro-char #\[ #'elisp::read-vector-literal t)
...
(:case :preserve))
(defreadtable scheme:syntax
(:merge :standard)
(:macro-char #\[ #'(lambda (stream char)
(read-delimited-list #\] stream)))
(:macro-char #\# :dispatch)
(:dispatch-macro-char #\# #\t #'scheme::read-#t)
(:dispatch-macro-char #\# #\f #'scheme::read-#f)
...
(:case :preserve))
(in-readtable elisp:syntax)
...
(in-readtable scheme:syntax)
...
```
## Reference
- [macro] DEFREADTABLE NAME &BODY OPTIONS
Define a new named readtable, whose name is given by the symbol NAME.
Or, if a readtable is already registered under that name, redefine
that one.
The readtable can be populated using the following OPTIONS:
- `(:MERGE READTABLE-DESIGNATORS+)`
Merge the readtables designated into the new readtable being
defined as per MERGE-READTABLES-INTO.
If no :MERGE clause is given, an empty readtable is used. See
MAKE-READTABLE.
- `(:FUSE READTABLE-DESIGNATORS+)`
Like :MERGE except:
Error conditions of type READER-MACRO-CONFLICT that are signaled
during the merge operation will be silently *continued*. It
follows that reader macros in earlier entries will be
overwritten by later ones. For backward compatibility, :FUZE is
accepted as an alias of :FUSE.
- `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)`
Define a new sub character `SUB-CHAR` for the dispatching macro
character `MACRO-CHAR`, per SET-DISPATCH-MACRO-CHARACTER. You
probably have to define `MACRO-CHAR` as a dispatching macro
character by the following option first.
- `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])`
Define a new macro character in the readtable, per
SET-MACRO-CHARACTER. If `FUNCTION` is the keyword :DISPATCH,
`MACRO-CHAR` is made a dispatching macro character, per
MAKE-DISPATCH-MACRO-CHARACTER.
- `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)`
Set the character syntax of TO-CHAR in the readtable being
defined to the same syntax as FROM-CHAR as per
SET-SYNTAX-FROM-CHAR.
- `(:CASE CASE-MODE)`
Defines the *case sensitivity mode* of the resulting readtable.
Any number of option clauses may appear. The options are grouped by
their type, but in each group the order the options appeared
textually is preserved. The following groups exist and are executed
in the following order: :MERGE and :FUSE (one
group), :CASE, :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group),
finally :SYNTAX-FROM.
Notes:
The readtable is defined at load-time. If you want to have it
available at compilation time -- say to use its reader-macros in the
same file as its definition -- you have to wrap the DEFREADTABLE
form in an explicit EVAL-WHEN.
On redefinition, the target readtable is made empty first before
it's refilled according to the clauses.
NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are
preregistered readtable names.
- [macro] IN-READTABLE NAME
Set *READTABLE* to the readtable referred to by the symbol NAME.
- [function] MAKE-READTABLE &OPTIONAL (NAME NIL NAME-SUPPLIED-P) &KEY MERGE
Creates and returns a new readtable under the specified
NAME.
MERGE takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
readtables the new readtable is created from. (See the :MERGE clause
of DEFREADTABLE for details.)
If MERGE is NIL, an empty readtable is used instead.
If NAME is not given, an anonymous empty readtable is returned.
Notes:
An empty readtable is a readtable where each character's syntax is
the same as in the *standard readtable* except that each macro
character has been made a constituent. Basically: whitespace stays
whitespace, everything else is constituent.
- [function] MERGE-READTABLES-INTO RESULT-READTABLE &REST NAMED-READTABLES
Copy the contents of each readtable in NAMED-READTABLES into
RESULT-READTABLE.
If a macro character appears in more than one of the readtables,
i.e. if a conflict is discovered during the merge, an error of type
READER-MACRO-CONFLICT is signaled.
- [function] FIND-READTABLE NAME
Looks for the readtable specified by NAME and returns it if it is
found. Returns NIL otherwise.
- [function] ENSURE-READTABLE NAME &OPTIONAL (DEFAULT NIL DEFAULT-P)
Looks up the readtable specified by NAME and returns it if it's found.
If it is not found, it registers the readtable designated by DEFAULT
under the name represented by NAME; or if no default argument is
given, it signals an error of type READTABLE-DOES-NOT-EXIST
instead.
- [function] RENAME-READTABLE OLD-NAME NEW-NAME
Replaces the associated name of the readtable designated by
OLD-NAME with NEW-NAME. If a readtable is already registered under
NEW-NAME, an error of type READTABLE-DOES-ALREADY-EXIST is
signaled.
- [function] READTABLE-NAME NAMED-READTABLE
Returns the name of the readtable designated by NAMED-READTABLE,
or NIL.
- [function] REGISTER-READTABLE NAME READTABLE
Associate READTABLE with NAME. Returns the readtable.
- [function] UNREGISTER-READTABLE NAMED-READTABLE
Remove the association of NAMED-READTABLE. Returns T if successfull,
NIL otherwise.
- [function] COPY-NAMED-READTABLE NAMED-READTABLE
Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument.
- [function] LIST-ALL-NAMED-READTABLES
Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates.
- [type] NAMED-READTABLE-DESIGNATOR
Either a symbol or a readtable itself.
- [condition] READER-MACRO-CONFLICT READTABLE-ERROR
Continuable.
This condition is signaled during the merge process if a reader
macro (be it a macro character or the sub character of a dispatch
macro character) is present in the both source and the target
readtable and the two respective reader macro functions differ.
- [condition] READTABLE-DOES-ALREADY-EXIST READTABLE-ERROR
Continuable.
- [condition] READTABLE-DOES-NOT-EXIST READTABLE-ERROR
* * *
###### \[generated by [MGL-PAX](https://github.com/melisgl/mgl-pax)\]
abcl-src-1.9.0/contrib/named-readtables/test/README.md 0100644 0000000 0000000 00000044312 14202767264 021042 0 ustar 00 0000000 0000000
# Named Readtables Manual
## Table of Contents
- [1 named-readtables ASDF System Details][9b5b]
- [2 Introduction][6faf]
- [2.1 Links][8688]
- [2.2 Acknowledgements][059d]
- [3 Overview][0bc2]
- [3.1 Notes on the API][e4cd]
- [3.2 Important API idiosyncrasies][62b8]
- [3.3 Preregistered Readtables][58c6]
- [3.4 Examples][cf94]
- [4 Reference][373d]
###### \[in package EDITOR-HINTS.NAMED-READTABLES\]
## 1 named-readtables ASDF System Details
- Version: 0.9
- Description: Library that creates a namespace for named readtable
akin to the namespace of packages.
- Licence: BSD, see LICENSE
- Author: Tobias C. Rittweiler
- Maintainer: Gábor Melis
- Mailto: [mega@retes.hu](mailto:mega@retes.hu)
## 2 Introduction
Named-Readtables is a library that provides a namespace for
readtables akin to the already-existing namespace of packages. In
particular:
- you can associate readtables with names, and retrieve
readtables by names;
- you can associate source files with readtable names, and be
sure that the right readtable is active when compiling/loading
the file;
- similiarly, your development environment now has a chance to
automatically determine what readtable should be active while
processing source forms on interactive commands. (E.g. think of
`C-c C-c` in Slime (yet to be done))
It follows that Named-Readtables is a facility for using readtables in
a localized way.
Additionally, it also attempts to become a facility for using
readtables in a *modular* way. In particular:
- it provides a macro to specify the content of a readtable at a
glance;
- it makes it possible to use multiple inheritance between readtables.
### 2.1 Links
Here is the [official repository][named-readtables-repo] and the
[HTML documentation][named-readtables-doc] for the latest version.
[named-readtables-repo]: https://github.com/melisgl/named-readtables
[named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html
### 2.2 Acknowledgements
Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
Botta, David Crawford, and Pascal Costanza for being early adopters,
providing comments and bugfixes.
## 3 Overview
### 3.1 Notes on the API
The API heavily imitates the API of packages. This has the nice
property that any experienced Common Lisper will take it up without
effort.
DEFREADTABLE - DEFPACKAGE
IN-READTABLE - IN-PACKAGE
MERGE-READTABLES-INTO - USE-PACKAGE
MAKE-READTABLE - MAKE-PACKAGE
UNREGISTER-READTABLE - DELETE-PACKAGE
RENAME-READTABLE - RENAME-PACKAGE
FIND-READTABLE - FIND-PACKAGE
READTABLE-NAME - PACKAGE-NAME
LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES
### 3.2 Important API idiosyncrasies
There are three major differences between the API of Named-Readtables,
and the API of packages.
1. Readtable names are symbols not strings.
Time has shown that the fact that packages are named by strings
causes severe headache because of the potential of package names
colliding with each other.
Hence, readtables are named by symbols lest to make the
situation worse than it already is. Consequently, readtables
named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can
happily coexist next to each other. Or, taken to an extreme,
`SCHEME:SYNTAX` and `ELISP:SYNTAX`.
If, for example to duly signify the importance of your cool
readtable hack, you really think it deserves a global name, you
can always resort to keywords.
2. The inheritance is resolved statically, not dynamically.
A package that uses another package will have access to all the
other package's exported symbols, even to those that will be
added after its definition. I.e. the inheritance is resolved at
run-time, that is dynamically.
Unfortunately, we cannot do the same for readtables in a
portable manner.
Therefore, we do not talk about "using" another readtable but
about "merging" the other readtable's definition into the
readtable we are going to define. I.e. the inheritance is
resolved once at definition time, that is statically.
(Such merging can more or less be implemented portably albeit at
a certain cost. Most of the time, this cost manifests itself at
the time a readtable is defined, i.e. once at compile-time, so
it may not bother you. Nonetheless, we provide extra support for
Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your
implementation of choice are welcome, of course.)
3. [`DEFREADTABLE`][8b94] does not have compile-time effects.
If you define a package via `DEFPACKAGE`, you can make that
package the currently active package for the subsequent
compilation of the same file via `IN-PACKAGE`. The same is,
however, not true for [`DEFREADTABLE`][8b94] and [`IN-READTABLE`][de3b] for the
following reason:
It's unlikely that the need for special reader-macros arises for
a problem which can be solved in just one file. Most often,
you're going to define the reader macro functions, and set up
the corresponding readtable in an extra file.
If [`DEFREADTABLE`][8b94] had compile-time effects, you'd have to wrap
each definition of a reader-macro function in an `EVAL-WHEN` to
make its definition available at compile-time. Because that's
simply not the common case, [`DEFREADTABLE`][8b94] does not have a
compile-time effect.
If you want to use a readtable within the same file as its
definition, wrap the [`DEFREADTABLE`][8b94] and the reader-macro function
definitions in an explicit `EVAL-WHEN`.
### 3.3 Preregistered Readtables
- `NIL`, `:STANDARD`, and `:COMMON-LISP` designate the
*standard readtable*.
- `:MODERN` designates a *case-preserving* *standard-readtable*.
- `:CURRENT` designates the *current readtable*.
### 3.4 Examples
```commonlisp
(defreadtable elisp:syntax
(:merge :standard)
(:macro-char #\? #'elisp::read-character-literal t)
(:macro-char #\[ #'elisp::read-vector-literal t)
...
(:case :preserve))
(defreadtable scheme:syntax
(:merge :standard)
(:macro-char #\[ #'(lambda (stream char)
(read-delimited-list #\] stream)))
(:macro-char #\# :dispatch)
(:dispatch-macro-char #\# #\t #'scheme::read-#t)
(:dispatch-macro-char #\# #\f #'scheme::read-#f)
...
(:case :preserve))
(in-readtable elisp:syntax)
...
(in-readtable scheme:syntax)
...
```
## 4 Reference
- [macro] **DEFREADTABLE** *NAME &BODY OPTIONS*
Define a new named readtable, whose name is given by the symbol `NAME`.
Or, if a readtable is already registered under that name, redefine
that one.
The readtable can be populated using the following `OPTIONS`:
- `(:MERGE READTABLE-DESIGNATORS+)`
Merge the readtables designated into the new readtable being
defined as per [`MERGE-READTABLES-INTO`][77fa].
If no `:MERGE` clause is given, an empty readtable is used. See
[`MAKE-READTABLE`][958e].
- `(:FUSE READTABLE-DESIGNATORS+)`
Like `:MERGE` except:
Error conditions of type [`READER-MACRO-CONFLICT`][acb7] that are signaled
during the merge operation will be silently *continued*. It
follows that reader macros in earlier entries will be
overwritten by later ones. For backward compatibility, `:FUZE` is
accepted as an alias of `:FUSE`.
- `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)`
Define a new sub character `SUB-CHAR` for the dispatching macro
character `MACRO-CHAR`, per `SET-DISPATCH-MACRO-CHARACTER`. You
probably have to define `MACRO-CHAR` as a dispatching macro
character by the following option first.
- `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])`
Define a new macro character in the readtable, per
`SET-MACRO-CHARACTER`. If `FUNCTION` is the keyword `:DISPATCH`,
`MACRO-CHAR` is made a dispatching macro character, per
`MAKE-DISPATCH-MACRO-CHARACTER`.
- `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)`
Set the character syntax of `TO-CHAR` in the readtable being
defined to the same syntax as `FROM-CHAR` as per
`SET-SYNTAX-FROM-CHAR`.
- `(:CASE CASE-MODE)`
Defines the *case sensitivity mode* of the resulting readtable.
Any number of option clauses may appear. The options are grouped by
their type, but in each group the order the options appeared
textually is preserved. The following groups exist and are executed
in the following order: `:MERGE` and `:FUSE` (one
group), `:CASE`, `:MACRO-CHAR` and `:DISPATCH-MACRO-CHAR` (one group),
finally `:SYNTAX-FROM`.
Notes:
The readtable is defined at load-time. If you want to have it
available at compilation time -- say to use its reader-macros in the
same file as its definition -- you have to wrap the [`DEFREADTABLE`][8b94]
form in an explicit `EVAL-WHEN`.
On redefinition, the target readtable is made empty first before
it's refilled according to the clauses.
`NIL`, `:STANDARD`, `:COMMON-LISP`, `:MODERN`, and `:CURRENT` are
preregistered readtable names.
- [macro] **IN-READTABLE** *NAME*
Set `*READTABLE*` to the readtable referred to by the symbol `NAME`.
- [function] **MAKE-READTABLE** *&OPTIONAL (NAME NIL NAME-SUPPLIED-P) &KEY MERGE*
Creates and returns a new readtable under the specified
`NAME`.
`MERGE` takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
readtables the new readtable is created from. (See the `:MERGE` clause
of [`DEFREADTABLE`][8b94] for details.)
If `MERGE` is `NIL`, an empty readtable is used instead.
If `NAME` is not given, an anonymous empty readtable is returned.
Notes:
An empty readtable is a readtable where each character's syntax is
the same as in the *standard readtable* except that each macro
character has been made a constituent. Basically: whitespace stays
whitespace, everything else is constituent.
- [function] **MERGE-READTABLES-INTO** *RESULT-READTABLE &REST NAMED-READTABLES*
Copy the contents of each readtable in `NAMED-READTABLES`([`0`][] [`1`][9b5b]) into
`RESULT-READTABLE`.
If a macro character appears in more than one of the readtables,
i.e. if a conflict is discovered during the merge, an error of type
[`READER-MACRO-CONFLICT`][acb7] is signaled.
- [function] **FIND-READTABLE** *NAME*
Looks for the readtable specified by `NAME` and returns it if it is
found. Returns `NIL` otherwise.
- [function] **ENSURE-READTABLE** *NAME &OPTIONAL (DEFAULT NIL DEFAULT-P)*
Looks up the readtable specified by `NAME` and returns it if it's found.
If it is not found, it registers the readtable designated by `DEFAULT`
under the name represented by NAME; or if no default argument is
given, it signals an error of type [`READTABLE-DOES-NOT-EXIST`][437a]
instead.
- [function] **RENAME-READTABLE** *OLD-NAME NEW-NAME*
Replaces the associated name of the readtable designated by
`OLD-NAME` with `NEW-NAME`. If a readtable is already registered under
`NEW-NAME`, an error of type [`READTABLE-DOES-ALREADY-EXIST`][4b51] is
signaled.
- [function] **READTABLE-NAME** *NAMED-READTABLE*
Returns the name of the readtable designated by `NAMED-READTABLE`,
or `NIL`.
- [function] **REGISTER-READTABLE** *NAME READTABLE*
Associate `READTABLE` with `NAME`. Returns the readtable.
- [function] **UNREGISTER-READTABLE** *NAMED-READTABLE*
Remove the association of `NAMED-READTABLE`. Returns `T` if successfull,
`NIL` otherwise.
- [function] **COPY-NAMED-READTABLE** *NAMED-READTABLE*
Like `COPY-READTABLE` but takes a [`NAMED-READTABLE-DESIGNATOR`][fa0c] as argument.
- [function] **LIST-ALL-NAMED-READTABLES**
Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates.
- [type] **NAMED-READTABLE-DESIGNATOR**
Either a symbol or a readtable itself.
- [condition] **READER-MACRO-CONFLICT** *READTABLE-ERROR*
Continuable.
This condition is signaled during the merge process if a reader
macro (be it a macro character or the sub character of a dispatch
macro character) is present in the both source and the target
readtable and the two respective reader macro functions differ.
- [condition] **READTABLE-DOES-ALREADY-EXIST** *READTABLE-ERROR*
Continuable.
- [condition] **READTABLE-DOES-NOT-EXIST** *READTABLE-ERROR*
[059d]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-ACKNOWLEDGEMENTS-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-ACKNOWLEDGEMENTS MGL-PAX:SECTION)"
[0bc2]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-OVERVIEW-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-OVERVIEW MGL-PAX:SECTION)"
[373d]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-REFERENCE-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-REFERENCE MGL-PAX:SECTION)"
[437a]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AREADTABLE-DOES-NOT-EXIST-20CONDITION-29 "(EDITOR-HINTS.NAMED-READTABLES:READTABLE-DOES-NOT-EXIST CONDITION)"
[4b51]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AREADTABLE-DOES-ALREADY-EXIST-20CONDITION-29 "(EDITOR-HINTS.NAMED-READTABLES:READTABLE-DOES-ALREADY-EXIST CONDITION)"
[58c6]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-PREREGISTERED-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-PREREGISTERED MGL-PAX:SECTION)"
[62b8]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-API-IDIOSYNCRASIES-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-API-IDIOSYNCRASIES MGL-PAX:SECTION)"
[6faf]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-INTRODUCTION-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-INTRODUCTION MGL-PAX:SECTION)"
[77fa]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AMERGE-READTABLES-INTO-20FUNCTION-29 "(EDITOR-HINTS.NAMED-READTABLES:MERGE-READTABLES-INTO FUNCTION)"
[8688]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-LINKS-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-LINKS MGL-PAX:SECTION)"
[8b94]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3ADEFREADTABLE-20-28MGL-PAX-3AMACRO-29-29 "(EDITOR-HINTS.NAMED-READTABLES:DEFREADTABLE (MGL-PAX:MACRO))"
[958e]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AMAKE-READTABLE-20FUNCTION-29 "(EDITOR-HINTS.NAMED-READTABLES:MAKE-READTABLE FUNCTION)"
[9b5b]: #x-28-22named-readtables-22-20ASDF-2FSYSTEM-3ASYSTEM-29 "(\"named-readtables\" ASDF/SYSTEM:SYSTEM)"
[acb7]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AREADER-MACRO-CONFLICT-20CONDITION-29 "(EDITOR-HINTS.NAMED-READTABLES:READER-MACRO-CONFLICT CONDITION)"
[cf94]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-EXAMPLES-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-EXAMPLES MGL-PAX:SECTION)"
[de3b]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AIN-READTABLE-20-28MGL-PAX-3AMACRO-29-29 "(EDITOR-HINTS.NAMED-READTABLES:IN-READTABLE (MGL-PAX:MACRO))"
[e4cd]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-API-NOTES-20MGL-PAX-3ASECTION-29 "(EDITOR-HINTS.NAMED-READTABLES:@NAMED-READTABLES-API-NOTES MGL-PAX:SECTION)"
[fa0c]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3ANAMED-READTABLE-DESIGNATOR-20-28TYPE-29-29 "(EDITOR-HINTS.NAMED-READTABLES:NAMED-READTABLE-DESIGNATOR (TYPE))"
* * *
###### \[generated by [MGL-PAX](https://github.com/melisgl/mgl-pax)\]
abcl-src-1.9.0/contrib/named-readtables/test/doc/named-readtables.html 0100644 0000000 0000000 00000105067 14202767264 024413 0 ustar 00 0000000 0000000
EDITOR-HINTS.NAMED-READTABLES - 0.9
EDITOR-HINTS.NAMED-READTABLES - 0.9
by Tobias C Rittweiler
Repository:
darcs get http://common-lisp.net/project/editor-hints/darcs/named-readtables/
Download:
editor-hints.named-readtables-0.9.tar.gz
- What are Named-Readtables?
- Notes on the API
- Important API idiosyncrasies
- Preregistered Readtables
- Examples
- Acknowledgements
- Dictionary
COPY-NAMED-READTABLE
DEFREADTABLE
ENSURE-READTABLE
FIND-READTABLE
IN-READTABLE
LIST-ALL-NAMED-READTABLES
MAKE-READTABLE
MERGE-READTABLES-INTO
NAMED-READTABLE-DESIGNATOR
READER-MACRO-CONFLICT
READTABLE-DOES-ALREADY-EXIST
READTABLE-DOES-NOT-EXIST
READTABLE-NAME
REGISTER-READTABLE
RENAME-READTABLE
UNREGISTER-READTABLE
Named-Readtables is a library that provides a namespace for readtables akin to the
already-existing namespace of packages. In particular:
- you can associate readtables with names, and retrieve readtables by names;
- you can associate source files with readtable names, and be sure that the right readtable is
active when compiling/loading the file;
- similiarly, your development environment now has a chance to automatically determine what
readtable should be active while processing source forms on interactive commands. (E.g. think
of `C-c C-c' in Slime [yet to be done])
Additionally, it also attempts to become a facility for using readtables in a modular way. In
particular:
- it provides a macro to specify the content of a readtable at a glance;
- it makes it possible to use multiple inheritance between readtables.
The API heavily imitates the API of packages. This has the nice property that any experienced
Common Lisper will take it up without effort.
DEFREADTABLEDEFPACKAGE
IN-READTABLEIN-PACKAGE
MERGE-READTABLES-INTOUSE-PACKAGE
MAKE-READTABLEMAKE-PACKAGE
UNREGISTER-READTABLEDELETE-PACKAGE
RENAME-READTABLERENAME-PACKAGE
FIND-READTABLEFIND-PACKAGE
READTABLE-NAMEPACKAGE-NAME
LIST-ALL-NAMED-READTABLESLIST-ALL-PACKAGES
There are three major differences between the API of Named-Readtables, and the API of packages.
1. Readtable names are symbols not strings.
Time has shown that the fact that packages are named by strings causes severe headache because of
the potential of package names colliding with each other.
Hence, readtables are named by symbols lest to make the situation worse than it already is.
Consequently, readtables named CL-ORACLE:SQL-SYNTAX and CL-MYSQL:SQL-SYNTAX can happily coexist
next to each other. Or, taken to an extreme, SCHEME:SYNTAX and ELISP:SYNTAX.
If, for example to duly signify the importance of your cool readtable hack, you really think it
deserves a global name, you can always resort to keywords.
2. The inheritance is resolved statically, not dynamically.
A package that uses another package will have access to all the other package's exported
symbols, even to those that will be added after its definition. I.e. the inheritance is resolved at
run-time, that is dynamically.
Unfortunately, we cannot do the same for readtables in a portable manner.
Therefore, we do not talk about "using" another readtable but about "merging"
the other readtable's definition into the readtable we are going to define. I.e. the
inheritance is resolved once at definition time, that is statically.
(Such merging can more or less be implemented portably albeit at a certain cost. Most of the time,
this cost manifests itself at the time a readtable is defined, i.e. once at compile-time, so it may
not bother you. Nonetheless, we provide extra support for Sbcl, ClozureCL, and AllegroCL at the
moment. Patches for your implementation of choice are welcome, of course.)
3. DEFREADTABLE
If you define a package via DEFPACKAGE,
the subsequent compilation of the same file via IN-PACKAGE.
DEFREADTABLEIN-READTABLE
It's unlikely that the need for special reader-macros arises for a problem which can be
solved in just one file. Most often, you're going to define the reader macro functions, and
set up the corresponding readtable in an extra file.
If DEFREADTABLE
reader-macro function in an EVAL-WHEN
that's simply not the common case, DEFREADTABLE
If you want to use a readtable within the same file as its definition, wrap the DEFREADTABLE
the reader-macro function definitions in an explicit EVAL-WHEN.
- NIL, :STANDARD, and :COMMON-LISP designate the standard readtable.
- :MODERN designates a case-preserving standard-readtable.
- :CURRENT designates the current readtable.
(defreadtable elisp:syntax
(:merge :standard)
(:macro-char #\? #'elisp::read-character-literal t)
(:macro-char #\[ #'elisp::read-vector-literal t)
...
(:case :preserve))
(defreadtable scheme:syntax
(:merge :standard)
(:macro-char #\[ #'(lambda (stream char)
(read-delimited-list #\] stream)))
(:macro-char #\# :dispatch)
(:dispatch-macro-char #\# #\t #'scheme::read-#t)
(:dispatch-macro-char #\# #\f #'scheme::read-#f)
...
(:case :preserve))
(in-readtable elisp:syntax)
...
(in-readtable scheme:syntax)
...
Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart Botta, David Crawford, and Pascal
Costanza for being early adopters, providing comments and bugfixes.
[Function]
copy-named-readtable named-readtable => result
Argument and Values:
named-readtable: (OR
READTABLE
SYMBOL)
result: READTABLE
Description:
Like COPY-READTABLENAMED-READTABLE-DESIGNATOR
[Macro]
defreadtable name &body options => result
Description:
Define a new named readtable, whose name is given by the symbol name. Or, if a readtable is
already registered under that name, redefine that one.
The readtable can be populated using the following options:
(:MERGE readtable-designators+)
Merge the readtables designated into the new readtable being defined as per MERGE-READTABLES-INTO.
If no :MERGE clause is given, an empty readtable is used. See MAKE-READTABLE.
(:FUZE readtable-designators+)
Like :MERGE except:
Error conditions of type READER-MACRO-CONFLICT
be silently continued. It follows that reader macros in earlier entries will be overwritten by
later ones.
(:DISPATCH-MACRO-CHAR macro-char sub-char function)
Define a new sub character sub-char for the dispatching macro character macro-char,
per SET-DISPATCH-MACRO-CHARACTER.
macro character by the following option first.
(:MACRO-CHAR macro-char function [non-terminating-p])
Define a new macro character in the readtable, per SET-MACRO-CHARACTER.
keyword :DISPATCH, macro-char is made a dispatching macro character, per
MAKE-DISPATCH-MACRO-CHARACTER.
(:SYNTAX-FROM from-readtable-designator from-char to-char)
Set the character syntax of to-char in the readtable being defined to the same syntax as
from-char as per SET-SYNTAX-FROM-CHAR.
(:CASE case-mode)
Defines the case sensitivity mode of the resulting readtable.
Any number of option clauses may appear. The options are grouped by their type, but in each group
the order the options appeared textually is preserved. The following groups exist and are executed
in the following order: :MERGE and :FUZE (one group), :CASE, :MACRO-CHAR and :DISPATCH-MACRO-CHAR
(one group), finally :SYNTAX-FROM.
Notes:
The readtable is defined at load-time. If you want to have it available at compilation time --
to use its reader-macros in the same file as its definition --DEFREADTABLE
form in an explicit EVAL-WHEN.
On redefinition, the target readtable is made empty first before it's refilled according to
the clauses.
NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are preregistered readtable names.
[Function]
ensure-readtable name &optional default => result
Argument and Values:
name: (OR
READTABLE
SYMBOL)
default: (OR
READTABLE
SYMBOL)
result: READTABLE
Description:
Looks up the readtable specified by name and returns it if it's found. If it is not
found, it registers the readtable designated by default under the name represented by
name; or if no default argument is given, it signals an error of type
READTABLE-DOES-NOT-EXIST
[Function]
find-readtable name => result
Argument and Values:
name: (OR
READTABLE
SYMBOL)
result: (OR
READTABLE
NULL)
Description:
Looks for the readtable specified by name and returns it if it is found. Returns NIL
otherwise.
[Macro]
in-readtable name => result
Description:
Set *READTABLE*
[Function]
list-all-named-readtables => result
Argument and Values:
result: LIST
Description:
Returns a list of all registered readtables. The returned list is guaranteed to be fresh, but may
contain duplicates.
[Function]
make-readtable &optional name &key merge => result
Argument and Values:
name: (OR
READTABLE
SYMBOL)
merge: LIST
result: READTABLE
Description:
Creates and returns a new readtable under the specified name.
merge takes a list of NAMED-READTABLE-DESIGNATORS
readtable is created from. (See the :MERGE clause of DEFREADTABLE
If merge is NIL, an empty readtable is used instead.
If name is not given, an anonymous empty readtable is returned.
Notes:
An empty readtable is a readtable where each character's syntax is the same as in the
standard readtable except that each macro character has been made a constituent. Basically:
whitespace stays whitespace, everything else is constituent.
[Function]
merge-readtables-into result-readtable &rest named-readtables => result
Argument and Values:
result-readtable: (OR
READTABLE
SYMBOL)
named-readtables: (OR
READTABLE
SYMBOL)
result: READTABLE
Description:
Copy the contents of each readtable in named-readtables into result-table.
If a macro character appears in more than one of the readtables, i.e. if a conflict is discovered
during the merge, an error of type READER-MACRO-CONFLICT
[Type]
named-readtable-designator
Description:
Either a symbol or a readtable itself.
[Condition type]
reader-macro-conflict
Description:
Continuable.
This condition is signaled during the merge process if a) a reader macro (be it a macro character
or the sub character of a dispatch macro character) is both present in the source as well as the
target readtable, and b) if and only if the two respective reader macro functions differ.
[Condition type]
readtable-does-already-exist
Description:
Continuable.
[Condition type]
readtable-does-not-exist
[Function]
readtable-name named-readtable => result
Argument and Values:
named-readtable: (OR
READTABLE
SYMBOL)
result: SYMBOL
Description:
Returns the name of the readtable designated by named-readtable, or NIL.
[Function]
register-readtable name readtable => result
Argument and Values:
name: SYMBOL
readtable: READTABLE
result: READTABLE
Description:
Associate readtable with name. Returns the readtable.
[Function]
rename-readtable old-name new-name => result
Argument and Values:
old-name: (OR
READTABLE
SYMBOL)
new-name: SYMBOL
result: READTABLE
Description:
Replaces the associated name of the readtable designated by old-name with new-name.
If a readtable is already registered under new-name, an error of type
READTABLE-DOES-ALREADY-EXIST
[Function]
unregister-readtable named-readtable => result
Argument and Values:
named-readtable: (OR
READTABLE
SYMBOL)
result: (MEMBER
T
NIL)
Description:
Remove the association of named-readtable. Returns TNIL otherwise.
This documentation was generated on 2009-11-5 from a Lisp image using some home-brewn,
duct-taped,
evolutionary hacked extension of Edi Weitz'
DOCUMENTATION-TEMPLATE.
abcl-src-1.9.0/contrib/named-readtables/test/named-readtables.asd 0100644 0000000 0000000 00000003172 14202767264 023443 0 ustar 00 0000000 0000000 ;;;; -*- mode: Lisp -*-
(in-package :asdf)
(defclass named-readtables-source-file (cl-source-file) ())
#+sbcl
(defmethod perform :around ((o compile-op)
(c named-readtables-source-file))
(let ((sb-ext:*derive-function-types* t))
(call-next-method)))
(defsystem "named-readtables"
:description "Library that creates a namespace for named readtable
akin to the namespace of packages."
:author "Tobias C. Rittweiler "
:maintainer "Gábor Melis"
:mailto "mega@retes.hu"
:version "0.9"
:licence "BSD, see LICENSE"
:default-component-class named-readtables-source-file
:pathname "src"
:serial t
:components ((:file "package")
(:file "utils")
(:file "define-api")
(:file "cruft")
(:file "named-readtables"))
:in-order-to ((test-op (test-op "named-readtables/test"))))
(defsystem "named-readtables/test"
:description "Test suite for the Named-Readtables library."
:author "Tobias C. Rittweiler "
:maintainer "Gábor Melis"
:mailto "mega@retes.hu"
:depends-on ("named-readtables")
:pathname "test"
:serial t
:default-component-class named-readtables-source-file
:components
((:file "package")
(:file "rt")
(:file "tests"))
:perform (test-op (o c) (symbol-call :named-readtables-test '#:do-tests)))
;;; MGL-PAX depends on NAMED-READTABLES so we must put documentation
;;; in a separate system in order to be able to use MGL-PAX.
(defsystem "named-readtables/doc"
:depends-on ("named-readtables" "mgl-pax")
:pathname "src"
:components ((:file "doc")))
abcl-src-1.9.0/contrib/named-readtables/test/package.lisp 0100644 0000000 0000000 00000000424 14202767264 022043 0 ustar 00 0000000 0000000 ;;; -*- Mode:Lisp -*-
(in-package :cl-user)
(defpackage :named-readtables-test
(:use :cl :named-readtables)
(:import-from :named-readtables
#:dispatch-macro-char-p
#:do-readtable
#:ensure-function
#:ensure-dispatch-macro-character
#:function=))
abcl-src-1.9.0/contrib/named-readtables/test/rt.lisp 0100644 0000000 0000000 00000021456 14202767264 021105 0 ustar 00 0000000 0000000 #|----------------------------------------------------------------------------|
| Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
| |
| Permission to use, copy, modify, and distribute this software and its |
| documentation for any purpose and without fee is hereby granted, provided |
| that this copyright and permission notice appear in all copies and |
| supporting documentation, and that the name of M.I.T. not be used in |
| advertising or publicity pertaining to distribution of the software |
| without specific, written prior permission. M.I.T. makes no |
| representations about the suitability of this software for any purpose. |
| It is provided "as is" without express or implied warranty. |
| |
| M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
| ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
| M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
| ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
| WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
| ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
| SOFTWARE. |
|----------------------------------------------------------------------------|#
;; (defpackage :rt
;; (:use #:cl)
;; (:export #:*do-tests-when-defined* #:*test* #:continue-testing
;; #:deftest #:do-test #:do-tests #:get-test #:pending-tests
;; #:rem-all-tests #:rem-test)
;; (:documentation "The MIT regression tester"))
;; (in-package :rt)
(in-package :named-readtables-test)
(defvar *test* nil "Current test name")
(defvar *do-tests-when-defined* nil)
(defvar *entries* '(nil) "Test database")
(defvar *in-test* nil "Used by TEST")
(defvar *debug* nil "For debugging")
(defvar *catch-errors* t
"When true, causes errors in a test to be caught.")
(defvar *print-circle-on-failure* nil
"Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
(defvar *compile-tests* nil
"When true, compile the tests before running them.")
(defvar *optimization-settings* '((safety 3)))
(defvar *expected-failures* nil
"A list of test names that are expected to fail.")
(defstruct (entry (:conc-name nil)
(:type list))
pend name form)
(defmacro vals (entry) `(cdddr ,entry))
(defmacro defn (entry) `(cdr ,entry))
(defun pending-tests ()
(do ((l (cdr *entries*) (cdr l))
(r nil))
((null l) (nreverse r))
(when (pend (car l))
(push (name (car l)) r))))
(defun rem-all-tests ()
(setq *entries* (list nil))
nil)
(defun rem-test (&optional (name *test*))
(do ((l *entries* (cdr l)))
((null (cdr l)) nil)
(when (equal (name (cadr l)) name)
(setf (cdr l) (cddr l))
(return name))))
(defun get-test (&optional (name *test*))
(defn (get-entry name)))
(defun get-entry (name)
(let ((entry (find name (cdr *entries*)
:key #'name
:test #'equal)))
(when (null entry)
(report-error t
"~%No test with name ~:@(~S~)."
name))
entry))
(defmacro deftest (name form &rest values)
`(add-entry '(t ,name ,form .,values)))
(defun add-entry (entry)
(setq entry (copy-list entry))
(do ((l *entries* (cdr l))) (nil)
(when (null (cdr l))
(setf (cdr l) (list entry))
(return nil))
(when (equal (name (cadr l))
(name entry))
(setf (cadr l) entry)
(report-error nil
"Redefining test ~:@(~S~)"
(name entry))
(return nil)))
(when *do-tests-when-defined*
(do-entry entry))
(setq *test* (name entry)))
(defun report-error (error? &rest args)
(cond (*debug*
(apply #'format t args)
(if error? (throw '*debug* nil)))
(error? (apply #'error args))
(t (apply #'warn args))))
(defun do-test (&optional (name *test*))
(do-entry (get-entry name)))
(defun equalp-with-case (x y)
"Like EQUALP, but doesn't do case conversion of characters."
(cond
((eq x y) t)
((consp x)
(and (consp y)
(equalp-with-case (car x) (car y))
(equalp-with-case (cdr x) (cdr y))))
((and (typep x 'array)
(= (array-rank x) 0))
(equalp-with-case (aref x) (aref y)))
((typep x 'vector)
(and (typep y 'vector)
(let ((x-len (length x))
(y-len (length y)))
(and (eql x-len y-len)
(loop
for e1 across x
for e2 across y
always (equalp-with-case e1 e2))))))
((and (typep x 'array)
(typep y 'array)
(not (equal (array-dimensions x)
(array-dimensions y))))
nil)
((typep x 'array)
(and (typep y 'array)
(let ((size (array-total-size x)))
(loop for i from 0 below size
always (equalp-with-case (row-major-aref x i)
(row-major-aref y i))))))
(t (eql x y))))
(defun do-entry (entry &optional
(s *standard-output*))
(catch '*in-test*
(setq *test* (name entry))
(setf (pend entry) t)
(let* ((*in-test* t)
;; (*break-on-warnings* t)
(aborted nil)
r)
;; (declare (special *break-on-warnings*))
(block aborted
(setf r
(flet ((%do
()
(if *compile-tests*
(multiple-value-list
(funcall (compile
nil
`(lambda ()
(declare
(optimize ,@*optimization-settings*))
,(form entry)))))
(multiple-value-list
(eval (form entry))))))
(if *catch-errors*
(handler-bind
((style-warning #'muffle-warning)
(error #'(lambda (c)
(setf aborted t)
(setf r (list c))
(return-from aborted nil))))
(%do))
(%do)))))
(setf (pend entry)
(or aborted
(not (equalp-with-case r (vals entry)))))
(when (pend entry)
(let ((*print-circle* *print-circle-on-failure*))
(format s "~&Test ~:@(~S~) failed~
~%Form: ~S~
~%Expected value~P: ~
~{~S~^~%~17t~}~%"
*test* (form entry)
(length (vals entry))
(vals entry))
(format s "Actual value~P: ~
~{~S~^~%~15t~}.~%"
(length r) r)))))
(when (not (pend entry)) *test*))
(defun continue-testing ()
(if *in-test*
(throw '*in-test* nil)
(do-entries *standard-output*)))
(defun do-tests (&optional
(out *standard-output*))
(dolist (entry (cdr *entries*))
(setf (pend entry) t))
(if (streamp out)
(do-entries out)
(with-open-file
(stream out :direction :output)
(do-entries stream))))
(defun do-entries (s)
(format s "~&Doing ~A pending test~:P ~
of ~A tests total.~%"
(count t (cdr *entries*)
:key #'pend)
(length (cdr *entries*)))
(dolist (entry (cdr *entries*))
(when (pend entry)
(format s "~@[~<~%~:; ~:@(~S~)~>~]"
(do-entry entry s))))
(let ((pending (pending-tests))
(expected-table (make-hash-table :test #'equal)))
(dolist (ex *expected-failures*)
(setf (gethash ex expected-table) t))
(let ((new-failures
(loop for pend in pending
unless (gethash pend expected-table)
collect pend)))
(if (null pending)
(format s "~&No tests failed.")
(progn
(format s "~&~A out of ~A ~
total tests failed: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
(length pending)
(length (cdr *entries*))
pending)
(if (null new-failures)
(format s "~&No unexpected failures.")
(when *expected-failures*
(format s "~&~A unexpected failures: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
(length new-failures)
new-failures)))
))
(finish-output s)
(null pending))))
abcl-src-1.9.0/contrib/named-readtables/test/src/cruft.lisp 0100644 0000000 0000000 00000042037 14202767264 022370 0 ustar 00 0000000 0000000 ;;;;
;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler
;;;;
;;;; All rights reserved.
;;;;
;;;; See LICENSE for details.
;;;;
(in-package :editor-hints.named-readtables)
(defmacro define-cruft (name lambda-list &body (docstring . alternatives))
(assert (typep docstring 'string) (docstring) "Docstring missing!")
(assert (not (null alternatives)))
`(progn
(declaim (inline ,name))
(defun ,name ,lambda-list ,docstring ,(first alternatives))))
(eval-when (:compile-toplevel :execute)
#+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"
(find-package "SB-IMPL"))
(pushnew :sbcl+safe-standard-readtable *features*)))
;;;;; Implementation-dependent cruft
;;;; Mapping between a readtable object and its readtable-name.
(defvar *readtable-names* (make-hash-table :test 'eq))
(define-cruft %associate-readtable-with-name (name readtable)
"Associate READTABLE with NAME for READTABLE-NAME to work."
#+ :common-lisp (setf (gethash readtable *readtable-names*) name))
(define-cruft %unassociate-readtable-from-name (name readtable)
"Remove the association between READTABLE and NAME."
#+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*)))
(remhash readtable *readtable-names*)))
(define-cruft %readtable-name (readtable)
"Return the name associated with READTABLE."
#+ :common-lisp (values (gethash readtable *readtable-names*)))
(define-cruft %list-all-readtable-names ()
"Return a list of all available readtable names."
#+ :common-lisp (list* :standard :current
(loop for name being each hash-value of *readtable-names*
collect name)))
;;;; Mapping between a readtable-name and the actual readtable object.
;;; On Allegro we reuse their named-readtable support so we work
;;; nicely on their infrastructure.
#-allegro
(defvar *named-readtables* (make-hash-table :test 'eq))
#+allegro
(defun readtable-name-for-allegro (symbol)
(multiple-value-bind (kwd status)
(if (keywordp symbol)
(values symbol nil)
;; Kludge: ACL uses keywords to name readtables, we allow
;; arbitrary symbols.
(intern (format nil "~A.~A"
(package-name (symbol-package symbol))
(symbol-name symbol))
:keyword))
(prog1 kwd
(assert (or (not status) (get kwd 'named-readtable-designator)))
(setf (get kwd 'named-readtable-designator) t))))
(define-cruft %associate-name-with-readtable (name readtable)
"Associate NAME with READTABLE for FIND-READTABLE to work."
#+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable)
#+ :common-lisp (setf (gethash name *named-readtables*) readtable))
(define-cruft %unassociate-name-from-readtable (name readtable)
"Remove the association between NAME and READTABLE"
#+ :allegro (let ((n (readtable-name-for-allegro name)))
(assert (eq readtable (excl:named-readtable n)))
(setf (excl:named-readtable n) nil))
#+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*)))
(remhash name *named-readtables*)))
(define-cruft %find-readtable (name)
"Return the readtable named NAME."
#+ :allegro (excl:named-readtable (readtable-name-for-allegro name) nil)
#+ :common-lisp (values (gethash name *named-readtables* nil)))
;;;; Reader-macro related predicates
;;; CLISP creates new function objects for standard reader macros on
;;; each readtable copy.
(define-cruft function= (fn1 fn2)
"Are reader-macro function-designators FN1 and FN2 the same?"
#+ :clisp
(let* ((fn1 (ensure-function fn1))
(fn2 (ensure-function fn2))
(n1 (system::function-name fn1))
(n2 (system::function-name fn2)))
(if (and (eq n1 :lambda) (eq n2 :lambda))
(eq fn1 fn2)
(equal n1 n2)))
#+ :sbcl
(let ((fn1 (ensure-function fn1))
(fn2 (ensure-function fn2)))
(or (eq fn1 fn2)
;; After SBCL 1.1.18, for dispatch macro characters
;; GET-MACRO-CHARACTER returns closures whose name is:
;;
;; (LAMBDA (STREAM CHAR) :IN SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR)
;;
;; Treat all these closures equivalent.
(flet ((internal-dispatch-macro-closure-name-p (name)
(find "SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR" name
:key #'prin1-to-string :test #'string-equal)))
(let ((n1 (sb-impl::%fun-name fn1))
(n2 (sb-impl::%fun-name fn2)))
(and (listp n1) (listp n2)
(internal-dispatch-macro-closure-name-p n1)
(internal-dispatch-macro-closure-name-p n2))))))
#+ :common-lisp
(eq (ensure-function fn1) (ensure-function fn2)))
;;; CLISP will incorrectly fold the call to G-D-M-C away
;;; if not declared inline.
(define-cruft dispatch-macro-char-p (char rt)
"Is CHAR a dispatch macro character in RT?"
#+ :common-lisp
(handler-case (locally
#+clisp (declare (notinline get-dispatch-macro-character))
(get-dispatch-macro-character char #\x rt)
t)
(error () nil)))
;; (defun macro-char-p (char rt)
;; (let ((reader-fn (%get-macro-character char rt)))
;; (and reader-fn t)))
;; (defun standard-macro-char-p (char rt)
;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)
;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*)
;; (and (eq rt-fn std-fn)
;; (eq rt-flag std-flag)))))
;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt)
;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt))))
;; (and (eq (non-terminating-p disp-char rt)
;; (non-terminating-p disp-char *standard-readtable*))
;; (eq (get-dispatch-macro-character disp-char sub-char rt)
;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))
;;;; Readtables Iterators
(defmacro with-readtable-iterator ((name readtable) &body body)
(let ((it (gensym)))
`(let ((,it (%make-readtable-iterator ,readtable)))
(macrolet ((,name () `(funcall ,',it)))
,@body))))
#+sbcl
(defun %make-readtable-iterator (readtable)
(let ((char-macro-array (sb-impl::character-macro-array readtable))
(char-macro-ht (sb-impl::character-macro-hash-table readtable))
(dispatch-tables (sb-impl::dispatch-tables readtable))
(char-code 0))
(with-hash-table-iterator (ht-iterator char-macro-ht)
(labels ((grovel-base-chars ()
(if (>= char-code sb-int:base-char-code-limit)
(grovel-unicode-chars)
(let ((reader-fn (svref char-macro-array char-code))
(char (code-char (shiftf char-code (1+ char-code)))))
(if reader-fn
(yield char)
(grovel-base-chars)))))
(grovel-unicode-chars ()
(multiple-value-bind (more? char) (ht-iterator)
(if (not more?)
(values nil nil nil nil nil)
(yield char))))
(yield (char)
(let ((disp-fn (get-macro-character char readtable))
(disp-ht))
(cond
((setq disp-ht (cdr (assoc char dispatch-tables)))
(let ((sub-char-alist))
(maphash (lambda (k v)
(push (cons k v) sub-char-alist))
disp-ht)
(values t char disp-fn t sub-char-alist)))
(t
(values t char disp-fn nil nil))))))
#'grovel-base-chars))))
#+clozure
(defun %make-readtable-iterator (readtable)
(flet ((ensure-alist (x)
#.`(etypecase x
(list x)
,@(uiop:if-let (sv (uiop:find-symbol* '#:sparse-vector :ccl nil))
`((,sv
(let ((table (uiop:symbol-call :ccl '#:sparse-vector-table x)))
(uiop:while-collecting (c)
(loop for i below (length table) do
(uiop:if-let ((v (svref table i)))
(loop with i8 = (ash i 8)
for j below (length v) do
(uiop:if-let ((datum (svref v j)))
(c (cons (code-char (+ i8 j)) datum))))))))))))))
(let ((char-macros
(ensure-alist
(#.(or (uiop:find-symbol* '#:rdtab.macros :ccl nil) (uiop:find-symbol* '#:rdtab.alist :ccl)) readtable))))
(lambda ()
(if char-macros
(destructuring-bind (char . defn) (pop char-macros)
(if (consp defn)
(values t char (car defn) t (ensure-alist (cdr defn)))
(values t char defn nil nil)))
(values nil nil nil nil nil))))))
;;; Written on ACL 8.0.
#+allegro
(defun %make-readtable-iterator (readtable)
(declare (optimize speed)) ; for TCO
(check-type readtable readtable)
(let* ((macro-table (first (excl::readtable-macro-table readtable)))
(dispatch-tables (excl::readtable-dispatch-tables readtable))
(table-length (length macro-table))
(idx 0))
(labels ((grovel-macro-chars ()
(if (>= idx table-length)
(grovel-dispatch-chars)
(let ((read-fn (svref macro-table idx))
(oidx idx))
(incf idx)
(if (or (eq read-fn #'excl::read-token)
(eq read-fn #'excl::read-dispatch-char)
(eq read-fn #'excl::undefined-macro-char))
(grovel-macro-chars)
(values t (code-char oidx) read-fn nil nil)))))
(grovel-dispatch-chars ()
(if (null dispatch-tables)
(values nil nil nil nil nil)
(destructuring-bind (disp-char sub-char-table)
(first dispatch-tables)
(setf dispatch-tables (rest dispatch-tables))
;;; Kludge. We can't fully clear dispatch tables
;;; in %CLEAR-READTABLE.
(when (eq (svref macro-table (char-code disp-char))
#'excl::read-dispatch-char)
(values t
disp-char
(svref macro-table (char-code disp-char))
t
(loop for subch-fn across sub-char-table
for subch-code from 0
when subch-fn
collect (cons (code-char subch-code)
subch-fn))))))))
#'grovel-macro-chars)))
#-(or sbcl clozure allegro)
(eval-when (:compile-toplevel)
(let ((*print-pretty* t))
(simple-style-warn
"~&~@< ~@;~A has not been ported to ~A. ~
We fall back to a portable implementation of readtable iterators. ~
This implementation has to grovel through all available characters. ~
On Unicode-aware implementations this may come with some costs.~@:>"
(package-name '#.*package*) (lisp-implementation-type))))
#-(or sbcl clozure allegro)
(defun %make-readtable-iterator (readtable)
(check-type readtable readtable)
(let ((char-code 0))
#'(lambda ()
(prog ()
:GROVEL
(when (< char-code char-code-limit)
(let ((char (code-char char-code)))
(incf char-code)
(when (not char) (go :GROVEL))
(let ((fn (get-macro-character char readtable)))
(when (not fn) (go :GROVEL))
(multiple-value-bind (disp? alist)
(handler-case ; grovel dispatch macro characters.
(values
t
;; Only grovel upper case characters to
;; avoid duplicates.
(loop for code from 0 below char-code-limit
for subchar = (non-lowercase-code-char code)
for disp-fn = (and subchar
(get-dispatch-macro-character
char subchar readtable))
when disp-fn
collect (cons subchar disp-fn)))
(error () nil))
(return (values t char fn disp? alist))))))))))
#-(or sbcl clozure allegro)
(defun non-lowercase-code-char (code)
(let ((ch (code-char code)))
(when (and ch (or (not (alpha-char-p ch))
(upper-case-p ch)))
ch)))
(defmacro do-readtable ((entry-designator readtable &optional result)
&body body)
"Iterate through a readtable's macro characters, and dispatch macro characters."
(destructuring-bind (char &optional reader-fn non-terminating-p disp? table)
(if (symbolp entry-designator)
(list entry-designator)
entry-designator)
(let ((iter (gensym "ITER+"))
(more? (gensym "MORE?+"))
(rt (gensym "READTABLE+")))
`(let ((,rt ,readtable))
(with-readtable-iterator (,iter ,rt)
(loop
(multiple-value-bind (,more?
,char
,@(when reader-fn (list reader-fn))
,@(when disp? (list disp?))
,@(when table (list table)))
(,iter)
(unless ,more? (return ,result))
(let ,(when non-terminating-p
;; FIXME: N-T-P should be incorporated in iterators.
`((,non-terminating-p
(nth-value 1 (get-macro-character ,char ,rt)))))
,@body))))))))
;;;; Misc
;;; This should return an implementation's actual standard readtable
;;; object only if the implementation makes the effort to guard against
;;; modification of that object. Otherwise it should better return a
;;; copy.
(define-cruft %standard-readtable ()
"Return the standard readtable."
#+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
#+ :common-lisp (copy-readtable nil))
;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;;; readtable's dispatch table properly.
;;; Same goes for Allegro but that does not seem to provide a
;;; setter for their readtable's dispatch tables. Hence this ugly
;;; workaround.
(define-cruft %clear-readtable (readtable)
"Make all macro characters in READTABLE be constituents."
#+ :sbcl
(prog1 readtable
(do-readtable (char readtable)
(set-syntax-from-char char #\A readtable))
(setf (sb-impl::dispatch-tables readtable) nil))
#+ :allegro
(prog1 readtable
(do-readtable (char readtable)
(set-syntax-from-char char #\A readtable))
(let ((dispatch-tables (excl::readtable-dispatch-tables readtable)))
(setf (cdr dispatch-tables) nil)
(setf (caar dispatch-tables) #\Backspace)
(setf (cadar dispatch-tables) (fill (cadar dispatch-tables) nil))))
#+ :common-lisp
(do-readtable (char readtable readtable)
(set-syntax-from-char char #\A readtable)))
;;; See Clozure Trac Ticket 601. This is supposed to be removed at
;;; some point in the future.
(define-cruft %get-dispatch-macro-character (char subchar rt)
"Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER."
#+ :ccl (ignore-errors
(get-dispatch-macro-character char subchar rt))
#+ :common-lisp (get-dispatch-macro-character char subchar rt))
;;; Allegro stores READ-TOKEN as reader macro function of each
;;; constituent character.
(define-cruft %get-macro-character (char rt)
"Ensure ANSI behaviour for GET-MACRO-CHARACTER."
#+ :allegro (let ((fn (get-macro-character char rt)))
(cond ((not fn) nil)
((function= fn #'excl::read-token) nil)
(t fn)))
#+ :common-lisp (get-macro-character char rt))
;;;; Specialized PRINT-OBJECT for named readtables.
;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT
;;; that specializes on READTABLE is actually forbidden. It's quite
;;; likely to work (modulo package-locks) on most implementations,
;;; though.
;;; We don't need this on Allegro CL's as we hook into their
;;; named-readtable facility, and they provide such a method already.
#-allegro
(without-package-lock (:common-lisp #+lispworks :implementation)
(defmethod print-object :around ((rt readtable) stream)
(let ((name (readtable-name rt)))
(if name
(print-unreadable-object (rt stream :type nil :identity t)
(format stream "~A ~S" :named-readtable name))
(call-next-method)))))
abcl-src-1.9.0/contrib/named-readtables/test/src/define-api.lisp 0100644 0000000 0000000 00000005543 14202767264 023247 0 ustar 00 0000000 0000000 (in-package :named-readtables)
(defmacro define-api (name lambda-list type-list &body body)
(flet ((parse-type-list (type-list)
(let ((pos (position '=> type-list)))
(assert pos () "You forgot to specify return type (`=>' missing.)")
(values (subseq type-list 0 pos)
`(values ,@(nthcdr (1+ pos) type-list) &optional)))))
(multiple-value-bind (body decls docstring)
(parse-body body :documentation t :whole `(define-api ,name))
(multiple-value-bind (arg-typespec value-typespec)
(parse-type-list type-list)
(multiple-value-bind (reqs opts rest keys)
(parse-ordinary-lambda-list lambda-list)
(declare (ignorable reqs opts rest keys))
`(progn
(declaim (ftype (function ,arg-typespec ,value-typespec) ,name))
(locally
;;; Muffle the annoying "&OPTIONAL and &KEY found in
;;; the same lambda list" style-warning
#+sbcl (declare (sb-ext:muffle-conditions style-warning))
(defun ,name ,lambda-list
,docstring
#+sbcl (declare (sb-ext:unmuffle-conditions style-warning))
,@decls
;; SBCL will interpret the ftype declaration as
;; assertion and will insert type checks for us.
#-sbcl
(progn
;; CHECK-TYPE required parameters
,@(loop for req-arg in reqs
for req-type = (pop type-list)
do (assert req-type)
collect `(check-type ,req-arg ,req-type))
;; CHECK-TYPE optional parameters
,@(loop initially (assert (or (null opts)
(eq (pop type-list) '&optional)))
for (opt-arg . nil) in opts
for opt-type = (pop type-list)
do (assert opt-type)
collect `(check-type ,opt-arg ,opt-type))
;; CHECK-TYPE rest parameter
,@(when rest
(assert (eq (pop type-list) '&rest))
(let ((rest-type (pop type-list)))
(assert rest-type)
`((dolist (x ,rest)
(check-type x ,rest-type)))))
;; CHECK-TYPE key parameters
,@(loop initially (assert (or (null keys)
(eq (pop type-list) '&key)))
for ((keyword key-arg) . nil) in keys
for (nil key-type) = (find keyword type-list :key #'car)
collect `(check-type ,key-arg ,key-type)))
,@body))))))))
abcl-src-1.9.0/contrib/named-readtables/test/src/doc.lisp 0100644 0000000 0000000 00000021117 14202767264 022006 0 ustar 00 0000000 0000000 (in-package :named-readtables)
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :mgl-pax))
(defsection @named-readtables-manual (:title "Named Readtables Manual")
(named-readtables asdf:system)
(@named-readtables-introduction section)
(@named-readtables-overview section)
(@named-readtables-reference section))
(defsection @named-readtables-introduction (:title "Introduction")
"Named-Readtables is a library that provides a namespace for
readtables akin to the already-existing namespace of packages. In
particular:
* you can associate readtables with names, and retrieve
readtables by names;
* you can associate source files with readtable names, and be
sure that the right readtable is active when compiling/loading
the file;
* similiarly, your development environment now has a chance to
automatically determine what readtable should be active while
processing source forms on interactive commands. (E.g. think of
`C-c C-c` in Slime (yet to be done))
It follows that Named-Readtables is a facility for using readtables in
a localized way.
Additionally, it also attempts to become a facility for using
readtables in a _modular_ way. In particular:
* it provides a macro to specify the content of a readtable at a
glance;
* it makes it possible to use multiple inheritance between readtables."
(@named-readtables-links section)
(@named-readtables-acknowledgements section))
(defsection @named-readtables-links (:title "Links")
"Here is the [official repository][named-readtables-repo] and the
[HTML documentation][named-readtables-doc] for the latest version.
[named-readtables-repo]: https://github.com/melisgl/named-readtables
[named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html")
(defsection @named-readtables-acknowledgements (:title "Acknowledgements")
"Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
Botta, David Crawford, and Pascal Costanza for being early adopters,
providing comments and bugfixes.")
(defsection @named-readtables-overview (:title "Overview")
(@named-readtables-api-notes section)
(@named-readtables-api-idiosyncrasies section)
(@named-readtables-preregistered section)
(@named-readtables-examples section))
(defsection @named-readtables-api-notes (:title "Notes on the API" :export nil)
"The API heavily imitates the API of packages. This has the nice
property that any experienced Common Lisper will take it up without
effort.
DEFREADTABLE - DEFPACKAGE
IN-READTABLE - IN-PACKAGE
MERGE-READTABLES-INTO - USE-PACKAGE
MAKE-READTABLE - MAKE-PACKAGE
UNREGISTER-READTABLE - DELETE-PACKAGE
RENAME-READTABLE - RENAME-PACKAGE
FIND-READTABLE - FIND-PACKAGE
READTABLE-NAME - PACKAGE-NAME
LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES")
(defsection @named-readtables-api-idiosyncrasies
(:title "Important API idiosyncrasies" :export nil)
"There are three major differences between the API of Named-Readtables,
and the API of packages.
1. Readtable names are symbols not strings.
Time has shown that the fact that packages are named by strings
causes severe headache because of the potential of package names
colliding with each other.
Hence, readtables are named by symbols lest to make the
situation worse than it already is. Consequently, readtables
named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can
happily coexist next to each other. Or, taken to an extreme,
`SCHEME:SYNTAX` and `ELISP:SYNTAX`.
If, for example to duly signify the importance of your cool
readtable hack, you really think it deserves a global name, you
can always resort to keywords.
2. The inheritance is resolved statically, not dynamically.
A package that uses another package will have access to all the
other package's exported symbols, even to those that will be
added after its definition. I.e. the inheritance is resolved at
run-time, that is dynamically.
Unfortunately, we cannot do the same for readtables in a
portable manner.
Therefore, we do not talk about \"using\" another readtable but
about \"merging\" the other readtable's definition into the
readtable we are going to define. I.e. the inheritance is
resolved once at definition time, that is statically.
(Such merging can more or less be implemented portably albeit at
a certain cost. Most of the time, this cost manifests itself at
the time a readtable is defined, i.e. once at compile-time, so
it may not bother you. Nonetheless, we provide extra support for
Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your
implementation of choice are welcome, of course.)
3. DEFREADTABLE does not have compile-time effects.
If you define a package via DEFPACKAGE, you can make that
package the currently active package for the subsequent
compilation of the same file via IN-PACKAGE. The same is,
however, not true for DEFREADTABLE and IN-READTABLE for the
following reason:
It's unlikely that the need for special reader-macros arises for
a problem which can be solved in just one file. Most often,
you're going to define the reader macro functions, and set up
the corresponding readtable in an extra file.
If DEFREADTABLE had compile-time effects, you'd have to wrap
each definition of a reader-macro function in an EVAL-WHEN to
make its definition available at compile-time. Because that's
simply not the common case, DEFREADTABLE does not have a
compile-time effect.
If you want to use a readtable within the same file as its
definition, wrap the DEFREADTABLE and the reader-macro function
definitions in an explicit EVAL-WHEN.")
(defsection @named-readtables-preregistered (:title "Preregistered Readtables"
:export nil)
"- NIL, :STANDARD, and :COMMON-LISP designate the
_standard readtable_.
- :MODERN designates a _case-preserving_ _standard-readtable_.
- :CURRENT designates the _current readtable_.")
(defsection @named-readtables-examples (:title "Examples" :export nil)
"```commonlisp
(defreadtable elisp:syntax
(:merge :standard)
(:macro-char #\\? #'elisp::read-character-literal t)
(:macro-char #\\[ #'elisp::read-vector-literal t)
...
(:case :preserve))
(defreadtable scheme:syntax
(:merge :standard)
(:macro-char #\\[ #'(lambda (stream char)
(read-delimited-list #\\] stream)))
(:macro-char #\\# :dispatch)
(:dispatch-macro-char #\\# #\\t #'scheme::read-#t)
(:dispatch-macro-char #\\# #\\f #'scheme::read-#f)
...
(:case :preserve))
(in-readtable elisp:syntax)
...
(in-readtable scheme:syntax)
...
```")
(defsection @named-readtables-reference (:title "Reference")
(defreadtable macro)
(in-readtable macro)
(make-readtable function)
(merge-readtables-into function)
(find-readtable function)
(ensure-readtable function)
(rename-readtable function)
(readtable-name function)
(register-readtable function)
(unregister-readtable function)
(copy-named-readtable function)
(list-all-named-readtables function)
(named-readtable-designator type)
(reader-macro-conflict condition)
(readtable-does-already-exist condition)
(readtable-does-not-exist condition))
;;;; Generating own docs
(defun update-readmes ()
(with-open-file (stream (asdf:system-relative-pathname :named-readtables
"README.md")
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(document @named-readtables-manual :stream stream)
(print-markdown-footer stream))
(with-open-file (stream (asdf:system-relative-pathname :named-readtables
"README")
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(describe @named-readtables-manual stream)
(print-markdown-footer stream)))
(defun print-markdown-footer (stream)
(format stream "~%* * *~%")
(format stream "###### \\[generated by ~
[MGL-PAX](https://github.com/melisgl/mgl-pax)\\]~%"))
#|
(update-readmes)
|#
abcl-src-1.9.0/contrib/named-readtables/test/src/named-readtables.lisp 0100644 0000000 0000000 00000053675 14202767264 024447 0 ustar 00 0000000 0000000 ;;;; -*- Mode:Lisp -*-
;;;;
;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler
;;;; Copyright (c) 2007, Robert P. Goldman and SIFT, LLC
;;;;
;;;; All rights reserved.
;;;;
;;;; See LICENSE for details.
;;;;
(in-package :editor-hints.named-readtables)
;;;
;;; ``This is enough of a foothold to implement a more elaborate
;;; facility for using readtables in a localized way.''
;;;
;;; (X3J13 Cleanup Issue IN-SYNTAX)
;;;
;;;;;; DEFREADTABLE &c.
(defmacro defreadtable (name &body options)
"Define a new named readtable, whose name is given by the symbol NAME.
Or, if a readtable is already registered under that name, redefine
that one.
The readtable can be populated using the following OPTIONS:
- `(:MERGE READTABLE-DESIGNATORS+)`
Merge the readtables designated into the new readtable being
defined as per MERGE-READTABLES-INTO.
If no :MERGE clause is given, an empty readtable is used. See
MAKE-READTABLE.
- `(:FUSE READTABLE-DESIGNATORS+)`
Like :MERGE except:
Error conditions of type READER-MACRO-CONFLICT that are signaled
during the merge operation will be silently _continued_. It
follows that reader macros in earlier entries will be
overwritten by later ones. For backward compatibility, :FUZE is
accepted as an alias of :FUSE.
- `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)`
Define a new sub character `SUB-CHAR` for the dispatching macro
character `MACRO-CHAR`, per SET-DISPATCH-MACRO-CHARACTER. You
probably have to define `MACRO-CHAR` as a dispatching macro
character by the following option first.
- `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])`
Define a new macro character in the readtable, per
SET-MACRO-CHARACTER. If `FUNCTION` is the keyword :DISPATCH,
`MACRO-CHAR` is made a dispatching macro character, per
MAKE-DISPATCH-MACRO-CHARACTER.
- `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)`
Set the character syntax of TO-CHAR in the readtable being
defined to the same syntax as FROM-CHAR as per
SET-SYNTAX-FROM-CHAR.
- `(:CASE CASE-MODE)`
Defines the _case sensitivity mode_ of the resulting readtable.
Any number of option clauses may appear. The options are grouped by
their type, but in each group the order the options appeared
textually is preserved. The following groups exist and are executed
in the following order: :MERGE and :FUSE (one
group), :CASE, :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group),
finally :SYNTAX-FROM.
Notes:
The readtable is defined at load-time. If you want to have it
available at compilation time -- say to use its reader-macros in the
same file as its definition -- you have to wrap the DEFREADTABLE
form in an explicit EVAL-WHEN.
On redefinition, the target readtable is made empty first before
it's refilled according to the clauses.
NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are
preregistered readtable names."
(check-type name symbol)
(when (reserved-readtable-name-p name)
(error "~A is the designator for a predefined readtable. ~
Not acceptable as a user-specified readtable name." name))
(flet ((process-option (option var)
(destructure-case option
((:merge &rest readtable-designators)
`(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)
readtable-designators)))
((:fuse &rest readtable-designators)
`(handler-bind ((reader-macro-conflict #'continue))
(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)
readtable-designators))))
;; alias for :FUSE
((:fuze &rest readtable-designators)
`(handler-bind ((reader-macro-conflict #'continue))
(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)
readtable-designators))))
((:dispatch-macro-char disp-char sub-char function)
`(set-dispatch-macro-character ,disp-char ,sub-char
,function ,var))
((:macro-char char function &optional non-terminating-p)
(if (eq function :dispatch)
`(make-dispatch-macro-character ,char ,non-terminating-p ,var)
`(set-macro-character ,char ,function
,non-terminating-p ,var)))
((:syntax-from from-rt-designator from-char to-char)
`(set-syntax-from-char ,to-char ,from-char
,var (find-readtable ,from-rt-designator)))
((:case mode)
`(setf (readtable-case ,var) ,mode))))
(remove-clauses (clauses options)
(setq clauses (if (listp clauses) clauses (list clauses)))
(remove-if-not #'(lambda (x) (member x clauses))
options :key #'first)))
(let* ((merge-clauses (remove-clauses '(:merge :fuze :fuse) options))
(case-clauses (remove-clauses :case options))
(macro-clauses (remove-clauses '(:macro-char :dispatch-macro-char)
options))
(syntax-clauses (remove-clauses :syntax-from options))
(other-clauses
(set-difference options
(append merge-clauses case-clauses
macro-clauses syntax-clauses))))
(cond
((not (null other-clauses))
(error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))
(t
`(eval-when (:load-toplevel :execute)
;; The (FIND-READTABLE ...) isqrt important for proper
;; redefinition semantics, as redefining has to modify the
;; already existing readtable object.
(let ((readtable (find-readtable ',name)))
(cond ((not readtable)
(setq readtable (make-readtable ',name)))
(t
(setq readtable (%clear-readtable readtable))
(simple-style-warn
"Overwriting already existing readtable ~S."
readtable)))
,@(loop for option in merge-clauses
collect (process-option option 'readtable))
,@(loop for option in case-clauses
collect (process-option option 'readtable))
,@(loop for option in macro-clauses
collect (process-option option 'readtable))
,@(loop for option in syntax-clauses
collect (process-option option 'readtable))
readtable)))))))
(defmacro in-readtable (name)
"Set *READTABLE* to the readtable referred to by the symbol NAME."
(check-type name symbol)
`(eval-when (:compile-toplevel :load-toplevel :execute)
;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO*
;; (GET-MACRO-CHARACTER #\"))
(setf *readtable* (ensure-readtable ',name))
(when (find-package :swank)
(%frob-swank-readtable-alist *package* *readtable*))))
;;; KLUDGE: [interim solution]
;;;
;;; We need support for this in Slime itself, because we want IN-READTABLE
;;; to work on a per-file basis, and not on a per-package basis.
;;;
(defun %frob-swank-readtable-alist (package readtable)
(let ((readtable-alist (find-symbol (string '#:*readtable-alist*)
(find-package :swank))))
(when (boundp readtable-alist)
(pushnew (cons (package-name package) readtable)
(symbol-value readtable-alist)
:test #'(lambda (entry1 entry2)
(destructuring-bind (pkg-name1 . rt1) entry1
(destructuring-bind (pkg-name2 . rt2) entry2
(and (string= pkg-name1 pkg-name2)
(eq rt1 rt2)))))))))
(deftype readtable-designator ()
`(or null readtable))
(deftype named-readtable-designator ()
"Either a symbol or a readtable itself."
`(or readtable-designator symbol))
;;;;; Compiler macros
;;; Since the :STANDARD readtable is interned, and we can't enforce
;;; its immutability, we signal a style-warning for suspicious uses
;;; that may result in strange behaviour:
;;; Modifying the standard readtable would, obviously, lead to a
;;; propagation of this change to all places which use the :STANDARD
;;; readtable (and thus rendering this readtable to be non-standard,
;;; in fact.)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun constant-standard-readtable-expression-p (thing)
(or (null thing)
(eq thing :standard)
(and (consp thing)
(find thing
'((find-readtable nil)
(find-readtable :standard)
(ensure-readtable nil)
(ensure-readtable :standard))
:test #'equal))))
(defun signal-suspicious-registration-warning (name-expr readtable-expr)
(when (constant-standard-readtable-expression-p readtable-expr)
(simple-style-warn
"Caution: ~~% ~S"
(list name-expr name-expr) readtable-expr))))
(define-compiler-macro register-readtable (&whole form name readtable)
(signal-suspicious-registration-warning name readtable)
form)
(define-compiler-macro ensure-readtable (&whole form name &optional
(default nil default-p))
(when default-p
(signal-suspicious-registration-warning name default))
form)
(declaim (special *standard-readtable* *empty-readtable*))
(define-api make-readtable
(&optional (name nil name-supplied-p) &key merge)
(&optional named-readtable-designator &key (:merge list) => readtable)
"Creates and returns a new readtable under the specified
NAME.
MERGE takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
readtables the new readtable is created from. (See the :MERGE clause
of DEFREADTABLE for details.)
If MERGE is NIL, an empty readtable is used instead.
If NAME is not given, an anonymous empty readtable is returned.
Notes:
An empty readtable is a readtable where each character's syntax is
the same as in the _standard readtable_ except that each macro
character has been made a constituent. Basically: whitespace stays
whitespace, everything else is constituent."
(cond ((not name-supplied-p)
(copy-readtable *empty-readtable*))
((reserved-readtable-name-p name)
(error "~A is the designator for a predefined readtable. ~
Not acceptable as a user-specified readtable name." name))
((let ((rt (find-readtable name)))
(and rt (prog1 nil
(cerror "Overwrite existing entry."
'readtable-does-already-exist :readtable-name name)
;; Explicitly unregister to make sure that we do
;; not hold on of any reference to RT.
(unregister-readtable rt)))))
(t (let ((result (apply #'merge-readtables-into
;; The first readtable specified in
;; the :merge list is taken as the
;; basis for all subsequent
;; (destructive!) modifications (and
;; hence it's copied.)
(copy-readtable (if merge
(ensure-readtable
(first merge))
*empty-readtable*))
(rest merge))))
(register-readtable name result)))))
(define-api rename-readtable
(old-name new-name)
(named-readtable-designator symbol => readtable)
"Replaces the associated name of the readtable designated by
OLD-NAME with NEW-NAME. If a readtable is already registered under
NEW-NAME, an error of type READTABLE-DOES-ALREADY-EXIST is
signaled."
(when (find-readtable new-name)
(cerror "Overwrite existing entry."
'readtable-does-already-exist :readtable-name new-name))
(let* ((readtable (ensure-readtable old-name))
(readtable-name (readtable-name readtable)))
;; We use the internal functions directly to omit repeated
;; type-checking.
(%unassociate-name-from-readtable readtable-name readtable)
(%unassociate-readtable-from-name readtable-name readtable)
(%associate-name-with-readtable new-name readtable)
(%associate-readtable-with-name new-name readtable)
readtable))
(define-api merge-readtables-into
(result-readtable &rest named-readtables)
(named-readtable-designator &rest named-readtable-designator => readtable)
"Copy the contents of each readtable in NAMED-READTABLES into
RESULT-READTABLE.
If a macro character appears in more than one of the readtables,
i.e. if a conflict is discovered during the merge, an error of type
READER-MACRO-CONFLICT is signaled."
(flet ((merge-into (to from)
(do-readtable ((char reader-fn non-terminating-p disp? table) from)
(check-reader-macro-conflict from to char)
(cond ((not disp?)
(set-macro-character char reader-fn non-terminating-p to))
(t
(ensure-dispatch-macro-character char non-terminating-p to)
(loop for (subchar . subfn) in table do
(check-reader-macro-conflict from to char subchar)
(set-dispatch-macro-character char subchar
subfn to)))))
to))
(let ((result-table (ensure-readtable result-readtable)))
(dolist (table (mapcar #'ensure-readtable named-readtables))
(merge-into result-table table))
result-table)))
(defun ensure-dispatch-macro-character (char &optional non-terminating-p
(readtable *readtable*))
(if (dispatch-macro-char-p char readtable)
t
(make-dispatch-macro-character char non-terminating-p readtable)))
(define-api copy-named-readtable
(named-readtable)
(named-readtable-designator => readtable)
"Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."
(copy-readtable (ensure-readtable named-readtable)))
(define-api list-all-named-readtables () (=> list)
"Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates."
(mapcar #'ensure-readtable (%list-all-readtable-names)))
(define-condition readtable-error (error) ())
(define-condition readtable-does-not-exist (readtable-error)
((readtable-name :initarg :readtable-name
:initform (required-argument)
:accessor missing-readtable-name
:type named-readtable-designator))
(:report (lambda (condition stream)
(format stream "A readtable named ~S does not exist."
(missing-readtable-name condition)))))
(define-condition readtable-does-already-exist (readtable-error)
((readtable-name :initarg :readtable-name
:initform (required-argument)
:accessor existing-readtable-name
:type named-readtable-designator))
(:report (lambda (condition stream)
(format stream "A readtable named ~S already exists."
(existing-readtable-name condition))))
(:documentation "Continuable."))
(define-condition reader-macro-conflict (readtable-error)
((macro-char
:initarg :macro-char
:initform (required-argument)
:accessor conflicting-macro-char
:type character)
(sub-char
:initarg :sub-char
:initform nil
:accessor conflicting-dispatch-sub-char
:type (or null character))
(from-readtable
:initarg :from-readtable
:initform (required-argument)
:accessor from-readtable
:type readtable)
(to-readtable
:initarg :to-readtable
:initform (required-argument)
:accessor to-readtable
:type readtable))
(:report
(lambda (condition stream)
(format stream "~@"
(conflicting-dispatch-sub-char condition)
(conflicting-macro-char condition)
(conflicting-dispatch-sub-char condition)
(from-readtable condition)
(to-readtable condition))))
(:documentation "Continuable.
This condition is signaled during the merge process if a reader
macro (be it a macro character or the sub character of a dispatch
macro character) is present in the both source and the target
readtable and the two respective reader macro functions differ."))
(defun check-reader-macro-conflict (from to char &optional subchar)
(flet ((conflictp (from-fn to-fn)
(assert from-fn ()
"Bug in readtable iterators or concurrent access?")
(and to-fn (not (function= to-fn from-fn)))))
(when (if subchar
(conflictp (%get-dispatch-macro-character char subchar from)
(%get-dispatch-macro-character char subchar to))
(conflictp (%get-macro-character char from)
(%get-macro-character char to)))
(cerror (format nil "Overwrite ~@C in ~A." char to)
'reader-macro-conflict
:from-readtable from
:to-readtable to
:macro-char char
:sub-char subchar))))
;;; Although there is no way to get at the standard readtable in
;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
;;; up the perception of its existence by interning a copy of it.
;;;
;;; We do this for reverse lookup (cf. READTABLE-NAME), i.e. for
;;;
;;; (equal (readtable-name (find-readtable :standard)) "STANDARD")
;;;
;;; holding true.
;;;
;;; We, however, inherit the restriction that the :STANDARD
;;; readtable _must not be modified_ (cf. CLHS 2.1.1.2), although it'd
;;; technically be feasible (as *STANDARD-READTABLE* will contain a
;;; mutable copy of the implementation-internal standard readtable.)
;;; We cannot enforce this restriction without shadowing
;;; CL:SET-MACRO-CHARACTER and CL:SET-DISPATCH-MACRO-FUNCTION which
;;; is out of scope of this library, though. So we just threaten
;;; with nasal demons.
;;;
(defvar *standard-readtable*
(%standard-readtable))
(defvar *empty-readtable*
(%clear-readtable (copy-readtable nil)))
(defvar *case-preserving-standard-readtable*
(let ((readtable (copy-readtable nil)))
(setf (readtable-case readtable) :preserve)
readtable))
(defparameter *reserved-readtable-names*
'(nil :standard :common-lisp :modern :current))
(defun reserved-readtable-name-p (name)
(and (member name *reserved-readtable-names*) t))
;;; In principle, we could DEFREADTABLE some of these. But we do
;;; reserved readtable lookup seperately, since we can't register a
;;; readtable for :CURRENT anyway.
(defun find-reserved-readtable (reserved-name)
(cond ((eq reserved-name nil) *standard-readtable*)
((eq reserved-name :standard) *standard-readtable*)
((eq reserved-name :common-lisp) *standard-readtable*)
((eq reserved-name :modern) *case-preserving-standard-readtable*)
((eq reserved-name :current) *readtable*)
(t (error "Bug: no such reserved readtable: ~S" reserved-name))))
(define-api find-readtable
(name)
(named-readtable-designator => (or readtable null))
"Looks for the readtable specified by NAME and returns it if it is
found. Returns NIL otherwise."
(cond ((readtablep name) name)
((reserved-readtable-name-p name)
(find-reserved-readtable name))
((%find-readtable name))))
;;; FIXME: This doesn't take a NAMED-READTABLE-DESIGNATOR, but only a
;;; STRING-DESIGNATOR. (When fixing, heed interplay with compiler
;;; macros below.)
(defsetf find-readtable register-readtable)
(define-api ensure-readtable
(name &optional (default nil default-p))
(named-readtable-designator &optional (or named-readtable-designator null)
=> readtable)
"Looks up the readtable specified by NAME and returns it if it's found.
If it is not found, it registers the readtable designated by DEFAULT
under the name represented by NAME; or if no default argument is
given, it signals an error of type READTABLE-DOES-NOT-EXIST
instead."
(cond ((find-readtable name))
((not default-p)
(error 'readtable-does-not-exist :readtable-name name))
(t (setf (find-readtable name) (ensure-readtable default)))))
(define-api register-readtable
(name readtable)
(symbol readtable => readtable)
"Associate READTABLE with NAME. Returns the readtable."
(assert (typep name '(not (satisfies reserved-readtable-name-p))))
(%associate-readtable-with-name name readtable)
(%associate-name-with-readtable name readtable)
readtable)
(define-api unregister-readtable
(named-readtable)
(named-readtable-designator => boolean)
"Remove the association of NAMED-READTABLE. Returns T if successfull,
NIL otherwise."
(let* ((readtable (find-readtable named-readtable))
(readtable-name (and readtable (readtable-name readtable))))
(if (not readtable-name)
nil
(prog1 t
(check-type readtable-name
(not (satisfies reserved-readtable-name-p)))
(%unassociate-readtable-from-name readtable-name readtable)
(%unassociate-name-from-readtable readtable-name readtable)))))
(define-api readtable-name
(named-readtable)
(named-readtable-designator => symbol)
"Returns the name of the readtable designated by NAMED-READTABLE,
or NIL."
(let ((readtable (ensure-readtable named-readtable)))
(cond ((%readtable-name readtable))
((eq readtable *readtable*) :current)
((eq readtable *standard-readtable*) :common-lisp)
((eq readtable *case-preserving-standard-readtable*) :modern)
(t nil))))
abcl-src-1.9.0/contrib/named-readtables/test/src/package.lisp 0100644 0000000 0000000 00000002347 14202767264 022640 0 ustar 00 0000000 0000000 (in-package :common-lisp-user)
;;; This is is basically MGL-PAX:DEFINE-PACKAGE but we don't have it
;;; defined yet. The package variance stuff is because we export
;;; documentation from the NAMED-READTABLES-DOC system.
(eval-when (:compile-toplevel :load-toplevel :execute)
(locally
(declare #+sbcl
(sb-ext:muffle-conditions sb-kernel::package-at-variance))
(handler-bind
(#+sbcl (sb-kernel::package-at-variance #'muffle-warning))
(defpackage :editor-hints.named-readtables
(:use :common-lisp)
(:nicknames :named-readtables)
(:export
#:defreadtable
#:in-readtable
#:make-readtable
#:merge-readtables-into
#:find-readtable
#:ensure-readtable
#:rename-readtable
#:readtable-name
#:register-readtable
#:unregister-readtable
#:copy-named-readtable
#:list-all-named-readtables
;; Types
#:named-readtable-designator
;; Conditions
#:reader-macro-conflict
#:readtable-does-already-exist
#:readtable-does-not-exist)
(:documentation "See NAMED-READTABLES:@NAMED-READTABLES-MANUAL.")))))
(pushnew :named-readtables *features*)
abcl-src-1.9.0/contrib/named-readtables/test/src/utils.lisp 0100644 0000000 0000000 00000023445 14202767264 022407 0 ustar 00 0000000 0000000 ;;;;
;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler