#lang scheme/base

;; Live interaction and parsing words. This simulates an interactive
;; Forth console.

;; Namespace = (target)
;; - transformers = prefix parsing words
;; - words = target-word records
;;
;; All functionality comes from Scat.




(require
 "../tools.ss"
 "../scat.ss"
 "../forth.ss"
 "../comp.ss"  ;; macro evaluation
 "reflection.ss"
 "tethered.ss"
 "../target.ss"
 "../forth/parser-tx.ss" ;; forth-rules
 (for-syntax
  scheme/base))

(provide (all-defined-out))

  
;; Types are handled by prefixes. I.e (+) => (2sim +)
(define-syntax substitution-types
  (syntax-rules ()
    ((_ #t ns type (name ...))
     (substitutions ns ((name) (type name)) ...))
    ((_ ns (type . names) ...)
     (begin (substitution-types #t ns type names) ...))))

(primitive-substitutions
 (target) scat:
 ;; Words that modify the semantics of the following symbol.

 ;; FIXME: either >> or 2/ needs 'truncate' for simulation, or
 ;; explicit signed/unsigned conversion.
 
 ((see w)  ('w tsee))
 ((msee w) ('w msee))
 ((vsee w) ('w vsee))
 
 ((help w)    ('w print-doc))
 ((load w)    ('w forth-load))
; ((prj  w)    ("prj/" 'w ->string string-append project))
; ((project w) ('w ->string project))

 ((prog w)    ('w symbol->string piklab-prog))
 
 ((start w)   ('w tfind tstart/w))
 ((|'| w)     ('w tfind _>t))
 ((dump w)    ('w tfind 1 <<< f! fdump))
 
 ((plot n)    ('n plot))
 ((2plot n)   ('n 2plot))

 ;; Memory access is never overridden by target
 ;; implementation. FIXME: why is this?
 
 ((@)         (1 (access-bank t@) sim))
 ((!)         (2 (access-bank t!) sim))

 ;; Subsitition type prefixes
 
 ((_1cmd w)   (t> t> hilo> w))
 ((1cmd w)    (t> w))
 ((0cmd w)    (w))
 
 ;; To simulate or not is decided by the 'sim/target' word. We
 ;; just provide the word symbol and simulation code. The
 ;; arguments to 'sim' are the number of atoms to get from the
 ;; target stack in a list, and the function to apply to this
 ;; list before putting back the result.
 
 ((2sim w)    ('w (2 (w) sim) sim/target))
 ((1sim w)    ('w (1 (w) sim) sim/target))
 
 ;; FIXME: x >x x>

 ((|.|) (t> p))
 
 )




;; target -> target
(substitution-types
 (target)
 
 ;; In case the target does not contain the compiled forms of the
 ;; following words, they will be simulated. This is to interact
 ;; with a 'clean' target.
 
 ;; FIXME: u* u**
 
 (2sim  + - * / and or xor min max swap)
 (1sim  not 2/ >> << rot<< rot>> dup drop)


 ;; Some commands will perform host actions, but might take
 ;; arguments from the target stack. To limit surprises this list
 ;; is exhaustive: there are no automaticly delegated (prj:)
 ;; words.
 
 (0cmd  dtc sync
        ts tss tsx _ts _tss _tsx
        pa ppa revert OK
        cold scrap pdict pforth
        clear more bin macros words install adump fdump
        hub tnop
        revert-macros ;; FIXME: make sure 'empty' does this
        )
 
 (1cmd  ablock fblock kb a! f!
        abd fbd bd
        p px ps        ;; one byte unsigned, hex, signed
        erase-block
        erase-from-block
        client
        )
 (_1cmd _p _px _ps))



;; ;; Entry point for (syntax-only!) live interaction -> prj code
;; ;; transformation.
;; (define (live->prj code)

;;   (define default
;;     (predicates->parsers
;;      (number?  ((n)  (n tlit)))
;;      (symbol?  ((w)  ('w tinterpret)))))
  
;;   (apply-parsers-ns/default
;;    '(live) default code))


;; ;; Append a line to a log of lines.

;; (define (log-line str stack)
;;   (if (or
;;        (null? stack)
;;        (not (equal? str (car stack))))
;;       (cons str stack)
;;       stack))



;; ;; DIRECT
;; (provide vm->native/compile
;;          live/vm->prj)


;; (define (underscore stx)
;;   (->syntax
;;    stx
;;    (string->symbol
;;     (string-append
;;      "_"
;;      (symbol->string (->datum stx))))))


;; (define (vm->native/compile code)

;;   (define default
;;     (predicates->parsers
;;      (symbol?      ((w)       (|'| #,(underscore #'w)
;;                                    |'| _compile macro/default)))
;;      (number?      ((n)       (n _literal)))))

;;   (apply-parsers-ns/default
;;    '(compile-vm) default code))


;; (named-parsers
;;  (compile-vm)
               
;;  (0cmd         ((w)       (w)))
;;  (|:|          ((_ name)  (: #,(underscore #'name) enter)))
;;  (|;|          ((_)       (_exit))))
  
;;   (named-parser-clones (compile-vm)
;;                        (0cmd pa clear))
  


;;   ;; FIXME abstract out ns/default thingy
  
;;   (define (live/vm->prj code)

;;     (define default
;;       (predicates->parsers
;;        (symbol?   ((w)   ('#,(underscore #'w) tf
;;                           _tlit 'dtc tfind texec/w)))
;;        (number?   ((n)   (n _tlit)))))
    
;;     (apply-parsers-ns/default
;;      '(live-vm) default code))
  
  

;;   ;; FIXME: find a way to extend the other live commands.
;;   ;; map these to their '_' counterpart

;;   ;; FIXME: commands that take no args can be simply mapped.
;;   ;;(define (_command? x)  (element-of x '(ts tss tsx cold ping)))

;;   (named-parsers
;;    (live-vm)

;;    (0cmd      ((w)   (w))) ;; just use same as native
;;    (_0cmd     ((w)   (#,(underscore #'w)))) ;; special

;;    (1cmd      ((w)   (_t> #,(underscore #'w)))))

  
;;   (named-parser-clones
;;    (live-vm)
   
;;    (0cmd   commit clear pa ppa cold ping)
;;    (_0cmd  ts tss tsx)
;;    (1cmd   p ps px kb))