scm/src/parser/lisp.ml

   1 open Base
   2 open Sexp
   3 open Parsec
   4 open Node
   5
   6 let dot =
   7   Str.regexp "\\."
   8 let qname ({Node.value = sym} as node) =
   9   match List.rev @@ Str.split_delim dot sym with
  10       [] ->
  11         failwith "must not happen"
  12     | [name] ->
  13         {node with Node.value = ([],name)}
  14     | ""::name::ns ->
  15         {node with Node.value = (List.rev ns,name^".")}
  16     | name::ns ->
  17         {node with Node.value = (List.rev ns,name)}
  18
  19 let list f stream =
  20   match Stream.peek stream with
  21       Some (List {Node.value=xs}) ->
  22         let xs' =
  23           Stream.of_list xs in
  24         let res =
  25           f xs' in
  26           Stream.junk stream;
  27           if Stream.peek xs' <> None then
  28             raise (Stream.Error "")
  29           else
  30             res
  31     | _ ->
  32         Parsec.fail ()
  33
  34 let symbol stream =
  35   match Stream.peek stream with
  36       Some (Symbol s) ->
  37         Stream.junk stream;
  38         s
  39     | _ ->
  40         Parsec.fail ()
  41
  42 let kwd kwd stream =
  43   match Stream.peek stream with
  44       Some (Symbol {Node.value = v}) when kwd = v->
  45         Stream.next stream;
  46     | _ ->
  47         Parsec.fail ()
  48
  49 let one_list hd tl =
  50   parser
  51       [< x = hd; y = Parsec.many tl>] ->
  52         (x,y)
  53
  54 let pair car cdr =
  55   parser [< x = car; y = cdr >] ->
  56     (x,y)
  57
  58 let variable_arguments = [
  59   "+";"-";"*";
  60   "+.";"-.";"*.";"/";
  61 ]
  62
  63 let rec expr =
  64   parser
  65       [<' Int n       >] ->
  66         `Int n
  67     | [<' String s    >] ->
  68         `String s
  69     | [<' Bool b      >] ->
  70         `Bool b
  71     | [<' Float v     >] ->
  72         `Float v
  73     | [<' Symbol name >] ->
  74         `Var (qname name)
  75     | [< e = list p_list >] ->
  76         e
  77 and vars =
  78   parser
  79       [<' Symbol var; init = expr >] ->
  80         (var,init)
  81 and block =
  82   parser
  83       [< e = Parsec.many expr >] ->
  84         `Block e
  85 and cond_clause =
  86   parser
  87       [< _ = kwd "else"; body = block>] ->
  88         `Else body
  89     | [< cond = expr; body = block>] ->
  90         `Cond (cond,body)
  91 and p_list =
  92   parser
  93       [< _ = kwd "if"; t = expr; c = expr; a = expr >] ->
  94         `If (t,c,a)
  95     | [< _ =kwd "cond"; body = Parsec.many @@ list cond_clause >] ->
  96         List.fold_right
  97           (fun clause sub ->
  98              match clause with
  99                  `Else body ->
 100                    body
 101                | `Cond (cond,body) ->
 102                    `If (cond,body,sub))
 103           body (`Block [])
 104     | [< _ = kwd "let"; vars = list @@ Parsec.many @@ list vars;
 105          body = Parsec.many expr>] ->
 106         `Let (vars,`Block body)
 107     | [< _ = kwd "letrec"; vars = list @@ Parsec.many @@ list vars;
 108          body = block>] ->
 109         `LetRec (vars,body)
 110     | [< _ = kwd "begin"; body = block >] ->
 111         body
 112     | [< _ = kwd "array"; xs = Parsec.many expr >] ->
 113         `Array xs
 114     | [< _ = kwd "lambda"; args = list @@ Parsec.many symbol; body = block >] ->
 115         `Lambda (args,body)
 116     | [< _ = kwd "new"; name = symbol; args = Parsec.many expr >] ->
 117         `New (qname name,args)
 118     | [< _ = kwd "."; obj = expr; (name,args) = list @@ one_list symbol expr >] ->
 119         `Invoke (obj,name,args)
 120     | [< _ = kwd "slot-ref"; obj = expr; name = symbol >] ->
 121         `SlotRef (obj,name)
 122     | [< _ = kwd "slot-set!";obj = expr;
 123          name = symbol; value = expr>] ->
 124         `SlotSet (obj,name,value)
 125     | [< _ = kwd "list"; xs = Parsec.many expr >] ->
 126         let cons x y =
 127           `Call [`Var (Node.ghost ([],"cons")); x; y] in
 128         let nil =
 129           `Var (Node.ghost ([],"nil")) in
 130           List.fold_right cons xs nil
 131     | [< Symbol op = HList.fold_left1 (<|>) @@ List.map kwd variable_arguments;
 132          args      = Parsec.many expr >]  ->
 133         let op' =
 134           `Var (qname op) in
 135           HList.fold_left1 (fun x y -> `Call [op'; x; y]) args
 136     | [< xs = Parsec.many1 expr >]  ->
 137         `Call xs
 138
 139 let define_value =
 140   parser
 141       [< _ = kwd "define"; name = symbol; body = Parsec.many expr >] ->
 142         `Define (name,`Block body)
 143
 144 let define_func =
 145   parser
 146       [< _ = kwd "define"; (name,args) = list @@ one_list symbol symbol; body = block >] ->
 147         let f =
 148           `Lambda (args,body) in
 149           `Define (name,f)
 150
 151 let define =
 152   (try_ define_value) <|> define_func
 153
 154 let is_valid_module xs =
 155   if  xs = "" then
 156     false
 157   else
 158     match xs.[0] with
 159         'A' .. 'Z' ->
 160           true
 161       | _ ->
 162           false
 163
 164 (*
 165 type 'expr method_ = {
 166   method_name : [`Public of sname | `Static of sname];
 167   args : sname list;
 168   body : 'expr;
 169 }
 170 *)
 171 let p_method =
 172   parser
 173       [<_ = kwd "method"; name = symbol; args = list @@ many symbol; body = block>] ->
 174         {
 175           Ast.method_name = `Public name;
 176           args = args;
 177           body = body
 178         }
 179     | [<_ = kwd "static"; name = symbol; args = list @@ many symbol; body = block>] ->
 180         {
 181           Ast.method_name = `Static name;
 182           args = args;
 183           body = body
 184         }
 185
 186 let rec p_stmt =
 187   parser
 188       [< def = define >] ->
 189         def
 190     | [< _ = kwd "open"; module_name = symbol >] ->
 191         `Open (Node.lift (Str.split_delim dot) module_name)
 192     | [< _         = kwd "class";
 193          name      = symbol;
 194          supers    = list @@ many symbol;
 195          attrs     = list @@ many symbol;
 196          methods   = many @@ list p_method>] ->
 197         let super =
 198           match supers with
 199               [x] -> x
 200             | []  -> Node.ghost "Object"
 201             | _   -> Parsec.fail () in
 202           `Class {Ast.class_name = name;
 203                   super          = qname super;
 204                   attrs          = attrs;
 205                   methods        = methods}
 206     | [< _ = kwd "module"; name = symbol; exports = list @@ many symbol; stmts = many stmt>] ->
 207         if exports = [] then
 208           (* exports nothing must not be happened. *)
 209           `Module {Ast.module_name=name;
 210                    exports=`All;
 211                    stmts=stmts}
 212         else
 213           `Module {Ast.module_name=name;
 214                    exports=`Only exports;
 215                    stmts=stmts}
 216 and stmt =
 217   parser
 218       [< s = list p_stmt >] ->
 219         s
 220     | [< x = expr >] ->
 221         (`Expr x)
 222
 223 let loc s =
 224   function
 225       Int n ->
 226         {n with Node.value = s}
 227     | String n ->
 228         {n with Node.value = s}
 229     | Float n ->
 230         {n with Node.value = s}
 231     | Bool n ->
 232         {n with Node.value = s}
 233     | Symbol n ->
 234         {n with Node.value = s}
 235     | List n ->
 236         {n with Node.value = s}
 237
 238 let parse xs =
 239   let stream' =
 240     Stream.of_list xs in
 241   many (syntax_error (stmt <?> "malformed syntax") (loc "")) stream'