7b58024 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Merge pull request #2547 from Melvar/fix-number-show

Fix show for negative numbers

commit7b580241eabf2dcf8ff14a7b369ac6006e78ca0c authorDavid Christiansen <david@davidchristiansen.dk> dateWed 26 Aug 2015, 09:08 (11 years ago) parentf5aecf7 9dd4233

7 files changed+138−240

compare with master

unifiedsplit

libs/prelude/Prelude/Show.idr+11−8 rts/idris_rts.c+1−1 src/IRTS/CodegenJavaScript.hs+75−184 src/IRTS/JavaScript/AST.hs+1−1 test/primitives002/expected+13−13 test/primitives002/run+34−30 test/quasiquote001/expected+3−3

libs/prelude/Prelude/Show.idr+11−8

@@ -91,19 +91,22 @@ showCon d conName shownArgs = showParens (d >= App) $ conName ++ shownArgs

9191showArg : Show a => (x : a) -> String

9292showArg x = " " ++ showPrec App x

9393

94+firstCharIs : (Char -> Bool) -> String -> Bool

95+firstCharIs p s with (strM s)

96+ firstCharIs p "" | StrNil = False

97+ firstCharIs p (strCons c cs) | StrCons c cs = p c

98+

99+primNumShow : (a -> String) -> Prec -> a -> String

100+primNumShow f d x = let str = f x in showParens (d >= PrefixMinus && firstCharIs (== '-') str) str

101+

94102instance Show Int where

95− show = prim__toStrInt

103+ showPrec = primNumShow prim__toStrInt

96104

97105instance Show Integer where

98− show = prim__toStrBigInt

106+ showPrec = primNumShow prim__toStrBigInt

99107

100108instance Show Double where

101− show = prim__floatToStr

102−

103−firstCharIs : (Char -> Bool) -> String -> Bool

104−firstCharIs p s with (strM s)

105− firstCharIs p "" | StrNil = False

106− firstCharIs p (strCons c cs) | StrCons c cs = p c

109+ showPrec = primNumShow prim__floatToStr

107110

108111protectEsc : (Char -> Bool) -> String -> String -> String

109112protectEsc p f s = f ++ (if firstCharIs p s then "\\&" else "") ++ s

rts/idris_rts.c+1−1

@@ -470,7 +470,7 @@ VAL idris_castFloatStr(VM* vm, VAL i) {

470470 Closure* cl = allocate(sizeof(Closure) + sizeof(char)*32, 0);

471471 SETTY(cl, STRING);

472472 cl -> info.str = (char*)cl + sizeof(Closure);

473− sprintf(cl -> info.str, "%g", GETFLOAT(i));

473+ snprintf(cl -> info.str, 32, "%.16g", GETFLOAT(i));

474474 return cl;

475475}

476476

src/IRTS/CodegenJavaScript.hs+75−184

@@ -695,15 +695,15 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

695695 | (LSRem (ATInt ITBig)) <- op

696696 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]

697697 | (LEq (ATInt ITBig)) <- op

698− , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]

698+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]

699699 | (LSLt (ATInt ITBig)) <- op

700− , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]

700+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]

701701 | (LSLe (ATInt ITBig)) <- op

702− , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]

702+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]

703703 | (LSGt (ATInt ITBig)) <- op

704− , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]

704+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]

705705 | (LSGe (ATInt ITBig)) <- op

706− , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]

706+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]

707707

708708 | (LPlus ATFloat) <- op

709709 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs

@@ -714,15 +714,15 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

714714 | (LSDiv ATFloat) <- op

715715 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs

716716 | (LEq ATFloat) <- op

717− , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs

717+ , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs

718718 | (LSLt ATFloat) <- op

719− , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs

719+ , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs

720720 | (LSLe ATFloat) <- op

721− , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs

721+ , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs

722722 | (LSGt ATFloat) <- op

723− , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs

723+ , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs

724724 | (LSGe ATFloat) <- op

725− , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs

725+ , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs

726726

727727 | (LPlus (ATInt ITChar)) <- op

728728 , (lhs:rhs:_) <- args =

@@ -761,44 +761,26 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

761761 ]

762762

763763 | (LLSHR (ITFixed IT8)) <- op

764− , (lhs:rhs:_) <- args =

765− jsPackUBits8 (

766− JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)

767− )

764+ , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp ">>" lhs rhs

768765

769766 | (LLSHR (ITFixed IT16)) <- op

770− , (lhs:rhs:_) <- args =

771− jsPackUBits16 (

772− JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)

773− )

767+ , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp ">>" lhs rhs

774768

775769 | (LLSHR (ITFixed IT32)) <- op

776− , (lhs:rhs:_) <- args =

777− jsPackUBits32 (

778− JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)

779− )

770+ , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp ">>" lhs rhs

780771

781772 | (LLSHR (ITFixed IT64)) <- op

782773 , (lhs:rhs:_) <- args =

783774 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]

784775

785776 | (LSHL (ITFixed IT8)) <- op

786− , (lhs:rhs:_) <- args =

787− jsPackUBits8 (

788− JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)

789− )

777+ , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "<<" lhs rhs

790778

791779 | (LSHL (ITFixed IT16)) <- op

792− , (lhs:rhs:_) <- args =

793− jsPackUBits16 (

794− JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)

795− )

780+ , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "<<" lhs rhs

796781

797782 | (LSHL (ITFixed IT32)) <- op

798− , (lhs:rhs:_) <- args =

799− jsPackUBits32 (

800− JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)

801− )

783+ , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "<<" lhs rhs

802784

803785 | (LSHL (ITFixed IT64)) <- op

804786 , (lhs:rhs:_) <- args =

@@ -807,88 +789,52 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

807789 ]

808790

809791 | (LAnd (ITFixed IT8)) <- op

810− , (lhs:rhs:_) <- args =

811− jsPackUBits8 (

812− JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

813− )

792+ , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "&" lhs rhs

814793

815794 | (LAnd (ITFixed IT16)) <- op

816− , (lhs:rhs:_) <- args =

817− jsPackUBits16 (

818− JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

819− )

795+ , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "&" lhs rhs

820796

821797 | (LAnd (ITFixed IT32)) <- op

822− , (lhs:rhs:_) <- args =

823− jsPackUBits32 (

824− JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

825− )

798+ , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "&" lhs rhs

826799

827800 | (LAnd (ITFixed IT64)) <- op

828801 , (lhs:rhs:_) <- args =

829802 jsMeth (translateReg lhs) "and" [translateReg rhs]

830803

831804 | (LOr (ITFixed IT8)) <- op

832− , (lhs:rhs:_) <- args =

833− jsPackUBits8 (

834− JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

835− )

805+ , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "|" lhs rhs

836806

837807 | (LOr (ITFixed IT16)) <- op

838− , (lhs:rhs:_) <- args =

839− jsPackUBits16 (

840− JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

841− )

808+ , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "|" lhs rhs

842809

843810 | (LOr (ITFixed IT32)) <- op

844− , (lhs:rhs:_) <- args =

845− jsPackUBits32 (

846− JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

847− )

811+ , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "|" lhs rhs

848812

849813 | (LOr (ITFixed IT64)) <- op

850814 , (lhs:rhs:_) <- args =

851815 jsMeth (translateReg lhs) "or" [translateReg rhs]

852816

853817 | (LXOr (ITFixed IT8)) <- op

854− , (lhs:rhs:_) <- args =

855− jsPackUBits8 (

856− JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

857− )

818+ , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "^" lhs rhs

858819

859820 | (LXOr (ITFixed IT16)) <- op

860− , (lhs:rhs:_) <- args =

861− jsPackUBits16 (

862− JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

863− )

821+ , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "^" lhs rhs

864822

865823 | (LXOr (ITFixed IT32)) <- op

866− , (lhs:rhs:_) <- args =

867− jsPackUBits32 (

868− JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

869− )

824+ , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "^" lhs rhs

870825

871826 | (LXOr (ITFixed IT64)) <- op

872827 , (lhs:rhs:_) <- args =

873828 jsMeth (translateReg lhs) "xor" [translateReg rhs]

874829

875830 | (LPlus (ATInt (ITFixed IT8))) <- op

876− , (lhs:rhs:_) <- args =

877− jsPackUBits8 (

878− JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

879− )

831+ , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "+" lhs rhs

880832

881833 | (LPlus (ATInt (ITFixed IT16))) <- op

882− , (lhs:rhs:_) <- args =

883− jsPackUBits16 (

884− JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

885− )

834+ , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "+" lhs rhs

886835

887836 | (LPlus (ATInt (ITFixed IT32))) <- op

888− , (lhs:rhs:_) <- args =

889− jsPackUBits32 (

890− JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

891− )

837+ , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "+" lhs rhs

892838

893839 | (LPlus (ATInt (ITFixed IT64))) <- op

894840 , (lhs:rhs:_) <- args =

@@ -897,22 +843,13 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

897843 ]

898844

899845 | (LMinus (ATInt (ITFixed IT8))) <- op

900− , (lhs:rhs:_) <- args =

901− jsPackUBits8 (

902− JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

903− )

846+ , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "-" lhs rhs

904847

905848 | (LMinus (ATInt (ITFixed IT16))) <- op

906− , (lhs:rhs:_) <- args =

907− jsPackUBits16 (

908− JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

909− )

849+ , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "-" lhs rhs

910850

911851 | (LMinus (ATInt (ITFixed IT32))) <- op

912− , (lhs:rhs:_) <- args =

913− jsPackUBits32 (

914− JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

915− )

852+ , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "-" lhs rhs

916853

917854 | (LMinus (ATInt (ITFixed IT64))) <- op

918855 , (lhs:rhs:_) <- args =

@@ -921,22 +858,13 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

921858 ]

922859

923860 | (LTimes (ATInt (ITFixed IT8))) <- op

924− , (lhs:rhs:_) <- args =

925− jsPackUBits8 (

926− JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

927− )

861+ , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "*" lhs rhs

928862

929863 | (LTimes (ATInt (ITFixed IT16))) <- op

930− , (lhs:rhs:_) <- args =

931− jsPackUBits16 (

932− JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

933− )

864+ , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "*" lhs rhs

934865

935866 | (LTimes (ATInt (ITFixed IT32))) <- op

936− , (lhs:rhs:_) <- args =

937− jsPackUBits32 (

938− JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

939− )

867+ , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "*" lhs rhs

940868

941869 | (LTimes (ATInt (ITFixed IT64))) <- op

942870 , (lhs:rhs:_) <- args =

@@ -945,110 +873,62 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

945873 ]

946874

947875 | (LEq (ATInt (ITFixed IT8))) <- op

948− , (lhs:rhs:_) <- args =

949− jsPackUBits8 (

950− JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

951− )

876+ , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs

952877

953878 | (LEq (ATInt (ITFixed IT16))) <- op

954− , (lhs:rhs:_) <- args =

955− jsPackUBits16 (

956− JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

957− )

879+ , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs

958880

959881 | (LEq (ATInt (ITFixed IT32))) <- op

960− , (lhs:rhs:_) <- args =

961− jsPackUBits32 (

962− JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

963− )

882+ , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs

964883

965884 | (LEq (ATInt (ITFixed IT64))) <- op

966− , (lhs:rhs:_) <- args =

967− jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [

968− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)

969− ]

885+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]

970886

971887 | (LLt (ITFixed IT8)) <- op

972− , (lhs:rhs:_) <- args =

973− jsPackUBits8 (

974− JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

975− )

888+ , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs

976889

977890 | (LLt (ITFixed IT16)) <- op

978− , (lhs:rhs:_) <- args =

979− jsPackUBits16 (

980− JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

981− )

891+ , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs

982892

983893 | (LLt (ITFixed IT32)) <- op

984− , (lhs:rhs:_) <- args =

985− jsPackUBits32 (

986− JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

987− )

894+ , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs

988895

989896 | (LLt (ITFixed IT64)) <- op

990− , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]

897+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]

991898

992899 | (LLe (ITFixed IT8)) <- op

993− , (lhs:rhs:_) <- args =

994− jsPackUBits8 (

995− JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

996− )

900+ , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs

997901

998902 | (LLe (ITFixed IT16)) <- op

999− , (lhs:rhs:_) <- args =

1000− jsPackUBits16 (

1001− JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

1002− )

903+ , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs

1003904

1004905 | (LLe (ITFixed IT32)) <- op

1005− , (lhs:rhs:_) <- args =

1006− jsPackUBits32 (

1007− JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

1008− )

906+ , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs

1009907

1010908 | (LLe (ITFixed IT64)) <- op

1011− , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]

909+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]

1012910

1013911 | (LGt (ITFixed IT8)) <- op

1014− , (lhs:rhs:_) <- args =

1015− jsPackUBits8 (

1016− JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

1017− )

912+ , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs

1018913

1019914 | (LGt (ITFixed IT16)) <- op

1020− , (lhs:rhs:_) <- args =

1021− jsPackUBits16 (

1022− JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

1023− )

915+ , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs

1024916 | (LGt (ITFixed IT32)) <- op

1025− , (lhs:rhs:_) <- args =

1026− jsPackUBits32 (

1027− JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

1028− )

917+ , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs

1029918

1030919 | (LGt (ITFixed IT64)) <- op

1031− , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]

920+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]

1032921

1033922 | (LGe (ITFixed IT8)) <- op

1034− , (lhs:rhs:_) <- args =

1035− jsPackUBits8 (

1036− JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

1037− )

923+ , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs

1038924

1039925 | (LGe (ITFixed IT16)) <- op

1040− , (lhs:rhs:_) <- args =

1041− jsPackUBits16 (

1042− JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

1043− )

926+ , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs

1044927 | (LGe (ITFixed IT32)) <- op

1045− , (lhs:rhs:_) <- args =

1046− jsPackUBits32 (

1047− JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

1048− )

928+ , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs

1049929

1050930 | (LGe (ITFixed IT64)) <- op

1051− , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]

931+ , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]

1052932

1053933 | (LUDiv (ITFixed IT8)) <- op

1054934 , (lhs:rhs:_) <- args =

@@ -1150,8 +1030,7 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

11501030 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)

11511031

11521032 | (LCompl (ITFixed IT64)) <- op

1153− , (arg:_) <- args =

1154− invokeMeth arg "not" []

1033+ , (arg:_) <- args = invokeMeth arg "not" []

11551034

11561035 | (LPlus _) <- op

11571036 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs

@@ -1164,15 +1043,15 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

11641043 | (LSRem _) <- op

11651044 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs

11661045 | (LEq _) <- op

1167− , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs

1046+ , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs

11681047 | (LSLt _) <- op

1169− , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs

1048+ , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs

11701049 | (LSLe _) <- op

1171− , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs

1050+ , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs

11721051 | (LSGt _) <- op

1173− , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs

1052+ , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs

11741053 | (LSGe _) <- op

1175− , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs

1054+ , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs

11761055 | (LAnd _) <- op

11771056 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs

11781057 | (LOr _) <- op

@@ -1189,9 +1068,9 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

11891068 | LStrConcat <- op

11901069 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs

11911070 | LStrEq <- op

1192− , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs

1071+ , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs

11931072 | LStrLt <- op

1194− , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs

1073+ , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs

11951074 | LStrLen <- op

11961075 , (arg:_) <- args = JSProj (translateReg arg) "length"

11971076 | (LStrInt ITNative) <- op

@@ -1269,13 +1148,25 @@ jsOP _ reg op args = JSAssign (translateReg reg) jsOP'

12691148 , _ <- args = JSNull

12701149 | LExternal ex <- op

12711150 , ex == sUN "prim__eqPtr"

1272− , [lhs, rhs] <- args = JSBinOp "==" (translateReg lhs) (translateReg rhs)

1151+ , [lhs, rhs] <- args = translateCompareOp "==" lhs rhs

12731152 | otherwise = JSError $ "Not implemented: " ++ show op

12741153 where

12751154 translateBinaryOp :: String -> Reg -> Reg -> JS

12761155 translateBinaryOp op lhs rhs =

12771156 JSBinOp op (translateReg lhs) (translateReg rhs)

12781157

1158+ translateCompareOp :: String -> Reg -> Reg -> JS

1159+ translateCompareOp op lhs rhs =

1160+ JSPreOp "+" $ translateBinaryOp op lhs rhs

1161+

1162+ bitsBinaryOp :: String -> Reg -> Reg -> JS

1163+ bitsBinaryOp op lhs rhs =

1164+ JSBinOp op (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))

1165+

1166+ bitsCompareOp :: String -> Reg -> Reg -> JS

1167+ bitsCompareOp op lhs rhs =

1168+ JSPreOp "+" $ bitsBinaryOp op lhs rhs

1169+

12791170 invokeMeth :: Reg -> String -> [Reg] -> JS

12801171 invokeMeth obj meth args =

12811172 JSApp (JSProj (translateReg obj) meth) $ map translateReg args

src/IRTS/JavaScript/AST.hs+1−1

@@ -194,7 +194,7 @@ compileJS' indent (JSBinOp op lhs rhs) =

194194 `T.append` compileJS' indent rhs

195195

196196compileJS' indent (JSPreOp op val) =

197− T.pack op `T.append` compileJS' indent val

197+ T.pack op `T.append` "(" `T.append` compileJS' indent val `T.append` ")"

198198

199199compileJS' indent (JSProj obj field)

200200 | JSFunction {} <- obj =

test/primitives002/expected+13−13

@@ -1,15 +1,15 @@

11prim__floatToStr 0.0

2−"0.0"

3−prim__strToFloat "0.0"

4−0.0

2+"0"

3+prim__strToFloat 0.0

4+0

55prim__addFloat 1.0 1.0

6−2.0

6+2

77prim__subFloat 1.0 1.0

8−0.0

8+0

99prim__mulFloat 1.0 1.0

10−1.0

10+1

1111prim__divFloat 1.0 1.0

12−1.0

12+1

1313prim__slteFloat 1.0 1.0

14141

1515prim__sltFloat 1.0 1.0

@@ -21,13 +21,13 @@ prim__sgtFloat 1.0 1.0

2121prim__eqFloat 1.0 1.0

22221

2323prim__floatACos 1.0

24−0.0

24+0

2525prim__floatATan 1.0

26260.78539816

2727prim__floatCos 1.0

28280.54030230

2929prim__floatFloor 1.0

30−1.0

30+1

3131prim__floatSin 1.0

32320.84147098

3333prim__floatTan 1.0

@@ -35,12 +35,12 @@ prim__floatTan 1.0

3535prim__floatASin 1.0

36361.57079632

3737prim__floatCeil 1.0

38−1.0

38+1

3939prim__floatExp 1.0

40402.71828182

4141prim__floatLog 1.0

42−0.0

42+0

4343prim__floatSqrt 1.0

44−1.0

44+1

4545prim__negFloat 1.0

46−-1.0

46+-1

test/primitives002/run+34−30

@@ -1,37 +1,41 @@

11#!/usr/bin/env bash

3−HEAD="module Main

3+HEAD='module Main

55import Data.Floats

77strtake : Nat -> String -> String

88strtake n str = pack (take n (unpack str))

10−main : IO ()"

11−

12−TESTS=("prim__floatToStr 0.0"

13−"prim__strToFloat \"0.0\""

14−"prim__addFloat 1.0 1.0"

15−"prim__subFloat 1.0 1.0"

16−"prim__mulFloat 1.0 1.0"

17−"prim__divFloat 1.0 1.0"

18−"prim__slteFloat 1.0 1.0"

19−"prim__sltFloat 1.0 1.0"

20−"prim__sgteFloat 1.0 1.0"

21−"prim__sgtFloat 1.0 1.0"

22−"prim__eqFloat 1.0 1.0"

23−"prim__floatACos 1.0"

24−"prim__floatATan 1.0"

25−"prim__floatCos 1.0"

26−"prim__floatFloor 1.0"

27−"prim__floatSin 1.0"

28−"prim__floatTan 1.0"

29−"prim__floatASin 1.0"

30−"prim__floatCeil 1.0"

31−"prim__floatExp 1.0"

32−"prim__floatLog 1.0"

33−"prim__floatSqrt 1.0"

34−"prim__negFloat 1.0"

10+getf : IO Double

11+getf = map cast getLine

12+

13+main : IO ()'

14+

15+# code separated from input with '#'

16+TESTS=('prim__floatToStr !getf#0.0'

17+ 'prim__strToFloat !getLine#0.0'

18+$'prim__addFloat !getf !getf#1.0\n1.0'

19+$'prim__subFloat !getf !getf#1.0\n1.0'

20+$'prim__mulFloat !getf !getf#1.0\n1.0'

21+$'prim__divFloat !getf !getf#1.0\n1.0'

22+$'prim__slteFloat !getf !getf#1.0\n1.0'

23+$'prim__sltFloat !getf !getf#1.0\n1.0'

24+$'prim__sgteFloat !getf !getf#1.0\n1.0'

25+$'prim__sgtFloat !getf !getf#1.0\n1.0'

26+$'prim__eqFloat !getf !getf#1.0\n1.0'

27+ 'prim__floatACos !getf#1.0'

28+ 'prim__floatATan !getf#1.0'

29+ 'prim__floatCos !getf#1.0'

30+ 'prim__floatFloor !getf#1.0'

31+ 'prim__floatSin !getf#1.0'

32+ 'prim__floatTan !getf#1.0'

33+ 'prim__floatASin !getf#1.0'

34+ 'prim__floatCeil !getf#1.0'

35+ 'prim__floatExp !getf#1.0'

36+ 'prim__floatLog !getf#1.0'

37+ 'prim__floatSqrt !getf#1.0'

38+ 'prim__negFloat !getf#1.0'

3539)

3640

3741generate_testfile()

@@ -44,9 +48,9 @@ EOF

4448

4549for T in "${TESTS[@]}"

4650do

47− echo ${T}

48− generate_testfile "tmptest.idr" "${T}"

49− idris $@ --quiet tmptest.idr -o tmptest || echo "missing primitive in ${CG}"

50− ./tmptest

51+ echo ${T%% *} ${T##*#}

52+ generate_testfile "tmptest.idr" "${T%%#*}"

53+ idris "$@" --quiet tmptest.idr -o tmptest || echo "missing primitive in ${CG}"

54+ ./tmptest <<<"${T##*#}"

5155 rm tmptest.idr tmptest.ibc tmptest

5256done

test/quasiquote001/expected+3−3

@@ -1,5 +1,5 @@

1−App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0) (TType (UVar -1))) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN "Unit") (TType (UVar -1)))) (P (DCon 0 0) (UN "MkUnit") (P (TCon 0 0) (UN "Unit") Erased))) (App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0) (TType (UVar -1))) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN "Unit") (TType (UVar -1)))) (P (DCon 0 0) (UN "MkUnit") (P (TCon 0 0) (UN "Unit") Erased))) (App (P (DCon 0 1) (NS (UN "Nil") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar -1)) (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 0)))) (P (TCon 8 0) (UN "Unit") (TType (UVar -1)))))

1+App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (MN 0 "_t") (Pi (V 0) (TType (UVar (-1)))) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN "Unit") (TType (UVar (-1))))) (P (DCon 0 0) (UN "MkUnit") (P (TCon 0 0) (UN "Unit") Erased))) (App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (MN 0 "_t") (Pi (V 0) (TType (UVar (-1)))) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN "Unit") (TType (UVar (-1))))) (P (DCon 0 0) (UN "MkUnit") (P (TCon 0 0) (UN "Unit") Erased))) (App (P (DCon 0 1) (NS (UN "Nil") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 0)))) (P (TCon 8 0) (UN "Unit") (TType (UVar (-1))))))

22--------------

3−App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0) (TType (UVar -1))) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 24))) (TType (UVar 25))) (App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0) (TType (UVar -1))) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 26))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (UN "B") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (UN "a") (Pi (V 1) (TType (UVar -1))) (Bind (UN "b") (Pi (V 1) (TType (UVar -1))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar -1)))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar -1))))) (App (P (DCon 0 1) (NS (UN "Nil") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar -1)) (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar 27))))

3+App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (MN 0 "_t") (Pi (V 0) (TType (UVar (-1)))) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 24))) (TType (UVar 25))) (App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (MN 0 "_t") (Pi (V 0) (TType (UVar (-1)))) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 26))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "B") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "a") (Pi (V 1) (TType (UVar (-1)))) (Bind (UN "b") (Pi (V 1) (TType (UVar (-1)))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar (-1))))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar (-1)))))) (App (P (DCon 0 1) (NS (UN "Nil") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar 27))))

44--------------

5−App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (UN "B") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (UN "a") (Pi (V 1) (TType (UVar -1))) (Bind (UN "b") (Pi (V 1) (TType (UVar -1))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (UN "B") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (UN "a") (Pi (V 1) (TType (UVar -1))) (Bind (UN "b") (Pi (V 1) (TType (UVar -1))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (TType (UVar 24))) (TType (UVar 24)))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (UN "B") (Pi (TType (UVar -1)) (TType (UVar -1))) (Bind (UN "a") (Pi (V 1) (TType (UVar -1))) (Bind (UN "b") (Pi (V 1) (TType (UVar -1))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (TType (UVar 24))) (TType (UVar 24)))

5+App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "B") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "a") (Pi (V 1) (TType (UVar (-1)))) (Bind (UN "b") (Pi (V 1) (TType (UVar (-1)))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "B") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "a") (Pi (V 1) (TType (UVar (-1)))) (Bind (UN "b") (Pi (V 1) (TType (UVar (-1)))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (TType (UVar 24))) (TType (UVar 24)))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "B") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "a") (Pi (V 1) (TType (UVar (-1)))) (Bind (UN "b") (Pi (V 1) (TType (UVar (-1)))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (TType (UVar 24))) (TType (UVar 24)))