;; COMPOSITIONAL LANGUAGE VM

;; this is currently used for 2 different languages:
;; - CAT, a concatenative version of scheme.
;; - FORTH's compile time semantics.

;; the SEMANTICS of a particular language is implemented by a 'parser'
;; associated with a 'binder'. the former defines syntax, and the
;; latter symbol semantics.

;; for example, in the CAT source SEMANTICS, lists mean quoted
;; programs, which mean at parse time these programs need to be
;; explicitly quoted (by wrapping them in a lambda expression ==
;; delayed evaluation)

;; in the IMPLEMENTATION of the interpreter below, code takes two
;; forms.

;; - (lazy) primitive functions
;; - lists of such, called compositions

;; a composition is executed by successively applying all primitives
;; to a parameter stack, ensuring proper tail recursion. each
;; composition can be wrapped in a primitive.

;; instead of a primtive function, a promice can be stored in
;; composite code (program). this promise should deliver a primitive
;; function when forced. this effectively implements JIT compilation,
;; which is used to solve the problem of circular references. (in
;; addition, it can be used for a whole load of different tricks that
;; require lazy binding of functionality)

;; this duality PRIMITIVE - COMPOSITE needs to be made explicit to
;; provide proper introspection. code on CAT level (what 'run'
;; understands) is always a composition. it has the added property
;; that symbolic code maps 1-1 to quoted (compiled) code, (for FORTH
;; this is no longer the case, since it employs explicit quotation
;; words).

;; most binding (name resolution) is solved using hash
;; tables. however, the interpreter binds only VALUES, not
;; VARIABLES. this means, the behaviour of a function cannot be
;; changed at run time. you are allowed to cheat and just reload the
;; whole core with the data intact, but that's just a convenient
;; trick: when daddy's looking NAME BINDINGS ARE IMMUTABLE.



;; the core routine in the inner interpreter is 'iterate'. it is the
;; basic monadic composition operator: apply a list of things to a
;; stack.



;; INTERPRETER / COMPILER

;; this defines the basic VM for executing
;; compositional/combinatorial/concatenative/forth/... whatever you
;; want to call it.


(module vm mzscheme
  (require (lib "match.ss")
           "word.ss"
           "list-utils.ss")

  (provide (all-defined))

  ;; SFRI-1 cons*
  (define-syntax pack
    (syntax-rules ()
      ((_ a) a)
      ((_ a b more ...)
       (cons a (pack b more ...)))))

  (define-syntax unpack
    (syntax-rules ()
      ((_ pattern expr body ...) ;=>
       (apply
        (lambda pattern body ...)
        expr))))


  ;; general state accumulation with proper tail recursion

  ;; - abstract interpretation of an abstract list
  ;; - the last element is called in tail position

  (define-syntax interpret-list
    (syntax-rules ()
      ((_ interpret_        ;; abstract code interpretation
          car_ cdr_ null?_  ;; abstract list access
          lst               ;; code sequence
          state)            ;; state accumulator

       ;; evaluate once
       (let ((_interpret interpret_)
             (_car car_)
             (_cdr cdr_)
             (_null? null?_))

         (let next ((l lst)
                    (s state))
           
           (if (_null? l)
               s                                  ;; nop
               (if (_null? (_cdr l))
                   (_interpret (_car l) s)        ;; tail call
                   (next (_cdr l)                 ;; recursive call
                         (_interpret (_car l) s))
                   )))))))
  
  ;; leaf node interpreter == (delayed) scheme procedures
  (define (run-word word stack)
    (let ((proc (word->procedure word)))
      ;; (write (word-source word)) (newline)
      (apply proc stack)))


  (define (run-program code stack)
    (interpret-list run-word      ;; interpret
                    car cdr null? ;; using proper lists
                    code stack))







  ;; COMPILE & PARSE subroutines

  ;; convert a constant value into a word that that will push this value
  ;; to the parameter stack.

  (define (cs-constant item)
    (lambda stack (cons item stack)))

  (define (constant->word value)
    (atom->word value         ;; source rep
                cs-constant)) ;; shared compiler


  ;; delay parsing for quoted programs: the source rep needs to be
  ;; parsed using the parser supplied, then wrapped in a constant
  ;; quoter.

  (define (program->word parse source)
    (atom->word source
                (lambda (src)
                  (cs-constant (parse src)))))


  ;; convert a quoted parsed program (list of words) to a primitive by
  ;; associating it to the composite program interpreter.

  (define (cs-program code)
    (lambda stack (run-program code stack)))

  ;; the above needs to be wrapped in a word structure. since there is
  ;; no late binding here, we save it as a primitive. de default for
  ;; programs is quoted, so we call this 'subroutine'

  (define (subroutine->word parse source)
    (atom->word source
                (lambda (src)
                  (cs-program (parse source)))))

  ;; same as above, but include a lifter (primitive transformer)
  (define (lifted-subroutine->word lift-primitive parse source)
    (atom->word source
                (lambda (src)
                  (lift-primitive
                   (cs-program
                    (parse source))))))
  

  ;; create a composer. requires 3 argumens (register! parse find)

  ;; register!   saves target semantics (binds name -> word)
  ;; parse       convert source syntax to VM representation
  ;; find        resolves source semantics
  
  (define (make-composer register! parse . parse-args)
    (let ((compile ;; word semantics
           (lambda (source)
             (cs-program
              (apply parse `(,@parse-args ,source))))))
    
      (lambda (name body)
        ;; (display name) (display body) (newline)
        (register! name
                   (atom->word body
                               compile)))))



  ;; highlevel code. the 'def!' part can be a composer created by the
  ;; function above.

  (define-syntax compositions
    (syntax-rules ()
      ((_ register! def1 ...)
       (map (lambda (def)
              (register! (car def) (cdr def)))
            '(def1 ...)))))




  ;; symbol table

  ;; define a simbol table register word in terms of an already defined
  ;; default binder (to implement inheritance). note that proper
  ;; semantics requires names to be defined only once!

  ;; however, if you know what you're doing, you can redefine
  ;; things. code that's bound (by being executed) before a symbol
  ;; redefinition will keep it's old functionality.

  (define *symbol-tables* '())
  (define (register-symbol-table name x)
    (push! *symbol-tables* (cons name x)))

  ;; return all symbols present in a table
  (define (symbol-table-words name)
    (let ((table (assoc-ref name *symbol-tables*)))
      (if table
          (hash-table-map table
                          (lambda (key value) key))
          (raise `(symbol-table-not-found ,name)))))

  (define-syntax define-symbol-table
    (syntax-rules ()
      ((_ register! find default)
       (begin
         (printf "table: ~s\n" 'register!)
         (match-define
          (find register!)
          (let ((hash (make-hash-table))
                (deflt default))                ;; make sure we use the value!
            (register-symbol-table 'find hash)  ;; register table using 'find' name
            (list
             (lambda (name)
               (hash-table-get hash name
                               (lambda () (deflt name))))
             (lambda (name code)
               (hash-table-put! hash name code)))))))))
  )