* ========== Copyright Header Begin ==========================================
* Hypervisor Software File: wrapper.c
* Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
* - Do no alter or remove copyright notices
* - Redistribution and use of this software in source and binary forms, with
* or without modification, are permitted provided that the following
* - Redistribution of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
* - Redistribution in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* Neither the name of Sun Microsystems, Inc. or the names of contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
* This software is provided "AS IS," without a warranty of any kind.
* ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
* INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
* PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
* MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
* ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
* DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
* OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
* FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
* DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
* ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
* SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
* You acknowledge that this software is not designed, licensed or
* intended for use in the design, construction, operation or maintenance of
* ========== Copyright Header End ============================================
* @(#)wrapper.c 2.29 02/09/23
* Copyright 1985-1994 Bradley Forthware
* Copyright 2001-2002 Sun Microsystems, Inc. All Rights Reserved
* Use is subject to license terms.
* This is the C wrapper program for Forthmacs. There are 3 problems to
* solve in porting Forthmacs to a different machine.
* 1) What is the format of a binary file
* 2) How are I/O system calls invoked
* 3) At which address will the binary run (relocation)
* This C program finesses problems 1 and 2 by assuming that the C
* compiler/linker knows how to do those those things. The Forth
* interpreter itself is stored in a file whose format is system-independent.
* The C program mallocs an array, reads the Forth image into that array,
* and calls the array as a subroutine, passing it the address of another
* array containing entry points for I/O subroutines.
* The Forth interpreter relocates itself from a relocation bitmap
* which is part of the Forth image file.
static char sccsid
[] = "wrapper.c 2.4 91/07/25";
* Dynamic loader for Forth. This program reads in a binary image of
* a Forth system and executes it. It connects standard input to the
* Forth input stream (key and expect) and puts the Forth output stream
* (emit and type) on standard output.
* An array of entry points for system calls is provided to the Forth
* system, so that Forth doesn't have to know the details of how to
* forth [ -e dict-size ] [ -d <forth-binary>.dic ] [ -u ]
* dict-size is an optional decimal number specifying the number of
* kilobytes of dictionary extension space to allocate. The dictionary
* extension space is the amount that the dictionary may grow as a result
* of additional compilation, ALLOTing, etc. If the dict-size argument
* is omitted, a default value DEF_DICT is used.
* <forth-binary> is the name of the ".dic" file containing the forth binary
* image. The binary image is in a system-independent format, which contains
* a header, the relocatable program image, and a relocation bitmap.
* If there is no such argument, the default binary file DEF_EXE is used.
* The Forth system may determine whether the input stream is coming from
* a file or from standard input by calling the function "fileques()".
* This is useful for deciding whether or not to prompt if it is possible
* to redirect the input stream to a file.
* deprecate all syscalls above 45
extern long f_open(), f_creat();
extern long f_close(), f_read(), f_write();
extern int errno
; /* Wherever the error code goes */
extern long s_flushcache();
extern long f_init(), f_op(), f_move(), f_rows(), f_cols();
extern long printnum(), mmap(), close(), open();
extern long dlopen(), dlsym(), dlerror(), dlclose();
void error(char *str1
, char *str2
);
long save_image(/* char *name, header_t *header */);
long bootstrap(/* char *name */);
long includefile(/* char *name */);
long refill(/* char *adr, fd, actual not-eof? error? */);
#define UNIMPL(x) printf("%s:%d: Unimplemented syscall " #x "\n", \
long ((*functions
[])()) = {
f_open
, f_creat
, f_close
, f_read
,
f_write
, f_ioctl
, c_keyques
,
s_bye
, f_lseek
, f_unlink
, fileques
,
c_type
, c_expect
, syserror
,
s_flushcache
, pr_error
, emacs
,
f_init
, f_op
, f_move
, f_rows
, f_cols
,
printnum
, mmap
, open
, close
,
dlopen
, dlsym
, dlerror
, dlclose
,
* Functions which are the names of Unix system calls have the semantics
* of those Unix system calls.
* char c_key(); Gets next input character
* no echo or editing, don't wait for a newline.
* c_emit(char c); Outputs the character.
* long f_open(char *path, long mode); Opens a file.
* Mode must agree with wrsys.fth
* long f_creat(char *path, long mode); Creates a file.
* Mode must agree with wrsys.fth
* long f_read(long fd, char *buf, long cnt); Reads from a file
* long f_write(long fd, char *buf, long cnt); Writes to a file
* long f_ioctl(long fd, long code, char *buf); Is not used right now.
* long c_keyques(); True if a keystroke is pending.
* If you can't implement this, return false.
* s_bye(long status); Cleans up and exits.
* long f_lseek(long fd, long offset, long whence);Changes file position.
* Whence: 0 - from start of file 1 - from current pos. 2 - from end
* long f_unlink(char *path); Deletes a file.
* long fileques(); True if input stream has been
* redirected away from a keyboard.
* long c_type(long len, char *addr); Outputs len characters.
* long c_expect(long max, char *buffer); Reads an edited line of input.
* long c_cr(); Advances to next line.
* long f_crstr() Returns file line terminator.
* long syserror(); Error code from the last
extern void exit_handler();
extern void cont_handler();
extern void stop_handler();
char sccs_get_cmd
[128]; /* sccs get command string */
int uflag
= 0; /* controls auto execution of sccs get */
int vflag
= 0; /* controls reporting of file names */
int xref_enable_forward_refs
= 0;
int compile_warnings
= 0;
* Execute the MicroEmacs editor.
extern char *emacs_main();
char *fake_argv
[] = { "micro-emacs", "dontexit", 0 };
eret
= emacs_main(2, fake_argv
, genvp
);
"Forth [flags] [forth-flags]\n"
"[Flags] may be some of:\n"
" -d <file> : use dictionary <file>\n"
" -e <Kb> : set dictionary extent\n"
" -L : little endian mode"
" -D <symbol> : define <symbol>, value follows optional =\n"
" -U <symbol> : undefine <symbol>\n"
" -S : show all defined symbols at exit\n"
" -F : enable forward XREF definitions (metacompiler)\n"
" -u : enable SCCS get\n"
" -x <file> : Xref save to <file>\n"
" Any flag not recognised above terminates the argument parsing; it and\n"
" all subsequent args will be passed to the forth engine, all forth flags\n"
" must therefore appear after the wrapper flags\n"
" # forth -e 900 -d ${BP}/fm/kernel/sparc/k32t32.dic -x forth.xref\n"
" Which translates to: Run 32bit forth with 32bit tokens, \n"
" extend dictionary to 900KB, using forth.xref as the reference index file\n"
create_xref_symbol(char *name
, char *value
)
tstr
= malloc(strlen(name
) + strlen(value
) + 2);
/* set the default limit */
sprintf(tstr
, "%s=%s", name
, value
);
undef_symbol(name
, CMD_UNDEF
);
define_symbol(tstr
, CMD_DEFINE
);
main(int argc
, char *argv
[], char *envp
)
long dictsize
, extrasize
, imagesize
;
* We only look at the last 5 characters of the name in case
* the path name was explicitly specified, e.g. /usr/bin/emacs
if ((strlen(progname
) >= 5) &&
(strcmp(substr(progname
, -5, 5), "emacs") == 0)) {
emacs_main(argc
, argv
, envp
);
fargv
= malloc(((argc
+5) * sizeof (char *)));
memset(fargv
, 0, ((argc
+5) * sizeof (char *)));
fargv
[fargc
++] = argv
[0];
while ((extraargs
== 0) &&
((c
= getopt(argc
, argv
, "he:d:Luvx:X:r:l:D:U:SF")) != EOF
))
create_xref_symbol("XREF-FILE", optarg
);
define_symbol(optarg
, CMD_DEFINE
);
undef_symbol(optarg
, CMD_UNDEF
);
xref_enable_forward_refs
= 1;
if (extraargs
|| (argc
- optind
)) {
if (extraargs
== 0) extraargs
= optind
;
while (extraargs
< argc
) {
fargv
[fargc
++] = argv
[extraargs
++];
for (i
= 0; i
< fargc
; i
++) {
printf("Farg[%d] = %s\n", i
, fargv
[i
]);
if ((input_args
& 1) == 0) {
printf("Warning: falling back to default dictionary: %s\n",
/* Open file for reading */
if ((f
= path_open(dictfile
)) < 0) {
error("forth: Can't open dictionary file ", dictfile
);
strcpy(sccs_get_cmd
, "sccs ");
if (getenv("SCCSFLAGS") != NULL
)
strcat(sccs_get_cmd
, getenv("SCCSFLAGS"));
strcat(sccs_get_cmd
, " get ");
if (getenv("SCCSGETFLAGS") == NULL
)
strcat(sccs_get_cmd
, " -s");
strcat(sccs_get_cmd
, getenv("SCCSGETFLAGS"));
strcat(sccs_get_cmd
, " ");
* Read just the header into a separate buffer,
* use it to find the size of text+data+bss, allocate that
* much memory plus sizeof(header), copy header to the
* new place, then read the rest of the file.
if (f_read(f
, (char *)&header
, (long)sizeof (header
)) !=
error("forth: Can't read dictionary file header", "");
* Determine the dictionary growth size.
* First priority: command line specification
* Second priority: h_blen header field
extrasize
= header
.h_blen
? header
.h_blen
: DEF_DICT
;
extrasize
= (long)extrak
* 1024L;
/* imagesize is the number of bytes to read from the file */
imagesize
= header
.h_tlen
+ header
.h_dlen
+ header
.h_trlen
+ header
.h_drlen
;
/* dictsize is the total amount of dictionary memory to allocate */
dictsize
= sizeof (header
) + imagesize
+ extrasize
;
dictsize
= ROUNDUP(dictsize
, DICT_SIZE_ALIGNMENT
);
loadaddr
= (char *)getmem(dictsize
);
memcpy(loadaddr
, &header
, sizeof (header
));
if (f_read(f
, loadaddr
+sizeof (header
), imagesize
) != imagesize
) {
error("forth: The dictionary file is too short", "");
simulate(sizeof (functions
)/sizeof (void *), loadaddr
,
(long)loadaddr
+dictsize
, functions
, fargc
, fargv
);
signal(SIGHUP
, exit_handler
);
signal(SIGINT
, exit_handler
);
signal(SIGILL
, exit_handler
);
signal(SIGIOT
, exit_handler
);
signal(SIGTRAP
, exit_handler
);
signal(SIGFPE
, exit_handler
);
signal(SIGEMT
, exit_handler
);
signal(SIGBUS
, exit_handler
);
signal(SIGSEGV
, exit_handler
);
signal(SIGSYS
, exit_handler
);
signal(SIGCONT
, cont_handler
);
signal(SIGTSTP
, stop_handler
);
s_flushcache(); /* We're about to execute data! */
* Call the Forth interpreter as a subroutine. If it returns,
* exit with its return value as the status code.
simulate(0, loadaddr
+sizeof (header
),
loadaddr
, functions
, ((long)loadaddr
+dictsize
- 16) & ~15,
argc
, argv
, little_endian
);
s_bye((*(long (*)())(loadaddr
+sizeof (header
)))
(loadaddr
, functions
, (long)loadaddr
+dictsize
, fargc
, fargv
));
* If the input string contains only decimal digits, returns the base 10
* number represented by that digit string. Otherwise returns -1.
if ((digit
< 0) || (digit
> 9))
* Returns true if a key has been typed on the keyboard since the last
if ((nchars
= stdin
->_r
) == 0) {
nchars
= read(0, c
, 1) > 0;
nchars
= read(0, c
, 1) > 0;
* Get the next character from the input stream.
* There is a minor problem under Regulus relating to interrupted system
* calls. If the user types the INTERRUPT character (e.g. DEL) while
* Forth is waiting for input, the read system call will be interrupted.
* Forth will field the signal thus generated, save the state, and return
* to the Forth interpreter. If the user then tries to restart from the
* saved state, the restarted system call will return 0, which is the same
* code that is returned for end-of-file. This is especially nasty when
* using the Regulus standard-I/O package, because when it see the 0-length
* read, it set a flag in the stdio file descriptor and returns EOF
* forevermore. What we really want to happen is for the read system call
* to restart cleanly and continue waiting for input, rather than returning
if ((c
= getc(stdin
)) != EOF
)
* Send the character c to the output stream.
* This routine is called by the Forth system to determine whether
* its input stream is connected to a file or to a terminal.
* It uses this information to decide whether or not to
* prompt at the beginning of a line. If you are running in an environment
* where input cannot be redirected away from the terminal, just return 0L.
return (!isatty(fileno(stdin
)));
* Get at least "size" bytes of memory, returning the starting address
start
= (char *)sbrk(size
+DICT_ORIGIN_ALIGNMENT
+DICT_HEADER_SIZE
);
if (start
== (char *)-1) {
error("forth: couldn't get memory", "");
return ((char *)((ulong_t
)
ROUNDUP(start
+DICT_HEADER_SIZE
, DICT_ORIGIN_ALIGNMENT
)
tcgetattr(0, &ostate
); /* save old state */
tcgetattr(0, &lstate
); /* base of line state */
lstate
.c_iflag
|= IXON
|IXANY
|IXOFF
; /* XON/XOFF */
lstate
.c_iflag
|= ICRNL
; /* CR/NL munging */
lstate
.c_iflag
&= ~(IUCLC
); /* no case folding */
/* Always turning on ONLCR is safe, but it is a pain in an EMACS window */
lstate
.c_oflag
|= OPOST
|ONLCR
; /* Map NL to CR-LF */
lstate
.c_oflag
&= ~(OLCUC
); /* No case folding */
lstate
.c_oflag
&= ~(OCRNL
|ONLRET
); /* Don't swap cr and lf */
lstate
.c_lflag
|= ICANON
|ECHO
; /* Line editing on */
lstate
.c_cc
[VMIN
] = 1; /* Don't hold up input */
lstate
.c_cc
[VTIME
] = 0; /* No input delay */
tcgetattr(0, &kstate
); /* base of key state */
kstate
.c_iflag
&= ~(IXON
|IXANY
|IXOFF
); /* no XON/XOFF */
kstate
.c_iflag
&= ~(INLCR
|ICRNL
); /* no CR/NL munging */
kstate
.c_iflag
&= ~(IUCLC
); /* no case folding */
/* Always turning on ONLCR is safe, but it is a pain in an EMACS window */
kstate
.c_oflag
|= OPOST
|ONLCR
; /* Map NL to CR-LF */
kstate
.c_oflag
&= ~(OLCUC
); /* No case folding */
kstate
.c_oflag
&= ~(OCRNL
|ONLRET
); /* Don't swap cr and lf */
kstate
.c_oflag
|= OPOST
; /* */
kstate
.c_lflag
&= ~(ICANON
|ECHO
); /* No editing characters */
kstate
.c_cc
[VMIN
] = 1; /* Don't hold up input */
kstate
.c_cc
[VTIME
] = 0; /* No input delay */
kqstate
.c_cc
[VMIN
] = 0; /* Poll for character */
tcsetattr(0, TCSANOW
, &lstate
);
tcsetattr(0, TCSANOW
, &kqstate
);
tcsetattr(0, TCSANOW
, &kstate
);
tcsetattr(0, TCSANOW
, &ostate
);
* Get an edited line of input from the keyboard, placing it at buffer.
* At most "max" characters will be placed in the buffer.
* The line terminator character is not stored in the buffer.
c_expect(long max
, char *buffer
)
while (max
-- && ((c
= getc(stdin
)) != '\n') && (c
!= EOF
))
return ((long)(p
- buffer
));
* Send len characters from the buffer at addr to the output stream.
c_type(long len
, char *addr
)
* Sends an end-of-line sequence to the output stream.
* Returns the end-of-line sequence that is used within files as
* a packed (leading count byte) string.
finish_symbols(show_symbols
); /* display? */
finish_symbols(0); /* force a free if not already done */
if (compile_msgs
|| compile_errors
) {
"%s: Compile completed with "
"%d messages, %d warnings, %d errors\n",
(compile_errors
? "ERROR" : "NOTICE"),
compile_msgs
, compile_warnings
, compile_errors
);
exit((int)(code
|compile_errors
));
* Display the two strings, followed by an newline, on the error output
error(char *str1
, char *str2
)
write(2, str1
, strlen(str1
));
write(2, str2
, strlen(str2
));
/* Find the error code returned by the last failing system call. */
/* Display an error message */
f_open(char *name
, long flag
, long mode
)
printf("File: %s\n", name
);
name
= expand_name(name
);
if (isobsolete(name
) == 1)
s_system(sccs_get(name
));
return ((long)open(name
, (int)flag
, (int)mode
));
f_creat(char *name
, long mode
)
name
= expand_name(name
);
return ((long)open(name
, O_RDWR
|O_CREAT
|O_TRUNC
, (int)mode
));
f_read(long fd
, char *buf
, long cnt
)
return (read((int)fd
, buf
, cnt
));
f_write(long fd
, char *buf
, long cnt
)
return (write((int)fd
, buf
, cnt
));
return ((long)close((int)fd
));
return ((long)unlink(name
));
f_lseek(long fd
, long offset
, long flag
)
return (lseek((int)fd
, offset
, (int)flag
));
f_ioctl(long fd
, long code
, char *buf
)
return ((long)ioctl((int)fd
, (int)code
, buf
));
s_signal(long signo
, void (*adr
)())
return ((long)signal((int)signo
, (void (*)())adr
));
return ((long)chdir(str
));
return ((long)getcwd(buf
, MAXPATHLEN
));
#define bzero(b, n) (void *)memset(b, 0, n)
if (r
) bzero((char *)r
, size
);
m_free(long size
, char *adr
)
return ((long)sbrk(size
));
return ((long)getenv(str
));
extern struct tm
*localtime();
return ((long)localtime(&tadd
));
static struct timezone tz
;
extern int gettimeofday();
return ((long)tz
.tz_minuteswest
);
return ((long)480); /* Assume PST */
/* Return a string representing the name of the time zone */
return ((long)""); /* Regulus doesn't seem to have this */
* Flush the data cache if necessary and possible. Used after writing
* instructions into the dictionary.
* Tries to open the named file looking in each directory of the
* search path specified by the environment variable FTHPATH.
* Returns file descriptor or -1 if not found
path
= getenv("FTHPATH");
lpath
= (*fn
== '/') ? "" : path
;
while (*lpath
&& *lpath
!= ':')
executable(char *filename
) /* True if file is executable */
return ((stat(filename
, &stbuf
) == 0) &&
((stbuf
.st_mode
& S_IFMT
) == S_IFREG
) &&
(access(filename
, 1) == 0));
/* Find fname for symbol table */
if ((*cp
== ':') || (*progname
== '/')) {
if (executable(progname
)) {
/* copy over current directory and then append progname */
while ((*cp
!= 0) && (*cp
!= ':')) {
if (!executable(buf
)) continue;
substr(char *str
, int pos
, int n
)
strncpy(outstr
, str
+ pos
- 1, n
);
static char sccsname
[512];
/* Find the beginning of the last filename component */
if ((p
= strrchr(name
, '/')) == NULL
)
strcpy(sccsname
, name
); /* Copy whole path */
strcpy(sccsname
+dirlen
, "SCCS/s."); /* Merge in "SCCS/s." */
strcat(sccsname
, p
); /* Put filename back */
* file | SCCS | obsolete (return value)
* -----+------+------------------------
* Y | Y | ? (SCCS > file)
struct stat status
, sccsstatus
;
file
= stat(name
, &status
);
sccsfile
= stat(sccs_name(name
), &sccsstatus
);
/* If the file is missing, it is deemed "obsolete" */
return (-1); /* Both file and SCCS file missing */
return (1); /* file missing, SCCS file is there */
return (0); /* file is there, no SCCS file */
else /* Both exist, compare times */
return ((sccsstatus
.st_mtime
> status
.st_mtime
) ? 1 : 0);
strcpy(str
, sccs_get_cmd
);
char envvar
[64], *fnamep
, *envp
, paren
;
static char fullname
[256];
if ((*fnamep
== '{') || (*fnamep
== '(')) {
/* multi char env variable */
envvar
[ndx
++] = *(fnamep
++);
while ((*fnamep
!= paren
) && (ndx
< 64) &&
envvar
[ndx
++] = *(fnamep
++);
/* single char env. var. */
envvar
[ndx
++] = *(fnamep
++);
if (ndx
> 0 && (envp
= getenv(envvar
)) != NULL
) {
strcat(fullname
, fnamep
);
printf("Can't find environment variable %s in %s\n",
find_next(int tshift
, int token_size
, int origin
, char *link
, char *str
)
link
= (char *)((*(unsigned long *)(link
)) +(origin
));
link
= (char *)((*(unsigned short *)(link
) << tshift
) +(origin
));
while (link
!= (char *)origin
) {
namep
= link
- token_size
- 1;
nextlen
= (*namep
) & 0x1f;
if (*(namep
++) != *(p
++))
return (((long)link
)-token_size
);
link
= (char *)((*(unsigned long *)(link
-token_size
))
link
= (char *)((*(unsigned short *)(link
-token_size
)
extern fstackp ((*sfunctions
[])(fstackp
));
fstackp stack
= (fstackp
)p
;
printf("fsyscall: %x\n", fsyscall
);
printf("fptr: %x\n", sfunctions
[fsyscall
]);
return ((long)((sfunctions
[fsyscall
])(stack
)));
printf("tos = %x, tos-1 = %x, tos-2 = %x\n", a
, b
, c
);