home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / calls.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-10-06  |  6.2 KB  |  282 lines
  1. /* ******************************************************************** */
  2. /*  calls.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* explicit funcalls                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, March 1990 (Compiler rationalisation) 
  10.  */
  11.  
  12. #include "funcalls.h"
  13. #include "defs.h"
  14. #include "structs.h"
  15.  
  16. #include "error.h"
  17. #include "global.h"
  18.  
  19. #include "allocate.h"
  20. #include "lists.h"
  21. #include "modules.h"
  22. #include "modboot.h"
  23. #include "class.h"
  24.  
  25. #include "calls.h"
  26.  
  27. EUFUN_1( Fn_functionp, obj)
  28. {
  29.   return(EUCALL_2(Fn_subclassp,classof(obj),Function));
  30. }
  31. EUFUN_CLOSE
  32.  
  33. EUFUN_1( Fn_real_functionp, obj)
  34. {
  35.   LispObject a;
  36.   EUCALLSET_2(a, Fn_subclassp, classof(obj), Function);
  37.   obj = ARG_0(stackbase);
  38.   return ((a && !is_i_macro(obj) && !is_c_macro(obj)) ? lisptrue : nil);
  39. }
  40. EUFUN_CLOSE
  41.  
  42. EUFUN_1( Fn_function_lambda_list, form)
  43. {
  44.   while (!is_function(form))
  45.     form = CallError(stacktop,
  46.              "Not function in function-lambda-list",form,CONTINUABLE);
  47.   if (is_i_function(form)) return (form->I_FUNCTION).bvl;
  48.   if (is_c_function(form)) {
  49.     int args = form->C_FUNCTION.argtype;
  50.     LispObject ans = nil;
  51.     LispObject tt = nil;
  52.     char *name = 
  53.        "@\0a\0b\0c\0d\0e\0f\0g\0h\0i\0j\0k\0l\0m\0n\0o\0p\0q\0r\0s\0t\0u\0v\0w\0x\0y\0z";
  54.     if (args<0) {
  55.       ans = (LispObject)allocate_symbol(stacktop,"@");
  56.       args = -args-1;
  57.     }
  58.     while (args>0) {
  59.       STACK_TMP(ans);
  60.       tt = (LispObject)allocate_symbol(stacktop,name+2*args);
  61.       UNSTACK_TMP(ans);
  62.       EUCALLSET_2(ans, Fn_cons, tt, ans);
  63.       args--;
  64.     }
  65.     return ans;
  66.   }
  67.   fprintf(stderr,"What is an e-function??\n");
  68.   return nil;
  69. }
  70. EUFUN_CLOSE
  71.  
  72. EUFUN_2( Fn_apply, fun, args)
  73. {
  74.   LispObject ret;
  75.   /* args are automatically listed so... */
  76.   EUCALLSET_2(ret,module_mv_apply_1,fun,args);
  77.   return(ret);
  78. }
  79. EUFUN_CLOSE
  80.  
  81. static LispObject nary_apply_aux(LispObject *stacktop, LispObject l)
  82. {
  83.   LispObject xx;
  84.   if (l == nil) return(nil);
  85.   if (!is_cons(CDR(l))) {
  86.     if (!is_cons(CAR(l)) && CAR(l) != nil)
  87.       CallError(stacktop,"apply: bad list",CAR(l),NONCONTINUABLE);
  88.     else
  89.       return(CAR(l));
  90.   }
  91.   STACK_TMP(CAR(l));
  92.   xx = nary_apply_aux(stacktop,CDR(l));
  93.   UNSTACK_TMP(l);
  94.   return(EUCALL_2(Fn_cons, l, xx));
  95. }
  96.  
  97. EUFUN_2( Fn_nary_apply, fun, stuff)
  98. {
  99.   LispObject ans;
  100.  
  101.   ans = nary_apply_aux(stacktop,stuff);
  102.   EUCALLSET_2(ans, Fn_apply, ARG_0(stackbase), ans);
  103.   return(ans);
  104. }
  105. EUFUN_CLOSE
  106.  
  107. EUFUN_2( apply1, fun, arg)
  108. {
  109.   if (EUCALL_1(Fn_functionp,fun) != nil) {
  110.     LispObject ret;
  111.  
  112.     EUCALLSET_2(arg, Fn_cons,ARG_1(stackbase),nil); /* Multiple valuize */
  113.     EUCALLSET_2(ret,module_mv_apply_1,ARG_0(stackbase),arg);
  114.     return ret;
  115.   }
  116.  
  117.   CallError(stacktop,"apply1: invalid operator",fun,NONCONTINUABLE);
  118.  
  119.   return(nil);
  120. }
  121. EUFUN_CLOSE
  122.  
  123. EUFUN_3( apply2, fun, arg1, arg2)
  124. {
  125.   if (EUCALL_1(Fn_functionp, fun) != nil) {
  126.     LispObject ret;
  127.  
  128.     EUCALLSET_2(arg2,Fn_cons,arg2,nil); /* Multiple valuize */
  129.     EUCALLSET_2(arg1,Fn_cons,ARG_1(stackbase),arg2);
  130.     EUCALLSET_2(ret,module_mv_apply_1,ARG_0(stackbase),arg1);
  131.     return ret;
  132.   }
  133.  
  134.   CallError(stacktop,"apply2: invalid operator",fun,NONCONTINUABLE);
  135.  
  136.   return(nil);
  137. }
  138. EUFUN_CLOSE
  139.  
  140. EUFUN_2( macroexpand_1, mod, exp)
  141. {
  142.   LispObject op,ret;
  143.   LispObject bind;
  144.  
  145.   if (!is_cons(exp)) {
  146.     EUCALLSET_2(ret, Fn_cons, nil,nil);
  147.     EUCALLSET_2(ret, Fn_cons, ARG_1(stackbase),ret);
  148.     return(ret);
  149.   }
  150.  
  151.   exp=ARG_1(stackbase);
  152.   op = CAR(exp); 
  153.  
  154.   if (!is_symbol(op)) {
  155.     EUCALLSET_2(ret, Fn_cons, nil,nil);
  156.     EUCALLSET_2(ret, Fn_cons, ARG_1(stackbase),ret);
  157.     return(ret);
  158.   }
  159.  
  160.   mod=ARG_0(stackbase);
  161.   /* HACK !!! Should really be imported test */
  162.   bind=GET_BINDING(mod,op);
  163.   if (bind==nil) {
  164.     EUCALLSET_2(ret, Fn_cons, nil,nil);
  165.     EUCALLSET_2(ret, Fn_cons, ARG_1(stackbase),ret);
  166.     return(ret);
  167.   }  
  168.  
  169.   op = symbol_ref(stacktop,mod,NULL,op);
  170.   
  171.   if (!is_i_macro(op) && !is_c_macro(op)) {
  172.     EUCALLSET_2(ret, Fn_cons, nil,nil);
  173.     EUCALLSET_2(ret, Fn_cons, ARG_1(stackbase),ret);
  174.     return(ret);
  175.   }
  176.  
  177.   /* What a dumb order... I'll rewrite it later (?) */
  178.  
  179.   EUCALLSET_2(ret,module_mv_apply_1,op,CDR(exp));
  180.   STACK_TMP(ret);
  181.   EUCALLSET_2(exp, Fn_cons, lisptrue, nil);
  182.   UNSTACK_TMP(ret);
  183.   EUCALLSET_2(ret, Fn_cons, ret, exp);
  184.   return(ret);
  185. }
  186. EUFUN_CLOSE
  187.  
  188. EUFUN_3( Sf_macroexpand_1, mod, env, forms)
  189. {
  190.   LispObject ret;
  191.  
  192.   if (!is_cons(forms))
  193.     CallError(stacktop,"macroexpand-1: null form",forms,NONCONTINUABLE);
  194.  
  195.   EUCALLSET_2(ret, macroexpand_1,mod,CAR(forms));
  196.  
  197.   return(ret);
  198. }
  199. EUFUN_CLOSE
  200.  
  201. EUFUN_3( Sf_macroexpand, mod, env, forms)
  202. {
  203.   LispObject last,res,exp;
  204.  
  205.   if (!is_cons(forms))
  206.     CallError(stacktop,"macroexpand: null form",forms,NONCONTINUABLE);
  207.  
  208.   exp = CAR(forms);
  209.   
  210.   res = nil;
  211.  
  212.   do {
  213.  
  214.     last = res;
  215.     STACK_TMP(last);
  216.     mod = ARG_0(stackbase);
  217.     EUCALLSET_2(res, macroexpand_1, mod, exp);
  218.     UNSTACK_TMP(last); 
  219.     exp = CAR(res);
  220.  
  221.   } while (CAR(CDR(res)) != nil);
  222.  
  223.   if (last != nil)
  224.     return(last);
  225.   else
  226.     return(res);
  227. }
  228. EUFUN_CLOSE
  229.  
  230. /* Macroexpand with this macro... */
  231.  
  232. EUFUN_2( Fn_apply_macro, macro, form)
  233. {    
  234.   LispObject ret;
  235.  
  236.   if (!is_i_macro(macro) && !is_c_macro(macro))
  237.     CallError(stacktop,"apply-macro: non-macro",macro,NONCONTINUABLE);
  238.  
  239.   EUCALLSET_2(ret,module_mv_apply_1,macro,form);    
  240.   return ret;
  241. }
  242. EUFUN_CLOSE
  243.  
  244. /* Predicate... */
  245.  
  246. EUFUN_1( Fn_macrop, obj)
  247. {
  248.  
  249.   return((is_i_macro(obj) || is_c_macro(obj) ? lisptrue : nil));
  250.  
  251. }
  252. EUFUN_CLOSE
  253.  
  254. /*
  255.  
  256.  * Initialise calls
  257.  
  258.  */
  259.  
  260. #define CALLS_ENTRIES 7
  261. MODULE Module_calls;
  262. LispObject Module_calls_values[CALLS_ENTRIES];
  263.  
  264. void initialise_calls(LispObject *stacktop)
  265. {
  266.   open_module(stacktop,
  267.           &Module_calls,
  268.           Module_calls_values,
  269.           "calls",
  270.           CALLS_ENTRIES);
  271.  
  272.   (void) make_module_function(stacktop,"apply",Fn_nary_apply,-2);
  273.   (void) make_module_special(stacktop,"macroexpand-1",Sf_macroexpand_1);
  274.   (void) make_module_special(stacktop,"macroexpand",Sf_macroexpand);
  275.   (void) make_module_function(stacktop,"apply-macro",Fn_apply_macro,2);
  276.   (void) make_module_function(stacktop,"macrop",Fn_macrop,1);
  277.   (void) make_module_function(stacktop,"functionp",Fn_real_functionp,1);
  278.   (void) make_module_function(stacktop,"function-lambda-list",Fn_function_lambda_list,1);
  279.  
  280.   close_module();
  281. }
  282.