X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=base%2Futils.lisp;h=1584104d72ceb16d8836473cc9c2dc3f245b9ce7;hb=c339a403634db7fc71308bb6da91e81af4cde1bb;hp=98ada92fca4932c6658100063ca9d59d78d2f623;hpb=2c14c425a4a203e03b74b868fdf727ea0d48572a;p=clsql.git diff --git a/base/utils.lisp b/base/utils.lisp index 98ada92..1584104 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -178,14 +178,14 @@ returns (VALUES string-output error-output exit-status)" #+lispworks ;; BUG: Lispworks combines output and error streams - (let ((output (make-output-string-stream))) + (let ((output (make-string-output-stream))) (unwind-protect (let ((status (system:call-system-showing-output command :shell-type "/bin/sh" :output-stream output))) - (values (get-output-string output) nil status)) + (values (get-output-stream-string output) nil status)) (close output))) #+clisp @@ -231,3 +231,60 @@ returns (VALUES string-output error-output exit-status)" (keyword name) (string (nth-value 0 (intern (string-default-case name) :keyword))) (symbol (nth-value 0 (intern (symbol-name name) :keyword))))) + +;; From KMRCL +(defmacro in (obj &rest choices) + (let ((insym (gensym))) + `(let ((,insym ,obj)) + (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c)) + choices))))) + +;; From KMRCL +(defun substitute-char-string (procstr match-char subst-str) + "Substitutes a string for a single matching character of a string" + (substitute-chars-strings procstr (list (cons match-char subst-str)))) + +(defun replaced-string-length (str repl-alist) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((i 0 (1+ i)) + (orig-len (length str)) + (new-len orig-len)) + ((= i orig-len) new-len) + (declare (fixnum i orig-len new-len)) + (let* ((c (char str i)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (when match + (incf new-len (1- (length + (the simple-string (cdr match))))))))) + + +(defun substitute-chars-strings (str repl-alist) + "Replace all instances of a chars with a string. repl-alist is an assoc +list of characters and replacement strings." + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((orig-len (length str)) + (new-string (make-string (replaced-string-length str repl-alist))) + (spos 0 (1+ spos)) + (dpos 0)) + ((>= spos orig-len) + new-string) + (declare (fixnum spos dpos) (simple-string new-string)) + (let* ((c (char str spos)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (if match + (let* ((subst (cdr match)) + (len (length subst))) + (declare (fixnum len) + (simple-string subst)) + (dotimes (j len) + (declare (fixnum j)) + (setf (char new-string dpos) (char subst j)) + (incf dpos))) + (progn + (setf (char new-string dpos) c) + (incf dpos)))))) +