;;=============================================================================
;; This code implements SRFI-2 "AND-LET*: an AND with local bindings,
;; a guarded LET* special form" proposed by Oleg Kiselyov. This
;; implementation is written by Marc Nieper-Wißkirchen, who has put it in
;; the public domain.".
;;
;;    Creation date: 30-Aug-1999 14:43 (eg)
;;
;;=============================================================================


;           Checking of a LAND* special form
;
; LAND* is a generalized AND: it evaluates a sequence of forms one after another
; till the first one that yields #f; the non-#f result of a form can be bound
; to a fresh variable and used in the subsequent forms.
;
; When an ordinary AND is formed of _proper_ boolean expressions:
;   (AND E1 E2 ...)
; expression E2, if it gets to be evaluated, knows that E1 has returned non-#f.
; Moreover, E2 knows exactly what the result of E1 was - #t - so E2 can use
; this knowledge to its advantage. If E1 however is an _extended_
; boolean expression, E2 can no longer tell which particular non-#f
; value E1 has returned. Chances are it took a lot of work to evaluate E1,
; and the produced result (a number, a vector, a string, etc) may be of
; value to E2. Alas, the AND form merely checks that the result is not an #f,
; and throws it away. If E2 needs it, it has to recompute the value again.
; This proposed LAND* special form lets constituent expressions get
; hold of the results of already evaluated expressions, without re-doing
; their work.
;
; Syntax:
;   LAND* (CLAWS) BODY
;
; where CLAWS is a list of expressions or bindings:
;   CLAWS ::= '() | (cons CLAW CLAWS)
; Every element of the CLAWS list, a CLAW, must be one of the following:
;   (VARIABLE EXPRESSION)
; or
;   (EXPRESSION)
; or
;   BOUND-VARIABLE
; These CLAWS are evaluated in the strict left-to-right order. For each
; CLAW, the EXPRESSION part is evaluated first (or BOUND-VARIABLE is looked up).
; If the result is #f, LAND* immediately returns #f, thus disregarding the rest
; of the CLAWS and the BODY. If the EXPRESSION evaluates to not-#f, and
; the CLAW is of the form
;   (VARIABLE EXPRESSION)
; the EXPRESSION's value is bound to a freshly made VARIABLE. The VARIABLE is
; available for _the rest_ of the CLAWS, and the BODY. As usual, all
; VARIABLEs must be unique (like in let*).
;
; Thus LAND* is a sort of cross-breed between LET* and AND.
;
; Denotation semantics:
;
; Eval[ (LAND* (CLAW1 ...) BODY), Env] =
;   EvalClaw[ CLAW1, Env ] andalso
;       Eval[ (LAND* ( ...) BODY), ExtClawEnv[ CLAW1, Env]]
;
; Eval[ (LAND* (CLAW) ), Env] = EvalClaw[ CLAW, Env ]
; Eval[ (LAND* () FORM1 ...), Env] = Eval[ (BEGIN FORM1 ...), Env ]
; Eval[ (LAND* () ), Env] = #t
;
; EvalClaw[ BOUND-VARIABLE, Env ] = Eval[ BOUND-VARIABLE, Env ]
; EvalClaw[ (EXPRESSION), Env ] = Eval[ EXPRESSION, Env ]
; EvalClaw[ (VARIABLE EXPRESSION), Env ] = Eval[ EXPRESSION, Env ]
;
; ExtClawEnv[ BOUND-VARIABLE, Env ] = Env
; ExtClawEnv[ (EXPRESSION), Env ] = EnvAfterEval[ EXPRESSION, Env ]
; ExtClawEnv[ (VARIABLE EXPRESSION), Env ] =
;   ExtendEnv[ EnvAfterEval[ EXPRESSION, Env ],
;          VARIABLE boundto Eval[ EXPRESSION, Env ]]
;
;
; If one has a Scheme interpreter written in Prolog/ML/Haskell, he can
; implement the above semantics right away. Within Scheme, it is trivial to
; code LAND* with R4RS "define-syntax". Alas, Gambit does not have this
; facility. So this implementation uses macros instead.
;
; The following LAND* macro will convert a LAND* expression into a "tree" of
; AND and LET expressions. For example,
; (LAND* ((my-list (compute-list)) ((not (null? my-list))))
;   (do-something my-list))
; is transformed into
; (and (let ((my-list (compute-list)))
;   (and my-list  (not (null? my-list)) (begin (do-something my-list)))))
;
; I must admit the LAND* macro is written in a pathetic anti-functional style.
; To my excuse, the macro's goal is a syntactic transformation of source
; code, that is, performing a re-writing. IMHO, rewriting kind of suggests
; mutating.
;
; Sample applications:
;
; The following piece of code (from my treap package)
;   (let ((new-root (node:dispatch-on-key root key ...)))
;      (if new-root (set! root new-root)))
; could be elegantly re-written as
;   (land* ((new-root (node:dispatch-on-key root key ...)))
;       (set! root new-root))
;
; A very common application of land* is looking up a value
; associated with a given key in an assoc list, returning #f in case of a
; look-up failure:
;
;       ; Standard implementation
; (define (look-up key alist)
;   (let ((found-assoc (assq key alist)))
;   (and found-assoc (cdr found-assoc))))
;
;       ; A more elegant solution
; (define (look-up key alist)
;   (cdr (or (assq key alist) '(#f . #f))))
;
;       ; An implementation which is just as graceful as the latter
;       ; and just as efficient as the former:
; (define (look-up key alist)
;   (land* ((x (assq key alist))) (cdr x)))
;
; Generalized cond:
;
; (or
;   (land* (bindings-cond1) body1)
;   (land* (bindings-cond2) body2)
;   (begin else-clause))
;
; Unlike => (cond's send), LAND* applies beyond cond. LAND* can also be used
; to generalize cond, as => is limited to sending of only a single value;
; LAND* allows as many bindings as necessary (which are performed in sequence)
;
; (or
;  (land* ((c (read-char)) ((not (eof-object? c))))
;   (string-set! some-str i c) (++! i))
;  (begin (do-process-eof)))
;
; Another concept LAND* is reminiscent of is programming with guards:
; a LAND* form can be considered a sequence of _guarded_ expressions.
; In a regular program, forms may produce results, bind them to variables
; and let other forms use these results. LAND* differs in that it checks
; to make sure that every produced result "makes sense" (that is, not an #f).
; The first "failure" triggers the guard and aborts the rest of the
; sequence (which presumably would not make any sense to execute anyway).
;

(define-module srfi/2
  (export and-let*)

  ;; The original version of this code is below. As a lot of other Scheme,
  ;; this version accepts expressions such as
  ;;   (and-let* (#f (a 1)))
  ;;   (and-let* (2  (a 1)))
  ;; which tagged as incorrect in the SRFI. On the other side,
  ;;   (let ((b 10)) (and-let* (b (a 1))))
  ;; is correct.
  ;; It is difficult to impose that the first expression be a symbol with
  ;; syntax-rules. So this code was rewritten with old macros.

  #;(define-syntax and-let*
    (syntax-rules ()
      ((_ ())
       #t)
      ((and-let () form form* ...)
     (begin form form* ...))
      ((_ ((id expr)))
       expr)
      ((_ ((expr)))
       expr)
      ((_ (id))
       id)
      ((_ ((id expr) . claw*) . body)
       (let ((id expr))
         (and id (and-let* claw* . body))))
      ((_ ((expr) . claw*) . body)
       (and expr (and-let* claw* . body)))
      ((_ (id . claw*) . body)
       (and id (and-let* claw* . body)))
      ((_ . _)
       (syntax-error "ill-formed and-let* form"))))

  ;; ----------------------------------------------------------------------
  ;; The following code is a rewrite of the SLIB implementation of SRFi-2.
  ;; Added syntax-error messages.
  ;; (May 2023)
  ;; ----------------------------------------------------------------------
  (define-macro (and-let* claws . body)
    (define (andin claw rest)
      (if (and (pair? rest) (eq? 'and (car rest)))
          `(and ,claw ,@(cdr rest))
          `(and ,claw ,rest)))

    ;; body of and-let*
    (if (list? claws)
        (let Loop ((claws (reverse claws))
                   (res   (cond
                           ((null? body)       '(and))
                           ((null? (cdr body)) (car body))
                           (else               (cons 'begin body)))))
          (cond
           ((null? claws)
            res)
           ((pair? claws)
            (let ((claw (car claws))
                  (rest (cdr claws)))
              (Loop rest
                    (cond
                     ((symbol? claw)
                      (andin claw res))
                     ((and (pair? claw) (null? (cdr claw)))
                      (andin (car claw) res))
                     (else
                      (if (pair? claw)
                          `(let (,claw) ,(andin (car claw) res))
                          (syntax-error 'and-let* "symbol expected (was ~s)"
                                        claw)))))))
           (else (syntax-error 'and-let* "bad form: ~s" claws))))
        (syntax-error 'and-let* "claws is not a list (was ~s)" claws))))



(provide "srfi/2")
