test

[Jonathan A Rees <JAR@AI.AI.MIT.EDU>]

I just changed the mailing list so that it uses fully qualified domain
names instead of nicknames.  This is a test to see whether I made any
mistakes.

Just so this message isn't a total bore for those reading it, I thought
I'd include some amusing Scheme code.  It was inspired by the
programming language Icon.

    - Jonathan


(define (fail) (*fail*))

(define *fail*
  (lambda () (error "Please do (INIT) first.")))

(define cwcc call-with-current-continuation)

(define (init)
  (cwcc (lambda (c)
	  (set! *fail* (lambda () (c 'failed)))
	  'initialized)))

(define (either a b)    ;a and b are thunks
  (let ((saved-fail *fail*))
    (cwcc (lambda (c)
	    (set! *fail* (lambda ()
			   (set! *fail* saved-fail)
			   (c (b))))
	    (a)))))

(define (bag-of a)     ;a is a thunk
  (let ((saved-fail *fail*)
	(l '()))
    (cwcc (lambda (c)
	    (set! *fail*
		  (lambda ()
		    (set! *fail* saved-fail)
		    (c l)))
	    (set! l (cons (a) l))
	    (fail)))))

(define (member-of l)  ;generates members of list l
  (if (null? l)
      (fail)
      (either (lambda () (car l))
	      (lambda () (member-of (cdr l))))))

(define (fringe s)    ;generates fringe of s-expression s
  (if (null? s)
      (fail)
      (if (pair? s)
	  (either (lambda () (fringe (car s)))
		  (lambda () (fringe (cdr s))))
	  s)))

(define (f-equal? a b)  ;fails if not equal
  (if (equal? a b)
      a
      (fail)))

(define (dot proc g1 g2)  ;g1, g2 are thunks
  (let ((fail1 nil)
	(fail2 nil)
	(v1 nil))
    (set! fail2 (let ((fail0 *fail*))
		  (lambda ()
		    (set! *fail* fail0)
		    (let ((v2 (g2)))
		      (set! fail2 *fail*)
		      (set! *fail* fail1)
		      (proc v1 v2)))))
    (set! v1 (g1))
    (set! fail1 *fail*)
    (fail2)))

;;; Examples:
;;;
;;; (f-equal? (member-of '(a b c d)))
;;;	      (member-of '(e c f)))
;;;   =>  c
;;;
;;; (bag-of (lambda ()
;;;	      (dot list (lambda () (fringe '((a b) c)))
;;;			(lambda () (fringe '(d (e f)))))))
;;;   =>  ((c f) (b e) (a d))