1282 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1283 |
} |
} |
1284 |
|
|
1285 |
|
|
1286 |
|
/* General assoc function */ |
1287 |
|
void assocgen(environment *env, funcp eqfunc) |
1288 |
|
{ |
1289 |
|
value *key, *item; |
1290 |
|
|
1291 |
|
/* Needs two values on the stack, the top one must be an association |
1292 |
|
list */ |
1293 |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
1294 |
|
printerr("Too Few Arguments"); |
1295 |
|
env->err= 1; |
1296 |
|
return; |
1297 |
|
} |
1298 |
|
|
1299 |
|
if(CAR(env->head)->type!=tcons) { |
1300 |
|
printerr("Bad Argument Type"); |
1301 |
|
env->err= 2; |
1302 |
|
return; |
1303 |
|
} |
1304 |
|
|
1305 |
|
key=CAR(CDR(env->head)); |
1306 |
|
item=CAR(env->head); |
1307 |
|
|
1308 |
|
while(item->type == tcons){ |
1309 |
|
if(CAR(item)->type != tcons){ |
1310 |
|
printerr("Bad Argument Type"); |
1311 |
|
env->err= 2; |
1312 |
|
return; |
1313 |
|
} |
1314 |
|
push_val(env, key); |
1315 |
|
push_val(env, CAR(CAR(item))); |
1316 |
|
eqfunc(env); if(env->err) return; |
1317 |
|
|
1318 |
|
/* Check the result of 'eqfunc' */ |
1319 |
|
if(env->head->type==empty) { |
1320 |
|
printerr("Too Few Arguments"); |
1321 |
|
env->err= 1; |
1322 |
|
return; |
1323 |
|
} |
1324 |
|
if(CAR(env->head)->type!=integer) { |
1325 |
|
printerr("Bad Argument Type"); |
1326 |
|
env->err= 2; |
1327 |
|
return; |
1328 |
|
} |
1329 |
|
|
1330 |
|
if(CAR(env->head)->content.i){ |
1331 |
|
toss(env); if(env->err) return; |
1332 |
|
break; |
1333 |
|
} |
1334 |
|
toss(env); if(env->err) return; |
1335 |
|
|
1336 |
|
if(item->type!=tcons) { |
1337 |
|
printerr("Bad Argument Type"); |
1338 |
|
env->err= 2; |
1339 |
|
return; |
1340 |
|
} |
1341 |
|
|
1342 |
|
item=CDR(item); |
1343 |
|
} |
1344 |
|
|
1345 |
|
if(item->type == tcons){ /* A match was found */ |
1346 |
|
push_val(env, CAR(item)); |
1347 |
|
} else { |
1348 |
|
push_int(env, 0); |
1349 |
|
} |
1350 |
|
swap(env); if(env->err) return; |
1351 |
|
toss(env); if(env->err) return; |
1352 |
|
swap(env); if(env->err) return; |
1353 |
|
toss(env); |
1354 |
|
} |
1355 |
|
|
1356 |
|
|
1357 |
/* 2: 3 => */ |
/* 2: 3 => */ |
1358 |
/* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */ |
/* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */ |
1359 |
extern void assq(environment *env) |
extern void assq(environment *env) |