Initial version

main.rkt

@@ -0,0 +1,83 @@
+#lang racket/base
+
+(require racket/contract)
+
+(provide define/return
+         define/contract/return
+         return
+         (all-from-out racket/contract)
+         )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; define/return
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(struct exn:return exn (value) #:transparent)
+
+(define-syntax raise-return
+  (syntax-rules ()
+    ((_ v)
+     (raise (exn:return "return" (current-continuation-marks) v)))))
+
+(define (return-value r)
+  (exn:return-value r))
+  
+(define-syntax return
+  (syntax-rules ()
+    ((_ val)
+     (raise-return val))))
+
+(define-syntax define/return
+  (syntax-rules ()
+    ((_ def b1 ...)
+     (define def
+       (with-handlers ([exn:return? return-value])
+         b1
+         ...
+         )
+       )
+     )
+    )
+  )
+
+
+(define-syntax def-returner
+  (syntax-rules ()
+    ((_ pred name)
+     (define/contract (name x)
+       (-> any/c pred)
+       (return-value x))
+     )
+    )
+  )
+
+(define-syntax call-returner
+  (syntax-rules ()
+    ((_ x name)
+     (name x))))
+
+(define-syntax define/contract/return
+  (syntax-rules ()
+    ((_ (name . formals) (c ... last-pred) b1 ...)
+     (define/contract (name . formals)
+       (c ... last-pred)
+       
+       (let ((ret (λ (x)
+                    (def-returner last-pred name)
+                    (call-returner x name))))
+         (with-handlers ([exn:return? ret])
+           b1
+           ...)))
+     )
+    ((_ name last-pred value)
+     (define/contract name
+       last-pred
+       (let ((ret (λ (x)
+                    (def-returner last-pred name)
+                    (call-returner x name))))
+         (with-handlers ([exn:return? ret])
+           value)))
+     )
+    )
+  )
+