scheme48/ps-compiler/prescheme/test/eval3.scm

; Part of Scheme 48 1.9.  See file COPYING for notices and license.

; Authors: Richard Kelsey


(define-local-syntax (define-primitive id nargs)
  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
    `(define (,id . ,args)
       (call-primitively ,id . ,args))))

(define-primitive ashl 2)
(define-primitive ashr 2)
(define-primitive = 2)
(define-primitive bitwise-and 2)

(define (input-type pred coercer)  ;Alonzo wins
  (lambda (f) (f pred coercer)))

(define (input-type-predicate type) (type (lambda (x y) y x)))
(define (input-type-coercion type)  (type (lambda (x y) x y)))

(define (no-coercion x) x)

(define (odd? x)
  (= 1 (bitwise-and x 1)))

(define (extract-odd x)
  (ashr x 1))

(define any->      (input-type (lambda (x) x #t) no-coercion))
(define odd->      (input-type odd?  extract-odd))

(define (test x y)
  (if (and ((input-type-predicate any->) x)
	   ((input-type-predicate odd->) y))
      (let ((a ((input-type-coercion any->) x))
	    (b ((input-type-coercion odd->) y)))
	(+ a b))
      x))