Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Move to git, minor love and care

* Bring in two ideas from Jochen Schmidt to increase reliablity
* Add dev/utilities.lisp
* Various perturbations
* Moved to git, tweaked website
  • Loading branch information...
commit 70aad20ac5f7ec8573e76e43a919b3f64eb23d9b 1 parent 62bb144
Gary King authored
View
15 .gitignore
@@ -0,0 +1,15 @@
+# really this is private to my build process
+make/
+common-lisp.net
+.vcs
+GNUmakefile
+init-lisp.lisp
+website/changelog.xml
+
+
+lift.tar.gz
+website/output/
+test-results*/
+lift-local.config
+*.dribble
+*.fasl
View
2  dev/definitions.lisp
@@ -4,4 +4,4 @@
"The path to a Bourne compatible command shell in
physical pathname notation.")
-(defvar *shell-search-paths* '("/usr/bin/" "/usr/local/bin"))
+(defvar *shell-search-paths* '("/usr/bin/" "/usr/local/bin/"))
View
3  dev/shell.lisp
@@ -37,7 +37,8 @@ may be used to find a shell to use in executing `command`."
(or (loop for path in *shell-search-paths* do
(let ((full-binary (make-pathname :name binary
:defaults path)))
- (when (probe-file full-binary)
+ (when (and (probe-file full-binary)
+ (directory-pathname-p full-binary))
(return full-binary))))
binary)))
(multiple-value-bind (output error status)
View
16 dev/utilities.lisp
@@ -10,11 +10,25 @@
(dolist (mapping *os-alist*)
(destructuring-bind (os &rest features) mapping
(dolist (f features)
- (when (find f *features*) (return-from os os))))))
+ (when (find f *features*) (return-from host-os os))))))
+#+(or)
(defun os-pathname (pathname &key (os (os)))
(namestring pathname))
+(defun directory-pathname-p (pathname)
+ "Does `pathname` syntactically represent a directory?
+
+A directory-pathname is a pathname _without_ a filename. The three
+ways that the filename components can be missing are for it to be `nil`,
+`:unspecific` or the empty string.
+"
+ (flet ((check-one (x)
+ (not (null (member x '(nil :unspecific "")
+ :test 'equal)))))
+ (and (check-one (pathname-name pathname))
+ (check-one (pathname-type pathname)))))
+
#+(or)
;; from asdf-install
(defun tar-argument (arg)
View
189 timeout/with-timeout.lisp
@@ -2,67 +2,142 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (and (find-symbol (symbol-name '#:with-timeout)
- '#:com.metabang.trivial-timeout)
- (fboundp (find-symbol (symbol-name '#:with-timeout)
- '#:com.metabang.trivial-timeout)))
+ '#:com.metabang.trivial-timeout)
+ (fboundp (find-symbol (symbol-name '#:with-timeout)
+ '#:com.metabang.trivial-timeout)))
(define-condition timeout-error (error)
()
(:report (lambda (c s)
- (declare (ignore c))
- (format s "Process timeout"))))
+ (declare (ignore c))
+ (format s "Process timeout")))
+ (:documentation "An error signaled when the duration specified in
+the [with-timeout][] is exceeded."))
+
+#+allegro
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ `(mp:with-timeout (,seconds-symbol (error 'timeout-error))
+ (,doit-symbol)))
+
+
+#+(and sbcl (not sb-thread))
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (let ((glabel (gensym "label-"))
+ (gused-timer? (gensym "used-timer-")))
+ `(let ((,gused-timer? nil))
+ (catch ',glabel
+ (sb-ext:schedule-timer
+ (sb-ext:make-timer (lambda ()
+ (setf ,gused-timer? t)
+ (throw ',glabel nil)))
+ ,seconds-symbol)
+ (,doit-symbol))
+ (when ,gused-timer?
+ (error 'timeout-error)))))
+
+#+(and sbcl sb-thread)
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ `(handler-case
+ (sb-ext:with-timeout ,seconds-symbol (,doit-symbol))
+ (sb-ext::timeout (c)
+ (declare (ignore c))
+ (error 'timeout-error))))
+
+#+cmu
+;;; surely wrong
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ `(handler-case
+ (mp:with-timeout (seconds-symbol) (,doit-symbol))
+ (sb-ext::timeout (c)
+ (declare (ignore c))
+ (error 'timeout-error))))
+
+#+(or digitool openmcl ccl)
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (let ((checker-process (format nil "Checker ~S" (gensym)))
+ (waiting-process (format nil "Waiter ~S" (gensym)))
+ (result (gensym))
+ (process (gensym)))
+ `(let* ((,result nil)
+ (,process (ccl:process-run-function
+ ,checker-process
+ (lambda ()
+ (setf ,result (multiple-value-list (,doit-symbol)))))))
+ (ccl:process-wait-with-timeout
+ ,waiting-process
+ (* ,seconds-symbol #+(or openmcl ccl)
+ ccl:*ticks-per-second* #+digitool 60)
+ (lambda ()
+ (not (ccl::process-active-p ,process))))
+ (when (ccl::process-active-p ,process)
+ (ccl:process-kill ,process)
+ (cerror "Timeout" 'timeout-error))
+ (values-list ,result))))
+
+#+(or digitool openmcl ccl)
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (let ((gsemaphore (gensym "semaphore"))
+ (gresult (gensym "result"))
+ (gprocess (gensym "process")))
+ `(let* ((,gsemaphore (ccl:make-semaphore))
+ (,gresult)
+ (,gprocess
+ (ccl:process-run-function
+ ,(format nil "Timed Process ~S" gprocess)
+ (lambda ()
+ (setf ,gresult (multiple-value-list (,doit-symbol)))
+ (ccl:signal-semaphore ,gsemaphore)))))
+ (cond ((ccl:timed-wait-on-semaphore ,gsemaphore ,seconds-symbol)
+ (values-list ,gresult))
+ (t
+ (ccl:process-kill ,gprocess)
+ (error 'timeout-error))))))
+
+#+lispworks
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (let ((gresult (gensym "result-"))
+ (gprocess (gensym "process-")))
+ `(let* (,gresult
+ (,gprocess (mp:process-run-function
+ "WITH-TIMEOUT"
+ '()
+ (lambda ()
+ (setq ,gresult (multiple-value-list (,doit-symbol)))))))
+ (unless (mp:process-wait-with-timeout
+ "WITH-TIMEOUT"
+ ,seconds-symbol
+ (lambda ()
+ (not (mp:process-alive-p ,gprocess))))
+ (mp:process-kill ,gprocess)
+ (cerror "Timeout" 'timeout-error))
+ (values-list ,gresult))))
+
+(unless (let ((symbol
+ (find-symbol (symbol-name '#:generate-platform-specific-code)
+ '#:com.metabang.trivial-timeout)))
+ (and symbol (fboundp symbol)))
+ (defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (declare (ignore seconds-symbol))
+ `(,doit-symbol)))
(defmacro with-timeout ((seconds) &body body)
+ "Execute `body` for no more than `seconds` time.
+
+If `seconds` is exceeded, then a [timeout-error][] will be signaled.
+
+If `seconds` is nil, then the body will be run normally until it completes
+or is interrupted."
+ (build-with-timeout seconds body))
+
+(defun build-with-timeout (seconds body)
(let ((gseconds (gensym "seconds-"))
- #+(and sbcl (not sb-thread))
- (glabel (gensym "label-"))
- #+(and sbcl (not sb-thread))
- (gused-timer? (gensym "used-timer-")))
+ (gdoit (gensym "doit-")))
`(let ((,gseconds ,seconds))
- (flet ((doit ()
- (progn ,@body)))
- (cond (,gseconds
- #+allegro
- (mp:with-timeout (,gseconds (error 'timeout-error))
- (doit))
- #+cmu
- (mp:with-timeout (,gseconds) (doit))
- #+(and sbcl sb-thread)
- (handler-case
- (sb-ext:with-timeout ,gseconds (doit))
- (sb-ext::timeout (c)
- (error 'timeout-error)))
- #+(and sbcl (not sb-thread))
- (let ((,gused-timer? nil))
- (catch ',glabel
- (sb-ext:schedule-timer
- (sb-ext:make-timer (lambda ()
- (setf ,gused-timer? t)
- (throw ',glabel nil)))
- ,gseconds)
- (doit))
- (when ,gused-timer?
- (error 'timeout-error)))
- #+(or digitool openmcl ccl)
- ,(let ((checker-process (format nil "Checker ~S" (gensym)))
- (waiting-process (format nil "Waiter ~S" (gensym)))
- (result (gensym))
- (process (gensym)))
- `(let* ((,result nil)
- (,process (ccl:process-run-function
- ,checker-process
- (lambda ()
- (setf ,result (progn (doit)))))))
- (ccl:process-wait-with-timeout
- ,waiting-process
- (* ,gseconds #+(or openmcl ccl)
- ccl:*ticks-per-second* #+digitool 60)
- (lambda ()
- (not (ccl::process-active-p ,process))))
- (when (ccl::process-active-p ,process)
- (ccl:process-kill ,process)
- (cerror "Timeout" 'timeout-error))
- (values ,result)))
- #-(or allegro cmu sb-thread openmcl ccl mcl digitool)
- (progn (doit)))
- (t
- (doit)))))))))
+ (flet ((,gdoit ()
+ (progn ,@body)))
+ (cond (,gseconds
+ ,(generate-platform-specific-code gseconds gdoit))
+ (t
+ (,gdoit)))))))
+
+
+))
View
1  trivial-shell.asd
@@ -39,6 +39,7 @@ of gamma radiation and repeated does of the sonic screwdriver.
:components
((:file "definitions")
(:file "macros")
+ (:file "utilities")
(:file "shell"
:depends-on ("definitions" "macros" #+digitool "mcl"))))
(:module
View
29 website/source/index.mmd
@@ -4,13 +4,13 @@
<div class="contents">
<div class="system-links">
- * [Mailing Lists][3]
* [Getting it][4]
* [News][6]
- * [Test results][tr]
- * [Changelog][7]
-
- [3]: #mailing-lists
+{remark
+ * [Test results][tr]
+ * [Changelog][7]
+ }
+
[4]: #downloads
[5]: documentation/ (documentation link)
[6]: #news
@@ -29,21 +29,15 @@ the underlying Operating System. It includes:
* [os-process-id][] and, of course,
* [shell-command][]
-{anchor mailing-lists}
-
-### Mailing Lists
-
- * [trivial-shell-devel][devel-list]: A list for questions,
- patches, bug reports, and so on; You name it, it's for
- it.
-
{anchor downloads}
### Where is it
-A [darcs][] repository is available. The darcs command is:
-
- darcs get http://common-lisp.net/project/trivial-shell
+metabang.com is slowly switching from [darcs][] to [git][]
+for source control; the *trivial-shell* repository is on
+[github][github-trivial-shell] and you can clone it using:
+
+ git clone git://github.com/gwkkwg/trivial-shell
Trivial-shell is also [ASDF installable][asdf-install]. Its
CLiki home is right [where][cliki-home] you'd
@@ -56,6 +50,9 @@ There's also a handy [gzipped tar file][tarball].
### What is happening
+25 April 2010 - (time flies); moved to git and pulled in some
+fixes from Jochen Schmidt (thanks!).
+
10 Jun 2008 - S'S'S'Syncing up with the jones
6 Nov 2007 - Pulled website to [CL-Markdown][] format,
Please sign in to comment.
Something went wrong with that request. Please try again.