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: