#lang scheme/base

;; Macro Forth for PIC18.

(require
 scheme/control
 "forth/forth-tx.ss"
 "tools.ss"
 (for-syntax scheme/base
             "tools/grabbag.ss"
             ;; "tools.ss"
             ))

(require
 ;; LANGUAGE/COMPILER
 "coma/comma-unit.ss"       ;; comma^
 "coma/code-unit.ss"        ;; code^
 "control/control-unit.ss"  ;; control^
 "comp/compiler-unit.ss"    ;; jump^
 "pic18/pic18-unit.ss"      ;; PIC18-specific macros
 "pic18/pic18-control-unit.ss"
) 

(require/provide

 ;; BASE LANGUAGE
 "coma/macro.ss"    ;; base macro tools

 ;; CFG postprocessing
 "comp/postprocess.ss"      
 
 ;; FORTH PREFIX PARSING
 "coma/macro-forth.ss"      ;; rpn prefix parsing words bound to macro.ss
 "pic18/forth.ss"           ;; PIC18 specific

 ;; FORTH LEXING
 "forth/forth-lex.ss"

 ;; ASSEMBLER
 "asm.ss"
 "pic18/asm.ss"
 "pic18/sig.ss"
 "pic18/pic18-const.ss"

 ;; CODE REGISTRY
 "code.ss"

 ;; MISC LOWLEVEL
 "rpn.ss"
 
 )

(provide (all-defined-out))





;; MACRO LANGUAGE

;; The macro language is implemented in a collection of units.
(define/invoke
  (stack^
   stack-extra^
   memory-extra^
   ram^
   comma^
   comma-extra^
   code^
   jump^
   cjump^
   control^
   cfg^
   rstack^
   org^
   machine^
   instantiate^
   pic18-assembler^
   pic18-extra^
   pic18-postproc^)
  (pic18@ pic18-control@ comma@ code@ compiler@ control@))


;; COMPILER

;; Instantiation converts Forth words in postponed form (concatenative
;; macros) to a control flow graph containing assembly code nodes.

;; Get the postprocessors from the macro namespace.
(define-syntax-rule (postproc name)
  (macro->postprocess (macro name)))

(define (pic18-compile->cfg inline-macros)
  (words->cfg!
   (compile-words   ;; functional compiler from instantiated module
    inline-macros)  ;; word definitions passed in by forth-begin-tx
   ;; postprocessor
   (compose
    (postproc opti-save)
    (postproc pseudo)
    )))


;; CODE REGISTRY

;; The parsing step will only produce macros and target labels.  Forth
;; words (as opposed to Forth macros) are collected by the parser in
;; postponed form later to be instantiated.

(define pic18-debug (make-parameter #f))
(define (compile!)
  (code-compile!
   (lambda (in)
     (let ((cfg (pic18-compile->cfg in)))
       (when (pic18-debug)
         (code-print cfg))
       cfg))
   assemble!))
   


;; PARSER

;; Link the parser to the compiler: create defining prefix macros in
;; terms of code wrapping functions and the postponed code registry.
;; In addition to 'forth-begin, this introduces some (macro) prefix
;; parsing words.
(define-forth-parser forth-parse (code-register-postponed!
                                  wrap-macro
                                  wrap-word
                                  wrap-variable))

;; Toplevel begin used for interactive development.
(define-syntax (forth-begin stx)
  (syntax-case stx ()
    ((_ . code)
     #`(begin
         (forth-parse
          path #,(build-path (home) "pic18") ;; library path
          . code)
         (compile!)))))

;; Module level begin used in pic18/lang.ss
(define-syntax-rule (pic18-module-begin . words)
  (#%plain-module-begin
   (forth-begin . words)))

;; String/file read-eval interface.
(define-syntax-rule (forth-compile str)
  (forth-lex-string/cps forth-begin str))
(define-syntax-rule (forth-load/compile str)
  (forth-begin load str))

;; Note: all compilation needs to be in macro from.  Interactive
;; compilation always needs "eval" to call a macro as a function, to
;; make sure it is at toplevel to introduce bindings in the module or
;; toplevel namespace.


;; DISASSEMBLER

;; This non-hygienic form collects all disassembler functions visible
;; in this module namespace.  This is used during live interaction.
(define-dasm-collection dasm-collection)

;; ALLOT STACKS

;; These are currently not settable from assembly code due to
;; dependence on the order of module instantiation and "load"
;; statements.  It is only possible to change them locally (using
;; "org-begin" and "org-end") for the purpose of installing vectors.
;; We start at #x0022 because the first #20 words are reserved as
;; separately erasable block0, and the start of block1 contains a
;; 2-word slot for a jump to boot code to which the default boot code
;; will jump.

(code-pointers-set!
 '((code #x0022)
   (data #x0000)))

;; Convert the address type used by the assembler to byte addresses.
(define (target-byte-address addr realm)
  (case realm
    ((code) (* 2 addr))
    ((data) addr)))