Intrinsic functions (SQRT and DSQRT)

fco2/AST.hs

@@ -109,6 +109,7 @@ data Expression =
   | True Meta
   | False Meta
   | FunctionCall Meta Name [Expression]
+  | IntrinsicFunctionCall Meta String [Expression]
   | SubscriptedExpr Meta Subscript Expression
   | BytesInExpr Meta Expression
   | BytesInType Meta Type

fco2/GenerateC.hs

@@ -394,6 +394,7 @@ genExpression (A.ExprLiteral m l) = genLiteral l
 genExpression (A.True m) = tell ["true"]
 genExpression (A.False m) = tell ["false"]
 --genExpression (A.FunctionCall m n es)
+genExpression (A.IntrinsicFunctionCall m s es) = genIntrinsicFunction m s es
 --genExpression (A.SubscriptedExpr m s e)
 --genExpression (A.BytesInExpr m e)
 genExpression (A.BytesInType m t) = genBytesInType t
@@ -405,6 +406,13 @@ genTypeSymbol s t
     = case scalarType t of
         Just ct -> tell ["occam_", s, "_", ct]
         Nothing -> missing $ "genTypeSymbol " ++ show t
+
+genIntrinsicFunction :: Meta -> String -> [A.Expression] -> CGen ()
+genIntrinsicFunction m s es
+    =  do tell ["occam_", s, " ("]
+          sequence [genExpression e >> genComma | e <- es]
+          genMeta m
+          tell [")"]
 --}}}
 
 --{{{  operators

fco2/Intrinsics.hs

@@ -0,0 +1,16 @@
+-- | Definitions of intrinsic FUNCTIONs and PROCs.
+module Intrinsics where
+
+import qualified AST as A
+
+intrinsicFunctions :: [(String, ([A.Type], [(A.Type, String)]))]
+intrinsicFunctions =
+    [ ("SQRT", ([A.Real32], [(A.Real32, "value")]))
+    , ("DSQRT", ([A.Real64], [(A.Real64, "value")]))
+    ]
+
+intrinsicProcs :: [(String, [(A.AbbrevMode, A.Type, String)])]
+intrinsicProcs =
+    [ ("ASSERT", [(A.ValAbbrev, A.Bool, "value")])
+    ]
+

fco2/LANGUAGE

@@ -12,4 +12,6 @@ what gets inlined).
 
 Intrinsics:
 - ASSERT
+- SQRT
+- DSQRT
 

fco2/Makefile

@@ -9,6 +9,7 @@ sources = \
 	EvalLiterals.hs \
 	GenerateC.hs \
 	Indentation.hs \
+	Intrinsics.hs \
 	Main.hs \
 	Metadata.hs \
 	Parse.hs \

fco2/Parse.hs

@@ -18,6 +18,7 @@ import Errors
 import EvalConstants
 import EvalLiterals
 import Indentation
+import Intrinsics
 import Metadata
 import ParseState
 import Pass
@@ -746,41 +747,9 @@ character
     <?> "character"
 --}}}
 --{{{ expressions
-functionNameSingle :: OccParser A.Name
-functionNameSingle
-    =  do n <- functionName
-          rts <- returnTypesOfFunction n
-          case rts of
-            [_] -> return n
-            _ -> pzero
-    <?> "function with single return value"
-
-functionNameMulti :: OccParser A.Name
-functionNameMulti
-    =  do n <- functionName
-          rts <- returnTypesOfFunction n
-          case rts of
-            [_] -> pzero
-            _ -> return n
-    <?> "function with multiple return values"
-
-functionActuals :: A.Name -> OccParser [A.Expression]
-functionActuals func
-    =  do A.Function _ _ fs _ <- specTypeOfName func
-          let ats = [t | A.Formal _ t _ <- fs]
-          sLeftR
-          es <- intersperseP (map expressionOfType ats) sComma
-          sRightR
-          return es
-
 expressionList :: [A.Type] -> OccParser A.ExpressionList
 expressionList types
-    =   do m <- md
-           n <- try functionNameMulti
-           as <- functionActuals n
-           rts <- returnTypesOfFunction n
-           matchTypes types rts
-           return $ A.FunctionCallList m n as
+    =   functionMulti types
     <|> do m <- md
            es <- intersperseP (map expressionOfType types) sComma
            return $ A.ExpressionList m es
@@ -870,6 +839,73 @@ operandOfType wantT
           matchType wantT t
           return o
 --}}}
+--{{{ functions
+functionNameValued :: Bool -> OccParser A.Name
+functionNameValued isMulti
+    =  do n <- functionName
+          rts <- returnTypesOfFunction n
+          case (rts, isMulti) of
+            ([_], False) -> return n
+            ((_:_:_), True) -> return n
+            _ -> pzero
+    <?> "function name"
+
+functionActuals :: [A.Formal] -> OccParser [A.Expression]
+functionActuals fs
+    =  do let actuals = [expressionOfType t <?> "actual for " ++ show n
+                         | A.Formal _ t n <- fs]
+          es <- intersperseP actuals sComma
+          return es
+
+functionSingle :: OccParser A.Expression
+functionSingle
+    =  do m <- md
+          n <- tryVX (functionNameValued False) sLeftR
+          A.Function _ _ fs _ <- specTypeOfName n
+          as <- functionActuals fs
+          sRightR
+          return $ A.FunctionCall m n as
+    <?> "single-valued function call"
+
+functionMulti :: [A.Type] -> OccParser A.ExpressionList
+functionMulti types
+    =  do m <- md
+          n <- tryVX (functionNameValued True) sLeftR
+          A.Function _ _ fs _ <- specTypeOfName n
+          as <- functionActuals fs
+          sRightR
+          rts <- returnTypesOfFunction n
+          matchTypes types rts
+          return $ A.FunctionCallList m n as
+    <?> "multi-valued function call"
+--}}}
+--{{{ intrinsic functions
+intrinsicFunctionName :: Bool -> OccParser (String, [A.Type], [A.Formal])
+intrinsicFunctionName isMulti
+    =  do n <- anyName A.FunctionName
+          let s = A.nameName n
+          case (lookup s intrinsicFunctions, isMulti) of
+            (Nothing, _) -> pzero
+            (Just ([_], _), True) -> pzero
+            (Just ((_:_:_), _), False) -> pzero
+            (Just (rts, tns), _) ->
+              return (s, rts, [A.Formal A.ValAbbrev t (A.Name emptyMeta A.VariableName n)
+                               | (t, n) <- tns])
+    <?> "intrinsic function name"
+
+intrinsicFunctionSingle :: OccParser A.Expression
+intrinsicFunctionSingle
+    =  do m <- md
+          (s, _, fs) <- tryVX (intrinsicFunctionName False) sLeftR
+          as <- functionActuals fs
+          sRightR
+          return $ A.IntrinsicFunctionCall m s as
+    <?> "single-valued intrinsic function call"
+
+-- No support for multi-valued intrinsic functions, because I don't think there
+-- are likely to be any, and supporting them in the C backend is slightly
+-- tricky.
+--}}}
 
 monadicOperator :: OccParser A.MonadicOp
 monadicOperator
@@ -965,7 +1001,8 @@ operandNotTable'
     <|> do { m <- md; l <- literal; return $ A.ExprLiteral m l }
     <|> do { sLeftR; e <- expression; sRightR; return e }
 -- XXX value process
-    <|> do { m <- md; n <- try functionNameSingle; as <- functionActuals n; return $ A.FunctionCall m n as }
+    <|> functionSingle
+    <|> intrinsicFunctionSingle
     <|> do m <- md
            sBYTESIN
            sLeftR
@@ -1720,11 +1757,6 @@ actual (A.Formal am t n)
       an = A.nameName n
 --}}}
 --{{{ intrinsic PROC call
-intrinsicProcs :: [(String, [(A.AbbrevMode, A.Type, String)])]
-intrinsicProcs =
-    [ ("ASSERT", [(A.ValAbbrev, A.Bool, "value")])
-    ]
-
 intrinsicProcName :: OccParser (String, [A.Formal])
 intrinsicProcName
     =  do n <- anyName A.ProcName
@@ -1737,11 +1769,11 @@ intrinsicProcName
 intrinsicProc :: OccParser A.Process
 intrinsicProc
     =  do m <- md
-          (n, fs) <- tryVX intrinsicProcName sLeftR
+          (s, fs) <- tryVX intrinsicProcName sLeftR
           as <- actuals fs
           sRightR
           eol
-          return $ A.IntrinsicProcCall m n as
+          return $ A.IntrinsicProcCall m s as
     <?> "intrinsic PROC instance"
 --}}}
 --{{{ preprocessor directives

fco2/Types.hs

@@ -11,6 +11,7 @@ import Data.Maybe
 import qualified AST as A
 import Errors
 import EvalLiterals
+import Intrinsics
 import ParseState
 import Metadata
 
@@ -143,6 +144,7 @@ typeOfExpression e
         A.True m -> return A.Bool
         A.False m -> return A.Bool
         A.FunctionCall m n es -> liftM head $ returnTypesOfFunction n
+        A.IntrinsicFunctionCall _ s _ -> liftM head $ returnTypesOfIntrinsic s
         A.SubscriptedExpr m s e ->
           typeOfExpression e >>= subscriptType s
         A.BytesInExpr m e -> return A.Int
@@ -166,6 +168,12 @@ returnTypesOfFunction n
                  checkJust "not defined as a function" $
                    lookup (A.nameName n) (psFunctionReturns ps)
 
+returnTypesOfIntrinsic :: (PSM m, Die m) => String -> m [A.Type]
+returnTypesOfIntrinsic s
+    = case lookup s intrinsicFunctions of
+        Just (rts, _) -> return rts
+        Nothing -> die $ "unknown intrinsic function " ++ s
+
 -- | Get the items in a channel's protocol (for typechecking).
 -- Returns Left if it's a simple protocol, Right if it's tagged.
 protocolItems :: (PSM m, Die m) => A.Variable -> m (Either [A.Type] [(A.Name, [A.Type])])

fco2/fco_support.h

@@ -1,4 +1,5 @@
 // C99 support definitions for FCO.
+// vim:set foldmethod=marker:
 
 #ifndef FCO_SUPPORT_H
 #define FCO_SUPPORT_H
@@ -9,9 +10,11 @@
 #include <limits.h>
 #include <float.h>
 #include <stdio.h>
+#include <math.h>
 
 #include <cifccsp.h>
 
+//{{{ mostneg/mostpos
 #define occam_mostneg_bool false
 #define occam_mostpos_bool true
 #define occam_mostneg_char CHAR_MIN
@@ -28,7 +31,9 @@
 #define occam_mostpos_float FLT_MAX
 #define occam_mostneg_double -DBL_MAX
 #define occam_mostpos_double DBL_MAX
+//}}}
 
+//{{{ compiler-specific attributes
 #ifdef __GNUC__
 #define occam_struct_packed __attribute__ ((packed))
 #define occam_unused __attribute__ ((unused))
@@ -37,7 +42,9 @@
 #define occam_struct_packed
 #define occam_unused
 #endif
+//}}}
 
+//{{{ runtime check functions
 #define occam_stop(pos, format, args...) \
 	do { \
 		EXTERNAL_CALLN (fprintf, stderr, "Program stopped at %s: " format "\n", pos, ##args); \
@@ -59,7 +66,9 @@ static int occam_check_index (int i, int limit, const char *pos) {
 	}
 	return i;
 }
+//}}}
 
+//{{{ type-specific runtime checks
 #define MAKE_RANGE_CHECK(type, format) \
 	static type occam_range_check_##type (type, type, type, const char *) occam_unused; \
 	static type occam_range_check_##type (type lower, type upper, type n, const char *pos) { \
@@ -163,5 +172,20 @@ MAKE_DIV(double)
 #undef MAKE_MUL
 #undef MAKE_DIV
 #undef MAKE_REM
+//}}}
+
+//{{{ intrinsics
+// FIXME These should do range checks.
+
+static float occam_SQRT (float, const char *) occam_unused;
+static float occam_SQRT (float v, const char *pos) {
+	return sqrtf (v);
+}
+
+static double occam_DSQRT (double, const char *) occam_unused;
+static double occam_DSQRT (double v, const char *pos) {
+	return sqrt (v);
+}
+//}}}
 
 #endif

fco2/testcases/intrinsics.occ

@@ -1,4 +1,6 @@
 PROC P ()
+  REAL32 r:
+  REAL64 d:
   SEQ
     ASSERT (TRUE)
     -- check we can override an intrinsic
@@ -6,4 +8,8 @@ PROC P ()
       SKIP
     :
     ASSERT (FALSE)
+
+    r := SQRT (3.141)
+    r := 41.5 + SQRT (SQRT (SQRT (4.0)))
+    d := DSQRT (3.141 (REAL64))
 :