Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Splitting off the win32caml/ subdirectory (the simplistic Win32 UI for the toplevel). It now lives at https://forge.ocamlcore.org/projects/ocamltopwin/ 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12268 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Leroy 2012-03-24 10:37:53 +00:00
parent 0e4baac4cc
commit af3cafad25
17 changed files with 5 additions and 4123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Changes
View File

@ -158,7 +158,10 @@ Shedding weight:
* The "DBM" library (interface with Unix DBM key-value stores) is no
longer part of this distribution. It now lives its own life at
https://forge.ocamlcore.org/projects/camldbm/
* The "OCamlWin" toplevel user interface for MS Windows is no longer
part of this distribution. It now lives its own life at
https://forge.ocamlcore.org/projects/ocamltopwin/
Other changes:
- Copy VERSION file to library directory when installing.

11
Makefile.nt
View File

@ -121,7 +121,7 @@ defaultentry:
@echo "Please refer to the installation instructions in file README.win32."
# Recompile the system using the bootstrap compiler
all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) win32gui
all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER)
# The compilation of ocaml will fail if the runtime has changed.
# Never mind, just do make bootstrap to reach fixpoint again.
@ -239,7 +239,6 @@ installbyt:
for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done
if test -f debugger/ocamldebug.exe; then (cd debugger; $(MAKEREC) install); \
else :; fi
cd win32caml ; $(MAKE) install
./build/partial-install.sh
cp config/Makefile $(LIBDIR)/Makefile.config
cp README $(DISTRIB)/Readme.general.txt
@ -616,14 +615,6 @@ ocamlbuild-mixed-boot:
partialclean::
rm -rf _build
# The Win32 toplevel GUI
win32gui:
cd win32caml ; $(MAKE) all
clean::
cd win32caml ; $(MAKE) clean
# Default rules
.SUFFIXES: .ml .mli .cmo .cmi .cmx

3
README.win32
View File

@ -179,9 +179,6 @@ The initial port of Caml Special Light (the ancestor of OCaml) to
Windows NT was done by Kevin Gallo at Microsoft Research, who kindly
contributed his changes to the OCaml project.
The graphical user interface for the toplevel was initially developed
by Jacob Navia, then significantly improved by Christopher A. Watford.
------------------------------------------------------------------------------
The native Win32 port built with Mingw

57
win32caml/Makefile
View File

@ -1,57 +0,0 @@
#########################################################################
# #
# OCaml #
# #
# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
# #
# Copyright 2001 Institut National de Recherche en Informatique et #
# en Automatique. All rights reserved. This file is distributed #
# under the terms of the GNU Library General Public License, with #
# the special exception on linking described in file ../LICENSE. #
# #
#########################################################################
# $Id$
include ../config/Makefile
CC=$(BYTECC)
CFLAGS=$(BYTECCCOMPOPTS)
OBJS=startocaml.$(O) ocamlres.$(O) ocaml.$(O) menu.$(O) \
history.$(O) editbuffer.$(O)
LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,advapi32) $(call SYSLIB,gdi32) \
$(call SYSLIB,user32) $(call SYSLIB,comdlg32) $(call SYSLIB,comctl32)
all: ocamlwin.exe
ocamlwin.exe: $(OBJS)
$(MKEXE) -o ocamlwin.exe $(OBJS) $(LIBS) $(EXTRALIBS) -subsystem windows
ocamlres.$(O): ocaml.rc ocaml.ico
ifeq ($(TOOLCHAIN),msvc)
rc ocaml.rc
ifeq ($(ARCH),amd64)
cvtres /nologo /machine:amd64 /out:$@ ocaml.res
else
cvtres /nologo /machine:ix86 /out:$@ ocaml.res
endif
rm -f ocaml.res
endif
ifeq ($(TOOLCHAIN),mingw)
$(TOOLPREF)windres -i ocaml.rc -o $@
endif
$(OBJS): inria.h inriares.h history.h editbuffer.h
clean:
rm -f ocamlwin.exe *.$(O) *.pdb ocamlwin.ilk
install:
cp ocamlwin.exe $(PREFIX)/OCamlWin.exe
.SUFFIXES: .c .$(O)
.c.$(O):
$(CC) $(CFLAGS) -c $*.c

515
win32caml/editbuffer.c
View File

@ -1,515 +0,0 @@
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Developed by Jacob Navia. */
/* */
/* Copyright 2001 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/***********************************************************************/
/* Changes made by Chris Watford to enhance the source editor */
/* Began 14 Sept 2003 - watford@uiuc.edu */
/***********************************************************************/
#include <string.h>
#include <stdlib.h>
#include "inriares.h"
#include "inria.h"
/*------------------------------------------------------------------------
Procedure: editbuffer_addline ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Adds a line to the current edit buffer
Input: Line of text to append to the end
Output:
Errors:
--------------------------------------------------------------------------
Edit History:
18 Sept 2003 - Chris Watford watford@uiuc.edu
- Corrected doubly linked list issue
------------------------------------------------------------------------*/
BOOL editbuffer_addline(EditBuffer* edBuf, char* line)
{
LineList *tail = NULL; //head of the edit buffer line list
LineList *newline = NULL;
// sanity check
if(edBuf == NULL)
{
return FALSE;
}
// perform edit buffer sanity checks
if((edBuf->LineCount < 0) || (edBuf->Lines == NULL))
{
edBuf->LineCount = 0;
}
// move to the end of the line list in the edit buffer
if((tail = edBuf->Lines) != NULL)
for( ; tail->Next != NULL; tail = tail->Next);
// create the new line entry
newline = (LineList*)SafeMalloc(sizeof(LineList));
newline->Next = NULL;
newline->Prev = tail;
newline->Text = (char*)SafeMalloc(strlen(line)+1);
strncpy(newline->Text, line, strlen(line)+1);
newline->Text[strlen(line)] = '\0';
// add it to the list as the head or the tail
if(tail != NULL)
{
tail->Next = newline;
} else {
edBuf->Lines = newline;
}
// update the number of lines in the buffer
edBuf->LineCount++;
return TRUE;
}
/*------------------------------------------------------------------------
Procedure: editbuffer_updateline ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Updates the edit buffer's internal contents for a line
Input: idx - Line index
line - String to add
Output: if the line was updated or not
Errors:
------------------------------------------------------------------------*/
BOOL editbuffer_updateline(EditBuffer* edBuf, int idx, char* line)
{
LineList *update = edBuf->Lines; //head of the edit buffer line list
LineList *newline = NULL;
int i;
// sanity checks
if(edBuf == NULL)
{
return FALSE;
} else if( (edBuf->LineCount == 0) ||
(edBuf->Lines == NULL) ||
(idx >= edBuf->LineCount) ||
(idx < 0) ) {
return FALSE;
}
// move to the index in the line list
// i left in update != NULL as a sanity check
for(i = 0; ((update != NULL) && (i != idx)); update = update->Next, i++);
// did things mess up?
if( (update == NULL) || (i != idx) )
{
return FALSE;
}
// get rid of the old line
free(update->Text);
// get the new line updated
update->Text = (char*)SafeMalloc(strlen(line)+1);
strncpy(update->Text, line, strlen(line)+1);
update->Text[strlen(line)] = '\0';
return TRUE;
}
/*------------------------------------------------------------------------
Procedure: editbuffer_updateoraddline ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Updates the edit buffer's internal contents for a line
Input: idx - Line index
line - String to add
Output: if the line was updated or not
Errors:
------------------------------------------------------------------------*/
BOOL editbuffer_updateoraddline(EditBuffer* edBuf, int idx, char* line)
{
LineList *update;
// sanity checks
if(edBuf == NULL)
{
return FALSE;
} else if((idx > edBuf->LineCount) || (idx < 0)) {
return FALSE;
}
update = edBuf->Lines; //head of the edit buffer line list
// do we update or add?
if((idx < edBuf->LineCount) && (edBuf->Lines != NULL))
{ //interior line, update
return editbuffer_updateline(edBuf, idx, line);
} else {
//fence line, add
return editbuffer_addline(edBuf, line);
}
}
/*------------------------------------------------------------------------
Procedure: editbuffer_removeline ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Removes a line from the edit buffer
Input: idx - Line index to remove
Output: if the line was removed or not
Errors:
--------------------------------------------------------------------------
Edit History:
18 Sept 2003 - Chris Watford watford@uiuc.edu
- Added to allow backspace and delete support
- Corrected doubly linked list issue
------------------------------------------------------------------------*/
BOOL editbuffer_removeline(EditBuffer* edBuf, int idx)
{
LineList *update = NULL;
int i = 0;
// sanity checks
if(edBuf == NULL)
{
return FALSE;
} else if( (edBuf->LineCount == 0) ||
(edBuf->Lines == NULL) ||
(idx >= edBuf->LineCount) ||
(idx < 0) ) {
return FALSE;
}
// move to the index in the line list
// i left in update != NULL as a sanity check
for(i = 0, update = edBuf->Lines; ((update != NULL) && (i != idx)); update = update->Next, i++);
// remove this line
if(update != NULL)
{
// break links, removing our line
if(update->Prev != NULL)
{
// we're not the first so just break the link
update->Prev->Next = update->Next;
// fix the prev check
if(update->Next != NULL)
update->Next->Prev = update->Prev;
} else {
// we're the first, attach the next guy to lines
edBuf->Lines = update->Next;
}
// one less line to worry about
edBuf->LineCount--;
// get rid of the text
if(update->Text != NULL)
free(update->Text);
// get rid of us
free(update);
return TRUE;
}
return FALSE;
}
/*------------------------------------------------------------------------
Procedure: editbuffer_getasline ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Returns the edit buffer as one big line, \n's and \t's
become spaces.
Input:
Output:
Errors:
------------------------------------------------------------------------*/
char* editbuffer_getasline(EditBuffer* edBuf)
{
LineList *line = NULL; //head of the edit buffer line list
char* retline = (char*)realloc(NULL, 1);
unsigned int i = 0;
// fix retline bug
retline[0] = '\0';
// sanity checks
if(edBuf == NULL)
{
return NULL;
} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
// fix any possible errors that may come from this
edBuf->LineCount = 0;
edBuf->Lines = NULL;
return NULL;
}
// get the big line
for(line = edBuf->Lines; line != NULL; line = line->Next)
{
if(line->Text != NULL)
{
retline = (char*)realloc(retline, (strlen(retline) + strlen(line->Text) + (strlen(retline) > 0 ? 2 : 1)));
if(strlen(retline) > 0)
retline = strcat(retline, " ");
retline = strcat(retline, line->Text);
//concat in the hoouuusssseee!
}
}
// now we have the big line, so lets ditch all \n's \t's and \r's
for(i = 0; i < strlen(retline); i++)
{
switch(retline[i])
{
case '\n':
case '\t':
case '\r':
retline[i] = ' ';
}
}
return retline;
}
/*------------------------------------------------------------------------
Procedure: editbuffer_getasbuffer ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Returns the edit buffer as one big line, \n's and \t's
become spaces.
Input:
Output:
Errors:
------------------------------------------------------------------------*/
char* editbuffer_getasbuffer(EditBuffer* edBuf)
{
LineList *line = NULL; //head of the edit buffer line list
char* retbuf = (char*)realloc(NULL, 1);
unsigned int i = 0;
// fix retline bug
retbuf[0] = '\0';
// sanity checks
if(edBuf == NULL)
{
return NULL;
} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
// fix any possible errors that may come from this
edBuf->LineCount = 0;
edBuf->Lines = NULL;
return NULL;
}
// get the big line
for(line = edBuf->Lines; line != NULL; line = line->Next)
{
if(line->Text != NULL)
{
int len = strlen(retbuf);
len += strlen(line->Text) + (len > 0 ? 3 : 1);
retbuf = (char*)realloc(retbuf, len);
if(strlen(retbuf) > 0)
retbuf = strcat(retbuf, "\r\n");
retbuf = strcat(retbuf, line->Text);
retbuf[len-1] = '\0';
//concat in the hoouuusssseee!
}
}
return retbuf;
}
/*------------------------------------------------------------------------
Procedure: editbuffer_lastline ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Returns the last line in the edit buffer
Input:
Output:
Errors:
------------------------------------------------------------------------*/
char* editbuffer_lastline(EditBuffer* edBuf)
{
LineList *line = NULL; //head of the edit buffer line list
// sanity checks
if(edBuf == NULL)
{
return NULL;
} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
// fix any possible errors that may come from this
edBuf->LineCount = 0;
edBuf->Lines = NULL;
return NULL;
}
// go to the last line
for(line = edBuf->Lines; line->Next != NULL; line = line->Next);
return line->Text;
}
/*------------------------------------------------------------------------
Procedure: editbuffer_copy ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Makes an exact copy of an edit buffer
Input:
Output:
Errors:
--------------------------------------------------------------------------
Edit History:
16 Sept 2003 - Chris Watford watford@uiuc.edu
- Added to make copies of history entries
18 Sept 2003 - Chris Watford watford@uiuc.edu
- Corrected doubly linked list issue
06 Oct 2003 - Chris Watford watford@uiuc.edu
- Added isCorrect flag
------------------------------------------------------------------------*/
EditBuffer* editbuffer_copy(EditBuffer* edBuf)
{
// sanity checks
if(edBuf == NULL)
{
return NULL;
} else {
EditBuffer* copy = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
LineList* lines = edBuf->Lines;
LineList* lastLine = NULL;
// clear its initial values
copy->LineCount = 0;
copy->Lines = NULL;
copy->isCorrect = FALSE;
// well we don't have to copy much
if((lines == NULL) || (edBuf->LineCount <= 0))
{
return copy;
}
// get if its correct
copy->isCorrect = edBuf->isCorrect;
// go through each line, malloc it and add it
for( ; lines != NULL; lines = lines->Next)
{
LineList* curline = (LineList*)SafeMalloc(sizeof(LineList));
curline->Next = NULL;
curline->Prev = NULL;
// if there was a last line, link them to us
if(lastLine != NULL)
{
lastLine->Next = curline;
curline->Prev = lastLine;
}
// are we the first line? add us to the edit buffer as the first
if(copy->Lines == NULL)
{
copy->Lines = curline;
}
// check if there is text on the line
if(lines->Text == NULL)
{ // no text, make it blankz0r
curline->Text = (char*)SafeMalloc(sizeof(char));
curline->Text[0] = '\0';
} else {
// there is text, copy it and null-terminate
curline->Text = (char*)SafeMalloc(strlen(lines->Text) + 1);
strncpy(curline->Text, lines->Text, strlen(lines->Text));
curline->Text[strlen(lines->Text)] = '\0';
}
// up the line count and make us the last line
copy->LineCount++;
lastLine = curline;
}
// return our new copy
return copy;
}
}
/*------------------------------------------------------------------------
Procedure: editbuffer_destroy ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Destroys an edit buffer
Input:
Output:
Errors:
------------------------------------------------------------------------*/
void editbuffer_destroy(EditBuffer* edBuf)
{
// sanity checks
if(edBuf == NULL)
{ // nothing to do
return;
} else if(edBuf->Lines != NULL) {
LineList* lastline = NULL;
// loop through each line free'ing its text
for( ; edBuf->Lines != NULL; edBuf->Lines = edBuf->Lines->Next)
{
if(edBuf->Lines->Text != NULL)
free(edBuf->Lines->Text);
// if there was a line before us, free it
if(lastline != NULL)
{
free(lastline);
lastline = NULL;
}
lastline = edBuf->Lines;
}
// free the last line
free(lastline);
}
// free ourself
free(edBuf);
}
/*------------------------------------------------------------------------
Procedure: editbuffer_new ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Creates an edit buffer
Input:
Output:
Errors:
--------------------------------------------------------------------------
Edit History:
06 Oct 2003 - Chris Watford watford@uiuc.edu
- Added isCorrect flag
------------------------------------------------------------------------*/
EditBuffer* editbuffer_new(void)
{
// create a new one
EditBuffer *edBuf = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
// default vals
edBuf->LineCount = 0;
edBuf->Lines = NULL;
edBuf->isCorrect = FALSE;
// return it
return edBuf;
}

47
win32caml/editbuffer.h
View File

@ -1,47 +0,0 @@
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Jacob Navia, after Xavier Leroy */
/* */
/* Copyright 2001 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/***********************************************************************/
/* Changes made by Chris Watford to enhance the source editor */
/* Began 14 Sept 2003 - watford@uiuc.edu */
/***********************************************************************/
#ifndef _EDITBUFFER_H_
#define _EDITBUFFER_H_
// All the below was added by Chris Watford watford@uiuc.edu
typedef struct tagLineList {
struct tagLineList *Next;
struct tagLineList *Prev;
char *Text;
} LineList;
typedef struct tagEditBuffer {
int LineCount;
struct tagLineList *Lines;
BOOL isCorrect;
} EditBuffer;
BOOL editbuffer_addline (EditBuffer* edBuf, char* line);
BOOL editbuffer_updateline (EditBuffer* edBuf, int idx, char* line);
BOOL editbuffer_updateoraddline (EditBuffer* edBuf, int idx, char* line);
BOOL editbuffer_removeline (EditBuffer* edBuf, int idx);
char* editbuffer_getasline (EditBuffer* edBuf);
char* editbuffer_getasbuffer (EditBuffer* edBuf);
char* editbuffer_lastline (EditBuffer* edBuf);
EditBuffer* editbuffer_copy (EditBuffer* edBuf);
void editbuffer_destroy (EditBuffer* edBuf);
EditBuffer* editbuffer_new (void);
#endif

98
win32caml/history.c
View File

@ -1,98 +0,0 @@
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Jacob Navia, after Xavier Leroy */
/* */
/* Copyright 2001 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/***********************************************************************/
/* Changes made by Chris Watford to enhance the source editor */
/* Began 14 Sept 2003 - watford@uiuc.edu */
/***********************************************************************/
#include "inria.h"
#include "history.h"
/*------------------------------------------------------------------------
Procedure: AddToHistory ID:2
Author: Chris Watford watford@uiuc.edu
Purpose: Adds an edit buffer to the history control
Input: Pointer to the edit buffer to add
Output:
Errors:
--------------------------------------------------------------------------
Edit History:
15 Sept 2003 - Chris Watford watford@uiuc.edu
- Complete rewrite
- Got it to add the edit buffer to the history
17 Sept 2003 - Chris Watford watford@uiuc.edu
- Added doubly link list support
------------------------------------------------------------------------*/
void AddToHistory(EditBuffer *edBuf)
{
StatementHistory *newLine;
// sanity checks
if(edBuf == NULL)
{
return;
} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
// fix any possible errors that may come from this
edBuf->LineCount = 0;
edBuf->Lines = NULL;
return;
}
// setup newline and add as the front of the linked list
newLine = SafeMalloc(sizeof(StatementHistory));
newLine->Next = History;
newLine->Prev = NULL;
newLine->Statement = edBuf;
// setup back linking
if(History != NULL)
History->Prev = newLine;
// set the history up
History = newLine;
// search for the new history tail
for(HistoryTail = (HistoryTail != NULL ? HistoryTail : History); HistoryTail->Next != NULL; HistoryTail = HistoryTail->Next);
}
/*------------------------------------------------------------------------
Procedure: GetHistoryLine ID:2
Author: Chris Watford watford@uiuc.edu
Purpose: Returns an entry from the history table
Input: Index of the history entry to return
Output: The history entry as a single line
Errors:
--------------------------------------------------------------------------
Edit History:
15 Sept 2003 - Chris Watford watford@uiuc.edu
- Complete rewrite
17 Sept 2003 - Chris Watford watford@uiuc.edu
- Added doubly link list support
------------------------------------------------------------------------*/
char *GetHistoryLine(int n)
{
StatementHistory *histentry = History;
int i;
// traverse linked list looking for member n
for (i = 0; ((i < n) && (histentry != NULL)); i++, histentry = histentry->Next);
// figure out what to return
if (histentry != NULL)
{
return editbuffer_getasline(histentry->Statement);
} else {
return "";
}
}

35
win32caml/history.h
View File

@ -1,35 +0,0 @@
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Jacob Navia, after Xavier Leroy */
/* */
/* Copyright 2001 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/***********************************************************************/
/* Changes made by Chris Watford to enhance the source editor */
/* Began 14 Sept 2003 - watford@uiuc.edu */
/***********************************************************************/
#ifndef _HISTORY_H_
#define _HISTORY_H_
#include "editbuffer.h"
// Simple linked list for holding the history lines
typedef struct tagStatementHistory {
struct tagStatementHistory *Next;
struct tagStatementHistory *Prev;
EditBuffer *Statement;
} StatementHistory;
void AddToHistory (EditBuffer *edBuf);
char *GetHistoryLine (int n);
static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam);
#endif

135
win32caml/inria.h
View File

@ -1,135 +0,0 @@
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Developed by Jacob Navia. */
/* */
/* Copyright 2001 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/* $Id$ */
/*------------------------------------------------------------------------
Module: D:\lcc\inria\inria.h
Author: Jacob
Project:
State:
Creation Date: June 2001
Description: The user interface works as follows:
1: At startup it will look for the path to the
ocaml interpreter in the registry using the
key HKEY_CURRENT_USER\SOFTWARE\ocaml. If not
found will prompt the user.
2: It will start the ocaml interpreter with
its standard output and standard input
connected to two pipes in a dedicated thread.
3: It will open a window containing an edit
field. The output from the interpreter will be
shown in the edit field, and the input of the
user in the edit field will be sent to the
interpreter when the user types return.
4: Line editing is provided by moving to the
desired line with the arrows, then pressing
return; If we aren't in the last input line,
the input will be copied to the last line and
sent to the interpreter.
5: The GUI ensures that when we exit the ocaml
interpreter is stopped by sending the
character string "#quit;;\nCtrl-Z"
6: A history of all lines sent to the interpreter
is maintained in a simple linked list. The
History dialog box shows that, and allows the
user to choose a given input line.
7: Memory limits. The edit buffer can be of an
arbitrary length, i.e. maybe 7-8MB or more,
there are no fixed limits. The History list
will always grow too, so memory consumption
could be "high" after several days of
uninterrupted typing at the keyboard. For that
cases it is recommended to stop the GUI and
get some sleep...
9: The GUI will start a timer, looking 4 times a
second if the interpreter has written
something in the pipe. This is enough for most
applications.
------------------------------------------------------------------------*/
#ifndef _INRIA_H_
#define _INRIA_H_
#include <windows.h>
#include "editbuffer.h"
#include "history.h"
#if _MSC_VER <= 1200 && !defined(__MINGW32__)
#define GetWindowLongPtr GetWindowLong
#define SetWindowLongPtr SetWindowLong
#define DWLP_USER DWL_USER
#define GWLP_WNDPROC GWL_WNDPROC
#define LONG_PTR DWORD
#endif
// In this structure should go eventually all global variables scattered
// through the program.
typedef struct _programParams {
HFONT hFont; // The handle of the current font
COLORREF TextColor; // The text color
char CurrentWorkingDir[MAX_PATH];// The current directory
} PROGRAM_PARAMS;
//**************** Global variables ***********************
extern PROGRAM_PARAMS ProgramParams;
extern COLORREF BackColor; // The background color
extern HBRUSH BackgroundBrush; // A brush built with the background color
extern char LibDir[]; // The lib directory
extern char OcamlPath[]; // The Path to ocaml.exe
extern HANDLE hInst; // The instance handle for this application
extern HWND hwndSession; // The current session window handle
extern LOGFONT CurrentFont; // The current font characteristics
extern HWND hwndMain,hwndMDIClient; // Window handles of frame and mdi window
// ***************** Function prototypes ******************
int WriteToPipe(char *data); // Writes to the pipe
int ReadFromPipe(char *data,int len);// Reads from the pipe
int AskYesOrNo(char *msg); //Ditto!
int BrowseForFile(char *fname,char *path);
void GotoEOF(void); // Positions the cursor at the end of the text
void ShowDbgMsg(char *msg); // Shows an error message
void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam);
int GetOcamlPath(void); // Finds where ocaml.exe is
void ForceRepaint(void); // Ditto.
void AddLineToControl(char *buf);
void AddStringToControl(char* buf);
char *GetHistoryLine(int n); // Gets the nth history line base 1.
int StartOcaml(void);
void InterruptOcaml(void);
int ResetText(void);
BOOL SendingFullCommand(void);
void RewriteCurrentEditBuffer(void);
void RefreshCurrentEditBuffer(void);
// **************** User defined window messages *************
#define WM_NEWLINE (WM_USER+6000)
#define WM_TIMERTICK (WM_USER+6001)
#define WM_QUITOCAML (WM_USER+6002)
#define WM_SYNTAXERROR (WM_USER+6003)
#define WM_UNBOUNDVAL (WM_USER+6004)
#define WM_ILLEGALCHAR (WM_USER+6005)
// ********************** Structures ***********************
typedef struct tagPosition {
int line;
int col;
} POSITION;
extern void *SafeMalloc(int);
extern StatementHistory *History; // The root of the history lines
extern StatementHistory *HistoryTail; // The tail of the history lines
extern EditBuffer *CurrentEditBuffer; // current edit buffer
#define IDEDITCONTROL 15432
#endif

48
win32caml/inriares.h
View File

@ -1,48 +0,0 @@
/* Weditres generated include file. Do NOT edit */
#define IDD_ABOUT 100
#define IDM_NEW 200
#define IDM_OPEN 210
#define IDM_SAVE 220
#define IDM_SAVEAS 230
#define IDM_CLOSE 240
#define IDM_PRINT 250
#define IDM_PRINTSU 260
#define IDM_PRINTPRE 265
#define IDM_PAGESETUP 267
#define IDM_EXIT 270
#define IDM_HISTORY 281
#define IDM_GC 282
#define IDCTRLC 283
#define IDD_HISTORY 300
#define IDLIST 301
#define IDM_EDITUNDO 310
#define IDM_EDITCUT 320
#define IDM_EDITCOPY 330
#define IDM_EDITPASTE 340
#define IDM_EDITCLEAR 350
#define IDM_EDITDELETE 360
#define IDM_EDITREPLACE 370
#define IDM_EDITREDO 380
#define IDM_WINDOWTILE 410
#define IDM_WINDOWCASCADE 420
#define IDM_WINDOWICONS 430
#define IDM_WINDOWCLOSEALL 440
#define IDM_PROPERTIES 450
#define IDM_ABOUT 500
#define IDM_HELP 510
#define IDMAINMENU 600
#define IDM_FIND 700
#define IDAPPLICON 710
#define IDI_CHILDICON 800
#define IDAPPLCURSOR 810
#define OCAML_ICON 1000
#define IDS_FILEMENU 2000
#define IDS_HELPMENU 2010
#define IDS_SYSMENU 2030
#define IDM_STATUSBAR 3000
#define IDM_WINDOWCHILD 3010
#define ID_TOOLBAR 5000
#define IDACCEL 10000
#define IDM_FONT 40002
#define IDM_COLORTEXT 40004
#define IDM_BACKCOLOR 40005

108
win32caml/libgraph.h
View File

@ -1,108 +0,0 @@
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Jacob Navia, after Xavier Leroy */
/* */
/* Copyright 2001 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/* $Id$ */
#include <stdio.h>
#include <windows.h>
struct canvas {
int w, h; /* Dimensions of the drawable */
HWND win; /* The drawable itself */
HDC gc; /* The associated graphics context */
};
extern HWND grdisplay; /* The display connection */
//extern int grscreen; /* The screen number */
//extern Colormap grcolormap; /* The color map */
//extern struct canvas grwindow; /* The graphics window */
//extern struct canvas grbstore; /* The pixmap used for backing store */
//extern int grwhite, grblack; /* Black and white pixels for X */
//extern int grbackground; /* Background color for X
// (used for CAML color -1) */
extern COLORREF grbackground;
extern BOOL grdisplay_mode; /* Display-mode flag */
extern BOOL grremember_mode; /* Remember-mode flag */
extern int grx, gry; /* Coordinates of the current point */
extern int grcolor; /* Current *CAML* drawing color (can be -1) */
extern HFONT * grfont; /* Current font */
extern BOOL direct_rgb;
extern int byte_order;
extern int bitmap_unit;
extern int bits_per_pixel;
#define Wcvt(y) (grwindow.height - 1 - (y))
#define Bcvt(y) (grwindow.height - 1 - (y))
#define WtoB(y) ((y) + WindowRect.bottom - grwindow.h)
//#define BtoW(y) ((y) + WindowRect.bottom - grbstore.h)
#define DEFAULT_SCREEN_WIDTH 1024
#define DEFAULT_SCREEN_HEIGHT 768
#define BORDER_WIDTH 2
#define WINDOW_NAME "OCaml graphics"
#define ICON_NAME "OCaml graphics"
#define DEFAULT_EVENT_MASK \
(ExposureMask | KeyPressMask | StructureNotifyMask)
#define DEFAULT_FONT "fixed"
#define SIZE_QUEUE 256
/* To handle events asynchronously */
#ifdef HAS_ASYNC_IO
#define USE_ASYNC_IO
#define EVENT_SIGNAL SIGIO
#else
#ifdef HAS_SETITIMER
#define USE_INTERVAL_TIMER
#define EVENT_SIGNAL SIGALRM
#else
#define USE_ALARM
#define EVENT_SIGNAL SIGALRM
#endif
#endif
void gr_fail(char *fmt, char *arg);
void gr_check_open(void);
unsigned long gr_pixel_rgb(int rgb);
int gr_rgb_pixel(long unsigned int pixel);
void gr_enqueue_char(unsigned char c);
void gr_init_color_cache(void);
// Windows specific definitions
extern RECT WindowRect;
extern int grCurrentColor;
typedef struct tagWindow {
HDC gc;
HDC gcBitmap;
HWND hwnd;
HBRUSH CurrentBrush;
HPEN CurrentPen;
DWORD CurrentColor;
int width;
int height;
int grx;
int gry;
HBITMAP hBitmap;
HFONT CurrentFont;
int CurrentFontSize;
HDC tempDC; // For image operations;
} GR_WINDOW;
extern GR_WINDOW grwindow;
HFONT CreationFont(char *name);
extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
extern HANDLE EventHandle;
extern int InspectMessages;
extern MSG msg;

831
win32caml/menu.c
View File

@ -1,831 +0,0 @@
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Developed by Jacob Navia. */
/* */
/* Copyright 2001 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/***********************************************************************/
/* Changes made by Chris Watford to enhance the source editor */
/* Began 14 Sept 2003 - watford@uiuc.edu */
/***********************************************************************/
/* $Id$ */
#include <stdio.h>
#include <windows.h>
#include <Richedit.h>
#include "inria.h"
#include "inriares.h"
#include "history.h"
LOGFONT CurrentFont;
int CurrentFontFamily = (FIXED_PITCH | FF_MODERN);
int CurrentFontStyle;
char CurrentFontName[64] = "Courier";
/*------------------------------------------------------------------------
Procedure: OpenMlFile ID:1
Purpose: Opens a file, either a source file (*.ml) or an *.cmo
file.
Input: A buffer where the name will be stored, and its
length
Output: The user's choice will be stored in the buffer.
Errors: None
------------------------------------------------------------------------*/
int OpenMlFile(char *fname,int lenbuf)
{
OPENFILENAME ofn;
int r;
char *p,defext[5],tmp[512];
memset(&ofn,0,sizeof(OPENFILENAME));
memset(tmp,0,sizeof(tmp));
fname[0] = 0;
strcpy(tmp,"ocaml sources|*.ml|bytecode object files|*.cmo|All files|*.*");
p = tmp;
while (*p) {
if (*p == '|')
*p = 0;
p++;
}
strcpy(defext,"ml");
ofn.lStructSize = sizeof(OPENFILENAME);
ofn.hwndOwner = hwndMain;
ofn.lpstrFilter = tmp;
ofn.nFilterIndex = 1;
ofn.hInstance = hInst;
ofn.lpstrFile = fname;
ofn.lpstrTitle = "Open file";
ofn.lpstrInitialDir = LibDir;
ofn.nMaxFile = lenbuf;
ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES |
OFN_HIDEREADONLY |OFN_EXPLORER;
r = GetOpenFileName(&ofn);
if (r) {
/* Replace backslashes by forward slashes in file name */
for (p = fname; *p != 0; p++)
if (*p == '\\') *p = '/';
}
return r;
}
/*------------------------------------------------------------------------
Procedure: GetSaveName ID:1
Purpose: Get a name to save the current session (Save as menu
item)
Input: A buffer where the name of the file will be stored,
and its length
Output: The name of the file choosen by the user will be
stored in the buffer
Errors: none
------------------------------------------------------------------------*/
int GetSaveName(char *fname,int lenbuf)
{
OPENFILENAME ofn;
int r;
char *p,defext[5],tmp[512];
memset(&ofn,0,sizeof(OPENFILENAME));
memset(tmp,0,sizeof(tmp));
fname[0] = 0;
strcpy(tmp,"Text files|*.txt");
p = tmp;
while (*p) {
if (*p == '|')
*p = 0;
p++;
}
strcpy(defext,"txt");
ofn.lStructSize = sizeof(OPENFILENAME);
ofn.hwndOwner = hwndMain;
ofn.lpstrFilter = tmp;
ofn.nFilterIndex = 1;
ofn.hInstance = hInst;
ofn.lpstrFile = fname;
ofn.lpstrTitle = "Save as";
ofn.lpstrInitialDir = LibDir;
ofn.nMaxFile = lenbuf;
ofn.Flags = OFN_NOCHANGEDIR | OFN_LONGNAMES |
OFN_HIDEREADONLY |OFN_EXPLORER;
r = GetSaveFileName(&ofn);
if (r == 0)
return 0;
else return 1;
}
/*------------------------------------------------------------------------
Procedure: GetSaveMLName ID:1
Purpose: Get a name to save the current OCaml code to (Save as menu
item)
Input: A buffer where the name of the file will be stored,
and its length
Output: The name of the file choosen by the user will be
stored in the buffer
Errors: none
------------------------------------------------------------------------*/
int GetSaveMLName(char *fname, int lenbuf)
{
OPENFILENAME ofn;
int r;
char *p,defext[5],tmp[512];
memset(&ofn,0,sizeof(OPENFILENAME));
memset(tmp,0,sizeof(tmp));
fname[0] = 0;
strcpy(tmp,"OCaml Source Files|*.ml");
p = tmp;
while (*p) {
if (*p == '|')
*p = 0;
p++;
}
strcpy(defext,"ml");
ofn.lStructSize = sizeof(OPENFILENAME);
ofn.hwndOwner = hwndMain;
ofn.lpstrFilter = tmp;
ofn.nFilterIndex = 1;
ofn.hInstance = hInst;
ofn.lpstrFile = fname;
ofn.lpstrTitle = "Save as";
ofn.lpstrInitialDir = LibDir;
ofn.nMaxFile = lenbuf;
ofn.Flags = OFN_NOCHANGEDIR | OFN_LONGNAMES |
OFN_HIDEREADONLY |OFN_EXPLORER;
r = GetSaveFileName(&ofn);
if (r == 0)
return 0;
else return 1;
}
/*------------------------------------------------------------------------
Procedure: BrowseForFile ID:1
Purpose: Let's the user browse for a certain kind of file.
Currently this is only used when browsing for
ocaml.exe.
Input: The name of the file to browse for, and the path
where the user's choice will be stored.
Output: 1 if user choosed a path, zero otherwise
Errors: None
------------------------------------------------------------------------*/
int BrowseForFile(char *fname,char *path)
{
OPENFILENAME ofn;
char *p,tmp[512],browsefor[512];
int r;
memset(tmp,0,sizeof(tmp));
strncpy(tmp,fname,sizeof(tmp)-1);
p = tmp;
while (*p) {
if (*p == '|')
*p = 0;
p++;
}
memset(&ofn,0,sizeof(OPENFILENAME));
ofn.lpstrFilter = tmp;
ofn.nFilterIndex = 1;
ofn.lStructSize = sizeof(OPENFILENAME);
ofn.hwndOwner = hwndMain;
ofn.hInstance = hInst;
ofn.lpstrFilter = tmp;
ofn.lpstrFile = path;
wsprintf(browsefor,"Open %s",fname);
ofn.lpstrTitle = browsefor;
ofn.lpstrInitialDir = "c:\\";
ofn.nMaxFile = MAX_PATH;
ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES |
OFN_HIDEREADONLY |OFN_EXPLORER;
r = GetOpenFileName(&ofn);
if (r == 0)
return 0;
else return 1;
}
/*------------------------------------------------------------------------
Procedure: CallChangeFont ID:1
Purpose: Calls the standard windows font change dialog. If the
user validates a font, it will destroy the current
font, and recreate a new font with the given
parameters.
Input: The calling window handle
Output: Zero if the user cancelled, 1 otherwise.
Errors: None
------------------------------------------------------------------------*/
static int CallChangeFont(HWND hwnd)
{
LOGFONT lf;
CHOOSEFONT cf;
int r;
HWND hwndChild;
memset(&cf, 0, sizeof(CHOOSEFONT));
memcpy(&lf, &CurrentFont, sizeof(LOGFONT));
cf.lStructSize = sizeof(CHOOSEFONT);
cf.hwndOwner = hwnd;
cf.lpLogFont = &lf;
cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_APPLY | CF_INITTOLOGFONTSTRUCT;
cf.nFontType = SCREEN_FONTTYPE;
r = ChooseFont(&cf);
if (!r)
return (0);
DeleteObject(ProgramParams.hFont);
memcpy(&CurrentFont, &lf, sizeof(LOGFONT));
ProgramParams.hFont = CreateFontIndirect(&CurrentFont);
strcpy(CurrentFontName, CurrentFont.lfFaceName);
CurrentFontFamily = lf.lfPitchAndFamily;
CurrentFontStyle = lf.lfWeight;
hwndChild = (HWND) GetWindowLongPtr(hwndSession, DWLP_USER);
SendMessage(hwndChild,WM_SETFONT,(WPARAM)ProgramParams.hFont,0);
ForceRepaint();
return (1);
}
/*------------------------------------------------------------------------
Procedure: CallDlgProc ID:1
Purpose: Calls a dialog box procedure
Input: The function to call, and the numerical ID of the
resource where the dialog box is stored
Output: Returns the result of the dialog box.
Errors: None
------------------------------------------------------------------------*/
int CallDlgProc(BOOL (CALLBACK *fn)(HWND,UINT,WPARAM,LPARAM), int id)
{
int result;
result = DialogBoxParam(hInst, MAKEINTRESOURCE(id), GetActiveWindow(),
fn, 0);
return result;
}
/*------------------------------------------------------------------------
Procedure: CallChangeColor ID:1
Purpose: Calls the standard color dialog of windows, starting
with the given color reference. The result is the
same as the input if the user cancels, or another
color if the user validates another one.
Input: The starting color
Output: The color the user has choosen.
Errors: None
------------------------------------------------------------------------*/
static COLORREF CallChangeColor(COLORREF InitialColor)
{
CHOOSECOLOR CC;
COLORREF CustColors[16];
int r, g, b, i;
memset(&CC, 0, sizeof(CHOOSECOLOR));
r = g = b = 0;
for (i = 0; i < 16; i++) {
CustColors[i] = RGB(r, g, b);
if (r < 255)
r += 127;
else if (g < 255)
g += 127;
else if (b < 255)
g += 127;
}
CC.lStructSize = sizeof(CHOOSECOLOR);
CC.hwndOwner = hwndMain;
CC.hInstance = hInst;
CC.rgbResult = InitialColor;
CC.lpCustColors = CustColors;
CC.Flags = CC_RGBINIT;
if (!ChooseColor(&CC))
return (InitialColor);
return (CC.rgbResult);
}
/*------------------------------------------------------------------------
Procedure: CallPrintSetup ID:1
Purpose: Calls the printer setup dialog. Currently it is not
connected to the rest of the software, since printing
is not done yet
Input: None
Output: 1 if OK, 0, user cancelled
Errors: None
------------------------------------------------------------------------*/
static int CallPrintSetup(void)
{
PAGESETUPDLG sd;
int r;
memset(&sd,0,sizeof(sd));
sd.lStructSize = sizeof(sd);
sd.Flags = PSD_RETURNDEFAULT;
r = PageSetupDlg(&sd);
if (!r)
return 0;
sd.Flags = 0;
r = PageSetupDlg(&sd);
return r;
}
/*------------------------------------------------------------------------
Procedure: Undo ID:1
Purpose: Send an UNDO command to the edit field.
Input: The parent window of the control
Output: None
Errors: None
------------------------------------------------------------------------*/
void Undo(HWND hwnd)
{
HWND hEdit;
hEdit = (HWND)GetWindowLongPtr(hwnd,DWLP_USER);
SendMessage(hEdit,EM_UNDO,0,0);
}
/*------------------------------------------------------------------------
Procedure: ForceRepaint ID:1
Purpose: Forces a complete redraw of the edit control of the
current session.
Input: None
Output: None
Errors: None
------------------------------------------------------------------------*/
void ForceRepaint(void)
{
HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
InvalidateRect(hwndEdit,NULL,1);
}
/*------------------------------------------------------------------------
Procedure: Add_Char_To_Queue ID:1
Purpose: Puts a character onto the buffer
Input: The char to be added
Output: None
Errors:
------------------------------------------------------------------------*/
static void Add_Char_To_Queue(int c)
{
HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
SendMessage(hwndEdit,WM_CHAR,c,1);
}
/*------------------------------------------------------------------------
Procedure: AddLineToControl ID:1
Purpose: It will ad the given text at the end of the edit
control, then it will send a return character to it.
This simulates user input. The history will not be
modified by this procedure.
Input: The text to be added
Output: None
Errors: If the line is empty, nothing will be done
------------------------------------------------------------------------*/
void AddLineToControl(char *buf)
{
HWND hEditCtrl;
if (*buf == 0)
return;
hEditCtrl = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
GotoEOF();
SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)buf);
SendMessage(hEditCtrl,WM_CHAR,'\r',0);
}
/*------------------------------------------------------------------------
Procedure: AddStringToControl ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: It will ad the given text at the end of the edit
control. This simulates user input. The history will not
be modified by this procedure.
Input: The text to be added
Output: None
Errors: If the line is empty, nothing will be done
--------------------------------------------------------------------------
Edit History:
16 Sept 2003 - Chris Watford watford@uiuc.edu
- Basically this is AddLineToControl, but without appending a
newline
------------------------------------------------------------------------*/
void AddStringToControl(char* buf)
{
HWND hEditCtrl;
if(buf == NULL)
return;
if((*buf) == 0)
return;
hEditCtrl = (HWND)GetWindowLongPtr(hwndSession, DWLP_USER);
GotoEOF();
SendMessage(hEditCtrl ,EM_REPLACESEL, (WPARAM)FALSE, (LPARAM)buf);
}
/*------------------------------------------------------------------------
Procedure: AboutDlgProc ID:1
Purpose: Shows the "About" dialog box
Input:
Output:
Errors:
------------------------------------------------------------------------*/
static BOOL CALLBACK AboutDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam)
{
if (message == WM_CLOSE)
EndDialog(hDlg,1);
return 0;
}
/*------------------------------------------------------------------------
Procedure: HistoryDlgProc ID:1
Purpose: Shows the history of the session. Only input lines
are shown. A double click in a line will make this
dialog box procedure return the index of the selected
line (1 based). If the windows is closed (what is
equivalent to cancel), the return value is zero.
Input: Normal windows callback
Output:
Errors:
--------------------------------------------------------------------------
Edit History:
15 Sept 2003 - Chris Watford watford@uiuc.edu
- Added support for my StatementHistory structure
- Added the ability to export it as its exact entry, rather than
just a 1 liner
------------------------------------------------------------------------*/
static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam)
{
StatementHistory *histentry;
int idx;
RECT rc;
switch (message) {
case WM_INITDIALOG:
SendDlgItemMessage(hDlg,IDLIST,WM_SETFONT,(WPARAM)ProgramParams.hFont,0);
histentry = History; // get our statement history object
idx = 0;
// loop through each history entry adding it to the dialog
while (histentry != NULL) {
SendDlgItemMessage(hDlg,IDLIST,LB_INSERTSTRING,0,(LPARAM)editbuffer_getasline(histentry->Statement));
SendDlgItemMessage(hDlg,IDLIST,LB_SETITEMDATA,0,(LPARAM)idx);
histentry = histentry->Next;
idx++;
}
SendDlgItemMessage(hDlg,IDLIST,LB_SETCURSEL,(LPARAM)idx-1,0);
return 1;
case WM_COMMAND:
switch(LOWORD(wParam)) {
case IDLIST:
switch(HIWORD(wParam)) {
case LBN_DBLCLK:
idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETCURSEL,0,0);
if (idx == LB_ERR)
break;
idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETITEMDATA,idx,0);
EndDialog(hDlg,idx+1);
return 1;
}
break;
}
break;
case WM_SIZE:
GetClientRect(hDlg,&rc);
MoveWindow(GetDlgItem(hDlg,IDLIST),0,0,rc.right,rc.bottom,1);
break;
case WM_CLOSE:
EndDialog(hDlg,0);
break;
}
return 0;
}
/*------------------------------------------------------------------------
Procedure: SaveText ID:1
Purpose: Saves the contents of the session transcript. It will
loop for each line and write it to the specified file
Input: The name of the file where the session will be saved
Output: The session is saved
Errors: If it can't open the file for writing it will show an
error box
--------------------------------------------------------------------------
Edit History:
06 Oct 2003 - Chris Watford watford@uiuc.edu
- Corrected wsprintf error
------------------------------------------------------------------------*/
static void SaveText(char *fname)
{
int i,len;
HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
FILE *f;
char *buf = SafeMalloc(8192);
f = fopen(fname,"wb");
if (f == NULL)
{
// corrected error using wsprintf
wsprintf(buf, "Impossible to open %s for writing", fname);
ShowDbgMsg(buf);
return;
}
for (i = 0; i < linesCount; i++)
{
*(unsigned short *)buf = 8100;
len = SendMessage(hEdit, EM_GETLINE, i, (LPARAM)buf);
buf[len] = '\0';
fprintf(f, "%s\r\n", buf+1);
//fwrite(buf,1,len+2,f);
}
fclose(f);
free(buf);
}
/*------------------------------------------------------------------------
Procedure: SaveML ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Saves the ML source to a file, commenting out functions
that contained errors
Input: The name of the file where the session will be saved
Output: The session is saved
Errors: If it can't open the file for writing it will show an
error box
------------------------------------------------------------------------*/
static void SaveML(char *fname)
{
FILE *f;
char *buf = SafeMalloc(8192);
f = fopen(fname, "wb");
if(f == NULL)
{
wsprintf(buf, "Impossible to open %s for writing", fname);
ShowDbgMsg(buf);
return;
}
fprintf(f, "(* %s *)\r\n\r\n", fname);
if(History != NULL)
{
StatementHistory *h = NULL;
EditBuffer *stmt = NULL;
// get to the end
for(h = History; h->Next != NULL; h = h->Next);
// go back :(
// this is NOT the fastest method, BUT this is the easiest
// on the subsystem
for(; h != NULL; h = h->Prev)
{
stmt = h->Statement;
if(stmt != NULL)
{
// comment out incorrect lines
if(stmt->isCorrect)
{
char *buff = editbuffer_getasbuffer(stmt);
fprintf(f, "%s\r\n", buff);
free(buff);
} else {
char *buff = editbuffer_getasbuffer(stmt);
fprintf(f, "(* Syntax Error or Unbound Value\r\n%s\r\n *)\r\n", buff);
free(buff);
}
}
fprintf(f, "\r\n");
}
}
fclose(f);
free(buf);
}
/*------------------------------------------------------------------------
Procedure: Add_Clipboard_To_Queue ID:1
Author: Chris Watford watford@uiuc.edu
Purpose: Adds the clipboard text to the control
Input:
Output:
Errors:
--------------------------------------------------------------------------
Edit History:
16 Sept 2003 - Chris Watford watford@uiuc.edu
- Added method to update edit buffer with paste contents
------------------------------------------------------------------------*/
static void Add_Clipboard_To_Queue(void)
{
if (IsClipboardFormatAvailable(CF_TEXT) && OpenClipboard(hwndMain))
{
HANDLE hClipData = GetClipboardData(CF_TEXT);
if (hClipData != NULL)
{
char *str = GlobalLock(hClipData);
if (str != NULL)
{
while ((*str) != 0)
{
if (*str != '\r')
Add_Char_To_Queue(*str);
str++;
}
// added to fix odd errors
RefreshCurrentEditBuffer();
}
GlobalUnlock(hClipData);
}
CloseClipboard();
}
}
/*------------------------------------------------------------------------
Procedure: CopyToClipboard ID:1
Purpose: Copies text to the clipboard
Input: Window with the edit control
Output:
Errors:
------------------------------------------------------------------------*/
static void CopyToClipboard(HWND hwnd)
{
HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
SendMessage(hwndEdit,WM_COPY,0,0);
}
/*------------------------------------------------------------------------
Procedure: ResetText ID:1
Purpose: Resets the text? I'm not really sure
Input:
Output: Always returns 0
Errors:
------------------------------------------------------------------------*/
int ResetText(void)
{
HWND hwndEdit = (HWND) GetWindowLongPtr(hwndSession,DWLP_USER);
TEXTRANGE cr;
int len = SendMessage(hwndEdit,WM_GETTEXTLENGTH,0,0);
char *tmp = malloc(len+10),*p;
memset(tmp,0,len+10);
cr.chrg.cpMin = 0;
cr.chrg.cpMax = -1;
cr.lpstrText = tmp;
SendMessage(hwndEdit,EM_GETTEXTRANGE,0,(LPARAM)&cr);
p = tmp+len/2;
while (*p && *p != '\r')
p++;
SendMessage(hwndEdit,EM_SETSEL,0,(LPARAM)-1);
SendMessage(hwndEdit,EM_REPLACESEL,0,(LPARAM)p);
InvalidateRect(hwndEdit,0,1);
free(tmp);
return 0;
}
/*------------------------------------------------------------------------
Procedure: HandleCommand ID:1
Purpose: Handles all menu commands.
Input:
Output:
Errors:
--------------------------------------------------------------------------
Edit History:
06 Oct 2003 - Chris Watford watford@uiuc.edu
- Removed entries that crashed OCaml
- Removed useless entries
- Added Save ML and Save Transcript
------------------------------------------------------------------------*/
void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
{
char *fname;
int r;
switch(LOWORD(wParam)) {
case IDM_OPEN:
fname = SafeMalloc(512);
if (OpenMlFile(fname,512)) {
char *buf = SafeMalloc(512);
char *p = strrchr(fname,'.');
if (p && !stricmp(p,".ml")) {
wsprintf(buf, "#use \"%s\";;", fname);
AddLineToControl(buf);
}
else if (p && !stricmp(p,".cmo")) {
wsprintf(buf, "#load \"%s\";;", fname);
AddLineToControl(buf);
}
free(buf);
}
free(fname);
break;
case IDM_GC:
AddLineToControl("Gc.full_major();;");
break;
case IDCTRLC:
InterruptOcaml();
break;
case IDM_EDITPASTE:
Add_Clipboard_To_Queue();
break;
case IDM_EDITCOPY:
CopyToClipboard(hwnd);
break;
// updated to save a transcript
case IDM_SAVEAS:
fname = SafeMalloc(512);
if (GetSaveName(fname,512)) {
SaveText(fname);
}
free(fname);
break;
// updated to save an ML file
case IDM_SAVE:
fname = SafeMalloc(512);
if (GetSaveMLName(fname,512))
{
SaveML(fname);
}
free(fname);
break;
// updated to work with new history system
case IDM_HISTORY:
r = CallDlgProc(HistoryDlgProc,IDD_HISTORY);
if (r)
{
AddLineToControl(GetHistoryLine(r-1));
}
break;
case IDM_PRINTSU:
// Removed by Chris Watford
// seems to die
// CallPrintSetup();
break;
case IDM_FONT:
CallChangeFont(hwndMain);
break;
case IDM_COLORTEXT:
ProgramParams.TextColor = CallChangeColor(ProgramParams.TextColor);
ForceRepaint();
break;
case IDM_BACKCOLOR:
BackColor = CallChangeColor(BackColor);
DeleteObject(BackgroundBrush);
BackgroundBrush = CreateSolidBrush(BackColor);
ForceRepaint();
break;
case IDM_EDITUNDO:
Undo(hwnd);
break;
/* Removed, really not very useful in this IDE
case IDM_WINDOWTILE:
SendMessage(hwndMDIClient,WM_MDITILE,0,0);
break;
case IDM_WINDOWCASCADE:
SendMessage(hwndMDIClient,WM_MDICASCADE,0,0);
break;
case IDM_WINDOWICONS:
SendMessage(hwndMDIClient,WM_MDIICONARRANGE,0,0);
break;
*/
case IDM_EXIT:
PostMessage(hwnd,WM_CLOSE,0,0);
break;
case IDM_ABOUT:
CallDlgProc(AboutDlgProc,IDD_ABOUT);
break;
default:
if (LOWORD(wParam) >= IDEDITCONTROL && LOWORD(wParam) < IDEDITCONTROL+5) {
switch (HIWORD(wParam)) {
case EN_ERRSPACE:
ResetText();
break;
}
}
break;
}
}

1601
win32caml/ocaml.c
View File

File diff suppressed because it is too large Load Diff

BIN
win32caml/ocaml.ico
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 766 B

255
win32caml/ocaml.rc
View File

@ -1,255 +0,0 @@
// Microsoft Visual C++ generated resource script.
//
#include "resource.h"
#define APSTUDIO_READONLY_SYMBOLS
/////////////////////////////////////////////////////////////////////////////
//
// Generated from the TEXTINCLUDE 2 resource.
//
#define APSTUDIO_HIDDEN_SYMBOLS
#include "windows.h"
#undef APSTUDIO_HIDDEN_SYMBOLS
#include "inriares.h"
/////////////////////////////////////////////////////////////////////////////
#undef APSTUDIO_READONLY_SYMBOLS
/////////////////////////////////////////////////////////////////////////////
// English (U.S.) resources
#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU)
#ifdef _WIN32
LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US
#pragma code_page(1252)
#endif //_WIN32
/////////////////////////////////////////////////////////////////////////////
//
// Icon
//
// Icon with lowest ID value placed first to ensure application icon
// remains consistent on all systems.
1000 ICON "ocaml.ico"
/////////////////////////////////////////////////////////////////////////////
//
// Menu
//
IDMAINMENU MENU
BEGIN
POPUP "&File"
BEGIN
MENUITEM "&Open...", IDM_OPEN
MENUITEM "&Save ML...", IDM_SAVE
MENUITEM "Save &Transcript...", IDM_SAVEAS
MENUITEM SEPARATOR
MENUITEM "&Print", IDM_PRINT, GRAYED
MENUITEM "P&rint Setup...", IDM_PRINTSU, GRAYED
MENUITEM SEPARATOR
MENUITEM "E&xit", IDM_EXIT
END
POPUP "&Edit"
BEGIN
MENUITEM "&Undo\tAlt+BkSp", IDM_EDITUNDO
MENUITEM SEPARATOR
MENUITEM "Cu&t\t Shift+Del", IDM_EDITCUT
MENUITEM "&Copy\tCtrl+Ins", IDM_EDITCOPY
MENUITEM "&Paste\tShift+Ins", IDM_EDITPASTE
END
POPUP "Workspace"
BEGIN
MENUITEM "&Font...", IDM_FONT
MENUITEM "Text &Color...", IDM_COLORTEXT
MENUITEM "&Background Color...", IDM_BACKCOLOR
MENUITEM SEPARATOR
MENUITEM "&History...", IDM_HISTORY
MENUITEM "&Garbage Collect", IDM_GC
MENUITEM "&Interrupt", IDCTRLC
END
POPUP "&Window", GRAYED
BEGIN
MENUITEM "&Tile", IDM_WINDOWTILE, INACTIVE
MENUITEM "&Cascade", IDM_WINDOWCASCADE, INACTIVE
MENUITEM "Arrange &Icons", IDM_WINDOWICONS, INACTIVE
MENUITEM "Close &All", IDM_WINDOWCLOSEALL, INACTIVE
END
POPUP "&Help"
BEGIN
MENUITEM "&About...", IDM_ABOUT
END
END
/////////////////////////////////////////////////////////////////////////////
//
// Accelerator
//
BARMDI ACCELERATORS
BEGIN
"Q", IDM_EXIT, VIRTKEY, CONTROL
END
/////////////////////////////////////////////////////////////////////////////
//
// Dialog
//
IDD_ABOUT DIALOGEX 7, 29, 236, 81
STYLE DS_SETFONT | DS_CENTER | WS_POPUP | WS_VISIBLE | WS_CAPTION |
WS_SYSMENU
EXSTYLE WS_EX_TOOLWINDOW | WS_EX_CLIENTEDGE
CAPTION "About OCamlWinPlus"
FONT 8, "MS Sans Serif", 0, 0, 0x1
BEGIN
LTEXT "OCaml for Windows",101,75,7,90,12
LTEXT "New Windows Interface 1.9RC4",102,68,15,104,12
CTEXT "Copyright 1996-2001\nUpdated 2003",103,88,25,66,23
CTEXT "Institut National de Recherche en Informatique et Automatique",
104,16,46,211,10
CTEXT "Réalisé par Jacob Navia 2001. Updated by Chris Watford 2003.\nwatford@uiuc.edu",
105,18,54,207,19
END
IDD_HISTORY DIALOGEX 6, 18, 261, 184
STYLE DS_SETFONT | DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION |
WS_SYSMENU | WS_THICKFRAME
EXSTYLE WS_EX_TOOLWINDOW
CAPTION "Session History"
FONT 8, "MS Sans Serif", 0, 0, 0x1
BEGIN
LISTBOX IDLIST,7,7,247,173,LBS_USETABSTOPS | WS_VSCROLL |
WS_HSCROLL | WS_TABSTOP
END
#ifdef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// TEXTINCLUDE
//
1 TEXTINCLUDE
BEGIN
"resource.h\0"
END
2 TEXTINCLUDE
BEGIN
"#define APSTUDIO_HIDDEN_SYMBOLS\r\n"
"#include ""windows.h""\r\n"
"#undef APSTUDIO_HIDDEN_SYMBOLS\r\n"
"#include ""inriares.h""\r\n"
"\0"
END
3 TEXTINCLUDE
BEGIN
"\r\n"
"\0"
END
#endif // APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// String Table
//
STRINGTABLE
BEGIN
3010 "Switches to "
END
STRINGTABLE
BEGIN
2000 "Create, open, save, or print documents"
2010 "Get help"
END
STRINGTABLE
BEGIN
500 "Displays information about this application"
END
STRINGTABLE
BEGIN
440 "Closes all open windows"
END
STRINGTABLE
BEGIN
420 "Arranges windows as overlapping tiles"
430 "Arranges minimized window icons"
END
STRINGTABLE
BEGIN
410 "Arranges windows as non-overlapping tiles"
END
STRINGTABLE
BEGIN
340 "Inserts the clipboard contents at the insertion point"
350 "Removes the selection without putting it on the clipboard"
END
STRINGTABLE
BEGIN
320 "Cuts the selection and puts it on the clipboard"
330 "Copies the selection and puts it on the clipboard"
END
STRINGTABLE
BEGIN
310 "Reverses the last action"
END
STRINGTABLE
BEGIN
260 "Changes the printer selection or configuration"
270 "Quits this application"
END
STRINGTABLE
BEGIN
240 "Closes the active document"
250 "Prints the active document"
END
STRINGTABLE
BEGIN
230 "Saves the active document under a different name"
END
STRINGTABLE
BEGIN
210 "Opens an existing document"
220 "Saves the active document"
END
STRINGTABLE
BEGIN
200 "Creates a new session"
END
#endif // English (U.S.) resources
/////////////////////////////////////////////////////////////////////////////
#ifndef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// Generated from the TEXTINCLUDE 3 resource.
//
/////////////////////////////////////////////////////////////////////////////
#endif // not APSTUDIO_INVOKED

16
win32caml/resource.h
View File

@ -1,16 +0,0 @@
//{{NO_DEPENDENCIES}}
// Microsoft Visual C++ generated include file.
// Used by ocaml.rc
//
// Next default values for new objects
//
#ifdef APSTUDIO_INVOKED
#ifndef APSTUDIO_READONLY_SYMBOLS
#define _APS_NO_MFC 1
#define _APS_NEXT_RESOURCE_VALUE 101
#define _APS_NEXT_COMMAND_VALUE 40001
#define _APS_NEXT_CONTROL_VALUE 1000
#define _APS_NEXT_SYMED_VALUE 101
#endif
#endif

363
win32caml/startocaml.c
View File

@ -1,363 +0,0 @@
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Developed by Jacob Navia. */
/* */
/* Copyright 2001 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/***********************************************************************/
/* Changes made by Chris Watford to enhance the source editor */
/* Began 14 Sept 2003 - watford@uiuc.edu */
/***********************************************************************/
/* $Id$ */
#include <windows.h>
#include <stdio.h>
#include <io.h>
#include <direct.h>
#include "inria.h"
PROCESS_INFORMATION pi;
#define BUFSIZE 4096
STARTUPINFO startInfo;
/*------------------------------------------------------------------------
Procedure: ShowDbgMsg ID:1
Purpose: Puts up a dialog box with a message, forcing it to
the foreground.
Input:
Output:
Errors:
------------------------------------------------------------------------*/
void ShowDbgMsg(char *str)
{
HWND hWnd;
char p[20], message[255];
hWnd = hwndMain;
if (IsIconic(hWnd)){
ShowWindow(hWnd,SW_RESTORE);
}
strncpy(message, str, 254);
message[254] = 0;
strcpy(p, "Error");
MessageBox(hWnd, message, p, MB_OK | MB_ICONHAND|MB_TASKMODAL|MB_SETFOREGROUND);
}
int AskYesOrNo(char *msg)
{
HWND hwnd;
int r;
hwnd = hwndMain;
r = MessageBox(hwnd, msg, "OCaml", MB_YESNO | MB_SETFOREGROUND);
if (r == IDYES)
return (TRUE);
return (FALSE);
}
static DWORD OcamlStatus;
static int RegistryError(void)
{
char buf[512];
wsprintf(buf,"Error %d writing to the registry",GetLastError());
ShowDbgMsg(buf);
return 0;
}
static int ReadRegistry(HKEY hroot,
char * p1, char * p2, char * p3,
char dest[1024])
{
HKEY h1, h2;
DWORD dwType;
unsigned long size;
LONG ret;
if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
return 0;
if (RegOpenKeyExA(h1, p2, 0, KEY_QUERY_VALUE, &h2) != ERROR_SUCCESS) {
RegCloseKey(h1);
return 0;
}
dwType = REG_SZ;
size = 1024;
ret = RegQueryValueExA(h2, p3, 0, &dwType, dest, &size);
RegCloseKey(h2);
RegCloseKey(h1);
return ret == ERROR_SUCCESS;
}
static int WriteRegistry(HKEY hroot,
char * p1, char * p2, char * p3,
char data[1024])
{
HKEY h1, h2;
DWORD disp;
LONG ret;
if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
return 0;
if (RegCreateKeyExA(h1, p2, 0, NULL, 0, KEY_ALL_ACCESS, NULL, &h2, &disp)
!= ERROR_SUCCESS) {
RegCloseKey(h1);
return 0;
}
ret = RegSetValueEx(h2, p3, 0, REG_SZ, data, strlen(data) + 1);
RegCloseKey(h2);
RegCloseKey(h1);
return ret == ERROR_SUCCESS;
}
/*------------------------------------------------------------------------
Procedure: GetOcamlPath ID:1
Purpose: Read the registry key
HKEY_LOCAL_MACHINE\Software\Objective Caml
or
HKEY_CURRENT_USER\Software\Objective Caml,
and creates it if it doesn't exists.
If any error occurs, i.e. the
given path doesn't exist, or the key didn't exist, it
will put up a browse dialog box to allow the user to
enter the path. The path will be verified that it
points to a file that exists. If that file is in a
directory called 'bin', it will look for another
directory in the same level called lib' and set the
Lib path to that.
Input: None explicit
Output: 1 means sucess, zero failure
Errors: Almost all system calls will be verified
------------------------------------------------------------------------*/
int GetOcamlPath(void)
{
char path[1024], *p;
while (( !ReadRegistry(HKEY_CURRENT_USER,
"Software", "Objective Caml",
"InterpreterPath", path)
&&
!ReadRegistry(HKEY_LOCAL_MACHINE,
"Software", "Objective Caml",
"InterpreterPath", path))
|| _access(path, 0) != 0) {
/* Registry key doesn't exist or contains invalid path */
/* Ask user */
if (!BrowseForFile("OCaml interpreter|ocaml.exe", path)) {
ShowDbgMsg("Impossible to find ocaml.exe. I quit");
exit(0);
}
WriteRegistry(HKEY_CURRENT_USER,
"Software", "Objective Caml",
"InterpreterPath", path);
/* Iterate to validate again */
}
strcpy(OcamlPath, path);
p = strrchr(OcamlPath,'\\');
if (p) {
*p = 0;
strcpy(LibDir,OcamlPath);
*p = '\\';
p = strrchr(LibDir,'\\');
if (p && !stricmp(p,"\\bin")) {
*p = 0;
strcat(LibDir,"\\lib");
}
}
return 1;
}
static HANDLE hChildStdinRd, hChildStdinWr,hChildStdoutRd, hChildStdoutWr;
/*------------------------------------------------------------------------
Procedure: IsWindowsNT ID:1
Purpose: Returns 1 if we are running under windows NT, zero
otherwise.
Input: None
Output: 1 or zero
Errors:
------------------------------------------------------------------------*/
int IsWindowsNT(void)
{
OSVERSIONINFO osv;
osv.dwOSVersionInfoSize = sizeof(osv);
GetVersionEx(&osv);
return(osv.dwPlatformId == VER_PLATFORM_WIN32_NT);
}
/*------------------------------------------------------------------------
Procedure: DoStartOcaml ID:1
Purpose: Starts the ocaml interpreter ocaml.exe. The standard
input of the interpreter will be connected to a pipe,
and the standard output and standard error to another
pipe. The interpreter starts as a hidden process,
showing only in the task list. Since this is in an
own thread, its workings are independent of the rest
of the program. After starting the interpreter, the
thread waits in case the interpreter exits, for
instance if the user or some program types #quit;;.
In this case, the waiting thread awakens and exits
the user interface.
Input: Not used. It uses the OcamlPath global variable, that
is supposed to be correct, no test for its validity
are done here.
Output: None visible
Errors: If any system call for whatever reason fails, the
thread will exit. No error message is shown.
------------------------------------------------------------------------*/
DWORD WINAPI DoStartOcaml(LPVOID param)
{
HWND hwndParent = (HWND) param;
char *cmdline;
int processStarted;
LPSECURITY_ATTRIBUTES lpsa=NULL;
SECURITY_ATTRIBUTES sa;
SECURITY_DESCRIPTOR sd;
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
// Under windows NT/2000/Whistler we have to initialize the security descriptors
// This is not necessary under windows 98/95.
if (IsWindowsNT()) {
InitializeSecurityDescriptor(&sd,SECURITY_DESCRIPTOR_REVISION);
SetSecurityDescriptorDacl(&sd,TRUE,NULL,FALSE);
sa.bInheritHandle = TRUE;
sa.lpSecurityDescriptor = &sd;
lpsa = &sa;
}
memset(&startInfo,0,sizeof(STARTUPINFO));
startInfo.cb = sizeof(STARTUPINFO);
// Create a pipe for the child process's STDOUT.
if (! CreatePipe(&hChildStdoutRd, &hChildStdoutWr, &sa, 0))
return 0;
// Create a pipe for the child process's STDIN.
if (! CreatePipe(&hChildStdinRd, &hChildStdinWr, &sa, 0))
return 0;
// Setup the start info structure
startInfo.dwFlags = STARTF_USESTDHANDLES|STARTF_USESHOWWINDOW;
startInfo.wShowWindow = SW_HIDE;
startInfo.hStdOutput = hChildStdoutWr;
startInfo.hStdError = hChildStdoutWr;
startInfo.hStdInput = hChildStdinRd;
cmdline = OcamlPath;
// Set the OCAMLLIB environment variable
SetEnvironmentVariable("OCAMLLIB", LibDir);
// Let's go: start the ocaml interpreter
processStarted = CreateProcess(NULL,cmdline,lpsa,lpsa,1,
CREATE_NEW_PROCESS_GROUP|NORMAL_PRIORITY_CLASS,
NULL,ProgramParams.CurrentWorkingDir,&startInfo,&pi);
if (processStarted) {
WaitForSingleObject(pi.hProcess,INFINITE);
GetExitCodeProcess(pi.hProcess,(unsigned long *)&OcamlStatus);
CloseHandle(pi.hProcess);
PostMessage(hwndMain,WM_QUITOCAML,0,0);
}
else {
char *msg = malloc(1024);
wsprintf(msg,"Impossible to start ocaml.exe in:\n%s",cmdline);
ShowDbgMsg(msg);
free(msg);
}
return 0;
}
/*------------------------------------------------------------------------
Procedure: WriteToPipe ID:1
Purpose: Writes the given character string to the standard
input of the interpreter
Input: The character string (zero terminated) to be written
Output: The number of characters written or zero if an error
occurs
Errors: None
------------------------------------------------------------------------*/
int WriteToPipe(char *data)
{
DWORD dwWritten;
if (! WriteFile(hChildStdinWr, data, strlen(data), &dwWritten, NULL))
return 0;
return dwWritten;
}
/*------------------------------------------------------------------------
Procedure: ReadFromPipe ID:1
Purpose: Reads from the standard output of the interpreter and
stores the data in the given buffer up to the given
length. This is done in a non-blocking manner, i.e.
it is safe to call this even if there is no data
available.
Input: The buffer to be used and its length.
Output: Returns the number of characters read from the pipe.
Errors: None explicit
------------------------------------------------------------------------*/
int ReadFromPipe(char *data,int len)
{
DWORD dwRead;
PeekNamedPipe(hChildStdoutRd,data,len,NULL,&dwRead,NULL);
if (dwRead == 0)
return 0;
// Read output from the child process, and write to parent's STDOUT.
if( !ReadFile( hChildStdoutRd, data, len, &dwRead, NULL) || dwRead == 0)
return 0;
return dwRead;
}
static DWORD tid;
/*------------------------------------------------------------------------
Procedure: StartOcaml ID:1
Purpose: Starts the thread that will call the ocaml.exe
program.
Input:
Output:
Errors:
------------------------------------------------------------------------*/
int StartOcaml(void)
{
getcwd(ProgramParams.CurrentWorkingDir,sizeof(ProgramParams.CurrentWorkingDir));
CreateThread(NULL,0,DoStartOcaml,hwndMain,0,&tid);
return 1;
}
void *SafeMalloc(int size)
{
void *result;
if (size < 0) {
char message[1024];
error:
sprintf(message,"Can't allocate %d bytes",size);
MessageBox(NULL, message, "OCaml", MB_OK);
exit(-1);
}
result = malloc(size);
if (result == NULL)
goto error;
return result;
}
void InterruptOcaml(void)
{
if (!GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pi.dwProcessId)) {
char message[1024];
sprintf(message, "GenerateConsole failed: %lu\n", GetLastError());
MessageBox(NULL, message, "OCaml", MB_OK);
}
WriteToPipe(" ");
}