1214: fun_arg: 1215: | LPAR parameter_comma_list WHEN expr RPAR { rstoken $1 $3,($2,Some $4) } 1216: | LPAR parameter_comma_list RPAR { rstoken $1 $3,($2,None) } 1217: | NAME { slift (fst $1),([snd $1,`TYP_none],None) } 1218: 1219: fun_args: 1220: | fun_arg fun_args { $1 :: $2 } 1221: | fun_arg { [$1] } 1222: opt_fun_args: 1223: | fun_args { $1 } 1224: | { [] } 1225: 1226: opt_type_expr: 1227: | COLON expr EXPECT expr { typecode_of_expr $2, Some $4 } 1228: | COLON expr { typecode_of_expr $2, None } 1229: | EXPECT expr { `TYP_none, Some $2 } 1230: | { `TYP_none, None } 1231: 1232: opt_cstring: 1233: | EQUAL code_spec { Some $2 } 1234: | { None } 1235: 1236: adjective: 1237: | INLINE { $1,`InlineFunction } 1238: | NOINLINE { $1,`NoInlineFunction } 1239: 1240: adjectives: 1241: | adjective adjectives { $1 :: $2 } 1242: | { [] } 1243: 1244: opt_prec: 1245: | IS NAME { snd $2 } 1246: | { "" } 1247: 1248: opt_traint_eq: 1249: | EXPECT expr EQUAL { Some $2 } 1250: | { None } 1251: 1252: reduce_args: 1253: | LPAR parameter_comma_list RPAR { $2 } 1254: 1255: function_definition: 1256: | REDUCE NAME tvarlist reduce_args COLON expr EQRIGHTARROW expr SEMI 1257: { 1258: let sr = rstoken $1 $9 1259: and name = snd $2 1260: and vs = $3 1261: and args = $4 1262: and rsrc = $6 1263: and rdst = $8 1264: in 1265: `AST_reduce (sr,name,vs,args,rsrc,rdst) 1266: } 1267: 1268: | AXIOM NAME tvarlist reduce_args COLON expr SEMI 1269: { 1270: let sr = rstoken $1 $7 1271: and name = snd $2 1272: and vs = $3 1273: and args = $4 1274: and rsrc = $6 1275: in 1276: `AST_axiom (sr,name,vs,args,rsrc) 1277: } 1278: 1279: | adjectives FUNCTION NAME tvarlist fun_args opt_type_expr EQRIGHTARROW expr SEMI 1280: { 1281: let kind = match $1 with 1282: | [] -> `Function 1283: | h :: t -> snd h 1284: in 1285: let sr = rstoken $2 $9 in 1286: let name = snd $3 1287: and return_type = $6 1288: and body = [`AST_fun_return (sr,$8)] 1289: and args = List.map snd $5 (* elide srcref *) 1290: and vs = $4 1291: in 1292: mkcurry sr name vs args return_type kind body 1293: } 1294: 1295: | adjectives FUNCTION NAME tvarlist fun_args opt_type_expr EQUAL compound 1296: { 1297: let kind = match $1 with 1298: | [] -> `Function 1299: | h :: t -> snd h 1300: in 1301: let sr = rsrange (slift $2) (fst $8) 1302: and name = snd $3 1303: and return_type = $6 1304: and body = snd $8 1305: and args = List.map snd $5 (* elide srcref *) 1306: and vs = $4 1307: in mkcurry sr name vs args return_type kind body 1308: } 1309: 1310: | adjectives FUNCTION NAME tvarlist opt_type_expr opt_cstring opt_prec requires_clause SEMI 1311: { 1312: let name = snd $3 1313: and vs = $4 1314: and t,traint = $5 1315: and sr = rstoken $2 $9 1316: and prec = $7 1317: and reqs = $8 1318: in 1319: let ct = 1320: match $6 with 1321: | Some x -> x 1322: | None -> `StrTemplate (name ^ "($a)") 1323: in 1324: match t with 1325: | `TYP_cfunction (arg, ret) 1326: | `TYP_function (arg, ret) -> 1327: let args = 1328: match arg with 1329: | `TYP_tuple lst -> lst 1330: | x -> [x] 1331: in 1332: if List.length args > 0 && list_last args = `TYP_ellipsis 1333: then 1334: let vs = vs @ ["_varargs",`TPAT_any] in 1335: let args = List.rev (`AST_name (sr,"_varargs",[]) :: List.tl (List.rev args)) in 1336: `AST_fun_decl (sr, name, vs, args, ret, ct, reqs,prec) 1337: else 1338: `AST_fun_decl (sr, name, vs, args, ret, ct, reqs,prec) 1339: | _ -> 1340: failwith 1341: ( 1342: "Function '"^name^"' requires function type, got " ^ 1343: string_of_typecode t ^ " in " ^ 1344: short_string_of_src sr 1345: ) 1346: } 1347: 1348: | adjectives FUNCTION NAME tvarlist opt_type_expr EQRIGHTARROW expr SEMI 1349: { 1350: let kind = match $1 with 1351: | [] -> `Function 1352: | h :: t -> snd h 1353: in 1354: let sr = rstoken $2 $8 in 1355: let name = snd $3 1356: and return_type = $5 1357: and body = [`AST_fun_return (sr,$7)] 1358: and args = [] 1359: and vs = $4 1360: in 1361: mkcurry sr name vs args return_type kind body 1362: } 1363: 1364: | adjectives FUNCTION NAME tvarlist opt_type_expr EQUAL matchings SEMI 1365: { 1366: let kind = match $1 with 1367: | [] -> `Function 1368: | h :: t -> snd h 1369: in 1370: let sr = rstoken $2 $8 in 1371: let name = snd $3 in 1372: let vs = $4 in 1373: let t,traint = $5 in 1374: let body = $7 in 1375: match t with 1376: | `TYP_function (argt, return_type) -> 1377: let args = [["_a",argt],None] in 1378: let match_expr = `AST_match (sr,(`AST_name (sr,"_a",[]),body)) in 1379: let body = [`AST_fun_return (sr,match_expr)] in 1380: mkcurry sr name vs args (return_type,traint) kind body 1381: | _ -> 1382: failwith 1383: ( 1384: "Function '"^name^"' requires function type, got " ^ 1385: string_of_typecode t ^ " in " ^ 1386: short_string_of_src sr 1387: ) 1388: } 1389: 1390: ctor_init: 1391: | NAME LPAR expr RPAR { $1,$3 } 1392: 1393: ctor_init_list: 1394: | ctor_init COMMA ctor_init_list { $1 :: $3 } 1395: | ctor_init { [$1] } 1396: 1397: ctor_inits: 1398: | COLON ctor_init_list { $2 } 1399: | {[]} 1400: 1401: procedure_definition: 1402: | CTOR tvarlist opt_fun_args opt_traint_eq ctor_inits compound 1403: { 1404: let sr = rsrange (slift $1) (fst $6) in 1405: let name = "__constructor__" 1406: and vs = $2 1407: and return_type = `AST_void sr 1408: and traint = $4 1409: and body = snd $6 1410: and inits = $5 1411: and args = List.map snd $3 (* elide srcref *) 1412: in 1413: let body = map (fun (n,e) -> `AST_init (slift (fst n), snd n, e)) inits @ body in 1414: mkcurry sr name vs args (return_type,traint) `Ctor body 1415: } 1416: 1417: | PROCEDURE NAME tvarlist opt_fun_args opt_traint_eq compound 1418: { 1419: let sr = rsrange (slift $1) (fst $6) in 1420: let name = snd $2 1421: and vs = $3 1422: and return_type = `AST_void sr 1423: and traint = $5 1424: and body = snd $6 1425: and args = List.map snd $4 (* elide srcref *) 1426: in mkcurry sr name vs args (return_type,traint) `Function body 1427: } 1428: 1429: | adjective PROCEDURE NAME tvarlist fun_args opt_traint_eq compound 1430: { 1431: let sr = rsrange (slift (fst $1)) (fst $7) in 1432: let name = snd $3 1433: and vs = $4 1434: and return_type = `AST_void sr 1435: and traint = $6 1436: and body = snd $7 1437: and args = List.map snd $5 (* elide srcref *) 1438: and adjective = snd $1 1439: in mkcurry sr name vs args (return_type,traint) adjective body 1440: } 1441: 1442: | PROCEDURE NAME tvarlist COLON expr opt_cstring requires_clause SEMI 1443: { 1444: let sr = rstoken $1 $8 1445: and vs = $3 1446: and name = snd $2 1447: and t = typecode_of_expr $5 1448: in 1449: let ct = 1450: match $6 with 1451: | Some x -> x 1452: | None -> `StrTemplate (name ^ "($a);") 1453: in 1454: let args = 1455: match t with 1456: | `TYP_tuple lst -> lst 1457: | x -> [x] 1458: in 1459: if List.length args > 0 && list_last args = `TYP_ellipsis 1460: then 1461: let vs = vs @ ["_varargs",`TPAT_any] in 1462: let args = List.rev (`AST_name (sr,"_varargs",[]) :: List.tl (List.rev args)) in 1463: `AST_fun_decl (sr, name, vs, args, `AST_void sr, ct,$7,"") 1464: else 1465: `AST_fun_decl (sr,name,vs, args,`AST_void sr, ct, $7,"") 1466: } 1467: