chez-openbsd/mats/examples.ms

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