mirror of
https://github.com/kanaka/mal.git
synced 2024-08-17 01:30:26 +03:00
SML: Step 1
This commit is contained in:
parent
5cdd487de4
commit
444dd6e37d
@ -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)
|
||||
|
||||
|
6
impls/sml/printer.sml
Normal file
6
impls/sml/printer.sml
Normal file
@ -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 *)
|
122
impls/sml/reader.sml
Normal file
122
impls/sml/reader.sml
Normal file
@ -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
|
10
impls/sml/step1_read_print.mlb
Normal file
10
impls/sml/step1_read_print.mlb
Normal file
@ -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
|
24
impls/sml/step1_read_print.sml
Normal file
24
impls/sml/step1_read_print.sml
Normal file
@ -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
|
5
impls/sml/types.sml
Normal file
5
impls/sml/types.sml
Normal file
@ -0,0 +1,5 @@
|
||||
datatype mal_type = NIL
|
||||
| SYMBOL of string
|
||||
| BOOL of bool
|
||||
| INT of int
|
||||
| LIST of mal_type list
|
5
impls/sml/util.sml
Normal file
5
impls/sml/util.sml
Normal file
@ -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
|
Loading…
Reference in New Issue
Block a user