1 /* -*- c -*- */
2 #define requires(x,t,msg) \
3    if(x == NULL||SCM_INUMP(x)||((SOBJ)x)->type!=t){SCM_ERR(msg,x);}
4 
5 /****************************************************************
6  * cell && list
7  ****************************************************************/
8 Prim(pairp, "pair?", 1)   	/* obj -- bool */
9 {
10   TOS = SCM_MKBOOL(TOS != NULL && SCM_PAIRP(TOS));
11   NEXT;
12 }
13 
14 Prim(cons, "cons", 2) 		/* n2 n1 -- obj */
15 {
16   SOBJ new;
17   sresync(); /* need to resync in case of gc */
18   new = scm_newcell(SOBJ_T_PAIR);
19   spop(SCM_CAR(new));
20   SCM_CDR(new) = TOS;
21   TOS = new;
22   NEXT;
23 }
24 
25 /*E* (list2 OBJ1 OBJ2) => LIST */
26 /*D* Returns a newly allocated list of 2 elements. */
27 Prim(list2, "list2", 2) 	/* l2 l1 -- new */
28 {
29   SOBJ new, l1;
30   sresync();
31   spop(l1);
32   new = SCM_LIST2(l1, TOS);
33   RETURN(new);
34 }
35 
36 Prim(car, "car", 1)		/* obj -- obj */
37 {
38   requires(TOS, SOBJ_T_PAIR, "car: wrong arg type");
39   TOS = SCM_CAR((SOBJ)TOS);
40   NEXT;
41 }
42 
43 Prim(cdr, "cdr", 1)		/* obj -- obj */
44 {
45   requires(TOS, SOBJ_T_PAIR, "cdr: wrong arg type");
46   TOS = SCM_CDR((SOBJ)TOS);
47   NEXT;
48 }
49 
50 Prim(setcar, "set-car!", 2) 	/* value obj -- undefined */
51 {
52   SOBJ sym;
53   requires(TOS, SOBJ_T_PAIR, "set-car!: wrong arg type");
54   spop(sym);
55   SCM_CAR(sym) = TOS;
56   TOS = scm_undefined;
57   NEXT;
58 }
59 
60 /*S* (set-cdr! PAIR OBJ) => #undefined */
61 /*D* Change the cdr field of the PAIR to OBJ. */
62 Prim(setcdr, "set-cdr!", 2) 	/* value obj -- undefined */
63 {
64   SOBJ sym;
65   requires(TOS, SOBJ_T_PAIR, "set-cdr!: wrong arg type");
66   spop(sym);
67   SCM_CDR(sym) = TOS;
68   TOS = scm_undefined;
69   NEXT;
70 }
71 
72 Prim(nullp, "null?", 1) /* obj -- #t | #f */
73 {
74   TOS = SCM_NULLP(TOS) ? scm_true : scm_false;
75   NEXT;
76 }
77 
78 Prim(listp, "list?", 1)		/* obj -- len */
79 {
80   TOS = (scm_list_length(TOS) >= 0) ? scm_true : scm_false;
81   NEXT;
82 }
83 
84 PrimVarargs(list, "list")	/* objn .. obj2 obj1 -- (obj1 obj2 .. objn) */
85 {
86   SOBJ list = NULL;
87   SOBJ *l   = (SOBJ*)cont;
88 
89   sp[0] = TOS;
90   while(--l >= sp) list = scm_cons(*l, list);
91   VRETURN(list);
92 }
93 
94 Prim(length, "length", 1) 		/* obj -- n */
95 {
96   int len = scm_list_length(TOS);
97   if (len >= 0) {
98 	TOS = SCM_MKINUM(len);
99 	NEXT;
100   }
101   SCM_ERR("length: cannot calculate", TOS);
102 }
103 
104 Prim(nth, "nth", 2)				/* l n -- obj */
105 {
106   SOBJ n;
107   int i, limit;
108   spop(n);
109   if (!SCM_INUMP(n)) SCM_ERR("bad nth index", n);
110   for (i=0, limit=SCM_INUM(n);
111 	   (i<limit) && SCM_PAIRP(TOS);
112 	   i++, TOS=SCM_CDR(TOS));
113   if (!SCM_PAIRP(TOS)) SCM_ERR("bad nth list", TOS);
114   RETURN(SCM_CAR(TOS));
115 }
116 
117 /*-- need by macro */
118 Prim(qq_append2, "qq-append2", 2)	/* l2 l1 -- (l1 l2) */
119 {
120   SOBJ l1, new, last, list;
121   spop(l1);
122 
123   if (l1 == NULL) {                   /* l2 is TOS*/
124          NEXT;
125   }
126   if (!SCM_PAIRP(l1)) {  SCM_ERR("append: argument is not a list", l1); }
127 
128   sresync(); /* need to resync in case of gc */
129   list = scm_newcell(SOBJ_T_PAIR);
130   new = list;
131   last = NULL;
132   while(1) {
133       SCM_CAR(new) = SCM_CAR(l1);
134       if (last) { SCM_CDR(last) = new; }
135       last = new;
136       l1 = SCM_CDR(l1);
137       if (l1 == NULL || ! SCM_PAIRP(l1)) break;
138       new = scm_newcell(SOBJ_T_PAIR);
139   }
140   SCM_CDR(new) = TOS;
141   TOS = list;
142   NEXT;
143 }
144 
145 /*-- IO */
146 PrimVarargs(display, "display") 	/* [ port ] string -- undef */
147 {
148   if (NARGS >= 1) {
149 	scm_display2(TOS, (NARGS >= 2) ? sp[1] : NULL);
150   }
151   VRETURN(scm_undefined);
152 }
153 
154 PrimVarargs(print, "print") 	/* [ port ] string -- undef */
155 {
156   if (NARGS >= 1) {
157 	scm_print2(TOS, (NARGS >= 2) ? sp[1] : NULL);
158   }
159   VRETURN(scm_undefined);
160 }
161 
162 PrimVarargs(write, "write") 	/* [ port ] string -- undef */
163 {
164   if (NARGS >= 1) {
165 	scm_write2(TOS, (NARGS >= 2) ? sp[1] : NULL);
166   }
167   VRETURN(scm_undefined);
168 }
169 
170 /*S* (newline [PORT]) => #undefined */
171 /*D* Output a newline char on port PORT. If no PORT argument is given,
172  * newline is sended to current-output-port */
173 PrimVarargs(newline, "newline") 	/* [ port ] -- undef */
174 {
175   VRETURN(scm_newline1( NARGS >= 1 ? TOS : NULL));
176 }
177 
178 /****************************************************************
179  * boolean
180  ****************************************************************/
181 /*S* (not OBJ) => BOOL */
182 /*D* Returns #t if OBJ is #f, #f otherwise */
183 Prim(not, "not", 1)
184 {
185   TOS = (TOS == scm_false) ? scm_true : scm_false;  NEXT;
186 }
187 
188 /*S* (boolean? OBJ) => BOOL */
189 /*D* Returns #t if OBJ is either #t or #f. Otherwise #f is returned. */
190 Prim(booleanp, "boolean?", 1)
191 {
192   TOS = SCM_BOOLEANP( (SOBJ) TOS) ? scm_true : scm_false;  NEXT;
193 }
194 
195 /*S* (eq? OBJ1 OBJ2) => BOOL */
196 /*D* Returns #t if OBJ1 and OBJ2 refer to same scheme object. */
197 Prim(eqp, "eq?", 2)
198 {
199   SOBJ n;  spop(n);
200   TOS = (TOS == n) ? scm_true : scm_false;  NEXT;
201 }
202 
203 /****************************************************************
204  * control
205  ****************************************************************/
206 PrimVarargs(compile, "compile")
207 {
208   sresync();
209   VRETURN(scm_compile(TOS, (NARGS > 1) ? sp[1] : NULL));
210 }
211 
212 PrimVarargs(eval, "eval")
213 {
214   sresync();
215   TOS = scm_compile(TOS, (NARGS > 1) ? sp[1] : NULL);
216   cont->ip = ip; cont->env = env;
217   ip = SCM_CODE_CODE(TOS);
218   NEXT;
219 }
220 
221 PrimVarargs(neval, "neval")
222 {
223   sresync();
224 #ifdef OLD_COMPILER
225   TOS = scm_compile2(TOS, (NARGS > 1) ? sp[1] : NULL);
226 #else
227   TOS = scm_compile(TOS, (NARGS > 1) ? sp[1] : NULL);
228 #endif
229   cont->ip = ip; cont->env = env;
230   ip = SCM_CODE_CODE(TOS);
231   NEXT;
232 }
233 
234 Prim(execute, "execute", 1)
235 {
236   SOBJ code;
237   spop(code);
238   if (!SCM_CODEP(code)) SCM_ERR("execute: bad code", code);
239 
240   PUSH_CONT();
241   cont->ip = ip;
242   ip = (SOBJ*)SCM_CODE_CODE(code);
243   NEXT;
244 }
245 
246 /*E* (load FILE) => OBJ */
247 /*D* Interpret the content of the file which name is given in
248  * STR. Returns the value of the last evaluated expression */
249 Prim(load, "load", 1)
250 {
251   sresync();
252   TOS = scm_load(TOS);
253   NEXT;
254 }
255 
256 /*S* (apply PROC ARG1 ARG2 ... ARGS) => VALUE*/
257 /*D* Build an argument list such as (append (list arg1 arg2 ...) args)
258  * and call proc with this list as argument */
259 PrimVarargs(apply, "apply")
260 {
261   SOBJ list;
262   int len, nargs;
263 
264   spop(proc);
265 
266   if (SCM_MACROP(proc)) {
267 	if (SCM_MACRO_FUNC(proc) == NULL)
268 	  SCM_ERR("apply: cannot apply to macro", proc);
269 	proc = SCM_MACRO_FUNC(proc);
270   }
271 
272   if (NARGS < 1) SCM_ERR("apply: needs at least 2 arguments", proc);
273 
274   nargs = NARGS-1;
275 
276   list = sp[nargs]; /* list should be last */
277   if (list) {
278 	len = scm_list_length(list);
279 	if (len < 0)  SCM_ERR("apply: bad argument list", list);
280 
281 	if (len == 1) {				/* only one element : replace list by elt */
282 	  sp[nargs] = SCM_CAR(list);
283 	} else {					/* more than one element */
284 	  scm_vm_move_stack(sp - (len - 1), sp, nargs);
285 	  sp -= (len - 1);
286 	  while(list) {
287 		sp[nargs++] = SCM_CAR(list);
288 		list = SCM_CDR(list);
289 	  }
290 	}
291   } else {						/* pop list */
292 	spop(list);
293   }
294   TOS = *sp;
295   spush(proc);
296   goto l_call;
297 }
298 
299 Prim(engine, "engine", 1)
300 {
301   scm_cprint(TOS);
302   RETURN(TOS);
303 }
304 
305 
306 /****************************************************************
307  * Symbol
308  ****************************************************************/
309 /*S* (symbol? OBJ) => BOOL */
310 /*D* Returns #t if OBJ is a symbol, #f otherwise */
311 Prim(symbolp, "symbol?", 1)
312 {
313   RETURN(SCM_MKBOOL((SCM_SYMBOLP(TOS) || SCM_ATOMP(TOS))));
314 }
315 
316 /*E* (pure-symbol? OBJ) => BOOL */
317 /*D* Returns #t if OBJ is a pure symbol, #f otherwise. Pure symbols
318  * are binding a name with a value. Quoted symbols are not pure
319  * symbols, they are atoms. */
320 Prim(pure_symbolp, "pure-symbol?", 1)
321 {
322   RETURN(SCM_MKBOOL(SCM_SYMBOLP(TOS)));
323 }
324 
325 /****************************************************************
326  * Keyword
327  ****************************************************************/
328 /*E* (keyword? OBJ) => BOOL */
329 /*D* Returns #t if OBJ is a keyword, #f otherwise */
330 Prim(keywordp, "keyword?", 1)
331 {
332   RETURN(SCM_MKBOOL(SCM_KEYWORDP(TOS)));
333 }
334 
335 /*E* (keyword->string KEYW) => STR */
336 /*D* Convert a keyword to a string representation */
337 Prim(keyw2str, "keyword->string", 1)
338 {
339   RETURN(scm_keyword_to_string(TOS));
340 }
341 
342 /*E* (string->keyword STR) => KEYWORD */
343 /*D* Returns the keyword corresponding to the string STR. */
344 
345 Prim(str2keyw, "string->keyword", 1)
346 {
347   RETURN(scm_string_to_keyword(TOS));
348 }
349 
350 /*E* (get-keyword KEYW LIST DEFAULT) => VALUE */
351 /*D* Search KEYW in the LIST. Returns the value following the keyword
352  * or DEFAULT if not found. */
353 PrimVarargs(getkeyw, "get-keyword")
354 {
355   if (NARGS < 2)	SCM_ERR("get-keyword: bad number of args", NULL);
356   VRETURN(scm_get_keyword(TOS, sp[1], (NARGS >= 3) ? sp[2]: scm_false));
357 }
358 
359 /****************************************************************
360  * Misc predicates
361  ****************************************************************/
362 
363 /*E* (atom? OBJ) => BOOL */
364 /*D* Returns #t if OBJ is an atom, #f otherwise */
365 Prim(atomp, "atom?", 1)
366 {
367   RETURN(SCM_MKBOOL(SCM_ATOMP(TOS)));
368 }
369 
370 
371 /*E* (undefined-object? OBJ) => BOOL */
372 /*D* Returns #t if OBJ is undefined, #f otherwise */
373 Prim(undefinedp, "undefined-object?", 1)
374 {
375   RETURN(SCM_MKBOOL(SCM_OBJTYPE(TOS) == SOBJ_T_UNDEFINED));
376 }
377 
378 /*E* (unbound-object? OBJ) => BOOL */
379 /*D* Returns #t if OBJ is unbound, #f otherwise */
380 Prim(unboundp, "unbound-object?", 1)
381 {
382   RETURN(SCM_MKBOOL(SCM_OBJTYPE(TOS) == SOBJ_T_UNBOUND));
383 }
384 
385 /*E* (macro? OBJ) => BOOL */
386 /*D* Returns #t if OBJ is a macro, #f otherwise */
387 Prim(macrop, "macro?", 1)
388 {
389   RETURN(SCM_MKBOOL(SCM_MACROP(TOS)));
390 }
391