summaryrefslogtreecommitdiffstats
path: root/vscm.init
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitf24b9140d6f74804d5599ec225717d38ca443813 (patch)
tree0da952f1a5a7c0eacfc05c296766523e32c05fe2 /vscm.init
parent8ffbc2df0fde83082610149d24e594c1cd879f4a (diff)
downloadslib-f24b9140d6f74804d5599ec225717d38ca443813.tar.gz
slib-f24b9140d6f74804d5599ec225717d38ca443813.zip
Import Upstream version 2c0upstream/2c0
Diffstat (limited to 'vscm.init')
-rw-r--r--vscm.init89
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)