diff options
| -rw-r--r-- | ChangeLog | 22 | ||||
| -rw-r--r-- | Makefile | 12 | ||||
| -rw-r--r-- | eval.c | 5 | ||||
| -rw-r--r-- | eval.h | 1 | ||||
| -rw-r--r-- | lisplib.c | 16 | ||||
| -rw-r--r-- | share/txr/stdlib/ifa.tl | 44 | ||||
| -rw-r--r-- | txr.c | 7 | ||||
| -rw-r--r-- | txr.h | 1 |
8 files changed, 103 insertions, 5 deletions
@@ -1,5 +1,27 @@ 2015-06-17 Kaz Kylheku <kaz@kylheku.com> + Adding anaphoric ifa macro. + + * Makefile (install): Install .tl files present in stdlib directory. + (INSTALL): Handle argument 2 being a list. + + * eval.c (load): New function. + + * eval.h (load): Declared. + + * lisplib.c (ifa_set_entries, ifa_instantiate): New functions + to lazily load ifa.tl. + (lisplib_init): Register new functions. + + * txr.c (stdlib_path): New variable. + (sysroot_init): Store the stdlib path in stdlib_path. + + * txr.h (stdlib_path): Declared. + + * share/txr/stdlib/ifa.tl: New file. + +2015-06-17 Kaz Kylheku <kaz@kylheku.com> + Refactoring of lisplib.c * lisplib.c (set_dlt_entries): New static function. @@ -345,8 +345,11 @@ define INSTALL $(call ABBREV3,INSTALL,$(3),$(2)) $(V)mkdir -p $(3) $(V)cp -f $(2) $(3) - $(V)chmod $(1) $(3)/$(notdir $(2)) - $(V)for x in $(2) ; do touch -r $$x $(3)/$$(basename $$x) ; done + $(V)for x in $(2) ; do \ + y=$(strip $(3))/$$(basename $$x) ; \ + touch -r $$x $$y ; \ + chmod $(1) $$y ; \ + done endef PREINSTALL := : @@ -358,7 +361,10 @@ install: $(PROG) $(call INSTALL,0444,$(top_srcdir)/LICENSE,$(DESTDIR)$(datadir)) $(call INSTALL,0444,$(top_srcdir)/METALICENSE,$(DESTDIR)$(datadir)) $(call INSTALL,0444,$(top_srcdir)/txr.1,$(DESTDIR)$(mandir)/man1) - $(call INSTALL,0444,$(top_srcdir)/share/txr/stdlib/*.txr,$(DESTDIR)$(datadir)/stdlib) + $(call INSTALL,0444,\ + $(addprefix $(top_srcdir)/share/txr/stdlib/,\ + *.txr *.tl),\ + $(DESTDIR)$(datadir)/stdlib) .PHONY: unixtar gnutar zip @@ -2855,6 +2855,11 @@ static val me_load(val form, val menv) return list(sys_load_s, name, list(quote_s, source_loc(form), nao), nao); } +val load(val target) +{ + return sys_load(target, nil); +} + static val expand_catch_clause(val form, val menv) { val sym = first(form); @@ -43,6 +43,7 @@ val apply_intrinsic(val fun, val args); val eval_progn(val forms, val env, val ctx_form); val eval(val form, val env, val ctx_form); val eval_intrinsic(val form, val env); +val load(val target); val expand(val form, val menv); val expand_forms(val forms, val menv); val bindable(val obj); @@ -36,6 +36,7 @@ #include "hash.h" #include "gc.h" #include "place.h" +#include "txr.h" #include "lisplib.h" static val dl_table; @@ -82,6 +83,20 @@ static val place_instantiate(val set_fun) colon_k, lit("place.tl")), nil); } +static val ifa_set_entries(val dlt, val fun) +{ + val name[] = { lit("ifa"), nil }; + set_dlt_entries(dlt, name, fun); + return nil; +} + +static val ifa_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(format(nil, lit("~a/ifa.tl"), stdlib_path, nao)); + return nil; +} + static val dlt_register(val dlt, val (*instantiate)(val), val (*set_entries)(val, val)) @@ -94,6 +109,7 @@ void lisplib_init(void) prot1(&dl_table); dl_table = make_hash(nil, nil, nil); dlt_register(dl_table, place_instantiate, place_set_entries); + dlt_register(dl_table, ifa_instantiate, ifa_set_entries); } val lisplib_try_load(val sym) diff --git a/share/txr/stdlib/ifa.tl b/share/txr/stdlib/ifa.tl new file mode 100644 index 00000000..f7c4fcb0 --- /dev/null +++ b/share/txr/stdlib/ifa.tl @@ -0,0 +1,44 @@ +;; 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. + +(defmacro ifa (:env e test then : else) + (flet ((candidate-p (expr) + (not (or (constantp expr e) (symbolp expr))))) + (cond + ((or (atom test) (null (cdr test))) ^(let ((it ,test)) + (if it ,then ,else))) + ((member (first test) '(not null)) ^(ifa ,(second test) ,else ,then)) + (t (let* ((sym (first test)) + (args (rest test)) + (n-candidate-args [count-if candidate-p args]) + (pos-candidate (or [pos-if candidate-p args] 0))) + (unless (fboundp sym) + (error "ifa: only works with global functions.")) + (when (> n-candidate-args 1) + (error "ifa: ambiguous situation: not clear what can be \"it\".")) + (let* ((temps (mapcar (ret (gensym)) args)) + (it-temp [temps pos-candidate])) + ^(let* (,*(zip temps args) (it ,it-temp)) + (if (,sym ,*temps) ,then ,else)))))))) @@ -60,6 +60,7 @@ static const char *progname_u8; static val progpath = nil; int opt_noninteractive; int opt_compat; +val stdlib_path; /* * Can implement an emergency allocator here from a fixed storage @@ -250,12 +251,14 @@ static void sysroot_init(void) val slash = regex_compile(lit("\\\\"), nil); #endif prot1(&progpath); + prot1(&stdlib_path); progpath = get_self_path(); #if HAVE_WINDOWS_H progpath = regsub(slash, lit("/"), progpath); #endif - reg_var(intern(lit("stdlib"), user_package), - sysroot(lit("share/txr/stdlib"))); + stdlib_path = sysroot(lit("share/txr/stdlib")); + + reg_var(intern(lit("stdlib"), user_package), stdlib_path); reg_var(intern(lit("*txr-version*"), user_package), toint(lit(TXR_VER), nil)); } @@ -38,3 +38,4 @@ extern int opt_compat; extern alloc_bytes_t opt_gc_delta; extern const wchli_t *version; extern const wchar_t *progname; +extern val stdlib_path; |