microscheme/init.scm

;    Initialization file for TinySCHEME 1.41

(gc-verbose #t)

;;;; 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 exact-integer? integer?)
(define (inexact? x) (and (real? x) (not (integer? x))))
(define (exact->inexact n) (* n 1.0))
(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 (<> n1 n2) (not (= n1 n2)))
(define (square n) (* n n))
;; missing: numerator denominator rationalize exact-integer-sqrt

; min and max must return inexact if any arg is inexact
(define (max . lst)
  (foldr (lambda (a b)
           (if (> a b)
             (if (exact? b) a (exact->inexact a))
             (if (exact? a) b (exact->inexact b))))
         (car lst) (cdr lst)))
(define (min . lst)
  (foldr (lambda (a b)
           (if (< a b)
             (if (exact? b) a (exact->inexact a))
             (if (exact? a) b (exact->inexact b))))
         (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)))))

;TODO string-upcase
;TODO string-downcase
;TODO string-foldcase
;TODO string-copy!
;TODO string-fill!

(define substring string-copy)

(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))

(define (digit-value ch)
  (if (and (char<=? #\0 ch) (char<=? ch #\9))
    (- (char->integer ch) (char->integer #\0))
    #f))

(define char-foldcase char-downcase)

; 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 (make-list k . fill) (vector->list (vector k (car fill))))

(define (list-copy l) (vector->list (list->vector l)))

(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))

;TODO vector-fill! v e start end
(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)))))

;TODO vector->string vector start end

(define (string->vector . args)
  (list->vector (string->list (apply string-copy args))))

;TODO vector-copy v s e
;TODO vector-copy! to at v s e

(define (vector-append hd . tl)
  (if (null? tl)
    hd
    (list->vector (append (hd (vector->list (vector-append tl)))))))

;; 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)

(define (symbol=? hd . tl)
  (if (null? tl)
    #t
    (and (symbol? hd) (eq? hd (car tl)) (symbol=? (cdr tl)))))

(define (boolean=? hd . tl)
  (if (null? tl)
    #t
    (and (boolean? hd) (eq? hd (car tl)) (boolean=? (cdr tl)))))

;;;;; 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)))

; catch handler thunk
(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)

; same as above, r7rs
(define (with-exception-handler handler thunk)
  (catch (handler) (thunk)))

(define (raise-continuable x)
     (if (more-handlers?)
          ((pop-handler) x)
          (error x)))

(define (raise x)
  (raise-continuable x)
  (error "raise: exception handler returned"))

;(with-exception-handler
;  (lambda () (display (list "xerror")))
;  (lambda () (begin (display ("aaa") (raise 5)))))

;TODO: a lot more is missing, and it doesn't work

;;;;; 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*))


(define-macro (aif a b c)
  `(let ((it ,a))
     (if it ,b ,c)))

;; 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)))))))

; done late so that "when" is functional
(define exact  ) (when (defined? 'inexact->exact) (set! exact   inexact->exact))
(define inexact) (when (defined? 'exact->inexact) (set! inexact exact->inexact))

(macro (defmacro dform)
  (let ((name (cadr dform)) (formals (caddr dform)) (body (cdddr dform)))
    `(define-macro (,name . ,formals) ,@body)))

;; r7rs
; sring-map, vector-map, string-for-each, vector-for-each
; bytevectors

;; srfi-1

(define (check-arg pred val caller)
  (let lp ((val val))
    (if (pred val) val (lp (error "Bad argument" val pred caller)))))

; Some macros and functions that the SRFI 1 reference implementation
; requires that it does not define and are not part of R5RS.

(define-macro let-optionals
  (lambda (input names . code)
    (let ((input-left (gensym)))
      `(let ((,input-left ,input))
         ,(let next ((names names))
            (if (null? names)
                `(begin ,@code)
                `(let ((,input-left (if (null? ,input-left)
                                        '()
                                        (cdr ,input-left)))
                       (,(caar names) (if (null? ,input-left)
                                          ,(cadar names)
                                          (car ,input-left))))
                   ,(next (cdr names)))))))))

(define-macro receive
  (lambda (names values . code)
    `(call-with-values (lambda () ,values)
                       (lambda ,names ,@code))))


(define (:optional data default)
  (if (null? data)
      default
      (car data)))

(load "srfi-1.scm")

;; macros-by-example

(define append!
      (lambda args
        (cond ((null? args) '())
              ((null? (cdr args)) (car args))
              ((null? (car args)) (apply append! (cdr args)))
              (else
               (set-cdr! (last-pair (car args))
                         (apply append! (cdr args)))
               (car args)))))

(define (some pred lst . rest)
  (cond ((null? rest)
         (let mapf ((lst lst))
           (and (not (null? lst))
                (or (pred (car lst)) (mapf (cdr lst))))))
        (else (let mapf ((lst lst) (rest rest))
                (and (not (null? lst))
                     (or (apply pred (car lst) (map car rest))
                         (mapf (cdr lst) (map cdr rest))))))))

(define (every pred lst . rest)
  (cond ((null? rest)
         (let mapf ((lst lst))
           (or (null? lst)
               (and (pred (car lst)) (mapf (cdr lst))))))
        (else (let mapf ((lst lst) (rest rest))
                (or (null? lst)
                    (and (apply pred (car lst) (map car rest))
                         (mapf (cdr lst) (map cdr rest))))))))

;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (nreverse rev-it)
;;; Reverse order of elements of LIST by mutating cdrs.
  (cond ((null? rev-it) rev-it)
        ((not (list? rev-it))
         (error "nreverse: Not a list in arg1" rev-it))
        (else (do ((reved '() rev-it)
                   (rev-cdr (cdr rev-it) (cdr rev-cdr))
                   (rev-it rev-it rev-cdr))
                  ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it)))))

(load "mbe.scm")

(load "srfi-55.scm")

(register-extension '(srfi  1) (lambda () ()))                   ; list library, always loaded
(register-extension '(srfi  6) (lambda () ()))                   ; basic string ports (not verified)
(register-extension '(srfi  8) (lambda () ()))                   ; receive always available
;(register-extension '(srfi  9) (lambda () (load "srfi-9.scmx")))
(register-extension '(srfi 11) (lambda () (load "srfi-11.scm"))) ; let-values
(register-extension '(srfi 13) (lambda () (load "srfi-13.scm"))) ; string library
(register-extension '(srfi 16) (lambda () (load "srfi-16.scm"))) ; casd-lambda
(register-extension '(srfi 23) (lambda () ()))                   ; error builtin
;(register-extension '(srfi 34) (lambda () (load "srfi-34.scmx"))) ; exception handling, subset of r7rs?
(register-extension '(srfi 42) (lambda () (load "srfi-42.scm"))) ; eager list comprehensions
(register-extension '(srfi 55) (lambda () ()))                   ; extension mechanism, always available
(register-extension '(srfi 61) (lambda () (load "srfi-61.scm"))) ; more general cond (=>)
; look at: 0, 4, 19, 14, 8, 18, 2, 95, 97, 106
; r7rs start: 39 40 41 46 62! 87! (replacing 61?)
; supersede: 0
; rule out:; 4, 7, 35, 36, 38, 47, 66, 69, 71, 74, 86, 88, 89, 90, 94, 99

;; end of init

;(load "test.scm")

(load "test.scm")

(gc-verbose #t)

Revision:	1.30
Committed:	Mon Dec 7 18:10:57 2015 UTC (8 years, 6 months ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.29:	+5 -0 lines
Log Message:	* empty log message *