#lang scheme/base
(require "main.ss"
         "../ns.ss"
         "../forth/forth-lex.ss"
         (for-syntax scheme/base
                     "main.ss"
                     "../ns.ss"
                     "../tools.ss"
                     "../forth/forth-tx.ss"  ;; also perform some forth tests
                     "parse-tx.ss")
         (lib "78.ss" "srfi") ;; check
         scheme/pretty)
          

(provide (all-defined-out)
         (all-from-out "main.ss"))

(check-set-mode! 'report-failed)


;; The RPN language serves mostly as a test for the rpn-parse macro,
;; and an example or prototype for building different language
;; semantics on top of the basic syntax.

;; This file implements a simple RPN language on top of scheme.  It is
;; extended by the scat: and macro: languages, and serves as a test
;; and concrete example of how to use the rpn parser to build modified
;; syntax/semantics for a concatenative language.
;;
;; The easiest way to see how this work is to take the forms used in
;; the test at the end of this file and observe the successive macro
;; expansion steps in DrScheme's macro stepper.
;;
;;
;;
;; The parser has 2 distinct translation stages to facilitate Forth's
;; incremental compilation model.
;;
;;   * TOKENS -> DICTIONARY
;;
;;      During this stage a flat stream of tokens (coming from the
;;      lexer) is parsed by the 'rpn-parse macro, a non-nested parser
;;      loop implementing basic RPN language elements.
;;
;;      The ``semantics macros'' passed to 'rpn-parse will end up in
;;      the dictionary, associated with the proper token types as recognised by the parser.
;;
;;      I.e. for the rpn: and rpn-begin forms below tokens get mapped
;;      as:
;;
;;         token-stx -> tagged-instruction-stx = (list semantics-stx expr-stx)
;;         ---------------------------------------
;;         123       -> (p-push 123)
;;         foo       -> (p-apply rpn/foo)
;;         (1 2)     -> (p-push (rpn: 1 2))
;;         '(123)    -> (p-push `(,123))
;;         ...
;;
;;      The dictionary format is:
;;        (list-of (cons name-stx (list-of tagged-instruction-stx)))
;;        (list-of (cons name-stx (list-of (list semantics-stx expr-stx))))
;;
;;      This stage is extensible by binding instances of the
;;      rpn-transformer struct to mapped identifers
;;      (syntax-local-value), which will be executed by the parser
;;      loop.  In addition token streams can contain rpn-transformer
;;      instances.
;;
;;
;;   * DICTIONARY -> SCHEME
;;
;;      The second phase is the conversion from dictionary format to
;;      scheme binding forms and lambda expressions.
;;
;;      Examples of this conversion are 'rpn-begin-mk, 'rpn:-ml.
;;      These will pass the conversion on to 'rpn-lambda.
;;
;;      The macro 'rpn-parse-test when passed with a 'quote form will
;;      give a symbolic representation of the dictionary as
;;      constructed by rpn-parse.
;;
;;      For the rpn: language the tagged-instruction syntax gets
;;      transformed to single-assignment form (nested let expressions)
;;      in the rpn-lambda macro.  See p-apply and p-push for
;;      individual function and immediate semantics.
;;
;;
;;




;; Namespace macros.
(define-syntax-rule (rpn form) (ns (rpn) form))
                      
;; Macro bound to macros implementing semantics.
(define-syntax-rule (rpn->dict dict-mk init-dict code ...)
  (rpn-parse (dict-mk       ;; dictionary form transformer (macro continuation)
              (rpn)         ;; namespace of function references
              p-apply       ;; function semantics (= execute)
              p-push        ;; immediate smenatics (= push)
              p-push        ;; quoted program semantics (= push)
              rpn:          ;; anonymous program quoter for recursive parse
              init-dict     ;; initial dictionary line
              ) code ...))

;; Now use this to create 2 forms: a definer mapping a dictionary to
;; an expression containing defining forms, ...
(define-syntax-rule (rpn-begin code ...)
  (rpn->dict begin (rpn-no-anon) code ...))
(define-syntax-rule (rpn-no-anon) (begin))


;; Syntax checker: no anonymous code allowed on the first dict line.
;; (define-syntax-rule (rpn-no-anonymous) (begin))


;; rpn-parse output testing: quotes the dictionary.
(define-syntax-rule (rpn-begin-test code ...)
  (rpn->dict quote* () code ...))


;; ... and an anonymous code compiler mapping a dictionary to a single
;; lamda expression.
(define-syntax-rule (rpn: code ...)
  (rpn->dict rpn:-compile (rpn-lambda) code ...))




;; P (parameter) stack is abstract.
(define-syntax-rule (p-car p) (car p))
(define-syntax-rule (p-cadr p) (cadr p))
(define-syntax-rule (p-cdr p) (cdr p))
(define-syntax-rule (p-cddr p) (cddr p))
(define-syntax-rule (p-cons x p) (cons x p))
(define-syntax-rule (p->list p) p)
(define-syntax-rule (list->p l) l)


;; Semantics for the locals construct.
(define-syntax-rule (p-locals . a)
  (rpn-let-locals ((rpn)
                   rpn:
                   p-pop-values) . a))




(define (p-pop-values p n)
  (let next ((n n)
             (v '())
             (p p))
    (if (zero? n)
        (apply values (cons p v))
        (next (sub1 n)
              (cons (p-car p) v)
              (p-cdr p)))))

;; Expand to fast primitives.
(define-syntax-rule (op-2->1 op)
  (lambda (p)
    (p-cons (op (p-car p)
                (p-cadr p))
            (p-cddr p))))

(define-syntax-rule (op-1->1 op)
  (lambda (p)
    (p-cons (op (p-car p))
            (p-cdr p))))

(define-syntax-rule (snarfs snarfer (op ...))
  (begin
    (ns (rpn) (define op (snarfer op)))
    ...))

(define (rpn-print-stack p)
  (let ((s (p->list p)))
    (printf "<~s>" (length s))
    (for ((e (reverse s))) (printf " ~a" e))
    (newline)))

;; Basic expression compilers.  The code is right folded in
;; rpn-lambda, so we use nested let expressions here.  Read this as:

;; p <- (p-cons val p)
;; p <- (fn p)

;; The assignment is implemented by shadowing p with a new binding.


(define-syntax-rule (p-push  val p sub) (let ((p (p-cons val p))) sub))
(define-syntax-rule (p-apply fn  p sub) (let ((p (fn p))) sub))
(define-syntax-rule (p-prog  pr  p sub) (let ((p (p-cons (rpn: . pr) p))) sub))

(define-syntax-rule (p-word  name compile code ...)
  (ns (rpn) (define name (compile code ...))))

;; Prefix parsing words.
(ns (rpn) (define-syntax : (make-rpn-definition-transformer
                            (lambda (name d) ;; compile
                              (let* ((d (d-compile #'p-word d))
                                     (d (d-compile name d))
                                     (d (d-compile #'rpn-lambda d))) d)))))
    
(ns (rpn) (define-syntax \| (make-rpn-locals-transformer #'p-locals)))
(ns (rpn) (define-syntax \[  ;; nested quoted programs from flat Forth syntax.
            (let ((open (string->symbol "["))
                  (close (string->symbol "]")))
              (make-rpn-sexp-transformer
               open close
               (lambda (expr dict)
                 (d-compile #`(p-prog #,expr) dict))))))

(ns (rpn) (define-syntax include  ;; nested files
            (make-rpn-include-transformer
             file->syntax-list
             ;; syntax->datum  ;; normal scheme reader
             (lambda (it)
               (let* ((it (syntax->datum it))
                      (it (if (symbol? it) (symbol->string it) it))) it))
             (lambda () '()))))  ;; no search path


;; s-expressions are dumped as a single dictionary entry = toplevel expression.
(ns (rpn) (define-syntax  \{
            (make-rpn-sexp-transformer
             (string->symbol "{")
             (string->symbol "}")
             rpn-compile-toplevel)))

(ns (rpn) (define-syntax tick
            (rpn-syntax-rules () ((_ atom) ('atom)))))




;; Printing + functionality for testing.
(define-syntax-rule (rpn->stack code ...)
  ((rpn: code ...) (list->p '())))

;; read-eval-print
(define-syntax-rule (rpn> code ...)
  (rpn-print-stack (rpn->stack code ...)))

;; read-eval-print with Forth syntax
(define-syntax-rule (forth-command str)
  (forth-lex-string/cps rpn> str))
(define-syntax-rule (forth-compile str)
  (pretty-print (forth-lex-string/cps rpn-begin-test str)))

(snarfs op-2->1 (+ - * /))
(snarfs op-1->1 (sin cos car cdr))

(ns (rpn) (define (i p) ((p-car p) (p-cdr p))))


;; Tests for all syntactic elements.
(define-syntax-rule (rpn-test code ...)
  (reverse (rpn->stack code ...)))
(define-syntax-rule (rpn-checks ((code ...) => list) ...)
  (begin (check (rpn-test code ...) => list) ...))



(rpn-begin : add3 + +     ;; definitions
           : add4 + + +)

(let ((inc (rpn: 1 +))
      (two 2))
  (rpn-checks
   ((1 2 3) => '(1 2 3))                     ;; immediate + stack order
   ((1 2 +) => '(3))                         ;; immediate + function
   ((1 ,inc) => '(2))                        ;; unquote
   ((1 ',two +) => '(3))                     ;; quote+unquote
   ((1 (2 +) i) => '(3))                     ;; code quotation + interpretation
   ((1 (,inc) i) => '(2))                    ;; code quotation + interpretation + function unquote
   ((`(1 2 ,+)) => `((1 2 ,(ns (rpn) +))))   ;; quasiquotation + identifier unquote
   ((1 2 3 `(,(+ +)) car i) => '(6))         ;; quasiquotation + program unquote
   ((1 2 \| a b \| a b a a) => '(1 2 1 1))   ;; locals
   ((1 2 3 add3) => '(6))                    ;; definitions
   ((1 2 3 4 add4) => '(10))
   ))