/[cvs]/stack/symbols.c
ViewVC logotype

Diff of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by masse, Mon Aug 4 11:23:43 2003 UTC revision 1.2 by masse, Mon Aug 4 14:13:16 2003 UTC
# Line 1282  extern void cons(environment *env) Line 1282  extern void cons(environment *env)
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)
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26