;; -*- 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)
(%make-vector n val))
(define (make-vec16 n)
(%make-vec16 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)
(%%cexp ('a -> 'b) "PXLL_UNDEFINED; result = %0; goto Lreturn" 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")
(%%cexp (-> 'a) "PXLL_UNDEFINED; goto Lreturn")
)
(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) so that call/cc etc
;; will still work if inlining is turned off.
(defmacro getcc
(getcc) -> (%%cexp (-> (continuation 'a)) "k"))
(defmacro putcc
(putcc k r) -> (%%cexp ((continuation 'a) 'a -> 'b) "(k=%0, %1)" k r))
;; the '^' prefix tells the compiler to never inline this
;; function - which would not work correctly otherwise
;; (i.e., it can capture the wrong continuation...)
;; [this will be Done Better Later]
(define (^call/cc p)
(let ((k (getcc)))
(p (lambda (r) (putcc k r)))
))
;; sml-nj version
(define (^callcc p)
(p (getcc)))
(define callcc ^callcc)
(define (throw k v)
(putcc k v))
;; this won't work because it captures the wrong continuation
;; (defmacro let/cc
;; (let/cc name body ...)
;; -> (let ((k (getcc))
;; (name (lambda (r) (putcc k r))))
;; body ...))
(defmacro let/cc
(let/cc name body ...)
-> (^call/cc (lambda (name) body ...)))
;; using smlnj callcc
(defmacro letcc
(let/cc name body ...)
-> (callcc (lambda (name) body ...)))
;; avoid forcing the user to use the funky name
(define call/cc ^call/cc)
(define call-with-current-continuation ^call/cc)
;; haskell maybe /ml option
(datatype maybe (:yes 'a) (:no))
(datatype bool (:true) (:false))
(datatype symbol (:t string))
;; useful for polyvariant pairs
(define pair-first
(:pair a _) -> a)
(define pair-second
(:pair _ b) -> b)
;; 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?
;; *********************************************************************
;; 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
;; (define (make-generator producer)
;; (let ((ready #f)
;; ;; just holding useless continuations
;; (caller (call/cc id))
;; (saved-point (call/cc id)))
;; (define (entry-point)
;; (call/cc
;; (lambda (k)
;; (set! caller k)
;; (if ready
;; (saved-point #f)
;; (producer yield)))))
;; (define (yield v)
;; (call/cc
;; (lambda (k)
;; (set! ready #t)
;; (set! saved-point k)
;; (caller v))))
;; entry-point
;; ))
(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
))