#lang scheme/base

;; I've been looking for a long time to find a solution to writing a
;; frontend that's ANS Forth compatible.  I'm still not sure wheter it
;; is really useful at this point, but if it is not too difficult, it
;; might be a nice addition that enables the inclusion of Staapl into
;; a more traditional Forth based project. 

;; The problem in itself isn't very difficult: Find a Forth written in
;; Forth + a small set of primitives and implement the primitives.
;; However, I'd like to do it in a way that enables some more
;; flexibility.

;; After pondering this for a while, I think this might be an
;; interesting approach: Write a simulated Forth, use it to generate a
;; memory image, and translate the compiled threaded code to run on
;; top of Scat's Forth / Coma.

;; Doing this in a way that enables gradual offloading to the target
;; is not that simple.  Wanting more control over dictionary format
;; and execution model (i'd like to use STC primitives) makes things
;; quite challenging.



;; -----

(require
 "../scat.ss"
 (for-syntax
  scheme/base
  "../scat-tx.ss"))

;; In contrast to Coma, the ANS Forth frontend is implemented using
;; mutable state. This state is stored in parameters to keep it local.

(define ans-dictionary '())
(define-struct ans-link (name mode code))
(define ans-input-stream (make-parameter #f))
(define ans-output-stream (make-parameter #f))

;; I'm curious if memory needs to be an array. This probably depends
;; on the implementation of fetch and store only..
(define ans-memory (make-parameter (make-vector 100)))

(define (ans-fetch addr)     (vector-ref  (ans-memory) addr))
(define (ans-store val addr) (vector-set! (ans-memory) addr val))

(snarf as-void (ans) ((val addr) ((! ans-store))))
(snarf as-push (ans) ((addr)     ((@ ans-fetch))))

(define-syntax-rule (scat-snarf id ...)
  (begin (define-ns (ans) id (ns (scat) id)) ...))

(scat-snarf * + - 2/ 2*)
 

;; Primitive ANS words
(compositions
 (ans) scat:
 

)

(define-syntax (ans: stx)
  (syntax-case stx ()
    ((_ . code)
     (with-scat-syntax
      (lambda ()
        (parameterize
            ((rpn-map-identifier (lambda (id) (ns-prefixed #'(ans) id))))
          (rpn-compile #'code)))))))

(compositions
 (ans) ans:
 
 

 )
;; http://lars.nocrew.org/dpans/dpans.htm
;; core wordset:

;; !  # #> #S ' ( * */ */MOD + +!  +LOOP , - .  ."  / /MOD 0< 0= 1+ 1- 2!
;; 2* 2/ 2@ 2DROP 2DUP 2OVER 2SWAP : ; < <# = > >BODY >IN >NUMBER >R ?DUP
;; @ ABORT ABORT" ABS ACCEPT ALIGN ALIGNED ALLOT AND BASE BEGIN BL C!  C,
;; C@ CELL+ CELLS CHAR CHAR+ CHARS CONSTANT COUNT CR CREATE DECIMAL DEPTH
;; DO DOES> DROP DUP ELSE EMIT ENVIRONMENT?  EVALUATE EXECUTE EXIT FILL
;; FIND FM/MOD HERE HOLD I IF IMMEDIATE INVERT J KEY LEAVE LITERAL LOOP
;; LSHIFT M* MAX MIN MOD MOVE NEGATE OR OVER POSTPONE QUIT R> R@ RECURSE
;; REPEAT ROT RSHIFT S" S>D SIGN SM/REM SOURCE SPACE SPACES STATE SWAP
;; THEN TYPE U.  U< UM* UM/MOD UNLOOP UNTIL VARIABLE WHILE WORD XOR [ [']
;; [CHAR] ]


;; The problem with implementing this in a way that it can be
;; simulated on the host and moved to the target lies in 3 parts:

;;   * INPUT:       ACCEPT

;;   * DICTIONARY:  FIND WORD VARIABLE CONSTANT CREATE POSTPONE

;;   * THREADING: