From 123f2400f92ba0aaac34340b9276954bd2371743 Mon Sep 17 00:00:00 2001 From: sof Date: Fri, 14 Aug 1998 12:07:29 +0000 Subject: [PATCH] [project @ 1998-08-14 12:07:18 by sof] Front end changes to handle foreign declarations --- ghc/compiler/parser/binding.ugn | 11 +++++++++++ ghc/compiler/parser/hschooks.c | 39 +++++++++++++++++++++++++++++++++++++- ghc/compiler/parser/hslexer.flex | 8 ++++++++ ghc/compiler/parser/hsparser.y | 36 +++++++++++++++++++++++++++++++---- ghc/compiler/parser/utils.h | 9 +++++++++ 5 files changed, 98 insertions(+), 5 deletions(-) diff --git a/ghc/compiler/parser/binding.ugn b/ghc/compiler/parser/binding.ugn index 74c8a92..1d8e617 100644 --- a/ghc/compiler/parser/binding.ugn +++ b/ghc/compiler/parser/binding.ugn @@ -56,6 +56,17 @@ type binding; gibindsource : long; gibindline : long; >; + /* FFI declarations */ + + fobind : < gfobind_id : qid; + gfobind_ty : ttype; + gfobind_ext : maybe; + gfobind_flag : long; + gfobind_cc : long; + gfobind_kind : long; + gfobind_line : long; >; + + /* user-specified pragmas:XXXX */ vspec_uprag : < gvspec_id : qid; diff --git a/ghc/compiler/parser/hschooks.c b/ghc/compiler/parser/hschooks.c index 7fb06bb..5f848fe 100644 --- a/ghc/compiler/parser/hschooks.c +++ b/ghc/compiler/parser/hschooks.c @@ -5,15 +5,26 @@ in instead of the defaults. */ #include +/* Included so as to bring the right prototypes into scope */ +#include "rtsdefs.h" + #define W_ unsigned long int #define I_ long int +#if __GLASGOW_HASKELL__ >= 303 +void +ErrorHdrHook (long fd) +{ + char msg[]="\n"; + write(fd,msg,1); +} +#else void ErrorHdrHook (FILE *where) { fprintf(where, "\n"); /* no "Fail: " */ } - +#endif void OutOfHeapHook (W_ request_size, W_ heap_size) /* both in bytes */ @@ -29,6 +40,31 @@ StackOverflowHook (I_ stack_size) /* in bytes */ fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K' option to increase it.\n", stack_size); } +#if __GLASGOW_HASKELL__ >= 303 +void +PatErrorHdrHook (long fd) +{ + const char msg[]="\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\nFail:"; + write(fd,msg,sizeof(msg)-1); +} + +void +PreTraceHook (long fd) +{ + const char msg[]="\n"; + write(fd,msg,sizeof(msg)-1); +} + +void +PostTraceHook (long fd) +{ +#if 0 + const char msg[]="\n"; + write(fd,msg,sizeof(msg)-1); +#endif +} + +#else void PatErrorHdrHook (FILE *where) { @@ -46,3 +82,4 @@ PostTraceHook (FILE *where) { fprintf(where, "\n"); /* not "Trace Off" */ } +#endif diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex index a3abd5a..a5adef3 100644 --- a/ghc/compiler/parser/hslexer.flex +++ b/ghc/compiler/parser/hslexer.flex @@ -399,6 +399,14 @@ NL [\n\r] "_ccall_GC_" { RETURN(CCALL_GC); } "_casm_" { RETURN(CASM); } "_casm_GC_" { RETURN(CASM_GC); } +"foreign" { RETURN(FOREIGN); } +"export" { RETURN(EXPORT); } +"unsafe" { RETURN(UNSAFE); } +"_stdcall" { RETURN(STDCALL); } +"_ccall" { RETURN(C_CALL); } +"_pascal" { RETURN(PASCAL); } +"_fastcall" { RETURN(FASTCALL); } +"dynamic" { RETURN(DYNAMIC); } %{ /* diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 6637779..59d6f9d 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -161,7 +161,8 @@ BOOLEAN pat_check=TRUE; %token SCC %token CCALL CCALL_GC CASM CASM_GC - +%token EXPORT UNSAFE STDCALL C_CALL +%token PASCAL FASTCALL FOREIGN DYNAMIC /********************************************************************** * * @@ -239,7 +240,8 @@ BOOLEAN pat_check=TRUE; gdrhs gdpat valrhs lampats cexps gd -%type maybeexports impspec deriving +%type maybeexports impspec deriving + ext_name %type lit_constant @@ -261,10 +263,10 @@ BOOLEAN pat_check=TRUE; qvar qcon qvarop qconop qop qvark qconk qtycon qtycls gcon gconk gtycon itycon qop1 qvarop1 - ename iname + ename iname %type topdecl topdecls letdecls - typed datad newtd classd instd defaultd + typed datad newtd classd instd defaultd foreignd decl decls valdef instdef instdefs maybe_where cbody rinst type_and_maybe_id @@ -284,6 +286,7 @@ BOOLEAN pat_check=TRUE; %type export import %type commas importkey get_line_no + unsafe_flag callconv /********************************************************************** * * @@ -482,6 +485,7 @@ topdecl : typed { $$ = $1; FN = NULL; SAMEFN = 0; } | classd { $$ = $1; FN = NULL; SAMEFN = 0; } | instd { $$ = $1; FN = NULL; SAMEFN = 0; } | defaultd { $$ = $1; FN = NULL; SAMEFN = 0; } + | foreignd { $$ = $1; FN = NULL; SAMEFN = 0; } | decl { $$ = $1; } ; @@ -540,6 +544,27 @@ defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); } ; +/* FFI primitive declarations - GHC/Hugs specific */ +foreignd: foreignkey IMPORT callconv ext_name unsafe_flag qvarid DCOLON sigtype { $$ = mkfobind($6,$8,$4,$5,$3,FOREIGN_IMPORT,startlineno); } + | foreignkey EXPORT callconv ext_name qvarid DCOLON sigtype { $$ = mkfobind($5,$7,$4,0,$3,FOREIGN_EXPORT,startlineno); } + ; + +callconv: STDCALL { $$ = CALLCONV_STDCALL; } + | C_CALL { $$ = CALLCONV_CCALL; } + | PASCAL { $$ = CALLCONV_PASCAL; } + | FASTCALL { $$ = CALLCONV_FASTCALL; } + ; + +ext_name: STRING { $$ = mkjust(lsing($1)); } + | STRING STRING { $$ = mkjust(mklcons ($1,lsing($2))); } + | DYNAMIC { $$ = mknothing(); } + +unsafe_flag: UNSAFE { $$ = 1; } + | /*empty*/ { $$ = 0; } + ; + + + decls : decl | decls SEMI decl { @@ -1431,6 +1456,9 @@ instkey : INSTANCE { setstartlineno(); defaultkey: DEFAULT { setstartlineno(); } ; +foreignkey: FOREIGN { setstartlineno(); } + ; + classkey: CLASS { setstartlineno(); if(etags) #if 1/*etags*/ diff --git a/ghc/compiler/parser/utils.h b/ghc/compiler/parser/utils.h index 95389ec..8124440 100644 --- a/ghc/compiler/parser/utils.h +++ b/ghc/compiler/parser/utils.h @@ -114,6 +114,15 @@ void precparse PROTO((tree)); void checkprec PROTO((tree, qid, BOOLEAN)); */ +/* FFI predefines */ +#define CALLCONV_STDCALL 0 +#define CALLCONV_CCALL 1 +#define CALLCONV_PASCAL 2 +#define CALLCONV_FASTCALL 3 + +#define FOREIGN_IMPORT 0 +#define FOREIGN_EXPORT 1 + BOOLEAN isconstr PROTO((char *)); void setstartlineno PROTO((void)); -- 1.7.10.4