Commit 9ec33a99 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏘
Browse files

Unix version

parent c9d8be95
// this is for Windows
definition module CoclSystemDependent
//1.3
from StdString import String
from StdFile import Files
//3.1
/*2.0
from StdFile import ::Files
0.2*/
// RWS split
// from deltaIOSystem import DeviceSystem
// from deltaEventIO import InitialIO, IOState
PathSeparator
:== ':'
DirectorySeparator
:== '/'
SystemDependentDevices :: [a]
SystemDependentInitialIO :: [a]
ensureCleanSystemFilesExists :: !String !*Files -> (!Bool, !*Files)
set_compiler_id :: Int -> Int
// this is for Unix
implementation module CoclSystemDependent
import StdEnv
// import for filesystem
import code from "cDirectory.o" // Unix
import code from "ipc.o"
from filesystem import ensureDirectoryExists
PathSeparator
:== ':'
DirectorySeparator
:== '/'
SystemDependentDevices :: [a]
SystemDependentDevices
= []
SystemDependentInitialIO :: [a]
SystemDependentInitialIO
= []
ensureCleanSystemFilesExists :: !String !*Files -> (!Bool, !*Files)
// returned bool: now there is such a subfolder
ensureCleanSystemFilesExists path env
= ensureDirectoryExists path env
set_compiler_id :: Int -> Int
set_compiler_id compiler_id = compiler_id
/*
Unix clm/cocl interface
Ronny Wichers Schreur
*/
# include <stdio.h>
# include <stdlib.h>
# include <stdarg.h>
# include <strings.h>
/*
Clean string
============
*/
typedef struct clean_string {int length; char chars [1]; } *CleanString;
# define Clean(ignore)
# include "ipc.h"
static void
log (char *format, ...)
{
#ifdef DEBUG
va_list ap;
va_start (ap, format);
(void) fputs(" cocl: ", stderr);
(void) vfprintf(stderr, format, ap);
va_end(ap);
#else /* ifndef DEBUG */
#endif
}
static char *
ConvertCleanString (CleanString string)
{
int length;
char *copy;
length = string->length;
copy = malloc (length+1);
strncpy (copy, string->chars, length);
copy [length] = '\0';
return (copy);
} /* ConvertCleanString */
static FILE *commands, *results;
# define COMMAND_BUFFER_SIZE 1024
static char command_buffer[COMMAND_BUFFER_SIZE];
static void
crash (void)
{
int *p;
p = NULL;
log ("crashing\n");
*p = 0;
} /* crash */
static void
hang (void)
{
log ("hanging\n");
for (;;)
;
} /* hang */
int open_pipes (CleanString commands_clean, CleanString results_clean)
{
char *commands_name, *results_name;
commands_name = ConvertCleanString (commands_clean);
results_name = ConvertCleanString (results_clean);
if ((commands = fopen(commands_name, "r")) == NULL)
{
fprintf(stderr,"commands = %s\n",commands_name);
perror("fopen commands");
return -1;
}
if ((results = fopen(results_name, "w")) == NULL)
{
fprintf(stderr,"results = %s\n",results_name);
perror("fopen results");
return -1;
}
return 0;
}
int get_command_length (void)
{
log ("reading command\n");
if (fgets (command_buffer, COMMAND_BUFFER_SIZE, commands) == NULL)
return -1;
else
{
log ("command = %s", command_buffer);
return (strlen (command_buffer));
}
}
int get_command (CleanString cleanString)
{
fprintf (stderr, "%s\n", command_buffer);
strncpy (cleanString->chars, command_buffer, cleanString->length);
cleanString->chars [cleanString->length] = '\0';
return (0);
}
int send_result (int result)
{
int r;
if (fprintf (results, "%d\n", result) > 0)
r=0;
else
r=-1;
fflush (results);
return r;
}
definition module ipc;
from StdString import String;
open_pipes :: !String !String -> Int;
// int open_pipes (CleanString commands_name,CleanString results_name);
get_command_length :: Int;
// int get_command_length ();
get_command :: !String -> Int;
// int get_command (CleanString cleanString);
send_result :: !Int -> Int;
// int send_result (int result);
int open_pipes (CleanString commands_name, CleanString results_name);
Clean (open_pipes :: String String -> Int)
int get_command_length (void);
Clean (get_command_length :: Int)
int get_command (CleanString cleanString);
Clean (get_command :: String -> Int)
int send_result (int result);
Clean (send_result :: Int -> Int)
implementation module ipc;
from StdString import String;
open_pipes :: !String !String -> Int;
open_pipes a0 a1 = code {
ccall open_pipes "SS:I"
}
// int open_pipes (CleanString commands_name,CleanString results_name);
get_command_length :: Int;
get_command_length = code {
ccall get_command_length ":I"
}
// int get_command_length ();
get_command :: !String -> Int;
get_command a0 = code {
ccall get_command "S:I"
}
// int get_command (CleanString cleanString);
send_result :: !Int -> Int;
send_result a0 = code {
ccall send_result "I:I"
}
// int send_result (int result);
File added
definition module set_return_code;
//1.3
from StdString import String;
//3.1
:: *UniqueWorld :== World;
set_return_code :: !Int !UniqueWorld -> UniqueWorld;
// void set_return_code (int return_code);
implementation module set_return_code;
import code from "set_return_code.obj";
import StdString;
import StdDebug;
:: *UniqueWorld :== World;
set_return_code :: !Int !UniqueWorld -> UniqueWorld;
set_return_code a0 a1 = code
{
ccall set_return_code "I:V:A"
fill_a 0 1
pop_a 1
}
// void set_return_code (int return_code);
extern int return_code;
void set_return_code (int code)
{
return_code = code;
}
...@@ -8,10 +8,14 @@ import StdEnv ...@@ -8,10 +8,14 @@ import StdEnv
import coclmain import coclmain
import frontend import frontend
import StdDebug
// Start :: *World -> *World // Start :: *World -> *World
Start world Start world
= (testArgs, coclMain testArgs world) # world = trace_n "hello from cocl!\n" world
# world
= coclMain testArgs world
= trace_n "bye from cocl!\n" world
where where
testArgs testArgs
= [ = [
......
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
implementation module coclmain implementation module coclmain
import StdEnv import StdEnv
import StdDebug
import ArgEnv import ArgEnv
import set_return_code import set_return_code
...@@ -12,12 +13,14 @@ import compile ...@@ -12,12 +13,14 @@ import compile
coclMain :: ![{#Char}] !*World -> *World coclMain :: ![{#Char}] !*World -> *World
// currentVersion latestDefVersion latestImpVersion testArgs world // currentVersion latestDefVersion latestImpVersion testArgs world
coclMain testArgs world coclMain testArgs world
# world
= set_return_code 0 world
# (commandArgs, world) # (commandArgs, world)
= getCommandArgs (tl [arg \\ arg <-: getCommandLine]) testArgs world = getCommandArgs (tl [arg \\ arg <-: getCommandLine]) testArgs world
# (symbol_table,world) # (symbol_table,world)
= init_identifiers newHeap world = init_identifiers newHeap world
# (success, world) # (success, world)
= accFiles (compiler commandArgs symbol_table) world = accFiles (compiler symbol_table) world
= set_return_code (if success 0(-1)) world = set_return_code (if success 0(-1)) world
where where
getCommandArgs :: [{#Char}] [{#Char}] *World -> ([{#Char}], *World) getCommandArgs :: [{#Char}] [{#Char}] *World -> ([{#Char}], *World)
...@@ -75,19 +78,40 @@ coclMain testArgs world ...@@ -75,19 +78,40 @@ coclMain testArgs world
CoclArgsFile :== "coclargs.txt" CoclArgsFile :== "coclargs.txt"
/*
import thread_message; import thread_message;
import code from "thread_message.obj"; import code from "thread_message.obj";
*/
// compiler driver
compiler :: ![{#Char}] *SymbolTable *Files -> *(!Bool,!*Files); /* Windows
compiler commandArgs symbol_table files compiler symbol_table files
# dcl_cache = empty_cache symbol_table # dcl_cache = empty_cache symbol_table
| length commandArgs==2 && commandArgs!!0=="-ide" | length commandArgs==2 && commandArgs!!0=="-ide"
# wm_number=get_message_number; # wm_number=get_message_number;
# thread_id=hex_to_int (commandArgs!!1); # thread_id=hex_to_int (commandArgs!!1);
= (True,compile_files dcl_cache thread_id wm_number files) = (True,compile_files compile dcl_cache thread_id wm_number files)
# (r,cache,files)=compile commandArgs dcl_cache files # (r,dcl_cache,files)=compile commandArgs dcl_cache files
= (r,files) = (r,files)
where
commandArgs
= tl [arg \\ arg <-: getCommandLine]
*/
// Unix
compiler symbol_table files
# dcl_cache = empty_cache symbol_table
| length commandArgs==3 && commandArgs!!0=="--pipe"
# commands_name= (commandArgs!!1);
# results_name= (commandArgs!!2);
= (True,compile_loop compile dcl_cache commands_name results_name files)
# (r,dcl_cache,files)=compile commandArgs dcl_cache files
= (r,files)
where
commandArgs
= tl [arg \\ arg <-: getCommandLine]
// ... Unix
hex_to_int :: {#Char} -> Int hex_to_int :: {#Char} -> Int
hex_to_int s hex_to_int s
...@@ -150,24 +174,35 @@ string_to_args string ...@@ -150,24 +174,35 @@ string_to_args string
= i; = i;
= skip_to_double_quote (i+1); = skip_to_double_quote (i+1);
compile_files cache thread_id wm_number files // Unix
# (r,a,s) =get_integers_from_message wm_number; import ipc
| r==0 import code from "ipc.o"
compile_loop compile cache commands results files
# r=open_pipes commands results;
| r<>0
= abort ("compile_loop\n");
= compile_files compile cache files
compile_files compile cache files
# n = get_command_length;
| n==(-1)
= abort "compile_files 1"; = abort "compile_files 1";
# string=createArray a '\0'; # string=createArray n '\0';
# r=get_string_from_file_map_and_delete_map s string; # r=get_command string;
| r==0 | r<>0
= abort ("compile_files 2 "); = abort ("compile_files 2 ");
# args=string_to_args (string % (0,size string-2)) # args=string_to_args (string % (0,size string-2))
= case args of = case args of
["cocl":cocl_args] ["cocl":cocl_args]
# (ok,cache,files)=compile cocl_args cache files # (ok,cache,files)=compile cocl_args cache files
# result=if ok 0(-1); # result=if ok 0(-1);
# r=send_integers_to_thread thread_id wm_number 0 result; # r=send_result result
| r==0 | r<>0
-> abort "compile_files 3"; -> abort "compile_files 3";
-> compile_files cache thread_id wm_number files -> compile_files compile cache files
["exit"] ["quit"]
-> files; -> trace_n "quiting" files;
_ _
-> abort "compile_files 4" -> abort "compile_files 4"
...@@ -16,6 +16,7 @@ from type_io import openTclFile, closeTclFile, baseName, directoryName, splitBy ...@@ -16,6 +16,7 @@ from type_io import openTclFile, closeTclFile, baseName, directoryName, splitBy
:: CoclOptions = :: CoclOptions =
{ moduleName:: {#Char} { moduleName:: {#Char}
, pathName ::{#Char} , pathName ::{#Char}
, outputPathName ::{#Char}
, errorPath:: {#Char} , errorPath:: {#Char}
, errorMode:: Int , errorMode:: Int
, outPath:: {#Char} , outPath:: {#Char}
...@@ -28,12 +29,16 @@ from type_io import openTclFile, closeTclFile, baseName, directoryName, splitBy ...@@ -28,12 +29,16 @@ from type_io import openTclFile, closeTclFile, baseName, directoryName, splitBy
, compile_with_generics :: !Bool , compile_with_generics :: !Bool
} }
StdErrPathName :== "_stderr_"
StdOutPathName :== "_stderr_"
InitialCoclOptions = InitialCoclOptions =
{ moduleName= "" { moduleName= ""
, pathName= "" , pathName= ""
, errorPath= "errors" , outputPathName= ""
, errorPath= StdErrPathName
, errorMode= FWriteText , errorMode= FWriteText
, outPath= "out" , outPath= StdErrPathName
, outMode= FWriteText , outMode= FWriteText
, searchPaths= {sp_locations = [], sp_paths = []} , searchPaths= {sp_locations = [], sp_paths = []}
, listTypes = {lto_showAttributes = True, lto_listTypesKind = ListTypesNone} , listTypes = {lto_showAttributes = True, lto_listTypesKind = ListTypesNone}
...@@ -68,6 +73,8 @@ compile args cache files ...@@ -68,6 +73,8 @@ compile args cache files
parseCommandLine :: [{#Char}] CoclOptions -> ([{#Char}],[{#Char}],CoclOptions) parseCommandLine :: [{#Char}] CoclOptions -> ([{#Char}],[{#Char}],CoclOptions)
parseCommandLine [] options parseCommandLine [] options
= ([],[],options) = ([],[],options)
parseCommandLine [arg1=:"-o", outputPathName : args] options=:{searchPaths}
= parseCommandLine args {options & outputPathName = outputPathName}
parseCommandLine [arg1=:"-P", searchPathsString : args] options=:{searchPaths} parseCommandLine [arg1=:"-P", searchPathsString : args] options=:{searchPaths}
// RWS, voor Maarten +++ = parseCommandLine args {options & searchPaths = {searchPaths & sp_paths = splitPaths searchPathsString}} // RWS, voor Maarten +++ = parseCommandLine args {options & searchPaths = {searchPaths & sp_paths = splitPaths searchPathsString}}
# (args,modules,options) = parseCommandLine args {options & searchPaths.sp_paths = splitPaths searchPathsString} # (args,modules,options) = parseCommandLine args {options & searchPaths.sp_paths = splitPaths searchPathsString}
...@@ -158,14 +165,25 @@ compile_modules [module_:modules] n_compiles cocl_options args_without_modules c ...@@ -158,14 +165,25 @@ compile_modules [module_:modules] n_compiles cocl_options args_without_modules c
compile_modules [] n_compiles cocl_options args_without_modules cache files compile_modules [] n_compiles cocl_options args_without_modules cache files
= (True,cache,files); = (True,cache,files);
openPath :: {#Char} Int *Files -> (Bool, *File, *Files)
openPath path mode files
| path == StdErrPathName
= (True, stderr, files)
| path == StdOutPathName
# (io, files)
= stdio files
= (True, io, files)
// otherwise
= fopen path mode files
compileModule :: CoclOptions [{#Char}] *DclCache *Files -> (!Bool,!*DclCache,!*Files) compileModule :: CoclOptions [{#Char}] *DclCache *Files -> (!Bool,!*DclCache,!*Files)
compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbols,hash_table,heaps} files compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbols,hash_table,heaps} files
# (opened, error, files) # (opened, error, files)
= fopen options.errorPath options.errorMode files = openPath options.errorPath options.errorMode files
| not opened | not opened
= abort ("couldn't open error file \"" +++ options.errorPath +++ "\"\n") = abort ("couldn't open error file \"" +++ options.errorPath +++ "\"\n")
# (opened, out, files) # (opened, out, files)
= fopen options.outPath options.outMode files = openPath options.outPath options.outMode files
| not opened | not opened
= abort ("couldn't open out file \"" +++ options.outPath +++ "\"\n") = abort ("couldn't open out file \"" +++ options.outPath +++ "\"\n")
# (tcl_file, files) # (tcl_file, files)
...@@ -212,6 +230,7 @@ compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbo ...@@ -212,6 +230,7 @@ compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbo
# (success, var_heap, attrHeap, error, files) # (success, var_heap, attrHeap, error, files)
= backEndInterface outputPath (map appendRedirection backendArgs) options.listTypes options.outPath predef_symbols syntaxTree main_dcl_module_n var_heap attrHeap error files = backEndInterface outputPath (map appendRedirection backendArgs) options.listTypes options.outPath predef_symbols syntaxTree main_dcl_module_n var_heap attrHeap error files
-> (success,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,attrHeap, error, files) -> (success,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,attrHeap, error, files)
// -> (True,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,attrHeap, error, files)
with with
appendRedirection arg appendRedirection arg
= case arg of = case arg of
...@@ -224,6 +243,12 @@ compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbo ...@@ -224,6 +243,12 @@ compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbo
No No
-> (False,{},0,var_heap,attrHeap,error, files) -> (False,{},0,var_heap,attrHeap,error, files)
with with
/*
outputPath
= if (options.outputPathName == "")
(directoryName options.pathName +++ "Clean System Files" +++ {DirectorySeparator} +++ baseName options.pathName)
options.outputPathName
*/
outputPath outputPath
// = /* directoryName options.pathName +++ "Clean System Files" +++ {DirectorySeparator} +++ */ baseName options.pathName // = /* directoryName options.pathName +++ "Clean System Files" +++ {DirectorySeparator} +++ */ baseName options.pathName
= baseName options.pathName = baseName options.pathName
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment