d3d41a368b4f149e5cf4ebb5f7fa1db0f29cdcc4
[mes.git] / scaffold / boot / 4e-string-split.scm
1
2 (define (cons* . rest)
3   (if (null? (cdr rest)) (car rest)
4       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
5
6 (define (caar x) (car (car x)))
7 (define (cadr x) (car (cdr x)))
8 (define (cdar x) (cdr (car x)))
9 (define (cddr x) (cdr (cdr x)))
10
11 (define <cell:symbol> 11)
12 (define (symbol? x)
13   (eq? (core:type x) <cell:symbol>))
14
15 (define (map f lst)
16   (if (null? lst) (list)
17       (cons (f (car lst)) (map f (cdr lst)))))
18
19 (define-macro (simple-let bindings . rest)
20   (cons (cons 'lambda (cons (map car bindings) rest))
21         (map cadr bindings)))
22
23 ;; (define-macro (xsimple-let bindings rest)
24 ;;   `(,`(lambda ,(map car bindings) ,@rest)
25 ;;     ,@(map cadr bindings)))
26
27 (define-macro (xsimple-let bindings rest)
28   (cons* (cons* (quote lambda)
29                 (map car bindings) (append2 rest (quote ())))
30          (append2 (map cadr bindings) (quote ()))))
31
32 ;; (define-macro (xnamed-let name bindings rest)
33 ;;   `(simple-let ((,name *unspecified*))
34 ;;      (set! ,name (lambda ,(map car bindings) ,@rest))
35 ;;      (,name ,@(map cadr bindings))))
36
37 (define-macro  (xnamed-let name bindings rest)
38   (list (quote simple-let)
39         (list (cons* name (quote (*unspecified*))))
40         (list (quote set!)
41               name
42               (cons* (quote lambda)
43                      (map car bindings)
44                      (append2 rest (quote ()))))
45         (cons* name (append2 (map cadr bindings) (quote ())))))
46
47 ;; (define-macro (let bindings-or-name . rest)
48 ;;   (if (symbol? bindings-or-name)
49 ;;       `(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
50 ;;       `(xsimple-let ,bindings-or-name ,rest)))
51
52 (define-macro (let bindings-or-name . rest)
53   (if (symbol? bindings-or-name) (list (quote xnamed-let) bindings-or-name (car rest) (cdr rest))
54       (list (quote xsimple-let) bindings-or-name rest)))
55
56 (define ss-memq-inner #f)
57 (define (ss-memq x lst)
58   (if (null? lst) #f ;; IF
59       (if (eq? x (car lst)) lst
60           (ss-memq-inner x (cdr lst)))))
61
62 (define (ss-memq-inner x lst)
63   (if (null? lst) #f ;; IF
64       (if (eq? x (car lst)) lst
65           (ss-memq-inner x (cdr lst)))))
66
67 (define (ss-list-head x n)
68   (if (= 0 n) '()
69       (cons (car x) (ss-list-head (cdr x) (- n 1)))))
70
71 ;; (define (foo x y)
72 ;;   (cons x y))
73
74 ;; (define (ss-list-head x n)
75 ;;   (if (= 0 n) '()
76 ;;       (foo (car x) (ss-list-head (cdr x) (- n 1)))))
77
78 (define (string->list s)
79   (core:car s))
80
81 (define <cell:string> 10)
82
83 (define (list->string lst)
84   (core:make-cell <cell:string> lst 0))
85
86 (define (not x) (if x #f #t))
87
88 (define (string-split s c)
89   (let loop ((lst (string->list s)) (result '()))
90     (let ((rest (ss-memq c lst)))
91       (if (not rest) (append2 result (list (list->string lst)))
92           (loop (cdr rest)
93                 (append2 result
94                          (list (list->string (ss-list-head lst (- (length lst) (length rest)))))))))))
95
96 (core:display-error "*START*\n")
97 (string-split "foo bar" #\space)
98 (string-split "baz bla" #\space)