haskeem-0.7.16: delcont.scm

; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>
; $Id: delcont.scm,v 1.15 2009-08-09 05:38:50 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.

; These are renamed to reset/m etc, all with trailing /m, to denote
; that they're macros, and to not interfere with the native versions
; of at least reset and shift.

(define *delcont-list* '())

(defmacro (reset/m . 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/m (car ex))
				(eqv? 'shift0/m (car ex))
				(eqv? 'control/m (car ex))
				(eqv? 'control0/m (car ex)))
			    (let ((f1 (or (eqv? 'shift/m (car ex))
					  (eqv? 'shift0/m (car ex))))
				  (f2 (or (eqv? 'shift/m (car ex))
					  (eqv? 'control/m (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/m reset/m)
(define prompt/m reset/m)
(define prompt0/m reset/m)

; stupid-catchers

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

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

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

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