diff --git a/impls/sml/Makefile b/impls/sml/Makefile index 3be1a17d..4964ab04 100644 --- a/impls/sml/Makefile +++ b/impls/sml/Makefile @@ -1,10 +1,13 @@ -STEP_BINS = step0_repl +STEP_BINS = step0_repl step1_read_print all: $(STEP_BINS) step0_repl: step0_repl.mlb step0_repl.sml main.sml mlton -output $@ $< +step1_read_print: step1_read_print.mlb step1_read_print.sml reader.sml printer.sml types.sml util.sml + mlton -output $@ $< + clean: rm -f $(STEP_BINS) diff --git a/impls/sml/printer.sml b/impls/sml/printer.sml new file mode 100644 index 00000000..b23beb7e --- /dev/null +++ b/impls/sml/printer.sml @@ -0,0 +1,6 @@ +fun prStr NIL = "nil" + | prStr (SYMBOL s) = s + | prStr (BOOL true) = "true" + | prStr (BOOL false) = "false" + | prStr (INT i) = if i > 0 then Int.toString i else "-" ^ (Int.toString (Int.abs i)) + | prStr (LIST l) = "(" ^ (String.concatWith " " (map prStr l)) ^ ")" (* N.B. not tail recursive *) diff --git a/impls/sml/reader.sml b/impls/sml/reader.sml new file mode 100644 index 00000000..18f7e51d --- /dev/null +++ b/impls/sml/reader.sml @@ -0,0 +1,122 @@ +structure Ss = Substring + +datatype token = + SPACE + | COMMENT of string + | BRACKET_LEFT | BRACKET_RIGHT + | BRACE_LEFT | BRACE_RIGHT + | PAREN_LEFT | PAREN_RIGHT + | QUOTE | BACK_TICK | TILDE | TILDE_AT + | CARET + | AT + | ATOM of string + +fun tokenString SPACE = "SPACE" + | tokenString (COMMENT s) = "COMMENT (" ^ s ^ ")" + | tokenString BRACKET_LEFT = "BRACKET_LEFT" + | tokenString BRACKET_RIGHT = "BRACKET_RIGHT" + | tokenString BRACE_LEFT = "BRACE_LEFT" + | tokenString BRACE_RIGHT = "BRACE_RIGHT" + | tokenString PAREN_LEFT = "PAREN_LEFT" + | tokenString PAREN_RIGHT = "PAREN_RIGHT" + | tokenString QUOTE = "QUOTE" + | tokenString BACK_TICK = "BACK_TICK" + | tokenString TILDE = "TILDE" + | tokenString TILDE_AT = "TILDE_AT" + | tokenString CARET = "CARET" + | tokenString AT = "AT" + | tokenString (ATOM s) = "ATOM (" ^ s ^ ")" + +exception SyntaxError of string +exception ReaderError of string + +datatype reader = READER of token list + +fun next (READER (x::xs)) = SOME (x, READER xs) + | next r = NONE + +fun peek (READER (x::_)) = SOME x + | peek r = NONE + +fun rest (READER (_::xs)) = READER xs + | rest r = raise ReaderError "out of tokens" + +fun findSpecial #"[" = SOME BRACKET_LEFT + | findSpecial #"]" = SOME BRACKET_RIGHT + | findSpecial #"(" = SOME PAREN_LEFT + | findSpecial #")" = SOME PAREN_RIGHT + | findSpecial #"{" = SOME BRACE_LEFT + | findSpecial #"}" = SOME BRACE_RIGHT + | findSpecial #"'" = SOME QUOTE + | findSpecial #"`" = SOME BACK_TICK + | findSpecial #"~" = SOME TILDE + | findSpecial #"^" = SOME CARET + | findSpecial #"@" = SOME AT + | findSpecial _ = NONE + +fun scanSpace ss = + let fun isSpace c = Char.isSpace c orelse c = #"," + val (tok, rest) = Ss.splitl isSpace ss in + if Ss.isEmpty tok then NONE else SOME (SPACE, rest) + end + +fun scanComment ss = + if Ss.isPrefix ";" ss + then SOME (Ss.slice (ss, 1, NONE) |> Ss.string |> COMMENT, + Ss.slice (ss, Ss.size ss, SOME 0)) + else NONE + +fun scanSpecial ss = + if Ss.isPrefix "~@" ss + then SOME (TILDE_AT, Ss.slice (ss, 2, NONE)) + else let fun findToken (c, rest) = findSpecial c |> Option.map (fn t => (t, rest)) in + Option.composePartial (findToken, Ss.getc) ss + end + +fun scanAtom ss = + let fun isAtomChar c = Char.isGraph c andalso (findSpecial c = NONE) + val (tok, rest) = Ss.splitl isAtomChar ss in + if Ss.isEmpty tok then NONE else SOME (ATOM (Ss.string tok), rest) + end + +fun scanToken ss = + let val scanners = [scanSpace, scanComment, scanSpecial, scanAtom] + val findScanner = List.find (fn f => isSome (f ss)) + fun applyScanner s = s ss + in + Option.composePartial (applyScanner, findScanner) scanners + end + +fun tokenize s = + s |> Ss.full + |> tokenize' [] + |> List.filter (fn x => x <> SPACE) + |> takeWhile (fn COMMENT _ => false | _ => true) +and tokenize' acc ss = + case scanToken ss of + SOME (token, rest) => tokenize' (token::acc) rest + | NONE => rev acc + +fun makeAtom "nil" = NIL + | makeAtom "true" = BOOL true + | makeAtom "false" = BOOL false + | makeAtom s = case Int.fromString s of SOME i => INT i | NONE => SYMBOL s + +fun readAtom r = + case next r of + SOME (ATOM a, r') => (makeAtom a, r') + | SOME (token, _) => raise SyntaxError ("unexpected token reading atom: " ^ (tokenString token)) + | NONE => raise SyntaxError "end of input reached when reading atom" + +fun readList acc r = + if peek r = SOME PAREN_RIGHT + then (LIST (rev acc), (rest r)) + else let val (a, r') = readForm r in readList (a::acc) r' end + +and readForm r = + if peek r = SOME PAREN_LEFT + then readList [] (rest r) + else readAtom r + +fun readStr s = + s |> tokenize |> READER |> readForm |> #1 diff --git a/impls/sml/step1_read_print.mlb b/impls/sml/step1_read_print.mlb new file mode 100644 index 00000000..20927d5e --- /dev/null +++ b/impls/sml/step1_read_print.mlb @@ -0,0 +1,10 @@ +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + step1_read_print.sml +in + main.sml +end diff --git a/impls/sml/step1_read_print.sml b/impls/sml/step1_read_print.sml new file mode 100644 index 00000000..0f31b74e --- /dev/null +++ b/impls/sml/step1_read_print.sml @@ -0,0 +1,24 @@ +fun READ s = + readStr s + +fun EVAL f = + f + +fun PRINT f = + prStr f + +fun rep s = + s |> READ |> EVAL |> PRINT + handle SyntaxError msg => "SYNTAX ERROR: " ^ msg + +fun repl () = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => ( + print(rep(line) ^ "\n"); + repl () + ) + | NONE => () + ) end diff --git a/impls/sml/types.sml b/impls/sml/types.sml new file mode 100644 index 00000000..6293d900 --- /dev/null +++ b/impls/sml/types.sml @@ -0,0 +1,5 @@ +datatype mal_type = NIL + | SYMBOL of string + | BOOL of bool + | INT of int + | LIST of mal_type list diff --git a/impls/sml/util.sml b/impls/sml/util.sml new file mode 100644 index 00000000..bd92219a --- /dev/null +++ b/impls/sml/util.sml @@ -0,0 +1,5 @@ +fun takeWhile f xs = takeWhile' f [] xs +and takeWhile' f acc [] = rev acc + | takeWhile' f acc (x::xs) = if f x then takeWhile' f (x::acc) xs else rev acc + +infix 3 |> fun x |> f = f x