src/boot/fe/item.ml

   1
   2 open Common;;
   3 open Token;;
   4 open Parser;;
   5
   6 (* Item grammar. *)
   7
   8 let default_exports =
   9   let e = Hashtbl.create 0 in
  10     Hashtbl.add e Ast.EXPORT_all_decls ();
  11     e
  12 ;;
  13
  14 let empty_view = { Ast.view_imports = Hashtbl.create 0;
  15                    Ast.view_exports = default_exports }
  16 ;;
  17
  18 let rec parse_expr (ps:pstate) : (Ast.stmt array * Ast.expr) =
  19   let pexp = ctxt "expr" Pexp.parse_pexp ps in
  20     Pexp.desugar_expr ps pexp
  21
  22 and parse_expr_atom (ps:pstate) : (Ast.stmt array * Ast.atom) =
  23   let pexp = ctxt "expr" Pexp.parse_pexp ps in
  24     Pexp.desugar_expr_atom ps pexp
  25
  26 and parse_expr_atom_list
  27     (bra:token)
  28     (ket:token)
  29     (ps:pstate)
  30     : (Ast.stmt array * Ast.atom array) =
  31   arj1st (bracketed_zero_or_more bra ket (Some COMMA)
  32             (ctxt "expr-atom list" parse_expr_atom) ps)
  33
  34 and parse_expr_init (lv:Ast.lval) (ps:pstate) : (Ast.stmt array) =
  35   let pexp = ctxt "expr" Pexp.parse_pexp ps in
  36     Pexp.desugar_expr_init ps lv pexp
  37
  38 and parse_lval (ps:pstate) : (Ast.stmt array * Ast.lval) =
  39   let pexp = Pexp.parse_pexp ps in
  40     Pexp.desugar_lval ps pexp
  41
  42 and parse_identified_slot_and_ident
  43     (aliases_ok:bool)
  44     (ps:pstate)
  45     : (Ast.slot identified * Ast.ident) =
  46   let slot =
  47     ctxt "identified slot and ident: slot"
  48       (Pexp.parse_identified_slot aliases_ok) ps
  49   in
  50   let ident =
  51     ctxt "identified slot and ident: ident" Pexp.parse_ident ps
  52   in
  53     (slot, ident)
  54
  55 and parse_zero_or_more_identified_slot_ident_pairs
  56     (aliases_ok:bool)
  57     (ps:pstate)
  58     : (((Ast.slot identified) * Ast.ident) array) =
  59   ctxt "zero+ slots and idents"
  60     (paren_comma_list
  61        (parse_identified_slot_and_ident aliases_ok)) ps
  62
  63 and parse_block (ps:pstate) : Ast.block =
  64   let apos = lexpos ps in
  65   let stmts =
  66     arj (ctxt "block: stmts"
  67            (bracketed_zero_or_more LBRACE RBRACE
  68               None parse_stmts) ps)
  69   in
  70   let bpos = lexpos ps in
  71     span ps apos bpos stmts
  72
  73 and parse_block_stmt (ps:pstate) : Ast.stmt =
  74   let apos = lexpos ps in
  75   let block = parse_block ps in
  76   let bpos = lexpos ps in
  77     span ps apos bpos (Ast.STMT_block block)
  78
  79 and parse_init
  80     (lval:Ast.lval)
  81     (ps:pstate)
  82     : Ast.stmt array =
  83   let apos = lexpos ps in
  84   let stmts =
  85     match peek ps with
  86         EQ ->
  87           bump ps;
  88           parse_expr_init lval ps
  89       | LARROW ->
  90           bump ps;
  91           let (stmts, rhs) = ctxt "init: port" parse_lval ps in
  92           let bpos = lexpos ps in
  93           let stmt = Ast.STMT_recv (lval, rhs) in
  94             Array.append stmts [| (span ps apos bpos stmt) |]
  95       | _ -> arr []
  96   in
  97   let _ = expect ps SEMI in
  98     stmts
  99
 100 and parse_slot_and_ident_and_init
 101     (ps:pstate)
 102     : (Ast.stmt array * Ast.slot * Ast.ident) =
 103   let apos = lexpos ps in
 104   let (slot, ident) =
 105     ctxt "slot, ident and init: slot and ident"
 106       (Pexp.parse_slot_and_ident false) ps
 107   in
 108   let bpos = lexpos ps in
 109   let lval = Ast.LVAL_base (span ps apos bpos (Ast.BASE_ident ident)) in
 110   let stmts = ctxt "slot, ident and init: init" (parse_init lval) ps in
 111     (stmts, slot, ident)
 112
 113 and parse_auto_slot_and_init
 114     (ps:pstate)
 115     : (Ast.stmt array * Ast.slot * Ast.ident) =
 116   let apos = lexpos ps in
 117   let ident = Pexp.parse_ident ps in
 118   let bpos = lexpos ps in
 119   let lval = Ast.LVAL_base (span ps apos bpos (Ast.BASE_ident ident)) in
 120   let stmts = ctxt "slot, ident and init: init" (parse_init lval) ps in
 121     (stmts, slot_auto, ident)
 122
 123 (*
 124  * We have no way to parse a single Ast.stmt; any incoming syntactic statement
 125  * may desugar to N>1 real Ast.stmts
 126  *)
 127
 128 and parse_stmts (ps:pstate) : Ast.stmt array =
 129   let apos = lexpos ps in
 130     match peek ps with
 131
 132         LOG ->
 133           bump ps;
 134           let (stmts, atom) = ctxt "stmts: log value" parse_expr_atom ps in
 135             expect ps SEMI;
 136             spans ps stmts apos (Ast.STMT_log atom)
 137
 138       | CHECK ->
 139           bump ps;
 140           begin
 141
 142             let rec name_to_lval (bpos:pos) (name:Ast.name)
 143                 : Ast.lval =
 144               match name with
 145                   Ast.NAME_base nb ->
 146                     Ast.LVAL_base (span ps apos bpos nb)
 147                 | Ast.NAME_ext (n, nc) ->
 148                     Ast.LVAL_ext (name_to_lval bpos n, Ast.COMP_named nc)
 149             in
 150
 151             let rec carg_path_to_lval (bpos:pos) (path:Ast.carg_path)
 152                 : Ast.lval =
 153               match path with
 154                   Ast.CARG_base Ast.BASE_formal ->
 155                     raise (err "converting formal constraint-arg to atom" ps)
 156                 | Ast.CARG_base (Ast.BASE_named nb) ->
 157                     Ast.LVAL_base (span ps apos bpos nb)
 158                 | Ast.CARG_ext (pth, nc) ->
 159                     Ast.LVAL_ext (carg_path_to_lval bpos pth,
 160                                   Ast.COMP_named nc)
 161             in
 162
 163             let carg_to_atom (bpos:pos) (carg:Ast.carg)
 164                 : Ast.atom =
 165               match carg with
 166                   Ast.CARG_lit lit ->
 167                     Ast.ATOM_literal (span ps apos bpos lit)
 168                 | Ast.CARG_path pth ->
 169                     Ast.ATOM_lval (carg_path_to_lval bpos pth)
 170             in
 171
 172             let synthesise_check_call (bpos:pos) (constr:Ast.constr)
 173                 : (Ast.lval * (Ast.atom array)) =
 174               let lval = name_to_lval bpos constr.Ast.constr_name in
 175               let args =
 176                 Array.map (carg_to_atom bpos) constr.Ast.constr_args
 177               in
 178                 (lval, args)
 179             in
 180
 181             let synthesise_check_calls (bpos:pos) (constrs:Ast.constrs)
 182                 : Ast.check_calls =
 183               Array.map (synthesise_check_call bpos) constrs
 184             in
 185
 186               match peek ps with
 187                   LPAREN ->
 188                     bump ps;
 189                     let (stmts, expr) =
 190                       ctxt "stmts: check value" parse_expr ps
 191                     in
 192                       expect ps RPAREN;
 193                       expect ps SEMI;
 194                       spans ps stmts apos (Ast.STMT_check_expr expr)
 195
 196                 | IF ->
 197                     bump ps;
 198                     expect ps LPAREN;
 199                     let constrs = Pexp.parse_constrs ps in
 200                       expect ps RPAREN;
 201                       let block = parse_block ps in
 202                       let bpos = lexpos ps in
 203                       let calls = synthesise_check_calls bpos constrs in
 204                         [| span ps apos bpos
 205                              (Ast.STMT_check_if (constrs, calls, block))
 206                         |]
 207
 208                 | _ ->
 209                     let constrs = Pexp.parse_constrs ps in
 210                       expect ps SEMI;
 211                       let bpos = lexpos ps in
 212                       let calls = synthesise_check_calls bpos constrs in
 213                         [| span ps apos bpos
 214                              (Ast.STMT_check (constrs, calls))
 215                         |]
 216           end
 217
 218       | ALT ->
 219           bump ps;
 220           begin
 221             match peek ps with
 222                 TYPE -> [| |]
 223               | LPAREN ->
 224                   let (stmts, lval) = bracketed LPAREN RPAREN parse_lval ps in
 225                   let rec parse_pat ps =
 226                     match peek ps with
 227                         IDENT ident ->
 228                           let apos = lexpos ps in
 229                           bump ps;
 230                           let bpos = lexpos ps in
 231
 232                           (* TODO: nullary constructors *)
 233                           if peek ps != LPAREN then
 234                             let slot =
 235                               { Ast.slot_mode = Ast.MODE_interior;
 236                                 Ast.slot_mutable = false;
 237                                 Ast.slot_ty = None }
 238                             in
 239                             Ast.PAT_slot ((span ps apos bpos slot), ident)
 240                           else
 241                             let pats =
 242                               paren_comma_list parse_pat ps
 243                             in
 244                             Ast.PAT_tag (ident, pats)
 245                       | LIT_INT _ | LIT_CHAR _ | LIT_BOOL _ ->
 246                           Ast.PAT_lit (Pexp.parse_lit ps)
 247                       | UNDERSCORE -> bump ps; Ast.PAT_wild
 248                       | tok -> raise (Parse_err (ps,
 249                           "Expected pattern but found '" ^
 250                             (string_of_tok tok) ^ "'"))
 251                   in
 252                   let rec parse_arms ps =
 253                     match peek ps with
 254                         CASE ->
 255                           bump ps;
 256                           let pat = bracketed LPAREN RPAREN parse_pat ps in
 257                           let block = parse_block ps in
 258                           let arm = (pat, block) in
 259                           (span ps apos (lexpos ps) arm)::(parse_arms ps)
 260                       | _ -> []
 261                   in
 262                   let parse_alt_block ps =
 263                     let arms = ctxt "alt tag arms" parse_arms ps in
 264                     spans ps stmts apos begin
 265                       Ast.STMT_alt_tag {
 266                         Ast.alt_tag_lval = lval;
 267                         Ast.alt_tag_arms = Array.of_list arms
 268                       }
 269                     end
 270                   in
 271                   bracketed LBRACE RBRACE parse_alt_block ps
 272               | _ -> [| |]
 273           end
 274
 275       | IF ->
 276           let final_else = ref None in
 277           let rec parse_stmt_if _ =
 278             bump ps;
 279             let (stmts, expr) =
 280               ctxt "stmts: if cond"
 281                 (bracketed LPAREN RPAREN parse_expr) ps
 282             in
 283             let then_block = ctxt "stmts: if-then" parse_block ps in
 284               begin
 285                 match peek ps with
 286                     ELSE ->
 287                       begin
 288                         bump ps;
 289                         match peek ps with
 290                             IF ->
 291                               let nested_if = parse_stmt_if () in
 292                               let bpos = lexpos ps in
 293                                 final_else :=
 294                                   Some (span ps apos bpos nested_if)
 295                           | _ ->
 296                               final_else :=
 297                                 Some (ctxt "stmts: if-else" parse_block ps)
 298                       end
 299                   | _ -> ()
 300               end;
 301               let res =
 302                 spans ps stmts apos
 303                   (Ast.STMT_if
 304                      { Ast.if_test = expr;
 305                        Ast.if_then = then_block;
 306                        Ast.if_else = !final_else; })
 307               in
 308                 final_else := None;
 309                 res
 310           in
 311             parse_stmt_if()
 312
 313       | FOR ->
 314           bump ps;
 315           begin
 316             match peek ps with
 317                 EACH ->
 318                   bump ps;
 319                   let inner ps : ((Ast.slot identified * Ast.ident)
 320                                   * Ast.stmt array
 321                                   * (Ast.lval * Ast.atom array)) =
 322                     let slot = (parse_identified_slot_and_ident true ps) in
 323                     let _    = (expect ps IN) in
 324                     let (stmts1, iter) = (rstr true parse_lval) ps in
 325                     let (stmts2, args) =
 326                       parse_expr_atom_list LPAREN RPAREN ps
 327                     in
 328                       (slot, Array.append stmts1 stmts2, (iter, args))
 329                   in
 330                   let (slot, stmts, call) = ctxt "stmts: foreach head"
 331                     (bracketed LPAREN RPAREN inner) ps
 332                   in
 333                   let body_block =
 334                     ctxt "stmts: foreach body" parse_block ps
 335                   in
 336                   let bpos = lexpos ps in
 337                   let head_block =
 338                     (*
 339                      * Slightly weird, but we put an extra nesting level of
 340                      * block here to separate the part that lives in our frame
 341                      * (the iter slot) from the part that lives in the callee
 342                      * frame (the body block).
 343                      *)
 344                     span ps apos bpos [|
 345                       span ps apos bpos (Ast.STMT_block body_block);
 346                     |]
 347                   in
 348                     Array.append stmts
 349                       [| span ps apos bpos
 350                            (Ast.STMT_for_each
 351                               { Ast.for_each_slot = slot;
 352                                 Ast.for_each_call = call;
 353                                 Ast.for_each_head = head_block;
 354                                 Ast.for_each_body = body_block; }) |]
 355               | _ ->
 356                   let inner ps =
 357                     let slot = (parse_identified_slot_and_ident false ps) in
 358                     let _    = (expect ps IN) in
 359                     let lval = (parse_lval ps) in
 360                       (slot, lval) in
 361                   let (slot, seq) =
 362                     ctxt "stmts: for head" (bracketed LPAREN RPAREN inner) ps
 363                   in
 364                   let body_block = ctxt "stmts: for body" parse_block ps in
 365                   let bpos = lexpos ps in
 366                     [| span ps apos bpos
 367                          (Ast.STMT_for
 368                             { Ast.for_slot = slot;
 369                               Ast.for_seq = seq;
 370                               Ast.for_body = body_block; }) |]
 371           end
 372
 373       | WHILE ->
 374           bump ps;
 375           let (stmts, test) =
 376             ctxt "stmts: while cond" (bracketed LPAREN RPAREN parse_expr) ps
 377           in
 378           let body_block = ctxt "stmts: while body" parse_block ps in
 379           let bpos = lexpos ps in
 380             [| span ps apos bpos
 381                  (Ast.STMT_while
 382                     { Ast.while_lval = (stmts, test);
 383                       Ast.while_body = body_block; }) |]
 384
 385       | PUT ->
 386           begin
 387             bump ps;
 388             match peek ps with
 389                 EACH ->
 390                   bump ps;
 391                   let (lstmts, lval) =
 392                     ctxt "put each: lval" (rstr true parse_lval) ps
 393                   in
 394                   let (astmts, args) =
 395                     ctxt "put each: args"
 396                       (parse_expr_atom_list LPAREN RPAREN) ps
 397                   in
 398                   let bpos = lexpos ps in
 399                   let be =
 400                     span ps apos bpos (Ast.STMT_put_each (lval, args))
 401                   in
 402                     expect ps SEMI;
 403                     Array.concat [ lstmts; astmts; [| be |] ]
 404
 405               | _ ->
 406                   begin
 407                     let (stmts, e) =
 408                       match peek ps with
 409                           SEMI -> (arr [], None)
 410                         | _ ->
 411                             let (stmts, expr) =
 412                               ctxt "stmts: put expr" parse_expr_atom ps
 413                             in
 414                               expect ps SEMI;
 415                               (stmts, Some expr)
 416                     in
 417                       spans ps stmts apos (Ast.STMT_put e)
 418                   end
 419           end
 420
 421       | RET ->
 422           bump ps;
 423           let (stmts, e) =
 424             match peek ps with
 425                 SEMI -> (bump ps; (arr [], None))
 426               | _ ->
 427                   let (stmts, expr) =
 428                     ctxt "stmts: ret expr" parse_expr_atom ps
 429                   in
 430                     expect ps SEMI;
 431                     (stmts, Some expr)
 432           in
 433             spans ps stmts apos (Ast.STMT_ret e)
 434
 435       | BE ->
 436           bump ps;
 437           let (lstmts, lval) = ctxt "be: lval" (rstr true parse_lval) ps in
 438           let (astmts, args) =
 439             ctxt "be: args" (parse_expr_atom_list LPAREN RPAREN) ps
 440           in
 441           let bpos = lexpos ps in
 442           let be = span ps apos bpos (Ast.STMT_be (lval, args)) in
 443             expect ps SEMI;
 444             Array.concat [ lstmts; astmts; [| be |] ]
 445
 446       | LBRACE -> [| ctxt "stmts: block" parse_block_stmt ps |]
 447
 448       | LET ->
 449           bump ps;
 450           let (stmts, slot, ident) =
 451             ctxt "stmt slot" parse_slot_and_ident_and_init ps in
 452           let slot = Pexp.apply_mutability slot true in
 453           let bpos = lexpos ps in
 454           let decl = Ast.DECL_slot (Ast.KEY_ident ident,
 455                                     (span ps apos bpos slot))
 456           in
 457             Array.concat [[| span ps apos bpos (Ast.STMT_decl decl) |]; stmts]
 458
 459       | AUTO ->
 460           bump ps;
 461           let (stmts, slot, ident) =
 462             ctxt "stmt slot" parse_auto_slot_and_init ps in
 463           let slot = Pexp.apply_mutability slot true in
 464           let bpos = lexpos ps in
 465           let decl = Ast.DECL_slot (Ast.KEY_ident ident,
 466                                     (span ps apos bpos slot))
 467           in
 468             Array.concat [[| span ps apos bpos (Ast.STMT_decl decl) |]; stmts]
 469
 470       | YIELD ->
 471           bump ps;
 472           expect ps SEMI;
 473           let bpos = lexpos ps in
 474             [| span ps apos bpos Ast.STMT_yield |]
 475
 476       | FAIL ->
 477           bump ps;
 478           expect ps SEMI;
 479           let bpos = lexpos ps in
 480             [| span ps apos bpos Ast.STMT_fail |]
 481
 482       | JOIN ->
 483           bump ps;
 484           let (stmts, lval) = ctxt "stmts: task expr" parse_lval ps in
 485             expect ps SEMI;
 486             spans ps stmts apos (Ast.STMT_join lval)
 487
 488       | MOD | OBJ | TYPE | FN | USE | NATIVE ->
 489           let (ident, item) = ctxt "stmt: decl" parse_mod_item ps in
 490           let decl = Ast.DECL_mod_item (ident, item) in
 491           let stmts = expand_tags_to_stmts ps item in
 492             spans ps stmts apos (Ast.STMT_decl decl)
 493
 494       | _ ->
 495           let (lstmts, lval) = ctxt "stmt: lval" parse_lval ps in
 496             begin
 497               match peek ps with
 498
 499                   SEMI -> (bump ps; lstmts)
 500
 501                 | EQ -> parse_init lval ps
 502
 503                 | OPEQ binop_token ->
 504                     bump ps;
 505                     let (stmts, rhs) =
 506                       ctxt "stmt: opeq rhs" parse_expr_atom ps
 507                     in
 508                     let binop =
 509                       match binop_token with
 510                           PLUS    -> Ast.BINOP_add
 511                         | MINUS   -> Ast.BINOP_sub
 512                         | STAR    -> Ast.BINOP_mul
 513                         | SLASH   -> Ast.BINOP_div
 514                         | PERCENT -> Ast.BINOP_mod
 515                         | AND     -> Ast.BINOP_and
 516                         | OR      -> Ast.BINOP_or
 517                         | CARET   -> Ast.BINOP_xor
 518                         | LSL     -> Ast.BINOP_lsl
 519                         | LSR     -> Ast.BINOP_lsr
 520                         | ASR     -> Ast.BINOP_asr
 521                         | _       -> raise (err "unknown opeq token" ps)
 522                     in
 523                       expect ps SEMI;
 524                       spans ps stmts apos
 525                         (Ast.STMT_copy_binop (lval, binop, rhs))
 526
 527                 | LARROW ->
 528                     bump ps;
 529                     let (stmts, rhs) = ctxt "stmt: recv rhs" parse_lval ps in
 530                     let _ = expect ps SEMI in
 531                       spans ps stmts apos (Ast.STMT_recv (lval, rhs))
 532
 533                 | SEND ->
 534                     bump ps;
 535                     let (stmts, rhs) =
 536                       ctxt "stmt: send rhs" parse_expr_atom ps
 537                     in
 538                     let _ = expect ps SEMI in
 539                     let bpos = lexpos ps in
 540                     let (src, copy) = match rhs with
 541                         Ast.ATOM_lval lv -> (lv, [| |])
 542                       | _ ->
 543                           let (_, tmp, tempdecl) =
 544                             build_tmp ps slot_auto apos bpos
 545                           in
 546                           let copy = span ps apos bpos
 547                             (Ast.STMT_copy (tmp, Ast.EXPR_atom rhs)) in
 548                               ((clone_lval ps tmp), [| tempdecl; copy |])
 549                     in
 550                     let send =
 551                       span ps apos bpos
 552                         (Ast.STMT_send (lval, src))
 553                     in
 554                       Array.concat [ stmts; copy; [| send |] ]
 555
 556                 | _ -> raise (unexpected ps)
 557             end
 558
 559
 560 and parse_ty_param (iref:int ref) (ps:pstate) : Ast.ty_param identified =
 561   let apos = lexpos ps in
 562   let e = Pexp.parse_effect ps in
 563   let ident = Pexp.parse_ident ps in
 564   let i = !iref in
 565   let bpos = lexpos ps in
 566     incr iref;
 567     span ps apos bpos (ident, (i, e))
 568
 569 and parse_ty_params (ps:pstate)
 570     : (Ast.ty_param identified) array =
 571   match peek ps with
 572       LBRACKET ->
 573         bracketed_zero_or_more LBRACKET RBRACKET (Some COMMA)
 574           (parse_ty_param (ref 0)) ps
 575     | _ -> arr []
 576
 577 and parse_ident_and_params (ps:pstate) (cstr:string)
 578     : (Ast.ident * (Ast.ty_param identified) array) =
 579   let ident = ctxt ("mod " ^ cstr ^ " item: ident") Pexp.parse_ident ps in
 580   let params =
 581     ctxt ("mod " ^ cstr ^ " item: type params") parse_ty_params ps
 582   in
 583     (ident, params)
 584
 585 and parse_inputs
 586     (ps:pstate)
 587     : ((Ast.slot identified * Ast.ident) array * Ast.constrs)  =
 588   let slots =
 589     match peek ps with
 590         LPAREN -> ctxt "inputs: input idents and slots"
 591           (parse_zero_or_more_identified_slot_ident_pairs true) ps
 592       | _ -> raise (unexpected ps)
 593   in
 594   let constrs =
 595     match peek ps with
 596         COLON -> (bump ps; ctxt "inputs: constrs" Pexp.parse_constrs ps)
 597       | _ -> [| |]
 598   in
 599   let rec rewrite_carg_path cp =
 600     match cp with
 601         Ast.CARG_base (Ast.BASE_named (Ast.BASE_ident ident)) ->
 602           begin
 603             let res = ref cp in
 604               for i = 0 to (Array.length slots) - 1
 605               do
 606                 let (_, ident') = slots.(i) in
 607                   if ident' = ident
 608                   then res := Ast.CARG_ext (Ast.CARG_base Ast.BASE_formal,
 609                                             Ast.COMP_idx i)
 610                   else ()
 611               done;
 612               !res
 613           end
 614       | Ast.CARG_base _ -> cp
 615       | Ast.CARG_ext (cp, ext) ->
 616           Ast.CARG_ext (rewrite_carg_path cp, ext)
 617   in
 618     (* Rewrite constrs with input tuple as BASE_formal. *)
 619     Array.iter
 620       begin
 621         fun constr ->
 622           let args = constr.Ast.constr_args in
 623             Array.iteri
 624               begin
 625                 fun i carg ->
 626                   match carg with
 627                       Ast.CARG_path cp ->
 628                         args.(i) <- Ast.CARG_path (rewrite_carg_path cp)
 629                     | _ -> ()
 630               end
 631               args
 632       end
 633       constrs;
 634     (slots, constrs)
 635
 636
 637 and parse_in_and_out
 638     (ps:pstate)
 639     : ((Ast.slot identified * Ast.ident) array
 640        * Ast.constrs
 641        * Ast.slot identified) =
 642   let (inputs, constrs) = parse_inputs ps in
 643   let output =
 644     match peek ps with
 645         RARROW ->
 646           bump ps;
 647           ctxt "fn in and out: output slot"
 648             (Pexp.parse_identified_slot true) ps
 649       | _ ->
 650           let apos = lexpos ps in
 651             span ps apos apos slot_nil
 652   in
 653     (inputs, constrs, output)
 654
 655
 656 (* parse_fn starts at the first lparen of the sig. *)
 657 and parse_fn
 658     (is_iter:bool)
 659     (effect:Ast.effect)
 660     (ps:pstate)
 661     : Ast.fn =
 662     let (inputs, constrs, output) =
 663       ctxt "fn: in_and_out" parse_in_and_out ps
 664     in
 665     let body = ctxt "fn: body" parse_block ps in
 666       { Ast.fn_input_slots = inputs;
 667         Ast.fn_input_constrs = constrs;
 668         Ast.fn_output_slot = output;
 669         Ast.fn_aux = { Ast.fn_effect = effect;
 670                        Ast.fn_is_iter = is_iter; };
 671         Ast.fn_body = body; }
 672
 673 and parse_meta_input (ps:pstate) : (Ast.ident * string option) =
 674   let lab = (ctxt "meta input: label" Pexp.parse_ident ps) in
 675     match peek ps with
 676         EQ ->
 677           bump ps;
 678           let v =
 679             match peek ps with
 680                 UNDERSCORE -> bump ps; None
 681               | LIT_STR s -> bump ps; Some s
 682               | _ -> raise (unexpected ps)
 683           in
 684             (lab, v)
 685       | _ -> raise (unexpected ps)
 686
 687 and parse_meta_pat (ps:pstate) : Ast.meta_pat =
 688   bracketed_zero_or_more LPAREN RPAREN
 689     (Some COMMA) parse_meta_input ps
 690
 691 and parse_meta (ps:pstate) : Ast.meta =
 692   Array.map
 693     begin
 694       fun (id,v) ->
 695         match v with
 696             None ->
 697               raise (err ("wildcard found in meta "
 698                           ^ "pattern where value expected") ps)
 699           | Some v -> (id,v)
 700     end
 701     (parse_meta_pat ps)
 702
 703 and parse_optional_meta_pat (ps:pstate) (ident:Ast.ident) : Ast.meta_pat =
 704   match peek ps with
 705       LPAREN -> parse_meta_pat ps
 706     | _ -> [| ("name", Some ident) |]
 707
 708
 709 and parse_obj_item
 710     (ps:pstate)
 711     (apos:pos)
 712     (effect:Ast.effect)
 713     : (Ast.ident * Ast.mod_item) =
 714   expect ps OBJ;
 715   let (ident, params) = parse_ident_and_params ps "obj" in
 716   let (state, constrs) = (ctxt "obj state" parse_inputs ps) in
 717   let drop = ref None in
 718     expect ps LBRACE;
 719     let fns = Hashtbl.create 0 in
 720       while (not (peek ps = RBRACE))
 721       do
 722         let apos = lexpos ps in
 723           match peek ps with
 724               IO | STATE | UNSAFE | FN | ITER ->
 725                 let effect = Pexp.parse_effect ps in
 726                 let is_iter = (peek ps) = ITER in
 727                   bump ps;
 728                   let ident = ctxt "obj fn: ident" Pexp.parse_ident ps in
 729                   let fn = ctxt "obj fn: fn" (parse_fn is_iter effect) ps in
 730                   let bpos = lexpos ps in
 731                     htab_put fns ident (span ps apos bpos fn)
 732             | DROP ->
 733                 bump ps;
 734                 drop := Some (parse_block ps)
 735             | RBRACE -> ()
 736             | _ -> raise (unexpected ps)
 737       done;
 738       expect ps RBRACE;
 739       let bpos = lexpos ps in
 740       let obj = { Ast.obj_state = state;
 741                   Ast.obj_effect = effect;
 742                   Ast.obj_constrs = constrs;
 743                   Ast.obj_fns = fns;
 744                   Ast.obj_drop = !drop }
 745       in
 746         (ident,
 747          span ps apos bpos
 748            (decl params (Ast.MOD_ITEM_obj obj)))
 749
 750
 751 and parse_mod_item (ps:pstate) : (Ast.ident * Ast.mod_item) =
 752   let apos = lexpos ps in
 753   let parse_lib_name ident =
 754     match peek ps with
 755         EQ ->
 756           begin
 757             bump ps;
 758             match peek ps with
 759                 LIT_STR s -> (bump ps; s)
 760               | _ -> raise (unexpected ps)
 761           end
 762       | _ -> ps.pstate_infer_lib_name ident
 763   in
 764
 765     match peek ps with
 766
 767         IO | STATE | UNSAFE | OBJ | FN | ITER ->
 768           let effect = Pexp.parse_effect ps in
 769             begin
 770               match peek ps with
 771                   OBJ -> parse_obj_item ps apos effect
 772                 | _ ->
 773                     let is_iter = (peek ps) = ITER in
 774                       bump ps;
 775                       let (ident, params) = parse_ident_and_params ps "fn" in
 776                       let fn =
 777                         ctxt "mod fn item: fn" (parse_fn is_iter effect) ps
 778                       in
 779                       let bpos = lexpos ps in
 780                         (ident,
 781                          span ps apos bpos
 782                            (decl params (Ast.MOD_ITEM_fn fn)))
 783             end
 784
 785       | TYPE ->
 786           bump ps;
 787           let (ident, params) = parse_ident_and_params ps "type" in
 788           let _ = expect ps EQ in
 789           let ty = ctxt "mod type item: ty" Pexp.parse_ty ps in
 790           let _ = expect ps SEMI in
 791           let bpos = lexpos ps in
 792           let item = Ast.MOD_ITEM_type ty in
 793             (ident, span ps apos bpos (decl params item))
 794
 795       | MOD ->
 796           bump ps;
 797           let (ident, params) = parse_ident_and_params ps "mod" in
 798             expect ps LBRACE;
 799             let items = parse_mod_items ps RBRACE in
 800             let bpos = lexpos ps in
 801               (ident,
 802                span ps apos bpos
 803                  (decl params (Ast.MOD_ITEM_mod items)))
 804
 805       | NATIVE ->
 806           begin
 807             bump ps;
 808             let conv =
 809               match peek ps with
 810                   LIT_STR s ->
 811                     bump ps;
 812                     begin
 813                       match string_to_conv s with
 814                           None -> raise (unexpected ps)
 815                         | Some c -> c
 816                     end
 817                 | _ -> CONV_cdecl
 818             in
 819               expect ps MOD;
 820               let (ident, params) = parse_ident_and_params ps "native mod" in
 821               let path = parse_lib_name ident in
 822               let items = parse_mod_items_from_signature ps in
 823               let bpos = lexpos ps in
 824               let rlib = REQUIRED_LIB_c { required_libname = path;
 825                                           required_prefix = ps.pstate_depth }
 826               in
 827               let item = decl params (Ast.MOD_ITEM_mod items) in
 828               let item = span ps apos bpos item in
 829                 note_required_mod ps {lo=apos; hi=bpos} conv rlib item;
 830                 (ident, item)
 831           end
 832
 833       | USE ->
 834           begin
 835             bump ps;
 836             let ident = ctxt "use mod: ident" Pexp.parse_ident ps in
 837             let meta =
 838               ctxt "use mod: meta" parse_optional_meta_pat ps ident
 839             in
 840             let bpos = lexpos ps in
 841             let id = (span ps apos bpos ()).id in
 842             let (path, items) =
 843               ps.pstate_get_mod meta id ps.pstate_node_id ps.pstate_opaque_id
 844             in
 845             let bpos = lexpos ps in
 846               expect ps SEMI;
 847               let rlib =
 848                 REQUIRED_LIB_rust { required_libname = path;
 849                                     required_prefix = ps.pstate_depth }
 850               in
 851                 iflog ps
 852                   begin
 853                     fun _ ->
 854                       log ps "extracted mod from %s (binding to %s)"
 855                         path ident;
 856                       log ps "%a" Ast.sprintf_mod_items items;
 857                   end;
 858                 let item = decl [||] (Ast.MOD_ITEM_mod (empty_view, items)) in
 859                 let item = span ps apos bpos item in
 860                   note_required_mod ps {lo=apos; hi=bpos} CONV_rust rlib item;
 861                   (ident, item)
 862           end
 863
 864
 865
 866       | _ -> raise (unexpected ps)
 867
 868
 869 and parse_mod_items_from_signature
 870     (ps:pstate)
 871     : (Ast.mod_view * Ast.mod_items) =
 872     let mis = Hashtbl.create 0 in
 873       expect ps LBRACE;
 874       while not (peek ps = RBRACE)
 875       do
 876         let (ident, mti) = ctxt "mod items from sig: mod item"
 877           parse_mod_item_from_signature ps
 878         in
 879           Hashtbl.add mis ident mti;
 880       done;
 881       expect ps RBRACE;
 882       (empty_view, mis)
 883
 884
 885 and parse_mod_item_from_signature (ps:pstate)
 886     : (Ast.ident * Ast.mod_item) =
 887   let apos = lexpos ps in
 888     match peek ps with
 889         MOD ->
 890           bump ps;
 891           let (ident, params) = parse_ident_and_params ps "mod signature" in
 892           let items = parse_mod_items_from_signature ps in
 893           let bpos = lexpos ps in
 894           (ident, span ps apos bpos (decl params (Ast.MOD_ITEM_mod items)))
 895
 896       | IO | STATE | UNSAFE | FN | ITER ->
 897           let effect = Pexp.parse_effect ps in
 898           let is_iter = (peek ps) = ITER in
 899             bump ps;
 900             let (ident, params) = parse_ident_and_params ps "fn signature" in
 901             let (inputs, constrs, output) = parse_in_and_out ps in
 902             let bpos = lexpos ps in
 903             let body = span ps apos bpos [| |] in
 904             let fn =
 905               Ast.MOD_ITEM_fn
 906                 { Ast.fn_input_slots = inputs;
 907                   Ast.fn_input_constrs = constrs;
 908                   Ast.fn_output_slot = output;
 909                   Ast.fn_aux = { Ast.fn_effect = effect;
 910                                  Ast.fn_is_iter = is_iter; };
 911                   Ast.fn_body = body; }
 912             in
 913             let node = span ps apos bpos (decl params fn) in
 914               begin
 915                 match peek ps with
 916                     EQ ->
 917                       bump ps;
 918                       begin
 919                         match peek ps with
 920                             LIT_STR s ->
 921                               bump ps;
 922                               htab_put ps.pstate_required_syms node.id s
 923                           | _ -> raise (unexpected ps)
 924                       end;
 925                   | _ -> ()
 926               end;
 927               expect ps SEMI;
 928               (ident, node)
 929
 930     | TYPE ->
 931         bump ps;
 932         let (ident, params) = parse_ident_and_params ps "type type" in
 933         let t =
 934           match peek ps with
 935               SEMI -> Ast.TY_native (next_opaque_id ps)
 936             | _ -> Pexp.parse_ty ps
 937         in
 938           expect ps SEMI;
 939           let bpos = lexpos ps in
 940             (ident, span ps apos bpos (decl params (Ast.MOD_ITEM_type t)))
 941
 942     (* FIXME: parse obj. *)
 943     | _ -> raise (unexpected ps)
 944
 945
 946 and expand_tags
 947     (ps:pstate)
 948     (item:Ast.mod_item)
 949     : (Ast.ident * Ast.mod_item) array =
 950   let handle_ty_tag id ttag =
 951     let tags = ref [] in
 952       Hashtbl.iter
 953         begin
 954           fun name tup ->
 955             let ident = match name with
 956                 Ast.NAME_base (Ast.BASE_ident ident) -> ident
 957               | _ ->
 958                   raise (Parse_err
 959                            (ps, "unexpected name type while expanding tag"))
 960             in
 961             let header =
 962               Array.map (fun slot -> (clone_span ps item slot)) tup
 963             in
 964             let tag_item' = Ast.MOD_ITEM_tag (header, ttag, id) in
 965             let cloned_params =
 966               Array.map (fun p -> clone_span ps p p.node)
 967                 item.node.Ast.decl_params
 968             in
 969             let tag_item =
 970               clone_span ps item (decl cloned_params tag_item')
 971             in
 972               tags := (ident, tag_item) :: (!tags)
 973         end
 974         ttag;
 975       arr (!tags)
 976   in
 977   let handle_ty_decl id tyd =
 978     match tyd with
 979         Ast.TY_tag ttag -> handle_ty_tag id ttag
 980       | _ -> [| |]
 981   in
 982     match item.node.Ast.decl_item with
 983         Ast.MOD_ITEM_type tyd -> handle_ty_decl item.id tyd
 984       | _ -> [| |]
 985
 986
 987 and expand_tags_to_stmts
 988     (ps:pstate)
 989     (item:Ast.mod_item)
 990     : Ast.stmt array =
 991   let id_items = expand_tags ps item in
 992     Array.map
 993       (fun (ident, tag_item) ->
 994          clone_span ps item
 995            (Ast.STMT_decl
 996               (Ast.DECL_mod_item (ident, tag_item))))
 997       id_items
 998
 999
1000 and expand_tags_to_items
1001     (ps:pstate)
1002     (item:Ast.mod_item)
1003     (items:Ast.mod_items)
1004     : unit =
1005   let id_items = expand_tags ps item in
1006     Array.iter
1007       (fun (ident, item) -> htab_put items ident item)
1008       id_items
1009
1010
1011 and note_required_mod
1012     (ps:pstate)
1013     (sp:span)
1014     (conv:nabi_conv)
1015     (rlib:required_lib)
1016     (item:Ast.mod_item)
1017     : unit =
1018   iflog ps
1019     begin
1020       fun _ -> log ps "marking item #%d as required" (int_of_node item.id)
1021     end;
1022   htab_put ps.pstate_required item.id (rlib, conv);
1023   if not (Hashtbl.mem ps.pstate_sess.Session.sess_spans item.id)
1024   then Hashtbl.add ps.pstate_sess.Session.sess_spans item.id sp;
1025   match item.node.Ast.decl_item with
1026       Ast.MOD_ITEM_mod (_, items) ->
1027         Hashtbl.iter
1028           begin
1029             fun _ sub ->
1030               note_required_mod ps sp conv rlib sub
1031           end
1032           items
1033     | _ -> ()
1034
1035
1036 and parse_import
1037     (ps:pstate)
1038     (imports:(Ast.ident, Ast.name) Hashtbl.t)
1039     : unit =
1040   let import a n =
1041     let a = match a with
1042         None ->
1043           begin
1044             match n with
1045                 Ast.NAME_ext (_, Ast.COMP_ident i)
1046               | Ast.NAME_ext (_, Ast.COMP_app (i, _))
1047               | Ast.NAME_base (Ast.BASE_ident i)
1048               | Ast.NAME_base (Ast.BASE_app (i, _)) -> i
1049               | _ -> raise (Parse_err (ps, "bad import specification"))
1050           end
1051       | Some i -> i
1052     in
1053       Hashtbl.add imports a n
1054   in
1055     match peek ps with
1056         IDENT i ->
1057           begin
1058             bump ps;
1059             match peek ps with
1060                 EQ ->
1061                   (*
1062                    * import x = ...
1063                    *)
1064                   bump ps;
1065                   import (Some i) (Pexp.parse_name ps)
1066               | _ ->
1067                   (*
1068                    * import x...
1069                    *)
1070                   import None (Pexp.parse_name_ext ps
1071                                  (Ast.NAME_base
1072                                     (Ast.BASE_ident i)))
1073           end
1074       | _ ->
1075           import None (Pexp.parse_name ps)
1076
1077
1078 and parse_export
1079     (ps:pstate)
1080     (exports:(Ast.export, unit) Hashtbl.t)
1081     : unit =
1082   let e =
1083     match peek ps with
1084         STAR -> bump ps; Ast.EXPORT_all_decls
1085       | IDENT i -> bump ps; Ast.EXPORT_ident i
1086       | _ -> raise (unexpected ps)
1087   in
1088     Hashtbl.add exports e ()
1089
1090
1091 and parse_mod_items
1092     (ps:pstate)
1093     (terminal:token)
1094     : (Ast.mod_view * Ast.mod_items) =
1095   ps.pstate_depth <- ps.pstate_depth + 1;
1096   let imports = Hashtbl.create 0 in
1097   let exports = Hashtbl.create 0 in
1098   let in_view = ref true in
1099   let items = Hashtbl.create 4 in
1100     while (not (peek ps = terminal))
1101     do
1102       if !in_view
1103       then
1104         match peek ps with
1105             IMPORT ->
1106               bump ps;
1107               parse_import ps imports;
1108               expect ps SEMI;
1109           | EXPORT ->
1110               bump ps;
1111               parse_export ps exports;
1112               expect ps SEMI;
1113           | _ ->
1114               in_view := false
1115       else
1116         let (ident, item) = parse_mod_item ps in
1117           htab_put items ident item;
1118           expand_tags_to_items ps item items;
1119     done;
1120     if (Hashtbl.length exports) = 0
1121     then Hashtbl.add exports Ast.EXPORT_all_decls ();
1122     expect ps terminal;
1123     ps.pstate_depth <- ps.pstate_depth - 1;
1124     let view = { Ast.view_imports = imports;
1125                  Ast.view_exports = exports }
1126     in
1127       (view, items)
1128 ;;
1129
1130
1131
1132 (*
1133  * Local Variables:
1134  * fill-column: 78;
1135  * indent-tabs-mode: nil
1136  * buffer-file-coding-system: utf-8-unix
1137  * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
1138  * End:
1139  *)