Import Upstream version 2c0upstream/2c0

1 files changed, 85 insertions, 4 deletions

diff --git a/vscm.init b/vscm.init
index 7d4661b..6868213 100644
--- a/vscm.init
+++ b/vscm.init
@@ -1,5 +1,5 @@
 ;;;"vscm.init" Configuration of *features* for VSCM	-*-scheme-*-
-;Copyright (C) 1994 Aubrey Jaffer
+;Copyright (C) 1994, 1996, 1997 Aubrey Jaffer
 ;
 ;Permission to copy this software, to redistribute it, and to use it
 ;for any purpose is granted, subject to the following restrictions and
@@ -21,8 +21,6 @@
 ;;; Date: Tue, 1 Mar 1994 11:42:31 -0500
 ;;; Disclaimer: The code below is only a quick hack.  If I find some
 ;;; time to spare I might get around to make some more things work.
-;;; In particular, string ports could be made available without too
-;;; much trouble.
 
 ;;; You have to provide ``vscm.init'' as an explicit command line
 ;;; argument.  Since this is not very nice I would recommend the
@@ -89,6 +87,14 @@
 	       (else "")))))
     (lambda () library-path)))
 
+;;; (home-vicinity) should return the vicinity of the user's HOME
+;;; directory, the directory which typically contains files which
+;;; customize a computer environment for a user.
+
+(define home-vicinity
+  (let ((home-path (getenv "HOME")))
+    (lambda () home-path)))
+
 ;;; *FEATURES* should be set to a list of symbols describing features
 ;;; of this implementation.  Suggestions for features are:
 
@@ -120,7 +126,7 @@
 	delay				;has DELAY and FORCE
 	with-file			;has WITH-INPUT-FROM-FILE and
 					;WITH-OUTPUT-FROM-FILE
-;	string-port			;has CALL-WITH-INPUT-STRING and
+	string-port			;has CALL-WITH-INPUT-STRING and
 					;CALL-WITH-OUTPUT-STRING
 ;	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
 ;	char-ready?
@@ -184,6 +190,75 @@
 ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
 ;;; port versions of CALL-WITH-*PUT-FILE.
 
+(define (call-with-output-string proc)
+  (let ((outsp (open-output-string)))
+    (proc outsp)
+    (close-output-port outsp)))
+
+(define (call-with-input-string string proc)
+  (let* ((insp (open-input-string string))
+	 (res (proc insp)))
+    (close-input-port insp)
+    res))
+
+;;; Implementation of string ports using generic ports
+(define (open-input-string s)
+
+  (let ((l (string-length s))
+	(eof (call-with-values (lambda () (string-read "")) (lambda (x y) x))))
+
+    (define (read)
+      (call-with-values
+       (lambda ()
+	 (string-read s))
+       (lambda (obj res)
+	 (set! s res)
+	 (set! l (string-length res))
+	 obj)))
+
+  (define (read-char)
+    (if (zero? l)
+	eof
+	(let ((c (string-ref s 0)))
+	  (set! s (substring s 1 l))
+	  (set! l (- l 1))
+	  c)))
+
+  (define (peek-char)
+    (if (zero? l) eof (string-ref s 0)))
+
+  (define (char-ready?) #t)
+
+  (define (close) s)
+
+  (open-input-generic read read-char peek-char char-ready? close)))
+
+(define (open-output-string)
+
+  (let ((s ""))
+
+    (define (write x)
+      (set! s (string-append s (string-write x)))
+      x)
+
+    (define (display x)
+      (set! s (string-append s (string-display x)))
+      x)
+
+    (define (write-char x)
+      (set! s (string-append s (string x)))
+      x)
+
+    (define (newline)
+      (set! s (string-append s "\n"))
+      #f)
+
+    (define (flush) #f)
+
+    (define (close) s)
+
+    (open-output-generic write display write-char newline flush close)))
+
 ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
 ;;; be returned by CHAR->INTEGER.
 (define char-code-limit 256)
@@ -251,6 +326,12 @@
 	  (evl o))
 	(set! *load-pathname* old-load-pathname)))))
 
+(define slib:warn
+  (lambda args
+    (let ((port (current-error-port)))
+      (display "Warn: " port)
+      (for-each (lambda (x) (display x port)) args))))
+
 ;;; define an error procedure for the library
 (define slib:error error)