Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 4679:2c64d2bbb316

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Test the multiple-value functionality. tests/ChangeLog addition: 2009-08-16 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el (foo): Test the Common Lisp-compatibile multiple value functionality.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 16 Aug 2009 21:00:08 +0100
parents b5e1d4f6b66f
children cdabd56ce1b5
comparison
equal deleted inserted replaced
4678:b5e1d4f6b66f 4679:2c64d2bbb316
1937 (princ (list 'quote (multiple-value-list (truncate first second)))) 1937 (princ (list 'quote (multiple-value-list (truncate first second))))
1938 (princ " :one-ftruncate-result ") 1938 (princ " :one-ftruncate-result ")
1939 (princ (list 'quote (multiple-value-list (ftruncate first)))) 1939 (princ (list 'quote (multiple-value-list (ftruncate first))))
1940 (princ " :two-ftruncate-result ") 1940 (princ " :two-ftruncate-result ")
1941 (princ (list 'quote (multiple-value-list (ftruncate first second)))))) 1941 (princ (list 'quote (multiple-value-list (ftruncate first second))))))
1942
1943 ;; Multiple value tests.
1944
1945 (flet ((foo (x y)
1946 (floor (+ x y) y))
1947 (foo-zero (x y)
1948 (values (floor (+ x y) y)))
1949 (multiple-value-function-returning-t ()
1950 (values t pi e degrees-to-radians radians-to-degrees))
1951 (multiple-value-function-returning-nil ()
1952 (values t pi e radians-to-degrees degrees-to-radians))
1953 (function-throwing-multiple-values ()
1954 (let* ((listing '(0 3 4 nil "string" symbol))
1955 (tail listing)
1956 elt)
1957 (while t
1958 (setq tail (cdr listing)
1959 elt (car listing)
1960 listing tail)
1961 (when (null elt)
1962 (throw 'VoN61Lo4Y (multiple-value-function-returning-t)))))))
1963 (Assert
1964 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5)
1965 "Checking that multiple values are discarded correctly as func args")
1966 (Assert
1967 (= 2 (length (multiple-value-list (foo 400 (1+ most-positive-fixnum)))))
1968 "Checking multiple values are passed through correctly as return values")
1969 (Assert
1970 (= 1 (length (multiple-value-list
1971 (foo-zero 400 (1+ most-positive-fixnum)))))
1972 "Checking multiple values are discarded correctly when forced")
1973 (Check-Error setting-constant (setq multiple-values-limit 20))
1974 (Assert
1975 (equal '(-1 1)
1976 (multiple-value-list (floor -3 4)))
1977 "Checking #'multiple-value-list gives a sane result")
1978 (let ((ey 40000)
1979 (bee "this is a string")
1980 (cee #s(hash-table size 256 data (969 ?\xF9))))
1981 (Assert
1982 (equal
1983 (multiple-value-list (values ey bee cee))
1984 (multiple-value-list (values-list (list ey bee cee))))
1985 "Checking that #'values and #'values-list are correctly related")
1986 (Assert
1987 (equal
1988 (multiple-value-list (values-list (list ey bee cee)))
1989 (multiple-value-list (apply #'values (list ey bee cee))))
1990 "Checking #'values-list and #'apply with #values are correctly related"))
1991 (Assert
1992 (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10)
1993 "Checking #'multiple-value-call gives reasonable results.")
1994 (Assert
1995 (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10)
1996 "Checking #'multiple-value-call correct when first arg multiple.")
1997 (Assert
1998 (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))))
1999 "Checking #'prog1 does not pass back multiple values")
2000 (Assert
2001 (= 2 (length (multiple-value-list
2002 (multiple-value-prog1 (floor pi) "hi there"))))
2003 "Checking #'multiple-value-prog1 passes back multiple values")
2004 (multiple-value-bind (floored remainder this-is-nil)
2005 (floor pi 1.0)
2006 (Assert (= floored 3)
2007 "Checking floored bound correctly")
2008 (Assert (eql remainder (- pi 3.0))
2009 "Checking remainder bound correctly")
2010 (Assert (null this-is-nil)
2011 "Checking trailing arg bound but nil"))
2012 (let ((ey 40000)
2013 (bee "this is a string")
2014 (cee #s(hash-table size 256 data (969 ?\xF9))))
2015 (multiple-value-setq (ey bee cee)
2016 (ffloor e 1.0))
2017 (Assert (eql 2.0 ey) "Checking ey set correctly")
2018 (Assert (eql bee (- e 2.0)) "Checking bee set correctly")
2019 (Assert (null cee) "Checking cee set to nil correctly"))
2020 (Assert
2021 (= 3 (length (multiple-value-list (eval '(values nil t pi)))))
2022 "Checking #'eval passes back multiple values")
2023 (Assert
2024 (= 2 (length (multiple-value-list (apply #'floor '(5 3)))))
2025 "Checking #'apply passes back multiple values")
2026 (Assert
2027 (= 2 (length (multiple-value-list (funcall #'floor 5 3))))
2028 "Checking #'funcall passes back multiple values")
2029 (Assert
2030 (equal '(1 2) (multiple-value-list
2031 (multiple-value-call #'floor (values 5 3))))
2032 "Checking #'multiple-value-call passes back multiple values correctly")
2033 (Assert
2034 (= 1 (length (multiple-value-list
2035 (and (multiple-value-function-returning-nil) t))))
2036 "Checking multiple values from non-trailing forms discarded by #'and")
2037 (Assert
2038 (= 5 (length (multiple-value-list
2039 (and t (multiple-value-function-returning-nil)))))
2040 "Checking multiple values from final forms not discarded by #'and")
2041 (Assert
2042 (= 1 (length (multiple-value-list
2043 (or (multiple-value-function-returning-t) t))))
2044 "Checking multiple values from non-trailing forms discarded by #'and")
2045 (Assert
2046 (= 5 (length (multiple-value-list
2047 (or nil (multiple-value-function-returning-t)))))
2048 "Checking multiple values from final forms not discarded by #'and")
2049 (Assert
2050 (= 1 (length (multiple-value-list
2051 (cond ((multiple-value-function-returning-t))))))
2052 "Checking cond doesn't pass back multiple values in tests.")
2053 (Assert
2054 (equal (list t pi e degrees-to-radians radians-to-degrees)
2055 (multiple-value-list
2056 (cond (t (multiple-value-function-returning-nil)))))
2057 "Checking cond passes back multiple values in clauses.")
2058 (Assert
2059 (= 1 (length (multiple-value-list
2060 (prog1 (multiple-value-function-returning-nil)))))
2061 "Checking prog1 discards multiple values correctly.")
2062 (Assert
2063 (= 5 (length (multiple-value-list
2064 (multiple-value-prog1
2065 (multiple-value-function-returning-nil)))))
2066 "Checking multiple-value-prog1 passes back multiple values correctly.")
2067 (Assert
2068 (equal (list t pi e degrees-to-radians radians-to-degrees)
2069 (multiple-value-list
2070 (catch 'VoN61Lo4Y (function-throwing-multiple-values)))))
2071 (Assert
2072 (equal (list t pi e radians-to-degrees degrees-to-radians)
2073 (multiple-value-list
2074 (loop
2075 for eye in `(a b c d ,e f g ,nil ,pi)
2076 do (when (null eye)
2077 (return (multiple-value-function-returning-t))))))
2078 "Checking #'loop passes back multiple values correctly."))