Java example source code file (PrimitiveCoder.hs)

This example Java source code file (PrimitiveCoder.hs) is included in the alvinalexander.com "Java Source Code Warehouse" project. The intent of this project is to help you "Learn Java by Example" ^TM.

Learn more about this Java project at its project page.

Java - Java tags/keywords

ffitype, jboolean, jbyte, jlong, jshort, nbool, nschar, nslong, ntype, nuchar, nulong, w32, w64, width

The PrimitiveCoder.hs Java example source code

#!/usr/bin/env runhaskell

{-
/*
 * Copyright (c) 2011, 2013, Oracle and/or its affiliates. All rights reserved.
 * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
 *
 * This code is free software; you can redistribute it and/or modify it
 * under the terms of the GNU General Public License version 2 only, as
 * published by the Free Software Foundation.  Oracle designates this
 * particular file as subject to the "Classpath" exception as provided
 * by Oracle in the LICENSE file that accompanied this code.
 *
 * This code is distributed in the hope that it will be useful, but WITHOUT
 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 * version 2 for more details (a copy is included in the LICENSE file that
 * accompanied this code).
 *
 * You should have received a copy of the GNU General Public License version
 * 2 along with this work; if not, write to the Free Software Foundation,
 * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
 *
 * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
 * or visit www.oracle.com if you need additional information or have any
 * questions.
 */
-}
{-
The simplest way to get Haskell is through MacPorts: sudo port install ghc

Otherwise, see http://www.haskell.org/ghc/
-}

import Data.List
import Data.Maybe
import Data.Char

data Width = W32 | W64
             deriving (Show, Eq, Bounded, Enum)

data NType = NBOOL | Nschar | Nuchar | Nsshort | Nushort | Nsint | Nuint
           | Nslong | Nulong | Nslonglong | Nulonglong | Nfloat | Ndouble
             deriving (Show, Eq, Bounded, Enum)

data JPrim = Jboolean | Jbyte | Jchar | Jshort | Jint | Jlong | Jfloat | Jdouble
             deriving (Show, Eq, Bounded, Enum)

data JClass = JBoolean | JByte | JCharacter | JShort | JInteger | JLong
            | JFloat | JDouble
              deriving (Show, Eq, Bounded, Enum)

data FFIType = SINT8 | UINT8 | SINT16 | UINT16 | SINT32 | UINT32
             | SINT64 | UINT64 | FLOAT | DOUBLE
             deriving (Show, Eq, Bounded, Enum)

widths = [minBound..maxBound] :: [Width]
ntypes = [minBound..maxBound] :: [NType]
jprims = [minBound..maxBound] :: [JPrim]
jclasses = [minBound..maxBound] :: [JClass]
ffitypes = [minBound..maxBound] :: [FFIType]

-- What's the FFIType for a given Width and NType? For example: W32 NBOOL -> SINT8
ffitype :: Width -> NType -> FFIType
ffitype _ NBOOL   = SINT8
ffitype _ Nschar  = SINT8
ffitype _ Nuchar  = UINT8
ffitype _ Nsshort = SINT16
ffitype _ Nushort = UINT16
ffitype _ Nsint   = SINT32
ffitype _ Nuint   = UINT32
ffitype W32 Nslong = SINT32
ffitype W64 Nslong = SINT64
ffitype W32 Nulong = UINT32
ffitype W64 Nulong = UINT64
ffitype _ Nslonglong = SINT64
ffitype _ Nulonglong = UINT64
ffitype _ Nfloat  = FLOAT
ffitype _ Ndouble = DOUBLE

sizeof :: FFIType -> Int
sizeof SINT8  = 1
sizeof UINT8  = 1
sizeof SINT16 = 2
sizeof UINT16 = 2
sizeof SINT32 = 4
sizeof UINT32 = 4
sizeof SINT64 = 8
sizeof UINT64 = 8
sizeof FLOAT  = 4
sizeof DOUBLE = 8

-- What's the Obj-C encoding for a given NType? For example: unsigned char -> 'C'
encoding nt = fromJust $ lookup nt $
              [(NBOOL, 'B'), (Nschar, 'c'), (Nuchar, 'C'), (Nsshort, 's'),
               (Nushort, 'S'), (Nsint, 'i'), (Nuint, 'I'), (Nslong, 'l'),
               (Nulong, 'L'), (Nslonglong, 'q'), (Nulonglong, 'Q'),
               (Nfloat, 'f'), (Ndouble, 'd')]

-- What's the JPrim for a given NType? For example: native signed long long -> java long
ntype2jprim nt = fromJust $ lookup nt $
                 [(NBOOL, Jboolean), (Nschar, Jbyte), (Nuchar, Jbyte),
                  (Nsshort, Jshort), (Nushort, Jshort), (Nsint, Jint), (Nuint, Jint),
                  (Nslong, Jlong), (Nulong, Jlong),
                  (Nslonglong, Jlong), (Nulonglong, Jlong),
                  (Nfloat, Jfloat), (Ndouble, Jdouble)]

-- What's the JClass for a given JPrim? For example: int -> Integer
jprim2jclass jp = fromJust $ lookup jp $
                  [(Jboolean, JBoolean), (Jbyte, JByte), (Jchar, JCharacter),
                   (Jshort, JShort), (Jint, JInteger), (Jlong, JLong),
                   (Jfloat, JFloat), (Jdouble, JDouble)]

-- Convert a type to something suitable for Java code. For example: Jboolean -> boolean
ntype2js nt = tail $ show nt
jclass2js t = tail $ show t
jprim2js p = tail $ show p
ffitype2js f = "FFI_" ++ (show f)

-- Capitalize the first letter of a String
capitalize [] = []
capitalize s = [toUpper $ head s] ++ tail s

-- Given an Width and NType, return the Java code for reading said NType from memory.
popAddr :: Width -> NType -> String
popAddr _ NBOOL   = "rt.unsafe.getByte(addr) != 0"
popAddr _ Nschar  = "rt.unsafe.getByte(addr)"
popAddr _ Nuchar  = "rt.unsafe.getByte(addr)"
popAddr W32 Nslong = "rt.unsafe.getInt(addr)"
popAddr W32 Nulong = "rt.unsafe.getInt(addr)"
popAddr _ ntype = "rt.unsafe.get" ++ (capitalize.jprim2js.ntype2jprim $ ntype) ++ "(addr)"

-- Given an Width and NType, return the Java code for writing said NType to memory.
pushAddr :: Width -> NType -> String
pushAddr _ NBOOL   = "rt.unsafe.putByte(addr, (byte) (x ? 1 : 0));"
pushAddr _ Nschar  = "rt.unsafe.putByte(addr, x);"
pushAddr _ Nuchar  = "rt.unsafe.putByte(addr, x);"
pushAddr W32 Nslong = "rt.unsafe.putInt(addr, (int) x);"
pushAddr W32 Nulong = "rt.unsafe.putInt(addr, (int) x);"
pushAddr _ ntype = "rt.unsafe.put" ++ (capitalize jprimS) ++ "(addr, (" ++ jprimS ++ ") x);"
    where jprimS = jprim2js.ntype2jprim $ ntype

-- Helpers for generating Java ternarnies and conditionals.
archExpr x32 x64 = if x32 /= x64 then retdiff else x32
    where retdiff = "(JObjCRuntime.IS64 ? (" ++ x64 ++ ") : (" ++ x32 ++ "))"

archStmt x32 x64 = if x32 /= x64 then retdiff else x32
    where retdiff = "if(JObjCRuntime.IS64){ " ++ x64 ++ " }else{ " ++ x32 ++ " }"

-- Get a Java expression for the correct FFIType at runtime. For example: (JObjCRuntime.IS64 ? FFI_SINT64 : FFI_SINT32)
ffitypeVal nt = archExpr (ffitype2js $ ffitype W32 nt)
                         (ffitype2js $ ffitype W64 nt)

-- Similar to ffiTypeVal. Get the correct pop expression and push statement.
popAddrVal nt = archExpr (popAddr W32 nt) (popAddr W64 nt)
pushAddrVal nt = archStmt (pushAddr W32 nt) (pushAddr W64 nt)

-- What's the Coder class name we're using for a given NType?
coderName nt = aux nt ++ "Coder"
    where
      aux NBOOL   = "Bool"
      aux Nschar  = "SChar"
      aux Nuchar  = "UChar"
      aux Nsshort = "SShort"
      aux Nushort = "UShort"
      aux Nsint   = "SInt"
      aux Nuint   = "UInt"
      aux Nslong  = "SLong"
      aux Nulong  = "ULong"
      aux Nslonglong   = "SLongLong"
      aux Nulonglong   = "ULongLong"
      aux Nfloat  = "Float"
      aux Ndouble = "Double"

-- Operation for converting between primitives. Usually it just casts, but booleans are special.
jconvertPrims sym Jboolean Jboolean = sym
jconvertPrims sym Jboolean b = "((" ++ jprim2js b ++ ")(" ++ sym ++ " ? 1 : 0))"
jconvertPrims sym a Jboolean = "(" ++ sym ++ " != 0)"
jconvertPrims sym a b = if a == b then sym else "((" ++ jprim2js b ++ ")" ++ sym ++ ")"

sizeofRet nt =
    let ffitypes = map (\w -> ffitype w nt) widths
        sizes = map sizeof ffitypes in
    if (length $ nub sizes) == 1
    then "\t\treturn " ++ (show.head $ sizes) ++ ";"
    else unlines [
              "\t\tswitch(w){",
              (unlines $ map casestmt widths),
              "\t\tdefault: return -1;",
               "\t\t}"]
    where
      casestmt w = "\t\t\tcase " ++ (show w) ++ ": return " ++
                   (show.sizeof $ ffitype w nt) ++ ";"

-- Generate a coder class for a given NType.
c2java ntype =
    unlines [
 "// native " ++ ntypeS ++ " -> java " ++ jprimS,
 "public static final class " ++ className ++ " extends PrimitiveCoder<" ++ jclassS ++ ">{",
 "\tpublic static final " ++ className ++ " INST = new " ++ className ++ "();",
 "\tpublic " ++ className ++ "(){ super("++ffitypeVal ntype++", \"" ++ [encoding ntype] ++ "\", "++jclassS++".class, "++jprimS++".class); }",
 "\t// compile time",
 "\t@Override public void push(JObjCRuntime rt, long addr, " ++ jprimS ++ " x){",
 "\t\t" ++ pushAddrVal ntype,
 "\t}",
 "\t@Override public " ++ jprimS ++ " pop" ++ capitalize jprimS ++ "(JObjCRuntime rt, long addr){",
 "\t\treturn " ++ popAddrVal ntype ++ ";",
 "\t}",
 "\t// for runtime coding",
 "\t@Override public int sizeof(Width w){",
 sizeofRet ntype,
 "\t}",
 "\t@Override public void push(JObjCRuntime rt, long addr, " ++ jclassS ++ " x){ " ++
 "push(rt, addr, (" ++ jprimS ++ ") x); }",
 "\t@Override public " ++ jclassS ++ " pop(JObjCRuntime rt, long addr){ " ++
 "return pop" ++ capitalize jprimS ++ "(rt, addr); }",
 "\t// proxies for mixed encoding",
 makeProxyMethods ntype,
 "}"
 ]
     where
       jprim = ntype2jprim ntype
       jclass = jprim2jclass jprim
       jprimS = jprim2js jprim
       jclassS = jclass2js jclass
       ntypeS = ntype2js ntype
       className = coderName ntype

-- Generate push and pop methods that convert and proxy to actual implementation.
makeProxyMethods nt = unlines $ map aux jprims
    where
      targetJPrim = ntype2jprim nt
      targetJPrimS = jprim2js targetJPrim
      aux jprim = if targetJPrim == jprim then "" else unlines [
                   "\t@Override public void push(JObjCRuntime rt, long addr, " ++ jprimS ++ " x){ " ++
                   "push(rt, addr, " ++ pushConversion "x" ++ "); }",
                   "\t@Override public " ++ jprimS ++ " pop" ++ capitalize jprimS ++ "(JObjCRuntime rt, long addr){ " ++
                   "return " ++ (popConversion ("pop" ++ capitalize targetJPrimS ++ "(rt, addr)")) ++ "; }"
                  ]
          where
            jprimS = jprim2js jprim
            pushConversion sym = jconvertPrims sym jprim targetJPrim
            popConversion sym = jconvertPrims sym targetJPrim jprim

main = do
  putStrLn "package com.apple.jobjc;"

  putStrLn "import com.apple.jobjc.JObjCRuntime.Width;"

  putStrLn "// Auto generated by PrimitiveCoder.hs"
  putStrLn "// Do not edit by hand."

  putStrLn "public abstract class PrimitiveCoder<T> extends Coder{"

  putStrLn "\tpublic PrimitiveCoder(int ffiTypeCode, String objCEncoding, Class jclass, Class jprim){"
  putStrLn "\t\tsuper(ffiTypeCode, objCEncoding, jclass, jprim);"
  putStrLn "\t}"

  mapM_ (\p -> putStrLn $ unlines [makePopI p, makePushI p]) jprims

  mapM_ (putStrLn . c2java) ntypes

  putStrLn "}"
    where
      makePopI jprim = unlines ["\tpublic final " ++ jprim2js jprim ++ " pop" ++ (capitalize.jprim2js $ jprim)
                                   ++ "(NativeArgumentBuffer args){\n"
                                   ++ "\t\treturn pop" ++ (capitalize.jprim2js $ jprim) ++ "(args.runtime, args.retValPtr);\n"
                                   ++ "\t}",
                                "\tpublic abstract " ++ jprim2js jprim ++ " pop" ++ (capitalize.jprim2js $ jprim) ++ "(JObjCRuntime runtime, long addr);"]
      makePushI jprim = unlines ["\tpublic final void push"
          ++ "(NativeArgumentBuffer args, " ++ jprim2js jprim ++ " x){\n"
          ++ "\t\tpush(args.runtime, args.argValuesPtr, x);\n"
          ++ "\t\targs.didPutArgValue(sizeof());\n"
          ++ "\t}",
        "\tpublic abstract void push(JObjCRuntime runtime, long addr, " ++ jprim2js jprim ++ " x);"]