diff options
| author | Keith Packard <keithp@keithp.com> | 2018-01-10 23:11:40 -0800 | 
|---|---|---|
| committer | Keith Packard <keithp@keithp.com> | 2018-01-10 23:11:40 -0800 | 
| commit | f26cc1a677f577da533425a15485fcaa24626b23 (patch) | |
| tree | 2f1e96addf6af39a9013acc76409f9df74a5e561 /src/scheme/ao_scheme_string.scheme | |
| parent | 4b52fc6eea9a478cb3dd42dcd32c92838df39734 (diff) | |
altos/scheme: Move ao-scheme to a separate repository
This way it can be incorporated into multiple operating systems more easily.
Signed-off-by: Keith Packard <keithp@keithp.com>
Diffstat (limited to 'src/scheme/ao_scheme_string.scheme')
| -rw-r--r-- | src/scheme/ao_scheme_string.scheme | 156 | 
1 files changed, 0 insertions, 156 deletions
| diff --git a/src/scheme/ao_scheme_string.scheme b/src/scheme/ao_scheme_string.scheme deleted file mode 100644 index 99f16fab..00000000 --- a/src/scheme/ao_scheme_string.scheme +++ /dev/null @@ -1,156 +0,0 @@ -; -; Copyright © 2018 Keith Packard <keithp@keithp.com> -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU -; General Public License for more details. -; -; string functions placed in ROM - -(define string (lambda chars (list->string chars))) - -(string #\a #\b #\c) - -(define string-map -  (lambda (proc . strings) -					; result length is min of arg lengths -    (let* ((l (apply min (map string-length strings))) -					; create the result -	   (s (make-string l))) -					; walk the strings, doing evaluation -      (define (_m p) -	(if (equal? p l) -	    s -	    (begin -	      (string-set! s p (apply proc (map (lambda (s) (string-ref s p)) strings))) -	      (_m (+ p 1)) -	      ) -	    ) -	) -      (_m 0) -      ) -    ) -  ) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-copy! -  (lambda (t a f . args) -    (let ((l 0) -	  (h (string-length f)) -	  (o a) -	  (d 1)) -					; handle optional start/end args -       -      (if (not (null? args)) -	  (begin -	    (set! l (car args)) -	    (if (not (null? (cdr args))) -		(set! h (cadr args))) -	    (set! o (- a l)) -	    ) -	  ) -					; flip copy order if dst is -					; after src -      (if (< l a) -	  (begin -	    (set! d h) -	    (set! h (- l 1)) -	    (set! l (- d 1)) -	    (set! d -1) -	    ) -	  ) -					; loop copying one at a time -      (do ((p l (+ p d)) -	   ) -	  ((= p h) t) -	(string-set! t (+ p o) (string-ref f p)) -	) -      ) -    ) -  ) - -(string-copy! (make-string 10) 0 "hello" 0 5) -(string-copy! (make-string 10) 1 "hello" 0 5) -(string-copy! (make-string 10) 0 "hello" 0 5) - -(define (string-upcase s) (string-map char-upcase s)) -(define (string-downcase s) (string-map char-downcase s)) -(define string-foldcase string-downcase) - -(define string-copy -  (lambda (s . args) -    (let ((l 0) -	  (h (string-length s))) -      (if (not (null? args)) -	  (begin -	    (set! l (car args)) -	    (if (not (null? (cdr args))) -		(set! h (cadr args))) -	    ) -	  ) -      (string-copy! (make-string (- h l)) 0 s l h) -      ) -    ) -  ) - -(string-copy "hello" 0 1) -(string-copy "hello" 1) -(string-copy "hello") - -(define substring string-copy) - -(define string-fill! -  (lambda (s a . args) -    (let ((l 0) -	  (h (string-length s))) -      (cond ((not (null? args)) -	     (set! l (car args)) -	     (cond ((not (null? (cdr args))) -		    (set! h (cadr args))) -		   ) -	     ) -	    ) -      (define (_f b) -	(cond ((< b h) -	       (string-set! s b a) -	       (_f (+ b 1)) -	       ) -	      (else s) -	      ) -	) -      (_f l) -      ) -    ) -  ) - -(string-fill! (make-string 10) #\a) -(string-fill! (make-string 10) #\a 1 2) - -(define string-for-each -  (lambda (proc . strings) -					; result length is min of arg lengths -    (let* ((l (apply min (map string-length strings))) -	   ) -					; walk the strings, doing evaluation -      (define (_m p) -	(if (equal? p l) -	    #t -	    (begin -	      (apply proc (map (lambda (s) (string-ref s p)) strings)) -	      (_m (+ p 1)) -	      ) -	    ) -	) -      (_m 0) -      ) -    ) -  ) - -(string-for-each write-char "IBM\n") | 
