From 6892a6968691e4a5f0965acb83f7e6df202c6007 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Fri, 6 Jun 2014 08:43:00 -0700 Subject: * eval.c (eval_init): Register new search function as intrinsic. * lib.c (search_list): New static function. (search): New function. * lib.h (search): New function declared. * txr.1: Documented. * txr.vim: Regenerated. --- ChangeLog | 13 +++++++++++++ eval.c | 1 + lib.c | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ lib.h | 1 + txr.1 | 51 ++++++++++++++++++++++++++++++++++++++++++++++++ txr.vim | 64 ++++++++++++++++++++++++++++++------------------------------- 6 files changed, 164 insertions(+), 32 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9cbb1bb3..d792a7d9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2014-06-06 Kaz Kylheku + + * eval.c (eval_init): Register new search function as intrinsic. + + * lib.c (search_list): New static function. + (search): New function. + + * lib.h (search): New function declared. + + * txr.1: Documented. + + * txr.vim: Regenerated. + 2014-06-05 Kaz Kylheku * parser.l: Adding an explicit lexical rule to diff --git a/eval.c b/eval.c index 1be989f2..a4f320ab 100644 --- a/eval.c +++ b/eval.c @@ -3528,6 +3528,7 @@ void eval_init(void) reg_fun(intern(lit("refset"), user_package), func_n3(refset)); reg_fun(intern(lit("replace"), user_package), func_n4o(replace, 2)); reg_fun(intern(lit("update"), user_package), func_n2(update)); + reg_fun(intern(lit("search"), user_package), func_n4o(search, 2)); reg_fun(intern(lit("symbol-value"), user_package), func_n1(symbol_value)); reg_fun(intern(lit("symbol-function"), user_package), func_n1(symbol_function)); diff --git a/lib.c b/lib.c index 5c51ed7f..a459f44f 100644 --- a/lib.c +++ b/lib.c @@ -5105,6 +5105,72 @@ val update(val seq, val fun) return seq; } +static val search_list(val seq, val key, val testfun, val keyfun) +{ + val iter, siter, kiter; + val pos = zero; + + switch (type(key)) { + case NIL: + return pos; + case CONS: + case LCONS: + case LIT: + case STR: + case LSTR: + case VEC: + /* TODO: optimize me */ + for (iter = seq; iter; iter = cdr(iter)) { + for (siter = iter, kiter = key; + siter && kiter; + siter = cdr(siter), kiter = cdr(kiter)) + { + if (!funcall2(testfun, + funcall1(keyfun, car(siter)), + funcall1(keyfun, car(kiter)))) + { + pos = plus(pos, one); + break; + } + } + + if (!kiter) + return pos; + + if (!siter) + break; + } + break; + default: + type_mismatch(lit("search: ~s is not a sequence"), cons, nao); + } + + return nil; +} + +val search(val seq, val key, val testfun, val keyfun) +{ + testfun = default_arg(testfun, equal_f); + keyfun = default_arg(keyfun, identity_f); + + switch (type(seq)) { + case NIL: + return if3(length(key) == zero, zero, nil); + case CONS: + case LCONS: + case LIT: + case STR: + case LSTR: + case VEC: + /* TODO: optimize me */ + return search_list(seq, key, testfun, keyfun); + default: + type_mismatch(lit("search: ~s is not a sequence"), cons, nao); + } + + return seq; +} + val env(void) { if (env_list) { diff --git a/lib.h b/lib.h index 3724b6f9..c67866c8 100644 --- a/lib.h +++ b/lib.h @@ -744,6 +744,7 @@ val ref(val seq, val ind); val refset(val seq, val ind, val newval); val replace(val seq, val items, val from, val to); val update(val seq, val fun); +val search(val seq, val key, val from, val to); val env(void); val obj_print(val obj, val stream); val obj_pprint(val obj, val stream); diff --git a/txr.1 b/txr.1 index 2a62737d..e34c5118 100644 --- a/txr.1 +++ b/txr.1 @@ -9918,6 +9918,57 @@ This operation is destructive: it may work "in place" by modifying the original sequence. The caller should retain the return value and stop relying on the original input sequence. +.SS Function search + +.TP +Syntax: + + (search [ []) + +.TP +Description: + +The search function determines whether the sequence occurs as substring +within , under the given comparison function and +key function . If this is the case, then the zero-based position of +the leftmost occurrence of within is returned. Otherwise nil +is returned to indicate that does not occur within . +If is empty, then zero is always returned. + +The arguments and are sequences: lists, vectors +or strings, in any combination. + +If is not empty, then occurs at some position N within if +the first element of matches the element at position N of , +the second element of matches the element at position N+1 of + and so forth, for all elements of . A match between elements +is determined by passing each element through , and then comparing +the resulting values using . + +If is supplied, it must be a function which can be +called with two arguments. If it is not supplied, it defaults to eql. + +If is supplied, it must be a function which can be called +with one argument. If it is not supplied, it deafaults to identity. + +.TP +Examples: + + ;; fails because 3.0 doesn't match 3 under the default eql function + [search #(1.0 3.0 4.0 7.0) '(3 4)] -> nil + + ;; occurrence found at position 1: (3.0 4.0) matches (3 4) under = + [search #(1.0 3.0 4.0 7.0) '(3 4) =] -> 1 + + ;; "even odd odd odd even" pattern matches at position 2 + [search #(1 1 2 3 5 7 8) '(2 1 1 1 2) : evenp] -> 2 + + ;; Case insensitive string search + [search "abcd" "CD" : chr-toupper] -> 2 + + ;; Case insensitive string search using vector of characters as key + [search "abcd" #(#\eC #\eD) : chr-toupper] -> 2 + .SS Functions ref and refset .TP diff --git a/txr.vim b/txr.vim index c2482975..0f52d103 100644 --- a/txr.vim +++ b/txr.vim @@ -139,38 +139,38 @@ syn keyword txl_keyword contained s-ifsock s-irgrp s-iroth s-irusr syn keyword txl_keyword contained s-irwxg s-irwxo s-irwxu s-isgid syn keyword txl_keyword contained s-isuid s-isvtx s-iwgrp s-iwoth syn keyword txl_keyword contained s-iwusr s-ixgrp s-ixoth s-ixusr -syn keyword txl_keyword contained search-regex search-str search-str-tree second -syn keyword txl_keyword contained seek-stream set set-diff set-hash-userdata -syn keyword txl_keyword contained set-sig-handler sethash setlogmask sh -syn keyword txl_keyword contained sig-abrt sig-alrm sig-bus sig-check -syn keyword txl_keyword contained sig-chld sig-cont sig-fpe sig-hup -syn keyword txl_keyword contained sig-ill sig-int sig-io sig-iot -syn keyword txl_keyword contained sig-kill sig-lost sig-pipe sig-poll -syn keyword txl_keyword contained sig-prof sig-pwr sig-quit sig-segv -syn keyword txl_keyword contained sig-stkflt sig-stop sig-sys sig-term -syn keyword txl_keyword contained sig-trap sig-tstp sig-ttin sig-ttou -syn keyword txl_keyword contained sig-urg sig-usr1 sig-usr2 sig-vtalrm -syn keyword txl_keyword contained sig-winch sig-xcpu sig-xfsz sin -syn keyword txl_keyword contained sixth size-vec some sort -syn keyword txl_keyword contained source-loc source-loc-str span-str splice -syn keyword txl_keyword contained split-str split-str-set sqrt stat -syn keyword txl_keyword contained stream-get-prop stream-set-prop streamp string-cmp -syn keyword txl_keyword contained string-extend string-lt stringp sub -syn keyword txl_keyword contained sub-list sub-str sub-vec symacrolet -syn keyword txl_keyword contained symbol-function symbol-name symbol-package symbol-value -syn keyword txl_keyword contained symbolp symlink sys-qquote sys-splice -syn keyword txl_keyword contained sys-unquote syslog tan third -syn keyword txl_keyword contained throw throwf time time-fields-local -syn keyword txl_keyword contained time-fields-utc time-string-local time-string-utc time-usec -syn keyword txl_keyword contained tofloat toint tok-str tostring -syn keyword txl_keyword contained tostringp tree-bind tree-case tree-find -syn keyword txl_keyword contained trie-add trie-compress trim-str trunc -syn keyword txl_keyword contained typeof unget-byte unget-char unless -syn keyword txl_keyword contained unquote until upcase-str update -syn keyword txl_keyword contained url-decode url-encode usleep uw-protect -syn keyword txl_keyword contained vec vec-push vec-set-length vecref -syn keyword txl_keyword contained vector vector-list vectorp when -syn keyword txl_keyword contained while with-saved-vars zerop +syn keyword txl_keyword contained search search-regex search-str search-str-tree +syn keyword txl_keyword contained second seek-stream set set-diff +syn keyword txl_keyword contained set-hash-userdata set-sig-handler sethash setlogmask +syn keyword txl_keyword contained sh sig-abrt sig-alrm sig-bus +syn keyword txl_keyword contained sig-check sig-chld sig-cont sig-fpe +syn keyword txl_keyword contained sig-hup sig-ill sig-int sig-io +syn keyword txl_keyword contained sig-iot sig-kill sig-lost sig-pipe +syn keyword txl_keyword contained sig-poll sig-prof sig-pwr sig-quit +syn keyword txl_keyword contained sig-segv sig-stkflt sig-stop sig-sys +syn keyword txl_keyword contained sig-term sig-trap sig-tstp sig-ttin +syn keyword txl_keyword contained sig-ttou sig-urg sig-usr1 sig-usr2 +syn keyword txl_keyword contained sig-vtalrm sig-winch sig-xcpu sig-xfsz +syn keyword txl_keyword contained sin sixth size-vec some +syn keyword txl_keyword contained sort source-loc source-loc-str span-str +syn keyword txl_keyword contained splice split-str split-str-set sqrt +syn keyword txl_keyword contained stat stream-get-prop stream-set-prop streamp +syn keyword txl_keyword contained string-cmp string-extend string-lt stringp +syn keyword txl_keyword contained sub sub-list sub-str sub-vec +syn keyword txl_keyword contained symacrolet symbol-function symbol-name symbol-package +syn keyword txl_keyword contained symbol-value symbolp symlink sys-qquote +syn keyword txl_keyword contained sys-splice sys-unquote syslog tan +syn keyword txl_keyword contained third throw throwf time +syn keyword txl_keyword contained time-fields-local time-fields-utc time-string-local time-string-utc +syn keyword txl_keyword contained time-usec tofloat toint tok-str +syn keyword txl_keyword contained tostring tostringp tree-bind tree-case +syn keyword txl_keyword contained tree-find trie-add trie-compress trim-str +syn keyword txl_keyword contained trunc typeof unget-byte unget-char +syn keyword txl_keyword contained unless unquote until upcase-str +syn keyword txl_keyword contained update url-decode url-encode usleep +syn keyword txl_keyword contained uw-protect vec vec-push vec-set-length +syn keyword txl_keyword contained vecref vector vector-list vectorp +syn keyword txl_keyword contained when while with-saved-vars zerop syn match txr_error "@[\t ]*[*]\?[\t ]*." syn match txr_nested_error "[^\t `]\+" contained -- cgit v1.2.3