fixed bug in prepareStackForAbsOpt (rtemgr.c).
[bugg-scheme-compiler.git] / src / scm / support-code.scm~
blob16956dd436241c706821325924b10335dc8578d6
1 ;;; support-code.scm
2 ;;; Part of the initial environment that you will need to provide with your
3 ;;; compiler, but written in [very elementary] Scheme. Put otherwise, your
4 ;;; compiler will have to be able to compile this code in order to provide it.
6 ;;; Programmer: Mayer Goldberg, 2009
8 ;;; (define binary-add #f)
9 ;;; (define binary-sub #f)
10 ;;; (define binary-mul #f)
11 ;;; (define binary-div #f)
12 ;;; (define binary<? #f)
13 ;;; (define binary=? #f)
14 ;;; 
15 ;;; (let ((+ +) (- -) (* *) (/ /) (< <) (= =))
16 ;;;   (set! binary-add (lambda (a b) (+ a b)))
17 ;;;   (set! binary-sub (lambda (a b) (- a b)))
18 ;;;   (set! binary-mul (lambda (a b) (* a b)))
19 ;;;   (set! binary-div (lambda (a b) (/ a b)))
20 ;;;   (set! binary<? (lambda (a b) (< a b)))
21 ;;;   (set! binary=? (lambda (a b) (= a b))))
23 (define foldr
24   (lambda (binop final s)
25     (letrec ((loop (lambda (s)
26                      (if (null? s)
27                          final
28                          (binop (car s) (loop (cdr s)))))))
29       (loop s))))
31 (define add1 (lambda (n) (binary-add n 1)))
32 (define sub1 (lambda (n) (binary-sub n 1)))
34 (define order
35   (lambda (<)
36     (letrec ((loop
37               (lambda (a s)
38                 (or (null? s)
39                     (and (< a (car s))
40                          (loop (car s) (cdr s)))))))
41       (lambda (a . s)
42         (loop a s)))))
44 (define < (order binary<?))
46 (define <=
47   (let ((binary<=?
48          (lambda (a b)
49            (or (binary<? a b)
50                (binary=? a b)))))
51     (order binary<=?)))
53 (define >
54   (let ((binary>?
55          (lambda (a b)
56            (binary<? b a))))
57     (order binary>?)))
59 (define >=
60   (let ((binary>=?
61          (lambda (a b)
62            (or (binary=? a b)
63                (binary>? a b)))))
64     (order binary>=?)))
66 (define = (order binary=?))
68 ;;; extension: a variadic not-equal
69 (define <>
70   (letrec ((loop
71             (lambda (a s)
72               (or (null? s)
73                   (and (andmap (lambda (b) (not (= a b))) s)
74                        (loop (car s) (cdr s)))))))
75     (lambda s
76       (loop (car s) (cdr s)))))
78 (define not (lambda (x) (if x #f #t)))
80 (define compose
81   (let ((binary-compose
82          (lambda (f g)
83            (lambda (x)
84              (f (g x))))))
85     (lambda s
86       (foldr binary-compose (lambda (x) x) s))))
88 (define caar (compose car car))
89 (define cadr (compose car cdr))
90 (define cdar (compose cdr car))
91 (define cddr (compose cdr cdr))
92 (define caaar (compose car caar))
93 (define caadr (compose car cadr))
94 (define cadar (compose car cdar))
95 (define caddr (compose car cddr))
96 (define cdaar (compose cdr caar))
97 (define cdadr (compose cdr cadr))
98 (define cddar (compose cdr cdar))
99 (define cdddr (compose cdr cddr))
100 (define caaaar (compose car caaar))
101 (define caaadr (compose car caadr))
102 (define caadar (compose car cadar))
103 (define caaddr (compose car caddr))
104 (define cadaar (compose car cdaar))
105 (define cadadr (compose car cdadr))
106 (define caddar (compose car cddar))
107 (define cadddr (compose car cdddr))
108 (define cdaaar (compose cdr caaar))
109 (define cdaadr (compose cdr caadr))
110 (define cdadar (compose cdr cadar))
111 (define cdaddr (compose cdr caddr))
112 (define cddaar (compose cdr cdaar))
113 (define cddadr (compose cdr cdadr))
114 (define cdddar (compose cdr cddar))
115 (define cddddr (compose cdr cdddr))
117 (define ^variadic-right-from-binary
118   (lambda (binary-op base-value)
119     (letrec ((op-list
120               (lambda (s)
121                 (if (null? s) base-value
122                     (binary-op (car s) (op-list (cdr s)))))))
123       (lambda args
124         (op-list args)))))
126 (define ^variadic-left-from-binary
127   (lambda (binary-op base-value)
128     (letrec ((op-list
129               (lambda (acc s)
130                 (if (null? s) acc
131                     (op-list (binary-op acc (car s)) (cdr s))))))
132       (lambda args
133         (if (null? args) base-value
134             (op-list (car args) (cdr args)))))))
136 (define + (^variadic-right-from-binary binary-add 0))
137 (define * (^variadic-right-from-binary binary-mul 1))
139 (define - (^variadic-left-from-binary binary-sub 0))
140 (define / (^variadic-left-from-binary binary-div 1))
142 (define ^char-op
143   (lambda (int-op)
144     (lambda (ch1 ch2)
145       (int-op (char->integer ch1) (char->integer ch2)))))
147 (define char<=? (order (^char-op <=)))
148 (define char<? (order (^char-op <)))
149 (define char>=? (order (^char-op >=)))
150 (define char>? (order (^char-op >)))
152 (define char-uppercase?
153   (lambda (ch)
154     (and (char<=? #\A ch)
155          (char<=? ch #\Z))))
157 (define char-lowercase?
158   (lambda (ch)
159     (and (char<=? #\a ch)
160          (char<=? ch #\z))))
162 (define char-upcase
163   (let ((char-aA (- (char->integer #\a) (char->integer #\A))))
164     (lambda (ch)
165       (if (char-lowercase? ch)
166               (integer->char
167                 (- (integer->char ch) char-aA))
168           ch))))
170 (define char-downcase
171   (let ((char-aA (- (char->integer #\a) (char->integer #\A))))
172     (lambda (ch)
173       (if (char-uppercase? ch)
174               (integer->char
175                 (+ (integer->char ch) char-aA))
176           ch))))
178 (define char-ci<=?
179   (order
180    (lambda (ch1 ch2)
181      (char<=? (char-upcase ch1) (char-upcase ch2)))))
183 (define char-ci<?
184   (order
185    (lambda (ch1 ch2)
186      (char<? (char-upcase ch1) (char-upcase ch2)))))
188 (define char-ci=?
189   (order
190    (lambda (ch1 ch2)
191      (char=? (char-upcase ch1) (char-upcase ch2)))))
193 (define char-ci>?
194   (order
195    (lambda (ch1 ch2)
196      (char>? (char-upcase ch1) (char-upcase ch2)))))
198 (define char-ci>=?
199   (order
200    (lambda (ch1 ch2)
201      (char>=? (char-upcase ch1) (char-upcase ch2)))))
203 (define string-upcase
204   (lambda (string)
205     (list->string
206      (map char-upcase (string->list string)))))
208 (define string-downcase
209   (lambda (string)
210     (list->string
211      (map char-downcase (string->list string)))))
213 (define even?
214   (lambda (n)
215     (zero? (remainder n 2))))
217 (define odd?
218   (lambda (n)
219     (not (zero? (remainder n 2)))))
221 (define length
222   (lambda (s)
223     (if (null? s) 0
224         (add1 (length (cdr s))))))
226 (define list (lambda args args))
228 (define list-ref
229   (lambda (s i)
230     (if (zero? i) (car s)
231         (list-ref (cdr s) (- i 1)))))
233 (define list?
234   (lambda (e)
235     (or (null? e)
236         (and (pair? e)
237              (list? (cdr e))))))
239 (define map
240   (letrec ((map-list
241             (lambda (f lists)
242               (if (null? (car lists)) '()
243                   (cons (apply f (map-one car lists))
244                         (map-list f (map-one cdr lists))))))
245            (map-one
246             (lambda (f s)
247               (if (null? s) '()
248                   (cons (f (car s))
249                         (map-one f (cdr s)))))))
250     (lambda (f . args)
251       (map-list f args))))
253 (define member?
254   (lambda (a s)
255     (ormap (lambda (b) (eq? a b)) s)))
257 (define negative? (lambda (n) (< n 0)))
259 (define positive? (lambda (n) (> n 0)))
261 (define zero? (lambda (x) (= x 0)))
263 (define vector (lambda args (list->vector args)))
265 (define ormap
266   (lambda (f s)
267     (and (pair? s)
268          (or (f (car s))
269              (ormap f (cdr s))))))
271 (define andmap
272   (lambda (f s)
273     (or (null? s)
274         (and (f (car s))
275              (andmap f (cdr s))))))
277 (define string->list
278   (letrec ((loop
279             (lambda (str n s)
280               (if (= n -1) s
281                   (loop str
282                         (- n 1)
283                         (cons (string-ref str n) s))))))
284     (lambda (str)
285       (loop str (- (string-length str) 1) '()))))
287 (define vector->list
288   (letrec ((loop
289             (lambda (v n s)
290               (if (= n -1) s
291                   (loop v
292                         (- n 1)
293                         (cons (vector-ref v n) s))))))
294     (lambda (v)
295       (loop v (- (vector-length v) 1) '()))))
297 (define list->string
298   (lambda (s)
299     (let* ((n (length s))
300            (str (make-string n)))
301       (letrec ((loop
302                 (lambda (s i)
303                   (if (= i n) str
304                       (begin
305                         (string-set! str i (car s))
306                         (loop (cdr s) (+ i 1)))))))
307         (loop s 0)))))
309 (define list->vector
310   (lambda (s)
311     (let* ((n (length s))
312            (v (make-vector n)))
313       (letrec ((loop
314                 (lambda (s i)
315                   (if (= i n) v
316                       (begin
317                         (vector-set! v i (car s))
318                         (loop (cdr s) (+ i 1)))))))
319         (loop s 0)))))
321 (define member
322   (lambda (a s)
323     (cond ((null? s) #f)
324           ((eq? (car s) a) s)
325           (else (member a (cdr s))))))
327 (define assoc
328   (lambda (a s)
329     (cond ((null? s) #f)
330           ((eq? (caar s) a) (car s))
331           (else (assoc a (cdr s))))))
333 (define equal?
334   (lambda (e1 e2)
335     (cond ((and (pair? e1) (pair? e2))
336            (and (equal? (car e1) (car e2))
337                 (equal? (cdr e1) (cdr e2))))
338           ((and (vector? e1) (vector? e2)
339                 (= (vector-length e1) (vector-length e2)))
340            (equal? (vector->list e1) (vector->list e2)))
341           ((and (null? e1) (null? e2)) #t)
342           ((and (boolean? e1) (boolean? e2)) (and e1 e2))
343           ((and (char? e1) (char? e2))
344            (char=? e1 e2))
345           ((and (number? e1) (number? e2))
346            (= e1 e2))
347           ((and (string? e1) (string? e2))
348            (string=? e1 e2))
349           ((and (symbol? e1) (symbol? e2))
350            (eq? e1 e2))
351           ((and (void? e1) (void? e2)) #t)
352           (else #f))))
354 (define void
355   (let ((void-object
356          (if #f #f)))
357     (lambda () void-object)))
359 (define void?
360   (let ((void-object (void)))
361     (lambda (x) (eq? x void-object))))
363 (define string-append
364   (lambda s
365     (list->string (apply append (map string->list s)))))
367 (define vector-append
368   (lambda s
369     (list->vector (apply append (map vector->list s)))))
371 (define append
372   (letrec ((binary-append
373             (lambda (s1 s2)
374               (if (null? s1) s2
375                   (cons (car s1) (binary-append (cdr s1) s2))))))
376     (lambda s
377       (foldr binary-append '() s))))
379 (define reverse
380   (letrec ((loop
381             (lambda (s r)
382               (if (null? s) r
383                   (loop (cdr s) (cons (car s) r))))))
384     (lambda (s)
385       (loop s '()))))
387 (define string-reverse
388   (compose
389    list->string
390    reverse
391    string->list))
393 (define list-ref
394   (lambda (s i)
395     (if (zero? i) (car s)
396         (list-ref (cdr s) (- i 1)))))
398 (define list-set!
399   (lambda (s i x)
400     (if (zero? i) (set-car! s x)
401         (list-set! (cdr s) (- i 1) x))))
403 (define max
404   (let ((binary-max (lambda (a b) (if (> a b) a b))))
405     (lambda (a . s)
406       (foldr binary-max a s))))
408 (define min
409   (let ((binary-min (lambda (a b) (if (< a b) a b))))
410     (lambda (a . s)
411       (foldr binary-min a s))))
413 (define gcd
414   (letrec ((binary-gcd
415             (lambda (a b)
416               (if (zero? b) a
417                   (let ((r (remainder a b)))
418                     (if (zero? r) b
419                         (binary-gcd b r)))))))
420     (lambda (a . s)
421       (foldr binary-gcd a s))))
423 (define lcm
424   (lambda s
425     (/ (apply * s)
426        (apply gcd s))))
428 ;(define box
429 ;  (lambda (x)
430 ;    (let ((v (make-vector 1)))
431 ;      (vector-set! v 0 x)
432 ;      v)))