Merge pull request #1393 from melted/select_foreign

Choose foreign string based on priority

src/Compiler/Common.idr

@@ -342,23 +342,20 @@ exists f
              | Left err => pure False
          closeFile ok
          pure True
-
--- Parse a calling convention into a backend/target for the call, and
--- a comma separated list of any other location data.
+-- Select the most preferred target from an ordered list of choices and
+-- parse the calling convention into a backend/target for the call, and
+-- a comma separated list of any other location data. For example
+-- the chez backend would supply ["scheme,chez", "scheme", "C"]. For a function with
+-- more than one string, a string with "scheme" would be preferred over one
+-- with "C" and "scheme,chez" would be preferred to both.
 -- e.g. "scheme:display" - call the scheme function 'display'
 --      "C:puts,libc,stdio.h" - call the C function 'puts' which is in
 --      the library libc and the header stdio.h
--- Returns Nothing if the string is empty (which a backend can interpret
--- however it likes)
+-- Returns Nothing if there is no match.
 export
-parseCC : String -> Maybe (String, List String)
-parseCC "" = Nothing
-parseCC str
-    = case span (/= ':') str of
-           (target, "") => Just (trim target, [])
-           (target, opts) => Just (trim target,
-                                   map trim (getOpts
-                                       (assert_total (strTail opts))))
+parseCC : List String -> List String -> Maybe (String, List String)
+parseCC [] _ = Nothing
+parseCC (target::ts) strs = findTarget target strs <|> parseCC ts strs
   where
     getOpts : String -> List String
     getOpts "" = []
@@ -366,6 +363,17 @@ parseCC str
         = case span (/= ',') str of
                (opt, "") => [opt]
                (opt, rest) => opt :: getOpts (assert_total (strTail rest))
+    hasTarget : String -> String -> Bool
+    hasTarget target str = case span (/= ':') str of
+                            (targetSpec, _) => targetSpec == target
+    findTarget : String -> List String -> Maybe (String, List String)
+    findTarget target [] = Nothing
+    findTarget target (s::xs) = if hasTarget target s
+                                  then case span (/= ':') s of
+                                        (t, "") => Just (trim t, [])
+                                        (t, opts) => Just (trim t, map trim (getOpts
+                                                                  (assert_total (strTail opts))))
+                                  else findTarget target xs
 
 export
 dylib_suffix : String

src/Compiler/Scheme/Chez.idr

@@ -272,10 +272,9 @@ schemeCall fc sfn argns ret
 useCC : {auto c : Ref Ctxt Defs} ->
         {auto l : Ref Loaded (List String)} ->
         String -> FC -> List String -> List (Name, CFType) -> CFType -> Core (String, String)
-useCC appdir fc [] args ret = throw (NoForeignCC fc)
-useCC appdir fc (cc :: ccs) args ret
-    = case parseCC cc of
-           Nothing => useCC appdir fc ccs args ret
+useCC appdir fc ccs args ret
+    = case parseCC ["scheme,chez", "scheme", "C"] ccs of
+           Nothing => throw (NoForeignCC fc)
            Just ("scheme,chez", [sfn]) =>
                do body <- schemeCall fc sfn (map fst args) ret
                   pure ("", body)
@@ -284,7 +283,7 @@ useCC appdir fc (cc :: ccs) args ret
                   pure ("", body)
            Just ("C", [cfn, clib]) => cCall appdir fc cfn clib args ret
            Just ("C", [cfn, clib, chdr]) => cCall appdir fc cfn clib args ret
-           _ => useCC appdir fc ccs args ret
+           _ => throw (NoForeignCC fc)
 
 -- For every foreign arg type, return a name, and whether to pass it to the
 -- foreign call (we don't pass '%World')

src/Compiler/Scheme/Gambit.idr

@@ -301,15 +301,14 @@ schemeCall fc sfn argns ret
 useCC : {auto c : Ref Ctxt Defs} ->
         {auto l : Ref Loaded (List String)} ->
         FC -> List String -> List (Name, CFType) -> CFType -> Core (Maybe String, (String, String))
-useCC fc [] args ret = throw (NoForeignCC fc)
-useCC fc (cc :: ccs) args ret
-    = case parseCC cc of
-           Nothing => useCC fc ccs args ret
+useCC fc ccs args ret
+    = case parseCC ["scheme,gambit", "scheme", "C"] ccs of
+           Nothing => throw (NoForeignCC fc)
            Just ("scheme,gambit", [sfn]) => pure (Nothing, (!(schemeCall fc sfn (map fst args) ret), ""))
            Just ("scheme", [sfn]) => pure (Nothing, (!(schemeCall fc sfn (map fst args) ret), ""))
            Just ("C", [cfn, clib]) => pure (Just clib, !(cCall fc cfn (fnWrapName cfn) clib args ret))
            Just ("C", [cfn, clib, chdr]) => pure (Just clib, !(cCall fc cfn (fnWrapName cfn) clib args ret))
-           _ => useCC fc ccs args ret
+           _ => throw (NoForeignCC fc)
   where
     fnWrapName : String -> String -> String
     fnWrapName cfn schemeArgName = schemeArgName ++ "-" ++ cfn ++ "-cFunWrap"

src/Compiler/Scheme/Racket.idr

@@ -260,10 +260,9 @@ useCC : {auto f : Ref Done (List String) } ->
         {auto c : Ref Ctxt Defs} ->
         {auto l : Ref Loaded (List String)} ->
         String -> FC -> List String -> List (Name, CFType) -> CFType -> Core (String, String)
-useCC appdir fc [] args ret = throw (NoForeignCC fc)
-useCC appdir fc (cc :: ccs) args ret
-    = case parseCC cc of
-           Nothing => useCC appdir fc ccs args ret
+useCC appdir fc ccs args ret
+    = case parseCC ["scheme,racket", "scheme", "C"] ccs of
+           Nothing => throw (NoForeignCC fc)
            Just ("scheme,racket", [sfn]) =>
                do body <- schemeCall fc sfn (map fst args) ret
                   pure ("", body)
@@ -272,7 +271,7 @@ useCC appdir fc (cc :: ccs) args ret
                   pure ("", body)
            Just ("C", [cfn, clib]) => cCall appdir fc cfn clib args ret
            Just ("C", [cfn, clib, chdr]) => cCall appdir fc cfn clib args ret
-           _ => useCC appdir fc ccs args ret
+           _ => throw (NoForeignCC fc)
 
 -- For every foreign arg type, return a name, and whether to pass it to the
 -- foreign call (we don't pass '%World')