forth/parser-tx.ss
#lang scheme/base


(provide
 forth-tx
 macro-tx
 
 :-tx
 :forth-tx
 :macro-tx
 create-tx

 load-tx
 require-tx
 provide-tx
 open-paren-tx
 close-paren-tx

 open-sexp-tx

 forth-toplevel-forms

 ;; forth-quoter
 forth->records
 forth-rules
 ;; forth->nested-dictionaries
 )

(require
 "../tools.ss"
 "../tools-tx.ss"
 "../scat-tx.ss"
 "locals-tx.ss"
 "lexer.ss"         ;; for load-tx
 scheme/control
 syntax/stx
 scheme/pretty
 (for-template
  (lib "match.ss")
  "../scat.ss"
  scheme/base))

;; Parsing words are defined in the transformer environment, and
;; implemented as binary function that behave similar to 'next' in
;; rpn-tx.ss. Delegate can be an expression. If it's an identifier
;; it's mapped.

;; NOTE: this is a bit of a mess: a mix of threaded state (the way the
;; rpn parser works) and some side effects to parameters to perform
;; Forth dictionary bookkeeping. Maintenance of the 'there is always a
;; current definition' invariant is not in a single point.

;; UTIL


;; Syntax-rules equivalent for forth code.
(define-sr (forth-rules (literals ...)
                        ((pattern ...) (template ...)) ...)
  (lambda (stx expr)
    (syntax-case stx (literals ...)
      ((pattern ... . code+)
       ((rpn-next) #`(template ... . code+) expr)) ...)))




;; MODES

;; The RPN transformers 'macro' and 'forth' will switch compilation
;; mode between macros and forth words. The latter are instantiated
;; macros. The mode information is used as a field in dictionary
;; records.

(define current-mode (make-parameter #f))
(define forth-mode (make-parameter #f))
(define macro-mode (make-parameter #f))
(define variable-mode (make-parameter #f))


(define (mode-tx mode)
  (lambda (code expr)
    (current-mode (mode))
    ;; Mode switch terminates a definition.
    ((finalize-current) expr)
    (init-record)
    (collect-next (stx-cdr code))))

(define macro-tx (mode-tx macro-mode))
(define forth-tx (mode-tx forth-mode))

(define (temp sym)
  (car (generate-temporaries (list sym))))


(define (stx-srcloc stx)
  #`(list #,(syntax-source stx)
          #,(syntax-line stx)
          #,(syntax-column stx)
          #,(syntax-position stx)
          #,(syntax-span stx)))


;; DEFINITIONS

;; Note: the scat parser is designed to parse delimited definitions:
;; one syntax list per code quotation. In Forth syntax however,
;; multiple definitions are encoded in a single syntax list. Therefore
;; a parameter is used to accumulate the definitions.


;; Record current definition information, waiting for an expression to
;; be completed. This is called at the start of a definition.
(define (new-record name mode loc)
  ;; (printf "N: ~a ~a ~a\n" name mode loc)
  (finalize-current
   (lambda (expr)
     (register-record
      #`(#,name #,mode #,loc
                #,(rpn-close-expression expr)))
     (finalize-current no-record))))

(define (no-record expr) (error 'no-current-record))
(define finalize-current (make-parameter no-record))

;; Start accumulating a nested expression.
(define (collect-next code)
  ((rpn-next) code (rpn-state)))

;; Definers terminate the previous definition and create a header for
;; the next one.
(define (definer mode)
  (lambda (code expr)
    ((finalize-current) expr)
    (syntax-case code ()
      ((_ name . code+)
       (new-record #'name
                   (mode)
                   (stx-srcloc #'name))
       (collect-next #'code+)))))


(define :-tx         (definer current-mode))

;; modeless
(define create-tx    (definer variable-mode))
(define :macro-tx    (definer macro-mode))
(define :forth-tx    (definer forth-mode))


;; Top driver for parsing forth syntax. Results are accumulated in
;; dynamic parameters: no threaded state here.

(define forth-toplevel-forms (make-parameter '()))
(define forth-records (make-parameter '()))

(define (register-toplevel x)
  (forth-toplevel-forms
   (cons x (forth-toplevel-forms))))

(define (register-record x)
  ;; (printf "R: ~a\n" (syntax->datum x))
  (forth-records
   (cons x (forth-records))))

;; START PARSING

(define (forth->records forth variable macro
                        forth-definitions)
  (parameterize
      ((forth-mode forth)
       (variable-mode variable)
       (macro-mode macro)
       (current-mode forth)

       (forth-records '()))

    ;; Start parsing effectively by calling represent directly
    ;; (effecitvely prefixing the code with ': #f'). This will
    ;; accumulate toplevel scheme forms and forth records in the
    ;; dynamic parameters.

    (rpn-init ;; We don't use rpn-compile but call rpn-next directly,
              ;; so have to call initializer manually upon entry.
     (lambda ()
       (init-record)
       (let-values
           (((_ last)  ;; _ should be empty
             (collect-next forth-definitions)))
         ((finalize-current) last))
       (let ((records (reverse (forth-records))))
         ;; (pretty-print (map syntax->datum records))
         records)))))
           
(define (init-record [mode current-mode])
  (new-record #f (mode) #f))



;; NESTING

;; In Forth syntax without s-expressions, there is no nesting
;; mechanism: (rpn-next) only returns at the end of the input
;; stream. However, implementing parsers that use scheme function
;; nesting can be done using prompt tags.

(define abort/cc abort-current-continuation)
(define (make-until tag)
  (lambda (code expr)
    ;; (printf "UNTIL: ~a\n" tag)
    (abort/cc tag
              (lambda ()
                (values (stx-cdr code) expr)))))

(define (next-until tag code expr)
  (prompt-at tag
             ((rpn-next) code expr)
             ;; It's not legal to leave nested context by falling off
             ;; the end of a code list.
             (error 'non-terminated-parser-nesting "~a" tag)))


;; CODE QUOTATION

;; Flat code quotation. This is the same as using lists in the
;; s-expression syntax. The open paren relies on the close paren to
;; terminate the current expression, and quotes it as a program. Note
;; that because interpret-mode is not used, the square brackets can be
;; used to perform quotation.

(define code-quotation
  (make-continuation-prompt-tag 'code-quotation))

(define (open-paren-tx code exp)
  (let-values
      (((code+ body)
        (next-until code-quotation
                    (stx-cdr code) (rpn-state))))
    ((rpn-next)
     code+
     ((rpn-immediate)
      (rpn-close-expression body)
      exp))))

(define close-paren-tx (make-until code-quotation))


;; FILE INCLUDE

;; Loading forth code sets the current load handler so path tracking
;; can be handled automatically.

(define load-end (make-continuation-prompt-tag 'load))
  
(define (load-tx code expr)
  (syntax-case code ()
    ((_ file . code+)
     (call-with-values
         (lambda ()
           (parameterize
               ;; Continue parsing inside load handler: this makes
               ;; sure load-relative path is set correctly.
               ((current-load
                 (lambda (path module-name)
                   (next-until load-end
                               (append
                                ;; Make sure lexical context is right.
                                (file->forth-syntax #'file path)
                                (list (make-until load-end))
                                #'code+)
                               expr))))
             (let ((dfile (syntax->datum #'file)))
               (load-relative
                (if (symbol? dfile)
                    (symbol->string dfile) dfile)))))

       ;; When the 'load-end' marker is encountered, parsing escapes
       ;; the dynamic context entered by 'load-relative'.
       (rpn-next)))))


     

;; S-EXPRESSIONS

;; Scheme s-expressions are moved to toplevel.
(define (open-sexp-tx code exp)
  (define open (string->symbol "{"))
  (define close (string->symbol "}"))

  (define (collect stx-list)
    (let next ((l '())
               (s stx-list))
      (cond
       ((null? s)
        (error 'sexp-error))
       ((eq? open (syntax->datum (car s)))
        (let-values
            (((list rest) (collect (cdr s))))
          (next (cons list l)
                rest)))
       ((eq? close (syntax->datum (car s)))
        (values
         (reverse l)
         (cdr s)))
       (else
        (next (cons (car s) l)
              (cdr s))))))


  (let-values (((list code+)
                (collect (stx-cdr code))))
    (register-toplevel list)
    ((rpn-next) code+ exp)))



;; TOPLEVEL EXPRESIONS
              
(define (require-tx code expr)
  (syntax-case code ()
    ((_ module . code+)
     (register-toplevel
      `(require ,(symbol->string
                  (syntax->datum #'module))))
     ((rpn-next) #'code+ expr))))

(define (provide-tx code expr)
  (syntax-case code ()
    ((_ name . code+)
     (register-toplevel
      `(provide ,#'name))
     ((rpn-next) #'code+ expr))))