From d6851c5e380e025b6e55dff661b8c83ffbabd34d Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Wed, 6 Aug 2008 17:22:12 +0200
Subject: Add %FOREIGN-LAMBDA.

---
 MLKInterpreter.m | 35 +++++++++++++++++++++++++++++++++++
 1 file changed, 35 insertions(+)

(limited to 'MLKInterpreter.m')

diff --git a/MLKInterpreter.m b/MLKInterpreter.m
index fcc0e84..64e23de 100644
--- a/MLKInterpreter.m
+++ b/MLKInterpreter.m
@@ -16,10 +16,15 @@
  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  */
 
+#define _XOPEN_SOURCE 600
+#define _GNU_SOURCE  // for RTLD_DEFAULT
+#define _ISOC99_SOURCE
+
 #import "MLKInterpretedClosure.h"
 #import "MLKCons.h"
 #import "MLKDynamicContext.h"
 #import "MLKEnvironment.h"
+#import "MLKForeignProcedure.h"
 #import "MLKFuncallable.h"
 #import "MLKInterpreter.h"
 #import "MLKLexicalContext.h"
@@ -37,6 +42,12 @@
 #import <Foundation/NSNull.h>
 #import <Foundation/NSString.h>
 
+#ifndef _WIN32
+#include <dlfcn.h>
+#else
+#include <windows.h>
+#endif
+
 #include <stdio.h>
 
 
@@ -72,6 +83,7 @@ static MLKSymbol *PROGV;
 static MLKSymbol *UNWIND_PROTECT;
 static MLKSymbol *VALUES;
 static MLKSymbol *_DEFMACRO;
+static MLKSymbol *_FOREIGN_LAMBDA;
 static MLKSymbol *_LAMBDA;
 static MLKSymbol *_LOOP;
 static MLKSymbol *V_INITP;
@@ -120,6 +132,7 @@ static MLKSymbol *MULTIPLE_VALUE_CALL;
   VALUES = [cl intern:@"VALUES"];
   UNWIND_PROTECT = [cl intern:@"UNWIND-PROTECT"];
   _DEFMACRO = [sys intern:@"%DEFMACRO"];
+  _FOREIGN_LAMBDA = [sys intern:@"%FOREIGN-LAMBDA"];
   _LAMBDA = [sys intern:@"%LAMBDA"];
   V_INITP = [sys intern:@"*SYSTEM-INITIALISED-P*"];
   MULTIPLE_VALUE_CALL = [cl intern:@"MULTIPLE-VALUE-CALL"];
@@ -473,6 +486,28 @@ static MLKSymbol *MULTIPLE_VALUE_CALL;
                     }
                 }
             }
+          else if (car == _FOREIGN_LAMBDA)
+            {
+              int (*function)();
+              NSString *name = [[program cdr] car];
+              id libraryDesignator = [[[program cdr] cdr] car];
+              id argtypes = [[[[program cdr] cdr] cdr] car];
+              id returnType = [[[[[program cdr] cdr] cdr] cdr] car];
+
+              // FIXME: Support library designators.
+
+#ifdef _WIN32
+              EnumProcessModules (...);
+              GetProcAddress (..., [name UTF8String]);
+#else
+              function = dlsym (RTLD_DEFAULT, [name UTF8String]);
+#endif
+
+              return LAUTORELEASE ([[MLKForeignProcedure alloc]
+                                     initWithCode:function
+                                     argumentTypes:[argtypes array]
+                                     returnType:returnType]);
+            }
           else if (car == FUNCTION)
             {
               id functionName = [[program cdr] car];
-- 
cgit v1.2.3