#lang scheme/base

;; Primitives for the base SCAT language. This should bring the
;; language up to a point where it is useful to start writing
;; programs.


(require
 "rpn-scat.ss"   ;; scat: macro
 ;; use SCAT rpn syntax + namespace tools..
 "scat-syntax.ss"
 "../ns.ss"

 ;; ..to define/snarf functionality from
 "rep.ss"
 "../tools.ss"
 "print.ss"

 (lib "pretty.ss")

 ;; with names not to be exported tucked away here, so a simple
 ;; provide statement can be used.
 "base-utils.ss"
;;  (for-syntax  scheme/base)

 )

(provide
 ;; define-word
 (all-defined-out))


;; For debugging convenience at the command line, this is a macro
;; for defining named code. It returns the value of the defined code
;; so it fits the normal 'language:' behaviour, though has a side
;; effect.

;; This is ONLY a notational shortcut to make life easier on the
;; debug repl. Don't use it in source files!

(define-syntax define-base
  (syntax-rules ()
    ((_ name . body)
     (ns (scat) (define name (scat: . body))))))


;; DEBUG

(define-word ctrace s
  (cons
   (continuation-mark-set->list
    (current-continuation-marks)
    'word) s))



;; Interpret the rest of the code body as a scheme lambda
;; expression. This allows the use of scheme-style lambda
;; expressions as quotations.

;; (define-syntax --base/lambda
;;   (syntax-rules ()
;;     ((_ (formals . body) expr)
;;      (apply (lambda formals . body) expr))))

;; Example 'parsing word'. Transfer control back to the compiler
;; after combining a datum as a quoted immediate value.

;; (define-syntax (--base/qw stx)
;;   (syntax-case stx ()
;;     ((_ (datum . code) expr)
;;      ((rpn-next)
;;       #'code
;;       ((rpn-immediate)
;;        #'(quote datum)
;;        #'expr)))))

;; Quoting word with delegate.




;;   (define-parsing-word
;;     base/qw (word)
;;     (lambda (code expr)
;;       ((rpn-immediate (stx-cons


;; Dynamic environment constructors. These construct a unary function
;; that accepts a thunk, which can be combined with 'dynamic'. This is
;; factored so the code here doesn't need to know about the state
;; abstraction / control passing mechanism.


(define-syntax define-dynamic
  (syntax-rules ()
    ((_ name fn)
     (define-word name (thing . s)
       (make-dynamic fn thing s)))
    ((_ name)
     (define-dynamic name name))))

(define (make-dynamic fn thing s)
  (cons
   (lambda (thunk)
     (fn thing thunk)) s))

(define-dynamic with-output-to-file/safe)
;; (define-dynamic with-io-device)
  

  ;; FIXME

  
  ;; PRIMITIVES

  ;; These are language primitives that can't be directly snarfed from
  ;; scheme functions. The implementation is exposed here: we map the
  ;; input argument list to an single output list value.

  
  (define-word id     s            s)
  
  (define-word stack@ s            (list* s s))
  (define-word stack! (new . s)    new)
  (define-word stack  s            (list s))
  
  (define-word drop   (a . s)      s)
  (define-word dup    (a . s)      (list*  a a  s))
  (define-word swap   (a b . s)    (list*  b a  s))
  (define-word swap3  (a b c . s)  (list*  c b a  s))
  (define-word over   (a b . s)    (list*  b a b  s))
  (define-word rot    (a b c . s)  (list*  c a b  s))
  (define-word -rot   (a b c . s)  (list*  b c a  s))

  (define-word rot4   (a b c d . s) (list* d a b c  s))
  (define-word -rot4  (a b c d . s) (list* b c d a  s))
  
  
  (define-word uncons (pair . s)
    (list* (cdr pair) (car pair) s))

  
  (define-word cons   (kdr kar . s)   (list* (cons kar kdr) s))
  (define-word append (tail head . s) (list* (append head tail) s))
  
  
;;  (define-word union         (a b . s) (list* (lset-union eq? a b) s))
;;  (define-word intersection  (a b . s) (list* (lset-intersection eq? a b) s))
;;  (define-word difference    (a b . s) (list* (lset-difference eq? b a) s))

  (define-word and  (a b . s) (list* (if (number? a) (bitwise-and a b) (and a b)) s))
  (define-word or   (a b . s) (list* (if (number? a) (bitwise-ior a b) (or a b)) s))

  (define-word not  (a . s)   (list* (not a) s))  ;; use -1 xor for bitwise
  
  
  (define-word unlist (l . s)      (foldl cons s l))
  (define-word nil    s            (cons '() s))

  (define-word read-byte   (p . s)   (cons (read-byte-timeout p 1) s))
  (define-word write-byte  (p b . s) (write-byte b p) s)

  (define-word format (fmt l . s) (list* (apply format fmt l) s))



  (define-word lex-stream (p . stack)
    (let next ((l '()))
      (let ((thing (read p)))
        (if (eof-object? thing)
            (list* (reverse l) stack)
            (next (cons thing l))))))


  ;; DELIMITED CONTINUATIONS

  ;; NOTE: Syntactic structures can violate the premise that scat code
  ;; is concatenative. However, the shift/reset macros do not process
  ;; the code stream, so won't violate this.


  (require scheme/control)

  ;; Use a specific prompt tag so scat code has no access to the
  ;; scheme driver code that sets up the state threading.
  (define scat-prompt (make-continuation-prompt-tag 'scat-prompt))

;;  (ns (scat) (define-syntax reset (rpn-wrap (expr) #`(reset-at scat-prompt #,expr))))
            
;;  (ns (scat) (define-syntax shift (rpn-wrap (expr) #`(shift-at scat-prompt k #,((rpn-immediate) #'k expr)))))
     

  ;; DYNAMIC ENVIRONMENTS



  ;; SNARFS


  ;; These get functionality straight from scheme with minimal
  ;; hassle. below '+' means define word '+' using scheme's '+' and
  ;; (choose if) means, define word 'choose' using scheme's 'if'.
  
  (snarf as-push (scat)

;;     ((d t)    (dict-find dict-find/false dict-recursive-find))   
;;     ((d t i)  (dict-set dict-shadow dict-recursive-mute))

     
     ((a b)    (= < > >= <= + - * / modulo <<< >>>
                eq? eqv? equal?
                string-append list->table
                min max))

     ((a b)    ((xor bitwise-xor)))

     ((a)      (exp log sin cos tan 2/ 2* << sqrt))

     ;; ((path)   (ns-ls ns-ref))


     ((thing)  (symbol? number? null? procedure? string? list? pair?
                vector? eof-object? ->string))

     ((number) (round floor ceiling inexact->exact exact->inexact
               integer->char))

     ((symbol) (symbol->string))

     ((str)    (string->list string->symbol bytes->string/utf-8))
   
     ((fname)  (open-input-string open-input-file))
     ((port)   (read))     

     ((c a b)   ((choose if)))

;;     ((word)   (word-source))

     ;; For run time compilation to work, the appropriate modules need
     ;; to be loaded into the runtime compiler namespace using
     ;; 'rpn-modules'.
     
     ;; ((code compiler) (rpn-compile))
     ;; ((modules)       (rpn-modules))



     (()    (current-process-milliseconds cpm-mark))

     ((lst) (reverse flatten car caar caaar cdr cadr cddr
             list->string list->bytes eval))


     
    )

  
  ;; Side-effecting words.
  
  (snarf as-void (scat)

    ((datum)     (write display print write-tree pretty-print))
    ((s fmt)     (stack-print))
;    ((exception) ((throw raise)))
    ((filename)  (delete-file close-input-port close-output-port load))
    ((to from)   (rename-file-or-directory))

    ((word)      (print-word))
    
    )


     
  
  ;; COMPOSITE CODE

  (compositions
   (scat) scat:

   ;; (infra     reverse-infra reverse)

   ;; constants
   (true      #t)
   (false     #f)

   ;; math
   (pow       log * exp)
   
   ;; stacks & lists & vectors
   (swons     swap cons)
   (unswons   uncons swap)
   (2dup      over over)
   (nip       swap drop)
   ;; (vector    list list->vector)
   (cycle     uncons reverse cons reverse)
   (sd        stack drop)

   ;; printing
   (cr       "\n" display)
   (space    " "  display)
   (tab      "\t" display)
   (p        print space)
   (d        display space)
   (pp       pretty-print)
   
   (hs       stack@ print-stack) ;; host stack

   (print-stack " ~s" stack-print)

   ;; files
   (read-file  open-input-file   lex-stream)
   (lex-line   open-input-string lex-stream)

   

   ;; CODE / DATA


   ;; (:base     'scat: rpn-compile)   ;; source -> program
    ;; (source    word-source)          ;; get source code, discard semantics
   ;; (semantics word-semantics)


   ;; MONADS

   ;; The 'lift' operation (a.k.a. the 'map' operation) is the only
   ;; one that can be made ignorant of the monad type, given that
   ;; monad state is always implemented as the top of the data stack.

   ;; The other operations: 'join' and 'return' need to be
   ;; monad-specific. Since I don't have type classes, i'm stuck with
   ;; name tagging. But, I didn't run into uses for this.


   ;; This will only work for base syntax.
   
   ;; (lift   unrun:base (dip) compose)
   

   
   
   )

  
;; Convert a list of functions to a function.
(define (scat-compose lst)
  (apply compose (reverse lst)))