home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.src.lha / src / foreign.d < prev    next >
Text File  |  1996-07-26  |  159KB  |  3,599 lines
  1. # Foreign language interface for CLISP
  2. # Marcus Daniels 8.4.1994
  3. # Bruno Haible 21.1.1995, 23.6.1995
  4.  
  5. #include "lispbibl.c"
  6. #include "arilev0.c" # für mulu32_unchecked
  7. #undef valid
  8.  
  9. #ifdef DYNAMIC_FFI
  10.  
  11. #include "avcall.h"      # Low level support for call-out
  12.  
  13. #include "vacall.h"      # Low level support for call-in
  14. #include "trampoline.h"  # Low level support for call-in
  15.  
  16. #ifdef AMIGAOS
  17. #include "amiga2.c"      # declares OpenLibrary(), CloseLibrary()
  18. #endif
  19.  
  20. # Complain about an invalid foreign pointer.
  21. # fehler_fpointer_invalid(obj);
  22. # > obj: invalid Fpointer
  23.   nonreturning_function(local, fehler_fpointer_invalid, (object obj));
  24.   local void fehler_fpointer_invalid(obj)
  25.     var reg1 object obj;
  26.     { pushSTACK(obj);
  27.       //: DEUTSCH "~ stammt aus einer früheren Lisp-Sitzung und ist jetzt ungültig."
  28.       //: ENGLISH "~ comes from a previous Lisp session and is invalid"
  29.       //: FRANCAIS "~ provient d'une séance Lisp passée et est inadmissible"
  30.       fehler(error, GETTEXT("~ comes from a previous Lisp session and is invalid"));
  31.     }
  32.  
  33. # (FFI::VALIDP foreign-entity) tests whether a foreign entity is still valid
  34. # or refers to an invalid foreign pointer.
  35. LISPFUNN(validp,1)
  36.   { var reg1 object obj = popSTACK();
  37.     var reg2 boolean valid = TRUE; # default: non-foreign objects are valid
  38.     if (orecordp(obj))
  39.       { switch (TheRecord(obj)->rectype)
  40.           { case Rectype_Fpointer:
  41.               valid = fp_validp(TheFpointer(obj));
  42.               break;
  43.             case Rectype_Faddress:
  44.               obj = TheFaddress(obj)->fa_base;
  45.               valid = fp_validp(TheFpointer(obj));
  46.               break;
  47.             case Rectype_Fvariable:
  48.               obj = TheFvariable(obj)->fv_address;
  49.               obj = TheFaddress(obj)->fa_base;
  50.               valid = fp_validp(TheFpointer(obj));
  51.               break;
  52.             case Rectype_Ffunction:
  53.               obj = TheFfunction(obj)->ff_address;
  54.               obj = TheFaddress(obj)->fa_base;
  55.               valid = fp_validp(TheFpointer(obj));
  56.               break;
  57.       }   }
  58.     value1 = (valid ? T : NIL); mv_count=1;
  59.   }
  60.  
  61. # Allocate a foreign address.
  62. # make_faddress(base,offset)
  63. # > base: base address
  64. # > offset: offset relative to the base address
  65. # < result: Lisp object
  66.   local object make_faddress (object base, uintP offset);
  67.   local object make_faddress(base,offset)
  68.     var reg2 object base;
  69.     var reg2 uintP offset;
  70.     { pushSTACK(base);
  71.      {var reg1 object result = allocate_faddress();
  72.       TheFaddress(result)->fa_base = popSTACK(); # base
  73.       TheFaddress(result)->fa_offset = offset;
  74.       return result;
  75.     }}
  76.  
  77. # Registers a foreign variable.
  78. # register_foreign_variable(address,name,flags,size);
  79. # > address: address of a variable in memory
  80. # > name: its name
  81. # > flags: fv_readonly for read-only variables
  82. # > size: its size in bytes
  83. # kann GC auslösen
  84.   global void register_foreign_variable (void* address, const char * name, uintBWL flags, uintL size);
  85.   global void register_foreign_variable(address,name_asciz,flags,size)
  86.     var reg3 void* address;
  87.     var reg4 const char * name_asciz;
  88.     var reg5 uintBWL flags;
  89.     var reg6 uintL size;
  90.     { var reg2 object name = asciz_to_string(name_asciz);
  91.       var reg1 object obj = gethash(name,O(foreign_variable_table));
  92.       if (!eq(obj,nullobj))
  93.         { obj = TheFvariable(obj)->fv_address;
  94.           obj = TheFaddress(obj)->fa_base;
  95.           if (fp_validp(TheFpointer(obj)))
  96.             { pushSTACK(name);
  97.               //: DEUTSCH "Eine Foreign-Variable ~ gibt es schon."
  98.               //: ENGLISH "A foreign variable ~ already exists"
  99.               //: FRANCAIS "Il y a déjà une variable étrangère ~."
  100.               fehler(error, GETTEXT("A foreign variable ~ already exists"));
  101.             }
  102.             else
  103.             # Variable already existed in a previous Lisp session.
  104.             # Update the address, and make it and any of its subvariables valid.
  105.             { TheFpointer(obj)->fp_pointer = address;
  106.               mark_fp_valid(TheFpointer(obj));
  107.         }   }
  108.         else
  109.         { pushSTACK(name);
  110.           pushSTACK(make_faddress(allocate_fpointer(address),0));
  111.           obj = allocate_fvariable();
  112.           TheFvariable(obj)->fv_address = popSTACK();
  113.           TheFvariable(obj)->fv_name = name = popSTACK();
  114.           TheFvariable(obj)->fv_size = fixnum(size);
  115.           TheFvariable(obj)->recflags = flags;
  116.           shifthash(O(foreign_variable_table),name,obj);
  117.     }   }
  118.  
  119. # Registers a foreign function.
  120. # register_foreign_function(address,name,flags);
  121. # > address: address of the function in memory
  122. # > name: its name
  123. # > flags: its language and parameter passing convention
  124. # kann GC auslösen
  125.   global void register_foreign_function (void* address, const char * name, uintWL flags);
  126.   global void register_foreign_function(address,name_asciz,flags)
  127.     var reg3 void* address;
  128.     var reg4 const char * name_asciz;
  129.     var reg5 uintWL flags;
  130.     { var reg2 object name = asciz_to_string(name_asciz);
  131.       var reg1 object obj = gethash(name,O(foreign_function_table));
  132.       if (!eq(obj,nullobj))
  133.         { obj = TheFfunction(obj)->ff_address;
  134.           obj = TheFaddress(obj)->fa_base;
  135.           if (fp_validp(TheFpointer(obj)))
  136.             { pushSTACK(name);
  137.               //: DEUTSCH "Eine Foreign-Funktion ~ gibt es schon."
  138.               //: ENGLISH "A foreign function ~ already exists"
  139.               //: FRANCAIS "Il y a déjà une fonction étrangère ~."
  140.               fehler(error, GETTEXT("A foreign function ~ already exists"));
  141.             }
  142.             else
  143.             # Function already existed in a previous Lisp session.
  144.             # Update the address, and make it valid.
  145.             { TheFpointer(obj)->fp_pointer = address;
  146.               mark_fp_valid(TheFpointer(obj));
  147.         }   }
  148.         else
  149.         { pushSTACK(name);
  150.           pushSTACK(make_faddress(allocate_fpointer(address),0));
  151.           obj = allocate_ffunction();
  152.           TheFfunction(obj)->ff_address = popSTACK();
  153.           TheFfunction(obj)->ff_name = name = popSTACK();
  154.           TheFfunction(obj)->ff_flags = fixnum(flags);
  155.           shifthash(O(foreign_function_table),name,obj);
  156.     }   }
  157.  
  158.  
  159. # A foreign value descriptor describes an item of foreign data.
  160. # <c-type> ::=
  161. #   <simple-c-type>   as described in foreign.txt
  162. #   c-pointer
  163. #   c-string
  164. #   #(c-struct slots constructor <c-type>*)
  165. #   #(c-union alternatives <c-type>*)
  166. #   #(c-array <c-type> number*)
  167. #   #(c-array-max <c-type> number)
  168. #   #(c-function <c-type> #({<c-type> flags}*) flags)
  169. #   #(c-ptr <c-type>)
  170. #   #(c-ptr-null <c-type>)
  171. #   #(c-array-ptr <c-type>)
  172.  
  173. # Error message.
  174. nonreturning_function(local, fehler_foreign_type, (object fvd));
  175. local void fehler_foreign_type(fvd)
  176.   var reg1 object fvd;
  177.   { var reg2 object *fvd_ptr;
  178.     pushSTACK(fvd); fvd_ptr=&STACK_0;
  179.     dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  180.     pushSTACK(*fvd_ptr);
  181.     //: DEUTSCH "ungültiger Typ für externe Daten: ~"
  182.     //: ENGLISH "illegal foreign data type ~"
  183.     //: FRANCAIS "type invalide de données externes : ~"
  184.     fehler(error, GETTEXT("illegal foreign data type ~"));
  185.   }
  186.  
  187. # Error message.
  188. nonreturning_function(local, fehler_convert, (object fvd, object obj));
  189. local void fehler_convert(fvd,obj)
  190.   var reg1 object fvd;
  191.   var reg2 object obj;
  192.   { var reg3 object *fvd_ptr;
  193.     var reg4 object *obj_ptr;
  194.     pushSTACK(fvd); fvd_ptr = &STACK_0;
  195.     pushSTACK(obj); obj_ptr = &STACK_0;
  196.     dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  197.     pushSTACK(*fvd_ptr);
  198.     pushSTACK(*obj_ptr);
  199.     //: DEUTSCH "~ kann nicht in den Foreign-Typ ~ umgewandelt werden."
  200.     //: ENGLISH "~ cannot be converted to the foreign type ~"
  201.     //: FRANCAIS "~ ne peut être transformé en type étranger ~."
  202.     fehler(error, GETTEXT("~ cannot be converted to the foreign type ~"));
  203.   }
  204.  
  205. #if !defined(HAVE_LONGLONG)
  206. # Error message.
  207. nonreturning_function(local, fehler_64bit, (object fvd));
  208. local void fehler_64bit(fvd)
  209.   var reg1 object fvd;
  210.   { var reg2 object *fvd_ptr; 
  211.     pushSTACK(fvd); fvd_ptr=&STACK_0;
  212.     dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  213.     pushSTACK(*fvd_ptr);
  214.     //: DEUTSCH "64-Bit-Ganzzahlen werden auf dieser Plattform und mit diesem C-Compiler nicht unterstützt: ~"
  215.     //: ENGLISH "64 bit integers are not supported on this platform and with this C compiler: ~"
  216.     //: FRANCAIS "Des nombres à 64 bits ne sont pas supportés sur cette machine et avec ce compilateur C : ~"
  217.     fehler(error, GETTEXT("64 bit integers are not supported on this platform and with this C compiler: ~"));
  218.   }
  219. #endif
  220.  
  221. # Comparison of two fvd's.
  222. # According to the ANSI C rules, two "c-struct"s are only equivalent if they
  223. # come from the same declaration. Same for "c-union"s.
  224. # "c-array"s, "c-ptr", "c-ptr-null" are compared recursively. Same for "c-function".
  225.   local boolean equal_fvd (object fvd1, object fvd2);
  226. # As an exception to strict type and prototype checking,
  227. # C-POINTER matches any C-PTR, C-PTR-NULL, C-ARRAY-PTR and C-FUNCTION type.
  228.   local boolean equalp_fvd (object fvd1, object fvd2);
  229. # Comparison of two argument type vectors.
  230.   local boolean equal_argfvds (object argfvds1, object argfvds2);
  231.  
  232.   local boolean equal_fvd(fvd1,fvd2)
  233.     var reg1 object fvd1;
  234.     var reg2 object fvd2;
  235.     { check_SP();
  236.       recurse:
  237.       if (eq(fvd1,fvd2))
  238.         { return TRUE; }
  239.       if (simple_vector_p(fvd1) && simple_vector_p(fvd2))
  240.         if (TheSvector(fvd1)->length == TheSvector(fvd2)->length)
  241.           { var reg4 uintL len = TheSvector(fvd1)->length;
  242.             if (len > 0)
  243.               { if (eq(TheSvector(fvd1)->data[0],TheSvector(fvd2)->data[0]))
  244.                   { var reg5 object obj;
  245.                     obj = TheSvector(fvd1)->data[0];
  246.                     if ((len >= 2) && 
  247.                         (eq(obj,S(c_array)) || eq(obj,S(c_array_max))
  248.                          || eq(obj,S(c_ptr)) || eq(obj,S(c_ptr_null)) || eq(obj,S(c_array_ptr))))
  249.                       { var reg3 uintL i;
  250.                         for (i = 2; i < len; i++)
  251.                           { if (!eql(TheSvector(fvd1)->data[i],TheSvector(fvd2)->data[i]))
  252.                               goto no;
  253.                           }
  254.                         fvd1 = TheSvector(fvd1)->data[1];
  255.                         fvd2 = TheSvector(fvd2)->data[1];
  256.                         goto recurse;
  257.                       }
  258.                     elif ((len == 4) && eq(obj,S(c_function)))
  259.                       { if (!equal_fvd(TheSvector(fvd1)->data[1],TheSvector(fvd2)->data[1]))
  260.                           goto no;
  261.                         if (!equal_argfvds(TheSvector(fvd1)->data[2],TheSvector(fvd2)->data[2]))
  262.                           goto no;
  263.                         if (!eql(TheSvector(fvd1)->data[3],TheSvector(fvd2)->data[3]))
  264.                           goto no;
  265.                         return TRUE;
  266.                       }
  267.           }   }   }
  268.       no:
  269.       return FALSE;
  270.     }
  271.  
  272.   local boolean equal_argfvds(argfvds1,argfvds2)
  273.     var reg1 object argfvds1;
  274.     var reg2 object argfvds2;
  275.     { ASSERT(simple_vector_p(argfvds1) && simple_vector_p(argfvds2));
  276.      {var reg3 uintL len = TheSvector(argfvds1)->length;
  277.       if (!(len == TheSvector(argfvds2)->length)) return FALSE;
  278.       while (len > 0)
  279.         { len--;
  280.           if (!equal_fvd(TheSvector(argfvds1)->data[len],TheSvector(argfvds2)->data[len]))
  281.             return FALSE;
  282.         }
  283.       return TRUE;
  284.     }}
  285.  
  286.   local boolean equalp_fvd(fvd1,fvd2)
  287.     var reg1 object fvd1;
  288.     var reg2 object fvd2;
  289.     { if (eq(fvd1,fvd2))
  290.         { return TRUE; }
  291.       if (eq(fvd1,S(c_pointer))
  292.           && simple_vector_p(fvd2) && (TheSvector(fvd2)->length > 0)
  293.          )
  294.         { var reg3 object fvd2type = TheSvector(fvd2)->data[0];
  295.           if (eq(fvd2type,S(c_ptr)) || eq(fvd2type,S(c_ptr_null))
  296.               || eq(fvd2type,S(c_array_ptr)) || eq(fvd2type,S(c_function)))
  297.             return TRUE;
  298.         }
  299.       if (eq(fvd2,S(c_pointer))
  300.           && simple_vector_p(fvd1) && (TheSvector(fvd1)->length > 0)
  301.          )
  302.         { var reg3 object fvd1type = TheSvector(fvd1)->data[0];
  303.           if (eq(fvd1type,S(c_ptr)) || eq(fvd1type,S(c_ptr_null))
  304.               || eq(fvd1type,S(c_array_ptr)) || eq(fvd1type,S(c_function)))
  305.             return TRUE;
  306.         }
  307.       return equal_fvd(fvd1,fvd2);
  308.     }
  309.  
  310.  
  311. # When a Lisp function is converted to a C function, it has to be stored in
  312. # a table of call-back functions. (Because we can't give away pointers to
  313. # Lisp objects for GC reasons.)
  314. # There is a two-way correspondence:
  315. #
  316. #                   hash table, alist
  317. #    Lisp function ------------------> index       array
  318. #    Lisp function <------------------ index -----------------> trampoline
  319. #                        array               <-----------------
  320. #                                             trampoline_data()
  321. #
  322. # The index also has a reference count attached, in order to not generate
  323. # several trampolines for different conversions of the same Lisp function.
  324.  
  325. # O(foreign_callin_table) is a hash table.
  326. # O(foreign_callin_vector) is an extendable vector of size 3*n+1, of triples
  327. # #(... lisp-function foreign-function reference-count ...).
  328. #       3*index-2     3*index-1        3*index
  329. # (The foreign-function itself contains the trampoline address.)
  330. # Free triples are linked together to a free list like this:
  331. # #(... nil           nil              next-index      ...)
  332. #       3*index-2     3*index-1        3*index
  333.  
  334. # This variable is used to pass information from the trampoline to us.
  335.   local void* trampvar;
  336.   local void callback ();
  337.  
  338. # Convert a Lisp function to a C function.
  339. # convert_function_to_foreign(address,resulttype,argtypes,flags)
  340. # The real C function address is Faddress_value(TheFfunction(result)->ff_address).
  341. # kann GC auslösen
  342.   local object convert_function_to_foreign (object fun, object resulttype, object argtypes, object flags);
  343.   local object convert_function_to_foreign(fun,resulttype,argtypes,flags)
  344.     var reg5 object fun;
  345.     var reg6 object resulttype;
  346.     var reg7 object argtypes;
  347.     var reg8 object flags;
  348.     { # Convert to a function:
  349.       subr_self = L(coerce); fun = coerce_function(fun);
  350.       # If it is already a foreign function, return it immediately:
  351.       if (ffunctionp(fun))
  352.         { if (equal_fvd(resulttype,TheFfunction(fun)->ff_resulttype)
  353.               && equal_argfvds(argtypes,TheFfunction(fun)->ff_argtypes)
  354.               && eq(flags,TheFfunction(fun)->ff_flags)
  355.              )
  356.             { return fun; }
  357.             else
  358.             { pushSTACK(fun);
  359.               //: DEUTSCH "~ kann nicht in eine Foreign-Funktion mit anderer Aufrufkonvention umgewandelt werden."
  360.               //: ENGLISH "~ cannot be converted to a foreign function with another calling convention."
  361.               //: FRANCAIS "~ ne peut être converti en une fonction étrangère avec une autre convention d'appel."
  362.               fehler(error, GETTEXT("~ cannot be converted to a foreign function with another calling convention."));
  363.         }   }
  364.       # Look it up in the hash table, alist:
  365.       { var reg2 object alist = gethash(fun,O(foreign_callin_table));
  366.         if (!eq(alist,nullobj))
  367.           { while (consp(alist))
  368.               { var reg1 object acons = Car(alist);
  369.                 alist = Cdr(alist);
  370.                 if (equal_fvd(resulttype,Car(acons))
  371.                     && equal_argfvds(argtypes,Car(Cdr(acons)))
  372.                     && eq(flags,Car(Cdr(Cdr(acons))))
  373.                    )
  374.                   { var reg4 object index = Cdr(Cdr(Cdr(acons)));
  375.                     var reg3 object* triple = &TheSvector(TheArray(O(foreign_callin_vector))->data)->data[3*posfixnum_to_L(index)-2];
  376.                     triple[2] = fixnum_inc(triple[2],1); # increment reference count
  377.                    {var reg2 object ffun = triple[1];
  378.                     ASSERT(equal_fvd(resulttype,TheFfunction(ffun)->ff_resulttype));
  379.                     ASSERT(equal_argfvds(argtypes,TheFfunction(ffun)->ff_argtypes));
  380.                     ASSERT(eq(flags,TheFfunction(ffun)->ff_flags));
  381.                     return ffun;
  382.       }   }   }   }}
  383.       # Not already in the hash table -> allocate new:
  384.       pushSTACK(fun);
  385.       pushSTACK(NIL);
  386.       pushSTACK(resulttype);
  387.       pushSTACK(argtypes);
  388.       pushSTACK(flags);
  389.       # First grab an index.
  390.      {var reg2 uintL index = posfixnum_to_L(TheSvector(TheArray(O(foreign_callin_vector))->data)->data[0]);
  391.       if (!(index == 0))
  392.         # remove first index from the free list
  393.         { var reg1 object dv = TheArray(O(foreign_callin_vector))->data;
  394.           TheSvector(dv)->data[0] = TheSvector(dv)->data[3*index];
  395.         }
  396.         else
  397.         # free list exhausted
  398.         { var reg1 uintC i;
  399.           dotimesC(i,3,
  400.             { pushSTACK(NIL); pushSTACK(O(foreign_callin_vector));
  401.               funcall(L(vector_push_extend),2);
  402.             });
  403.           index = floor(vector_length(O(foreign_callin_vector)),3);
  404.         }
  405.       # Next allocate the trampoline.
  406.       {var reg3 void* trampoline = alloc_trampoline((__TR_function)&vacall,&trampvar,(void*)index);
  407.        pushSTACK(make_faddress(O(fp_zero),(uintP)trampoline));
  408.        # Now allocate the foreign-function.
  409.        {var reg1 object obj = allocate_ffunction();
  410.         TheFfunction(obj)->ff_name = NIL;
  411.         TheFfunction(obj)->ff_address = popSTACK();
  412.         TheFfunction(obj)->ff_resulttype = STACK_2;
  413.         TheFfunction(obj)->ff_argtypes = STACK_1;
  414.         TheFfunction(obj)->ff_flags = STACK_0;
  415.         STACK_3 = obj;
  416.       }}
  417.       pushSTACK(fixnum(index)); funcall(L(liststern),4); pushSTACK(value1);
  418.       # Stack layout: fun, obj, acons.
  419.       # Put it into the hash table.
  420.       { var reg1 object new_cons = allocate_cons();
  421.         Car(new_cons) = popSTACK();
  422.        {var reg2 object alist = gethash(STACK_1,O(foreign_callin_table));
  423.         if (eq(alist,nullobj)) { alist = NIL; }
  424.         Cdr(new_cons) = alist;
  425.         shifthash(O(foreign_callin_table),STACK_1,new_cons);
  426.       }}
  427.       # Put it into the vector.
  428.       {var reg1 object* triple = &TheSvector(TheArray(O(foreign_callin_vector))->data)->data[3*index-2];
  429.        triple[1] = popSTACK(); # obj
  430.        triple[0] = popSTACK(); # fun
  431.        triple[2] = Fixnum_1; # refcount := 1
  432.        return triple[1];
  433.     }}}
  434.  
  435. # Undoes the allocation effect of convert_function_to_foreign().
  436.   local void free_foreign_callin (void* address);
  437.   local void free_foreign_callin(address)
  438.     var reg7 void* address;
  439.     { if (is_trampoline(address) # safety check
  440.           && (trampoline_address(address) == (__TR_function)&vacall)
  441.           && (trampoline_variable(address) == &trampvar)
  442.          )
  443.         { var reg9 uintL index = (uintL)trampoline_data(address);
  444.           var reg3 object dv = TheArray(O(foreign_callin_vector))->data;
  445.           var reg4 object* triple = &TheSvector(dv)->data[3*index-2];
  446.           if (!nullp(triple[1])) # safety check
  447.             { triple[2] = fixnum_inc(triple[2],-1); # decrement reference count
  448.               if (eq(triple[2],Fixnum_0))
  449.                 { var reg8 object fun = triple[0];
  450.                   var reg6 object ffun = triple[1];
  451.                   # clear vector entry, put index onto free list:
  452.                   triple[0] = NIL; triple[1] = NIL;
  453.                   triple[2] = TheSvector(dv)->data[0];
  454.                   TheSvector(dv)->data[0] = fixnum(index);
  455.                   # remove from hash table entry:
  456.                   { var reg5 object alist = gethash(fun,O(foreign_callin_table));
  457.                     if (!eq(alist,nullobj)) # safety check
  458.                       { # vgl. list.d:deleteq()
  459.                         var reg2 object alist1 = alist;
  460.                         var reg1 object alist2 = alist;
  461.                         loop
  462.                           { if (atomp(alist2)) break;
  463.                             if (eq(Cdr(Cdr(Cdr(Car(alist2)))),fixnum(index)))
  464.                               if (eq(alist2,alist))
  465.                                 { alist2 = alist1 = Cdr(alist2);
  466.                                   shifthash(O(foreign_callin_table),fun,alist2);
  467.                                 }
  468.                                 else
  469.                                 { Cdr(alist1) = alist2 = Cdr(alist2); }
  470.                               else
  471.                                 { alist1 = alist2; alist2 = Cdr(alist2); }
  472.                   }   }   }
  473.                   # free the trampoline:
  474.                   free_trampoline(Faddress_value(TheFfunction(ffun)->ff_address));
  475.     }   }   }   }
  476.  
  477.  
  478. # Convert a C function to a Lisp foreign function.
  479. # convert_function_from_foreign(address,resulttype,argtypes,flags)
  480.   local object convert_function_from_foreign (void* address, object resulttype, object argtypes, object flags);
  481.   local object convert_function_from_foreign(address,resulttype,argtypes,flags)
  482.     var reg2 void* address;
  483.     var reg6 object resulttype;
  484.     var reg7 object argtypes;
  485.     var reg5 object flags;
  486.     { if (is_trampoline(address)
  487.           && (trampoline_address(address) == (__TR_function)&vacall)
  488.           && (trampoline_variable(address) == &trampvar)
  489.          )
  490.         { var reg4 uintL index = (uintL)trampoline_data(address);
  491.           var reg3 object* triple = &TheSvector(TheArray(O(foreign_callin_vector))->data)->data[3*index-2];
  492.           var reg1 object ffun = triple[1];
  493.           if (equal_fvd(resulttype,TheFfunction(ffun)->ff_resulttype)
  494.               && equal_argfvds(argtypes,TheFfunction(ffun)->ff_argtypes)
  495.               && eq(flags,TheFfunction(ffun)->ff_flags)
  496.              )
  497.             { return ffun; }
  498.             else
  499.             { pushSTACK(ffun);
  500.               //: DEUTSCH "~ kann nicht in eine Foreign-Funktion mit anderer Aufrufkonvention umgewandelt werden."
  501.               //: ENGLISH "~ cannot be converted to a foreign function with another calling convention."
  502.               //: FRANCAIS "~ ne peut être converti en une fonction étrangère avec une autre convention d'appel."
  503.               fehler(error, GETTEXT("~ cannot be converted to a foreign function with another calling convention."));
  504.             }
  505.         }
  506.       pushSTACK(argtypes);
  507.       pushSTACK(resulttype);
  508.       pushSTACK(make_faddress(O(fp_zero),(uintP)address));
  509.      {var reg1 object obj = allocate_ffunction();
  510.       TheFfunction(obj)->ff_name = NIL;
  511.       TheFfunction(obj)->ff_address = popSTACK();
  512.       TheFfunction(obj)->ff_resulttype = popSTACK();
  513.       TheFfunction(obj)->ff_argtypes = popSTACK();
  514.       TheFfunction(obj)->ff_flags = flags;
  515.       return obj;
  516.     }}
  517.  
  518.  
  519. #if (long_bitsize<64)
  520.   # 64-bit integers are passed as structs.
  521.   #if BIG_ENDIAN_P
  522.     typedef struct { uint32 hi; uint32 lo; } struct_uint64;
  523.     typedef struct { sint32 hi; uint32 lo; } struct_sint64;
  524.   #else
  525.     typedef struct { uint32 lo; uint32 hi; } struct_uint64;
  526.     typedef struct { uint32 lo; sint32 hi; } struct_sint64;
  527.   #endif
  528. #else
  529.   #define struct_uint64  uint64
  530.   #define struct_sint64  sint64
  531. #endif
  532.  
  533. # malloc() with error check.
  534. local void* xmalloc (uintL size);
  535. #if !defined(AMIGAOS)
  536. local void* xmalloc(size)
  537.   var reg2 uintL size;
  538.   { var reg1 void* ptr = malloc(size);
  539.     if (ptr) return ptr;
  540.     //: DEUTSCH "Speicherplatz reicht nicht für die Fremdsprachen-Schnittstelle."
  541.     //: ENGLISH "No more room for foreign language interface"
  542.     //: FRANCAIS "Il n'y a pas assez de place pour l'interface aux langages étrangers."
  543.     fehler(storage_condition, GETTEXT("No more room for foreign language interface"));
  544.   }
  545. #else # defined(AMIGAOS)
  546. # No malloc() is available. Disable malloc() and free() altogether.
  547. nonreturning_function(global, fehler_malloc_free, (void));
  548. global void fehler_malloc_free()
  549.   { 
  550.     //: DEUTSCH ":MALLOC-FREE ist unter AMIGAOS nicht verfügbar."
  551.     //: ENGLISH ":MALLOC-FREE is not available under AMIGAOS."
  552.     //: FRANCAIS ":MALLOC-FREE n'est pas applicable sous AMIGAOS."
  553.     fehler(error, GETTEXT(":MALLOC-FREE is not available under AMIGAOS."));
  554.   }
  555. #define malloc(amount)  (fehler_malloc_free(), NULL)
  556. #define free(pointer)  fehler_malloc_free()
  557. #define xmalloc(size)  malloc(size)
  558. #endif
  559.  
  560. # Compute the size and alignment of foreign data.
  561. # foreign_layout(fvd);
  562. # > fvd: foreign value descriptor
  563. # < data_size, data_alignment: size and alignment (in bytes) of the type
  564. # < data_splittable: splittable flag of the type, if a struct/union/array type
  565. local void foreign_layout (object fvd);
  566. local uintL data_size;
  567. local uintL data_alignment;
  568. local boolean data_splittable;
  569. #define alignof(type)  offsetof(struct { char slot1; type slot2; }, slot2)
  570. # `struct_alignment' is what gcc calls STRUCTURE_SIZE_BOUNDARY/8.
  571. # It is = 1 on most machines, but = 2 on MC680X0 and = 4 on ARM.
  572. #define struct_alignment  sizeof(struct { char slot1; })
  573. local void foreign_layout(fvd)
  574.   var reg1 object fvd;
  575.   { check_SP();
  576.     if (symbolp(fvd))
  577.       { if (eq(fvd,S(nil)))
  578.           { data_size = 0; data_alignment = 1;
  579.             data_splittable = TRUE; return;
  580.           }
  581.         elif (eq(fvd,S(boolean)))
  582.           { data_size = sizeof(int); data_alignment = alignof(int);
  583.             data_splittable = TRUE; return;
  584.           }
  585.         elif (eq(fvd,S(character)))
  586.           { data_size = sizeof(unsigned char); data_alignment = alignof(unsigned char);
  587.             data_splittable = TRUE; return;
  588.           }
  589.         elif (eq(fvd,S(char)) || eq(fvd,S(sint8)))
  590.           { data_size = sizeof(sint8); data_alignment = alignof(sint8);
  591.             data_splittable = TRUE; return;
  592.           }
  593.         elif (eq(fvd,S(uchar)) || eq(fvd,S(uint8)))
  594.           { data_size = sizeof(uint8); data_alignment = alignof(uint8);
  595.             data_splittable = TRUE; return;
  596.           }
  597.         elif (eq(fvd,S(short)) || eq(fvd,S(sint16)))
  598.           { data_size = sizeof(sint16); data_alignment = alignof(sint16);
  599.             data_splittable = TRUE; return;
  600.           }
  601.         elif (eq(fvd,S(ushort)) || eq(fvd,S(uint16)))
  602.           { data_size = sizeof(uint16); data_alignment = alignof(uint16);
  603.             data_splittable = TRUE; return;
  604.           }
  605.         elif (eq(fvd,S(sint32)))
  606.           { data_size = sizeof(sint32); data_alignment = alignof(sint32);
  607.             data_splittable = TRUE; return;
  608.           }
  609.         elif (eq(fvd,S(uint32)))
  610.           { data_size = sizeof(uint32); data_alignment = alignof(uint32);
  611.             data_splittable = TRUE; return;
  612.           }
  613.         elif (eq(fvd,S(sint64)))
  614.           {
  615.             #ifdef HAVE_LONGLONG
  616.             data_size = sizeof(sint64); data_alignment = alignof(sint64);
  617.             data_splittable = (long_bitsize<64 ? av_word_splittable_2(uint32,uint32) : av_word_splittable_1(uint64)); # always TRUE
  618.             #else
  619.             data_size = sizeof(struct_sint64); data_alignment = alignof(struct_sint64);
  620.             data_splittable = av_word_splittable_2(uint32,uint32); # always TRUE
  621.             #endif
  622.             return;
  623.           }
  624.         elif (eq(fvd,S(uint64)))
  625.           {
  626.             #ifdef HAVE_LONGLONG
  627.             data_size = sizeof(uint64); data_alignment = alignof(uint64);
  628.             data_splittable = (long_bitsize<64 ? av_word_splittable_2(uint32,uint32) : av_word_splittable_1(uint64)); # always TRUE
  629.             #else
  630.             data_size = sizeof(struct_uint64); data_alignment = alignof(struct_uint64);
  631.             data_splittable = av_word_splittable_2(uint32,uint32); # always TRUE
  632.             #endif
  633.             return;
  634.           }
  635.         elif (eq(fvd,S(int)))
  636.           { data_size = sizeof(int); data_alignment = alignof(int);
  637.             data_splittable = TRUE; return;
  638.           }
  639.         elif (eq(fvd,S(uint)))
  640.           { data_size = sizeof(unsigned int); data_alignment = alignof(unsigned int);
  641.             data_splittable = TRUE; return;
  642.           }
  643.         elif (eq(fvd,S(long)))
  644.           { data_size = sizeof(long); data_alignment = alignof(long);
  645.             data_splittable = TRUE; return;
  646.           }
  647.         elif (eq(fvd,S(ulong)))
  648.           { data_size = sizeof(unsigned long); data_alignment = alignof(unsigned long);
  649.             data_splittable = TRUE; return;
  650.           }
  651.         elif (eq(fvd,S(single_float)))
  652.           { data_size = sizeof(float); data_alignment = alignof(float);
  653.             data_splittable = (sizeof(float) <= sizeof(long)); return;
  654.           }
  655.         elif (eq(fvd,S(double_float)))
  656.           { data_size = sizeof(double); data_alignment = alignof(double);
  657.             data_splittable = (sizeof(double) <= sizeof(long)); return;
  658.           }
  659.         elif (eq(fvd,S(c_pointer)))
  660.           { data_size = sizeof(void*); data_alignment = alignof(void*);
  661.             data_splittable = TRUE; return;
  662.           }
  663.         elif (eq(fvd,S(c_string)))
  664.           { data_size = sizeof(char*); data_alignment = alignof(char*);
  665.             data_splittable = TRUE; return;
  666.           }
  667.       }
  668.     elif (simple_vector_p(fvd))
  669.       { var reg9 uintL fvdlen = TheSvector(fvd)->length;
  670.         if (fvdlen > 0)
  671.           { var reg2 object fvdtype = TheSvector(fvd)->data[0];
  672.             if (eq(fvdtype,S(c_struct)) && (fvdlen > 2))
  673.               { var reg3 uintL cumul_size = 0;
  674.                 var reg4 uintL cumul_alignment = struct_alignment;
  675.                 var reg6 boolean cumul_splittable = TRUE;
  676.                 var reg5 uintL i;
  677.                 for (i = 3; i < fvdlen; i++)
  678.                   { foreign_layout(TheSvector(fvd)->data[i]);
  679.                     # We assume all alignments are of the form 2^k.
  680.                     cumul_size += (-cumul_size) & (data_alignment-1);
  681.                     # cumul_splittable = cumul_splittable AND
  682.                     #       (cumul_size..cumul_size+data_size-1) fits in a word;
  683.                     if (floor(cumul_size,sizeof(long)) < floor(cumul_size+data_size-1,sizeof(long)))
  684.                       cumul_splittable = FALSE;
  685.                     cumul_size += data_size;
  686.                     # cumul_alignment = lcm(cumul_alignment,data_alignment);
  687.                     if (data_alignment > cumul_alignment)
  688.                       cumul_alignment = data_alignment;
  689.                   }
  690.                 cumul_size += (-cumul_size) & (cumul_alignment-1);
  691.                 data_size = cumul_size; data_alignment = cumul_alignment;
  692.                 data_splittable = cumul_splittable;
  693.                 return;
  694.               }
  695.             elif (eq(fvdtype,S(c_union)) && (fvdlen > 1))
  696.               { var reg3 uintL cumul_size = 0;
  697.                 var reg4 uintL cumul_alignment = struct_alignment;
  698.                 var reg6 boolean cumul_splittable = FALSE;
  699.                 var reg5 uintL i;
  700.                 for (i = 2; i < fvdlen; i++)
  701.                   { foreign_layout(TheSvector(fvd)->data[i]);
  702.                     # We assume all alignments are of the form 2^k.
  703.                     # cumul_size = max(cumul_size,data_size);
  704.                     if (data_size > cumul_size)
  705.                       cumul_size = data_size;
  706.                     # cumul_alignment = lcm(cumul_alignment,data_alignment);
  707.                     if (data_alignment > cumul_alignment)
  708.                       cumul_alignment = data_alignment;
  709.                     # cumul_splittable = cumul_splittable OR data_splittable;
  710.                     if (data_splittable)
  711.                       cumul_splittable = TRUE;
  712.                   }
  713.                 data_size = cumul_size; data_alignment = cumul_alignment;
  714.                 data_splittable = cumul_splittable;
  715.                 return;
  716.               }
  717.             elif ((eq(fvdtype,S(c_array)) && (fvdlen > 1)) || (eq(fvdtype,S(c_array_max)) && (fvdlen == 3)))
  718.               { var reg4 uintL i;
  719.                 foreign_layout(TheSvector(fvd)->data[1]);
  720.                 for (i = 2; i < fvdlen; i++)
  721.                   { var reg3 object dim = TheSvector(fvd)->data[i];
  722.                     if (!uint32_p(dim)) { fehler_foreign_type(fvd); }
  723.                     data_size = data_size * I_to_uint32(dim);
  724.                   }
  725.                 data_splittable = (data_size <= sizeof(long));
  726.                 return;
  727.               }
  728.             elif (eq(fvdtype,S(c_function)) && (fvdlen == 4))
  729.               { data_size = sizeof(void*); data_alignment = alignof(void*);
  730.                 data_splittable = TRUE; return;
  731.               }
  732.             elif ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null)) || eq(fvdtype,S(c_array_ptr)))
  733.                   && (fvdlen == 2))
  734.               { data_size = sizeof(void*); data_alignment = alignof(void*);
  735.                 data_splittable = TRUE; return;
  736.               }
  737.       }   }
  738.     fehler_foreign_type(fvd);
  739.   }
  740.  
  741. # (FFI::%SIZEOF c-type) returns the size and alignment of a C type,
  742. # measured in bytes.
  743. LISPFUNN(sizeof,1)
  744.   { var reg1 object fvd = popSTACK();
  745.     foreign_layout(fvd);
  746.     value1 = UL_to_I(data_size); value2 = fixnum(data_alignment); mv_count=2;
  747.   }
  748.  
  749. # (FFI::%BITSIZEOF c-type) returns the size and alignment of a C type,
  750. # measured in bits.
  751. LISPFUNN(bitsizeof,1)
  752.   { var reg1 object fvd = popSTACK();
  753.     foreign_layout(fvd);
  754.     value1 = UL_to_I(8*data_size); value2 = fixnum(8*data_alignment); mv_count=2;
  755.   }
  756.  
  757. # Zero a block of memory.
  758. local void blockzero (void* ptr, unsigned long size);
  759. local void blockzero(ptr,size)
  760.   var reg3 void* ptr;
  761.   var reg2 unsigned long size;
  762.   { if (size > 0)
  763.       { if ((size % sizeof(long)) || ((uintP)ptr % sizeof(long)))
  764.           { var reg1 char* p = (char*)ptr;
  765.             do { *p++ = 0; } while (--size > 0);
  766.           }
  767.           else
  768.           { var reg1 long* p = (long*)ptr;
  769.             do { *p++ = 0; } while ((size -= sizeof(long)) > 0);
  770.           }
  771.   }   }
  772.  
  773. # Test a block of memory for zero.
  774. local boolean blockzerop (void* ptr, unsigned long size);
  775. local boolean blockzerop(ptr,size)
  776.   var reg3 void* ptr;
  777.   var reg2 unsigned long size;
  778.   { if ((size % sizeof(long)) || ((uintP)ptr % sizeof(long)))
  779.       { var reg1 char* p = (char*)ptr;
  780.         do { if (!(*p++ == 0)) return FALSE; } while (--size > 0);
  781.         return TRUE;
  782.       }
  783.       else
  784.       { var reg1 long* p = (long*)ptr;
  785.         do { if (!(*p++ == 0)) return FALSE; } while ((size -= sizeof(long)) > 0);
  786.         return TRUE;
  787.       }
  788.   }
  789.  
  790. # Convert foreign data to Lisp data.
  791. # kann GC auslösen
  792. global object convert_from_foreign (object fvd, void* data);
  793.   # Allocate an array corresponding to a foreign array.
  794.   # kann GC auslösen
  795.   local object convert_from_foreign_array_alloc (object dims, object eltype);
  796.   local object convert_from_foreign_array_alloc(dims,eltype)
  797.     var reg3 object dims;
  798.     var reg1 object eltype;
  799.     { var reg2 uintL argcount = 1;
  800.       pushSTACK(dims);
  801.       if (symbolp(eltype))
  802.         { if (eq(eltype,S(character)))
  803.             { pushSTACK(S(Kelement_type)); pushSTACK(S(string_char));
  804.               argcount += 2;
  805.             }
  806.           elif (eq(eltype,S(uint8)))
  807.             { pushSTACK(S(Kelement_type)); pushSTACK(O(type_uint8));
  808.               argcount += 2;
  809.             }
  810.           #if 0
  811.           elif (eq(eltype,S(sint8)))
  812.             { pushSTACK(S(Kelement_type)); pushSTACK(O(type_sint8));
  813.               argcount += 2;
  814.             }
  815.           #endif
  816.           elif (eq(eltype,S(uint16)))
  817.             { pushSTACK(S(Kelement_type)); pushSTACK(O(type_uint16));
  818.               argcount += 2;
  819.             }
  820.           #if 0
  821.           elif (eq(eltype,S(sint16)))
  822.             { pushSTACK(S(Kelement_type)); pushSTACK(O(type_sint16));
  823.               argcount += 2;
  824.             }
  825.           #endif
  826.           elif (eq(eltype,S(uint32)))
  827.             { pushSTACK(S(Kelement_type)); pushSTACK(O(type_uint32));
  828.               argcount += 2;
  829.             }
  830.           #if 0
  831.           elif (eq(eltype,S(sint32)))
  832.             { pushSTACK(S(Kelement_type)); pushSTACK(O(type_sint32));
  833.               argcount += 2;
  834.             }
  835.           #endif
  836.         }
  837.       funcall(L(make_array),argcount);
  838.       return value1;
  839.     }
  840.   # Fill a specialized Lisp array with foreign data.
  841.   local void convert_from_foreign_array_fill (object eltype, uintL size, object array, void* data);
  842.   local void convert_from_foreign_array_fill(eltype,size,array,data)
  843.     var reg1 object eltype;
  844.     var reg1 uintL size;
  845.     var reg1 object array;
  846.     var reg1 void* data;
  847.     { if (eq(eltype,S(character)))
  848.         { var reg5 uintB* ptr1 = (uintB*)data;
  849.           var reg4 uintB* ptr2 = &TheSstring(array)->data[0];
  850.           dotimesL(size,size, { *ptr2++ = *ptr1++; } );
  851.         }
  852.       elif (eq(eltype,S(uint8)))
  853.         { var reg5 uint8* ptr1 = (uint8*)data;
  854.           var reg4 uint8* ptr2 = (uint8*)&TheSbvector(TheArray(array)->data)->data[0];
  855.           dotimesL(size,size, { *ptr2++ = *ptr1++; } );
  856.         }
  857.       #if 0
  858.       elif (eq(eltype,S(sint8)))
  859.         { var reg5 sint8* ptr1 = (sint8*)data;
  860.           var reg4 sint8* ptr2 = (sint8*)&TheSbvector(TheArray(array)->data)->data[0];
  861.           dotimesL(size,size, { *ptr2++ = *ptr1++; } );
  862.         }
  863.       #endif
  864.       elif (eq(eltype,S(uint16)))
  865.         { var reg5 uint16* ptr1 = (uint16*)data;
  866.           var reg4 uint16* ptr2 = (uint16*)&TheSbvector(TheArray(array)->data)->data[0];
  867.           dotimesL(size,size, { *ptr2++ = *ptr1++; } );
  868.         }
  869.       #if 0
  870.       elif (eq(eltype,S(sint16)))
  871.         { var reg5 sint16* ptr1 = (sint16*)data;
  872.           var reg4 sint16* ptr2 = (sint16*)&TheSbvector(TheArray(array)->data)->data[0];
  873.           dotimesL(size,size, { *ptr2++ = *ptr1++; } );
  874.         }
  875.       #endif
  876.       elif (eq(eltype,S(uint32)))
  877.         { var reg5 uint32* ptr1 = (uint32*)data;
  878.           var reg4 uint32* ptr2 = (uint32*)&TheSbvector(TheArray(array)->data)->data[0];
  879.           dotimesL(size,size, { *ptr2++ = *ptr1++; } );
  880.         }
  881.       #if 0
  882.       elif (eq(eltype,S(sint32)))
  883.         { var reg5 sint32* ptr1 = (sint32*)data;
  884.           var reg4 sint32* ptr2 = (sint32*)&TheSbvector(TheArray(array)->data)->data[0];
  885.           dotimesL(size,size, { *ptr2++ = *ptr1++; } );
  886.         }
  887.       #endif
  888.       else
  889.         { NOTREACHED }
  890.     }
  891. global object convert_from_foreign(fvd,data)
  892.   var reg1 object fvd;
  893.   var reg3 void* data;
  894.   { check_SP();
  895.     check_STACK();
  896.     if (symbolp(fvd))
  897.       { if (eq(fvd,S(nil)))
  898.           # If we are presented the empty type, we take it as "ignore"
  899.           # and return NIL.
  900.           { return NIL; }
  901.         elif (eq(fvd,S(boolean)))
  902.           { var reg2 int* pdata = (int*)data;
  903.             return (*pdata ? T : NIL);
  904.           }
  905.         elif (eq(fvd,S(character)))
  906.           { var reg2 uintB* pdata = (unsigned char *)data;
  907.             return code_char(*pdata);
  908.           }
  909.         elif (eq(fvd,S(char)) || eq(fvd,S(sint8)))
  910.           { var reg2 sint8* pdata = (sint8*)data;
  911.             return sint8_to_I(*pdata);
  912.           }
  913.         elif (eq(fvd,S(uchar)) || eq(fvd,S(uint8)))
  914.           { var reg2 uint8* pdata = (uint8*)data;
  915.             return uint8_to_I(*pdata);
  916.           }
  917.         elif (eq(fvd,S(short)) || eq(fvd,S(sint16)))
  918.           { var reg2 sint16* pdata = (sint16*)data;
  919.             return sint16_to_I(*pdata);
  920.           }
  921.         elif (eq(fvd,S(ushort)) || eq(fvd,S(uint16)))
  922.           { var reg2 uint16* pdata = (uint16*)data;
  923.             return uint16_to_I(*pdata);
  924.           }
  925.         elif (eq(fvd,S(sint32)))
  926.           { var reg2 sint32* pdata = (sint32*)data;
  927.             return sint32_to_I(*pdata);
  928.           }
  929.         elif (eq(fvd,S(uint32)))
  930.           { var reg2 uint32* pdata = (uint32*)data;
  931.             return uint32_to_I(*pdata);
  932.           }
  933.         elif (eq(fvd,S(sint64)))
  934.           { var reg2 struct_sint64* pdata = (struct_sint64*)data;
  935.             #ifdef HAVE_LONGLONG
  936.             var reg5 sint64 val;
  937.             #if (long_bitsize<64)
  938.             val = ((sint64)(pdata->hi)<<32) | (sint64)(pdata->lo);
  939.             #else
  940.             val = *pdata;
  941.             #endif
  942.             return sint64_to_I(val);
  943.             #else
  944.             return L2_to_I(pdata->hi,pdata->lo);
  945.             #endif
  946.           }
  947.         elif (eq(fvd,S(uint64)))
  948.           { var reg2 struct_uint64* pdata = (struct_uint64*)data;
  949.             #ifdef HAVE_LONGLONG
  950.             var reg5 uint64 val;
  951.             #if (long_bitsize<64)
  952.             val = ((uint64)(pdata->hi)<<32) | (uint64)(pdata->lo);
  953.             #else
  954.             val = *pdata;
  955.             #endif
  956.             return uint64_to_I(val);
  957.             #else
  958.             return UL2_to_I(pdata->hi,pdata->lo);
  959.             #endif
  960.           }
  961.         elif (eq(fvd,S(int)))
  962.           { var reg2 int* pdata = (int*)data;
  963.             return sint_to_I(*pdata);
  964.           }
  965.         elif (eq(fvd,S(uint)))
  966.           { var reg2 unsigned int * pdata = (unsigned int *)data;
  967.             return uint_to_I(*pdata);
  968.           }
  969.         elif (eq(fvd,S(long)))
  970.           { var reg2 long* pdata = (long*)data;
  971.             return slong_to_I(*pdata);
  972.           }
  973.         elif (eq(fvd,S(ulong)))
  974.           { var reg2 unsigned long * pdata = (unsigned long *)data;
  975.             return ulong_to_I(*pdata);
  976.           }
  977.         elif (eq(fvd,S(single_float)))
  978.           { var reg2 ffloatjanus* pdata = (ffloatjanus*) data;
  979.             return c_float_to_FF(pdata);
  980.           }
  981.         elif (eq(fvd,S(double_float)))
  982.           { var reg2 dfloatjanus* pdata = (dfloatjanus*) data;
  983.             return c_double_to_DF(pdata);
  984.           }
  985.         elif (eq(fvd,S(c_pointer)))
  986.           { return make_faddress(O(fp_zero),(uintP)(*(void* *) data)); }
  987.         elif (eq(fvd,S(c_string)))
  988.           { var reg2 const char * asciz = *(const char * *) data;
  989.             if (asciz == NULL)
  990.               { return NIL; }
  991.               else
  992.               { return asciz_to_string(asciz); }
  993.           }
  994.       }
  995.     elif (simple_vector_p(fvd))
  996.       { var reg8 uintL fvdlen = TheSvector(fvd)->length;
  997.         if (fvdlen > 0)
  998.           { var reg2 object fvdtype = TheSvector(fvd)->data[0];
  999.             if (eq(fvdtype,S(c_struct)) && (fvdlen > 2))
  1000.               { pushSTACK(fvd);
  1001.                 { var reg8 object* fvd_ = &STACK_0;
  1002.                   var reg5 uintL cumul_size = 0;
  1003.                   var reg6 uintL cumul_alignment = struct_alignment;
  1004.                   var reg7 uintL i;
  1005.                   for (i = 3; i < fvdlen; i++)
  1006.                     { var reg4 object fvdi = TheSvector(*fvd_)->data[i];
  1007.                       foreign_layout(fvdi);
  1008.                       # We assume all alignments are of the form 2^k.
  1009.                       cumul_size += (-cumul_size) & (data_alignment-1);
  1010.                      {var reg9 void* pdata = (char*)data + cumul_size;
  1011.                       cumul_size += data_size;
  1012.                       # cumul_alignment = lcm(cumul_alignment,data_alignment);
  1013.                       if (data_alignment > cumul_alignment)
  1014.                         cumul_alignment = data_alignment;
  1015.                       # Now we are finished with data_size and data_alignment.
  1016.                       # Convert the structure slot:
  1017.                       fvdi = convert_from_foreign(fvdi,pdata);
  1018.                       pushSTACK(fvdi);
  1019.                     }}
  1020.                   # Call the constructor.
  1021.                   funcall(TheSvector(*fvd_)->data[2],fvdlen-3);
  1022.                 }
  1023.                 skipSTACK(1);
  1024.                 return value1;
  1025.               }
  1026.             elif (eq(fvdtype,S(c_union)) && (fvdlen > 1))
  1027.               { 
  1028.                 # Use the union's first component.
  1029.                 return convert_from_foreign(fvdlen > 2 ? TheSvector(fvd)->data[2] : NIL, data);
  1030.               }
  1031.             elif (eq(fvdtype,S(c_array)) && (fvdlen > 1))
  1032.               { pushSTACK(fvd);
  1033.                 # Allocate the resulting array: (MAKE-ARRAY dims :element-type ...)
  1034.                {var reg10 object dims = Cdr(Cdr((coerce_sequence(fvd,S(list)),value1)));
  1035.                 var reg10 object array = convert_from_foreign_array_alloc(dims,TheSvector(STACK_0)->data[1]);
  1036.                 # Fill the resulting array.
  1037.                 # Only a single loop is needed since C and Lisp both store the
  1038.                 # elements in row-major order.
  1039.                 { var reg7 object eltype = TheSvector(STACK_0)->data[1];
  1040.                   var reg9 uintL eltype_size = (foreign_layout(eltype), data_size);
  1041.                   STACK_0 = eltype;
  1042.                  {var reg6 uintL size = array_total_size(array);
  1043.                   pushSTACK(array);
  1044.                   if (!vectorp(array))
  1045.                     { array = TheArray(array)->data; } # fetch the data vector
  1046.                   if (!simple_vector_p(array))
  1047.                     # Fill specialized array.
  1048.                     { convert_from_foreign_array_fill(eltype,size,array,data); }
  1049.                     else
  1050.                     # Fill general array.
  1051.                     # SYS::ROW-MAJOR-STORE is equivalent to SETF SVREF here.
  1052.                     { pushSTACK(array);
  1053.                      {var reg4 char* pdata = (char*)data;
  1054.                       var reg5 uintL i;
  1055.                       for (i = 0; i < size; i++, pdata += eltype_size)
  1056.                         { # pdata = (char*)data + i*eltype_size
  1057.                           var reg1 object el = convert_from_foreign(STACK_2,(void*)pdata);
  1058.                           TheSvector(STACK_0)->data[i] = el;
  1059.                         }
  1060.                       skipSTACK(1);
  1061.                     }}
  1062.                   array = popSTACK();
  1063.                 }}
  1064.                 skipSTACK(1);
  1065.                 return array;
  1066.               }}
  1067.             elif (eq(fvdtype,S(c_array_max)) && (fvdlen == 3))
  1068.               { var reg9 object eltype = TheSvector(fvd)->data[1];
  1069.                 var reg7 uintL eltype_size = (foreign_layout(eltype), data_size);
  1070.                 if (eltype_size == 0)
  1071.                   { pushSTACK(fvd);
  1072.                     //: DEUTSCH "Elementtyp hat Größe 0: ~"
  1073.                     //: ENGLISH "element type has size 0: ~"
  1074.                     //: FRANCAIS "Le type des éléments est de grandeur 0 : ~"
  1075.                     fehler(error, GETTEXT("element type has size 0: ~"));
  1076.                   }
  1077.                 # Determine length of array:
  1078.                {var reg5 uintL len = 0;
  1079.                 { var reg4 uintL maxdim = I_to_UL(TheSvector(fvd)->data[2]);
  1080.                   var reg2 void* ptr = data;
  1081.                   until ((len == maxdim) || blockzerop(ptr,eltype_size))
  1082.                     { ptr = (void*)((uintP)ptr + eltype_size); len++; }
  1083.                 }
  1084.                 pushSTACK(eltype);
  1085.                 # Allocate the resulting array:
  1086.                 { var reg7 object array = convert_from_foreign_array_alloc(UL_to_I(len),eltype);
  1087.                   # Fill the resulting array.
  1088.                   if (!simple_vector_p(array))
  1089.                     # Fill specialized array.
  1090.                     { convert_from_foreign_array_fill(STACK_0,len,array,data); }
  1091.                     else
  1092.                     # Fill general array, using SYS::SVSTORE.
  1093.                     { pushSTACK(array);
  1094.                      {var reg4 char* pdata = (char*)data;
  1095.                       var reg5 uintL i;
  1096.                       for (i = 0; i < len; i++, pdata += eltype_size)
  1097.                         { # pdata = (char*)data + i*eltype_size
  1098.                           pushSTACK(STACK_0); # array
  1099.                           pushSTACK(fixnum(i));
  1100.                           pushSTACK(convert_from_foreign(STACK_(1+2),(void*)pdata));
  1101.                           funcall(L(svstore),3);
  1102.                         }
  1103.                       array = popSTACK();
  1104.                     }}
  1105.                   skipSTACK(1);
  1106.                   return array;
  1107.               }}}
  1108.             elif (eq(fvdtype,S(c_function)) && (fvdlen == 4))
  1109.               { if (*(void**)data == NULL)
  1110.                   return NIL;
  1111.                 else
  1112.                   return convert_function_from_foreign(*(void**)data,
  1113.                                                        TheSvector(fvd)->data[1],
  1114.                                                        TheSvector(fvd)->data[2],
  1115.                                                        TheSvector(fvd)->data[3]
  1116.                                                       );
  1117.               }
  1118.             elif ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null))) && (fvdlen == 2))
  1119.               { if (*(void**)data == NULL)
  1120.                   return NIL;
  1121.                 else
  1122.                   return convert_from_foreign(TheSvector(fvd)->data[1], *(void**)data);
  1123.               }
  1124.             elif (eq(fvdtype,S(c_array_ptr)) && (fvdlen == 2))
  1125.               { if (*(void**)data == NULL)
  1126.                   return NIL;
  1127.                 else
  1128.                   { var reg9 object eltype = TheSvector(fvd)->data[1];
  1129.                     var reg7 uintL eltype_size = (foreign_layout(eltype), data_size);
  1130.                     if (eltype_size == 0)
  1131.                       { pushSTACK(fvd);
  1132.                         //: DEUTSCH "Elementtyp hat Größe 0: ~"
  1133.                         //: ENGLISH "element type has size 0: ~"
  1134.                         //: FRANCAIS "Le type des éléments est de grandeur 0 : ~"
  1135.                         fehler(error, GETTEXT("element type has size 0: ~"));
  1136.                       }
  1137.                     # Determine length of array:
  1138.                    {var reg5 uintL len = 0;
  1139.                     { var reg4 void* ptr = *(void**)data;
  1140.                       until (blockzerop(ptr,eltype_size))
  1141.                         { ptr = (void*)((uintP)ptr + eltype_size); len++; }
  1142.                     }
  1143.                     pushSTACK(eltype);
  1144.                     # Allocate Lisp array:
  1145.                     pushSTACK(allocate_vector(len));
  1146.                     # Fill Lisp array:
  1147.                     { var reg4 void* ptr = *(void**)data;
  1148.                       var reg6 uintL i;
  1149.                       for (i = 0; i < len; i++)
  1150.                         { var reg5 object obj = convert_from_foreign(STACK_1,ptr);
  1151.                           TheSvector(STACK_0)->data[i] = obj;
  1152.                           ptr = (void*)((uintP)ptr + eltype_size);
  1153.                     }   }
  1154.                     { var reg4 object result = STACK_0;
  1155.                       skipSTACK(2);
  1156.                       return result;
  1157.               }   }}}
  1158.       }   }
  1159.     fehler_foreign_type(fvd);
  1160.   }
  1161.  
  1162. # Test whether a foreign type contained C-PTRs (recursively).
  1163. local boolean foreign_with_pointers_p (object fvd);
  1164. local boolean foreign_with_pointers_p(fvd)
  1165.   var reg1 object fvd;
  1166.   { check_SP();
  1167.     if (symbolp(fvd))
  1168.       { if (eq(fvd,S(c_string))) return TRUE;
  1169.         return FALSE;
  1170.       }
  1171.     elif (simple_vector_p(fvd))
  1172.       { var reg4 uintL fvdlen = TheSvector(fvd)->length;
  1173.         if (fvdlen > 0)
  1174.           { var reg2 object fvdtype = TheSvector(fvd)->data[0];
  1175.             if (eq(fvdtype,S(c_struct)) && (fvdlen > 2))
  1176.               { var reg3 uintL i;
  1177.                 for (i = 3; i < fvdlen; i++)
  1178.                   if (foreign_with_pointers_p(TheSvector(fvd)->data[i]))
  1179.                     return TRUE;
  1180.                 return FALSE;
  1181.               }
  1182.             elif (eq(fvdtype,S(c_union)) && (fvdlen > 1))
  1183.               { # Use the union's first component.
  1184.                 return foreign_with_pointers_p(fvdlen > 2 ? TheSvector(fvd)->data[2] : NIL);
  1185.               }
  1186.             elif ((eq(fvdtype,S(c_array)) && (fvdlen > 1)) || (eq(fvdtype,S(c_array_max)) && (fvdlen == 3)))
  1187.               { var reg3 uintL i;
  1188.                 for (i = 2; i < fvdlen; i++)
  1189.                   if (eq(TheSvector(fvd)->data[i],Fixnum_0))
  1190.                     return FALSE;
  1191.                 return foreign_with_pointers_p(TheSvector(fvd)->data[1]);
  1192.               }
  1193.             elif (eq(fvdtype,S(c_function)) && (fvdlen == 4))
  1194.               { return TRUE; }
  1195.             elif ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null)) || eq(fvdtype,S(c_array_ptr)))
  1196.                   && (fvdlen == 2))
  1197.               { return TRUE; }
  1198.       }   }
  1199.     fehler_foreign_type(fvd);
  1200.   }
  1201.  
  1202. # Walk foreign data, giving special attention to the pointers.
  1203. local void walk_foreign_pointers (object fvd, void* data);
  1204. # Some flags and hooks that direct the walk:
  1205. local boolean walk_foreign_null_terminates;
  1206. local void (*walk_foreign_pre_hook) (object fvd, void** pdata); # what's the meaning of fvd here??
  1207. local void (*walk_foreign_post_hook) (object fvd, void** pdata); # what's the meaning of fvd here??
  1208. local void (*walk_foreign_function_hook) (object fvd, void** pdata);
  1209. local void walk_foreign_pointers(fvd,data)
  1210.   var reg1 object fvd;
  1211.   var reg3 void* data;
  1212.   { if (!foreign_with_pointers_p(fvd))
  1213.       return;
  1214.     check_SP();
  1215.     if (symbolp(fvd))
  1216.       { if (eq(fvd,S(c_string)))
  1217.           { if (walk_foreign_null_terminates)
  1218.               # NULL pointers stop the recursion
  1219.               { if (*(void**)data == NULL) return; }
  1220.             (*walk_foreign_pre_hook)(fvd,(void**)data);
  1221.             (*walk_foreign_post_hook)(fvd,(void**)data);
  1222.             return;
  1223.       }   }
  1224.     elif (simple_vector_p(fvd))
  1225.       { var reg8 uintL fvdlen = TheSvector(fvd)->length;
  1226.         if (fvdlen > 0)
  1227.           { var reg2 object fvdtype = TheSvector(fvd)->data[0];
  1228.             if (eq(fvdtype,S(c_struct)) && (fvdlen > 2))
  1229.               { var reg4 uintL cumul_size = 0;
  1230.                 var reg5 uintL cumul_alignment = struct_alignment;
  1231.                 var reg6 uintL i;
  1232.                 for (i = 3; i < fvdlen; i++)
  1233.                   { var reg7 object fvdi = TheSvector(fvd)->data[i];
  1234.                     foreign_layout(fvdi);
  1235.                     # We assume all alignments are of the form 2^k.
  1236.                     cumul_size += (-cumul_size) & (data_alignment-1);
  1237.                    {var reg9 void* pdata = (char*)data + cumul_size;
  1238.                     cumul_size += data_size;
  1239.                     # cumul_alignment = lcm(cumul_alignment,data_alignment);
  1240.                     if (data_alignment > cumul_alignment)
  1241.                       cumul_alignment = data_alignment;
  1242.                     # Now we are finished with data_size and data_alignment.
  1243.                     # Descend into the structure slot:
  1244.                     walk_foreign_pointers(fvdi,pdata);
  1245.                   }}
  1246.                 return;
  1247.               }
  1248.             elif (eq(fvdtype,S(c_union)) && (fvdlen > 1))
  1249.               { # Use the union's first component.
  1250.                 if (fvdlen > 2)
  1251.                   walk_foreign_pointers(TheSvector(fvd)->data[2],data);
  1252.                 return;
  1253.               }
  1254.             elif (eq(fvdtype,S(c_array)) && (fvdlen > 1))
  1255.               { var reg9 object eltype = TheSvector(fvd)->data[1];
  1256.                 var reg7 uintL eltype_size = (foreign_layout(eltype), data_size);
  1257.                 var reg6 uintL size = 1;
  1258.                 { var reg5 uintL i;
  1259.                   for (i = 2; i < fvdlen; i++)
  1260.                     { var reg4 object dim = TheSvector(fvd)->data[i];
  1261.                       if (!uint32_p(dim)) { fehler_foreign_type(fvd); }
  1262.                       size = size * I_to_uint32(dim);
  1263.                 }   }
  1264.                 { var reg4 uintL i;
  1265.                   var reg5 char* pdata = (char*)data;
  1266.                   for (i = 0; i < size; i++, pdata += eltype_size)
  1267.                     { # pdata = (char*)data + i*eltype_size
  1268.                       walk_foreign_pointers(eltype,pdata);
  1269.                 }   }
  1270.                 return;
  1271.               }
  1272.             elif (eq(fvdtype,S(c_array_max)) && (fvdlen == 3))
  1273.               { var reg9 object eltype = TheSvector(fvd)->data[1];
  1274.                 var reg7 uintL eltype_size = (foreign_layout(eltype), data_size);
  1275.                 if (eltype_size == 0)
  1276.                   { pushSTACK(fvd);
  1277.                     //: DEUTSCH "Elementtyp hat Größe 0: ~"
  1278.                     //: ENGLISH "element type has size 0: ~"
  1279.                     //: FRANCAIS "Le type des éléments est de grandeur 0 : ~"
  1280.                     fehler(error, GETTEXT("element type has size 0: ~"));
  1281.                   }
  1282.                 { var reg6 uintL maxdim = I_to_UL(TheSvector(fvd)->data[2]);
  1283.                   var reg5 uintL len = 0;
  1284.                   var reg4 void* ptr = data;
  1285.                   until ((len == maxdim) || blockzerop(ptr,eltype_size))
  1286.                     { walk_foreign_pointers(eltype,ptr);
  1287.                       ptr = (void*)((uintP)ptr + eltype_size); len++;
  1288.                 }   }
  1289.                 return;
  1290.               }
  1291.             elif (eq(fvdtype,S(c_function)) && (fvdlen == 4))
  1292.               { (*walk_foreign_function_hook)(fvd,(void**)data);
  1293.                 return;
  1294.               }
  1295.             elif ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null))) && (fvdlen == 2))
  1296.               { if (walk_foreign_null_terminates)
  1297.                   # NULL pointers stop the recursion
  1298.                   { if (*(void**)data == NULL) return; }
  1299.                 fvd = TheSvector(fvd)->data[1];
  1300.                 (*walk_foreign_pre_hook)(fvd,(void**)data);
  1301.                 walk_foreign_pointers(fvd,*(void**)data);
  1302.                 (*walk_foreign_post_hook)(fvd,(void**)data);
  1303.                 return;
  1304.               }
  1305.             elif (eq(fvdtype,S(c_array_ptr)) && (fvdlen == 2))
  1306.               { if (walk_foreign_null_terminates)
  1307.                   # NULL pointers stop the recursion
  1308.                   { if (*(void**)data == NULL) return; }
  1309.                {var reg6 object elfvd = TheSvector(fvd)->data[1];
  1310.                 (*walk_foreign_pre_hook)(elfvd,(void**)data);
  1311.                 { var reg5 uintL eltype_size = (foreign_layout(elfvd), data_size);
  1312.                   if (eltype_size == 0)
  1313.                     { pushSTACK(fvd);
  1314.                       //: DEUTSCH "Elementtyp hat Größe 0: ~"
  1315.                       //: ENGLISH "element type has size 0: ~"
  1316.                       //: FRANCAIS "Le type des éléments est de grandeur 0 : ~"
  1317.                       fehler(error, GETTEXT("element type has size 0: ~"));
  1318.                     }
  1319.                  {var reg4 void* ptr = *(void**)data;
  1320.                   until (blockzerop(ptr,eltype_size))
  1321.                     { walk_foreign_pointers(elfvd,ptr);
  1322.                       ptr = (void*)((uintP)ptr + eltype_size);
  1323.                 }}  }
  1324.                 (*walk_foreign_post_hook)(elfvd,(void**)data);
  1325.                 return;
  1326.               }}
  1327.       }   }
  1328.     fehler_foreign_type(fvd);
  1329.   }
  1330.  
  1331. # Free the storage used by foreign data.
  1332. global void free_foreign (object fvd, void* data);
  1333. local void free_walk_pre (object fvd, void** pdata);
  1334. local void free_walk_post (object fvd, void** pdata);
  1335. local void free_walk_function (object fvd, void** pdata);
  1336. local void free_walk_pre(fvd,pdata)
  1337.   var reg1 object fvd;
  1338.   var reg2 void** pdata;
  1339.   { }
  1340. local void free_walk_post(fvd,pdata)
  1341.   var reg2 object fvd;
  1342.   var reg1 void** pdata;
  1343.   { free(*pdata);
  1344.     *pdata = NULL; # for safety
  1345.   }
  1346. local void free_walk_function(fvd,pdata)
  1347.   var reg2 object fvd;
  1348.   var reg1 void** pdata;
  1349.   { free_foreign_callin(*pdata);
  1350.     *pdata = NULL; # for safety
  1351.   }
  1352. global void free_foreign(fvd,data)
  1353.   var reg1 object fvd;
  1354.   var reg2 void* data;
  1355.   { walk_foreign_null_terminates = TRUE;
  1356.     walk_foreign_pre_hook = &free_walk_pre;
  1357.     walk_foreign_post_hook = &free_walk_post;
  1358.     walk_foreign_function_hook = &free_walk_function;
  1359.     walk_foreign_pointers(fvd,data);
  1360.   }
  1361.  
  1362. # Walk Lisp data, giving special attention to the pointers.
  1363. # kann GC auslösen
  1364. local void walk_lisp_pointers (object fvd, object obj);
  1365. # Some flags and hooks that direct the walk:
  1366. local boolean walk_lisp_nil_terminates;
  1367. local void (*walk_lisp_pre_hook) (object fvd, object obj);
  1368. local void (*walk_lisp_post_hook) (object fvd, object obj);
  1369. local void (*walk_lisp_function_hook) (object fvd, object obj);
  1370. local void walk_lisp_pointers(fvd,obj)
  1371.   var reg1 object fvd;
  1372.   var reg3 object obj;
  1373.   { if (!foreign_with_pointers_p(fvd))
  1374.       return;
  1375.     check_SP();
  1376.     check_STACK();
  1377.     if (symbolp(fvd))
  1378.       { if (eq(fvd,S(c_string)))
  1379.           { if (walk_lisp_nil_terminates)
  1380.               # NIL pointers stop the recursion
  1381.               { if (nullp(obj)) return; }
  1382.             if (!stringp(obj)) goto bad_obj;
  1383.             (*walk_lisp_pre_hook)(fvd,obj);
  1384.             (*walk_lisp_post_hook)(fvd,obj);
  1385.             return;
  1386.       }   }
  1387.     elif (simple_vector_p(fvd))
  1388.       { var reg8 uintL fvdlen = TheSvector(fvd)->length;
  1389.         if (fvdlen > 0)
  1390.           { var reg2 object fvdtype = TheSvector(fvd)->data[0];
  1391.             if (eq(fvdtype,S(c_struct)) && (fvdlen > 2))
  1392.               { var reg8 object slots = TheSvector(fvd)->data[1];
  1393.                 var reg8 object constructor = TheSvector(fvd)->data[2];
  1394.                 if (!(simple_vector_p(slots) && (TheSvector(slots)->length==fvdlen-3)))
  1395.                   { fehler_foreign_type(fvd); }
  1396.                 if (eq(constructor,L(vector)))
  1397.                   { if (!(simple_vector_p(obj) && (TheSvector(obj)->length==fvdlen-3)))
  1398.                       goto bad_obj;
  1399.                   }
  1400.                 elif (eq(constructor,L(list)))
  1401.                   { }
  1402.                 else
  1403.                   { if (!(structurep(obj) || instancep(obj)))
  1404.                       goto bad_obj;
  1405.                   }
  1406.                 pushSTACK(constructor);
  1407.                 pushSTACK(slots);
  1408.                 pushSTACK(fvd);
  1409.                 pushSTACK(obj);
  1410.                {var reg4 uintL cumul_size = 0;
  1411.                 var reg5 uintL cumul_alignment = struct_alignment;
  1412.                 var reg6 uintL i;
  1413.                 for (i = 3; i < fvdlen; i++)
  1414.                   { var reg8 object obji;
  1415.                     if (eq(STACK_3,L(vector)))
  1416.                       { obji = TheSvector(STACK_0)->data[i-3]; }
  1417.                     elif (eq(STACK_3,L(list)))
  1418.                       { obji = STACK_0;
  1419.                         if (atomp(obji)) goto bad_obj;
  1420.                         STACK_0 = Cdr(obji); obji = Car(obji);
  1421.                       }
  1422.                     else # simple_vector_p(slots) && (TheSvector(slots)->length==fvdlen-3)
  1423.                       { pushSTACK(STACK_0); pushSTACK(TheSvector(STACK_(2+1))->data[i-3]);
  1424.                         funcall(L(slot_value),2); obji = value1;
  1425.                       }
  1426.                     { var reg7 object fvdi = TheSvector(STACK_1)->data[i];
  1427.                       foreign_layout(fvdi);
  1428.                       # We assume all alignments are of the form 2^k.
  1429.                       cumul_size += (-cumul_size) & (data_alignment-1);
  1430.                       cumul_size += data_size;
  1431.                       # cumul_alignment = lcm(cumul_alignment,data_alignment);
  1432.                       if (data_alignment > cumul_alignment)
  1433.                         cumul_alignment = data_alignment;
  1434.                       # Now we are finished with data_size and data_alignment.
  1435.                       # Descend into the structure slot:
  1436.                       walk_lisp_pointers(fvdi,obji);
  1437.                   } }
  1438.                 skipSTACK(4);
  1439.                 return;
  1440.               }}
  1441.             elif (eq(fvdtype,S(c_union)) && (fvdlen > 1))
  1442.               { # Use the union's first component.
  1443.                 if (fvdlen > 2)
  1444.                   walk_lisp_pointers(TheSvector(fvd)->data[2],obj);
  1445.                 return;
  1446.               }
  1447.             elif (eq(fvdtype,S(c_array)) && (fvdlen > 1))
  1448.               { var reg9 object eltype = TheSvector(fvd)->data[1];
  1449.                 var reg6 uintL size = 1;
  1450.                 foreign_layout(eltype);
  1451.                 { var reg5 uintL i;
  1452.                   for (i = 2; i < fvdlen; i++)
  1453.                     { var reg4 object dim = TheSvector(fvd)->data[i];
  1454.                       if (!uint32_p(dim)) { fehler_foreign_type(fvd); }
  1455.                       size = size * I_to_uint32(dim);
  1456.                 }   }
  1457.                 if (!(arrayp(obj) && array_total_size(obj)==size))
  1458.                   goto bad_obj;
  1459.                 pushSTACK(eltype);
  1460.                 pushSTACK(obj);
  1461.                 { var reg4 uintL i;
  1462.                   for (i = 0; i < size; i++)
  1463.                     { pushSTACK(STACK_0); pushSTACK(fixnum(i));
  1464.                       funcall(L(row_major_aref),2);
  1465.                       walk_lisp_pointers(STACK_1,value1);
  1466.                 }   }
  1467.                 skipSTACK(2);
  1468.                 return;
  1469.               }
  1470.             elif (eq(fvdtype,S(c_array_max)) && (fvdlen == 3))
  1471.               { var reg9 object eltype = TheSvector(fvd)->data[1];
  1472.                 var reg6 uintL maxdim = I_to_UL(TheSvector(fvd)->data[2]);
  1473.                 foreign_layout(eltype);
  1474.                 if (!vectorp(obj))
  1475.                   goto bad_obj;
  1476.                {var reg5 uintL len = vector_length(obj);
  1477.                 if (len > maxdim) { len = maxdim; }
  1478.                 pushSTACK(eltype);
  1479.                 pushSTACK(obj);
  1480.                 { var reg4 uintL i;
  1481.                   for (i = 0; i < len; i++)
  1482.                     { pushSTACK(STACK_0); pushSTACK(fixnum(i));
  1483.                       funcall(L(aref),2);
  1484.                       walk_lisp_pointers(STACK_1,value1);
  1485.                 }   }
  1486.                 skipSTACK(2);
  1487.                 return;
  1488.               }}
  1489.             elif (eq(fvdtype,S(c_function)) && (fvdlen == 4))
  1490.               { (*walk_lisp_function_hook)(fvd,obj);
  1491.                 return;
  1492.               }
  1493.             elif ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null))) && (fvdlen == 2))
  1494.               { if (walk_lisp_nil_terminates)
  1495.                   # NIL pointers stop the recursion
  1496.                   { if (nullp(obj)) return; }
  1497.                 (*walk_lisp_pre_hook)(fvd,obj);
  1498.                 pushSTACK(fvd);
  1499.                 walk_lisp_pointers(TheSvector(fvd)->data[1],obj);
  1500.                 fvd = popSTACK();
  1501.                 (*walk_lisp_post_hook)(fvd,obj);
  1502.                 return;
  1503.               }
  1504.             elif (eq(fvdtype,S(c_array_ptr)) && (fvdlen == 2))
  1505.               { if (walk_lisp_nil_terminates)
  1506.                   # NIL pointers stop the recursion
  1507.                   { if (nullp(obj)) return; }
  1508.                 if (!vectorp(obj)) goto bad_obj;
  1509.                 (*walk_lisp_pre_hook)(fvd,obj);
  1510.                 pushSTACK(fvd);
  1511.                 pushSTACK(TheSvector(fvd)->data[1]); # eltype
  1512.                 pushSTACK(obj);
  1513.                 { var reg5 uintL size = vector_length(obj);
  1514.                   var reg4 uintL i;
  1515.                   for (i = 0; i < size; i++)
  1516.                     { pushSTACK(STACK_0); pushSTACK(fixnum(i));
  1517.                       funcall(L(aref),2);
  1518.                       walk_lisp_pointers(STACK_1,value1);
  1519.                 }   }
  1520.                 skipSTACK(2);
  1521.                 fvd = popSTACK();
  1522.                 (*walk_lisp_post_hook)(fvd,obj);
  1523.                 return;
  1524.               }
  1525.       }   }
  1526.     fehler_foreign_type(fvd);
  1527.    bad_obj:
  1528.     fehler_convert(fvd,obj);
  1529.   }
  1530.  
  1531. # Determine amount of additional storage needed to convert Lisp data to foreign data.
  1532. # kann GC auslösen
  1533. local void convert_to_foreign_needs (object fvd, object obj);
  1534. local uintL walk_counter;
  1535. local uintL walk_alignment;
  1536. local void count_walk_pre (object fvd, object obj);
  1537. local void count_walk_post (object fvd, object obj);
  1538. local void count_walk_pre(fvd,obj)
  1539.   var reg1 object fvd;
  1540.   var reg4 object obj;
  1541.   { var reg3 uintL size;
  1542.     var reg2 uintL alignment;
  1543.     if (eq(fvd,S(c_string)))
  1544.       { size = (nullp(obj) ? 0 : vector_length(obj)+1); alignment = 1; }
  1545.       else # fvd = #(c-ptr ...) or #(c-ptr-null ...) or #(c-array-ptr ...)
  1546.       { foreign_layout(TheSvector(fvd)->data[1]);
  1547.         size = data_size; alignment = data_alignment;
  1548.       }
  1549.     walk_counter = ((walk_counter + alignment-1) & -alignment) + size;
  1550.     # walk_alignment = lcm(walk_alignment,alignment);
  1551.     if (alignment > walk_alignment)
  1552.       walk_alignment = alignment;
  1553.   }
  1554. local void count_walk_post(fvd,obj)
  1555.   var reg1 object fvd;
  1556.   var reg2 object obj;
  1557.   { }
  1558. local void convert_to_foreign_needs(fvd,obj)
  1559.   var reg1 object fvd;
  1560.   var reg2 object obj;
  1561.   { walk_lisp_nil_terminates = TRUE;
  1562.     walk_counter = 0; walk_alignment = 1;
  1563.     walk_lisp_pre_hook = &count_walk_pre;
  1564.     walk_lisp_post_hook = &count_walk_post;
  1565.     walk_lisp_function_hook = &count_walk_post;
  1566.     walk_lisp_pointers(fvd,obj);
  1567.     data_size = walk_counter; data_alignment = walk_alignment;
  1568.   }
  1569.  
  1570. # Convert Lisp data to foreign data. Storage is allocated through converter_malloc().
  1571. # Only the toplevel storage must already exist; its address is given.
  1572. # kann GC auslösen
  1573. local void convert_to_foreign (object fvd, object obj, void* data);
  1574. local void* (*converter_malloc) (void* old_data, uintL size, uintL alignment);
  1575. local void convert_to_foreign(fvd,obj,data)
  1576.   var reg9 object fvd;
  1577.   var reg9 object obj;
  1578.   var reg9 void* data;
  1579.   { check_SP();
  1580.     check_STACK();
  1581.     if (symbolp(fvd))
  1582.       { if (eq(fvd,S(nil)))
  1583.           # If we are presented the empty type, we take it as "ignore".
  1584.           { return; }
  1585.         elif (eq(fvd,S(boolean)))
  1586.           { var reg2 int* pdata = (int*)data;
  1587.             if (eq(obj,NIL)) { *pdata = 0; }
  1588.             elif (eq(obj,T)) { *pdata = 1; }
  1589.             else goto bad_obj;
  1590.             return;
  1591.           }
  1592.         elif (eq(fvd,S(character)))
  1593.           { var reg2 uintB* pdata = (unsigned char *)data;
  1594.             if (!string_char_p(obj)) goto bad_obj;
  1595.             *pdata = char_code(obj);
  1596.             return;
  1597.           }
  1598.         elif (eq(fvd,S(char)) || eq(fvd,S(sint8)))
  1599.           { var reg2 sint8* pdata = (sint8*)data;
  1600.             if (!sint8_p(obj)) goto bad_obj;
  1601.             *pdata = I_to_sint8(obj);
  1602.             return;
  1603.           }
  1604.         elif (eq(fvd,S(uchar)) || eq(fvd,S(uint8)))
  1605.           { var reg2 uint8* pdata = (uint8*)data;
  1606.             if (!uint8_p(obj)) goto bad_obj;
  1607.             *pdata = I_to_uint8(obj);
  1608.             return;
  1609.           }
  1610.         elif (eq(fvd,S(short)) || eq(fvd,S(sint16)))
  1611.           { var reg2 sint16* pdata = (sint16*)data;
  1612.             if (!sint16_p(obj)) goto bad_obj;
  1613.             *pdata = I_to_sint16(obj);
  1614.             return;
  1615.           }
  1616.         elif (eq(fvd,S(ushort)) || eq(fvd,S(uint16)))
  1617.           { var reg2 uint16* pdata = (uint16*)data;
  1618.             if (!uint16_p(obj)) goto bad_obj;
  1619.             *pdata = I_to_uint16(obj);
  1620.             return;
  1621.           }
  1622.         elif (eq(fvd,S(sint32)))
  1623.           { var reg2 sint32* pdata = (sint32*)data;
  1624.             if (!sint32_p(obj)) goto bad_obj;
  1625.             *pdata = I_to_sint32(obj);
  1626.             return;
  1627.           }
  1628.         elif (eq(fvd,S(uint32)))
  1629.           { var reg2 uint32* pdata = (uint32*)data;
  1630.             if (!uint32_p(obj)) goto bad_obj;
  1631.             *pdata = I_to_uint32(obj);
  1632.             return;
  1633.           }
  1634.         #ifdef HAVE_LONGLONG
  1635.         elif (eq(fvd,S(sint64)))
  1636.           { var reg2 struct_sint64* pdata = (struct_sint64*)data;
  1637.             if (!sint64_p(obj)) goto bad_obj;
  1638.            {var reg5 sint64 val = I_to_sint64(obj);
  1639.             #if (long_bitsize<64)
  1640.             pdata->hi = (sint32)(val>>32); pdata->lo = (uint32)val;
  1641.             #else
  1642.             *pdata = val;
  1643.             #endif
  1644.             return;
  1645.           }}
  1646.         elif (eq(fvd,S(uint64)))
  1647.           { var reg2 struct_uint64* pdata = (struct_uint64*)data;
  1648.             if (!uint64_p(obj)) goto bad_obj;
  1649.            {var reg5 uint64 val = I_to_uint64(obj);
  1650.             #if (long_bitsize<64)
  1651.             pdata->hi = (uint32)(val>>32); pdata->lo = (uint32)val;
  1652.             #else
  1653.             *pdata = val;
  1654.             #endif
  1655.             return;
  1656.           }}
  1657.         #else
  1658.         elif (eq(fvd,S(sint64)) || eq(fvd,S(uint64)))
  1659.           { fehler_64bit(fvd); }
  1660.         #endif
  1661.         elif (eq(fvd,S(int)))
  1662.           { var reg2 int* pdata = (int*)data;
  1663.             if (!sint_p(obj)) goto bad_obj;
  1664.             *pdata = I_to_sint(obj);
  1665.             return;
  1666.           }
  1667.         elif (eq(fvd,S(uint)))
  1668.           { var reg2 unsigned int * pdata = (unsigned int *)data;
  1669.             if (!uint_p(obj)) goto bad_obj;
  1670.             *pdata = I_to_uint(obj);
  1671.             return;
  1672.           }
  1673.         elif (eq(fvd,S(long)))
  1674.           { var reg2 long* pdata = (long*)data;
  1675.             if (!slong_p(obj)) goto bad_obj;
  1676.             *pdata = I_to_slong(obj);
  1677.             return;
  1678.           }
  1679.         elif (eq(fvd,S(ulong)))
  1680.           { var reg2 unsigned long * pdata = (unsigned long *)data;
  1681.             if (!ulong_p(obj)) goto bad_obj;
  1682.             *pdata = I_to_ulong(obj);
  1683.             return;
  1684.           }
  1685.         elif (eq(fvd,S(single_float)))
  1686.           { var reg2 ffloatjanus* pdata = (ffloatjanus*) data;
  1687.             if (!single_float_p(obj)) goto bad_obj;
  1688.             FF_to_c_float(obj,pdata);
  1689.             return;
  1690.           }
  1691.         elif (eq(fvd,S(double_float)))
  1692.           { var reg2 dfloatjanus* pdata = (dfloatjanus*) data;
  1693.             if (!double_float_p(obj)) goto bad_obj;
  1694.             DF_to_c_double(obj,pdata);
  1695.             return;
  1696.           }
  1697.         elif (eq(fvd,S(c_pointer)))
  1698.           { if (!faddressp(obj)) goto bad_obj;
  1699.             *(void**)data = Faddress_value(obj);
  1700.             return;
  1701.           }
  1702.         elif (eq(fvd,S(c_string)))
  1703.           { if (nullp(obj))
  1704.               { *(char**)data = NULL; return; }
  1705.             if (!stringp(obj)) goto bad_obj;
  1706.            {var uintL len;
  1707.             var reg2 uintB* ptr1 = unpack_string(obj,&len);
  1708.             var reg5 char* asciz = converter_malloc(*(char**)data,len+1,1);
  1709.             {var reg1 uintB* ptr2 = (uintB*)asciz;
  1710.              var reg4 uintL count;
  1711.              dotimesL(count,len, { *ptr2++ = *ptr1++; } );
  1712.              *ptr2++ = '\0';
  1713.             }
  1714.             *(char**)data = asciz;
  1715.             return;
  1716.           }}
  1717.       }
  1718.     elif (simple_vector_p(fvd))
  1719.       { var reg8 uintL fvdlen = TheSvector(fvd)->length;
  1720.         if (fvdlen > 0)
  1721.           { var reg2 object fvdtype = TheSvector(fvd)->data[0];
  1722.             if (eq(fvdtype,S(c_struct)) && (fvdlen > 2))
  1723.               { var reg8 object slots = TheSvector(fvd)->data[1];
  1724.                 var reg8 object constructor = TheSvector(fvd)->data[2];
  1725.                 if (!(simple_vector_p(slots) && (TheSvector(slots)->length==fvdlen-3)))
  1726.                   { fehler_foreign_type(fvd); }
  1727.                 if (eq(constructor,L(vector)))
  1728.                   { if (!(simple_vector_p(obj) && (TheSvector(obj)->length==fvdlen-3)))
  1729.                       goto bad_obj;
  1730.                   }
  1731.                 elif (eq(constructor,L(list)))
  1732.                   { }
  1733.                 else
  1734.                   { if (!(structurep(obj) || instancep(obj)))
  1735.                       goto bad_obj;
  1736.                   }
  1737.                 pushSTACK(constructor);
  1738.                 pushSTACK(slots);
  1739.                 pushSTACK(fvd);
  1740.                 pushSTACK(obj);
  1741.                {var reg4 uintL cumul_size = 0;
  1742.                 var reg5 uintL cumul_alignment = struct_alignment;
  1743.                 var reg6 uintL i;
  1744.                 for (i = 3; i < fvdlen; i++)
  1745.                   { var reg8 object obji;
  1746.                     if (eq(STACK_3,L(vector)))
  1747.                       { obji = TheSvector(STACK_0)->data[i-3]; }
  1748.                     elif (eq(STACK_3,L(list)))
  1749.                       { obji = STACK_0;
  1750.                         if (atomp(obji)) goto bad_obj;
  1751.                         STACK_0 = Cdr(obji); obji = Car(obji);
  1752.                       }
  1753.                     else # simple_vector_p(slots) && (TheSvector(slots)->length==fvdlen-3)
  1754.                       { pushSTACK(STACK_0); pushSTACK(TheSvector(STACK_(2+1))->data[i-3]);
  1755.                         funcall(L(slot_value),2); obji = value1;
  1756.                       }
  1757.                     { var reg7 object fvdi = TheSvector(STACK_1)->data[i];
  1758.                       foreign_layout(fvdi);
  1759.                       # We assume all alignments are of the form 2^k.
  1760.                       cumul_size += (-cumul_size) & (data_alignment-1);
  1761.                      {var reg9 void* pdata = (char*)data + cumul_size;
  1762.                       cumul_size += data_size;
  1763.                       # cumul_alignment = lcm(cumul_alignment,data_alignment);
  1764.                       if (data_alignment > cumul_alignment)
  1765.                         cumul_alignment = data_alignment;
  1766.                       # Now we are finished with data_size and data_alignment.
  1767.                       # Descend into the structure slot:
  1768.                       convert_to_foreign(fvdi,obji,pdata);
  1769.                   } }}
  1770.                 skipSTACK(4);
  1771.                 return;
  1772.               }}
  1773.             elif (eq(fvdtype,S(c_union)) && (fvdlen > 1))
  1774.               { # Use the union's first component.
  1775.                 convert_to_foreign(fvdlen > 2 ? TheSvector(fvd)->data[2] : NIL,obj,data);
  1776.                 return;
  1777.               }
  1778.             elif (eq(fvdtype,S(c_array)) && (fvdlen > 1))
  1779.               { var reg9 object eltype = TheSvector(fvd)->data[1];
  1780.                 var reg7 uintL eltype_size = (foreign_layout(eltype), data_size);
  1781.                 var reg6 uintL size = 1;
  1782.                 { var reg5 uintL i;
  1783.                   for (i = 2; i < fvdlen; i++)
  1784.                     { var reg4 object dim = TheSvector(fvd)->data[i];
  1785.                       if (!uint32_p(dim)) { fehler_foreign_type(fvd); }
  1786.                       size = size * I_to_uint32(dim);
  1787.                 }   }
  1788.                 if (!(arrayp(obj) && array_total_size(obj)==size))
  1789.                   goto bad_obj;
  1790.                 if (eq(eltype,S(character)) && stringp(obj))
  1791.                   { var uintL len;
  1792.                     var reg2 uintB* ptr1 = unpack_string(obj,&len);
  1793.                     var reg1 uintB* ptr2 = (uintB*)data;
  1794.                     var reg4 uintL count;
  1795.                     dotimesL(count,len, { *ptr2++ = *ptr1++; } );
  1796.                   }
  1797.                 elif (eq(eltype,S(uint8))
  1798.                       && ((typecode(obj) & ~imm_array_mask) == bvector_type)
  1799.                       && ((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_8Bit)
  1800.                      )
  1801.                   { var uintL index = 0;
  1802.                     obj = array_displace_check(obj,size,&index);
  1803.                    {var reg2 uint8* ptr1 = &TheSbvector(TheArray(obj)->data)->data[index];
  1804.                     var reg1 uint8* ptr2 = (uint8*)data;
  1805.                     var reg4 uintL count;
  1806.                     dotimesL(count,size, { *ptr2++ = *ptr1++; } );
  1807.                   }}
  1808.                 elif (eq(eltype,S(uint16))
  1809.                       && ((typecode(obj) & ~imm_array_mask) == bvector_type)
  1810.                       && ((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_16Bit)
  1811.                      )
  1812.                   { var uintL index = 0;
  1813.                     obj = array_displace_check(obj,size,&index);
  1814.                    {var reg2 uint16* ptr1 = (uint16*)&TheSbvector(TheArray(obj)->data)->data[2*index];
  1815.                     var reg1 uint16* ptr2 = (uint16*)data;
  1816.                     var reg4 uintL count;
  1817.                     dotimesL(count,size, { *ptr2++ = *ptr1++; } );
  1818.                   }}
  1819.                 elif (eq(eltype,S(uint32))
  1820.                       && ((typecode(obj) & ~imm_array_mask) == bvector_type)
  1821.                       && ((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_32Bit)
  1822.                      )
  1823.                   { var uintL index = 0;
  1824.                     obj = array_displace_check(obj,size,&index);
  1825.                    {var reg2 uint32* ptr1 = (uint32*)&TheSbvector(TheArray(obj)->data)->data[4*index];
  1826.                     var reg1 uint32* ptr2 = (uint32*)data;
  1827.                     var reg4 uintL count;
  1828.                     dotimesL(count,size, { *ptr2++ = *ptr1++; } );
  1829.                   }}
  1830.                 else
  1831.                   { pushSTACK(eltype);
  1832.                     pushSTACK(obj);
  1833.                     { var reg4 uintL i;
  1834.                       var reg5 char* pdata = (char*)data;
  1835.                       for (i = 0; i < size; i++, pdata += eltype_size)
  1836.                         { # pdata = (char*)data + i*eltype_size
  1837.                           pushSTACK(STACK_0); pushSTACK(fixnum(i));
  1838.                           funcall(L(row_major_aref),2);
  1839.                           convert_to_foreign(STACK_1,value1,pdata);
  1840.                     }   }
  1841.                     skipSTACK(2);
  1842.                   }
  1843.                 return;
  1844.               }
  1845.             elif (eq(fvdtype,S(c_array_max)) && (fvdlen == 3))
  1846.               { var reg9 object eltype = TheSvector(fvd)->data[1];
  1847.                 var reg7 uintL eltype_size = (foreign_layout(eltype), data_size);
  1848.                 var reg6 uintL maxdim = I_to_UL(TheSvector(fvd)->data[2]);
  1849.                 if (!vectorp(obj))
  1850.                   goto bad_obj;
  1851.                {var reg5 uintL len = vector_length(obj);
  1852.                 if (len > maxdim) { len = maxdim; }
  1853.                 if (eq(eltype,S(character)) && stringp(obj))
  1854.                   { var uintL dummy_len;
  1855.                     var reg2 uintB* ptr1 = unpack_string(obj,&dummy_len);
  1856.                     var reg1 uintB* ptr2 = (uintB*)data;
  1857.                     var reg4 uintL count;
  1858.                     dotimesL(count,len, { *ptr2++ = *ptr1++; } );
  1859.                     if (len < maxdim) { *ptr2 = '\0'; }
  1860.                   }
  1861.                 elif (eq(eltype,S(uint8))
  1862.                       && ((typecode(obj) & ~imm_array_mask) == bvector_type)
  1863.                       && ((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_8Bit)
  1864.                      )
  1865.                   { var uintL index = 0;
  1866.                     obj = array_displace_check(obj,len,&index);
  1867.                    {var reg2 uint8* ptr1 = &TheSbvector(TheArray(obj)->data)->data[index];
  1868.                     var reg1 uint8* ptr2 = (uint8*)data;
  1869.                     var reg4 uintL count;
  1870.                     dotimesL(count,len, { *ptr2++ = *ptr1++; } );
  1871.                     if (len < maxdim) { *ptr2 = 0; }
  1872.                   }}
  1873.                 elif (eq(eltype,S(uint16))
  1874.                       && ((typecode(obj) & ~imm_array_mask) == bvector_type)
  1875.                       && ((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_16Bit)
  1876.                      )
  1877.                   { var uintL index = 0;
  1878.                     obj = array_displace_check(obj,len,&index);
  1879.                    {var reg2 uint16* ptr1 = (uint16*)&TheSbvector(TheArray(obj)->data)->data[2*index];
  1880.                     var reg1 uint16* ptr2 = (uint16*)data;
  1881.                     var reg4 uintL count;
  1882.                     dotimesL(count,len, { *ptr2++ = *ptr1++; } );
  1883.                     if (len < maxdim) { *ptr2 = 0; }
  1884.                   }}
  1885.                 elif (eq(eltype,S(uint32))
  1886.                       && ((typecode(obj) & ~imm_array_mask) == bvector_type)
  1887.                       && ((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_32Bit)
  1888.                      )
  1889.                   { var uintL index = 0;
  1890.                     obj = array_displace_check(obj,len,&index);
  1891.                    {var reg2 uint32* ptr1 = (uint32*)&TheSbvector(TheArray(obj)->data)->data[4*index];
  1892.                     var reg1 uint32* ptr2 = (uint32*)data;
  1893.                     var reg4 uintL count;
  1894.                     dotimesL(count,len, { *ptr2++ = *ptr1++; } );
  1895.                     if (len < maxdim) { *ptr2 = 0; }
  1896.                   }}
  1897.                 else
  1898.                   { pushSTACK(eltype);
  1899.                     pushSTACK(obj);
  1900.                     { var reg4 uintL i;
  1901.                       var reg5 char* pdata = (char*)data;
  1902.                       for (i = 0; i < len; i++, pdata += eltype_size)
  1903.                         { # pdata = (char*)data + i*eltype_size
  1904.                           pushSTACK(STACK_0); pushSTACK(fixnum(i));
  1905.                           funcall(L(aref),2);
  1906.                           convert_to_foreign(STACK_1,value1,pdata);
  1907.                         }
  1908.                       if (len < maxdim) { blockzero(pdata,eltype_size); }
  1909.                     }
  1910.                     skipSTACK(2);
  1911.                   }
  1912.                 return;
  1913.               }}
  1914.             elif (eq(fvdtype,S(c_function)) && (fvdlen == 4))
  1915.               { var reg3 object ffun =
  1916.                   convert_function_to_foreign(obj,
  1917.                                               TheSvector(fvd)->data[1],
  1918.                                               TheSvector(fvd)->data[2],
  1919.                                               TheSvector(fvd)->data[3]
  1920.                                              );
  1921.                 *(void**)data = Faddress_value(TheFfunction(ffun)->ff_address);
  1922.                 return;
  1923.               }
  1924.             elif (eq(fvdtype,S(c_ptr)) && (fvdlen == 2))
  1925.               { fvd = TheSvector(fvd)->data[1];
  1926.                 foreign_layout(fvd);
  1927.                {var reg3 void* p = converter_malloc(*(void**)data,data_size,data_alignment);
  1928.                 *(void**)data = p;
  1929.                 convert_to_foreign(fvd,obj,p);
  1930.                 return;
  1931.               }}
  1932.             elif (eq(fvdtype,S(c_ptr_null)) && (fvdlen == 2))
  1933.               { if (nullp(obj))
  1934.                   { *(void**)data = NULL; return; }
  1935.                 fvd = TheSvector(fvd)->data[1];
  1936.                 foreign_layout(fvd);
  1937.                {var reg3 void* p = converter_malloc(*(void**)data,data_size,data_alignment);
  1938.                 *(void**)data = p;
  1939.                 convert_to_foreign(fvd,obj,p);
  1940.                 return;
  1941.               }}
  1942.             elif (eq(fvdtype,S(c_array_ptr)) && (fvdlen == 2))
  1943.               { if (nullp(obj))
  1944.                   { *(void**)data = NULL; return; }
  1945.                 if (!vectorp(obj)) goto bad_obj;
  1946.                {var reg5 uintL len = vector_length(obj);
  1947.                 fvd = TheSvector(fvd)->data[1];
  1948.                 foreign_layout(fvd);
  1949.                 {var reg4 uintL eltype_size = data_size;
  1950.                  var reg3 void* p = converter_malloc(*(void**)data,(len+1)*eltype_size,data_alignment);
  1951.                  *(void**)data = p;
  1952.                  pushSTACK(fvd);
  1953.                  pushSTACK(obj);
  1954.                  {var reg1 uintL i;
  1955.                   for (i = 0; i < len; i++, p = (void*)((char*)p + eltype_size))
  1956.                     { pushSTACK(STACK_0); pushSTACK(fixnum(i));
  1957.                       funcall(L(aref),2);
  1958.                       convert_to_foreign(STACK_1,value1,p);
  1959.                  }  }
  1960.                  skipSTACK(2);
  1961.                  blockzero(p,eltype_size);
  1962.                 }
  1963.                 return;
  1964.               }}
  1965.       }   }
  1966.     fehler_foreign_type(fvd);
  1967.    bad_obj:
  1968.     fehler_convert(fvd,obj);
  1969.   }
  1970.  
  1971. # Convert Lisp data to foreign data.
  1972. # The foreign data has dynamic extent.
  1973. # 1. convert_to_foreign_need(fvd,obj);
  1974. # 2. make room according to data_size and data_alignment, set allocaing_room_pointer.
  1975. # 3. convert_to_foreign_allocaing(fvd,obj,data,room_pointer);
  1976. global void convert_to_foreign_allocaing (object fvd, object obj, void* data);
  1977. local void* allocaing_room_pointer;
  1978. local void* allocaing (void* old_data, uintL size, uintL alignment);
  1979. local void* allocaing(old_data,size,alignment)
  1980.   var reg2 void* old_data;
  1981.   var reg1 uintL size;
  1982.   var reg3 uintL alignment;
  1983.   { allocaing_room_pointer = (void*)(((uintP)allocaing_room_pointer + alignment-1) & -(long)alignment);
  1984.    {var reg4 void* result = allocaing_room_pointer;
  1985.     allocaing_room_pointer = (void*)((uintP)allocaing_room_pointer + size);
  1986.     return result;
  1987.   }}
  1988. global void convert_to_foreign_allocaing(fvd,obj,data)
  1989.   var reg1 object fvd;
  1990.   var reg2 object obj;
  1991.   var reg3 void* data;
  1992.   { converter_malloc = &allocaing;
  1993.     convert_to_foreign(fvd,obj,data);
  1994.   }
  1995.  
  1996. # Convert Lisp data to foreign data.
  1997. # The foreign data is allocated through malloc() and has more than dynamic
  1998. # extent. (Not exactly indefinite extent: It is deallocated the next time
  1999. # free_foreign() is called on it.)
  2000. global void convert_to_foreign_mallocing (object fvd, object obj, void* data);
  2001. local void* mallocing (void* old_data, uintL size, uintL alignment);
  2002. local void* mallocing(old_data,size,alignment)
  2003.   var reg2 void* old_data;
  2004.   var reg1 uintL size;
  2005.   var reg3 uintL alignment;
  2006.   { return xmalloc(size); }
  2007. global void convert_to_foreign_mallocing(fvd,obj,data)
  2008.   var reg1 object fvd;
  2009.   var reg2 object obj;
  2010.   var reg3 void* data;
  2011.   { converter_malloc = &mallocing;
  2012.     convert_to_foreign(fvd,obj,data);
  2013.   }
  2014.  
  2015. # Convert Lisp data to foreign data.
  2016. # The foreign data storage is reused.
  2017. # DANGEROUS, especially for type C-STRING !!
  2018. # Also beware against NULL pointers! They are not treated specially.
  2019. global void convert_to_foreign_nomalloc (object fvd, object obj, void* data);
  2020. local void* nomalloc (void* old_data, uintL size, uintL alignment);
  2021. local void* nomalloc(old_data,size,alignment)
  2022.   var reg1 void* old_data;
  2023.   var reg2 uintL size;
  2024.   var reg3 uintL alignment;
  2025.   { return old_data; }
  2026. global void convert_to_foreign_nomalloc(fvd,obj,data)
  2027.   var reg1 object fvd;
  2028.   var reg2 object obj;
  2029.   var reg3 void* data;
  2030.   { converter_malloc = &nomalloc;
  2031.     convert_to_foreign(fvd,obj,data);
  2032.   }
  2033.  
  2034.  
  2035. # Error messages.
  2036. nonreturning_function(local, fehler_foreign_variable, (object obj));
  2037. local void fehler_foreign_variable(obj)
  2038.   var reg1 object obj;
  2039.   { pushSTACK(obj);
  2040.     pushSTACK(TheSubr(subr_self)->name);
  2041.     //: DEUTSCH "~: Argument ist keine Foreign-Variable: ~"
  2042.     //: ENGLISH "~: argument is not a foreign variable: ~"
  2043.     //: FRANCAIS "~ : l'argument n'est pas une variable étrangère: ~"
  2044.     fehler(error, GETTEXT("~: argument is not a foreign variable: ~"));
  2045.   }
  2046. nonreturning_function(local, fehler_variable_no_fvd, (object obj));
  2047. local void fehler_variable_no_fvd(obj)
  2048.   var reg1 object obj;
  2049.   { pushSTACK(obj);
  2050.     pushSTACK(TheSubr(subr_self)->name);
  2051.     //: DEUTSCH "~: Foreign-Variable mit unbekanntem Typ, DEF-C-VAR fehlt: ~"
  2052.     //: ENGLISH "~: foreign variable with unknown type, missing DEF-C-VAR: ~"
  2053.     //: FRANCAIS "~ : variable étrangère de type inconnu, DEF-C-VAR manquant: ~"
  2054.     fehler(error, GETTEXT("~: foreign variable with unknown type, missing DEF-C-VAR: ~"));
  2055.   }
  2056.  
  2057. # (FFI::LOOKUP-FOREIGN-VARIABLE foreign-variable-name foreign-type)
  2058. # looks up a foreign variable, given its Lisp name.
  2059. LISPFUNN(lookup_foreign_variable,2)
  2060.   { var reg3 object fvd = popSTACK();
  2061.     var reg2 object name = popSTACK();
  2062.     var reg1 object fvar = gethash(name,O(foreign_variable_table));
  2063.     if (eq(fvar,nullobj))
  2064.       { pushSTACK(name);
  2065.         //: DEUTSCH "Eine Foreign-Variable ~ gibt es nicht."
  2066.         //: ENGLISH "A foreign variable ~ does not exist"
  2067.         //: FRANCAIS "Il n'y a pas de variable étrangère ~."
  2068.         fehler(error, GETTEXT("A foreign variable ~ does not exist"));
  2069.       }
  2070.     # The first LOOKUP-FOREIGN-VARIABLE determines the variable's type.
  2071.     if (nullp(TheFvariable(fvar)->fv_type))
  2072.       { foreign_layout(fvd);
  2073.         if (!((posfixnum_to_L(TheFvariable(fvar)->fv_size) == data_size)
  2074.               && (((long)Faddress_value(TheFvariable(fvar)->fv_address) & (data_alignment-1)) == 0)
  2075.            ) )
  2076.           { pushSTACK(fvar);
  2077.             pushSTACK(TheSubr(subr_self)->name);
  2078.             //: DEUTSCH "~: Foreign-Variable ~ hat nicht die geforderte Größe oder Alignment."
  2079.             //: ENGLISH "~: foreign variable ~ does not have the required size or alignment"
  2080.             //: FRANCAIS "~ : variable étrangère ~ n'a pas la taille ou le placement nécessaire."
  2081.             fehler(error, GETTEXT("~: foreign variable ~ does not have the required size or alignment"));
  2082.           }
  2083.         TheFvariable(fvar)->fv_type = fvd;
  2084.       }
  2085.     # Subsequent LOOKUP-FOREIGN-VARIABLE calls only compare the type.
  2086.     elif (!equal_fvd(TheFvariable(fvar)->fv_type,fvd))
  2087.       { if (!equalp_fvd(TheFvariable(fvar)->fv_type,fvd))
  2088.           { var reg4 object *fvd_ptr;
  2089.             var reg5 object *fvar_ptr;
  2090.             pushSTACK(fvd); fvd_ptr=&STACK_0;
  2091.             pushSTACK(fvar); fvar_ptr=&STACK_0;
  2092.             dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  2093.             pushSTACK(*fvd_ptr);
  2094.             fvar=*fvar_ptr;
  2095.             pushSTACK(TheFvariable(fvar)->fv_type);
  2096.             pushSTACK(fvar);
  2097.             pushSTACK(TheSubr(subr_self)->name);
  2098.             //: DEUTSCH "~: Typangaben für Foreign-Variable ~ widersprechen sich: ~ und ~"
  2099.             //: ENGLISH "~: type specifications for foreign variable ~ conflict: ~ and ~"
  2100.             //: FRANCAIS "~ : type de variable étrangère ~ se contredisent: ~ et ~"
  2101.             fehler(error, GETTEXT("~: type specifications for foreign variable ~ conflict: ~ and ~"));
  2102.           }
  2103.         # If the types are not exactly the same but still compatible,
  2104.         # allocate a new foreign variable with the given fvd.
  2105.         pushSTACK(fvd);
  2106.         pushSTACK(fvar);
  2107.        {var reg2 object new_fvar = allocate_fvariable();
  2108.         fvar = popSTACK();
  2109.         TheFvariable(new_fvar)->recflags   = TheFvariable(fvar)->recflags;
  2110.         TheFvariable(new_fvar)->fv_name    = TheFvariable(fvar)->fv_name;
  2111.         TheFvariable(new_fvar)->fv_address = TheFvariable(fvar)->fv_address;
  2112.         TheFvariable(new_fvar)->fv_size    = TheFvariable(fvar)->fv_size;
  2113.         TheFvariable(new_fvar)->fv_type    = popSTACK();
  2114.         fvar = new_fvar;
  2115.       }}
  2116.     value1 = fvar; mv_count=1;
  2117.   }
  2118.  
  2119. # (FFI::FOREIGN-VALUE foreign-variable)
  2120. # returns the value of the foreign variable as a Lisp data structure.
  2121. LISPFUNN(foreign_value,1)
  2122.   { var reg1 object fvar = popSTACK();
  2123.     if (!fvariablep(fvar)) { fehler_foreign_variable(fvar); }
  2124.    {var reg3 void* address = Faddress_value(TheFvariable(fvar)->fv_address);
  2125.     var reg2 object fvd = TheFvariable(fvar)->fv_type;
  2126.     if (nullp(fvd)) { fehler_variable_no_fvd(fvar); }
  2127.     value1 = convert_from_foreign(fvd,address);
  2128.     mv_count=1;
  2129.   }}
  2130.  
  2131. # (FFI::SET-FOREIGN-VALUE foreign-variable new-value)
  2132. # sets the value of the foreign variable.
  2133. LISPFUNN(set_foreign_value,2)
  2134.   { var reg1 object fvar = STACK_1;
  2135.     if (!fvariablep(fvar)) { fehler_foreign_variable(fvar); }
  2136.    {var reg3 void* address = Faddress_value(TheFvariable(fvar)->fv_address);
  2137.     var reg2 object fvd = TheFvariable(fvar)->fv_type;
  2138.     if (nullp(fvd)) { fehler_variable_no_fvd(fvar); }
  2139.     if (TheFvariable(fvar)->recflags & fv_readonly)
  2140.       { pushSTACK(fvar);
  2141.         pushSTACK(TheSubr(subr_self)->name);
  2142.         //: DEUTSCH "~: Foreign-Variable ~ darf nicht verändert werden."
  2143.         //: ENGLISH "~: foreign variable ~ may not be modified"
  2144.         //: FRANCAIS "~ : variable étrangère ~ n'est pas modifiable."
  2145.         fehler(error, GETTEXT("~: foreign variable ~ may not be modified"));
  2146.       }
  2147.     if (TheFvariable(fvar)->recflags & fv_malloc)
  2148.       { # Protect this using a semaphore??
  2149.         # Free old value:
  2150.         free_foreign(fvd,address);
  2151.         # Put in new value:
  2152.         convert_to_foreign_mallocing(fvd,STACK_0,address);
  2153.       }
  2154.       else
  2155.       { # Protect this using a semaphore??
  2156.         # Put in new value, reusing the old value's storage:
  2157.         convert_to_foreign_nomalloc(fvd,STACK_0,address);
  2158.       }
  2159.     value1 = STACK_0; mv_count=1;
  2160.     skipSTACK(2);
  2161.   }}
  2162.  
  2163. # (FFI::FOREIGN-TYPE foreign-variable)
  2164. LISPFUNN(foreign_type,1)
  2165.   { var reg1 object fvar = popSTACK();
  2166.     if (!fvariablep(fvar)) { fehler_foreign_variable(fvar); }
  2167.     if (nullp((value1 = TheFvariable(fvar)->fv_type))) { fehler_variable_no_fvd(fvar); }
  2168.     mv_count=1;
  2169.   }
  2170.  
  2171. # (FFI::FOREIGN-SIZE foreign-variable)
  2172. LISPFUNN(foreign_size,1)
  2173.   { var reg1 object fvar = popSTACK();
  2174.     if (!fvariablep(fvar)) { fehler_foreign_variable(fvar); }
  2175.     if (nullp(TheFvariable(fvar)->fv_type)) { fehler_variable_no_fvd(fvar); }
  2176.     value1 = TheFvariable(fvar)->fv_size; mv_count=1;
  2177.   }
  2178.  
  2179.   local void fehler_subscripts_wrong_type (void);
  2180.   local void fehler_subscripts_wrong_type()
  2181.     {
  2182.       //: DEUTSCH "~: Subscripts ~ für ~ sind nicht vom Typ `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))."
  2183.       //: ENGLISH "~: subscripts ~ for ~ are not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"
  2184.       //: FRANCAIS "~: Les indices ~ pour ~ ne sont pas de type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))."
  2185.       fehler(error, GETTEXT("~: subscripts ~ for ~ are not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"));
  2186.     }
  2187.  
  2188.   local void fehler_subscripts_out_of_range (void);
  2189.   local void fehler_subscripts_out_of_range()
  2190.     {
  2191.       //: DEUTSCH "~: Subscripts ~ für ~ liegen nicht im erlaubten Bereich."
  2192.       //: ENGLISH "~: subscripts ~ for ~ are out of range"
  2193.       //: FRANCAIS "~: Les indices ~ pour ~ ne sont pas dans l'intervalle permis."
  2194.       fehler(error, GETTEXT("~: subscripts ~ for ~ are out of range"));
  2195.     }
  2196.  
  2197. # (FFI::%ELEMENT foreign-array-variable {index}*)
  2198. # returns a foreign variable, corresponding to the specified array element.
  2199. LISPFUN(element,1,0,rest,nokey,0,NIL)
  2200.   { var reg2 object fvar = Before(rest_args_pointer);
  2201.     # Check that fvar is a foreign variable:
  2202.     if (!fvariablep(fvar)) { fehler_foreign_variable(fvar); }
  2203.     # Check that fvar is a foreign array:
  2204.    {var reg3 object fvd = TheFvariable(fvar)->fv_type;
  2205.     var reg5 uintL fvdlen;
  2206.     if (!(simple_vector_p(fvd)
  2207.           && ((fvdlen = TheSvector(fvd)->length) > 1)
  2208.           && (eq(TheSvector(fvd)->data[0],S(c_array)) || eq(TheSvector(fvd)->data[0],S(c_array_max)))
  2209.        ) )
  2210.       { var reg6 object *fvd_ptr;
  2211.         var reg7 object *fvar_ptr;
  2212.         pushSTACK(fvd); fvd_ptr=&STACK_0;
  2213.         pushSTACK(fvar); fvar_ptr=&STACK_0;
  2214.         dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  2215.         pushSTACK(*fvd_ptr);
  2216.         pushSTACK(*fvar_ptr);
  2217.         pushSTACK(S(element));
  2218.         //: DEUTSCH "~: Foreign-Variable ~ vom Typ ~ ist kein Array."
  2219.         //: ENGLISH "~: foreign variable ~ of type ~ is not an array"
  2220.         //: FRANCAIS "~ : variable étrangère ~ de type ~ n'est pas une matrice."
  2221.         fehler(error, GETTEXT("~: foreign variable ~ of type ~ is not an array"));
  2222.       }
  2223.     # Check the subscript count:
  2224.     if (!(argcount == fvdlen-2))
  2225.       { pushSTACK(fixnum(fvdlen-2));
  2226.         pushSTACK(fvar);
  2227.         pushSTACK(fixnum(argcount));
  2228.         pushSTACK(S(element));
  2229.         //: DEUTSCH "~: Es wurden ~ Subscripts angegeben, ~ hat aber den Rang ~."
  2230.         //: ENGLISH "~: got ~ subscripts, but ~ has rank ~"
  2231.         //: FRANCAIS "~: ~ indices donnés mais ~ est de rang ~."
  2232.         fehler(error, GETTEXT("~: got ~ subscripts, but ~ has rank ~"));
  2233.       }
  2234.     # Check the subscripts:
  2235.     {var reg9 uintL row_major_index = 0;
  2236.      {var reg7 object* args_pointer = rest_args_pointer;
  2237.       var reg6 object* dimptr = &TheSvector(fvd)->data[2];
  2238.       var reg8 uintC count;
  2239.       dotimesC(count,argcount,
  2240.         { var reg1 object subscriptobj = NEXT(args_pointer);
  2241.           if (!posfixnump(subscriptobj))
  2242.             { var reg10 object list = listof(argcount);
  2243.               # STACK_0 is fvar now.
  2244.               pushSTACK(list);
  2245.               pushSTACK(S(element));
  2246.               fehler_subscripts_wrong_type();
  2247.             }
  2248.          {var reg4 uintL subscript = posfixnum_to_L(subscriptobj);
  2249.           var reg8 uintL dim = I_to_uint32(*dimptr);
  2250.           if (!(subscript<dim))
  2251.             { var reg10 object list = listof(argcount);
  2252.               # STACK_0 is fvar now.
  2253.               pushSTACK(list);
  2254.               pushSTACK(S(element));
  2255.               fehler_subscripts_out_of_range();
  2256.             }
  2257.           # Compute row_major_index := row_major_index*dim+subscript:
  2258.           row_major_index = mulu32_unchecked(row_major_index,dim)+subscript;
  2259.           *dimptr++;
  2260.         }});
  2261.      }
  2262.      set_args_end_pointer(rest_args_pointer);
  2263.      fvd = TheSvector(fvd)->data[1]; # the element's foreign type
  2264.      pushSTACK(fvd);
  2265.      foreign_layout(fvd);
  2266.      {var reg4 uintL size = data_size; # the element's size
  2267.       pushSTACK(make_faddress(TheFaddress(TheFvariable(fvar)->fv_address)->fa_base,
  2268.                               TheFaddress(TheFvariable(fvar)->fv_address)->fa_offset
  2269.                               + row_major_index * size
  2270.                )             );
  2271.       {var reg1 object new_fvar = allocate_fvariable();
  2272.        fvar = STACK_2;
  2273.        TheFvariable(new_fvar)->recflags   = TheFvariable(fvar)->recflags;
  2274.        TheFvariable(new_fvar)->fv_name    = NIL; # no name known
  2275.        TheFvariable(new_fvar)->fv_address = popSTACK();
  2276.        TheFvariable(new_fvar)->fv_size    = fixnum(size);
  2277.        TheFvariable(new_fvar)->fv_type    = popSTACK();
  2278.        value1 = new_fvar; mv_count=1;
  2279.        skipSTACK(1);
  2280.   }}}}}
  2281.  
  2282. # (FFI::%DEREF foreign-pointer-variable)
  2283. # returns a foreign variable, corresponding to what the specified pointer
  2284. # points to.
  2285. LISPFUNN(deref,1)
  2286.   { var reg2 object fvar = STACK_0;
  2287.     # Check that fvar is a foreign variable:
  2288.     if (!fvariablep(fvar)) { fehler_foreign_variable(fvar); }
  2289.     # Check that fvar is a foreign pointer:
  2290.    {var reg3 object fvd = TheFvariable(fvar)->fv_type;
  2291.     if (!(simple_vector_p(fvd)
  2292.           && (TheSvector(fvd)->length == 2)
  2293.           && (eq(TheSvector(fvd)->data[0],S(c_ptr))
  2294.               || eq(TheSvector(fvd)->data[0],S(c_ptr_null)))
  2295.        ) )
  2296.       { var reg4 object *fvd_ptr;
  2297.         var reg5 object *fvar_ptr;
  2298.         pushSTACK(fvd); fvd_ptr=&STACK_0;
  2299.         pushSTACK(fvar); fvar_ptr=&STACK_0;
  2300.         dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  2301.         pushSTACK(*fvd_ptr);
  2302.         pushSTACK(*fvar_ptr);
  2303.         pushSTACK(S(element));
  2304.         //: DEUTSCH "~: Foreign-Variable ~ vom Typ ~ ist kein Pointer."
  2305.         //: ENGLISH "~: foreign variable ~ of type ~ is not a pointer"
  2306.         //: FRANCAIS "~ : variable étrangère ~ de type ~ n'est pas un pointeur."
  2307.         fehler(error, GETTEXT("~: foreign variable ~ of type ~ is not a pointer"));
  2308.       }
  2309.     fvd = TheSvector(fvd)->data[1]; # the target's foreign type
  2310.     pushSTACK(fvd);
  2311.     foreign_layout(fvd);
  2312.     {var reg4 uintL size = data_size; # the target's size
  2313.      # Actually dereference the pointer:
  2314.      var reg5 void* address = *(void**)Faddress_value(TheFvariable(fvar)->fv_address);
  2315.      if (address == NULL)
  2316.        # Don't mess with NULL pointers, return NIL instead.
  2317.        { value1 = NIL; mv_count=1; skipSTACK(2); }
  2318.        else
  2319.        { pushSTACK(make_faddress(O(fp_zero),(uintP)address));
  2320.         {var reg1 object new_fvar = allocate_fvariable();
  2321.          fvar = STACK_2;
  2322.          TheFvariable(new_fvar)->recflags   = TheFvariable(fvar)->recflags;
  2323.          TheFvariable(new_fvar)->fv_name    = NIL; # no name known
  2324.          TheFvariable(new_fvar)->fv_address = popSTACK();
  2325.          TheFvariable(new_fvar)->fv_size    = fixnum(size);
  2326.          TheFvariable(new_fvar)->fv_type    = popSTACK();
  2327.          value1 = new_fvar; mv_count=1;
  2328.          skipSTACK(1);
  2329.   }}}  }}
  2330.  
  2331. # (FFI::%SLOT foreign-struct/union-variable slot-name)
  2332. # returns a foreign variable, corresponding to the specified struct slot or
  2333. # union alternative.
  2334. LISPFUNN(slot,2)
  2335.   { var reg6 object fvar = STACK_1;
  2336.     var reg4 object slot = STACK_0;
  2337.     # Check that fvar is a foreign variable:
  2338.     if (!fvariablep(fvar)) { fehler_foreign_variable(fvar); }
  2339.     # Check that fvar is a foreign struct or a foreign union:
  2340.    {var reg2 object fvd = TheFvariable(fvar)->fv_type;
  2341.     var reg8 uintL fvdlen;
  2342.     if (simple_vector_p(fvd) && ((fvdlen = TheSvector(fvd)->length) > 0))
  2343.       { if (eq(TheSvector(fvd)->data[0],S(c_struct)) && (fvdlen > 2))
  2344.           { var reg1 object slots = TheSvector(fvd)->data[1];
  2345.             if (!(simple_vector_p(slots) && (TheSvector(slots)->length==fvdlen-3)))
  2346.               { fehler_foreign_type(fvd); }
  2347.            {var reg5 uintL cumul_size = 0;
  2348.             var reg3 uintL i;
  2349.             for (i = 3; i < fvdlen; i++)
  2350.               { var reg7 object fvdi = TheSvector(fvd)->data[i];
  2351.                 foreign_layout(fvdi);
  2352.                 # We assume all alignments are of the form 2^k.
  2353.                 cumul_size += (-cumul_size) & (data_alignment-1);
  2354.                 if (eq(TheSvector(slots)->data[i-3],slot))
  2355.                   { pushSTACK(fvdi); goto found_struct_slot; }
  2356.                 cumul_size += data_size;
  2357.               }
  2358.             goto bad_slot;
  2359.             found_struct_slot:
  2360.             { var reg3 uintL size = data_size;
  2361.               pushSTACK(make_faddress(TheFaddress(TheFvariable(fvar)->fv_address)->fa_base,
  2362.                                       TheFaddress(TheFvariable(fvar)->fv_address)->fa_offset
  2363.                                       + cumul_size
  2364.                        )             );
  2365.              {var reg1 object new_fvar = allocate_fvariable();
  2366.               fvar = STACK_3;
  2367.               TheFvariable(new_fvar)->recflags   = TheFvariable(fvar)->recflags;
  2368.               TheFvariable(new_fvar)->fv_name    = NIL; # no name known
  2369.               TheFvariable(new_fvar)->fv_address = popSTACK();
  2370.               TheFvariable(new_fvar)->fv_size    = fixnum(size);
  2371.               TheFvariable(new_fvar)->fv_type    = popSTACK();
  2372.               value1 = new_fvar; mv_count=1;
  2373.               skipSTACK(2);
  2374.               return;
  2375.           }}}}
  2376.         if (eq(TheSvector(fvd)->data[0],S(c_union)) && (fvdlen > 1))
  2377.           { var reg1 object slots = TheSvector(fvd)->data[1];
  2378.             if (!(simple_vector_p(slots) && (TheSvector(slots)->length==fvdlen-2)))
  2379.               { fehler_foreign_type(fvd); }
  2380.            {var reg3 uintL i;
  2381.             for (i = 2; i < fvdlen; i++)
  2382.               { if (eq(TheSvector(slots)->data[i-2],slot))
  2383.                   goto found_union_slot;
  2384.               }
  2385.             goto bad_slot;
  2386.             found_union_slot:
  2387.             pushSTACK(TheSvector(fvd)->data[i]);
  2388.             {var reg1 object new_fvar = allocate_fvariable();
  2389.              fvd = popSTACK(); # the alternative's type
  2390.              fvar = STACK_1;
  2391.              TheFvariable(new_fvar)->recflags   = TheFvariable(fvar)->recflags;
  2392.              TheFvariable(new_fvar)->fv_name    = NIL; # no name known
  2393.              TheFvariable(new_fvar)->fv_address = TheFvariable(fvar)->fv_address;
  2394.              TheFvariable(new_fvar)->fv_size    = (foreign_layout(fvd), fixnum(data_size));
  2395.              TheFvariable(new_fvar)->fv_type    = fvd;
  2396.              value1 = new_fvar; mv_count=1;
  2397.              skipSTACK(2);
  2398.              return;
  2399.           }}}
  2400.       }
  2401.     { var reg1 object *fvd_ptr;
  2402.       var reg2 object *fvar_ptr;
  2403.       pushSTACK(fvd); fvd_ptr=&STACK_0;
  2404.       pushSTACK(fvar); fvar_ptr=&STACK_0;
  2405.       dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  2406.       pushSTACK(*fvd_ptr);
  2407.       pushSTACK(*fvar_ptr);
  2408.       pushSTACK(S(slot));
  2409.       //: DEUTSCH "~: Foreign-Variable ~ vom Typ ~ ist kein Struct oder Union."
  2410.       //: ENGLISH "~: foreign variable ~ of type ~ is not a struct or union"
  2411.       //: FRANCAIS "~ : variable étrangère ~ de type ~ n'est pas un «struct» ou «union»."
  2412.       fehler(error, GETTEXT("~: foreign variable ~ of type ~ is not a struct or union"));
  2413.     }
  2414.     bad_slot:
  2415.     { var reg1 object *fvd_ptr;
  2416.       var reg2 object *fvar_ptr;
  2417.       var reg3 object *slot_ptr;
  2418.       pushSTACK(fvd); fvd_ptr=&STACK_0;
  2419.       pushSTACK(fvar); fvar_ptr=&STACK_0;
  2420.       pushSTACK(slot); slot_ptr=&STACK_0;
  2421.       dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  2422.       pushSTACK(*slot_ptr);
  2423.       pushSTACK(*fvd_ptr);
  2424.       pushSTACK(*fvar_ptr);
  2425.       pushSTACK(S(slot));
  2426.       //: DEUTSCH "~: Foreign-Variable ~ vom Typ ~ hat keine Komponente namens ~."
  2427.       //: ENGLISH "~: foreign variable ~ of type ~ has no component with name ~"
  2428.       //: FRANCAIS "~ : variable étrangère ~ de type ~ n'a pas de composante de nom ~."
  2429.       fehler(error, GETTEXT("~: foreign variable ~ of type ~ has no component with name ~"));
  2430.     }
  2431.   }}
  2432.  
  2433. # (FFI::%CAST foreign-variable c-type)
  2434. # returns a foreign variable, referring to the same memory locations, but of
  2435. # the given c-type.
  2436. LISPFUNN(cast,2)
  2437.   { var reg1 object fvar = STACK_1;
  2438.     if (!fvariablep(fvar)) { fehler_foreign_variable(fvar); }
  2439.    {var reg3 object fvd = TheFvariable(fvar)->fv_type;
  2440.     if (nullp(fvd)) { fehler_variable_no_fvd(fvar); }
  2441.     # The old and the new type must have the same size.
  2442.     foreign_layout(STACK_0);
  2443.     if (!eq(TheFvariable(fvar)->fv_size,fixnum(data_size)))
  2444.       { fehler_convert(STACK_0,fvar); }
  2445.     # Allocate a new foreign variable.
  2446.     {var reg2 object new_fvar = allocate_fvariable();
  2447.      fvar = STACK_1;
  2448.      TheFvariable(new_fvar)->recflags   = TheFvariable(fvar)->recflags;
  2449.      TheFvariable(new_fvar)->fv_name    = TheFvariable(fvar)->fv_name;
  2450.      TheFvariable(new_fvar)->fv_address = TheFvariable(fvar)->fv_address;
  2451.      TheFvariable(new_fvar)->fv_size    = TheFvariable(fvar)->fv_size;
  2452.      TheFvariable(new_fvar)->fv_type    = STACK_0;
  2453.      value1 = new_fvar; mv_count=1;
  2454.      skipSTACK(2);
  2455.   }}}
  2456.  
  2457.  
  2458. # Error messages.
  2459. nonreturning_function(local, fehler_foreign_function, (object obj));
  2460. local void fehler_foreign_function(obj)
  2461.   var reg1 object obj;
  2462.   { pushSTACK(obj);
  2463.     pushSTACK(TheSubr(subr_self)->name);
  2464.     //: DEUTSCH "~: Argument ist keine Foreign-Funktion: ~"
  2465.     //: ENGLISH "~: argument is not a foreign function: ~"
  2466.     //: FRANCAIS "~ : l'argument n'est pas une fonction étrangère: ~"
  2467.     fehler(error, GETTEXT("~: argument is not a foreign function: ~"));
  2468.   }
  2469. nonreturning_function(local, fehler_function_no_fvd, (object obj, object caller));
  2470. local void fehler_function_no_fvd(obj,caller)
  2471.   var reg1 object obj;
  2472.   var reg2 object caller;
  2473.   { pushSTACK(obj);
  2474.     pushSTACK(caller);
  2475.     //: DEUTSCH "~: Foreign-Funktion mit unbekannter Aufrufkonvention, DEF-CALL-OUT fehlt: ~"
  2476.     //: ENGLISH "~: foreign function with unknown calling convention, missing DEF-CALL-OUT: ~"
  2477.     //: FRANCAIS "~ : convention d'appel inconnue pour fonction étrangère, DEF-CALL-OUT manquant: ~"
  2478.     fehler(error, GETTEXT("~: foreign function with unknown calling convention, missing DEF-CALL-OUT: ~"));
  2479.   }
  2480.  
  2481. # (FFI::LOOKUP-FOREIGN-FUNCTION foreign-function-name foreign-type)
  2482. # looks up a foreign function, given its Lisp name.
  2483. LISPFUNN(lookup_foreign_function,2)
  2484.   { var reg1 object ffun = allocate_ffunction();
  2485.     var reg4 object fvd = popSTACK();
  2486.     var reg3 object name = popSTACK();
  2487.     if (!(simple_vector_p(fvd) && (TheSvector(fvd)->length == 4)
  2488.           && eq(TheSvector(fvd)->data[0],S(c_function))
  2489.        ) )
  2490.       { var reg5 object *fvd_ptr;
  2491.         pushSTACK(fvd); fvd_ptr=&STACK_0;
  2492.         dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  2493.         pushSTACK(*fvd_ptr);
  2494.         pushSTACK(S(lookup_foreign_function));
  2495.         //: DEUTSCH "~: ungültiger Typ für externe Funktion: ~"
  2496.         //: ENGLISH "~: illegal foreign function type ~"
  2497.         //: FRANCAIS "~ : type invalide de fonction externe : ~"
  2498.         fehler(error, GETTEXT("~: illegal foreign function type ~"));
  2499.       }
  2500.    {var reg2 object oldffun = gethash(name,O(foreign_function_table));
  2501.     if (eq(oldffun,nullobj))
  2502.       { pushSTACK(name);
  2503.         pushSTACK(S(lookup_foreign_function));
  2504.         //: DEUTSCH "~: Eine Foreign-Funktion ~ gibt es nicht."
  2505.         //: ENGLISH "~: A foreign function ~ does not exist"
  2506.         //: FRANCAIS "~ : Il n'y a pas de fonction étrangère ~."
  2507.         fehler(error, GETTEXT("~: A foreign function ~ does not exist"));
  2508.       }
  2509.     if (!eq(TheFfunction(oldffun)->ff_flags,TheSvector(fvd)->data[3]))
  2510.       { pushSTACK(oldffun);
  2511.         pushSTACK(S(lookup_foreign_function));
  2512.         //: DEUTSCH "~: Aufrufkonventionen für Foreign-Funktion ~ widersprechen sich."
  2513.         //: ENGLISH "~: calling conventions for foreign function ~ conflict"
  2514.         //: FRANCAIS "~ : conventions d'appel de fonction étrangère ~ se contredisent."
  2515.         fehler(error, GETTEXT("~: calling conventions for foreign function ~ conflict"));
  2516.       }
  2517.     TheFfunction(ffun)->ff_name = TheFfunction(oldffun)->ff_name;
  2518.     TheFfunction(ffun)->ff_address = TheFfunction(oldffun)->ff_address;
  2519.     TheFfunction(ffun)->ff_resulttype = TheSvector(fvd)->data[1];
  2520.     TheFfunction(ffun)->ff_argtypes = TheSvector(fvd)->data[2];
  2521.     TheFfunction(ffun)->ff_flags = TheSvector(fvd)->data[3];
  2522.     value1 = ffun; mv_count=1;
  2523.   }}
  2524.  
  2525. # Here is the point where we use the AVCALL package.
  2526.  
  2527. # Call the appropriate av_start_xxx macro for the result.
  2528. # do_av_start(flags,result_fvd,&alist,address,result_address,result_size,result_splittable);
  2529.   local void do_av_start (uintWL flags, object result_fvd, av_alist * alist, void* address, void* result_address, uintL result_size, boolean result_splittable);
  2530.   local void do_av_start(flags,result_fvd,alist,address,result_address,result_size,result_splittable)
  2531.     var reg3 uintWL flags;
  2532.     var reg1 object result_fvd;
  2533.     var reg4 av_alist * alist;
  2534.     var reg5 void* address;
  2535.     var reg6 void* result_address;
  2536.     var reg7 uintL result_size;
  2537.     var reg8 boolean result_splittable;
  2538.     { if (symbolp(result_fvd))
  2539.         { if (eq(result_fvd,S(nil)))
  2540.             { av_start_void(*alist,address); }
  2541.           elif (eq(result_fvd,S(char)) || eq(result_fvd,S(sint8)))
  2542.             { if (flags & ff_lang_ansi_c)
  2543.                 { av_start_schar(*alist,address,result_address); }
  2544.                 else # `signed char' promotes to `int'
  2545.                 { av_start_int(*alist,address,result_address); }
  2546.             }
  2547.           elif (eq(result_fvd,S(uchar)) || eq(result_fvd,S(uint8)) || eq(result_fvd,S(character)))
  2548.             { if (flags & ff_lang_ansi_c)
  2549.                 { av_start_uchar(*alist,address,result_address); }
  2550.                 else # `unsigned char' promotes to `unsigned int'
  2551.                 { av_start_uint(*alist,address,result_address); }
  2552.             }
  2553.           elif (eq(result_fvd,S(short)) || eq(result_fvd,S(sint16)))
  2554.             { if (flags & ff_lang_ansi_c)
  2555.                 { av_start_short(*alist,address,result_address); }
  2556.                 else # `short' promotes to `int'
  2557.                 { av_start_int(*alist,address,result_address); }
  2558.             }
  2559.           elif (eq(result_fvd,S(ushort)) || eq(result_fvd,S(uint16)))
  2560.             { if (flags & ff_lang_ansi_c)
  2561.                 { av_start_ushort(*alist,address,result_address); }
  2562.                 else # `unsigned short' promotes to `unsigned int'
  2563.                 { av_start_uint(*alist,address,result_address); }
  2564.             }
  2565.           elif (eq(result_fvd,S(boolean)) || eq(result_fvd,S(int))
  2566.                 #if (int_bitsize==32)
  2567.                 || eq(result_fvd,S(sint32))
  2568.                 #endif
  2569.                )
  2570.             { av_start_int(*alist,address,result_address); }
  2571.           elif (eq(result_fvd,S(uint))
  2572.                 #if (int_bitsize==32)
  2573.                 || eq(result_fvd,S(uint32))
  2574.                 #endif
  2575.                )
  2576.             { av_start_uint(*alist,address,result_address); }
  2577.           elif (eq(result_fvd,S(long))
  2578.                 #if (int_bitsize<32) && (long_bitsize==32)
  2579.                 || eq(result_fvd,S(sint32))
  2580.                 #endif
  2581.                 #if (long_bitsize==64)
  2582.                 || eq(result_fvd,S(sint64))
  2583.                 #endif
  2584.                )
  2585.             { av_start_long(*alist,address,result_address); }
  2586.           elif (eq(result_fvd,S(ulong))
  2587.                 #if (int_bitsize<32) && (long_bitsize==32)
  2588.                 || eq(result_fvd,S(uint32))
  2589.                 #endif
  2590.                 #if (long_bitsize==64)
  2591.                 || eq(result_fvd,S(uint64))
  2592.                 #endif
  2593.                )
  2594.             { av_start_ulong(*alist,address,result_address); }
  2595.           #if (long_bitsize<64)
  2596.           elif (eq(result_fvd,S(sint64)))
  2597.             { av_start_struct(*alist,address,struct_sint64,av_word_splittable_2(uint32,uint32),result_address); }
  2598.           elif (eq(result_fvd,S(uint64)))
  2599.             { av_start_struct(*alist,address,struct_uint64,av_word_splittable_2(uint32,uint32),result_address); }
  2600.           #endif
  2601.           elif (eq(result_fvd,S(single_float)))
  2602.             { if (flags & ff_lang_ansi_c)
  2603.                 { av_start_float(*alist,address,result_address); }
  2604.                 else # `float' promotes to `double'
  2605.                 { av_start_double(*alist,address,result_address); }
  2606.             }
  2607.           elif (eq(result_fvd,S(double_float)))
  2608.             { av_start_double(*alist,address,result_address); }
  2609.           elif (eq(result_fvd,S(c_pointer)) || eq(result_fvd,S(c_string)))
  2610.             { av_start_ptr(*alist,address,void*,result_address); }
  2611.           else
  2612.             { fehler_foreign_type(result_fvd); }
  2613.         }
  2614.       elif (simple_vector_p(result_fvd))
  2615.         { var reg2 object result_fvdtype = TheSvector(result_fvd)->data[0];
  2616.           if (eq(result_fvdtype,S(c_struct)) || eq(result_fvdtype,S(c_union))
  2617.               || eq(result_fvdtype,S(c_array)) || eq(result_fvdtype,S(c_array_max))
  2618.              )
  2619.             { _av_start_struct(*alist,address,result_size,result_splittable,result_address); }
  2620.           elif (eq(result_fvdtype,S(c_function))
  2621.                 || eq(result_fvdtype,S(c_ptr))
  2622.                 || eq(result_fvdtype,S(c_ptr_null))
  2623.                 || eq(result_fvdtype,S(c_array_ptr))
  2624.                )
  2625.             { av_start_ptr(*alist,address,void*,result_address); }
  2626.           else
  2627.             { fehler_foreign_type(result_fvd); }
  2628.         }
  2629.       else
  2630.         { fehler_foreign_type(result_fvd); }
  2631.     }
  2632.  
  2633. # Call the appropriate av_xxx macro for an argument.
  2634. # do_av_arg(flags,arg_fvd,&alist,arg_address,arg_size,arg_alignment);
  2635.   local void do_av_arg (uintWL flags, object arg_fvd, av_alist * alist, void* arg_address, unsigned long arg_size, unsigned long arg_alignment);
  2636.   #ifdef AMIGAOS
  2637.   local sintWL AV_ARG_REGNUM; # number of register where the argument is to be passed
  2638.   #endif
  2639.   local void do_av_arg(flags,arg_fvd,alist,arg_address,arg_size,arg_alignment)
  2640.     var reg3 uintWL flags;
  2641.     var reg1 object arg_fvd;
  2642.     var reg4 av_alist * alist;
  2643.     var reg2 void* arg_address;
  2644.     var reg5 unsigned long arg_size;
  2645.     var reg6 unsigned long arg_alignment;
  2646.     { if (symbolp(arg_fvd))
  2647.         { if (eq(arg_fvd,S(nil)))
  2648.             { }
  2649.           elif (eq(arg_fvd,S(char)) || eq(arg_fvd,S(sint8)))
  2650.             { if (flags & ff_lang_ansi_c)
  2651.                 { av_schar(*alist,*(sint8*)arg_address); }
  2652.                 else # `signed char' promotes to `int'
  2653.                 { av_int(*alist,*(sint8*)arg_address); }
  2654.             }
  2655.           elif (eq(arg_fvd,S(uchar)) || eq(arg_fvd,S(uint8)) || eq(arg_fvd,S(character)))
  2656.             { if (flags & ff_lang_ansi_c)
  2657.                 { av_uchar(*alist,*(uint8*)arg_address); }
  2658.                 else # `unsigned char' promotes to `unsigned int'
  2659.                 { av_uint(*alist,*(uint8*)arg_address); }
  2660.             }
  2661.           elif (eq(arg_fvd,S(short)) || eq(arg_fvd,S(sint16)))
  2662.             { if (flags & ff_lang_ansi_c)
  2663.                 { av_short(*alist,*(sint16*)arg_address); }
  2664.                 else # `short' promotes to `int'
  2665.                 { av_int(*alist,*(sint16*)arg_address); }
  2666.             }
  2667.           elif (eq(arg_fvd,S(ushort)) || eq(arg_fvd,S(uint16)))
  2668.             { if (flags & ff_lang_ansi_c)
  2669.                 { av_ushort(*alist,*(uint16*)arg_address); }
  2670.                 else # `unsigned short' promotes to `unsigned int'
  2671.                 { av_uint(*alist,*(uint16*)arg_address); }
  2672.             }
  2673.           elif (eq(arg_fvd,S(boolean)) || eq(arg_fvd,S(int))
  2674.                 #if (int_bitsize==32)
  2675.                 || eq(arg_fvd,S(sint32))
  2676.                 #endif
  2677.                )
  2678.             { av_int(*alist,*(int*)arg_address); }
  2679.           elif (eq(arg_fvd,S(uint))
  2680.                 #if (int_bitsize==32)
  2681.                 || eq(arg_fvd,S(uint32))
  2682.                 #endif
  2683.                )
  2684.             { av_uint(*alist,*(unsigned int *)arg_address); }
  2685.           elif (eq(arg_fvd,S(long))
  2686.                 #if (int_bitsize<32) && (long_bitsize==32)
  2687.                 || eq(arg_fvd,S(sint32))
  2688.                 #endif
  2689.                 #if (long_bitsize==64)
  2690.                 || eq(arg_fvd,S(sint64))
  2691.                 #endif
  2692.                )
  2693.             { av_long(*alist,*(long*)arg_address); }
  2694.           elif (eq(arg_fvd,S(ulong))
  2695.                 #if (int_bitsize<32) && (long_bitsize==32)
  2696.                 || eq(arg_fvd,S(uint32))
  2697.                 #endif
  2698.                 #if (long_bitsize==64)
  2699.                 || eq(arg_fvd,S(uint64))
  2700.                 #endif
  2701.                )
  2702.             { av_ulong(*alist,*(unsigned long *)arg_address); }
  2703.           #if (long_bitsize<64)
  2704.           elif (eq(arg_fvd,S(sint64)))
  2705.             { av_struct(*alist,struct_sint64,*(struct_sint64*)arg_address); }
  2706.           elif (eq(arg_fvd,S(uint64)))
  2707.             { av_struct(*alist,struct_uint64,*(struct_uint64*)arg_address); }
  2708.           #endif
  2709.           elif (eq(arg_fvd,S(single_float)))
  2710.             { if (flags & ff_lang_ansi_c)
  2711.                 { av_float(*alist,*(float*)arg_address); }
  2712.                 else # `float' promotes to `double'
  2713.                 { av_double(*alist,*(float*)arg_address); }
  2714.             }
  2715.           elif (eq(arg_fvd,S(double_float)))
  2716.             { av_double(*alist,*(double*)arg_address); }
  2717.           elif (eq(arg_fvd,S(c_pointer)))
  2718.             { av_ptr(*alist,void*,*(void**)arg_address); }
  2719.           elif (eq(arg_fvd,S(c_string)))
  2720.             { av_ptr(*alist,char*,*(char**)arg_address); }
  2721.           else
  2722.             { fehler_foreign_type(arg_fvd); }
  2723.         }
  2724.       elif (simple_vector_p(arg_fvd))
  2725.         { var reg5 object arg_fvdtype = TheSvector(arg_fvd)->data[0];
  2726.           if (eq(arg_fvdtype,S(c_struct)) || eq(arg_fvdtype,S(c_union))
  2727.               || eq(arg_fvdtype,S(c_array)) || eq(arg_fvdtype,S(c_array_max))
  2728.              )
  2729.             { _av_struct(*alist,arg_size,arg_alignment,arg_address); }
  2730.           elif (eq(arg_fvdtype,S(c_function))
  2731.                 || eq(arg_fvdtype,S(c_ptr)) 
  2732.                 || eq(arg_fvdtype,S(c_ptr_null))
  2733.                 || eq(arg_fvdtype,S(c_array_ptr))
  2734.                )
  2735.             { av_ptr(*alist,void*,*(void**)arg_address); }
  2736.           else
  2737.             { fehler_foreign_type(arg_fvd); }
  2738.         }
  2739.       else
  2740.         { fehler_foreign_type(arg_fvd); }
  2741.     }
  2742.  
  2743. # (FFI::FOREIGN-CALL-OUT foreign-function . args)
  2744. # calls a foreign function with Lisp data structures as arguments,
  2745. # and returns the return value as a Lisp data structure.
  2746. LISPFUN(foreign_call_out,1,0,rest,nokey,0,NIL)
  2747.   { var reg3 object ffun = Before(rest_args_pointer);
  2748.     if (!ffunctionp(ffun)) { fehler_foreign_function(ffun); }
  2749.    {var reg4 object argfvds = TheFfunction(ffun)->ff_argtypes;
  2750.     if (!simple_vector_p(argfvds)) { fehler_function_no_fvd(ffun,S(foreign_call_out)); }
  2751.     { var reg6 uintWL flags = posfixnum_to_L(TheFfunction(ffun)->ff_flags);
  2752.       switch (flags & 0xFF00)
  2753.         { # For the moment, the only supported languages are "C" and "ANSI C".
  2754.           case ff_lang_c:
  2755.           case ff_lang_ansi_c:
  2756.             break;
  2757.           default:
  2758.             fehler_function_no_fvd(ffun,S(foreign_call_out));
  2759.         }
  2760.       { var av_alist alist;
  2761.        {var reg6 void* address = Faddress_value(TheFfunction(ffun)->ff_address);
  2762.         var reg5 object result_fvd = TheFfunction(ffun)->ff_resulttype;
  2763.         # Allocate space for the result and maybe the args:
  2764.         foreign_layout(result_fvd);
  2765.         { var reg4 uintL result_size = data_size;
  2766.           var reg4 uintL result_alignment = data_alignment;
  2767.           var reg10 boolean result_splittable = data_splittable;
  2768.           var reg4 uintL result_totalsize = result_size+result_alignment; # >= result_size+result_alignment-1, > 0
  2769.           var reg4 uintL cumul_alignment = result_alignment;
  2770.           var reg4 uintL cumul_size = result_totalsize;
  2771.           var reg4 uintL allargcount = TheSvector(argfvds)->length/2;
  2772.           var reg4 uintL outargcount = 0;
  2773.           { var reg4 sintL inargcount = 0;
  2774.             var reg3 uintL i;
  2775.             for (i = 0; i < allargcount; i++)
  2776.               { var reg9 object argfvds = TheFfunction(Before(rest_args_pointer))->ff_argtypes;
  2777.                 var reg5 object arg_fvd = TheSvector(argfvds)->data[2*i];
  2778.                 var reg5 uintWL arg_flags = posfixnum_to_L(TheSvector(argfvds)->data[2*i+1]);
  2779.                 if (!(arg_flags & ff_out))
  2780.                   { inargcount++;
  2781.                     if (!(inargcount <= argcount))
  2782.                       { pushSTACK(ffun);
  2783.                         pushSTACK(fixnum(inargcount));
  2784.                         pushSTACK(fixnum(argcount));
  2785.                         pushSTACK(S(foreign_call_out));
  2786.                         //: DEUTSCH "~: Zu wenig Argumente (~ statt mindestens ~) für ~."
  2787.                         //: ENGLISH "~: Too few arguments (~ instead of at least ~) to ~"
  2788.                         //: FRANCAIS "~ : Trop peu d'arguments (~ au lieu d'au moins ~) pour ~."
  2789.                         fehler(error, GETTEXT("~: Too few arguments (~ instead of at least ~) to ~"));
  2790.                   }   }
  2791.                 if (arg_flags & (ff_out | ff_inout))
  2792.                   { if (!(simple_vector_p(arg_fvd) && (TheSvector(arg_fvd)->length == 2)
  2793.                           && (eq(TheSvector(arg_fvd)->data[0],S(c_ptr))
  2794.                               || eq(TheSvector(arg_fvd)->data[0],S(c_ptr_null))
  2795.                        ) )   )
  2796.                       { var reg1 object *arg_fvd_ptr;
  2797.                         pushSTACK(arg_fvd); arg_fvd_ptr=&STACK_0;
  2798.                         dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  2799.                         pushSTACK(*arg_fvd_ptr);
  2800.                         pushSTACK(S(foreign_call_out));
  2801.                         //: DEUTSCH "~: :OUT-Argument ist kein Pointer: ~"
  2802.                         //: ENGLISH "~: :OUT argument is not a pointer: ~"
  2803.                         //: FRANCAIS "~ : paramètre :OUT n'est pas indirecte: ~"
  2804.                         fehler(error, GETTEXT("~: :OUT argument is not a pointer: ~"));
  2805.                       }
  2806.                     outargcount++;
  2807.                   }
  2808.                 if (arg_flags & ff_alloca)
  2809.                   { # Room for arg itself:
  2810.                     { foreign_layout(arg_fvd);
  2811.                       # We assume all alignments are of the form 2^k.
  2812.                       cumul_size += (-cumul_size) & (data_alignment-1);
  2813.                       cumul_size += data_size;
  2814.                       # cumul_alignment = lcm(cumul_alignment,data_alignment);
  2815.                       if (data_alignment > cumul_alignment)
  2816.                         cumul_alignment = data_alignment;
  2817.                     }
  2818.                     if (arg_flags & ff_out)
  2819.                       # Room for top-level pointer in arg:
  2820.                       { var reg8 object argo_fvd = TheSvector(arg_fvd)->data[1];
  2821.                         foreign_layout(argo_fvd);
  2822.                         # We assume all alignments are of the form 2^k.
  2823.                         cumul_size += (-cumul_size) & (data_alignment-1);
  2824.                         cumul_size += data_size;
  2825.                         # cumul_alignment = lcm(cumul_alignment,data_alignment);
  2826.                         if (data_alignment > cumul_alignment)
  2827.                           cumul_alignment = data_alignment;
  2828.                       }
  2829.                       else
  2830.                       # Room for pointers in arg:
  2831.                       { var reg8 object arg = Before(rest_args_pointer STACKop -inargcount);
  2832.                         convert_to_foreign_needs(arg_fvd,arg);
  2833.                         # We assume all alignments are of the form 2^k.
  2834.                         cumul_size += (-cumul_size) & (data_alignment-1);
  2835.                         cumul_size += data_size;
  2836.                         # cumul_alignment = lcm(cumul_alignment,data_alignment);
  2837.                         if (data_alignment > cumul_alignment)
  2838.                           cumul_alignment = data_alignment;
  2839.               }   }   }
  2840.             if (!(argcount == inargcount))
  2841.               { pushSTACK(ffun);
  2842.                 pushSTACK(fixnum(inargcount));
  2843.                 pushSTACK(fixnum(argcount));
  2844.                 pushSTACK(S(foreign_call_out));
  2845.                 //: DEUTSCH "~: Zu viele Argumente (~ statt ~) für ~."
  2846.                 //: ENGLISH "~: Too many arguments (~ instead of ~) to ~"
  2847.                 //: FRANCAIS "~ : Trop d'arguments (~ au lieu de ~) pour ~."
  2848.                 fehler(error, GETTEXT("~: Too many arguments (~ instead of ~) to ~"));
  2849.               }
  2850.           }
  2851.           #ifdef AMIGAOS
  2852.           # set register a6 as for a library call, even if not used
  2853.           # library pointer has already been validated through Fpointer_value() above
  2854.           alist.regargs[8+7-1] = (uintP)TheFpointer(TheFaddress(TheFfunction(ffun)->ff_address)->fa_base)->fp_pointer;
  2855.           #endif
  2856.          {var reg4 uintL result_count = 0;
  2857.           typedef struct { void* address; } result_descr; # fvd is pushed onto the STACK
  2858.           var DYNAMIC_ARRAY(reg10,results,result_descr,1+outargcount);
  2859.           cumul_size += (-cumul_size) & (cumul_alignment-1);
  2860.           { var DYNAMIC_ARRAY(reg10,total_room,char,cumul_size+cumul_alignment/*-1*/);
  2861.            {var reg7 void* result_address = (void*)((uintP)(total_room+result_alignment-1) & -(long)result_alignment);
  2862.             allocaing_room_pointer = (void*)((uintP)result_address + result_size);
  2863.             if (!eq(result_fvd,S(nil)))
  2864.               { pushSTACK(result_fvd); results[0].address = result_address; result_count++; }
  2865.             # Call av_start_xxx:
  2866.             do_av_start(flags,result_fvd,&alist,address,result_address,result_size,result_splittable);
  2867.             # Now pass the arguments.
  2868.             { var reg3 uintL i;
  2869.               var reg4 sintL j;
  2870.               for (i = 0, j = 0; i < allargcount; i++)
  2871.                 { var reg9 object argfvds = TheFfunction(Before(rest_args_pointer))->ff_argtypes;
  2872.                   var reg5 object arg_fvd = TheSvector(argfvds)->data[2*i];
  2873.                   var reg5 uintWL arg_flags = posfixnum_to_L(TheSvector(argfvds)->data[2*i+1]);
  2874.                   var reg8 object arg;
  2875.                   if (arg_flags & ff_out)
  2876.                     { arg = unbound; } # only to avoid uninitialized variable
  2877.                     else
  2878.                     { arg = Next(rest_args_pointer STACKop -j); j++; }
  2879.                   # Allocate temporary space for the argument:
  2880.                   foreign_layout(arg_fvd);
  2881.                   { var reg4 uintL arg_size = data_size;
  2882.                     var reg4 uintL arg_alignment = data_alignment;
  2883.                     if (arg_flags & ff_alloca)
  2884.                       { allocaing_room_pointer = (void*)(((uintP)allocaing_room_pointer + arg_alignment-1) & -(long)arg_alignment);
  2885.                        {var reg7 void* arg_address = allocaing_room_pointer;
  2886.                         allocaing_room_pointer = (void*)((uintP)allocaing_room_pointer + arg_size);
  2887.                         if (arg_flags & ff_out)
  2888.                           # Pass top-level pointer only:
  2889.                           { var reg8 object argo_fvd = TheSvector(arg_fvd)->data[1];
  2890.                             foreign_layout(argo_fvd);
  2891.                             allocaing_room_pointer = (void*)(((uintP)allocaing_room_pointer + data_alignment-1) & -(long)data_alignment);
  2892.                             *(void**)arg_address = allocaing_room_pointer;
  2893.                             pushSTACK(argo_fvd); results[result_count].address = allocaing_room_pointer;
  2894.                             result_count++;
  2895.                             # Durchnullen, um uninitialisiertes Ergebnis zu vermeiden:
  2896.                             blockzero(allocaing_room_pointer,data_size);
  2897.                             allocaing_room_pointer = (void*)((uintP)allocaing_room_pointer + data_size);
  2898.                           }
  2899.                           else
  2900.                           # Convert argument:
  2901.                           { convert_to_foreign_allocaing(arg_fvd,arg,arg_address);
  2902.                             if (arg_flags & ff_inout)
  2903.                               { pushSTACK(TheSvector(arg_fvd)->data[1]); results[result_count].address = *(void**)arg_address;
  2904.                                 result_count++;
  2905.                               }
  2906.                           }
  2907.                         # Call av_xxx:
  2908.                         #ifdef AMIGAOS
  2909.                         AV_ARG_REGNUM = (int)(arg_flags >> 8) - 1;
  2910.                         #endif
  2911.                         do_av_arg(flags,arg_fvd,&alist,arg_address,arg_size,arg_alignment);
  2912.                       }}
  2913.                       else
  2914.                       { var reg4 uintL arg_totalsize = arg_size+arg_alignment; # >= arg_size+arg_alignment-1, > 0
  2915.                         var DYNAMIC_ARRAY(reg10,arg_room,char,arg_totalsize);
  2916.                        {var reg7 void* arg_address = (void*)((uintP)(arg_room+arg_alignment-1) & -(long)arg_alignment);
  2917.                         if (!(arg_flags & ff_out))
  2918.                           # Convert argument:
  2919.                           { if (arg_flags & ff_malloc)
  2920.                               { convert_to_foreign_mallocing(arg_fvd,arg,arg_address); }
  2921.                               else
  2922.                               { convert_to_foreign_nomalloc(arg_fvd,arg,arg_address); }
  2923.                             if (arg_flags & ff_inout)
  2924.                               { pushSTACK(TheSvector(arg_fvd)->data[1]); results[result_count].address = *(void**)arg_address;
  2925.                                 result_count++;
  2926.                               }
  2927.                           }
  2928.                         # Call av_xxx:
  2929.                         #ifdef AMIGAOS
  2930.                         AV_ARG_REGNUM = (int)(arg_flags >> 8) - 1;
  2931.                         #endif
  2932.                         do_av_arg(flags,arg_fvd,&alist,arg_address,arg_size,arg_alignment);
  2933.                         FREE_DYNAMIC_ARRAY(arg_room);
  2934.                       }}
  2935.             }   } }
  2936.             # Finally call the function.
  2937.             begin_call();
  2938.             av_call(alist);
  2939.             end_call();
  2940.             # Convert the result(s) back to Lisp.
  2941.             { var reg1 object* resptr = (&STACK_0 STACKop result_count) STACKop -1;
  2942.               var reg4 uintL i;
  2943.               for (i = 0; i < result_count; i++)
  2944.                 { *resptr = convert_from_foreign(*resptr,results[i].address);
  2945.                   resptr skipSTACKop -1;
  2946.             }   }
  2947.             # Return them as multiple values.
  2948.             if (result_count >= mv_limit) { fehler_mv_zuviel(S(foreign_call_out)); }
  2949.             STACK_to_mv(result_count);
  2950.             if (flags & ff_alloca)
  2951.               { # The C functions we passed also have dynamic extent. Free them.
  2952.                 # Not done now. ??
  2953.               }
  2954.             if (flags & ff_malloc)
  2955.               { result_fvd = TheFfunction(Before(rest_args_pointer))->ff_resulttype;
  2956.                 free_foreign(result_fvd,result_address);
  2957.               }
  2958.             FREE_DYNAMIC_ARRAY(total_room);
  2959.           }}
  2960.           FREE_DYNAMIC_ARRAY(results);
  2961.       }}}}
  2962.       set_args_end_pointer(rest_args_pointer STACKop 1); # STACK aufräumen
  2963.   }}}
  2964.  
  2965. # Here is the point where we use the VACALL package.
  2966.  
  2967. # Call the appropriate va_start_xxx macro for the result.
  2968. # do_va_start(flags,result_fvd,alist,result_size,result_alignment,result_splittable);
  2969.   local void do_va_start (uintWL flags, object result_fvd, va_alist alist, uintL result_size, uintL result_alignment, boolean result_splittable);
  2970.   local void do_va_start(flags,result_fvd,alist,result_size,result_alignment,result_splittable)
  2971.     var reg3 uintWL flags;
  2972.     var reg1 object result_fvd;
  2973.     var reg4 va_alist alist;
  2974.     var reg5 uintL result_size;
  2975.     var reg6 uintL result_alignment;
  2976.     var reg7 boolean result_splittable;
  2977.     { if (symbolp(result_fvd))
  2978.         { if (eq(result_fvd,S(nil)))
  2979.             { va_start_void(alist); }
  2980.           elif (eq(result_fvd,S(char)) || eq(result_fvd,S(sint8)))
  2981.             { if (flags & ff_lang_ansi_c)
  2982.                 { va_start_schar(alist); }
  2983.                 else # `signed char' promotes to `int'
  2984.                 { va_start_int(alist); }
  2985.             }
  2986.           elif (eq(result_fvd,S(uchar)) || eq(result_fvd,S(uint8)) || eq(result_fvd,S(character)))
  2987.             { if (flags & ff_lang_ansi_c)
  2988.                 { va_start_uchar(alist); }
  2989.                 else # `unsigned char' promotes to `unsigned int'
  2990.                 { va_start_uint(alist); }
  2991.             }
  2992.           elif (eq(result_fvd,S(short)) || eq(result_fvd,S(sint16)))
  2993.             { if (flags & ff_lang_ansi_c)
  2994.                 { va_start_short(alist); }
  2995.                 else # `short' promotes to `int'
  2996.                 { va_start_int(alist); }
  2997.             }
  2998.           elif (eq(result_fvd,S(ushort)) || eq(result_fvd,S(uint16)))
  2999.             { if (flags & ff_lang_ansi_c)
  3000.                 { va_start_ushort(alist); }
  3001.                 else # `unsigned short' promotes to `unsigned int'
  3002.                 { va_start_uint(alist); }
  3003.             }
  3004.           elif (eq(result_fvd,S(boolean)) || eq(result_fvd,S(int))
  3005.                 #if (int_bitsize==32)
  3006.                 || eq(result_fvd,S(sint32))
  3007.                 #endif
  3008.                )
  3009.             { va_start_int(alist); }
  3010.           elif (eq(result_fvd,S(uint))
  3011.                 #if (int_bitsize==32)
  3012.                 || eq(result_fvd,S(uint32))
  3013.                 #endif
  3014.                )
  3015.             { va_start_uint(alist); }
  3016.           elif (eq(result_fvd,S(long))
  3017.                 #if (int_bitsize<32) && (long_bitsize==32)
  3018.                 || eq(result_fvd,S(sint32))
  3019.                 #endif
  3020.                 #if (long_bitsize==64)
  3021.                 || eq(result_fvd,S(sint64))
  3022.                 #endif
  3023.                )
  3024.             { va_start_long(alist); }
  3025.           elif (eq(result_fvd,S(ulong))
  3026.                 #if (int_bitsize<32) && (long_bitsize==32)
  3027.                 || eq(result_fvd,S(uint32))
  3028.                 #endif
  3029.                 #if (long_bitsize==64)
  3030.                 || eq(result_fvd,S(uint64))
  3031.                 #endif
  3032.                )
  3033.             { va_start_ulong(alist); }
  3034.           #if (long_bitsize<64)
  3035.           elif (eq(result_fvd,S(sint64)))
  3036.             { va_start_struct(alist,struct_sint64,va_word_splittable_2(uint32,uint32)); }
  3037.           elif (eq(result_fvd,S(uint64)))
  3038.             { va_start_struct(alist,struct_uint64,va_word_splittable_2(uint32,uint32)); }
  3039.           #endif
  3040.           elif (eq(result_fvd,S(single_float)))
  3041.             { if (flags & ff_lang_ansi_c)
  3042.                 { va_start_float(alist); }
  3043.                 else # `float' promotes to `double'
  3044.                 { va_start_double(alist); }
  3045.             }
  3046.           elif (eq(result_fvd,S(double_float)))
  3047.             { va_start_double(alist); }
  3048.           elif (eq(result_fvd,S(c_pointer)) || eq(result_fvd,S(c_string)))
  3049.             { va_start_ptr(alist,void*); }
  3050.           else
  3051.             { fehler_foreign_type(result_fvd); }
  3052.         }
  3053.       elif (simple_vector_p(result_fvd))
  3054.         { var reg2 object result_fvdtype = TheSvector(result_fvd)->data[0];
  3055.           if (eq(result_fvdtype,S(c_struct)) || eq(result_fvdtype,S(c_union))
  3056.               || eq(result_fvdtype,S(c_array)) || eq(result_fvdtype,S(c_array_max))
  3057.              )
  3058.             { _va_start_struct(alist,result_size,result_alignment,result_splittable); }
  3059.           elif (eq(result_fvdtype,S(c_function))
  3060.                 || eq(result_fvdtype,S(c_ptr)) 
  3061.                 || eq(result_fvdtype,S(c_ptr_null))
  3062.                 || eq(result_fvdtype,S(c_array_ptr))
  3063.                )
  3064.             { va_start_ptr(alist,void*); }
  3065.           else
  3066.             { fehler_foreign_type(result_fvd); }
  3067.         }
  3068.       else
  3069.         { fehler_foreign_type(result_fvd); }
  3070.     }
  3071.  
  3072. # Call the appropriate va_arg_xxx macro for an arguemnt
  3073. # and return its address (in temporary storage).
  3074. # do_va_arg(flags,arg_fvd,alist)
  3075.   local void* do_va_arg (uintWL flags, object arg_fvd, va_alist alist);
  3076.   local void* do_va_arg(flags,arg_fvd,alist)
  3077.     var reg3 uintWL flags;
  3078.     var reg1 object arg_fvd;
  3079.     var reg4 va_alist alist;
  3080.     { if (symbolp(arg_fvd))
  3081.         { if (eq(arg_fvd,S(nil)))
  3082.             { return NULL; }
  3083.           elif (eq(arg_fvd,S(char)) || eq(arg_fvd,S(sint8)))
  3084.             { alist->tmp._schar =
  3085.                 (flags & ff_lang_ansi_c
  3086.                  ? va_arg_schar(alist)
  3087.                  : # `signed char' promotes to `int'
  3088.                    va_arg_int(alist)
  3089.                 );
  3090.               return &alist->tmp._schar;
  3091.             }
  3092.           elif (eq(arg_fvd,S(uchar)) || eq(arg_fvd,S(uint8)) || eq(arg_fvd,S(character)))
  3093.             { alist->tmp._uchar =
  3094.                 (flags & ff_lang_ansi_c
  3095.                  ? va_arg_uchar(alist)
  3096.                  : # `unsigned char' promotes to `unsigned int'
  3097.                    va_arg_uint(alist)
  3098.                 );
  3099.               return &alist->tmp._uchar;
  3100.             }
  3101.           elif (eq(arg_fvd,S(short)) || eq(arg_fvd,S(sint16)))
  3102.             { alist->tmp._short =
  3103.                 (flags & ff_lang_ansi_c
  3104.                  ? va_arg_short(alist)
  3105.                  : # `short' promotes to `int'
  3106.                    va_arg_int(alist)
  3107.                 );
  3108.               return &alist->tmp._short;
  3109.             }
  3110.           elif (eq(arg_fvd,S(ushort)) || eq(arg_fvd,S(uint16)))
  3111.             { alist->tmp._ushort =
  3112.                 (flags & ff_lang_ansi_c
  3113.                  ? va_arg_ushort(alist)
  3114.                  : # `unsigned short' promotes to `unsigned int'
  3115.                    va_arg_uint(alist)
  3116.                 );
  3117.               return &alist->tmp._ushort;
  3118.             }
  3119.           elif (eq(arg_fvd,S(boolean)) || eq(arg_fvd,S(int))
  3120.                 #if (int_bitsize==32)
  3121.                 || eq(arg_fvd,S(sint32))
  3122.                 #endif
  3123.                )
  3124.             { alist->tmp._int = va_arg_int(alist);
  3125.               return &alist->tmp._int;
  3126.             }
  3127.           elif (eq(arg_fvd,S(uint))
  3128.                 #if (int_bitsize==32)
  3129.                 || eq(arg_fvd,S(uint32))
  3130.                 #endif
  3131.                )
  3132.             { alist->tmp._uint = va_arg_uint(alist);
  3133.               return &alist->tmp._uint;
  3134.             }
  3135.           elif (eq(arg_fvd,S(long))
  3136.                 #if (int_bitsize<32) && (long_bitsize==32)
  3137.                 || eq(arg_fvd,S(sint32))
  3138.                 #endif
  3139.                 #if (long_bitsize==64)
  3140.                 || eq(arg_fvd,S(sint64))
  3141.                 #endif
  3142.                )
  3143.             { alist->tmp._long = va_arg_long(alist);
  3144.               return &alist->tmp._long;
  3145.             }
  3146.           elif (eq(arg_fvd,S(ulong))
  3147.                 #if (int_bitsize<32) && (long_bitsize==32)
  3148.                 || eq(arg_fvd,S(uint32))
  3149.                 #endif
  3150.                 #if (long_bitsize==64)
  3151.                 || eq(arg_fvd,S(uint64))
  3152.                 #endif
  3153.                )
  3154.             { alist->tmp._ulong = va_arg_ulong(alist);
  3155.               return &alist->tmp._ulong;
  3156.             }
  3157.           #if (long_bitsize<64)
  3158.           elif (eq(arg_fvd,S(sint64)))
  3159.             { return &va_arg_struct(alist,struct_sint64); }
  3160.           elif (eq(arg_fvd,S(uint64)))
  3161.             { return &va_arg_struct(alist,struct_uint64); }
  3162.           #endif
  3163.           elif (eq(arg_fvd,S(single_float)))
  3164.             { alist->tmp._float =
  3165.                 (flags & ff_lang_ansi_c
  3166.                  ? va_arg_float(alist)
  3167.                  : # `float' promotes to `double'
  3168.                    va_arg_double(alist)
  3169.                 );
  3170.               return &alist->tmp._float;
  3171.             }
  3172.           elif (eq(arg_fvd,S(double_float)))
  3173.             { alist->tmp._double = va_arg_double(alist);
  3174.               return &alist->tmp._double;
  3175.             }
  3176.           elif (eq(arg_fvd,S(c_pointer)) || eq(arg_fvd,S(c_string)))
  3177.             { alist->tmp._ptr = va_arg_ptr(alist,void*);
  3178.               return &alist->tmp._ptr;
  3179.             }
  3180.           else
  3181.             { fehler_foreign_type(arg_fvd); }
  3182.         }
  3183.       elif (simple_vector_p(arg_fvd))
  3184.         { var reg2 object arg_fvdtype = TheSvector(arg_fvd)->data[0];
  3185.           if (eq(arg_fvdtype,S(c_struct)) || eq(arg_fvdtype,S(c_union))
  3186.               || eq(arg_fvdtype,S(c_array)) || eq(arg_fvdtype,S(c_array_max))
  3187.              )
  3188.             { foreign_layout(arg_fvd);
  3189.              {var reg5 uintL arg_size = data_size;
  3190.               var reg6 uintL arg_alignment = data_alignment;
  3191.               return _va_arg_struct(alist,arg_size,arg_alignment);
  3192.             }}
  3193.           elif (eq(arg_fvdtype,S(c_function))
  3194.                 || eq(arg_fvdtype,S(c_ptr)) 
  3195.                 || eq(arg_fvdtype,S(c_ptr_null))
  3196.                 || eq(arg_fvdtype,S(c_array_ptr))
  3197.                )
  3198.             { alist->tmp._ptr = va_arg_ptr(alist,void*);
  3199.               return &alist->tmp._ptr;
  3200.             }
  3201.           else
  3202.             { fehler_foreign_type(arg_fvd); }
  3203.         }
  3204.       else
  3205.         { fehler_foreign_type(arg_fvd); }
  3206.     }
  3207.  
  3208. # Call the appropriate va_return_xxx macro for the result.
  3209. # do_va_return(flags,result_fvd,alist,result_size,result_alignment);
  3210.   local void do_va_return (uintWL flags, object result_fvd, va_alist alist, void* result_address, uintL result_size, uintL result_alignment);
  3211.   local void do_va_return(flags,result_fvd,alist,result_address,result_size,result_alignment)
  3212.     var reg4 uintWL flags;
  3213.     var reg1 object result_fvd;
  3214.     var reg5 va_alist alist;
  3215.     var reg3 void* result_address;
  3216.     var reg6 uintL result_size;
  3217.     var reg7 uintL result_alignment;
  3218.     { if (symbolp(result_fvd))
  3219.         { if (eq(result_fvd,S(nil)))
  3220.             { va_return_void(alist); }
  3221.           elif (eq(result_fvd,S(char)) || eq(result_fvd,S(sint8)))
  3222.             { if (flags & ff_lang_ansi_c)
  3223.                 { va_return_schar(alist,*(sint8*)result_address); }
  3224.                 else # `signed char' promotes to `int'
  3225.                 { va_return_int(alist,*(sint8*)result_address); }
  3226.             }
  3227.           elif (eq(result_fvd,S(uchar)) || eq(result_fvd,S(uint8)) || eq(result_fvd,S(character)))
  3228.             { if (flags & ff_lang_ansi_c)
  3229.                 { va_return_uchar(alist,*(uint8*)result_address); }
  3230.                 else # `unsigned char' promotes to `unsigned int'
  3231.                 { va_return_uint(alist,*(uint8*)result_address); }
  3232.             }
  3233.           elif (eq(result_fvd,S(short)) || eq(result_fvd,S(sint16)))
  3234.             { if (flags & ff_lang_ansi_c)
  3235.                 { va_return_short(alist,*(sint16*)result_address); }
  3236.                 else # `short' promotes to `int'
  3237.                 { va_return_int(alist,*(sint16*)result_address); }
  3238.             }
  3239.           elif (eq(result_fvd,S(ushort)) || eq(result_fvd,S(uint16)))
  3240.             { if (flags & ff_lang_ansi_c)
  3241.                 { va_return_ushort(alist,*(uint16*)result_address); }
  3242.                 else # `unsigned short' promotes to `unsigned int'
  3243.                 { va_return_uint(alist,*(uint16*)result_address); }
  3244.             }
  3245.           elif (eq(result_fvd,S(boolean)) || eq(result_fvd,S(int))
  3246.                 #if (int_bitsize==32)
  3247.                 || eq(result_fvd,S(sint32))
  3248.                 #endif
  3249.                )
  3250.             { va_return_int(alist,*(int*)result_address); }
  3251.           elif (eq(result_fvd,S(uint))
  3252.                 #if (int_bitsize==32)
  3253.                 || eq(result_fvd,S(uint32))
  3254.                 #endif
  3255.                )
  3256.             { va_return_uint(alist,*(unsigned int *)result_address); }
  3257.           elif (eq(result_fvd,S(long))
  3258.                 #if (int_bitsize<32) && (long_bitsize==32)
  3259.                 || eq(result_fvd,S(sint32))
  3260.                 #endif
  3261.                 #if (long_bitsize==64)
  3262.                 || eq(result_fvd,S(sint64))
  3263.                 #endif
  3264.                )
  3265.             { va_return_long(alist,*(long*)result_address); }
  3266.           elif (eq(result_fvd,S(ulong))
  3267.                 #if (int_bitsize<32) && (long_bitsize==32)
  3268.                 || eq(result_fvd,S(uint32))
  3269.                 #endif
  3270.                 #if (long_bitsize==64)
  3271.                 || eq(result_fvd,S(uint64))
  3272.                 #endif
  3273.                )
  3274.             { va_return_ulong(alist,*(unsigned long *)result_address); }
  3275.           #if (long_bitsize<64)
  3276.           elif (eq(result_fvd,S(sint64)))
  3277.             { va_return_struct(alist,struct_sint64,*(struct_sint64*)result_address); }
  3278.           elif (eq(result_fvd,S(uint64)))
  3279.             { va_return_struct(alist,struct_uint64,*(struct_uint64*)result_address); }
  3280.           #endif
  3281.           elif (eq(result_fvd,S(single_float)))
  3282.             { if (flags & ff_lang_ansi_c)
  3283.                 { va_return_float(alist,*(float*)result_address); }
  3284.                 else # `float' promotes to `double'
  3285.                 { va_return_double(alist,*(float*)result_address); }
  3286.             }
  3287.           elif (eq(result_fvd,S(double_float)))
  3288.             { va_return_double(alist,*(double*)result_address); }
  3289.           elif (eq(result_fvd,S(c_pointer)) || eq(result_fvd,S(c_string)))
  3290.             { va_return_ptr(alist,void*,*(void**)result_address); }
  3291.           else
  3292.             { fehler_foreign_type(result_fvd); }
  3293.         }
  3294.       elif (simple_vector_p(result_fvd))
  3295.         { var reg2 object result_fvdtype = TheSvector(result_fvd)->data[0];
  3296.           if (eq(result_fvdtype,S(c_struct)) || eq(result_fvdtype,S(c_union))
  3297.               || eq(result_fvdtype,S(c_array)) || eq(result_fvdtype,S(c_array_max))
  3298.              )
  3299.             { _va_return_struct(alist,result_size,result_alignment,result_address); }
  3300.           elif (eq(result_fvdtype,S(c_function))
  3301.                 || eq(result_fvdtype,S(c_ptr)) 
  3302.                 || eq(result_fvdtype,S(c_ptr_null))
  3303.                 || eq(result_fvdtype,S(c_array_ptr))
  3304.                )
  3305.             { va_return_ptr(alist,void*,*(void**)result_address); }
  3306.           else
  3307.             { fehler_foreign_type(result_fvd); }
  3308.         }
  3309.       else
  3310.         { fehler_foreign_type(result_fvd); }
  3311.     }
  3312.  
  3313. # This is the CALL-IN function called by the trampolines.
  3314.   local void callback ();
  3315.   local void callback(alist)
  3316.     va_alist alist;
  3317.     { var reg1 uintL index = (uintL)trampvar;
  3318.       begin_callback();
  3319.      {var reg2 object* triple = &TheSvector(TheArray(O(foreign_callin_vector))->data)->data[3*index-2];
  3320.       var reg4 object fun = triple[0];
  3321.       var reg1 object ffun = triple[1];
  3322.       var reg3 uintWL flags = posfixnum_to_L(TheFfunction(ffun)->ff_flags);
  3323.       var reg5 object result_fvd = TheFfunction(ffun)->ff_resulttype;
  3324.       var reg9 object argfvds = TheFfunction(ffun)->ff_argtypes;
  3325.       var reg6 uintL argcount = TheSvector(argfvds)->length/2;
  3326.       pushSTACK(result_fvd);
  3327.       pushSTACK(fun);
  3328.       pushSTACK(argfvds);
  3329.       switch (flags & 0xFF00)
  3330.         { # For the moment, the only supported languages are "C" and "ANSI C".
  3331.           case ff_lang_c:
  3332.           case ff_lang_ansi_c:
  3333.             break;
  3334.           default:
  3335.             fehler_function_no_fvd(ffun,S(foreign_call_in));
  3336.         }
  3337.       foreign_layout(result_fvd);
  3338.       { var reg7 uintL result_size = data_size;
  3339.         var reg8 uintL result_alignment = data_alignment;
  3340.         var reg10 boolean result_splittable = data_splittable;
  3341.         # Call va_start_xxx:
  3342.         do_va_start(flags,result_fvd,alist,result_size,result_alignment,result_splittable);
  3343.         # Walk through the arguments, convert them to Lisp data:
  3344.         { var reg2 uintL i;
  3345.           for (i = 0; i < argcount; i++)
  3346.             { var reg9 object argfvds = STACK_(i);
  3347.               var reg1 object arg_fvd = TheSvector(argfvds)->data[2*i];
  3348.               var reg9 uintWL arg_flags = posfixnum_to_L(TheSvector(argfvds)->data[2*i+1]);
  3349.               var reg4 void* arg_addr = do_va_arg(flags,arg_fvd,alist);
  3350.               var reg5 object arg = convert_from_foreign(arg_fvd,arg_addr);
  3351.               if (arg_flags & ff_malloc)
  3352.                 { free_foreign(arg_fvd,arg_addr); }
  3353.               pushSTACK(arg);
  3354.         }   }
  3355.         # Call the Lisp function:
  3356.         funcall(STACK_(1+argcount),argcount);
  3357.         # Allocate space for the result:
  3358.         { var DYNAMIC_ARRAY(reg10,result_room,char,result_size+result_alignment/*-1*/);
  3359.          {var reg7 void* result_address = (void*)((uintP)(result_room+result_alignment-1) & -(long)result_alignment);
  3360.         # Convert the result:
  3361.           if (flags & ff_malloc)
  3362.             { convert_to_foreign_mallocing(STACK_2,value1,result_address); }
  3363.             else
  3364.             { convert_to_foreign_nomalloc(STACK_2,value1,result_address); }
  3365.         # Call va_return_xxx:
  3366.           do_va_return(flags,STACK_2,alist,result_address,result_size,result_alignment);
  3367.           FREE_DYNAMIC_ARRAY(result_room);
  3368.         }}
  3369.       }
  3370.       skipSTACK(3);
  3371.       end_callback();
  3372.     }}
  3373.  
  3374.  
  3375. #ifdef AMIGAOS
  3376.  
  3377. # O(foreign_libraries) is an alist of all open libraries.
  3378.  
  3379. # Open a library.
  3380.   local struct Library * open_library (object name, uintL version);
  3381.   local struct Library * open_library(name,version)
  3382.     var reg5 object name;
  3383.     var reg6 uintL version;
  3384.     { var reg4 struct Library * libaddr;
  3385.       with_string_0(name,libname,
  3386.         { begin_system_call();
  3387.           libaddr = OpenLibrary(libname,version);
  3388.           end_system_call();
  3389.         });
  3390.       if (libaddr == NULL)
  3391.         { pushSTACK(name);
  3392.           pushSTACK(S(foreign_library));
  3393.           //: DEUTSCH "~: Kann Bibliothek ~ nicht öffnen."
  3394.           //: ENGLISH "~: Cannot open library ~"
  3395.           //: FRANCAIS "~ : Ne peux ouvrir bibliothèque ~."
  3396.           fehler(error, GETTEXT("~: Cannot open library ~"));
  3397.         }
  3398.       return libaddr;
  3399.     }
  3400.  
  3401. # (FFI::FOREIGN-LIBRARY name [required-version])
  3402. # returns a foreign library specifier.
  3403. LISPFUN(foreign_library,1,1,norest,nokey,0,NIL)
  3404.   { var reg2 object name = STACK_1;
  3405.     var reg6 uintL v;
  3406.     if (!stringp(name)) { fehler_string(name); }
  3407.     { var reg7 object version = STACK_0;
  3408.       if (eq(STACK_0,unbound))
  3409.         { v = 0; }
  3410.       else
  3411.         { check_uint32(version); v = I_to_uint32(version); }
  3412.     }
  3413.     # Check whether the library is on the alist or has already been opened.
  3414.     { var reg1 object alist = O(foreign_libraries);
  3415.       while (consp(alist))
  3416.         { if (equal(name,Car(Car(alist))))
  3417.             { var reg4 object address = Cdr(Car(alist));
  3418.               var reg3 object lib = TheFaddress(address)->fa_base;
  3419.               if (!fp_validp(TheFpointer(lib)))
  3420.                 # Library already existed in a previous Lisp session.
  3421.                 # Update the address, and make it valid.
  3422.                 { var reg5 struct Library * libaddr = open_library(name,v);
  3423.                   TheFpointer(lib)->fp_pointer = libaddr;
  3424.                   mark_fp_valid(TheFpointer(lib));
  3425.                 }
  3426.               value1 = address;
  3427.               goto done;
  3428.             }
  3429.           alist = Cdr(alist);
  3430.     }   }
  3431.     # Pre-allocate room:
  3432.     pushSTACK(allocate_cons()); pushSTACK(allocate_cons());
  3433.     pushSTACK(allocate_fpointer((void*)0));
  3434.     pushSTACK(allocate_faddress());
  3435.     # Open the library:
  3436.     { var reg5 struct Library * libaddr = open_library(STACK_(1+4),v);
  3437.       var reg4 object lib = popSTACK();
  3438.       TheFpointer(STACK_0)->fp_pointer = libaddr;
  3439.       TheFaddress(lib)->fa_base = popSTACK();
  3440.       TheFaddress(lib)->fa_offset = 0;
  3441.       value1 = lib;
  3442.      {var reg1 object acons = popSTACK();
  3443.       var reg3 object new_cons = popSTACK();
  3444.       Car(acons) = STACK_1; Cdr(acons) = lib;
  3445.       Car(new_cons) = acons; Cdr(new_cons) = O(foreign_libraries);
  3446.       O(foreign_libraries) = new_cons;
  3447.     }}
  3448.     done:
  3449.     mv_count=1; skipSTACK(2);
  3450.   }
  3451.  
  3452. # Try to make a Foreign-Pointer valid again.
  3453. # validate_fpointer(obj);
  3454.   global void validate_fpointer (object obj);
  3455.   global void validate_fpointer(obj)
  3456.     var reg3 object obj;
  3457.     { # If the foreign pointer belongs to a foreign library from a previous
  3458.       # session, we reopen the library.
  3459.       { var reg1 object l = O(foreign_libraries);
  3460.         while (consp(l))
  3461.           { var reg2 object acons = Car(l);
  3462.             l = Cdr(l);
  3463.             if (eq(TheFaddress(Cdr(acons))->fa_base,obj))
  3464.               { var reg4 struct Library * libaddr = open_library(Car(acons),0); # version ??
  3465.                 TheFpointer(obj)->fp_pointer = libaddr;
  3466.                 mark_fp_valid(TheFpointer(obj));
  3467.                 return;
  3468.       }   }   }
  3469.       fehler_fpointer_invalid(obj);
  3470.     }
  3471.  
  3472. # (FFI::FOREIGN-ADDRESS-VARIABLE name library offset c-type)
  3473. # returns a foreign variable.
  3474. LISPFUNN(foreign_library_variable,4)
  3475.   { if (!mstringp(STACK_3)) { fehler_string(STACK_3); }
  3476.     STACK_3 = coerce_ss(STACK_3);
  3477.     if (!faddressp(STACK_2))
  3478.       { pushSTACK(STACK_2);
  3479.         pushSTACK(TheSubr(subr_self)->name);
  3480.         //: DEUTSCH "~: Argument ist keine Foreign-Adresse: ~"
  3481.         //: ENGLISH "~: argument is not a foreign address: ~"
  3482.         //: FRANCAIS "~ : l'argument n'est pas une adresse étrangère : ~."
  3483.         fehler(error, GETTEXT("~: argument is not a foreign address: ~"));
  3484.       }
  3485.     check_sint32(STACK_1);
  3486.     foreign_layout(STACK_0);
  3487.    {var reg3 uintL size = data_size;
  3488.     var reg2 uintL alignment = data_alignment;
  3489.     pushSTACK(make_faddress(TheFaddress(STACK_2)->fa_base,
  3490.                             TheFaddress(STACK_2)->fa_offset
  3491.                             + (sintP)I_to_sint32(STACK_1)));
  3492.     { var reg1 object fvar = allocate_fvariable();
  3493.       TheFvariable(fvar)->fv_name = STACK_(3+1);
  3494.       TheFvariable(fvar)->fv_address = STACK_0;
  3495.       TheFvariable(fvar)->fv_size = fixnum(size);
  3496.       TheFvariable(fvar)->fv_type = STACK_(0+1);
  3497.       if (!(((uintP)Faddress_value(TheFvariable(fvar)->fv_address) & (alignment-1)) == 0))
  3498.         { pushSTACK(fvar);
  3499.           pushSTACK(TheSubr(subr_self)->name);
  3500.           //: DEUTSCH "~: Foreign-Variable ~ hat nicht das geforderte Alignment."
  3501.           //: ENGLISH "~: foreign variable ~ does not have the required alignment"
  3502.           //: FRANCAIS "~ : variable étrangère ~ n'a pas le placement nécessaire."
  3503.           fehler(error, GETTEXT("~: foreign variable ~ does not have the required alignment"));
  3504.         }
  3505.       value1 = fvar; mv_count=1; skipSTACK(4+1);
  3506.   }}}
  3507.  
  3508. # (FFI::FOREIGN-LIBRARY-FUNCTION name library offset c-function-type)
  3509. # returns a foreign function.
  3510. LISPFUNN(foreign_library_function,4)
  3511.   { if (!mstringp(STACK_3)) { fehler_string(STACK_3); }
  3512.     STACK_3 = coerce_ss(STACK_3);
  3513.     if (!faddressp(STACK_2)) # TODO? search in O(foreign_libraries)
  3514.       { pushSTACK(STACK_2);
  3515.         pushSTACK(TheSubr(subr_self)->name);
  3516.         //: DEUTSCH "~: ~ ist keine Bibliothek."
  3517.         //: ENGLISH "~: ~ is not a library"
  3518.         //: FRANCAIS "~ : ~ n'est pas une bibliothèque."
  3519.         fehler(error, GETTEXT("~: ~ is not a library"));
  3520.       }
  3521.     check_sint32(STACK_1);
  3522.     { var reg1 object fvd = STACK_0;
  3523.       if (!(simple_vector_p(fvd)
  3524.             && (TheSvector(fvd)->length == 4)
  3525.             && eq(TheSvector(fvd)->data[0],S(c_function))
  3526.             && m_simple_vector_p(TheSvector(fvd)->data[2])
  3527.          ) )
  3528.         { var reg1 object *fvd_ptr;
  3529.           pushSTACK(fvd); fvd_ptr=&STACK_0;
  3530.           dynamic_bind(S(print_circle),T); # *PRINT-CIRCLE* an T binden
  3531.           pushSTACK(*fvd_ptr);
  3532.           pushSTACK(TheSubr(subr_self)->name);
  3533.           //: DEUTSCH "~: ungültiger Typ für externe Funktion: ~"
  3534.           //: ENGLISH "~: illegal foreign function type ~"
  3535.           //: FRANCAIS "~ : type invalide de fonction externe : ~"
  3536.           fehler(error, GETTEXT("~: illegal foreign function type ~"));
  3537.         }
  3538.     }
  3539.     pushSTACK(make_faddress(TheFaddress(STACK_2)->fa_base,
  3540.                             TheFaddress(STACK_2)->fa_offset
  3541.                             + (sintP)I_to_sint32(STACK_1)));
  3542.     { var reg1 object ffun = allocate_ffunction();
  3543.       var reg2 object fvd = STACK_(0+1);
  3544.       TheFfunction(ffun)->ff_name = STACK_(3+1);
  3545.       TheFfunction(ffun)->ff_address = STACK_0;
  3546.       TheFfunction(ffun)->ff_resulttype = TheSvector(fvd)->data[1];
  3547.       TheFfunction(ffun)->ff_argtypes = TheSvector(fvd)->data[2];
  3548.       TheFfunction(ffun)->ff_flags = TheSvector(fvd)->data[3];
  3549.       value1 = ffun; mv_count=1; skipSTACK(4+1);
  3550.   } }
  3551.  
  3552. #else # UNIX
  3553.  
  3554. # Try to make a Foreign-Pointer valid again.
  3555. # validate_fpointer(obj);
  3556.   global void validate_fpointer (object obj);
  3557.   global void validate_fpointer(obj)
  3558.     var reg1 object obj;
  3559.     { # Can't do anything.
  3560.       fehler_fpointer_invalid(obj);
  3561.     }
  3562.  
  3563. #endif
  3564.  
  3565. # Initialize the FFI.
  3566.   global void init_ffi (void);
  3567.   global void init_ffi()
  3568.     { # Make vacall() call callback():
  3569.       vacall_function = &callback;
  3570.       # Allocate a fresh zero foreign pointer:
  3571.       O(fp_zero) = allocate_fpointer((void*)0);
  3572.     }
  3573.  
  3574. # De-Initialize the FFI.
  3575.   global void exit_ffi (void);
  3576.   global void exit_ffi()
  3577.     {
  3578.       #ifdef AMIGAOS
  3579.       # Close all foreign libraries.
  3580.       { var reg1 object alist = O(foreign_libraries);
  3581.         while (consp(alist))
  3582.           { var reg4 object acons = Car(alist);
  3583.             var reg3 object obj = TheFaddress(Cdr(acons))->fa_base;
  3584.             if (fp_validp(TheFpointer(obj)))
  3585.               { var reg2 struct Library * libaddr = (struct Library *)(TheFpointer(obj)->fp_pointer);
  3586.                 begin_system_call();
  3587.                 CloseLibrary(libaddr);
  3588.                 end_system_call();
  3589.               }
  3590.             alist = Cdr(alist);
  3591.           }
  3592.         O(foreign_libraries) = NIL;
  3593.       }
  3594.       #endif
  3595.     }
  3596.  
  3597. #endif
  3598.  
  3599.