;; -*- Mode: Irken -*-

(define (printn x)
  (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x))

(define (print x)
  (%%cexp ('a -> undefined) "dump_object (%0, 0)" x))

(define (print-string s)
  (%%cexp (string int -> undefined) "(fwrite (%0, 1, %1, stdout), PXLL_UNDEFINED)" s (string-length s)))

;; original version returns how many chars were written...
(define (print-string* s)
  (%%cexp (string int -> int) "fwrite (%0, 1, %1, stdout)" s (string-length s)))

(define (print-char ch)
  (%%cexp (char -> int) "fputc (GET_CHAR(%0), stdout)" ch))

(define (terpri)
  (print-char #\newline))

(define newline terpri)

(define (= a b)
  (%%cexp (int int -> bool) "%0==%1" a b))

(define (zero? a)
  (%%cexp (int -> bool) "%0==0" a))

(define (< a b)
  (%%cexp (int int -> bool) "%0<%1" a b))

(define (<= a b)
  (%%cexp (int int -> bool) "%0<=%1" a b))

(define (> a b)
  (%%cexp (int int -> bool) "%0>%1" a b))

(define (>= a b)
  (%%cexp (int int -> bool) "%0>=%1" a b))

(define (>0 a)
  (%%cexp (int -> bool) "%0>0" a))  

(define (<0 a)
  (%%cexp (int -> bool) "%0<0" a))  

(define (+ a b)
  (%%cexp (int int -> int) "%0+%1" a b))

(define (- a b)
  (%%cexp (int int -> int) "%0-%1" a b))

(define (* a b)
  (%%cexp (int int -> int) "%0*%1" a b))

(define (/ a b)
  (%%cexp (int int -> int) "%0/%1" a b))

(define (remainder a b)
  (%%cexp (int int -> int) "%0 %% %1" a b))

(define (<< a b)
  (%%cexp (int int -> int) "%0<<%1" a b))

(define (>> a b)
  (%%cexp (int int -> int) "%0>>%1" a b))

(define (bit-get n i)
  (%%cexp (int int -> bool) "(%0&(1<<%1))>0" n i))

(define (bit-set n i)
  (%%cexp (int int -> int) "%0|(1<<%1)" n i))

;; any reason I can't use the same characters that C does?
;; yeah - '|' is a comment start character in scheme.
(define (logior a b)
  (%%cexp (int int -> int) "%0|%1" a b))

(define (logxor a b)
  (%%cexp (int int -> int) "%0^%1" a b))

(define (logand a b)
  (%%cexp (int int -> int) "%0&%1" a b))

(define (lognot a b)
  (%%cexp (int int -> int) "%0~%1" a b))

(define (min x y)
  (if (< x y) x y))

(define (max x y)
  (if (> x y) x y))

(define (abs x) (if (< x 0) (- 0 x) x))

(define (eq? a b)
  (%%cexp ('a 'a -> bool) "%0==%1" a b))

(define (not x)
  (eq? x #f))

(define (char=? a b)
  (%%cexp (char char -> bool) "%0==%1" a b))

(define (string-length s)
  (%%cexp ((raw string) -> int) "%0->len" s))

(define (make-vector n val)
  (%ensure-heap #f n)
  (%make-vector #f n val))

;; (define (make-vec16 n)
;;   ;; XXX ensure-heap here
;;   (%make-vec16 #f n))

(define (vector-length v)
  (%%cexp
   ((vector 'a) -> int)
   "(%0 == (object*) TC_EMPTY_VECTOR) ? 0 : GET_TUPLE_LENGTH(*%0)" v))

(define (address-of ob)
  (%%cexp ('a -> int) "(pxll_int)%0" ob))

;; this is a little harsh. 8^)
;; think of it as a placeholder for something better to come.
(define (error x)
  (print-string "\n***\nRuntime Error, halting: ")
  (printn x)
  (%exit #f x)
  )

(define (error1 msg ob)
  (newline)
  (print-string msg)
  (print-string " ")
  (error ob))

(define (error2 msg ob0 ob1)
  (newline)
  (print-string msg)
  (print-string "\n\t")
  (print ob0)
  (print-string "\n\t")
  (print ob1)
  (print-string "\n")
  (%exit #f #u)
  )

(define (impossible)
  (error "Why, sometimes I've believed as many as six impossible things before breakfast."))

(define (id x) x)

;; these must be macros (rather than functions) in order to inline them.
;; Note that outside of callcc and throw, these are not necessarily type-safe.
(defmacro getcc
  (getcc) -> (%getcc #f))

(defmacro putcc
  (putcc k r) -> (%putcc #f k r))

;; type-safe callcc & throw from sml/nj. See "Typing First-Class Continuations in ML", Duba, Harper & McQueen.
;; http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.22.1725
(define (callcc p) : (((continuation 'a) -> 'a) -> 'a)
  (p (getcc)))

(define (throw k v)
  (putcc k v))

(defmacro letcc
  (letcc name body ...)
  -> (callcc (lambda (name) body ...)))

(defmacro let/cc
  (let/cc name body ...)
  -> (callcc
      (lambda ($k)
	(let ((name (lambda ($val)
		      (throw $k $val))))
	  body ...))))

;; haskell maybe /ml option
(datatype maybe (:yes 'a) (:no))
(datatype bool (:true) (:false))
;;(datatype symbol (:t string int))

;; useful for polyvariant pairs
(define pair->first
  (:pair a _) -> a)
(define pair->second
  (:pair _ b) -> b)

(define maybe?
  (maybe:yes _) -> #t
  (maybe:no)    -> #f
  )

;; ocaml's Obj.magic
(define (magic x)
  (%%cexp ('a -> 'b) "%0" x))

;; world save/load
;; is this is a big restriction - requiring that the thunk return an int?
;; Note: <thunk> isn't really a thunk because there's no way to cast away the
;; argument from call/cc.

(define (dump filename thunk)
  (%%cexp (string ('a -> int) -> int) "dump_image (%0, %1)" filename thunk))

(define (load filename)
  (%%cexp (string -> ('a -> int)) "load_image (%0)" filename))

;; *********************************************************************
;; VERY IMPORTANT LESSON: do not *ever* make a generator that doesn't
;;   have an infinite loop at the end.  Very Weird Shit happens, and
;;   you'll waste two days trying to figure out how the compiler is
;;   borken.
;; I suppose I could build such a thing into make-generator? Maybe force
;;   the user to pass in an end-of-stream object?
;; Better idea: use a "maybe" object.  That way we don't have to
;;   invent a value to act as a sentinel, which won't work for some
;;   types - e.g. bools.
;; *********************************************************************

;; based on:
;;   http://list.cs.brown.edu/pipermail/plt-scheme/2006-April/012418.html
;;  urgh, they've broken that link now.  try this instead:
;;   http://hkn.eecs.berkeley.edu/~dyoo/plt/generator/
;;  this might be the original message:
;;  http://list.cs.brown.edu/pipermail/plt-scheme/2006-April/012456.html

;; this simpler version uses getcc and putcc directly.
(define (make-generator producer)
  (let ((ready #f)
        ;; holding useless continuations
        (caller (getcc))
        (saved-point (getcc))
        )
    (define (entry-point)
      (set! caller (getcc))
      (if ready
          (putcc saved-point #u)
          (producer yield)))
    (define (yield v)
      (set! saved-point (getcc))
      (set! ready #t)
      (putcc caller v))
    entry-point
    ))

;; We use polymorphic variants for exceptions.
;; Since we're a whole-program compiler there's no need to declare
;; them - though I might could be convinced it's still a good idea.
;;
;; Exception data must be monomorphic to preserve type safety.
;;
;; <try> and <raise> are implemented as macros, with one extra hitch:
;;  two special compiler primitives are used to check that exception
;;  types are consistent: %exn-raise and %exn-handle

;; consider catching OSError here and printing strerror(errno):
;; (copy-cstring (%%cexp (-> cstring) "strerror (errno)"))))

(define (base-exception-handler exn) : ((rsum 'a) -> 'b)
  (error1 "uncaught exception" exn))

(define *the-exception-handler* base-exception-handler)

(defmacro raise
  (raise exn) -> (*the-exception-handler* (%exn-raise #f exn))
  )

;; TODO:
;; * might be nice to have exceptions automatically capture __LINE__ and __FILE__
;; * have the compiler keep a map of the names of exceptions so that uncaught
;;   ones are reported in a useful way.  [another approach might be to auto-generate
;;   the base exception handler to catch and print the names of all known exceptions]

(defmacro try
  ;; done accumulating body parts, finish up.
  (try (begin body0 ...) <except> exn-match ...)
  -> (callcc
      (lambda ($exn-k0)
        (let (($old-hand *the-exception-handler*))
          (set!
           *the-exception-handler*
           (lambda ($exn-val)
             (set! *the-exception-handler* $old-hand)
             (throw $exn-k0
              (%exn-handle #f $exn-val
               (match $exn-val with
                 exn-match ...
                 _ -> (raise $exn-val))))))
          (let (($result (begin body0 ...)))
            (set! *the-exception-handler* $old-hand)
            $result))))
  ;; accumulating body parts...
  (try (begin body0 ...) body1 body2 ...) -> (try (begin body0 ... body1) body2 ...)
  ;; begin to accumulate...
  (try body0 body1 ...)                   -> (try (begin body0) body1 ...)
  )

(cinclude "sys/errno.h")

(define (syscall retval)
  (if (< retval 0)
      (raise (:OSError (%%cexp (-> int) "errno")))
      retval))