#lang scheme/base

;; Primitives for the control stack extension. This supports Forth's
;; control flow words, which are implemented in terms of jumps and
;; labels.

;; A practicaly Forth compiler implemented in instatiate.ss will
;; replace the underlying jump/label mechanism with a more powerful
;; control flow analysis mechanism.

(require
 "../tools.ss"
 "../scat.ss"
 "../coma.ss"
  "2stack.ss")

(provide (all-defined-out))


;; Label symbol generator.
(define next-label
  (let ((next (make-counter 0)))
    (lambda () (string->symbol
                (format "_L~a" (next))))))



(patterns
 (macro)

 ;; CONTROL STACK OPS
 
 ((m-swap)          (macro-prim: ctrl-swap))
 ((m>)              (macro-prim: ctrl> literal))
 (([qw a]  >m)      (macro-prim: ',a >ctrl))
 (([cw a]  word>m)  (macro-prim: ',a >ctrl))


 ;; LABELS

 ;; Stubs for target label operations used in label.ss /
 ;; instantiate.ss to build structured code graphs that allow control
 ;; flow analysis. This allows the forth control words (that use only
 ;; the 2nd stack) to be defined here, for use in testing or any other
 ;; use that doesn't need control flow analysis and label management.

 ((sym)               ([qw (next-label)]))      ;; labels are symbols
 (([qw sym] label:)   ([label sym]))            ;; pseudo op.
)

;; JUMP PRIMITIVES
(compositions
 (macro) macro-prim:

 ;; Override with target conditional jump macro.
 (or-jump    'jw/if >tag))
 
(compositions
 (macro) macro:

 ;; The macro primitive-exit is from coma/core.ss and does not perform
 ;; control flow marking. Here we introduce exit as an indirection. It
 ;; will be redefined by macro/instantiate.ss
 (exit    primitive-exit)

 ;; Control flow primitives in terms of label ops and exit.
 (jump    execute exit)       ;; \ name --   (start of branch)

)

;; FORTH-STYLE CONTROL FLOW

(compositions
 (macro) macro:

 ;; Mark basic block end. The label is not used, only the effect it
 ;; has: to split the basic block.

 ;; For control flow analysis we need to obtain the conditional branch
 ;; target so a basic block can have two exit paths. If each block has
 ;; only a single conditional exit, this is possible. (Maybe mark the
 ;; block as a branch block too?)
 
 (end:    sym label:)  

 ;; 'if should be the ONLY macro calling the machine-specific 'or-jump
 ;; macro.
 
 (if      sym dup >m or-jump end:)
 (else    sym dup >m jump m-swap then)
 (then    m> label:) 

 (begin   sym dup >m label:)
 (again   m> jump)

 (do      begin)
 (while   if)
 (repeat  m-swap again then)
 
 (until   not while repeat)

 ;; Note: for .. next used to have an optimization wrapping the inner
 ;; loop in a dup .. drop construct. Given the current implementation,
 ;; this is not so straightforward to implement, so it's currently
 ;; disabled. The main problem being that the composition implementing
 ;; the loop body can't be recovered easily, and a more direct code
 ;; inspection mechanism is necessary.  However, using higher order
 ;; macros, this should be fairly trivial to do directly, so I'm not
 ;; bothering right now.
 
 ;; one with drop .. save wrapped around it. this generates better
 ;; code for loops that do 'read modify write'. platform specific
 ;; needs to define for0 ... next0
; (for1  dup for0 drop)
; (next1 save next0 drop)

 ;; amb-compile will non-deterministically compile (execute) one of
 ;; the two quoted macros. each macro quotes a macro implementing
 ;; its 'next' behavirour (next just executes macro from m>).

; (for   (for0 (constraint:label-nodup
;               next0) >m)
;        (for1 (next1) >m)
;        amb-compile)

; (amb-compile   swap >m >m m-amb-run/s)

; (next  m> compile)

 )

;; HIGHER ORDER MACROS

;; Written in terms of Forth style control words. Note that to provide
;; a clean Coma language with higher order control macros, these need
;; to be implementented in a different module, so the lowlevel Forth
;; control words can be hidden.

(patterns
 (macro)
 
 (([qw a] [qw b] ifte)
  (macro: if ',a run else ',b run then))
 
 )