diff options
Diffstat (limited to 'vscm.init')
| -rw-r--r-- | vscm.init | 89 |
1 files changed, 85 insertions, 4 deletions
@@ -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) |