Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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
authored April 25, 2010
15  .gitignore
... ...
@@ -0,0 +1,15 @@
  1
+# really this is private to my build process
  2
+make/
  3
+common-lisp.net
  4
+.vcs
  5
+GNUmakefile
  6
+init-lisp.lisp
  7
+website/changelog.xml
  8
+
  9
+
  10
+lift.tar.gz
  11
+website/output/
  12
+test-results*/
  13
+lift-local.config
  14
+*.dribble
  15
+*.fasl
2  dev/definitions.lisp
@@ -4,4 +4,4 @@
4 4
   "The path to a Bourne compatible command shell in 
5 5
 physical pathname notation.")
6 6
 
7  
-(defvar *shell-search-paths* '("/usr/bin/" "/usr/local/bin"))
  7
+(defvar *shell-search-paths* '("/usr/bin/" "/usr/local/bin/"))
3  dev/shell.lisp
@@ -37,7 +37,8 @@ may be used to find a shell to use in executing `command`."
37 37
 	    (or (loop for path in *shell-search-paths* do
38 38
 		     (let ((full-binary (make-pathname :name binary
39 39
 						       :defaults path))) 
40  
-		       (when (probe-file full-binary)
  40
+		       (when (and (probe-file full-binary)
  41
+				  (directory-pathname-p full-binary))
41 42
 			 (return full-binary))))
42 43
 		binary)))
43 44
     (multiple-value-bind (output error status)
16  dev/utilities.lisp
@@ -10,11 +10,25 @@
10 10
   (dolist (mapping *os-alist*)
11 11
     (destructuring-bind (os &rest features) mapping
12 12
       (dolist (f features)
13  
-	(when (find f *features*) (return-from os os))))))
  13
+	(when (find f *features*) (return-from host-os os))))))
14 14
 
  15
+#+(or)
15 16
 (defun os-pathname (pathname &key (os (os)))
16 17
   (namestring pathname))
17 18
 
  19
+(defun directory-pathname-p (pathname)
  20
+  "Does `pathname` syntactically  represent a directory?
  21
+
  22
+A directory-pathname is a pathname _without_ a filename. The three
  23
+ways that the filename components can be missing are for it to be `nil`, 
  24
+`:unspecific` or the empty string.
  25
+"
  26
+  (flet ((check-one (x)
  27
+	   (not (null (member x '(nil :unspecific "")
  28
+			      :test 'equal)))))
  29
+    (and (check-one (pathname-name pathname))
  30
+	 (check-one (pathname-type pathname)))))
  31
+
18 32
 #+(or)
19 33
 ;; from asdf-install
20 34
 (defun tar-argument (arg)
189  timeout/with-timeout.lisp
@@ -2,67 +2,142 @@
2 2
 
3 3
 (eval-when (:compile-toplevel :load-toplevel :execute)
4 4
 (unless (and (find-symbol (symbol-name '#:with-timeout)
5  
-			  '#:com.metabang.trivial-timeout)
6  
-	     (fboundp (find-symbol (symbol-name '#:with-timeout)
7  
-			  '#:com.metabang.trivial-timeout)))
  5
+        '#:com.metabang.trivial-timeout)
  6
+       (fboundp (find-symbol (symbol-name '#:with-timeout)
  7
+        '#:com.metabang.trivial-timeout)))
8 8
 (define-condition timeout-error (error)
9 9
                   ()
10 10
   (:report (lambda (c s)
11  
-	     (declare (ignore c))
12  
-	     (format s "Process timeout"))))
  11
+       (declare (ignore c))
  12
+       (format s "Process timeout")))
  13
+  (:documentation "An error signaled when the duration specified in 
  14
+the [with-timeout][] is exceeded."))
  15
+
  16
+#+allegro
  17
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
  18
+  `(mp:with-timeout (,seconds-symbol (error 'timeout-error)) 
  19
+     (,doit-symbol)))
  20
+
  21
+
  22
+#+(and sbcl (not sb-thread))
  23
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
  24
+  (let ((glabel (gensym "label-"))
  25
+  (gused-timer? (gensym "used-timer-")))
  26
+    `(let ((,gused-timer? nil))
  27
+       (catch ',glabel
  28
+   (sb-ext:schedule-timer
  29
+    (sb-ext:make-timer (lambda ()
  30
+             (setf ,gused-timer? t)
  31
+             (throw ',glabel nil)))
  32
+    ,seconds-symbol)
  33
+   (,doit-symbol))
  34
+       (when ,gused-timer?
  35
+   (error 'timeout-error)))))
  36
+
  37
+#+(and sbcl sb-thread)
  38
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
  39
+  `(handler-case 
  40
+      (sb-ext:with-timeout ,seconds-symbol (,doit-symbol))
  41
+    (sb-ext::timeout (c)
  42
+      (declare (ignore c))
  43
+      (error 'timeout-error))))
  44
+
  45
+#+cmu
  46
+;;; surely wrong
  47
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
  48
+  `(handler-case 
  49
+      (mp:with-timeout (seconds-symbol) (,doit-symbol))
  50
+    (sb-ext::timeout (c)
  51
+      (declare (ignore c))
  52
+      (error 'timeout-error))))
  53
+
  54
+#+(or digitool openmcl ccl)
  55
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
  56
+  (let ((checker-process (format nil "Checker ~S" (gensym)))
  57
+   (waiting-process (format nil "Waiter ~S" (gensym)))
  58
+   (result (gensym))
  59
+   (process (gensym)))
  60
+    `(let* ((,result nil)
  61
+      (,process (ccl:process-run-function 
  62
+           ,checker-process
  63
+           (lambda ()
  64
+       (setf ,result (multiple-value-list (,doit-symbol))))))) 
  65
+       (ccl:process-wait-with-timeout
  66
+  ,waiting-process
  67
+  (* ,seconds-symbol #+(or openmcl ccl)
  68
+     ccl:*ticks-per-second* #+digitool 60)
  69
+  (lambda ()
  70
+    (not (ccl::process-active-p ,process)))) 
  71
+       (when (ccl::process-active-p ,process)
  72
+   (ccl:process-kill ,process)
  73
+   (cerror "Timeout" 'timeout-error))
  74
+       (values-list ,result))))
  75
+
  76
+#+(or digitool openmcl ccl)
  77
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
  78
+  (let ((gsemaphore (gensym "semaphore"))
  79
+	(gresult (gensym "result"))
  80
+	(gprocess (gensym "process")))
  81
+   `(let* ((,gsemaphore (ccl:make-semaphore))
  82
+           (,gresult)
  83
+           (,gprocess
  84
+            (ccl:process-run-function
  85
+             ,(format nil "Timed Process ~S" gprocess)
  86
+             (lambda ()
  87
+               (setf ,gresult (multiple-value-list (,doit-symbol)))
  88
+               (ccl:signal-semaphore ,gsemaphore)))))
  89
+      (cond ((ccl:timed-wait-on-semaphore ,gsemaphore ,seconds-symbol)
  90
+             (values-list ,gresult))
  91
+            (t
  92
+             (ccl:process-kill ,gprocess)
  93
+             (error 'timeout-error))))))
  94
+
  95
+#+lispworks
  96
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
  97
+  (let ((gresult (gensym "result-"))
  98
+  (gprocess (gensym "process-")))
  99
+    `(let* (,gresult
  100
+      (,gprocess (mp:process-run-function
  101
+      "WITH-TIMEOUT"
  102
+      '()
  103
+      (lambda ()
  104
+        (setq ,gresult (multiple-value-list (,doit-symbol)))))))
  105
+       (unless (mp:process-wait-with-timeout
  106
+    "WITH-TIMEOUT"
  107
+    ,seconds-symbol
  108
+    (lambda ()
  109
+      (not (mp:process-alive-p ,gprocess))))
  110
+   (mp:process-kill ,gprocess)
  111
+   (cerror "Timeout" 'timeout-error))
  112
+       (values-list ,gresult))))
  113
+
  114
+(unless (let ((symbol
  115
+         (find-symbol (symbol-name '#:generate-platform-specific-code)
  116
+          '#:com.metabang.trivial-timeout)))
  117
+    (and symbol (fboundp symbol)))
  118
+  (defun generate-platform-specific-code (seconds-symbol doit-symbol)
  119
+    (declare (ignore seconds-symbol))
  120
+    `(,doit-symbol)))
13 121
 
14 122
 (defmacro with-timeout ((seconds) &body body)
  123
+  "Execute `body` for no more than `seconds` time. 
  124
+
  125
+If `seconds` is exceeded, then a [timeout-error][] will be signaled. 
  126
+
  127
+If `seconds` is nil, then the body will be run normally until it completes
  128
+or is interrupted."
  129
+  (build-with-timeout seconds body))
  130
+
  131
+(defun build-with-timeout (seconds body)
15 132
   (let ((gseconds (gensym "seconds-"))
16  
-	#+(and sbcl (not sb-thread))
17  
-	(glabel (gensym "label-"))
18  
-	#+(and sbcl (not sb-thread))
19  
-	(gused-timer? (gensym "used-timer-")))
  133
+  (gdoit (gensym "doit-")))
20 134
     `(let ((,gseconds ,seconds))
21  
-       (flet ((doit ()
22  
-		(progn ,@body)))
23  
-	 (cond (,gseconds
24  
-		#+allegro
25  
-		(mp:with-timeout (,gseconds (error 'timeout-error)) 
26  
-		  (doit))
27  
-		#+cmu
28  
-		(mp:with-timeout (,gseconds) (doit))
29  
-		#+(and sbcl sb-thread)
30  
-		(handler-case 
31  
-		    (sb-ext:with-timeout ,gseconds (doit))
32  
-		  (sb-ext::timeout (c)
33  
-		    (error 'timeout-error)))
34  
-		#+(and sbcl (not sb-thread))
35  
-		(let ((,gused-timer? nil))
36  
-		  (catch ',glabel
37  
-		    (sb-ext:schedule-timer
38  
-		     (sb-ext:make-timer (lambda ()
39  
-					  (setf ,gused-timer? t)
40  
-					  (throw ',glabel nil)))
41  
-		     ,gseconds)
42  
-		    (doit))
43  
-		  (when ,gused-timer?
44  
-		    (error 'timeout-error)))
45  
-		#+(or digitool openmcl ccl)
46  
-		,(let ((checker-process (format nil "Checker ~S" (gensym)))
47  
-		       (waiting-process (format nil "Waiter ~S" (gensym)))
48  
-		       (result (gensym))
49  
-		       (process (gensym)))
50  
-		      `(let* ((,result nil)
51  
-			      (,process (ccl:process-run-function 
52  
-					 ,checker-process
53  
-					 (lambda ()
54  
-					   (setf ,result (progn (doit))))))) 
55  
-			 (ccl:process-wait-with-timeout
56  
-			  ,waiting-process
57  
-			  (* ,gseconds #+(or openmcl ccl)
58  
-			     ccl:*ticks-per-second* #+digitool 60)
59  
-			  (lambda ()
60  
-			    (not (ccl::process-active-p ,process)))) 
61  
-			 (when (ccl::process-active-p ,process)
62  
-			   (ccl:process-kill ,process)
63  
-			   (cerror "Timeout" 'timeout-error))
64  
-			 (values ,result)))
65  
-		#-(or allegro cmu sb-thread openmcl ccl mcl digitool)
66  
-		(progn (doit)))
67  
-	       (t
68  
-		(doit)))))))))
  135
+       (flet ((,gdoit ()
  136
+    (progn ,@body)))
  137
+   (cond (,gseconds
  138
+    ,(generate-platform-specific-code gseconds gdoit))
  139
+         (t
  140
+    (,gdoit)))))))
  141
+
  142
+
  143
+))
1  trivial-shell.asd
@@ -39,6 +39,7 @@ of gamma radiation and repeated does of the sonic screwdriver.
39 39
 		:components 
40 40
 		((:file "definitions")
41 41
 		 (:file "macros")
  42
+		 (:file "utilities")
42 43
 		 (:file "shell"
43 44
 			:depends-on ("definitions" "macros" #+digitool "mcl"))))
44 45
 	       (:module
29  website/source/index.mmd
@@ -4,13 +4,13 @@
4 4
 <div class="contents">
5 5
 <div class="system-links">
6 6
 
7  
-  * [Mailing Lists][3]
8 7
   * [Getting it][4]
9 8
   * [News][6]
10  
-  * [Test results][tr]
11  
-  * [Changelog][7]
12  
-
13  
-   [3]: #mailing-lists
  9
+{remark 
  10
+    * [Test results][tr]
  11
+    * [Changelog][7]
  12
+  }
  13
+  
14 14
    [4]: #downloads
15 15
    [5]: documentation/ (documentation link)
16 16
    [6]: #news
@@ -29,21 +29,15 @@ the underlying Operating System. It includes:
29 29
  * [os-process-id][] and, of course,
30 30
  * [shell-command][]
31 31
  
32  
-{anchor mailing-lists}
33  
-
34  
-### Mailing Lists
35  
-
36  
-  * [trivial-shell-devel][devel-list]: A list for questions,
37  
-    patches, bug reports, and so on; You name it, it's for
38  
-    it.
39  
-
40 32
 {anchor downloads}
41 33
 
42 34
 ### Where is it
43 35
 
44  
-A [darcs][] repository is available. The darcs command is:
45  
-    
46  
-    darcs get http://common-lisp.net/project/trivial-shell
  36
+metabang.com is slowly switching from [darcs][] to [git][]
  37
+for source control; the *trivial-shell* repository is on
  38
+[github][github-trivial-shell] and you can clone it using:
  39
+
  40
+    git clone git://github.com/gwkkwg/trivial-shell
47 41
 
48 42
 Trivial-shell is also [ASDF installable][asdf-install]. Its
49 43
 CLiki home is right [where][cliki-home] you'd
@@ -56,6 +50,9 @@ There's also a handy [gzipped tar file][tarball].
56 50
 
57 51
 ### What is happening
58 52
 
  53
+25 April 2010 - (time flies); moved to git and pulled in some
  54
+fixes from Jochen Schmidt (thanks!).
  55
+
59 56
 10 Jun 2008 - S'S'S'Syncing up with the jones
60 57
 
61 58
 6 Nov 2007 - Pulled website to [CL-Markdown][] format,

0 notes on commit 70aad20

Please sign in to comment.
Something went wrong with that request. Please try again.