src/c/builtins.c

   1 /* <Built-in procedures> */
   2
   3 /* Creates a closure and adds it to the top-level
   4    @param name (string) the name of the built-in procedure
   5    @param code (void*) the address of the built-in procedure (label address)
   6 */
   7 #define CREATE_BUILTIN_CLOS(name,code) \
   8     r_res = (int)getSymbol((name),topLevel); /* create a hash bucket */ \
   9     ((SymbolEntry*)r_res)->sob = makeSchemeClosure(NULL,(code)); \
  10     ASSERT_ALWAYS( ((SymbolEntry*)r_res)->sob!=NULL,"" ); \
  11     ((SymbolEntry*)r_res)->isDefined = 1;
  12
  13 /* The stack when in a built-in precedure (there is no fp):
  14   sp -> |      |
  15         | ret  |  - return address
  16         | env  |  - points to the enviroment vector
  17         | n    |  - number of arguments
  18         | A0   |  - argument 0
  19         | A1   |  - argument 1
  20         | ...  |  - ...
  21         | An-1 |  - argument n-1
  22
  23    Macros for built-in procedures:
  24 */
  25 #define BI_ST_ARG(n) (stack[sp-4-(n)])
  26 #define BI_ST_ARG_COUNT() (stack[sp-3])
  27 #define BI_ST_RET() (stack[sp-1])
  28 #define BI_RETURN() goto *pop()
  29
  30     goto Lstart; /* skip all definitions */
  31
  32 Lcar:
  33     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("car",1) );
  34     r[0] = BI_ST_ARG(0);
  35     ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
  36     r_res = (int)SOB_PAIR_CAR(r[0]);
  37     BI_RETURN();
  38
  39 Lcdr:
  40     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("cdr",1) );
  41     r[0] = BI_ST_ARG(0);
  42     ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
  43     r_res = (int)SOB_PAIR_CDR(r[0]);
  44     BI_RETURN();
  45
  46 Lsymbol:
  47     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("symbol?",1) );
  48     r[0] = BI_ST_ARG(0);
  49     if ( IS_SOB_SYMBOL(r[0]) ) goto Lsymbol_true;
  50     r_res = (int)&sc_false;
  51     BI_RETURN();
  52 Lsymbol_true:
  53     r_res = (int)&sc_true;
  54     BI_RETURN();
  55
  56 Lset_car:
  57     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("set-car!",2) );
  58     r[0] = BI_ST_ARG(0);
  59     r[1] = BI_ST_ARG(1);
  60     ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
  61     SOB_PAIR_CAR(r[0]) = (SchemeObject*)r[1];
  62     r_res = (int)&sc_void;
  63     BI_RETURN();
  64
  65 Lset_cdr:
  66     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("set-cdr!",2) );
  67     r[0] = BI_ST_ARG(0);
  68     r[1] = BI_ST_ARG(1);
  69     ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
  70     SOB_PAIR_CDR(r[0]) = (SchemeObject*)r[1];
  71     r_res = (int)&sc_void;
  72     BI_RETURN();
  73
  74 Lmake_vector:
  75     ASSERT_ALWAYS( BI_ST_ARG_COUNT()>=1,MSG_ERR_ARGCOUNT("make-vector",1) );
  76     r[0] = BI_ST_ARG(0);
  77     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
  78     r[0] = SOB_INT_VALUE(r[0]);
  79     r_res = (int)makeSchemeVectorInit(r[0],&sc_void);
  80     /* initialize vector elements
  81     for (int i=1; i<BI_ST_ARG_COUNT(); ++i)
  82         SOB_VECTOR_SET(r_res,i,BI_ST_ARG(i));
  83     */
  84     BI_RETURN();
  85
  86 Lvector_set:
  87     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==3,MSG_ERR_ARGCOUNT("vector-set!",3) );
  88     r[0] = BI_ST_ARG(0);
  89     ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), "");
  90     r[1] = BI_ST_ARG(1);
  91     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
  92     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
  93     r[2] = BI_ST_ARG(2);
  94     SOB_VECTOR_SET((SchemeObject*)r[0],r[1],(SchemeObject*)r[2]);
  95     r_res = (int)&sc_void;
  96     BI_RETURN();
  97
  98 Lvector_ref:
  99     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("vector-ref",2) );
 100     r[0] = BI_ST_ARG(0);
 101     ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), "");
 102     r[1] = BI_ST_ARG(1);
 103     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 104     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 105     r_res = (int)SOB_VECTOR_REF((SchemeObject*)r[0],r[1]);
 106     BI_RETURN();
 107
 108 Lvector_length:
 109     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("vector-length",1) );
 110     r[0] = BI_ST_ARG(0);
 111     ASSERT_ALWAYS( IS_SOB_VECTOR(r[0]), "" );
 112     r_res = SOB_VECTOR_LENGTH(r[0]);
 113     r_res = (int)makeSchemeInt(r_res);
 114     BI_RETURN();
 115
 116 LbinaryEQ:
 117     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary=?",2) );
 118     r[0] = BI_ST_ARG(0);
 119     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 120     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 121     r[1] = BI_ST_ARG(1);
 122     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 123     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 124     if (r[0] != r[1]) goto LbinaryEQ_false;
 125     r_res = (int)&sc_true;
 126     BI_RETURN();
 127 LbinaryEQ_false:
 128     r_res = (int)&sc_false;
 129     BI_RETURN();
 130
 131 LbinaryADD:
 132     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-add",2) );
 133     r[0] = BI_ST_ARG(0);
 134     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 135     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 136     r[1] = BI_ST_ARG(1);
 137     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 138     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 139     r_res = r[0] + r[1];
 140     r_res = (int)makeSchemeInt( r_res );
 141     BI_RETURN();
 142
 143 LbinarySUB:
 144     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-sub",2) );
 145     r[0] = BI_ST_ARG(0);
 146     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 147     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 148     r[1] = BI_ST_ARG(1);
 149     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 150     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 151     r_res = r[0] - r[1];
 152     r_res = (int)makeSchemeInt( r_res );
 153     BI_RETURN();
 154
 155 LbinaryMUL:
 156     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-mul",2) );
 157     r[0] = BI_ST_ARG(0);
 158     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 159     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 160     r[1] = BI_ST_ARG(1);
 161     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 162     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 163     r_res = (int)r[0] * (int)r[1]; /* multiply as signed integers */
 164     r_res = (int)makeSchemeInt( r_res );
 165     BI_RETURN();
 166
 167 LbinaryDIV:
 168     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-div",2) );
 169     r[0] = BI_ST_ARG(0);
 170     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 171     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 172     r[1] = BI_ST_ARG(1);
 173     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 174     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 175     ASSERT_ALWAYS( (int)r[1]!=0, MSG_ERR_DIVZERO );
 176     r_res = (int)r[0] / (int)r[1]; /* divide as signed integers */
 177     r_res = (int)makeSchemeInt( r_res );
 178     BI_RETURN();
 179
 180 LbinaryLT:
 181     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary<?",2) );
 182     r[0] = BI_ST_ARG(0);
 183     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 184     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 185     r[1] = BI_ST_ARG(1);
 186     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 187     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 188     r_res = ((int)r[0] < (int)r[1]); /* compare as signed integers */
 189     if ( r_res ) goto LbinaryLT_true;
 190     r_res = (int)&sc_false;
 191     BI_RETURN();
 192 LbinaryLT_true:
 193     r_res = (int)&sc_true;
 194     BI_RETURN();
 195
 196 Lbox:
 197     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("box",1) );
 198     r[0] = BI_ST_ARG(0);
 199     r_res = (int)makeSchemeVectorInit( 1,(SchemeObject*)(r[0]) );
 200     BI_RETURN();
 201
 202 Lnull:
 203     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("null?",1) );
 204     r[0] = BI_ST_ARG(0);
 205     if ( IS_SOB_NIL(r[0]) ) goto Lnull_true;
 206     r_res = (int)&sc_false;
 207     BI_RETURN();
 208 Lnull_true:
 209     r_res = (int)&sc_true;
 210     BI_RETURN();
 211
 212 Lchar_to_integer:
 213     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("char->integer",1) );
 214     r[0] = BI_ST_ARG(0);
 215     ASSERT_ALWAYS( IS_SOB_CHAR(r[0]), "" );
 216     r[0] = (unsigned char)SOB_CHAR_VALUE(r[0]);
 217     r_res = (int)makeSchemeInt( (int)r[0] );
 218     BI_RETURN();
 219
 220 Linteger_to_char:
 221     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("integer->char",1) );
 222     r[0] = BI_ST_ARG(0);
 223     ASSERT_ALWAYS( IS_SOB_INT(r[0]), "" );
 224     r[0] = SOB_INT_VALUE(r[0]);
 225     r_res = (int)makeSchemeChar( (char)r[0] );
 226     BI_RETURN();
 227
 228 Lapply:
 229     push( fp );
 230     fp = sp;
 231     ASSERT_ALWAYS( ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("apply",2) );
 232     r[0] = ST_ARG(0); /* r[0] is now the closure */
 233     ASSERT_ALWAYS( IS_SOB_CLOSURE(r[0]), MSG_ERR_APPNONPROC );
 234     r[1] = ST_ARG(1); /* r[1] is now the list of arguments */
 235     ASSERT_ALWAYS( (r[1]==(int)&sc_nil) | (IS_SOB_PAIR(r[1])), MSG_ERR_NOTLIST );
 236     /* push arguments (backwards) and number of arguments */
 237     pushArgsList( (SchemeObject*)r[1] );
 238     /* push env. of closure */
 239     push( (int)SOB_CLOSURE_ENV(r[0]) );
 240     /* push current return address (it's a tail call) */
 241     push( (int)ST_RET() );
 242     /* override current frame (it's a tail call) */
 243     shiftActFrmDown();
 244     /* branch */
 245     goto *SOB_CLOSURE_CODE(r[0]);
 246
 247 Lboolean:
 248     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("boolean?",1) );
 249     r[0] = BI_ST_ARG(0);
 250     r_res = (IS_SOB_BOOL(r[0])) ? (int)&sc_true : (int)&sc_false;
 251     BI_RETURN();
 252
 253 Lchar:
 254     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("char?",1) );
 255     r[0] = BI_ST_ARG(0);
 256     r_res = (IS_SOB_CHAR(r[0])) ? (int)&sc_true : (int)&sc_false;
 257     BI_RETURN();
 258
 259 Linteger:
 260     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("integer?",1) );
 261     r[0] = BI_ST_ARG(0);
 262     r_res = (IS_SOB_INT(r[0])) ? (int)&sc_true : (int)&sc_false;
 263     BI_RETURN();
 264
 265 Lpair:
 266     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("pair?",1) );
 267     r[0] = BI_ST_ARG(0);
 268     r_res = (IS_SOB_PAIR(r[0])) ? (int)&sc_true : (int)&sc_false;
 269     BI_RETURN();
 270
 271 Lprocedure:
 272     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("procedure?",1) );
 273     r[0] = BI_ST_ARG(0);
 274     r_res = (IS_SOB_CLOSURE(r[0])) ? (int)&sc_true : (int)&sc_false;
 275     BI_RETURN();
 276
 277 Lstring:
 278     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("string?",1) );
 279     r[0] = BI_ST_ARG(0);
 280     r_res = (IS_SOB_STRING(r[0])) ? (int)&sc_true : (int)&sc_false;
 281     BI_RETURN();
 282
 283 Lvector:
 284     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("vector?",1) );
 285     r[0] = BI_ST_ARG(0);
 286     r_res = (IS_SOB_VECTOR(r[0])) ? (int)&sc_true : (int)&sc_false;
 287     BI_RETURN();
 288
 289 Lzero:
 290     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("zero?",1) );
 291     r[0] = BI_ST_ARG(0);
 292     ASSERT_ALWAYS( IS_SOB_INT(r[0]), "" );
 293     r[0] = SOB_INT_VALUE(r[0]);
 294     r_res = (r[0]==0) ? (int)&sc_true : (int)&sc_false;
 295     BI_RETURN();
 296
 297 Lcons:
 298     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("cons",2) );
 299     r[0] = BI_ST_ARG(0);
 300     r[1] = BI_ST_ARG(1);
 301     r_res = (int)makeSchemePair( (SchemeObject*)r[0], (SchemeObject*)r[1] );
 302     BI_RETURN();
 303
 304 Leq:
 305     /* The eq? procedure compare the
 306        VALUES of booleans,
 307                  chars,
 308                  integers,
 309                  symbols,
 310        and the ADDRESSES of pairs,
 311                             strings, and
 312                             vectors.
 313     */
 314     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("eq?",2) );
 315     r[0] = BI_ST_ARG(0);
 316     r[1] = BI_ST_ARG(1);
 317     if ( IS_SOB_BOOL(r[0]) ) goto Leq_boolval;
 318     if ( IS_SOB_CHAR(r[0]) ) goto Leq_charval;
 319     if ( IS_SOB_INT(r[0]) ) goto Leq_intval;
 320     if ( IS_SOB_SYMBOL(r[0]) ) goto Leq_symval;
 321     if ( r[0]==r[1] ) goto Leq_true;
 322     goto Leq_false;
 323 Leq_boolval:
 324     if ( !IS_SOB_BOOL(r[1]) ) goto Leq_false;
 325     if ( SOB_BOOL_VALUE(r[0])==SOB_BOOL_VALUE(r[1]) ) goto Leq_true;
 326     goto Leq_false;
 327 Leq_charval:
 328     if ( !IS_SOB_CHAR(r[1]) ) goto Leq_false;
 329     if ( SOB_CHAR_VALUE(r[0])==SOB_CHAR_VALUE(r[1]) ) goto Leq_true;
 330     goto Leq_false;
 331 Leq_intval:
 332     if ( !IS_SOB_INT(r[1]) ) goto Leq_false;
 333     if ( SOB_INT_VALUE(r[0])==SOB_INT_VALUE(r[1]) ) goto Leq_true;
 334     goto Leq_false;
 335 Leq_symval:
 336     if ( !IS_SOB_SYMBOL(r[1]) ) goto Leq_false;
 337     if ( SOB_SYMBOL_ENTRY(r[0])==SOB_SYMBOL_ENTRY(r[1]) ) goto Leq_true;
 338     goto Leq_false;
 339 Leq_true:
 340     r_res = (int)&sc_true;
 341     BI_RETURN();
 342 Leq_false:
 343     r_res = (int)&sc_false;
 344     BI_RETURN();
 345
 346 Lmake_string:
 347     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("make-string",2) );
 348     r[0] = BI_ST_ARG(0);
 349     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 350     r[0] = SOB_INT_VALUE(r[0]);
 351     r[1] = BI_ST_ARG(1);
 352     ASSERT_ALWAYS(IS_SOB_CHAR((SchemeObject*)r[1]), "");
 353     r[1] = (int)SOB_CHAR_VALUE(r[1]);
 354     r_res = (int)makeSchemeString(r[0],(char)r[1]);
 355     BI_RETURN();
 356
 357 Lremainder:
 358     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("remainder",2) );
 359     r[0] = BI_ST_ARG(0);
 360     ASSERT_ALWAYS( IS_SOB_INT(r[0]), "" );
 361     r[0] = SOB_INT_VALUE(r[0]);
 362     r[1] = BI_ST_ARG(1);
 363     ASSERT_ALWAYS( IS_SOB_INT(r[1]), "" );
 364     r[1] = SOB_INT_VALUE(r[1]);
 365     ASSERT_ALWAYS( (int)r[1]!=0, MSG_ERR_DIVZERO );
 366     r_res = (int)r[0] % (int)r[1]; /* divide as signed integers */
 367     r_res = (int)makeSchemeInt( r_res );
 368     BI_RETURN();
 369
 370 Lstring_to_symbol:
 371     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("string->symbol",1) );
 372     r[0] = BI_ST_ARG(0);
 373     ASSERT_ALWAYS( IS_SOB_STRING(r[0]), "" );
 374     r[0] = (int)SOB_STRING_VALUE(r[0]);
 375     r_res = (int)makeSchemeSymbol((char*)r[0]);
 376     BI_RETURN();
 377
 378 Lsymbol_to_string:
 379     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("symbol->string",1) );
 380     r[0] = BI_ST_ARG(0);
 381     ASSERT_ALWAYS( IS_SOB_SYMBOL(r[0]), "" );
 382     r[0] = (int)SOB_SYMBOL_NAME(r[0]);
 383     r_res = (int)makeSchemeStringFromCString( (char*)r[0] );
 384     BI_RETURN();
 385
 386 Lstring_length:
 387     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("string-length",1) );
 388     r[0] = BI_ST_ARG(0);
 389     ASSERT_ALWAYS( IS_SOB_STRING(r[0]), "" );
 390     r_res = SOB_STRING_LENGTH(r[0]);
 391     r_res = (int)makeSchemeInt(r_res);
 392     BI_RETURN();
 393
 394 Lstring_ref:
 395     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("string-ref",2) );
 396     r[0] = BI_ST_ARG(0);
 397     ASSERT_ALWAYS( IS_SOB_STRING(r[0]), "" );
 398     r[1] = BI_ST_ARG(1);
 399     ASSERT_ALWAYS( IS_SOB_INT(r[1]), "" );
 400     r[1] = SOB_INT_VALUE( r[1] );
 401     ASSERT_ALWAYS( (r[1]>=0) & (r[1]<SOB_STRING_LENGTH(r[0])), MSG_ERR_NDXOUTOFBOUNDS );
 402     r_res = SOB_STRING_REF(r[0],r[1]);
 403     r_res = (int)makeSchemeChar(r_res);
 404     BI_RETURN();
 405
 406 Lstring_set:
 407     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==3,MSG_ERR_ARGCOUNT("string-set!",3) );
 408     r[0] = BI_ST_ARG(0);
 409     ASSERT_ALWAYS( IS_SOB_STRING(r[0]), "" );
 410
 411     r[1] = BI_ST_ARG(1);
 412     ASSERT_ALWAYS( IS_SOB_INT(r[1]), "" );
 413     r[1] = SOB_INT_VALUE( r[1] );
 414     ASSERT_ALWAYS( (r[1]>=0) & (r[1]<SOB_STRING_LENGTH(r[0])), MSG_ERR_NDXOUTOFBOUNDS );
 415
 416     r[2] = BI_ST_ARG(2);
 417     ASSERT_ALWAYS( IS_SOB_CHAR(r[2]), "" );
 418     r[2] = SOB_CHAR_VALUE( r[2] );
 419     SOB_STRING_SET((SchemeObject*)r[0],r[1],(char)r[2]);
 420     r_res = (int)&sc_void;
 421     BI_RETURN();
 422
 423 Lstart:
 424     /* create closures for the free variables of the built-in procedures */
 425     CREATE_BUILTIN_CLOS("car"           ,&&Lcar);
 426     CREATE_BUILTIN_CLOS("cdr"           ,&&Lcdr);
 427     CREATE_BUILTIN_CLOS("symbol?"       ,&&Lsymbol);
 428     CREATE_BUILTIN_CLOS("set-car!"      ,&&Lset_car);
 429     CREATE_BUILTIN_CLOS("set-cdr!"      ,&&Lset_cdr);
 430     CREATE_BUILTIN_CLOS("make-vector"   ,&&Lmake_vector);
 431     CREATE_BUILTIN_CLOS("vector-set!"   ,&&Lvector_set);
 432     CREATE_BUILTIN_CLOS("vector-ref"    ,&&Lvector_ref);
 433     CREATE_BUILTIN_CLOS("vector-length"    ,&&Lvector_length);
 434     CREATE_BUILTIN_CLOS("binary=?"      ,&&LbinaryEQ);
 435     CREATE_BUILTIN_CLOS("binary-add"    ,&&LbinaryADD);
 436     CREATE_BUILTIN_CLOS("binary-sub"    ,&&LbinarySUB);
 437     CREATE_BUILTIN_CLOS("binary-mul"    ,&&LbinaryMUL);
 438     CREATE_BUILTIN_CLOS("binary-div"    ,&&LbinaryDIV);
 439     CREATE_BUILTIN_CLOS("binary<?"      ,&&LbinaryLT);
 440     CREATE_BUILTIN_CLOS("box"           ,&&Lbox);
 441     CREATE_BUILTIN_CLOS("null?"         ,&&Lnull);
 442     CREATE_BUILTIN_CLOS("char->integer" ,&&Lchar_to_integer);
 443     CREATE_BUILTIN_CLOS("integer->char" ,&&Linteger_to_char);
 444     CREATE_BUILTIN_CLOS("apply"         ,&&Lapply);
 445     CREATE_BUILTIN_CLOS("boolean?"      ,&&Lboolean);
 446     CREATE_BUILTIN_CLOS("char?"         ,&&Lchar);
 447     CREATE_BUILTIN_CLOS("cons"          ,&&Lcons);
 448     CREATE_BUILTIN_CLOS("eq?"           ,&&Leq);
 449     CREATE_BUILTIN_CLOS("integer?"      ,&&Linteger);
 450     CREATE_BUILTIN_CLOS("make-string"   ,&&Lmake_string);
 451     CREATE_BUILTIN_CLOS("number?"       ,&&Linteger); /* same as integer? */
 452     CREATE_BUILTIN_CLOS("pair?"         ,&&Lpair);
 453     CREATE_BUILTIN_CLOS("procedure?"    ,&&Lprocedure);
 454     CREATE_BUILTIN_CLOS("string?"       ,&&Lstring);
 455     CREATE_BUILTIN_CLOS("vector?"       ,&&Lvector);
 456     CREATE_BUILTIN_CLOS("zero?"         ,&&Lzero);
 457     CREATE_BUILTIN_CLOS("remainder"     ,&&Lremainder);
 458     CREATE_BUILTIN_CLOS("string->symbol",&&Lstring_to_symbol);
 459     CREATE_BUILTIN_CLOS("symbol->string",&&Lsymbol_to_string);
 460     CREATE_BUILTIN_CLOS("string-length" ,&&Lstring_length);
 461     CREATE_BUILTIN_CLOS("string-ref"    ,&&Lstring_ref);
 462     CREATE_BUILTIN_CLOS("string-set!"   ,&&Lstring_set);
 463
 464 /* </Built-in procedures> */