;; the CAT language. modeled after the one in brood.

;; TODO:
;; - control structures: for each?
;; - bring over library code


(module catcomp mzscheme

  (require-for-syntax
   (lib "match.ss"))
  
  (require
   (lib "match.ss")
   "list-utils.ss"
   "binary-utils.ss"
   "io-utils.ss"
   "word.ss"
   "dict.ss"
   "vm.ss"
   "writer.ss"
   )

  (provide (all-defined))

  ;; PARSER / COMPILER


  ;; convert a list of symbolic code to internal representation. leaves
  ;; the symbols intact since they will be compiled using the jit
  ;; compiler. this basicly changes all sublists into quoted code using
  ;; a lambda abstraction, and freezes the lexical environment.

  ;; note: parse creates a NEW list, this means that the original
  ;; symbolic code is completely decoupled from the parsed one (which
  ;; will be compiled in-place later)

  ;; note: the parser is a 'map'. this is one of the important features
  ;; of CAT: compiled code has a 1-1 correspondence to symbolic code:
  ;; there are no "parsing words".


  ;; these 2 are factored out so they can be used in similar parsers
  (define (quote? thing)
    (match thing
           (('quote x) x)
           (else #f)))

  ;; the compiler for symbols looks up the word in the environment
  ;; defined by the finite function 'find', and forces it to reveal its
  ;; implementation.

  (define (find->cs find)
    (lambda (sym) (word->procedure (find sym))))
      

  ;; create parser body with abstract prototype
  (define (cat-parse find comp)
    (let ((cs-cat (find->cs find)))   ;; symbol semantics
      (let parse ((composition comp)) ;; bind 'parse' for delayed parsing

        (define (parse-atom atom)
          (cond
           
           ;; make sure that parsing (compilation) is idempotent
           ((word? atom) atom)
           
           ;; lisp style quote?
           ((quote? atom) => constant->word)
           
           ;; quoted program -> delay parsing
           ((list? atom) 
            (program->word parse atom))
           
           ;; symbols will later be JIT compiled.
           ((symbol? atom)
            (atom->word atom cs-cat))
           
           ;; all the rest is quoted
           (else
            (constant->word atom))))

        (map parse-atom composition))))


  ;; default cat parser
  (define (cat-parse-default code)
    (cat-parse cat-find code))

  
  ;; SYMBOL TABLE

  ;; root and register this is a bit convoluted (value vs. toplevel
  ;; variable). maybe switch back to a simple stack and assoc?


  (define (cat-find-default name)
    (raise `(undefined ,name)))

  (define-symbol-table
    cat-register!
    cat-find
    cat-find-default)

  ;; shortcut, since it's used a lot
  (define cat!
    (make-composer  cat-register!
                    cat-parse
                    cat-find))


  ;; PRIMITIVES

  ;; convert a scheme function to a machine primitive
  (define-for-syntax stx->d syntax-object->datum)
  (define-for-syntax d->stx datum->syntax-object)


  ;; NOTE: care needs to be taken that snarfed names are evaluated in
  ;; the right name space: see cat-snarfs (let ((fn-val val)) ...
    
  (define-syntax snarf-lambda
    (lambda (stx)
      (match
       (stx->d stx)
       ((_ args fn)
        (d->stx stx
               `(lambda (,@(reverse args) . stack)
                  (cons (,fn ,@args) stack)))))))


  (define-syntax cat-register-primitive!
    (syntax-rules ()
      ((_ name fn-expr)
       (cat-register!
        'name
        (procedure->word 'name
                         (let ((name   ;; for error reporting name inference
                                fn-expr))
                           name))))))

  ;; virtual machine primitive in toplevel cat dict
  (define-syntax define-word
    (syntax-rules ()
      ((_ name formals body ...)
       (cat-register-primitive! name
                                (lambda formals body ...)))))

  (define-syntax cat-snarfs
    (syntax-rules (row)
      ((_ row formals (fn ...))  ;; expand columns
       (begin
          (let ((fn-val fn))
            (cat-register-primitive!
             fn
             (snarf-lambda formals fn-val)))
          ...))
      
      ((_ (formals fns) ...)     ;; expand rows
       (begin
         (cat-snarfs row formals fns) ...))))



)