(*
 * Abstype lispVal is a complete data abstration for Lisp values.  It has a
 * hidden rep, with alternatives for the atomic Lisp types, and a recursive rep
 * component for Lisp lists.  It provides public ops for the Lisp basics,
 * including car, cdr, cons, and more.
 *)

use "streams.ml";

abstype lispVal =
    T |                 (* Lisp t as an ML enumeration literal *)
    NIL |               (* Lisp nil as an ML enumeration literal *)
    N of int |          (* Lisp number as an ML int (who cares about reals)*)
    S of string |       (* Lisp string as an ML string *)
    A of string |       (* Lisp symbolic atom as an ML string *)
    L of lispVal list   (* Lisp list as an ML list *)
with
    (*
     * One of the following three exceptions may occur during lispVal read.
     *)
    exception MissingDoubleQuote
    exception TooManyRightParens
    exception TooFewRightParens

    (*
     * Lisp nil is called "lnil" to avoid conflict with ML's nil.
     *)
    val lnil = NIL

    (*
     * Basic Lisp ops follow.  I.e., car, cdr, cons, etc.
     *)
    fun car(L(x)) = hd(x) |
	car(x) = lnil

    fun cdr(L(x::y)) = L(y) |
	cdr(x) = lnil

    fun cons(x, L(y)) = L(x::y) |
	cons(x, y) = lnil

    fun caar(x) = car(car(x))
    fun cadr(x) = car(cdr(x))
    fun caddr(x) = car(cdr(cdr(x)))
    fun cadddr(x) = car(cdr(cdr(cdr(x))))
    fun cddr(x) = cdr(cdr(x))
    fun cdddr(x) = cdr(cdr(cdr(x)))
    fun cddddr(x) = cdr(cdr(cdr(cdr(x))))

    fun eq(x:lispVal, y) = x = y

    fun lnull(NIL) = true |	(* as with nil, we prefix to avoid redef *)
	lnull(x) = false

    fun numberp(N(x)) = true |
	numberp(x) = false

    fun stringp(S(x)) = true |
	stringp(x) = false

    fun atom(A(x)) = true |
	atom(x) = false

    fun list(x) = L(x)

    fun assoc(name, alist) =
	if lnull(alist) then
	    lnil
	else if eq(name, caar(alist)) then
	    car(alist)
	else
	    assoc(name, cdr(alist))

    fun plus(N(x), N(y)) = N(x + y) |
	plus(x, y) = NIL

    fun minus(N(x), N(y)) = N(x - y) |
	minus(x, y) = NIL

    fun terpri() = print("\n")

    fun princ1(nil) = print("") |
        princ1(x::nil) = princ(x) |
        princ1(x::xs) = (princ(x); print(" "); princ1(xs))
      and
        princ(T) = print("T") |
        princ(NIL) = print("NIL") |
        princ(N(x)) = print(x) |
        princ(S(x)) = (print("\""); print(x); print("\"")) |
        princ(A(x)) = print(x) |
	princ(L(x)) = (print("("); princ1(x); print(")"))
(*
	princ(L(A("quote")::x)) = (print("'"); princ1(x)) |
	princ(L(A(a)::x)) = (print(a); print(" "); princ1(x)) |
        princ(L(x::nil)) = (print("("); princ(x); print(")")) |
        princ(L(x::y)) = (print("("); princ(x); princ1(y); print(")"))
 *)

    fun lprint(x) =
	(terpri();
	 princ(x))

    fun saneprint(x) =
	(princ(x);
	 terpri())


    (*
     * From here to the end of the abstype is the reader and its aux functions.
     *)

    fun iswhite(c) =
	(c = " ") orelse (c = "\t") orelse (c = "\n")

    fun isbreak(c) =
	iswhite(c) orelse (c = "(") orelse (c = ")")

    fun isdigit(c) =
	let
	    val d = ord(c) - 48
	in
	    (d >= 0) andalso (d <= 9)
	end

    fun moveOverWhitespace(l) =
	if snull(l) then
	    snil
	else if iswhite(shd(l)) then
	    moveOverWhitespace(stl(l))
	else
	    l

    fun sreadstring(l, result) =
	if snull(l) then
	    raise MissingDoubleQuote
	else if shd(l) = "\"" then
	    (stl(l), result)
	else
	    sreadstring(stl(l), result ^ shd(l))

    fun sreadatom1(l, num, str, isnum) =
        if (snull(l)) orelse (isbreak(shd(l))) then
	    (l, num, str, isnum)
	else
	    let
		val char = shd(l)
		val rest = stl(l)
	    in
		if isdigit(char) andalso (str = "") then
		    sreadatom1(rest,
			num * 10 + (ord(char) - 48), str ^ char, true)
		else
		    sreadatom1(rest, 0, str ^ char, false)
	    end

    fun sreadatom(l) =
	let
	    val (l, num, str, isnum) = sreadatom1(l, 0, "", true)
	in
	    if isnum then
		(l, N(num))
	    else
	        if (str = "t") orelse (str = "T") then
		    (l, T)
		else if (str = "nil") orelse (str = "NIL") then
		    (l, NIL)
		else
		    (l, A(str))
	end

    fun sread1(l) =
	let
	    val l = moveOverWhitespace(l)
	in
	    if snull(l) then
		(snil, NIL)
	    else if shd(l) = "'" then
		quoteit(stl(l))
	    else if shd(l) = "\"" then
		let
		    val (l, result) = sreadstring(stl(l), "")
		in
		    (l, S(result))
		end
	    else if shd(l) = "(" then
		let
		    val (l, result) = sreadlist(stl(l), nil)
		in
		    (l, L(result))
		end
	    else if shd(l) = ")" then
		raise TooManyRightParens
	    else
		sreadatom(l)
	end

    and quoteit(l) =
	let
	    val (l, result) = sread1(l)
	in
	    (l, L[A("quote"), result])
	end

    and sreadlist(l, result) =
	if snull(l) then
	    raise TooFewRightParens
	else if iswhite(shd(l)) then
	    sreadlist(moveOverWhitespace(l), result)
	else if shd(l) = ")" then
	    (stl(l), result)
	else
	    let
		val (l, newresult) = sread1(l)
	    in
		sreadlist(l, result @ [newresult])
	    end

    fun sread0(l, result) =
	if snull(l) then
	    (l, result)
	else
	    let
		val (l, newresult) = sread1(l)
	    in
		sread0(l, result @ [newresult])
	    end

    (*
     * Convert a whitespace-separated string of Lisp values into a list of
     * lispVals.  E.g., convert
     *
     *	    "a 10 \"x\" (a b c) t"
     *
     * into
     *
     *	    [ A("a"), N(10), S("x"), L[A("a"), A("b"), A("c")], T ]
     *)
    fun sread(s: string): lispVal list =
	#2(sread0(sstream(s), nil))

    (*
     * Read an entire file into a string list, a la sread.
     *)
    fun fread(filename): lispVal list =
        #2(sread0(fstream(filename), nil))

    (*
     * Here's Lisp's actual read, i.e., read a Lisp val from stdin. 
     *)
    fun read() = 
	#2(sread1(stl(std_in_stream)))

    fun isGoodbye(result) =
	result = #2(sread1(sstream("(bye)"))) orelse
	    (lnull(result) andalso
		end_of_stream(std_in))

    fun read_print_loop() =
	while true do (
	    print("MLX>");
	    flush_out(std_out);
	    let
		exception LispDone;
		val result = read()
	    in
		princ(result);
		print("\n");
		flush_out(std_out);
		if isGoodbye(result) then (
		    print("Bye.\n");
		    raise LispDone
		)
		else (
		    print("\n");
		    flush_out(std_out)
		)
	    end handle
		MissingDoubleQuote => print("Missing double quote.\n\n") |
		TooManyRightParens => print("Too many right parens.\n\n") |
		TooFewRightParens => print("Too few right parens.\n\n")
	)

end;

fun tester() =
    let
	val l =
	    hd(sread("( 10 20 x \"hi there\" t y (30 40 50 (60 70)) nil 80 )"))
    in
	(saneprint(car(l));
	saneprint(cdr(l));
	eq(cons(car(l), cdr(l)), l);
	saneprint(car(cdr(car(cdr(cdr(cdr(car(cdr(cdr(cdr(cdr(cdr(cdr(l
								))))))))))))));

	saneprint(hd(tl(sread("''a '(a b ''''c)")))))
    end;

tester();