goof-loop/goof-impl.scm

;; goof-impl.scm - portable parts of goof loop..
;;
;; Copyright 2020 Linus Björnstam
;; Copyright 2000-2015 Alex Shinn (original author of chibi-loop)
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. The name of the author(s) may not be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


(define-aux-syntaxes
  ;; Auxiliary syntax for the loop clauses
  :when :unless :break :final :let :let* :subloop :for :acc
  ;; Auxiliary syntax for the iterators.
  :gen
  ;; auxiliary auxiliary syntax
  ;; for vectoring
  :length :fill 
  ;; Internal syntax. %acc is turned into :acc by the forify macro
  ;; it is used make it possible to report an error if :acc is used in
  ;; one of the simple macros.
  %acc
  )


(include "goof/iterators.scm")


(define-syntax loop
  (syntax-rules ()
    ((loop . rest)
     (%loop (loop . rest) . rest))))

(define-syntax %loop
  (syntax-rules (=>)
    ((%loop o () => expr body ...)
     (%loop o ((:for ensure-once (up-from 0 1))) => expr body ...))
    ((%loop o () body ...)
     (%loop o ((:for ensure-once (up-from 0 1))) body ...))
    ((%loop o name () => expr body ...)
     (%loop o name ((:for ensure-once (up-from 0 1))) => expr body ...))
    ((%loop o  name () body ...)
     (%loop o name ((:for ensure-once (up-from 0 1))) body ...))
    ((%loop o (clauses ...)  body ...)
     (ensure-for-clause o
                        loop-name (clauses ...)
                        body ... (loop-name)))
    ((%loop o name (clauses ...) . body)
     (ensure-for-clause o
                        name
                        (clauses ...)
                        . body))))

;; Should this check for more?
(define-syntax ensure-for-clause
  (syntax-rules (:for :acc :break :subloop :when :unless :final :let :let*)
    ((_ orig name ((:for for-rest ...) clauses ...) . body)
     (cl orig name
         (()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
         ((:for for-rest ...) clauses ...) . body))
    ((_ orig rest ...)
     (syntax-error "First clause must be a :for clause" orig))))
     

(define-syntax push-new-subloop
  (syntax-rules ()
    ((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (((ff-cur ...) (ff-above ...)) . ff-rest)
        (ul ...) (uw ...) (ub ...) uf clauses . body)
     (cl orig name
         (() lets ...)
         (() accs ...)
         (() vars ...)
         (() checks ...)
         (() refs ...)
         f
         ;; propagate :for-finalizers to subloop to be run in case of :break
         ((() (ff-cur ... ff-above ...)) ((ff-cur ...) (ff-above ...)) .  ff-rest)
         (() ul ...)
         (() uw ...)
         (() ub ...)
         uf
         clauses . body))))


;; Clauses sorts all the clauses into subloops and positions everything where it should be.
(define-syntax cl
  (syntax-rules (=> :for :acc :when :unless :break :final :let :let* :subloop)
    ((_ orig name l a v c r f ff ul uw ub uf () => expr . body)
     (emit orig name l a v c r f ff ul uw ub uf expr . body))
    ((_ orig name l a v c r f ff ul uw ub uf () . body)
     (emit orig name l a v c r f ff ul uw ub uf (if #f #f) . body))

    ;; USER LETS
    ((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) uw ub uf (:let (id id* ... expr) clauses ...) . body)
     (cl orig name l a v c r f ff ((cur-ul ... (:let id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
    ((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) uw ub uf (:let* (id id* ... expr) clauses ...) . body)
     (cl orig name l a v c r f ff ((cur-ul ... (:let* id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
    ;; user-whens
    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:when test clauses ...) . body)
     (cl orig name l a v c r f ff ul ((cur-uw ... test) . uw-rest) ub uf (clauses ...) . body))
    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:unless test clauses ...) . body)
     (cl orig name l a v c r f ff ul ((cur-uw ... (not test)) . uw-rest) ub uf (clauses ...) . body))
    ;; USER BREAKS
    ;; This pushes a #t to the user when expression, thus forcing a subloop if a for-clause is found afterwards.
    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ((cur-ub ...) . ub-rest) uf (:break expr clauses ...) . body)
     (cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) uf (clauses ...) . body))
    ;; user final
    ;; This pushes a #t to the user when expression, thus forcing a subloop if a for-clause is found afterwards.
    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub (cur-uf ...) (:final expr clauses ...) . body)
     (cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub (cur-uf ... expr) (clauses ...) . body))
    
    ;; Explicit subloop. Shorthand for (:when #t)
    ((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:subloop clauses ...) . body)
     (cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub uf  (clauses ...) . body))
    ;; :for-clauses
    ;; found a for clause when we have a :when or :unless clause. Push new subloop
    ((_ orig name l a v c r f ff ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body)
     (push-new-subloop orig name l a v c r f ff ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body))

    ;; For clause with a sequence creator.
    ((_ orig name l a v c r f ff ul uw ub uf ((:for id ids ... (iterator source ...)) clauses ...) . body)
     (valid-clause? iterator ((id ids ...) (source ...)) cl-next/for orig name l a v c r f ff ul uw ub uf (clauses ...) . body))

    ;; accumulator clause
    ((_ orig name l a v c r f ff ul uw ub uf ((:acc id ids ... (accumulator source ...)) clauses ...) . body)
     (valid-clause? accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff ul uw ub uf (clauses ...) . body))

    ;; ERROR HANDLING?
    ((_ orig name l a v c r f ff ul uw ub uf (clause . rest) . body)
     (syntax-error "Invalid clause in loop" clause orig))

    ))


;; HOLY CODE-DUPLICATION-BATMAN!
;; cl-next/acc integrates all the bindings by an :acc clause. The complexity comes from pushing :acc-clauses
;; into the outer loops. Since accumulators need to be available in the (final-fun ...), they need to be visible also
;; in the outer loops if the loop exits there.
(define-syntax cl-next/acc
  (syntax-rules (:acc)
    ;; :acc clause without any subloops
    ((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-checks ...) (new-refs ...) (new-finals ...)
        orig name
        ((lets ...))
        ((accs ...))
        vars
        ((checks ...))
        ((refs ...))
        (finals ...)
        ff ul uw ub uf clauses . body)
      (cl orig name
          ((lets ... new-lets ...))
          ((accs ... (accvar accinit accupdate) ...))
          vars
          ((checks ... new-checks ...))
          ((refs ... new-refs ...))
          (finals ... new-finals ...)
          ff ul uw ub uf clauses . body))
    ;; We have ONE subloop!
    ((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-checks ...) (new-refs ...) (new-finals ...)
        orig name
        (lets ... (outermost-lets ...))
        ((accs ...) ((oldacc oldinit oldupdate) ...))
        vars
        ((checks ...) . checks-rest)
        ((refs ...) . refs-rest)
        (finals ...)
        ff ul uw ub uf clauses . body)
      (cl orig name
          (lets ... (outermost-lets ... new-lets ...))
          ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...))
          vars
          ((checks ... new-checks ...) . checks-rest)
          ((refs ... new-refs ...) . refs-rest)
          (finals ... new-finals ...)
          ff ul uw ub uf clauses . body))
    ;; We have several subloops!
    ((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-checks ...) (new-refs ...) (new-finals ...)
        orig name
        (lets ... (outermost-lets ...))
        ((accs ...) ((oldacc oldinit oldupdate) ...) ... ((oldestacc oldestinit oldestupdate) ...))
        vars
        ((checks ...) . checks-rest)
        ((refs ...) . refs-rest)
        (finals ...)
        ff ul uw ub uf clauses . body)
     (cl orig name
          (lets ... (outermost-lets ... new-lets ...))
          ((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accvar accvar) ...) ...
           ((oldestacc oldestinit oldestupdate) ... (accvar accinit accvar) ...))
          vars
          ((checks ... new-checks ...) . checks-rest)
          ((refs ... new-refs ...) . refs-rest)
          (finals ... new-finals ...)
          ff ul uw ub uf clauses . body))))

;; Integrating for clauses is not as involved, since they only want to be introduced into the current
;; loop. Any propagation of for finalizers (ff) is done by push-new-subloop
(define-syntax cl-next/for
  (syntax-rules ()
    ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-for-finals ...)
        orig name
        ((lets ...) . lets-rest)
        accs
        ((vars ...) . vars-rest)
        ((checks ...) . checks-rest)
        ((refs ...) . refs-rest)
        finals
        (((ff-cur ...) (ff-above ...)) . ff-rest)
        ul uw ub uf clauses . body)
     (cl orig name
         ((lets ... new-lets ...) . lets-rest)
         accs
         ((vars ... new-vars ...) . vars-rest)
         ((checks ... new-checks ...) . checks-rest)
         ((refs ... new-refs ...) . refs-rest)
         finals
         (((ff-cur ... new-for-finals ...) (ff-above ...)) . ff-rest)
         ul uw ub uf clauses . body))
    ((cl err ...)
     '(cl err ...))))

(define-syntax user-let
  (syntax-rules (:let :let*)
    ((_ () () () body ...)
     (begin body ...))
    ((_ (lets ...) () () . body)
     (let (lets ...)
       . body))
    ((_ () (stars ...) () . body)
     (let* (stars ...) . body))

    ;; These twe clauses handle let type changes.
    ((_ () (stars ... last) ((:let id id* ... expr) clauses ...) . body)
     (let* (stars ...)
       (user-let (last (id id* ... expr)) () (clauses ...) . body)))
    ((_ (lets ...) () ((:let* id id* ... expr) clauses ...) . body)
     (let (lets ...)
       (user-let () ((id id* ... expr)) (clauses ...) . body)))

    ;; 2 clauses new of the same that already existed
    ((_ (lets ...) () ((:let id id* ... expr) clauses ...) . body)
     (user-let (lets ... (id id* ... expr)) () (clauses ...) . body))
    ((_ () (stars ...) ((:let* id id* ... expr) clauses ...) . body)
     (user-let () (stars ... (id id* ... expr)) (clauses ...) . body))))

;; If there is no subloops, we emit to the simple case
(define-syntax emit
  (syntax-rules ()
    ((_ orig name (one) . rest)
     (emit-one orig name (one) . rest))
    ((_ orig name . rest)
     (emit-many/first #f name . rest))))
    
(define-syntax emit-one
  (syntax-rules ()
    ((_ orig name
        ((lets ...))
        (((accvar accinit accstep) ...))
        (((var init step) ...))
        ((checks ...))
        ((refs ...))
        ((final-binding final-value) ...)
        (((ff-cur ...) (ff-above ...)))
        ((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) uf
        final-expr . body)
     (let* (lets ...)
       (define (final-fun final-binding ...)
         final-expr)
       (define (loopy-loop accvar ... var ...)
         (if (or checks ...)
             (begin
               ff-cur ...
               (final-fun final-value ...))
             (ref-let (refs ...)
               (user-let () () (user-lets ...)
                 (if (and user-whens ...)
                     (let-kw-form name
                                  (final-fun final-value ...)
                                  uf
                                  (loopy-loop (accvar accstep) ... (var step) ...)
                       (cond
                        ((or user-breaks ...)
                         ff-above ... ff-cur ...
                         (final-fun final-value ...))
                        (else
                         (let () (if #f #f) . body))))
                     (loopy-loop accvar ... step ...) )))))
       (loopy-loop accinit ... init ...)))))

;; Emit-many/first emits the outermost let loop and binds the final lambda.
(define-syntax emit-many/first
  (syntax-rules ()
    ((_ orig name
        (lets-next ... (lets ...))
        (accs-next ... ((accvar accinit accstep) ...))
        (vars-next ... ((var init step) ...))
        (checks-next ... (checks ...))
        (refs-next ... (refs ...))
        ((final-binding final-value) ...)
        (ff-next ... ((ff-cur ...) ()))
        (ul-next ... (user-lets ...))
        (uw-next ... (user-whens ...))
        (ub-next ... (user-breaks ...))
        uf
        final-expr
        . body)
     (let* ((final-fun (lambda (final-binding ...) final-expr))
            lets ...)
       (let outer-loop ((accvar accinit) ...
                        (var init) ...)
         (if (or checks ...)
             (begin
               ff-cur ...
               (final-fun final-value ...))
             (ref-let (refs ...)
               (user-let () () (user-lets ...)
                 (if (and user-whens ...)
                     (cond
                      ((or user-breaks ...)
                       ff-cur ...
                       (final-fun final-value ...))
                      (else (emit-many/rest orig
                                             name
                                             (outer-loop accstep ... step ...)
                                             (lets-next ...)
                                             (accs-next ...)
                                             (vars-next ...)
                                             (checks-next ...)
                                             (refs-next ...)
                                             ;; THIS IS NOW A COMPLETE call to final
                                             (final-fun final-value ...)
                                             (ff-next ...)
                                             (ul-next ...)
                                             (uw-next ...)
                                             (ub-next ...)
                                             uf
                                             . body)))
                     (outer-loop accvar ... step ...))))))))))

(define-syntax emit-many/rest
  (syntax-rules ()
    ;; match innermost loop
    ((_ orig
        name
        outer
        ((lets ...))
        (((accvar accinit accstep) ...))
        (((var init step) ...))
        ((checks ...))
        ((refs ...))
        final
        (((ff-cur ...) (ff-above ...)))
        ((user-lets ...))
        ((user-whens ...))
        ((user-breaks ...))
        uf
        . body)
     (let* (lets ...)
       (let innermost-loop ((accvar accinit) ...
                            (var init) ...)
         (if (or checks ...)
             (begin
               ff-cur ...
               outer)
             (ref-let (refs ...)
               (user-let () () (user-lets ...)
                 (if (and user-whens ...)         
                     (cond
                      ((or user-breaks ...)
                       ff-above ... ff-cur ...
                       final)
                      (else
                       (let-kw-form name final uf (innermost-loop (accvar accstep) ... (var step) ...)
                         . body)))
                     (innermost-loop accvar ... step ...))))))))

    ;; Any intermediate loops
    ((_ orig
        name
        outer
        (next-lets ... (lets ...))
        (next-accs ... ((accvar accinit accstep) ...))
        (next-vars ... ((var init step) ...))
        (next-checks ... (checks ...))
        (next-refs ... (refs ...))
        final
        (next-ff ... ((ff-cur ...) (ff-above ...)))
        (ul-next ... (user-lets ...))
        (uw-next ... (user-whens ...))
        (ub-next ... (user-breaks ...))
        uf
        . body)
     (let* (lets ...)
       (let intermediate-loop ((accvar accinit) ...
                               (var init) ...)
         (if (or checks ...)
             (begin
               ff-cur ...
               outer)
             (ref-let (refs ...)
               (user-let () () (user-lets ...)
                 (if (and user-whens ...)
                     (cond
                      ((or user-breaks ...)
                       ff-above ... ff-cur ...
                       final)
                      (else (emit-many/rest orig
                                            name
                                            (intermediate-loop accstep ... step ...)
                                            (next-lets ...)
                                            (next-accs ...)
                                            (next-vars ...)
                                            (next-checks ...)
                                            (next-refs ...)
                                            final
                                            (next-ff ...)
                                            (ul-next ...)
                                            (uw-next ...)
                                            (ub-next ...)
                                            uf
                                            . body)))
                     (intermediate-loop accvar ... step ...))))))))))

(define-syntax forify
  (syntax-rules (%acc)
    ((_ orig name () ((%acc . acc-rest) . argsrest) . body)
     (forify* orig name () ((:for ensure-once (up-from 0 1)) (%acc . acc-rest) . argsrest) . body))
    ((_ . rest)
     (forify* . rest))))

(define-syntax forify*
  (syntax-rules (:for :acc :when :unless :break :final :subloop :let :let* %acc)
    ((_ o n done-clauses () . body)
     (%loop o n done-clauses . body))
    ((_      o n (s ...) ((:for c-rest ...) clauses ...) . body)
     (forify* o n (s ... (:for c-rest ...)) (clauses ...) . body))
    ((_      o n (s ...) (:when expr clauses ...) . body)
     (forify* o n (s ... :when expr) (clauses ...) . body))
    ((_      o n (s ...) (:unless expr clauses ...) . body)
     (forify* o n (s ... :when expr) (clauses ...) . body))
    ((_      o n (s ...) (:break expr clauses ...) . body)
     (forify* o n (s ... :break expr) (clauses ...) . body))
    ((_      o n (s ...) (:final expr clauses ...) . body)
     (forify* o n (s ... :final expr) (clauses ...) . body))
    ((_      o n (s ...) (:subloop clauses ...) . body)
     (forify* o n (s ... :subloop) (clauses ...) . body))
    ((_      o n (s ...) (:let (id id* ... expr) clauses ...) . body)
     (forify* o n (s ... :let (id id* ... expr)) (clauses ...) . body))
    ((_      o n (s ...) (:let* (id id* ... expr) clauses ...) . body)
     (forify* o n (s ... :let* (id id* ... expr)) (clauses ...) . body))
    ((_      o n (s ...) ((%acc c-rest ...) clauses ...) . body)
     (forify* o n (s ... (:acc c-rest ...)) (clauses ...) . body))
    ((_      o n (s ...) ((:acc c-rest ...) clauses ...) . body)
     (syntax-error "Accumulating clauses are not allowed in simplified loop forms." o))
    ((_      o n (s ...) ((id id* ... (iterator source ...)) clauses ...) . body)
     (forify* o n (s ... (:for id id* ... (iterator source ...))) (clauses ...) . body))))

(define-syntax loop/list
  (syntax-rules ()
    ((_  (clauses ...) body ...)
     (forify (loop/list (clauses ...) body ...)
             loop-name () (clauses ...)
       => '()
       (cons (let () body ...) (loop-name))))))

(define-syntax loop/sum
  (syntax-rules ()
    ((_ (clauses ...) body ...)
     (forify (loop-sum (clauses ...) body ...)
             loop-name
             () (clauses ... (%acc acc (summing (let () body ...))))
       => acc
       (loop-name)))))

(define-syntax loop/product
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             product-loop () (clauses ... (%acc acc (multiplying (let () body ...))))
             => acc
             (product-loop)))))

(define sentinel (list 'unique))

;; TODO: maybe have a look at the expansion of this. It seems weird.
(define-syntax loop/first
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             loop/first
             () (clauses ... :final #t)
             => #f
             body ...))))


(define-syntax loop/last
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             loop-name (clauses ... (%acc acc (folding sentinel)))
       => (if (eq? sentinel acc) #f acc)
       (let ((result (let () body ...)))
         (loop-name (=> acc result)))))))

(define-syntax loop/and
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             and-loop
             () (clauses ... (%acc acc (folding #t)))
       => acc
       (let ((res (let () body ...)))
         (and res (and-loop (=> acc res))))))))

(define-syntax loop/or
  (syntax-rules ()
    ((n (clauses ...) body ...)
     (forify (n (clauses ...) body ...)
             or-loop
             () (clauses ...)
       => #f
       (or (let () body ...) (or-loop))))))