blob: 2427772ac44e44b874644d60b7e0430ab54fe6a2 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
; This is a init file for Mini-Scheme.
; Modified for UNSLISP.
(define modulo remainder)
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (list . x) x)
(define (map proc list)
(if (pair? list)
(cons (proc (car list)) (map proc (cdr list)))))
(define (for-each proc list)
(if (pair? list)
(begin (proc (car list)) (for-each proc (cdr list)))
#t ))
(define (list-tail x k)
(if (zero? k)
x
(list-tail (cdr x) (- k 1))))
(define (list-ref x k)
(car (list-tail x k)))
(define list-set!
(lambda (lst k obj)
(if (= k 0)
(set-car! lst obj)
(list-set! (cdr lst) (- k 1) obj))))
(define (last-pair x)
(if (pair? (cdr x))
(last-pair (cdr x))
x))
(define vector list)
(define vector-ref list-ref)
(define vector-set! list-set!)
(define make-vector
(lambda (num)
(letrec
((loop
(lambda (iter cell)
(if (= iter 0)
cell
(loop (- iter 1) (cons #f cell))))))
(loop num '()))))
(define (head stream) (car stream))
(define (tail stream) (force (cdr stream)))
(define (eof-object? x) (eq? x #f))
;;;;; following part is written by a.k
;;;; atom?
(define (atom? x)
(not (pair? x)))
;;;; memq
(define (memq obj lst)
(cond
((null? lst) #f)
((eq? obj (car lst)) lst)
(else (memq obj (cdr lst)))))
;;;; equal?
(define (equal? x y)
(if (pair? x)
(and (pair? y)
(equal? (car x) (car y))
(equal? (cdr x) (cdr y)))
(and (not (pair? y))
(eqv? x y))))
;;; Emulation of mutable strings.
(define mutable-string-ref list-ref)
(define mutable-string-set! list-set!)
(define mutable-string list)
(define (mutable-string->list x) x)
(define list<=>
(lambda (x y <=>)
(cond
((and (null? x) (null? y)) '=)
((null? x) '<)
((null? y) '>)
(else
(let ((dir (<=> (car x) (car y))))
(if (eq? dir '=)
(list<=> (cdr x) (cdr y) <=>)
dir))))))
(define max
(lambda (curmax . rest)
(if (null? rest)
curmax
(let ((next-num (car rest)))
(apply max
(cons (if (> next-num curmax) next-num curmax)
(cdr rest)))))))
(define all
(lambda (f l)
(cond
((null? l) #t)
((not (f (car l))) (all f (cdr l)))
(else #f))))
(define any
(lambda (f l)
(cond
((null? l) #f)
((f (car l)) #t)
(else (any f (cdr l))))))
(define string->list
(lambda (str)
(let ((len (string-length str)))
(letrec ((loop
(lambda (i lst)
(if (= i len)
(reverse lst)
(loop (+ i 1)
(cons (string-ref str i)
lst))))))
(loop 0)))))
(define string
(lambda args
(list->string args)))
(macro
cond-expand
(lambda (body)
(letrec
((loop
(lambda (body)
(if (null? body)
#f
(let ((elem (car body)))
(cond
((eqv? (car elem) 'else)
(cons 'begin (cdr elem)))
((and (pair? elem)
(passes? (car elem)))
(cons 'begin (cdr elem)))
(else (loop (cdr body))))))))
(passes?
(lambda (boolean-form)
(cond
((eqv? boolean-form 'miniscm-unslisp) #t)
((eqv? boolean-form 'r3rs) #t)
((symbol? boolean-form) #f)
((not (pair? boolean-form)) (error "invalid boolean form"))
((eqv? (car boolean-form) 'and)
(all passes? (cdr boolean-form)))
((eqv? (car boolean-form) 'or)
(any passes? (cdr boolean-form)))
((eqv? (car boolean-form) 'not)
(not (passes? (cadr boolean-form))))
(else (error "invalid boolean function"))))))
(loop (cdr body)))))
(define (abs x)
(if (< x 0)
(- x)
x))
|
