home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-2.LHA / CLISP960530-di.lha / src / affi.d next >
Encoding:
Text File  |  1996-08-11  |  23.9 KB  |  639 lines
  1. # AFFI Poor man's simple foreign function calls
  2. # Jörg Höhle 11.8.1996
  3.  
  4. #include "lispbibl.c"
  5. # TODO? check offset against number of library vectors
  6. # TODO: LISPFUN(%CHECK-PROTO) by calling a do-nothing function
  7. # TODO: LISPFUN(VALIDP)             \
  8. # TODO: LISPFUN(INVALIDATE-FOREIGN)  +- useful with FINALIZE
  9. # TODO: LISPFUN(FOREIGN-NULLP)      /
  10.  
  11. #ifdef HAVE_AFFI
  12.  
  13. # die Moduldefinition ist am Dateiende
  14.  
  15. #ifdef MC680X0
  16.   #undef HAVE_REG_FF_CALL
  17.   #define HAVE_REG_FF_CALL
  18.  
  19.   #define reg_num  15
  20.   #define reg_coding 4 # used bits in mask
  21.   struct reg_map { ULONG reg[reg_num]; }; # d0-7,a0-6. a7 ist sp und nicht belegbar
  22.  
  23.   #ifdef AMIGAOS
  24.     #define libbase_reg 14 # a6 wird mit der Librarybase belegt
  25.   #endif
  26.  
  27.   #if defined(GNU) && !defined(NO_ASM)
  28.   local ULONG reg_call (aint address, struct reg_map *);
  29.   local ULONG reg_call(address, regs)
  30.     var reg2 aint address;
  31.     var reg1 struct reg_map *regs;
  32.     { var reg3 ULONG result  __asm__("d0");
  33.   #if 1 # DEBUG
  34.       begin_system_call();
  35.       asm("
  36.           moveml #0x3f3e,sp@-     | d2-d7,a2-a6
  37.         | pea pc@(Lgoon)          | ATTN: BUG: previous gas needed pc@(Lgoon+2)
  38.           pea Lgoon               | ATTN: BUG: as-2.5.x makes 68020 code for pea pc@(Lgoon)
  39.           movel %1,sp@-           | where to jump
  40.           moveml %2@,#0x7fff      | a6-a0,d7-d0
  41.           rts                     | jump
  42.         Lgoon:
  43.           moveml sp@+,#0x7cfc     | a6-a2,d7-d2
  44.   "
  45.           : "=d" (result)
  46.           : "r" (address), "a" (regs)
  47.           : "memory");
  48.       end_system_call();
  49.   #elif 0
  50.       begin_system_call();
  51.       asm("
  52.           moveml #0x3f3e,sp@-     | d2-d7,a2-a6
  53.           movel %1,sp@-           | where to jump
  54.           moveml %2@,#0x7fff      | a6-a0,d7-d0
  55.           jbsr sp@(4)             | call function
  56.           addqw #4,sp             | pop address
  57.           moveml sp@+,#0x7cfc     | a6-a2,d7-d2
  58.   "
  59.           : "=d" (result)
  60.           : "r" (address), "a" (regs)
  61.           : "memory");
  62.       end_system_call();
  63.   #else
  64.       var reg1 uintC count = reg_num;
  65.       asciz_out("Sprungadresse "); hex_out(address); asciz_out("\n");
  66.       dotimesC(count,count,
  67.         { dez_out(count); asciz_out(": "); hex_out(regs->reg[count]); asciz_out("\n"); });
  68.       result = regs->reg[0];
  69.   #endif # DEBUG
  70.       return result;
  71.     }
  72.   #endif # GNU
  73. #endif # MC680X0
  74.  
  75.  
  76. # stattdessen fehler_funspec verwenden?
  77. nonreturning_function(local, fehler_ffi_nocall, (object ffinfo));
  78. local void fehler_ffi_nocall(ffinfo)
  79.   var reg1 object ffinfo;
  80.   { pushSTACK(ffinfo); pushSTACK(TheSubr(subr_self)->name);
  81.     //: DEUTSCH "~: Nicht unterstützter Aufrufmechanismus: ~"
  82.     //: ENGLISH "~: Unsupported call mechanism: ~"
  83.     //: FRANCAIS "~: Convention d'appel non supportée : ~"
  84.     fehler(control_error,GETTEXT("~: Unsupported call mechanism: ~"));
  85.   }
  86.  
  87. nonreturning_function(local, fehler_ffi_proto, (object ffinfo));
  88. local void fehler_ffi_proto(ffinfo)
  89.   var reg1 object ffinfo;
  90.   { pushSTACK(ffinfo);
  91.     pushSTACK(TheSubr(subr_self)->name);
  92.     //: DEUTSCH "~: Ungültiger Funktionsprototyp: ~"
  93.     //: ENGLISH "~: Bad function prototype: ~"
  94.     //: FRANCAIS "~ : Mauvais prototype : ~"
  95.     fehler(program_error,GETTEXT("~: Bad function prototype: ~"));
  96.   }
  97.  
  98. nonreturning_function(local, fehler_ffi_argcount, (object ffinfo));
  99. local void fehler_ffi_argcount(ffinfo)
  100.   var reg1 object ffinfo;
  101.   { pushSTACK(ffinfo);
  102.     pushSTACK(TheSubr(subr_self)->name);
  103.     //: DEUTSCH "~: Unpassende Anzahl Argumente für Prototyp ~."
  104.     //: ENGLISH "~: Wrong number of arguments for prototype ~"
  105.     //: FRANCAIS "~: Mauvais nombre d'arguments pour le prototype ~."
  106.     fehler(program_error,GETTEXT("~: Wrong number of arguments for prototype ~"));
  107.   }
  108.  
  109. nonreturning_function(local, fehler_ffi_argtype, (object obj, object type, object ffinfo));
  110. local void fehler_ffi_argtype(obj,type,ffinfo)
  111.   var reg2 object obj;
  112.   var reg1 object type; # wird nur unpräzise verwendet
  113.   var reg3 object ffinfo;
  114.   { pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  115.     pushSTACK(fixnump(type) ? S(integer) : T); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  116.     pushSTACK(obj); pushSTACK(ffinfo); pushSTACK(TheSubr(subr_self)->name);
  117.     //: DEUTSCH "~: Unpassendes Argument für Prototyp ~: ~"
  118.     //: ENGLISH "~: Bad argument for prototype ~: ~"
  119.     //: FRANCAIS "~: Argument incorrect pour le prototype ~ : ~"
  120.     fehler(type_error,GETTEXT("~: Bad argument for prototype ~: ~"));
  121.   }
  122.  
  123. #define fehler_ffi_type  fehler_ffi_arg
  124. nonreturning_function(local, fehler_ffi_arg, (object obj));
  125. local void fehler_ffi_arg(obj)
  126.   var reg1 object obj;
  127.   { pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
  128.     //: DEUTSCH "~: Unpassendes Argument: ~"
  129.     //: ENGLISH "~: Bad argument: ~"
  130.     //: FRANCAIS "~: Argument incorrect : ~"
  131.     fehler(control_error,GETTEXT("~: Bad argument: ~"));
  132.   }
  133.  
  134. # Lese gültige Adresse inklusive Offset
  135. local aint convert_address (object obj, object offset);
  136. local aint convert_address(obj, offset)
  137.   var reg1 object obj;
  138.   var reg3 object offset;
  139.   { var reg2 aint address = 0;
  140.     if (uint32_p(obj))
  141.       { address = I_to_UL(obj); }
  142.     elif (fpointerp(obj) && fp_validp(TheFpointer(obj)))
  143.       { address = (aint)(TheFpointer(obj)->fp_pointer); }
  144.     if (address == 0)
  145.       { pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  146.         pushSTACK(S(unsigned_byte)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  147.         pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
  148.         //: DEUTSCH "~: ~ ist keine gültige Adresse."
  149.         //: ENGLISH "~: ~ is not a valid address"
  150.         //: FRANCAIS "~: ~ n'est pas une bonne adresse."
  151.         fehler(type_error,GETTEXT("~: ~ is not a valid address"));
  152.       }
  153.     if (!eq(offset,unbound))
  154.       { address += I_to_L(offset); }
  155.     return address;
  156.   }
  157.  
  158.  
  159. #if defined(HAVE_LONGLONG) && 1 # benötigt Funktionen aus INTELEM.D und LISPBIBL.D
  160. #define uintbig  uint64
  161. #define uintbig_p(obj)  uint64_p(obj) # reicht für reg_num <= 16 (AmigaOS)
  162. #define I_to_Ubig(obj)  I_to_UQ(obj)
  163. #else
  164. #define uintbig  uintL
  165. #define uintbig_p(obj)  uint32_p(obj) # reicht nicht für reg_num > 8
  166. #define I_to_Ubig(obj)  I_to_UL(obj)
  167. #endif
  168.  
  169. # Führt Funktionsaufruf aus und erzeugt LISP-Ergebnis.
  170. # Die Argumente müssen zuvor überprüft worden sein (Typ und Zahl)
  171. # < value1, mv_count
  172. local void affi_callit (aint address, object ffinfo, aint* args);
  173. local void affi_callit(address, ffinfo, args)
  174.   var reg6 aint address;
  175.   var object ffinfo;
  176.   var reg4 aint* args;
  177.   { var reg7 sintL offset;
  178.     var reg3 object mask;
  179.     var reg3 aint thing;
  180.     { var reg4 object both = TheSvector(ffinfo)->data[0];
  181.       if (nullp(both))
  182.         { mask = NIL;
  183.           offset = 0;
  184.         }
  185.       elif (consp(both))
  186.         { mask = Cdr(both);
  187.           offset = I_to_L(Car(both)); # nur fixnum_to_L() (dann mit Überprüfung) ?
  188.         }
  189.       else goto bad_proto;
  190.     }
  191.     if (nullp(mask))
  192.       { # Stack-based call mechanism
  193.         #ifdef HAVE_STACK_FF_CALL
  194.         thing = stack_call(address+offset,args,ffinfo);
  195.         #else
  196.         goto bad_call;
  197.         #endif
  198.       }
  199.     elif (integerp(mask))
  200.       { # Register-based call mechanism
  201.         #ifdef HAVE_REG_FF_CALL
  202.         var struct reg_map regs;
  203.         if (uintbig_p(mask))
  204.           {
  205.             var reg2 uintC count = TheSvector(ffinfo)->length-2;
  206.             #ifdef AMIGAOS # Always fill a6 with possible library base address
  207.             regs.reg[libbase_reg] = address;
  208.             #endif
  209.             if (eq(mask,Fixnum_0))
  210.               { if (count!=0) goto bad_proto; }
  211.               else
  212.               { var reg5 unsigned_int_with_n_bits(reg_num) used = 0;
  213.                 var reg3 uintbig lowmask = I_to_Ubig(mask);
  214.                 dotimesC(count,count,
  215.                   { var reg1 uintBW index = (lowmask & (bit(reg_coding)-1));
  216.                     index = index-1; # 0 gilt nicht als Index
  217.                     if (index >= reg_num || bit_test(used,index)) goto bad_proto;
  218.                     used |= bit(index);
  219.                     regs.reg[index] = *args++;
  220.                     lowmask >>= reg_coding;
  221.                   });
  222.                 if (lowmask!=0) goto bad_proto;
  223.           }   }
  224.         else goto bad_proto;
  225.         # Regcall ausführen
  226.         thing = reg_call(address+offset,®s);
  227.         #else
  228.         goto bad_call;
  229.         #endif
  230.       }
  231.     else
  232.       { bad_proto:
  233.         fehler_ffi_proto(ffinfo);
  234.         bad_call:
  235.         fehler_ffi_nocall(ffinfo);
  236.       }
  237.     # Aufruf erfolgreich, Werte setzen
  238.     # Ergebnis kann bei GC (wegen String oder Bignum) und RESET verloren gehen
  239.     { var reg2 object rtype = TheSvector(ffinfo)->data[1];
  240.       if (eq(rtype,NIL))
  241.         { mv_count=0; value1 = NIL; }
  242.         else
  243.         { if (fixnump(rtype))
  244.             { switch(fixnum_to_L(rtype))
  245.                 { case  4L: value1 = UL_to_I(thing); break;
  246.                   case  2L: value1 = UL_to_I((uint16)thing); break;
  247.                   case  1L: value1 = UL_to_I((uint8)thing); break;
  248.                   case  0L: value1 = thing ? T : NIL; break; # Typ BOOL
  249.                   case -1L: value1 = L_to_I((sint8)thing); break;
  250.                   case -2L: value1 = L_to_I((sint16)thing); break;
  251.                   case -4L: value1 = L_to_I(thing); break;
  252.                   # andere Fälle wurde schon mit Fehler abgefangen
  253.                   default: value1 = NIL;
  254.             }   }
  255.           elif (eq(rtype,S(string)))    # string
  256.             { value1 = (thing == 0) ? NIL : asciz_to_string((char*)thing); }
  257.           elif (eq(rtype,S(mal)))       # *
  258.             { value1 = UL_to_I(thing); }
  259.           elif (eq(rtype,S(Kexternal))) # :external
  260.             { value1 = (thing == 0) ? NIL : allocate_fpointer((FOREIGN)thing); }
  261.           # andere Fälle wurden schon mit Fehler abgefangen
  262.           else { value1 = NIL; }
  263.           mv_count=1;
  264.   } }   }
  265.  
  266.  
  267. # Führt Typüberprüfungen und Aufruf aus. Ermittelt dabei und belegt
  268. # mittels alloca() die Größe des Bereichs für die LISP-STRING nach C
  269. # (asciz) Umwandlung
  270. # Darf bis zum Aufruf keine GC auslösen.
  271. # < value1, mv_count
  272. local void affi_call_argsa (aint address, object ffinfo, object* args, uintC count);
  273. local void affi_call_argsa(address, ffinfo, args, count)
  274.   var aint address;
  275.   var reg3 object ffinfo;
  276.   var reg7 object* args;
  277.   var reg4 uintC count;
  278.   { # if (!simple_vector_p(ffinfo)) goto bad_proto; # oder fehler_kein_svector();
  279.     # Zahl der Argumente überprüfen
  280.     { var reg1 uintL vlen = TheSvector(ffinfo)->length;
  281.       if (vlen != count+2) { fehler_ffi_argcount(ffinfo); }
  282.     }
  283.     # Return-Type schon vor dem Aufruf überprüfen
  284.     { var reg2 object rtype = TheSvector(ffinfo)->data[1];
  285.       if (fixnump(rtype))
  286.         { var reg1 sintL size = fixnum_to_L(rtype);
  287.           if (size < 0) { size = -size; }
  288.           if (size > 4 || size == 3) goto bad_proto;
  289.         }
  290.       elif (!( nullp(rtype) || eq(rtype,S(mal)) || eq(rtype,S(Kexternal)) || eq(rtype,S(string)) )) goto bad_proto;
  291.     }
  292.     # Typprüfung und Speicherung (auf Stack SP) der Argumente
  293.     #define ACCEPT_ADDR_ARG      bit(0)
  294.     #define ACCEPT_STRING_ARG    bit(1)
  295.     #define ACCEPT_UBVECTOR_ARG  bit(2)
  296.     #define ACCEPT_MAKE_ASCIZ    bit(3)
  297.     #define ACCEPT_NIL_ARG       bit(4)
  298.     #define ACCEPT_NUM_ARG       bit(5)
  299.     { var DYNAMIC_ARRAY(,things,aint,count);
  300.       var reg6 object* types = &TheSvector(ffinfo)->data[2];
  301.       var reg8 aint* thing = &things[0];
  302.       dotimesC(count,count,
  303.         { var reg2 object type = *types++;
  304.           var reg3 object arg = NEXT(args);
  305.           if (fixnump(type))
  306.             { if (integerp(arg))
  307.                 { switch (fixnum_to_L(type))
  308.                     { case 1L:
  309.                         if (!uint8_p(arg)) goto bad_arg; # Fehlermeldung mit O(type_uint8) denkbar
  310.                           else *thing = I_to_uint8(arg);
  311.                         break;
  312.                       case 2L:
  313.                         if (!uint16_p(arg)) goto bad_arg;
  314.                           else *thing = I_to_uint16(arg);
  315.                         break;
  316.                       case 4L:
  317.                         if (!uint32_p(arg)) goto bad_arg;
  318.                           else *thing = I_to_uint32(arg);
  319.                         break;
  320.                       case -1L:
  321.                         if (!sint8_p(arg)) goto bad_arg;
  322.                           else *thing = I_to_sint8(arg);
  323.                         break;
  324.                       case -2L:
  325.                         if (!sint16_p(arg)) goto bad_arg;
  326.                           else *thing = I_to_sint16(arg);
  327.                         break;
  328.                       case -4L:
  329.                         if (!sint32_p(arg)) goto bad_arg;
  330.                           else *thing = I_to_sint32(arg);
  331.                         break;
  332.                       default: goto bad_proto;
  333.                 }   }
  334.                 else
  335.                 { bad_arg:
  336.                   fehler_ffi_argtype(arg,type,ffinfo);
  337.             }   }
  338.             else # !fixnump(type)
  339.             { var reg1 uintBWL accept;
  340.               if (eq(type,S(mal))) # Zeiger
  341.                   { accept = ACCEPT_ADDR_ARG | ACCEPT_UBVECTOR_ARG | ACCEPT_STRING_ARG | ACCEPT_MAKE_ASCIZ | ACCEPT_NIL_ARG; }
  342.               elif (eq(type,S(string)))
  343.                   { accept = ACCEPT_ADDR_ARG | ACCEPT_STRING_ARG | ACCEPT_MAKE_ASCIZ | ACCEPT_NIL_ARG; }
  344.               elif (eq(type,S(Kio)))
  345.                   { accept = ACCEPT_ADDR_ARG | ACCEPT_UBVECTOR_ARG | ACCEPT_STRING_ARG; }
  346.               elif (eq(type,S(Kexternal)))
  347.                   { accept = ACCEPT_ADDR_ARG | ACCEPT_NIL_ARG; }
  348.               else goto bad_proto;
  349.               switch (typecode(arg))
  350.                 { case_posfixnum: case_posbignum:
  351.                     if (!(accept & ACCEPT_ADDR_ARG)) goto bad_arg;
  352.                     *thing = (aint)I_to_UL(arg);
  353.                     break;
  354.                   case_string:
  355.                     if (!(accept & ACCEPT_STRING_ARG)) goto bad_arg;
  356.                     # Cf. with_string_0() macro in lispbibl.d
  357.                     { var uintL length;
  358.                       var reg2 uintB* charptr = unpack_string(arg,&length);
  359.                       if (accept & ACCEPT_MAKE_ASCIZ)
  360.                         { var reg1 uintB* ptr = alloca(1+length); # TODO Ergebnis testen
  361.                           *thing = (aint)ptr;
  362.                           dotimesL(length,length, { *ptr++ = *charptr++; } );
  363.                           *ptr = '\0';
  364.                         }
  365.                         else
  366.                         { *thing = (aint)charptr; }
  367.                     }
  368.                     break;
  369.                   case_symbol:
  370.                     if (!(accept & ACCEPT_NIL_ARG)) goto bad_arg;
  371.                     if (!nullp(arg)) goto bad_arg;
  372.                     *thing = (aint)0;
  373.                     break;
  374.                   case_orecord:
  375.                     if (!(accept & ACCEPT_ADDR_ARG)) goto bad_arg;
  376.                     if (!((TheRecord(arg)->rectype == Rectype_Fpointer)
  377.                           && fp_validp(TheFpointer(arg)))) goto bad_arg;
  378.                     *thing = (aint)(TheFpointer(arg)->fp_pointer);
  379.                     break;
  380.                   case_obvector:
  381.                     if (!(accept & ACCEPT_UBVECTOR_ARG)) goto bad_arg;
  382.                     { var reg1 uintBWL bsize = TheArray(arg)->flags & arrayflags_atype_mask;
  383.                       if (!((bsize==Atype_8Bit) || (bsize==Atype_16Bit) || (bsize==Atype_32Bit))) goto bad_arg;
  384.                      {var uintL index = 0;
  385.                       arg = array1_displace_check(arg,0,&index); # UNSAFE
  386.                       *thing = (aint)&TheSbvector(TheArray(arg)->data)->data[index];
  387.                     }}
  388.                     break;
  389.                   default: goto bad_arg;
  390.             }   }
  391.           thing++;
  392.         });
  393.       affi_callit(address,ffinfo,&things[0]);
  394.       FREE_DYNAMIC_ARRAY(things);
  395.       return;
  396.     }
  397.     bad_proto:
  398.     fehler_ffi_proto(ffinfo);
  399.   }
  400.  
  401. # (SYSTEM::%LIBCALL base ff-description &rest args)
  402. # kann GC auslösen (nach erfolgtem Aufruf)
  403. LISPFUN(affi_libcall,2,0,rest,nokey,0,NIL)
  404.   { var reg1 object ffinfo = Before(rest_args_pointer); # #((offset . mask) return-type . arg-types*))
  405.     var reg2 aint address = convert_address(Before(rest_args_pointer STACKop 1),unbound);
  406.     if (!simple_vector_p(ffinfo))
  407.       { fehler_kein_svector(TheSubr(subr_self)->name,ffinfo); }
  408.     affi_call_argsa(address,ffinfo,rest_args_pointer,argcount);
  409.     # value1 und mv_count wurden darin gesetzt
  410.     set_args_end_pointer(rest_args_pointer STACKop 2);
  411.   }
  412.  
  413.  
  414. local void bytecopy (void* to, const void* from, uintL length, uintC size);
  415. local void bytecopy(to,from,length,size)
  416.   var reg3 void* to;
  417.   var reg2 const void* from;
  418.   var reg1 uintL length;
  419.   var reg4 uintC size;
  420.   { switch (size)
  421.       { case 1: case 8:
  422.           dotimesL(length,length, { *((UBYTE*)to)++ = *((UBYTE*)from)++; }); break;
  423.         case 2: case 16:
  424.           dotimesL(length,length, { *((UWORD*)to)++ = *((UWORD*)from)++; }); break;
  425.         case 4: case 32:
  426.           dotimesL(length,length, { *((ULONG*)to)++ = *((ULONG*)from)++; }); break;
  427.         default:
  428.           /* NOTREACHED */
  429.   }   }
  430.  
  431. # (SYSTEM::MEM-READ address into [offset]) reads from address[+offset].
  432. # kann GC auslösen
  433. LISPFUN(mem_read,2,1,norest,nokey,0,NIL)
  434.   { var reg2 aint address = convert_address(STACK_2,STACK_0);
  435.     # TODO? address could be a LISP string or vector. Better not
  436.     var reg3 object into = STACK_1; # Größe in Byte, '*, 'STRING, string oder vector
  437.     skipSTACK(3);
  438.     if (eq(into,S(mal))) # pointer dereference
  439.       { value1 = UL_to_I(*(aint*)address); }
  440.     elif (posfixnump(into))
  441.       { var reg1 uintL content;
  442.         switch (posfixnum_to_L(into))
  443.           { case 1L: content = *(UBYTE *)address; break;
  444.             case 2L: content = *(UWORD *)address; break;
  445.             case 4L: content = *(ULONG *)address; break;
  446.             default: goto fehler_type;
  447.           }
  448.         value1 = UL_to_I(content);
  449.       }
  450.     elif (fixnump(into))
  451.       { var reg1 sintL content;
  452.         switch (negfixnum_to_L(into))
  453.           { case -1L: content = *(BYTE *)address; break;
  454.             case -2L: content = *(WORD *)address; break;
  455.             case -4L: content = *(LONG *)address; break;
  456.             default: goto fehler_type;
  457.           }
  458.         value1 = L_to_I(content);
  459.       }
  460.     elif (eq(into,S(string))) # make a LISP string
  461.       { value1 = asciz_to_string((uintB*)address); }
  462.     elif (stringp(into)) # copy memory into a LISP string
  463.       { var uintL length;
  464.         var reg1 uintB* charptr = unpack_string(into,&length);
  465.         dotimesL(length,length, { *charptr++ = *((uintB*)address)++; } );
  466.         value1 = into;
  467.       }
  468.     elif (!bit_vector_p(into) # copy memory into a LISP unsigned-byte vector
  469.           && ((typecode(into)&~imm_array_mask)==bvector_type))
  470.       { var reg3 uintBWL size = TheArray(into)->flags & arrayflags_atype_mask;
  471.         if (!((size==Atype_8Bit) || (size==Atype_16Bit) || (size==Atype_32Bit))) { goto fehler_type; }
  472.        {var reg4 uintL length = vector_length(into);
  473.         var uintL index = 0;
  474.         var reg5 object dv = array1_displace_check(into,length,&index);
  475.         bytecopy(&TheSbvector(TheArray(dv)->data)->data[index],(void*)address,length,bit(size));
  476.         value1 = into;
  477.       }}
  478.     else
  479.       { fehler_type:
  480.         fehler_ffi_type(into);
  481.       }
  482.     mv_count=1;
  483.   }
  484.  
  485.  
  486. # (SYSTEM::MEM-WRITE address type value [offset]) writes to address[+offset].
  487. LISPFUN(mem_write,3,1,norest,nokey,0,NIL)
  488.   { var reg1 aint address = convert_address(STACK_3,STACK_0);
  489.     var reg2 object wert = STACK_1;
  490.     var reg3 object type = STACK_2; # Größe in Byte oder *
  491.     skipSTACK(4);
  492.     if (eq(type,S(mal))) # pointer dereference
  493.       { if (integerp(wert))
  494.           { *(aint*)address = I_to_UL(wert); }
  495.         elif (fpointerp(wert))
  496.           { *(aint*)address = (aint)TheFpointer(wert)->fp_pointer; }
  497.         else goto bad_arg;
  498.       }
  499.     elif (!integerp(wert)) goto bad_arg;
  500.     elif (posfixnump(type))
  501.       { var reg2 ULONG value = I_to_UL(wert);
  502.         switch (posfixnum_to_L(type))
  503.           { case 1L: if (value & ~0xFF) goto bad_arg;
  504.                      else *(UBYTE *)address = value; break;
  505.             case 2L: if (value & ~0xFFFF) goto bad_arg;
  506.                      else *(UWORD *)address = value; break;
  507.             case 4L:      *(ULONG *)address = value; break;
  508.             default: goto bad_type;
  509.       }   }
  510.     elif (fixnump(type))
  511.       { var reg2 LONG value = I_to_L(wert);
  512.         switch (negfixnum_to_L(type)) # TODO valid range checks
  513.           { case -1L: *(BYTE *)address = value; break;
  514.             case -2L: *(WORD *)address = value; break;
  515.             case -4L: *(LONG *)address = value; break;
  516.             default: goto bad_type;
  517.       }   }
  518.     else
  519.       { bad_type:
  520.         fehler_ffi_type(type);
  521.         bad_arg:
  522.         fehler_ffi_arg(wert);
  523.       }
  524.     value1 = NIL; mv_count=0;
  525.   }
  526.  
  527. # (SYSTEM::MEM-WRITE-VECTOR address vector [offset]) writes string to address.
  528. LISPFUN(mem_write_vector,2,1,norest,nokey,0,NIL)
  529.   { var reg1 aint address = convert_address(STACK_2,STACK_0);
  530.     var reg2 object from = STACK_1;
  531.     skipSTACK(3);
  532.     if (stringp(from)) # write a LISP string to memory
  533.       { var uintL length;
  534.         var reg1 uintB* charptr = unpack_string(from,&length);
  535.         dotimesL(length,length, { *((uintB*)address)++ = *charptr++; } );
  536.         *(uintB*)address = '\0'; # and zero-terminate memory!
  537.       }
  538.     elif (!bit_vector_p(from) # copy memory into a LISP unsigned-byte vector
  539.           && ((typecode(from)&~imm_array_mask)==bvector_type))
  540.       { var reg3 uintBWL size = TheArray(from)->flags & arrayflags_atype_mask;
  541.         if (!((size==Atype_8Bit) || (size==Atype_16Bit) || (size==Atype_32Bit))) { goto fehler_type; }
  542.        {var reg4 uintL length = vector_length(from);
  543.         var uintL index = 0;
  544.         var reg5 object dv = array1_displace_check(from,length,&index);
  545.         bytecopy((void*)address,&TheSbvector(TheArray(dv)->data)->data[index],length,bit(size));
  546.       }}
  547.     else
  548.       { fehler_type:
  549.         fehler_ffi_type(from);
  550.       }
  551.     value1 = NIL; mv_count=0;
  552.   }
  553.  
  554. # (SYSTEM::NZERO-POINTER-P pointer) returns NIL for either NIL, 0 or NULL fpointer
  555. LISPFUN(affi_nonzerop,1,0,norest,nokey,0,NIL)
  556.   { var reg1 object arg = popSTACK();
  557. #if 0
  558.     # TODO? error if other data type
  559.     if (nullp(arg)
  560.         || eq(arg,Fixnum_0)
  561.         || (fpointerp(arg) && (TheFpointer(arg)->fp_pointer == (void*)0)))
  562.       { value1 = NIL; }
  563.     else
  564.       { value1 = T; }
  565. #else
  566.     switch (typecode(arg))
  567.       { case_posfixnum: case_posbignum:
  568.           value1 = (eq(arg,Fixnum_0)) ? NIL : T;
  569.           break;
  570.         case_orecord:
  571.           if (TheRecord(arg)->rectype == Rectype_Fpointer)
  572.             { value1 = (TheFpointer(arg)->fp_pointer == (void*)0) ? NIL : T;
  573.               break;
  574.             }
  575.           # fall through
  576.         case_symbol:
  577.           if (nullp(arg))
  578.             { value1 = NIL;
  579.               break;
  580.             }
  581.           # fall through
  582.         default:
  583.           fehler_ffi_arg(arg);
  584.       }
  585. #endif
  586.     mv_count=1;
  587.   }
  588.  
  589.  
  590. # Moduldefinitionen
  591.  
  592. uintC module__affi__object_tab_size = 0;
  593. object module__affi__object_tab[1];
  594. object_initdata module__affi__object_tab_initdata[1];
  595.  
  596. #undef LISPFUN
  597. #define LISPFUN LISPFUN_F
  598. #undef LISPSYM
  599. #define LISPSYM(name,printname,package)  { package, printname },
  600. #define system  "SYSTEM"
  601.  
  602. #define subr_anz  5
  603.  
  604. uintC module__affi__subr_tab_size = subr_anz;
  605.  
  606. subr_ module__affi__subr_tab[subr_anz] = {
  607.   LISPFUN(affi_libcall,2,0,rest,nokey,0,NIL)
  608.   LISPFUN(mem_read,2,1,norest,nokey,0,NIL)
  609.   LISPFUN(mem_write,3,1,norest,nokey,0,NIL)
  610.   LISPFUN(mem_write_vector,2,1,norest,nokey,0,NIL)
  611.   LISPFUN(affi_nonzerop,1,0,norest,nokey,0,NIL)
  612. # LISPFUNN(string_to_asciz,1)
  613. };
  614.  
  615. subr_initdata module__affi__subr_tab_initdata[subr_anz] = {
  616.   LISPSYM(affi_libcall,"%LIBCALL",system)
  617.   LISPSYM(mem_read,"MEM-READ",system)
  618.   LISPSYM(mem_write,"MEM-WRITE",system)
  619.   LISPSYM(mem_write_vector,"MEM-WRITE-VECTOR",system)
  620.   LISPSYM(affi_nonzerop,"NZERO-POINTER-P",system)
  621. # LISPSYM(string_to_asciz,"STRING-TO-ASCIZ",system)
  622. };
  623.  
  624. # called once when module is initialized, not called if found in .mem file
  625. void module__affi__init_function_1(module)
  626.   var reg3 module_* module;
  627.   { # evtl. keywords-Slot müssten wir initialisieren
  628.   }
  629.  
  630. # called for every session
  631. void module__affi__init_function_2(module)
  632.   var reg3 module_* module;
  633.   {
  634.   }
  635.  
  636. # If we had a module exit function, we could close all libraries the programmer forgot.
  637.  
  638. #endif # HAVE_AFFI
  639.