1; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
2; Part of Scheme 48 1.9.  See file COPYING for notices and license.
3
4; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
5
6
7; This is file base.scm.
8
9;;;; Fundamental definitions
10
11; Order of appearance is approximately that of the Revised^4 Report.
12
13; Booleans
14
15(define (not x) (if x #f #t))
16(define (boolean? x) (or (eq? x #t) (eq? x #f)))
17
18; Equality
19
20(define (eqv? x y)
21  (or (eq? x y)
22      (and (number? x)
23           (number? y)
24           (eq? (exact? x) (exact? y))
25           (= x y))))
26
27(define (equal? obj1 obj2)
28  (cond ((eqv? obj1 obj2) #t)
29        ((pair? obj1)
30         (and (pair? obj2)
31              (equal? (car obj1) (car obj2))
32              (equal? (cdr obj1) (cdr obj2))))
33        ((string? obj1)
34         (and (string? obj2)
35              (string=? obj1 obj2)))
36        ((vector? obj1)
37         (and (vector? obj2)
38              (let ((z (vector-length obj1)))
39                (and (= z (vector-length obj2))
40                     (let loop ((i 0))
41                       (cond ((= i z) #t)
42                             ((equal? (vector-ref obj1 i) (vector-ref obj2 i))
43                              (loop (+ i 1)))
44                             (else #f)))))))
45        (else #f)))
46
47; Messy because of inexact contagion.
48
49(define (max first . rest)
50  (max-or-min first rest #t))
51
52(define (min first . rest)
53  (max-or-min first rest #f))
54
55(define (max-or-min first rest max?)
56  (let loop ((result first) (rest rest) (lose? (inexact? first)))
57    (if (null? rest)
58	(if (and lose? (exact? result))
59	    (exact->inexact result)
60	    result)
61	(let ((next (car rest)))
62	  (loop (if (if max?
63			(< result next)
64			(> result next))
65		    next
66		    result)
67		(cdr rest)
68		(or lose? (inexact? next)))))))
69
70(define (abs n) (if (< n 0) (- 0 n) n))
71
72(define (zero? x) (= x 0))
73(define (positive? x) (< 0 x))
74(define (negative? x) (< x 0))
75
76(define (even? n) (= 0 (remainder n 2)))
77(define (odd? n) (not (even? n)))
78
79; Lists
80
81(define (caar   x) (car (car x)))
82(define (cadr   x) (car (cdr x)))
83(define (cdar   x) (cdr (car x)))
84(define (cddr   x) (cdr (cdr x)))
85
86(define (caaar  x) (caar (car x)))
87(define (caadr  x) (caar (cdr x)))
88(define (cadar  x) (cadr (car x)))
89(define (caddr  x) (cadr (cdr x)))
90(define (cdaar  x) (cdar (car x)))
91(define (cdadr  x) (cdar (cdr x)))
92(define (cddar  x) (cddr (car x)))
93(define (cdddr  x) (cddr (cdr x)))
94
95(define (caaaar x) (caaar (car x)))
96(define (caaadr x) (caaar (cdr x)))
97(define (caadar x) (caadr (car x)))
98(define (caaddr x) (caadr (cdr x)))
99(define (cadaar x) (cadar (car x)))
100(define (cadadr x) (cadar (cdr x)))
101(define (caddar x) (caddr (car x)))
102(define (cadddr x) (caddr (cdr x)))
103(define (cdaaar x) (cdaar (car x)))
104(define (cdaadr x) (cdaar (cdr x)))
105(define (cdadar x) (cdadr (car x)))
106(define (cdaddr x) (cdadr (cdr x)))
107(define (cddaar x) (cddar (car x)))
108(define (cddadr x) (cddar (cdr x)))
109(define (cdddar x) (cdddr (car x)))
110(define (cddddr x) (cdddr (cdr x)))
111
112(define (null? x) (eq? x '()))
113
114(define (list . l) l)
115
116;(define (length l)
117;  (reduce (lambda (ignore n) (+ n 1)) 0 l))
118
119; Bummed version.  Pretend that you didn't see this.
120
121(define (length l)
122  (real-length l 0))
123
124(define (real-length l r)
125  (if (null? l)
126      r
127      (real-length (cdr l) (+ r 1))))
128
129(define (append . lists)
130  (if (null? lists)
131      '()
132      (let recur ((lists lists))
133	(if (null? (cdr lists))
134	    (car lists)
135	    (reduce cons (recur (cdr lists)) (car lists))))))
136
137(define (reverse list)
138  (append-reverse list '()))
139
140(define (append-reverse list seed)
141  (if (null? list)
142      seed
143      (append-reverse (cdr list) (cons (car list) seed))))
144
145(define (list-tail l i)
146  (cond ((= i 0) l)
147	(else (list-tail (cdr l) (- i 1)))))
148
149(define (list-ref l k)
150  (car (list-tail l k)))
151
152(define (mem pred)
153  (lambda (obj l)
154    (let loop ((l l))
155      (cond ((null? l) #f)
156	    ((pred obj (car l)) l)
157	    (else (loop (cdr l)))))))
158
159(define memq   (mem eq?))
160(define memv   (mem eqv?))
161(define member (mem equal?))
162
163(define (ass pred)
164  (lambda (obj l)
165    (let loop ((l l))
166      (cond ((null? l) #f)
167            ((pred obj (caar l)) (car l))
168            (else (loop (cdr l)))))))
169
170;(define assq  (ass eq?))  ; done by VM for speed
171(define assv  (ass eqv?))
172(define assoc (ass equal?))
173
174(define (list? l)			;New in R4RS
175  (let recur ((l l) (lag l))		;Cycle detection
176    (or (null? l)
177	(and (pair? l)
178	     (or (null? (cdr l))
179		 (and (pair? (cdr l))
180		      (not (eq? (cdr l) lag))
181		      (recur (cddr l) (cdr lag))))))))
182
183; Characters
184
185(define (char>? x y) (char<? y x))
186(define (char>=? x y) (not (char<? x y)))
187(define (char<=? x y) (not (char>? x y)))
188
189
190; Strings
191
192(define (string . rest)
193  (list->string rest))
194
195(define (substring s start end)
196  (let ((new-string (make-string (- end start) #\space)))
197    (do ((i start (+ i 1))
198         (j 0 (+ j 1)))
199        ((= i end) new-string)
200      (string-set! new-string j (string-ref s i)))))
201
202(define (string-append  . strings)
203  (let ((len (reduce (lambda (s n) (+ (string-length s) n)) 0 strings)))
204    (let ((new-string (make-string len #\space)))
205      (let loop ((s strings)
206		 (i 0))
207	(if (null? s)
208	    new-string
209	    (let* ((string (car s))
210		   (l (string-length string)))
211	      (do ((j 0 (+ j 1))
212		   (i i (+ i 1)))
213		  ((= j l) (loop (cdr s) i))
214		(string-set! new-string i (string-ref string j)))))))))
215
216(define (string->list v)
217  (let ((z (string-length v)))
218    (do ((i (- z 1) (- i 1))
219         (l '() (cons (string-ref v i) l)))
220        ((< i 0) l))))
221
222(define (list->string l)
223  (let ((v (make-string (length l) #\space)))
224    (do ((i 0 (+ i 1))
225         (l l (cdr l)))
226        ((null? l) v)
227      (string-set! v i (car l)))))
228
229; comes from low-level package ...
230;(define (string-copy s)
231;  (let ((z (string-length s)))
232;    (let ((copy (make-string z #\space)))
233;      (let loop ((i 0))
234;        (cond ((= i z) copy)
235;              (else
236;               (string-set! copy i (string-ref s i))
237;               (loop (+ i 1))))))))
238
239(define (string-fill! v x)
240  (let ((z (string-length v)))
241    (do ((i 0 (+ i 1)))
242        ((= i z) (unspecific))
243      (string-set! v i x))))
244
245(define (make-string=? char=?)
246  (lambda (s1 s2)
247    (let ((z (string-length s1)))
248      (and (= z (string-length s2))
249	   (let loop ((i 0))
250	     (cond ((= i z) #t)
251		   ((char=? (string-ref s1 i) (string-ref s2 i))
252		    (loop (+ i 1)))
253		   (else #f)))))))
254
255;(define string=?    (make-string=? char=?))  -- VM implements this
256(define string-ci=?-proc (make-string=? char-ci=?))
257
258(define (string-ci=? s1 s2)
259  (string-ci=?-proc s1 s2))
260
261(define (make-string<? char<? char=?)
262  (lambda (s1 s2)
263    (let ((z1 (string-length s1))
264	  (z2 (string-length s2)))
265      (let ((z (min z1 z2)))
266	(let loop ((i 0))
267	  (if (= i z)
268	      (< z1 z2)
269	      (let ((c1 (string-ref s1 i))
270		    (c2 (string-ref s2 i)))
271		(or (char<? c1 c2)
272		    (and (char=? c1 c2)
273			 (loop (+ i 1)))))))))))
274
275(define string<?    (make-string<? char<? char=?))
276
277(define string-ci<?-proc (make-string<? char-ci<? char-ci=?))
278
279(define (string-ci<? s1 s2)
280  (string-ci<?-proc s1 s2))
281
282(define (string>? s1 s2) (string<? s2 s1))
283(define (string<=? s1 s2) (not (string>? s1 s2)))
284(define (string>=? s1 s2) (not (string<? s1 s2)))
285
286(define (string-ci>? s1 s2) (string-ci<? s2 s1))
287(define (string-ci<=? s1 s2) (not (string-ci>? s1 s2)))
288(define (string-ci>=? s1 s2) (not (string-ci<? s1 s2)))
289
290(define (set-string-ci-procedures! ci=? ci<?)
291  (set! string-ci=?-proc ci=?)
292  (set! string-ci<?-proc ci<?))
293
294; Vectors
295
296;(define (vector . l)   ; now an opcode for efficiency
297;  (list->vector l))
298
299(define (vector->list v)
300  (do ((i (- (vector-length v) 1) (- i 1))
301       (l '() (cons (vector-ref v i) l)))
302      ((< i 0) l)))
303
304(define (list->vector l)
305  (let ((v (make-vector (length l) #f)))
306    (do ((i 0 (+ i 1))
307         (l l (cdr l)))
308        ((null? l) v)
309      (vector-set! v i (car l)))))
310
311(define (vector-fill! v x)
312  (let ((z (vector-length v)))
313    (do ((i 0 (+ i 1)))
314        ((= i z) (unspecific))
315      (vector-set! v i x))))
316
317; Control features
318
319(define (map proc first . rest)
320  (if (null? rest)
321      (map1 proc first)
322      (map2+ proc first rest)))
323
324(define (map1 proc l)
325  ;; (reduce (lambda (x l) (cons (proc x) l)) '() l)
326  (if (null? l)
327      '()
328      (cons (proc (car l)) (map1 proc (cdr l)))))
329
330(define (map2+ proc first rest)
331  (if (or (null? first)
332	  (any null? rest))
333      '()
334      (cons (apply proc (cons (car first) (map1 car rest)))
335	    (map2+ proc (cdr first) (map1 cdr rest)))))
336
337(define (for-each proc first . rest)
338  (if (null? rest)
339      (for-each1 proc first)
340      (for-each2+ proc first rest)))
341
342(define (for-each1 proc first)
343  (let loop ((first first))
344    (if (null? first)
345	(unspecific)
346	(begin (proc (car first))
347	       (loop (cdr first))))))
348
349(define (for-each2+ proc first rest)
350  (let loop ((first first) (rest rest))
351    (if (or (null? first)
352	    (any null? rest))
353	(unspecific)
354	(begin (apply proc (cons (car first) (map car rest)))
355	       (loop (cdr first) (map cdr rest))))))
356
357
358; Promises, promises.
359
360(define-syntax delay
361  (syntax-rules ()
362    ((delay ?exp) (make-promise (lambda () ?exp)))))
363
364; A slightly modified copy of the code from R4RS; the modification ensures
365; that the thunk is GC'ed after the promise is evaluted.
366; JAR writes: "It is not for us to judge the wisdom of the new definition."
367
368(define (make-promise thunk-then-result)
369  (let ((already-run? #f))
370    (lambda ()
371      (if already-run?                         ; can't be interrupted from now
372	  thunk-then-result
373	  (let ((result (thunk-then-result)))  ; until after this call
374	    (cond ((not already-run?)
375		   (set! already-run? #t)
376		   (set! thunk-then-result result)))
377	    thunk-then-result)))))
378
379(define (force promise)
380  (promise))
381