diff options
| -rw-r--r-- | ChangeLog | 22 | ||||
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | cadr.c | 486 | ||||
| -rw-r--r-- | cadr.h | 88 | ||||
| -rw-r--r-- | gencadr.txr | 109 | ||||
| -rw-r--r-- | lib.c | 2 | ||||
| -rw-r--r-- | lisplib.c | 10 | ||||
| -rw-r--r-- | lisplib.h | 6 | ||||
| -rw-r--r-- | share/txr/stdlib/cadr.tl | 1104 | ||||
| -rw-r--r-- | txr.1 | 80 |
10 files changed, 1903 insertions, 6 deletions
@@ -1,5 +1,27 @@ 2015-07-21 Kaz Kylheku <kaz@kylheku.com> + Implementing caar, cadr, cdar and friends. + + * lib.c (init): Call cadr_init. + + * lisplib.c (dl_table, set_dlt_entries, dlt_register): Externalize. + + * lisplib.h (dl_table, set_dlt_entries, dlt_register): Declared. + + * Makefile (OBJS): Add cadr.o. + + * cadr.c: New file. + + * cadr.h: New file. + + * gencadr.txr: New file. + + * share/txr/stdlib/cadr.tl: New file. + + * txr.1: Document cadr accessors. + +2015-07-21 Kaz Kylheku <kaz@kylheku.com> + * share/txr/stdlib/place.tl (defplace cdr): Change deletion semantics so that (del (cdr x)) is symmetric with (del (car x)). @@ -46,7 +46,7 @@ EXTRA_OBJS-y := OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o OBJS += arith.o hash.o utf8.o filter.o eval.o parser.o rand.o combi.o sysif.o -OBJS += lisplib.o +OBJS += lisplib.o cadr.o OBJS-$(debug_support) += debug.o OBJS-$(have_syslog) += syslog.o OBJS-$(have_glob) += glob.o @@ -0,0 +1,486 @@ +/* Copyright 2009-2015 + * Kaz Kylheku <kaz@kylheku.com> + * Vancouver, Canada + * All rights reserved. + * + * Redistribution of this software in source and binary forms, with or without + * modification, is permitted provided that the following two conditions are met. + * + * Use of this software in any manner constitutes agreement with the disclaimer + * which follows the two conditions. + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED + * WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED, + * AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#include <stdio.h> +#include <string.h> +#include <dirent.h> +#include <stdarg.h> +#include <stdlib.h> +#include <setjmp.h> +#include <limits.h> +#include <signal.h> +#include "config.h" +#include "lib.h" +#include "gc.h" +#include "signal.h" +#include "unwind.h" +#include "eval.h" +#include "stream.h" +#include "lisplib.h" +#include "txr.h" +#include "cadr.h" + +val caar(val cons) +{ + return car(car(cons)); +} + +val cadr(val cons) +{ + return car(cdr(cons)); +} + +val cdar(val cons) +{ + return cdr(car(cons)); +} + +val cddr(val cons) +{ + return cdr(cdr(cons)); +} + +val caaar(val cons) +{ + return car(car(car(cons))); +} + +val caadr(val cons) +{ + return car(car(cdr(cons))); +} + +val cadar(val cons) +{ + return car(cdr(car(cons))); +} + +val caddr(val cons) +{ + return car(cdr(cdr(cons))); +} + +val cdaar(val cons) +{ + return cdr(car(car(cons))); +} + +val cdadr(val cons) +{ + return cdr(car(cdr(cons))); +} + +val cddar(val cons) +{ + return cdr(cdr(car(cons))); +} + +val cdddr(val cons) +{ + return cdr(cdr(cdr(cons))); +} + +val caaaar(val cons) +{ + return car(car(car(car(cons)))); +} + +val caaadr(val cons) +{ + return car(car(car(cdr(cons)))); +} + +val caadar(val cons) +{ + return car(car(cdr(car(cons)))); +} + +val caaddr(val cons) +{ + return car(car(cdr(cdr(cons)))); +} + +val cadaar(val cons) +{ + return car(cdr(car(car(cons)))); +} + +val cadadr(val cons) +{ + return car(cdr(car(cdr(cons)))); +} + +val caddar(val cons) +{ + return car(cdr(cdr(car(cons)))); +} + +val cadddr(val cons) +{ + return car(cdr(cdr(cdr(cons)))); +} + +val cdaaar(val cons) +{ + return cdr(car(car(car(cons)))); +} + +val cdaadr(val cons) +{ + return cdr(car(car(cdr(cons)))); +} + +val cdadar(val cons) +{ + return cdr(car(cdr(car(cons)))); +} + +val cdaddr(val cons) +{ + return cdr(car(cdr(cdr(cons)))); +} + +val cddaar(val cons) +{ + return cdr(cdr(car(car(cons)))); +} + +val cddadr(val cons) +{ + return cdr(cdr(car(cdr(cons)))); +} + +val cdddar(val cons) +{ + return cdr(cdr(cdr(car(cons)))); +} + +val cddddr(val cons) +{ + return cdr(cdr(cdr(cdr(cons)))); +} + +val caaaaar(val cons) +{ + return car(car(car(car(car(cons))))); +} + +val caaaadr(val cons) +{ + return car(car(car(car(cdr(cons))))); +} + +val caaadar(val cons) +{ + return car(car(car(cdr(car(cons))))); +} + +val caaaddr(val cons) +{ + return car(car(car(cdr(cdr(cons))))); +} + +val caadaar(val cons) +{ + return car(car(cdr(car(car(cons))))); +} + +val caadadr(val cons) +{ + return car(car(cdr(car(cdr(cons))))); +} + +val caaddar(val cons) +{ + return car(car(cdr(cdr(car(cons))))); +} + +val caadddr(val cons) +{ + return car(car(cdr(cdr(cdr(cons))))); +} + +val cadaaar(val cons) +{ + return car(cdr(car(car(car(cons))))); +} + +val cadaadr(val cons) +{ + return car(cdr(car(car(cdr(cons))))); +} + +val cadadar(val cons) +{ + return car(cdr(car(cdr(car(cons))))); +} + +val cadaddr(val cons) +{ + return car(cdr(car(cdr(cdr(cons))))); +} + +val caddaar(val cons) +{ + return car(cdr(cdr(car(car(cons))))); +} + +val caddadr(val cons) +{ + return car(cdr(cdr(car(cdr(cons))))); +} + +val cadddar(val cons) +{ + return car(cdr(cdr(cdr(car(cons))))); +} + +val caddddr(val cons) +{ + return car(cdr(cdr(cdr(cdr(cons))))); +} + +val cdaaaar(val cons) +{ + return cdr(car(car(car(car(cons))))); +} + +val cdaaadr(val cons) +{ + return cdr(car(car(car(cdr(cons))))); +} + +val cdaadar(val cons) +{ + return cdr(car(car(cdr(car(cons))))); +} + +val cdaaddr(val cons) +{ + return cdr(car(car(cdr(cdr(cons))))); +} + +val cdadaar(val cons) +{ + return cdr(car(cdr(car(car(cons))))); +} + +val cdadadr(val cons) +{ + return cdr(car(cdr(car(cdr(cons))))); +} + +val cdaddar(val cons) +{ + return cdr(car(cdr(cdr(car(cons))))); +} + +val cdadddr(val cons) +{ + return cdr(car(cdr(cdr(cdr(cons))))); +} + +val cddaaar(val cons) +{ + return cdr(cdr(car(car(car(cons))))); +} + +val cddaadr(val cons) +{ + return cdr(cdr(car(car(cdr(cons))))); +} + +val cddadar(val cons) +{ + return cdr(cdr(car(cdr(car(cons))))); +} + +val cddaddr(val cons) +{ + return cdr(cdr(car(cdr(cdr(cons))))); +} + +val cdddaar(val cons) +{ + return cdr(cdr(cdr(car(car(cons))))); +} + +val cdddadr(val cons) +{ + return cdr(cdr(cdr(car(cdr(cons))))); +} + +val cddddar(val cons) +{ + return cdr(cdr(cdr(cdr(car(cons))))); +} + +val cdddddr(val cons) +{ + return cdr(cdr(cdr(cdr(cdr(cons))))); +} + +static val cadr_register(val set_fun) +{ + funcall1(set_fun, nil); + reg_fun(intern(lit("caar"), user_package), func_n1(caar)); + reg_fun(intern(lit("cadr"), user_package), func_n1(cadr)); + reg_fun(intern(lit("cdar"), user_package), func_n1(cdar)); + reg_fun(intern(lit("cddr"), user_package), func_n1(cddr)); + reg_fun(intern(lit("caaar"), user_package), func_n1(caaar)); + reg_fun(intern(lit("caadr"), user_package), func_n1(caadr)); + reg_fun(intern(lit("cadar"), user_package), func_n1(cadar)); + reg_fun(intern(lit("caddr"), user_package), func_n1(caddr)); + reg_fun(intern(lit("cdaar"), user_package), func_n1(cdaar)); + reg_fun(intern(lit("cdadr"), user_package), func_n1(cdadr)); + reg_fun(intern(lit("cddar"), user_package), func_n1(cddar)); + reg_fun(intern(lit("cdddr"), user_package), func_n1(cdddr)); + reg_fun(intern(lit("caaaar"), user_package), func_n1(caaaar)); + reg_fun(intern(lit("caaadr"), user_package), func_n1(caaadr)); + reg_fun(intern(lit("caadar"), user_package), func_n1(caadar)); + reg_fun(intern(lit("caaddr"), user_package), func_n1(caaddr)); + reg_fun(intern(lit("cadaar"), user_package), func_n1(cadaar)); + reg_fun(intern(lit("cadadr"), user_package), func_n1(cadadr)); + reg_fun(intern(lit("caddar"), user_package), func_n1(caddar)); + reg_fun(intern(lit("cadddr"), user_package), func_n1(cadddr)); + reg_fun(intern(lit("cdaaar"), user_package), func_n1(cdaaar)); + reg_fun(intern(lit("cdaadr"), user_package), func_n1(cdaadr)); + reg_fun(intern(lit("cdadar"), user_package), func_n1(cdadar)); + reg_fun(intern(lit("cdaddr"), user_package), func_n1(cdaddr)); + reg_fun(intern(lit("cddaar"), user_package), func_n1(cddaar)); + reg_fun(intern(lit("cddadr"), user_package), func_n1(cddadr)); + reg_fun(intern(lit("cdddar"), user_package), func_n1(cdddar)); + reg_fun(intern(lit("cddddr"), user_package), func_n1(cddddr)); + reg_fun(intern(lit("caaaaar"), user_package), func_n1(caaaaar)); + reg_fun(intern(lit("caaaadr"), user_package), func_n1(caaaadr)); + reg_fun(intern(lit("caaadar"), user_package), func_n1(caaadar)); + reg_fun(intern(lit("caaaddr"), user_package), func_n1(caaaddr)); + reg_fun(intern(lit("caadaar"), user_package), func_n1(caadaar)); + reg_fun(intern(lit("caadadr"), user_package), func_n1(caadadr)); + reg_fun(intern(lit("caaddar"), user_package), func_n1(caaddar)); + reg_fun(intern(lit("caadddr"), user_package), func_n1(caadddr)); + reg_fun(intern(lit("cadaaar"), user_package), func_n1(cadaaar)); + reg_fun(intern(lit("cadaadr"), user_package), func_n1(cadaadr)); + reg_fun(intern(lit("cadadar"), user_package), func_n1(cadadar)); + reg_fun(intern(lit("cadaddr"), user_package), func_n1(cadaddr)); + reg_fun(intern(lit("caddaar"), user_package), func_n1(caddaar)); + reg_fun(intern(lit("caddadr"), user_package), func_n1(caddadr)); + reg_fun(intern(lit("cadddar"), user_package), func_n1(cadddar)); + reg_fun(intern(lit("caddddr"), user_package), func_n1(caddddr)); + reg_fun(intern(lit("cdaaaar"), user_package), func_n1(cdaaaar)); + reg_fun(intern(lit("cdaaadr"), user_package), func_n1(cdaaadr)); + reg_fun(intern(lit("cdaadar"), user_package), func_n1(cdaadar)); + reg_fun(intern(lit("cdaaddr"), user_package), func_n1(cdaaddr)); + reg_fun(intern(lit("cdadaar"), user_package), func_n1(cdadaar)); + reg_fun(intern(lit("cdadadr"), user_package), func_n1(cdadadr)); + reg_fun(intern(lit("cdaddar"), user_package), func_n1(cdaddar)); + reg_fun(intern(lit("cdadddr"), user_package), func_n1(cdadddr)); + reg_fun(intern(lit("cddaaar"), user_package), func_n1(cddaaar)); + reg_fun(intern(lit("cddaadr"), user_package), func_n1(cddaadr)); + reg_fun(intern(lit("cddadar"), user_package), func_n1(cddadar)); + reg_fun(intern(lit("cddaddr"), user_package), func_n1(cddaddr)); + reg_fun(intern(lit("cdddaar"), user_package), func_n1(cdddaar)); + reg_fun(intern(lit("cdddadr"), user_package), func_n1(cdddadr)); + reg_fun(intern(lit("cddddar"), user_package), func_n1(cddddar)); + reg_fun(intern(lit("cdddddr"), user_package), func_n1(cdddddr)); + load(format(nil, lit("~a/cadr.tl"), stdlib_path, nao)); + return nil; +} + +static val cadr_set_entries(val dlt, val fun) +{ + val name[] = { + lit("caar"), + lit("cadr"), + lit("cdar"), + lit("cddr"), + lit("caaar"), + lit("caadr"), + lit("cadar"), + lit("caddr"), + lit("cdaar"), + lit("cdadr"), + lit("cddar"), + lit("cdddr"), + lit("caaaar"), + lit("caaadr"), + lit("caadar"), + lit("caaddr"), + lit("cadaar"), + lit("cadadr"), + lit("caddar"), + lit("cadddr"), + lit("cdaaar"), + lit("cdaadr"), + lit("cdadar"), + lit("cdaddr"), + lit("cddaar"), + lit("cddadr"), + lit("cdddar"), + lit("cddddr"), + lit("caaaaar"), + lit("caaaadr"), + lit("caaadar"), + lit("caaaddr"), + lit("caadaar"), + lit("caadadr"), + lit("caaddar"), + lit("caadddr"), + lit("cadaaar"), + lit("cadaadr"), + lit("cadadar"), + lit("cadaddr"), + lit("caddaar"), + lit("caddadr"), + lit("cadddar"), + lit("caddddr"), + lit("cdaaaar"), + lit("cdaaadr"), + lit("cdaadar"), + lit("cdaaddr"), + lit("cdadaar"), + lit("cdadadr"), + lit("cdaddar"), + lit("cdadddr"), + lit("cddaaar"), + lit("cddaadr"), + lit("cddadar"), + lit("cddaddr"), + lit("cdddaar"), + lit("cdddadr"), + lit("cddddar"), + lit("cdddddr"), + nil + }; + + set_dlt_entries(dlt, name, fun); + return nil; +} + +void cadr_init(void) +{ + dlt_register(dl_table, cadr_register, cadr_set_entries); +} @@ -0,0 +1,88 @@ +/* Copyright 2009-2015 + * Kaz Kylheku <kaz@kylheku.com> + * Vancouver, Canada + * All rights reserved. + * + * Redistribution of this software in source and binary forms, with or without + * modification, is permitted provided that the following two conditions are met. + * + * Use of this software in any manner constitutes agreement with the disclaimer + * which follows the two conditions. + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED + * WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL THE + * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED, + * AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +val caar(val); +val cadr(val); +val cdar(val); +val cddr(val); +val caaar(val); +val caadr(val); +val cadar(val); +val caddr(val); +val cdaar(val); +val cdadr(val); +val cddar(val); +val cdddr(val); +val caaaar(val); +val caaadr(val); +val caadar(val); +val caaddr(val); +val cadaar(val); +val cadadr(val); +val caddar(val); +val cadddr(val); +val cdaaar(val); +val cdaadr(val); +val cdadar(val); +val cdaddr(val); +val cddaar(val); +val cddadr(val); +val cdddar(val); +val cddddr(val); +val caaaaar(val); +val caaaadr(val); +val caaadar(val); +val caaaddr(val); +val caadaar(val); +val caadadr(val); +val caaddar(val); +val caadddr(val); +val cadaaar(val); +val cadaadr(val); +val cadadar(val); +val cadaddr(val); +val caddaar(val); +val caddadr(val); +val cadddar(val); +val caddddr(val); +val cdaaaar(val); +val cdaaadr(val); +val cdaadar(val); +val cdaaddr(val); +val cdadaar(val); +val cdadadr(val); +val cdaddar(val); +val cdadddr(val); +val cddaaar(val); +val cddaadr(val); +val cddadar(val); +val cddaddr(val); +val cdddaar(val); +val cdddadr(val); +val cddddar(val); +val cdddddr(val); + +void cadr_init(void); diff --git a/gencadr.txr b/gencadr.txr new file mode 100644 index 00000000..f21386fd --- /dev/null +++ b/gencadr.txr @@ -0,0 +1,109 @@ +@(bind ad @(append-each* ((i (range 2 5))) (rperm "ad" i))) +@(do + (defun compile-ad (string arg) + (casequal string + ("" arg) + (t `c@[string 0]r(@(compile-ad [string 1..:] arg))`)))) +@(next "lib.c") +@(collect) +@{c-copyright} +@(until) + +@(end) +@(next "share/txr/stdlib/place.tl") +@(collect) +@{tl-copyright} +@(until) + +@(end) +@(output "cadr.c") +@{c-copyright "\n"} + +#include <stdio.h> +#include <string.h> +#include <dirent.h> +#include <stdarg.h> +#include <stdlib.h> +#include <setjmp.h> +#include <limits.h> +#include <signal.h> +#include "config.h" +#include "lib.h" +#include "gc.h" +#include "signal.h" +#include "unwind.h" +#include "eval.h" +#include "stream.h" +#include "lisplib.h" +#include "txr.h" +#include "cadr.h" +@ (repeat) + +val c@{ad}r(val cons) +{ + return @(compile-ad ad 'cons); +} +@ (end) + +static val cadr_register(val set_fun) +{ + funcall1(set_fun, nil); +@ (repeat) + reg_fun(intern(lit("c@{ad}r"), user_package), func_n1(c@{ad}r)); +@ (end) + load(format(nil, lit("~a/cadr.tl"), stdlib_path, nao)); + return nil; +} + +static val cadr_set_entries(val dlt, val fun) +{ + val name[] = { +@ (repeat) + lit("c@{ad}r"), +@ (end) + nil + }; + + set_dlt_entries(dlt, name, fun); + return nil; +} + +void cadr_init(void) +{ + dlt_register(dl_table, cadr_register, cadr_set_entries); +} +@(end) +@(output "cadr.h") +@{c-copyright "\n"} + +@ (repeat) +val c@{ad}r(val); +@ (end) + +void cadr_init(void); +@(end) +@(output "share/txr/stdlib/cadr.tl") +@{tl-copyright "\n"} +@ (repeat) + +(defplace (c@{ad}r cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (c@{ad [1..:]}r ,cell))) + (macrolet ((,getter () ^(c@{ad [0]}r ,',cell-sym)) + (,setter (val) ^(sys:rplac@{ad [0]} ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplac@{ad [0]} (c@{ad [1..:]}r ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(c@{ad [1..:]}r ,cell) nil + ^(let ((,tmp (,cgetter))) + @(if (equal [ad 0] #\a) + `(prog1 (car ,tmp) (,csetter (cdr ,tmp)))` + `(prog1 (cdr ,tmp) (,csetter (car ,tmp)))`)))))) + ,body))) +@ (end) +@(end) @@ -60,6 +60,7 @@ #include "parser.h" #include "syslog.h" #include "glob.h" +#include "cadr.h" #include "txr.h" #define max(a, b) ((a) > (b) ? (a) : (b)) @@ -7450,6 +7451,7 @@ void init(const wchar_t *pn, mem_t *(*oom)(mem_t *, size_t), #if HAVE_GLOB glob_init(); #endif + cadr_init(); gc_state(gc_save); } @@ -38,9 +38,9 @@ #include "txr.h" #include "lisplib.h" -static val dl_table; +val dl_table; -static void set_dlt_entries(val dlt, val *name, val fun) +void set_dlt_entries(val dlt, val *name, val fun) { for (; *name; name++) { val sym = intern(*name, user_package); @@ -126,9 +126,9 @@ static val txr_case_instantiate(val set_fun) return nil; } -static val dlt_register(val dlt, - val (*instantiate)(val), - val (*set_entries)(val, val)) +val dlt_register(val dlt, + val (*instantiate)(val), + val (*set_entries)(val, val)) { return set_entries(dl_table, func_f0(func_f1(dlt, set_entries), instantiate)); } @@ -24,5 +24,11 @@ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ +extern val dl_table; + void lisplib_init(void); val lisplib_try_load(val sym); +void set_dlt_entries(val dlt, val *name, val fun); +val dlt_register(val dlt, + val (*instantiate)(val), + val (*set_entries)(val, val)); diff --git a/share/txr/stdlib/cadr.tl b/share/txr/stdlib/cadr.tl new file mode 100644 index 00000000..7516094d --- /dev/null +++ b/share/txr/stdlib/cadr.tl @@ -0,0 +1,1104 @@ +;; Copyright 2015 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution of this software in source and binary forms, with or without +;; modification, is permitted provided that the following two conditions are met. +;; +;; Use of this software in any manner constitutes agreement with the disclaimer +;; which follows the two conditions. +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED +;; WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL THE +;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED, +;; AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defplace (caar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (car ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (car ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(car ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cdar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (car ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (car ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(car ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (caaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cdaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (caaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cdaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (caaaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caaaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caaadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caadar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caaddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caddar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdaaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdaadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdadar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdaddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdddar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cdaaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caaaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caaadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caadar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caaddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (caddar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cadddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdaaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdaadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdadar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdaddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cdddar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(rlet ((,cell-sym (cddddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) @@ -14171,6 +14171,86 @@ then .code nil is returned. +.coNP Accessors @, caar @, cadr @, cdar @, cddr ... @ cdddddr +.synb +.mets (caar << object ) +.mets (cadr << object ) +.mets (cdar << object ) +.mets (cddr << object ) +.mets ... +.mets (cdddr << object ) +.mets (set (caar << object ) << new-value ) +.mets (set (cadr << object ) << new-value ) +.mets ... +.syne +.desc +The +.I a-d accessors +provide a shorthand notation for accessing two to five +levels deep into a cons-cell-based tree structure. For instance, the +the equivalent of the nested function call expression +.cblk +.meti (car (car (cdr << object ))) +.cble +can be achieved using the single function call +.cblk +.meti (caadr << object ). +The symbol names of the a-d accessors are a generalization of the words +"car" and "cdr". They encodes the pattern of +.code car +and +.code cdr +traversal of the structure using a sequence of the the letters +.code a +and +.code d +placed between +.code c +and +.codn r . +The traversal is encoded in right-to-left order, so that +.code cadr +indicates a traversal of the +.code cdr +link, followed by the +.codn car . +This order corresponds to the nested function call notation, which also +encodes the traversal right-to-left. The following diagram illustrates +the straightforward relationship: +.cblk + (cdr (car (cdr x))) + ^ ^ ^ + | / | + | / / + | / ____/ + || / + (cdadr x) +.cble + +\*(TL provides all possible a-d accessors up to five levels deep, from +.code caar +all the way through +.codn cdddddr . + +Expressions involving a-d accessors are places. For example, +.code (caddr x) +denotes the same place as +.codn (car (cddr x)) , +and +.code (cdadr x) +denotes the same place as +.codn (cdr (cadr x)) . + +The a-d accessor places support deletion, with semantics derived from +the deletion semantics of the +.code car +and +.code cdr +places. For example, +.code (del (caddr x)) +means the same as +.code (del (car (cddr x))) . + .coNP Functions @ flatten and @ flatten* .synb .mets (flatten << list ) |