diff --git a/doc/toothless.scm.doc b/doc/toothless.scm.doc new file mode 100644 index 0000000..c6839cb --- /dev/null +++ b/doc/toothless.scm.doc @@ -0,0 +1,64 @@ +This file documents names defined in toothless.scm + + + + +NOTES + +toothless.scm defines a Scheme 48 module that is R4RS without features +that could examine or effect the file system. You can also use it as a +model of how to execute code in other protected environments in S48. + + + + +DEFINITIONS AND DESCRIPTIONS + + +structure +loser-package + +Exports: + +procedure +loser name --> error + +Raises an error like "Illegal call NAME". + + +structure +toothless + +Exports everything of R4RS. Following procedures are redefined, so +they raise an error if the are called: + +call-with-input-file +call-with-output-file +load +open-input-file +open-output-file +transcript-on +with-input-from-file +with-input-to-file +eval +interaction-environment +scheme-report-environment + +toothless shall create an environment as described in NOTES. + + +structure +toothless-eval + +Exports: + +procedure +eval-safely expression + +Creates a brand new package, imports the TOOTHLESS structure, and +evaluates EXP in it. When the evaluation is done, the environment is +thrown away, so EXP's side-effects don't persist from one EVAL-SAFELY +call to the next. If EXP raises an error exception, we abort and +return #f. + + diff --git a/stringhax.scm b/stringhax.scm index 30b5d59..d4de51f 100644 --- a/stringhax.scm +++ b/stringhax.scm @@ -2,6 +2,7 @@ ;;; Copyright (c) 1995 by Olin Shivers. ;;; Copyright (c) 1997 by Mike Sperber +; do a 'map' on each character of the string (define (string-map f s) (let* ((slen (string-length s)) (ns (make-string slen))) @@ -9,6 +10,7 @@ ((< i 0) ns) (string-set! ns i (f (string-ref s i)))))) +; convert string to down-/uppercase (define (downcase-string s) (string-map char-downcase s)) @@ -16,6 +18,7 @@ (string-map char-upcase s)) +;return index of first character contained in char-set (define (char-set-index str cset . maybe-start) (let-optionals maybe-start ((start 0)) (let ((len (string-length str))) @@ -24,6 +27,8 @@ (char-set-contains? cset (string-ref str i))) (and (< i len) i)))))) +;return index of last character contained in char-set +;NOTE: character defined by maybe-start is not looked up (define (char-set-rindex str cset . maybe-start) (let ((len (string-length str))) (let-optionals maybe-start ((start len)) @@ -32,12 +37,15 @@ (char-set-contains? cset (string-ref str i))) (and (>= i 0) i)))))) +;do a "fold-right" on string +;(string-reduce nil cons s) ==> (cons ... (cons s[1] (cons s[0] nil)) ...) (define (string-reduce nil cons s) (let ((slen (string-length s))) (do ((ans nil (cons (string-ref s i) ans)) (i 0 (+ i 1))) ((= i slen) ans)))) +;is PREFIX a prefix of STRING? (define (string-prefix? prefix string) (let ((plen (string-length prefix)) (slen (string-length string))) @@ -48,6 +56,7 @@ (string-ref string i)) (lp (+ i 1)))))))) +;is SUFFIX a suffix of STRING? (define (string-suffix? suffix string) (let ((slen (string-length suffix)) (len (string-length string))) @@ -59,31 +68,22 @@ (string-ref string j)) (lp (- i 1) (- j 1)))))))) +;return index of first non-whitespace character in S, #f otherwise (define skip-whitespace (let ((non-whitespace (char-set-complement char-set:whitespace))) (lambda (s) (char-set-index s non-whitespace)))) ; Why is this so complicated? +; Hope, it isn't anymore *g* Andreas (define (trim-spaces string) - (if (string=? "" string) - string - (let* ((length (string-length string)) - (start - (if (not (char=? #\space (string-ref string 0))) - 0 - (do ((index 0 (+ 1 index))) - ((or (= index length) - (not (char=? #\space (string-ref string index)))) - index)))) - (end - (if (not (char=? #\space (string-ref string (- length 1)))) - length - (do ((index (- length 1) (- index 1))) - ((or (= index 0) - (not (char=? #\space (string-ref string index)))) - (+ 1 index)))))) - (if (and (= 0 start) - (= length end)) - string - (substring string start end))))) + (let* ((the-loop + (lambda (start incr) + (let lp ((i start)) + (if (char=? #\space (string-ref string i)) + (lp (+ i incr)) + i)))) + (start (the-loop 0 1)) + (end (+ 1 (the-loop (- (string-length string) 1) -1)))) + (substring string start end))) +