2 /* --------------------------------------------------------------------------
3 * Machine dependent code
4 * RISCOS specific code provided by Bryan Scatergood, JBS
5 * Macintosh specific code provided by Hans Aberg (haberg@matematik.su.se)
6 * HaskellScript code and recursive directory search provided by
7 * Daan Leijen (leijen@fwi.uva.nl)
9 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
10 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
11 * Technology, 1994-1999, All rights reserved. It is distributed as
12 * free software under the license in the file "License", which is
13 * included in the distribution.
15 * $RCSfile: machdep.c,v $
17 * $Date: 1999/10/20 02:16:01 $
18 * ------------------------------------------------------------------------*/
23 #ifdef HAVE_SYS_TYPES_H
24 # include <sys/types.h>
31 # include <sys/param.h>
33 #ifdef HAVE_SYS_STAT_H
34 # include <sys/stat.h>
44 /* Windows/DOS include files */
48 #if defined HAVE_CONIO_H && ! HUGS_FOR_WINDOWS
65 extern HCURSOR HandCursor; /* Forward references to cursors */
66 extern HCURSOR GarbageCursor;
67 extern HCURSOR SaveCursor;
68 static void local DrawStatusLine Args((HWND));
73 extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */
81 /* Macintosh include files */
104 int allow_break_count = 0;
107 /* --------------------------------------------------------------------------
108 * Prototypes for registry reading
109 * ------------------------------------------------------------------------*/
113 /* where have we hidden things in the registry? */
115 #define HScriptRoot ("SOFTWARE\\Haskell\\HaskellScript\\")
118 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
119 #define ProjectRoot ("SOFTWARE\\Haskell\\Projects\\")
121 static Bool local createKey Args((HKEY, String, PHKEY, REGSAM));
122 static Bool local queryValue Args((HKEY, String, String, LPDWORD, LPBYTE, DWORD));
123 static Bool local setValue Args((HKEY, String, String, DWORD, LPBYTE, DWORD));
124 static String local readRegString Args((HKEY, String, String, String));
125 static Int local readRegInt Args((String,Int));
126 static Bool local writeRegString Args((String,String));
127 static Bool local writeRegInt Args((String,Int));
129 static String local readRegChildStrings Args((HKEY, String, String, Char, String));
130 #endif /* USE_REGISTRY */
132 /* --------------------------------------------------------------------------
133 * Find information about a file:
134 * ------------------------------------------------------------------------*/
137 typedef struct { unsigned hi, lo; } Time;
138 #define timeChanged(now,thn) (now.hi!=thn.hi || now.lo!=thn.lo)
139 #define timeSet(var,tm) var.hi = tm.hi; var.lo = tm.lo
140 error timeEarlier not defined
143 #define timeChanged(now,thn) (now!=thn)
144 #define timeSet(var,tm) var = tm
145 #define timeEarlier(earlier,now) (earlier < now)
148 static Bool local readable Args((String));
149 static Void local getFileInfo Args((String, Time *, Long *));
151 static Void local getFileInfo(f,tm,sz) /* find time stamp and size of file*/
155 #if defined HAVE_SYS_STAT_H || defined HAVE_STAT_H || defined HAVE_UNIX_H
157 if (!stat(f,&scbuf)) {
158 if (tm) *tm = scbuf.st_mtime;
159 *sz = (Long)(scbuf.st_size);
164 #else /* normally just use stat() */
165 os_regset r; /* RISCOS PRM p.850 and p.837 */
166 r.r[0] = 17; /* Read catalogue, no path */
169 if(r.r[0] == 1 && (r.r[2] & 0xFFF00000) == 0xFFF00000) {
170 if (tm) tm->hi = r.r[2] & 0xFF; /* Load address (high byte) */
171 if (tm) tm->lo = r.r[3]; /* Execution address (low 4 bytes) */
172 } else { /* Not found, or not time-stamped */
173 if (tm) tm->hi = tm->lo = 0;
175 *sz = (Long)(r.r[0] == 1 ? r.r[4] : 0);
179 Void getFileSize ( String f, Long* sz )
181 getFileInfo ( f, NULL, sz );
184 #if defined HAVE_GETFINFO /* Mac971031 */
185 /* --------------------------------------------------------------------------
186 * Define a MacOS version of access():
187 * If the file is not accessible, -1 is returned and errno is set to
188 * the reason for the failure.
189 * If the file is accessible and the dummy is 0 (existence), 2 (write),
190 * or 4 (read), the return is 0.
191 * If the file is accessible, and the dummy is 1 (executable), then if
192 * the file is a program (of type 'APPL'), the return is 0, otherwise -1.
193 * Warnings: Use with caution. UNIX access do no translate to Macs.
194 * Check of write access is not implemented (same as read).
195 * ------------------------------------------------------------------------*/
197 int access(char *fileName, int dummy) {
201 errno = getfinfo(fileName, 0, &fi);
202 if (errno != 0) return -1; /* Check file accessible. */
204 /* Cases dummy = existence, read, write. */
205 if (dummy == 0 || dummy & 0x6) return 0;
207 /* Case dummy = executable. */
209 if (fi.fdType == 'APPL') return 0;
218 static Bool local readable(f) /* is f a regular, readable file */
220 #if DJGPP2 || defined HAVE_GETFINFO /* stat returns bogus mode bits on djgpp2 */
221 return (0 == access(f,4));
222 #elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H
224 //fprintf(stderr, "readable: %s\n", f );
225 return ( !stat(f,&scbuf)
226 && (scbuf.st_mode & S_IREAD) /* readable */
227 && (scbuf.st_mode & S_IFREG) /* regular file */
229 #elif defined HAVE_OS_SWI /* RISCOS specific */
230 os_regset r; /* RISCOS PRM p.850 -- JBS */
232 r.r[0] = 17; /* Read catalogue, no path */
235 return r.r[0] != 1; /* Does this check it's a regular file? ADR */
240 /* --------------------------------------------------------------------------
241 * Search for script files on the HUGS path:
242 * ------------------------------------------------------------------------*/
244 static String local hugsdir Args((Void));
246 static String local hscriptDir Args((Void));
248 //static String local RealPath Args((String));
249 static int local pathCmp Args((String, String));
250 static String local normPath Args((String));
251 static Void local searchChr Args((Int));
252 static Void local searchStr Args((String));
253 static Bool local tryEndings Args((String));
257 # define isSLASH(c) ((c)=='\\' || (c)=='/')
259 # define DLL_ENDING ".dll"
262 # define isSLASH(c) ((c)==SLASH)
264 /* Mac PEF (Preferred Executable Format) file */
265 # define DLL_ENDING ".pef"
268 # define isSLASH(c) ((c)==SLASH)
270 # define DLL_ENDING ".o"
273 static String local hugsdir() { /* directory containing lib/Prelude.hs */
275 /* In HaskellScript (Win32 only), we lookup InstallDir in the registry. */
276 static char dir[FILENAME_MAX+1] = "";
277 if (dir[0] == '\0') { /* not initialised yet */
278 String s = readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"InstallDir",
285 #elif HAVE_GETMODULEFILENAME && !DOS
286 /* On Windows, we can find the binary we're running and it's
287 * conventional to put the libraries in the same place.
289 static char dir[FILENAME_MAX+1] = "";
290 if (dir[0] == '\0') { /* not initialised yet */
292 GetModuleFileName((HMODULE)0,dir,FILENAME_MAX+1);
293 if (dir[0] == '\0') { /* GetModuleFileName must have failed */
296 if (slash = strrchr(dir,SLASH)) { /* truncate after directory name */
302 /* On Unix systems, we can't find the binary we're running and
303 * the libraries may not be installed near the binary anyway.
304 * This forces us to use a hardwired path which is set at
305 * configuration time (--datadir=...).
312 static String local hscriptDir() { /* Directory containing hscript.dll */
313 static char dir[FILENAME_MAX+1] = "";
314 if (dir[0] == '\0') { /* not initialised yet */
315 String s = readRegString(HKEY_LOCAL_MACHINE,HScriptRoot,"InstallDir","");
324 #if 0 /* apparently unused */
325 static String local RealPath(s) /* Find absolute pathname of file */
327 #if HAVE__FULLPATH /* eg DOS */
328 static char path[FILENAME_MAX+1];
329 _fullpath(path,s,FILENAME_MAX+1);
330 #elif HAVE_REALPATH /* eg Unix */
331 static char path[MAXPATHLEN+1];
334 static char path[FILENAME_MAX+1];
342 static int local pathCmp(p1,p2) /* Compare paths after normalisation */
345 #if HAVE__FULLPATH /* eg DOS */
346 static char path1[FILENAME_MAX+1];
347 static char path2[FILENAME_MAX+1];
348 _fullpath(path1,p1,FILENAME_MAX+1);
349 _fullpath(path2,p2,FILENAME_MAX+1);
350 #elif HAVE_REALPATH /* eg Unix */
351 static char path1[MAXPATHLEN+1];
352 static char path2[MAXPATHLEN+1];
356 static char path1[FILENAME_MAX+1];
357 static char path2[FILENAME_MAX+1];
361 #if CASE_INSENSITIVE_FILENAMES
365 return filenamecmp(path1,path2);
368 static String local normPath(s) /* Try, as much as possible, to normalize */
369 String s; { /* a pathname in some appropriate manner. */
370 #if PATH_CANONICALIZATION
371 String path = RealPath(s);
372 #if CASE_INSENSITIVE_FILENAMES
373 strlwr(path); /* and convert to lowercase */
376 #else /* ! PATH_CANONICALIZATION */
378 #endif /* ! PATH_CANONICALIZATION */
382 static String endings[] = { "", ".hi", ".hs", ".lhs", ".hsx", ".hash", 0 };
384 static String endings[] = { "", ".hi", ".hs", ".lhs", 0 };
386 static char searchBuf[FILENAME_MAX+1];
387 static Int searchPos;
389 #define searchReset(n) searchBuf[searchPos=(n)]='\0'
391 static Void local searchChr(c) /* Add single character to search buffer */
393 if (searchPos<FILENAME_MAX) {
394 searchBuf[searchPos++] = (char)c;
395 searchBuf[searchPos] = '\0';
399 static Void local searchStr(s) /* Add string to search buffer */
401 while (*s && searchPos<FILENAME_MAX)
402 searchBuf[searchPos++] = *s++;
403 searchBuf[searchPos] = '\0';
406 static Bool local tryEndings(s) /* Try each of the listed endings */
410 for (; endings[i]; ++i) {
411 Int save = searchPos;
412 searchStr(endings[i]);
413 if (readable(searchBuf))
424 /* scandir, June 98 Daan Leijen
425 searches the base directory and its direct subdirectories for a file
427 input: searchbuf contains SLASH terminated base directory
428 argument s contains the (base) filename
429 output: TRUE: searchBuf contains the full filename
430 FALSE: searchBuf is garbage, file not found
434 #ifdef HAVE_WINDOWS_H
436 static Bool scanSubDirs(s)
439 struct _finddata_t findInfo;
444 /* is it in the current directory ? */
445 if (tryEndings(s)) return TRUE;
450 /* initiate the search */
451 handle = _findfirst( searchBuf, &findInfo );
452 if (handle==-1) { errno = 0; return FALSE; }
454 /* search all subdirectories */
456 /* if we have a valid sub directory */
457 if (((findInfo.attrib & _A_SUBDIR) == _A_SUBDIR) &&
458 (findInfo.name[0] != '.')) {
460 searchStr(findInfo.name);
466 } while (_findnext( handle, &findInfo ) == 0);
468 _findclose( handle );
472 #elif defined(HAVE_FTW_H)
476 static char baseFile[FILENAME_MAX+1];
477 static char basePath[FILENAME_MAX+1];
478 static int basePathLen;
480 static int scanitem( const char* path,
481 const struct stat* statinfo,
484 if (info == FTW_D) { /* is it a directory */
488 if (tryEndings(baseFile)) {
495 static Bool scanSubDirs(s)
500 strcpy(basePath,searchBuf);
501 basePathLen = strlen(basePath);
503 /* is it in the current directory ? */
504 if (tryEndings(s)) return TRUE;
506 /* otherwise scan the subdirectories */
507 r = ftw( basePath, scanitem, 2 );
512 #endif /* HAVE_WINDOWS_H || HAVE_FTW_H */
513 #endif /* SEARCH_DIR */
515 String findPathname(along,nm) /* Look for a file along specified path */
516 String along; /* Return NULL if file does not exist */
518 /* AC, 1/21/99: modified to search hugsPath first, then projectPath */
519 String s = findMPathname(along,nm,hugsPath);
524 s = findMPathname(along,nm,projectPath);
527 #endif /* USE_REGISTRY */
528 return s ? s : normPath(searchBuf);
531 /* AC, 1/21/99: modified to pass in path to search explicitly */
532 String findMPathname(along,nm,path)/* Look for a file along specified path */
533 String along; /* If nonzero, a path prefix from along is */
534 String nm; /* used as the first prefix in the search. */
536 String pathpt = path;
539 if (along) { /* Was a path for an existing file given? */
542 for (; along[i]; i++) {
544 if (isSLASH(along[i]))
550 return normPath(searchBuf);
552 if (pathpt && *pathpt) { /* Otherwise, we look along the HUGSPATH */
555 Bool recurse = FALSE; /* DL: shall we recurse ? */
558 if (*pathpt!=PATHSEP) {
559 /* Pre-define one MPW-style "shell-variable" */
560 if (strncmp(pathpt,"{Hugs}",6)==0) {
561 searchStr(hugsdir());
565 /* And another - we ought to generalise this stuff */
566 else if (strncmp(pathpt,"{HScript}",9)==0) {
567 searchStr(hscriptDir());
572 searchChr(*pathpt++);
573 } while (*pathpt && *pathpt!=PATHSEP);
574 recurse = (pathpt[-1] == SLASH);
579 if (*pathpt==PATHSEP)
587 if (recurse ? scanSubDirs(nm) : tryEndings(nm)) {
588 return normPath(searchBuf);
591 if (tryEndings(nm)) {
592 return normPath(searchBuf);
598 searchReset(0); /* As a last resort, look for file in the current dir */
599 return (tryEndings(nm) ? normPath(searchBuf) : 0);
602 /* --------------------------------------------------------------------------
603 * New path handling stuff for the Combined System (tm)
604 * ------------------------------------------------------------------------*/
606 #define N_DEFAULT_LIBDIR 1000
607 char defaultLibDir[N_DEFAULT_LIBDIR];
609 /* Assumes that getcwd()++argv[0] is the absolute path to the
610 executable. Basically wrong.
612 void setDefaultLibDir ( String argv_0 )
615 if (argv_0[0] != SLASH) {
616 if (!getcwd(defaultLibDir,N_DEFAULT_LIBDIR-strlen(argv_0)-10)) {
617 ERRMSG(0) "Can't get current working directory"
620 i = strlen(defaultLibDir);
621 defaultLibDir[i++] = SLASH;
625 strcpy(&defaultLibDir[i],argv_0);
627 while (defaultLibDir[i] != SLASH) i--;
629 strcpy(&defaultLibDir[i], "lib");
630 /* fprintf ( stderr, "default lib dir = %s\n", defaultLibDir ); */
633 Bool findFilesForModule (
637 Bool* sAvail, Time* sTime, Long* sSize,
638 Bool* iAvail, Time* iTime, Long* iSize,
639 Bool* oAvail, Time* oTime, Long* oSize
642 /* Let the module name given be M.
643 For each path entry P,
644 a s(rc) file will be P/M.hs or P/M.lhs
645 an i(nterface) file will be P/M.hi
646 an o(bject) file will be P/M.o
647 If there is a s file or (both i and o files)
648 use P to fill in the path names.
649 Otherwise, move on to the next path entry.
650 If all path entries are exhausted, return False.
654 String peStart, peEnd;
655 String augdPath; /* .:defaultLibDir:hugsPath */
657 *path = *sExt = NULL;
658 *sAvail = *iAvail = *oAvail = FALSE;
659 *sSize = *iSize = *oSize = 0;
661 augdPath = malloc(4+strlen(defaultLibDir)+strlen(hugsPath));
663 internal("moduleNameToFileNames: malloc failed(2)");
665 augdPath[1] = PATHSEP;
667 strcat ( augdPath, defaultLibDir );
668 augdPath[2+strlen(defaultLibDir)] = PATHSEP;
669 augdPath[3+strlen(defaultLibDir)] = 0;
670 strcat(augdPath,hugsPath);
674 /* Advance peStart and peEnd very paranoically, giving up at
675 the first sign of mutancy in the path string.
677 if (peEnd >= augdPath && !(*peEnd)) { free(augdPath); return FALSE; }
680 while (*peEnd && *peEnd != PATHSEP) peEnd++;
682 /* Now peStart .. peEnd-1 bracket the next path element. */
683 nPath = peEnd-peStart;
684 if (nPath + strlen(modName) + 10 /*slush*/ > FILENAME_MAX) {
685 ERRMSG(0) "Hugs path \"%s\" contains excessively long component",
692 strncpy(searchBuf, peStart, nPath);
693 searchBuf[nPath] = 0;
694 if (nPath > 0 && !isSLASH(searchBuf[nPath-1]))
695 searchBuf[nPath++] = SLASH;
697 strcpy(searchBuf+nPath, modName);
698 nPath += strlen(modName);
700 /* searchBuf now holds 'P/M'. Try out the various endings. */
701 *path = *sExt = NULL;
702 *sAvail = *iAvail = *oAvail = FALSE;
703 *sSize = *iSize = *oSize = 0;
705 strcpy(searchBuf+nPath, DLL_ENDING);
706 if (readable(searchBuf)) {
708 getFileInfo(searchBuf, oTime, oSize);
711 strcpy(searchBuf+nPath, ".hi");
712 if (readable(searchBuf)) {
714 getFileInfo(searchBuf, iTime, iSize);
717 strcpy(searchBuf+nPath, ".hs");
718 if (readable(searchBuf)) {
721 getFileInfo(searchBuf, sTime, sSize);
724 strcpy(searchBuf+nPath, ".lhs");
725 if (readable(searchBuf)) {
728 getFileInfo(searchBuf, sTime, sSize);
734 if (*sAvail || (*oAvail && *iAvail)) {
735 nPath -= strlen(modName);
736 *path = malloc(nPath+1);
738 internal("moduleNameToFileNames: malloc failed(1)");
739 strncpy(*path, searchBuf, nPath);
750 /* --------------------------------------------------------------------------
751 * Substitute old value of path into empty entries in new path
752 * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
753 * ------------------------------------------------------------------------*/
755 static String local substPath Args((String,String));
757 static String local substPath(new,sub) /* substitute sub path into new path*/
760 Bool substituted = FALSE; /* only allow one replacement */
761 Int maxlen = strlen(sub) + strlen(new); /* safe upper bound */
762 String r = (String) malloc(maxlen+1); /* result string */
763 String t = r; /* pointer into r */
764 String next = new; /* next uncopied char in new */
765 String start = next; /* start of last path component */
767 ERRMSG(0) "String storage space exhausted"
771 if (*next == PATHSEP || *next == '\0') {
772 if (!substituted && next == start) {
774 for(; *s != '\0'; ++s) {
781 } while ((*t++ = *next++) != '\0');
786 /* --------------------------------------------------------------------------
787 * Garbage collection notification:
788 * ------------------------------------------------------------------------*/
790 Bool gcMessages = FALSE; /* TRUE => print GC messages */
792 Void gcStarted() { /* Notify garbage collector start */
794 SaveCursor = SetCursor(GarbageCursor);
802 Void gcScanning() { /* Notify garbage collector scans */
809 Void gcRecovered(recovered) /* Notify garbage collection done */
812 Printf("%d}}",recovered);
816 SetCursor(SaveCursor);
820 Cell *CStackBase; /* Retain start of C control stack */
822 #if RISCOS /* Stack traversal for RISCOS */
824 /* Warning: The following code is specific to the Acorn ARM under RISCOS
825 (and C4). We must explicitly walk back through the stack frames, since
826 the stack is extended from the heap. (see PRM pp. 1757). gcCStack must
827 not be modified, since the offset '5' assumes that only v1 is used inside
828 this function. Hence we do all the real work in gcARM.
831 #define spreg 13 /* C3 has SP=R13 */
833 #define previousFrame(fp) ((int *)((fp)[-3]))
834 #define programCounter(fp) ((int *)((*(fp)-12) & ~0xFC000003))
835 #define isSubSPSP(w) (((w)&dontCare) == doCare)
836 #define doCare (0xE24DD000) /* SUB r13,r13,#0 */
837 #define dontCare (~0x00100FFF) /* S and # bits */
838 #define immediateArg(x) ( ((x)&0xFF) << (((x)&0xF00)>>7) )
840 static void gcARM(int *fp) {
841 int si = *programCounter(fp); /* Save instruction indicates how */
842 /* many registers in this frame */
844 if (si & (1<<0)) markWithoutMove(*regs--);
845 if (si & (1<<1)) markWithoutMove(*regs--);
846 if (si & (1<<2)) markWithoutMove(*regs--);
847 if (si & (1<<3)) markWithoutMove(*regs--);
848 if (si & (1<<4)) markWithoutMove(*regs--);
849 if (si & (1<<5)) markWithoutMove(*regs--);
850 if (si & (1<<6)) markWithoutMove(*regs--);
851 if (si & (1<<7)) markWithoutMove(*regs--);
852 if (si & (1<<8)) markWithoutMove(*regs--);
853 if (si & (1<<9)) markWithoutMove(*regs--);
854 if (previousFrame(fp)) {
855 /* The non-register stack space is for the previous frame is above
856 this fp, and not below the previous fp, because of the way stack
857 extension works. It seems the only way of discovering its size is
858 finding the SUB sp, sp, #? instruction by walking through the code
859 following the entry point.
861 int *oldpc = programCounter(previousFrame(fp));
863 for(i = 1; i < 6; ++i)
864 if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
865 for(i=1; i<=fsize; ++i)
866 markWithoutMove(fp[i]);
872 int *fp = 5 + &dummy;
875 fp = previousFrame(fp);
879 #else /* Garbage collection for standard stack machines */
881 Void gcCStack() { /* Garbage collect elements off */
882 Cell stackTop = NIL; /* C stack */
883 Cell *ptr = &stackTop;
885 if (((long)(ptr) - (long)(CStackBase))&1)
887 #elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
888 if (((long)(ptr) - (long)(CStackBase))&1)
891 if (((long)(ptr) - (long)(CStackBase))&3)
895 #define Blargh markWithoutMove(*ptr);
897 markWithoutMove((*ptr)/sizeof(Cell)); \
898 markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell)); \
899 markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell))
902 #define StackGrowsDown { while (ptr<=CStackBase) { Blargh; ptr++; }; }
903 #define StackGrowsUp { while (ptr>=CStackBase) { Blargh; ptr--; }; }
904 #define GuessDirection if (ptr>CStackBase) StackGrowsUp else StackGrowsDown
906 #if STACK_DIRECTION > 0
908 #elif STACK_DIRECTION < 0
914 #if SIZEOF_INTP==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
915 ptr = (Cell *)((long)(&stackTop) + 2);
919 #undef StackGrowsDown
921 #undef GuessDirection
925 /* --------------------------------------------------------------------------
926 * Terminal dependent stuff:
927 * ------------------------------------------------------------------------*/
929 #if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
931 /* grab the varargs prototype for ioctl */
933 # include <sys/ioctl.h>
936 /* The order of these three tests is very important because
937 * some systems have more than one of the requisite header file
938 * but only one of them seems to work.
939 * Anyone changing the order of the tests should try enabling each of the
940 * three branches in turn and write down which ones work as well as which
941 * OS/compiler they're using.
943 * OS Compiler sgtty termio termios notes
944 * Linux 2.0.18 gcc 2.7.2 absent works works 1
947 * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
948 * implemented using termios.h.
949 * sgtty.h is in /usr/include/bsd which is not on my standard include
950 * path. Adding it does no harm but you might as well use termios.
952 * reid-alastair@cs.yale.edu
957 typedef struct termios TermParams;
958 #define getTerminal(tp) tcgetattr(fileno(stdin), &tp)
959 #define setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
960 #define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
967 typedef struct sgttyb TermParams;
968 #define getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
969 #define setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
971 #define noEcho(tp) tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
973 #define noEcho(tp) tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
979 typedef struct termio TermParams;
980 #define getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
981 #define setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
982 #define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
988 static Bool messedWithTerminal = FALSE;
989 static TermParams originalSettings;
991 Void normalTerminal() { /* restore terminal initial state */
992 if (messedWithTerminal)
993 setTerminal(originalSettings);
996 Void noechoTerminal() { /* set terminal into noecho mode */
999 if (!messedWithTerminal) {
1000 getTerminal(originalSettings);
1001 messedWithTerminal = TRUE;
1003 getTerminal(settings);
1005 setTerminal(settings);
1008 Int getTerminalWidth() { /* determine width of terminal */
1010 #ifdef _M_UNIX /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
1011 #include <sys/stream.h> /* Required by sys/ptem.h */
1012 #include <sys/ptem.h> /* Required to declare winsize */
1014 static struct winsize terminalSize;
1015 ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
1016 return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
1022 Int readTerminalChar() { /* read character from terminal */
1023 return getchar(); /* without echo, assuming that */
1024 } /* noechoTerminal() is active... */
1028 Int readTerminalChar() { /* read character from terminal */
1029 return getchar(); /* without echo, assuming that */
1030 } /* noechoTerminal() is active... */
1032 Int getTerminalWidth() {
1033 return console_options.ncols;
1036 Void normalTerminal() {
1037 csetmode(C_ECHO, stdin);
1040 Void noechoTerminal() {
1041 csetmode(C_NOECHO, stdin);
1044 #else /* no terminal driver - eg DOS, RISCOS */
1046 static Bool terminalEchoReqd = TRUE;
1048 Int getTerminalWidth() {
1051 (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
1058 Void normalTerminal() { /* restore terminal initial state */
1059 terminalEchoReqd = TRUE;
1062 Void noechoTerminal() { /* turn terminal echo on/off */
1063 terminalEchoReqd = FALSE;
1066 Int readTerminalChar() { /* read character from terminal */
1067 if (terminalEchoReqd) {
1070 #if IS_WIN32 && !HUGS_FOR_WINDOWS && !__BORLANDC__
1071 /* When reading a character from the console/terminal, we want
1072 * to operate in 'raw' mode (to use old UNIX tty parlance) and have
1073 * it return when a character is available and _not_ wait until
1074 * the next time the user hits carriage return. On Windows platforms,
1075 * this _can_ be done by reading directly from the console, using
1076 * getch(). However, this doesn't sit well with programming
1077 * environments such as Emacs which allow you to create sub-processes
1078 * running Hugs, and then communicate with the running interpreter
1079 * through its standard input and output handles. If you use getch()
1080 * in that setting, you end up trying to read the (unused) console
1081 * of the editor itself, through which not a lot of characters is
1082 * bound to come out, since the editor communicates input to Hugs
1083 * via the standard input handle.
1085 * To avoid this rather unfortunate situation, we use the Win32
1086 * console API and re-jig the input properties of the standard
1087 * input handle before trying to read a character using stdio's
1090 * The 'cost' of this solution is that it is Win32 specific and
1091 * won't work with Windows 3.1 + it is kind of ugly and verbose
1092 * to have to futz around with the console properties on a
1093 * per-char basis. Both of these disadvantages aren't in my
1102 /* I don't quite understand why, but if the FILE*'s underlying file
1103 descriptor is in text mode, we seem to lose the first carriage
1106 setmode(fileno(stdin), _O_BINARY);
1107 hIn = GetStdHandle(STD_INPUT_HANDLE);
1108 GetConsoleMode(hIn, &mo);
1109 SetConsoleMode(hIn, mo & ~(ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT));
1112 /* Same as it ever was - revert back state of stdin. */
1113 SetConsoleMode(hIn, mo);
1114 setmode(fileno(stdin), _O_TEXT);
1118 return c=='\r' ? '\n' : c; /* slight paranoia about CR-LF */
1122 #endif /* no terminal driver */
1124 /* --------------------------------------------------------------------------
1125 * Interrupt handling:
1126 * ------------------------------------------------------------------------*/
1128 Bool broken = FALSE;
1129 static Bool breakReqd = FALSE;
1130 static sigProto(ignoreBreak);
1131 static Void local installHandlers Args((Void));
1133 Bool breakOn(reqd) /* set break trapping on if reqd, */
1134 Bool reqd; { /* or off otherwise, returning old */
1135 Bool old = breakReqd;
1139 if (broken) { /* repond to break signal received */
1140 broken = FALSE; /* whilst break trap disabled */
1141 sigRaise(breakHandler);
1144 #if HANDLERS_CANT_LONGJMP
1145 ctrlbrk(ignoreBreak);
1147 ctrlbrk(breakHandler);
1150 ctrlbrk(ignoreBreak);
1155 static sigHandler(ignoreBreak) { /* record but don't respond to break*/
1156 ctrlbrk(ignoreBreak); /* reinstall signal handler */
1157 /* redundant on BSD systems but essential */
1158 /* on POSIX and other systems */
1165 static sigProto(panic);
1166 static sigHandler(panic) { /* exit in a panic, on receipt of */
1167 everybody(EXIT); /* an unexpected signal */
1168 fprintf(stderr,"\nUnexpected signal\n");
1170 sigResume;/*NOTREACHED*/
1172 #endif /* !DONT_PANIC */
1175 BOOL WINAPI consoleHandler(DWORD dwCtrlType) {
1176 switch (dwCtrlType) { /* Allows Hugs to be terminated */
1177 case CTRL_CLOSE_EVENT : /* from the window's close menu. */
1184 static Void local installHandlers() { /* Install handlers for all fatal */
1185 /* signals except SIGINT and SIGBREAK*/
1187 SetConsoleCtrlHandler(consoleHandler,TRUE);
1189 #if !DONT_PANIC && !DOS
1191 signal(SIGABRT,panic);
1194 signal(SIGBUS,panic);
1197 signal(SIGFPE,panic);
1200 signal(SIGHUP,panic);
1203 signal(SIGILL,panic);
1206 signal(SIGQUIT,panic);
1209 signal(SIGSEGV,panic);
1212 signal(SIGTERM,panic);
1214 #endif /* !DONT_PANIC && !DOS */
1217 /* --------------------------------------------------------------------------
1219 * ------------------------------------------------------------------------*/
1221 static Bool local startEdit(line,nm) /* Start editor on file name at */
1222 Int line; /* given line. Both name and line */
1223 String nm; { /* or just line may be zero */
1224 static char editorCmd[FILENAME_MAX+1];
1227 if (hugsEdit && *hugsEdit) { /* Check that editor configured */
1229 /* On a Mac, files have creator information, telling which program
1230 to launch to, so an editor named to the empty string "" is often
1232 if (hugsEdit) { /* Check that editor configured */
1234 Int n = FILENAME_MAX;
1235 String he = hugsEdit;
1236 String ec = editorCmd;
1237 String rd = NULL; /* Set to nonnull to redo ... */
1239 for (; n>0 && *he && *he!=' ' && *he!='%'; n--)
1240 *ec++ = *he++; /* Copy editor name to buffer */
1241 /* assuming filename ends at space */
1243 if (nm && line && n>1 && *he){ /* Name, line, and enough space */
1244 rd = ec; /* save, in case we don't find name*/
1245 while (n>0 && *he) {
1247 if (*++he=='d' && n>10) {
1248 sprintf(ec,"%d",line);
1251 else if (*he=='s' && (size_t)n>strlen(nm)) {
1256 else if (*he=='%' && n>1) {
1260 else /* Ignore % char if not followed */
1261 *ec = '\0'; /* by one of d, s, or %, */
1262 for (; *ec && n>0; n--)
1264 } /* ignore % followed by anything other than d, s, or % */
1265 else { /* Copy other characters across */
1274 if (rd) { /* If file name was not included */
1279 if (nm && line==0 && n>1) { /* Name, but no line ... */
1281 for (; n>0 && *nm; n--) /* ... just copy file name */
1285 *ec = '\0'; /* Add terminating null byte */
1288 ERRMSG(0) "Hugs is not configured to use an editor"
1293 WinExec(editorCmd, SW_SHOW);
1296 if (shellEsc(editorCmd))
1297 Printf("Warning: Editor terminated abnormally\n");
1302 Int shellEsc(s) /* run a shell command (or shell) */
1305 return macsystem(s);
1309 s = fromEnv("SHELL","/bin/sh");
1316 #if RISCOS /* RISCOS also needs a chdir() */
1317 int chdir(char *s) { /* RISCOS PRM p. 885 -- JBS */
1318 return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
1320 #elif defined HAVE_PBHSETVOLSYNC /* Macintosh */
1321 int chdir(const char *s) {
1324 wd.ioCompletion = 0;
1325 str = (char*)malloc(strlen(s) + 1);
1326 if (str == 0) return -1;
1328 wd.ioNamePtr = C2PStr(str);
1331 errno = PBHSetVolSync(&wd);
1342 /*---------------------------------------------------------------------------
1343 * Printf-related operations:
1344 *-------------------------------------------------------------------------*/
1346 #if !defined(HAVE_VSNPRINTF)
1347 int vsnprintf(buffer, count, fmt, ap)
1352 #if defined(HAVE__VSNPRINTF)
1353 return _vsnprintf(buffer, count, fmt, ap);
1358 #endif /* HAVE_VSNPRINTF */
1360 #if !defined(HAVE_SNPRINTF)
1361 int snprintf(char* buffer, int count, const char* fmt, ...) {
1362 #if defined(HAVE__VSNPRINTF)
1364 va_list ap; /* pointer into argument list */
1365 va_start(ap, fmt); /* make ap point to first arg after fmt */
1366 r = vsnprintf(buffer, count, fmt, ap);
1367 va_end(ap); /* clean up */
1373 #endif /* HAVE_SNPRINTF */
1375 /* --------------------------------------------------------------------------
1376 * Read/write values from/to the registry
1378 * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
1379 * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key. (Machine entry is only used if
1380 * user entry doesn't exist).
1382 * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
1383 * ------------------------------------------------------------------------*/
1387 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
1389 static Bool local createKey Args((HKEY, PHKEY, REGSAM));
1390 static Bool local queryValue Args((HKEY, String, LPDWORD, LPBYTE, DWORD));
1391 static Bool local setValue Args((HKEY, String, DWORD, LPBYTE, DWORD));
1393 static Bool local createKey(hKey, phRootKey, samDesired)
1396 REGSAM samDesired; {
1398 return RegCreateKeyEx(hKey, HugsRoot,
1399 0, "", REG_OPTION_NON_VOLATILE,
1400 samDesired, NULL, phRootKey, &dwDisp)
1404 static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
1413 if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
1416 LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
1417 RegCloseKey(hRootKey);
1418 return (res == ERROR_SUCCESS);
1422 static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
1431 if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
1434 LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
1435 RegCloseKey(hRootKey);
1436 return (res == ERROR_SUCCESS);
1440 static String local readRegString(key,regPath,var,def) /* read String from registry */
1445 static char buf[300];
1447 if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
1448 && type == REG_SZ) {
1455 static Int local readRegInt(var, def) /* read Int from registry */
1461 if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
1462 (LPBYTE)&buf, sizeof(buf))
1463 && type == REG_DWORD) {
1465 } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
1466 (LPBYTE)&buf, sizeof(buf))
1467 && type == REG_DWORD) {
1474 static Bool local writeRegString(var,val) /* write String to registry */
1480 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1481 REG_SZ, (LPBYTE)val, lstrlen(val)+1);
1484 static Bool local writeRegInt(var,val) /* write String to registry */
1487 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1488 REG_DWORD, (LPBYTE)&val, sizeof(val));
1491 #endif /* USE_REGISTRY */
1493 /* --------------------------------------------------------------------------
1494 * Machine dependent control:
1495 * ------------------------------------------------------------------------*/
1497 Void machdep(what) /* Handle machine specific */
1498 Int what; { /* initialisation etc.. */
1501 case INSTALL : installHandlers();
1505 case EXIT : normalTerminal();
1506 #if HUGS_FOR_WINDOWS
1508 DestroyWindow(hWndMain);
1510 SetCursor(LoadCursor(NULL,IDC_ARROW));
1516 /*-------------------------------------------------------------------------*/