From: <cli...@li...> - 2007-12-29 23:11:56
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src funarg.d, NONE, 1.1 weak.d, 1.8, 1.9 sequence.d, 1.111, 1.112 makemake.in, 1.712, 1.713 list.d, 1.80, 1.81 lispbibl.d, 1.751, 1.752 ChangeLog, 1.5876, 1.5877 (Sam Steingold) ---------------------------------------------------------------------- Message: 1 Date: Sat, 29 Dec 2007 23:11:40 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src funarg.d, NONE, 1.1 weak.d, 1.8, 1.9 sequence.d, 1.111, 1.112 makemake.in, 1.712, 1.713 list.d, 1.80, 1.81 lispbibl.d, 1.751, 1.752 ChangeLog, 1.5876, 1.5877 To: cli...@li... Message-ID: <E1J...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv11821/src Modified Files: weak.d sequence.d makemake.in list.d lispbibl.d ChangeLog Added Files: funarg.d Log Message: funarg.d: new file, extracted from list.d, sequence.d, weak.d replace up_function_t and up2_function_t with funarg_t extend the 2001-06-16 patch (do not go through FUNCALL for simple tests) by selecting the test function once, not testing on each comparison Index: list.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/list.d,v retrieving revision 1.80 retrieving revision 1.81 diff -u -d -r1.80 -r1.81 --- list.d 13 Dec 2007 22:27:46 -0000 1.80 +++ list.d 29 Dec 2007 23:11:35 -0000 1.81 @@ -407,75 +407,8 @@ VALUES1(cons_from_stack()); } - -# Unterprogramm zum Ausführen des Tests :TEST -# up2_test(stackptr,arg1,arg2) -# > *(stackptr+1): die Testfunktion -# > arg1,arg2: Argumente -# < result: true falls der Test erfüllt ist, false sonst -# can trigger GC -local maygc bool up2_test (const gcv_object_t* stackptr, object arg1, object arg2) { - var object fun = *(stackptr STACKop 1); - # Special case the most frequent cases - if (eq(fun,L(eq))) - return eq(arg1,arg2); - if (eq(fun,L(eql))) - return eql(arg1,arg2); - if (eq(fun,L(equal))) - return equal(arg1,arg2); - pushSTACK(arg1); pushSTACK(arg2); funcall(fun,2); - return !nullp(value1); -} - -# Unterprogramm zum Ausführen des Tests :TEST-NOT -# up2_test_not(stackptr,arg1,arg2) -# > *(stackptr+0): die Testfunktion -# > arg1,arg2: Argumente -# < result: true falls der Test erfüllt ist, false sonst -# can trigger GC -local maygc bool up2_test_not (const gcv_object_t* stackptr, object arg1, object arg2) { - pushSTACK(arg1); pushSTACK(arg2); funcall(*(stackptr STACKop 0),2); - return nullp(value1); -} - -# UP: Ãberprüft die :TEST, :TEST-NOT - Argumente -# test_test2_args(stackptr) -# > stackptr: Pointer in den STACK -# > *(stackptr+1): :TEST-Argument -# > *(stackptr+0): :TEST-NOT-Argument -# < *(stackptr+1): verarbeitetes :TEST-Argument -# < *(stackptr+0): verarbeitetes :TEST-NOT-Argument -# < up2_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist: -# > stackptr: derselbe Pointer in den Stack, arg1, arg2: Argumente -# < true, falls der Test erfüllt ist, false sonst. -# up2_function_t sei der Typ der Adresse einer solchen Testfunktion: -typedef maygc bool (*up2_function_t) (const gcv_object_t* stackptr, - object arg1, object arg2); -local up2_function_t test_test2_args (gcv_object_t* stackptr) { - var object test_arg = *(stackptr STACKop 1); - if (!boundp(test_arg)) - test_arg=NIL; - # test_arg ist das :TEST-Argument - var object test_not_arg = *(stackptr STACKop 0); - if (!boundp(test_not_arg)) - test_not_arg=NIL; - # test_not_arg ist das :TEST-NOT-Argument - if (nullp(test_not_arg)) { - # :TEST-NOT wurde nicht angegeben - if (nullp(test_arg)) - *(stackptr STACKop 1) = L(eql); # #'EQL als Default für :TEST - return &up2_test; - } else { - # :TEST-NOT wurde angegeben - if (nullp(test_arg)) - return &up2_test_not; - else - error_both_tests(); - } -} - # UP: Testet, ob zwei Bäume gleich sind. -# tree_equal(stackptr,up2_fun,arg1,arg2) +# tree_equal(stackptr,pcall_test,arg1,arg2) # > arg1,arg2: Bäume # > stackptr: Pointer in den Stack # > A5: Adresse einer Testfunktion, die arg1 und arg2 vergleicht und dabei auf @@ -483,13 +416,13 @@ # *(stackprt+0).L zugreifen kann. # < result: true, falls gleich, false sonst # can trigger GC -local maygc bool tree_equal (const gcv_object_t* stackptr, up2_function_t up2_fun, +local maygc bool tree_equal (const gcv_object_t* stackptr, funarg_t* pcall_test, object arg1, object arg2) { start: if (atomp(arg1)) if (atomp(arg2)) # arg1 und arg2 sind beide Atome - return up2_fun(stackptr,arg1,arg2); + return pcall_test(stackptr,arg1,arg2); else return false; else @@ -499,7 +432,7 @@ # arg1 und arg2 sind beides Conses check_STACK(); check_SP(); pushSTACK(Cdr(arg1)); pushSTACK(Cdr(arg2)); - if (tree_equal(stackptr,up2_fun,Car(arg1),Car(arg2))) { # rekursiv die CARs vergleichen + if (tree_equal(stackptr,pcall_test,Car(arg1),Car(arg2))) { /* recursive on CARs */ # falls gleich, tail-end-rekursiv die CDRs vergleichen arg2 = popSTACK(); arg1 = popSTACK(); goto start; } else { @@ -512,8 +445,8 @@ { /* (TREE-EQUAL x y :test :test-not), CLTL p. 264 */ var gcv_object_t* stackptr = &STACK_0; /* check :TEST/:TEST-NOT arguments: */ - var up2_function_t up2_fun = test_test2_args(stackptr); - VALUES_IF(tree_equal(stackptr,up2_fun,STACK_3,STACK_2)); + var funarg_t* pcall_test = check_test_args(stackptr); + VALUES_IF(tree_equal(stackptr,pcall_test,STACK_3,STACK_2)); skipSTACK(4); } @@ -1263,132 +1196,8 @@ VALUES1(arg2); } -# Unterprogramm zum Ausführen des Tests :TEST -# up_test(stackptr,x) -# > *(stackptr+1): die Testfunktion -# > *(stackptr+3): das zu vergleichende Item -# > x: Argument -# < result: true falls der Test erfüllt ist, false sonst -# can trigger GC -local maygc bool up_test (const gcv_object_t* stackptr, object x) { - # nach CLTL S. 247 ein (funcall testfun item x) ausführen: - var object item = *(stackptr STACKop 3); - var object fun = *(stackptr STACKop 1); - # Special case the most frequent cases, - if (eq(fun,L(eq))) - return eq(item,x); - if (eq(fun,L(eql))) - return eql(item,x); - if (eq(fun,L(equal))) - return equal(item,x); - pushSTACK(item); - pushSTACK(x); # x - funcall(fun,2); - return !nullp(value1); -} - -# Unterprogramm zum Ausführen des Tests :TEST-NOT -# up_test_not(stackptr,x) -# > *(stackptr+0): die Testfunktion -# > *(stackptr+3): das zu vergleichende Item -# > x: Argument -# < result: true falls der Test erfüllt ist, false sonst -# can trigger GC -local maygc bool up_test_not (const gcv_object_t* stackptr, object x) { - # nach CLTL S. 247 ein (not (funcall testfun item x)) ausführen: - pushSTACK(*(stackptr STACKop 3)); # item - pushSTACK(x); # x - funcall(*(stackptr STACKop 0),2); - return nullp(value1); -} - -# Unterprogramm zum Ausführen des Tests -IF -# up_if(stackptr,x) -# > *(stackptr+1): das Testprädikat -# > x: Argument -# < result: true falls der Test erfüllt ist, false sonst -# can trigger GC -local maygc bool up_if (const gcv_object_t* stackptr, object x) { - # nach CLTL S. 247 ein (funcall predicate x) ausführen: - pushSTACK(x); funcall(*(stackptr STACKop 1),1); - return !nullp(value1); -} - -# Unterprogramm zum Ausführen des Tests -IF-NOT -# up_if_not(stackptr,x) -# > *(stackptr+1): das Testprädikat -# > x: Argument -# < result: true falls der Test erfüllt ist, false sonst -# can trigger GC -local maygc bool up_if_not (const gcv_object_t* stackptr, object x) { - # nach CLTL S. 247 ein (not (funcall predicate x)) ausführen: - pushSTACK(x); funcall(*(stackptr STACKop 1),1); - return nullp(value1); -} - -# UP: Ãberprüft das :KEY-Argument -# test_key_arg() -# > STACK_0: optionales Argument -# < STACK_0: korrekte KEY-Funktion -local void test_key_arg (void) { - var object key_arg = STACK_0; - if (missingp(key_arg)) - STACK_0 = L(identity); # #'IDENTITY als Default für :KEY -} - -# Applies a :KEY argument. -# funcall_key(key,item); -# > key: value of the :KEY argument -# > item: object being considered -# < value1: (FUNCALL key item) -#define funcall_key(key,item) \ - { \ - var object _key = (key); \ - var object _item = (item); \ - # shortcut for :KEY #'IDENTITY, very frequent \ - if (!eq(_key,L(identity))) { \ - pushSTACK(_item); funcall(_key,1); \ - } else { \ - value1 = _item; \ - } \ - } - -# UP: Ãberprüft die :TEST, :TEST-NOT - Argumente -# test_test_args() -# > stackptr:=&STACK_1 : Pointer in den STACK -# > STACK_2: :TEST-Argument -# > STACK_1: :TEST-NOT-Argument -# < STACK_2: verarbeitetes :TEST-Argument -# < STACK_1: verarbeitetes :TEST-NOT-Argument -# < up_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist: -# > stackptr: derselbe Pointer in den Stack, *(stackptr+3) = item, -# *(stackptr+1) = :test-Argument, *(stackptr+0) = :test-not-Argument, -# > x: Argument -# < true, falls der Test erfüllt ist, false sonst. - # up_function_t sei der Typ der Adresse einer solchen Testfunktion: -typedef maygc bool (*up_function_t) (const gcv_object_t* stackptr, object x); -local up_function_t test_test_args (void) { - var object test_arg = STACK_2; - if (!boundp(test_arg)) - test_arg=NIL; - # test_arg ist das :TEST-Argument - var object test_not_arg = STACK_1; - if (!boundp(test_not_arg)) - test_not_arg=NIL; - # test_not_arg ist das :TEST-NOT-Argument - if (nullp(test_not_arg)) { - # :TEST-NOT wurde nicht angegeben - if (nullp(test_arg)) - STACK_2 = L(eql); # #'EQL als Default für :TEST - return &up_test; - } else { - # :TEST-NOT wurde angegeben - if (nullp(test_arg)) - return &up_test_not; - else - error_both_tests(); - } -} +/* (funcall TESTFUN ...) */ +#define CALL_TEST(p) (*pcall_test)(p,*(p STACKop 3),value1) # UP: Ersetzt im Baum tree alle x, deren KEY der TESTFUNktion genügen, # durch NEW. Konstruktiv. @@ -1400,11 +1209,12 @@ # Sie liefert true, falls der Test erfüllt ist, false sonst. # < result: (evtl. neuer) Baum # can trigger GC -local maygc object subst (object tree, gcv_object_t* stackptr, up_function_t up_fun) { +local maygc object subst (object tree, gcv_object_t* stackptr, + funarg_t* pcall_test) { # erst (KEY tree) berechnen und TESTFUN aufrufen: pushSTACK(tree); # tree retten funcall_key(*(stackptr STACKop -1),tree); # (KEY tree) - if (up_fun(stackptr,value1)) { # TESTFUN aufrufen + if (CALL_TEST(stackptr)) { /* (funcall TESTFUN ...) */ # Test erfüllt skipSTACK(1); return *(stackptr STACKop -2); # NEW als Wert } else @@ -1416,10 +1226,10 @@ # Argument ist ein Cons -> SUBST rekursiv aufrufen: check_STACK(); check_SP(); # rekursiv für den CDR aufrufen: - var object new_cdr = subst(Cdr(STACK_0),stackptr,up_fun); + var object new_cdr = subst(Cdr(STACK_0),stackptr,pcall_test); pushSTACK(new_cdr); # CDR-Ergebnis retten # rekursiv für den CAR aufrufen: - var object new_car = subst(Car(STACK_1),stackptr,up_fun); + var object new_car = subst(Car(STACK_1),stackptr,pcall_test); if (eq(new_car,Car(STACK_1)) && eq(STACK_0,Cdr(STACK_1))) { # beides unverändert skipSTACK(1); # CDR-Ergebnis vergessen @@ -1434,29 +1244,29 @@ LISPFUN(subst,seclass_default,3,0,norest,key,3, (kw(test),kw(test_not),kw(key)) ) { /* (SUBST new old tree :test :test-not :key), CLTL p. 273 */ - test_key_arg(); /* :KEY-Argument in STACK_0 */ - var up_function_t up_fun = test_test_args(); /* :TEST/:TEST-NOT-Arguments in STACK_2,STACK_1 */ - { var object newobj = STACK_5; pushSTACK(newobj); } + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + var funarg_t* pcall_test = check_test_args(&STACK_1); /* :TEST/:TEST-NOT-Arguments in STACK_2,STACK_1 */ + pushSTACK(STACK_5); /* newobj */ /* stack layout: new, old, tree, test, test_not, key, new. */ - VALUES1(subst(STACK_4,&STACK_2,up_fun)); /* do the substitution */ + VALUES1(subst(STACK_4,&STACK_2,pcall_test)); /* do the substitution */ skipSTACK(7); } LISPFUN(subst_if,seclass_default,3,0,norest,key,1, (kw(key)) ) { /* (SUBST-IF new pred tree :key), CLTL p. 273 */ - test_key_arg(); /* :KEY-Argument in STACK_0 */ - { var object newobj = STACK_3; pushSTACK(newobj); } + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + pushSTACK(STACK_3); /* newobj */ /* stack layout: new, pred, tree, key, new. */ - VALUES1(subst(STACK_2,&STACK_2,&up_if)); /* do the substitution */ + VALUES1(subst(STACK_2,&STACK_2,&call_if)); /* do the substitution */ skipSTACK(5); } LISPFUN(subst_if_not,seclass_default,3,0,norest,key,1, (kw(key)) ) { /* (SUBST-IF-NOT new pred tree :key), CLTL S. 273 */ - test_key_arg(); /* :KEY-Argument in STACK_0 */ - { var object newobj = STACK_3; pushSTACK(newobj); } + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + pushSTACK(STACK_3); /* newobj */ /* stack layout: new, pred, tree, key, new. */ - VALUES1(subst(STACK_2,&STACK_2,&up_if_not)); /* do the substitution */ + VALUES1(subst(STACK_2,&STACK_2,&call_if_not)); /* do the substitution */ skipSTACK(5); } @@ -1470,11 +1280,12 @@ # Sie liefert true, falls der Test erfüllt ist, false sonst. # < result: Baum # can trigger GC -local maygc object nsubst (object tree, gcv_object_t* stackptr, up_function_t up_fun) { +local maygc object nsubst (object tree, gcv_object_t* stackptr, + funarg_t* pcall_test) { # erst (KEY tree) berechnen und TESTFUN aufrufen: pushSTACK(tree); # tree retten funcall_key(*(stackptr STACKop -1),tree); # (KEY tree) - if (up_fun(stackptr,value1)) { # TESTFUN aufrufen + if (CALL_TEST(stackptr)) { /* (funcall TESTFUN ...) */ # Test erfüllt skipSTACK(1); return *(stackptr STACKop -2); # NEW als Wert } else { @@ -1484,12 +1295,12 @@ check_STACK(); check_SP(); # rekursiv für den CDR aufrufen: { - var object modified_cdr = nsubst(Cdr(STACK_0),stackptr,up_fun); + var object modified_cdr = nsubst(Cdr(STACK_0),stackptr,pcall_test); Cdr(STACK_0) = modified_cdr; } # rekursiv für den CAR aufrufen: { - var object modified_car = nsubst(Car(STACK_0),stackptr,up_fun); + var object modified_car = nsubst(Car(STACK_0),stackptr,pcall_test); Car(STACK_0) = modified_car; } } @@ -1500,29 +1311,29 @@ LISPFUN(nsubst,seclass_default,3,0,norest,key,3, (kw(test),kw(test_not),kw(key)) ) { /* (NSUBST new old tree :test :test-not :key), CLTL p. 274 */ - test_key_arg(); /* :KEY-Argument in STACK_0 */ - var up_function_t up_fun = test_test_args(); /* :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 */ - { var object newobj = STACK_5; pushSTACK(newobj); } + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + var funarg_t* pcall_test = check_test_args(&STACK_1); /* :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 */ + pushSTACK(STACK_5); /* newobj */ /* stack layout: new, old, tree, test, test_not, key, new. */ - VALUES1(nsubst(STACK_4,&STACK_2,up_fun)); /* do the substitution */ + VALUES1(nsubst(STACK_4,&STACK_2,pcall_test)); /* do the substitution */ skipSTACK(7); } LISPFUN(nsubst_if,seclass_default,3,0,norest,key,1, (kw(key)) ) { /* (NSUBST-IF new pred tree :key), CLTL p. 274 */ - test_key_arg(); /* :KEY-Argument in STACK_0 */ - { var object newobj = STACK_3; pushSTACK(newobj); } + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + pushSTACK(STACK_3); /* newobj */ /* stack layout: new, pred, tree, key, new. */ - VALUES1(nsubst(STACK_2,&STACK_2,&up_if)); /* do the substitution */ + VALUES1(nsubst(STACK_2,&STACK_2,&call_if)); /* do the substitution */ skipSTACK(5); } LISPFUN(nsubst_if_not,seclass_default,3,0,norest,key,1, (kw(key)) ) { /* (NSUBST-IF-NOT new pred tree :key), CLTL p. 274 */ - test_key_arg(); /* :KEY-Argument in STACK_0 */ - { var object newobj = STACK_3; pushSTACK(newobj); } + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + pushSTACK(STACK_3); /* newobj */ /* stack layout: new, pred, tree, key, new. */ - VALUES1(nsubst(STACK_2,&STACK_2,&up_if_not)); /* do the substitution */ + VALUES1(nsubst(STACK_2,&STACK_2,&call_if_not)); /* do the substitution */ skipSTACK(5); } @@ -1562,7 +1373,7 @@ *(stackptr-3) (an adress!), called on u and the value in *(stackptr-2), returns true: */ var bool erg = /* 2-argument test function, called on (KEY x) and u */ - (*(up2_function_t)TheMachineCode(*(stackptr STACKop -3))) + (*(funarg_t*)TheMachineCode(*(stackptr STACKop -3))) ( stackptr, *(stackptr STACKop -2), Car(head) ); if (erg) /* test passed ==> return x = (u . v) = (CAR alist) */ return Car(popSTACK()); @@ -1622,18 +1433,17 @@ (kw(test),kw(test_not),kw(key)) ) # (SUBLIS alist tree :test :test-not :key), CLTL S. 274 { - test_key_arg(); # :KEY-Argument in STACK_0 + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ var gcv_object_t* stackptr = &STACK_1; - var up2_function_t up2_fun = test_test2_args(stackptr); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 - # up2_fun = Testfunktion, wird mit stackptr und (KEY x) und u als + var funarg_t* pcall_test = check_test_args(stackptr); /* :TEST/:TEST-NOT-Arguments in STACK_2,STACK_1 */ # Argumenten angesprungen. Sie liefert true, falls der Test erfüllt ist. if (nullp(STACK_4)) { # shortcut: nothing to do if alist = () VALUES1(STACK_3); skipSTACK(5); } else { pushSTACK(NIL); # Dummy - pushSTACK(make_machine_code(up2_fun)); # Testfunktion, wegen Typinfo=machine_type GC-sicher! - # stack layout: alist, tree, test, test_not, key, dummy, up2_fun. + pushSTACK(make_machine_code(pcall_test)); # Testfunktion, wegen Typinfo=machine_type GC-sicher! + # stack layout: alist, tree, test, test_not, key, dummy, pcall_test. VALUES1(sublis(STACK_5,stackptr)); /* do the substitution */ skipSTACK(7); } @@ -1681,18 +1491,17 @@ (kw(test),kw(test_not),kw(key)) ) # (NSUBLIS alist tree :test :test-not :key), CLTL S. 275 { - test_key_arg(); # :KEY-Argument in STACK_0 + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ var gcv_object_t* stackptr = &STACK_1; - var up2_function_t up2_fun = test_test2_args(stackptr); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 - # up2_fun = Testfunktion, wird mit stackptr und (KEY x) und u als + var funarg_t* pcall_test = check_test_args(stackptr); /* :TEST/:TEST-NOT-Arguments in STACK_2,STACK_1 */ # Argumenten angesprungen. Sie liefert true, falls der Test erfüllt ist. if (nullp(STACK_4)) { # shortcut: nothing to do if alist = () VALUES1(STACK_3); skipSTACK(5); } else { pushSTACK(NIL); # Dummy - pushSTACK(make_machine_code(up2_fun)); # Testfunktion, wegen Typinfo=machine_type GC-sicher! - # Stackaufbau: alist, tree, test, test_not, key, dummy, up2_fun. + pushSTACK(make_machine_code(pcall_test)); # Testfunktion, wegen Typinfo=machine_type GC-sicher! + # Stackaufbau: alist, tree, test, test_not, key, dummy, pcall_test. VALUES1(nsublis(STACK_5,stackptr)); /* do the substitution */ skipSTACK(7); } @@ -1727,12 +1536,13 @@ # Sie liefert true, falls der Test erfüllt ist, false sonst. # < result: Listenrest # can trigger GC -local maygc object member (object list, gcv_object_t* stackptr, up_function_t up_fun) { +local maygc object member (object list, gcv_object_t* stackptr, + funarg_t* pcall_test) { while (!endp(list)) { pushSTACK(list); # Listenrest retten funcall_key(*(stackptr STACKop -1),Car(list)); # (KEY x) { - var bool erg = up_fun(stackptr,value1); # TESTFUN aufrufen + var bool erg = CALL_TEST(stackptr); /* (funcall TESTFUN ...) */ list = popSTACK(); if (erg) return list; # Test erfüllt -> list als Ergebnis @@ -1747,25 +1557,25 @@ (kw(test),kw(test_not),kw(key)) ) # (MEMBER item list :test :test-not :key), CLTL S. 275 { - test_key_arg(); # :KEY-Argument in STACK_0 - var up_function_t up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 - VALUES1(member(STACK_3,&STACK_1,up_fun)); /* do the search */ + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + var funarg_t* pcall_test = check_test_args(&STACK_1); /* :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 */ + VALUES1(member(STACK_3,&STACK_1,pcall_test)); /* do the search */ skipSTACK(5); } LISPFUN(member_if,seclass_default,2,0,norest,key,1, (kw(key)) ) # (MEMBER-IF pred list :key), CLTL S. 275 { - test_key_arg(); # :KEY-Argument in STACK_0 - VALUES1(member(STACK_1,&STACK_1,&up_if)); /* do the search */ + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + VALUES1(member(STACK_1,&STACK_1,&call_if)); /* do the search */ skipSTACK(3); } LISPFUN(member_if_not,seclass_default,2,0,norest,key,1, (kw(key)) ) # (MEMBER-IF-NOT pred list :key), CLTL S. 275 { - test_key_arg(); # :KEY-Argument in STACK_0 - VALUES1(member(STACK_1,&STACK_1,&up_if_not)); /* do the search */ + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + VALUES1(member(STACK_1,&STACK_1,&call_if_not)); /* do the search */ skipSTACK(3); } @@ -1814,15 +1624,15 @@ # (ADJOIN item list :test :test-not :key), CLTL S. 276 { # erst Test auf (MEMBER (key item) list :test :test-not :key): - test_key_arg(); # :KEY-Argument in STACK_0 - var up_function_t up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + var funarg_t* pcall_test = check_test_args(&STACK_1); /* :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 */ { var object item = STACK_4; pushSTACK(item); # item retten funcall_key(STACK_1,item); STACK_5 = value1; # item := (funcall key item) } # Stackaufbau: (key item), list, test, test-not, key, item - if (nullp(member(STACK_4,&STACK_2,up_fun))) { # Suche durchführen + if (nullp(member(STACK_4,&STACK_2,pcall_test))) { # Suche durchführen # item noch nicht in list gefunden: muss consen var object new_cons = allocate_cons(); Cdr(new_cons) = STACK_4; # = list @@ -1896,7 +1706,8 @@ # Sie liefert true, falls der Test erfüllt ist, false sonst. # < result: Listenelement (ein Cons) oder NIL # can trigger GC -local maygc object assoc (object alist, gcv_object_t* stackptr, up_function_t up_fun) +local maygc object assoc (object alist, gcv_object_t* stackptr, + funarg_t* pcall_test) { start: if (endp(alist)) /* end of alist ==> NIL */ @@ -1906,7 +1717,7 @@ if (mconsp(head)) { # atomare Listenelemente überspringen pushSTACK(alist); # Listenrest ((u . v) ...) retten funcall_key(*(stackptr STACKop -1),Car(head)); # (KEY u) - var bool erg = up_fun(stackptr,value1); # TESTFUN aufrufen + var bool erg = CALL_TEST(stackptr); /* (funcall TESTFUN ...) */ alist = popSTACK(); if (erg) # Test erfüllt -> x = (u . v) = (CAR alist) als Ergebnis @@ -1923,25 +1734,25 @@ (kw(test),kw(test_not),kw(key)) ) # (ASSOC item alist :test :test-not :key), CLTL S. 280 { - test_key_arg(); # :KEY-Argument in STACK_0 - var up_function_t up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 - VALUES1(assoc(STACK_3,&STACK_1,up_fun)); /* do the search */ + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + var funarg_t* pcall_test = check_test_args(&STACK_1); /* :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 */ + VALUES1(assoc(STACK_3,&STACK_1,pcall_test)); /* do the search */ skipSTACK(5); } LISPFUN(assoc_if,seclass_default,2,0,norest,key,1, (kw(key)) ) # (ASSOC-IF pred alist :key), CLTL S. 280 { - test_key_arg(); # :KEY-Argument in STACK_0 - VALUES1(assoc(STACK_1,&STACK_1,&up_if)); /* do the search */ + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + VALUES1(assoc(STACK_1,&STACK_1,&call_if)); /* do the search */ skipSTACK(3); } LISPFUN(assoc_if_not,seclass_default,2,0,norest,key,1, (kw(key)) ) # (ASSOC-IF-NOT pred alist :key), CLTL S. 280 { - test_key_arg(); # :KEY-Argument in STACK_0 - VALUES1(assoc(STACK_1,&STACK_1,&up_if_not)); /* do the search */ + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + VALUES1(assoc(STACK_1,&STACK_1,&call_if_not)); /* do the search */ skipSTACK(3); } @@ -1955,8 +1766,7 @@ # < result: Listenelement (ein Cons) oder NIL # can trigger GC local maygc object rassoc (object alist, gcv_object_t* stackptr, - up_function_t up_fun) -{ + funarg_t* pcall_test) { start: if (endp(alist)) /* end of alist ==> NIL */ return NIL; @@ -1965,7 +1775,7 @@ if (mconsp(head)) { # atomare Listenelemente überspringen pushSTACK(alist); # Listenrest ((u . v) ...) retten funcall_key(*(stackptr STACKop -1),Cdr(head)); # (KEY v) - var bool erg = up_fun(stackptr,value1); # TESTFUN aufrufen + var bool erg = CALL_TEST(stackptr); /* (funcall TESTFUN ...) */ alist = popSTACK(); if (erg) # Test erfüllt -> x = (u . v) = (CAR alist) als Ergebnis @@ -1981,23 +1791,23 @@ LISPFUN(rassoc,seclass_default,2,0,norest,key,3, (kw(test),kw(test_not),kw(key)) ) { /* (RASSOC item alist :test :test-not :key), CLTL S. 281 */ - test_key_arg(); # :KEY-Argument in STACK_0 - var up_function_t up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 - VALUES1(rassoc(STACK_3,&STACK_1,up_fun)); /* do the search */ + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + var funarg_t* pcall_test = check_test_args(&STACK_1); /* :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1 */ + VALUES1(rassoc(STACK_3,&STACK_1,pcall_test)); /* do the search */ skipSTACK(5); } LISPFUN(rassoc_if,seclass_default,2,0,norest,key,1, (kw(key)) ) { /* (RASSOC-IF pred alist :key), CLTL S. 281 */ - test_key_arg(); # :KEY-Argument in STACK_0 - VALUES1(rassoc(STACK_1,&STACK_1,&up_if)); /* do the search */ + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + VALUES1(rassoc(STACK_1,&STACK_1,&call_if)); /* do the search */ skipSTACK(3); } LISPFUN(rassoc_if_not,seclass_default,2,0,norest,key,1, (kw(key)) ) { /* (RASSOC-IF-NOT pred alist :key), CLTL S. 281 */ - test_key_arg(); # :KEY-Argument in STACK_0 - VALUES1(rassoc(STACK_1,&STACK_1,&up_if_not)); /* do the search */ + check_key_arg(&STACK_0); /* :KEY-Argument in STACK_0 */ + VALUES1(rassoc(STACK_1,&STACK_1,&call_if_not)); /* do the search */ skipSTACK(3); } Index: weak.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/weak.d,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- weak.d 26 Dec 2007 18:00:19 -0000 1.8 +++ weak.d 29 Dec 2007 23:11:32 -0000 1.9 @@ -829,107 +829,8 @@ skipSTACK(2); } -/* UP: Checks the :KEY argument - test_key_arg() - > STACK_0: optional argument - < STACK_0: correct KEY function */ -local void test_key_arg (void) { - var object key_arg = STACK_0; - if (missingp(key_arg)) - STACK_0 = L(identity); /* #'IDENTITY as default for :KEY */ -} - -/* Applies a :KEY argument. - funcall_key(key,item); - > key: value of the :KEY argument - > item: object being considered - < value1: (FUNCALL key item) */ -#define funcall_key(key,item) do { \ - var object _key = (key); \ - var object _item = (item); \ - /* shortcut for :KEY #'IDENTITY, very frequent */ \ - if (!eq(_key,L(identity))) { \ - pushSTACK(_item); funcall(_key,1); \ - } else { \ - value1 = _item; \ - } \ - } while(0) - -/* Subroutine to compute the test :TEST - up_test(stackptr,x) - > *(stackptr+1): the test function - > *(stackptr+3): the item to compare with - > x: the argument - < result: true if the test is okay, otherwise false. - can trigger GC */ -local maygc bool up_test (const gcv_object_t* stackptr, object x) { - /* Per CLTL p.247 do a (funcall testfun item x): */ - var object item = *(stackptr STACKop 3); - var object fun = *(stackptr STACKop 1); - /* Special case the most frequent cases, */ - if (eq(fun,L(eq))) - return eq(item,x); - if (eq(fun,L(eql))) - return eql(item,x); - if (eq(fun,L(equal))) - return equal(item,x); - pushSTACK(item); - pushSTACK(x); /* x */ - funcall(fun,2); - return !nullp(value1); -} - -/* Subroutine to compute the test :TEST-NOT - up_test_not(stackptr,x) - > *(stackptr+1): the test function - > *(stackptr+3): the item to compare with - > x: the argument - < result: true if the test is okay, otherwise false. - can trigger GC */ -local maygc bool up_test_not (const gcv_object_t* stackptr, object x) { - /* Per CLTL p.247 do a (not (funcall testfun item x)): */ - pushSTACK(*(stackptr STACKop 3)); /* item */ - pushSTACK(x); /* x */ - funcall(*(stackptr STACKop 0),2); - return nullp(value1); -} - -/* UP: Check the :TEST, :TEST-NOT - arguments - test_test_args() - > stackptr: Pointer to the STACK - > *(stackptr+1): :TEST argument - > *(stackptr+0): :TEST-NOT argument - < *(stackptr+1): computed :TEST argument - < *(stackptr+0): computed :TEST-NOT argument - < up_fun: Adress of a test function, specified like this: - > stackptr: same Pointer to the Stack, *(stackptr+3) = item, - *(stackptr+1) = :test argument, *(stackptr+0) = :test-not argument, - > x: the argument - < true, if the test returns true, otherwise false. - Let up_function_t be the type of such a test function address: */ -typedef maygc bool (*up_function_t) (const gcv_object_t* stackptr, object x); -local up_function_t test_test_args (gcv_object_t* stackptr) { - var object test_arg = *(stackptr STACKop 1); - if (!boundp(test_arg)) - test_arg = NIL; - /* test_arg is the :TEST argument */ - var object test_not_arg = *(stackptr STACKop 0); - if (!boundp(test_not_arg)) - test_not_arg = NIL; - /* test_not_arg is the :TEST-NOT argument */ - if (nullp(test_not_arg)) { - /* :TEST-NOT was not specified */ - if (nullp(test_arg)) - *(stackptr STACKop 1) = L(eql); /* #'EQL as default for :TEST */ - return &up_test; - } else { - /* :TEST-NOT was not specified */ - if (nullp(test_arg)) - return &up_test_not; - else - error_both_tests(); - } -} +/* call test/test-not function on the appropriate STACK arguments */ +#define CALL_TEST(shift,key) (*pcall_test)(&STACK_(shift),STACK_(shift+3),key) /* (WEAK-ALIST-ASSOC item weak-alist [:test] [:test-not] [:key]) is equivalent to @@ -940,13 +841,12 @@ /* Check weak-alist argument: */ STACK_3 = check_weakalist(STACK_3); /* Check :TEST/:TEST-NOT arguments in STACK_2,STACK_1: */ - var up_function_t up_fun = test_test_args(&STACK_1); - /* Check :KEY argument in STACK_0: */ - test_key_arg(); + var funarg_t* pcall_test = check_test_args(&STACK_1); + check_key_arg(&STACK_0); /* Check :KEY argument in STACK_0 */ /* Search: */ var object wal = TheMutableWeakAlist(STACK_3)->mwal_list; - /* We cannot use TheWeakAlist(wal)->wal_count here, because it can be */ - /* decremented by a GC happening during the loop. */ + /* We cannot use TheWeakAlist(wal)->wal_count here, because it can be + decremented by a GC happening during the loop. */ var uintL maxlen = (Lrecord_length(wal)-2)/2; pushSTACK(wal); pushSTACK(NIL); @@ -960,7 +860,7 @@ STACK_1 = key; STACK_0 = TheWeakAlist(wal)->wal_data[2*i+1]; funcall_key(STACK_(0+3),key); - if (up_fun(&STACK_(1+3),value1)) { + if (CALL_TEST(1+3,value1)) { var object result = allocate_cons(); Car(result) = STACK_1; Cdr(result) = STACK_0; VALUES1(result); @@ -983,9 +883,8 @@ /* Check weak-alist argument: */ STACK_3 = check_weakalist(STACK_3); /* Check :TEST/:TEST-NOT arguments in STACK_2,STACK_1: */ - var up_function_t up_fun = test_test_args(&STACK_1); - /* Check :KEY argument in STACK_0: */ - test_key_arg(); + var funarg_t* pcall_test = check_test_args(&STACK_1); + check_key_arg(&STACK_0); /* Check :KEY argument in STACK_0 */ /* Search: */ var object wal = TheMutableWeakAlist(STACK_3)->mwal_list; /* We cannot use TheWeakAlist(wal)->wal_count here, because it can be @@ -1003,7 +902,7 @@ STACK_0 = value; STACK_1 = TheWeakAlist(wal)->wal_data[2*i+0]; funcall_key(STACK_(0+3),value); - if (up_fun(&STACK_(1+3),value1)) { + if (CALL_TEST(1+3,value1)) { var object result = allocate_cons(); Car(result) = STACK_1; Cdr(result) = STACK_0; VALUES1(result); @@ -1026,7 +925,7 @@ /* Check weak-alist argument: */ STACK_2 = check_weakalist(STACK_2); /* Check :TEST/:TEST-NOT arguments in STACK_1,STACK_0: */ - var up_function_t up_fun = test_test_args(&STACK_0); + var funarg_t* pcall_test = check_test_args(&STACK_0); /* Search: */ var object wal = TheMutableWeakAlist(STACK_2)->mwal_list; /* We cannot use TheWeakAlist(wal)->wal_count here, because it can be @@ -1041,7 +940,7 @@ var object key = TheWeakAlist(wal)->wal_data[2*i+0]; if (!eq(key,unbound)) { STACK_0 = TheWeakAlist(wal)->wal_data[2*i+1]; - if (up_fun(&STACK_(0+2),key)) { + if (CALL_TEST(0+2,key)) { VALUES1(STACK_0); skipSTACK(4+2); return; @@ -1063,7 +962,7 @@ /* Check weak-alist argument: */ STACK_2 = check_weakalist(STACK_2); /* Check :TEST/:TEST-NOT arguments in STACK_1,STACK_0: */ - var up_function_t up_fun = test_test_args(&STACK_0); + var funarg_t* pcall_test = check_test_args(&STACK_0); /* Search: */ var object wal = TheMutableWeakAlist(STACK_2)->mwal_list; /* We cannot use TheWeakAlist(wal)->wal_count here, because it can be @@ -1082,7 +981,7 @@ while we call the :TEST/:TEST-NOT function. */ STACK_1 = key; STACK_0 = TheWeakAlist(wal)->wal_data[2*i+1]; - if (up_fun(&STACK_(0+3),key)) { + if (CALL_TEST(0+3,key)) { /* Replace the pair's value. */ wal = STACK_2; TheWeakAlist(wal)->wal_data[2*i+1] = STACK_(4+3); Index: sequence.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/sequence.d,v retrieving revision 1.111 retrieving revision 1.112 diff -u -d -r1.111 -r1.112 --- sequence.d 13 Dec 2007 22:27:42 -0000 1.111 +++ sequence.d 29 Dec 2007 23:11:32 -0000 1.112 @@ -1,7 +1,7 @@ /* * Sequences for CLISP * Bruno Haible 1987-2005 - * Sam Steingold 1998-2006 + * Sam Steingold 1998-2007 */ #include "lispbibl.c" @@ -1756,31 +1756,6 @@ return_Values seq_boolop(&boolop_notevery,rest_args_pointer STACKop 2,rest_args_pointer,argcount,NIL); } [...1170 lines suppressed...] } funcall(*(stackptr STACKop 0),2); # (FUNCALL predicate item2 item1) @@ -4871,7 +4687,7 @@ # Argumente start und end überprüfen: test_start_end(&O(kwpair_start),&STACK_1); # key überprüfen: - test_key_arg(&STACK_7); + check_key_arg(&STACK_3); # l := (- end start), ein Integer >=0 var object l = I_I_minus_I(STACK_1,STACK_2); pushSTACK(l); @@ -4912,7 +4728,7 @@ pushSTACK(NIL); # Stackaufbau: result-type, sequence1, sequence2, predicate, key, nil. # key-Argument überprüfen: - test_key_arg(&STACK_5); + check_key_arg(&STACK_1); # sequence1 überprüfen: { var object seq1 = STACK_4; Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.5876 retrieving revision 1.5877 diff -u -d -r1.5876 -r1.5877 --- ChangeLog 26 Dec 2007 18:06:30 -0000 1.5876 +++ ChangeLog 29 Dec 2007 23:11:36 -0000 1.5877 @@ -1,3 +1,14 @@ +2007-12-27 Sam Steingold <sd...@gn...> + + * funarg.d: new file, extracted from list.d, sequence.d, weak.d + * list.d, sequence.d, weak.d: use funarg.d + replace up_function_t and up2_function_t with funarg_t + extend the 2001-06-16 patch (do not go through FUNCALL for simple tests) + by selecting the test function once, not testing on each comparison + * makemake.in (CPARTS): add funarg + * lispbibl.d (check_key_arg, funcall_key, check_test_args): add + (error_both_tests): remove + 2007-12-26 Sam Steingold <sd...@gn...> * lispbibl.d, spvw_gcstat.d, time.d (TIME_1, TIME_2): replace with --- NEW FILE: funarg.d --- /* * functional arguments, like :TEST, :TEST-NOT, and :KEY * the common part of list.d, sequence.d, weak.d * extracted by Sam Steingold 2007-12-26 */ #include "lispbibl.c" /* UP: Checks the :KEY argument check_key_arg() > *pkey_arg: optional argument < *pkey_arg: correct KEY function */ global void check_key_arg (gcv_object_t *pkey_arg) { if (missingp(*pkey_arg)) *pkey_arg = L(identity); /* :KEY defaults to #'IDENTITY */ } /* Subroutine to compute the test :TEST call_test(fun,arg1,arg2) > *fun: the test function > arg1: the first item to compare > arg2: the second item < result: true if the test is okay, otherwise false. can trigger GC */ funarg_t call_test, call_test_not; funarg_t call_test_eq, call_test_eql, call_test_equal, call_test_equalp; funarg_t call_test_not_eq, call_test_not_eql, call_test_not_equal, call_test_not_equalp; global maygc bool call_test (const gcv_object_t* fun, object arg1, object arg2) { /* Per CLTL p.247 do a (funcall testfun arg1 arg2): */ pushSTACK(arg1); pushSTACK(arg2); funcall(*(fun STACKop 1),2); return !nullp(value1); } /* special case the most frequent cases: */ global maygc bool call_test_eq (const gcv_object_t* fun, object arg1, object arg2) { (void)fun/*ASSERT(eq(*(fun STACKop 1),L(eq)))*/; return eq(arg2,arg1); } global maygc bool call_test_eql (const gcv_object_t* fun, object arg1, object arg2) { (void)fun/*ASSERT(eq(*(fun STACKop 1),L(eql)))*/; return eql(arg2,arg1); } global maygc bool call_test_equal (const gcv_object_t* fun, object arg1, object arg2) { (void)fun/*ASSERT(eq(*(fun STACKop 1),L(equal)))*/; return equal(arg2,arg1); } global maygc bool call_test_equalp (const gcv_object_t* fun, object arg1, object arg2) { (void)fun/*ASSERT(eq(*(fun STACKop 1),L(equalp)))*/; return equalp(arg2,arg1); } /* Subroutine to compute the test :TEST-NOT call_test_not(fun,arg1,arg2) > *fun: the test function > arg1: the first item to compare > arg2: the second item < result: true if the test is okay, otherwise false. can trigger GC */ global maygc bool call_test_not (const gcv_object_t* fun, object arg1, object arg2) { /* Per CLTL p.247 do a (not (funcall testfun arg1 arg2)): */ pushSTACK(arg1); pushSTACK(arg2); funcall(*(fun STACKop 0),2); return nullp(value1); } /* special case the most frequent cases: */ global maygc bool call_test_not_eq (const gcv_object_t* fun, object arg1, object arg2) { (void)fun/*ASSERT(eq(*(fun STACKop 0),L(eq)))*/; return !eq(arg2,arg1); } global maygc bool call_test_not_eql (const gcv_object_t* fun, object arg1, object arg2) { (void)fun/*ASSERT(eq(*(fun STACKop 0),L(eql)))*/; return !eql(arg2,arg1); } global maygc bool call_test_not_equal (const gcv_object_t* fun, object arg1, object arg2) { (void)fun/*ASSERT(eq(*(fun STACKop 0),L(equal)))*/; return !equal(arg2,arg1); } global maygc bool call_test_not_equalp (const gcv_object_t* fun, object arg1, object arg2) { (void)fun/*ASSERT(eq(*(fun STACKop 0),L(equalp)))*/; return !equalp(arg2,arg1); } /* for -IF and -IF-NOT functions */ global maygc bool call_if (const gcv_object_t* stackptr, object arg1, object arg2) { (void)arg1; /* unused */ /* Per CLTL p. 247 call (funcall predicate arg2): */ pushSTACK(arg2); funcall(*(stackptr STACKop 1),1); return !nullp(value1); } global maygc bool call_if_not (const gcv_object_t* stackptr, object arg1, object arg2) { (void)arg1; /* unused */ /* Per CLTL p. 247 call (not (funcall predicate arg2)): */ pushSTACK(arg2); funcall(*(stackptr STACKop 1),1); return nullp(value1); } /* Error when both :TEST and :TEST-NOT are supplied error_both_tests(); */ nonreturning_function(local, error_both_tests, (void)) { pushSTACK(TheSubr(subr_self)->name); error(error_condition, GETTEXT("~S: Must not specify both :TEST and :TEST-NOT arguments")); } /* UP: Check the :TEST, :TEST-NOT - arguments check_test_args() > stackptr: Pointer to the STACK > *(stackptr+1): :TEST argument > *(stackptr+0): :TEST-NOT argument < *(stackptr+1): computed :TEST argument < *(stackptr+0): computed :TEST-NOT argument < call_test: Adress of a test function */ global funarg_t* check_test_args (gcv_object_t* stackptr) { var object test_arg = *(stackptr STACKop 1); if (!boundp(test_arg)) *(stackptr STACKop 1) = test_arg = NIL; /* test_arg is the :TEST argument */ var object test_not_arg = *(stackptr STACKop 0); if (!boundp(test_not_arg)) *(stackptr STACKop 0) = test_not_arg = NIL; /* test_not_arg is the :TEST-NOT argument */ if (nullp(test_not_arg)) { /* :TEST-NOT was not specified */ if (nullp(test_arg)) *(stackptr STACKop 1) = test_arg = L(eql); /* :TEST defaults to #'EQL */ if (eq(test_arg,L(eq))) return &call_test_eq; if (eq(test_arg,L(eql))) return &call_test_eql; if (eq(test_arg,L(equal))) return &call_test_equal; if (eq(test_arg,L(equalp))) return &call_test_equalp; return &call_test; } if (!nullp(test_arg)) error_both_tests(); if (eq(test_not_arg,L(eq))) return &call_test_not_eq; if (eq(test_arg,L(eql))) return &call_test_not_eql; if (eq(test_arg,L(equal))) return &call_test_not_equal; if (eq(test_arg,L(equalp))) return &call_test_not_equalp; return &call_test_not; } Index: makemake.in =================================================================== RCS file: /cvsroot/clisp/clisp/src/makemake.in,v retrieving revision 1.712 retrieving revision 1.713 diff -u -d -r1.712 -r1.713 --- makemake.in 17 Dec 2007 01:33:05 -0000 1.712 +++ makemake.in 29 Dec 2007 23:11:35 -0000 1.713 @@ -1573,7 +1573,7 @@ if [ $TSYS = master -o $TOS = unix -o $TOS = win32 ] ; then CPARTS=$CPARTS' socket' fi -CPARTS=$CPARTS' io' +CPARTS=$CPARTS' io funarg' CPARTS=$CPARTS' array hashtabl list package record weak sequence' CPARTS=$CPARTS' charstrg debug error misc time predtype symbol lisparit i18n' if [ $TSYS = master -o "${with_dynamic_ffi}" != no ] ; then Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.751 retrieving revision 1.752 diff -u -d -r1.751 -r1.752 --- lispbibl.d 26 Dec 2007 18:06:30 -0000 1.751 +++ lispbibl.d 29 Dec 2007 23:11:35 -0000 1.752 @@ -9531,6 +9531,9 @@ /* print the object to a C stream - not all objects can be handled yet! non-consing, STACK non-modifying */ extern maygc object nobject_out (FILE* out, object obj); +#define NOBJECT_OUT(obj,label) \ + (printf("[%s:%d] %s: %s: ",__FILE__,__LINE__,STRING(obj),label), \ + nobject_out(stdout,obj), printf("\n")) # used for debugging purposes %% puts("extern object object_out (object obj);"); %% puts("#define OBJECT_OUT(obj,label) (printf(\"[%s:%d] %s: %s:\\n\",__FILE__,__LINE__,STRING(obj),label),obj=object_out(obj))"); @@ -14051,6 +14054,53 @@ #define terpri(stream_) write_ascii_char(stream_,NL) # is used by IO, DEBUG, PACKAGE, ERROR, SPVW +# ####################### Functional arguments for FUNARG.D ################ # +/* used by LIST, WEAK, SEQUENCE */ + +/* UP: Checks the :KEY argument + check_key_arg() + > *pkey_arg: optional argument + < *pkey_arg: correct KEY function */ +global void check_key_arg (gcv_object_t *pkey_arg); +/* used by LIST, SEQUENCE, WEAK */ + +/* Applies a :KEY argument. + funcall_key(key,item); + > key: value of the :KEY argument + > item: object being considered + < value1: (FUNCALL key item) */ +#define funcall_key(key,item) do { \ + var object _key = (key); \ + var object _item = (item); \ + GCTRIGGER2(_key,_item); \ + /* shortcut for :KEY #'IDENTITY, very common */ \ + if (!eq(_key,L(identity))) { \ + pushSTACK(_item); funcall(_key,1); \ + } else { \ + value1 = _item; \ + } \ + } while(0) + +/* Subroutine to compute the test :TEST & :TEST-NOT + call_test(fun,item,x) + > *fun: the test function + > item: the item to compare with + > x: the argument + < result: true if the test is okay, otherwise false. + can trigger GC */ +typedef maygc bool funarg_t (const gcv_object_t* fun, object item, object x); +funarg_t call_if, call_if_not; + +/* UP: Check the :TEST, :TEST-NOT - arguments + check_test_args() + > stackptr: Pointer to the STACK + > *(stackptr+1): :TEST argument + > *(stackptr+0): :TEST-NOT argument + < *(stackptr+1): computed :TEST argument + < *(stackptr+0): computed :TEST-NOT argument + < call_test: Adress of a test function */ +extern funarg_t* check_test_args (gcv_object_t* stackptr); + # ####################### LISTBIBL for LIST.D ############################## # # UP: Copies a list @@ -15334,11 +15384,6 @@ %% puts("typedef void map_sequence_function_t (void* arg, object element);"); %% puts("extern void map_sequence (object obj, map_sequence_function_t* fun, void* arg);"); -# Error, if both :TEST, :TEST-NOT - argumente have been given. -# error_both_tests(); -nonreturning_function(extern, error_both_tests, (void)); -# is used by LIST, SEQUENCE, WEAK - # ###################### STRMBIBL for STREAM.D ############################# # /* Error message, if an argument isn't a stream: ------------------------------ ------------------------------------------------------------------------- This SF.net email is sponsored by: Microsoft Defy all challenges. Microsoft(R) Visual Studio 2005. http://clk.atdmt.com/MRT/go/vse0120000070mrt/direct/01/ ------------------------------ _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest, Vol 20, Issue 47 ***************************************** |