#lang scheme/base

;; Packet Forth interface to PLT Scheme.

(require
 (lib "foreign.ss")
 (lib "etc.ss")
 )

(unsafe!)

;; PRIVIATE STUFF

(define libpf
  (let ((sys (system-type)))
  (case sys
    [(unix)
     (ffi-lib "libpf")]
    [else (error 'platform-not-supported "~a" sys)])))


(define-syntax defpf
  (syntax-rules ()
    [(_ name type ...)
     (define name
       (get-ffi-obj (regexp-replaces 'name '((#rx"-" "_")))
                    libpf (_fun type ...)))]))

(define (make-carray-type _x n)
  (make-cstruct-type
   (build-list n (lambda (i) _x))))

;; These are for inspection only! Constructors are not exported since
;; they are not legal to use: all memory management needs to be done
;; inside the VM.

(define-cstruct _pf-atom-struct
  ([next _pf-atom-struct-pointer/null]
   [type _int]
   [word _int]
   ))

(define-cstruct _pf-list-struct
  ([first _pf-atom-struct-pointer/null]
   [last  _pf-atom-struct-pointer/null]
   [elements _int]))

(define-cstruct _pf-symbol-struct
  ([s_next _pf-symbol-struct-pointer/null]
   [s_name _string/utf-8]))

;; (define-cstruct _pf-symbol ())

(define-cstruct _pf-vm-struct
  ([data-stack _pf-list-struct-pointer/null]))


(define-cpointer-type _pf-xt)
(define-cpointer-type _pf-packet)

;; NOTE: creating a packet without returning it to the VM will leak
;; memory.


(defpf pf-init _int (_list i _string) -> _void)
(define (libpf-init . args) (pf-init (length args) args))

(defpf pf-forth-vm -> _pf-vm-struct-pointer/null)
(define (pf-stack) (pf-vm-struct-data-stack (pf-forth-vm)))
(define (on-stack fn . args) (apply fn (pf-stack) args))


(defpf pf-symbol _symbol  -> _pf-symbol-struct-pointer/null)
(defpf pf-list-new -> _pf-list-struct-pointer/null)

(define-syntax-rule (def-push-list name thing)
  (defpf name _pf-list-struct-pointer/null thing -> _void))

(def-push-list pf-list-push-symbol   _pf-symbol-struct-pointer/null)
(def-push-list pf-list-push-list     _pf-list-struct-pointer/null)
(def-push-list pf-list-push-packet   _pf-packet)
(def-push-list pf-list-push-int      _int)
(def-push-list pf-list-push-float    _float)
(def-push-list pf-list-push-forth-xt _pf-xt)


(define (->inexact x)
  (if (inexact? x)
      x (exact->inexact x)))
(define (int? x)
  (and
   (exact? x)
   (not (rational? x))))

;; Push to list.
(define (push-pf-list lst args)
  (for ((x (reverse args)))
    (cond
     ((pf-xt? x)     (pf-list-push-forth-xt lst x))
     ((pf-packet? x) (pf-list-push-forth-xt lst x))
     ((symbol? x)    (pf-list-push-symbol lst (pf-symbol x)))
     ((string? x)    (pf-list-push-packet lst (pf-string x)))
     ((list? x)      (pf-list-push-list lst (make-pf-list x)))
     ((int? x)       (pf-list-push-int lst x))
     ((number? x)    (pf-list-push-float lst (->inexact x)))
     (else 'conversion-not-supported "~s" x))))

;; Construct list.
(define (make-pf-list args)
  (let ((lst (pf-list-new)))
    (push-pf-list lst args)
    lst))

(defpf pf-vm-resume _pf-vm-struct-pointer/null -> _int)
(defpf pf-vm-find   _pf-vm-struct-pointer/null
                    _pf-symbol-struct-pointer/null
                    -> _pf-xt/null)

(defpf pf-packet-stringf _string _string -> _pf-packet)
(define (pf-string str) (pf-packet-stringf "%s" str))

;; PUBLIC VM INTERFACE

;; LITERALS
(define (elements)      (on-stack pf-list-struct-elements))
(define (push x)        (on-stack push-pf-list (list x)))


;; EXECUTION
(define (resume)
  (let ((e (pf-vm-resume (pf-forth-vm))))
    (case e
      ((-129) (void))
      (else (error 'invalid-vm-error-code "~s" e)))))

(define (find/false sym)
  (pf-vm-find (pf-forth-vm) (pf-symbol sym)))
(define (find sym)
  (or (find/false sym)
      (error 'word-not-found "~s" sym)))

(define (interpret-list . code)
  (for ((x (reverse code))) (push x))
  (push (find 'interpret-list))
  (resume))

;; Macro supports unquoting, but beware that this goes through the
;; outer interpreter.  It might be interesting to define a language on
;; top of PF that uses just its list structure filled with XTs.

(define-syntax-rule (pf> . code) (interpret-list `code))


;; SCHEDULER

(define (make-cached name)
  (let* ((xt (find name)) ;; cache lookup
         (go (lambda () (push xt) (resume))))
    (go) go))

(define-syntax-rule (define-cached name)
  (define (name) (set! name (make-cached 'name))))

(define-cached schedule-poll)

;; Until a decent (pipe-based?) sync mechanism works, we just yield to
;; the scheduler in the plt/pf thread, which will call us back once
;; per scheduling cycle.
(define (spawn-poll)
  (define (loop) (schedule-poll) (loop))
  (thread loop))


;; INITIALIZE

;; Default init runs script/plt.pf which installs a repl around c-yield.
(libpf-init "plt-scheme" "plt.pf")
;; (pf> : interactive "interactive mode disabled" p cr)



;; TEST
;;(define (test) (pf> 1 2 + p cr))

(define (test)
  (pf> "../demo/ca.pf" load)
  (spawn-poll))