Commit 34e38a46 authored by John van Groningen's avatar John van Groningen

merged with backend C source code on the mac

parent b488c2f1
#include "compiledefines.h"
#ifdef KARBON
# define TARGET_API_MAC_CARBON 1
#endif
#include <stdio.h>
#include <unix.h>
#include <SIOUX.h>
......@@ -15,6 +21,7 @@
#include "Gestalt.h"
#include "AERegistry.h"
#include "types.t"
#include "system.h"
#include "path_cache.h"
#include "compiler.h"
......@@ -23,6 +30,7 @@ extern void clear_inline_cache (void);
#undef BACKGROUND
#define MW_DEBUG 0
#define NO68K
#ifndef BACKGROUND
# undef NO_REDIRECT_STDFILES
......@@ -40,22 +48,22 @@ extern void clear_inline_cache (void);
static Boolean gAppleEventsFlag, gQuitFlag;
static long gSleepVal;
static pascal OSErr DoAEOpenApplication (AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,long refCon)
static pascal OSErr DoAEOpenApplication (const AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,unsigned long refCon)
{
return noErr;
}
static pascal OSErr DoAEOpenDocuments (AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent, long refCon)
static pascal OSErr DoAEOpenDocuments (const AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,unsigned long refCon)
{
return errAEEventNotHandled;
}
static pascal OSErr DoAEPrintDocuments (AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,long refCon)
static pascal OSErr DoAEPrintDocuments (const AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,unsigned long refCon)
{
return errAEEventNotHandled;
}
static pascal OSErr DoAEQuitApplication (AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,long refCon)
static pascal OSErr DoAEQuitApplication (const AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,unsigned long refCon)
{
gQuitFlag = true;
return noErr;
......@@ -68,15 +76,19 @@ extern int CallCompiler (int argc,char **argv);
#ifdef CODE_GENERATOR
# ifdef __cplusplus
extern "C" { int generate_code (int,char **); }
# ifndef NO68K
extern int generate_code68 (int,char **);
# endif
# else
extern int generate_code (int,char **);
# ifndef NO68K
extern int generate_code68__FiPPc (int,char **);
#define generate_code68 generate_code68__FiPPc
#define generate_code68 generate_code68__FiPPc
# endif
# endif
#endif
#ifdef LINKER
#if defined (LINKER) && !defined (NO68K)
# ifdef __cplusplus
extern "C" { int link_application_argc_argv (int,char **); }
# else
......@@ -104,7 +116,7 @@ int do_command (char *command)
++p;
while (*p!='\0' && argc<256){
if (*p=='>' || *p==''){
if (*p=='>' || *p==''){
int redirection_char;
char *file_name;
......@@ -153,7 +165,7 @@ int do_command (char *command)
freopen (file_name,"w",stdout);
redirect_stdout=1;
#endif
} else if (redirection_char=='' && redirect_stderr==0){
} else if (redirection_char=='' && redirect_stderr==0){
#ifndef NO_REDIRECT_STDFILES
freopen (file_name,"w",stderr);
redirect_stderr=1;
......@@ -215,6 +227,10 @@ int do_command (char *command)
*/
if (argc>0){
#ifdef CLEAN2
if (0)
;
#else
if (!strcmp (argv[0],"cocl")){
if (argc>=2 && !strcmp ("-clear_cache",argv[1])){
result=CallCompiler (argc-2,&argv[2]);
......@@ -224,13 +240,16 @@ int do_command (char *command)
} else
result=CallCompiler (argc-1,&argv[1]);
}
#endif
#ifdef CODE_GENERATOR
else if (!strcmp (argv[0],"cg"))
result=generate_code (argc,&argv[0]);
# ifndef NO68K
else if (!strcmp (argv[0],"cg68"))
result=generate_code68 (argc,&argv[0]);
# endif
#endif
#ifdef LINKER
#if defined (LINKER) && !defined (NO68K)
else if (!strcmp (argv[0],"linker"))
result=link_application_argc_argv (argc,&argv[0]);
#endif
......@@ -255,7 +274,13 @@ int do_command (char *command)
static char script_string[16001];
static pascal OSErr do_script_apple_event (AppleEvent *apple_event,AppleEvent *replyAppleEvent,long refCon)
#ifdef CLEAN2
int compiler_id;
#else
extern int compiler_id;
#endif
pascal OSErr do_script_apple_event (const AppleEvent *apple_event,AppleEvent *replyAppleEvent,unsigned long refCon)
{
DescType returned_type;
long actual_size;
......@@ -272,7 +297,13 @@ static pascal OSErr do_script_apple_event (AppleEvent *apple_event,AppleEvent *r
#if !MW_DEBUG
error=do_command (script_string);
#endif
if (compiler_id>=0){
error += (compiler_id+1)<<1;
compiler_id = -1;
}
return_error_string_length=strlen (return_error_string);
if (return_error_string_length!=0){
AEPutParamPtr (replyAppleEvent,keyErrorString,typeChar,return_error_string,return_error_string_length);
......@@ -337,16 +368,22 @@ int /*clean_compiler_*/ main (void)
EventRecord mainEventRec;
Boolean eventFlag;
#ifndef KARBON
SetApplLimit (GetApplLimit() - 200*1024);
InitGraf (&qd.thePort);
InitFonts();
#endif
FlushEvents (everyEvent,0);
#ifndef BACKGROUND
# ifndef KARBON
InitWindows();
# endif
InitCursor();
# ifndef KARBON
InitMenus();
# endif
#endif
_fcreator='3PRM';
......@@ -360,7 +397,7 @@ int /*clean_compiler_*/ main (void)
else
gAppleEventsFlag = false;
#ifdef STDIO_WINDOW
#if defined (STDIO_WINDOW)
SIOUXSettings.autocloseonquit=1;
SIOUXSettings.showstatusline=0;
SIOUXSettings.asktosaveonclose=0;
......
#define CODE_INLINE_FLAG
#define DYNAMIC_TYPE 1
# include "system.h"
# include "compiledefines.h"
# include "types.t"
# include "system.h"
# include "syntaxtr.t"
# include "codegen_types.h"
# include "statesgen.h"
......@@ -1022,6 +1023,52 @@ BELiteralSymbol (BESymbKind kind, CleanString value)
return (symbol);
} /* BELiteralSymbol */
#if STRICT_LISTS
void BEPredefineListConstructorSymbol(int arity,int constructorIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness)
{
BEModuleP module;
SymbolP symbol_p;
Assert (moduleIndex == kPredefinedModuleIndex);
Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
module = &gBEState.be_modules [moduleIndex];
Assert ((unsigned int) constructorIndex < module->bem_nConstructors);
symbol_p=module->bem_constructors [constructorIndex];
Assert (symbol_p->symb_kind == erroneous_symb);
symbol_p->symb_kind = symbolKind;
symbol_p->symb_arity = arity;
symbol_p->symb_head_strictness=head_strictness;
symbol_p->symb_tail_strictness=tail_strictness;
}
void BEPredefineListTypeSymbol(int typeIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness)
{
BEModuleP module;
SymbolP symbol_p;
Assert (moduleIndex == kPredefinedModuleIndex);
Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
module = &gBEState.be_modules [moduleIndex];
Assert ((unsigned int) typeIndex < module->bem_nTypes);
symbol_p=module->bem_types [typeIndex];
Assert (symbol_p->symb_kind == erroneous_symb);
symbol_p->symb_kind = symbolKind;
symbol_p->symb_arity = 1;
symbol_p->symb_head_strictness=head_strictness;
symbol_p->symb_tail_strictness=tail_strictness;
}
#endif
void
BEPredefineConstructorSymbol (int arity, int constructorIndex, int moduleIndex, BESymbKind symbolKind)
{
......@@ -2532,6 +2579,26 @@ BEGenerateCode (CleanString outputFile)
gBEState.be_icl.beicl_module->im_rules = rule;
outputFileName = ConvertCleanString (outputFile);
#if 0
{
File f;
f=fopen ("Rules","w");
if (f){
ImpRuleS *rule;
for (rule=gBEState.be_icl.beicl_module->im_rules; rule!=NULL; rule=rule->rule_next){
PrintImpRule (rule,4,f);
if (rule->rule_next!=NULL)
FPutC ('\n',f);
}
fclose (f);
}
}
#endif
CodeGeneration (gBEState.be_icl.beicl_module, outputFileName);
return (!CompilerError);
......
......@@ -200,6 +200,14 @@ Clean (BEBoolSymbol :: Bool BackEnd -> (BESymbolP, BackEnd))
BESymbolP BELiteralSymbol (BESymbKind kind, CleanString value);
Clean (BELiteralSymbol :: BESymbKind String BackEnd -> (BESymbolP, BackEnd))
/*
void BEPredefineListConstructorSymbol (int arity, int constructorIndex, int moduleIndex, BESymbKind symbolKind,int head_strictness,int tail_strictness);
Clean (BEPredefineListConstructorSymbol :: Int Int Int BESymbKind Int Int BackEnd -> BackEnd)
void BEPredefineListTypeSymbol (int typeIndex, int moduleIndex, BESymbKind symbolKind,int head_strictness,int tail_strictness);
Clean (BEPredefineListTypeSymbol :: Int Int BESymbKind Int Int BackEnd -> BackEnd)
*/
void BEPredefineConstructorSymbol (int arity, int constructorIndex, int moduleIndex, BESymbKind symbolKind);
Clean (BEPredefineConstructorSymbol :: Int Int Int BESymbKind BackEnd -> BackEnd)
......
# include "compiledefines.h"
# include "types.t"
# include "system.h"
# include "comsupport.h"
# include "backendsupport.h"
......@@ -30,6 +33,36 @@ AssertionFailed (char *conditionString, char *file, int line)
Debugger ();
}
#else
# ifdef _MAC_
{
FILE *f;
f=fopen ("AssertionFailedError","w");
if (f!=NULL){
FPrintF (f, "Error in backend: File %s, Line %d (%s)\n", file, line, conditionString);
fclose (f);
}
}
# endif
Debugger ();
#endif
} /* AssertionFailed */
void
fatal_backend_error (char *s)
{
FPrintF (StdError, "Error in backend: %s\n", s);
#ifdef _MAC_
{
FILE *f;
f=fopen ("AssertionFailedError","w");
if (f!=NULL){
FPrintF (f, "Error in backend: %s\n", s);
fclose (f);
}
}
#endif
Debugger ();
}
......@@ -12,6 +12,8 @@ typedef struct clean_string {int length; char chars [1]; } *CleanString;
extern void AssertionFailed (char *conditionString, char *file, int line);
# define Assert(condition) {if (!(condition)) AssertionFailed ("!(" #condition ")", __FILE__, __LINE__);}
extern void fatal_backend_error (char *s);
/*
Memory management
=================
......
# include "compiledefines.h"
# include "types.t"
# include "syntaxtr.t"
# include "comsupport.h"
......@@ -15,6 +17,15 @@ SymbolP BasicTypeSymbols [Nr_Of_Basic_Types],
EmptyTypeSymbol,
TupleTypeSymbols [MaxNodeArity];
#if STRICT_LISTS
SymbolP
StrictListSymbol, StrictConsSymbol, StrictNilSymbol,
UnboxedListSymbol, UnboxedConsSymbol, UnboxedNilSymbol,
TailStrictListSymbol, TailStrictConsSymbol, TailStrictNilSymbol,
StrictTailStrictListSymbol, StrictTailStrictConsSymbol, StrictTailStrictNilSymbol,
UnboxedTailStrictListSymbol, UnboxedTailStrictConsSymbol, UnboxedTailStrictNilSymbol;
#endif
char BasicTypeIds [] = BASIC_TYPE_IDS_STRING;
IdentP gArrayIdents [NrOfArrayInstances];
......
......@@ -53,6 +53,15 @@ extern NodeP NewNodeByKind (NodeKind nodeKind, SymbolP symb, Args args, int arit
# define NewNil() NewNormalNode (NilSymbol, NIL, 0)
# define NewFalse() NewNormalNode (FalseSymbol, NIL, 0)
# define NewTrue() NewNormalNode (TrueSymbol, NIL, 0)
#if STRICT_LISTS
# define NewStrictNil() NewNormalNode (StrictNilSymbol, NIL, 0)
# define NewUnboxedNil() NewNormalNode (UnboxedNilSymbol, NIL, 0)
# define NewTailStrictNil() NewNormalNode (TailStrictNilSymbol, NIL, 0)
# define NewStrictTailStrictNil() NewNormalNode (StrictTailStrictNilSymbol, NIL, 0)
# define NewUnboxedTailStrictNil() NewNormalNode (UnboxedTailStrictNilSymbol, NIL, 0)
#endif
extern NodeP NewIntNode (int value);
extern ImpRules NewRule (unsigned line_number, TypeAlts typeAlternative, NodeP rule_root, ScopeP scope);
......@@ -101,6 +110,14 @@ extern SymbolP BasicTypeSymbols [],
TrueSymbol, FalseSymbol, TupleSymbol, ListSymbol, ConsSymbol, NilSymbol,
ApplySymbol, ApplyTypeSymbol, SelectSymbols[],
FailSymbol, IfSymbol, AllSymbol, EmptyTypeSymbol;
#if STRICT_LISTS
extern SymbolP
StrictListSymbol, StrictConsSymbol, StrictNilSymbol,
UnboxedListSymbol, UnboxedConsSymbol, UnboxedNilSymbol,
TailStrictListSymbol, TailStrictConsSymbol, TailStrictNilSymbol,
StrictTailStrictListSymbol, StrictTailStrictConsSymbol, StrictTailStrictNilSymbol,
UnboxedTailStrictListSymbol, UnboxedTailStrictConsSymbol, UnboxedTailStrictNilSymbol;
#endif
extern SymbolP TupleTypeSymbols [];
IdentP UseArrayFunctionId (ArrayFunKind kind);
......
......@@ -7,6 +7,9 @@
extern Ident AnnotatedId, ListId, TupleId, ConsId, NilId, ApplyId, SelectId, IfId, FailId, DeltaBId,
AndId, OrId, StdArrayId, ArrayFunctionIds [], ArrayId, StrictArrayId, UnboxedArrayId, ArrayClassId;
#if STRICT_LISTS
extern Ident StrictListId,UnboxedListId,TailStrictListId,StrictTailStrictListId,UnboxedTailStrictListId;
#endif
#ifdef CLEAN2
extern Ident DynamicId;
#endif
......
......@@ -12,6 +12,7 @@
#define MOVE_CURRIED_APPLICATIONS
#define MOVE_FUNCTIONS_IN_LAMBDAS
#include "compiledefines.h"
#include "types.t"
#include "system.h"
#include "syntaxtr.t"
......
#include "compiledefines.h"
#include "types.t"
#include "syntaxtr.t"
#include "comsupport.h"
......
......@@ -8,6 +8,7 @@
#define COMPLEX_ABSTYPES
#include "compiledefines.h"
#include "types.t"
#include "syntaxtr.t"
#include "comsupport.h"
......
#include "compiledefines.h"
#include "system.h"
#include <ctype.h>
#include "comsupport.h"
#include "settings.h"
#include "system.h"
#include <ctype.h>
#include "compiler.h"
#include "version.h"
......
......@@ -4,6 +4,8 @@
#define SHARE_UPDATE_CODE 0 /* also in codegen1.c */
#define SELECTORS_FIRST 1 /* also in codegen2.c */
#include "compiledefines.h"
#include "types.t"
#include "system.h"
#include "syntaxtr.t"
#include "comsupport.h"
......@@ -26,7 +28,6 @@
# if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION
#include "tuple_tail_recursion.h"
# endif
#include "dbprint.h"
static char *ECodeBlock = "incorrect number of output parameters";
......
......@@ -9,8 +9,9 @@
#define FREE_STRICT_LHS_TUPLE_ELEMENTS 1 /* also in codegen2.c */
#define BIND_UNBOXED_LHS_TUPLE_AND_RECORD_ARGUMENTS_IN_BIND_ARGUMENTS 1
#include "compiledefines.h"
#include "types.t"
#include "system.h"
#include "settings.h"
#include "syntaxtr.t"
#include "comsupport.h"
......@@ -88,6 +89,11 @@ LabDef tuple_lab = {NULL, "", False, "_Tuple", 0};
LabDef empty_lab = {NULL, "", False, "_", 0};
LabDef add_arg_lab = {NULL, "", False, "_add_arg", 0};
LabDef match_error_lab = {NULL, "", False, "_match_error", 0};
#if STRICT_LISTS
LabDef conss_lab = {NULL, "", False, "_Conss", 0};
LabDef consts_lab = {NULL, "", False, "_Consts", 0};
LabDef conssts_lab = {NULL, "", False, "_Conssts", 0};
#endif
#ifdef CLEAN2
LabDef select_with_dictionary_lab = {NULL, "", False, "_select_with_dictionary", 0};
LabDef update_with_dictionary_lab = {NULL, "", False, "_update_with_dictionary", 0};
......
......@@ -16,6 +16,9 @@ extern char channel_code [],ext_nf_reducer_code[],nf_reducer_code[],hnf_reducer_
extern LabDef
cycle_lab, reserve_lab, type_error_lab, indirection_lab, ind_lab,
hnf_lab, cons_lab, nil_lab, tuple_lab, empty_lab, add_arg_lab, match_error_lab,
#if STRICT_LISTS
conss_lab,consts_lab,conssts_lab,
#endif
#ifdef CLEAN2
select_with_dictionary_lab, update_with_dictionary_lab,
#endif
......
......@@ -14,6 +14,8 @@
#define FREE_STRICT_LHS_TUPLE_ELEMENTS 1 /* also in codegen1.c */
#define SELECTORS_FIRST 1 /* also in codegen.c */
#include "compiledefines.h"
#include "types.t"
#include "system.h"
#include "syntaxtr.t"
#include "comsupport.h"
......
......@@ -10,6 +10,8 @@
#define for_li(v,i,l,n) for(v=(l),i=0;v!=NULL;v=v->n,++i)
#define for_ll(v1,v2,l1,l2,n1,n2) for(v1=(l1),v2=(l2);v1!=NULL;v1=v1->n1,v2=v2->n2)
#include "compiledefines.h"
#include "types.t"
#include "system.h"
#include "syntaxtr.t"
#include "comsupport.h"
......
......@@ -13,6 +13,7 @@
# undef H
# include "compiledefines.h"
# include "types.t"
# include "syntaxtr.t"
......@@ -119,6 +120,78 @@ InitParser (void)
ListSymbol = NewSymbol (list_type);
ConsSymbol = NewSymbol (cons_symb);
NilSymbol = NewSymbol (nil_symb);
#if STRICT_LISTS
ListSymbol->symb_head_strictness=0;
ListSymbol->symb_tail_strictness=0;
ConsSymbol->symb_head_strictness=0;
ConsSymbol->symb_tail_strictness=0;
NilSymbol->symb_head_strictness=0;
NilSymbol->symb_tail_strictness=0;
StrictListSymbol= NewSymbol (list_type);
StrictListSymbol->symb_head_strictness=1;
StrictListSymbol->symb_tail_strictness=0;
UnboxedListSymbol= NewSymbol (list_type);
UnboxedListSymbol->symb_head_strictness=2;
UnboxedListSymbol->symb_tail_strictness=0;
TailStrictListSymbol= NewSymbol (list_type);
TailStrictListSymbol->symb_head_strictness=0;
TailStrictListSymbol->symb_tail_strictness=1;
StrictTailStrictListSymbol= NewSymbol (list_type);
StrictTailStrictListSymbol->symb_head_strictness=1;
StrictTailStrictListSymbol->symb_tail_strictness=1;
UnboxedTailStrictListSymbol= NewSymbol (list_type);
UnboxedTailStrictListSymbol->symb_head_strictness=2;
UnboxedTailStrictListSymbol->symb_tail_strictness=1;
StrictConsSymbol= NewSymbol (cons_symb);
StrictConsSymbol->symb_head_strictness=1;
StrictConsSymbol->symb_tail_strictness=0;
UnboxedConsSymbol= NewSymbol (cons_symb);
UnboxedConsSymbol->symb_head_strictness=2;
UnboxedConsSymbol->symb_tail_strictness=0;
TailStrictConsSymbol= NewSymbol (cons_symb);
TailStrictConsSymbol->symb_head_strictness=0;
TailStrictConsSymbol->symb_tail_strictness=1;
StrictTailStrictConsSymbol= NewSymbol (cons_symb);
StrictTailStrictConsSymbol->symb_head_strictness=1;
StrictTailStrictConsSymbol->symb_tail_strictness=1;
UnboxedTailStrictConsSymbol= NewSymbol (cons_symb);
UnboxedTailStrictConsSymbol->symb_head_strictness=2;
UnboxedTailStrictConsSymbol->symb_tail_strictness=1;
StrictNilSymbol = NewSymbol (nil_symb);
StrictNilSymbol->symb_head_strictness=1;
StrictNilSymbol->symb_tail_strictness=0;
UnboxedNilSymbol = NewSymbol (nil_symb);
UnboxedNilSymbol->symb_head_strictness=2;
UnboxedNilSymbol->symb_tail_strictness=0;
TailStrictNilSymbol = NewSymbol (nil_symb);
TailStrictNilSymbol->symb_head_strictness=0;
TailStrictNilSymbol->symb_tail_strictness=1;
StrictTailStrictNilSymbol = NewSymbol (nil_symb);
StrictTailStrictNilSymbol->symb_head_strictness=1;
StrictTailStrictNilSymbol->symb_tail_strictness=1;
UnboxedTailStrictNilSymbol = NewSymbol (nil_symb);
UnboxedTailStrictNilSymbol->symb_head_strictness=2;
UnboxedTailStrictNilSymbol->symb_tail_strictness=1;
#endif
ApplySymbol = NewSymbol (apply_symb);
FailSymbol = NewSymbol (fail_symb);
AllSymbol = NewSymbol (all_symb);
......
......@@ -17,3 +17,7 @@
#define IMPORT_OBJ_AND_LIB 1
#define WRITE_DCL_MODIFICATI