Commit 3176b414 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Various run-program related fixes:

* have run-program on ECL on SLIME.
* remove now unnecessary &allow-other-keys from slurp-input-stream and vomit-output-stream.
* add stripln and :stripped t support to slurp-input-stream string.
* add convenience functions println and writeln.
parent 4caf0cc7
...@@ -140,7 +140,7 @@ by /bin/sh in POSIX" ...@@ -140,7 +140,7 @@ by /bin/sh in POSIX"
(apply fun (first processor) stream (rest processor)) (apply fun (first processor) stream (rest processor))
(funcall fun processor stream))) (funcall fun processor stream)))
(defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys) (defgeneric slurp-input-stream (processor input-stream &key)
(:documentation (:documentation
"SLURP-INPUT-STREAM is a generic function with two positional arguments "SLURP-INPUT-STREAM is a generic function with two positional arguments
PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps) PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
...@@ -165,40 +165,40 @@ Built-in methods include the following: ...@@ -165,40 +165,40 @@ Built-in methods include the following:
Programmers are encouraged to define their own methods for this generic function.")) Programmers are encouraged to define their own methods for this generic function."))
#-(or gcl2.6 genera) #-(or gcl2.6 genera)
(defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys) (defmethod slurp-input-stream ((function function) input-stream &key)
(funcall function input-stream)) (funcall function input-stream))
(defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys) (defmethod slurp-input-stream ((list cons) input-stream &key)
(apply (first list) input-stream (rest list))) (apply (first list) input-stream (rest list)))
#-(or gcl2.6 genera) #-(or gcl2.6 genera)
(defmethod slurp-input-stream ((output-stream stream) input-stream (defmethod slurp-input-stream ((output-stream stream) input-stream
&key linewise prefix (element-type 'character) buffer-size &allow-other-keys) &key linewise prefix (element-type 'character) buffer-size)
(copy-stream-to-stream (copy-stream-to-stream
input-stream output-stream input-stream output-stream
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
(defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys) (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
(declare (ignorable x)) (declare (ignorable x))
(slurp-stream-string stream)) (slurp-stream-string stream :stripped stripped))
(defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys) (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
(declare (ignorable x)) (declare (ignorable x))
(slurp-stream-string stream)) (slurp-stream-string stream :stripped stripped))
(defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys) (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
(declare (ignorable x)) (declare (ignorable x))
(slurp-stream-lines stream :count count)) (slurp-stream-lines stream :count count))
(defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys) (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
(declare (ignorable x)) (declare (ignorable x))
(slurp-stream-line stream :at at)) (slurp-stream-line stream :at at))
(defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys) (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
(declare (ignorable x)) (declare (ignorable x))
(slurp-stream-forms stream :count count)) (slurp-stream-forms stream :count count))
(defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys) (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
(declare (ignorable x)) (declare (ignorable x))
(slurp-stream-form stream :at at)) (slurp-stream-form stream :at at))
...@@ -206,8 +206,8 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -206,8 +206,8 @@ Programmers are encouraged to define their own methods for this generic function
(declare (ignorable x)) (declare (ignorable x))
(apply 'slurp-input-stream *standard-output* stream keys)) (apply 'slurp-input-stream *standard-output* stream keys))
(defmethod slurp-input-stream ((x null) stream &rest keys &key &allow-other-keys) (defmethod slurp-input-stream ((x null) stream &key)
(declare (ignorable x stream keys)) (declare (ignorable x stream))
nil) nil)
(defmethod slurp-input-stream ((pathname pathname) input (defmethod slurp-input-stream ((pathname pathname) input
...@@ -228,8 +228,7 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -228,8 +228,7 @@ Programmers are encouraged to define their own methods for this generic function
:element-type element-type :buffer-size buffer-size :linewise linewise))) :element-type element-type :buffer-size buffer-size :linewise linewise)))
(defmethod slurp-input-stream (x stream (defmethod slurp-input-stream (x stream
&key linewise prefix (element-type 'character) buffer-size &key linewise prefix (element-type 'character) buffer-size)
&allow-other-keys)
(declare (ignorable stream linewise prefix element-type buffer-size)) (declare (ignorable stream linewise prefix element-type buffer-size))
(cond (cond
#+(or gcl2.6 genera) #+(or gcl2.6 genera)
...@@ -244,7 +243,7 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -244,7 +243,7 @@ Programmers are encouraged to define their own methods for this generic function
(with-upgradability () (with-upgradability ()
(defgeneric vomit-output-stream (processor output-stream &key &allow-other-keys) (defgeneric vomit-output-stream (processor output-stream &key)
(:documentation (:documentation
"VOMIT-OUTPUT-STREAM is a generic function with two positional arguments "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits) PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
...@@ -263,20 +262,20 @@ Built-in methods include the following: ...@@ -263,20 +262,20 @@ Built-in methods include the following:
Programmers are encouraged to define their own methods for this generic function.")) Programmers are encouraged to define their own methods for this generic function."))
#-(or gcl2.6 genera) #-(or gcl2.6 genera)
(defmethod vomit-output-stream ((function function) output-stream &key &allow-other-keys) (defmethod vomit-output-stream ((function function) output-stream &key)
(funcall function output-stream)) (funcall function output-stream))
(defmethod vomit-output-stream ((list cons) output-stream &key &allow-other-keys) (defmethod vomit-output-stream ((list cons) output-stream &key)
(apply (first list) output-stream (rest list))) (apply (first list) output-stream (rest list)))
#-(or gcl2.6 genera) #-(or gcl2.6 genera)
(defmethod vomit-output-stream ((input-stream stream) output-stream (defmethod vomit-output-stream ((input-stream stream) output-stream
&key linewise prefix (element-type 'character) buffer-size &allow-other-keys) &key linewise prefix (element-type 'character) buffer-size)
(copy-stream-to-stream (copy-stream-to-stream
input-stream output-stream input-stream output-stream
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
(defmethod vomit-output-stream ((x string) stream &key fresh-line terpri &allow-other-keys) (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
(princ x stream) (princ x stream)
(when fresh-line (fresh-line stream)) (when fresh-line (fresh-line stream))
(when terpri (terpri stream)) (when terpri (terpri stream))
...@@ -286,8 +285,8 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -286,8 +285,8 @@ Programmers are encouraged to define their own methods for this generic function
(declare (ignorable x)) (declare (ignorable x))
(apply 'vomit-output-stream *standard-input* stream keys)) (apply 'vomit-output-stream *standard-input* stream keys))
(defmethod vomit-output-stream ((x null) stream &rest keys &key &allow-other-keys) (defmethod vomit-output-stream ((x null) stream &key)
(declare (ignorable x stream keys)) (declare (ignorable x stream))
(values)) (values))
(defmethod vomit-output-stream ((pathname pathname) input (defmethod vomit-output-stream ((pathname pathname) input
...@@ -308,8 +307,7 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -308,8 +307,7 @@ Programmers are encouraged to define their own methods for this generic function
:element-type element-type :buffer-size buffer-size :linewise linewise))) :element-type element-type :buffer-size buffer-size :linewise linewise)))
(defmethod vomit-output-stream (x stream (defmethod vomit-output-stream (x stream
&key linewise prefix (element-type 'character) buffer-size &key linewise prefix (element-type 'character) buffer-size)
&allow-other-keys)
(declare (ignorable stream linewise prefix element-type buffer-size)) (declare (ignorable stream linewise prefix element-type buffer-size))
(cond (cond
#+(or gcl2.6 genera) #+(or gcl2.6 genera)
...@@ -320,7 +318,7 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -320,7 +318,7 @@ Programmers are encouraged to define their own methods for this generic function
x stream x stream
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
(t (t
(error "Invalid ~S destination ~S" 'vomit-output-stream x))))) (error "Invalid ~S source ~S" 'vomit-output-stream x)))))
;;;; ----- Running an external program ----- ;;;; ----- Running an external program -----
......
...@@ -23,6 +23,7 @@ ...@@ -23,6 +23,7 @@
#:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line
#:read-file-forms #:read-file-form #:safe-read-file-form #:read-file-forms #:read-file-form #:safe-read-file-form
#:eval-input #:eval-thunk #:standard-eval-thunk #:eval-input #:eval-thunk #:standard-eval-thunk
#:println #:writeln
;; Temporary files ;; Temporary files
#:*temporary-directory* #:temporary-directory #:default-temporary-directory #:*temporary-directory* #:temporary-directory #:default-temporary-directory
#:setup-temporary-directory #:setup-temporary-directory
...@@ -39,22 +40,35 @@ ...@@ -39,22 +40,35 @@
"the original standard input stream at startup") "the original standard input stream at startup")
(defun setup-stdin () (defun setup-stdin ()
(setf *stdin* #+clozure ccl::*stdin* #-clozure *standard-input*)) (setf *stdin*
#.(or #+clozure 'ccl::*stdin*
#+(or cmu scl) 'system:*stdin*
#+ecl 'ext::+process-standard-input+
#+sbcl 'sb-sys:*stdin*
'*standard-input*)))
(defvar *stdout* *standard-output* (defvar *stdout* *standard-output*
"the original standard output stream at startup") "the original standard output stream at startup")
(defun setup-stdout () (defun setup-stdout ()
(setf *stdout* #+clozure ccl::*stdout* #-clozure *standard-output*)) (setf *stdout*
#.(or #+clozure 'ccl::*stdout*
#+(or cmu scl) 'system:*stdout*
#+ecl 'ext::+process-standard-output+
#+sbcl 'sb-sys:*stdout*
'*standard-output*)))
(defvar *stderr* *error-output* (defvar *stderr* *error-output*
"the original error output stream at startup") "the original error output stream at startup")
(defun setup-stderr () (defun setup-stderr ()
(setf *stderr* (setf *stderr*
#+allegro excl::*stderr* #.(or #+allegro excl::*stderr*
#+clozure ccl::*stderr* #+clozure 'ccl::*stderr*
#-(or allegro clozure) *error-output*)) #+(or cmu scl) 'system:*stderr*
#+ecl 'ext::+process-error-output+
#+sbcl 'sb-sys:*stderr*
'*error-output*)))
(setup-stdin) (setup-stdout) (setup-stderr)) (setup-stdin) (setup-stdout) (setup-stderr))
...@@ -319,11 +333,13 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." ...@@ -319,11 +333,13 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f) ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
(concatenate-files (list input) output)) (concatenate-files (list input) output))
(defun slurp-stream-string (input &key (element-type 'character)) (defun slurp-stream-string (input &key (element-type 'character) stripped)
"Read the contents of the INPUT stream as a string" "Read the contents of the INPUT stream as a string"
(with-open-stream (input input) (let ((string
(with-output-to-string (output) (with-open-stream (input input)
(copy-stream-to-stream input output :element-type element-type)))) (with-output-to-string (output)
(copy-stream-to-stream input output :element-type element-type)))))
(if stripped (stripln string) string)))
(defun slurp-stream-lines (input &key count) (defun slurp-stream-lines (input &key count)
"Read the contents of the INPUT stream as a list of lines, return those lines. "Read the contents of the INPUT stream as a list of lines, return those lines.
...@@ -454,6 +470,13 @@ If a string, repeatedly read and evaluate from it, returning the last values." ...@@ -454,6 +470,13 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(let ((*read-eval* t)) (let ((*read-eval* t))
(eval-thunk thunk)))))) (eval-thunk thunk))))))
(with-upgradability ()
(defun println (x &optional (stream *standard-output*))
(princ x stream) (terpri stream) (values))
(defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys)
(apply 'write x keys) (terpri stream) (values)))
;;; Using temporary files ;;; Using temporary files
(with-upgradability () (with-upgradability ()
......
...@@ -20,7 +20,7 @@ ...@@ -20,7 +20,7 @@
#:emptyp ;; sequences #:emptyp ;; sequences
#:+non-base-chars-exist-p+ ;; characters #:+non-base-chars-exist-p+ ;; characters
#:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
#:first-char #:last-char #:split-string #:first-char #:last-char #:split-string #:stripln
#:string-prefix-p #:string-enclosed-p #:string-suffix-p #:string-prefix-p #:string-enclosed-p #:string-suffix-p
#:find-class* ;; CLOS #:find-class* ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
...@@ -248,6 +248,22 @@ starting the separation from the end, e.g. when called with arguments ...@@ -248,6 +248,22 @@ starting the separation from the end, e.g. when called with arguments
(incf words) (incf words)
(setf end start)))))) (setf end start))))))
(defvar *cr* (coerce #(#\cr) 'string))
(defvar *lf* (coerce #(#\newline) 'string))
(defvar *crlf* (coerce #(#\cr #\newline) 'string))
(defun stripln (x)
(check-type x string)
(let* ((len (length x))
(endlfp (equal (last-char x) #\linefeed))
(endcrlfp (and endlfp (<= 2 len) (eql (char x (- len 2)) #\return)))
(endcrp (equal (last-char x) #\return)))
(cond
(endlfp (values (subseq x 0 (- len 1)) *lf*))
(endcrp (values (subseq x 0 (- len 1)) *cr*))
(endcrlfp (values (subseq x 0 (- len 2)) *crlf*))
(t (values x nil)))))
(defun string-prefix-p (prefix string) (defun string-prefix-p (prefix string)
"Does STRING begin with PREFIX?" "Does STRING begin with PREFIX?"
(let* ((x (string prefix)) (let* ((x (string prefix))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment