This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/mats/examples.ms

595 lines
18 KiB
Scheme
Raw Normal View History

2022-07-29 15:12:07 +02:00
;;; examples.ms
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;; define *examples-directory* in Makefile
(define-syntax examples-mat
(syntax-rules ()
[(_ name (file ...) expr ...)
(begin
(mat name
(begin
(parameterize ((source-directories (cons *examples-directory* (source-directories))))
(load (format "~a/~a.ss" *examples-directory* file))
...)
#t)
expr ...)
(mat name
(begin
(parameterize ((source-directories (cons *examples-directory* (source-directories))))
(load (format "~a/~a.so" *examples-directory* file))
...
#t))
expr ...))]))
(define load-example
(case-lambda
[(str)
(load (format "~a/~a.ss" *examples-directory* str))
#t]
[(str eval)
(load (format "~a/~a.ss" *examples-directory* str) eval)
#t]))
(define (example-file file) (format "~a/~a" *mats-dir* file))
(define file=?
(lambda (fn1 fn2)
(let ([p1 (open-input-file fn1)] [p2 (open-input-file fn2)])
(let loop ()
(let ([c1 (read-char p1)] [c2 (read-char p2)])
(if (eof-object? c1)
(begin
(close-port p1)
(close-port p2)
(eof-object? c2))
(and (not (eof-object? c2))
(char=? c1 c2)
(loop))))))))
(examples-mat def-edit ("def" "edit")
(begin (def fact (lambda (x) (if (zero? x) 1 (* x (fact ( x 1))))))
(procedure? fact))
(equal? (ls-def) '(fact))
(let ([in (open-input-string "3 3 4 3 2 (ib 1 -) t")]
[out (open-output-string)])
(and (eqv? (parameterize ([current-input-port in]
[current-output-port out])
(ed-def fact))
'fact)
(equal? (get-output-string out)
"(def fact (lambda (...) (...)))
edit> (lambda (x) (if (...) 1 (...)))
edit> (if (zero? x) 1 (* x (...)))
edit> (* x (fact (...)))
edit> (fact (x 1))
edit> (x 1)
edit> (- x 1)
edit> (def fact (lambda (...) (...)))
edit>
")))
(eqv? (fact 30) 265252859812191058636308480000000)
)
(examples-mat fact ("fact")
(eqv? (fact 30) 265252859812191058636308480000000)
)
(examples-mat fatfib ("fatfib")
(eqv? (fatfib 10) 89)
)
(examples-mat fib ("fib")
(begin (printf "***** expect trace of (fib 4):~%")
(eqv? (fib 4) 5))
)
(examples-mat freq ("freq")
;; freq.in and freq.out come from example in TSPL
(begin (delete-file "testfile.freq" #f) #t)
(begin (frequency (example-file "freq.in") "testfile.freq")
(file=? "testfile.freq" (example-file "freq.out")))
)
;-------- freq.in: --------
;Peter Piper picked a peck of pickled peppers;
;A peck of pickled peppers Peter Piper picked.
;If Peter Piper picked a peck of pickled peppers,
;Where's the peck of pickled peppers Peter Piper picked?
;-------- freq.out: --------
;1 A
;1 If
;4 Peter
;4 Piper
;1 Where
;2 a
;4 of
;4 peck
;4 peppers
;4 picked
;4 pickled
;1 s
;1 the
; "interpret" can't handle all Chez core forms
;(mat interpret
; (and (eq? (getprop 'interpret '*type*) 'primitive)
; (begin (remprop 'interpret '*type*) #t))
; (load-example "interpret")
; (load-example "interpret" interpret)
; (load-example "fatfib" interpret)
; (eqv? (fatfib 4) 5)
; (begin (putprop 'interpret '*type* 'primitive) #t)
; )
(examples-mat m4 ("m4")
(begin (m4 "testfile.m4" (example-file "m4test.in"))
(file=? (example-file "m4test.out") "testfile.m4"))
)
(examples-mat macro ("macro")
(begin (macro xxxxxx (lambda (x) `',x)) #t)
(equal? (xxxxxx 3) '(xxxxxx 3))
)
(examples-mat matrix ("matrix")
;; examples from TSPL2:
(equal? (mul 3 4) 12)
(equal? (mul 1/2 '#(#(1 2 3))) '#(#(1/2 1 3/2)))
(equal? (mul -2
'#(#(3 -2 -1)
#(-3 0 -5)
#(7 -1 -1))) '#(#(-6 4 2)
#(6 0 10)
#(-14 2 2)))
(equal? (mul '#(#(1 2 3))
'#(#(2 3)
#(3 4)
#(4 5))) '#(#(20 26)))
(equal? (mul '#(#(2 3 4)
#(3 4 5))
'#(#(1) #(2) #(3))) '#(#(20) #(26)))
(equal? (mul '#(#(1 2 3)
#(4 5 6))
'#(#(1 2 3 4)
#(2 3 4 5)
#(3 4 5 6))) '#(#(14 20 26 32)
#(32 47 62 77)))
)
(examples-mat object ("object")
(begin (define-object (summit x)
([y 3])
([getx (lambda () x)]
[sumxy (lambda () (+ x y))]
[setx (lambda (v) (set! x v))]))
(procedure? summit))
(begin (define a (summit 1)) (procedure? a))
(eq? (send-message a getx) 1)
(eq? (send-message a sumxy) 4)
(begin (send-message a setx 13)
(eq? (send-message a sumxy) 16))
;; examples from TSPL:
(begin (define-object (kons kar kdr)
([get-car (lambda () kar)]
[get-cdr (lambda () kdr)]
[set-car! (lambda (x) (set! kar x))]
[set-cdr! (lambda (x) (set! kdr x))]))
(procedure? kons))
(begin (define p (kons 'a 'b)) (procedure? p))
(eq? (send-message p get-car) 'a)
(eq? (send-message p get-cdr) 'b)
(begin (send-message p set-cdr! 'c)
(eq? (send-message p get-cdr) 'c))
(begin (define-object (kons kar kdr pwd)
([get-car (lambda () kar)]
[get-cdr (lambda () kar)]
[set-car!
(lambda (x p)
(when (string=? p pwd)
(set! kar x)))]
[set-cdr!
(lambda (x p)
(when (string=? p pwd)
(set! kar x)))]))
(procedure? kons))
(begin (define p1 (kons 'a 'b "magnificent")) (procedure? p1))
(begin (send-message p1 set-car! 'c "magnificent")
(eq? (send-message p1 get-car) 'c))
(begin (send-message p1 set-car! 'd "please")
(eq? (send-message p1 get-car) 'c))
(begin (define p2 (kons 'x 'y "please")) (procedure? p2))
(begin (send-message p2 set-car! 'z "please")
(eq? (send-message p2 get-car) 'z))
(begin (define-object (kons kar kdr)
([count 0])
([get-car
(lambda ()
(set! count (+ count 1))
kar)]
[get-cdr
(lambda ()
(set! count (+ count 1))
kdr)]
[accesses
(lambda () count)]))
(procedure? kons))
(begin (define p (kons 'a 'b)) (procedure? p))
(eq? (send-message p get-car) 'a)
(eq? (send-message p get-cdr) 'b)
(eq? (send-message p accesses) '2)
(eq? (send-message p get-cdr) 'b)
(eq? (send-message p accesses) '3)
)
(examples-mat power ("power")
(eqv? (power 1/2 3) 1/8)
)
(examples-mat rabbit ("rabbit")
(begin (printf "***** expect rabbit output:~%")
(rabbit 3)
(dispatch)
#t)
)
(examples-mat rsa ("rsa")
(begin (printf "***** expect rsa output:~%")
(make-user bonzo)
(make-user bobo)
(make-user tiger)
(show-center)
#t)
(equal? (send "hi there" bonzo bobo) "hi there")
(equal? (send "hi there to you" bobo bonzo) "hi there to you")
(not (equal? (decrypt (encrypt "hi there" bonzo bobo) tiger)
"hi there"))
)
(define stream->list
(lambda (s)
(if (procedure? s)
'()
(cons (car s) (stream->list (cdr s))))))
(examples-mat scons ("scons")
(eqv? (stream-ref factlist 3) 6)
(equal? (stream->list factlist) '(1 1 2 6))
(eqv? (stream-ref factlist 10) 3628800)
(equal? (stream->list factlist)
'(1 1 2 6 24 120 720 5040 40320 362880 3628800))
(eqv? (stream-ref fiblist 3) 3)
(equal? (stream->list fiblist) '(1 1 2 3))
(eqv? (stream-ref fiblist 5) 8)
(equal? (stream->list fiblist) '(1 1 2 3 5 8))
)
(examples-mat setof ("setof")
(equal? (set-of x (x in '(a b c))) '(a b c))
(equal? (set-of x (x in '(1 2 3 4)) (even? x)) '(2 4))
(equal? (set-of (cons x y) (x in '(1 2 3)) (y is (* x x)))
'((1 . 1) (2 . 4) (3 . 9)))
(equal? (set-of (cons x y) (x in '(a b)) (y in '(1 2)))
'((a . 1) (a . 2) (b . 1) (b . 2)))
)
(examples-mat unify ("unify")
;; examples from TSPL:
(eq? (unify 'x 'y) 'y)
(equal? (unify '(f x y) '(g x y)) "clash")
(equal? (unify '(f x (h)) '(f (h) y)) '(f (h) (h)))
(equal? (unify '(f (g x) y) '(f y x)) "cycle")
(equal? (unify '(f (g x) y) '(f y (g x))) '(f (g x) (g x)))
)
(examples-mat fft ("fft")
(equal? (dft '(0 0 0 0)) '(0 0 0 0))
(equal? (dft '(2.0 2.0 2.0 2.0)) '(8.0 0.0-0.0i 0.0 0.0+0.0i))
(equal? (dft '(+2.i +2.i +2.i +2.i)) '(+0.0+8.0i 0.0+0.0i 0.0+0.0i 0.0+0.0i))
)
(examples-mat compat ("compat")
(eqv? (define! defined-with-define! (lambda () defined-with-define!))
'defined-with-define!)
(let ((p defined-with-define!))
(set! defined-with-define! 0)
(eqv? (p) 0))
(eqv? (defrec! defined-with-defrec! (lambda () defined-with-defrec!))
'defined-with-defrec!)
(let ((p defined-with-defrec!))
(set! defined-with-defrec! 0)
(eqv? (p) p))
(eqv? (begin0 1 2 3 4) 1)
(equal? (recur f ((ls '(a b c)) (new '()))
(if (null? ls) new (f (cdr ls) (cons (car ls) new))))
'(c b a))
(equal? (tree-copy '()) '())
(equal? (tree-copy 'a) 'a)
(equal? (tree-copy '(a)) '(a))
(equal? (tree-copy '(a (b c) . d)) '(a (b c) . d))
(let* ((p1 '((a . b) c)) (p2 (car p1)) (p3 (cdr p1)))
(let ((c1 (tree-copy p1)))
(not
(or (memq c1 (list p1 p2 p3))
(memq (car c1) (list p1 p2 p3))
(memq (cdr c1) (list p1 p2 p3))))))
(= *most-positive-short-integer*
*most-positive-fixnum*
(most-positive-fixnum))
(= *most-negative-short-integer*
*most-negative-fixnum*
(most-negative-fixnum))
(eof-object? *eof*)
(eq? short-integer? fixnum?)
(eq? big-integer? bignum?)
(eq? ratio? ratnum?)
(eq? float? flonum?)
(eq? bound? top-level-bound?)
(eq? global-value top-level-value)
(eq? set-global-value! set-top-level-value!)
(eq? define-global-value define-top-level-value)
(eq? symbol-value top-level-value)
(eq? set-symbol-value! set-top-level-value!)
(eq? put putprop)
(eq? get getprop)
(eq? copy-list list-copy)
(eq? copy-tree tree-copy)
(eq? copy-string string-copy)
(eq? copy-vector vector-copy)
(eq? intern string->symbol)
(eq? symbol-name symbol->string)
(eq? make-temp-symbol gensym)
(eq? temp-symbol? gensym?)
(eq? string->uninterned-symbol gensym)
(eq? uninterned-symbol? gensym?)
(eq? compile-eval compile)
(eq? closure? procedure?)
(eq? =? =)
(eq? <? <)
(eq? >? >)
(eq? <=? <=)
(eq? >=? >=)
(eq? float exact->inexact)
(eq? rational inexact->exact)
(eq? char-equal? char=?)
(eq? char-less? char<?)
(eq? string-equal? string=?)
(eq? string-less? string<?)
(eq? flush-output flush-output-port)
(eq? clear-output clear-output-port)
(eq? clear-input clear-input-port)
(eq? mapcar map)
(eq? mapc for-each)
(eq? true #t)
(eq? false #f)
(eq? t #t)
(eq? nil '())
(eq? macro-expand expand)
(eq? (cull negative? '()) '())
(let ((x (list -1 2 -3 -3 1 -5 2 6)))
(and
(equal? (cull pair? x) '())
(equal? (cull negative? x) '(-1 -3 -3 -5))
(equal? x '(-1 2 -3 -3 1 -5 2 6))))
(eq? (cull! negative? '()) '())
(let ((x (list -1 2 -3 -3 1 -5 2 6)))
(and
(equal? (cull! pair? x) '())
(equal? (cull! negative? x) '(-1 -3 -3 -5))))
(eq? (mem (lambda (x) #t) '()) #f)
(let ((x '(a b c)))
(and
(equal? (mem (lambda (x) (eq? x 'a)) x) x)
(equal? (mem (lambda (x) (eq? x 'b)) x) (cdr x))
(equal? (mem (lambda (x) (eq? x 'c)) x) (cddr x))
(equal? (mem (lambda (x) (eq? x 'd)) x) #f)))
(let ((x '(1 -2 3)))
(and
(equal? (mem negative? x) (cdr x))
(equal? (mem positive? x) x)
(equal? (mem pair? x) #f)))
(eq? (rem (lambda (x) #t) '()) '())
(let ((x (list 1 -2 3)))
(and
(equal? (rem negative? x) '(1 3))
(equal? x '(1 -2 3))))
(let ((x (list 1 -2 3)))
(and
(equal? (rem positive? x) '(-2))
(equal? x '(1 -2 3))))
(eq? (rem! (lambda (x) #t) '()) '())
(let ((x (list 1 -2 3))) (equal? (rem! negative? x) '(1 3)))
(let ((x (list 1 -2 3))) (equal? (rem! positive? x) '(-2)))
(eq? (ass (lambda (x) #t) '()) #f)
(let ((a (list -1)) (b (list 2)) (c (list 3)))
(let ((l (list a b c)))
(and
(equal? (ass negative? l) a)
(equal? (ass positive? l) b)
(equal? (ass (lambda (x) (= x 3)) l) c)
(equal? (ass pair? l) #f))))
(equal? (decode-float 0.0) '#(0 0 1))
(let ((x (decode-float (inexact 2/3))))
(define ~=
(let ([*fuzz* .0001])
(lambda (x y)
(and (flonum? x)
(flonum? y)
(<= (abs (- x y)) *fuzz*)))))
(~= (inexact (* (vector-ref x 2)
(vector-ref x 0)
(expt 2 (vector-ref x 1))))
(inexact 2/3)))
(let ((x (box 3)))
(and (equal? (swap-box! x 4) 3) (equal? (unbox x) 4)))
(begin (define-macro! fudge (a (b . c) d) `(quote (,a ,b ,c ,d)))
(equal? (fudge + (- . *) /) '(+ - * /)))
; tests from MichaelL@frogware.com, testing the changes he suggested
(let ()
(define-macro test-1 (val)
`',val)
(equal? 'x (test-1 x)))
(let ()
(define-macro (test-1 val)
`',val)
(equal? 'x (test-1 x)))
(let ()
(define-macro test-2 (val)
`'(,val))
(equal? '(x) (test-2 x)))
(let ()
(define-macro (test-2 val)
`'(,val))
(equal? '(x) (test-2 x)))
(let ([xyz '(x y z)])
(define-macro test-3 (val)
`(,@val))
(equal? '(x y z) (test-3 xyz)))
(let ([xyz '(x y z)])
(define-macro (test-3 val)
`(,@val))
(equal? '(x y z) (test-3 xyz)))
(let ()
(define-macro test-4 (val)
(let ([test-function (lambda (x)
(string->symbol
(string-append
(symbol->string x)
"!!!")))])
`'(,(test-function val))))
(equal? '(xyz!!!) (test-4 xyz)))
(let ()
(define-macro (test-4 val)
(let ([test-function (lambda (x)
(string->symbol
(string-append
(symbol->string x)
"!!!")))])
`'(,(test-function val))))
(equal? '(xyz!!!) (test-4 xyz)))
(let ()
(define-macro test-5 (this . that)
`'(,this ,that))
(equal? '(x (y z)) (test-5 x y z)))
(let ()
(define-macro (test-5 this . that)
`'(,this ,that))
(equal? '(x (y z)) (test-5 x y z)))
(let ()
(define-macro test-6 (this . that)
`'(,this ,@that))
(equal? '(x y z) (test-6 x y z)))
(let ()
(define-macro (test-6 this . that)
`'(,this ,@that))
(equal? '(x y z) (test-6 x y z)))
(let ()
(defmacro test-1 (val)
`',val)
(equal? 'x (test-1 x)))
(let ()
(defmacro (test-1 val)
`',val)
(equal? 'x (test-1 x)))
(let ()
(defmacro test-2 (val)
`'(,val))
(equal? '(x) (test-2 x)))
(let ()
(defmacro (test-2 val)
`'(,val))
(equal? '(x) (test-2 x)))
(let ([xyz '(x y z)])
(defmacro test-3 (val)
`(,@val))
(equal? '(x y z) (test-3 xyz)))
(let ([xyz '(x y z)])
(defmacro (test-3 val)
`(,@val))
(equal? '(x y z) (test-3 xyz)))
(let ()
(defmacro test-4 (val)
(let ([test-function (lambda (x)
(string->symbol
(string-append
(symbol->string x)
"!!!")))])
`'(,(test-function val))))
(equal? '(xyz!!!) (test-4 xyz)))
(let ()
(defmacro (test-4 val)
(let ([test-function (lambda (x)
(string->symbol
(string-append
(symbol->string x)
"!!!")))])
`'(,(test-function val))))
(equal? '(xyz!!!) (test-4 xyz)))
(let ()
(defmacro test-5 (this . that)
`'(,this ,that))
(equal? '(x (y z)) (test-5 x y z)))
(let ()
(defmacro (test-5 this . that)
`'(,this ,that))
(equal? '(x (y z)) (test-5 x y z)))
(let ()
(defmacro test-6 (this . that)
`'(,this ,@that))
(equal? '(x y z) (test-6 x y z)))
(let ()
(defmacro (test-6 this . that)
`'(,this ,@that))
(equal? '(x y z) (test-6 x y z)))
(begin (define-struct! caramel x y z) (eqv? (caramel-x (caramel 1 2 3)) 1))
)
(examples-mat ez-grammar-test ("ez-grammar-test")
(equal?
(with-output-to-string ez-grammar-test)
"8 tests ran\n")
)