early-return construct added

main.rkt

@@ -1,13 +1,70 @@
 #lang racket/base
 
-(provide define/return
-         ;return
+(provide early-return
+         define/return
          )
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; define/return
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+
+(define-syntax early-return*
+  (syntax-rules (-> ? ~ do)
+    ((_ () (b1 ...))
+     (let () b1 ...))
+    ((_ ((do d1 ...)) (b1 ...))
+     (let () d1 ...
+       (let () b1 ...)))
+    ((_ ((do d1 ...) c1 ...) (b1 ...))
+     (let () d1 ...
+       (early-return* (c1 ...) (b1 ...))))
+    ((_ ((v expr ? pred? -> retval ~ cleanup)) (b1 ...))
+     (let ((v expr))
+       (cond (pred? cleanup retval)
+             (else (let () b1 ...)))))
+    ((_ ((v expr ? pred? -> retval ~ cleanup) c1 ...) (b1 ...))
+     (let ((v expr))
+       (cond (pred? cleanup retval)
+             (else (early-return* (c1 ...) (b1 ...))))))
+    ((_ ((v expr ? pred? -> retval)) (b1 ...))
+     (let ((v expr))
+       (cond (pred? retval)
+             (else (let () b1 ...)))))
+    ((_ ((v expr ? pred? -> retval) c1 ...) (b1 ...))
+     (let ((v expr))
+       (cond (pred? retval)
+             (else (early-return* (c1 ...) (b1 ...))))))
+    ((_ ((? pred? -> retval)) (b1 ...))
+     (cond (pred? retval)
+           (else (let () b1 ...))))
+    ((_ ((? pred? -> retval) c1 ...) (b1 ...))
+     (cond (pred? retval)
+           (else (early-return* (c1 ...) (b1 ...)))))
+    ((_ ((? pred? -> retval ~ cleanup)) (b1 ...))
+     (cond (pred? cleanup retval)
+           (else (let () b1 ...))))
+    ((_ ((? pred? -> retval ~ cleanup) c1 ...) (b1 ...))
+     (cond (pred? cleanup retval)
+           (else (early-return* (c1 ...) (b1 ...)))))
+    ((_ ((v expr)) (b1 ...))
+     (let ((v expr))
+       b1 ...))
+    ((_ ((v expr) c1 ...) (b1 ...))
+     (let ((v expr))
+       (early-return* (c1 ...) (b1 ...))))
+    )
+  )
+
+(define-syntax early-return
+  (syntax-rules ()
+    ((_ (er1 ...) b1 ...)
+     (early-return* (er1 ...) (b1 ...))
+     )
+    )
+  )
+
+
 (define-syntax define/return
   (syntax-rules ()
     ((_ def return
@@ -21,75 +78,3 @@
     )
   )
 
-#|
-                
-
-(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)))
-     )
-    )
-  )
-|#