;; This a replacement for the lambda statement
;; - lambda generates anonymous functions
;; - lambda-res generates anonymous coroutines (-res stands for "resumable")
;; - indide coroutines you can use the yield statement to pause the execution
;;   and then use the resume method to resume execution
(defmacro lambda-res (lambda-list &body body)
  (let* ((name (gensym "lambda-res-"))
	 (arg-parser (let ((parser (make-instance 'defun-lambda-list-parser)))
		       (parse-lambda-list parser lambda-list)
		       parser))
	 (m-env
	   (multiple-value-bind (arg-symbols aux-symbols) (get-defun-parser-symbols arg-parser) 
		 (make-instance 'resumable-macro-state-env
				:var-symbols (union arg-symbols aux-symbols))))
	 ;; Derived class name and declaration
	 (derived-class-name (read-from-string (concatenate 'string "%resumable-state-env-" (string name) "%")))
	 (derived-class-decl `(defclass ,derived-class-name (resumable-state-env) ()))
	 ;; Function that creates task class instance and initializes argument values and local variables
	 (resumable-init-fn (multiple-value-bind (arg-symbols aux-symbols arg-defaults) (get-defun-parser-symbols arg-parser)
			 `(defun ,name (,@lambda-list)
			    (let* ((env (make-instance (quote ,derived-class-name))))
			      ,@(loop for arg-symbol in arg-symbols collect
				      `(if (null ,arg-symbol)
					   (push ,(getf arg-defaults arg-symbol) (gethash (quote ,arg-symbol) (resumable-locals env)))
					   ;; else
					   (push ,arg-symbol (gethash (quote ,arg-symbol) (resumable-locals env)))))
			      ,@(loop for aux-symbol in aux-symbols collect
				      `(if (null ,aux-symbol)
					   (push ,(getf arg-defaults aux-symbol) (gethash (quote ,aux-symbol) (resumable-locals env)))
					   ;; else
					   (push ,aux-symbol (gethash (quote ,aux-symbol) (resumable-locals env)))))
			      env))))
	 ;; Generate the code enclosed by the tagbody
	 (resumable-tagbody (progn (translate-resumable-body m-env body)
			      (resumable-tagbody m-env)))
	 ;; Generate resume method which resumes execution of the task
	 (resume-method `(defmethod resume ((env ,derived-class-name))
			      (symbol-macrolet
				  (,@(loop for var-name in (var-symbols m-env)
					   collect
					   (list  var-name `(first (gethash (quote ,var-name) (resumable-locals env))))))
				(tagbody
				   (cond
				     ,@(loop for state across (valid-states m-env) collect `((equal (resumable-state env) ,state) (go ,state)))
				     ((equal (resumable-state env) nil) (error (format nil "Resumable function ~a aleady finished." (quote ,name))))
				     (t (error (format nil "Invalid state code ~a" (resumable-state env)))))
				 0 ; State 0 where the tasks starts 
				   ,@resumable-tagbody)
				(setf (resumable-state env) nil)))))
    `(progn
       ,derived-class-decl
       ,resumable-init-fn
       ,resume-method
       (function ,name))))

;; An example usecase of lambda-res
;; - defun-res is similar to lambda-res but it replaces defun
;; - the fork-join macro schedules 2 or more anonymous coroutines to run interleaved
;;   while the parent coroutine waits for both of them to finish
;; - sim-wait is a macro which uses yield behind the scenes
(defun-res test-fork-join-res ()
  (fork-join 
    (lambda-res ()
      (format t "~a func1 before delay~%" (time-now *sim*))
      (sim-delay 5)
      (format t "~a func1 after delay~%" (time-now *sim*)))
    
    (lambda-res ()
      (format t "~a func2 before delay~%" (time-now *sim*))
      (sim-delay 10)
      (format t "~a funct2 after delay~%" (time-now *sim*))))
  (sim-finish))

(defun test-fork-join ()
  (let ((*sim* (make-instance 'sl-sim)))
    (reset-sim)
    (spawn #'test-fork-join-res)
    (run 100)
    (format t "Stop time is ~a ~%" (time-now *sim*))))

;; When I compile test-fork-join-res I see these warnings:
; file: /tmp/slimeDhHPcH
; in: DEFUN-RES TEST-FORK-JOIN-RES
;     (SYSTEM-LISP::LAMBDA-RES NIL
;       (FORMAT T "~a func1 before delay~%"
;               (SYSTEM-LISP::TIME-NOW SYSTEM-LISP::*SIM*))
;       (SYSTEM-LISP::SIM-DELAY 5)
;       (FORMAT T "~a func1 after delay~%"
;               (SYSTEM-LISP::TIME-NOW SYSTEM-LISP::*SIM*)))
; 
; caught STYLE-WARNING:
;   Cannot find type for specializer
;   SYSTEM-LISP::%RESUMABLE-STATE-ENV-LAMBDA-RES-2% when executing
;   SB-PCL:SPECIALIZER-TYPE-SPECIFIER for a STANDARD-METHOD of a
;   STANDARD-GENERIC-FUNCTION.
; 
; caught STYLE-WARNING:
;   Cannot find type for specializer
;   SYSTEM-LISP::%RESUMABLE-STATE-ENV-LAMBDA-RES-2% when executing
;   SB-PCL:SPECIALIZER-TYPE-SPECIFIER for a STANDARD-METHOD of a
;   STANDARD-GENERIC-FUNCTION.

;     (SYSTEM-LISP::LAMBDA-RES NIL
;       (FORMAT T "~a func2 before delay~%"
;               (SYSTEM-LISP::TIME-NOW SYSTEM-LISP::*SIM*))
;       (SYSTEM-LISP::SIM-DELAY 10)
;       (FORMAT T "~a funct2 after delay~%"
;               (SYSTEM-LISP::TIME-NOW SYSTEM-LISP::*SIM*)))
; 
; caught STYLE-WARNING:
;   Cannot find type for specializer
;   SYSTEM-LISP::%RESUMABLE-STATE-ENV-LAMBDA-RES-13% when executing
;   SB-PCL:SPECIALIZER-TYPE-SPECIFIER for a STANDARD-METHOD of a
;   STANDARD-GENERIC-FUNCTION.
; 
; caught STYLE-WARNING:
;   Cannot find type for specializer
;   SYSTEM-LISP::%RESUMABLE-STATE-ENV-LAMBDA-RES-13% when executing
;   SB-PCL:SPECIALIZER-TYPE-SPECIFIER for a STANDARD-METHOD of a
;   STANDARD-GENERIC-FUNCTION.