/[gcl]/gcl/o/makefun.c
ViewVC logotype

Diff of /gcl/o/makefun.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by camm, Thu Nov 6 16:08:09 2003 UTC revision 1.8 by camm, Sun Nov 6 18:07:37 2005 UTC
# Line 101  DEFUN_NEW("SET-KEY-STRUCT",object,fSset_ Line 101  DEFUN_NEW("SET-KEY-STRUCT",object,fSset_
101    return Cnil;    return Cnil;
102  }  }
103            
104    #define collect(top_,next_,val_) ({object _x=MMcons(val_,Cnil);\
105                                       if (top_==Cnil) top_=next_=_x; \
106                                       else next_=next_->c.c_cdr=_x;})
107    
108    
109    static void
110    put_fn_procls(object sym,int argd,int oneval) {
111    
112      unsigned int atypes=F_TYPES(argd) >> F_TYPE_WIDTH;
113      unsigned int minargs=F_MIN_ARGS(argd);
114      unsigned int maxargs=F_MAX_ARGS(argd);
115      unsigned int rettype=F_RESULT_TYPE(argd);
116      unsigned int i;
117      object ta=Cnil,na=Cnil;
118    
119      for (i=0;i<minargs;i++,atypes >>=F_TYPE_WIDTH)
120        switch(maxargs!=minargs ? F_object : atypes & MASK_RANGE(0,F_TYPE_WIDTH)) {
121        case F_object:
122          collect(ta,na,Ct);
123          break;
124        case F_int:
125          collect(ta,na,sLfixnum);
126          break;
127        case F_shortfloat:
128          collect(ta,na,sLshort_float);
129          break;
130        case F_double_ptr:
131          collect(ta,na,sLlong_float);
132          break;
133        default:
134          FEerror("Bad sfn declaration",0);
135          break;
136        }
137      if (maxargs!=minargs)
138        collect(ta,na,sLA);
139      putprop(sym,ta,sSproclaimed_arg_types);
140      ta=na=Cnil;
141      if (oneval)
142        switch(rettype) {
143        case F_object:
144          ta=Ct;
145          break;
146        case F_int:
147          ta=sLfixnum;
148          break;
149        case F_shortfloat:
150          ta=sLshort_float;
151          break;
152        case F_double_ptr:
153          ta=sLlong_float;
154          break;
155        default:
156          FEerror("Bad sfn declaration",0);
157          break;
158        }
159      else
160        ta=MMcons(sLA,Cnil);
161      putprop(sym,ta,sSproclaimed_return_type);
162      if (oneval)
163        putprop(sym,Ct,sSproclaimed_function);
164    
165    }  
166    
167    
168  void  void
169  SI_makefun(char *strg, object (*fn) (/* ??? */), unsigned int argd)  SI_makefun(char *strg, object (*fn) (/* ??? */), unsigned int argd)
170  { object sym = make_si_ordinary(strg);  { object sym = make_si_ordinary(strg);
171   fSfset(sym, fSmakefun(sym,fn,argd));   fSfset(sym, fSmakefun(sym,fn,argd));
172     put_fn_procls(sym,argd,1);
173  }  }
174    
175  void  void
176  LISP_makefun(char *strg, object (*fn) (/* ??? */), unsigned int argd)  LISP_makefun(char *strg, object (*fn) (/* ??? */), unsigned int argd)
177  { object sym = make_ordinary(strg);  { object sym = make_ordinary(strg);
178   fSfset(sym, fSmakefun(sym,fn,argd));   fSfset(sym, fSmakefun(sym,fn,argd));
179     put_fn_procls(sym,argd,1);
180    }
181    
182    void
183    SI_makefunm(char *strg, object (*fn) (/* ??? */), unsigned int argd)
184    { object sym = make_si_ordinary(strg);
185     fSfset(sym, fSmakefun(sym,fn,argd));
186     put_fn_procls(sym,argd,0);
187    }
188    
189    void
190    LISP_makefunm(char *strg, object (*fn) (/* ??? */), unsigned int argd)
191    { object sym = make_ordinary(strg);
192     fSfset(sym, fSmakefun(sym,fn,argd));
193     put_fn_procls(sym,argd,0);
194  }  }
195    
196    

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26