-
+ 816C72CA3FE3ED9F9A2C1C1E779ADCA1279EDABAF547E70D5BBEBD00300C2062D7C2BA51A3ED200472639640577FB3643D780E204546ACA62807978BA3F54449tinyscheme/init.scm(0 . 0)(1 . 716)
1475 ; Initialization file for TinySCHEME 1.41
1476
1477 ; Per R5RS, up to four deep compositions should be defined
1478 (define (caar x) (car (car x)))
1479 (define (cadr x) (car (cdr x)))
1480 (define (cdar x) (cdr (car x)))
1481 (define (cddr x) (cdr (cdr x)))
1482 (define (caaar x) (car (car (car x))))
1483 (define (caadr x) (car (car (cdr x))))
1484 (define (cadar x) (car (cdr (car x))))
1485 (define (caddr x) (car (cdr (cdr x))))
1486 (define (cdaar x) (cdr (car (car x))))
1487 (define (cdadr x) (cdr (car (cdr x))))
1488 (define (cddar x) (cdr (cdr (car x))))
1489 (define (cdddr x) (cdr (cdr (cdr x))))
1490 (define (caaaar x) (car (car (car (car x)))))
1491 (define (caaadr x) (car (car (car (cdr x)))))
1492 (define (caadar x) (car (car (cdr (car x)))))
1493 (define (caaddr x) (car (car (cdr (cdr x)))))
1494 (define (cadaar x) (car (cdr (car (car x)))))
1495 (define (cadadr x) (car (cdr (car (cdr x)))))
1496 (define (caddar x) (car (cdr (cdr (car x)))))
1497 (define (cadddr x) (car (cdr (cdr (cdr x)))))
1498 (define (cdaaar x) (cdr (car (car (car x)))))
1499 (define (cdaadr x) (cdr (car (car (cdr x)))))
1500 (define (cdadar x) (cdr (car (cdr (car x)))))
1501 (define (cdaddr x) (cdr (car (cdr (cdr x)))))
1502 (define (cddaar x) (cdr (cdr (car (car x)))))
1503 (define (cddadr x) (cdr (cdr (car (cdr x)))))
1504 (define (cdddar x) (cdr (cdr (cdr (car x)))))
1505 (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
1506
1507 ;;;; Utility to ease macro creation
1508 (define (macro-expand form)
1509 ((eval (get-closure-code (eval (car form)))) form))
1510
1511 (define (macro-expand-all form)
1512 (if (macro? form)
1513 (macro-expand-all (macro-expand form))
1514 form))
1515
1516 (define *compile-hook* macro-expand-all)
1517
1518
1519 (macro (unless form)
1520 `(if (not ,(cadr form)) (begin ,@(cddr form))))
1521
1522 (macro (when form)
1523 `(if ,(cadr form) (begin ,@(cddr form))))
1524
1525 ; DEFINE-MACRO Contributed by Andy Gaynor
1526 (macro (define-macro dform)
1527 (if (symbol? (cadr dform))
1528 `(macro ,@(cdr dform))
1529 (let ((form (gensym)))
1530 `(macro (,(caadr dform) ,form)
1531 (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
1532
1533 ; Utilities for math. Notice that inexact->exact is primitive,
1534 ; but exact->inexact is not.
1535 (define exact? integer?)
1536 (define (inexact? x) (and (real? x) (not (integer? x))))
1537 (define (even? n) (= (remainder n 2) 0))
1538 (define (odd? n) (not (= (remainder n 2) 0)))
1539 (define (zero? n) (= n 0))
1540 (define (positive? n) (> n 0))
1541 (define (negative? n) (< n 0))
1542 (define complex? number?)
1543 (define rational? real?)
1544 (define (abs n) (if (>= n 0) n (- n)))
1545 (define (exact->inexact n) (* n 1.0))
1546 (define (<> n1 n2) (not (= n1 n2)))
1547
1548 ; min and max must return inexact if any arg is inexact; use (+ n 0.0)
1549 (define (max . lst)
1550 (foldr (lambda (a b)
1551 (if (> a b)
1552 (if (exact? b) a (+ a 0.0))
1553 (if (exact? a) b (+ b 0.0))))
1554 (car lst) (cdr lst)))
1555 (define (min . lst)
1556 (foldr (lambda (a b)
1557 (if (< a b)
1558 (if (exact? b) a (+ a 0.0))
1559 (if (exact? a) b (+ b 0.0))))
1560 (car lst) (cdr lst)))
1561
1562 (define (succ x) (+ x 1))
1563 (define (pred x) (- x 1))
1564 (define gcd
1565 (lambda a
1566 (if (null? a)
1567 0
1568 (let ((aa (abs (car a)))
1569 (bb (abs (cadr a))))
1570 (if (= bb 0)
1571 aa
1572 (gcd bb (remainder aa bb)))))))
1573 (define lcm
1574 (lambda a
1575 (if (null? a)
1576 1
1577 (let ((aa (abs (car a)))
1578 (bb (abs (cadr a))))
1579 (if (or (= aa 0) (= bb 0))
1580 0
1581 (abs (* (quotient aa (gcd aa bb)) bb)))))))
1582
1583
1584 (define (string . charlist)
1585 (list->string charlist))
1586
1587 (define (list->string charlist)
1588 (let* ((len (length charlist))
1589 (newstr (make-string len))
1590 (fill-string!
1591 (lambda (str i len charlist)
1592 (if (= i len)
1593 str
1594 (begin (string-set! str i (car charlist))
1595 (fill-string! str (+ i 1) len (cdr charlist)))))))
1596 (fill-string! newstr 0 len charlist)))
1597
1598 (define (string-fill! s e)
1599 (let ((n (string-length s)))
1600 (let loop ((i 0))
1601 (if (= i n)
1602 s
1603 (begin (string-set! s i e) (loop (succ i)))))))
1604
1605 (define (string->list s)
1606 (let loop ((n (pred (string-length s))) (l '()))
1607 (if (= n -1)
1608 l
1609 (loop (pred n) (cons (string-ref s n) l)))))
1610
1611 (define (string-copy str)
1612 (string-append str))
1613
1614 (define (string->anyatom str pred)
1615 (let* ((a (string->atom str)))
1616 (if (pred a) a
1617 (error "string->xxx: not a xxx" a))))
1618
1619 (define (string->number str . base)
1620 (let ((n (string->atom str (if (null? base) 10 (car base)))))
1621 (if (number? n) n #f)))
1622
1623 (define (anyatom->string n pred)
1624 (if (pred n)
1625 (atom->string n)
1626 (error "xxx->string: not a xxx" n)))
1627
1628 (define (number->string n . base)
1629 (atom->string n (if (null? base) 10 (car base))))
1630
1631
1632 (define (char-cmp? cmp a b)
1633 (cmp (char->integer a) (char->integer b)))
1634 (define (char-ci-cmp? cmp a b)
1635 (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
1636
1637 (define (char=? a b) (char-cmp? = a b))
1638 (define (char<? a b) (char-cmp? < a b))
1639 (define (char>? a b) (char-cmp? > a b))
1640 (define (char<=? a b) (char-cmp? <= a b))
1641 (define (char>=? a b) (char-cmp? >= a b))
1642
1643 (define (char-ci=? a b) (char-ci-cmp? = a b))
1644 (define (char-ci<? a b) (char-ci-cmp? < a b))
1645 (define (char-ci>? a b) (char-ci-cmp? > a b))
1646 (define (char-ci<=? a b) (char-ci-cmp? <= a b))
1647 (define (char-ci>=? a b) (char-ci-cmp? >= a b))
1648
1649 ; Note the trick of returning (cmp x y)
1650 (define (string-cmp? chcmp cmp a b)
1651 (let ((na (string-length a)) (nb (string-length b)))
1652 (let loop ((i 0))
1653 (cond
1654 ((= i na)
1655 (if (= i nb) (cmp 0 0) (cmp 0 1)))
1656 ((= i nb)
1657 (cmp 1 0))
1658 ((chcmp = (string-ref a i) (string-ref b i))
1659 (loop (succ i)))
1660 (else
1661 (chcmp cmp (string-ref a i) (string-ref b i)))))))
1662
1663
1664 (define (string=? a b) (string-cmp? char-cmp? = a b))
1665 (define (string<? a b) (string-cmp? char-cmp? < a b))
1666 (define (string>? a b) (string-cmp? char-cmp? > a b))
1667 (define (string<=? a b) (string-cmp? char-cmp? <= a b))
1668 (define (string>=? a b) (string-cmp? char-cmp? >= a b))
1669
1670 (define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
1671 (define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
1672 (define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
1673 (define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
1674 (define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
1675
1676 (define (list . x) x)
1677
1678 (define (foldr f x lst)
1679 (if (null? lst)
1680 x
1681 (foldr f (f x (car lst)) (cdr lst))))
1682
1683 (define (unzip1-with-cdr . lists)
1684 (unzip1-with-cdr-iterative lists '() '()))
1685
1686 (define (unzip1-with-cdr-iterative lists cars cdrs)
1687 (if (null? lists)
1688 (cons cars cdrs)
1689 (let ((car1 (caar lists))
1690 (cdr1 (cdar lists)))
1691 (unzip1-with-cdr-iterative
1692 (cdr lists)
1693 (append cars (list car1))
1694 (append cdrs (list cdr1))))))
1695
1696 (define (map proc . lists)
1697 (if (null? lists)
1698 (apply proc)
1699 (if (null? (car lists))
1700 '()
1701 (let* ((unz (apply unzip1-with-cdr lists))
1702 (cars (car unz))
1703 (cdrs (cdr unz)))
1704 (cons (apply proc cars) (apply map (cons proc cdrs)))))))
1705
1706 (define (for-each proc . lists)
1707 (if (null? lists)
1708 (apply proc)
1709 (if (null? (car lists))
1710 #t
1711 (let* ((unz (apply unzip1-with-cdr lists))
1712 (cars (car unz))
1713 (cdrs (cdr unz)))
1714 (apply proc cars) (apply map (cons proc cdrs))))))
1715
1716 (define (list-tail x k)
1717 (if (zero? k)
1718 x
1719 (list-tail (cdr x) (- k 1))))
1720
1721 (define (list-ref x k)
1722 (car (list-tail x k)))
1723
1724 (define (last-pair x)
1725 (if (pair? (cdr x))
1726 (last-pair (cdr x))
1727 x))
1728
1729 (define (head stream) (car stream))
1730
1731 (define (tail stream) (force (cdr stream)))
1732
1733 (define (vector-equal? x y)
1734 (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
1735 (let ((n (vector-length x)))
1736 (let loop ((i 0))
1737 (if (= i n)
1738 #t
1739 (and (equal? (vector-ref x i) (vector-ref y i))
1740 (loop (succ i))))))))
1741
1742 (define (list->vector x)
1743 (apply vector x))
1744
1745 (define (vector-fill! v e)
1746 (let ((n (vector-length v)))
1747 (let loop ((i 0))
1748 (if (= i n)
1749 v
1750 (begin (vector-set! v i e) (loop (succ i)))))))
1751
1752 (define (vector->list v)
1753 (let loop ((n (pred (vector-length v))) (l '()))
1754 (if (= n -1)
1755 l
1756 (loop (pred n) (cons (vector-ref v n) l)))))
1757
1758 ;; The following quasiquote macro is due to Eric S. Tiedemann.
1759 ;; Copyright 1988 by Eric S. Tiedemann; all rights reserved.
1760 ;;
1761 ;; Subsequently modified to handle vectors: D. Souflis
1762
1763 (macro
1764 quasiquote
1765 (lambda (l)
1766 (define (mcons f l r)
1767 (if (and (pair? r)
1768 (eq? (car r) 'quote)
1769 (eq? (car (cdr r)) (cdr f))
1770 (pair? l)
1771 (eq? (car l) 'quote)
1772 (eq? (car (cdr l)) (car f)))
1773 (if (or (procedure? f) (number? f) (string? f))
1774 f
1775 (list 'quote f))
1776 (if (eqv? l vector)
1777 (apply l (eval r))
1778 (list 'cons l r)
1779 )))
1780 (define (mappend f l r)
1781 (if (or (null? (cdr f))
1782 (and (pair? r)
1783 (eq? (car r) 'quote)
1784 (eq? (car (cdr r)) '())))
1785 l
1786 (list 'append l r)))
1787 (define (foo level form)
1788 (cond ((not (pair? form))
1789 (if (or (procedure? form) (number? form) (string? form))
1790 form
1791 (list 'quote form))
1792 )
1793 ((eq? 'quasiquote (car form))
1794 (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
1795 (#t (if (zero? level)
1796 (cond ((eq? (car form) 'unquote) (car (cdr form)))
1797 ((eq? (car form) 'unquote-splicing)
1798 (error "Unquote-splicing wasn't in a list:"
1799 form))
1800 ((and (pair? (car form))
1801 (eq? (car (car form)) 'unquote-splicing))
1802 (mappend form (car (cdr (car form)))
1803 (foo level (cdr form))))
1804 (#t (mcons form (foo level (car form))
1805 (foo level (cdr form)))))
1806 (cond ((eq? (car form) 'unquote)
1807 (mcons form ''unquote (foo (- level 1)
1808 (cdr form))))
1809 ((eq? (car form) 'unquote-splicing)
1810 (mcons form ''unquote-splicing
1811 (foo (- level 1) (cdr form))))
1812 (#t (mcons form (foo level (car form))
1813 (foo level (cdr form)))))))))
1814 (foo 0 (car (cdr l)))))
1815
1816 ;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom)
1817 (define (shared-tail x y)
1818 (let ((len-x (length x))
1819 (len-y (length y)))
1820 (define (shared-tail-helper x y)
1821 (if
1822 (eq? x y)
1823 x
1824 (shared-tail-helper (cdr x) (cdr y))))
1825
1826 (cond
1827 ((> len-x len-y)
1828 (shared-tail-helper
1829 (list-tail x (- len-x len-y))
1830 y))
1831 ((< len-x len-y)
1832 (shared-tail-helper
1833 x
1834 (list-tail y (- len-y len-x))))
1835 (#t (shared-tail-helper x y)))))
1836
1837 ;;;;;Dynamic-wind by Tom Breton (Tehom)
1838
1839 ;;Guarded because we must only eval this once, because doing so
1840 ;;redefines call/cc in terms of old call/cc
1841 (unless (defined? 'dynamic-wind)
1842 (let
1843 ;;These functions are defined in the context of a private list of
1844 ;;pairs of before/after procs.
1845 ( (*active-windings* '())
1846 ;;We'll define some functions into the larger environment, so
1847 ;;we need to know it.
1848 (outer-env (current-environment)))
1849
1850 ;;Poor-man's structure operations
1851 (define before-func car)
1852 (define after-func cdr)
1853 (define make-winding cons)
1854
1855 ;;Manage active windings
1856 (define (activate-winding! new)
1857 ((before-func new))
1858 (set! *active-windings* (cons new *active-windings*)))
1859 (define (deactivate-top-winding!)
1860 (let ((old-top (car *active-windings*)))
1861 ;;Remove it from the list first so it's not active during its
1862 ;;own exit.
1863 (set! *active-windings* (cdr *active-windings*))
1864 ((after-func old-top))))
1865
1866 (define (set-active-windings! new-ws)
1867 (unless (eq? new-ws *active-windings*)
1868 (let ((shared (shared-tail new-ws *active-windings*)))
1869
1870 ;;Define the looping functions.
1871 ;;Exit the old list. Do deeper ones last. Don't do
1872 ;;any shared ones.
1873 (define (pop-many)
1874 (unless (eq? *active-windings* shared)
1875 (deactivate-top-winding!)
1876 (pop-many)))
1877 ;;Enter the new list. Do deeper ones first so that the
1878 ;;deeper windings will already be active. Don't do any
1879 ;;shared ones.
1880 (define (push-many new-ws)
1881 (unless (eq? new-ws shared)
1882 (push-many (cdr new-ws))
1883 (activate-winding! (car new-ws))))
1884
1885 ;;Do it.
1886 (pop-many)
1887 (push-many new-ws))))
1888
1889 ;;The definitions themselves.
1890 (eval
1891 `(define call-with-current-continuation
1892 ;;It internally uses the built-in call/cc, so capture it.
1893 ,(let ((old-c/cc call-with-current-continuation))
1894 (lambda (func)
1895 ;;Use old call/cc to get the continuation.
1896 (old-c/cc
1897 (lambda (continuation)
1898 ;;Call func with not the continuation itself
1899 ;;but a procedure that adjusts the active
1900 ;;windings to what they were when we made
1901 ;;this, and only then calls the
1902 ;;continuation.
1903 (func
1904 (let ((current-ws *active-windings*))
1905 (lambda (x)
1906 (set-active-windings! current-ws)
1907 (continuation x)))))))))
1908 outer-env)
1909 ;;We can't just say "define (dynamic-wind before thunk after)"
1910 ;;because the lambda it's defined to lives in this environment,
1911 ;;not in the global environment.
1912 (eval
1913 `(define dynamic-wind
1914 ,(lambda (before thunk after)
1915 ;;Make a new winding
1916 (activate-winding! (make-winding before after))
1917 (let ((result (thunk)))
1918 ;;Get rid of the new winding.
1919 (deactivate-top-winding!)
1920 ;;The return value is that of thunk.
1921 result)))
1922 outer-env)))
1923
1924 (define call/cc call-with-current-continuation)
1925
1926
1927 ;;;;; atom? and equal? written by a.k
1928
1929 ;;;; atom?
1930 (define (atom? x)
1931 (not (pair? x)))
1932
1933 ;;;; equal?
1934 (define (equal? x y)
1935 (cond
1936 ((pair? x)
1937 (and (pair? y)
1938 (equal? (car x) (car y))
1939 (equal? (cdr x) (cdr y))))
1940 ((vector? x)
1941 (and (vector? y) (vector-equal? x y)))
1942 ((string? x)
1943 (and (string? y) (string=? x y)))
1944 (else (eqv? x y))))
1945
1946 ;;;; (do ((var init inc) ...) (endtest result ...) body ...)
1947 ;;
1948 (macro do
1949 (lambda (do-macro)
1950 (apply (lambda (do vars endtest . body)
1951 (let ((do-loop (gensym)))
1952 `(letrec ((,do-loop
1953 (lambda ,(map (lambda (x)
1954 (if (pair? x) (car x) x))
1955 `,vars)
1956 (if ,(car endtest)
1957 (begin ,@(cdr endtest))
1958 (begin
1959 ,@body
1960 (,do-loop
1961 ,@(map (lambda (x)
1962 (cond
1963 ((not (pair? x)) x)
1964 ((< (length x) 3) (car x))
1965 (else (car (cdr (cdr x))))))
1966 `,vars)))))))
1967 (,do-loop
1968 ,@(map (lambda (x)
1969 (if (and (pair? x) (cdr x))
1970 (car (cdr x))
1971 '()))
1972 `,vars)))))
1973 do-macro)))
1974
1975 ;;;; generic-member
1976 (define (generic-member cmp obj lst)
1977 (cond
1978 ((null? lst) #f)
1979 ((cmp obj (car lst)) lst)
1980 (else (generic-member cmp obj (cdr lst)))))
1981
1982 (define (memq obj lst)
1983 (generic-member eq? obj lst))
1984 (define (memv obj lst)
1985 (generic-member eqv? obj lst))
1986 (define (member obj lst)
1987 (generic-member equal? obj lst))
1988
1989 ;;;; generic-assoc
1990 (define (generic-assoc cmp obj alst)
1991 (cond
1992 ((null? alst) #f)
1993 ((cmp obj (caar alst)) (car alst))
1994 (else (generic-assoc cmp obj (cdr alst)))))
1995
1996 (define (assq obj alst)
1997 (generic-assoc eq? obj alst))
1998 (define (assv obj alst)
1999 (generic-assoc eqv? obj alst))
2000 (define (assoc obj alst)
2001 (generic-assoc equal? obj alst))
2002
2003 (define (acons x y z) (cons (cons x y) z))
2004
2005 ;;;; Handy for imperative programs
2006 ;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
2007 (macro (define-with-return form)
2008 `(define ,(cadr form)
2009 (call/cc (lambda (return) ,@(cddr form)))))
2010
2011 ;;;; Simple exception handling
2012 ;
2013 ; Exceptions are caught as follows:
2014 ;
2015 ; (catch (do-something to-recover and-return meaningful-value)
2016 ; (if-something goes-wrong)
2017 ; (with-these calls))
2018 ;
2019 ; "Catch" establishes a scope spanning multiple call-frames
2020 ; until another "catch" is encountered.
2021 ;
2022 ; Exceptions are thrown with:
2023 ;
2024 ; (throw "message")
2025 ;
2026 ; If used outside a (catch ...), reverts to (error "message)
2027
2028 (define *handlers* (list))
2029
2030 (define (push-handler proc)
2031 (set! *handlers* (cons proc *handlers*)))
2032
2033 (define (pop-handler)
2034 (let ((h (car *handlers*)))
2035 (set! *handlers* (cdr *handlers*))
2036 h))
2037
2038 (define (more-handlers?)
2039 (pair? *handlers*))
2040
2041 (define (throw . x)
2042 (if (more-handlers?)
2043 (apply (pop-handler))
2044 (apply error x)))
2045
2046 (macro (catch form)
2047 (let ((label (gensym)))
2048 `(call/cc (lambda (exit)
2049 (push-handler (lambda () (exit ,(cadr form))))
2050 (let ((,label (begin ,@(cddr form))))
2051 (pop-handler)
2052 ,label)))))
2053
2054 (define *error-hook* throw)
2055
2056
2057 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
2058
2059 (macro (make-environment form)
2060 `(apply (lambda ()
2061 ,@(cdr form)
2062 (current-environment))))
2063
2064 (define-macro (eval-polymorphic x . envl)
2065 (display envl)
2066 (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
2067 (xval (eval x env)))
2068 (if (closure? xval)
2069 (make-closure (get-closure-code xval) env)
2070 xval)))
2071
2072 ; Redefine this if you install another package infrastructure
2073 ; Also redefine 'package'
2074 (define *colon-hook* eval)
2075
2076 ;;;;; I/O
2077
2078 (define (input-output-port? p)
2079 (and (input-port? p) (output-port? p)))
2080
2081 (define (close-port p)
2082 (cond
2083 ((input-output-port? p) (close-input-port (close-output-port p)))
2084 ((input-port? p) (close-input-port p))
2085 ((output-port? p) (close-output-port p))
2086 (else (throw "Not a port" p))))
2087
2088 (define (call-with-input-file s p)
2089 (let ((inport (open-input-file s)))
2090 (if (eq? inport #f)
2091 #f
2092 (let ((res (p inport)))
2093 (close-input-port inport)
2094 res))))
2095
2096 (define (call-with-output-file s p)
2097 (let ((outport (open-output-file s)))
2098 (if (eq? outport #f)
2099 #f
2100 (let ((res (p outport)))
2101 (close-output-port outport)
2102 res))))
2103
2104 (define (with-input-from-file s p)
2105 (let ((inport (open-input-file s)))
2106 (if (eq? inport #f)
2107 #f
2108 (let ((prev-inport (current-input-port)))
2109 (set-input-port inport)
2110 (let ((res (p)))
2111 (close-input-port inport)
2112 (set-input-port prev-inport)
2113 res)))))
2114
2115 (define (with-output-to-file s p)
2116 (let ((outport (open-output-file s)))
2117 (if (eq? outport #f)
2118 #f
2119 (let ((prev-outport (current-output-port)))
2120 (set-output-port outport)
2121 (let ((res (p)))
2122 (close-output-port outport)
2123 (set-output-port prev-outport)
2124 res)))))
2125
2126 (define (with-input-output-from-to-files si so p)
2127 (let ((inport (open-input-file si))
2128 (outport (open-input-file so)))
2129 (if (not (and inport outport))
2130 (begin
2131 (close-input-port inport)
2132 (close-output-port outport)
2133 #f)
2134 (let ((prev-inport (current-input-port))
2135 (prev-outport (current-output-port)))
2136 (set-input-port inport)
2137 (set-output-port outport)
2138 (let ((res (p)))
2139 (close-input-port inport)
2140 (close-output-port outport)
2141 (set-input-port prev-inport)
2142 (set-output-port prev-outport)
2143 res)))))
2144
2145 ; Random number generator (maximum cycle)
2146 (define *seed* 1)
2147 (define (random-next)
2148 (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
2149 (set! *seed*
2150 (- (* a (- *seed*
2151 (* (quotient *seed* q) q)))
2152 (* (quotient *seed* q) r)))
2153 (if (< *seed* 0) (set! *seed* (+ *seed* m)))
2154 *seed*))
2155 ;; SRFI-0
2156 ;; COND-EXPAND
2157 ;; Implemented as a macro
2158 (define *features* '(srfi-0))
2159
2160 (define-macro (cond-expand . cond-action-list)
2161 (cond-expand-runtime cond-action-list))
2162
2163 (define (cond-expand-runtime cond-action-list)
2164 (if (null? cond-action-list)
2165 #t
2166 (if (cond-eval (caar cond-action-list))
2167 `(begin ,@(cdar cond-action-list))
2168 (cond-expand-runtime (cdr cond-action-list)))))
2169
2170 (define (cond-eval-and cond-list)
2171 (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
2172
2173 (define (cond-eval-or cond-list)
2174 (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
2175
2176 (define (cond-eval condition)
2177 (cond
2178 ((symbol? condition)
2179 (if (member condition *features*) #t #f))
2180 ((eq? condition #t) #t)
2181 ((eq? condition #f) #f)
2182 (else (case (car condition)
2183 ((and) (cond-eval-and (cdr condition)))
2184 ((or) (cond-eval-or (cdr condition)))
2185 ((not) (if (not (null? (cddr condition)))
2186 (error "cond-expand : 'not' takes 1 argument")
2187 (not (cond-eval (cadr condition)))))
2188 (else (error "cond-expand : unknown operator" (car condition)))))))
2189
2190 (gc-verbose #f)