#!/usr/bin/env mzscheme
#lang scheme/base

;; The 'Staapl Compiler' command line tool.
;; Provides a standard command line interface to all (compilation)
;; functionality.  It is invoked as:
;;   mzscheme -p zwizwa/staapl/staaplc -- <arg> ...

;; The dictionary file produced is a mzscheme module that when invoked
;; produces a REPL to a live target.  This makes it possible to lift
;; any kind of behaviour from project source files to actual REPL
;; behaviour.

;; However, it can be interpreted as a data file by observing the
;; following structure:

;;   * The first line contains the PLT Scheme #lang construct and can
;;     be skipped using the 'read-line function.

;;   * The first scheme form accessible using 'read is a 'begin form
;;     containing only data definitions (define <name> (quote <datum>))

;;   * The second form accessible through 'read contains a 'require
;;     statement which imports the bindings for the target language in
;;     which the project is written, and interaction code.

;;   * Subsequent forms contain opaque scheme code necessary to
;;     configure and optionally start the console command interpreter
;;     using the data provided in the previous forms.

(require scheme/pretty
         (planet zwizwa/staapl/tools))

(define-syntax-rule (flags: name ...)
  (begin (define name (make-parameter #f)) ...))

(flags: output-hex

;; Defaults
(device "/dev/staapl0")
(baud #f)
(print-asm void)
(dict-suffix ".dict")
(debug-suffix ".ss")

(define (get-arguments)

    #:program "staaplc"
    [("-o" "--output-hex") filename "Output Intel HEX file."
     (output-hex filename)]

    [("--print-code") "Print assembly and binary code output."
     (print-asm (lambda () (eval '(code-print))))]

    [("--script") "Don't wrap dictionary as a loadable module."
     (dict-suffix ".dict-script")
     (output-script #t)]

    [("-c" "--device") filename "Console device. (default: /dev/staapl0)"  (device filename)]
    [("--baud") number   "Console baud rate. (default from source file)" (baud (string->number number))]
    [("-d" "--output-dict") filename "Output dictionary file."
     (output-dict filename)]

    #:args (fname)

(define (out param template suffix)
  (let ((p (param)))
    (unless p
       (let-values (((base name _) (split-path template)))
         (path-replace-suffix name suffix))))))

;; (*) The extension .ss is too confusing.  This is a generated file,
;; which should be removable by a simple rm *.<ext> in a Makefile.

(define (absolute param)
  (let ((p (param)))
     (if (absolute-path? p)
         (string->path p)
         (path->complete-path p)))))

(define (dir-of path)
  (let-values (((base name _) (split-path path)))

;; Run + save.
(define (requirements path)
    (planet zwizwa/staapl/tools)      ;; misc tools
    (planet zwizwa/staapl/live)       ;; toplevel interaction
    (planet zwizwa/staapl/code)       ;; code->binary
    (planet zwizwa/staapl/port/ihex)  ;; write-ihex
    (planet zwizwa/staapl/pic18)      ;; base language (FIXME: obtain from module)
    (file ,(path->string path))))     ;; code as module

(define (process-arguments)
  (out output-hex (filename) ".hex")
  (out output-dict (filename) (dict-suffix)) ;; (*)
  (out debug-script (filename) (debug-suffix))

  ;; Why do these need to be absolute?
  (absolute filename)
  (absolute output-hex)
  (absolute output-dict)
  (absolute debug-script)

(define (warnf . args)
  (display "WARNING: ")
  (apply printf args))

(define (instantiate-and-save)
  ;;(printf "in:  ~a\n" (filename))
  ;;(printf "out: ~a ~a\n" (output-hex) (output-dict))

  (unless (file-exists? (filename))
    (printf "input file not found: ~a\n" (filename))
    (exit 1))


    ;; Load necessary code.
    (eval (requirements (filename)))

    ;; Optionally print assembler code.
    ;; Fetch some defaults from the forth namespace if necessary.
    (unless (baud)
      (let ((b (eval '(macro-constant 'baud))))
        (unless b (warnf "Couldn't determine baud rate.\n"))
        (baud b)))

    ;; Save binary output.
     (lambda ()
       (eval '(write-ihex (code->binary)))))

    ;; Save symbolic output.
    (let* ((defs
                (define labels   ',(eval '(code-labels)))
                (define pointers ',(eval '(code-pointers)))
                (define device   ',(device))
                (define baud     ',(baud))
                (define script   ',(path->string (debug-script)))))
           (reqs (requirements (filename)))
           (boot-init  ;; opaque console boot code
               (console (list device baud))
               (define (empty)
                 ;; After loading the .fm file the code buffer
                 ;; contains target code.  Get rid of it.
                 ;; Patch addresses to make sure that the target
                 ;; kernel words are correctly indexed.  I.e. it is
                 ;; possible the .fm kernel source is out of sync with
                 ;; the binary code.
                 (target-words-set!  labels)
                 (code-pointers-set! pointers)
                 ;; Delete all target scratch buffer code we don't
                 ;; have labels for.
                 ;; Load host debug script into toplevel namespace on
                 ;; a clean target.
                 (when-file script load))))
               (require readline/rep)
               (param-to-toplevel 'command repl-command-hook)
               (param-to-toplevel 'break   repl-break-hook)
               (run (lambda () (empty)))))
           ;; formatting
           (save (lambda (text [code #f])
                   (display text)
                   (when code
                     (pretty-print code))))
            (lambda ()
              (save ";; Target info"   defs)
              (save ";; Language"      reqs)
              (save ";; Console setup" boot-init)))
            (lambda ()
              (save "#lang scheme/load ; -*- scheme -*-")  ;; (2)
              (save ";; Console run"   boot-run))))
       (if (output-script)

;; (1) Saving the addresses is not necessary if source code and target
;; are kept in sync.  When the interactive script is started,
;; everything will be simply re-compiled.  However, to enable a
;; scenario where code has changed internally, but the procedure
;; _interface_ hasn't, we save the addresses as they are on the
;; target.

;; (2) For interactive development we're using a toplevel namespace
;; instead of a (static) module namespace.

;; Toplevel actions
(define (main)

; (vector "-m" "/home/tom/staapl/app/"))