--- stack/stack.c 2002/03/20 13:20:29 1.118 +++ stack/stack.c 2002/03/20 17:19:46 1.119 @@ -1109,7 +1109,7 @@ } if(myenv.interactive) { - printf("Stack version $Revision: 1.118 $\n\ + printf("Stack version $Revision: 1.119 $\n\ Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\ Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\ This is free software, and you are welcome to redistribute it\n\ @@ -2446,3 +2446,55 @@ swap(env); if(env->err) return; toss(env); if(env->err) return; } + +/* 2: 3 => */ +/* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */ +extern void assq(environment *env) +{ + value *key, *item; + + /* Needs two values on the stack, the top one must be an association + list */ + if(env->head->type==empty || CDR(env->head)->type==empty) { + printerr("Too Few Arguments"); + env->err= 1; + return; + } + + if(CAR(env->head)->type!=tcons) { + printerr("Bad Argument Type"); + env->err= 2; + return; + } + + key=CAR(CDR(env->head)); + item=CAR(env->head); + + while(item->type == tcons){ + if(CAR(item)->type != tcons){ + printerr("Bad Argument Type"); + env->err= 2; + return; + } + push_val(env, key); + push_val(env, CAR(CAR(item))); + eq(env); if(env->err) return; + + if(CAR(env->head)->content.i){ + toss(env); + break; + } + toss(env); + item=CDR(item); + } + + if(item->type == tcons){ /* A match was found */ + push_val(env, CAR(item)); + } else { + push_int(env, 0); + } + swap(env); if(env->err) return; + toss(env); if(env->err) return; + swap(env); if(env->err) return; + toss(env); +}