From 5093ad6645375d1d9259097ea5c9122e5592be2f Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Wed, 23 Jul 2003 22:08:21 +0000
Subject: [PATCH] r5379: *** empty log message ***

---
 kmrcl.asd     |  3 ++-
 os.lisp       | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++
 package.lisp  |  5 ++++-
 strmatch.lisp | 58 ++++++++++++++++++++++++++----------------------
 4 files changed, 99 insertions(+), 28 deletions(-)
 create mode 100644 os.lisp

diff --git a/kmrcl.asd b/kmrcl.asd
index 39596fe..a14a6e3 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: kmrcl.asd,v 1.42 2003/07/21 08:41:19 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.43 2003/07/23 22:07:48 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -55,6 +55,7 @@
      (:file "processes" :depends-on ("macros"))
      (:file "listener" :depends-on ("sockets" "processes" "console"))
      (:file "repl" :depends-on ("listener" "strings"))
+     (:file "os" :depends-on ("macros"))
      ))
 
 
diff --git a/os.lisp b/os.lisp
new file mode 100644
index 0000000..f7e600f
--- /dev/null
+++ b/os.lisp
@@ -0,0 +1,61 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          os.lisp
+;;;; Purpose:       Operating System utilities
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Jul 2003
+;;;;
+;;;; $Id: os.lisp,v 1.1 2003/07/23 22:08:21 kevin Exp $
+;;;;
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defun run-shell-command (control-string &rest args)
+  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, 
+returns (VALUES string-output exit-code)"
+  (let ((command (apply #'format nil control-string args)))
+    #+sbcl
+    (sb-impl::process-exit-code
+     (sb-ext:run-program  
+      "/bin/sh"
+      (list  "-c" command)
+      :input nil :output nil))
+    
+    #+(or cmu scl)
+    (ext:process-exit-code
+     (ext:run-program  
+      "/bin/sh"
+      (list  "-c" command)
+      :input nil :output nil))
+    
+    #+allegro
+    (multiple-value-bind (output dummy exit)
+	(excl:run-shell-command command :input nil :output :stream
+				:wait nil)
+      (declare (ignore dummy))
+      (values output exit))
+    
+    #+lispworks
+    (system:call-system-showing-output
+     command
+     :shell-type "/bin/sh"
+     :output-stream output)
+    
+    #+clisp		;XXX not exactly *verbose-out*, I know
+    (ext:run-shell-command  command :output :terminal :wait t)
+    
+    #+openmcl
+    (nth-value 1
+	       (ccl:external-process-status
+		(ccl:run-program "/bin/sh" (list "-c" command)
+				 :input nil :output nil
+				 :wait t)))
+	   
+    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+
+    ))
diff --git a/package.lisp b/package.lisp
index 16b5ed0..735662a 100644
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.53 2003/07/21 00:52:56 kevin Exp $
+;;;; $Id: package.lisp,v 1.54 2003/07/23 22:07:48 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -227,6 +227,9 @@
    
    ;; fformat.lisp
    #:fformat
+
+   ;; os.lisp
+   #:run-shell-command
    
    ))
 
diff --git a/strmatch.lisp b/strmatch.lisp
index a56f3bf..69d28e4 100644
--- a/strmatch.lisp
+++ b/strmatch.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: strmatch.lisp,v 1.1 2003/07/21 00:52:56 kevin Exp $
+;;;; $Id: strmatch.lisp,v 1.2 2003/07/23 22:07:48 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -20,36 +20,42 @@
 
 
 (defun score-multiword-match (s1 s2)
-  "Score a match between two strings with s1 being reference string"
-  (let* ((word-list-1 (split-alphanumeric-string s1))
+  "Score a match between two strings with s1 being reference string.
+S1 can be a string or a list or strings/conses"
+  (let* ((word-list-1 (if (stringp s1)
+			  (split-alphanumeric-string s1)
+			s1))
 	 (word-list-2 (split-alphanumeric-string s2))
 	 (n1 (length word-list-1))
 	 (n2 (length word-list-2))
 	 (unmatched n1)
-	 (score 0)
-	 (nlong 0)
-	 (nshort 0)
-	 short-list long-list)
-    (declare (fixnum n1 n2 nshort nlong score unmatched))
-    (if (> n1 n2)
-	(progn
-	  (setq nlong n1)
-	  (setq nshort n2)
-	  (setq long-list word-list-1)
-	  (setq short-list word-list-2))
-      (progn
-	(setq nlong n2)
-	(setq nshort n1)
-	(setq long-list word-list-2)
-	(setq short-list word-list-1)))
-    (decf score (* 3 (- nlong nshort))) ;; reduce score for extra words
-    (dotimes (iword nshort)
+	 (score 0))
+    (declare (fixnum n1 n2 score unmatched))
+    (decf score (* 4 (abs (- n1 n2))))
+    (dotimes (iword n1)
       (declare (fixnum iword))
-      (kmrcl:aif (position (nth iword short-list) long-list :test #'string-equal)
-		 (progn
-		   (incf score (- 20 (abs (- kmrcl::it iword))))
-		   (decf unmatched))))
-    (decf score (* 5 unmatched))
+      (let ((w1 (nth iword word-list-1))
+	    pos)
+	(cond
+	 ((consp w1)
+	  (let ((first t))
+	    (dotimes (i-alt (length w1))
+	      (setq pos
+		(position (nth i-alt w1) word-list-2
+			  :test #'string-equal))
+	      (when pos
+		(incf score (- 30
+			       (if first 0 5)
+			       (abs (- iword pos))))
+		(decf unmatched)
+		(return))
+	      (setq first nil))))
+	 ((stringp w1)
+	  (kmrcl:awhen (position w1 word-list-2
+			       :test #'string-equal)
+		       (incf score (- 30 (abs (- kmrcl::it iword))))
+		       (decf unmatched))))))
+    (decf score (* 4 unmatched))
     score))
 
 
-- 
2.34.1