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