Back to index

texmacs  1.0.7.15
tinyscheme_tm.hpp
Go to the documentation of this file.
00001 
00002 /******************************************************************************
00003  * MODULE     : tinyscheme_tm.hpp
00004  * DESCRIPTION: TinyScheme interface
00005  * COPYRIGHT  : (C) 2011 Massimiliano Gubinelli
00006  *******************************************************************************
00007  * This software falls under the GNU general public license version 3 or later.
00008  * It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
00009  * in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
00010  ******************************************************************************/
00011 
00012 
00013 #ifndef TINYSCHEME_TM_HPP
00014 #define TINYSCHEME_TM_HPP
00015 
00016 
00017 //#include "scheme.h" // TinyScheme
00018 
00019 #define TM_OP_APPLY OP_APPLY
00020 #undef OP_APPLY
00021 #include "scheme-private.h" // TinyScheme
00022 #undef cons
00023 //#define OP_APPLY TM_OP_APPLY
00024 
00025 #include "string.hpp"
00026 #include "array.hpp"
00027 #include "blackbox.hpp"
00028 
00029 
00030 typedef cell_ptr scm;
00031 
00032 
00033 
00034 //inline bool is_blackbox(scm p)   { return is_blackbox(p); }
00035 //inline blackbox blackboxvalue(scm p) { return static_cast<cell_tm*>(p)->blackboxvalue(); }
00036 //inline void set_blackbox(scm p, blackbox b) { return static_cast<cell_tm*>(p)->set_blackbox(b); }
00037 
00038 
00039 
00040 /**** Interfacing to TeXmacs *****/
00041 
00042 
00043 extern scheme *the_scheme;
00044 
00045 
00046 inline scm scm_null () { return the_scheme->NIL; }
00047 inline scm scm_true () { return the_scheme->T; }
00048 inline scm scm_false () { return the_scheme->F; }
00049 
00050 inline bool scm_is_equal(scm o1, scm o2) { return (o1 == o2); }
00051 
00052 inline bool scm_is_null (scm obj) { return (obj == scm_null()); }
00053 inline bool scm_is_pair (scm obj) { return is_pair (obj); }
00054 inline bool scm_is_list (scm obj) { return scm_is_pair(obj) || scm_is_null(obj); }
00055 inline bool scm_is_bool (scm obj) { return ((obj == scm_true ()) || (obj == scm_false ())); }
00056 inline bool scm_is_int (scm obj) { return is_integer (obj); }
00057 inline bool scm_is_double (scm obj) { return is_real (obj); }
00058 inline bool scm_is_string (scm obj) { return is_string (obj); }
00059 inline bool scm_is_symbol (scm obj) { return is_symbol (obj); }
00060 inline bool scm_is_blackbox (scm obj) { return is_blackbox (obj); }
00061 
00062 inline scm scm_cons (scm obj1, scm obj2) { return _cons (the_scheme,obj1,obj2,0); }
00063 inline scm scm_car (scm obj) { return pair_car (obj); }
00064 inline scm scm_cdr (scm obj) { return pair_cdr (obj); }
00065 inline scm scm_caar (scm obj) { return scm_car (scm_car (obj)); }
00066 inline scm scm_cadr (scm obj) { return scm_car (scm_cdr (obj)); }
00067 inline scm scm_cdar (scm obj) { return scm_cdr (scm_car (obj)); }
00068 inline scm scm_cddr (scm obj) { return scm_cdr (scm_cdr (obj)); }
00069 inline scm scm_caddr (scm obj) { return scm_cadr (scm_cdr (obj)); }
00070 inline scm scm_cadddr (scm obj) { return scm_caddr (scm_cdr (obj)); }
00071 
00072 inline void scm_set_car (scm obj, scm obj2) { set_car (obj, obj2); }
00073 inline void scm_set_cdr (scm obj, scm obj2) { set_cdr (obj, obj2); }
00074 
00075 
00076 
00077 inline scm bool_to_scm (bool b) { return b ? scm_true () : scm_false (); }
00078 inline scm int_to_scm (int i) {   return mk_integer (the_scheme,i); }
00079 inline scm double_to_scm (double i) { return mk_real (the_scheme,i); }
00080 inline scm blackbox_to_scm (blackbox b) { return mk_blackbox (the_scheme,(void*)(tm_new<blackbox>(b))); } // CHECK
00081 scm string_to_scm (string s);
00082 scm symbol_to_scm (string s);
00083 
00084 inline bool scm_to_bool (scm obj) { return (obj != scm_false()); } 
00085 inline int scm_to_int (scm obj) { return ivalue (obj); }
00086 inline double scm_to_double (scm obj) { return rvalue (obj); }
00087 inline string scm_to_string (scm obj) { return string ( string_value (obj),  string_length (obj)); }
00088 inline string scm_to_symbol (scm obj) { return string (symname (obj),  symlen (obj)); }
00089 inline blackbox scm_to_blackbox (scm obj) { return *(blackbox*)blackboxvalue(obj); }
00090 
00091 
00092 scm eval_scheme_file (string name);
00093 scm eval_scheme (string s);
00094 scm call_scheme (scm fun);
00095 scm call_scheme (scm fun, scm a1);
00096 scm call_scheme (scm fun, scm a1, scm a2);
00097 scm call_scheme (scm fun, scm a1, scm a2, scm a3);
00098 scm call_scheme (scm fun, scm a1, scm a2, scm a3, scm a4);
00099 scm call_scheme (scm fun, array<scm> a);
00100 
00101 
00102 
00103 /******************************************************************************
00104  * Gluing
00105  ******************************************************************************/
00106 
00107 
00108 template<scm (*PROC)()> 
00109 static scm proc (scheme*, scm ) { 
00110        scm res = PROC();
00111        return (res);
00112 }
00113 template<scm (*PROC)(scm)> 
00114 static scm proc (scheme*, scm args) { 
00115        scm a1 = (scm_car(args)); args = scm_cdr (args);
00116        scm res = PROC(a1);
00117        return (res);
00118 }
00119 template<scm (*PROC)(scm, scm)> 
00120 static scm proc (scheme*, scm args) { 
00121        scm a1 = (scm_car(args)); args = scm_cdr (args);
00122        scm a2 = (scm_car(args)); args = scm_cdr (args);
00123        scm res = PROC(a1,a2);
00124        return (res);
00125 }
00126 template<scm (*PROC)(scm, scm, scm)> 
00127 static scm proc (scheme*, scm args) { 
00128        scm a1 = (scm_car(args)); args = scm_cdr (args);
00129        scm a2 = (scm_car(args)); args = scm_cdr (args);
00130        scm a3 = (scm_car(args)); args = scm_cdr (args);
00131        scm res = PROC(a1,a2,a3);
00132        return (res);
00133 }
00134 template<scm (*PROC)(scm, scm, scm, scm)> 
00135 static scm proc (scheme*, scm args) { 
00136        scm a1 = (scm_car(args)); args = scm_cdr (args);
00137        scm a2 = (scm_car(args)); args = scm_cdr (args);
00138        scm a3 = (scm_car(args)); args = scm_cdr (args);
00139        scm a4 = (scm_car(args)); args = scm_cdr (args);
00140        scm res = PROC(a1,a2,a3,a4);
00141        return (res);
00142 }
00143 template<scm (*PROC)(scm, scm, scm, scm, scm)> 
00144 static scm proc (scheme*, scm args) { 
00145        scm a1 = (scm_car(args)); args = scm_cdr (args);
00146        scm a2 = (scm_car(args)); args = scm_cdr (args);
00147        scm a3 = (scm_car(args)); args = scm_cdr (args);
00148        scm a4 = (scm_car(args)); args = scm_cdr (args);
00149        scm a5 = (scm_car(args)); args = scm_cdr (args);
00150        scm res = PROC(a1,a2,a3,a4,a5);
00151        return (res);
00152 }
00153 
00154 template<scm (*PROC)(scm, scm, scm, scm, scm, scm)> 
00155 static scm proc (scheme*, scm args) { 
00156        scm a1 = (scm_car(args)); args = scm_cdr (args);
00157        scm a2 = (scm_car(args)); args = scm_cdr (args);
00158        scm a3 = (scm_car(args)); args = scm_cdr (args);
00159        scm a4 = (scm_car(args)); args = scm_cdr (args);
00160        scm a5 = (scm_car(args)); args = scm_cdr (args);
00161        scm a6 = (scm_car(args)); args = scm_cdr (args);
00162        scm res = PROC(a1,a2,a3,a4,a5,a6);
00163        return (res);
00164 }
00165 
00166 template<scm (*PROC)(scm, scm, scm, scm, scm, scm, scm, scm)> 
00167 static scm proc (scheme*, scm args) { 
00168        scm a1 = (scm_car(args)); args = scm_cdr (args);
00169        scm a2 = (scm_car(args)); args = scm_cdr (args);
00170        scm a3 = (scm_car(args)); args = scm_cdr (args);
00171        scm a4 = (scm_car(args)); args = scm_cdr (args);
00172        scm a5 = (scm_car(args)); args = scm_cdr (args);
00173        scm a6 = (scm_car(args)); args = scm_cdr (args);
00174        scm a7 = (scm_car(args)); args = scm_cdr (args);
00175        scm a8 = (scm_car(args)); args = scm_cdr (args);
00176        scm res = PROC(a1,a2,a3,a4,a5,a6,a7,a8);
00177        return (res);
00178 }
00179 
00180 
00181 typedef foreign_func scm_foreign_func;
00182 string scheme_dialect ();
00183 void scm_define_glue(const char *name, scm_foreign_func f);
00184 
00185 
00186 #define scm_install_procedure(name, func, args, p0, p1) scm_define_glue( name, proc<func>)
00187 
00188 #define SCM_ARG1
00189 #define SCM_ARG2
00190 #define SCM_ARG3
00191 #define SCM_ARG4
00192 #define SCM_ARG5
00193 #define SCM_ARG6
00194 #define SCM_ARG7
00195 #define SCM_ARG8
00196 
00197 #define TMSCM_ASSERT(_cond, _arg, _pos, _subr)
00198 
00199 #endif // TINYSCHEME_TM_HPP