haskeem-0.7.9: delcont.scm

; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>
; $Id: delcont.scm,v 1.14 2009-08-02 03:18:24 uwe Exp $
; BSD3

; Delimited continuations: these look simpler than call/cc, just a fairly
; simple code transformation. This code implements that code transformation,
; however it's not quite full-strength: in real code, the (shift) could be
; hidden inside a function, and in that case this version would not work. But
; for reset/shift that's all visible in one s-expr, I think this does pretty
; much the right thing.

; From CC Shan, "Shift to Control"

; M[(reset V)] -> M[V]

; M[(reset C [(shift f E)])] -> M[(reset E')]
; where E' = E{f -> (lambda (x) (reset C[x]))}

; M[(reset C [(control f E)])] -> M[(reset E')]
; where E' = E{f -> (lambda (x) C[x])}

; M[(reset C [(shift0 f E)])] -> M[E']
; where E' = E{f -> (lambda (x) (reset C[x]))}

; M[(reset C [(control0 f E)])] -> M[E']
; where E' = E{f -> (lambda (x) C[x])}

; TODO: the multiple-expressions handling in reset and int-s/c is
; seriously hacky: reset just wraps its args in a '(begin ...) if
; there are multiple args... gotta be a better way to do that?
; Still, this works and allows testing.

(define *delcont-list* '())

(defmacro (reset . expr)
  (letrec* ((id (gensym))
	    (ret (gensym))
	    (err (gensym))
	    (flag #f)
	    (elist (cond ((null? expr) '())
			 ((null? (cdr expr)) (car expr))
			 (else (cons 'begin expr))))
	    (r-aux (lambda (ex)
		     (cond ((not (list? ex)) ex)
			   ((null? ex) ex)
			   ((or (eqv? 'shift (car ex))
				(eqv? 'shift0 (car ex))
				(eqv? 'control (car ex))
				(eqv? 'control0 (car ex)))
			    (let ((f1 (or (eqv? 'shift (car ex))
					  (eqv? 'shift0 (car ex))))
				  (f2 (or (eqv? 'shift (car ex))
					  (eqv? 'control (car ex)))))
			      (set! flag #t)
			      (if (and (> (length ex) 2)
				       (symbol? (cadr ex)))
				  (append (list 'int-s/c id (gensym) f1 f2)
					  (r-aux (cdr ex)))
				  (raise
				   "malformed shift/control expression!" ex))))
			   ((eqv? 'int-s/c (car ex))
			    (set! flag #t)
			    (append (list 'int-s/c id) (cddr ex)))
			   (else (map r-aux ex)))))
	    (ex (r-aux elist)))
    (if flag
	(begin
	  (set! *delcont-list* (cons ex *delcont-list*))
	  `(let ((,ret (guard
			(,err ((and (pair? ,err) (eqv? ',id (car ,err)))
			       (cadr ,err)))
			,ex)))
	     (set! *delcont-list* (cdr *delcont-list*))
	     ,ret))
	elist)))

(defmacro (int-s/c mark id f1 f2 name . expr)
  (letrec* ((var (gensym))
	    (s-aux (lambda (ex)
		     (cond ((not (list? ex)) ex)
			   ((null? ex) ex)
			   ((eqv? 'int-s/c (car ex))
			    (if (eqv? id (caddr ex))
				var
				ex))
			   (else (map s-aux ex)))))
	    (subst-expr (lambda (ex)
			  (let ((body (s-aux ex)))
			    (if f1
				`(lambda (,var) (reset ,body))
				`(lambda (,var) ,body)))))
	    (lam-ex (subst-expr (car *delcont-list*))))
    (if f2
	`(raise ',mark (let ((,name ,lam-ex)) (reset ,@expr)))
	`(raise ',mark (let ((,name ,lam-ex)) ,@expr)))))

; aliases -- in this macro-based approach, they should be just sugar

(define reset0 reset)
(define prompt reset)
(define prompt0 reset)

; stupid-catchers

(defmacro (shift sym expr)
  (raise "oops, naked delcont form" 'shift sym expr))

(defmacro (shift0 sym expr)
  (raise "oops, naked delcont form" 'shift0 sym expr))

(defmacro (control sym expr)
  (raise "oops, naked delcont form" 'control sym expr))

(defmacro (control0 sym expr)
  (raise "oops, naked delcont form" 'control0 sym expr))