1; Initialization file for TinySCHEME 1.31 onwards 2 3; Per R5RS, up to four deep compositions should be defined 4(define (caar x) (car (car x))) 5(define (cadr x) (car (cdr x))) 6(define (cdar x) (cdr (car x))) 7(define (cddr x) (cdr (cdr x))) 8(define (caaar x) (car (car (car x)))) 9(define (caadr x) (car (car (cdr x)))) 10(define (cadar x) (car (cdr (car x)))) 11(define (caddr x) (car (cdr (cdr x)))) 12(define (cdaar x) (cdr (car (car x)))) 13(define (cdadr x) (cdr (car (cdr x)))) 14(define (cddar x) (cdr (cdr (car x)))) 15(define (cdddr x) (cdr (cdr (cdr x)))) 16(define (caaaar x) (car (car (car (car x))))) 17(define (caaadr x) (car (car (car (cdr x))))) 18(define (caadar x) (car (car (cdr (car x))))) 19(define (caaddr x) (car (car (cdr (cdr x))))) 20(define (cadaar x) (car (cdr (car (car x))))) 21(define (cadadr x) (car (cdr (car (cdr x))))) 22(define (caddar x) (car (cdr (cdr (car x))))) 23(define (cadddr x) (car (cdr (cdr (cdr x))))) 24(define (cdaaar x) (cdr (car (car (car x))))) 25(define (cdaadr x) (cdr (car (car (cdr x))))) 26(define (cdadar x) (cdr (car (cdr (car x))))) 27(define (cdaddr x) (cdr (car (cdr (cdr x))))) 28(define (cddaar x) (cdr (cdr (car (car x))))) 29(define (cddadr x) (cdr (cdr (car (cdr x))))) 30(define (cdddar x) (cdr (cdr (cdr (car x))))) 31(define (cddddr x) (cdr (cdr (cdr (cdr x))))) 32 33(macro (unless form) 34 `(if (not ,(cadr form)) (begin ,@(cddr form)))) 35 36(macro (when form) 37 `(if ,(cadr form) (begin ,@(cddr form)))) 38 39; DEFINE-MACRO Contributed by Andy Gaynor 40(macro (define-macro dform) 41 (if (symbol? (cadr dform)) 42 `(macro ,@(cdr dform)) 43 (let ((form (gensym))) 44 `(macro (,(caadr dform) ,form) 45 (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form)))))) 46 47; Utilities for math. Notice that inexact->exact is primitive, 48; but exact->inexact is not. 49(define exact? integer?) 50(define (inexact? x) (and (real? x) (not (integer? x)))) 51(define (even? n) (= (remainder n 2) 0)) 52(define (odd? n) (not (= (remainder n 2) 0))) 53(define (zero? n) (= n 0)) 54(define (positive? n) (> n 0)) 55(define (negative? n) (< n 0)) 56(define complex? number?) 57(define rational? real?) 58(define (abs n) (if (>= n 0) n (- n))) 59(define (exact->inexact n) (* n 1.0)) 60(define (<> n1 n2) (not (= n1 n2))) 61(define (max . lst) 62 (foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst))) 63(define (min . lst) 64 (foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst))) 65(define (succ x) (+ x 1)) 66(define (pred x) (- x 1)) 67(define (gcd a b) 68 (let ((aa (abs a)) 69 (bb (abs b))) 70 (if (= bb 0) 71 aa 72 (gcd bb (remainder aa bb))))) 73(define (lcm a b) 74 (if (or (= a 0) (= b 0)) 75 0 76 (abs (* (quotient a (gcd a b)) b)))) 77 78(define call/cc call-with-current-continuation) 79 80(define (string . charlist) 81 (list->string charlist)) 82 83(define (list->string charlist) 84 (let* ((len (length charlist)) 85 (newstr (make-string len)) 86 (fill-string! 87 (lambda (str i len charlist) 88 (if (= i len) 89 str 90 (begin (string-set! str i (car charlist)) 91 (fill-string! str (+ i 1) len (cdr charlist))))))) 92 (fill-string! newstr 0 len charlist))) 93 94(define (string-fill! s e) 95 (let ((n (string-length s))) 96 (let loop ((i 0)) 97 (if (= i n) 98 s 99 (begin (string-set! s i e) (loop (succ i))))))) 100 101(define (string->list s) 102 (let loop ((n (pred (string-length s))) (l '())) 103 (if (= n -1) 104 l 105 (loop (pred n) (cons (string-ref s n) l))))) 106 107(define (string-copy str) 108 (string-append str)) 109 110(define (string->anyatom str pred) 111 (let* ((a (string->atom str))) 112 (if (pred a) a 113 (error "string->xxx: not a xxx" a)))) 114 115(define (string->number str) (string->anyatom str number?)) 116 117(define (anyatom->string n pred) 118 (if (pred n) 119 (atom->string n) 120 (error "xxx->string: not a xxx" n))) 121 122 123(define (number->string n) (anyatom->string n number?)) 124 125(define (char-cmp? cmp a b) 126 (cmp (char->integer a) (char->integer b))) 127(define (char-ci-cmp? cmp a b) 128 (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b)))) 129 130(define (char=? a b) (char-cmp? = a b)) 131(define (char<? a b) (char-cmp? < a b)) 132(define (char>? a b) (char-cmp? > a b)) 133(define (char<=? a b) (char-cmp? <= a b)) 134(define (char>=? a b) (char-cmp? >= a b)) 135 136(define (char-ci=? a b) (char-ci-cmp? = a b)) 137(define (char-ci<? a b) (char-ci-cmp? < a b)) 138(define (char-ci>? a b) (char-ci-cmp? > a b)) 139(define (char-ci<=? a b) (char-ci-cmp? <= a b)) 140(define (char-ci>=? a b) (char-ci-cmp? >= a b)) 141 142; Note the trick of returning (cmp x y) 143(define (string-cmp? chcmp cmp a b) 144 (let ((na (string-length a)) (nb (string-length b))) 145 (if (<> na nb) 146 (cmp na nb) 147 (let loop ((i 0)) 148 (if (= i na) 149 (if (= na 0) (cmp 0 0) #t) 150 (and (chcmp cmp (string-ref a i) (string-ref b i)) 151 (loop (succ i)))))))) 152 153(define (string=? a b) (string-cmp? char-cmp? = a b)) 154(define (string<? a b) (string-cmp? char-cmp? < a b)) 155(define (string>? a b) (string-cmp? char-cmp? > a b)) 156(define (string<=? a b) (string-cmp? char-cmp? <= a b)) 157(define (string>=? a b) (string-cmp? char-cmp? >= a b)) 158 159(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b)) 160(define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b)) 161(define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b)) 162(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b)) 163(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b)) 164 165(define (list . x) x) 166 167(define (foldr f x lst) 168 (if (null? lst) 169 x 170 (foldr f (f x (car lst)) (cdr lst)))) 171 172(define (unzip1-with-cdr . lists) 173 (unzip1-with-cdr-iterative lists '() '())) 174 175(define (unzip1-with-cdr-iterative lists cars cdrs) 176 (if (null? lists) 177 (cons cars cdrs) 178 (let ((car1 (caar lists)) 179 (cdr1 (cdar lists))) 180 (unzip1-with-cdr-iterative 181 (cdr lists) 182 (append cars (list car1)) 183 (append cdrs (list cdr1)))))) 184 185(define (map proc . lists) 186 (if (null? lists) 187 (apply proc) 188 (if (null? (car lists)) 189 '() 190 (let* ((unz (apply unzip1-with-cdr lists)) 191 (cars (car unz)) 192 (cdrs (cdr unz))) 193 (cons (apply proc cars) (apply map (cons proc cdrs))))))) 194 195(define (for-each proc . lists) 196 (if (null? lists) 197 (apply proc) 198 (if (null? (car lists)) 199 #t 200 (let* ((unz (apply unzip1-with-cdr lists)) 201 (cars (car unz)) 202 (cdrs (cdr unz))) 203 (apply proc cars) (apply map (cons proc cdrs)))))) 204 205(define (list-tail x k) 206 (if (zero? k) 207 x 208 (list-tail (cdr x) (- k 1)))) 209 210(define (list-ref x k) 211 (car (list-tail x k))) 212 213(define (last-pair x) 214 (if (pair? (cdr x)) 215 (last-pair (cdr x)) 216 x)) 217 218(define (head stream) (car stream)) 219 220(define (tail stream) (force (cdr stream))) 221 222(define (vector-equal? x y) 223 (and (vector? x) (vector? y) (= (vector-length x) (vector-length y)) 224 (let ((n (vector-length x))) 225 (let loop ((i 0)) 226 (if (= i n) 227 #t 228 (and (equal? (vector-ref x i) (vector-ref y i)) 229 (loop (succ i)))))))) 230 231(define (list->vector x) 232 (apply vector x)) 233 234(define (vector-fill! v e) 235 (let ((n (vector-length v))) 236 (let loop ((i 0)) 237 (if (= i n) 238 v 239 (begin (vector-set! v i e) (loop (succ i))))))) 240 241(define (vector->list v) 242 (let loop ((n (pred (vector-length v))) (l '())) 243 (if (= n -1) 244 l 245 (loop (pred n) (cons (vector-ref v n) l))))) 246 247;; The following quasiquote macro is due to Eric S. Tiedemann. 248;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. 249;; 250;; Subsequently modified to handle vectors: D. Souflis 251 252(macro 253 quasiquote 254 (lambda (l) 255 (define (mcons f l r) 256 (if (and (pair? r) 257 (eq? (car r) 'quote) 258 (eq? (car (cdr r)) (cdr f)) 259 (pair? l) 260 (eq? (car l) 'quote) 261 (eq? (car (cdr l)) (car f))) 262 (if (or (procedure? f) (number? f) (string? f)) 263 f 264 (list 'quote f)) 265 (if (eqv? l vector) 266 (apply l (eval r)) 267 (list 'cons l r) 268 ))) 269 (define (mappend f l r) 270 (if (or (null? (cdr f)) 271 (and (pair? r) 272 (eq? (car r) 'quote) 273 (eq? (car (cdr r)) '()))) 274 l 275 (list 'append l r))) 276 (define (foo level form) 277 (cond ((not (pair? form)) 278 (if (or (procedure? form) (number? form) (string? form)) 279 form 280 (list 'quote form)) 281 ) 282 ((eq? 'quasiquote (car form)) 283 (mcons form ''quasiquote (foo (+ level 1) (cdr form)))) 284 (#t (if (zero? level) 285 (cond ((eq? (car form) 'unquote) (car (cdr form))) 286 ((eq? (car form) 'unquote-splicing) 287 (error "Unquote-splicing wasn't in a list:" 288 form)) 289 ((and (pair? (car form)) 290 (eq? (car (car form)) 'unquote-splicing)) 291 (mappend form (car (cdr (car form))) 292 (foo level (cdr form)))) 293 (#t (mcons form (foo level (car form)) 294 (foo level (cdr form))))) 295 (cond ((eq? (car form) 'unquote) 296 (mcons form ''unquote (foo (- level 1) 297 (cdr form)))) 298 ((eq? (car form) 'unquote-splicing) 299 (mcons form ''unquote-splicing 300 (foo (- level 1) (cdr form)))) 301 (#t (mcons form (foo level (car form)) 302 (foo level (cdr form))))))))) 303 (foo 0 (car (cdr l))))) 304 305 306;;;;; atom? and equal? written by a.k 307 308;;;; atom? 309(define (atom? x) 310 (not (pair? x))) 311 312;;;; equal? 313(define (equal? x y) 314 (cond 315 ((pair? x) 316 (and (pair? y) 317 (equal? (car x) (car y)) 318 (equal? (cdr x) (cdr y)))) 319 ((vector? x) 320 (and (vector? y) (vector-equal? x y))) 321 ((string? x) 322 (and (string? y) (string=? x y))) 323 (else (eqv? x y)))) 324 325;;;; (do ((var init inc) ...) (endtest result ...) body ...) 326;; 327(macro do 328 (lambda (do-macro) 329 (apply (lambda (do vars endtest . body) 330 (let ((do-loop (gensym))) 331 `(letrec ((,do-loop 332 (lambda ,(map (lambda (x) 333 (if (pair? x) (car x) x)) 334 `,vars) 335 (if ,(car endtest) 336 (begin ,@(cdr endtest)) 337 (begin 338 ,@body 339 (,do-loop 340 ,@(map (lambda (x) 341 (cond 342 ((not (pair? x)) x) 343 ((< (length x) 3) (car x)) 344 (else (car (cdr (cdr x)))))) 345 `,vars))))))) 346 (,do-loop 347 ,@(map (lambda (x) 348 (if (and (pair? x) (cdr x)) 349 (car (cdr x)) 350 '())) 351 `,vars))))) 352 do-macro))) 353 354;;;; generic-member 355(define (generic-member cmp obj lst) 356 (cond 357 ((null? lst) #f) 358 ((cmp obj (car lst)) lst) 359 (else (generic-member cmp obj (cdr lst))))) 360 361(define (memq obj lst) 362 (generic-member eq? obj lst)) 363(define (memv obj lst) 364 (generic-member eqv? obj lst)) 365(define (member obj lst) 366 (generic-member equal? obj lst)) 367 368;;;; generic-assoc 369(define (generic-assoc cmp obj alst) 370 (cond 371 ((null? alst) #f) 372 ((cmp obj (caar alst)) (car alst)) 373 (else (generic-assoc cmp obj (cdr alst))))) 374 375(define (assq obj alst) 376 (generic-assoc eq? obj alst)) 377(define (assv obj alst) 378 (generic-assoc eqv? obj alst)) 379(define (assoc obj alst) 380 (generic-assoc equal? obj alst)) 381 382(define (acons x y z) (cons (cons x y) z)) 383 384;;;; Utility to ease macro creation 385(define (macro-expand form) 386 ((eval (get-closure-code (eval (car form)))) form)) 387 388;;;; Handy for imperative programs 389;;;; Used as: (define-with-return (foo x y) .... (return z) ...) 390(macro (define-with-return form) 391 `(define ,(cadr form) 392 (call/cc (lambda (return) ,@(cddr form))))) 393 394;;;; Simple exception handling 395; 396; Exceptions are caught as follows: 397; 398; (catch (do-something to-recover and-return meaningful-value) 399; (if-something goes-wrong) 400; (with-these calls)) 401; 402; "Catch" establishes a scope spanning multiple call-frames 403; until another "catch" is encountered. 404; 405; Exceptions are thrown with: 406; 407; (throw "message") 408; 409; If used outside a (catch ...), reverts to (error "message) 410 411(define *handlers* (list)) 412 413(define (push-handler proc) 414 (set! *handlers* (cons proc *handlers*))) 415 416(define (pop-handler) 417 (let ((h (car *handlers*))) 418 (set! *handlers* (cdr *handlers*)) 419 h)) 420 421(define (more-handlers?) 422 (pair? *handlers*)) 423 424(define (throw . x) 425 (if (more-handlers?) 426 (apply (pop-handler)) 427 (apply error x))) 428 429(macro (catch form) 430 (let ((label (gensym))) 431 `(call/cc (lambda (exit) 432 (push-handler (lambda () (exit ,(cadr form)))) 433 (let ((,label (begin ,@(cddr form)))) 434 (pop-handler) 435 ,label))))) 436 437(define *error-hook* throw) 438 439 440;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL 441 442(macro (make-environment form) 443 `(apply (lambda () 444 ,@(cdr form) 445 (current-environment)))) 446 447(define-macro (eval-polymorphic x . envl) 448 (display envl) 449 (let* ((env (if (null? envl) (current-environment) (eval (car envl)))) 450 (xval (eval x env))) 451 (if (closure? xval) 452 (make-closure (get-closure-code xval) env) 453 xval))) 454 455; Redefine this if you install another package infrastructure 456; Also redefine 'package' 457(define *colon-hook* eval) 458 459;;;;; I/O 460 461(define (input-output-port? p) 462 (and (input-port? p) (output-port? p))) 463 464(define (close-port p) 465 (cond 466 ((input-output-port? p) (close-input-port (close-output-port p))) 467 ((input-port? p) (close-input-port p)) 468 ((output-port? p) (close-output-port p)) 469 (else (throw "Not a port" p)))) 470 471(define (call-with-input-file s p) 472 (let ((inport (open-input-file s))) 473 (if (eq? inport #f) 474 #f 475 (let ((res (p inport))) 476 (close-input-port inport) 477 res)))) 478 479(define (call-with-output-file s p) 480 (let ((outport (open-output-file s))) 481 (if (eq? outport #f) 482 #f 483 (let ((res (p outport))) 484 (close-output-port outport) 485 res)))) 486 487(define (with-input-from-file s p) 488 (let ((inport (open-input-file s))) 489 (if (eq? inport #f) 490 #f 491 (let ((prev-inport (current-input-port))) 492 (set-input-port inport) 493 (let ((res (p))) 494 (close-input-port inport) 495 (set-input-port prev-inport) 496 res))))) 497 498(define (with-output-to-file s p) 499 (let ((outport (open-output-file s))) 500 (if (eq? outport #f) 501 #f 502 (let ((prev-outport (current-output-port))) 503 (set-output-port outport) 504 (let ((res (p))) 505 (close-output-port outport) 506 (set-output-port prev-outport) 507 res))))) 508 509(define (with-input-output-from-to-files si so p) 510 (let ((inport (open-input-file si)) 511 (outport (open-input-file so))) 512 (if (not (and inport outport)) 513 (begin 514 (close-input-port inport) 515 (close-output-port outport) 516 #f) 517 (let ((prev-inport (current-input-port)) 518 (prev-outport (current-output-port))) 519 (set-input-port inport) 520 (set-output-port outport) 521 (let ((res (p))) 522 (close-input-port inport) 523 (close-output-port outport) 524 (set-input-port prev-inport) 525 (set-output-port prev-outport) 526 res))))) 527 528; Random number generator (maximum cycle) 529(define *seed* 1) 530(define (random-next) 531 (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a))) 532 (set! *seed* 533 (- (* a (- *seed* 534 (* (quotient *seed* q) q))) 535 (* (quotient *seed* q) r))) 536 (if (< *seed* 0) (set! *seed* (+ *seed* m))) 537 *seed*)) 538;; SRFI-0 539;; COND-EXPAND 540;; Implemented as a macro 541(define *features* '(srfi-0)) 542 543(define-macro (cond-expand . cond-action-list) 544 (cond-expand-runtime cond-action-list)) 545 546(define (cond-expand-runtime cond-action-list) 547 (if (null? cond-action-list) 548 #t 549 (if (cond-eval (caar cond-action-list)) 550 `(begin ,@(cdar cond-action-list)) 551 (cond-expand-runtime (cdr cond-action-list))))) 552 553(define (cond-eval-and cond-list) 554 (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list)) 555 556(define (cond-eval-or cond-list) 557 (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list)) 558 559(define (cond-eval condition) 560 (cond ((symbol? condition) 561 (if (member condition *features*) #t #f)) 562 ((eq? condition #t) #t) 563 ((eq? condition #f) #f) 564 (else (case (car condition) 565 ((and) (cond-eval-and (cdr condition))) 566 ((or) (cond-eval-or (cdr condition))) 567 ((not) (if (not (null? (cddr condition))) 568 (error "cond-expand : 'not' takes 1 argument") 569 (not (cond-eval (cadr condition))))) 570 (else (error "cond-expand : unknown operator" (car condition))))))) 571 572(gc-verbose #f) 573