microscheme/init.scm

;    Initialization file for TinySCHEME 1.41

; Per R5RS, up to four deep compositions should be defined
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))

;;;; Utility to ease macro creation
(define (macro-expand form)
     ((eval (get-closure-code (eval (car form)))) form))

(define (macro-expand-all form)
   (if (macro? form)
      (macro-expand-all (macro-expand form))
      form))

(define *compile-hook* macro-expand-all)


(macro (unless form)
     `(if (not ,(cadr form)) (begin ,@(cddr form))))

(macro (when form)
     `(if ,(cadr form) (begin ,@(cddr form))))

; DEFINE-MACRO Contributed by Andy Gaynor
(macro (define-macro dform)
  (if (symbol? (cadr dform))
    `(macro ,@(cdr dform))
    (let ((form (gensym)))
      `(macro (,(caadr dform) ,form)
         (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))

; Utilities for math. Notice that inexact->exact is primitive,
; but exact->inexact is not.
(define exact? integer?)
(define (inexact? x) (and (real? x) (not (integer? x))))
(define (even? n) (= (remainder n 2) 0))
(define (odd? n) (not (= (remainder n 2) 0)))
(define (zero? n) (= n 0))
(define (positive? n) (> n 0))
(define (negative? n) (< n 0))
(define complex? number?)
(define rational? real?)
(define (abs n) (if (>= n 0) n (- n)))
(define (exact->inexact n) (* n 1.0))
(define (<> n1 n2) (not (= n1 n2)))

; min and max must return inexact if any arg is inexact; use (+ n 0.0)
(define (max . lst)
  (foldr (lambda (a b)
           (if (> a b)
             (if (exact? b) a (+ a 0.0))
             (if (exact? a) b (+ b 0.0))))
         (car lst) (cdr lst)))
(define (min . lst)
  (foldr (lambda (a b)
           (if (< a b)
             (if (exact? b) a (+ a 0.0))
             (if (exact? a) b (+ b 0.0))))
         (car lst) (cdr lst)))

(define (succ x) (+ x 1))
(define (pred x) (- x 1))
(define gcd
  (lambda a
    (if (null? a)
      0
      (let ((aa (abs (car a)))
            (bb (abs (cadr a))))
         (if (= bb 0)
              aa
              (gcd bb (remainder aa bb)))))))
(define lcm
  (lambda a
    (if (null? a)
      1
      (let ((aa (abs (car a)))
            (bb (abs (cadr a))))
         (if (or (= aa 0) (= bb 0))
             0
             (abs (* (quotient aa (gcd aa bb)) bb)))))))


(define (string . charlist)
     (list->string charlist))

(define (list->string charlist)
     (let* ((len (length charlist))
            (newstr (make-string len))
            (fill-string!
               (lambda (str i len charlist)
                    (if (= i len)
                         str
                         (begin (string-set! str i (car charlist))
                         (fill-string! str (+ i 1) len (cdr charlist)))))))
          (fill-string! newstr 0 len charlist)))

(define (string-fill! s e)
     (let ((n (string-length s)))
          (let loop ((i 0))
               (if (= i n)
                    s
                    (begin (string-set! s i e) (loop (succ i)))))))

(define (string->list s)
     (let loop ((n (pred (string-length s))) (l '()))
          (if (= n -1)
               l
               (loop (pred n) (cons (string-ref s n) l)))))

(define (string-copy str)
     (string-append str))

(define (string->anyatom str pred)
     (let* ((a (string->atom str)))
       (if (pred a) a
         (error "string->xxx: not a xxx" a))))

(define (string->number str . base)
    (let ((n (string->atom str (if (null? base) 10 (car base)))))
        (if (number? n) n #f)))

(define (anyatom->string n pred)
  (if (pred n)
      (atom->string n)
      (error "xxx->string: not a xxx" n)))

(define (number->string n . base)
    (atom->string n (if (null? base) 10 (car base))))


(define (char-cmp? cmp a b)
     (cmp (char->integer a) (char->integer b)))
(define (char-ci-cmp? cmp a b)
     (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))

(define (char=? a b) (char-cmp? = a b))
(define (char<? a b) (char-cmp? < a b))
(define (char>? a b) (char-cmp? > a b))
(define (char<=? a b) (char-cmp? <= a b))
(define (char>=? a b) (char-cmp? >= a b))

(define (char-ci=? a b) (char-ci-cmp? = a b))
(define (char-ci<? a b) (char-ci-cmp? < a b))
(define (char-ci>? a b) (char-ci-cmp? > a b))
(define (char-ci<=? a b) (char-ci-cmp? <= a b))
(define (char-ci>=? a b) (char-ci-cmp? >= a b))

; Note the trick of returning (cmp x y)
(define (string-cmp? chcmp cmp a b)
     (let ((na (string-length a)) (nb (string-length b)))
          (let loop ((i 0))
               (cond
                    ((= i na)
                         (if (= i nb) (cmp 0 0) (cmp 0 1)))
                    ((= i nb)
                         (cmp 1 0))
                    ((chcmp = (string-ref a i) (string-ref b i))
                         (loop (succ i)))
                    (else
                         (chcmp cmp (string-ref a i) (string-ref b i)))))))


(define (string=? a b) (string-cmp? char-cmp? = a b))
(define (string<? a b) (string-cmp? char-cmp? < a b))
(define (string>? a b) (string-cmp? char-cmp? > a b))
(define (string<=? a b) (string-cmp? char-cmp? <= a b))
(define (string>=? a b) (string-cmp? char-cmp? >= a b))

(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
(define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
(define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))

(define (list . x) x)

(define (foldr f x lst)
     (if (null? lst)
          x
          (foldr f (f x (car lst)) (cdr lst))))

(define (unzip1-with-cdr . lists)
  (unzip1-with-cdr-iterative lists '() '()))

(define (unzip1-with-cdr-iterative lists cars cdrs)
  (if (null? lists)
      (cons cars cdrs)
      (let ((car1 (caar lists))
            (cdr1 (cdar lists)))
        (unzip1-with-cdr-iterative
          (cdr lists)
          (append cars (list car1))
          (append cdrs (list cdr1))))))

(define (map proc . lists)
  (if (null? lists)
      (apply proc)
      (if (null? (car lists))
        '()
        (let* ((unz (apply unzip1-with-cdr lists))
               (cars (car unz))
               (cdrs (cdr unz)))
          (cons (apply proc cars) (apply map (cons proc cdrs)))))))

(define (for-each proc . lists)
  (if (null? lists)
      (apply proc)
      (if (null? (car lists))
        #t
        (let* ((unz (apply unzip1-with-cdr lists))
               (cars (car unz))
               (cdrs (cdr unz)))
          (apply proc cars) (apply map (cons proc cdrs))))))

(define (list-tail x k)
    (if (zero? k)
        x
        (list-tail (cdr x) (- k 1))))

(define (list-ref x k)
    (car (list-tail x k)))

(define (last-pair x)
    (if (pair? (cdr x))
        (last-pair (cdr x))
        x))

(define (head stream) (car stream))

(define (tail stream) (force (cdr stream)))

(define (vector-equal? x y)
     (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
          (let ((n (vector-length x)))
               (let loop ((i 0))
                    (if (= i n)
                         #t
                         (and (equal? (vector-ref x i) (vector-ref y i))
                              (loop (succ i))))))))

(define (list->vector x)
     (apply vector x))

(define (vector-fill! v e)
     (let ((n (vector-length v)))
          (let loop ((i 0))
               (if (= i n)
                    v
                    (begin (vector-set! v i e) (loop (succ i)))))))

(define (vector->list v)
     (let loop ((n (pred (vector-length v))) (l '()))
          (if (= n -1)
               l
               (loop (pred n) (cons (vector-ref v n) l)))))

;; The following quasiquote macro is due to Eric S. Tiedemann.
;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
;;
;; Subsequently modified to handle vectors: D. Souflis

(macro
 quasiquote
 (lambda (l)
   (define (mcons f l r)
     (if (and (pair? r)
              (eq? (car r) 'quote)
              (eq? (car (cdr r)) (cdr f))
              (pair? l)
              (eq? (car l) 'quote)
              (eq? (car (cdr l)) (car f)))
         (if (or (procedure? f) (number? f) (string? f))
               f
               (list 'quote f))
         (if (eqv? l vector)
               (apply l (eval r))
               (list 'cons l r)
               )))
   (define (mappend f l r)
     (if (or (null? (cdr f))
             (and (pair? r)
                  (eq? (car r) 'quote)
                  (eq? (car (cdr r)) '())))
         l
         (list 'append l r)))
   (define (foo level form)
     (cond ((not (pair? form))
               (if (or (procedure? form) (number? form) (string? form))
                    form
                    (list 'quote form))
               )
           ((eq? 'quasiquote (car form))
            (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
           (#t (if (zero? level)
                   (cond ((eq? (car form) 'unquote) (car (cdr form)))
                         ((eq? (car form) 'unquote-splicing)
                          (error "Unquote-splicing wasn't in a list:"
                                 form))
                         ((and (pair? (car form))
                               (eq? (car (car form)) 'unquote-splicing))
                          (mappend form (car (cdr (car form)))
                                   (foo level (cdr form))))
                         (#t (mcons form (foo level (car form))
                                         (foo level (cdr form)))))
                   (cond ((eq? (car form) 'unquote)
                          (mcons form ''unquote (foo (- level 1)
                                                     (cdr form))))
                         ((eq? (car form) 'unquote-splicing)
                          (mcons form ''unquote-splicing
                                      (foo (- level 1) (cdr form))))
                         (#t (mcons form (foo level (car form))
                                         (foo level (cdr form)))))))))
   (foo 0 (car (cdr l)))))

;;;;;Helper for the dynamic-wind definition.  By Tom Breton (Tehom)
(define (shared-tail x y)
   (let ((len-x (length x))
         (len-y (length y)))
      (define (shared-tail-helper x y)
         (if
            (eq? x y)
            x
            (shared-tail-helper (cdr x) (cdr y))))

      (cond
         ((> len-x len-y)
            (shared-tail-helper
               (list-tail x (- len-x len-y))
               y))
         ((< len-x len-y)
            (shared-tail-helper
               x
               (list-tail y (- len-y len-x))))
         (#t (shared-tail-helper x y)))))

;;;;;Dynamic-wind by Tom Breton (Tehom)

;;Guarded because we must only eval this once, because doing so
;;redefines call/cc in terms of old call/cc
(unless (defined? 'dynamic-wind)
   (let
      ;;These functions are defined in the context of a private list of
      ;;pairs of before/after procs.
      (  (*active-windings* '())
         ;;We'll define some functions into the larger environment, so
         ;;we need to know it.
         (outer-env (current-environment)))

      ;;Poor-man's structure operations
      (define before-func car)
      (define after-func  cdr)
      (define make-winding cons)

      ;;Manage active windings
      (define (activate-winding! new)
         ((before-func new))
         (set! *active-windings* (cons new *active-windings*)))
      (define (deactivate-top-winding!)
         (let ((old-top (car *active-windings*)))
            ;;Remove it from the list first so it's not active during its
            ;;own exit.
            (set! *active-windings* (cdr *active-windings*))
            ((after-func old-top))))

      (define (set-active-windings! new-ws)
         (unless (eq? new-ws *active-windings*)
            (let ((shared (shared-tail new-ws *active-windings*)))

               ;;Define the looping functions.
               ;;Exit the old list.  Do deeper ones last.  Don't do
               ;;any shared ones.
               (define (pop-many)
                  (unless (eq? *active-windings* shared)
                     (deactivate-top-winding!)
                     (pop-many)))
               ;;Enter the new list.  Do deeper ones first so that the
               ;;deeper windings will already be active.  Don't do any
               ;;shared ones.
               (define (push-many new-ws)
                  (unless (eq? new-ws shared)
                     (push-many (cdr new-ws))
                     (activate-winding! (car new-ws))))

               ;;Do it.
               (pop-many)
               (push-many new-ws))))

      ;;The definitions themselves.
      (eval
         `(define call-with-current-continuation
             ;;It internally uses the built-in call/cc, so capture it.
             ,(let ((old-c/cc call-with-current-continuation))
                 (lambda (func)
                    ;;Use old call/cc to get the continuation.
                    (old-c/cc
                       (lambda (continuation)
                          ;;Call func with not the continuation itself
                          ;;but a procedure that adjusts the active
                          ;;windings to what they were when we made
                          ;;this, and only then calls the
                          ;;continuation.
                          (func
                             (let ((current-ws *active-windings*))
                                (lambda (x)
                                   (set-active-windings! current-ws)
                                   (continuation x)))))))))
         outer-env)
      ;;We can't just say "define (dynamic-wind before thunk after)"
      ;;because the lambda it's defined to lives in this environment,
      ;;not in the global environment.
      (eval
         `(define dynamic-wind
             ,(lambda (before thunk after)
                 ;;Make a new winding
                 (activate-winding! (make-winding before after))
                 (let ((result (thunk)))
                    ;;Get rid of the new winding.
                    (deactivate-top-winding!)
                    ;;The return value is that of thunk.
                    result)))
         outer-env)))

(define call/cc call-with-current-continuation)


;;;;; atom? and equal? written by a.k

;;;; atom?
(define (atom? x)
  (not (pair? x)))

;;;;    equal?
(define (equal? x y)
     (cond
          ((pair? x)
               (and (pair? y)
                    (equal? (car x) (car y))
                    (equal? (cdr x) (cdr y))))
          ((vector? x)
               (and (vector? y) (vector-equal? x y)))
          ((string? x)
               (and (string? y) (string=? x y)))
          (else (eqv? x y))))

;;;; (do ((var init inc) ...) (endtest result ...) body ...)
;;
(macro do
  (lambda (do-macro)
    (apply (lambda (do vars endtest . body)
             (let ((do-loop (gensym)))
               `(letrec ((,do-loop
                           (lambda ,(map (lambda (x)
                                           (if (pair? x) (car x) x))
                                      `,vars)
                             (if ,(car endtest)
                               (begin ,@(cdr endtest))
                               (begin
                                 ,@body
                                 (,do-loop
                                   ,@(map (lambda (x)
                                            (cond
                                              ((not (pair? x)) x)
                                              ((< (length x) 3) (car x))
                                              (else (car (cdr (cdr x))))))
                                       `,vars)))))))
                  (,do-loop
                    ,@(map (lambda (x)
                             (if (and (pair? x) (cdr x))
                               (car (cdr x))
                               '()))
                        `,vars)))))
      do-macro)))

;;;; generic-member
(define (generic-member cmp obj lst)
  (cond
    ((null? lst) #f)
    ((cmp obj (car lst)) lst)
    (else (generic-member cmp obj (cdr lst)))))

(define (memq obj lst)
     (generic-member eq? obj lst))
(define (memv obj lst)
     (generic-member eqv? obj lst))
(define (member obj lst)
     (generic-member equal? obj lst))

;;;; generic-assoc
(define (generic-assoc cmp obj alst)
     (cond
          ((null? alst) #f)
          ((cmp obj (caar alst)) (car alst))
          (else (generic-assoc cmp obj (cdr alst)))))

(define (assq obj alst)
     (generic-assoc eq? obj alst))
(define (assv obj alst)
     (generic-assoc eqv? obj alst))
(define (assoc obj alst)
     (generic-assoc equal? obj alst))

(define (acons x y z) (cons (cons x y) z))

;;;; Handy for imperative programs
;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
(macro (define-with-return form)
     `(define ,(cadr form)
          (call/cc (lambda (return) ,@(cddr form)))))

;;;; Simple exception handling
;
;    Exceptions are caught as follows:
;
;         (catch (do-something to-recover and-return meaningful-value)
;              (if-something goes-wrong)
;              (with-these calls))
;
;    "Catch" establishes a scope spanning multiple call-frames
;    until another "catch" is encountered.
;
;    Exceptions are thrown with:
;
;         (throw "message")
;
;    If used outside a (catch ...), reverts to (error "message)

(define *handlers* (list))

(define (push-handler proc)
     (set! *handlers* (cons proc *handlers*)))

(define (pop-handler)
     (let ((h (car *handlers*)))
          (set! *handlers* (cdr *handlers*))
          h))

(define (more-handlers?)
     (pair? *handlers*))

(define (throw . x)
     (if (more-handlers?)
          (apply (pop-handler))
          (apply error x)))

(macro (catch form)
     (let ((label (gensym)))
          `(call/cc (lambda (exit)
               (push-handler (lambda () (exit ,(cadr form))))
               (let ((,label (begin ,@(cddr form))))
                    (pop-handler)
                    ,label)))))

(define *error-hook* throw)


;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL

(macro (make-environment form)
     `(apply (lambda ()
               ,@(cdr form)
               (current-environment))))

(define-macro (eval-polymorphic x . envl)
  (display envl)
  (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
         (xval (eval x env)))
    (if (closure? xval)
      (make-closure (get-closure-code xval) env)
      xval)))

; Redefine this if you install another package infrastructure
; Also redefine 'package'
(define *colon-hook* eval)

;;;;; I/O

(define (input-output-port? p)
     (and (input-port? p) (output-port? p)))

(define (close-port p)
     (cond
          ((input-output-port? p) (close-input-port (close-output-port p)))
          ((input-port? p) (close-input-port p))
          ((output-port? p) (close-output-port p))
          (else (throw "Not a port" p))))

(define (call-with-input-file s p)
     (let ((inport (open-input-file s)))
          (if (eq? inport #f)
               #f
               (let ((res (p inport)))
                    (close-input-port inport)
                    res))))

(define (call-with-output-file s p)
     (let ((outport (open-output-file s)))
          (if (eq? outport #f)
               #f
               (let ((res (p outport)))
                    (close-output-port outport)
                    res))))

(define (with-input-from-file s p)
     (let ((inport (open-input-file s)))
          (if (eq? inport #f)
               #f
               (let ((prev-inport (current-input-port)))
                    (set-input-port inport)
                    (let ((res (p)))
                         (close-input-port inport)
                         (set-input-port prev-inport)
                         res)))))

(define (with-output-to-file s p)
     (let ((outport (open-output-file s)))
          (if (eq? outport #f)
               #f
               (let ((prev-outport (current-output-port)))
                    (set-output-port outport)
                    (let ((res (p)))
                         (close-output-port outport)
                         (set-output-port prev-outport)
                         res)))))

(define (with-input-output-from-to-files si so p)
     (let ((inport (open-input-file si))
           (outport (open-input-file so)))
          (if (not (and inport outport))
               (begin
                    (close-input-port inport)
                    (close-output-port outport)
                    #f)
               (let ((prev-inport (current-input-port))
                     (prev-outport (current-output-port)))
                    (set-input-port inport)
                    (set-output-port outport)
                    (let ((res (p)))
                         (close-input-port inport)
                         (close-output-port outport)
                         (set-input-port prev-inport)
                         (set-output-port prev-outport)
                         res)))))

; Random number generator (maximum cycle)
(define *seed* 1)
(define (random-next)
     (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
          (set! *seed*
               (-   (* a (- *seed*
                         (* (quotient *seed* q) q)))
                    (* (quotient *seed* q) r)))
          (if (< *seed* 0) (set! *seed* (+ *seed* m)))
          *seed*))

;; SRFI-0
;; COND-EXPAND
;; Implemented as a macro
(define *features* '(srfi-0))

(define-macro (cond-expand . cond-action-list)
  (cond-expand-runtime cond-action-list))

(define (cond-expand-runtime cond-action-list)
  (if (null? cond-action-list)
      #t
      (if (cond-eval (caar cond-action-list))
          `(begin ,@(cdar cond-action-list))
          (cond-expand-runtime (cdr cond-action-list)))))

(define (cond-eval-and cond-list)
  (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))

(define (cond-eval-or cond-list)
  (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))

(define (cond-eval condition)
  (cond
    ((symbol? condition)
       (if (member condition *features*) #t #f))
    ((eq? condition #t) #t)
    ((eq? condition #f) #f)
    (else (case (car condition)
            ((and) (cond-eval-and (cdr condition)))
            ((or) (cond-eval-or (cdr condition)))
            ((not) (if (not (null? (cddr condition)))
                     (error "cond-expand : 'not' takes 1 argument")
                     (not (cond-eval (cadr condition)))))
            (else (error "cond-expand : unknown operator" (car condition)))))))

(gc-verbose #f)

(do ((j 0 (+ j 1))) ((> j 100000)) ())

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