#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:

 ;; important note: all the archs (planned to be) supported in brood
 ;; are register machines, so 'literal' is always SAVE (which
 ;; reserves a cell on the data stack in the most efficient way,
 ;; mostly just DUP) followed by LDTOP (load top register).

 ;; (for a forth machines, brood would not need a peephole
 ;; optimizer.. the whole point of brood is to make the virtual
 ;; forth machine emulation happen with a good assembler mapping)
 
 ;; control flow

 ;; or-goto \ ? word --
 ;; equivalent to "swap if execute ; then drop"
 ;; aka JNZ
 
 (if      sym dup >m or-jump)
 (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))
 
 )