diff options
Diffstat (limited to 'maccaml/glue.c')
| -rw-r--r-- | maccaml/glue.c | 557 |
1 files changed, 0 insertions, 557 deletions
diff --git a/maccaml/glue.c b/maccaml/glue.c deleted file mode 100644 index ea9b5f97f..000000000 --- a/maccaml/glue.c +++ /dev/null @@ -1,557 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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 <CursorCtl.h> -#include <fcntl.h> -#include <signal.h> -#include <stdlib.h> - -#include "alloc.h" -#include "mlvalues.h" -#include "rotatecursor.h" -#include "signals.h" -#include "ui.h" - -#include "main.h" - -/* These are defined by the ocamlrun library. */ -void caml_main(char **argv); -Handle macos_getfullpathname (short vrefnum, long dirid); - -/* This pointer contains the environment variables. */ -char *envPtr = NULL; - -/* True if the Caml program is reading from the console. */ -static int caml_reading_console = 0; - -/* [Caml_working] is used to manage the processor idle state on - PowerBooks. [Caml_working (1)] disables the idle state, and - [Caml_working (0)] enables it. -*/ -static int caml_at_work = 0; -static void Caml_working (int newstate) -{ - if (gHasPowerManager){ - if (caml_at_work && !newstate) EnableIdle (); - if (!caml_at_work && newstate) DisableIdle (); - } - caml_at_work = newstate; -} - -/* - Animated cursor (only when toplevel window is frontmost). -*/ -typedef struct { - short nframes; - short current; - union { - CursHandle h; - struct { short id; short fill; } i; - } frames [1]; -} **AnimCursHandle; - -static AnimCursHandle acurh = NULL; - -pascal void InitCursorCtl (acurHandle newCursors) -{ -#pragma unused (newCursors) - long i; - - if (acurh != NULL) return; - acurh = (AnimCursHandle) GetResource ('acur', 0); - for (i = 0; i < (*acurh)->nframes; i++){ - (*acurh)->frames[i].h = GetCursor ((*acurh)->frames[i].i.id); - if ((*acurh)->frames[i].h == NULL){ - (*acurh)->frames[i].h = GetCursor (watchCursor); - Assert ((*acurh)->frames[i].h != NULL); - } - } - (*acurh)->current = 0; -} - -pascal void RotateCursor (long counter) -{ -#pragma unused (counter) - if (acurh == NULL) InitCursorCtl (NULL); - /* (*acurh)->current += (*acurh)->nframes + (counter >= 0 ? 1 : -1); */ - (*acurh)->current += (*acurh)->nframes + (caml_at_work ? 1 : -1); - (*acurh)->current %= (*acurh)->nframes; -} - -int AdjustRotatingCursor (void) -{ - static Point oldmouse = {-1, -1}; - Point mouse; - int res = 0; - - if (acurh == NULL) InitCursorCtl (NULL); - - GetMouse (&mouse); - if (mouse.h != oldmouse.h || mouse.v != oldmouse.v){ - last_event_date = TickCount (); - } - if (caml_reading_console == 0 && TickCount () > last_event_date + 60){ - SetCursor (*((*acurh)->frames[(*acurh)->current].h)); - ShowCursor (); - res = 1; - } - oldmouse = mouse; - return res; -} - -static pascal void interp_yield (long counter) -{ - RotateCursor (counter); - GetAndProcessEvents (noWait, 0, 0); - if (intr_requested){ - intr_requested = 0; - raise (SIGINT); - } -} - -/* Expand the percent escapes in the string specified by s. - The escapes are: - %a application file name - %d full pathname of the current working directory (ends in ':') - %t full pathname of the temporary directory (ends in ':') - %% a percent sign "%" -*/ -static OSErr expand_escapes (Handle s) -{ - Size i, j, l; - OSErr err; - Handle curdir = NULL, tmpdir = NULL; - char *ptr2; - long len2; - - l = GetHandleSize (s) - 1; - i = j = 0; - while (i < l){ - if ((*s)[j] == '%'){ - switch ((*s)[j+1]){ - case 'a': - ptr2 = (char *) LMGetCurApName () + 1; - len2 = * (LMGetCurApName ()); - break; - case 'd': - if (curdir == NULL) curdir = macos_getfullpathname (0, 0); - if (curdir == NULL){ err = fnfErr; goto failed; } - HLock (curdir); - ptr2 = *curdir; - len2 = GetHandleSize (curdir); - break; - case 't': - if (tmpdir == NULL){ - short vrefnum; - long dirid; - err = FindFolder (kOnSystemDisk, kTemporaryFolderType, true, - &vrefnum, &dirid); - tmpdir = macos_getfullpathname (vrefnum, dirid); - if (tmpdir == NULL){ err = fnfErr; goto failed; } - } - HLock (tmpdir); - ptr2 = *tmpdir; - len2 = GetHandleSize (tmpdir); - break; - case '%': - ptr2 = "%"; - len2 = 1; - break; - default: - ptr2 = ""; - len2 = 0; - break; - } - Munger (s, j, NULL, 2, ptr2, len2); - j += len2 - 2; - i += 1; - } - ++ i; - ++ j; - } - if (curdir != NULL) DisposeHandle (curdir); - if (tmpdir != NULL) DisposeHandle (tmpdir); - return noErr; - - failed: - if (curdir != NULL) DisposeHandle (curdir); - if (tmpdir != NULL) DisposeHandle (tmpdir); - return err; -} - -/* [build_command_line] creates the array of strings that represents - the command line according to the template found in - the 'Line'(kCommandLineTemplate) resource and the environment - variables according to the 'Line'(kEnvironmentTemplate). - - Each of these resources is a sequence of strings terminated by null - bytes. In each string, percent escapes are expanded (see above for - a description of percent escapes). - - Each resource ends with a null byte. -*/ -static OSErr build_command_line (char ***p_argv) -{ - Handle template = NULL; - Size len, i, j; - char *args = NULL; - int argc; - char **argv = NULL; - OSErr err; - - template = GetResource ('Line', kCommandLineTemplate); - if (template == NULL){ err = ResError (); goto failed; } - err = expand_escapes (template); if (err != noErr) goto failed; - len = GetHandleSize (template); - - args = malloc (len); - if (args == NULL){ err = memFullErr; goto failed; } - memmove (args, *template, len); - - argc = 0; - for (i = 0; i < len; i++){ - if (args[i] == '\000') ++ argc; - } - argv = malloc ((argc+1) * sizeof (char *)); - if (argv == NULL){ err = memFullErr; goto failed; } - - i = j = 0; - do{ - argv[j++] = args + i; - while (args [i] != '\000') ++ i; - ++ i; - }while (i < len); - argv [argc] = NULL; - - ReleaseResource (template); - - template = GetResource ('Line', kEnvironmentTemplate); - if (template == NULL){ err = ResError (); goto failed; } - err = expand_escapes (template); if (err != noErr) goto failed; - len = GetHandleSize (template); - envPtr = NewPtr (len); - if (envPtr == NULL){ err = MemError (); goto failed; } - memmove (envPtr, *template, len); - - *p_argv = argv; - return noErr; - - failed: - if (template != NULL) ReleaseResource (template); - if (args != NULL) free (args); - if (argv != NULL) free (argv); - return err; -} - -/* [launch_caml_main] is called by [main]. - - After building the command line, [launch_caml_main] launches [caml_main] - in a thread, then executes the GUI event loop in the main thread. -*/ - -OSErr launch_caml_main (void) -{ - char **argv; - OSErr err; - - rotatecursor_options (&something_to_do, 0, &interp_yield); - err = WinOpenToplevel (); - if (err != noErr) goto failed; - - err = build_command_line (&argv); - if (err) goto failed; - - Caml_working (1); - caml_main (argv); - ui_exit (0); - - failed: - return err; -} - -/* console I/O functions */ - -/* Management of error highlighting. */ -static int erroring = 0; -static long error_curpos; -static long error_anchor = -1; - -void FlushUnreadInput (void) -{ - WEReference we; - int active; - - we = WinGetWE (winToplevel); - Assert (we != NULL); - - WEFeatureFlag (weFReadOnly, weBitClear, we); - WESetSelection (wintopfrontier, wintopfrontier, we); - WEFeatureFlag (weFOutlineHilite, weBitClear, we); - active = WEIsActive (we); - if (active) WEDeactivate (we); - WESetSelection (wintopfrontier, WEGetTextLength (we), we); - WEDelete (we); - if (active) WEActivate (we); - WEFeatureFlag (weFOutlineHilite, weBitSet, we); -} - -int ui_read (int fd, char *buffer, unsigned int nCharsDesired) -{ - long len, i; - char **htext; - WEReference we; - long selstart, selend; - Boolean active; - short readonly, autoscroll; - int atend; - - if (fd != 0) return read (fd, buffer, nCharsDesired); - - we = WinGetWE (winToplevel); - Assert (we != NULL); - htext = (char **) WEGetText (we); - - ++ caml_reading_console; - - while (1){ - char *p; - - len = WEGetTextLength (we); - p = *htext; - for (i = wintopfrontier; i < len; i++){ - if (p[i] == '\n') goto gotit; - } - GetAndProcessEvents (waitEvent, 0, 0); - } - - gotit: - - len = i+1 - wintopfrontier; - if (len > nCharsDesired) len = nCharsDesired; - memmove (buffer, (*htext)+wintopfrontier, len); - - atend = ScrollAtEnd (winToplevel); - autoscroll = WEFeatureFlag (weFAutoScroll, weBitTest, we); - WEFeatureFlag (weFAutoScroll, weBitClear, we); - WEGetSelection (&selstart, &selend, we); - readonly = WEFeatureFlag (weFReadOnly, weBitTest, we); - WEFeatureFlag (weFReadOnly, weBitClear, we); - /* Always set an empty selection before changing OutlineHilite or - the active status. */ - WESetSelection (wintopfrontier, wintopfrontier, we); - WEFeatureFlag (weFOutlineHilite, weBitClear, we); - active = WEIsActive (we); - if (active) WEDeactivate (we); - WESetSelection (wintopfrontier, wintopfrontier+len, we); - WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace, - &prefs.input, we); - WESetSelection (wintopfrontier, wintopfrontier, we); - if (active) WEActivate (we); - WEFeatureFlag (weFOutlineHilite, weBitSet, we); - WESetSelection (selstart, selend, we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we); - if (autoscroll) WEFeatureFlag (weFAutoScroll, weBitSet, we); - AdjustScrollBars (winToplevel); - if (atend) ScrollToEnd (winToplevel); - - WinAdvanceTopFrontier (len); - - -- caml_reading_console; - return len; -} - -int ui_write (int fd, char *buffer, unsigned int nChars) -{ - long selstart, selend; - WEReference we; - OSErr err; - short readonly, autoscroll; - int atend; - - if (fd != 1 && fd != 2) return write (fd, buffer, nChars); - - Assert (nChars >= 0); - we = WinGetWE (winToplevel); - Assert (we != NULL); - - if (erroring){ /* overwrite mode to display errors; see terminfo_* */ - error_curpos += nChars; - if (error_curpos > wintopfrontier) error_curpos = wintopfrontier; - return nChars; - } - - atend = ScrollAtEnd (winToplevel); - autoscroll = WEFeatureFlag (weFAutoScroll, weBitTest, we); - WEFeatureFlag (weFAutoScroll, weBitClear, we); - WEGetSelection (&selstart, &selend, we); - readonly = WEFeatureFlag (weFReadOnly, weBitTest, we); - WEFeatureFlag (weFReadOnly, weBitClear, we); - WESetSelection (wintopfrontier, wintopfrontier, we); - WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace, - &prefs.output, we); - err = WEInsert (buffer, nChars, NULL, NULL, we); - if (err != noErr){ - WESetSelection (selstart, selend, we); - return nChars; - } - if (selstart >= wintopfrontier){ - selstart += nChars; - selend += nChars; - }else if (selend > wintopfrontier){ - selend += nChars; - } - WESetSelection (selstart, selend, we); - if (autoscroll) WEFeatureFlag (weFAutoScroll, weBitSet, we); - AdjustScrollBars (winToplevel); - if (atend) ScrollToEnd (winToplevel); - - WinAdvanceTopFrontier (nChars); - - return nChars; -} - -void ui_print_stderr (char *msg, void *arg) -{ - char buf [1000]; - - sprintf (buf, msg, arg); - ui_write (2, buf, strlen (buf)); -} - -void ui_exit (int return_code) -{ -#pragma unused (return_code) - Str255 buf0; - Str255 buf1; - - caml_reading_console = 1; /* hack: don't display rotating cursor */ - - if (return_code != 0){ - GetIndString (buf0, kMiscStrings, kWithErrorCodeIdx); - NumToString ((long) return_code, buf1); - }else{ - buf0[0] = 0; - buf1[0] = 0; - } - ParamText (buf0, buf1, NULL, NULL); - InitCursor (); - modalkeys = kKeysOK; - NoteAlert (kAlertExit, myModalFilterUPP); - - while (1) GetAndProcessEvents (waitEvent, 0, 0); - - if (winGraphics != NULL) WinCloseGraphics (); - WinCloseToplevel (); - rotatecursor_final (); - FinaliseAndQuit (); -} - - -/* - [getenv] in the standalone application - envPtr is set up by launch_caml_main -*/ -char *getenv (const char *name) -{ - Size envlen, i, namelen; - - Assert (envPtr != NULL); - envlen = GetPtrSize (envPtr); - namelen = strlen (name); - i = 0; - do{ - if (!strncmp (envPtr + i, name, namelen) && envPtr [i+namelen] == '='){ - return envPtr + i + namelen + 1; - } - while (envPtr [i] != '\000') ++ i; - ++ i; - }while (i < envlen); - return NULL; -} - - -/* - [terminfo] stuff: change the style of displayed text to show the - error locations. See also ui_write. -*/ - -value terminfo_setup (value vchan); -value terminfo_backup (value lines); -value terminfo_standout (value start); -value terminfo_resume (value lines); - -#define Good_term_tag 0 - -value terminfo_setup (value vchan) -{ -#pragma unused (vchan) - value result = alloc (1, Good_term_tag); - Field (result, 0) = Val_int (1000000000); - return result; -} - -value terminfo_backup (value lines) -{ - long i, j; - Handle txt; - char *p; - WEReference we = WinGetWE (winToplevel); - - Assert (we != NULL); - txt = WEGetText (we); - p = (char *) *txt; - j = wintopfrontier - 1; - - while (j >= 0 && p[j] != '\n') --j; - for (i = 0; i < Long_val (lines); i++){ - Assert (p[j] == '\n' || j == -1); - do{ --j; }while (j >= 0 && p[j] != '\n'); - } - Assert (p[j] == '\n' || j == -1); - error_curpos = j + 1; - erroring = 1; - error_anchor = -1; - return Val_unit; -} - -value terminfo_standout (value start) -{ - if (Bool_val (start) && error_anchor == -1){ - error_anchor = error_curpos; - }else if (!Bool_val (start) && error_anchor != -1){ - long selstart, selend; - WEReference we = WinGetWE (winToplevel); - short readonly; - - Assert (we != NULL); - WEGetSelection (&selstart, &selend, we); - readonly = WEFeatureFlag (weFReadOnly, weBitTest, we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitClear, we); - WESetSelection (error_anchor, error_curpos, we); - WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace, - &prefs.errors, we); - if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we); - WESetSelection (selstart, selend, we); - error_anchor = -1; - } - return Val_unit; -} - -value terminfo_resume (value lines) -{ -#pragma unused (lines) - erroring = 0; - return Val_unit; -} |