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