Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
152 lines (130 sloc) 5.17 KB
(in-package :asia)
(defmacro with-unique-names (names &body forms)
"Binds each variable named by a symbol in NAMES to a unique symbol around
FORMS. Each of NAMES must either be either a symbol, or of the form:
(symbol string-designator)
Bare symbols appearing in NAMES are equivalent to:
(symbol symbol)
The string-designator is used as the argument to GENSYM when constructing the
unique symbol the named variable will be bound to."
(flet ((%trans (name)
(multiple-value-bind (symbol string)
(etypecase name
(values name (symbol-name name)))
((cons symbol (cons (or symbol string character) null))
(values (first name) (string (second name)))))
`(,symbol (gensym ,string)))))
(let ((entries (mapcar #'%trans names)))
`(let ,entries
(defun emptyp (sequence)
"Returns true if SEQUENCE is an empty sequence. Signals an error if
SEQUENCE is not a sequence"
(etypecase sequence
(list (null sequence))
(sequence (zerop (length sequence)))))
(defun pathspec (name &key type defaults)
"This implements the concept of ASDF \"pathname specifier\".
If NAME is a pathname designator except a symbol or string, returns
itself; if NAME is a symbol, treat it as the downcase form of its
symbol-name; if NAME is a string, treat it as the \"pathname
If TYPE is :DIRECTORY or NAME ends with a slash, returns a directory
pathname; if TYPE is a string, it will be the new type component of
the specifier.
The specifier will use the host and device components from DEFAULTS or
See ASDF manual 5.3.4 for details."
(if (typep name '(or pathname symbol string))
(funcall (if (fboundp 'coerce-pathname)
name :type type :defaults defaults)
(pathspec (pathname name) :type type :defaults defaults)))
(defun location-designator-p (location-designator)
"Tests whether LOCATION-DESIGNATOR is available.
NOTE: Although NIL and T are available in ASDF, they are unavailable
in ASIA."
(and (asdf::location-designator-p location-designator)
(not (typep location-designator 'boolean))))
(defun location (location-designator &key directory wilden)
"This implements the concept of ASDF location DSL.
If DIRECTORY is true, LOCATION-DESIGNATOR will be treated as a
If WILDEN is true, LOCATION-DESIGNATOR can be a wildcard.
See ASDF manual 7.4 & 8.3 for the details of LOCATION-DESIGNATOR."
(if (location-designator-p location-designator)
(resolve-location location-designator :directory directory :wilden wilden)
(error "Invalid location designator ~S~%" location-designator)))
(let ((getpid (or (find-symbol "PROCESS-ID" :system)
;; old name prior to 2005-03-01, clisp <= 2.33.2
(find-symbol "PROGRAM-ID" :system)
#+win32 ; integrated into the above since 2005-02-24
(and (find-package :win32) ; optional modules/win32
(find-symbol "GetCurrentProcessId" :win32)))))
(defun %getpid () ; a required interface
(getpid (funcall getpid))
#+win32 ((ext:getenv "PID")) ; where does that come from?
(t -1))))
(defun %getpid ()
(defun %getpid ()
(let* ((runtime
(java:jstatic "getRuntime" "java.lang.Runtime"))
"java.lang.String" #("sh" "-c" "echo $PPID")))
;; Complicated because java.lang.Runtime.exec() is
;; overloaded on a non-primitive type (array of
;; java.lang.String), so we have to use the actual
;; parameter instance to get java.lang.Class
(java:jmethod "java.lang.Runtime" "exec"
(java:jmethod "java.lang.Object" "getClass")
(java:jcall runtime-exec-jmethod runtime command))
(java:jcall (java:jmethod "java.lang.Process" "getInputStream")
(java:jcall (java:jmethod "java.lang.Process" "waitFor")
(loop :with b
:do (setq b
(java:jcall (java:jmethod "" "read")
:until (member b '(-1 #x0a)) ; Either EOF or LF
:collecting (code-char b) :into result
:finally (return
(parse-integer (coerce result 'string)))))
(t () 0)))
(defun getpid ()
#-(or sbcl clozure clisp ecl cmucl lispworks allegro abcl)