;; FORTH COMPILER

;; a forth compiler using the VM in core.ss

;; this is structured as a rewriting compiler: most 'intelligent'
;; behaviour is a map from forth -> forth. all optimizations should be
;; done in this phase. what remains is 'assembler ready' forth code
;; that can be mapped straight to binary. (no more murking with
;; assembler code)
;;
;; (eventually, a disassembler should be written, which maps binary
;; code back to this low-level forth code.)


;; * the basic flow of control:
;;   - read a list of forth code
;;   - interpret (compile + run) it in the macro context
;;   - repeat
;;
;; * all rewriters map (forth . stack) -> (forth . stack)
;;   any state should be maintained on the stack
;;
;; * to make things easier, the rewriters are all divided into
;;   classes, which are then lifted to the prototype described above.
;;


;; PARSER/COMPILER

;; the default rewriter macro is just a quotation which outputs the
;; name to the forth list on the stack.
(define (make-quoting-macro literal)
  (lift-transform
   (lambda forth (cons literal forth))))

;; default rewrite postprocessor if pattern match fails = nop
(define (reduce-default  . forth) forth)

(define (reduce-find-default name)
  (make-quoting-macro name))

(define (reduce-find name) (reduce-macro-table name))

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

;; parser/compiler for macro text. this is forth code, so it doesn't
;; support sublists or fancy types like CAT does!

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


; invoke another macro
; uses quoted datum which will be set! to code later


;; FORTH REDUCER MACROS

(rewrite-patterns
 reduce-register! reduce-default

 ((word undo)  '())
 (('dup drop)  '())

 (([n a] [n b] +)   `(,(+ a b)))
 (([n a] [n b] -)   `(,(- a b)))
 
 (([n a] [n b] xor)    `(,(bitwise-xor a b)))
 (([n a] [n b] and)    `(,(bitwise-and a b)))
 (([n a] [n b] or)     `(,(bitwise-ior a b)))
 (([n a] not)          `(,(bitwise-xor a -1)))
 
 (([n a] negate)       `(,(* a -1))))
 
;; ((dup dup (drop a) !)  `((,a sta)))
;; ((dup (drop a) !)      `((,a sta) drop)))


;; for testing
(define (test-reduce init code)
  (reverse (car
            (run-primitive
             (parse-reduce code)
             (list (reverse init))))))