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