/*
* @implemented
*/
HWND WINAPI
FindWindowExW(HWND hwndParent,
HWND hwndChildAfter,
LPCWSTR lpszClass,
LPCWSTR lpszWindow)
{
UNICODE_STRING ucClassName, *pucClassName = NULL;
UNICODE_STRING ucWindowName, *pucWindowName = NULL;
if (IS_ATOM(lpszClass))
{
ucClassName.Length = 0;
ucClassName.Buffer = (LPWSTR)lpszClass;
pucClassName = &ucClassName;
}
else if (lpszClass != NULL)
{
RtlInitUnicodeString(&ucClassName,
lpszClass);
pucClassName = &ucClassName;
}
if (lpszWindow != NULL)
{
RtlInitUnicodeString(&ucWindowName,
lpszWindow);
pucWindowName = &ucWindowName;
}
return NtUserFindWindowEx(hwndParent,
hwndChildAfter,
pucClassName,
pucWindowName,
0);
}
LPCWSTR
FASTCALL
ClassNameToVersion(
LPCTSTR lpszClass,
LPCWSTR lpszMenuName,
LPCWSTR *plpLibFileName,
HANDLE *pContext,
BOOL bAnsi)
{
NTSTATUS Status;
UNICODE_STRING SectionName;
WCHAR SeactionNameBuf[MAX_PATH] = {0};
ACTCTX_SECTION_KEYED_DATA KeyedData = { sizeof(KeyedData) };
if (IS_ATOM(lpszClass))
{
SectionName.Buffer = (LPWSTR)&SeactionNameBuf;
SectionName.MaximumLength = sizeof(SeactionNameBuf);
if(!NtUserGetAtomName(LOWORD((DWORD_PTR)lpszClass), &SectionName))
{
return NULL;
}
}
else
{
if (bAnsi)
{
RtlCreateUnicodeStringFromAsciiz(&SectionName, (LPSTR)lpszClass);
}
else
{
RtlInitUnicodeString(&SectionName, lpszClass);
}
}
Status = RtlFindActivationContextSectionString( FIND_ACTCTX_SECTION_KEY_RETURN_HACTCTX,
NULL,
ACTIVATION_CONTEXT_SECTION_WINDOW_CLASS_REDIRECTION,
&SectionName,
&KeyedData );
if (NT_SUCCESS(Status) && KeyedData.ulDataFormatVersion == 1)
{
struct dll_redirect *dll = KeyedData.lpSectionBase;
if (plpLibFileName) *plpLibFileName = dll->name;
if (lpszMenuName)
{
WCHAR * mnubuf;
LPWSTR mnuNameW;
LPSTR mnuNameA;
int len = 0;
struct entity *entity = KeyedData.lpData;
FIXME("actctx: Needs to support menu name from redirected class!");
if (entity->clsid)
{
mnubuf = entity->clsid;
if (bAnsi)
{
mnuNameA = (LPSTR)lpszMenuName;
RtlUnicodeToMultiByteN( mnuNameA, 255, (PULONG)&len, mnubuf, strlenW(mnubuf) * sizeof(WCHAR) );
mnuNameA[len] = 0;
}
else
{
mnuNameW = (LPWSTR)lpszMenuName;
len = strlenW(mnubuf) * sizeof(WCHAR);
RtlCopyMemory((void *)mnuNameW, mnubuf, len);
mnuNameW[len] = 0;
}
}
}
if (pContext) *pContext = KeyedData.hActCtx;
}
if (!IS_ATOM(lpszClass) && bAnsi)
RtlFreeUnicodeString(&SectionName);
if (KeyedData.hActCtx)
RtlReleaseActivationContext(KeyedData.hActCtx);
return lpszClass;
}
term_t
eval_term(struct lisp0_state*state,term_t term){
X = term;
CALL(L_eval);
return X;
L_eval:
if(IS_ERROR(X)){
RETURN(X);
}
if(IS_ATOM(X)){
RETURN(subst(ENV,X));
}
if(!IS_LIST(X)){
RETURN(ERR(E_BAD_EXPR));
}
PUSH(CDR(X));
X = CAR(X);
CALL(L_eval);
Y = POP();
switch(TAG(X)){
case TAG_ERROR: RETURN(X);
case TAG_PRIMITIVE:
switch(VALUE(X)){
case PRIM_QUOTE: goto L_quote;
case PRIM_ATOM: goto L_atom;
case PRIM_EQ: goto L_eq;
case PRIM_COND: goto L_cond;
case PRIM_CAR: goto L_car;
case PRIM_CDR: goto L_cdr;
case PRIM_CONS: goto L_cons;
case PRIM_LABEL: goto L_label;
case PRIM_LAMBDA: goto L_lambda;
case PRIM_MACRO: goto L_macro;
default: break;
};
break;
case TAG_POINTER:
if(!X) break;
switch(PTAG(X)){
case PTAG_LAMBDA: goto L_eval_lambda;
case PTAG_MACRO: goto L_eval_macro;
default: break;
};
default: break;
}
RETURN(ERR(E_NOT_CALLABLE));
L_quote:
PARSE_ARG1();
RETURN(X);
L_atom:
PARSE_AND_EVAL_ARG1();
RETURN(((!X)||IS_ATOM(X))?TRUE:FALSE);
L_eq:
PARSE_AND_EVAL_ARG2();
RETURN(eq(Y,X)?TRUE:FALSE);
L_cond:
PARSE_ARG();
PUSH(CDR(Y));
Y = CAR(Y);
PARSE_ARG2();
PUSH(Y);
CLEAR(Y);
CALL(L_eval);
Y = POP();
switch(X){
case TRUE:
X = Y;
CLEAR(Y);
goto L_eval;
case FALSE:
Y = POP();
goto L_cond;
default:
RETURN(ERR(E_COND_END));
};
L_car:
PARSE_AND_EVAL_ARG1();
if(!IS_LIST(X)){
RETURN(ERR(E_ARGUMENT));
}
RETURN(CAR(X));
L_cdr:
PARSE_AND_EVAL_ARG1();
if(!IS_LIST(X)){
RETURN(ERR(E_ARGUMENT));
}
RETURN(CDR(X));
L_cons:
PARSE_AND_EVAL_ARG2();
L_cons_1:
RETURN(cons(state,Y,X));
L_label:
PARSE_ARG2();
PUSH(X);
X = Y;
CLEAR(Y);
CALL(L_eval);
RETURN_ERROR(X);
Y = POP();
CALL(L_cons_1);
Y = X;
X = ENV;
CALL(L_cons_1);
ENV = X;
RETURN(CDR(CAR(ENV)));
L_lambda:
PARSE_ARG2();
RETURN(mklist(state,X,Y,PTAG_LAMBDA));
L_macro:
PARSE_ARG2();
RETURN(mklist(state,X,Y,PTAG_MACRO));
L_eval_lambda:
PUSH(X);
push_list_builder(state);
CALL(L_eval_list);
Y = pop_list_builder(state,NIL);
RETURN_ERROR(X);
X = POP();
PUSH(CDR(X));
X = CAR(X);
push_list_builder(state);
CALL(L_zip);
Y = POP();
PUSH(ENV);
ENV = pop_list_builder(state,ENV);
RETURN_ERROR(X);
X = Y;
CLEAR(Y);
CALL(L_eval);
RETURN_ERROR(ENV);
ENV = POP();
RETURN(X);
L_eval_list:
if(!Y){
RETURN(Y);
}
PARSE_ARG();
X = CAR(Y);
PUSH(CDR(Y));
CLEAR(Y);
CALL(L_eval);
RETURN_ERROR(X);
list_builder_add_term(state,X);
Y = POP();
goto L_eval_list;
L_eval_macro:
PUSH(CDR(X));
X = CAR(X);
push_list_builder(state);
CALL(L_zip);
Y = POP();
PUSH(ENV);
ENV = pop_list_builder(state,ENV);
RETURN_ERROR(X);
X = Y;
CLEAR(Y);
CALL(L_eval);
ENV = POP();
goto L_eval;
L_zip:
if((!X)||(!Y))
goto L_zip_finish;
RETURN_ERROR(X);
RETURN_ERROR(Y);
if(!IS_LIST(X)){
RETURN(ERR(E_IMPROPER_LIST));
}
if(!IS_LIST(Y)){
RETURN(ERR(E_IMPROPER_LIST));
}
list_builder_add_term(state,cons(state,CAR(X),CAR(Y)));
X = CDR(X);
Y = CDR(Y);
goto L_zip;
L_zip_finish:
if(X||Y){
RETURN(ERR(E_ARGUMENT));
}
RETURN(NIL);
}
BOOL FreeClass(PVOID ClassName)
{
return IS_ATOM(ClassName) ? TRUE : FreeMemoryP(ClassName);
}
PWSTR ClassMByteToWChar(PCSTR AnsiString)
{
return IS_ATOM(AnsiString) ? (PWSTR)AnsiString : MByteToWChar(AnsiString);
}
PSTR ClassWCharToMByte(PCWSTR Unicode)
{
return IS_ATOM(Unicode) ? (PSTR)Unicode : WCharToMByte(Unicode);
}
HWND WINAPI
User32CreateWindowEx(DWORD dwExStyle,
LPCSTR lpClassName,
LPCSTR lpWindowName,
DWORD dwStyle,
int x,
int y,
int nWidth,
int nHeight,
HWND hWndParent,
HMENU hMenu,
HINSTANCE hInstance,
LPVOID lpParam,
DWORD dwFlags)
{
LARGE_STRING WindowName;
LARGE_STRING lstrClassName, *plstrClassName;
UNICODE_STRING ClassName;
WNDCLASSEXA wceA;
WNDCLASSEXW wceW;
HMODULE hLibModule = NULL;
DWORD save_error;
BOOL Unicode, ClassFound = FALSE;
HWND Handle = NULL;
#if 0
DbgPrint("[window] User32CreateWindowEx style %d, exstyle %d, parent %d\n", dwStyle, dwExStyle, hWndParent);
#endif
if (!RegisterDefaultClasses)
{
TRACE("RegisterSystemControls\n");
RegisterSystemControls();
}
Unicode = !(dwFlags & NUCWE_ANSI);
if (IS_ATOM(lpClassName))
{
plstrClassName = (PVOID)lpClassName;
}
else
{
if(Unicode)
RtlInitUnicodeString(&ClassName, (PCWSTR)lpClassName);
else
{
if (!RtlCreateUnicodeStringFromAsciiz(&ClassName, (PCSZ)lpClassName))
{
SetLastError(ERROR_OUTOFMEMORY);
return (HWND)0;
}
}
/* Copy it to a LARGE_STRING */
lstrClassName.Buffer = ClassName.Buffer;
lstrClassName.Length = ClassName.Length;
lstrClassName.MaximumLength = ClassName.MaximumLength;
plstrClassName = &lstrClassName;
}
/* Initialize a LARGE_STRING */
RtlInitLargeString(&WindowName, lpWindowName, Unicode);
// HACK: The current implementation expects the Window name to be UNICODE
if (!Unicode)
{
NTSTATUS Status;
PSTR AnsiBuffer = WindowName.Buffer;
ULONG AnsiLength = WindowName.Length;
WindowName.Length = 0;
WindowName.MaximumLength = AnsiLength * sizeof(WCHAR);
WindowName.Buffer = RtlAllocateHeap(RtlGetProcessHeap(),
0,
WindowName.MaximumLength);
if (!WindowName.Buffer)
{
SetLastError(ERROR_OUTOFMEMORY);
goto cleanup;
}
Status = RtlMultiByteToUnicodeN(WindowName.Buffer,
WindowName.MaximumLength,
&WindowName.Length,
AnsiBuffer,
AnsiLength);
if (!NT_SUCCESS(Status))
{
goto cleanup;
}
}
if(!hMenu && (dwStyle & (WS_OVERLAPPEDWINDOW | WS_POPUP)))
{
if(Unicode)
{
wceW.cbSize = sizeof(WNDCLASSEXW);
if(GetClassInfoExW(hInstance, (LPCWSTR)lpClassName, &wceW) && wceW.lpszMenuName)
{
hMenu = LoadMenuW(hInstance, wceW.lpszMenuName);
}
}
else
{
wceA.cbSize = sizeof(WNDCLASSEXA);
if(GetClassInfoExA(hInstance, lpClassName, &wceA) && wceA.lpszMenuName)
{
hMenu = LoadMenuA(hInstance, wceA.lpszMenuName);
}
}
}
if (!Unicode) dwExStyle |= WS_EX_SETANSICREATOR;
for(;;)
{
Handle = NtUserCreateWindowEx(dwExStyle,
plstrClassName,
NULL,
&WindowName,
dwStyle,
x,
y,
nWidth,
nHeight,
hWndParent,
hMenu,
hInstance,
lpParam,
dwFlags,
NULL);
if (Handle) break;
if (!ClassFound)
{
save_error = GetLastError();
if ( save_error == ERROR_CANNOT_FIND_WND_CLASS )
{
ClassFound = VersionRegisterClass(ClassName.Buffer, NULL, NULL, &hLibModule);
if (ClassFound) continue;
}
}
if (hLibModule)
{
save_error = GetLastError();
FreeLibrary(hLibModule);
SetLastError(save_error);
hLibModule = 0;
}
break;
}
#if 0
DbgPrint("[window] NtUserCreateWindowEx() == %d\n", Handle);
#endif
cleanup:
if(!Unicode)
{
if (!IS_ATOM(lpClassName))
{
RtlFreeUnicodeString(&ClassName);
}
RtlFreeLargeString(&WindowName);
}
return Handle;
}
int _18main()
{
int argc, argv;
int _4586;
int _1, _2;
argv = Command_Line();
argc = SEQ_PTR(argv)->length;
RefDS(argv);
DeRef(_4Argv);
_4Argv = argv;
_4Argc = argc;
DeRefi(_4eudir);
_4eudir = EGetEnv(NewString("EUDIR"));
if (IS_ATOM(_4eudir)) {
if (_4ELINUX) {
/* eudir = getenv("HOME") */
DeRefi(_4eudir);
_4eudir = EGetEnv(_4592);
if (IS_ATOM(_4eudir)) {
/* eudir = "euphoria" */
RefDS(_4595);
DeRefi(_4eudir);
_4eudir = _4595;
}
else {
/* eudir = eudir & "/euphoria" */
Concat((object_ptr)&_4eudir, _4eudir, (s1_ptr)_4596);
}
}
else {
/* eudir = "\\EUPHORIA" */
RefDS(_4598);
DeRefi(_4eudir);
_4eudir = _4598;
}
}
/* TempErrName = "ex.err" */
RefDS(_4602);
DeRefi(_6TempErrName);
_6TempErrName = _4602;
_11src_file = _18ProcessOptions();
if (_11src_file == -1) {
/* Can't open %s\n */
err_add(NewString("Can't open "));
err_add(SEQ_PTR(_4file_name)->base[1]);
err_add(NewString("\n"));
/* Output to screen and cleanup. Too early for set_err_stack. */
_6screen_output(2, error_stack);
_6Cleanup(1);
}
/* main_path = full_path(file_name[1]) */
DeRef(_4586);
_2 = (int)SEQ_PTR(_4file_name);
_4586 = (int)*(((s1_ptr)_2)->base + 1);
RefDS(_4586);
RefDS(_4586);
DeRef(_11main_path);
_11main_path = _11get_file_path(_4586);
_15InitGlobals();
_10InitSymTab();
_14InitEmit();
_15InitParser();
_11InitLex();
_11read_line();
_15parser();
_17BackEnd(); /* Call the backend (be_*.c files) */
_6Cleanup(0);
DeRef(argv);
DeRef(_4586);
return 0;
}
object call_c(int func, object proc_ad, object arg_list)
/* Call a WIN32 or Linux C function in a DLL or shared library.
Alternatively, call a machine-code routine at a given address. */
{
volatile unsigned long arg; // !!!! magic var to push values on the stack
volatile int argsize; // !!!! number of bytes to pop
s1_ptr arg_list_ptr, arg_size_ptr;
object_ptr next_arg_ptr, next_size_ptr;
object next_arg, next_size;
int iresult, i;
double dbl_arg, dresult;
float flt_arg, fresult;
unsigned long size;
int proc_index;
int cdecl_call;
int (*int_proc_address)();
unsigned return_type;
char NameBuff[100];
// Setup and Check for Errors
proc_index = get_pos_int("c_proc/c_func", proc_ad);
if ((unsigned)proc_index >= c_routine_next) {
sprintf(TempBuff, "c_proc/c_func: bad routine number (%d)", proc_index);
RTFatal(TempBuff);
}
int_proc_address = c_routine[proc_index].address;
#if defined(EWINDOWS) && !defined(EWATCOM)
cdecl_call = c_routine[proc_index].convention;
#endif
if (IS_ATOM(arg_list)) {
RTFatal("c_proc/c_func: argument list must be a sequence");
}
arg_list_ptr = SEQ_PTR(arg_list);
next_arg_ptr = arg_list_ptr->base + arg_list_ptr->length;
// only look at length of arg size sequence for now
arg_size_ptr = c_routine[proc_index].arg_size;
next_size_ptr = arg_size_ptr->base + arg_size_ptr->length;
return_type = c_routine[proc_index].return_size; // will be INT
if (func && return_type == 0 || !func && return_type != 0) {
if (c_routine[proc_index].name->length < 100)
MakeCString(NameBuff, MAKE_SEQ(c_routine[proc_index].name));
else
NameBuff[0] = '\0';
sprintf(TempBuff, func ? "%s does not return a value" :
"%s returns a value",
NameBuff);
RTFatal(TempBuff);
}
if (arg_list_ptr->length != arg_size_ptr->length) {
if (c_routine[proc_index].name->length < 100)
MakeCString(NameBuff, MAKE_SEQ(c_routine[proc_index].name));
else
NameBuff[0] = '\0';
sprintf(TempBuff, "C routine %s() needs %d argument%s, not %d",
NameBuff,
arg_size_ptr->length,
(arg_size_ptr->length == 1) ? "" : "s",
arg_list_ptr->length);
RTFatal(TempBuff);
}
argsize = arg_list_ptr->length << 2;
// Push the Arguments
for (i = 1; i <= arg_list_ptr->length; i++) {
next_arg = *next_arg_ptr--;
next_size = *next_size_ptr--;
if (IS_ATOM_INT(next_size))
size = INT_VAL(next_size);
else if (IS_ATOM(next_size))
size = (unsigned long)DBL_PTR(next_size)->dbl;
else
RTFatal("This C routine was defined using an invalid argument type");
if (size == C_DOUBLE || size == C_FLOAT) {
/* push 8-byte double or 4-byte float */
if (IS_ATOM_INT(next_arg))
dbl_arg = (double)next_arg;
else if (IS_ATOM(next_arg))
dbl_arg = DBL_PTR(next_arg)->dbl;
else {
arg = arg+argsize+9999; // 9999 = 270f hex - just a marker for asm code
RTFatal("arguments to C routines must be atoms");
}
if (size == C_DOUBLE) {
arg = *(1+(unsigned long *)&dbl_arg);
push(); // push high-order half first
argsize += 4;
arg = *(unsigned long *)&dbl_arg;
push(); // don't combine this with the push() below - Lcc bug
}
else {
/* C_FLOAT */
flt_arg = (float)dbl_arg;
arg = *(unsigned long *)&flt_arg;
push();
}
}
else {
/* push 4-byte integer */
if (size >= E_INTEGER) {
if (IS_ATOM_INT(next_arg)) {
if (size == E_SEQUENCE)
RTFatal("passing an integer where a sequence is required");
}
else {
if (IS_SEQUENCE(next_arg)) {
if (size != E_SEQUENCE && size != E_OBJECT)
RTFatal("passing a sequence where an atom is required");
}
else {
if (size == E_SEQUENCE)
RTFatal("passing an atom where a sequence is required");
}
RefDS(next_arg);
}
arg = next_arg;
push();
}
else if (IS_ATOM_INT(next_arg)) {
arg = next_arg;
push();
}
else if (IS_ATOM(next_arg)) {
// atoms are rounded to integers
arg = (unsigned long)DBL_PTR(next_arg)->dbl; //correct
// if it's a -ve f.p. number, Watcom converts it to int and
// then to unsigned int. This is exactly what we want.
// Works with the others too.
push();
}
else {
arg = arg+argsize+9999; // just a marker for asm code
RTFatal("arguments to C routines must be atoms");
}
}
}
// Make the Call - The C compiler thinks it's a 0-argument call
// might be VOID C routine, but shouldn't crash
if (return_type == C_DOUBLE) {
// expect double to be returned from C routine
#if defined(EWINDOWS) && !defined(EWATCOM)
if (cdecl_call) {
dresult = (*((double ( __cdecl *)())int_proc_address))();
pop();
}
else
#endif
dresult = (*((double (__stdcall *)())int_proc_address))();
#ifdef ELINUX
pop();
#endif
return NewDouble(dresult);
}
else if (return_type == C_FLOAT) {
// expect float to be returned from C routine
#if defined(EWINDOWS) && !defined(EWATCOM)
if (cdecl_call) {
fresult = (*((float ( __cdecl *)())int_proc_address))();
pop();
}
else
#endif
fresult = (*((float (__stdcall *)())int_proc_address))();
#ifdef ELINUX
pop();
#endif
return NewDouble((double)fresult);
}
else {
// expect integer to be returned
#if defined(EWINDOWS) && !defined(EWATCOM)
if (cdecl_call) {
iresult = (*((int ( __cdecl *)())int_proc_address))();
pop();
}
else
#endif
iresult = (*((int (__stdcall *)())int_proc_address))();
#ifdef ELINUX
pop();
#endif
if ((return_type & 0x000000FF) == 04) {
/* 4-byte integer - usual case */
// check if unsigned result is required
if ((return_type & C_TYPE) == 0x02000000) {
// unsigned integer result
if ((unsigned)iresult <= (unsigned)MAXINT) {
return iresult;
}
else
return NewDouble((double)(unsigned)iresult);
}
else {
// signed integer result
if (return_type >= E_INTEGER ||
(iresult >= MININT && iresult <= MAXINT)) {
return iresult;
}
else
return NewDouble((double)iresult);
}
}
else if (return_type == 0) {
return 0; /* void - procedure */
}
/* less common cases */
else if (return_type == C_UCHAR) {
return (unsigned char)iresult;
}
else if (return_type == C_CHAR) {
return (signed char)iresult;
}
else if (return_type == C_USHORT) {
return (unsigned short)iresult;
}
else if (return_type == C_SHORT) {
return (short)iresult;
}
else
return 0; // unknown function return type
}
}
