;; Shared forth parsing code.

;; This defines most of the PURRR language constructs that are not
;; compositional: symbols can have meaning other than
;; call/macro. i.e. those following "variable, constant, ..."

;; The parser is used to transform symbolic code with these properties
;; into symbolic compositional forth code + its quoting mechanism.

;; In addition to this, all MACRO DEFINITIONS are parsed to s-expressions.

;; The entire processing chain is:


;; FORTH -> [load flattener] 
;;       -> [forth stuff: parsing words + definer environents] 
;;       -> [quoting] 
;;       -> SEXP



(module forth mzscheme

  (require 
   (lib "match.ss")
   "list-utils.ss"

   "tx-utils.ss"
   "stream.ss"
   "stx-stream.ss" ;; syntax stream parser utils
   
   "ns.ss"         ;; macros stored in namespace

;   (lib "pretty.ss")

   )
  
  (provide forth->macro.code
           @forth->macro/code
           forth
           forth->string

           ;; define parser transformers
           named-parsers

           ;; parsers are not composable, so cloning is used as a form
           ;; of primitive abstraction.
           named-parser-clones

           ;; parsing with code from namespace and default behaviour
           apply-parsers-ns/default

           ;; DEBUG
           ;; other-def-parser
           )

  ;; FORTH

  ;; The parser dictionary and driver routine.
  
  ;; (ns-new '(forth))

  (define (forth name)
    (ns-ref `(forth ,name) #f))


  (define (forth->macro . a)
    (error 'not-implemented "forth->macro"))

  
  ;; Since parsers have no composition mechanism, factoring out common
  ;; behaviour is done using cloning.
  
  (define (register-parser-clones! ns clones)
    (for-each
     (match-lambda
      ((clone-from . names)
       (let ((behaviour
              (ns-ref `(,@ns ,clone-from))))
         (for-each
          (lambda (name)
            (ns-set! `(,@ns ,name) behaviour))
          names))))
     clones))
  
  (define-syntax named-parser-clones
    (syntax-rules ()
      ((_ ns . clones)
       (register-parser-clones! 'ns 'clones))))


  ;; combine namespace with default behaviour
  (define (apply-parsers-ns/default ns default code)
    (apply-parsers
     (lambda (name)
       (or (ns-ref `(,@ns ,name) #f)
           (default name)))
     code))

  ;; Convert forth source to a list of macro definitions and a list of
  ;; straight line code.

;  (define (:->datum stx)
;    (pretty-print stx)
;    (->datum stx))

  (define (forth->macro.code lst)
    (let-values
        (((macros code)
          (@forth->macro/code
           (@stx (->syntax #f lst)))))
      (cons
       (@unfold (@map ->datum macros))
       (@unfold (@map ->datum code)))))

  ;; Convert a forth stream into macro/code streams. The macro forms
  ;; are tagged with 'extension:' and parsed later using the
  ;; 'extend!' function/word defined in badnop.ss

  ;; Macros present in forth syntax code are one form of
  ;; extensions. Another is plt-scheme 'module' forms.

  (define (tag->tagged? sym)
    (lambda (stx)
      (let ((lst (syntax->list stx)))
        (and lst
             (not (null? lst))
             (eq? sym (->datum (car lst)))))))
  
  (define (@forth->macro/code stream)
    (let-values
        (((macros code)
          (@moses
           (tag->tagged? 'extension:)
           (@apply-parsers forth stream))))
      (values
       (@map
        ;; Get rid of tag. The procedure syntax-e (through stx-cdr)
        ;; unwraps an S-expr, not a pair, so we reconstruct.
        (lambda (stx)  
          (->syntax #f (stx-cdr stx)))
        macros) 
       code)))


  ;; PRIMARY QUOTE:

  ;; In compositional Forth, there is only one item of syntax
  ;; remaining: the ' word. This will quote the following word as a
  ;; literal. This is a stream -> stream processor

  (define (@parse-quote @stream)
    (lazy
     (@syntax-case @stream @tail (|'|)
                   ((|'| word) (@cons #'(quote word) (@parse-quote @tail)))
                   ((|'|)      (raise-syntax-error 'quote-needs-argument "none provided"))
                   ((word)     (@cons #'word (@parse-quote @tail)))
                   (()         @null)
                   )))
  ;; FIXME: currently this is done at 2 places: quote is a "parsing
  ;; word" and the macro above is called from with the definition
  ;; expander.
  

  ;; QUOTING PARSERS

  ;; If a syntactic construct just changes the semantics of the
  ;; following word, it is implemented using a simple quoting
  ;; transformation:  (<word> abc) -> ('abc *<word>)

  ;; A simple symbol mapping using some neutral prefix seems like a
  ;; good idea. '*' won the election.

  (define (quoted-makesymbol stx-sym)
    (string->symbol
     (format "*~a" (->datum stx-sym))))

  (define (quoted stream)
    (@syntax-case stream s+ ()
      ((macro label)
       (@parsed
        #`('label #,(quoted-makesymbol #'macro))
        s+))))
    

  (define-syntax named-parser-bodies
    (syntax-rules ()
      ((_ (ns ...) (name body) ...)
       (begin
         (ns-set! '(ns ... name) body) ...))))

  ;; Same, but bodies are parser-rules bodies.
  (define-syntax named-parsers
    (syntax-rules ()
      ((_ (ns ...) (name rules ...) ...)
       (named-parser-bodies (ns ...)
        (name (parser-rules () rules ...))
        ...))))
        
  (define-syntax quoting-parsers
    (syntax-rules ()
      ((_ (ns ...) name ...)
       (named-parser-bodies
        (ns ...)
        (name quoted) ...))))

    
  (quoting-parsers (forth)

                   |'| : fsymbol word dict dw 

                   ;; variable 2variable
                   ;; constant 2constant

                   ;; FIXME:
                   ;; quoter   ;; create a new quoting parser
                   ;; direct   ;; direct threaded forth on top of a native code forth
                   ;; load-usb ;; load usb device descriptors
                   ;; load-vm  ;; load using dtc parser
                   )


  ;; CONSTANT + VARIABLE

  (define (constants-obsoleted stx-stream)
    (error 'constants-obsoleted
           "~a"
           syntax-object->datum (@car (@cdr stx-stream))))

  (define (n-variable n)
    (lambda (stream)
      (@syntax-case stream s+ ()
        ((_ name)
         (@parsed
          #`((extension: name () ('name)) ;; macro quotes name 
             'name #,n buffer)            ;; code passes allocation to assembler
          s+)))))

  (named-parser-bodies (forth)
    (constant  constants-obsoleted)
    (2constant constants-obsoleted)

    (variable  (n-variable 1))
    (2variable (n-variable 2))

    (scheme    (parser-rules () ((_ expr) ((extension: scheme: expr)))))
                             
    
    )
  


  ;; RECURSIVE MACROS


  ;; This transforms forth syntax to internal definition syntax which
  ;; consists of 4 elements (<type:> <name> <locals> <body>). The
  ;; latter 3 are the format used in the target dictionary (type
  ;; defaults to forth macro).


  ;; stx processor: piggyback on stream processor.
  (define (stx-unflatten stx marker)
    (->syntax #f
              (@unfold
               (@stx-unflatten
                (@stx stx) marker))))
  
  (define (make-def-parser def:)
    (lambda (@stream)
      (@syntax-case
          ;; unflatten delimited body into list
          (@stx-unflatten (@cdr @stream) ;; ignore ':'
                          ";")           ;; read upto / excluding
          @tail (\|)

          ;; local variables
          (((name \| . locals+words))
           (syntax-case (stx-unflatten #'locals+words "|") ()
             ((locals . words)
              (let ((def
                     #`((#,def: name locals words)))) 
                ;; (printf "~s\n" (->datum def))
                (@parsed def @tail)))))

          ;; purely concatenative
          (((name . words))
           (let ((def #`((#,def: name () words))))
             ;; (printf "~s\n" (->datum def))
             (@parsed def @tail))))))


  (define (symbol->stx-pred sym)
    (lambda (stx)
      (eq? sym (->datum stx))))

  

  ;; - anything outside of : name ... ;  is illegal
  ;; -          inside                      wrapped in a def! call

  (define (make-mode-parser def: terminator)

    (define terminator? (symbol->stx-pred terminator))
    (define parse-def (make-def-parser def:))

    (lambda (@stream)
      (let next
          ((defs @null)            
           (s (@cdr @stream)))  ;; drop mode word
           
        (cond
         ;; done
         ((@null? s)             (values defs @null))    ;; permit this
         ((terminator? (@car s)) (values defs (@cdr s)))
         
         ;; parse next def
         (else
          (let-values
              (((def tail) (parse-def s)))
            ;; (printf "D: ~a\n" (->datum (car (@unfold def))))
            (next
             (@append defs def)
             tail)))))))

                  
  

  ;; macro ... forth generates 'extension:' forms
  
  ;; other parsers / parsing modes
  (named-parser-bodies (forth)
    (macro      (make-mode-parser 'extension: 'forth)))
      
  
  ;; Reserved words: mainly just for 'load', which only makes sense in
  ;; a context where a path is specified, and is handled separately in
  ;; lex.ss, but it's also used to throws an error on some often used
  ;; commands.
  
  (define (reserved sym)
    (lambda (stream)
      (error 'reserved-word "~a" sym)))
  
  (define-syntax reserved-words
    (syntax-rules ()
      ((_ word ...)
       (named-parser-bodies
        (forth)
        (word (reserved 'word)) ...))))

  (reserved-words
   load path ping commit ul)
                            
  

  ;; PRINTING

  (define (forth->string forth)
    
    (define (forth-newline? sym)
      (case sym
        ((variable 2variable
          macro forth :) #t)
        (else #f)))

    (define forth->list
      (match-lambda
       (()      (list "\n"))
       ((s . r) (list*
                 (if (forth-newline? s) "\n" "")
                 (format "~a "
                         (if (symbol? s)
                             (symbol->string s) s))
                 (forth->list r)))))

    (apply string-append
           (let ((lst (forth->list forth)))
             (if (equal? "\n" (car lst))
                 (cdr lst) lst))))
        


  
  (define (make-sym-test x)
    (lambda (thing)
      (let ((sym (if (syntax? thing)
                     (->datum thing)
                     thing)))
        (eq? x sym))))

  ;; i need to fix emacs:
  (define semicolon '|;|)
  
  (define semicolon? (make-sym-test semicolon))
  (define bar?       (make-sym-test '\|))


  
)