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: 2000/03/22 18:14:22 $
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
63 extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */
71 /* Macintosh include files */
94 int allow_break_count = 0;
97 /* --------------------------------------------------------------------------
98 * Prototypes for registry reading
99 * ------------------------------------------------------------------------*/
103 /* where have we hidden things in the registry? */
105 #define HScriptRoot ("SOFTWARE\\Haskell\\HaskellScript\\")
108 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
109 #define ProjectRoot ("SOFTWARE\\Haskell\\Projects\\")
111 static Bool local createKey ( HKEY, String, PHKEY, REGSAM );
112 static Bool local queryValue ( HKEY, String, String, LPDWORD, LPBYTE, DWORD );
113 static Bool local setValue ( HKEY, String, String, DWORD, LPBYTE, DWORD );
114 static String local readRegString ( HKEY, String, String, String );
115 static Int local readRegInt ( String,Int );
116 static Bool local writeRegString ( String,String );
117 static Bool local writeRegInt ( String,Int );
119 static String local readRegChildStrings ( HKEY, String, String, Char, String );
120 #endif /* USE_REGISTRY */
122 /* --------------------------------------------------------------------------
123 * Find information about a file:
124 * ------------------------------------------------------------------------*/
126 #include "machdep_time.h"
128 static Bool local readable ( String );
129 static Void local getFileInfo ( String, Time *, Long * );
131 static Void local getFileInfo(f,tm,sz) /* find time stamp and size of file*/
135 #if defined HAVE_SYS_STAT_H || defined HAVE_STAT_H || defined HAVE_UNIX_H
137 if (!stat(f,&scbuf)) {
138 if (tm) *tm = scbuf.st_mtime;
139 *sz = (Long)(scbuf.st_size);
144 #else /* normally just use stat() */
145 os_regset r; /* RISCOS PRM p.850 and p.837 */
146 r.r[0] = 17; /* Read catalogue, no path */
149 if(r.r[0] == 1 && (r.r[2] & 0xFFF00000) == 0xFFF00000) {
150 if (tm) tm->hi = r.r[2] & 0xFF; /* Load address (high byte) */
151 if (tm) tm->lo = r.r[3]; /* Execution address (low 4 bytes) */
152 } else { /* Not found, or not time-stamped */
153 if (tm) tm->hi = tm->lo = 0;
155 *sz = (Long)(r.r[0] == 1 ? r.r[4] : 0);
159 Void getFileSize ( String f, Long* sz )
161 getFileInfo ( f, NULL, sz );
164 #if defined HAVE_GETFINFO /* Mac971031 */
165 /* --------------------------------------------------------------------------
166 * Define a MacOS version of access():
167 * If the file is not accessible, -1 is returned and errno is set to
168 * the reason for the failure.
169 * If the file is accessible and the dummy is 0 (existence), 2 (write),
170 * or 4 (read), the return is 0.
171 * If the file is accessible, and the dummy is 1 (executable), then if
172 * the file is a program (of type 'APPL'), the return is 0, otherwise -1.
173 * Warnings: Use with caution. UNIX access do no translate to Macs.
174 * Check of write access is not implemented (same as read).
175 * ------------------------------------------------------------------------*/
177 int access(char *fileName, int dummy) {
181 errno = getfinfo(fileName, 0, &fi);
182 if (errno != 0) return -1; /* Check file accessible. */
184 /* Cases dummy = existence, read, write. */
185 if (dummy == 0 || dummy & 0x6) return 0;
187 /* Case dummy = executable. */
189 if (fi.fdType == 'APPL') return 0;
198 static Bool local readable(f) /* is f a regular, readable file */
200 #if DJGPP2 || defined HAVE_GETFINFO /* stat returns bogus mode bits on djgpp2 */
201 return (0 == access(f,4));
202 #elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H
204 /* fprintf(stderr, "readable: %s\n", f ); */
205 return ( !stat(f,&scbuf)
206 && (scbuf.st_mode & S_IREAD) /* readable */
207 && (scbuf.st_mode & S_IFREG) /* regular file */
209 #elif defined HAVE_OS_SWI /* RISCOS specific */
210 os_regset r; /* RISCOS PRM p.850 -- JBS */
212 r.r[0] = 17; /* Read catalogue, no path */
215 return r.r[0] != 1; /* Does this check it's a regular file? ADR */
220 /* --------------------------------------------------------------------------
221 * Search for script files on the HUGS path:
222 * ------------------------------------------------------------------------*/
224 static String local hugsdir ( Void );
226 static String local hscriptDir ( Void );
228 static int local pathCmp ( String, String );
229 static String local normPath ( String );
230 static Void local searchChr ( Int );
231 static Void local searchStr ( String );
232 static Bool local tryEndings ( String );
234 #if (DOS_FILENAMES || __CYGWIN32__)
236 # define isSLASH(c) ((c)=='\\' || (c)=='/')
238 # define PATHSEP_STR ";"
239 # define DLL_ENDING ".dll"
242 # define isSLASH(c) ((c)==SLASH)
244 # define PATHSEP_STR ";"
245 /* Mac PEF (Preferred Executable Format) file */
246 # define DLL_ENDING ".pef"
249 # define isSLASH(c) ((c)==SLASH)
251 # define PATHSEP_STR ":"
252 # define DLL_ENDING ".u_o"
255 static String local hugsdir() { /* directory containing lib/Prelude.hs */
257 /* In HaskellScript (Win32 only), we lookup InstallDir in the registry. */
258 static char dir[FILENAME_MAX+1] = "";
259 if (dir[0] == '\0') { /* not initialised yet */
260 String s = readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"InstallDir",
267 #elif HAVE_GETMODULEFILENAME && !DOS && !__CYGWIN32__
268 /* On Windows, we can find the binary we're running and it's
269 * conventional to put the libraries in the same place.
271 static char dir[FILENAME_MAX+1] = "";
272 if (dir[0] == '\0') { /* not initialised yet */
274 GetModuleFileName((HMODULE)0,dir,FILENAME_MAX+1);
275 if (dir[0] == '\0') { /* GetModuleFileName must have failed */
278 slash = strrchr(dir,SLASH);
279 if (slash) { /* truncate after directory name */
285 /* On Unix systems, we can't find the binary we're running and
286 * the libraries may not be installed near the binary anyway.
287 * This forces us to use a hardwired path which is set at
288 * configuration time (--datadir=...).
295 static String local hscriptDir() { /* Directory containing hscript.dll */
296 static char dir[FILENAME_MAX+1] = "";
297 if (dir[0] == '\0') { /* not initialised yet */
298 String s = readRegString(HKEY_LOCAL_MACHINE,HScriptRoot,"InstallDir","");
307 #if 0 /* apparently unused */
308 static String local RealPath(s) /* Find absolute pathname of file */
310 #if HAVE__FULLPATH /* eg DOS */
311 static char path[FILENAME_MAX+1];
312 _fullpath(path,s,FILENAME_MAX+1);
313 #elif HAVE_REALPATH /* eg Unix */
314 static char path[MAXPATHLEN+1];
317 static char path[FILENAME_MAX+1];
325 static int local pathCmp(p1,p2) /* Compare paths after normalisation */
328 #if HAVE__FULLPATH /* eg DOS */
329 static char path1[FILENAME_MAX+1];
330 static char path2[FILENAME_MAX+1];
331 _fullpath(path1,p1,FILENAME_MAX+1);
332 _fullpath(path2,p2,FILENAME_MAX+1);
333 #elif HAVE_REALPATH /* eg Unix */
334 static char path1[MAXPATHLEN+1];
335 static char path2[MAXPATHLEN+1];
339 static char path1[FILENAME_MAX+1];
340 static char path2[FILENAME_MAX+1];
344 #if CASE_INSENSITIVE_FILENAMES
348 return filenamecmp(path1,path2);
351 static String local normPath(s) /* Try, as much as possible, to normalize */
352 String s; { /* a pathname in some appropriate manner. */
353 #if PATH_CANONICALIZATION
354 String path = RealPath(s);
355 #if CASE_INSENSITIVE_FILENAMES
356 strlwr(path); /* and convert to lowercase */
359 #else /* ! PATH_CANONICALIZATION */
361 #endif /* ! PATH_CANONICALIZATION */
365 static String endings[] = { "", ".u_hi", ".hs", ".lhs", ".hsx", ".hash", 0 };
367 static String endings[] = { "", ".u_hi", ".hs", ".lhs", 0 };
369 static char searchBuf[FILENAME_MAX+1];
370 static Int searchPos;
372 #define searchReset(n) searchBuf[searchPos=(n)]='\0'
374 static Void local searchChr(c) /* Add single character to search buffer */
376 if (searchPos<FILENAME_MAX) {
377 searchBuf[searchPos++] = (char)c;
378 searchBuf[searchPos] = '\0';
382 static Void local searchStr(s) /* Add string to search buffer */
384 while (*s && searchPos<FILENAME_MAX)
385 searchBuf[searchPos++] = *s++;
386 searchBuf[searchPos] = '\0';
389 static Bool local tryEndings(s) /* Try each of the listed endings */
393 for (; endings[i]; ++i) {
394 Int save = searchPos;
395 searchStr(endings[i]);
396 if (readable(searchBuf))
407 /* scandir, June 98 Daan Leijen
408 searches the base directory and its direct subdirectories for a file
410 input: searchbuf contains SLASH terminated base directory
411 argument s contains the (base) filename
412 output: TRUE: searchBuf contains the full filename
413 FALSE: searchBuf is garbage, file not found
417 #ifdef HAVE_WINDOWS_H
419 static Bool scanSubDirs(s)
422 struct _finddata_t findInfo;
427 /* is it in the current directory ? */
428 if (tryEndings(s)) return TRUE;
433 /* initiate the search */
434 handle = _findfirst( searchBuf, &findInfo );
435 if (handle==-1) { errno = 0; return FALSE; }
437 /* search all subdirectories */
439 /* if we have a valid sub directory */
440 if (((findInfo.attrib & _A_SUBDIR) == _A_SUBDIR) &&
441 (findInfo.name[0] != '.')) {
443 searchStr(findInfo.name);
449 } while (_findnext( handle, &findInfo ) == 0);
451 _findclose( handle );
455 #elif defined(HAVE_FTW_H)
459 static char baseFile[FILENAME_MAX+1];
460 static char basePath[FILENAME_MAX+1];
461 static int basePathLen;
463 static int scanitem( const char* path,
464 const struct stat* statinfo,
467 if (info == FTW_D) { /* is it a directory */
471 if (tryEndings(baseFile)) {
478 static Bool scanSubDirs(s)
483 strcpy(basePath,searchBuf);
484 basePathLen = strlen(basePath);
486 /* is it in the current directory ? */
487 if (tryEndings(s)) return TRUE;
489 /* otherwise scan the subdirectories */
490 r = ftw( basePath, scanitem, 2 );
495 #endif /* HAVE_WINDOWS_H || HAVE_FTW_H */
496 #endif /* SEARCH_DIR */
498 String findPathname(along,nm) /* Look for a file along specified path */
499 String along; /* Return NULL if file does not exist */
501 /* AC, 1/21/99: modified to search hugsPath first, then projectPath */
502 String s = findMPathname(along,nm,hugsPath);
507 s = findMPathname(along,nm,projectPath);
510 #endif /* USE_REGISTRY */
511 return s ? s : normPath(searchBuf);
514 /* AC, 1/21/99: modified to pass in path to search explicitly */
515 String findMPathname(along,nm,path)/* Look for a file along specified path */
516 String along; /* If nonzero, a path prefix from along is */
517 String nm; /* used as the first prefix in the search. */
519 String pathpt = path;
522 if (along) { /* Was a path for an existing file given? */
525 for (; along[i]; i++) {
527 if (isSLASH(along[i]))
533 return normPath(searchBuf);
535 if (pathpt && *pathpt) { /* Otherwise, we look along the HUGSPATH */
538 Bool recurse = FALSE; /* DL: shall we recurse ? */
541 if (*pathpt!=PATHSEP) {
542 /* Pre-define one MPW-style "shell-variable" */
543 if (strncmp(pathpt,"{Hugs}",6)==0) {
544 searchStr(hugsdir());
548 /* And another - we ought to generalise this stuff */
549 else if (strncmp(pathpt,"{HScript}",9)==0) {
550 searchStr(hscriptDir());
555 searchChr(*pathpt++);
556 } while (*pathpt && *pathpt!=PATHSEP);
557 recurse = (pathpt[-1] == SLASH);
562 if (*pathpt==PATHSEP)
570 if (recurse ? scanSubDirs(nm) : tryEndings(nm)) {
571 return normPath(searchBuf);
574 if (tryEndings(nm)) {
575 return normPath(searchBuf);
581 searchReset(0); /* As a last resort, look for file in the current dir */
582 return (tryEndings(nm) ? normPath(searchBuf) : 0);
585 /* --------------------------------------------------------------------------
586 * New path handling stuff for the Combined System (tm)
587 * ------------------------------------------------------------------------*/
589 char installDir[N_INSTALLDIR];
591 /* Sets installDir to $STGHUGSDIR, and ensures there is a trailing
594 void setInstallDir ( String argv_0 )
597 char* r = getenv("STGHUGSDIR");
600 "%s: installation error: environment variable STGHUGSDIR is not set.\n",
603 "%s: pls set it to be the directory where STGHugs98 is installed.\n\n",
609 if (strlen(r) > N_INSTALLDIR-30 ) {
611 "%s: environment variable STGHUGSDIR is suspiciously long; pls remedy\n\n",
616 strcpy ( installDir, r );
617 i = strlen(installDir);
618 if (installDir[i-1] != SLASH) installDir[i++] = SLASH;
623 Bool findFilesForModule (
627 Bool* sAvail, Time* sTime, Long* sSize,
628 Bool* iAvail, Time* iTime, Long* iSize,
629 Bool* oAvail, Time* oTime, Long* oSize
632 /* Let the module name given be M.
633 For each path entry P,
634 a s(rc) file will be P/M.hs or P/M.lhs
635 an i(nterface) file will be P/M.hi
636 an o(bject) file will be P/M.o
637 If there is a s file or (both i and o files)
638 use P to fill in the path names.
639 Otherwise, move on to the next path entry.
640 If all path entries are exhausted, return False.
644 String peStart, peEnd;
645 String augdPath; /* .:hugsPath:installDir/GhcPrel:installDir/lib */
647 *path = *sExt = NULL;
648 *sAvail = *iAvail = *oAvail = FALSE;
649 *sSize = *iSize = *oSize = 0;
651 augdPath = malloc( 2*(10+3+strlen(installDir))
652 +strlen(hugsPath) +10/*paranoia*/);
654 internal("moduleNameToFileNames: malloc failed(2)");
657 strcat(augdPath, ".");
658 strcat(augdPath, PATHSEP_STR);
660 strcat(augdPath, hugsPath);
661 strcat(augdPath, PATHSEP_STR);
664 strcat(augdPath, installDir);
665 strcat(augdPath, "GhcPrel");
666 strcat(augdPath, PATHSEP_STR);
669 strcat(augdPath, installDir);
670 strcat(augdPath, "lib");
671 strcat(augdPath, PATHSEP_STR);
673 /* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
677 /* Advance peStart and peEnd very paranoically, giving up at
678 the first sign of mutancy in the path string.
680 if (peEnd >= augdPath && !(*peEnd)) { free(augdPath); return FALSE; }
683 while (*peEnd && *peEnd != PATHSEP) peEnd++;
685 /* Now peStart .. peEnd-1 bracket the next path element. */
686 nPath = peEnd-peStart;
687 if (nPath + strlen(modName) + 10 /*slush*/ > FILENAME_MAX) {
688 ERRMSG(0) "Hugs path \"%s\" contains excessively long component",
695 strncpy(searchBuf, peStart, nPath);
696 searchBuf[nPath] = 0;
697 if (nPath > 0 && !isSLASH(searchBuf[nPath-1]))
698 searchBuf[nPath++] = SLASH;
700 strcpy(searchBuf+nPath, modName);
701 nPath += strlen(modName);
703 /* searchBuf now holds 'P/M'. Try out the various endings. */
704 *path = *sExt = NULL;
705 *sAvail = *iAvail = *oAvail = FALSE;
706 *sSize = *iSize = *oSize = 0;
708 strcpy(searchBuf+nPath, DLL_ENDING);
709 if (readable(searchBuf)) {
711 getFileInfo(searchBuf, oTime, oSize);
714 strcpy(searchBuf+nPath, ".u_hi");
715 if (readable(searchBuf)) {
717 getFileInfo(searchBuf, iTime, iSize);
720 strcpy(searchBuf+nPath, ".hs");
721 if (readable(searchBuf)) {
724 getFileInfo(searchBuf, sTime, sSize);
727 strcpy(searchBuf+nPath, ".lhs");
728 if (readable(searchBuf)) {
731 getFileInfo(searchBuf, sTime, sSize);
737 if (*sAvail || (*oAvail && *iAvail)) {
738 nPath -= strlen(modName);
739 *path = malloc(nPath+1);
741 internal("moduleNameToFileNames: malloc failed(1)");
742 strncpy(*path, searchBuf, nPath);
753 /* If the primaryObjectName is (eg)
755 and the extraFileName is (eg)
757 and DLL_ENDING is set to .o
759 /foo/bar/swampy_cbits.o
760 and set *extraFileSize to its size, or -1 if not avail
762 String getExtraObjectInfo ( String primaryObjectName,
763 String extraFileName,
770 Int i = strlen(primaryObjectName)-1;
771 while (i >= 0 && primaryObjectName[i] != SLASH) i--;
772 if (i == -1) return extraFileName;
774 xtra = malloc ( i+3+strlen(extraFileName)+strlen(DLL_ENDING) );
775 if (!xtra) internal("deriveExtraObjectName: malloc failed");
776 strncpy ( xtra, primaryObjectName, i );
778 strcat ( xtra, extraFileName );
779 strcat ( xtra, DLL_ENDING );
782 if (readable(xtra)) {
783 getFileInfo ( xtra, &xTime, &xSize );
784 *extraFileSize = xSize;
790 /* --------------------------------------------------------------------------
791 * Substitute old value of path into empty entries in new path
792 * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
793 * ------------------------------------------------------------------------*/
795 static String local substPath ( String,String );
797 static String local substPath(new,sub) /* substitute sub path into new path*/
800 Bool substituted = FALSE; /* only allow one replacement */
801 Int maxlen = strlen(sub) + strlen(new); /* safe upper bound */
802 String r = (String) malloc(maxlen+1); /* result string */
803 String t = r; /* pointer into r */
804 String next = new; /* next uncopied char in new */
805 String start = next; /* start of last path component */
807 ERRMSG(0) "String storage space exhausted"
811 if (*next == PATHSEP || *next == '\0') {
812 if (!substituted && next == start) {
814 for(; *s != '\0'; ++s) {
821 } while ((*t++ = *next++) != '\0');
826 /* --------------------------------------------------------------------------
827 * Garbage collection notification:
828 * ------------------------------------------------------------------------*/
830 Bool gcMessages = FALSE; /* TRUE => print GC messages */
832 Void gcStarted() { /* Notify garbage collector start */
839 Void gcScanning() { /* Notify garbage collector scans */
846 Void gcRecovered(recovered) /* Notify garbage collection done */
849 Printf("%d}}",recovered);
854 Cell *CStackBase; /* Retain start of C control stack */
856 #if RISCOS /* Stack traversal for RISCOS */
858 /* Warning: The following code is specific to the Acorn ARM under RISCOS
859 (and C4). We must explicitly walk back through the stack frames, since
860 the stack is extended from the heap. (see PRM pp. 1757). gcCStack must
861 not be modified, since the offset '5' assumes that only v1 is used inside
862 this function. Hence we do all the real work in gcARM.
865 #define spreg 13 /* C3 has SP=R13 */
867 #define previousFrame(fp) ((int *)((fp)[-3]))
868 #define programCounter(fp) ((int *)((*(fp)-12) & ~0xFC000003))
869 #define isSubSPSP(w) (((w)&dontCare) == doCare)
870 #define doCare (0xE24DD000) /* SUB r13,r13,#0 */
871 #define dontCare (~0x00100FFF) /* S and # bits */
872 #define immediateArg(x) ( ((x)&0xFF) << (((x)&0xF00)>>7) )
874 static void gcARM(int *fp) {
875 int si = *programCounter(fp); /* Save instruction indicates how */
876 /* many registers in this frame */
878 if (si & (1<<0)) markWithoutMove(*regs--);
879 if (si & (1<<1)) markWithoutMove(*regs--);
880 if (si & (1<<2)) markWithoutMove(*regs--);
881 if (si & (1<<3)) markWithoutMove(*regs--);
882 if (si & (1<<4)) markWithoutMove(*regs--);
883 if (si & (1<<5)) markWithoutMove(*regs--);
884 if (si & (1<<6)) markWithoutMove(*regs--);
885 if (si & (1<<7)) markWithoutMove(*regs--);
886 if (si & (1<<8)) markWithoutMove(*regs--);
887 if (si & (1<<9)) markWithoutMove(*regs--);
888 if (previousFrame(fp)) {
889 /* The non-register stack space is for the previous frame is above
890 this fp, and not below the previous fp, because of the way stack
891 extension works. It seems the only way of discovering its size is
892 finding the SUB sp, sp, #? instruction by walking through the code
893 following the entry point.
895 int *oldpc = programCounter(previousFrame(fp));
897 for(i = 1; i < 6; ++i)
898 if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
899 for(i=1; i<=fsize; ++i)
900 markWithoutMove(fp[i]);
906 int *fp = 5 + &dummy;
909 fp = previousFrame(fp);
913 #else /* Garbage collection for standard stack machines */
915 Void gcCStack() { /* Garbage collect elements off */
916 Cell stackTop = NIL; /* C stack */
917 Cell *ptr = &stackTop;
918 #if SIZEOF_VOID_P == 2
919 if (((long)(ptr) - (long)(CStackBase))&1)
921 #elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
922 if (((long)(ptr) - (long)(CStackBase))&1)
925 if (((long)(ptr) - (long)(CStackBase))&3)
929 #define Blargh markWithoutMove(*ptr);
931 markWithoutMove((*ptr)/sizeof(Cell)); \
932 markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell)); \
933 markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell))
936 #define StackGrowsDown { while (ptr<=CStackBase) { Blargh; ptr++; }; }
937 #define StackGrowsUp { while (ptr>=CStackBase) { Blargh; ptr--; }; }
938 #define GuessDirection if (ptr>CStackBase) StackGrowsUp else StackGrowsDown
940 #if STACK_DIRECTION > 0
942 #elif STACK_DIRECTION < 0
948 #if SIZEOF_VOID_P==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
949 ptr = (Cell *)((long)(&stackTop) + 2);
953 #undef StackGrowsDown
955 #undef GuessDirection
959 /* --------------------------------------------------------------------------
960 * Terminal dependent stuff:
961 * ------------------------------------------------------------------------*/
963 #if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
965 /* grab the varargs prototype for ioctl */
967 # include <sys/ioctl.h>
970 /* The order of these three tests is very important because
971 * some systems have more than one of the requisite header file
972 * but only one of them seems to work.
973 * Anyone changing the order of the tests should try enabling each of the
974 * three branches in turn and write down which ones work as well as which
975 * OS/compiler they're using.
977 * OS Compiler sgtty termio termios notes
978 * Linux 2.0.18 gcc 2.7.2 absent works works 1
981 * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
982 * implemented using termios.h.
983 * sgtty.h is in /usr/include/bsd which is not on my standard include
984 * path. Adding it does no harm but you might as well use termios.
986 * reid-alastair@cs.yale.edu
991 typedef struct termios TermParams;
992 #define getTerminal(tp) tcgetattr(fileno(stdin), &tp)
993 #define setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
994 #define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
1001 typedef struct sgttyb TermParams;
1002 #define getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
1003 #define setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
1005 #define noEcho(tp) tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
1007 #define noEcho(tp) tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
1013 typedef struct termio TermParams;
1014 #define getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
1015 #define setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
1016 #define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
1017 tp.c_cc[VMIN] = 1; \
1022 static Bool messedWithTerminal = FALSE;
1023 static TermParams originalSettings;
1025 Void normalTerminal() { /* restore terminal initial state */
1026 if (messedWithTerminal)
1027 setTerminal(originalSettings);
1030 Void noechoTerminal() { /* set terminal into noecho mode */
1031 TermParams settings;
1033 if (!messedWithTerminal) {
1034 getTerminal(originalSettings);
1035 messedWithTerminal = TRUE;
1037 getTerminal(settings);
1039 setTerminal(settings);
1042 Int getTerminalWidth() { /* determine width of terminal */
1044 #ifdef _M_UNIX /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
1045 #include <sys/stream.h> /* Required by sys/ptem.h */
1046 #include <sys/ptem.h> /* Required to declare winsize */
1048 static struct winsize terminalSize;
1049 ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
1050 return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
1056 Int readTerminalChar() { /* read character from terminal */
1057 return getchar(); /* without echo, assuming that */
1058 } /* noechoTerminal() is active... */
1062 Int readTerminalChar() { /* read character from terminal */
1063 return getchar(); /* without echo, assuming that */
1064 } /* noechoTerminal() is active... */
1066 Int getTerminalWidth() {
1067 return console_options.ncols;
1070 Void normalTerminal() {
1071 csetmode(C_ECHO, stdin);
1074 Void noechoTerminal() {
1075 csetmode(C_NOECHO, stdin);
1078 #else /* no terminal driver - eg DOS, RISCOS */
1080 static Bool terminalEchoReqd = TRUE;
1082 Int getTerminalWidth() {
1085 (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
1092 Void normalTerminal() { /* restore terminal initial state */
1093 terminalEchoReqd = TRUE;
1096 Void noechoTerminal() { /* turn terminal echo on/off */
1097 terminalEchoReqd = FALSE;
1100 Int readTerminalChar() { /* read character from terminal */
1101 if (terminalEchoReqd) {
1104 #if IS_WIN32 && !__BORLANDC__
1105 /* When reading a character from the console/terminal, we want
1106 * to operate in 'raw' mode (to use old UNIX tty parlance) and have
1107 * it return when a character is available and _not_ wait until
1108 * the next time the user hits carriage return. On Windows platforms,
1109 * this _can_ be done by reading directly from the console, using
1110 * getch(). However, this doesn't sit well with programming
1111 * environments such as Emacs which allow you to create sub-processes
1112 * running Hugs, and then communicate with the running interpreter
1113 * through its standard input and output handles. If you use getch()
1114 * in that setting, you end up trying to read the (unused) console
1115 * of the editor itself, through which not a lot of characters is
1116 * bound to come out, since the editor communicates input to Hugs
1117 * via the standard input handle.
1119 * To avoid this rather unfortunate situation, we use the Win32
1120 * console API and re-jig the input properties of the standard
1121 * input handle before trying to read a character using stdio's
1124 * The 'cost' of this solution is that it is Win32 specific and
1125 * won't work with Windows 3.1 + it is kind of ugly and verbose
1126 * to have to futz around with the console properties on a
1127 * per-char basis. Both of these disadvantages aren't in my
1136 /* I don't quite understand why, but if the FILE*'s underlying file
1137 descriptor is in text mode, we seem to lose the first carriage
1140 setmode(fileno(stdin), _O_BINARY);
1141 hIn = GetStdHandle(STD_INPUT_HANDLE);
1142 GetConsoleMode(hIn, &mo);
1143 SetConsoleMode(hIn, mo & ~(ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT));
1145 * On Win9x, the first time you change the mode (as above) a
1146 * raw '\n' is inserted. Since enter maps to a raw '\r', and we
1147 * map this (below) to '\n', we can just ignore all *raw* '\n's.
1151 } while (c == '\n');
1153 /* Same as it ever was - revert back state of stdin. */
1154 SetConsoleMode(hIn, mo);
1155 setmode(fileno(stdin), _O_TEXT);
1159 return c=='\r' ? '\n' : c; /* slight paranoia about CR-LF */
1163 #endif /* no terminal driver */
1165 /* --------------------------------------------------------------------------
1166 * Interrupt handling:
1167 * ------------------------------------------------------------------------*/
1169 Bool broken = FALSE;
1170 static Bool breakReqd = FALSE;
1171 static sigProto(ignoreBreak);
1172 static Void local installHandlers ( Void );
1174 Bool breakOn(reqd) /* set break trapping on if reqd, */
1175 Bool reqd; { /* or off otherwise, returning old */
1176 Bool old = breakReqd;
1180 if (broken) { /* repond to break signal received */
1181 broken = FALSE; /* whilst break trap disabled */
1182 sigRaise(breakHandler);
1185 #if HANDLERS_CANT_LONGJMP
1186 ctrlbrk(ignoreBreak);
1188 ctrlbrk(breakHandler);
1191 ctrlbrk(ignoreBreak);
1196 static sigHandler(ignoreBreak) { /* record but don't respond to break*/
1197 ctrlbrk(ignoreBreak); /* reinstall signal handler */
1198 /* redundant on BSD systems but essential */
1199 /* on POSIX and other systems */
1206 static sigProto(panic);
1207 static sigHandler(panic) { /* exit in a panic, on receipt of */
1208 everybody(EXIT); /* an unexpected signal */
1209 fprintf(stderr,"\nUnexpected signal\n");
1211 sigResume;/*NOTREACHED*/
1213 #endif /* !DONT_PANIC */
1216 BOOL WINAPI consoleHandler(DWORD dwCtrlType) {
1217 switch (dwCtrlType) { /* Allows Hugs to be terminated */
1218 case CTRL_CLOSE_EVENT : /* from the window's close menu. */
1225 static Void local installHandlers() { /* Install handlers for all fatal */
1226 /* signals except SIGINT and SIGBREAK*/
1228 SetConsoleCtrlHandler(consoleHandler,TRUE);
1230 #if !DONT_PANIC && !DOS
1232 signal(SIGABRT,panic);
1235 signal(SIGBUS,panic);
1238 signal(SIGFPE,panic);
1241 signal(SIGHUP,panic);
1244 signal(SIGILL,panic);
1247 signal(SIGQUIT,panic);
1250 signal(SIGSEGV,panic);
1253 signal(SIGTERM,panic);
1255 #endif /* !DONT_PANIC && !DOS */
1258 /* --------------------------------------------------------------------------
1260 * ------------------------------------------------------------------------*/
1262 static Bool local startEdit(line,nm) /* Start editor on file name at */
1263 Int line; /* given line. Both name and line */
1264 String nm; { /* or just line may be zero */
1265 static char editorCmd[FILENAME_MAX+1];
1268 if (hugsEdit && *hugsEdit) { /* Check that editor configured */
1270 /* On a Mac, files have creator information, telling which program
1271 to launch to, so an editor named to the empty string "" is often
1273 if (hugsEdit) { /* Check that editor configured */
1275 Int n = FILENAME_MAX;
1276 String he = hugsEdit;
1277 String ec = editorCmd;
1278 String rd = NULL; /* Set to nonnull to redo ... */
1280 for (; n>0 && *he && *he!=' ' && *he!='%'; n--)
1281 *ec++ = *he++; /* Copy editor name to buffer */
1282 /* assuming filename ends at space */
1284 if (nm && line && n>1 && *he){ /* Name, line, and enough space */
1285 rd = ec; /* save, in case we don't find name*/
1286 while (n>0 && *he) {
1288 if (*++he=='d' && n>10) {
1289 sprintf(ec,"%d",line);
1292 else if (*he=='s' && (size_t)n>strlen(nm)) {
1297 else if (*he=='%' && n>1) {
1301 else /* Ignore % char if not followed */
1302 *ec = '\0'; /* by one of d, s, or %, */
1303 for (; *ec && n>0; n--)
1305 } /* ignore % followed by anything other than d, s, or % */
1306 else { /* Copy other characters across */
1315 if (rd) { /* If file name was not included */
1320 if (nm && line==0 && n>1) { /* Name, but no line ... */
1322 for (; n>0 && *nm; n--) /* ... just copy file name */
1326 *ec = '\0'; /* Add terminating null byte */
1329 ERRMSG(0) "Hugs is not configured to use an editor"
1334 WinExec(editorCmd, SW_SHOW);
1337 if (shellEsc(editorCmd))
1338 Printf("Warning: Editor terminated abnormally\n");
1343 Int shellEsc(s) /* run a shell command (or shell) */
1346 return macsystem(s);
1350 s = fromEnv("SHELL","/bin/sh");
1357 #if RISCOS /* RISCOS also needs a chdir() */
1358 int chdir(char *s) { /* RISCOS PRM p. 885 -- JBS */
1359 return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
1361 #elif defined HAVE_PBHSETVOLSYNC /* Macintosh */
1362 int chdir(const char *s) {
1365 wd.ioCompletion = 0;
1366 str = (char*)malloc(strlen(s) + 1);
1367 if (str == 0) return -1;
1369 wd.ioNamePtr = C2PStr(str);
1372 errno = PBHSetVolSync(&wd);
1383 /*---------------------------------------------------------------------------
1384 * Printf-related operations:
1385 *-------------------------------------------------------------------------*/
1387 #if !defined(HAVE_VSNPRINTF)
1388 int vsnprintf(buffer, count, fmt, ap)
1393 #if defined(HAVE__VSNPRINTF)
1394 return _vsnprintf(buffer, count, fmt, ap);
1399 #endif /* HAVE_VSNPRINTF */
1401 #if !defined(HAVE_SNPRINTF)
1402 int snprintf(char* buffer, int count, const char* fmt, ...) {
1403 #if defined(HAVE__VSNPRINTF)
1405 va_list ap; /* pointer into argument list */
1406 va_start(ap, fmt); /* make ap point to first arg after fmt */
1407 r = vsnprintf(buffer, count, fmt, ap);
1408 va_end(ap); /* clean up */
1414 #endif /* HAVE_SNPRINTF */
1416 /* --------------------------------------------------------------------------
1417 * Read/write values from/to the registry
1419 * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
1420 * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key. (Machine entry is only used if
1421 * user entry doesn't exist).
1423 * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
1424 * ------------------------------------------------------------------------*/
1428 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
1430 static Bool local createKey ( HKEY, PHKEY, REGSAM );
1431 static Bool local queryValue ( HKEY, String, LPDWORD, LPBYTE, DWORD );
1432 static Bool local setValue ( HKEY, String, DWORD, LPBYTE, DWORD );
1434 static Bool local createKey(hKey, phRootKey, samDesired)
1437 REGSAM samDesired; {
1439 return RegCreateKeyEx(hKey, HugsRoot,
1440 0, "", REG_OPTION_NON_VOLATILE,
1441 samDesired, NULL, phRootKey, &dwDisp)
1445 static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
1454 if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
1457 LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
1458 RegCloseKey(hRootKey);
1459 return (res == ERROR_SUCCESS);
1463 static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
1472 if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
1475 LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
1476 RegCloseKey(hRootKey);
1477 return (res == ERROR_SUCCESS);
1481 static String local readRegString(key,regPath,var,def) /* read String from registry */
1486 static char buf[300];
1488 if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
1489 && type == REG_SZ) {
1496 static Int local readRegInt(var, def) /* read Int from registry */
1502 if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
1503 (LPBYTE)&buf, sizeof(buf))
1504 && type == REG_DWORD) {
1506 } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
1507 (LPBYTE)&buf, sizeof(buf))
1508 && type == REG_DWORD) {
1515 static Bool local writeRegString(var,val) /* write String to registry */
1521 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1522 REG_SZ, (LPBYTE)val, lstrlen(val)+1);
1525 static Bool local writeRegInt(var,val) /* write String to registry */
1528 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1529 REG_DWORD, (LPBYTE)&val, sizeof(val));
1532 #endif /* USE_REGISTRY */
1534 /* --------------------------------------------------------------------------
1535 * Things to do with the argv/argc and the env
1536 * ------------------------------------------------------------------------*/
1538 int nh_argc ( void )
1543 int nh_argvb ( int argno, int offset )
1545 return (int)(prog_argv[argno][offset]);
1548 /* --------------------------------------------------------------------------
1549 * Machine dependent control:
1550 * ------------------------------------------------------------------------*/
1552 Void machdep(what) /* Handle machine specific */
1553 Int what; { /* initialisation etc.. */
1556 case POSTPREL: break;
1557 case PREPREL : installHandlers();
1561 case EXIT : normalTerminal();
1566 /*-------------------------------------------------------------------------*/