home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / liarc.h < prev    next >
C/C++ Source or Header  |  2000-12-05  |  16KB  |  528 lines
  1. /* -*-C-*-
  2.  
  3. $Id: liarc.h,v 1.15 2000/12/05 21:23:45 cph Exp $
  4.  
  5. Copyright (c) 1992-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. #ifndef LIARC_INCLUDED
  23. #define LIARC_INCLUDED
  24.  
  25. #ifndef COMPILE_FOR_STATIC_LINKING
  26. #ifndef COMPILE_FOR_DYNAMIC_LOADING
  27. #define COMPILE_FOR_DYNAMIC_LOADING
  28. #endif
  29. #endif
  30.  
  31. #ifndef MIT_SCHEME
  32. #define MIT_SCHEME
  33. #endif
  34.  
  35. #ifndef NATIVE_CODE_IS_C
  36. #define NATIVE_CODE_IS_C
  37. #endif
  38.  
  39. #include <stdio.h>
  40. #include "config.h"
  41. #include "dstack.h"
  42. #include "default.h"
  43. #include "object.h"
  44. #include "sdata.h"
  45. #include "types.h"
  46. #include "errors.h"
  47. #include "const.h"
  48. #include "interp.h"
  49. #include "prim.h"
  50. #include "cmpgc.h"
  51. #include "cmpintmd.h"
  52.  
  53. #ifdef __STDC__
  54. #  define USE_STDARG
  55. #  include <stdarg.h>
  56. #else
  57. #  include <varargs.h>
  58. #endif /* __STDC__ */
  59.  
  60. /* #define USE_GLOBAL_VARIABLES */
  61. #define USE_SHORTCKT_JUMP
  62.  
  63. extern PTR dstack_position;
  64. extern SCHEME_OBJECT * Free;
  65. extern SCHEME_OBJECT * Ext_Stack_Pointer;
  66. extern SCHEME_OBJECT Registers[];
  67.  
  68. union machine_word_u
  69. {
  70.   SCHEME_OBJECT Obj;
  71.   SCHEME_OBJECT * pObj;
  72.   long Lng;
  73.   char * pChr;
  74.   unsigned long uLng;
  75.   double * pDbl;
  76. };
  77.  
  78. typedef union machine_word_u machine_word;
  79.  
  80. #define ADDRESS_UNITS_PER_OBJECT    (sizeof (SCHEME_OBJECT))
  81. #define ADDRESS_UNITS_PER_FLOAT        (sizeof (double))
  82.  
  83. #ifdef HEAP_IN_LOW_MEMORY
  84. #define CLOSURE_ENTRY_DELTA    ADDRESS_UNITS_PER_OBJECT
  85. #else /* not HEAP_IN_LOW_MEMORY */
  86. #define CLOSURE_ENTRY_DELTA    1
  87. #endif /* HEAP_IN_LOW_MEMORY */
  88.  
  89. #undef FIXNUM_TO_LONG
  90. #define FIXNUM_TO_LONG(source)                        \
  91.   ((((long) (source)) << TYPE_CODE_LENGTH) >> TYPE_CODE_LENGTH)
  92.  
  93. #define ADDRESS_TO_LONG(source) ((long) (source))
  94.  
  95. #define LONG_TO_ADDRESS(source) (DATUM_TO_ADDRESS (source))
  96.  
  97. #define C_STRING_TO_SCHEME_STRING(len,str)                \
  98.   (MEMORY_TO_STRING ((len), (unsigned char *) str))
  99.  
  100. #define C_SYM_INTERN(len,str)                        \
  101.   (MEMORY_TO_SYMBOL ((len), ((unsigned char *) str)))
  102.  
  103. #define MAKE_PRIMITIVE_PROCEDURE(name,arity) (MAKE_PRIMITIVE (name, arity))
  104.  
  105. #define MAKE_LINKER_HEADER(kind,count)                    \
  106.   (OBJECT_NEW_TYPE (TC_FIXNUM,                        \
  107.             (MAKE_LINKAGE_SECTION_HEADER ((kind), (count)))))
  108.  
  109. #define ALLOCATE_VECTOR(len) (MAKE_VECTOR ((len), SHARP_F, true))
  110.  
  111. #define ALLOCATE_RECORD(len)                        \
  112.   (OBJECT_NEW_TYPE (TC_RECORD, (ALLOCATE_VECTOR (len))))
  113.  
  114. #define RECORD_SET(rec,off,val)    VECTOR_SET(rec,off,val)
  115.  
  116. #define INLINE_DOUBLE_TO_FLONUM(src,tgt) do                \
  117. {                                    \
  118.   double num = (src);                            \
  119.   SCHEME_OBJECT * val;                            \
  120.                                     \
  121.   ALIGN_FLOAT (Rhp);                            \
  122.   val = Rhp;                                \
  123.   Rhp += (1 + (BYTES_TO_WORDS (sizeof (double))));            \
  124.   * val = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,                \
  125.             (BYTES_TO_WORDS (sizeof (double)))));        \
  126.   (* ((double *) (val + 1))) = num;                    \
  127.   (tgt) = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (val)));            \
  128. } while (0)
  129.  
  130. #define MAKE_RATIO(num,den)                        \
  131.   (OBJECT_NEW_TYPE (TC_RATNUM, (CONS (num, den))))
  132.  
  133. #define MAKE_COMPLEX(real,imag)                        \
  134.   (OBJECT_NEW_TYPE (TC_COMPLEX, (CONS (real, imag))))
  135.  
  136. #define CC_BLOCK_TO_ENTRY(block,offset)                    \
  137.   (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY,                \
  138.             ((OBJECT_ADDRESS (block)) + (offset))))
  139.  
  140. #define INDEX_FIXNUM_P(arg) ((FIXNUM_P(arg)) && (FIXNUM_TO_LONG(arg)>=0))
  141.  
  142. #ifdef USE_GLOBAL_VARIABLES
  143.  
  144. #define Rvl Val
  145. #define Rhp Free
  146. #define Rrb Regs
  147. #define Rsp Stack_Pointer
  148.  
  149. #define DECLARE_VARIABLES() int unsed_variable_to_keep_C_happy
  150. #define UNCACHE_VARIABLES() do {} while (0)
  151. #define CACHE_VARIABLES() do {} while (0)
  152.  
  153. #else /* not USE_GLOBAL_VARIABLES */
  154.  
  155. #define REGISTER register
  156.  
  157. #define Rrb Regs
  158.  
  159. #define DECLARE_VARIABLES()                        \
  160. REGISTER SCHEME_OBJECT Rvl = Val;                    \
  161. REGISTER SCHEME_OBJECT * Rhp = Free;                    \
  162. REGISTER SCHEME_OBJECT * Rsp = Stack_Pointer
  163.  
  164. #define UNCACHE_VARIABLES() do                        \
  165. {                                    \
  166.   Stack_Pointer = Rsp;                            \
  167.   Free = Rhp;                                \
  168.   Val = Rvl;                                \
  169. } while (0)
  170.  
  171. #define CACHE_VARIABLES() do                        \
  172. {                                    \
  173.   Rvl = Val;                                \
  174.   Rhp = Free;                                \
  175.   Rsp = Stack_Pointer;                            \
  176. } while (0)
  177.  
  178. #endif /* USE_GLOBAL_VARIABLES */
  179.  
  180. #define JUMP(destination) do                        \
  181. {                                    \
  182.   Rpc = (destination);                            \
  183.   goto perform_dispatch;                        \
  184. } while(0)
  185.  
  186. #define JUMP_EXECUTE_CHACHE(label)                    \
  187.   JUMP ((SCHEME_OBJECT *) (current_block[label]))
  188.  
  189. #define POP_RETURN() goto pop_return
  190.  
  191. #define INVOKE_PRIMITIVE(prim, nargs) do                \
  192. {                                    \
  193.   primitive = (prim);                            \
  194.   primitive_nargs = (nargs);                        \
  195.   goto invoke_primitive;                        \
  196. } while (0)
  197.  
  198. #define INVOKE_PRIMITIVE_CODE() do                    \
  199. {                                    \
  200.   SCHEME_OBJECT * destination;                        \
  201.                                     \
  202.   UNCACHE_VARIABLES ();                            \
  203.   PRIMITIVE_APPLY (Val, primitive);                    \
  204.   POP_PRIMITIVE_FRAME (primitive_nargs);                \
  205.   destination = (OBJECT_ADDRESS (STACK_POP ()));            \
  206.   CACHE_VARIABLES ();                            \
  207.   JUMP (destination);                            \
  208. } while(0)
  209.  
  210. #define INVOKE_INTERFACE_CODE() do                    \
  211. {                                    \
  212.   SCHEME_OBJECT * destination;                        \
  213.                                     \
  214.   UNCACHE_VARIABLES ();                            \
  215.   destination = (invoke_utility (utlarg_code, utlarg_1, utlarg_2,    \
  216.                  utlarg_3, utlarg_4));            \
  217.   CACHE_VARIABLES ();                            \
  218.   JUMP (destination);                            \
  219. } while (0)
  220.  
  221. #define INVOKE_INTERFACE_4(code, one, two, three, four) do        \
  222. {                                    \
  223.   utlarg_4 = ((long) (four));                        \
  224.   utlarg_3 = ((long) (three));                        \
  225.   utlarg_2 = ((long) (two));                        \
  226.   utlarg_1 = ((long) (one));                        \
  227.   utlarg_code = (code);                            \
  228.   goto invoke_interface_4;                        \
  229. } while (0)
  230.  
  231. #define INVOKE_INTERFACE_3(code, one, two, three) do            \
  232. {                                    \
  233.   utlarg_3 = ((long) (three));                        \
  234.   utlarg_2 = ((long) (two));                        \
  235.   utlarg_1 = ((long) (one));                        \
  236.   utlarg_code = (code);                            \
  237.   goto invoke_interface_3;                        \
  238. } while (0)
  239.  
  240. #define INVOKE_INTERFACE_2(code, one, two) do                \
  241. {                                    \
  242.   utlarg_2 = ((long) (two));                        \
  243.   utlarg_1 = ((long) (one));                        \
  244.   utlarg_code = (code);                            \
  245.   goto invoke_interface_2;                        \
  246. } while (0)
  247.  
  248. #define INVOKE_INTERFACE_1(code, one) do                \
  249. {                                    \
  250.   utlarg_1 = ((long) (one));                        \
  251.   utlarg_code = (code);                            \
  252.   goto invoke_interface_1;                        \
  253. } while (0)
  254.  
  255. #define INVOKE_INTERFACE_0(code) do                    \
  256. {                                    \
  257.   utlarg_code = (code);                            \
  258.   goto invoke_interface_0;                        \
  259. } while (0)
  260.  
  261. #define MAX_BIT_SHIFT DATUM_LENGTH
  262.  
  263. #define RIGHT_SHIFT_UNSIGNED(source, number)                \
  264. (((number) > MAX_BIT_SHIFT)                        \
  265.  ? 0                                    \
  266.  : ((((unsigned long) (source)) & DATUM_MASK)                \
  267.     >> (number)))
  268.  
  269. #define RIGHT_SHIFT(source, number)                    \
  270. (((number) > MAX_BIT_SHIFT)                        \
  271.  ? 0                                    \
  272.  : ((source) >> (number)))
  273.  
  274. #define LEFT_SHIFT(source, number)                    \
  275. (((number) > MAX_BIT_SHIFT)                        \
  276.  ? 0                                    \
  277.  : ((source) << (number)))
  278.  
  279. #define FIXNUM_LSH(source, number)                    \
  280. (((number) >= 0)                            \
  281.  ? (LEFT_SHIFT (source, number))                    \
  282.  : (RIGHT_SHIFT_UNSIGNED (source, (- (number)))))
  283.  
  284. #define FIXNUM_REMAINDER(source1, source2)                \
  285. (((source2) > 0)                            \
  286.  ? (((source1) >= 0)                            \
  287.     ? ((source1) % (source2))                        \
  288.     : (- ((- (source1)) % (source2))))                    \
  289.  : (((source1) >= 0)                            \
  290.     ? ((source1) % (- (source2)))                    \
  291.     : (- ((- (source1)) % (- (source2))))))
  292.  
  293. #define FIXNUM_QUOTIENT(source1, source2)                \
  294. (((source2) > 0)                            \
  295.  ? (((source1) >= 0)                            \
  296.     ? ((source1) / (source2))                        \
  297.     : (- ((- (source1)) / (source2))))                    \
  298.  : (((source1) >= 0)                            \
  299.     ? (- ((source1) / (- (source2))))                    \
  300.     : ((- (source1)) / (- (source2)))))
  301.  
  302. #define INTERRUPT_CHECK(code, entry_point) do                \
  303. {                                    \
  304.   if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP])))            \
  305.     INVOKE_INTERFACE_1 (code, ¤t_block[entry_point]);        \
  306. } while (0)
  307.  
  308. #define DLINK_INTERRUPT_CHECK(code, entry_point) do            \
  309. {                                    \
  310.   if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP])))            \
  311.     INVOKE_INTERFACE_2 (code, ¤t_block[entry_point], Rdl);    \
  312. } while (0)
  313.  
  314. #define CLOSURE_HEADER(offset) do                    \
  315. {                                    \
  316.   SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) Rpc[1]);            \
  317.   current_block = (entry - offset);                    \
  318.   *--Rsp = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, Rpc));        \
  319. } while (0)
  320.  
  321. #define CLOSURE_INTERRUPT_CHECK(code) do                \
  322. {                                    \
  323.   if (((long) Rhp) >= ((long) (Rrb[REGBLOCK_MEMTOP])))            \
  324.     INVOKE_INTERFACE_0 (code);                        \
  325. } while (0)
  326.  
  327. /* Linking and initialization */
  328.  
  329. #define DECLARE_SUBCODE(name, nentries, decl_code, code) do        \
  330. {                                    \
  331.   int result = (declare_compiled_code (name, nentries,            \
  332.                        decl_code, code));        \
  333.                                     \
  334.   if (result != 0)                            \
  335.     return (result);                            \
  336. } while (0)
  337.  
  338. #define DECLARE_SUBDATA(name, decl_data, data) do            \
  339. {                                    \
  340.   int result = (declare_compiled_data (name, decl_data, data));        \
  341.                                     \
  342.   if (result != 0)                            \
  343.     return (result);                            \
  344. } while (0)
  345.  
  346. #ifndef COMPILE_FOR_DYNAMIC_LOADING
  347.  
  348. /* This does nothing in the sources. */
  349.  
  350. # define DECLARE_COMPILED_CODE(name, nentries, decl_code, code)        \
  351.   extern int EXFUN (decl_code, (void));                    \
  352.   extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, unsigned long));
  353.  
  354. # define DECLARE_COMPILED_DATA(name, decl_data, data)            \
  355.   extern int EXFUN (decl_data, (void));                    \
  356.   extern SCHEME_OBJECT * EXFUN (data, (unsigned long));
  357.  
  358. # define DECLARE_DYNAMIC_INITIALIZATION(name)
  359.  
  360. #else /* COMPILE_FOR_DYNAMIC_LOADING */
  361.  
  362. # define DECLARE_COMPILED_CODE(name, nentries, decl_code, code)        \
  363.   static int                                \
  364.   DEFUN_VOID (dload_initialize_code)                    \
  365.   {                                    \
  366.     int EXFUN (decl_code, (void));                    \
  367.     SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, unsigned long));    \
  368.                                     \
  369.     return (declare_compiled_code (name, nentries,            \
  370.                    decl_code, code));            \
  371.   }
  372.  
  373. # define DECLARE_COMPILED_DATA(name, decl_data, data)            \
  374.   static int                                \
  375.   DEFUN_VOID (dload_initialize_data)                    \
  376.   {                                    \
  377.     int EXFUN (decl_data, (void));                    \
  378.     SCHEME_OBJECT * EXFUN (data, (unsigned long));            \
  379.                                     \
  380.     return (declare_compiled_data (name, decl_data, data));        \
  381.   }
  382.  
  383. # define DECLARE_DYNAMIC_INITIALIZATION(name)                \
  384.   extern char * EXFUN (dload_initialize_file, (void));            \
  385.                                     \
  386.   char *                                \
  387.   DEFUN_VOID (dload_initialize_file)                    \
  388.   {                                    \
  389.     int result = (dload_initialize_code ());                \
  390.     if (result != 0)                            \
  391.       return ((char *) NULL);                        \
  392.     result = (dload_initialize_data ());                \
  393.     if (result != 0)                            \
  394.       return ((char *) NULL);                        \
  395.     else                                \
  396.       return (name);                            \
  397.   }                                    \
  398.  
  399. #endif /* COMPILE_FOR_DYNAMIC_LOADING */
  400.  
  401. #ifdef USE_STDARG
  402. # define RCONSM_TYPE(frob) SCHEME_OBJECT EXFUN (frob, (int, SCHEME_OBJECT DOTS))
  403. #else /* not USE_STDARG */
  404. # define RCONSM_TYPE(frob) SCHEME_OBJECT frob ()
  405. #endif /* USE_STDARG */
  406.  
  407. extern RCONSM_TYPE(rconsm);
  408.  
  409. extern int
  410.   EXFUN (multiply_with_overflow, (long, long, long *)),
  411.   EXFUN (declare_compiled_code,
  412.      (char *,
  413.       unsigned long,
  414.       int EXFUN ((*), (void)),
  415.       SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *, unsigned long)))),
  416.   EXFUN (declare_compiled_data,
  417.      (char *,
  418.       int EXFUN ((*), (void)),
  419.       SCHEME_OBJECT * EXFUN ((*), (unsigned long)))),
  420.   EXFUN (NO_SUBBLOCKS, (void));
  421.  
  422. extern SCHEME_OBJECT
  423.   EXFUN (initialize_subblock, (char *)),
  424.   * EXFUN (invoke_utility, (int, long, long, long, long));
  425.  
  426. extern double
  427.   EXFUN (acos, (double)),
  428.   EXFUN (asin, (double)),
  429.   EXFUN (atan, (double)),
  430.   EXFUN (ceil, (double)),
  431.   EXFUN (cos, (double)),
  432.   EXFUN (exp, (double)),
  433.   EXFUN (floor, (double)),
  434.   EXFUN (log, (double)),
  435.   EXFUN (sin, (double)),
  436.   EXFUN (sqrt, (double)),
  437.   EXFUN (tan, (double)),
  438.   EXFUN (double_truncate, (double)),
  439.   EXFUN (atan2, (double, double));
  440.  
  441. #define DOUBLE_ACOS acos
  442. #define DOUBLE_ASIN asin
  443. #define DOUBLE_ATAN atan
  444. #define DOUBLE_CEILING ceil
  445. #define DOUBLE_COS cos
  446. #define DOUBLE_EXP exp
  447. #define DOUBLE_FLOOR floor
  448. #define DOUBLE_LOG log
  449. #define DOUBLE_ROUND(dx) (double_truncate ((dx < 0) ? (dx - 0.5) : (dx + 0.5)))
  450. #define DOUBLE_SIN sin
  451. #define DOUBLE_SQRT sqrt
  452. #define DOUBLE_TAN tan
  453. #define DOUBLE_TRUNCATE double_truncate
  454. #define DOUBLE_ATAN2 atan2
  455.  
  456. #ifdef __GNUC__
  457. # if defined(hp9000s800) || defined(__hp9000s800)
  458. #  define BUG_GCC_LONG_CALLS
  459. # endif
  460. #endif
  461.  
  462. #ifndef BUG_GCC_LONG_CALLS
  463.  
  464. extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *));
  465. extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *));
  466. extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
  467. extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
  468. extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
  469. extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
  470. extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *));
  471. extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *));
  472. extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
  473.  
  474. #define MEMORY_TO_STRING memory_to_string
  475. #define MEMORY_TO_SYMBOL memory_to_symbol
  476. #define MAKE_VECTOR make_vector
  477. #define CONS cons
  478. #define RCONSM rconsm
  479. #define DOUBLE_TO_FLONUM double_to_flonum
  480. #define LONG_TO_INTEGER long_to_integer
  481. #define DIGIT_STRING_TO_INTEGER digit_string_to_integer
  482. #define DIGIT_STRING_TO_BIT_STRING digit_string_to_bit_string
  483. #define MAKE_PRIMITIVE make_primitive
  484.  
  485. #else /* GCC on Spectrum has a strange bug so do thing differently .... */
  486.  
  487. extern SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ());
  488.  
  489. #define MEMORY_TO_STRING                        \
  490.      ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *)))        \
  491.       (constructor_kludge[0]))
  492.  
  493. #define MEMORY_TO_SYMBOL                        \
  494.      ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *)))        \
  495.       (constructor_kludge[1]))
  496.  
  497. #define MAKE_VECTOR                            \
  498.      ((SCHEME_OBJECT EXFUN ((*), (long, SCHEME_OBJECT, Boolean)))    \
  499.       (constructor_kludge[2]))
  500.  
  501. #define CONS                                \
  502.      ((SCHEME_OBJECT EXFUN ((*), (SCHEME_OBJECT, SCHEME_OBJECT)))    \
  503.       (constructor_kludge[3]))
  504.  
  505. #define RCONSM                                \
  506.      ((RCONSM_TYPE ((*))) (constructor_kludge[4]))
  507.  
  508. #define DOUBLE_TO_FLONUM                        \
  509.      ((SCHEME_OBJECT EXFUN ((*), (double))) (constructor_kludge[5]))
  510.  
  511. #define LONG_TO_INTEGER                            \
  512.      ((SCHEME_OBJECT EXFUN ((*), (long))) (constructor_kludge[6]))
  513.  
  514. #define DIGIT_STRING_TO_INTEGER                        \
  515.      ((SCHEME_OBJECT EXFUN ((*), (Boolean, long, char *)))        \
  516.       (constructor_kludge[7]))
  517.  
  518. #define DIGIT_STRING_TO_BIT_STRING                    \
  519.      ((SCHEME_OBJECT EXFUN ((*), (long, long, char *)))            \
  520.       (constructor_kludge[8]))
  521.  
  522. #define MAKE_PRIMITIVE                            \
  523.      ((SCHEME_OBJECT EXFUN ((*), (char *, int))) (constructor_kludge[9]))
  524.  
  525. #endif /* BUG_GCC_LONG_CALLS */
  526.  
  527. #endif /* LIARC_INCLUDED */
  528.