5.16.7.11. Function and Procedure Definition

Start data section to src/flx_parse.mly[18 /35 ] Next Prev First Last
  1411: typefun_arg:
  1412:   | LPAR typeparameter_comma_list RPAR { rstoken $1 $3,$2 }
  1413:   | NAME { slift (fst $1),[snd $1,`TYP_none] }
  1414: typefun_args:
  1415:   | typefun_arg typefun_args      { $1 :: $2 }
  1416:   | typefun_arg               { [$1] }
  1417: 
  1418: 
  1419: fun_arg:
  1420:   | LPAR parameter_comma_list WHEN expr RPAR { rstoken $1 $3,($2,Some $4) }
  1421:   | LPAR parameter_comma_list RPAR { rstoken $1 $3,($2,None) }
  1422:   | NAME { slift (fst $1),([`PVal,snd $1,`TYP_none],None) }
  1423: 
  1424: fun_args:
  1425:   | fun_arg fun_args      { $1 :: $2 }
  1426:   | fun_arg               { [$1] }
  1427: opt_fun_args:
  1428:   | fun_args { $1 }
  1429:   | { [] }
  1430: 
  1431: opt_type_expr:
  1432:   | COLON expr EXPECT expr { typecode_of_expr $2, Some $4 }
  1433:   | COLON expr { typecode_of_expr $2, None }
  1434:   | EXPECT expr { `TYP_none, Some $2 }
  1435:   | { `TYP_none, None }
  1436: 
  1437: opt_cstring:
  1438:   | EQUAL code_spec { Some $2 }
  1439:   | { None }
  1440: 
  1441: adjective:
  1442:   | INLINE { $1,`InlineFunction }
  1443:   | NOINLINE { $1,`NoInlineFunction }
  1444:   | VIRTUAL { $1,`Virtual }
  1445: 
  1446: adjectives:
  1447:   | adjective adjectives { $1 :: $2 }
  1448:   | { [] }
  1449: 
  1450: opt_prec:
  1451:   | IS NAME { snd $2 }
  1452:   | { "" }
  1453: 
  1454: opt_traint_eq:
  1455:   | EXPECT expr EQUAL { Some $2 }
  1456:   | { None }
  1457: 
  1458: reduce_args:
  1459:   | LPAR typeparameter_comma_list RPAR { $2 }
  1460: 
  1461: fun_kind:
  1462:   | CFUNCTION { $1,`CFunction }
  1463:   | FUNCTION { $1,`Function }
  1464:   | GENERATOR { $1,`Generator }
  1465: 
  1466: function_definition:
  1467:   | REDUCE declname reduce_args COLON expr EQRIGHTARROW expr SEMI
  1468:     {
  1469:       let name,vs = hd $2 in
  1470:       let sr = rstoken $1 $8 in
  1471:       let args = $3 in
  1472:       let rsrc = $5 in
  1473:       let rdst = $7 in
  1474:       let stmt = `AST_reduce (sr,name,vs,args,rsrc,rdst) in
  1475:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $2)
  1476:     }
  1477: 
  1478:   | AXIOM declname fun_arg COLON expr SEMI
  1479:     {
  1480:       let name,vs = hd $2 in
  1481:       let sr = rstoken $1 $6 in
  1482:       let args = snd $3 in
  1483:       let rsrc = $5 in
  1484:       let stmt = `AST_axiom (sr,name,vs,args,`Predicate rsrc) in
  1485:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $2)
  1486:     }
  1487: 
  1488:   | AXIOM declname fun_arg COLON expr EQUAL expr SEMI
  1489:     {
  1490:       let name,vs = hd $2 in
  1491:       let sr = rstoken $1 $6 in
  1492:       let args = snd $3 in
  1493:       let l= $5 in
  1494:       let r= $7 in
  1495:       let stmt = `AST_axiom (sr,name,vs,args,`Equation (l,r)) in
  1496:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $2)
  1497:     }
  1498: 
  1499:   | LEMMA declname fun_arg COLON expr SEMI
  1500:     {
  1501:       let name,vs = hd $2 in
  1502:       let sr = rstoken $1 $6 in
  1503:       let args = snd $3 in
  1504:       let rsrc = $5 in
  1505:       let stmt = `AST_lemma (sr,name,vs,args,`Predicate rsrc) in
  1506:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $2)
  1507:     }
  1508: 
  1509:   | LEMMA declname fun_arg COLON expr EQUAL expr SEMI
  1510:     {
  1511:       let name,vs = hd $2 in
  1512:       let sr = rstoken $1 $6 in
  1513:       let args = snd $3 in
  1514:       let l= $5 in
  1515:       let r= $7 in
  1516:       let stmt = `AST_lemma (sr,name,vs,args,`Equation (l,r)) in
  1517:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $2)
  1518:     }
  1519: 
  1520:   | adjectives fun_kind declname fun_args opt_type_expr EQRIGHTARROW expr SEMI
  1521:     {
  1522:       let name,vs = hd $3 in
  1523:       let sr1,kind = cal_funkind $1 $2 in
  1524:       let sr = rstoken sr1 $8 in
  1525:       let return_type = $5 in
  1526:       let body = [`AST_fun_return (sr,$7)] in
  1527:       let args = List.map snd $4 in
  1528:       let stmt = mkcurry sr name vs args return_type kind body in
  1529:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $3)
  1530:     }
  1531: 
  1532:   | adjectives fun_kind declname fun_args opt_type_expr EQUAL compound
  1533:     {
  1534:       let name,vs = hd $3 in
  1535:       let sr1,kind = cal_funkind $1 $2 in
  1536:       let sr = rsrange (slift sr1) (fst $7) in
  1537:       let return_type = $5 in
  1538:       let body = snd $7 in
  1539:       let args = List.map snd $4 in
  1540:       let stmt = mkcurry sr name vs args return_type kind body in
  1541:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $3)
  1542:     }
  1543: 
  1544:   | adjectives fun_kind declname opt_type_expr opt_cstring opt_prec requires_clause SEMI
  1545:     {
  1546:       let name,vs = hd $3 in
  1547:       let sr1,kind = cal_funkind $1 $2 in
  1548:       let adjectives = map snd $1 in
  1549:       let t,traint = $4
  1550:       and sr = rstoken sr1 $8
  1551:       and prec = $6
  1552:       and reqs = $7
  1553:       in
  1554:       let ct =
  1555:         match $5 with
  1556:         | Some x -> x
  1557:         | None ->
  1558:           if mem `Virtual adjectives then `Virtual else
  1559:           `StrTemplate (name ^ "($a)")
  1560:       in
  1561:       match t with
  1562:       | `TYP_cfunction (arg, ret)
  1563:       | `TYP_function (arg, ret) ->
  1564:         let args =
  1565:           match arg with
  1566:           | `TYP_tuple lst -> lst
  1567:           | x -> [x]
  1568:         in
  1569:         let reqs = match kind with
  1570:           | `Generator ->
  1571:             `RREQ_and (`RREQ_atom (`Property_req "generator"),reqs)
  1572:           | _ -> reqs
  1573:         in
  1574:         let reqs =
  1575:           if mem `Virtual adjectives then
  1576:             `RREQ_and (`RREQ_atom (`Property_req "virtual"),reqs)
  1577:           else reqs
  1578:         in
  1579:         let stmt =
  1580:           if List.length args > 0 && list_last args = `TYP_ellipsis
  1581:           then
  1582:             (*
  1583:             let vs = vs @ ["_varargs",`TPAT_any] in
  1584:             *)
  1585:             let vs = let vs,t = vs in vs @ ["_varargs",`AST_patany sr],t in
  1586:             let args = List.rev (`AST_name (sr,"_varargs",[]) :: List.tl (List.rev args)) in
  1587:             `AST_fun_decl (sr, name, vs, args,  ret,  ct, reqs,prec)
  1588:           else
  1589:             `AST_fun_decl (sr, name, vs, args,  ret,  ct, reqs,prec)
  1590:           in
  1591:           fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $3)
  1592: 
  1593:       | _ ->
  1594:         failwith
  1595:         (
  1596:           "Function '"^name^"' requires function type, got " ^
  1597:           string_of_typecode t ^ " in " ^
  1598:           short_string_of_src sr
  1599:         )
  1600:     }
  1601: 
  1602:   | adjectives fun_kind declname opt_type_expr EQRIGHTARROW expr SEMI
  1603:     {
  1604:       let name,vs = hd $3 in
  1605:       let sr1,kind = cal_funkind $1 $2 in
  1606:       let sr = rstoken sr1 $7 in
  1607:       let return_type = $4
  1608:       and body = [`AST_fun_return (sr,$6)]
  1609:       and args = []
  1610:       in
  1611:       let stmt = mkcurry sr name vs args return_type kind body in
  1612:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $3)
  1613:     }
  1614: 
  1615:   | adjectives fun_kind declname opt_type_expr EQUAL matchings SEMI
  1616:     {
  1617:       let name,vs = hd $3 in
  1618:       let sr1,kind = cal_funkind $1 $2 in
  1619:       let sr = rstoken sr1 $7 in
  1620:       let t,traint = $4 in
  1621:       let body = $6 in
  1622:       match t with
  1623:       | `TYP_function (argt, return_type) ->
  1624:         let args = [[`PVal,"_a",argt],None] in
  1625:         let match_expr = `AST_match (sr,(`AST_name (sr,"_a",[]),body)) in
  1626:         let body = [`AST_fun_return (sr,match_expr)] in
  1627:         let stmt = mkcurry sr name vs args (return_type,traint) kind body in
  1628:         fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $3)
  1629:       | _ ->
  1630:         failwith
  1631:         (
  1632:           "Function '"^name^"' requires function type, got " ^
  1633:           string_of_typecode t ^ " in " ^
  1634:           short_string_of_src sr
  1635:         )
  1636:     }
  1637: 
  1638: ctor_init:
  1639:   | NAME LPAR expr RPAR { $1,$3 }
  1640: 
  1641: ctor_init_list:
  1642:   | ctor_init COMMA ctor_init_list { $1 :: $3 }
  1643:   | ctor_init { [$1] }
  1644: 
  1645: ctor_inits:
  1646:   | COLON ctor_init_list { $2 }
  1647:   | {[]}
  1648: 
  1649: proc_kind:
  1650:   | PROCEDURE { $1,`Function }
  1651:   | CPROCEDURE { $1,`CFunction }
  1652: 
  1653: procedure_definition:
  1654:   | CTOR tvarlist opt_fun_args opt_traint_eq ctor_inits compound
  1655:     {
  1656:       let sr = rsrange (slift $1) (fst $6) in
  1657:       let name = "__constructor__"
  1658:       and vs = $2
  1659:       and return_type = `AST_void sr
  1660:       and traint = $4
  1661:       and body = snd $6
  1662:       and inits = $5
  1663:       and args = List.map snd $3 (* elide srcref *)
  1664:       in
  1665:       let body = map (fun (n,e) -> `AST_init (slift (fst n), snd n, e)) inits @ body in
  1666:       mkcurry sr name vs args (return_type,traint) `Ctor body
  1667:     }
  1668: 
  1669:   | adjectives proc_kind declname opt_fun_args opt_traint_eq compound
  1670:     {
  1671:       let name,vs = hd $3 in
  1672:       let sr1,kind = cal_funkind $1 $2 in
  1673:       let sr = rsrange (slift sr1) (fst $6) in
  1674:       let return_type = `AST_void sr
  1675:       and traint = $5
  1676:       and body = snd $6
  1677:       and args = List.map snd $4 (* elide srcref *)
  1678:       in
  1679:       let stmt = mkcurry sr name vs args (return_type,traint) kind body in
  1680:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $3)
  1681:     }
  1682: 
  1683:   | adjectives proc_kind declname COLON expr opt_cstring requires_clause SEMI
  1684:     {
  1685:       let name,vs = hd $3 in
  1686:       let sr1,kind = cal_funkind $1 $2 in
  1687:       let sr = rstoken sr1 $8
  1688:       and t = typecode_of_expr $5
  1689:       and adjectives = map snd $1
  1690:       in
  1691:       let ct =
  1692:         match $6 with
  1693:         | Some x ->
  1694:           if mem `Virtual adjectives then
  1695:             Flx_exceptions.clierr sr "Virtual procedure can't have body"
  1696:           else x
  1697:         | None ->
  1698:           if mem `Virtual adjectives then `Virtual else
  1699:           `StrTemplate (name ^ "($a);")
  1700:       in
  1701:       let args =
  1702:         match t with
  1703:         | `TYP_tuple lst -> lst
  1704:         | x -> [x]
  1705:       in
  1706:       let stmt =
  1707:         if List.length args > 0 && list_last args = `TYP_ellipsis
  1708:         then
  1709:           (*
  1710:           let vs = match vs with vs,t -> vs @ ["_varargs",`TPAT_any],t in
  1711:           *)
  1712:           let vs = match vs with vs,t -> vs @ ["_varargs",`AST_patany sr],t in
  1713:           let args = List.rev (`AST_name (sr,"_varargs",[]) :: List.tl (List.rev args)) in
  1714:           `AST_fun_decl (sr, name, vs, args,  `AST_void sr,  ct,$7,"")
  1715:         else
  1716:           `AST_fun_decl (sr,name,vs, args,`AST_void sr, ct, $7,"")
  1717:       in
  1718:       fold_left (fun stmt (name,vs) -> `AST_namespace (sr,name,vs,[stmt])) stmt (tl $3)
  1719:     }
  1720: 
End data section to src/flx_parse.mly[18]