… | |
… | |
109 | (let loop ((n (pred (string-length s))) (l '())) |
109 | (let loop ((n (pred (string-length s))) (l '())) |
110 | (if (= n -1) |
110 | (if (= n -1) |
111 | l |
111 | l |
112 | (loop (pred n) (cons (string-ref s n) l))))) |
112 | (loop (pred n) (cons (string-ref s n) l))))) |
113 | |
113 | |
114 | (define (string-copy str) |
114 | ;TODO string-upcase |
115 | (string-append str)) |
115 | ;TODO string-downcase |
|
|
116 | ;TODO string-foldcase |
|
|
117 | ;TODO string-copy! |
|
|
118 | ;TODO string-fill! |
|
|
119 | |
|
|
120 | (define substring string-copy) |
116 | |
121 | |
117 | (define (string->anyatom str pred) |
122 | (define (string->anyatom str pred) |
118 | (let* ((a (string->atom str))) |
123 | (let* ((a (string->atom str))) |
119 | (if (pred a) a |
124 | (if (pred a) a |
120 | (error "string->xxx: not a xxx" a)))) |
125 | (error "string->xxx: not a xxx" a)))) |
… | |
… | |
146 | (define (char-ci=? a b) (char-ci-cmp? = a b)) |
151 | (define (char-ci=? a b) (char-ci-cmp? = a b)) |
147 | (define (char-ci<? a b) (char-ci-cmp? < a b)) |
152 | (define (char-ci<? a b) (char-ci-cmp? < a b)) |
148 | (define (char-ci>? a b) (char-ci-cmp? > a b)) |
153 | (define (char-ci>? a b) (char-ci-cmp? > a b)) |
149 | (define (char-ci<=? a b) (char-ci-cmp? <= a b)) |
154 | (define (char-ci<=? a b) (char-ci-cmp? <= a b)) |
150 | (define (char-ci>=? a b) (char-ci-cmp? >= a b)) |
155 | (define (char-ci>=? a b) (char-ci-cmp? >= a b)) |
|
|
156 | |
|
|
157 | (define (digit-value ch) |
|
|
158 | (if (and (char<=? #\0 ch) (char<=? ch #\9)) |
|
|
159 | (- (char->integer ch) (char->integer #\0)) |
|
|
160 | #f)) |
|
|
161 | |
|
|
162 | (define char-foldcase char-downcase) |
151 | |
163 | |
152 | ; Note the trick of returning (cmp x y) |
164 | ; Note the trick of returning (cmp x y) |
153 | (define (string-cmp? chcmp cmp a b) |
165 | (define (string-cmp? chcmp cmp a b) |
154 | (let ((na (string-length a)) (nb (string-length b))) |
166 | (let ((na (string-length a)) (nb (string-length b))) |
155 | (let loop ((i 0)) |
167 | (let loop ((i 0)) |
… | |
… | |
247 | (loop (succ i)))))))) |
259 | (loop (succ i)))))))) |
248 | |
260 | |
249 | (define (list->vector x) |
261 | (define (list->vector x) |
250 | (apply vector x)) |
262 | (apply vector x)) |
251 | |
263 | |
|
|
264 | ;TODO vector-fill! v e start end |
252 | (define (vector-fill! v e) |
265 | (define (vector-fill! v e) |
253 | (let ((n (vector-length v))) |
266 | (let ((n (vector-length v))) |
254 | (let loop ((i 0)) |
267 | (let loop ((i 0)) |
255 | (if (= i n) |
268 | (if (= i n) |
256 | v |
269 | v |
… | |
… | |
259 | (define (vector->list v) |
272 | (define (vector->list v) |
260 | (let loop ((n (pred (vector-length v))) (l '())) |
273 | (let loop ((n (pred (vector-length v))) (l '())) |
261 | (if (= n -1) |
274 | (if (= n -1) |
262 | l |
275 | l |
263 | (loop (pred n) (cons (vector-ref v n) l))))) |
276 | (loop (pred n) (cons (vector-ref v n) l))))) |
|
|
277 | |
|
|
278 | ;TODO vector->string vector start end |
|
|
279 | |
|
|
280 | (define (string->vector . args) |
|
|
281 | (list->vector (string->list (apply string-copy args)))) |
|
|
282 | |
|
|
283 | ;TODO vector-copy v s e |
|
|
284 | ;TODO vector-copy! to at v s e |
|
|
285 | |
|
|
286 | (define (vector-append hd . tl) |
|
|
287 | (if (null? tl) |
|
|
288 | hd |
|
|
289 | (list->vector (append (hd (vector->list (vector-append tl))))))) |
264 | |
290 | |
265 | ;; The following quasiquote macro is due to Eric S. Tiedemann. |
291 | ;; The following quasiquote macro is due to Eric S. Tiedemann. |
266 | ;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. |
292 | ;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. |
267 | ;; |
293 | ;; |
268 | ;; Subsequently modified to handle vectors: D. Souflis |
294 | ;; Subsequently modified to handle vectors: D. Souflis |
… | |
… | |
552 | (define (throw . x) |
578 | (define (throw . x) |
553 | (if (more-handlers?) |
579 | (if (more-handlers?) |
554 | (apply (pop-handler)) |
580 | (apply (pop-handler)) |
555 | (apply error x))) |
581 | (apply error x))) |
556 | |
582 | |
|
|
583 | ; catch handler thunk |
557 | (macro (catch form) |
584 | (macro (catch form) |
558 | (let ((label (gensym))) |
585 | (let ((label (gensym))) |
559 | `(call/cc (lambda (exit) |
586 | `(call/cc (lambda (exit) |
560 | (push-handler (lambda () (exit ,(cadr form)))) |
587 | (push-handler (lambda () (exit ,(cadr form)))) |
561 | (let ((,label (begin ,@(cddr form)))) |
588 | (let ((,label (begin ,@(cddr form)))) |
562 | (pop-handler) |
589 | (pop-handler) |
563 | ,label))))) |
590 | ,label))))) |
564 | |
591 | |
565 | (define *error-hook* throw) |
592 | (define *error-hook* throw) |
566 | |
593 | |
|
|
594 | ; same as above, r7rs |
|
|
595 | (define (with-exception-handler handler thunk) |
|
|
596 | (catch (handler) (thunk))) |
|
|
597 | |
|
|
598 | (define (raise-continuable x) |
|
|
599 | (if (more-handlers?) |
|
|
600 | ((pop-handler) x) |
|
|
601 | (error x))) |
|
|
602 | |
|
|
603 | (define (raise x) |
|
|
604 | (raise-continuable x) |
|
|
605 | (error "raise: exception handler returned")) |
|
|
606 | |
|
|
607 | (with-exception-handler |
|
|
608 | (lambda () (display (list "xerror"))) |
|
|
609 | (lambda () (begin (display ("aaa") (raise 5))))) |
|
|
610 | |
|
|
611 | ;TODO: a lot more is missing, and it doesn't work |
567 | |
612 | |
568 | ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL |
613 | ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL |
569 | |
614 | |
570 | (macro (make-environment form) |
615 | (macro (make-environment form) |
571 | `(apply (lambda () |
616 | `(apply (lambda () |
… | |
… | |
725 | ;(load "macros/syntaxenv.scm") |
770 | ;(load "macros/syntaxenv.scm") |
726 | ;(load "macros/syntaxrules.scm") |
771 | ;(load "macros/syntaxrules.scm") |
727 | ;(load "macros/usual.scm") |
772 | ;(load "macros/usual.scm") |
728 | |
773 | |
729 | ;; r7rs |
774 | ;; r7rs |
730 | ; char library |
|
|
731 | ; string-upcase |
|
|
732 | ; string-downcase |
|
|
733 | ; string-foldcase |
|
|
734 | ; sring-map, vector-map, string-for-each, vector-for-each |
775 | ; sring-map, vector-map, string-for-each, vector-for-each |
735 | ; bytevectors |
776 | ; bytevectors |
736 | |
777 | |
737 | ;; srfi-1 |
778 | ;; srfi-1 |
738 | |
779 | |