;; $Id$

;; MAL code for call-with-continuation-mark, which requires 
;; very careful stack handling. Not at all optimized for speed.

;; call-with-continuation-mark : key mark (-> 'a) -> 'a
;; Installs a frame with known structure on the continuation stack
;; and invokes thunk.

;; Mark Frame structure
;; +----------------------------+
;; | RA | up | ENV | mark-alist |
;; +----------------------------+
;;   --   --  slot0    slot1
;;
;; On a mark frame, ENV will always be 'call-with-continuation-mark',
;; so we can test for that and just pluck the alist out.

 `((,$lambda ((,$.proc)
             (,$args= 3)
             
             ;; Before we save, is the *current frame* a mark frame?
             ;; It's a mark frame iff it's ENV slot is CALL/CM, 
             ;; that is, the currently executing procedure.
             (,$load 4 0)      ;; Get the current frame's ENV slot => reg4
             (,$reg 0)         ;; Load self (call/cm) to Result
             (,$op2 eq? 4)    ;; Compare
             (,$branchf 1002)  ;; If different, save and invoke.
                               ;; Otherwise, fall though to overwrite.
             
             ;; Overwrite and invoke.
             ;; It's a mark frame, so it's okay to write on it, even
             ;; though we didn't create it.
             (,$load 4 1)      ;; Load the current mark-alist to reg4
             (,$save 1)         ;; Have to save the thunk
             (,$store 0 0)      ;; (unnecesary?!)
             (,$store 3 1)      ;; Store thunk to slot 1
             (,$movereg 4 3)   ;; Move alist to arg3 (args 1,2 already done)
             (,$setrtn 1003)
             (,$global sys$replace-mark-functional)
             (,$invoke 3)       ;; Compute the new mark-alist
             ;; -- write and invoke
             (,$.label 1003)
             (,$.cont)
             (,$load 0 0)
             (,$load 1 1)      ;; Reload the thunk
             (,$setreg 4)     ;; Store new mark-alist in reg4
             (,$pop 1)         ;; Discard old frame
             (,$store 4 1)    ;; Write the mark-alist to slot 1 of the frame.
             (,$reg 1)
             (,$invoke 0)      ;; Invoke thunk, keeping old mark frame.
             
             ;; Save and invoke.
             ;; Make a new mark frame with (list (cons arg1 arg2)) in the 
             ;; mark-alist slot.
             (,$.label 1002)
             (,$save 1)        ;; Create a new mark frame.
             (,$store 0 0)     ;; (unnecessary?!)
             (,$reg 1)         ;; arg1
             (,$op2 cons 2)    ;; Result = (cons arg1 arg2)
             (,$op2imm cons ());; Result = (list (cons arg1 arg2))
             (,$setreg 1)
             (,$store 1 1)     ;; Store the mark in slot 1 of the frame
             (,$reg 3)
             (,$setrtn 1001)
             (,$invoke 0)    ;; Invoke thunk... mark frame remains!
             
             (,$.label 1001)
             (,$pop 1)       ;; Remove mark frame.
             (,$return))
            0
            #f)
  (,$setglbl call-with-continuation-mark)
  (,$const   call-with-continuation-mark)
  (,$return))
