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"
(apply fun (first processor) stream (rest processor))
(funcall fun processor stream)))
(defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys)
(defgeneric slurp-input-stream (processor input-stream &key)
(:documentation
"SLURP-INPUT-STREAM is a generic function with two positional arguments
PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
......@@ -165,40 +165,40 @@ Built-in methods include the following:
Programmers are encouraged to define their own methods for this generic function."))
#-(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))
(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)))
#-(or gcl2.6 genera)
(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
input-stream output-stream
: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))
(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))
(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))
(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))
(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))
(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))
(slurp-stream-form stream :at at))
......@@ -206,8 +206,8 @@ Programmers are encouraged to define their own methods for this generic function
(declare (ignorable x))
(apply 'slurp-input-stream *standard-output* stream keys))
(defmethod slurp-input-stream ((x null) stream &rest keys &key &allow-other-keys)
(declare (ignorable x stream keys))
(defmethod slurp-input-stream ((x null) stream &key)
(declare (ignorable x stream))
nil)
(defmethod slurp-input-stream ((pathname pathname) input
......@@ -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)))
(defmethod slurp-input-stream (x stream
&key linewise prefix (element-type 'character) buffer-size
&allow-other-keys)
&key linewise prefix (element-type 'character) buffer-size)
(declare (ignorable stream linewise prefix element-type buffer-size))
(cond
#+(or gcl2.6 genera)
......@@ -244,7 +243,7 @@ Programmers are encouraged to define their own methods for this generic function
(with-upgradability ()
(defgeneric vomit-output-stream (processor output-stream &key &allow-other-keys)
(defgeneric vomit-output-stream (processor output-stream &key)
(:documentation
"VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
......@@ -263,20 +262,20 @@ Built-in methods include the following:
Programmers are encouraged to define their own methods for this generic function."))
#-(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))
(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)))
#-(or gcl2.6 genera)
(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
input-stream output-stream
: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)
(when fresh-line (fresh-line stream))
(when terpri (terpri stream))
......@@ -286,8 +285,8 @@ Programmers are encouraged to define their own methods for this generic function
(declare (ignorable x))
(apply 'vomit-output-stream *standard-input* stream keys))
(defmethod vomit-output-stream ((x null) stream &rest keys &key &allow-other-keys)
(declare (ignorable x stream keys))
(defmethod vomit-output-stream ((x null) stream &key)
(declare (ignorable x stream))
(values))
(defmethod vomit-output-stream ((pathname pathname) input
......@@ -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)))
(defmethod vomit-output-stream (x stream
&key linewise prefix (element-type 'character) buffer-size
&allow-other-keys)
&key linewise prefix (element-type 'character) buffer-size)
(declare (ignorable stream linewise prefix element-type buffer-size))
(cond
#+(or gcl2.6 genera)
......@@ -320,7 +318,7 @@ Programmers are encouraged to define their own methods for this generic function
x stream
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
(t
(error "Invalid ~S destination ~S" 'vomit-output-stream x)))))
(error "Invalid ~S source ~S" 'vomit-output-stream x)))))
;;;; ----- Running an external program -----
......
......@@ -23,6 +23,7 @@
#:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line
#:read-file-forms #:read-file-form #:safe-read-file-form
#:eval-input #:eval-thunk #:standard-eval-thunk
#:println #:writeln
;; Temporary files
#:*temporary-directory* #:temporary-directory #:default-temporary-directory
#:setup-temporary-directory
......@@ -39,22 +40,35 @@
"the original standard input stream at startup")
(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*
"the original standard output stream at startup")
(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*
"the original error output stream at startup")
(defun setup-stderr ()
(setf *stderr*
#+allegro excl::*stderr*
#+clozure ccl::*stderr*
#-(or allegro clozure) *error-output*))
#.(or #+allegro excl::*stderr*
#+clozure 'ccl::*stderr*
#+(or cmu scl) 'system:*stderr*
#+ecl 'ext::+process-error-output+
#+sbcl 'sb-sys:*stderr*
'*error-output*)))
(setup-stdin) (setup-stdout) (setup-stderr))
......@@ -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)
(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"
(with-open-stream (input input)
(with-output-to-string (output)
(copy-stream-to-stream input output :element-type element-type))))
(let ((string
(with-open-stream (input input)
(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)
"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."
(let ((*read-eval* t))
(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
(with-upgradability ()
......
......@@ -20,7 +20,7 @@
#:emptyp ;; sequences
#:+non-base-chars-exist-p+ ;; characters
#: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
#:find-class* ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
......@@ -248,6 +248,22 @@ starting the separation from the end, e.g. when called with arguments
(incf words)
(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)
"Does STRING begin with 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