;; Chaining block macro, which lets us use a series of applications (usually
;; macro applications) that take a body as their final argument, without all
;; that indentation.

(define-syntax block
  (syntax-rules ()
    ((block) (void))
    ((block X) X)
    ((block (X ...) REST ...)
     (X ... (block REST ...)))))

(define-syntax abortable-block
  (syntax-rules ()
    ((abortable-block ABORT BODY ...)
     (call-with-current-continuation
      (lambda (ABORT)
        (block BODY ...))))))

;; Single-binding destructuring let

(import matchable)

(define-syntax /let
  (syntax-rules ()
    ((/let X Y BODY)
     (match-let ((X Y))
       BODY))))

;; Single-binding function let

(define-syntax /flet
  (syntax-rules ()
    ((/flet (FUNC . ARGS) FBODY BODY)
     (letrec ((FUNC (lambda ARGS FBODY)))
       BODY))))

;; /finally, to do something in both normal and exceptional exits

(define-syntax /finally
  (syntax-rules ()
    ((/finally ACTIONS ... BODY)
     (let* ((thunk (lambda () ACTIONS ...))
            (return-value
             (handle-exceptions
              exn
              (begin
                (thunk)
                (abort exn))
              BODY)))
       (thunk)
       return-value))))

;; /assert, an assert that chains so it's nice in blocks

(define-syntax /assert
  (syntax-rules ()
    ((/assert EXP OBJ ... BODY)
     (begin
       (assert EXP OBJ ...)
       BODY))))

;; ->, which captures the rest of the block and binds it to a name, as a thunk,
;; within its body

(define-syntax ->
  (syntax-rules ()
    ((-> CONTINUE BODY CONTINUE-BODY)
     (let ((CONTINUE (lambda () CONTINUE-BODY)))
       BODY))))

;; Test / demo suite

(import test)

;; Test the basics

(define b 1)

(test 4
      (block
       (/let a 1)
       ;; Put side-effecting operations in a begin
       (begin (set! b 2))
       ;; Check nested scoping works right by shadowing the global b
       (/let b 3)
       ;; Final return value
       (+ a b)))

;; Check the mutation of b worked
(test 2 b)

;; Test abortable blocks

(test 1
      (abortable-block
       return
       (begin (return 1))
       2))

;; Test that /let destructures

(test 3
      (block
       (/let (a b) '(1 2))
       (+ a b)))

;; Test /flet
(test 123
      (block
       (/flet (sum a b) (+ a b))
       (sum 120 3)))

;; Test that /flet can recurse
(test #t
      (block
       (/flet (odd? x)
              (cond
               ((zero? x) #f)
               ((eq? 1 x) #t)
               (else (odd? (- x 2)))))
       (odd? 5)))

;; You can use conventional let forms and the block saves you some indentation

(test 3
      (block
       (let* ((a 1)
              (b (+ a 1))))
       (+ a b)))

;; Use if for early abort

(test 2
      (block
       (if #f 1)
       (if #t 2)
       (if #f 3)
       4))

;; handle-exceptions fits nicely, too

(test 2
      (block
       (handle-exceptions
        exn
        2)
       (error "Something bad")))

;; Test /finally

(define finally-test 0)

(test "test"
      (block
       (/finally
        (set! finally-test (+ finally-test 1)))
       ;; Success case
       "test"))

;; Check it has been called exactly once
(test 1 finally-test)

(set! finally-test 0)

(test-error "test"
      (block
       (/finally
        (set! finally-test (+ finally-test 1)))
       ;; Error
       (error "Expected error")))

;; Check it has been called exactly once
(test 1 finally-test)

;; Test ->

(test 2
      (block
       (-> ok (if #t (ok) 1))
       2))

(test 1
      (block
       (-> ok (if #f (ok) 1))
       2))

;; Test /assert

(test-error
 (block
  (/assert #f)
  123))

(test-error
 (block
  (/assert #f 'location "Oh dear" 1 2 3)
  123))

Generated by Alaric Snell-Pym using scpaste at Fri Mar 12 13:54:45 2021. GMT. (original)