tinyscheme_genesis

raw
tinyscheme_genesi...    1 ;    Initialization file for TinySCHEME 1.41
tinyscheme_genesi...    2 
tinyscheme_genesi...    3 ; Per R5RS, up to four deep compositions should be defined
tinyscheme_genesi...    4 (define (caar x) (car (car x)))
tinyscheme_genesi...    5 (define (cadr x) (car (cdr x)))
tinyscheme_genesi...    6 (define (cdar x) (cdr (car x)))
tinyscheme_genesi...    7 (define (cddr x) (cdr (cdr x)))
tinyscheme_genesi...    8 (define (caaar x) (car (car (car x))))
tinyscheme_genesi...    9 (define (caadr x) (car (car (cdr x))))
tinyscheme_genesi...   10 (define (cadar x) (car (cdr (car x))))
tinyscheme_genesi...   11 (define (caddr x) (car (cdr (cdr x))))
tinyscheme_genesi...   12 (define (cdaar x) (cdr (car (car x))))
tinyscheme_genesi...   13 (define (cdadr x) (cdr (car (cdr x))))
tinyscheme_genesi...   14 (define (cddar x) (cdr (cdr (car x))))
tinyscheme_genesi...   15 (define (cdddr x) (cdr (cdr (cdr x))))
tinyscheme_genesi...   16 (define (caaaar x) (car (car (car (car x)))))
tinyscheme_genesi...   17 (define (caaadr x) (car (car (car (cdr x)))))
tinyscheme_genesi...   18 (define (caadar x) (car (car (cdr (car x)))))
tinyscheme_genesi...   19 (define (caaddr x) (car (car (cdr (cdr x)))))
tinyscheme_genesi...   20 (define (cadaar x) (car (cdr (car (car x)))))
tinyscheme_genesi...   21 (define (cadadr x) (car (cdr (car (cdr x)))))
tinyscheme_genesi...   22 (define (caddar x) (car (cdr (cdr (car x)))))
tinyscheme_genesi...   23 (define (cadddr x) (car (cdr (cdr (cdr x)))))
tinyscheme_genesi...   24 (define (cdaaar x) (cdr (car (car (car x)))))
tinyscheme_genesi...   25 (define (cdaadr x) (cdr (car (car (cdr x)))))
tinyscheme_genesi...   26 (define (cdadar x) (cdr (car (cdr (car x)))))
tinyscheme_genesi...   27 (define (cdaddr x) (cdr (car (cdr (cdr x)))))
tinyscheme_genesi...   28 (define (cddaar x) (cdr (cdr (car (car x)))))
tinyscheme_genesi...   29 (define (cddadr x) (cdr (cdr (car (cdr x)))))
tinyscheme_genesi...   30 (define (cdddar x) (cdr (cdr (cdr (car x)))))
tinyscheme_genesi...   31 (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
tinyscheme_genesi...   32 
tinyscheme_genesi...   33 ;;;; Utility to ease macro creation
tinyscheme_genesi...   34 (define (macro-expand form)
tinyscheme_genesi...   35      ((eval (get-closure-code (eval (car form)))) form))
tinyscheme_genesi...   36 
tinyscheme_genesi...   37 (define (macro-expand-all form)
tinyscheme_genesi...   38    (if (macro? form)
tinyscheme_genesi...   39       (macro-expand-all (macro-expand form))
tinyscheme_genesi...   40       form))
tinyscheme_genesi...   41 
tinyscheme_genesi...   42 (define *compile-hook* macro-expand-all)
tinyscheme_genesi...   43 
tinyscheme_genesi...   44 
tinyscheme_genesi...   45 (macro (unless form)
tinyscheme_genesi...   46      `(if (not ,(cadr form)) (begin ,@(cddr form))))
tinyscheme_genesi...   47 
tinyscheme_genesi...   48 (macro (when form)
tinyscheme_genesi...   49      `(if ,(cadr form) (begin ,@(cddr form))))
tinyscheme_genesi...   50 
tinyscheme_genesi...   51 ; DEFINE-MACRO Contributed by Andy Gaynor
tinyscheme_genesi...   52 (macro (define-macro dform)
tinyscheme_genesi...   53   (if (symbol? (cadr dform))
tinyscheme_genesi...   54     `(macro ,@(cdr dform))
tinyscheme_genesi...   55     (let ((form (gensym)))
tinyscheme_genesi...   56       `(macro (,(caadr dform) ,form)
tinyscheme_genesi...   57          (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
tinyscheme_genesi...   58 
tinyscheme_genesi...   59 ; Utilities for math. Notice that inexact->exact is primitive,
tinyscheme_genesi...   60 ; but exact->inexact is not.
tinyscheme_genesi...   61 (define exact? integer?)
tinyscheme_genesi...   62 (define (inexact? x) (and (real? x) (not (integer? x))))
tinyscheme_genesi...   63 (define (even? n) (= (remainder n 2) 0))
tinyscheme_genesi...   64 (define (odd? n) (not (= (remainder n 2) 0)))
tinyscheme_genesi...   65 (define (zero? n) (= n 0))
tinyscheme_genesi...   66 (define (positive? n) (> n 0))
tinyscheme_genesi...   67 (define (negative? n) (< n 0))
tinyscheme_genesi...   68 (define complex? number?)
tinyscheme_genesi...   69 (define rational? real?)
tinyscheme_genesi...   70 (define (abs n) (if (>= n 0) n (- n)))
tinyscheme_genesi...   71 (define (exact->inexact n) (* n 1.0))
tinyscheme_genesi...   72 (define (<> n1 n2) (not (= n1 n2)))
tinyscheme_genesi...   73 
tinyscheme_genesi...   74 ; min and max must return inexact if any arg is inexact; use (+ n 0.0)
tinyscheme_genesi...   75 (define (max . lst)
tinyscheme_genesi...   76   (foldr (lambda (a b)
tinyscheme_genesi...   77            (if (> a b)
tinyscheme_genesi...   78              (if (exact? b) a (+ a 0.0))
tinyscheme_genesi...   79              (if (exact? a) b (+ b 0.0))))
tinyscheme_genesi...   80          (car lst) (cdr lst)))
tinyscheme_genesi...   81 (define (min . lst)
tinyscheme_genesi...   82   (foldr (lambda (a b)
tinyscheme_genesi...   83            (if (< a b)
tinyscheme_genesi...   84              (if (exact? b) a (+ a 0.0))
tinyscheme_genesi...   85              (if (exact? a) b (+ b 0.0))))
tinyscheme_genesi...   86          (car lst) (cdr lst)))
tinyscheme_genesi...   87 
tinyscheme_genesi...   88 (define (succ x) (+ x 1))
tinyscheme_genesi...   89 (define (pred x) (- x 1))
tinyscheme_genesi...   90 (define gcd
tinyscheme_genesi...   91   (lambda a
tinyscheme_genesi...   92     (if (null? a)
tinyscheme_genesi...   93       0
tinyscheme_genesi...   94       (let ((aa (abs (car a)))
tinyscheme_genesi...   95             (bb (abs (cadr a))))
tinyscheme_genesi...   96          (if (= bb 0)
tinyscheme_genesi...   97               aa
tinyscheme_genesi...   98               (gcd bb (remainder aa bb)))))))
tinyscheme_genesi...   99 (define lcm
tinyscheme_genesi...  100   (lambda a
tinyscheme_genesi...  101     (if (null? a)
tinyscheme_genesi...  102       1
tinyscheme_genesi...  103       (let ((aa (abs (car a)))
tinyscheme_genesi...  104             (bb (abs (cadr a))))
tinyscheme_genesi...  105          (if (or (= aa 0) (= bb 0))
tinyscheme_genesi...  106              0
tinyscheme_genesi...  107              (abs (* (quotient aa (gcd aa bb)) bb)))))))
tinyscheme_genesi...  108 
tinyscheme_genesi...  109 
tinyscheme_genesi...  110 (define (string . charlist)
tinyscheme_genesi...  111      (list->string charlist))
tinyscheme_genesi...  112 
tinyscheme_genesi...  113 (define (list->string charlist)
tinyscheme_genesi...  114      (let* ((len (length charlist))
tinyscheme_genesi...  115             (newstr (make-string len))
tinyscheme_genesi...  116             (fill-string!
tinyscheme_genesi...  117                (lambda (str i len charlist)
tinyscheme_genesi...  118                     (if (= i len)
tinyscheme_genesi...  119                          str
tinyscheme_genesi...  120                          (begin (string-set! str i (car charlist))
tinyscheme_genesi...  121                          (fill-string! str (+ i 1) len (cdr charlist)))))))
tinyscheme_genesi...  122           (fill-string! newstr 0 len charlist)))
tinyscheme_genesi...  123 
tinyscheme_genesi...  124 (define (string-fill! s e)
tinyscheme_genesi...  125      (let ((n (string-length s)))
tinyscheme_genesi...  126           (let loop ((i 0))
tinyscheme_genesi...  127                (if (= i n)
tinyscheme_genesi...  128                     s
tinyscheme_genesi...  129                     (begin (string-set! s i e) (loop (succ i)))))))
tinyscheme_genesi...  130 
tinyscheme_genesi...  131 (define (string->list s)
tinyscheme_genesi...  132      (let loop ((n (pred (string-length s))) (l '()))
tinyscheme_genesi...  133           (if (= n -1)
tinyscheme_genesi...  134                l
tinyscheme_genesi...  135                (loop (pred n) (cons (string-ref s n) l)))))
tinyscheme_genesi...  136 
tinyscheme_genesi...  137 (define (string-copy str)
tinyscheme_genesi...  138      (string-append str))
tinyscheme_genesi...  139 
tinyscheme_genesi...  140 (define (string->anyatom str pred)
tinyscheme_genesi...  141      (let* ((a (string->atom str)))
tinyscheme_genesi...  142        (if (pred a) a
tinyscheme_genesi...  143          (error "string->xxx: not a xxx" a))))
tinyscheme_genesi...  144 
tinyscheme_genesi...  145 (define (string->number str . base)
tinyscheme_genesi...  146     (let ((n (string->atom str (if (null? base) 10 (car base)))))
tinyscheme_genesi...  147         (if (number? n) n #f)))
tinyscheme_genesi...  148 
tinyscheme_genesi...  149 (define (anyatom->string n pred)
tinyscheme_genesi...  150   (if (pred n)
tinyscheme_genesi...  151       (atom->string n)
tinyscheme_genesi...  152       (error "xxx->string: not a xxx" n)))
tinyscheme_genesi...  153 
tinyscheme_genesi...  154 (define (number->string n . base)
tinyscheme_genesi...  155     (atom->string n (if (null? base) 10 (car base))))
tinyscheme_genesi...  156 
tinyscheme_genesi...  157 
tinyscheme_genesi...  158 (define (char-cmp? cmp a b)
tinyscheme_genesi...  159      (cmp (char->integer a) (char->integer b)))
tinyscheme_genesi...  160 (define (char-ci-cmp? cmp a b)
tinyscheme_genesi...  161      (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
tinyscheme_genesi...  162 
tinyscheme_genesi...  163 (define (char=? a b) (char-cmp? = a b))
tinyscheme_genesi...  164 (define (char<? a b) (char-cmp? < a b))
tinyscheme_genesi...  165 (define (char>? a b) (char-cmp? > a b))
tinyscheme_genesi...  166 (define (char<=? a b) (char-cmp? <= a b))
tinyscheme_genesi...  167 (define (char>=? a b) (char-cmp? >= a b))
tinyscheme_genesi...  168 
tinyscheme_genesi...  169 (define (char-ci=? a b) (char-ci-cmp? = a b))
tinyscheme_genesi...  170 (define (char-ci<? a b) (char-ci-cmp? < a b))
tinyscheme_genesi...  171 (define (char-ci>? a b) (char-ci-cmp? > a b))
tinyscheme_genesi...  172 (define (char-ci<=? a b) (char-ci-cmp? <= a b))
tinyscheme_genesi...  173 (define (char-ci>=? a b) (char-ci-cmp? >= a b))
tinyscheme_genesi...  174 
tinyscheme_genesi...  175 ; Note the trick of returning (cmp x y)
tinyscheme_genesi...  176 (define (string-cmp? chcmp cmp a b)
tinyscheme_genesi...  177      (let ((na (string-length a)) (nb (string-length b)))
tinyscheme_genesi...  178           (let loop ((i 0))
tinyscheme_genesi...  179                (cond
tinyscheme_genesi...  180                     ((= i na)
tinyscheme_genesi...  181                          (if (= i nb) (cmp 0 0) (cmp 0 1)))
tinyscheme_genesi...  182                     ((= i nb)
tinyscheme_genesi...  183                          (cmp 1 0))
tinyscheme_genesi...  184                     ((chcmp = (string-ref a i) (string-ref b i))
tinyscheme_genesi...  185                          (loop (succ i)))
tinyscheme_genesi...  186                     (else
tinyscheme_genesi...  187                          (chcmp cmp (string-ref a i) (string-ref b i)))))))
tinyscheme_genesi...  188 
tinyscheme_genesi...  189 
tinyscheme_genesi...  190 (define (string=? a b) (string-cmp? char-cmp? = a b))
tinyscheme_genesi...  191 (define (string<? a b) (string-cmp? char-cmp? < a b))
tinyscheme_genesi...  192 (define (string>? a b) (string-cmp? char-cmp? > a b))
tinyscheme_genesi...  193 (define (string<=? a b) (string-cmp? char-cmp? <= a b))
tinyscheme_genesi...  194 (define (string>=? a b) (string-cmp? char-cmp? >= a b))
tinyscheme_genesi...  195 
tinyscheme_genesi...  196 (define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
tinyscheme_genesi...  197 (define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
tinyscheme_genesi...  198 (define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
tinyscheme_genesi...  199 (define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
tinyscheme_genesi...  200 (define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
tinyscheme_genesi...  201 
tinyscheme_genesi...  202 (define (list . x) x)
tinyscheme_genesi...  203 
tinyscheme_genesi...  204 (define (foldr f x lst)
tinyscheme_genesi...  205      (if (null? lst)
tinyscheme_genesi...  206           x
tinyscheme_genesi...  207           (foldr f (f x (car lst)) (cdr lst))))
tinyscheme_genesi...  208 
tinyscheme_genesi...  209 (define (unzip1-with-cdr . lists)
tinyscheme_genesi...  210   (unzip1-with-cdr-iterative lists '() '()))
tinyscheme_genesi...  211 
tinyscheme_genesi...  212 (define (unzip1-with-cdr-iterative lists cars cdrs)
tinyscheme_genesi...  213   (if (null? lists)
tinyscheme_genesi...  214       (cons cars cdrs)
tinyscheme_genesi...  215       (let ((car1 (caar lists))
tinyscheme_genesi...  216             (cdr1 (cdar lists)))
tinyscheme_genesi...  217         (unzip1-with-cdr-iterative
tinyscheme_genesi...  218           (cdr lists)
tinyscheme_genesi...  219           (append cars (list car1))
tinyscheme_genesi...  220           (append cdrs (list cdr1))))))
tinyscheme_genesi...  221 
tinyscheme_genesi...  222 (define (map proc . lists)
tinyscheme_genesi...  223   (if (null? lists)
tinyscheme_genesi...  224       (apply proc)
tinyscheme_genesi...  225       (if (null? (car lists))
tinyscheme_genesi...  226         '()
tinyscheme_genesi...  227         (let* ((unz (apply unzip1-with-cdr lists))
tinyscheme_genesi...  228                (cars (car unz))
tinyscheme_genesi...  229                (cdrs (cdr unz)))
tinyscheme_genesi...  230           (cons (apply proc cars) (apply map (cons proc cdrs)))))))
tinyscheme_genesi...  231 
tinyscheme_genesi...  232 (define (for-each proc . lists)
tinyscheme_genesi...  233   (if (null? lists)
tinyscheme_genesi...  234       (apply proc)
tinyscheme_genesi...  235       (if (null? (car lists))
tinyscheme_genesi...  236         #t
tinyscheme_genesi...  237         (let* ((unz (apply unzip1-with-cdr lists))
tinyscheme_genesi...  238                (cars (car unz))
tinyscheme_genesi...  239                (cdrs (cdr unz)))
tinyscheme_genesi...  240           (apply proc cars) (apply map (cons proc cdrs))))))
tinyscheme_genesi...  241 
tinyscheme_genesi...  242 (define (list-tail x k)
tinyscheme_genesi...  243     (if (zero? k)
tinyscheme_genesi...  244         x
tinyscheme_genesi...  245         (list-tail (cdr x) (- k 1))))
tinyscheme_genesi...  246 
tinyscheme_genesi...  247 (define (list-ref x k)
tinyscheme_genesi...  248     (car (list-tail x k)))
tinyscheme_genesi...  249 
tinyscheme_genesi...  250 (define (last-pair x)
tinyscheme_genesi...  251     (if (pair? (cdr x))
tinyscheme_genesi...  252         (last-pair (cdr x))
tinyscheme_genesi...  253         x))
tinyscheme_genesi...  254 
tinyscheme_genesi...  255 (define (head stream) (car stream))
tinyscheme_genesi...  256 
tinyscheme_genesi...  257 (define (tail stream) (force (cdr stream)))
tinyscheme_genesi...  258 
tinyscheme_genesi...  259 (define (vector-equal? x y)
tinyscheme_genesi...  260      (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
tinyscheme_genesi...  261           (let ((n (vector-length x)))
tinyscheme_genesi...  262                (let loop ((i 0))
tinyscheme_genesi...  263                     (if (= i n)
tinyscheme_genesi...  264                          #t
tinyscheme_genesi...  265                          (and (equal? (vector-ref x i) (vector-ref y i))
tinyscheme_genesi...  266                               (loop (succ i))))))))
tinyscheme_genesi...  267 
tinyscheme_genesi...  268 (define (list->vector x)
tinyscheme_genesi...  269      (apply vector x))
tinyscheme_genesi...  270 
tinyscheme_genesi...  271 (define (vector-fill! v e)
tinyscheme_genesi...  272      (let ((n (vector-length v)))
tinyscheme_genesi...  273           (let loop ((i 0))
tinyscheme_genesi...  274                (if (= i n)
tinyscheme_genesi...  275                     v
tinyscheme_genesi...  276                     (begin (vector-set! v i e) (loop (succ i)))))))
tinyscheme_genesi...  277 
tinyscheme_genesi...  278 (define (vector->list v)
tinyscheme_genesi...  279      (let loop ((n (pred (vector-length v))) (l '()))
tinyscheme_genesi...  280           (if (= n -1)
tinyscheme_genesi...  281                l
tinyscheme_genesi...  282                (loop (pred n) (cons (vector-ref v n) l)))))
tinyscheme_genesi...  283 
tinyscheme_genesi...  284 ;; The following quasiquote macro is due to Eric S. Tiedemann.
tinyscheme_genesi...  285 ;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
tinyscheme_genesi...  286 ;;
tinyscheme_genesi...  287 ;; Subsequently modified to handle vectors: D. Souflis
tinyscheme_genesi...  288 
tinyscheme_genesi...  289 (macro
tinyscheme_genesi...  290  quasiquote
tinyscheme_genesi...  291  (lambda (l)
tinyscheme_genesi...  292    (define (mcons f l r)
tinyscheme_genesi...  293      (if (and (pair? r)
tinyscheme_genesi...  294               (eq? (car r) 'quote)
tinyscheme_genesi...  295               (eq? (car (cdr r)) (cdr f))
tinyscheme_genesi...  296               (pair? l)
tinyscheme_genesi...  297               (eq? (car l) 'quote)
tinyscheme_genesi...  298               (eq? (car (cdr l)) (car f)))
tinyscheme_genesi...  299          (if (or (procedure? f) (number? f) (string? f))
tinyscheme_genesi...  300                f
tinyscheme_genesi...  301                (list 'quote f))
tinyscheme_genesi...  302          (if (eqv? l vector)
tinyscheme_genesi...  303                (apply l (eval r))
tinyscheme_genesi...  304                (list 'cons l r)
tinyscheme_genesi...  305                )))
tinyscheme_genesi...  306    (define (mappend f l r)
tinyscheme_genesi...  307      (if (or (null? (cdr f))
tinyscheme_genesi...  308              (and (pair? r)
tinyscheme_genesi...  309                   (eq? (car r) 'quote)
tinyscheme_genesi...  310                   (eq? (car (cdr r)) '())))
tinyscheme_genesi...  311          l
tinyscheme_genesi...  312          (list 'append l r)))
tinyscheme_genesi...  313    (define (foo level form)
tinyscheme_genesi...  314      (cond ((not (pair? form))
tinyscheme_genesi...  315                (if (or (procedure? form) (number? form) (string? form))
tinyscheme_genesi...  316                     form
tinyscheme_genesi...  317                     (list 'quote form))
tinyscheme_genesi...  318                )
tinyscheme_genesi...  319            ((eq? 'quasiquote (car form))
tinyscheme_genesi...  320             (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
tinyscheme_genesi...  321            (#t (if (zero? level)
tinyscheme_genesi...  322                    (cond ((eq? (car form) 'unquote) (car (cdr form)))
tinyscheme_genesi...  323                          ((eq? (car form) 'unquote-splicing)
tinyscheme_genesi...  324                           (error "Unquote-splicing wasn't in a list:"
tinyscheme_genesi...  325                                  form))
tinyscheme_genesi...  326                          ((and (pair? (car form))
tinyscheme_genesi...  327                                (eq? (car (car form)) 'unquote-splicing))
tinyscheme_genesi...  328                           (mappend form (car (cdr (car form)))
tinyscheme_genesi...  329                                    (foo level (cdr form))))
tinyscheme_genesi...  330                          (#t (mcons form (foo level (car form))
tinyscheme_genesi...  331                                          (foo level (cdr form)))))
tinyscheme_genesi...  332                    (cond ((eq? (car form) 'unquote)
tinyscheme_genesi...  333                           (mcons form ''unquote (foo (- level 1)
tinyscheme_genesi...  334                                                      (cdr form))))
tinyscheme_genesi...  335                          ((eq? (car form) 'unquote-splicing)
tinyscheme_genesi...  336                           (mcons form ''unquote-splicing
tinyscheme_genesi...  337                                       (foo (- level 1) (cdr form))))
tinyscheme_genesi...  338                          (#t (mcons form (foo level (car form))
tinyscheme_genesi...  339                                          (foo level (cdr form)))))))))
tinyscheme_genesi...  340    (foo 0 (car (cdr l)))))
tinyscheme_genesi...  341 
tinyscheme_genesi...  342 ;;;;;Helper for the dynamic-wind definition.  By Tom Breton (Tehom)
tinyscheme_genesi...  343 (define (shared-tail x y)
tinyscheme_genesi...  344    (let ((len-x (length x))
tinyscheme_genesi...  345          (len-y (length y)))
tinyscheme_genesi...  346       (define (shared-tail-helper x y)
tinyscheme_genesi...  347          (if
tinyscheme_genesi...  348             (eq? x y)
tinyscheme_genesi...  349             x
tinyscheme_genesi...  350             (shared-tail-helper (cdr x) (cdr y))))
tinyscheme_genesi...  351 
tinyscheme_genesi...  352       (cond
tinyscheme_genesi...  353          ((> len-x len-y)
tinyscheme_genesi...  354             (shared-tail-helper
tinyscheme_genesi...  355                (list-tail x (- len-x len-y))
tinyscheme_genesi...  356                y))
tinyscheme_genesi...  357          ((< len-x len-y)
tinyscheme_genesi...  358             (shared-tail-helper
tinyscheme_genesi...  359                x
tinyscheme_genesi...  360                (list-tail y (- len-y len-x))))
tinyscheme_genesi...  361          (#t (shared-tail-helper x y)))))
tinyscheme_genesi...  362 
tinyscheme_genesi...  363 ;;;;;Dynamic-wind by Tom Breton (Tehom)
tinyscheme_genesi...  364 
tinyscheme_genesi...  365 ;;Guarded because we must only eval this once, because doing so
tinyscheme_genesi...  366 ;;redefines call/cc in terms of old call/cc
tinyscheme_genesi...  367 (unless (defined? 'dynamic-wind)
tinyscheme_genesi...  368    (let
tinyscheme_genesi...  369       ;;These functions are defined in the context of a private list of
tinyscheme_genesi...  370       ;;pairs of before/after procs.
tinyscheme_genesi...  371       (  (*active-windings* '())
tinyscheme_genesi...  372          ;;We'll define some functions into the larger environment, so
tinyscheme_genesi...  373          ;;we need to know it.
tinyscheme_genesi...  374          (outer-env (current-environment)))
tinyscheme_genesi...  375 
tinyscheme_genesi...  376       ;;Poor-man's structure operations
tinyscheme_genesi...  377       (define before-func car)
tinyscheme_genesi...  378       (define after-func  cdr)
tinyscheme_genesi...  379       (define make-winding cons)
tinyscheme_genesi...  380 
tinyscheme_genesi...  381       ;;Manage active windings
tinyscheme_genesi...  382       (define (activate-winding! new)
tinyscheme_genesi...  383          ((before-func new))
tinyscheme_genesi...  384          (set! *active-windings* (cons new *active-windings*)))
tinyscheme_genesi...  385       (define (deactivate-top-winding!)
tinyscheme_genesi...  386          (let ((old-top (car *active-windings*)))
tinyscheme_genesi...  387             ;;Remove it from the list first so it's not active during its
tinyscheme_genesi...  388             ;;own exit.
tinyscheme_genesi...  389             (set! *active-windings* (cdr *active-windings*))
tinyscheme_genesi...  390             ((after-func old-top))))
tinyscheme_genesi...  391 
tinyscheme_genesi...  392       (define (set-active-windings! new-ws)
tinyscheme_genesi...  393          (unless (eq? new-ws *active-windings*)
tinyscheme_genesi...  394             (let ((shared (shared-tail new-ws *active-windings*)))
tinyscheme_genesi...  395 
tinyscheme_genesi...  396                ;;Define the looping functions.
tinyscheme_genesi...  397                ;;Exit the old list.  Do deeper ones last.  Don't do
tinyscheme_genesi...  398                ;;any shared ones.
tinyscheme_genesi...  399                (define (pop-many)
tinyscheme_genesi...  400                   (unless (eq? *active-windings* shared)
tinyscheme_genesi...  401                      (deactivate-top-winding!)
tinyscheme_genesi...  402                      (pop-many)))
tinyscheme_genesi...  403                ;;Enter the new list.  Do deeper ones first so that the
tinyscheme_genesi...  404                ;;deeper windings will already be active.  Don't do any
tinyscheme_genesi...  405                ;;shared ones.
tinyscheme_genesi...  406                (define (push-many new-ws)
tinyscheme_genesi...  407                   (unless (eq? new-ws shared)
tinyscheme_genesi...  408                      (push-many (cdr new-ws))
tinyscheme_genesi...  409                      (activate-winding! (car new-ws))))
tinyscheme_genesi...  410 
tinyscheme_genesi...  411                ;;Do it.
tinyscheme_genesi...  412                (pop-many)
tinyscheme_genesi...  413                (push-many new-ws))))
tinyscheme_genesi...  414 
tinyscheme_genesi...  415       ;;The definitions themselves.
tinyscheme_genesi...  416       (eval
tinyscheme_genesi...  417          `(define call-with-current-continuation
tinyscheme_genesi...  418              ;;It internally uses the built-in call/cc, so capture it.
tinyscheme_genesi...  419              ,(let ((old-c/cc call-with-current-continuation))
tinyscheme_genesi...  420                  (lambda (func)
tinyscheme_genesi...  421                     ;;Use old call/cc to get the continuation.
tinyscheme_genesi...  422                     (old-c/cc
tinyscheme_genesi...  423                        (lambda (continuation)
tinyscheme_genesi...  424                           ;;Call func with not the continuation itself
tinyscheme_genesi...  425                           ;;but a procedure that adjusts the active
tinyscheme_genesi...  426                           ;;windings to what they were when we made
tinyscheme_genesi...  427                           ;;this, and only then calls the
tinyscheme_genesi...  428                           ;;continuation.
tinyscheme_genesi...  429                           (func
tinyscheme_genesi...  430                              (let ((current-ws *active-windings*))
tinyscheme_genesi...  431                                 (lambda (x)
tinyscheme_genesi...  432                                    (set-active-windings! current-ws)
tinyscheme_genesi...  433                                    (continuation x)))))))))
tinyscheme_genesi...  434          outer-env)
tinyscheme_genesi...  435       ;;We can't just say "define (dynamic-wind before thunk after)"
tinyscheme_genesi...  436       ;;because the lambda it's defined to lives in this environment,
tinyscheme_genesi...  437       ;;not in the global environment.
tinyscheme_genesi...  438       (eval
tinyscheme_genesi...  439          `(define dynamic-wind
tinyscheme_genesi...  440              ,(lambda (before thunk after)
tinyscheme_genesi...  441                  ;;Make a new winding
tinyscheme_genesi...  442                  (activate-winding! (make-winding before after))
tinyscheme_genesi...  443                  (let ((result (thunk)))
tinyscheme_genesi...  444                     ;;Get rid of the new winding.
tinyscheme_genesi...  445                     (deactivate-top-winding!)
tinyscheme_genesi...  446                     ;;The return value is that of thunk.
tinyscheme_genesi...  447                     result)))
tinyscheme_genesi...  448          outer-env)))
tinyscheme_genesi...  449 
tinyscheme_genesi...  450 (define call/cc call-with-current-continuation)
tinyscheme_genesi...  451 
tinyscheme_genesi...  452 
tinyscheme_genesi...  453 ;;;;; atom? and equal? written by a.k
tinyscheme_genesi...  454 
tinyscheme_genesi...  455 ;;;; atom?
tinyscheme_genesi...  456 (define (atom? x)
tinyscheme_genesi...  457   (not (pair? x)))
tinyscheme_genesi...  458 
tinyscheme_genesi...  459 ;;;;    equal?
tinyscheme_genesi...  460 (define (equal? x y)
tinyscheme_genesi...  461      (cond
tinyscheme_genesi...  462           ((pair? x)
tinyscheme_genesi...  463                (and (pair? y)
tinyscheme_genesi...  464                     (equal? (car x) (car y))
tinyscheme_genesi...  465                     (equal? (cdr x) (cdr y))))
tinyscheme_genesi...  466           ((vector? x)
tinyscheme_genesi...  467                (and (vector? y) (vector-equal? x y)))
tinyscheme_genesi...  468           ((string? x)
tinyscheme_genesi...  469                (and (string? y) (string=? x y)))
tinyscheme_genesi...  470           (else (eqv? x y))))
tinyscheme_genesi...  471 
tinyscheme_genesi...  472 ;;;; (do ((var init inc) ...) (endtest result ...) body ...)
tinyscheme_genesi...  473 ;;
tinyscheme_genesi...  474 (macro do
tinyscheme_genesi...  475   (lambda (do-macro)
tinyscheme_genesi...  476     (apply (lambda (do vars endtest . body)
tinyscheme_genesi...  477              (let ((do-loop (gensym)))
tinyscheme_genesi...  478                `(letrec ((,do-loop
tinyscheme_genesi...  479                            (lambda ,(map (lambda (x)
tinyscheme_genesi...  480                                            (if (pair? x) (car x) x))
tinyscheme_genesi...  481                                       `,vars)
tinyscheme_genesi...  482                              (if ,(car endtest)
tinyscheme_genesi...  483                                (begin ,@(cdr endtest))
tinyscheme_genesi...  484                                (begin
tinyscheme_genesi...  485                                  ,@body
tinyscheme_genesi...  486                                  (,do-loop
tinyscheme_genesi...  487                                    ,@(map (lambda (x)
tinyscheme_genesi...  488                                             (cond
tinyscheme_genesi...  489                                               ((not (pair? x)) x)
tinyscheme_genesi...  490                                               ((< (length x) 3) (car x))
tinyscheme_genesi...  491                                               (else (car (cdr (cdr x))))))
tinyscheme_genesi...  492                                        `,vars)))))))
tinyscheme_genesi...  493                   (,do-loop
tinyscheme_genesi...  494                     ,@(map (lambda (x)
tinyscheme_genesi...  495                              (if (and (pair? x) (cdr x))
tinyscheme_genesi...  496                                (car (cdr x))
tinyscheme_genesi...  497                                '()))
tinyscheme_genesi...  498                         `,vars)))))
tinyscheme_genesi...  499       do-macro)))
tinyscheme_genesi...  500 
tinyscheme_genesi...  501 ;;;; generic-member
tinyscheme_genesi...  502 (define (generic-member cmp obj lst)
tinyscheme_genesi...  503   (cond
tinyscheme_genesi...  504     ((null? lst) #f)
tinyscheme_genesi...  505     ((cmp obj (car lst)) lst)
tinyscheme_genesi...  506     (else (generic-member cmp obj (cdr lst)))))
tinyscheme_genesi...  507 
tinyscheme_genesi...  508 (define (memq obj lst)
tinyscheme_genesi...  509      (generic-member eq? obj lst))
tinyscheme_genesi...  510 (define (memv obj lst)
tinyscheme_genesi...  511      (generic-member eqv? obj lst))
tinyscheme_genesi...  512 (define (member obj lst)
tinyscheme_genesi...  513      (generic-member equal? obj lst))
tinyscheme_genesi...  514 
tinyscheme_genesi...  515 ;;;; generic-assoc
tinyscheme_genesi...  516 (define (generic-assoc cmp obj alst)
tinyscheme_genesi...  517      (cond
tinyscheme_genesi...  518           ((null? alst) #f)
tinyscheme_genesi...  519           ((cmp obj (caar alst)) (car alst))
tinyscheme_genesi...  520           (else (generic-assoc cmp obj (cdr alst)))))
tinyscheme_genesi...  521 
tinyscheme_genesi...  522 (define (assq obj alst)
tinyscheme_genesi...  523      (generic-assoc eq? obj alst))
tinyscheme_genesi...  524 (define (assv obj alst)
tinyscheme_genesi...  525      (generic-assoc eqv? obj alst))
tinyscheme_genesi...  526 (define (assoc obj alst)
tinyscheme_genesi...  527      (generic-assoc equal? obj alst))
tinyscheme_genesi...  528 
tinyscheme_genesi...  529 (define (acons x y z) (cons (cons x y) z))
tinyscheme_genesi...  530 
tinyscheme_genesi...  531 ;;;; Handy for imperative programs
tinyscheme_genesi...  532 ;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
tinyscheme_genesi...  533 (macro (define-with-return form)
tinyscheme_genesi...  534      `(define ,(cadr form)
tinyscheme_genesi...  535           (call/cc (lambda (return) ,@(cddr form)))))
tinyscheme_genesi...  536 
tinyscheme_genesi...  537 ;;;; Simple exception handling
tinyscheme_genesi...  538 ;
tinyscheme_genesi...  539 ;    Exceptions are caught as follows:
tinyscheme_genesi...  540 ;
tinyscheme_genesi...  541 ;         (catch (do-something to-recover and-return meaningful-value)
tinyscheme_genesi...  542 ;              (if-something goes-wrong)
tinyscheme_genesi...  543 ;              (with-these calls))
tinyscheme_genesi...  544 ;
tinyscheme_genesi...  545 ;    "Catch" establishes a scope spanning multiple call-frames
tinyscheme_genesi...  546 ;    until another "catch" is encountered.
tinyscheme_genesi...  547 ;
tinyscheme_genesi...  548 ;    Exceptions are thrown with:
tinyscheme_genesi...  549 ;
tinyscheme_genesi...  550 ;         (throw "message")
tinyscheme_genesi...  551 ;
tinyscheme_genesi...  552 ;    If used outside a (catch ...), reverts to (error "message)
tinyscheme_genesi...  553 
tinyscheme_genesi...  554 (define *handlers* (list))
tinyscheme_genesi...  555 
tinyscheme_genesi...  556 (define (push-handler proc)
tinyscheme_genesi...  557      (set! *handlers* (cons proc *handlers*)))
tinyscheme_genesi...  558 
tinyscheme_genesi...  559 (define (pop-handler)
tinyscheme_genesi...  560      (let ((h (car *handlers*)))
tinyscheme_genesi...  561           (set! *handlers* (cdr *handlers*))
tinyscheme_genesi...  562           h))
tinyscheme_genesi...  563 
tinyscheme_genesi...  564 (define (more-handlers?)
tinyscheme_genesi...  565      (pair? *handlers*))
tinyscheme_genesi...  566 
tinyscheme_genesi...  567 (define (throw . x)
tinyscheme_genesi...  568      (if (more-handlers?)
tinyscheme_genesi...  569           (apply (pop-handler))
tinyscheme_genesi...  570           (apply error x)))
tinyscheme_genesi...  571 
tinyscheme_genesi...  572 (macro (catch form)
tinyscheme_genesi...  573      (let ((label (gensym)))
tinyscheme_genesi...  574           `(call/cc (lambda (exit)
tinyscheme_genesi...  575                (push-handler (lambda () (exit ,(cadr form))))
tinyscheme_genesi...  576                (let ((,label (begin ,@(cddr form))))
tinyscheme_genesi...  577                     (pop-handler)
tinyscheme_genesi...  578                     ,label)))))
tinyscheme_genesi...  579 
tinyscheme_genesi...  580 (define *error-hook* throw)
tinyscheme_genesi...  581 
tinyscheme_genesi...  582 
tinyscheme_genesi...  583 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
tinyscheme_genesi...  584 
tinyscheme_genesi...  585 (macro (make-environment form)
tinyscheme_genesi...  586      `(apply (lambda ()
tinyscheme_genesi...  587                ,@(cdr form)
tinyscheme_genesi...  588                (current-environment))))
tinyscheme_genesi...  589 
tinyscheme_genesi...  590 (define-macro (eval-polymorphic x . envl)
tinyscheme_genesi...  591   (display envl)
tinyscheme_genesi...  592   (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
tinyscheme_genesi...  593          (xval (eval x env)))
tinyscheme_genesi...  594     (if (closure? xval)
tinyscheme_genesi...  595       (make-closure (get-closure-code xval) env)
tinyscheme_genesi...  596       xval)))
tinyscheme_genesi...  597 
tinyscheme_genesi...  598 ; Redefine this if you install another package infrastructure
tinyscheme_genesi...  599 ; Also redefine 'package'
tinyscheme_genesi...  600 (define *colon-hook* eval)
tinyscheme_genesi...  601 
tinyscheme_genesi...  602 ;;;;; I/O
tinyscheme_genesi...  603 
tinyscheme_genesi...  604 (define (input-output-port? p)
tinyscheme_genesi...  605      (and (input-port? p) (output-port? p)))
tinyscheme_genesi...  606 
tinyscheme_genesi...  607 (define (close-port p)
tinyscheme_genesi...  608      (cond
tinyscheme_genesi...  609           ((input-output-port? p) (close-input-port (close-output-port p)))
tinyscheme_genesi...  610           ((input-port? p) (close-input-port p))
tinyscheme_genesi...  611           ((output-port? p) (close-output-port p))
tinyscheme_genesi...  612           (else (throw "Not a port" p))))
tinyscheme_genesi...  613 
tinyscheme_genesi...  614 (define (call-with-input-file s p)
tinyscheme_genesi...  615      (let ((inport (open-input-file s)))
tinyscheme_genesi...  616           (if (eq? inport #f)
tinyscheme_genesi...  617                #f
tinyscheme_genesi...  618                (let ((res (p inport)))
tinyscheme_genesi...  619                     (close-input-port inport)
tinyscheme_genesi...  620                     res))))
tinyscheme_genesi...  621 
tinyscheme_genesi...  622 (define (call-with-output-file s p)
tinyscheme_genesi...  623      (let ((outport (open-output-file s)))
tinyscheme_genesi...  624           (if (eq? outport #f)
tinyscheme_genesi...  625                #f
tinyscheme_genesi...  626                (let ((res (p outport)))
tinyscheme_genesi...  627                     (close-output-port outport)
tinyscheme_genesi...  628                     res))))
tinyscheme_genesi...  629 
tinyscheme_genesi...  630 (define (with-input-from-file s p)
tinyscheme_genesi...  631      (let ((inport (open-input-file s)))
tinyscheme_genesi...  632           (if (eq? inport #f)
tinyscheme_genesi...  633                #f
tinyscheme_genesi...  634                (let ((prev-inport (current-input-port)))
tinyscheme_genesi...  635                     (set-input-port inport)
tinyscheme_genesi...  636                     (let ((res (p)))
tinyscheme_genesi...  637                          (close-input-port inport)
tinyscheme_genesi...  638                          (set-input-port prev-inport)
tinyscheme_genesi...  639                          res)))))
tinyscheme_genesi...  640 
tinyscheme_genesi...  641 (define (with-output-to-file s p)
tinyscheme_genesi...  642      (let ((outport (open-output-file s)))
tinyscheme_genesi...  643           (if (eq? outport #f)
tinyscheme_genesi...  644                #f
tinyscheme_genesi...  645                (let ((prev-outport (current-output-port)))
tinyscheme_genesi...  646                     (set-output-port outport)
tinyscheme_genesi...  647                     (let ((res (p)))
tinyscheme_genesi...  648                          (close-output-port outport)
tinyscheme_genesi...  649                          (set-output-port prev-outport)
tinyscheme_genesi...  650                          res)))))
tinyscheme_genesi...  651 
tinyscheme_genesi...  652 (define (with-input-output-from-to-files si so p)
tinyscheme_genesi...  653      (let ((inport (open-input-file si))
tinyscheme_genesi...  654            (outport (open-input-file so)))
tinyscheme_genesi...  655           (if (not (and inport outport))
tinyscheme_genesi...  656                (begin
tinyscheme_genesi...  657                     (close-input-port inport)
tinyscheme_genesi...  658                     (close-output-port outport)
tinyscheme_genesi...  659                     #f)
tinyscheme_genesi...  660                (let ((prev-inport (current-input-port))
tinyscheme_genesi...  661                      (prev-outport (current-output-port)))
tinyscheme_genesi...  662                     (set-input-port inport)
tinyscheme_genesi...  663                     (set-output-port outport)
tinyscheme_genesi...  664                     (let ((res (p)))
tinyscheme_genesi...  665                          (close-input-port inport)
tinyscheme_genesi...  666                          (close-output-port outport)
tinyscheme_genesi...  667                          (set-input-port prev-inport)
tinyscheme_genesi...  668                          (set-output-port prev-outport)
tinyscheme_genesi...  669                          res)))))
tinyscheme_genesi...  670 
tinyscheme_genesi...  671 ; Random number generator (maximum cycle)
tinyscheme_genesi...  672 (define *seed* 1)
tinyscheme_genesi...  673 (define (random-next)
tinyscheme_genesi...  674      (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
tinyscheme_genesi...  675           (set! *seed*
tinyscheme_genesi...  676                (-   (* a (- *seed*
tinyscheme_genesi...  677                          (* (quotient *seed* q) q)))
tinyscheme_genesi...  678                     (* (quotient *seed* q) r)))
tinyscheme_genesi...  679           (if (< *seed* 0) (set! *seed* (+ *seed* m)))
tinyscheme_genesi...  680           *seed*))
tinyscheme_genesi...  681 ;; SRFI-0
tinyscheme_genesi...  682 ;; COND-EXPAND
tinyscheme_genesi...  683 ;; Implemented as a macro
tinyscheme_genesi...  684 (define *features* '(srfi-0))
tinyscheme_genesi...  685 
tinyscheme_genesi...  686 (define-macro (cond-expand . cond-action-list)
tinyscheme_genesi...  687   (cond-expand-runtime cond-action-list))
tinyscheme_genesi...  688 
tinyscheme_genesi...  689 (define (cond-expand-runtime cond-action-list)
tinyscheme_genesi...  690   (if (null? cond-action-list)
tinyscheme_genesi...  691       #t
tinyscheme_genesi...  692       (if (cond-eval (caar cond-action-list))
tinyscheme_genesi...  693           `(begin ,@(cdar cond-action-list))
tinyscheme_genesi...  694           (cond-expand-runtime (cdr cond-action-list)))))
tinyscheme_genesi...  695 
tinyscheme_genesi...  696 (define (cond-eval-and cond-list)
tinyscheme_genesi...  697   (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
tinyscheme_genesi...  698 
tinyscheme_genesi...  699 (define (cond-eval-or cond-list)
tinyscheme_genesi...  700   (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
tinyscheme_genesi...  701 
tinyscheme_genesi...  702 (define (cond-eval condition)
tinyscheme_genesi...  703   (cond
tinyscheme_genesi...  704     ((symbol? condition)
tinyscheme_genesi...  705        (if (member condition *features*) #t #f))
tinyscheme_genesi...  706     ((eq? condition #t) #t)
tinyscheme_genesi...  707     ((eq? condition #f) #f)
tinyscheme_genesi...  708     (else (case (car condition)
tinyscheme_genesi...  709             ((and) (cond-eval-and (cdr condition)))
tinyscheme_genesi...  710             ((or) (cond-eval-or (cdr condition)))
tinyscheme_genesi...  711             ((not) (if (not (null? (cddr condition)))
tinyscheme_genesi...  712                      (error "cond-expand : 'not' takes 1 argument")
tinyscheme_genesi...  713                      (not (cond-eval (cadr condition)))))
tinyscheme_genesi...  714             (else (error "cond-expand : unknown operator" (car condition)))))))
tinyscheme_genesi...  715 
tinyscheme_genesi...  716 (gc-verbose #f)