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