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/24 14:32:03 $
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 static Void installHandlers ( void ) { /* Install handlers for all fatal */
1170 /* signals except SIGINT and SIGBREAK*/
1172 SetConsoleCtrlHandler(consoleHandler,TRUE);
1174 #if !DONT_PANIC && !DOS
1176 signal(SIGABRT,panic);
1179 signal(SIGBUS,panic);
1182 signal(SIGFPE,panic);
1185 signal(SIGHUP,panic);
1188 signal(SIGILL,panic);
1191 signal(SIGQUIT,panic);
1194 signal(SIGSEGV,panic);
1197 signal(SIGTERM,panic);
1199 #endif /* !DONT_PANIC && !DOS */
1202 /* --------------------------------------------------------------------------
1204 * ------------------------------------------------------------------------*/
1206 static Bool local startEdit(line,nm) /* Start editor on file name at */
1207 Int line; /* given line. Both name and line */
1208 String nm; { /* or just line may be zero */
1209 static char editorCmd[FILENAME_MAX+1];
1212 if (hugsEdit && *hugsEdit) { /* Check that editor configured */
1214 /* On a Mac, files have creator information, telling which program
1215 to launch to, so an editor named to the empty string "" is often
1217 if (hugsEdit) { /* Check that editor configured */
1219 Int n = FILENAME_MAX;
1220 String he = hugsEdit;
1221 String ec = editorCmd;
1222 String rd = NULL; /* Set to nonnull to redo ... */
1224 for (; n>0 && *he && *he!=' ' && *he!='%'; n--)
1225 *ec++ = *he++; /* Copy editor name to buffer */
1226 /* assuming filename ends at space */
1228 if (nm && line && n>1 && *he){ /* Name, line, and enough space */
1229 rd = ec; /* save, in case we don't find name*/
1230 while (n>0 && *he) {
1232 if (*++he=='d' && n>10) {
1233 sprintf(ec,"%d",line);
1236 else if (*he=='s' && (size_t)n>strlen(nm)) {
1241 else if (*he=='%' && n>1) {
1245 else /* Ignore % char if not followed */
1246 *ec = '\0'; /* by one of d, s, or %, */
1247 for (; *ec && n>0; n--)
1249 } /* ignore % followed by anything other than d, s, or % */
1250 else { /* Copy other characters across */
1259 if (rd) { /* If file name was not included */
1264 if (nm && line==0 && n>1) { /* Name, but no line ... */
1266 for (; n>0 && *nm; n--) /* ... just copy file name */
1270 *ec = '\0'; /* Add terminating null byte */
1273 ERRMSG(0) "Hugs is not configured to use an editor"
1278 WinExec(editorCmd, SW_SHOW);
1281 if (shellEsc(editorCmd))
1282 Printf("Warning: Editor terminated abnormally\n");
1287 Int shellEsc(s) /* run a shell command (or shell) */
1290 return macsystem(s);
1294 s = fromEnv("SHELL","/bin/sh");
1301 #if RISCOS /* RISCOS also needs a chdir() */
1302 int chdir(char *s) { /* RISCOS PRM p. 885 -- JBS */
1303 return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
1305 #elif defined HAVE_PBHSETVOLSYNC /* Macintosh */
1306 int chdir(const char *s) {
1309 wd.ioCompletion = 0;
1310 str = (char*)malloc(strlen(s) + 1);
1311 if (str == 0) return -1;
1313 wd.ioNamePtr = C2PStr(str);
1316 errno = PBHSetVolSync(&wd);
1327 /*---------------------------------------------------------------------------
1328 * Printf-related operations:
1329 *-------------------------------------------------------------------------*/
1331 #if !defined(HAVE_VSNPRINTF)
1332 int vsnprintf(buffer, count, fmt, ap)
1337 #if defined(HAVE__VSNPRINTF)
1338 return _vsnprintf(buffer, count, fmt, ap);
1343 #endif /* HAVE_VSNPRINTF */
1345 #if !defined(HAVE_SNPRINTF)
1346 int snprintf(char* buffer, int count, const char* fmt, ...) {
1347 #if defined(HAVE__VSNPRINTF)
1349 va_list ap; /* pointer into argument list */
1350 va_start(ap, fmt); /* make ap point to first arg after fmt */
1351 r = vsnprintf(buffer, count, fmt, ap);
1352 va_end(ap); /* clean up */
1358 #endif /* HAVE_SNPRINTF */
1360 /* --------------------------------------------------------------------------
1361 * Read/write values from/to the registry
1363 * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
1364 * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key. (Machine entry is only used if
1365 * user entry doesn't exist).
1367 * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
1368 * ------------------------------------------------------------------------*/
1372 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
1374 static Bool local createKey ( HKEY, PHKEY, REGSAM );
1375 static Bool local queryValue ( HKEY, String, LPDWORD, LPBYTE, DWORD );
1376 static Bool local setValue ( HKEY, String, DWORD, LPBYTE, DWORD );
1378 static Bool local createKey(hKey, phRootKey, samDesired)
1381 REGSAM samDesired; {
1383 return RegCreateKeyEx(hKey, HugsRoot,
1384 0, "", REG_OPTION_NON_VOLATILE,
1385 samDesired, NULL, phRootKey, &dwDisp)
1389 static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
1398 if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
1401 LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
1402 RegCloseKey(hRootKey);
1403 return (res == ERROR_SUCCESS);
1407 static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
1416 if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
1419 LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
1420 RegCloseKey(hRootKey);
1421 return (res == ERROR_SUCCESS);
1425 static String local readRegString(key,regPath,var,def) /* read String from registry */
1430 static char buf[300];
1432 if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
1433 && type == REG_SZ) {
1440 static Int local readRegInt(var, def) /* read Int from registry */
1446 if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
1447 (LPBYTE)&buf, sizeof(buf))
1448 && type == REG_DWORD) {
1450 } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
1451 (LPBYTE)&buf, sizeof(buf))
1452 && type == REG_DWORD) {
1459 static Bool local writeRegString(var,val) /* write String to registry */
1465 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1466 REG_SZ, (LPBYTE)val, lstrlen(val)+1);
1469 static Bool local writeRegInt(var,val) /* write String to registry */
1472 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1473 REG_DWORD, (LPBYTE)&val, sizeof(val));
1476 #endif /* USE_REGISTRY */
1478 /* --------------------------------------------------------------------------
1479 * Things to do with the argv/argc and the env
1480 * ------------------------------------------------------------------------*/
1482 int nh_argc ( void )
1487 int nh_argvb ( int argno, int offset )
1489 return (int)(prog_argv[argno][offset]);
1492 /* --------------------------------------------------------------------------
1493 * Machine dependent control:
1494 * ------------------------------------------------------------------------*/
1496 Void machdep(what) /* Handle machine specific */
1497 Int what; { /* initialisation etc.. */
1500 case POSTPREL: break;
1501 case PREPREL : installHandlers();
1505 case EXIT : normalTerminal();
1510 /*-------------------------------------------------------------------------*/