[[project @ 1997-06-15 06:53:22 by ghouston]
ghouston**19970615065331
 Ignore-this: 6645bf1d4a1605546e141ef1069b0319
 * configure.in: change the version to 1.2a so it will install
 in the right place (maybe).
 
 * README: now it's a port of scsh 0.5.1.
 
 * init.scm: don't include re.scm until Guile's interface is stable.
 
 * syscalls.scm (%filter-C-strings!): moved from re.scm, following
 scsh 0.5.1.
 
 * utilities.scm: new version from scsh 0.5.1, adds string-replace!,
 substring-replace!, string-reduce.
 
 * time.scm: minor changes for scsh 0.4.4 -> 0.5.1
 
 * rw.scm: delete y-or-n? and *y-or-n-eof-count* which have moved
 in scsh 0.5.1 (to scsh.scm, but we don't need them).
] hunk ./ChangeLog 1
+Sun Jun 15 06:06:58 1997  Gary Houston  <ghouston@actrix.gen.nz>
+
+	* configure.in: change the version to 1.2a so it will install
+	in the right place (maybe).
+
+	* README: now it's a port of scsh 0.5.1.
+
+	* init.scm: don't include re.scm until Guile's interface is stable.
+
+	* match:start, match:end, match:substring updated from scsh 0.5.1.
+	regexp-substitute, regexp-substitute/global, regexp-num-submatches:
+	new from scsh 0.5.1.
+
+	* syscalls.scm (%filter-C-strings!): moved from re.scm, following
+	scsh 0.5.1.
+
+	* utilities.scm: new version from scsh 0.5.1, adds string-replace!,
+	substring-replace!, string-reduce.
+
+	* time.scm: minor changes for scsh 0.4.4 -> 0.5.1
+
+	* rw.scm: delete y-or-n? and *y-or-n-eof-count* which have moved
+	in scsh 0.5.1 (to scsh.scm, but we don't need them).
+
hunk ./README 1
-This is an incomplete port of the scheme shell (scsh) 0.4.4 to Guile.
+This is an incomplete port of the scheme shell (scsh) 0.5.1 to Guile.
hunk ./README 17
-in the installed ice-9 directory.  SLIB can be obtained by ftp from
+in the "site" directory.  SLIB can be obtained by ftp from
hunk ./configure.in 3
-AM_INIT_AUTOMAKE(guile-scsh, 1.1a, no-define)
+AM_INIT_AUTOMAKE(guile-scsh, 1.2a, no-define)
hunk ./init.scm 38
-
hunk ./init.scm 45
-(load-from-path "scsh/re.scm")
+;;(load-from-path "scsh/re.scm")
hunk ./init.scm 55
-
hunk ./re.scm 21
-  (let ((i (:optional maybe-index 0)))
-    (or (vector-ref (regexp-match:start match) i)
-	(error match:start "No sub-match found." match i))))
+  (vector-ref (regexp-match:start match)
+	      (:optional maybe-index 0)))
hunk ./re.scm 25
-  (let ((i (:optional maybe-index 0)))
-    (or (vector-ref (regexp-match:end match) i)
-	(error match:start "No sub-match found." match i))))
+  (vector-ref (regexp-match:end match)
+	      (:optional maybe-index 0)))
hunk ./re.scm 31
-    (if start
-	(substring (regexp-match:string match)
-		   start
-		   (vector-ref (regexp-match:end match) i))
-	(error match:substring "No sub-match found." match i))))
-
+    (and start (substring (regexp-match:string match)
+			  start
+			  (vector-ref (regexp-match:end match) i)))))
hunk ./re.scm 116
-(define-foreign %regexp-subst (re_subst (string-desc compiled-regexp)
-					(string match)
-					(string str)
-					(integer start)
-					(vector-desc start-vec)
-					(vector-desc end-vec)
-					(string-desc outbuf))
-  static-string	; Error msg or #f
-  integer)
+(define (regexp-substitute port match . items)
+  (let* ((str (regexp-match:string match))
+	 (sv (regexp-match:start match))
+	 (ev (regexp-match:end match))
+	 (range (lambda (item)			; Return start & end of
+		  (cond ((integer? item)	; ITEM's range in STR.
+			 (values (vector-ref sv item)
+				 (vector-ref ev item)))
+			((eq? 'pre item) (values 0 (vector-ref sv 0)))
+			((eq? 'post item) (values (vector-ref ev 0)
+						  (string-length str)))
+			(else (error "Illegal substitution item."
+				     item
+				     regexp-substitute))))))
+    (if port
hunk ./re.scm 132
-(define-foreign %regexp-subst-len (re_subst_len (string-desc compiled-regexp)
-						(string match)
-						(string str)
-						(integer start)
-						(vector-desc start-vec)
-						(vector-desc end-vec))
-  static-string	; Error msg or #f
-  integer)
+	;; Output port case.
+	(for-each (lambda (item)
+		    (if (string? item) (write-string item port)
+			(receive (si ei) (range item)
+			  (write-string str port si ei))))
+		  items)
hunk ./re.scm 139
-;;; What does this do?
+	;; Here's the string case. Make two passes -- one to
+	;; compute the length of the target string, one to fill it in.
+	(let* ((len (reduce (lambda (i item)
+			      (+ i (if (string? item) (string-length item)
+				       (receive (si ei) (range item) (- ei si)))))
+			    0 items))
+	       (ans (make-string len)))
hunk ./re.scm 147
-;(define (regexp-subst re match replacement)
-;  (let ((cr (%regexp:bytes re))
-;	(str       (regexp-match:string match))
-;	(start-vec (regexp-match:start  match))
-;	(end-vec   (regexp-match:end    match)))
-;    (receive (err out-len) (%regexp-subst-len cr str replacement 0
-;					      start-vec end-vec)
-;      (if err (error err regexp-subst str replacement) ; More data here
-;	  (let ((out-buf (make-string out-len)))
-;	    (receive (err out-len) (%regexp-subst cr str replacement 0
-;						  start-vec end-vec out-buf)
-;	      (if err (error err regexp-subst str replacement)
-;		  (substring out-buf 0 out-len))))))))
+	  (reduce (lambda (index item)
+		    (cond ((string? item)
+			   (string-replace! ans index item)
+			   (+ index (string-length item)))
+			  (else (receive (si ei) (range item)
+				  (substring-replace! ans index str si ei)
+				  (+ index (- ei si))))))
+		  0 items)
+	  ans))))
hunk ./re.scm 157
-;;; Miscellaneous
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
hunk ./re.scm 158
-;;; I do this one in C, I'm not sure why:
-;;; It is used by MATCH-FILES.
-;;; For Guile it's done in Scheme.
hunk ./re.scm 159
-(define-foreign %filter-C-strings!
-  (filter_stringvec (string pattern) ((C "char const ** ~a") cvec))
-  static-string	; error message -- #f if no error.
-  integer)	; number of files that pass the filter.
+(define (regexp-substitute/global port re str . items)
+  (let ((range (lambda (start sv ev item)	; Return start & end of
+		 (cond ((integer? item)		; ITEM's range in STR.
+			(values (vector-ref sv item)
+				(vector-ref ev item)))
+		       ((eq? 'pre item) (values start (vector-ref sv 0)))
+		       (else (error "Illegal substitution item."
+				    item
+				    regexp-substitute/global)))))
+	(num-posts (reduce (lambda (count item)
+			     (+ count (if (eq? item 'post) 1 0)))
+			   0 items)))
+    (if (and port (< num-posts 2))
hunk ./re.scm 173
-(define (%filter-C-strings! pattern vec)
-  (let ((rx (make-regexp pattern))
-	(len (vector-length vec)))
-    (let loop ((i 0) (j 0))
-      (if (= i len)
-	  (values #f j)
-	  (loop (+ i 1)
-		(if (regexec rx (vector-ref vec i) #f)
-		    (begin
-		      (vector-set! vec j (vector-ref vec i))
-		      (+ j 1))
-		    j))))))
+	;; Output port case, with zero or one POST items.
+	(let recur ((start 0))
+	  (let ((match (string-match re str start)))
+	    (if match
+		(let* ((sv (regexp-match:start match))
+		       (ev (regexp-match:end match)))
+		  (for-each (lambda (item)
+			      (cond ((string? item) (write-string item port))
+				    ((procedure? item) (write-string (item match) port))
+				    ((eq? 'post item) (recur (vector-ref ev 0)))
+				    (else (receive (si ei)
+					           (range start sv ev item)
+					    (write-string str port si ei)))))
+			    items))
+
+		(write-string str port start)))) ; No match.
+
+	(let* ((pieces (let recur ((start 0))
+			 (let ((match (string-match re str start))
+			       (cached-post #f))
+			   (if match
+			       (let* ((sv (regexp-match:start match))
+				      (ev (regexp-match:end match)))
+				 (reduce (lambda (pieces item)
+					   (cond ((string? item)
+						  (cons item pieces))
+
+						 ((procedure? item)
+						  (cons (item match) pieces))
+
+						 ((eq? 'post item)
+						  (if (not cached-post)
+						      (set! cached-post
+							    (recur (vector-ref ev 0))))
+						  (append cached-post pieces))
+
+						 (else (receive (si ei)
+							   (range start sv ev item)
+							 (cons (substring str si ei)
+							       pieces)))))
+					 '() items))
+
+			       ;; No match. Return str[start,end].
+			       (list (if (zero? start) str 
+					 (substring str start (string-length str))))))))
+	       (pieces (reverse pieces)))
+	  (if port (for-each (lambda (p) (write-string p port)) pieces)
+	      (apply string-append pieces))))))
+
+
+
+;;; Miscellaneous
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
hunk ./re.scm 240
+
+
+;;; Count the number of possible sub-matches in a regexp 
+;;; (i.e., the number of left parens).
+
+(define (regexp-num-submatches s)
+  (let* ((len (string-length s))
+	 (len-1 (- len 1)))
+    (let lp ((i 0) (nsm 0))
+      (if (= i len) nsm
+	  (case (string-ref s i)
+	    ((#\\) (if (< i len-1) (lp (+ i 2) nsm) nsm))
+	    ((#\() (lp (+ i 1) (+ nsm 1)))
+	    (else (lp (+ i 1) nsm)))))))
hunk ./rw.scm 142
-;(define (y-or-n? question . maybe-eof-value)
-;  (let loop ((count *y-or-n-eof-count*))
-;    (display question)
-;    (display " (y/n)? ")
-;    (let ((line (read-line)))
-;      (cond ((eof-object? line)
-;	     (newline)
-;	     (if (= count 0)
-;		 (:optional maybe-eof-value (error "EOF in y-or-n?"))
-;		 (begin (display "I'll only ask another ")
-;			(write count)
-;			(display " times.")
-;			(newline)
-;			(loop (- count 1)))))
-;	    ((< (string-length line) 1) (loop count))
-;	    ((char=? (string-ref line 0) #\y) #t)
-;	    ((char=? (string-ref line 0) #\n) #f)
-;	    (else (loop count))))))
-
-;(define *y-or-n-eof-count* 100)
-
hunk ./syscalls.scm 64
+;;; I do this one in C, I'm not sure why:
+;;; It is used by MATCH-FILES.
+;;; For Guile it's done in Scheme.
+
+(define-foreign %filter-C-strings!
+  (filter_stringvec (string pattern) ((C "char const ** ~a") cvec))
+  static-string	; error message -- #f if no error.
+  integer)	; number of files that pass the filter.
+
+(define (%filter-C-strings! pattern vec)
+  (let ((rx (make-regexp pattern))
+	(len (vector-length vec)))
+    (let loop ((i 0) (j 0))
+      (if (= i len)
+	  (values #f j)
+	  (loop (+ i 1)
+		(if (regexec rx (vector-ref vec i) #f)
+		    (begin
+		      (vector-set! vec j (vector-ref vec i))
+		      (+ j 1))
+		    j))))))
+
hunk ./time.scm 107
-(define-foreign %date->time/errno (date2time (fixnum sec)
+(define-foreign %date->time/error (date2time (fixnum sec)
hunk ./time.scm 116
-  desc	  ; errno or #f
+  desc	  ; errno, -1, or #f
hunk ./time.scm 121
-  (if (null? args)
-      (current-time)		; Fast path for (time).
-      (let* ((date (check-arg date? (car args) time))
-	     (tm (gmtime 0)))
-	(set-tm:sec tm (date:seconds date))
-	(set-tm:min tm (date:minute date))
-	(set-tm:hour tm (date:hour date))
-	(set-tm:mday tm (date:month-day date))
-	(set-tm:mon tm (date:month date))
-	(set-tm:year tm (date:year date))
-	(set-tm:isdst tm (if (date:summer? date) 1 0))
-	(car (mktime tm)))))
+  (if (pair? args)
+      (if (null? (cdr args))
+	  (let* ((date (check-arg date? (car args) time))
+		 (tm (gmtime 0)))
+	    (set-tm:sec tm (date:seconds date))
+	    (set-tm:min tm (date:minute date))
+	    (set-tm:hour tm (date:hour date))
+	    (set-tm:mday tm (date:month-day date))
+	    (set-tm:mon tm (date:month date))
+	    (set-tm:year tm (date:year date))
+	    (set-tm:isdst tm (if (date:summer? date) 1 0))
+	    (car (mktime tm)))
+	  (error "Too many arguments to TIME procedure" args))
+      (current-time)))		; Fast path for (time).
hunk ./utilities.scm 174
+;;; Copy string SOURCE into TARGET[start,...]
+
+(define (string-replace! target start source)
+  (let ((len (string-length source)))
+    (do ((i (+ start len -1) (- i 1))
+	 (j (- len 1) (- j 1)))
+      ((< j 0) target)
+      (string-set! target i (string-ref source j)))))
+
+
+;;; Copy SOURCE[source-start, source-end) into TARGET[start,)
+
+(define (substring-replace! target start source source-start source-end)
+  (do ((i (+ start (- source-end source-start) -1) (- i 1))
+       (j (- source-end 1) (- j 1)))
+      ((< j source-start) target)
+    (string-set! target i (string-ref source j))))
+
+
+;;; Compute (... (f (f (f zero c0) c1) c2) ...)
+
+(define (string-reduce f zero s)
+  (let ((len (string-length s)))
+    (let lp ((v zero) (i 0))
+      (if (= i len)
+	  v
+	  (lp (f v (string-ref s i)) (+ i 1))))))
+