;; looked elegant, but i moved away from it in favour of a more direct
;; machine specific approach.

;; Idiomatic compiler for register machines.  main idea:
;; * All stack push/pops are made explicit.
;; * The stack register can be overwritten or copied out without
;;   affecting the stack.

;; this serves as a basic register machine compiler model

;; IDIOMS
(define (ldl lit) `(drop ,lit))    ;; load literal
(define (lda reg) `(drop ,reg @))  ;; load from address
(define (sta reg) `(,reg dup!))    ;; store to address

;; More can be defined, but PIC18 doesn't have many addressing modes.

;; Idioms will be stored in the code as lists. The benefit of this is
;; conceptual simplicity: when the list is flattened, it can be run
;; through the highlevel optimizing rewriter to produce 'decompiled'
;; code. This prevents us to have to move to different language
;; semantics while doing register machine specific peephole
;; optimization.



;; default rewrite postprocessor if pattern match fails
;; this is the CALL instruction for the register machine
(define (savedrop-default  name . forth)
  (pack `(,name) forth))


;; default word semantics created from the default rewriter
(define (savedrop-find-default name)
  (lift-transform
   (lambda forth
     (apply savedrop-default
            (cons name forth)))))

(define-symbol-table
  savedrop-register!
  savedrop-find
  savedrop-find-default)


;; This is the parser/compiler for macro text. Since we have forth
;; code, it doesn't support sublists or fancy types like CAT
;; does. Instead, lists are used to group forth instructions into
;; idioms. When they are present, they are simply quoted.

(define (parse-savedrop composition)
  (map
   (lambda (a)
     (let parse ((atom a))
       (cond
        ((symbol? atom) (delay (savedrop-find atom)))
        ((number? atom) (make-literal atom))
        ((list? atom)   (make-quoting-macro atom))
        ((string? atom) (parse (string->symbol atom)))
        (else
         (raise `(type-not-supported ,atom))))))
   composition))

;; run code from the compiler dictionary
(define-syntax run-savedrop
  (syntax-rules ()
    ((_ code args ...)
     (let ((compiled-code (parse-compile 'code)))
       (run-composite compiled-code (pack args ...))))))

; compile a literal
;; this invokes the 'save' macro, which can recombine with 'drop'
(define (make-literal literal)
  (lambda  stack
    (comma (reverse (ldl literal)) ;; reverse storage
           (run-savedrop (save) stack))))


(rewrite-macros
 savedrop-register!

;; eliminate stack cell allocation
;; (need to do this here because of dup/save symbol name)

;; dup  ( a -- a a )
;; save ( a -- a <DC> )

;; the reason is simple:
;; (drop save) == ()   -> becuse of the don't care <DC> value
;; (drop dup)  != ()

;; sometimes you do only need 'save', which then can undo
;; drop. because of <DC>, 'save' should always be followed by a
;; clobbering operation.
 
(save  (('drop rest ...) rest)
       ((rest ...)       (pack 'dup rest)))

)


;; NOTES:
;;
;; * [ldl a] matches ('drop (n a))
;;   [sta a] matches ((n a) dup!)
;;
;;   the reason i use this is that i don't use prefix virtual
;;   assembler (any more) in the representation, but instead use
;;   ideoms grouped in lists that can be flattened back to plain forth
;;   code. the same patterns are also defined as functions to generate
;;   the idioms.
;;
;; * the ';' word needs to be mapped by the lexer


(rewrite-patterns
 savedrop-register! savedrop-default

 (('dup 'dup [ldl a] !)   `(,[sta a]))       ;; dup elimination (as rewrite?)
 (('dup [ldl a] !)        `(,[sta a] drop))
 (([ldl a] !)             `(drop ,[sta a] drop))

 (([ldl a] @)             `(,[lda a]))       ;; register fetch

 ((word   ";")            `((word ";")))    ;; tail call
 
)