├── .circleci └── config.yml ├── .gitattributes ├── .gitignore ├── CHANGES ├── COPYING ├── INSTALL ├── Makefile.in ├── README.md ├── access.c ├── closure.c ├── configure.ac ├── conv.c ├── dict.c ├── doc ├── ERRATA ├── TODO ├── es-list.gz ├── es.1 └── usenix-w93.ps ├── dump.c ├── es.h ├── esconfig.h ├── esdebug ├── eval.c ├── examples ├── 99bottles.es ├── adventure.es ├── cd_colourprompt.es ├── cd_follow-symbolic.es ├── cd_history.es ├── cdpath.es ├── es-mode.el ├── esrc.haahr ├── friedman │ ├── README │ ├── lib │ │ ├── =TODO │ │ ├── Y.es │ │ ├── array.es │ │ ├── churchnum.es │ │ ├── compress.es │ │ ├── compresstbl.es │ │ ├── date.es │ │ ├── dirs.es │ │ ├── equal.es │ │ ├── exec.es │ │ ├── exports.es │ │ ├── hash.es │ │ ├── help.es │ │ ├── hook.es │ │ ├── list.es │ │ ├── load.es │ │ ├── mailcheck.es │ │ ├── mkautoloads.es │ │ ├── path-list.es │ │ ├── plist.es │ │ ├── primitives.es │ │ ├── prompt.es │ │ ├── repeat.es │ │ ├── repl.es │ │ ├── require.es │ │ ├── setterm.es │ │ ├── stack.es │ │ ├── subr.es │ │ ├── type-pred.es │ │ ├── which.es │ │ └── y-or-n-p.es │ ├── main │ │ ├── env.es │ │ ├── esrc.es │ │ ├── misc.es │ │ ├── options.es │ │ ├── settor.es │ │ └── startup.es │ ├── os │ │ └── sunos4.1.es │ └── term │ │ ├── emacs.es │ │ ├── sun.es │ │ └── vt100.es ├── jamesh.esrc ├── number.es └── sh_compat ├── except.c ├── fd.c ├── gc.c ├── gc.h ├── glob.c ├── glom.c ├── heredoc.c ├── history.c ├── initial.es ├── input.c ├── input.h ├── list.c ├── m4 └── readline.m4 ├── main.c ├── match.c ├── mksignal ├── open.c ├── opt.c ├── parse.y ├── prim-ctl.c ├── prim-etc.c ├── prim-io.c ├── prim-sys.c ├── prim.c ├── prim.h ├── print.c ├── print.h ├── proc.c ├── release.es ├── share ├── autoload.es ├── cdpath.es ├── interactive-init.es ├── path-cache.es └── status.es ├── sigmsgs.h ├── signal.c ├── split.c ├── status.c ├── stdenv.h ├── str.c ├── syntax.c ├── syntax.h ├── term.c ├── term.h ├── test ├── test.es ├── testrun.c └── tests │ ├── access.es │ ├── example.es │ ├── glob.es │ ├── match.es │ ├── option.es │ ├── regression.es │ ├── syntax.es │ ├── trip.es │ └── wait.es ├── token.c ├── tree.c ├── util.c ├── var.c ├── var.h ├── vec.c └── version.c /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: cimg/base:stable 6 | 7 | steps: 8 | - checkout 9 | 10 | - run: 11 | name: Install dependencies 12 | command: | 13 | sudo apt-get update 14 | sudo apt-get install -qy make gcc libtool autoconf automake bison libreadline-dev 15 | 16 | - run: 17 | name: Autotools 18 | command: | 19 | libtoolize -qi 20 | autoreconf 21 | 22 | - run: 23 | name: Configure 24 | command: ./configure --enable-strict --with-readline 25 | 26 | - run: 27 | name: Build 28 | command: make 29 | 30 | - run: 31 | name: Build test helper 32 | command: make testrun 33 | 34 | - persist_to_workspace: 35 | root: . 36 | paths: 37 | - es 38 | - testrun 39 | 40 | test: 41 | docker: 42 | - image: cimg/base:stable 43 | 44 | steps: 45 | - checkout 46 | 47 | - attach_workspace: 48 | at: . 49 | 50 | - run: 51 | name: Test 52 | command: | 53 | mkdir -p ./test/results 54 | ./es -ps < ./test/test.es --junit ./test/tests/* > ./test/results/results.xml 55 | 56 | - store_artifacts: 57 | path: ./test/results/ 58 | 59 | - store_test_results: 60 | path: ./test/results/ 61 | 62 | 63 | workflows: 64 | version: 2 65 | build_and_test: 66 | jobs: 67 | - build 68 | - test: 69 | requires: 70 | - build 71 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | test/tests/trip.es text diff 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # c 2 | *.o 3 | 4 | # http://www.gnu.org/software/autoconf 5 | 6 | autom4te.cache 7 | /autoscan.log 8 | /autoscan-*.log 9 | /aclocal.m4 10 | /compile 11 | /config.cache 12 | /config.guess 13 | /config.h.in 14 | /config.log 15 | /config.status 16 | /config.sub 17 | /configure 18 | /configure.scan 19 | /depcomp 20 | /install-sh 21 | /missing 22 | /stamp-h1 23 | /ltmain.sh 24 | /m4/libtool.m4 25 | /m4/ltoptions.m4 26 | /m4/ltsugar.m4 27 | /m4/ltversion.m4 28 | /m4/lt~obsolete.m4 29 | /config.h.in~ 30 | /configure~ 31 | 32 | Makefile 33 | config.h 34 | 35 | # yacc 36 | 37 | y.* 38 | 39 | # es 40 | 41 | initial.c 42 | sigmsgs.c 43 | token.h 44 | es 45 | esdump 46 | testrun 47 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Es is in the public domain. We hold no copyrights or patents on 2 | the source code, and do not place any restrictions on its distribution. 3 | We would appreciate it if any distributions do credit the authors. 4 | 5 | Enjoy! 6 | 7 | -- Paul Haahr & Byron Rakitzis 8 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | Basic Installation 2 | ------------------ 3 | 4 | Es uses the GNU configure system for configuration. This means that 5 | on nearly all platforms, it should just build and work fine. To do 6 | this, just type: 7 | 8 | % ./configure 9 | % make 10 | 11 | If you're building from the source repository rather than a 12 | distribution, it won't have a generated configure file. To generate it, 13 | you'll need to have autotools, and run: 14 | 15 | % libtoolize -qi 16 | % autoreconf 17 | 18 | Libtoolize -qi installs a bunch of dependencies that we'd otherwise 19 | get from automake, except that we're not actually using automake so 20 | we ask libtoolize to do the work. 21 | 22 | Es needs an ANSI compiler (or at least a compiler that respects 23 | protoypes and provides large portions of the ANSI library). 24 | Otherwise it should build with the basic tools available on most UNIX 25 | platforms. Es expects a POSIX.1-2001 compliant OS and C library. 26 | 27 | Es obeys the GNU configure convention of allowing you to build in 28 | a directory different from the source directory. To do this, just 29 | execute configure with a path to the source. For example: 30 | 31 | % /path/to/configure 32 | 33 | Also obeying the GNU configure convention, configure will take 34 | arguments specifying a variety of directories. Currently the only 35 | relevant ones are the prefix directory (/usr/local by default); bindir, 36 | the directory in which `es' will reside ($prefix/bin by default); 37 | mandir, the directory that will contain the manpage ($prefix/man by 38 | default); and datadir, the directory that will contain the es script 39 | library ($prefix/share by default). These are given to configure by: 40 | 41 | % ./configure --prefix=directory 42 | % ./configure --bindir=directory --mandir=directory 43 | 44 | Similarly, setting the `CC', `CFLAGS', and `LDFLAGS' environment 45 | variables will cause those to be used in the Makefile. 46 | 47 | Es Options 48 | ---------- 49 | 50 | Es can be built to link with GNU readline. Readline may be used by 51 | providing the --with-readline flag to ./configure. By default, readline 52 | is enabled if autoconf is able to find a working readline present on the 53 | system; to manually disable it, ./configure --without-readline. 54 | 55 | Problems with building 56 | ---------------------- 57 | 58 | OpenBSD requires some additional hoop-jumping to build from source. 59 | A recently successful installation required the following commands 60 | before ./configure. Note that your locally installed autotool versions 61 | may differ. 62 | 63 | % libtoolize -qi 64 | % AUTOMAKE_VERSION=1.16 AUTOCONF_VERSION=2.71 autoreconf 65 | 66 | In addition, OpenBSD has, by default, a very old version of readline 67 | installed, with which ./configure will detect and attempt to link. To 68 | use the more up-to-date readline library available, the following is 69 | required: 70 | 71 | % doas pkg_add readline # your exact command may differ 72 | % ./configure \ 73 | --mandir=/usr/local/man \ 74 | --with-readline \ 75 | READLINE_CFLAGS=-I/usr/local/include/ereadline \ 76 | READLINE_LIBS='-L/usr/local/lib -lereadline' 77 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![CircleCI](https://circleci.com/gh/wryun/es-shell.svg?style=svg)](https://circleci.com/gh/wryun/es-shell) 2 | 3 | Es is an extensible shell. The language was derived from the Plan 9 4 | shell, rc, and was influenced by functional programming languages, 5 | such as Scheme, and the Tcl embeddable programming language. This 6 | implementation is derived from Byron Rakitzis's public domain 7 | implementation of rc. 8 | 9 | See the INSTALL file for installation instructions. Once it's running 10 | have a look at the manual page and the docs and examples directories, 11 | in particular Haahr & Rakitzis's paper: ``Es: a shell with higher-order 12 | functions.'' The paper corresponds to a slightly older version of the 13 | shell; see the file ERRATA for changes which affect parts of the paper. 14 | 15 | The file initial.es, which is used to build the initial memory state of 16 | the es interpreter, can be read to better understand how pieces of the 17 | shell interact. 18 | 19 | The official ftp site (associated with the original authors) is at: 20 | 21 | ftp://ftp.sys.utoronto.ca/pub/es 22 | 23 | but all of the relevant information is mirrored in the repository and/or 24 | the website: 25 | 26 | http://www.github.com/wryun/es-shell 27 | http://wryun.github.io/es-shell 28 | 29 | including the change history and the old mailing list archives. 30 | 31 | An old version of Paul's .esrc (es startup) file is provided as an 32 | example as esrc.haahr; correctness is not guaranteed. A simple 33 | debugger for es scripts, esdebug, is also included; this is very 34 | untested and should be considered little more than a sketch of a few 35 | ideas. 36 | 37 | Copyright 38 | --------- 39 | 40 | Es is in the public domain. We hold no copyrights or patents on 41 | the source code, and do not place any restrictions on its distribution. 42 | We would appreciate it if any distributions do credit the authors. 43 | 44 | Enjoy! 45 | 46 | -- Paul Haahr & Byron Rakitzis 47 | 48 | Maintenance by: 49 | - Soren Dayton (0.9beta1) 50 | - James Haggerty (post 0.9beta1) 51 | -------------------------------------------------------------------------------- /access.c: -------------------------------------------------------------------------------- 1 | /* access.c -- access testing and path searching ($Revision: 1.2 $) */ 2 | 3 | #define REQUIRE_STAT 1 4 | #define REQUIRE_PARAM 1 5 | 6 | #include "es.h" 7 | #include "prim.h" 8 | 9 | #define READ 4 10 | #define WRITE 2 11 | #define EXEC 1 12 | 13 | #define USER 6 14 | #define GROUP 3 15 | #define OTHER 0 16 | 17 | #define IFREG 1 18 | #define IFDIR 2 19 | #define IFCHR 3 20 | #define IFBLK 4 21 | #define IFLNK 5 22 | #define IFSOCK 6 23 | #define IFIFO 7 24 | 25 | /* ingroupset -- determine whether gid lies in the user's set of groups */ 26 | static Boolean ingroupset(gidset_t gid) { 27 | int i; 28 | static int ngroups; 29 | static gidset_t *gidset; 30 | static Boolean initialized = FALSE; 31 | if (!initialized) { 32 | ngroups = getgroups(0, NULL); 33 | if (ngroups == -1) 34 | fail("$&access", "getgroups: %s", esstrerror(errno)); 35 | gidset = ealloc(ngroups * sizeof(gidset_t)); 36 | assert(getgroups(ngroups, gidset) != -1); 37 | initialized = TRUE; 38 | } 39 | for (i = 0; i < ngroups; i++) 40 | if (gid == gidset[i]) 41 | return TRUE; 42 | return FALSE; 43 | } 44 | 45 | static int testperm(struct stat *stat, unsigned int perm) { 46 | unsigned int mask; 47 | static gidset_t uid, gid; 48 | static Boolean initialized = FALSE; 49 | if (perm == 0) 50 | return 0; 51 | if (!initialized) { 52 | initialized = TRUE; 53 | uid = geteuid(); 54 | gid = getegid(); 55 | } 56 | mask = (uid == 0) 57 | ? (perm << USER) | (perm << GROUP) | (perm << OTHER) 58 | : (perm << 59 | ((uid == stat->st_uid) 60 | ? USER 61 | : ((gid == stat->st_gid || ingroupset(stat->st_gid)) 62 | ? GROUP 63 | : OTHER))); 64 | return (stat->st_mode & mask) == mask ? 0 : EACCES; 65 | } 66 | 67 | static int testfile(char *path, unsigned int perm, unsigned int type) { 68 | struct stat st; 69 | if ((type == IFLNK ? lstat(path, &st) : stat(path, &st)) == -1) 70 | return errno; 71 | /* is EACCES the right return value? */ 72 | switch(type) { 73 | case IFREG: if (!S_ISREG(st.st_mode)) return EACCES; break; 74 | case IFDIR: if (!S_ISDIR(st.st_mode)) return EACCES; break; 75 | case IFBLK: if (!S_ISBLK(st.st_mode)) return EACCES; break; 76 | case IFLNK: if (!S_ISLNK(st.st_mode)) return EACCES; break; 77 | case IFSOCK: if (!S_ISSOCK(st.st_mode)) return EACCES; break; 78 | case IFIFO: if (!S_ISFIFO(st.st_mode)) return EACCES; break; 79 | } 80 | return testperm(&st, perm); 81 | } 82 | 83 | static char *pathcat(char *prefix, char *suffix) { 84 | char *s; 85 | size_t plen, slen, len; 86 | static char *pathbuf = NULL; 87 | static size_t pathlen = 0; 88 | 89 | if (*prefix == '\0') 90 | return suffix; 91 | if (*suffix == '\0') 92 | return prefix; 93 | 94 | plen = strlen(prefix); 95 | slen = strlen(suffix); 96 | len = plen + slen + 2; /* one for '/', one for '\0' */ 97 | if (pathlen < len) { 98 | pathlen = len; 99 | pathbuf = erealloc(pathbuf, pathlen); 100 | } 101 | 102 | memcpy(pathbuf, prefix, plen); 103 | s = pathbuf + plen; 104 | if (s[-1] != '/') 105 | *s++ = '/'; 106 | memcpy(s, suffix, slen + 1); 107 | return pathbuf; 108 | } 109 | 110 | PRIM(access) { 111 | int c, estatus = ENOENT; 112 | unsigned int perm = 0, type = 0; 113 | Boolean first = FALSE, throws = FALSE; 114 | char *suffix = NULL; 115 | List *lp; 116 | const char * const usage = "access [-n name] [-1e] [-rwx] [-fdcblsp] path ..."; 117 | 118 | gcdisable(); 119 | esoptbegin(list, "$&access", usage, TRUE); 120 | while ((c = esopt("bcdefln:prswx1")) != EOF) 121 | switch (c) { 122 | case 'n': suffix = getstr(esoptarg()); break; 123 | case '1': first = TRUE; break; 124 | case 'e': throws = TRUE; break; 125 | case 'r': perm |= READ; break; 126 | case 'w': perm |= WRITE; break; 127 | case 'x': perm |= EXEC; break; 128 | case 'f': type = IFREG; break; 129 | case 'd': type = IFDIR; break; 130 | case 'c': type = IFCHR; break; 131 | case 'b': type = IFBLK; break; 132 | case 'l': type = IFLNK; break; 133 | case 's': type = IFSOCK; break; 134 | case 'p': type = IFIFO; break; 135 | default: 136 | esoptend(); 137 | fail("$&access", "access -%c is not supported on this system", c); 138 | } 139 | list = esoptend(); 140 | 141 | for (lp = NULL; list != NULL; list = list->next) { 142 | int error; 143 | char *name; 144 | 145 | name = getstr(list->term); 146 | if (suffix != NULL) 147 | name = pathcat(name, suffix); 148 | error = testfile(name, perm, type); 149 | 150 | if (first) { 151 | if (error == 0) { 152 | Ref(List *, result, 153 | mklist(mkstr(suffix == NULL 154 | ? name 155 | : gcdup(name)), 156 | NULL)); 157 | gcenable(); 158 | RefReturn(result); 159 | } else if (error != ENOENT) 160 | estatus = error; 161 | } else 162 | lp = mklist(mkstr(error == 0 ? "0" : gcdup(esstrerror(error))), 163 | lp); 164 | } 165 | 166 | if (first && throws) { 167 | gcenable(); 168 | if (suffix) 169 | fail("$&access", "%s: %s", suffix, esstrerror(estatus)); 170 | else 171 | fail("$&access", "%s", esstrerror(estatus)); 172 | } 173 | 174 | Ref(List *, result, reverse(lp)); 175 | gcenable(); 176 | RefReturn(result); 177 | } 178 | 179 | extern Dict *initprims_access(Dict *primdict) { 180 | X(access); 181 | return primdict; 182 | } 183 | 184 | extern char *checkexecutable(char *file) { 185 | int err = testfile(file, EXEC, IFREG); 186 | return err == 0 ? NULL : esstrerror(err); 187 | } 188 | -------------------------------------------------------------------------------- /closure.c: -------------------------------------------------------------------------------- 1 | /* closure.c -- operations on bindings, closures, lambdas, and thunks ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | 6 | /* 7 | * Closure garbage collection support 8 | */ 9 | 10 | DefineTag(Closure, static); 11 | 12 | extern Closure *mkclosure(Tree *tree, Binding *binding) { 13 | gcdisable(); 14 | Ref(Closure *, closure, gcnew(Closure)); 15 | closure->tree = tree; 16 | closure->binding = binding; 17 | gcenable(); 18 | RefReturn(closure); 19 | } 20 | 21 | static void *ClosureCopy(void *op) { 22 | void *np = gcnew(Closure); 23 | memcpy(np, op, sizeof (Closure)); 24 | return np; 25 | } 26 | 27 | static size_t ClosureScan(void *p) { 28 | Closure *closure = p; 29 | closure->tree = forward(closure->tree); 30 | closure->binding = forward(closure->binding); 31 | return sizeof (Closure); 32 | } 33 | 34 | /* revtree -- destructively reverse a list stored in a tree */ 35 | static Tree *revtree(Tree *tree) { 36 | Tree *prev, *next; 37 | if (tree == NULL) 38 | return NULL; 39 | prev = NULL; 40 | do { 41 | assert(tree->kind == nList); 42 | next = tree->u[1].p; 43 | tree->u[1].p = prev; 44 | prev = tree; 45 | } while ((tree = next) != NULL); 46 | return prev; 47 | } 48 | 49 | typedef struct Chain Chain; 50 | struct Chain { 51 | Closure *closure; 52 | Chain *next; 53 | }; 54 | static Chain *chain = NULL; 55 | 56 | static Binding *extract(Tree *tree, Binding *bindings) { 57 | assert(gcisblocked()); 58 | 59 | for (; tree != NULL; tree = tree->u[1].p) { 60 | Tree *defn = tree->u[0].p; 61 | assert(tree->kind == nList); 62 | if (defn != NULL) { 63 | List *list = NULL; 64 | Tree *name = defn->u[0].p; 65 | assert(name->kind == nWord || name->kind == nQword); 66 | defn = revtree(defn->u[1].p); 67 | for (; defn != NULL; defn = defn->u[1].p) { 68 | Term *term; 69 | Tree *word = defn->u[0].p; 70 | NodeKind k = word->kind; 71 | assert(defn->kind == nList); 72 | assert(k == nWord || k == nQword || k == nPrim); 73 | if (k == nPrim) { 74 | char *prim = word->u[0].s; 75 | if (streq(prim, "nestedbinding")) { 76 | int i, count; 77 | Chain *cp; 78 | if ( 79 | (defn = defn->u[1].p) == NULL 80 | || defn->u[0].p->kind != nWord 81 | || (count = (atoi(defn->u[0].p->u[0].s))) < 0 82 | ) { 83 | fail("$&parse", "improper use of $&nestedbinding"); 84 | NOTREACHED; 85 | } 86 | for (cp = chain, i = 0;; cp = cp->next, i++) { 87 | if (cp == NULL) { 88 | fail("$&parse", "bad count in $&nestedbinding: %d", count); 89 | NOTREACHED; 90 | } 91 | if (i == count) 92 | break; 93 | } 94 | term = mkterm(NULL, cp->closure); 95 | } else { 96 | fail("$&parse", "bad unquoted primitive in %%closure: $&%s", prim); 97 | NOTREACHED; 98 | } 99 | } else 100 | term = mkstr(word->u[0].s); 101 | list = mklist(term, list); 102 | } 103 | bindings = mkbinding(name->u[0].s, list, bindings); 104 | } 105 | } 106 | 107 | return bindings; 108 | } 109 | 110 | extern Closure *extractbindings(Tree *tree0) { 111 | Chain me; 112 | Tree *volatile tree = tree0; 113 | Binding *volatile bindings = NULL; 114 | 115 | gcdisable(); 116 | 117 | if (tree->kind == nList && tree->u[1].p == NULL) 118 | tree = tree->u[0].p; 119 | 120 | me.closure = mkclosure(NULL, NULL); 121 | me.next = chain; 122 | chain = &me; 123 | 124 | ExceptionHandler 125 | 126 | while (tree->kind == nClosure) { 127 | bindings = extract(tree->u[0].p, bindings); 128 | tree = tree->u[1].p; 129 | if (tree == NULL) 130 | fail("$&parse", "null body in %%closure"); 131 | if (tree->kind == nList && tree->u[1].p == NULL) 132 | tree = tree->u[0].p; 133 | } 134 | 135 | CatchException (e) 136 | 137 | chain = chain->next; 138 | throw(e); 139 | 140 | EndExceptionHandler 141 | 142 | chain = chain->next; 143 | 144 | Ref(Closure *, result, me.closure); 145 | result->tree = tree; 146 | result->binding = bindings; 147 | gcenable(); 148 | RefReturn(result); 149 | } 150 | 151 | 152 | /* 153 | * Binding garbage collection support 154 | */ 155 | 156 | DefineTag(Binding, static); 157 | 158 | extern Binding *mkbinding(char *name, List *defn, Binding *next) { 159 | assert(next == NULL || next->name != NULL); 160 | validatevar(name); 161 | gcdisable(); 162 | Ref(Binding *, binding, gcnew(Binding)); 163 | binding->name = name; 164 | binding->defn = defn; 165 | binding->next = next; 166 | gcenable(); 167 | RefReturn(binding); 168 | } 169 | 170 | extern Binding *reversebindings(Binding *binding) { 171 | if (binding == NULL) 172 | return NULL; 173 | else { 174 | Binding *prev, *next; 175 | prev = NULL; 176 | do { 177 | next = binding->next; 178 | binding->next = prev; 179 | prev = binding; 180 | } while ((binding = next) != NULL); 181 | return prev; 182 | } 183 | } 184 | 185 | static void *BindingCopy(void *op) { 186 | void *np = gcnew(Binding); 187 | memcpy(np, op, sizeof (Binding)); 188 | return np; 189 | } 190 | 191 | static size_t BindingScan(void *p) { 192 | Binding *binding = p; 193 | binding->name = forward(binding->name); 194 | binding->defn = forward(binding->defn); 195 | binding->next = forward(binding->next); 196 | return sizeof (Binding); 197 | } 198 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | dnl Process this file with autoconf to produce a configure script. 2 | AC_PREREQ([2.64]) 3 | AC_INIT 4 | AC_CONFIG_SRCDIR([access.c]) 5 | AC_CONFIG_HEADERS([config.h]) 6 | AC_CONFIG_MACRO_DIR([m4]) 7 | 8 | dnl AC_CMDSTDOUT_CPP(variable, command, headers) 9 | AC_DEFUN([AC_CMDSTDOUT_CPP], 10 | [cat > conftest.$ac_ext <&AS_MESSAGE_LOG_FD | $2` 16 | rm -f conftest* 17 | ]) 18 | 19 | AC_CANONICAL_HOST 20 | 21 | dnl Build configuration. 22 | 23 | AC_ARG_ENABLE(strict, AS_HELP_STRING([--enable-strict], [enable strict compiler flags for testing and debugging; not all compilers support these]), opt_strict_mode=$enableval, opt_strict_mode=no) 24 | 25 | if test $opt_strict_mode = yes; then 26 | AC_SUBST([STRICT_CFLAGS], ["-ansi -pedantic -DGCDEBUG=1 -D_POSIX_C_SOURCE=200112L -DREF_ASSERTIONS=1"]) 27 | fi 28 | 29 | dnl Checks for programs. 30 | AC_PROG_CC 31 | AC_PROG_CPP 32 | AC_PROG_INSTALL 33 | AC_PROG_MKDIR_P 34 | AC_PROG_YACC 35 | 36 | dnl ---------------------------- 37 | dnl CHECK FOR /dev/fd FILESYSTEM 38 | dnl ---------------------------- 39 | AC_CACHE_CHECK(for /dev/fd filesystem, es_cv_sys_dev_fd, 40 | [test -d /dev/fd && es_cv_sys_dev_fd=yes || es_cv_sys_dev_fd=no]) 41 | if test $es_cv_sys_dev_fd = yes; then 42 | AC_DEFINE(HAVE_DEV_FD, [1], [Do you have a /dev/fd/ directory?]) 43 | fi 44 | 45 | AC_SYS_INTERPRETER 46 | if test "$ac_cv_sys_interpreter" = yes 47 | then 48 | AC_DEFINE(KERNEL_POUNDBANG, [1], [Does your kernel support #!?]) 49 | fi 50 | 51 | 52 | dnl Checks for libraries. 53 | 54 | AC_CHECK_LIB(sun, getpwuid) 55 | 56 | ES_WITH_READLINE 57 | 58 | dnl Checks for header files. 59 | AC_HEADER_DIRENT 60 | AC_HEADER_SYS_WAIT 61 | AC_CHECK_HEADERS(fcntl.h limits.h sys/ioctl.h sys/time.h unistd.h memory.h stdarg.h sys/cdefs.h) 62 | 63 | 64 | dnl Checks for typedefs, structures, and compiler characteristics. 65 | AC_C_CONST 66 | AC_TYPE_UID_T 67 | AC_TYPE_SIZE_T 68 | 69 | dnl Checks for library functions. 70 | AC_TYPE_GETGROUPS 71 | AC_FUNC_MMAP 72 | 73 | AC_CHECK_FUNCS(strerror strtol lstat setrlimit sigrelse sighold sigaction \ 74 | sysconf sigsetjmp getrusage mmap mprotect) 75 | 76 | AC_CACHE_CHECK(whether getenv can be redefined, es_cv_local_getenv, 77 | [if test "$ac_cv_header_stdlib_h" = no || test "$ac_cv_header_stdc" = no; then 78 | es_cv_local_getenv=yes 79 | fi 80 | if test "$ac_cv_header_stdlib_h" = yes || test "$ac_cv_header_stdc" = yes; then 81 | AC_RUN_IFELSE([AC_LANG_SOURCE([[ 82 | #include 83 | static char *sentinel = "a value"; 84 | static int in_main = 0; 85 | 86 | char *getenv(const char *name) { return in_main ? sentinel : NULL; } 87 | 88 | int main(int argc, char **argv) { 89 | char *v; 90 | in_main = 1; 91 | v = getenv("key"); 92 | return (v == sentinel) ? 0 : 1; 93 | } 94 | ]])],[es_cv_local_getenv=yes],[es_cv_local_getenv=no]) 95 | fi 96 | ]) 97 | 98 | if test "$es_cv_local_getenv" = yes 99 | then 100 | AC_DEFINE(LOCAL_GETENV, [1], [Can getenv() be defined locally?]) 101 | fi 102 | 103 | dnl Check to see if you can assign to a va_list 104 | AC_CACHE_CHECK(whether assignment to va_list ok?, es_cv_assign_va_list, 105 | AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#ifndef HAVE_STDARG_H 106 | choke me 107 | #else 108 | #include 109 | #endif]], [[va_list first, second; first = second; return 0;]])],[es_cv_assign_va_list=yes],[es_cv_assign_va_list=no])) 110 | if test "$es_cv_assign_va_list" = no 111 | then 112 | AC_DEFINE(NO_VA_LIST_ASSIGN, [1], [NO_VA_LIST_ASSIGN]) 113 | fi 114 | 115 | dnl check for a u_quad_t or something like that 116 | AC_CACHE_CHECK(for rlimit type ..., es_cv_rlimit_t, 117 | AC_CMDSTDOUT_CPP(es_cv_rlimit_t, 118 | grep rlim_cur | sed -e 's/rlim_cur.*//' -e 's/^ //g' -e 's/^ //g' -e q, 119 | [#ifdef HAVE_SETRLIMIT 120 | # include 121 | #endif],long)) 122 | 123 | AC_CACHE_CHECK(for files to extract signal information from, 124 | es_cv_sigfiles, 125 | AC_CMDSTDOUT_CPP(es_cv_sigfiles, 126 | [changequote(,) 127 | grep -E '^#[ ]+1[ ]+' | sed 's/.*"\(.*\)".*/\1/' |sort -u | 128 | grep '^/' |tr '\012' ' ' 129 | changequote([,])], 130 | [#include ], /usr/include/signal.h)) 131 | 132 | AC_SUBST(SIGFILES, $es_cv_sigfiles) 133 | 134 | AC_DEFINE_UNQUOTED(LIMIT_T, $es_cv_rlimit_t, [What type are your limits?]) 135 | 136 | AC_CONFIG_FILES([Makefile]) 137 | AC_OUTPUT 138 | -------------------------------------------------------------------------------- /dict.c: -------------------------------------------------------------------------------- 1 | /* dict.c -- hash-table based dictionaries ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | 6 | #define INIT_DICT_SIZE 2 7 | #define REMAIN(n) (((n) * 2) / 3) 8 | #define GROW(n) ((n) * 2) 9 | 10 | /* 11 | * hashing 12 | */ 13 | 14 | /* strhash2 -- the (probably too slow) haahr hash function */ 15 | static unsigned long strhash2(const char *str1, const char *str2) { 16 | 17 | #define ADVANCE() { \ 18 | if ((c = *s++) == '\0') { \ 19 | if (str2 == NULL) \ 20 | break; \ 21 | else { \ 22 | s = (unsigned char *) str2; \ 23 | str2 = NULL; \ 24 | if ((c = *s++) == '\0') \ 25 | break; \ 26 | } \ 27 | } \ 28 | } 29 | 30 | unsigned int c; 31 | unsigned long n = 0; 32 | unsigned char *s = (unsigned char *) str1; 33 | assert(str1 != NULL); 34 | while (1) { 35 | ADVANCE(); 36 | n += (c << 17) ^ (c << 11) ^ (c << 5) ^ (c >> 1); 37 | ADVANCE(); 38 | n ^= (c << 14) + (c << 7) + (c << 4) + c; 39 | ADVANCE(); 40 | n ^= (~c << 11) | ((c << 3) ^ (c >> 1)); 41 | ADVANCE(); 42 | n -= (c << 16) | (c << 9) | (c << 2) | (c & 3); 43 | } 44 | return n; 45 | } 46 | 47 | /* strhash -- hash a single string */ 48 | static unsigned long strhash(const char *str) { 49 | return strhash2(str, NULL); 50 | } 51 | 52 | 53 | /* 54 | * data structures and garbage collection 55 | */ 56 | 57 | DefineTag(Dict, static); 58 | 59 | typedef struct { 60 | char *name; 61 | void *value; 62 | } Assoc; 63 | 64 | struct Dict { 65 | int size, remain; 66 | Assoc table[1]; /* variable length */ 67 | }; 68 | 69 | 70 | static Dict *mkdict0(int size) { 71 | size_t len = offsetof(Dict, table[size]); 72 | Dict *dict = gcalloc(len, &DictTag); 73 | memzero(dict, len); 74 | dict->size = size; 75 | dict->remain = REMAIN(size); 76 | return dict; 77 | } 78 | 79 | static void *DictCopy(void *op) { 80 | Dict *dict = op; 81 | size_t len = offsetof(Dict, table[dict->size]); 82 | void *np = gcalloc(len, &DictTag); 83 | memcpy(np, op, len); 84 | return np; 85 | } 86 | 87 | static size_t DictScan(void *p) { 88 | Dict *dict = p; 89 | int i; 90 | for (i = 0; i < dict->size; i++) { 91 | Assoc *ap = &dict->table[i]; 92 | ap->name = forward(ap->name); 93 | ap->value = forward(ap->value); 94 | } 95 | return offsetof(Dict, table[dict->size]); 96 | } 97 | 98 | 99 | /* 100 | * private operations 101 | */ 102 | 103 | static char DEAD[] = "DEAD"; 104 | 105 | static Assoc *get(Dict *dict, const char *name) { 106 | Assoc *ap; 107 | unsigned long n = strhash(name), mask = dict->size - 1; 108 | for (; (ap = &dict->table[n & mask])->name != NULL; n++) 109 | if (ap->name != DEAD && streq(name, ap->name)) 110 | return ap; 111 | return NULL; 112 | } 113 | 114 | static void recurseput(void *, char *, void *); 115 | 116 | static Dict *put(Dict *dict, char *name, void *value) { 117 | unsigned long n, mask; 118 | Assoc *ap; 119 | assert(get(dict, name) == NULL); 120 | assert(value != NULL); 121 | 122 | if (dict->remain <= 1) { 123 | Dict *new; 124 | Ref(Dict *, old, dict); 125 | Ref(char *, np, name); 126 | Ref(void *, vp, value); 127 | new = mkdict0(GROW(old->size)); 128 | dictforall(old, recurseput, new); 129 | dict = new; 130 | name = np; 131 | value = vp; 132 | RefEnd3(vp, np, old); 133 | } 134 | 135 | n = strhash(name); 136 | mask = dict->size - 1; 137 | for (; (ap = &dict->table[n & mask])->name != DEAD; n++) 138 | if (ap->name == NULL) { 139 | --dict->remain; 140 | break; 141 | } 142 | 143 | ap->name = name; 144 | ap->value = value; 145 | return dict; 146 | } 147 | 148 | static void recurseput(void *v1, char *c, void *v2) { 149 | put(v1, c, v2); 150 | } 151 | 152 | 153 | static void rm(Dict *dict, Assoc *ap) { 154 | unsigned long n, mask; 155 | assert(dict->table <= ap && ap < &dict->table[dict->size]); 156 | 157 | ap->name = DEAD; 158 | ap->value = NULL; 159 | n = ap - dict->table; 160 | mask = dict->size - 1; 161 | for (n++; (ap = &dict->table[n & mask])->name == DEAD; n++) 162 | ; 163 | if (ap->name != NULL) 164 | return; 165 | for (n--; (ap = &dict->table[n & mask])->name == DEAD; n--) { 166 | ap->name = NULL; 167 | ++dict->remain; 168 | } 169 | } 170 | 171 | 172 | 173 | /* 174 | * exported functions 175 | */ 176 | 177 | extern Dict *mkdict(void) { 178 | return mkdict0(INIT_DICT_SIZE); 179 | } 180 | 181 | extern void *dictget(Dict *dict, const char *name) { 182 | Assoc *ap = get(dict, name); 183 | if (ap == NULL) 184 | return NULL; 185 | return ap->value; 186 | } 187 | 188 | extern Dict *dictput(Dict *dict, char *name, void *value) { 189 | Assoc *ap = get(dict, name); 190 | if (value != NULL) 191 | if (ap == NULL) 192 | dict = put(dict, name, value); 193 | else 194 | ap->value = value; 195 | else if (ap != NULL) 196 | rm(dict, ap); 197 | return dict; 198 | } 199 | 200 | extern void dictforall(Dict *dp, void (*proc)(void *, char *, void *), void *arg) { 201 | int i; 202 | Ref(Dict *, dict, dp); 203 | Ref(void *, argp, arg); 204 | for (i = 0; i < dict->size; i++) { 205 | Assoc *ap = &dict->table[i]; 206 | if (ap->name != NULL && ap->name != DEAD) 207 | (*proc)(argp, ap->name, ap->value); 208 | } 209 | RefEnd2(argp, dict); 210 | } 211 | 212 | /* dictget2 -- look up the catenation of two names (such a hack!) */ 213 | extern void *dictget2(Dict *dict, const char *name1, const char *name2) { 214 | Assoc *ap; 215 | unsigned long n = strhash2(name1, name2), mask = dict->size - 1; 216 | for (; (ap = &dict->table[n & mask])->name != NULL; n++) 217 | if (ap->name != DEAD && streq2(ap->name, name1, name2)) 218 | return ap->value; 219 | return NULL; 220 | } 221 | -------------------------------------------------------------------------------- /doc/ERRATA: -------------------------------------------------------------------------------- 1 | The section named ``Return Values'' on page 56 introduces the <> 2 | operator for obtaining the return value of a command. That operator 3 | has been renamed <= to avoid conflicting with the posix-compatible 4 | definition of <> as ``open for reading and writing.'' 5 | 6 | error exceptions now have an additional piece of information. 7 | the second word (the one after ``error'') is now the name of 8 | the routine which caused the error. Thus, in the example 9 | below, the throw command has an extra ``in'' in it. 10 | 11 | The example at the top of the right-hand column on the fourth page 12 | (page 56 in the Usenix proceedings) uses an obsolete version of the 13 | fork builtin. The in function should now be 14 | 15 | fn in dir cmd { 16 | if {~ $#dir 0} { 17 | throw error in 'usage: in dir cmd' 18 | } 19 | fork { # run in a subshell 20 | cd $dir 21 | $cmd 22 | } 23 | } 24 | 25 | The pipe timing example from the paper may not work on your system. 26 | It depends on having a version of time(1) that understands es, either 27 | by building it in to es or having an external time use the SHELL 28 | environment variable. Es will include a (minimal) time function if 29 | it is built with BUITIN_TIME. 30 | -------------------------------------------------------------------------------- /doc/TODO: -------------------------------------------------------------------------------- 1 | 2 | `Bugs' 3 | 4 | 1. tag closures so that they are inherited in subshells. This would 5 | make some things a little more natural. 6 | 7 | 2. Make es tail recursive. In addition to being a Right Thing, this 8 | could be useful for reducing the number of primitives. The only 9 | difficulty here is making sure that the interaction with the garbage 10 | collector is done correctly. 11 | 12 | `Neat ideas' 13 | 14 | 1. Exposing `%parse' in both trivial and non-trivial ways. The 15 | non-trivial ways might amount to some sort of macro system or 16 | something else. I am not really sure. 17 | 18 | -------------------------------------------------------------------------------- /doc/es-list.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wryun/es-shell/cc6937f39133c1d8b5f6c31c3de939db147cd816/doc/es-list.gz -------------------------------------------------------------------------------- /examples/99bottles.es: -------------------------------------------------------------------------------- 1 | ow='on the wall' 2 | b=bottle 3 | n=' 4 | ' 5 | 6 | let( 7 | t=9 8 7 6 5 4 3 2 1 8 | o=9 8 7 6 5 4 3 2 1 0 9 | c= 10 | r=x 11 | ) { 12 | c=$t$o $o 13 | fn-ne=@ { 14 | if {~ $#c 0} {throw no} 15 | if {~ $#c 1} {c=no} 16 | return $c(1) 17 | } 18 | fn-bb=@ { 19 | return $b ^ <=@{ 20 | unwind-protect { 21 | if {! ~ $#c 2} {return s} {return ''} 22 | } { 23 | if {~ $#r 0} { 24 | r=x x x 25 | c=$c(2 ...) 26 | } 27 | r=$r(2 ...) 28 | } 29 | } of beer 30 | } 31 | } 32 | 33 | catch @ e { 34 | echo all done 35 | } { 36 | forever { 37 | echo '' <=ne <=bb $ow,$n <=ne <=bb $n if <=@{ 38 | if {~ <=ne no} { 39 | return that $b 40 | } { 41 | return one of those $b^s 42 | } 43 | } should happen to fall $n <=ne <=bb $ow $n 44 | } 45 | } 46 | -------------------------------------------------------------------------------- /examples/cd_colourprompt.es: -------------------------------------------------------------------------------- 1 | let (cd = $fn-cd) { fn cd {$cd $*; 2 | let (c = \001\033; z = \002) { 3 | wd = `pwd 4 | prompt = $c[4\;35m$z`{hostname}^$c[0m$z:$c[1\;34m$z$^wd$c[0m$z^'; ' 5 | }} 6 | } 7 | -------------------------------------------------------------------------------- /examples/cd_follow-symbolic.es: -------------------------------------------------------------------------------- 1 | # es hack to make cd "follow" symbolic links, so that cd symlink/.. 2 | # returns one to the intial directory, not the parent of the directory 3 | # pointed to by the symlink. 4 | 5 | fn pwd { 6 | if {~ $#cwd 0} { 7 | noexport = $noexport cwd 8 | cwd = `` \n /bin/pwd 9 | } 10 | echo $cwd 11 | } 12 | 13 | let (cd = $fn-cd) fn cd dir { 14 | if {~ $#cwd 0} { 15 | noexport = $noexport cwd 16 | } 17 | if {~ $#dir 0} { 18 | $cd 19 | cwd = ~ 20 | } { 21 | let (current = <={ 22 | if {~ $dir /*} { 23 | result 24 | } { 25 | if {~ $#cwd 0} { 26 | cwd = `` \n /bin/pwd 27 | } 28 | %split / $cwd 29 | } 30 | }) { 31 | for (name = <={%split / $dir}) { 32 | if {~ $name ..} { 33 | if {!~ $#current 0} { 34 | let (x = 1 $current) current = $x(2 ... $#current) 35 | } 36 | } {!~ $name . ''} { 37 | current = $current $name 38 | } 39 | } 40 | let (path = / ^ <={ %flatten / $current }) { 41 | $cd $path 42 | cwd = $path 43 | } 44 | } 45 | } 46 | } 47 | -------------------------------------------------------------------------------- /examples/cd_history.es: -------------------------------------------------------------------------------- 1 | # cd [ -[N] | dir ] 2 | # 3 | # This replaces the builtin version of cd, absorbing all of its features 4 | # and adding the ability to jump back to the Nth previous directory. The 5 | # number of previous directories that cd remembers may be adjusted by 6 | # incrementing cd-stack-depth. The size of the stack is actually 7 | # cd-stack-depth + 1 (if cd-stack-depth is not set, then the stack becomes 8 | # unabounded). 9 | 10 | cd-stack-depth = 3 11 | let ( cd-stack = .; cwd = `pwd ) { 12 | fn cd dir { 13 | if {~ $#dir 0} { 14 | if {! ~ $#home 1} { 15 | throw error cd <={ 16 | if {~ $#home 0} { 17 | result 'cd: $home not set' 18 | } { 19 | result 'cd: $home contains more than one word' 20 | } 21 | } 22 | } 23 | dir = $home 24 | } {~ $#dir 1} { 25 | if { ~ $dir -* } { 26 | let (index = <={%split - $dir}) { 27 | if {~ $#index 0} { 28 | index = 1 29 | } { ! ~ $index [0-9]* } { 30 | throw error cd 'cd: invalid argument' 31 | } 32 | dir = $cd-stack($index) 33 | echo $dir >[1=2] 34 | } 35 | if { ~ $#dir 0 } { 36 | throw error cd 'cd: stack not that deep' 37 | } 38 | } {! %is-absolute $dir} { 39 | let (old = $dir) { 40 | dir = <={%cdpathsearch $dir} 41 | if {! ~ $dir $old} { 42 | echo $dir >[1=2] 43 | } 44 | } 45 | } 46 | } { 47 | throw error cd 'usage: cd [-[N]|[directory]]' 48 | } 49 | 50 | if {$&cd $dir} { 51 | cd-stack = ($cwd $cd-stack( 1 ... $cd-stack-depth )) 52 | cwd = $dir 53 | } 54 | } 55 | } 56 | -------------------------------------------------------------------------------- /examples/cdpath.es: -------------------------------------------------------------------------------- 1 | let (cd = $fn-cd) fn cd dir { 2 | if {~ $#dir 1} { 3 | if {!%is-absolute $dir} { 4 | let (old = $dir) { 5 | dir = <={%cdpathsearch $dir} 6 | if {!~ $dir $old} { 7 | echo >[1=2] $dir 8 | } 9 | } 10 | } 11 | $cd $dir 12 | } { 13 | $cd $dir 14 | } 15 | } 16 | 17 | fn %cdpathsearch name { access -n $name -1e -d $cdpath } 18 | fn %is-absolute path { ~ $path /* ./* ../* } 19 | 20 | set-cdpath = @{local (set-CDPATH=) CDPATH=<={%flatten : $*}; result $*} 21 | set-CDPATH = @{local (set-cdpath=) cdpath=<={%fsplit : $*}; result $*} 22 | noexport = $noexport cdpath 23 | cdpath = '' 24 | -------------------------------------------------------------------------------- /examples/es-mode.el: -------------------------------------------------------------------------------- 1 | (defvar es-mode-hook nil) 2 | (defvar es-mode-map 3 | (let ((es-mode-map (make-keymap))) 4 | (define-key es-mode-map "\C-j" 'newline-and-indent) 5 | es-mode-map) 6 | "Keymap for es major mode") 7 | 8 | (add-to-list 'auto-mode-alist '("\\.es\\'" . es-mode)) 9 | 10 | (defvar es-font-lock-keywords 11 | '( 12 | ("#.*$" . font-lock-comment-face) 13 | ("'[^\']*'" font-lock-variable-face) 14 | 15 | ("\\<\\(let\\|if\\|for\\|while\\|fn\\)\\>" . font-lock-keyword-face) 16 | ("\\<\\(access\\|break\\|catch\\|cd\\|echo\\|eval\\|exec\\|exit\\|false\\|forever\\|fork\\|if\\|limit\\|newpgrp\\|result\\|return\\|throw\\|time\\|true\\|umask\\|unwind-protect\\|var\\|vars\\|wait\\|whatis\\|while\\|%read\\)\\>" . font-lock-builtin-face) 17 | 18 | ("\"[^\"]*\"" 0 font-lock-string-face t) 19 | ("`{[^}]*}" 0 font-lock-variable-name-face t) 20 | ("\\<-\\w*\\>" 0 font-lock-reference-face t) 21 | ("\$\\w*" 0 font-lock-reference-face t) 22 | )) 23 | 24 | (defvar es-mode-syntax-table 25 | (let ((es-mode-syntax-table (make-syntax-table))) 26 | (modify-syntax-entry ?_ "w" es-mode-syntax-table) 27 | (modify-syntax-entry ?- "w" es-mode-syntax-table) 28 | (modify-syntax-entry ?. "w" es-mode-syntax-table) 29 | es-mode-syntax-table) 30 | "Syntax table for es-mode") 31 | 32 | (defun es-indent-line () 33 | "Indent current line as es code" 34 | (interactive) 35 | (beginning-of-line)) 36 | 37 | (define-derived-mode es-mode fundamental-mode "es" 38 | "Major mode for editing Extensible Shell scripts." 39 | (set (make-local-variable 'font-lock-defaults) '(es-font-lock-keywords)) 40 | (set (make-local-variable 'indent-line-function) 'es-indent-line)) 41 | 42 | (provide 'es-mode) 43 | -------------------------------------------------------------------------------- /examples/friedman/README: -------------------------------------------------------------------------------- 1 | Scripts/programs in here were written by Noah Friedman. 2 | 3 | http://www.splode.com/~friedman/ 4 | 5 | No guarantees, but it may be a use of interesting es code. 6 | He published his environment setup, and it's since disappeared 7 | from the internet. 8 | -------------------------------------------------------------------------------- /examples/friedman/lib/=TODO: -------------------------------------------------------------------------------- 1 | * Rename fpath to load-path. Rename FPATH to ESLOADPATH. 2 | * Convert compress table frobs in compress.es to generic boxes. 3 | * Finish tc.es. 4 | * Finish list.es. 5 | * Fix the definition of `console?' in subr.es. 6 | * Change `featurep' to `feature?' in require.es and throughout. 7 | -------------------------------------------------------------------------------- /examples/friedman/lib/Y.es: -------------------------------------------------------------------------------- 1 | # Y.es --- Y combinator 2 | # Author: Noah Friedman 3 | # Created: 1993-05-19 4 | # Last modified: 1993-05-19 5 | # Public domain 6 | 7 | # Commentary: 8 | 9 | # The example in the docstring came from 10 | # Harald Hanche-Olsen 11 | 12 | # Code: 13 | 14 | #:docstring Y: 15 | # For a full explanation of the Y combinator, refer to any good tutorial 16 | # on functional programming languages. 17 | # 18 | # Here is an example of its usage in es: 19 | # 20 | # ; foo = <={Y @ r { 21 | # result @ x { 22 | # if {~ $#x 0} {result done} {echo $x; <=$r $x(2 ...)}}}} 23 | # 24 | # ; echo <={$foo a b c} 25 | # a b c 26 | # b c 27 | # c 28 | # done 29 | #:end docstring: 30 | 31 | ###;;;autoload 32 | fn Y f {@ g {$g $g} @ h {$f {$h $h}}} 33 | 34 | provide Y 35 | 36 | # Y.es ends here 37 | -------------------------------------------------------------------------------- /examples/friedman/lib/array.es: -------------------------------------------------------------------------------- 1 | # array.es --- flat array manipulation functions 2 | # Author: Noah Friedman 3 | # Created: 1993-11-07 4 | # Last modified: 1993-11-07 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | #:docstring array-delq: 11 | # Usage: array-delq [elt] [list] 12 | #:end docstring: 13 | 14 | ###;;;autoload 15 | fn array-delq elt list \ 16 | { 17 | # Speed hack: if it looks like the element isn't a member via pattern 18 | # matching, just return the list and avoid a possibly expensive 19 | # element-by-element search. 20 | if { ! ~ $elt $list } \ 21 | { result $list } \ 22 | { 23 | let (new-list =) 24 | { 25 | while { ! ~ $list () } \ 26 | { 27 | if { ~ $list(1) $elt } \ 28 | { 29 | new-list = $new-list $list(2 ...) 30 | break 31 | } 32 | new-list = $new-list $list(1) 33 | list = $list(2 ...) 34 | } 35 | result $new-list 36 | } 37 | } 38 | } 39 | 40 | #:docstring array-reverse: 41 | # Usage: array-reverse [args ...] 42 | # 43 | # Return a list of ARGS which is in the opposite order from the order 44 | # given. 45 | # 46 | # This function works on flat es arrays, not consed lists or vectors. 47 | #:end docstring: 48 | 49 | ###;;;autoload 50 | fn array-reverse list \ 51 | { 52 | let (new =) 53 | { 54 | for (nlist = $list) 55 | { new = $nlist $new } 56 | result $new 57 | } 58 | } 59 | 60 | provide array 61 | 62 | # array.es ends here 63 | -------------------------------------------------------------------------------- /examples/friedman/lib/churchnum.es: -------------------------------------------------------------------------------- 1 | # churchnum.es --- example of church numerals in es 2 | # Author: Harald Hanche-Olsen 3 | # Maintainer: Noah Friedman 4 | # Created: 1993-11-07 5 | # Last modified: 1993-11-07 6 | 7 | # Commentary: 8 | 9 | # An sample implementation of Church numerals using lambda calculus in es. 10 | # TODO: Get explicit permission from author to redistribute this freely. 11 | 12 | # Code: 13 | 14 | fn Compose f g {result @ x {$f <={$g $x}}} 15 | fn Succ n {result @ f {Compose <={$n $f} $f}} 16 | fn Plus m n {<={$m Succ} $n} 17 | fn Prod m n {result @ f {$m <={$n $f}}} 18 | fn Power m n {$m $n} 19 | One = $&result 20 | 21 | # Sample usage: 22 | # 23 | # ; Two =<={Succ $One} 24 | # ; Three=<={Succ $Two} 25 | # ; Nine =<={Prod $Three $Three} 26 | # ; Twelve=<={Plus $Three $Nine} 27 | # ; Twenty-Seven=<={Power $Three $Three} 28 | # ; dots=@ x {result . $x} 29 | # ; for (i = Three Nine Twelve Twenty-Seven) echo <={<={$$i $dots} $i}} 30 | # . . . Three 31 | # . . . . . . . . . Nine 32 | # . . . . . . . . . . . . Twelve 33 | # . . . . . . . . . . . . . . . . . . . . . . . . . . . Twenty-Seven 34 | 35 | provide churchnum 36 | 37 | # churchnum.es ends here 38 | -------------------------------------------------------------------------------- /examples/friedman/lib/compress.es: -------------------------------------------------------------------------------- 1 | # compress.es --- table-driven compression method handler 2 | # Author: Noah Friedman 3 | # Created: 1994-01-16 4 | # Last modified: 1994-03-31 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | ###;;;autoload 11 | fn compress:create-method-object method-list \ 12 | { 13 | method-list = 14 | result @ msg parms \ 15 | { 16 | if { ~ $msg value } \ 17 | { result $method-list } \ 18 | { ~ $msg set! } \ 19 | { method-list = $parms } \ 20 | { 21 | throw error compress.es invalid message to compress-method object, '`'^$msg^'''' 22 | } 23 | } 24 | } 25 | 26 | ###;;;autoload 27 | fn compress:method-object? \ 28 | { 29 | ~ $1 '%closure(method-list='*')@ msg parms{'* 30 | } 31 | 32 | ###;;;autoload 33 | fn compress:add-method! table type extension compress uncompress \ 34 | { 35 | if { ~ () <={ compress:get-method $table type $type } } \ 36 | { 37 | $table set! <={ $table value } \ 38 | { result $type $extension $compress $uncompress } 39 | } 40 | } 41 | 42 | ###;;;autoload 43 | fn compress:get-method table key value \ 44 | { 45 | let (type = 1; 46 | extension = 2; 47 | compress = 3; 48 | uncompress = 4; 49 | result =;) 50 | { 51 | for (method = <={ $table value }) 52 | { 53 | method = <={ $method } 54 | if { ~ $method($$key) $value } \ 55 | { 56 | result = $method 57 | break 58 | } 59 | } 60 | result $result 61 | } 62 | } 63 | 64 | ###;;;autoload 65 | fn compress:remove-method! table method \ 66 | { 67 | if { ! ~ () <={ compress:get-method $table type $method } } \ 68 | { 69 | let (method-list = <={ $table value } 70 | new-list = 71 | n =) 72 | { 73 | for (m = $method-list) 74 | { 75 | n = <={ $m } 76 | if { ! ~ $n(1) $method } \ 77 | { new-list = $new-list $m } 78 | } 79 | $table set! $new-list 80 | } 81 | } 82 | } 83 | 84 | provide compress 85 | 86 | # compress.es ends here 87 | -------------------------------------------------------------------------------- /examples/friedman/lib/compresstbl.es: -------------------------------------------------------------------------------- 1 | # compresstbl.es --- compression method handler using compress.es 2 | # Author: Noah Friedman 3 | # Created: 1994-03-31 4 | # Last modified: 1994-03-31 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | require compress 11 | 12 | # table type extension compress uncompress 13 | fn compresstbl:add-method! \ 14 | { 15 | compress:add-method! $compress-method-table $* 16 | } 17 | 18 | fn compresstbl:get-method \ 19 | { 20 | compress:get-method $compress-method-table $* 21 | } 22 | 23 | fn compresstbl:remove-method! \ 24 | { 25 | compress:remove-method! $compress-method-table $* 26 | } 27 | 28 | ### 29 | 30 | compress-method-table = <={ compress:create-method-object } 31 | for (method = ( 32 | { result compact .C compact uncompact } 33 | { result compress .Z compress @{compress -d -c $*} } 34 | { result gzip .gz gzip @{gzip -d -c $*} } 35 | { result pack .z pack unpack } 36 | { result yabba .Y @{let (f=`{basename $1 .Y}) {yabba < $1 > $f}} \ 37 | @{unyabba < $1 > $1^.Y}} 38 | { result unknown '' cat cat }) 39 | ) 40 | { 41 | compresstbl:add-method! <={ $method } 42 | } 43 | 44 | provide compresstbl 45 | 46 | # compress.es ends here 47 | -------------------------------------------------------------------------------- /examples/friedman/lib/date.es: -------------------------------------------------------------------------------- 1 | # date.es 2 | # Author: Noah Friedman 3 | # Created: 1993-03-20 4 | # Last modified: 1993-04-26 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | #:docstring numeric-date: 11 | # Usage: numeric-date [string] 12 | # 13 | # Echoes a numeric date in the form YYYY-MM-DD, e.g. 1993-03-20 14 | # Argument STRING should be a date string in the same format as the default 15 | # output from `date' command. If argument is not provided, STRING is 16 | # obtained by running `date'. 17 | #:end docstring: 18 | 19 | ###;;;autoload 20 | fn numeric-date \ 21 | { 22 | if { ~ $#1 0 } { local (ifs =) { * = `date } } 23 | 24 | echo $1 \ 25 | | sed -ne ' 26 | s/[^ ]* *\([^ ]*\) *\([^ ]*\).* \([^ ]*\)$/\3-\1-\2/ 27 | /-[0-9]$/s/\([0-9]\)$/0\1/ 28 | /Jan/{s/Jan/01/p;q;} 29 | /Feb/{s/Feb/02/p;q;} 30 | /Mar/{s/Mar/03/p;q;} 31 | /Apr/{s/Apr/04/p;q;} 32 | /May/{s/May/05/p;q;} 33 | /Jun/{s/Jun/06/p;q;} 34 | /Jul/{s/Jul/07/p;q;} 35 | /Aug/{s/Aug/08/p;q;} 36 | /Sep/{s/Sep/09/p;q;} 37 | /Oct/{s/Oct/10/p;q;} 38 | /Nov/{s/Nov/11/p;q;} 39 | /Dec/{s/Dec/12/p;q;}' 40 | } 41 | 42 | provide date 43 | 44 | # date.es ends here 45 | -------------------------------------------------------------------------------- /examples/friedman/lib/dirs.es: -------------------------------------------------------------------------------- 1 | # dirs.es --- directory tracking and directory stacks 2 | # Author: Noah Friedman 3 | # Created: 1993-04-26 4 | # Last modified: 1994-03-16 5 | # Public domain 6 | 7 | # Commentary: 8 | 9 | # This implementation has one important variation among most directory 10 | # stack mechanisms. If you set the global variable `dirs:file-name-prefix', 11 | # the `dirs' command will prepend this prefix to all pathnames in the 12 | # directory stack. This can be used in conjunction with the emacs shell 13 | # mode M-x dirs command to set the current directory. 14 | 15 | # Code: 16 | 17 | require hook 18 | require subr 19 | 20 | set-cdpath = @ { local (set-CDPATH = ) CDPATH = <={%flatten : $*}; result $* } 21 | set-CDPATH = @ { local (set-cdpath = ) cdpath = <={%fsplit : $*}; result $* } 22 | 23 | # Because shared lexically scoped environments become separate across shell 24 | # invocations (at least as of 0.83), we have just one function that 25 | # performs all operations on the dirstack variable. Other routines merely 26 | # access it indirectly. 27 | # Attempt to preserve old value of dirstack if this file is reloaded. 28 | let (dirstack = `{ if { ! ~ $fn-dirs () } dirs pwd }) 29 | { 30 | fn dirs:access-dirstack cmd op args \ 31 | { 32 | # Ops basically listed in order of most likely frequency. 33 | # `set1' and `set' are currently unused, but provided in case I need 34 | # to repair damage manually. 35 | if { ~ $op pwd } \ 36 | { $cmd $dirstack(1) } \ 37 | { ~ $op chdir } \ 38 | { dirstack = <={ expand-file-name $args(1) $dirstack(1) } $dirstack(2 ...) } \ 39 | { ~ $op dirs } \ 40 | { $cmd $^(dirs:file-name-prefix)^$dirstack } \ 41 | { ~ $op push } \ 42 | { dirstack = <={ expand-file-name $args(1) $dirstack(1) } $dirstack } \ 43 | { ~ $op swap } \ 44 | { 45 | if { ~ $#dirstack 1 } \ 46 | { throw error $0 pushd: No other directory } 47 | # This shouldn't be here, but it's faster & convenient. 48 | $&cd $dirstack(2) 49 | dirstack = $dirstack(2) $dirstack(1) $dirstack(3 ...) 50 | } \ 51 | { ~ $op pop } \ 52 | { 53 | # Do not actually want to pop last element off dirstack. 54 | if { ~ $#dirstack 1 } \ 55 | { throw error $0 popd: Directory stack empty } 56 | dirstack = $dirstack(2 ...) 57 | } \ 58 | { ~ $op set1 } \ 59 | { dirstack = $args(1) $dirstack(2 ...) } \ 60 | { ~ $op set } \ 61 | { dirstack = $args } \ 62 | { throw error $0 $0: $op: invalid op. } 63 | } 64 | } 65 | 66 | ###;;;autoload 67 | fn chdir \ 68 | { 69 | if { ~ $* () } { * = $home } 70 | 71 | if { ~ $1 ./* ../* /* } \ 72 | { 73 | $&cd $1 74 | dirs:access-dirstack result chdir $1 75 | } \ 76 | { 77 | let (dir =) 78 | { 79 | dir = <={ access -1 -d -n $1 $cdpath } ; 80 | if { ~ $dir () } { throw error $0 $0: $*(1) not in '$cdpath' } 81 | $&cd $dir 82 | dirs:access-dirstack result chdir $dir 83 | } 84 | } 85 | 86 | run-hooks cd-hook $* 87 | } 88 | 89 | ###;;;autoload 90 | fn popd \ 91 | { 92 | dirs:access-dirstack result pop 93 | $&cd `pwd 94 | run-hooks popd-hook $* 95 | } 96 | 97 | ###;;;autoload 98 | fn pushd \ 99 | { 100 | if { ~ $* () } \ 101 | { dirs:access-dirstack result swap } \ 102 | { ~ $1 ./* ../* /* } \ 103 | { 104 | $&cd $1 105 | dirs:access-dirstack result push $1 106 | } \ 107 | { 108 | let (dir =) 109 | { 110 | dir = <={ access -1 -d -n $1 $cdpath } ; 111 | if { ~ $dir () } { throw error $0 $0: $1 not in '$cdpath' } 112 | $&cd $dir 113 | dirs:access-dirstack result push $1 114 | } 115 | } 116 | 117 | run-hooks pushd-hook $* 118 | } 119 | 120 | ###;;;autoload 121 | fn-dirs = { dirs:access-dirstack echo dirs } 122 | 123 | ###;;;autoload 124 | fn-pwd = { dirs:access-dirstack echo pwd } 125 | 126 | ###;;;autoload 127 | fn-cwd = { dirs:access-dirstack result pwd } 128 | 129 | # Aliases 130 | 131 | ###;;;autoload 132 | fn-[d = pushd 133 | 134 | ###;;;autoload 135 | fn-]d = popd 136 | 137 | ###;;;autoload 138 | fn-cd = chdir 139 | 140 | provide dirs 141 | 142 | # dirs.es ends here 143 | -------------------------------------------------------------------------------- /examples/friedman/lib/equal.es: -------------------------------------------------------------------------------- 1 | # equal.es --- type-extensible equality predicates 2 | # Author: Noah Friedman 3 | # Created: 1993-11-07 4 | # Last modified: 1993-11-07 5 | # Public domain 6 | 7 | # Commentary: 8 | 9 | # TODO: Document how to extend them. 10 | 11 | # Code: 12 | 13 | require plist 14 | 15 | let (fn-equal-subr = @ caller obj1 obj2 \ 16 | { 17 | let (result = 18 | method-found? = <=false) 19 | { 20 | for (propname = <={ symbol-property-names $caller }) 21 | { 22 | if { $propname $obj1 && $propname $obj2 } \ 23 | { 24 | result = <={ <={ get $caller $propname } $obj1 $obj2 } 25 | method-found? = <=true 26 | break 27 | } 28 | } 29 | if { result $method-found? } \ 30 | { result $result } \ 31 | { ~ $obj1 $obj2 } 32 | } 33 | }) 34 | { 35 | 36 | #:docstring eq?: 37 | # Usage: eq? obj1 obj2 38 | #:end docstring: 39 | 40 | ###;;;autoload 41 | fn eq? { $fn-equal-subr $0 $* } 42 | 43 | #:docstring eqv?: 44 | # Usage: eqv? obj1 obj2 45 | #:end docstring: 46 | 47 | ###;;;autoload 48 | fn eqv? { $fn-equal-subr $0 $* } 49 | 50 | #:docstring equal?: 51 | # Usage: equal? obj1 obj2 52 | #:end docstring: 53 | 54 | ###;;;autoload 55 | fn equal? { $fn-equal-subr $0 $* } 56 | 57 | } 58 | 59 | provide equal 60 | 61 | # equal.es ends here 62 | -------------------------------------------------------------------------------- /examples/friedman/lib/exec.es: -------------------------------------------------------------------------------- 1 | # exec.es --- bash-compatible `exec' command 2 | # Author: Noah Friedman 3 | # Created: 1993-05-20 4 | # Last modified: 1993-05-20 5 | # Public domain 6 | 7 | # Commentary: 8 | 9 | # This version of exec prepends a `-' to the name of the program run if the 10 | # first argument is `-'. This is like the bash's exec command. Don't use 11 | # The `-' argument if you just want to do redirections in the current 12 | # shell. It will lose (but there's no reason why you would want to do such 13 | # a thing anyway). 14 | 15 | # Code: 16 | 17 | ###;;;autoload 18 | fn exec \ 19 | { 20 | if { ~ $1 '-' } \ 21 | { $&exec %run <={%pathsearch $2} -$2 $*(3 ...) } \ 22 | { $&exec $* } 23 | } 24 | 25 | provide exec 26 | 27 | # exec.es ends here 28 | -------------------------------------------------------------------------------- /examples/friedman/lib/exports.es: -------------------------------------------------------------------------------- 1 | # exports.es 2 | # Author: Noah Friedman 3 | # Created: 1993-10-18 4 | # Public domain 5 | 6 | # $Id: exports.es,v 1.2 1995/08/25 19:26:23 friedman Exp $ 7 | 8 | # Commentary: 9 | # Code: 10 | 11 | require subr 12 | 13 | #:docstring noexport-exceptions: 14 | # List of variables that should normally be exported to external programs 15 | # when using `with-minimal-exports' form except when overriden by explicit 16 | # list of export variables passed to the function (which see). 17 | # 18 | # Example: 19 | # ; local (noexport-exceptions = HOME SHELL TERM) with-minimal-exports env 20 | # HOME=/home/fsf/friedman 21 | # SHELL=/usr/local/bin/es 22 | # TERM=aaa-60 23 | # ; 24 | # 25 | #:end docstring: 26 | 27 | defvar noexport-exceptions HOME LOGNAME PATH SHELL TERM USER 28 | 29 | #:docstring with-minimal-exports: 30 | # Usage: with-minimal-exports bodyform exceptions ... 31 | # 32 | # Execute bodyform while inhibiting the export of all shell variables except 33 | # those passed as `exceptions'. If no exceptions are listed, 34 | # those symbols listed in the variable `noexport-exceptions' are used. 35 | # To run a program with no exports at all, use `with-no-exports' function. 36 | # 37 | # If bodyform is more than one word, it should be wrapped in a lambda, e.g. 38 | # { du -sk } 39 | # 40 | # Example: 41 | # ; with-minimal-exports { env } HOME SHELL TERM 42 | # HOME=/home/fsf/friedman 43 | # SHELL=/usr/local/bin/es 44 | # TERM=aaa-60 45 | # ; 46 | # 47 | #:end docstring: 48 | 49 | ###;;;autoload 50 | fn-with-minimal-exports = $&noreturn @ body exceptions \ 51 | { 52 | if { ~ $exceptions () } \ 53 | { exceptions = $noexport-exceptions } 54 | local (noexport = noexport) 55 | { 56 | for (v = <={ $&vars }) 57 | { 58 | if { ! ~ $v $exceptions } \ 59 | { noexport = $noexport $v } 60 | } 61 | { $body } 62 | } 63 | } 64 | 65 | #:docstring with-no-exports: 66 | # Usage: with-no-exports bodyform 67 | # 68 | # Execute bodyform while inhibiting the export of all variables. 69 | #:end docstring: 70 | 71 | ###;;;autoload 72 | fn-with-no-exports = $&noreturn @ \ 73 | { 74 | local (noexport = <={ $&vars }) { $* } 75 | } 76 | 77 | provide exports 78 | 79 | # exports.es ends here 80 | -------------------------------------------------------------------------------- /examples/friedman/lib/hash.es: -------------------------------------------------------------------------------- 1 | # hash.es --- command hashing for es 2 | # Author: Noah Friedman 3 | # Created: 1993-04-28 4 | # Last modified: 1993-04-28 5 | # Public domain 6 | 7 | # Commentary: 8 | 9 | # This implementation seems to make executing commands a tiny bit faster. 10 | # Another advantage is that hashing may avoid hanging the shell if an NFS 11 | # fileysystem goes down (assuming you only run commands that are already 12 | # hashed). 13 | # 14 | # This has yet to be benchmarked. 15 | 16 | # Code: 17 | 18 | require primitives 19 | require hook 20 | 21 | #:docstring hash: 22 | # Usage: hash [name ...] 23 | # 24 | # For each NAME, the full pathname of the command is determined and 25 | # remembered. If any of the NAMEs given do not exist in $path, an error 26 | # will be signalled and the remaining arguments will not be processed. 27 | #:end docstring: 28 | 29 | ###;;;autoload 30 | fn hash fns \ 31 | { 32 | let (result =; loc =) 33 | { 34 | for (f = $fns) 35 | if { ~ $(hash:cmd-$f) () } \ 36 | { 37 | loc = <={ access -n $f -1e -xf $path } 38 | result = $result $loc 39 | if { ~ $loc () } \ 40 | {} \ 41 | { hash:cmd-^$f = $loc } 42 | } \ 43 | { result = $result $(hash:cmd-$f) } 44 | 45 | result $result 46 | } 47 | } 48 | 49 | ###;;;autoload 50 | fn unhash fns \ 51 | { 52 | if { ~ $fns(1) '-a' } \ 53 | { 54 | for (var = <=$&vars) 55 | if { ~ $var 'hash:cmd-'* } \ 56 | { $var = } 57 | result 0 58 | } \ 59 | { 60 | for (var = $fns) \ 61 | hash:cmd-$var = 62 | } 63 | } 64 | 65 | ###;;;autoload 66 | fn showhash \ 67 | { 68 | for (var = <=$&vars) 69 | if { ~ $var 'hash:cmd-'* } \ 70 | { echo $var '=' $$var } 71 | result 0 72 | } 73 | 74 | ###;;;autoload 75 | fn hash-do-pathsearch \ 76 | { 77 | if { ~ $(hash:cmd-$1) () } \ 78 | { hash $1 } \ 79 | { result $(hash:cmd-$1) } 80 | } 81 | 82 | 83 | # Insert this hook before %pathsearch-default so that this supersedes it. 84 | insert-hook %pathsearch-hook hash-do-pathsearch 85 | 86 | provide hash 87 | 88 | # hash.es ends here 89 | -------------------------------------------------------------------------------- /examples/friedman/lib/help.es: -------------------------------------------------------------------------------- 1 | # help.es --- documentation system for runtime environment 2 | # Author: Noah Friedman 3 | # Created: 1992-06-18 4 | # Last modified: 1993-09-26 5 | # Public domain 6 | 7 | # Commentary: 8 | 9 | # TODO: Perhaps add a way of storing docstrings in variables so that future 10 | # lookups in same session will be faster. 11 | # 12 | # Get rid of the dependency on my personal shell environment. This is 13 | # really really yucky. 14 | 15 | # Code: 16 | 17 | # Ugh. 18 | help-file-name = $sinit/es/lib/.docstrings 19 | 20 | fn help-print-docstring \ 21 | { 22 | let (var = $1; 23 | dta-file = $help-file-name.dta 24 | idx-file = $help-file-name.idx) 25 | { 26 | * = `{ sed -ne '/^'$var' /{ 27 | s/ */ /g 28 | s/^'$var' \([0-9][0-9]*\) \([0-9][0-9]*\)/\1 \2/ 29 | p;q; 30 | }' $idx-file } 31 | 32 | if { ~ $#* 2 } \ 33 | { 34 | * = `` '' { sed -ne $1^,^$2^p $dta-file } 35 | if { ! ~ $* () } \ 36 | { echo $* } 37 | } \ 38 | { result 1 } 39 | } 40 | } 41 | 42 | #:docstring help: 43 | # Provide help for documented shell functions. 44 | #:end docstring: 45 | 46 | ###;;;autoload 47 | fn help \ 48 | { 49 | if { ~ $* () } \ 50 | { 51 | echo Usage: $0 '[function]' >[1=2] 52 | result 1 53 | } \ 54 | { 55 | help-print-docstring $* 56 | } 57 | } 58 | 59 | ###;;;autoload 60 | fn mkdocstrings \ 61 | { 62 | local (fn-$0 =) 63 | $0 --docstrings-file\=$help-file-name --verbose -- $sinit/es/lib/*.es 64 | } 65 | 66 | provide help 67 | 68 | # help.es ends here 69 | -------------------------------------------------------------------------------- /examples/friedman/lib/hook.es: -------------------------------------------------------------------------------- 1 | # hook.es --- hook creation, modification, and execution routines 2 | # Author: Noah Friedman 3 | # Created: 1993-04-25 4 | # Last modified: 1994-04-01 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | #:docstring run-hooks: 11 | # Usage: run-hooks [hook-name] {args} 12 | # 13 | # If `hook-name' (a symbol) has a non-empty value, that value may be a 14 | # function or a list of functions to be called. Each function is called in 15 | # turn with the argument(s) `args'. Returns a list of all the return 16 | # values from each hook. 17 | #:end docstring: 18 | 19 | # We could just define run-hooks as `run-hooks-until false', but that would 20 | # incur additional overhead and it's advantageous for run-hooks to be speedy. 21 | ###;;;autoload 22 | fn run-hooks hook-name args \ 23 | { 24 | let (result =) 25 | { 26 | for (do-hook = $$hook-name) 27 | result = $result <={ $do-hook $args } 28 | result $result 29 | } 30 | } 31 | 32 | #:docstring run-hooks: 33 | # Usage: run-hooks-until [condition] [hook-name] {args} 34 | # 35 | # Like `run-hooks', but only call successive hooks if previously-run hooks 36 | # do not satisfy the function `condition', which is called with the result 37 | # of the last hook executed. 38 | # 39 | # The return value is the result of the hook which finally satisfied 40 | # `condition' or the result of the last hook. 41 | #:end docstring: 42 | 43 | ###;;;autoload 44 | fn run-hooks-until condition hook-name args \ 45 | { 46 | let (result =) 47 | { 48 | for (do-hook = $$hook-name) 49 | { 50 | result = <={ $do-hook $args } 51 | if { $condition $result } \ 52 | { break } 53 | } 54 | result $result 55 | } 56 | } 57 | 58 | #:docstring add-hook: 59 | # Usage: add-hook hook function 60 | # 61 | # Append to the value of `hook' the function `function' unless already 62 | # present. `hook' should be a symbol and `function' may be any valid 63 | # function name or lambda expression. hook's value should be a list of 64 | # functions, not a single function. 65 | # 66 | # To detect whether `function' is already present in the hook, `add-hook' 67 | # does simple pattern matching. It cannot identify equivalent but 68 | # different lambda expressions. For example, it would consider 69 | # @ x {result x} and @ y {result y} different. 70 | # 71 | # The return value of `add-hook' is the new value of `hook'. 72 | #:end docstring: 73 | 74 | ###;;;autoload 75 | fn add-hook hook function \ 76 | { 77 | if { ! ~ $function $$hook } \ 78 | { $hook = $$hook $function } 79 | result $$hook 80 | } 81 | 82 | #:docstring insert-hook: 83 | # Usage: insert-hook hook function 84 | # 85 | # Like `add-hook', but prepend function to the beginning of hook list 86 | # rather than appending it to the end. See docstring for `add-hook' for 87 | # caveats about pattern matching. 88 | # 89 | # The return value of `insert-hook' is the new value of `hook'. 90 | #:end docstring: 91 | 92 | ###;;;autoload 93 | fn insert-hook hook function \ 94 | { 95 | if { ! ~ $function $$hook } \ 96 | { $hook = $function $$hook } 97 | result $$hook 98 | } 99 | 100 | #:docstring remove-hook: 101 | # Usage: remove-hook hook function 102 | # 103 | # Remove from the value of `hook' the function `function' if present. 104 | # `hook' should be a symbol and `function' may be any valid function name 105 | # or lambda expression. hook's value should be a list of functions, not a 106 | # single function. 107 | # 108 | # To detect whether `function' is present in the hook, `remove-hook' does 109 | # simple pattern matching. It cannot identify equivalent but different 110 | # lambda expressions. For example, it would consider 111 | # @ x {result x} and @ y {result y} different. 112 | # 113 | # The return value of `remove-hook' is the new value of `hook'. 114 | #:end docstring: 115 | 116 | ###;;;autoload 117 | fn remove-hook hook function \ 118 | { 119 | # speed hack: if it looks like the function isn't a member via pattern 120 | # matching, avoid an expensive element-by-element search. 121 | if { ! ~ $function $$hook } \ 122 | { result $$hook } \ 123 | { 124 | let (list = $$hook; nlist =) 125 | { 126 | while { ! ~ $list () } \ 127 | { 128 | if { ~ $list(1) $function } \ 129 | { 130 | $hook = $nlist $list(2 ...) 131 | list = 132 | } \ 133 | { 134 | nlist = $nlist $list(1) 135 | list = $list(2 ...) 136 | } 137 | } 138 | result $$hook 139 | } 140 | } 141 | } 142 | 143 | provide hook 144 | 145 | # hook.es ends here 146 | -------------------------------------------------------------------------------- /examples/friedman/lib/load.es: -------------------------------------------------------------------------------- 1 | # load.es --- load or autoload es library files 2 | # Author: Noah Friedman 3 | # Created: 1993-04-24 4 | # Last modified: 1993-05-26 5 | # Public domain 6 | 7 | # Commentary: 8 | 9 | # This file uses the `fpath-search' function defined in the `require' 10 | # package to do searches through fpath. 11 | 12 | # Code: 13 | 14 | # This require may look like a catch-22, but signalling an error will draw 15 | # the attention of whoever is interacting with the interpreter. 16 | require require 17 | 18 | #:docstring autoload: 19 | # Usage: autoload function pathname 20 | # 21 | # Declare a function that does not yet have a definition. The definition 22 | # is loaded from a file the first time the function is run. 23 | # 24 | # When the function actually needs to be loaded, the variable `fpath' is 25 | # searched as a pathlist for a file of the same name as the autoloaded 26 | # function. First, the file name with a `.es' suffix is appended and 27 | # searched for through all of fpath, then the file name itself is tried if 28 | # it hasn't been found already. The file is then loaded and the function 29 | # is executed. 30 | # 31 | # Note: if 2nd (optional) argument to autoload is given, then autoload will 32 | # expect to be able to load the definition of the function from that file 33 | # (with or without a `.es' suffix). For more details consult the docstring 34 | # for fpath-search. 35 | #:end docstring: 36 | 37 | ###;;;autoload 38 | fn autoload func file \ 39 | { 40 | if { ~ $func () } \ 41 | { throw error $0 Usage: $0 '[function] {filename}' } 42 | 43 | # Don't do anything if func is already defined. 44 | if { ~ $(fn-^$func) () } \ 45 | { 46 | file = $file(1) # Only one filename arg should have been given. 47 | if { ~ $file () } \ 48 | { file = $func } 49 | fn-$func = @ { autoload-internal $func $file $* } 50 | } 51 | } 52 | 53 | fn autoload-internal func file * \ 54 | { 55 | let (orig-fn = $(fn-$func)) 56 | { 57 | load $file 58 | if { ~ $orig-fn $(fn-$func) } \ 59 | { throw error $0 $0: autoload failed. } 60 | } 61 | $func $* 62 | } 63 | 64 | #:docstring load: 65 | # Usage: load [library] 66 | # 67 | # Load (source) contents of an es library, searching fpath for the file 68 | # (see fpath-search) if library name has no `/' chars in it (i.e. no path 69 | # name was specified). 70 | #:end docstring: 71 | 72 | ###;;;autoload 73 | fn load \ 74 | { 75 | if { ~ $* () } { throw error $0 Usage: $0 [file] } 76 | 77 | if { ~ $1 */* } \ 78 | { . $1 } \ 79 | { 80 | let (file = <={ fpath-search $1 }) 81 | if { ! ~ $file () } \ 82 | { . $file } \ 83 | { throw error $0 $0: could not find '`'$1'''' in fpath } 84 | } 85 | } 86 | 87 | provide load 88 | 89 | # load.es ends here 90 | -------------------------------------------------------------------------------- /examples/friedman/lib/mailcheck.es: -------------------------------------------------------------------------------- 1 | # mailcheck.es 2 | # Author: Noah Friedman 3 | # Created: 1993-09-29 4 | # Last modified: 1993-09-29 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | require hook 11 | 12 | #:docstring mailcheck: 13 | # See documentation for `mail-spool-check'. 14 | #:end docstring: 15 | 16 | #:docstring mail-spool-check: 17 | # This package ties itself into `repl-prompt-hook' so that it 18 | # is run immediately before every prompt. The variable `mail-spool' is a 19 | # list of files to search for new mail---if unset when this package is 20 | # loaded, it is initialized to search for a file named the same as the 21 | # value $USER in /var/mail, /usr/spool/mail, and /usr/mail. Reassigning 22 | # this variable can have it check for additions to any file 23 | # (e.g. /var/log/messages). 24 | # 25 | # When new mail is found, the hook `mail-spool-check-hook' is run, with 26 | # each function in the hook called with the name of the file where mail was 27 | # found. The hooks will be called separately for each file in $mail-spool 28 | # that is new. The default value of this hook is `mail-spool-check-notify'. 29 | # 30 | # mail-spool-check can be disabled either by unsetting `mail-spool' or by 31 | # doing: remove-hook repl-prompt-hook mail-spool-check 32 | #:end docstring: 33 | 34 | # Initialize mail-spool variable if unset. It's probably harmless to check 35 | # in all three standard places, so do it and don't make user guess. 36 | if { ~ $mail-spool () } \ 37 | { 38 | for (dir = /var/mail /usr/spool/mail /usr/mail) 39 | mail-spool = $mail-spool $dir/$USER 40 | } 41 | 42 | let (tmpfile = /tmp/mailcheck$pid) 43 | { 44 | ###;;;autoload 45 | fn mail-spool-check \ 46 | { 47 | if { ! ~ $mail-spool () } \ 48 | { 49 | if { ! access $tmpfile } \ 50 | { > $tmpfile } \ 51 | { 52 | * = `{ ls -t $mail-spool $tmpfile >[2] /dev/null } 53 | for (file = $*) 54 | { 55 | if { ~ $file $tmpfile } \ 56 | { 57 | > $tmpfile 58 | break 59 | } \ 60 | { test -s $file } \ 61 | { run-hooks $0^-hook $file } 62 | } 63 | } 64 | } 65 | } 66 | } 67 | 68 | ###;;;autoload 69 | fn mail-spool-check-notify \ 70 | { 71 | echo '#' There is new mail in $* >[1=2] 72 | } 73 | 74 | add-hook repl-prompt-hook mail-spool-check 75 | add-hook mail-spool-check-hook mail-spool-check-notify 76 | 77 | provide mailcheck 78 | 79 | # mailcheck.es ends here 80 | -------------------------------------------------------------------------------- /examples/friedman/lib/mkautoloads.es: -------------------------------------------------------------------------------- 1 | # mkautoloads.es --- es front end for mkautoloads script 2 | # Author: Noah Friedman 3 | # Created: 1993-09-26 4 | # Last modified: 1993-09-28 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | mkautoloads-file-name = $sinit/es/lib/.autoloads.es 11 | 12 | #:docstring mkautoloads: 13 | # Usage: mkautoloads 14 | # 15 | # Front end for the `mkautoloads' shell script. This function calls the 16 | # shell script with the appropriate arguments for es. 17 | #:end docstring: 18 | 19 | ###;;;autoload 20 | fn mkautoloads \ 21 | { 22 | local (fn-$0 =) 23 | $0 --autoload-file\=$mkautoloads-file-name --verbose -- $sinit/es/lib/*.es 24 | } 25 | 26 | provide mkautoloads 27 | 28 | # mkautoloads.es ends here 29 | -------------------------------------------------------------------------------- /examples/friedman/lib/path-list.es: -------------------------------------------------------------------------------- 1 | # path-list.es --- functions for parsing path files 2 | # Author: Noah Friedman 3 | # Created: 1992-05-11 4 | # Public domain 5 | 6 | # $Id: path-list.es,v 1.2 1994/11/01 21:10:18 friedman Exp $ 7 | 8 | # Commentary: 9 | # Code: 10 | 11 | #:docstring path-list: 12 | # Usage: path-list [file1] {files...} 13 | # 14 | # Parse {FILE1 FILES...}, which is assumed to contain a list of names 15 | # separated by whitespace (tabs, spaces, or newlines), and construct a list 16 | # consisting of those names. Comments in the file (lines beginning 17 | # with `#') are ignored, but names and comments cannot exist on the 18 | # same line. 19 | #:end docstring: 20 | 21 | ###;;;autoload 22 | fn path-list \ 23 | { 24 | if { ~ $#* 0 } \ 25 | { throw error $0 usage: $0 [file1] '{...}' } 26 | 27 | eval result `{ sed -e '/^[ ]*[#].*/d' $* } 28 | } 29 | 30 | #:docstring path-list-verify: 31 | # Usage: path-list-verify [predicate] [file1] {files...} 32 | # 33 | # Like path-list, but don't return names that don't satisfy predicate. 34 | # Some standard predicates available include: 35 | # path-list:name-exists? 36 | # path-list:name-exists-as-file? 37 | # path-list:name-exists-as-directory? 38 | #:end docstring: 39 | 40 | ###;;;autoload 41 | fn path-list-verify predicate names \ 42 | { 43 | let (newlist =) 44 | { 45 | for (dir = <={ path-list $names }) 46 | if { $predicate $dir } \ 47 | { newlist = $newlist $dir } 48 | 49 | result $newlist 50 | } 51 | } 52 | 53 | fn path-list:name-exists? { access $1 } 54 | fn path-list:name-exists-as-file? { access -f $1 } 55 | fn path-list:name-exists-as-directory? { access -d $1 } 56 | 57 | provide path-list 58 | 59 | # path-list.es ends here 60 | -------------------------------------------------------------------------------- /examples/friedman/lib/plist.es: -------------------------------------------------------------------------------- 1 | # plist.es --- property lists for symbols 2 | # Author: Noah Friedman 3 | # Created: 1993-11-07 4 | # Last modified: 1993-11-07 5 | # Public domain 6 | 7 | # Commentary: 8 | 9 | # TODO: Keep the plist symbols in a boxed closure such that it's possible 10 | # to add new symbols dynamically to the separate environment. Might 11 | # consider waiting until 1st-class environments are implemented. 12 | 13 | # Code: 14 | 15 | #:docstring get: 16 | # Usage: get [symbol] [propname] 17 | # 18 | # Return the value of SYMBOL's PROPNAME property. 19 | # This is the last VALUE stored with `put SYMBOL PROPNAME VALUE'. 20 | #:end docstring: 21 | 22 | ###;;;autoload 23 | fn get sym prop \ 24 | { 25 | let (plist = $(plist-$sym) 26 | result =) 27 | { 28 | if { ~ $plist $prop } \ 29 | { 30 | while { ! ~ $plist () } \ 31 | { 32 | if { ~ $plist(1) $prop } \ 33 | { 34 | result = <={ $plist(2) } 35 | plist = 36 | } 37 | plist = $plist(3 ...) 38 | } 39 | } 40 | result $result 41 | } 42 | } 43 | 44 | #:docstring put: 45 | # Usage: put [symbol] [propname] [value] 46 | # 47 | # Store SYMBOL's PROPNAME property with value VALUE. 48 | # It can be retrieved with `get SYMBOL PROPNAME'. 49 | #:end docstring: 50 | 51 | ###;;;autoload 52 | fn put sym prop val \ 53 | { 54 | # box-plist-value's definition is quoted to avoid creating an extra closure. 55 | # (There's no real harm in this except that it consumes space. 56 | let (box-plist-value = '@ { result { result $* } }' 57 | plist = $(plist-$sym) 58 | value = 59 | new-plist =) 60 | { 61 | value = <={ $box-plist-value $val } 62 | if { ~ $plist $prop } \ 63 | { 64 | while { ! ~ $plist () } \ 65 | { 66 | if { ~ $plist(1) $prop } \ 67 | { 68 | new-plist = $new-plist $plist(1) $value $plist(3 ...) 69 | plist = 70 | } \ 71 | { 72 | new-plist = $new-plist $plist(... 2) 73 | plist = $plist(3 ...) 74 | } 75 | } 76 | } \ 77 | { new-plist = $prop $value $plist } 78 | 79 | plist-^$sym = $new-plist 80 | } 81 | } 82 | 83 | #:docstring symbol-plist: 84 | # Usage: symbol-plist [symbol] 85 | # 86 | # Return SYMBOL's property list. 87 | #:end docstring: 88 | 89 | ###;;;autoload 90 | fn symbol-plist { result $(plist-$1) } 91 | 92 | #:docstring symbol-property-names: 93 | # Usage: symbol-property-names [symbol] 94 | # 95 | # Return a list of all SYMBOL's property names. 96 | #:end docstring: 97 | 98 | ###;;;autoload 99 | fn symbol-property-names \ 100 | { 101 | * = <={ symbol-plist $1 } 102 | let (res =) 103 | { 104 | while { ! ~ $* () } \ 105 | { 106 | res = $res $1 107 | * = $*(3 ...) 108 | } 109 | result $res 110 | } 111 | } 112 | 113 | #:docstring symbol-property-values: 114 | # Usage: symbol-property-values [symbol] 115 | # 116 | # Return a list of all values associated with SYMBOL's property names. 117 | # 118 | # The values are boxed to get around es' array flattening. To get at the 119 | # actual values, call the value as a procedure and save the result. 120 | #:end docstring: 121 | 122 | ###;;;autoload 123 | fn symbol-property-values \ 124 | { 125 | * = <={ symbol-plist $1 } 126 | let (res =) 127 | { 128 | while { ! ~ $* () } \ 129 | { 130 | res = $res $2 131 | * = $*(3 ...) 132 | } 133 | result $res 134 | } 135 | } 136 | 137 | provide plist 138 | 139 | # plist.es ends here 140 | -------------------------------------------------------------------------------- /examples/friedman/lib/primitives.es: -------------------------------------------------------------------------------- 1 | # primitives.es --- primitive es definitions 2 | # Author: Noah Friedman 3 | # Created: 1993-05-01 4 | # Public domain 5 | 6 | # $Id: primitives.es,v 1.2 2000/12/18 11:17:38 friedman Exp $ 7 | 8 | # Commentary: 9 | # Code: 10 | 11 | require hook 12 | 13 | ###;;;autoload 14 | fn-%and = $&noreturn @ first rest \ 15 | { 16 | let (result = <={ $first }) 17 | { 18 | if { ~ $rest () } \ 19 | { result $result } \ 20 | { 21 | if { result $result } \ 22 | { %and $rest } \ 23 | { result $result } 24 | } 25 | } 26 | } 27 | 28 | # This is no longer needed in es 0.91. 29 | # # Kludge to prevent the handler from catching return. 30 | # ###;;;autoload 31 | # fn-catch = $&noreturn @ handler body \ 32 | # { 33 | # local (fn-'$$catch-handler$$' = $&noreturn $handler) 34 | # $&catch '$$catch-handler$$' { $body } 35 | # } 36 | 37 | ###;;;autoload 38 | fn-eval = $&noreturn @ { '{'^$^*^'}' } 39 | 40 | ###;;;autoload 41 | fn exit { throw exit $* } 42 | 43 | ###;;;autoload 44 | fn-false = { result 1 } 45 | 46 | if { ! ~ $fn-%flatten $&flatten } \ 47 | { 48 | ###;;;autoload 49 | fn %flatten separator args \ 50 | { 51 | if { ~ $#args 0 } \ 52 | { throw error $0 usage: $0 separator [args ...] } 53 | let (result =) 54 | { 55 | result = $args(1) 56 | for (elt = $args(2 ...)) 57 | result = $result^$separator^$elt 58 | result $result 59 | } 60 | } 61 | } 62 | 63 | ###;;;autoload 64 | fn fork \ 65 | { 66 | $&fork \ 67 | { 68 | run-hooks fork-hook $* 69 | { $* } 70 | } 71 | } 72 | 73 | ###;;;autoload 74 | fn-%not = $&noreturn @ { if { $* } { result 1 } {} } 75 | 76 | ###;;;autoload 77 | fn-%or = $&noreturn @ first rest \ 78 | { 79 | if { ~ $first () } { first = false } 80 | let (result = <={ $first }) 81 | { 82 | if { ~ $rest () } \ 83 | { result $result } \ 84 | { 85 | if { result $result } \ 86 | { result $result } \ 87 | { %or $rest } 88 | } 89 | } 90 | } 91 | 92 | ###;;;autoload 93 | fn %pathsearch \ 94 | { 95 | let (result = <={ run-hooks-until @ { ! result $1 } %pathsearch-hook $* }) 96 | result $result 97 | } 98 | 99 | ###;;;autoload 100 | fn %pathsearch-default { access -n $* -1e -xf $path } 101 | 102 | if { ! ~ $fn-%split $&split } \ 103 | { 104 | ###;;;autoload 105 | fn %split separator args \ 106 | { 107 | if { ~ $#args 0 } \ 108 | { throw error $0 usage: $0 separator [args ...] } 109 | let (result =) 110 | { 111 | for (elt = <={ %fsplit $separator $args }) 112 | if { ! ~ $elt '' } { result = $result $elt } 113 | result $result 114 | } 115 | } 116 | } 117 | 118 | ###;;;autoload 119 | fn-true = {} 120 | 121 | ###;;;autoload 122 | fn-while = $&noreturn @ cond body \ 123 | { 124 | catch @ e value \ 125 | { 126 | if { ! ~ $e break } \ 127 | { throw $e $value } 128 | result $value 129 | } \ 130 | { 131 | let (result =) 132 | forever \ 133 | { 134 | if { ! $cond } \ 135 | { throw break $result } \ 136 | { result = <={ $body } } 137 | } 138 | } 139 | } 140 | 141 | 142 | add-hook %pathsearch-hook %pathsearch-default 143 | 144 | provide primitives 145 | 146 | # primitives.es ends here 147 | -------------------------------------------------------------------------------- /examples/friedman/lib/prompt.es: -------------------------------------------------------------------------------- 1 | # prompt.es --- fancy interactive prompt features 2 | # Author: Noah Friedman 3 | # Created: 1993-04-25 4 | # Public domain 5 | 6 | # $Id: prompt.es,v 1.2 2000/12/18 11:17:38 friedman Exp $ 7 | 8 | # Commentary: 9 | 10 | # This provides features intended for interactive use. 11 | 12 | # Code: 13 | 14 | require hook 15 | 16 | # Compress $home component of pwd into `~' 17 | ###;;;autoload 18 | fn pwd-pretty \ 19 | { 20 | let (pwd = `pwd; pwdl = ; homel =) 21 | { 22 | if { ~ $pwd $home } \ 23 | { result '~' } \ 24 | { ! ~ $pwd $home^* } \ 25 | { result $pwd } \ 26 | { 27 | pwdl = <={ %split '/' $pwd } 28 | homel = <={ %split '/' '.' $home } 29 | pwdl = $pwdl($#homel ...) 30 | %flatten '/' '~' $pwdl 31 | } 32 | } 33 | } 34 | 35 | ###;;;autoload 36 | fn-prompt-set-cnp-long = \ 37 | { 38 | fn prompt-set \ 39 | { 40 | prompt = 41 | if { ! ~ $USER () } \ 42 | { 43 | prompt = $prompt 'user = '^$USER 44 | } 45 | if { ! ~ $HOSTNAME () } \ 46 | { 47 | prompt = $prompt 'host = '^$HOSTNAME 48 | } 49 | if { ! ~ $es-SHLVL () } \ 50 | { 51 | prompt = $prompt 'shlvl = '^$#es-SHLVL 52 | } 53 | prompt = '# '^<={ %flatten \t $prompt } 54 | prompt = $prompt^\n^'# cwd = '^<={pwd-pretty}^\n'; ' 55 | 56 | # No continuation prompt in cnp mode. This gives the interpreter a more 57 | # lisp listener--like feel. 58 | #prompt = $prompt '>' 59 | result () 60 | } 61 | prompt-set 62 | } 63 | 64 | ###;;;autoload 65 | fn-prompt-set-cnp-short = \ 66 | { 67 | fn prompt-set \ 68 | { 69 | prompt = '# cwd = '^<={pwd-pretty}^\n^'; ' 70 | 71 | # No continuation prompt in cnp mode. This gives the interpreter a more 72 | # lisp listener--like feel. 73 | #prompt = $prompt '>' 74 | result () 75 | } 76 | prompt-set 77 | } 78 | 79 | ###;;;autoload 80 | fn-prompt-set-long = \ 81 | { 82 | fn prompt-set \ 83 | { 84 | prompt = '' 85 | if { ! ~ $USER () } { prompt = $prompt$USER } 86 | if { ! ~ $HOSTNICK () } { prompt = $prompt'@'$HOSTNICK } 87 | if { ! ~ $es-SHLVL () } { prompt = $prompt'['$#es-SHLVL']' } 88 | if { ! ~ $prompt '' () } { prompt = $prompt': ' } 89 | prompt = $prompt^<={pwd-pretty}^' ; ' 90 | # Add secondary prompt 91 | prompt = $prompt '> ' 92 | result () 93 | } 94 | prompt-set 95 | } 96 | 97 | ###;;;autoload 98 | fn-prompt-set-short = \ 99 | { 100 | fn prompt-set \ 101 | { 102 | prompt = ( 103 | <={pwd-pretty}^' ; ' 104 | '> ' 105 | ) 106 | result () 107 | } 108 | prompt-set 109 | } 110 | 111 | add-hook cd-hook prompt-set 112 | add-hook popd-hook prompt-set 113 | add-hook pushd-hook prompt-set 114 | add-hook repl-interactive-start-hook prompt-set 115 | 116 | # Initialize 117 | prompt-set-short 118 | 119 | provide prompt 120 | 121 | # prompt.es ends here 122 | -------------------------------------------------------------------------------- /examples/friedman/lib/repeat.es: -------------------------------------------------------------------------------- 1 | # repeat.es --- repeat a complex command multiple times 2 | # Author: Noah Friedman 3 | # Created: 1993-05-26 4 | # Last modified: 1993-05-26 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | #:docstring repeat: 11 | # Usage: repeat n command ... 12 | # 13 | # Repeat `command' `n' number of times. 14 | #:end docstring: 15 | 16 | ###;;;autoload 17 | fn-repeat = $&noreturn @ n cmd \ 18 | { 19 | if { ~ $n *[~0-9]* } \ 20 | { throw error $0 $0: argument '`n''' must be a number. } 21 | catch @ e value \ 22 | { 23 | if { ! ~ $e fn-repeat:break } \ 24 | { throw $e $value } 25 | result $value 26 | } \ 27 | { 28 | let (result = 0; i =) 29 | forever \ 30 | { 31 | if { ~ $#i $n } { throw fn-repeat:break $result } 32 | i = $i '' 33 | result = <={ $cmd } 34 | } 35 | } 36 | } 37 | 38 | provide repeat 39 | 40 | # repeat.es ends here 41 | -------------------------------------------------------------------------------- /examples/friedman/lib/require.es: -------------------------------------------------------------------------------- 1 | # require.es --- simple package system for es 2 | # Author: Noah Friedman 3 | # Created: 1993-04-24 4 | # Last modified: 1993-10-02 5 | # Public domain 6 | 7 | # Commentary: 8 | 9 | # "Yes! I know how you think, you Lisp fanatic!" 10 | # --Ben A. Mesander 11 | 12 | # The search path for libraries comes from the `fpath' array (or the 13 | # colon-separated `FPATH' variable; setting one will update the other 14 | # automatically). It has no default value and must be set by the user. 15 | 16 | # (TODO: work around this. It should be possible in es to save and restore 17 | # previous definitions by messing with the various hooks.) 18 | # Warning: because `require' ultimately uses the builtin `.' command to 19 | # read in files, it has no way of undoing the commands contained in the 20 | # file if there is an error or if no `provide' statement appeared (this 21 | # differs from the lisp implementation of require, which normally undoes 22 | # most of the forms that were loaded if the require fails). Therefore, to 23 | # minimize the number of problems caused by requiring a faulty package 24 | # (such as syntax errors in the source file) it is better to put the 25 | # provide at the end of the file, rather than at the beginning. 26 | 27 | # Code: 28 | 29 | # This defines a null function that allows one to put form feeds (^L) in 30 | # scripts without causing an undefined command to be executed. 31 | fn-\f = {} 32 | 33 | # Define settors for `fpath' and FPATH to keep them in sync. 34 | # (Adapted from the default PATH/path settors in initial.es.) 35 | set-fpath = @ { local (set-FPATH = ) FPATH = <={ %flatten : $* }; result $* } 36 | set-FPATH = @ { local (set-fpath = ) fpath = <={ %fsplit : $* }; result $* } 37 | 38 | # FEATURES is a lexically scoped variable that should only be directly 39 | # accessible to the various functions which actually manipulate it. 40 | # Because shared lexically scoped environments become separate across shell 41 | # invocations (at least as of 0.83), we have just one function that 42 | # performs all operations on the FEATURES variable. Other routines merely 43 | # access it indirectly. 44 | 45 | # Preserve value if this file is reloaded. 46 | let (FEATURES = <={ if { ~ $fn-features () } \ 47 | { result () } \ 48 | { result <=features } 49 | } ) 50 | { 51 | fn require:access-feature \ 52 | { 53 | if { ~ $1 featurep } \ 54 | { ~ $FEATURES $2 } \ 55 | { ~ $1 features } \ 56 | { result $FEATURES } \ 57 | { ~ $1 provide } \ 58 | { 59 | for (feature = $*(2 ...)) 60 | if { ! ~ $FEATURES $feature } \ 61 | { FEATURES = $feature $FEATURES } 62 | result 0 63 | } 64 | } 65 | } 66 | 67 | #:docstring featurep: 68 | # Usage: featurep argument 69 | # 70 | # Returns 0 (true) if argument is a provided feature. Returns 1 (false) 71 | # otherwise. 72 | #:end docstring: 73 | 74 | ###;;;autoload 75 | fn-featurep = require:access-feature featurep 76 | 77 | #:docstring features: 78 | # Usage: features 79 | # 80 | # Returns a list of all currently provided features. 81 | #:end docstring: 82 | 83 | ###;;;autoload 84 | fn-features = require:access-feature features 85 | 86 | #:docstring provide: 87 | # Usage: provide symbol ... 88 | # 89 | # Register a list of symbols as provided features. 90 | #:end docstring: 91 | 92 | ###;;;autoload 93 | fn-provide = require:access-feature provide 94 | 95 | #:docstring require: 96 | # Usage: require feature {file} 97 | # 98 | # load feature if it is not already provided. Note that `require' does not 99 | # call `provide' to register features. The loaded file must do that 100 | # itself. If the package does not explicitly do a `provide' after being 101 | # loaded, `require' will cause an error exception. 102 | # 103 | # Optional argument `file' means to try to load feature from `file'. If no 104 | # file argument is given, or if `file' doesn't contain any slashes, 105 | # `require' searches through `fpath' (see `fpath-search') for the 106 | # appropriate file. 107 | #:end docstring: 108 | 109 | ###;;;autoload 110 | fn require feature file \ 111 | { 112 | if { ! featurep $feature } \ 113 | { 114 | if { ~ $file */* } \ 115 | { . $file } \ 116 | { 117 | let (f = $feature) 118 | { 119 | if { ! ~ $file () } { f = $file } 120 | f = <={ fpath-search $f } 121 | if { ! ~ $f () } { . $f } 122 | } 123 | } 124 | 125 | if { ! featurep $feature } \ 126 | { throw error $0 $0: $feature: feature was not provided. } 127 | } 128 | 129 | result 0 130 | } 131 | 132 | #:docstring fpath-search: 133 | # Usage: fpath-search filename {path ...} 134 | # 135 | # Search $fpath for `filename' or, if `path' (a list) is specified, search 136 | # those directories instead of $fpath. First the path is searched for an 137 | # occurrence of `filename.es', then a second search is made for just 138 | # `filename'. 139 | #:end docstring: 140 | 141 | ###;;;autoload 142 | fn fpath-search name path \ 143 | { 144 | if { ~ $path () } \ 145 | { path = $fpath } 146 | 147 | let (result =) 148 | { 149 | for (file = $name^'.es' $name) 150 | { 151 | file = <={ access -f -1 -n $file $path } 152 | if { ! ~ $file () } \ 153 | { 154 | result = $file 155 | break 156 | } 157 | } 158 | result $result 159 | } 160 | } 161 | 162 | provide require 163 | 164 | # require.es ends here 165 | -------------------------------------------------------------------------------- /examples/friedman/lib/setterm.es: -------------------------------------------------------------------------------- 1 | # setterm.es 2 | # Author: Noah Friedman 3 | # Created: 1993-09-25 4 | # Public domain 5 | 6 | # $Id: setterm.es,v 1.2 1995/08/25 19:18:11 friedman Exp $ 7 | 8 | # Commentary: 9 | 10 | # The function `set-termcap' expects the variable `termcapfiles' to be 11 | # defined to a list of termcap files to search. If this variable is unset, 12 | # it will do nothing. 13 | 14 | # The function `set-terminfo' expects the variable `terminfodirs' to be 15 | # defined to a list of terminfo directories to search. If this variable is 16 | # unset, it will do nothing. 17 | 18 | # Code: 19 | 20 | ###;;;autoload 21 | fn setterm \ 22 | { 23 | catch @ e args \ 24 | { 25 | if { ~ $e signal && ~ $args(1) sigint } \ 26 | { result 1 } \ 27 | { throw $e $args } 28 | } \ 29 | { 30 | while {} \ 31 | { 32 | echo -n 'TERM = ('^$^default-term^') ' >[1=2] 33 | read TERM 34 | 35 | if { ~ $TERM () } \ 36 | { TERM = $default-term } 37 | 38 | if { ! set-terminfo } \ 39 | { echo 'warning: no terminfo description for' $TERM >[1=2] } 40 | 41 | if { set-termcap } \ 42 | { break } \ 43 | { echo 'Unknown terminal type:' $TERM >[1=2] } 44 | } 45 | 46 | if { ~ $TERM aixterm } \ 47 | { 48 | TERM = xterm 49 | tset -Q <[0=] 50 | } \ 51 | { ~ $^TERM '' emacs emacs-virtual xsession } \ 52 | {} \ 53 | { tset -Q <[0=] } 54 | } 55 | } 56 | 57 | ###;;;autoload 58 | fn set-termcap \ 59 | { 60 | let (re = '(^'$TERM')|(\|'$TERM'\|)|(\|'$TERM':)' 61 | result = 1) 62 | { 63 | for (f = $termcapfiles) 64 | if { egrep $re $f > /dev/null >[2=1] } \ 65 | { 66 | TERMCAP = $f 67 | result = 0 68 | break 69 | } 70 | result $result 71 | } 72 | } 73 | 74 | ###;;;autoload 75 | fn set-terminfo \ 76 | { 77 | let (result = 1) 78 | { 79 | for (f = $terminfodirs) 80 | if { access -f $f } \ 81 | { 82 | TERMINFO = $f 83 | result = 0 84 | break 85 | } 86 | result $result 87 | } 88 | } 89 | 90 | provide setterm 91 | 92 | # setterm.es ends here 93 | -------------------------------------------------------------------------------- /examples/friedman/lib/stack.es: -------------------------------------------------------------------------------- 1 | # stack.es --- trivial stack implementation 2 | # Author: Noah Friedman 3 | # Created: 1994-12-14 4 | # Public domain 5 | 6 | # $Id: stack.es,v 1.1 1994/12/14 19:01:02 friedman Exp $ 7 | 8 | # Commentary: 9 | 10 | # Based on an idea by Harald Hanche-Olsen . 11 | 12 | # Code: 13 | 14 | fn make-stack s \ 15 | { 16 | result { result ( 17 | # push 18 | @ i { s = $i $s } 19 | 20 | # pop 21 | { 22 | let (i = $s(1)) 23 | { 24 | s = $s(2 ...) 25 | result $i 26 | } 27 | } 28 | 29 | # list 30 | { result $s } 31 | ) 32 | } 33 | } 34 | 35 | fn stack-push! obj args { let (fun = <={ $obj }) { $fun(1) $args } } 36 | fn stack-pop! obj { let (fun = <={ $obj }) { $fun(2) } } 37 | fn stack-list obj { let (fun = <={ $obj }) { $fun(3) } } 38 | 39 | provide stack 40 | 41 | # stack.es ends here 42 | -------------------------------------------------------------------------------- /examples/friedman/lib/type-pred.es: -------------------------------------------------------------------------------- 1 | # type-pred.es --- misc type predicates for symbols 2 | # Author: Noah Friedman 3 | # Created: 1992-06-04 4 | # Last modified: 1993-05-20 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | #:docstring alphabetic?: 11 | # Usage: alphabetic? EXPR 12 | # 13 | # Return true if EXPR consists entirely of alphabetic characters (either 14 | # upper or lower case), false otherwise. 15 | #:end docstring: 16 | 17 | ###;;;autoload 18 | fn alphabetic? { ! ~ $1 '' *[~a-zA-Z]* } 19 | 20 | #:docstring alphanumeric?: 21 | # Usage: alphanumeric? EXPR 22 | # 23 | # Return true if EXPR consists entirely of alphabetic characters (either 24 | # upper or lower case) and/or numeric characters. Otherwise return false. 25 | #:end docstring: 26 | 27 | ###;;;autoload 28 | fn alphanumeric? { ! ~ $1 '' *[~a-zA-Z0-9]* } 29 | 30 | #:docstring lowercase?: 31 | # Usage: lowercase? STRING 32 | # 33 | # Return true if STRING consists entirely of lower case alphabetic 34 | # characters, otherwise return false. 35 | #:end docstring: 36 | 37 | ###;;;autoload 38 | fn lowercase? { ! ~ $1 '' *[~a-z]* } 39 | 40 | #:docstring numeric?: 41 | # Usage: numeric? EXPR 42 | # 43 | # Return true if EXPR consists entirely of numeric characters, false 44 | # otherwise. 45 | #:end docstring: 46 | 47 | ###;;;autoload 48 | fn numeric? { ! ~ $1 *[~0-9]* } 49 | 50 | #:docstring punctuation?: 51 | # Usage: punctuation? STRING 52 | # 53 | # Return true if STRING consists entirely of punctuation characters---that 54 | # is, any characters in the set 55 | # 56 | # []{}()<>!*~@#%^=_+-*$&!\`\|;:'\",./? 57 | # 58 | # Return false if any other characters appear in STRING. 59 | #:end docstring: 60 | #TODO: make this work. 61 | #-###;;;autoload 62 | #fn punctuation? { ! ~ $1 *[~]~@'#'%'^'=_+-{}()*$&!'`'|;:''",.<>/?[]* } 63 | 64 | #:docstring uppercase?: 65 | # Usage: uppercase? STRING 66 | # 67 | # Return true if STRING consists entirely of upper case alphabetic 68 | # characters, false otherwise. 69 | #:end docstring: 70 | 71 | ###;;;autoload 72 | fn uppercase? { ! ~ $1 '' *[~A-Z]* } 73 | 74 | #:docstring whitespace?: 75 | # Usage: whitespace? STRING 76 | # 77 | # Return true if STRING consists entirely of whitespace characters. 78 | # Whitespace is defined to be spaces, tabs, newlines, or BEL characters 79 | # (C-g). Return false if STRING contains any other characters. 80 | #:end docstring: 81 | 82 | ###;;;autoload 83 | fn whitespace? { ! ~ $1 *[~\t\ \007\010\013]* } 84 | 85 | provide type-pred 86 | 87 | # type-pred.es ends here 88 | -------------------------------------------------------------------------------- /examples/friedman/lib/which.es: -------------------------------------------------------------------------------- 1 | # which.es 2 | # Author: Noah Friedman 3 | # Created: 1993-05-01 4 | # Last modified: 1993-05-01 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | #:docstring which: 11 | # Usage: which PROG 12 | # 13 | # Like `where', but prints only first occurence. 14 | #:end docstring: 15 | 16 | ###;;;autoload 17 | fn which { echo <={ access -1fx -n $1 $path } } 18 | 19 | #:docstring where: 20 | # Usage: where PROG 21 | # 22 | # Print the paths of the all occurances of PROG as an executable program 23 | # (i.e. not a directory, character/block special device, etc) in PATH. 24 | # Returns 0 if at least one program is found, 1 otherwise. 25 | #:end docstring: 26 | 27 | ###;;;autoload 28 | fn where \ 29 | { 30 | for (p = $path) { access -fx $p'/'$1 && echo $p'/'$1 } 31 | result 0 32 | } 33 | 34 | #:docstring nth-prog-in-path: 35 | # Usage: nth-prog-in-path n program 36 | # 37 | # Find and echo path of the nth occurance of program in PATH. 38 | #:end docstring: 39 | 40 | ###;;;autoload 41 | fn nth-prog-in-path n prog \ 42 | { 43 | local (l =) 44 | { 45 | for (p = $path) { access -fx $p'/'$prog && l = $l $p'/'$prog } 46 | echo $l($n) 47 | } 48 | } 49 | 50 | provide which 51 | 52 | # which.es ends here 53 | -------------------------------------------------------------------------------- /examples/friedman/lib/y-or-n-p.es: -------------------------------------------------------------------------------- 1 | # y-or-n-p.es 2 | # Author: Noah Friedman 3 | # Created: 1993-05-26 4 | # Last modified: 1993-05-26 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | #:docstring y-or-n-p: 11 | # Usage: y-or-n-p QUERY 12 | # 13 | # Print QUERY on stderr, then read stdin for a y-or-n response. Actually, 14 | # the user may type anything they like, but the first character must be a 15 | # `y', `n', `q', or `!', otherwise the question is repeated until such an 16 | # answer is obtained. 17 | # 18 | # If user typed `y', y-or-n-p returns `y'. 19 | # 20 | # If user typed `n', y-or-n-p returns `n'. 21 | # 22 | # If user typed `!', y-or-n-p returns `!'. This is an indication to the 23 | # caller that no more queries should be made. Assume `y' for all the rest. 24 | # 25 | # If user typed `q', y-or-n-p returns `q'. This is an indication to the 26 | # caller that no more queries should be made. Assume `n' for all the rest. 27 | # 28 | #:end docstring: 29 | 30 | ###;;;autoload 31 | fn y-or-n-p \ 32 | { 33 | let (ans =) 34 | { 35 | while { ~ $ans () } \ 36 | { 37 | echo -n $* >[1=2] 38 | ans = `line 39 | if { ~ $ans y* Y* } \ 40 | { ans = y } \ 41 | { ~ $ans n* N* } \ 42 | { ans = n } \ 43 | { ~ $ans q* Q* } \ 44 | { ans = q } \ 45 | { ! ~ $ans ! } \ 46 | { 47 | ans = 48 | echo 'Please answer one of `y'', `n'', `q'', or `!''' >[1=2] 49 | } 50 | } 51 | result $ans 52 | } 53 | } 54 | 55 | #:docstring yes-or-no-p: 56 | # Usage: yes-or-no-p QUERY 57 | # 58 | # Like y-or-n-p, but require a full `yes', `no', `yes!', or `quit' response. 59 | # Return values are the same as y-or-n-p's. 60 | #:end docstring: 61 | 62 | ###;;;autoload 63 | fn yes-or-no-p \ 64 | { 65 | let (ans =) 66 | { 67 | while { ~ $ans () } \ 68 | { 69 | echo -n $* >[1=2] 70 | ans = `line 71 | if { ~ $ans yes YES } \ 72 | { ans = y } \ 73 | { ~ $ans no NO } \ 74 | { ans = n } \ 75 | { ~ $ans quit QUIT } \ 76 | { ans = q } \ 77 | { ! ~ $ans yes! YES! } \ 78 | { 79 | ans = 80 | echo 'Please answer one of `yes'', `no'', `quit'', or `yes!''' >[1=2] 81 | } 82 | } 83 | result $ans 84 | } 85 | } 86 | 87 | 88 | provide y-or-n-p 89 | 90 | # y-or-n-p.es ends here 91 | -------------------------------------------------------------------------------- /examples/friedman/main/env.es: -------------------------------------------------------------------------------- 1 | # env.es --- define environment variables 2 | # Author: Noah Friedman 3 | # Created: 1993-05-18 4 | # Public domain 5 | 6 | # $Id: env.es,v 1.12 2010/03/04 09:38:03 friedman Exp $ 7 | 8 | # Commentary: 9 | # Code: 10 | 11 | # First set a temporary path so we can set some needed variables, then load 12 | # functions we need during initialization time. 13 | path = $sinit/bin $path 14 | 15 | local (d = $sinit/share/paths; 16 | 17 | fn-verified-dirlist = @ \ 18 | { 19 | do-if-exist $1 \ 20 | { path-list-verify 'path-list:name-exists-as-directory?' $1 } 21 | } 22 | 23 | fn-verified-filelist = @ \ 24 | { 25 | do-if-exist $1 \ 26 | { path-list-verify 'path-list:name-exists-as-file?' $1 } 27 | } 28 | 29 | fn-flatten = @ \ 30 | { 31 | let (s = <={ %flatten $* }) 32 | { 33 | if { ~ $s 0 } \ 34 | { s = () } 35 | result $s 36 | } 37 | } 38 | 39 | fn-defvar-dirlist = @ var file \ 40 | { defvar $var <={ $fn-verified-dirlist $file } } 41 | 42 | fn-defvar-filelist = @ var file \ 43 | { defvar $var <={ $fn-verified-filelist $file } } 44 | 45 | fn-defvar-flat-dirlist = @ var file \ 46 | { defvar $var <={ $fn-flatten : <={ $fn-verified-dirlist $file } } } 47 | 48 | fn-defvar-flat-filelist = @ var file \ 49 | { defvar $var <={ $fn-flatten : <={ $fn-verified-filelist $file } } } 50 | 51 | fn-defvar-cmd = @ var package cmd \ 52 | { 53 | if { ~ $$var () } \ 54 | { 55 | if { ! ~ $package '' } \ 56 | { require $package } 57 | $var = `{ $cmd } 58 | } 59 | } 60 | ) 61 | { 62 | # Useful to have set before initializing real path. 63 | $fn-defvar-cmd SINIT_MACHTYPE '' hosttype 64 | defvar OS <={ let (l = <={ %split - $SINIT_MACHTYPE }) result $l(3) } 65 | 66 | $fn-defvar-cmd HOSTNAME '' hostname-fqdn 67 | 68 | require path-list 69 | do-if-exist $d/path { path = <={ $fn-verified-dirlist $d/path } } 70 | do-if-exist $d/cdpath { cdpath = <={ $fn-verified-dirlist $d/cdpath } } 71 | 72 | # $shellname is used in setting fpath by $sinit/share/paths/fpath 73 | local (shellname = es) 74 | do-if-exist $d/fpath { fpath = <={ $fn-verified-dirlist $d/fpath } } 75 | 76 | $fn-defvar-flat-dirlist LD_LIBRARY_PATH $d/ld_library_path 77 | $fn-defvar-flat-dirlist LD_RUN_PATH $d/ld_library_path 78 | $fn-defvar-flat-filelist MAILCAPS $d/mailcaps 79 | $fn-defvar-flat-dirlist MANPATH $d/manpath 80 | #$fn-defvar-flat-dirlist TEXFONTS $d/texfonts 81 | #$fn-defvar-flat-dirlist TEXFORMATS $d/texformats 82 | #$fn-defvar-flat-dirlist TEXINPUTS $d/texinputs 83 | #$fn-defvar-flat-dirlist TEXPOOL $d/texpool 84 | 85 | # Used by path-list.es library. 86 | $fn-defvar-filelist termcapfiles $d/termcapfiles 87 | $fn-defvar-dirlist terminfodirs $d/terminfodirs 88 | } 89 | 90 | 91 | defvar EDITOR ed 92 | defvar HOSTALIASES $sinit/share/hostaliases 93 | defvar LESS '-adeiqs -h10 -P--Less--?pB(%pB\%).' 94 | defvar MAILRC $sinit/share/mailrc 95 | defvar MORE '-s' 96 | defvar NCFTPDIR $sinit/share/ncftp 97 | defvar SCREENRC $sinit/share/screenrc 98 | 99 | set-USER 100 | 101 | # Set TERM if necessary. 102 | if { ~ $TERM xterm } \ 103 | { EMACS = } \ 104 | { ~ $EMACS t } \ 105 | { TERM = emacs } 106 | 107 | if { ~ $TERM '' su unknown dialup network dumb plugboard } \ 108 | { 109 | echo 110 | setterm 111 | } 112 | 113 | # used by some GNU utils for making backups 114 | defvar VERSION_CONTROL numbered 115 | defvar XINITRC $sinit/share/xinitrc 116 | 117 | # Some variables for common nonprintable characters. 118 | e = \033 # ESC 119 | g = \007 # BEL 120 | t = \011 # TAB 121 | 122 | source-local-es-init-file env 123 | 124 | # env.es ends here 125 | -------------------------------------------------------------------------------- /examples/friedman/main/esrc.es: -------------------------------------------------------------------------------- 1 | # esrc.es --- start of initialization for `es' shell 2 | # Author: Noah Friedman 3 | # Created: 1993-04-25 4 | # Public domain 5 | 6 | # $Id: esrc.es,v 1.2 1994/05/22 01:37:58 friedman Exp $ 7 | 8 | # Commentary: 9 | # Code: 10 | 11 | catch @ exception source message \ 12 | { 13 | local (fn-print = @ \ 14 | { 15 | if { ~ $* *\n* } \ 16 | { 17 | echo esrc.es: $* \ 18 | | sed -ne '1s/^/# / 19 | 1!s/^/#/ 20 | p' >[1=2] 21 | } \ 22 | { ! ~ $* () } \ 23 | { echo '#' esrc.es: $* >[1=2] } 24 | }) 25 | { 26 | echo >[1=2] 27 | print caught exception: $exception 28 | for (sym = source message) 29 | { 30 | if { ! ~ $$sym () } \ 31 | { print $sym '=' $$sym } 32 | } 33 | } 34 | 35 | result $exception $source 36 | } \ 37 | { 38 | sinit = $home/etc/init 39 | sinit-local = $sinit/local 40 | 41 | . $sinit/es/main/startup.es 42 | } 43 | 44 | # esrc.es ends here 45 | -------------------------------------------------------------------------------- /examples/friedman/main/misc.es: -------------------------------------------------------------------------------- 1 | # misc.es 2 | # Author: Noah Friedman 3 | # Created: 1993-04-24 4 | # Public domain 5 | 6 | # $Id: misc.es,v 1.9 2002/08/09 11:54:07 friedman Exp $ 7 | 8 | # Commentary: 9 | # Code: 10 | 11 | require subr 12 | 13 | # If `ls -g' prints the user and group of a file (GNU, POSIX, and BSD), 14 | # rather than just the group (SYSV), return true. 15 | fn ls-g-user+group? \ 16 | { 17 | let (str =) 18 | { 19 | str = `{ 20 | ls -gld . \ 21 | | { 22 | sed -ne 's/[ ][ ]*/ /g 23 | s/^.[sSrwx-]* *[0-9]* *\([^0-9]*\) *.*/\1/ 24 | p 25 | ' 26 | } 27 | } 28 | if { ~ $#str 2 } \ 29 | { result 0 } \ 30 | { result 1 } 31 | } 32 | } 33 | 34 | # Raise all soft limits to hard limits. 35 | # Ignore exceptions that may be cause by buggy limit code on 36 | # some machines (or if it's simply not defined); this is not too important. 37 | fn raise-limits \ 38 | { 39 | ignore-exceptions \ 40 | { 41 | # For some crazed reason, in es 0.84, some of the output from limit goes 42 | # to stderr instead of stdout. Hopefully that will be fixed someday. 43 | * = `{ limit -h >[2=1] } 44 | while { ! ~ $* () } \ 45 | { 46 | ignore-exceptions { limit $1 $2 } 47 | * = $*(3 ...) 48 | } 49 | } 50 | } 51 | 52 | fn ls-page \ 53 | { 54 | local (fn-ls =; fn-more =) { ls $* | more } 55 | } 56 | 57 | if { ls-g-user+group? } \ 58 | { 59 | fn ll { ls -lg $* } 60 | } \ 61 | { 62 | fn ll { ls -l $* } 63 | } \ 64 | 65 | fn lf { ls -aF $* } 66 | fn lh { li -L $* } 67 | fn li { ll -a $* } 68 | fn lid { li -d $* } 69 | fn lis { li -si $* } 70 | 71 | fn ls \ 72 | { 73 | local (fn-ls =) 74 | { 75 | if { ~ $LSCLEAN () } \ 76 | { 77 | ls-page -C $* 78 | } \ 79 | { ls-page -CB -I '*.o' $* } 80 | } 81 | } 82 | 83 | fn-f = finger 84 | fn-md = mkdir 85 | fn-mdh = mkdirhier 86 | fn-rd = rmdir 87 | 88 | fn stty-canon { stty cs8 -istrip -parenb -iexten -ixon -ixoff -ixany $* } 89 | 90 | if { ! ~ $TERM emacs } \ 91 | { 92 | fn ls \ 93 | { 94 | local (fn-ls =; fn-more =) { ls -C $* | more } 95 | } 96 | } 97 | 98 | { 99 | stty icanon tabs 100 | stty intr '^C' kill '^U' quit '^\\' eof '^D' 101 | } >[2] /dev/null 102 | 103 | raise-limits >[2] /dev/null 104 | 105 | umask 000 106 | 107 | add-hook repl-start-hook set-USER 108 | add-hook repl-interactive-start-hook repl-increment-shlvl 109 | add-hook repl-prompt-hook repl-print-multi-line-result-comment 110 | 111 | source-local-es-init-file misc 112 | 113 | # misc.es ends here 114 | -------------------------------------------------------------------------------- /examples/friedman/main/options.es: -------------------------------------------------------------------------------- 1 | # options.es 2 | # Author: Noah Friedman 3 | # Created: 1992-07-23 4 | # Last modified: 1993-10-12 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | # If `t', makes startup tell you what it's doing. 11 | verbose-startup? = t 12 | 13 | # If `t' and you have no ~/.hushlogin file, this makes startup tell you how 14 | # many mail messages you have. 15 | login-mail-check? = t 16 | 17 | # Default terminal type if unknown (user will be queried for confirmation) 18 | default-term = vt100 19 | 20 | # options.es ends here 21 | -------------------------------------------------------------------------------- /examples/friedman/main/settor.es: -------------------------------------------------------------------------------- 1 | # settor.es --- define various useful settors 2 | # Author: Noah Friedman 3 | # Created: 1993-05-18 4 | # Last modified: 1993-09-25 5 | # Public domain 6 | 7 | # Commentary: 8 | # Code: 9 | 10 | # Keep VISUAL and EDITOR in sync, since it's hard to guess which variable a 11 | # given program will actually use anyway. 12 | set-VISUAL = @ { local (set-EDITOR =) EDITOR = $*; result $* } 13 | set-EDITOR = @ { local (set-VISUAL =) VISUAL = $*; result $* } 14 | 15 | # Keep LOGNAME (SysV) and USER (BSD) in sync. 16 | set-LOGNAME = @ { local (set-USER =) USER = $*; result $* } 17 | set-USER = @ { local (set-LOGNAME =) LOGNAME = $*; result $* } 18 | 19 | # Keep LPDEST (SVR4) and PRINTER (BSD) in sync. 20 | set-PRINTER = @ { local (set-LPDEST =) LPDEST = $*; result $* } 21 | set-LPDEST = @ { local (set-PRINTER =) PRINTER = $*; result $* } 22 | 23 | # When value of TERM changes, save old value in $OLDTERM. This allows 24 | # subshells to know if they should source term files, etc. upon startup. 25 | # OLDTERM shouldn't be set by anything else. 26 | set-TERM = @ { local (set-OLDTERM =) OLDTERM = $TERM; result $* } 27 | set-OLDTERM = @ { throw error $0 attempt to modify read-only variable OLDTERM } 28 | 29 | set-HOSTNAME = @ \ 30 | { 31 | local (fields = <={%split . $* }; 32 | set-HOSTNICK =) 33 | HOSTNICK = $fields(1) 34 | result $* 35 | } 36 | 37 | source-local-es-init-file settor 38 | 39 | # settor.es ends here 40 | -------------------------------------------------------------------------------- /examples/friedman/main/startup.es: -------------------------------------------------------------------------------- 1 | # startup.es 2 | # Author: Noah Friedman 3 | # Created: 1993-05-18 4 | # Public domain 5 | 6 | # $Id: startup.es,v 1.5 2002/08/09 11:54:07 friedman Exp $ 7 | 8 | # Commentary: 9 | # Code: 10 | 11 | # This defines a null function that allows one to put form feeds (^L) in 12 | # scripts without causing an undefined command to be executed. 13 | fn-\f = {} 14 | 15 | let (indent-level =) 16 | { 17 | fn verbose-startup \ 18 | { 19 | if { ~ $(verbose-startup?) t } \ 20 | { 21 | let (indent-padding = ' '; padding = '') 22 | { 23 | if { ~ $* () } \ 24 | { 25 | echo -n ')' 26 | indent-level = $indent-level(2 ...) 27 | if { ~ $indent-level () } echo 28 | } \ 29 | { 30 | for (i = $indent-level) 31 | padding = $padding^$indent-padding 32 | if { ! ~ $indent-level () } echo 33 | echo -n '# '^$padding^'('^$^* 34 | indent-level = $indent-level '' 35 | } 36 | } 37 | } 38 | } 39 | } 40 | 41 | fn source-es-init-file \ 42 | { 43 | do-if-exist $sinit/es/$1.es \ 44 | { 45 | verbose-startup $1.es 46 | . $sinit/es/$1.es 47 | verbose-startup 48 | } 49 | } 50 | 51 | fn source-local-es-init-file \ 52 | { 53 | do-if-exist $sinit-local/es/$1.es \ 54 | { 55 | verbose-startup local/$1.es 56 | . $sinit-local/es/$1.es 57 | verbose-startup 58 | } 59 | } 60 | 61 | fn login-mail-check \ 62 | { 63 | let (spool = /var/mail 64 | user = $USER) 65 | { 66 | for (d = /var/mail /usr/spool/mail /usr/mail) 67 | if { access -d $d } \ 68 | { 69 | spool = $d 70 | break 71 | } 72 | 73 | # If access succeeds, it returns the pathname. If not it returns 74 | # nothing ("true"). Thus, use ! since the sense of success and 75 | # failure is reversed in this case. 76 | if { ! access -n test -1 $path && test -s $spool/$user } \ 77 | { 78 | * = `{ grep '^From ' $spool/$user | wc -l } 79 | echo '#' There are $1 messages in $spool/$user 80 | } 81 | } 82 | } 83 | 84 | fn set-USER \ 85 | { 86 | # Set USER (and also set LOGNAME, via settor in settor.es) 87 | if { ! ~ $* () } \ 88 | { USER = $* } \ 89 | { ! ~ $USER () } \ 90 | { USER = $USER } \ 91 | { ! ~ $LOGNAME () } \ 92 | { USER = $LOGNAME } \ 93 | { USER = `{ whoami } } 94 | } 95 | 96 | 97 | . $sinit/es/main/options.es 98 | 99 | set-USER 100 | if { ~ $(login-mail-check?) t && access ~/.hushlogin } \ 101 | { login-mail-check } 102 | 103 | fpath = $sinit/es/lib $home/lib/es 104 | . $fpath(1)^/require.es 105 | 106 | 107 | verbose-startup main/startup.es 108 | 109 | for (lib = primitives hook repl setterm load hash dirs prompt exec) 110 | { 111 | verbose-startup lib/$lib.es 112 | require $lib 113 | verbose-startup 114 | } 115 | 116 | for (file = settor env misc) 117 | { source-es-init-file main/$file } 118 | 119 | for (file = os/$OS term/$TERM) 120 | { source-es-init-file $file } 121 | 122 | verbose-startup 123 | 124 | # startup.es ends here 125 | -------------------------------------------------------------------------------- /examples/friedman/os/sunos4.1.es: -------------------------------------------------------------------------------- 1 | # sunos4.1.es 2 | # Author: Noah Friedman 3 | # Created: 1993-05-18 4 | # Public domain 5 | 6 | # $Id: sunos4.1.es,v 1.1 1995/10/04 00:24:18 friedman Exp $ 7 | 8 | # Commentary: 9 | 10 | # In SunOS 4.1, there is inscrutable magic that goes on with dlopen (a 11 | # dynamic linking routine) such that it will fail if a directory with 12 | # libdl.so is referenced via a symlink. Therefore, this template removes 13 | # symlinks from LD_LIBRARY_PATH. 14 | 15 | # Code: 16 | 17 | verbose-startup os/$OS.es 18 | 19 | # access -1 returns path if found, i.e. return value will be nonzero, hence 20 | # the use of !. 21 | if { ! ~ $LD_LIBRARY_PATH () && ! access -1n perl $path } \ 22 | { 23 | let (new =) 24 | { 25 | for (d = <={ %split ':' $LD_LIBRARY_PATH }) 26 | { 27 | if { ! access -l $d && access -d $d } \ 28 | { new = $new $d } 29 | } 30 | LD_LIBRARY_PATH = <={ %flatten ':' $new } 31 | } 32 | } 33 | 34 | verbose-startup 35 | 36 | # sunos4.1.es ends here 37 | -------------------------------------------------------------------------------- /examples/friedman/term/emacs.es: -------------------------------------------------------------------------------- 1 | # emacs.es 2 | # Author: Noah Friedman 3 | # Created: 1991-12-11 4 | # Public domain 5 | 6 | # $Id: emacs.es,v 1.5 2010/03/04 09:44:36 friedman Exp $ 7 | 8 | # Commentary: 9 | # Code: 10 | 11 | PAGER = cat 12 | EDITOR = ed 13 | 14 | # Unset ls pager function, which under normal conditions would pipe ls 15 | # through a pager. That's not necessary under emacs since we can already 16 | # scroll through the buffer. 17 | fn-ls-page = ls 18 | 19 | # emacs.es ends here 20 | -------------------------------------------------------------------------------- /examples/friedman/term/sun.es: -------------------------------------------------------------------------------- 1 | # sun.es 2 | # Author: Noah Friedman [2] /dev/null 28 | 29 | # sun.es ends here 30 | -------------------------------------------------------------------------------- /examples/friedman/term/vt100.es: -------------------------------------------------------------------------------- 1 | # vt100.es --- terminal-specific code for vt100 class terminals 2 | # Author: Noah Friedman 3 | # Created: 1993-05-18 4 | # Public domain 5 | 6 | # $Id: vt100.es,v 1.2 2010/03/04 09:44:36 friedman Exp $ 7 | 8 | # Change terminal to black-on-white 9 | fn-bow = echo -n \033^'[?5l' 10 | 11 | # Change terminal to white-on-black 12 | fn-wob = echo -n \033^'[?5h' 13 | 14 | #LINES = 24 15 | #COLUMNS = 80 16 | #stty erase '^?' rows $LINES columns $COLUMNS >[2] /dev/null 17 | 18 | # vt100.es ends here 19 | -------------------------------------------------------------------------------- /examples/jamesh.esrc: -------------------------------------------------------------------------------- 1 | # this file basically make 'es' look more like a modern bash prompt 2 | # (in terms of following symlinks, colours, cd - (+ enhancements)) 3 | 4 | # symlink cd (and pwd) 5 | 6 | fn pwd { 7 | if {~ $#cwd 0} { 8 | noexport = $noexport cwd 9 | cwd = `` \n /bin/pwd 10 | } 11 | echo $cwd 12 | } 13 | 14 | let (cd = $fn-cd) fn cd dir { 15 | if {~ $#cwd 0} { 16 | noexport = $noexport cwd 17 | } 18 | if {~ $#dir 0} { 19 | $cd 20 | cwd = ~ 21 | } { 22 | let (current = <={ 23 | if {~ $dir /*} { 24 | result 25 | } { 26 | if {~ $#cwd 0} { 27 | cwd = `` \n /bin/pwd 28 | } 29 | %split / $cwd 30 | } 31 | }) { 32 | for (name = <={%split / $dir}) { 33 | if {~ $name ..} { 34 | if {!~ $#current 0} { 35 | let (x = 1 $current) current = $x(2 ... $#current) 36 | } 37 | } {!~ $name . ''} { 38 | current = $current $name 39 | } 40 | } 41 | let (path = / ^ <={ %flatten / $current }) { 42 | $cd $path 43 | cwd = $path 44 | } 45 | } 46 | } 47 | } 48 | 49 | # go back -N directories in cd (cd -1 prints stack, cd - goes to previous) 50 | # 51 | let (cd = $fn-cd; cd-stack = (. . . . . . . . . .)) fn cd dir { 52 | if {~ $dir -*} { 53 | let (index = <={%split - $dir}) { 54 | if {~ $#index 0} { 55 | index = 2 56 | } 57 | if {~ $index [2-9]} { 58 | dir = $cd-stack($index) 59 | } {~ $index 1} { 60 | echo $cd-stack >[1=2] 61 | return 0 62 | } { 63 | throw error cd 'cd: invalid argument' 64 | } 65 | } 66 | } 67 | $cd $dir 68 | cd-stack = (`pwd $cd-stack(1 ... 9)) 69 | } 70 | 71 | # colourful prompt 72 | let (cd = $fn-cd; c = \1\033; z=\2) fn cd { 73 | $cd $*; 74 | let (w = `pwd) { 75 | if {~ $^w $home^*} { 76 | w = '~'^<={~~ $^w $home^*} 77 | } 78 | prompt = $c[4\;35m$z`{hostname}^$c[0m$z:$c[1\;34m$z$^w$c[0m$z^'; ' 79 | } 80 | } 81 | 82 | # colourful programs (symlinks to colorgcc in ~/bin) 83 | for (prog = ls grep) { 84 | let (o = `{which $prog}) fn $prog {$o --color\=auto $*} 85 | } 86 | 87 | # when we start, we should 'cd .' to set the colourful prompt 88 | fn %prompt { 89 | cd . 90 | fn %prompt # now lose the prompt function 91 | } 92 | -------------------------------------------------------------------------------- /examples/number.es: -------------------------------------------------------------------------------- 1 | # 2 | # number.es, 26-May-93 Noah Friedman 3 | # Last modified 18-Feb-94 4 | # 5 | # Public domain. 6 | # 7 | 8 | #:docstring number: 9 | # Usage: number [number] 10 | # 11 | # Converts decimal integers to english notation. Spaces and commas are 12 | # optional. Numbers 67 digits and larger will overflow this script. 13 | # 14 | # E.g: number 99,000,000,000,000,454 15 | # => ninety-nine quadrillion four hundred fifty-four 16 | # 17 | #:end docstring: 18 | 19 | fn number \ 20 | { 21 | if { ~ $* *[~0-9,.]* } \ 22 | { throw error $0 $0: invalid character in argument. } 23 | { ~ $* *.* } \ 24 | { throw error $0 $0: fractions not supported '(yet).' } 25 | 26 | # Strips excess spaces and commas, and puts each digit into a separate 27 | # slot in the array. 28 | * = <={ %fsplit '' <={%flatten '' <={%fsplit ', ' $^* } } } 29 | 30 | let (ones = one two three four five six seven eight nine; 31 | tens = ten twenty thirty forty fifty sixty seventy eighty ninety; 32 | teens = eleven twelve (thir four fif six seven eigh nine)^teen; 33 | bignum = (thousand 34 | (m b tr quadr quint sext sept oct non 35 | ('' un duo tre quattuoro quin sex septen octo novem)^dec 36 | vigint)^illion ); 37 | a = $* 38 | bignum-ref = ; 39 | val100 =; val10 =; val1 =; 40 | result =) 41 | { 42 | while { ! ~ $#a 0 1 2 3 } \ 43 | { 44 | a = $a(4 ...) 45 | bignum-ref = $bignum-ref '' 46 | } 47 | 48 | if { ~ $#a 1 } \ 49 | { * = 0 0 $* } \ 50 | { ~ $#a 2 } \ 51 | { * = 0 $* } 52 | 53 | while { ! ~ $* () } \ 54 | { 55 | val100 =; val10 =; val1 =; 56 | if { ! ~ $1 0 } { val100 = $ones($1) hundred } 57 | if { ! ~ $2 0 } { val10 = $tens($2) } 58 | if { ! ~ $3 0 } \ 59 | { 60 | if { ~ $val10 ten } \ 61 | { val10 = ; val1 = $teens($3) } \ 62 | { val1 = $ones($3) } 63 | } 64 | 65 | result = $result $val100 66 | if { ~ $val10 *ty && ! ~ $val1 () } \ 67 | { result = $result $^val10^-^$val1 } \ 68 | { result = $result $val10 $val1 } 69 | if { ! { ~ $bignum-ref () || ~ $1$2$3 000 } } \ 70 | { 71 | result = $result $bignum($#bignum-ref) 72 | } 73 | bignum-ref = $bignum-ref(2 ...) 74 | * = $*(4 ...) 75 | } 76 | result $result 77 | } 78 | } 79 | 80 | # eof 81 | -------------------------------------------------------------------------------- /examples/sh_compat: -------------------------------------------------------------------------------- 1 | # add this to your .profile file or similar for programs (like xsession or gdm) 2 | # that like running sh 3 | 4 | # load .esrc environment 5 | if [ -f "$HOME/.esrc" ]; then 6 | eval "`es -l <<-x 7 | sh <<<'export -p' 8 | x`" 9 | fi 10 | -------------------------------------------------------------------------------- /except.c: -------------------------------------------------------------------------------- 1 | /* except.c -- exception mechanism ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "print.h" 5 | 6 | /* globals */ 7 | Handler *tophandler = NULL; 8 | Handler *roothandler = NULL; 9 | List *exception = NULL; 10 | Push *pushlist = NULL; 11 | 12 | /* pophandler -- remove a handler */ 13 | extern void pophandler(Handler *handler) { 14 | assert(tophandler == handler); 15 | assert(handler->rootlist == rootlist); 16 | tophandler = handler->up; 17 | } 18 | 19 | /* throw -- raise an exception */ 20 | extern Noreturn throw(List *e) { 21 | Handler *handler = tophandler; 22 | 23 | assert(!gcisblocked()); 24 | assert(e != NULL); 25 | assert(handler != NULL); 26 | tophandler = handler->up; 27 | 28 | { 29 | Root excroot; 30 | exceptionroot(&excroot, &e); 31 | while (pushlist != handler->pushlist) { 32 | rootlist = &pushlist->defnroot; 33 | varpop(pushlist); 34 | } 35 | exceptionunroot(); 36 | } 37 | evaldepth = handler->evaldepth; 38 | 39 | #if ASSERTIONS 40 | for (; rootlist != handler->rootlist; rootlist = rootlist->next) 41 | assert(rootlist != NULL); 42 | #else 43 | rootlist = handler->rootlist; 44 | #endif 45 | exception = e; 46 | longjmp(handler->label, 1); 47 | NOTREACHED; 48 | } 49 | 50 | /* fail -- pass a user catchable error up the exception chain */ 51 | extern Noreturn fail VARARGS2(const char *, from, const char *, fmt) { 52 | char *s; 53 | va_list args; 54 | 55 | VA_START(args, fmt); 56 | s = strv(fmt, args); 57 | va_end(args); 58 | 59 | gcdisable(); 60 | Ref(List *, e, mklist(mkstr("error"), 61 | mklist(mkstr((char *) from), 62 | mklist(mkstr(s), NULL)))); 63 | while (gcisblocked()) 64 | gcenable(); 65 | throw(e); 66 | RefEnd(e); 67 | } 68 | 69 | /* newchildcatcher -- remove the current handler chain for a new child */ 70 | extern void newchildcatcher(void) { 71 | tophandler = roothandler; 72 | } 73 | 74 | #if DEBUG_EXCEPTIONS 75 | /* raised -- print exceptions as we climb the exception stack */ 76 | extern List *raised(List *e) { 77 | eprint("raised (sp @ %x) %L\n", &e, e, " "); 78 | return e; 79 | } 80 | #endif 81 | -------------------------------------------------------------------------------- /gc.h: -------------------------------------------------------------------------------- 1 | /* gc.h -- garbage collector interface for es ($Revision: 1.1.1.1 $) */ 2 | 3 | /* see also es.h for more generally applicable definitions */ 4 | 5 | /* 6 | * tags 7 | */ 8 | 9 | struct Tag { 10 | void *(*copy)(void *); 11 | size_t (*scan)(void *); 12 | #if ASSERTIONS || GCVERBOSE 13 | long magic; 14 | char *typename; 15 | #endif 16 | }; 17 | 18 | extern Tag StringTag; 19 | 20 | #if ASSERTIONS || GCVERBOSE 21 | enum {TAGMAGIC = 0xDefaced}; 22 | #define DefineTag(t, storage) \ 23 | static void *CONCAT(t,Copy)(void *); \ 24 | static size_t CONCAT(t,Scan)(void *); \ 25 | storage Tag CONCAT(t,Tag) = { CONCAT(t,Copy), CONCAT(t,Scan), TAGMAGIC, STRING(t) } 26 | #else 27 | #define DefineTag(t, storage) \ 28 | static void *CONCAT(t,Copy)(void *); \ 29 | static size_t CONCAT(t,Scan)(void *); \ 30 | storage Tag CONCAT(t,Tag) = { CONCAT(t,Copy), CONCAT(t,Scan) } 31 | #endif 32 | 33 | /* 34 | * allocation 35 | */ 36 | 37 | extern void *gcalloc(size_t, Tag *); 38 | 39 | typedef struct Buffer Buffer; 40 | struct Buffer { 41 | size_t len; 42 | size_t current; 43 | char str[1]; 44 | }; 45 | 46 | extern Buffer *openbuffer(size_t minsize); 47 | extern Buffer *expandbuffer(Buffer *buf, size_t minsize); 48 | extern Buffer *bufncat(Buffer *buf, const char *s, size_t len); 49 | extern Buffer *bufcat(Buffer *buf, const char *s); 50 | extern Buffer *bufputc(Buffer *buf, char c); 51 | extern char *sealbuffer(Buffer *buf); 52 | extern char *sealcountedbuffer(Buffer *buf); 53 | extern char *psealbuffer(Buffer *buf); /* pspace variant of sealbuffer */ 54 | extern char *psealcountedbuffer(Buffer *buf); /* pspace variant of sealcountedbuffer */ 55 | extern void freebuffer(Buffer *buf); 56 | 57 | extern void *forward(void *p); 58 | -------------------------------------------------------------------------------- /heredoc.c: -------------------------------------------------------------------------------- 1 | /* heredoc.c -- in-line files (here documents) ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | #include "input.h" 6 | #include "syntax.h" 7 | 8 | typedef struct Here Here; 9 | struct Here { 10 | Here *next; 11 | Tree *marker; 12 | }; 13 | 14 | static Here *hereq; 15 | 16 | /* getherevar -- read a variable from a here doc */ 17 | extern Tree *getherevar(void) { 18 | int c; 19 | char *s; 20 | size_t len; 21 | Buffer *buf = openbuffer(0); 22 | while ((c = GETC()) != EOF && !dnw[c]) 23 | buf = bufputc(buf, c); 24 | len = buf->len; 25 | s = psealcountedbuffer(buf); 26 | if (len == 0) { 27 | yyerror("null variable name in here document"); 28 | return NULL; 29 | } 30 | if (c != '^') 31 | UNGETC(c); 32 | return flatten(mk(nVar, mk(nWord, s)), " "); 33 | } 34 | 35 | /* snarfheredoc -- read a heredoc until the eof marker */ 36 | extern Tree *snarfheredoc(const char *eof, Boolean quoted) { 37 | Tree *tree, **tailp; 38 | Buffer *buf; 39 | unsigned char *s; 40 | 41 | assert(quoted || strchr(eof, '$') == NULL); /* can never be typed (whew!) */ 42 | if (strchr(eof, '\n') != NULL) { 43 | yyerror("here document eof-marker contains a newline"); 44 | return NULL; 45 | } 46 | ignoreeof = TRUE; 47 | 48 | for (tree = NULL, tailp = &tree, buf = openbuffer(0);;) { 49 | int c; 50 | print_prompt2(); 51 | for (s = (unsigned char *) eof; (c = GETC()) == *s; s++) 52 | ; 53 | if (*s == '\0' && (c == '\n' || c == EOF)) { 54 | if (buf->current == 0 && tree != NULL) 55 | freebuffer(buf); 56 | else 57 | *tailp = treecons(mk(nQword, psealcountedbuffer(buf)), NULL); 58 | break; 59 | } 60 | if (s != (unsigned char *) eof) 61 | buf = bufncat(buf, eof, s - (unsigned char *) eof); 62 | for (;; c = GETC()) { 63 | if (c == EOF) { 64 | yyerror("incomplete here document"); 65 | freebuffer(buf); 66 | ignoreeof = FALSE; 67 | return NULL; 68 | } 69 | if (c == '$' && !quoted && (c = GETC()) != '$') { 70 | Tree *var; 71 | UNGETC(c); 72 | if (buf->current == 0) 73 | freebuffer(buf); 74 | else { 75 | *tailp = treecons(mk(nQword, psealcountedbuffer(buf)), NULL); 76 | tailp = &(*tailp)->CDR; 77 | } 78 | var = getherevar(); 79 | if (var == NULL) { 80 | freebuffer(buf); 81 | ignoreeof = FALSE; 82 | return NULL; 83 | } 84 | *tailp = treecons(var, NULL); 85 | tailp = &(*tailp)->CDR; 86 | buf = openbuffer(0); 87 | continue; 88 | } 89 | buf = bufputc(buf, c); 90 | if (c == '\n') 91 | break; 92 | } 93 | } 94 | 95 | ignoreeof = FALSE; 96 | return tree->CDR == NULL ? tree->CAR : tree; 97 | } 98 | 99 | /* readheredocs -- read all the heredocs at the end of a line (or fail if at end of file) */ 100 | extern Boolean readheredocs(Boolean endfile) { 101 | for (; hereq != NULL; hereq = hereq->next) { 102 | Tree *marker, *eof; 103 | if (endfile) { 104 | yyerror("end of file with pending here documents"); 105 | return FALSE; 106 | } 107 | marker = hereq->marker; 108 | eof = marker->CAR; 109 | marker->CAR = snarfheredoc(eof->u[0].s, eof->kind == nQword); 110 | if (marker->CAR == NULL) 111 | return FALSE; 112 | } 113 | return TRUE; 114 | } 115 | 116 | /* queueheredoc -- add a heredoc to the queue to process at the end of the line */ 117 | extern Boolean queueheredoc(Tree *t) { 118 | Tree *eof; 119 | Here *here; 120 | 121 | assert(hereq == NULL || hereq->marker->kind == nList); 122 | assert(t->kind == nList); 123 | assert(t->CAR->kind == nWord); 124 | #if !REISER_CPP 125 | assert(streq(t->CAR->u[0].s, "%heredoc")); 126 | #endif 127 | t->CAR->u[0].s = "%here"; 128 | assert(t->CDR->kind == nList); 129 | eof = t->CDR->CDR; 130 | assert(eof->kind == nList); 131 | if (!eof->CAR || (eof->CAR->kind != nWord && eof->CAR->kind != nQword)) { 132 | yyerror("here document eof-marker not a single literal word"); 133 | return FALSE; 134 | } 135 | 136 | here = palloc(sizeof (Here), NULL); 137 | here->next = hereq; 138 | here->marker = eof; 139 | hereq = here; 140 | return TRUE; 141 | } 142 | 143 | extern void emptyherequeue(void) { 144 | hereq = NULL; 145 | } 146 | -------------------------------------------------------------------------------- /history.c: -------------------------------------------------------------------------------- 1 | /* history.c -- control the history file ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | #include "input.h" 6 | 7 | 8 | /* 9 | * constants 10 | */ 11 | 12 | #define BUFSIZE ((size_t) 4096) /* buffer size to fill reads into */ 13 | 14 | 15 | /* 16 | * globals 17 | */ 18 | 19 | static Buffer *histbuffer = NULL; 20 | 21 | #if HAVE_READLINE 22 | #include 23 | 24 | Boolean reloadhistory = FALSE; 25 | static char *history; 26 | 27 | #if 0 28 | /* These split history file entries by timestamp, which allows readline to pick up 29 | * multi-line commands correctly across process boundaries. Disabled by default, 30 | * because it leaves the history file itself kind of ugly. */ 31 | static int history_write_timestamps = 1; 32 | static char history_comment_char = '#'; 33 | #endif 34 | #endif 35 | 36 | 37 | /* 38 | * histbuffer -- build the history line during input and dump it as a gc-string 39 | */ 40 | 41 | 42 | extern void newhistbuffer(void) { 43 | assert(histbuffer == NULL); 44 | histbuffer = openbuffer(BUFSIZE); 45 | } 46 | 47 | extern void addhistbuffer(char c) { 48 | if (histbuffer == NULL) 49 | return; 50 | histbuffer = bufputc(histbuffer, c); 51 | } 52 | 53 | extern char *dumphistbuffer(void) { 54 | char *s; 55 | size_t len; 56 | assert(histbuffer != NULL); 57 | 58 | s = sealcountedbuffer(histbuffer); 59 | histbuffer = NULL; 60 | 61 | len = strlen(s); 62 | if (len > 0 && s[len - 1] == '\n') 63 | s[len - 1] = '\0'; 64 | return s; 65 | } 66 | 67 | 68 | /* 69 | * history file 70 | */ 71 | 72 | #if HAVE_READLINE 73 | extern void setmaxhistorylength(int len) { 74 | static int currenthistlen = -1; /* unlimited */ 75 | if (len != currenthistlen) { 76 | switch (len) { 77 | case -1: 78 | unstifle_history(); 79 | break; 80 | case 0: 81 | clear_history(); 82 | FALLTHROUGH; 83 | default: 84 | stifle_history(len); 85 | } 86 | currenthistlen = len; 87 | } 88 | } 89 | 90 | extern void loghistory(char *cmd) { 91 | int err; 92 | if (cmd == NULL) 93 | return; 94 | add_history(cmd); 95 | if (history == NULL) 96 | return; 97 | 98 | if ((err = append_history(1, history))) { 99 | eprint("history(%s): %s\n", history, esstrerror(err)); 100 | vardef("history", NULL, NULL); 101 | } 102 | } 103 | 104 | static void reload_history(void) { 105 | /* Attempt to populate readline history with new history file. */ 106 | if (history != NULL) 107 | read_history(history); 108 | using_history(); 109 | 110 | reloadhistory = FALSE; 111 | } 112 | 113 | extern void sethistory(char *file) { 114 | if (reloadhistory) 115 | reload_history(); 116 | reloadhistory = TRUE; 117 | history = file; 118 | } 119 | 120 | extern void checkreloadhistory(void) { 121 | if (reloadhistory) 122 | reload_history(); 123 | } 124 | 125 | /* 126 | * initialization 127 | */ 128 | 129 | /* inithistory -- called at dawn of time from main() */ 130 | extern void inithistory(void) { 131 | /* declare the global roots */ 132 | globalroot(&history); /* history file */ 133 | } 134 | #endif 135 | -------------------------------------------------------------------------------- /input.h: -------------------------------------------------------------------------------- 1 | /* input.h -- definitions for es lexical analyzer ($Revision: 1.1.1.1 $) */ 2 | 3 | #define MAXUNGET 2 /* maximum 2 character pushback */ 4 | 5 | typedef struct Input Input; 6 | struct Input { 7 | int (*get)(Input *self); 8 | int (*fill)(Input *self), (*rfill)(Input *self); 9 | void (*cleanup)(Input *self); 10 | Input *prev; 11 | const char *name; 12 | unsigned char *buf, *bufend, *bufbegin, *rbuf; 13 | size_t buflen; 14 | int unget[MAXUNGET]; 15 | int ungot; 16 | int lineno; 17 | int fd; 18 | int runflags; 19 | }; 20 | 21 | 22 | #define GETC() (*input->get)(input) 23 | #define UNGETC(c) unget(input, c) 24 | 25 | 26 | /* input.c */ 27 | 28 | extern Input *input; 29 | extern void unget(Input *in, int c); 30 | extern Boolean ignoreeof; 31 | extern void yyerror(const char *s); 32 | 33 | 34 | /* token.c */ 35 | 36 | extern const char dnw[]; 37 | extern int yylex(void); 38 | extern void inityy(void); 39 | extern void print_prompt2(void); 40 | 41 | 42 | /* parse.y */ 43 | 44 | extern Tree *parsetree; 45 | extern int yyparse(void); 46 | 47 | 48 | /* heredoc.c */ 49 | 50 | extern void emptyherequeue(void); 51 | -------------------------------------------------------------------------------- /list.c: -------------------------------------------------------------------------------- 1 | /* list.c -- operations on lists ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | 6 | /* 7 | * allocation and garbage collector support 8 | */ 9 | 10 | DefineTag(List, static); 11 | 12 | extern List *mklist(Term *term, List *next) { 13 | gcdisable(); 14 | assert(term != NULL); 15 | Ref(List *, list, gcnew(List)); 16 | list->term = term; 17 | list->next = next; 18 | gcenable(); 19 | RefReturn(list); 20 | } 21 | 22 | static void *ListCopy(void *op) { 23 | void *np = gcnew(List); 24 | memcpy(np, op, sizeof (List)); 25 | return np; 26 | } 27 | 28 | static size_t ListScan(void *p) { 29 | List *list = p; 30 | list->term = forward(list->term); 31 | list->next = forward(list->next); 32 | return sizeof (List); 33 | } 34 | 35 | 36 | /* 37 | * basic list manipulations 38 | */ 39 | 40 | /* reverse -- destructively reverse a list */ 41 | extern List *reverse(List *list) { 42 | List *prev, *next; 43 | if (list == NULL) 44 | return NULL; 45 | prev = NULL; 46 | do { 47 | next = list->next; 48 | list->next = prev; 49 | prev = list; 50 | } while ((list = next) != NULL); 51 | return prev; 52 | } 53 | 54 | /* append -- merge two lists, non-destructively */ 55 | extern List *append(List *head, List *tail) { 56 | List *lp, **prevp; 57 | Ref(List *, hp, head); 58 | Ref(List *, tp, tail); 59 | gcreserve(40 * sizeof (List)); 60 | gcdisable(); 61 | head = hp; 62 | tail = tp; 63 | RefEnd2(tp, hp); 64 | 65 | for (prevp = &lp; head != NULL; head = head->next) { 66 | List *np = mklist(head->term, NULL); 67 | *prevp = np; 68 | prevp = &np->next; 69 | } 70 | *prevp = tail; 71 | 72 | Ref(List *, result, lp); 73 | gcenable(); 74 | RefReturn(result); 75 | } 76 | 77 | /* listcopy -- make a copy of a list */ 78 | extern List *listcopy(List *list) { 79 | return append(list, NULL); 80 | } 81 | 82 | /* length -- lenth of a list */ 83 | extern int length(List *list) { 84 | int len = 0; 85 | for (; list != NULL; list = list->next) 86 | ++len; 87 | return len; 88 | } 89 | 90 | /* listify -- turn an argc/argv vector into a list */ 91 | extern List *listify(int argc, char **argv) { 92 | Ref(List *, list, NULL); 93 | while (argc > 0) { 94 | Term *term = mkstr(argv[--argc]); 95 | list = mklist(term, list); 96 | } 97 | RefReturn(list); 98 | } 99 | 100 | /* nth -- return nth element of a list, indexed from 1 */ 101 | extern Term *nth(List *list, int n) { 102 | for (; n > 0 && list != NULL; list = list->next) { 103 | assert(list->term != NULL); 104 | if (--n == 0) 105 | return list->term; 106 | } 107 | return NULL; 108 | } 109 | 110 | /* sortlist */ 111 | extern List *sortlist(List *list) { 112 | if (length(list) > 1) { 113 | Vector *v = vectorize(list); 114 | sortvector(v); 115 | gcdisable(); 116 | Ref(List *, lp, listify(v->count, v->vector)); 117 | gcenable(); 118 | list = lp; 119 | RefEnd(lp); 120 | } 121 | return list; 122 | } 123 | -------------------------------------------------------------------------------- /mksignal: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | # mksignal -- generate es's internal signal table from signal.h ($Revision: 1.1.1.1 $) 3 | 4 | echo '#include "es.h"' 5 | echo '#include "sigmsgs.h"' 6 | echo 7 | echo 'const Sigmsgs signals[] = {' 8 | 9 | sed -n ' 10 | s/^[ ]*\#[ ]*define[ ]*_*SIG/SIG/ 11 | s/\/\*[ ]*// 12 | s/[ ]*\*\/// 13 | s/([@*+!]) // 14 | s/[ ]*(.*)$// 15 | s/[ ]*signal$// 16 | /^SIG[A-Z][A-Z0-9]*[ ]/p 17 | 18 | ' $* | awk ' 19 | BEGIN { 20 | nsig = 0 21 | 22 | # set mesg["SIGNAME"] to override a message. since the 23 | # comments in /usr/include/sys/signal.h are awful, we 24 | # now provide messages for most signals 25 | 26 | mesg["SIGABRT"] = "abort" 27 | mesg["SIGALRM"] = "alarm clock" 28 | mesg["SIGBUS"] = "bus error" 29 | mesg["SIGCHLD"] = "child stopped or exited" 30 | mesg["SIGCLD"] = "child stopped or exited" 31 | mesg["SIGCONT"] = "continue" 32 | mesg["SIGEMT"] = "EMT instruction" 33 | mesg["SIGFPE"] = "floating point exception" 34 | mesg["SIGHUP"] = "hangup" 35 | mesg["SIGILL"] = "illegal instruction" 36 | mesg["SIGINFO"] = "information request" 37 | mesg["SIGIO"] = "input/output possible" 38 | mesg["SIGIOT"] = "IOT instruction" 39 | mesg["SIGKILL"] = "killed" 40 | mesg["SIGLOST"] = "resource lost" 41 | mesg["SIGLWP"] = "lightweight process library signal" 42 | mesg["SIGMIGRATE"] = "migrate process" 43 | mesg["SIGPOLL"] = "pollable event occurred" 44 | mesg["SIGPROF"] = "profiling timer alarm" 45 | mesg["SIGPWR"] = "power failure" 46 | mesg["SIGQUIT"] = "quit" 47 | mesg["SIGRESERVE"] = "reserved signal" 48 | mesg["SIGSEGV"] = "segmentation violation" 49 | mesg["SIGSTOP"] = "asynchronous stop" 50 | mesg["SIGSYS"] = "bad argument to system call" 51 | mesg["SIGTERM"] = "terminated" 52 | mesg["SIGTRAP"] = "trace trap" 53 | mesg["SIGTSTP"] = "stopped" 54 | mesg["SIGTTIN"] = "background tty read" 55 | mesg["SIGTTOU"] = "background tty write" 56 | mesg["SIGURG"] = "urgent condition on i/o channel" 57 | mesg["SIGUSR1"] = "user defined signal 1" 58 | mesg["SIGUSR2"] = "user defined signal 2" 59 | mesg["SIGVTALRM"] = "virtual timer alarm" 60 | mesg["SIGWAITING"] = "all lightweight processes blocked" 61 | mesg["SIGWINCH"] = "window size changed" 62 | mesg["SIGXCPU"] = "exceeded CPU time limit" 63 | mesg["SIGXFSZ"] = "exceeded file size limit" 64 | 65 | # these signals are dubious, but we may as well provide clean messages 66 | # for them. most of them occur on only one system, or, more likely, 67 | # are duplicates of one of the previous messages. 68 | 69 | mesg["SIGAIO"] = "base lan I/O available" 70 | mesg["SIGDANGER"] = "danger - system page space full" 71 | mesg["SIGEMSG"] = "process received an emergency message" 72 | mesg["SIGGRANT"] = "HFT monitor mode granted" 73 | mesg["SIGIOINT"] = "printer to backend error" 74 | mesg["SIGMSG"] = "input data is in the HFT ring buffer" 75 | mesg["SIGPRE"] = "programming exception" 76 | mesg["SIGPTY"] = "pty I/O available" 77 | mesg["SIGRETRACT"] = "HFT monitor mode should be relinquished" 78 | mesg["SIGSAK"] = "secure attention key" 79 | mesg["SIGSOUND"] = "HFT sound control has completed" 80 | mesg["SIGSTKFLT"] = "stack fault" 81 | mesg["SIGUNUSED"] = "unused signal" 82 | mesg["SIGVIRT"] = "virtual time alarm" 83 | mesg["SIGWINDOW"] = "window size changed" 84 | 85 | 86 | # set nomesg["SIGNAME"] to suppress message printing 87 | 88 | nomesg["SIGINT"] = 1 89 | nomesg["SIGPIPE"] = 1 90 | 91 | 92 | # set ignore["SIGNAME"] to explicitly ignore a named signal (usually, this 93 | # is just for things that look like signals but really are not) 94 | 95 | ignore["SIGALL"] = 1 96 | ignore["SIGARRAYSIZE"] = 1 97 | ignore["SIGCATCHALL"] = 1 98 | ignore["SIGDEFER"] = 1 99 | ignore["SIGDIL"] = 1 100 | ignore["SIGHOLD"] = 1 101 | ignore["SIGIGNORE"] = 1 102 | ignore["SIGMAX"] = 1 103 | ignore["SIGPAUSE"] = 1 104 | ignore["SIGRELSE"] = 1 105 | ignore["SIGRTMAX"] = 1 106 | ignore["SIGRTMIN"] = 1 107 | ignore["SIGSETS"] = 1 108 | ignore["SIGSTKSZ"] = 1 109 | 110 | # upper to lowercase translation table: can someone give me an easier 111 | # way to do this that works in ancient versions of awk? 112 | 113 | for (i = 65; i <= 90; i++) # 'A' to 'Z' 114 | uppertolower[sprintf("%c", i)] = sprintf("%c", i + 32) 115 | 116 | } 117 | sig[$1] == 0 && ignore[$1] == 0 { 118 | sig[$1] = ++nsig 119 | signame[nsig] = $1 120 | if (mesg[$1] == "" && nomesg[$1] == 0) { 121 | str = $3 122 | for (i = 4; i <= NF; i++) 123 | str = str " " $i 124 | mesg[$1] = str 125 | } 126 | # hack to print SIGIOT or SIGILL as "abort" if that is the most common 127 | # way of triggering it. 128 | if ($1 == "SIGABRT" && $2 ~ /^SIG/) 129 | mesg[$2] = mesg[$1] 130 | } 131 | END { 132 | for (i = 1; i <= nsig; i++) { 133 | signal = signame[i] 134 | # gawk, at very least, provides a tolower function, but this should 135 | # be portable. sigh. 136 | lcname = "" 137 | for (j = 1; j <= length(signal); j++) { 138 | c = substr(signal, j, 1) 139 | if (uppertolower[c] != "") 140 | c = uppertolower[c] 141 | lcname = lcname c 142 | } 143 | print "#ifdef", signal 144 | print "#if ", signal, " < NSIG" 145 | printf "\t{ %s,\t\"%s\",\t\"%s\" },\n", signal, lcname, mesg[signal] 146 | print "#endif" 147 | print "#endif" 148 | } 149 | } 150 | ' 151 | 152 | echo '};' 153 | echo 154 | echo 'const int nsignals = arraysize(signals);' 155 | -------------------------------------------------------------------------------- /open.c: -------------------------------------------------------------------------------- 1 | /* open.c -- to insulate from the rest of es ($Revision: 1.1.1.1 $) */ 2 | 3 | #define REQUIRE_FCNTL 1 4 | 5 | #include "es.h" 6 | 7 | #if NeXT 8 | extern int open(const char *, int, ...); 9 | #endif 10 | 11 | #define MIN_ttyfd 3 12 | 13 | 14 | /* 15 | * Opens a file with the necessary flags. Assumes the following order: 16 | * typedef enum { 17 | * oOpen, oCreate, oAppend, oReadCreate, oReadTrunc oReadAppend 18 | * } OpenKind; 19 | */ 20 | 21 | static int mode_masks[] = { 22 | O_RDONLY, /* rOpen */ 23 | O_WRONLY | O_CREAT | O_TRUNC, /* rCreate */ 24 | O_WRONLY | O_CREAT | O_APPEND, /* rAppend */ 25 | O_RDWR | O_CREAT, /* oReadWrite */ 26 | O_RDWR | O_CREAT | O_TRUNC, /* oReadCreate */ 27 | O_RDWR | O_CREAT | O_APPEND, /* oReadAppend */ 28 | }; 29 | 30 | extern int eopen(char *name, OpenKind k) { 31 | assert((unsigned) k < arraysize(mode_masks)); 32 | return open(name, mode_masks[k], 0666); 33 | } 34 | 35 | extern int opentty(void) { 36 | int e = 0, old, fd = 2; 37 | if (isatty(fd)) 38 | return fcntl(fd, F_DUPFD, MIN_ttyfd); 39 | old = open("/dev/tty", O_RDWR|O_NONBLOCK); 40 | fd = fcntl(old, F_DUPFD, MIN_ttyfd); 41 | if (fd == -1) 42 | e = errno; 43 | close(old); 44 | if (e != 0) 45 | errno = e; 46 | assert(fd < 0 || fd >= MIN_ttyfd); 47 | return fd; 48 | } 49 | -------------------------------------------------------------------------------- /opt.c: -------------------------------------------------------------------------------- 1 | /* opt.c -- option parsing ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | 5 | static const char *usage, *invoker; 6 | static List *args; 7 | static Term *termarg; 8 | static int nextchar; 9 | static Boolean throwonerr; 10 | 11 | extern void esoptbegin(List *list, const char *caller, const char *usagemsg, Boolean throws) { 12 | static Boolean initialized = FALSE; 13 | if (!initialized) { 14 | initialized = TRUE; 15 | globalroot(&usage); 16 | globalroot(&invoker); 17 | globalroot(&args); 18 | globalroot(&termarg); 19 | } 20 | assert(usage == NULL); 21 | usage = usagemsg; 22 | invoker = caller; 23 | args = list; 24 | termarg = NULL; 25 | nextchar = 0; 26 | throwonerr = throws; 27 | } 28 | 29 | extern int esopt(const char *options) { 30 | int c; 31 | const char *arg, *opt; 32 | 33 | assert(!throwonerr || usage != NULL); 34 | assert(termarg == NULL); 35 | if (nextchar == 0) { 36 | if (args == NULL) 37 | return EOF; 38 | assert(args->term != NULL); 39 | arg = getstr(args->term); 40 | if (*arg != '-') 41 | return EOF; 42 | if (arg[1] == '-' && arg[2] == '\0') { 43 | args = args->next; 44 | return EOF; 45 | } 46 | nextchar = 1; 47 | } else { 48 | assert(args != NULL && args->term != NULL); 49 | arg = getstr(args->term); 50 | } 51 | 52 | c = arg[nextchar++]; 53 | opt = strchr(options, c); 54 | if (opt == NULL) { 55 | const char *msg = usage; 56 | usage = NULL; 57 | args = NULL; 58 | nextchar = 0; 59 | if (throwonerr) 60 | fail(invoker, "illegal option: -%c -- usage: %s", c, msg); 61 | else return '?'; 62 | } 63 | 64 | if (arg[nextchar] == '\0') { 65 | nextchar = 0; 66 | args = args->next; 67 | } 68 | 69 | if (opt[1] == ':') { 70 | if (args == NULL) { 71 | const char *msg = usage; 72 | if (throwonerr) 73 | fail(invoker, 74 | "option -%c expects an argument -- usage: %s", 75 | c, msg); 76 | else return ':'; 77 | } 78 | termarg = (nextchar == 0) 79 | ? args->term 80 | : mkstr(gcdup(arg + nextchar)); 81 | nextchar = 0; 82 | args = args->next; 83 | } 84 | return c; 85 | } 86 | 87 | extern Term *esoptarg(void) { 88 | Term *t = termarg; 89 | assert(t != NULL); 90 | termarg = NULL; 91 | return t; 92 | } 93 | 94 | extern List *esoptend(void) { 95 | List *result = args; 96 | args = NULL; 97 | usage = NULL; 98 | return result; 99 | } 100 | -------------------------------------------------------------------------------- /parse.y: -------------------------------------------------------------------------------- 1 | /* parse.y -- grammar for es ($Revision: 1.2 $) */ 2 | 3 | %{ 4 | /* Some yaccs insist on including stdlib.h */ 5 | #include "es.h" 6 | #include "input.h" 7 | #include "syntax.h" 8 | %} 9 | 10 | %token WORD QWORD 11 | %token LOCAL LET FOR CLOSURE FN 12 | %token REDIR DUP 13 | %token ANDAND BACKBACK BBFLAT BFLAT EXTRACT CALL COUNT FLAT OROR PRIM SUB 14 | %token NL ENDFILE ERROR 15 | %token MATCH 16 | 17 | %left '^' '=' 18 | %left MATCH LOCAL LET FOR CLOSURE ')' 19 | %left ANDAND OROR NL 20 | %left '!' 21 | %left PIPE 22 | %right '$' 23 | %left SUB 24 | 25 | %union { 26 | Tree *tree; 27 | char *str; 28 | NodeKind kind; 29 | } 30 | 31 | %type keyword 32 | %type body cmd cmdsa cmdsan comword first fn line word param assign 33 | args binding bindings params nlwords words simple redir sword 34 | cases case 35 | %type binder 36 | 37 | %start es 38 | 39 | %% 40 | 41 | es : line end { parsetree = $1; YYACCEPT; } 42 | | error end { yyerrok; parsetree = NULL; YYABORT; } 43 | 44 | end : NL { if (!readheredocs(FALSE)) YYABORT; } 45 | | ENDFILE { if (!readheredocs(TRUE)) YYABORT; } 46 | 47 | line : cmd { $$ = $1; } 48 | | cmdsa line { $$ = mkseq("%seq", $1, $2); } 49 | 50 | body : cmd { $$ = $1; } 51 | | cmdsan body { $$ = mkseq("%seq", $1, $2); } 52 | 53 | cmdsa : cmd ';' { $$ = $1; } 54 | | cmd '&' { $$ = prefix("%background", mk(nList, thunkify($1), NULL)); } 55 | 56 | cmdsan : cmdsa { $$ = $1; } 57 | | cmd NL { $$ = $1; if (!readheredocs(FALSE)) YYABORT; } 58 | 59 | cmd : %prec LET { $$ = NULL; } 60 | | simple { $$ = redirect($1); if ($$ == &errornode) YYABORT; } 61 | | redir cmd %prec '!' { $$ = redirect(mk(nRedir, $1, $2)); if ($$ == &errornode) YYABORT; } 62 | | first assign { $$ = mk(nAssign, $1, $2); } 63 | | fn { $$ = $1; } 64 | | binder nl '(' bindings ')' nl cmd { $$ = mk($1, $4, $7); } 65 | | cmd ANDAND nl cmd { $$ = mkseq("%and", $1, $4); } 66 | | cmd OROR nl cmd { $$ = mkseq("%or", $1, $4); } 67 | | cmd PIPE nl cmd { $$ = mkpipe($1, $2->u[0].i, $2->u[1].i, $4); } 68 | | '!' caret cmd { $$ = prefix("%not", mk(nList, thunkify($3), NULL)); } 69 | | '~' word words { $$ = mk(nMatch, $2, $3); } 70 | | EXTRACT word words { $$ = mk(nExtract, $2, $3); } 71 | | MATCH word nl '(' cases ')' { $$ = mkmatch($2, $5); } 72 | 73 | cases : case { $$ = treecons($1, NULL); } 74 | | cases ';' case { $$ = treeconsend($1, $3); } 75 | | cases NL case { $$ = treeconsend($1, $3); } 76 | 77 | case : { $$ = NULL; } 78 | | word first { $$ = mk(nMatch, $1, thunkify($2)); } 79 | 80 | simple : first { $$ = treecons($1, NULL); } 81 | | first args { $$ = firstprepend($1, $2); } 82 | 83 | args : word { $$ = treecons($1, NULL); } 84 | | redir { $$ = redirappend(NULL, $1); } 85 | | args word { $$ = treeconsend($1, $2); } 86 | | args redir { $$ = redirappend($1, $2); } 87 | 88 | redir : DUP { $$ = $1; } 89 | | REDIR word { $$ = mkredir($1, $2); } 90 | 91 | bindings: binding { $$ = treecons($1, NULL); } 92 | | bindings ';' binding { $$ = treeconsend($1, $3); } 93 | | bindings NL binding { $$ = treeconsend($1, $3); } 94 | 95 | binding : { $$ = NULL; } 96 | | fn { $$ = $1; } 97 | | first assign { $$ = mk(nAssign, $1, $2); } 98 | 99 | assign : caret '=' caret words { $$ = $4; } 100 | 101 | fn : FN word params '{' body '}' { $$ = fnassign($2, mklambda($3, $5)); } 102 | | FN word { $$ = fnassign($2, NULL); } 103 | 104 | first : comword { $$ = $1; } 105 | | first '^' sword { $$ = mk(nConcat, $1, $3); } 106 | 107 | sword : comword { $$ = $1; } 108 | | keyword { $$ = mk(nWord, $1); } 109 | 110 | word : sword { $$ = $1; } 111 | | word '^' sword { $$ = mk(nConcat, $1, $3); } 112 | 113 | comword : param { $$ = $1; } 114 | | '(' nlwords ')' { $$ = $2; } 115 | | '{' body '}' { $$ = thunkify($2); } 116 | | '@' params '{' body '}' { $$ = mklambda($2, $4); } 117 | | '$' sword { $$ = mk(nVar, $2); } 118 | | '$' sword SUB words ')' { $$ = mk(nVarsub, $2, $4); } 119 | | CALL sword { $$ = mk(nCall, $2); } 120 | | COUNT sword { $$ = mk(nCall, prefix("%count", treecons(mk(nVar, $2), NULL))); } 121 | | FLAT sword { $$ = flatten(mk(nVar, $2), " "); } 122 | | PRIM WORD { $$ = mk(nPrim, $2); } 123 | | '`' sword { $$ = backquote(mk(nVar, mk(nWord, "ifs")), $2); } 124 | | BFLAT sword { $$ = flatten(backquote(mk(nVar, mk(nWord, "ifs")), $2), " "); } 125 | | BACKBACK word sword { $$ = backquote($2, $3); } 126 | | BBFLAT word sword { $$ = flatten(backquote($2, $3), " "); } 127 | 128 | param : WORD { $$ = mk(nWord, $1); } 129 | | QWORD { $$ = mk(nQword, $1); } 130 | 131 | params : { $$ = NULL; } 132 | | params param { $$ = treeconsend($1, $2); } 133 | 134 | words : { $$ = NULL; } 135 | | words word { $$ = treeconsend($1, $2); } 136 | 137 | nlwords : { $$ = NULL; } 138 | | nlwords word { $$ = treeconsend($1, $2); } 139 | | nlwords NL { $$ = $1; } 140 | 141 | nl : 142 | | nl NL 143 | 144 | caret : %prec '^' 145 | | '^' 146 | 147 | binder : LOCAL { $$ = nLocal; } 148 | | LET { $$ = nLet; } 149 | | FOR { $$ = nFor; } 150 | | CLOSURE { $$ = nClosure; } 151 | 152 | keyword : '!' { $$ = "!"; } 153 | | '~' { $$ = "~"; } 154 | | '=' { $$ = "="; } 155 | | EXTRACT { $$ = "~~"; } 156 | | LOCAL { $$ = "local"; } 157 | | LET { $$ = "let"; } 158 | | FOR { $$ = "for"; } 159 | | FN { $$ = "fn"; } 160 | | CLOSURE { $$ = "%closure"; } 161 | | MATCH { $$ = "match"; } 162 | 163 | -------------------------------------------------------------------------------- /prim-ctl.c: -------------------------------------------------------------------------------- 1 | /* prim-ctl.c -- control flow primitives ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "prim.h" 5 | 6 | PRIM(seq) { 7 | Ref(List *, result, ltrue); 8 | Ref(List *, lp, list); 9 | for (; lp != NULL; lp = lp->next) 10 | result = eval1(lp->term, evalflags &~ (lp->next == NULL ? 0 : eval_inchild)); 11 | RefEnd(lp); 12 | RefReturn(result); 13 | } 14 | 15 | PRIM(if) { 16 | Ref(List *, lp, list); 17 | for (; lp != NULL; lp = lp->next) { 18 | List *cond = ltrue; 19 | if (lp->next != NULL) { 20 | cond = eval1(lp->term, 0); 21 | lp = lp->next; 22 | } 23 | if (istrue(cond)) { 24 | List *result = eval1(lp->term, evalflags); 25 | RefPop(lp); 26 | return result; 27 | } 28 | } 29 | RefEnd(lp); 30 | return ltrue; 31 | } 32 | 33 | PRIM(forever) { 34 | Ref(List *, body, list); 35 | for (;;) 36 | list = eval(body, NULL, evalflags & eval_exitonfalse); 37 | RefEnd(body); 38 | return list; 39 | } 40 | 41 | PRIM(throw) { 42 | if (list == NULL) 43 | fail("$&throw", "usage: throw exception [args ...]"); 44 | throw(list); 45 | NOTREACHED; 46 | } 47 | 48 | PRIM(catch) { 49 | Atomic retry; 50 | 51 | if (list == NULL) 52 | fail("$&catch", "usage: catch catcher body"); 53 | 54 | Ref(List *, result, NULL); 55 | Ref(List *, lp, list); 56 | 57 | do { 58 | retry = FALSE; 59 | 60 | ExceptionHandler 61 | 62 | result = eval(lp->next, NULL, evalflags); 63 | 64 | CatchException (frombody) 65 | 66 | blocksignals(); 67 | ExceptionHandler 68 | result 69 | = prim("noreturn", 70 | mklist(lp->term, frombody), 71 | NULL, 72 | evalflags); 73 | unblocksignals(); 74 | CatchException (fromcatcher) 75 | 76 | if (termeq(fromcatcher->term, "retry")) { 77 | retry = TRUE; 78 | unblocksignals(); 79 | } else { 80 | unblocksignals(); 81 | throw(fromcatcher); 82 | } 83 | EndExceptionHandler 84 | 85 | EndExceptionHandler 86 | } while (retry); 87 | RefEnd(lp); 88 | RefReturn(result); 89 | } 90 | 91 | extern Dict *initprims_controlflow(Dict *primdict) { 92 | X(seq); 93 | X(if); 94 | X(throw); 95 | X(forever); 96 | X(catch); 97 | return primdict; 98 | } 99 | -------------------------------------------------------------------------------- /prim.c: -------------------------------------------------------------------------------- 1 | /* prim.c -- primitives and primitive dispatching ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "prim.h" 5 | 6 | static Dict *prims; 7 | 8 | extern List *prim(char *s, List *list, Binding *binding, int evalflags) { 9 | Prim *p; 10 | p = (Prim *) dictget(prims, s); 11 | if (p == NULL) 12 | fail("es:prim", "unknown primitive: %s", s); 13 | return (p->prim)(list, binding, evalflags); 14 | } 15 | 16 | static char *list_prefix; 17 | 18 | static void listwithprefix(void *arg, char *key, void *value) { 19 | if (strneq(key, list_prefix, strlen(list_prefix))) 20 | addtolist(arg, key, value); 21 | } 22 | 23 | extern List *primswithprefix(char *prefix) { 24 | Ref(List *, primlist, NULL); 25 | list_prefix = prefix; 26 | dictforall(prims, listwithprefix, &primlist); 27 | RefReturn(primlist); 28 | } 29 | 30 | PRIM(primitives) { 31 | static List *primlist = NULL; 32 | if (primlist == NULL) { 33 | globalroot(&primlist); 34 | dictforall(prims, addtolist, &primlist); 35 | primlist = sortlist(primlist); 36 | } 37 | return primlist; 38 | } 39 | 40 | extern void initprims(void) { 41 | prims = mkdict(); 42 | globalroot(&prims); 43 | 44 | prims = initprims_controlflow(prims); 45 | prims = initprims_io(prims); 46 | prims = initprims_etc(prims); 47 | prims = initprims_sys(prims); 48 | prims = initprims_proc(prims); 49 | prims = initprims_access(prims); 50 | 51 | #define primdict prims 52 | X(primitives); 53 | } 54 | -------------------------------------------------------------------------------- /prim.h: -------------------------------------------------------------------------------- 1 | /* prim.h -- definitions for es primitives ($Revision: 1.1.1.1 $) */ 2 | 3 | typedef struct { List *(*prim)(List *, Binding *, int); } Prim; 4 | 5 | #define PRIM(name) static List *CONCAT(prim_,name)( \ 6 | List UNUSED *list, Binding UNUSED *binding, int UNUSED evalflags \ 7 | ) 8 | #define X(name) STMT( \ 9 | static Prim CONCAT(prim_struct_,name) = { CONCAT(prim_,name) }; \ 10 | primdict = dictput( \ 11 | primdict, \ 12 | STRING(name), \ 13 | (void *) &CONCAT(prim_struct_,name) \ 14 | )) 15 | 16 | extern Dict *initprims_controlflow(Dict *primdict); /* prim-ctl.c */ 17 | extern Dict *initprims_io(Dict *primdict); /* prim-io.c */ 18 | extern Dict *initprims_etc(Dict *primdict); /* prim-etc.c */ 19 | extern Dict *initprims_sys(Dict *primdict); /* prim-sys.c */ 20 | extern Dict *initprims_proc(Dict *primdict); /* proc.c */ 21 | extern Dict *initprims_access(Dict *primdict); /* access.c */ 22 | -------------------------------------------------------------------------------- /print.h: -------------------------------------------------------------------------------- 1 | /* print.h -- interface to formatted printing routines ($Revision: 1.1.1.1 $) */ 2 | 3 | typedef struct Format Format; 4 | struct Format { 5 | /* for the formatting routines */ 6 | va_list args; 7 | long flags, f1, f2; 8 | int invoker; 9 | /* for the buffer maintenance routines */ 10 | char *buf, *bufbegin, *bufend; 11 | int flushed; 12 | int (*grow)(Format *, size_t); 13 | union { int n; void *p; } u; 14 | }; 15 | 16 | 17 | /* Format->flags values */ 18 | enum { 19 | FMT_long = 1, /* %l */ 20 | FMT_short = 2, /* %h */ 21 | FMT_unsigned = 4, /* %u */ 22 | FMT_zeropad = 8, /* %0 */ 23 | FMT_leftside = 16, /* %- */ 24 | FMT_altform = 32, /* %# */ 25 | FMT_f1set = 64, /* % */ 26 | FMT_f2set = 128 /* %. */ 27 | }; 28 | 29 | typedef Boolean (*Conv)(Format *); 30 | 31 | extern Conv fmtinstall(int, Conv); 32 | extern int printfmt(Format *, const char *); 33 | extern int fmtprint(Format *, const char * VARARGS); 34 | extern void fmtappend(Format *, const char *, size_t); 35 | extern void fmtcat(Format *, const char *); 36 | 37 | extern int print(const char *fmt VARARGS); 38 | extern int eprint(const char *fmt VARARGS); 39 | extern int fprint(int fd, const char *fmt VARARGS); 40 | 41 | extern char *strv(const char *fmt, va_list args); /* varargs interface to str() */ 42 | 43 | #define FPRINT_BUFSIZ 1024 44 | 45 | /* 46 | * the following macro should by rights be coded as an expression, not 47 | * a statement, but certain compilers (notably DEC) have trouble with 48 | * void expressions inside the ?: operator. (sheesh, give me a break!) 49 | */ 50 | #define fmtputc(f, c) \ 51 | STMT( \ 52 | if ((f)->buf >= (f)->bufend) \ 53 | (*(f)->grow)((f), (size_t)1); \ 54 | *(f)->buf++ = (c) \ 55 | ) 56 | -------------------------------------------------------------------------------- /proc.c: -------------------------------------------------------------------------------- 1 | /* proc.c -- process control system calls ($Revision: 1.2 $) */ 2 | 3 | #include "es.h" 4 | 5 | Boolean hasforked = FALSE; 6 | 7 | typedef struct Proc Proc; 8 | struct Proc { 9 | int pid; 10 | Boolean background; 11 | Proc *next, *prev; 12 | }; 13 | 14 | static Proc *proclist = NULL; 15 | 16 | static int ttyfd = -1; 17 | static pid_t espgid; 18 | #if JOB_PROTECT 19 | static pid_t tcpgid0; 20 | #endif 21 | 22 | /* mkproc -- create a Proc structure */ 23 | extern Proc *mkproc(int pid, Boolean background) { 24 | Proc *proc = ealloc(sizeof (Proc)); 25 | proc->next = proclist; 26 | proc->pid = pid; 27 | proc->background = background; 28 | proc->prev = NULL; 29 | return proc; 30 | } 31 | 32 | /* efork -- fork (if necessary) and clean up as appropriate */ 33 | extern int efork(Boolean parent, Boolean background) { 34 | if (parent) { 35 | int pid = fork(); 36 | switch (pid) { 37 | default: { /* parent */ 38 | Proc *proc = mkproc(pid, background); 39 | if (proclist != NULL) 40 | proclist->prev = proc; 41 | proclist = proc; 42 | return pid; 43 | } 44 | case 0: /* child */ 45 | while (proclist != NULL) { 46 | Proc *p = proclist; 47 | proclist = proclist->next; 48 | efree(p); 49 | } 50 | hasforked = TRUE; 51 | #if JOB_PROTECT 52 | tcpgid0 = 0; 53 | #endif 54 | break; 55 | case -1: 56 | fail("es:efork", "fork: %s", esstrerror(errno)); 57 | } 58 | } 59 | closefds(); 60 | setsigdefaults(); 61 | newchildcatcher(); 62 | return 0; 63 | } 64 | 65 | extern pid_t spgrp(pid_t pgid) { 66 | pid_t old = getpgrp(); 67 | setpgid(0, pgid); 68 | espgid = pgid; 69 | return old; 70 | } 71 | 72 | static int tcspgrp(pid_t pgid) { 73 | int e = 0; 74 | Sigeffect tstp, ttin, ttou; 75 | if (ttyfd < 0) 76 | return ENOTTY; 77 | tstp = esignal(SIGTSTP, sig_ignore); 78 | ttin = esignal(SIGTTIN, sig_ignore); 79 | ttou = esignal(SIGTTOU, sig_ignore); 80 | if (tcsetpgrp(ttyfd, pgid) != 0) 81 | e = errno; 82 | esignal(SIGTSTP, tstp); 83 | esignal(SIGTTIN, ttin); 84 | esignal(SIGTTOU, ttou); 85 | return e; 86 | } 87 | 88 | extern int tctakepgrp(void) { 89 | pid_t tcpgid = 0; 90 | if (ttyfd < 0) 91 | return ENOTTY; 92 | tcpgid = tcgetpgrp(ttyfd); 93 | if (espgid == 0 || tcpgid == espgid) 94 | return 0; 95 | return tcspgrp(espgid); 96 | } 97 | 98 | extern void initpgrp(void) { 99 | espgid = getpgrp(); 100 | ttyfd = opentty(); 101 | #if JOB_PROTECT 102 | if (ttyfd >= 0) 103 | tcpgid0 = tcgetpgrp(ttyfd); 104 | #endif 105 | } 106 | 107 | #if JOB_PROTECT 108 | extern void tcreturnpgrp(void) { 109 | if (tcpgid0 != 0 && ttyfd >= 0 && tcpgid0 != tcgetpgrp(ttyfd)) 110 | tcspgrp(tcpgid0); 111 | } 112 | 113 | extern Noreturn esexit(int code) { 114 | tcreturnpgrp(); 115 | exit(code); 116 | } 117 | #endif 118 | 119 | /* reap -- mark a process as dead and return it */ 120 | static Proc *reap(int pid) { 121 | Proc *proc; 122 | for (proc = proclist; proc != NULL; proc = proc->next) 123 | if (proc->pid == pid) 124 | break; 125 | assert(proc != NULL); 126 | if (proc->next != NULL) 127 | proc->next->prev = proc->prev; 128 | if (proc->prev != NULL) 129 | proc->prev->next = proc->next; 130 | else 131 | proclist = proc->next; 132 | return proc; 133 | } 134 | 135 | /* ewait -- wait for a specific process to die, or any process if pid == -1 */ 136 | extern int ewait(int pidarg, Boolean interruptible) { 137 | int deadpid, status; 138 | Proc *proc; 139 | while ((deadpid = waitpid(pidarg, &status, 0)) == -1) { 140 | if (errno == ECHILD && pidarg > 0) 141 | fail("es:ewait", "wait: %d is not a child of this shell", pidarg); 142 | else if (errno != EINTR) 143 | fail("es:ewait", "wait: %s", esstrerror(errno)); 144 | if (interruptible) 145 | SIGCHK(); 146 | } 147 | proc = reap(deadpid); 148 | #if JOB_PROTECT 149 | tctakepgrp(); 150 | #endif 151 | if (proc->background) 152 | printstatus(proc->pid, status); 153 | efree(proc); 154 | return status; 155 | } 156 | 157 | #include "prim.h" 158 | 159 | PRIM(apids) { 160 | Proc *p; 161 | Ref(List *, lp, NULL); 162 | for (p = proclist; p != NULL; p = p->next) 163 | if (p->background) { 164 | Term *t = mkstr(str("%d", p->pid)); 165 | lp = mklist(t, lp); 166 | } 167 | /* TODO: sort the return value, but by number? */ 168 | RefReturn(lp); 169 | } 170 | 171 | PRIM(wait) { 172 | int pid; 173 | if (list == NULL) 174 | pid = -1; 175 | else if (list->next == NULL) { 176 | pid = atoi(getstr(list->term)); 177 | if (pid <= 0) { 178 | fail("$&wait", "wait: %d: bad pid", pid); 179 | NOTREACHED; 180 | } 181 | } else { 182 | fail("$&wait", "usage: wait [pid]"); 183 | NOTREACHED; 184 | } 185 | return mklist(mkstr(mkstatus(ewait(pid, TRUE))), NULL); 186 | } 187 | 188 | extern Dict *initprims_proc(Dict *primdict) { 189 | X(apids); 190 | X(wait); 191 | return primdict; 192 | } 193 | -------------------------------------------------------------------------------- /release.es: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env es 2 | 3 | # Create a new tarball 4 | 5 | if {!~ $#* 1} { 6 | echo Must provide a single argument: the release version (e.g. 0.9.1) 7 | exit 1 8 | } 9 | 10 | if {! grep -q $1 version.c} { 11 | echo 'Must update version.c to '^$1 12 | echo '(yes, this should be automated)' 13 | } 14 | 15 | tar chzvf ../es-$1.tar.gz --exclude\=.circleci --exclude\=.gitignore --exclude\=release.es `{git ls-files} config.guess config.sub config.h.in configure install-sh 16 | -------------------------------------------------------------------------------- /share/autoload.es: -------------------------------------------------------------------------------- 1 | # autoload.es -- Auto-load shell functions on demand. 2 | # 3 | # An autoloadable function, say, foo, should be in the file foo and should 4 | # contain the definition of the function, as in 5 | # 6 | # ; cat foo 7 | # fn foo args { 8 | # body 9 | # } 10 | # 11 | # By default, the autoload directory is $XDG_DATA_HOME/es/autoload (if 12 | # $XDG_DATA_HOME is unset, that defaults to ~/.local/share/es/autoload). 13 | # The autoload directory can be changed by setting $es-autoload to the desired 14 | # location. 15 | # 16 | # This is a light adaptation of the original version written by Paul Haahr. 17 | # See esrc.haahr in the examples directory for more of his setup. 18 | 19 | let (search = $fn-%pathsearch) 20 | fn %pathsearch prog { 21 | let (autoload = $XDG_DATA_HOME/es/autoload) { 22 | if {!~ $#es-autoload 0} { 23 | autoload = $es-autoload(1) 24 | } {!~ $#autoload 1} { 25 | autoload = ~/.local/share/es/autoload 26 | } 27 | if {access -f -r $autoload/$prog} { 28 | . $autoload/$prog 29 | if {!~ $#(fn-$prog) 0} { 30 | return $(fn-$prog) 31 | } 32 | } 33 | } 34 | $search $prog 35 | } 36 | -------------------------------------------------------------------------------- /share/cdpath.es: -------------------------------------------------------------------------------- 1 | # cdpath.es -- Add rc-like $cdpath behavior to es. 2 | # 3 | # `cd'ing to an absolute directory (one which starts with a /, ./, or ../) is 4 | # unchanged. For any other directory, cd performs a path-search for the 5 | # directory in the list given by the $cdpath variable. 6 | # 7 | # If multiple arguments are given, then path searching is not performed, as we 8 | # don't know a priori which of the arguments are meant to be a searchable 9 | # directory. Perhaps a future improvement -- decomposing the cdpath behavior 10 | # to allow more-extended definitions of cd to integrate $cdpath a bit more 11 | # easily. 12 | 13 | let (cd = $fn-cd) 14 | fn cd dir { 15 | if {!~ $#dir 1 || ~ $dir (/* ./* ../*)} { 16 | return <={$cd $dir} 17 | } 18 | let (abs = <={%cdpathsearch $dir}) { 19 | if {!~ $abs ($dir ./$dir)} { 20 | echo >[1=2] $abs 21 | } 22 | $cd $abs 23 | } 24 | } 25 | 26 | # %cdpathsearch performs the cdpath-searching behavior for cd. It is nearly 27 | # identical to the default %pathsearch, except it searches for directories 28 | # rather than executable files. 29 | 30 | fn %cdpathsearch name { access -n $name -1e -d $cdpath } 31 | 32 | # cdpath and CDPATH contain the list of directories to search for cd. They 33 | # follow the convention that the uppercase CDPATH contains a single colon- 34 | # separated word which is understandable to other CDPATH-using shells, while 35 | # the lowercase cdpath contains an es list. For interoperability with other 36 | # utilities, CDPATH is exported while cdpath is not. 37 | 38 | # Somewhat awkwardly, we have to "re-noexport" cdpath in each shell which 39 | # inherits CDPATH, because noexport is itself not exported, so es "forgets" 40 | # about noexport state. This is probably the correct behavior in general, but 41 | # it's not very convenient in this case. 42 | 43 | set-cdpath = @ {local (set-CDPATH = ) CDPATH = <={%flatten : $*}; result $*} 44 | set-CDPATH = @ { 45 | local (set-cdpath = ) cdpath = <={%fsplit : $*} 46 | if {!~ $noexport cdpath} {noexport = $noexport cdpath} 47 | result $* 48 | } 49 | 50 | noexport = $noexport cdpath 51 | 52 | # The default value of cdpath is '.': the current directory. If cdpath is the 53 | # empty list, then path searching behavior will not work, and it will only be 54 | # possible to cd to paths starting with one of (/ ./ ../). 55 | 56 | cdpath = . 57 | -------------------------------------------------------------------------------- /share/interactive-init.es: -------------------------------------------------------------------------------- 1 | # interactive-init.es -- Add a hook function %interactive-init. 2 | # 3 | # If defined, the function %interactive-init is called with no arguments before 4 | # the interactive loop starts. It is called with a simple exception handler so 5 | # that any exceptions coming from %interactive-init don't break the shell. 6 | 7 | let (loop = $fn-%interactive-loop) 8 | fn %interactive-loop { 9 | if {!~ $#fn-%interactive-init 0} { 10 | catch @ e type msg { 11 | if {~ $e exit} { 12 | exit $type $msg 13 | } {~ $e error} { 14 | echo >[1=2] $msg 15 | } {!~ $e signal || !~ $type sigint} { 16 | echo >[1=2] uncaught exception: $e $type $msg 17 | } 18 | } { 19 | %interactive-init 20 | } 21 | } 22 | $loop $* 23 | } 24 | -------------------------------------------------------------------------------- /share/path-cache.es: -------------------------------------------------------------------------------- 1 | # path-cache.es -- Cache paths as functions. 2 | # 3 | # When a binary $prog is searched for in $path and run, then fn-$prog is set to 4 | # $path (if not already defined). This short-circuits the process of searching 5 | # path for that $prog in the future, which can be a performance win when path 6 | # searching is slow for whatever reason. Many Bourne-based shells do something 7 | # similar under the name "hashing". 8 | # 9 | # Caching the path also adds $prog to the path-cache variable. This is used by 10 | # the recache function described below. It can also be inspected by the user, 11 | # but should probably not be modified by anything other than recache. 12 | # 13 | # This implementation avoids redefining any already-defined functions, which may 14 | # be a bit over-conservative, but seems less surprising than the alternative. 15 | # 16 | # This is adapted from a version originally written by Paul Haahr. 17 | # See esrc.haahr in the examples directory for more of his setup. 18 | 19 | let (search = $fn-%pathsearch) 20 | fn %pathsearch prog { 21 | let (path = <={$search $prog}) { 22 | if {~ $path /*} { 23 | if {~ $#(fn-$prog) 0} { 24 | path-cache = $path-cache $prog 25 | fn-$prog = $path 26 | } 27 | } 28 | result $path 29 | } 30 | } 31 | 32 | # recache takes a list of binaries. For each one, if that prog is in 33 | # $path-cache, then fn-$prog is set to () and $prog is removed from 34 | # path-cache. If recache is called with no arguments, then the entire cache is 35 | # reset. 36 | 37 | fn recache progs { 38 | let (cache = $path-cache; new-cache = ()) { 39 | if {~ $#progs 0} { 40 | progs = $path-cache 41 | } 42 | for (p = $cache) { 43 | if {~ $p $progs} { 44 | fn-$p = () 45 | } { 46 | new-cache = $new-cache $p 47 | } 48 | } 49 | path-cache = $new-cache 50 | } 51 | } 52 | 53 | # precache also takes a list of binaries. For each one, if the binary is 54 | # valid, it caches the binary in the path cache without running it. This can 55 | # be useful in ~/.esrc for pre-caching binaries which are known ahead of time to 56 | # be frequently used. 57 | 58 | fn precache progs { 59 | let (result = ()) 60 | for (p = $progs) { 61 | catch @ e type msg { 62 | if {~ $e error} { 63 | echo >[1=2] $msg 64 | } { 65 | throw $e $type $msg 66 | } 67 | } { 68 | result = $result <={%pathsearch $p} 69 | } 70 | } 71 | } 72 | 73 | # path-cache and the fn-$progs defined by %pathsearch are exported to the 74 | # environment, under the assumption that subshells will also benefit from the 75 | # already-built cache. 76 | 77 | path-cache = () 78 | 79 | # cache-path, along with this set of settor functions, ensure that when the path 80 | # is changed, recache is called. 81 | 82 | cache-path = $path 83 | 84 | set-cache-path = @ { 85 | for (o = $cache-path; n = $*) { 86 | if {!~ $o $n} { 87 | recache 88 | break 89 | } 90 | } 91 | result $* 92 | } 93 | 94 | let (sp = $set-path) set-path = @ {cache-path = $*; $sp $*} 95 | let (sp = $set-PATH) set-PATH = @ {cache-path = <={%fsplit : $*}; $sp $*} 96 | -------------------------------------------------------------------------------- /share/status.es: -------------------------------------------------------------------------------- 1 | # status.es -- Make $status available in the interactive loop. 2 | # 3 | # With this, users can get the return value of the previous command invoked 4 | # at the REPL. This corresponds with $? in Bourne-compatible shells, or $status 5 | # in rc. Modifying $status is not very useful. 6 | # 7 | # One unique limitation of this $status is that it doesn't understand groups of 8 | # commands like: 9 | # 10 | # false; echo $status 11 | # 12 | # This will reflect the return value of the previous command typed at the REPL, 13 | # not the false. Because of this, users should, in general, still prefer to use 14 | # <= whenever possible. 15 | 16 | let (loop = $fn-%interactive-loop) 17 | fn %interactive-loop { 18 | let (d = $fn-%dispatch) 19 | local ( 20 | noexport = $noexport status 21 | status = <=true 22 | fn-%dispatch = $&noreturn @ { 23 | catch @ e rest { 24 | if {~ $e return} { 25 | status = $rest 26 | } 27 | throw $e $rest 28 | } { 29 | status = <={$d $*} 30 | } 31 | } 32 | ) $loop $* 33 | } 34 | -------------------------------------------------------------------------------- /sigmsgs.h: -------------------------------------------------------------------------------- 1 | /* sigmsgs.h -- interface to signal name and message date ($Revision: 1.1.1.1 $) */ 2 | 3 | typedef struct { 4 | int sig; 5 | const char *name, *msg; 6 | } Sigmsgs; 7 | extern const Sigmsgs signals[]; 8 | 9 | extern const int nsignals; 10 | -------------------------------------------------------------------------------- /split.c: -------------------------------------------------------------------------------- 1 | /* split.c -- split strings based on separators ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | 6 | static Boolean coalesce; 7 | static Boolean splitchars; 8 | static Buffer *buffer; 9 | static List *value; 10 | 11 | static Boolean ifsvalid = FALSE; 12 | static char ifs[10], isifs[256]; 13 | 14 | extern void startsplit(const char *sep, Boolean coalescef) { 15 | static Boolean initialized = FALSE; 16 | if (!initialized) { 17 | initialized = TRUE; 18 | globalroot(&value); 19 | } 20 | 21 | value = NULL; 22 | buffer = NULL; 23 | coalesce = coalescef; 24 | splitchars = !coalesce && *sep == '\0'; 25 | 26 | if (!ifsvalid || !streq(sep, ifs)) { 27 | int c; 28 | if (strlen(sep) + 1 < sizeof ifs) { 29 | strcpy(ifs, sep); 30 | ifsvalid = TRUE; 31 | } else 32 | ifsvalid = FALSE; 33 | memzero(isifs, sizeof isifs); 34 | for (isifs['\0'] = TRUE; (c = (*(unsigned const char *)sep)) != '\0'; sep++) 35 | isifs[c] = TRUE; 36 | } 37 | } 38 | 39 | extern char *stepsplit(char *in, size_t len, Boolean endword) { 40 | Buffer *buf = buffer; 41 | unsigned char *s = (unsigned char *) in, *inend = s + len; 42 | 43 | if (splitchars) { 44 | Boolean end; 45 | Term *term; 46 | 47 | if (*s == '\0') return NULL; 48 | assert(buf == NULL); 49 | 50 | end = *(s + 1) == '\0'; 51 | 52 | term = mkstr(gcndup((char *) s, 1)); 53 | value = mklist(term, value); 54 | 55 | if (end) return NULL; 56 | return (char *) ++s; 57 | } 58 | 59 | if (!coalesce && buf == NULL) 60 | buf = openbuffer(0); 61 | 62 | while (s < inend) { 63 | int c = *s++; 64 | if (buf != NULL) 65 | if (isifs[c]) { 66 | Term *term = mkstr(sealcountedbuffer(buf)); 67 | value = mklist(term, value); 68 | buffer = buf = coalesce ? NULL : openbuffer(0); 69 | return (char *) s; 70 | } else 71 | buf = bufputc(buf, c); 72 | else if (!isifs[c]) 73 | buf = bufputc(openbuffer(0), c); 74 | } 75 | 76 | if (endword && buf != NULL) { 77 | Term *term = mkstr(sealcountedbuffer(buf)); 78 | value = mklist(term, value); 79 | buf = NULL; 80 | } 81 | buffer = buf; 82 | return NULL; 83 | } 84 | 85 | extern void splitstring(char *in, size_t len, Boolean endword) { 86 | size_t remainder; 87 | char *s = in; 88 | do { 89 | remainder = len - (s - in); 90 | s = stepsplit(s, remainder, endword); 91 | } while (s != NULL); 92 | } 93 | 94 | extern List *endsplit(void) { 95 | List *result; 96 | 97 | if (buffer != NULL) { 98 | Term *term = mkstr(sealcountedbuffer(buffer)); 99 | value = mklist(term, value); 100 | buffer = NULL; 101 | } 102 | result = reverse(value); 103 | value = NULL; 104 | return result; 105 | } 106 | 107 | extern List *fsplit(const char *sep, List *list, Boolean coalesce) { 108 | Ref(List *, lp, list); 109 | startsplit(sep, coalesce); 110 | for (; lp != NULL; lp = lp->next) { 111 | char *bs = getstr(lp->term), *s = bs; 112 | do { 113 | char *ns = getstr(lp->term); 114 | s = ns + (s - bs); 115 | bs = ns; 116 | s = stepsplit(s, strlen(s), TRUE); 117 | } while (s != NULL); 118 | } 119 | RefEnd(lp); 120 | return endsplit(); 121 | } 122 | -------------------------------------------------------------------------------- /status.c: -------------------------------------------------------------------------------- 1 | /* status.c -- status manipulations ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "term.h" 5 | 6 | static const Term 7 | trueterm = { "0", NULL }, 8 | falseterm = { "1", NULL }; 9 | static const List 10 | truelist = { (Term *) &trueterm, NULL }, 11 | falselist = { (Term *) &falseterm, NULL }; 12 | List 13 | *ltrue = (List *) &truelist, 14 | *lfalse = (List *) &falselist; 15 | 16 | /* istrue -- is this status list true? */ 17 | extern Boolean istrue(List *status) { 18 | for (; status != NULL; status = status->next) { 19 | Term *term = status->term; 20 | if (term->closure != NULL) 21 | return FALSE; 22 | else { 23 | const char *str = term->str; 24 | assert(str != NULL); 25 | if (*str != '\0' && (*str != '0' || str[1] != '\0')) 26 | return FALSE; 27 | } 28 | } 29 | return TRUE; 30 | } 31 | 32 | /* exitstatus -- turn a status list into an exit(2) value */ 33 | extern int exitstatus(List *status) { 34 | Term *term; 35 | char *s; 36 | unsigned long n; 37 | 38 | if (status == NULL) 39 | return 0; 40 | if (status->next != NULL) 41 | return istrue(status) ? 0 : 1; 42 | term = status->term; 43 | if (term->closure != NULL) 44 | return 1; 45 | 46 | s = term->str; 47 | if (*s == '\0') 48 | return 0; 49 | n = strtol(s, &s, 0); 50 | if (*s != '\0' || n > 255) 51 | return 1; 52 | return n; 53 | } 54 | 55 | /* mkstatus -- turn a unix exit(2) status into a string */ 56 | extern char *mkstatus(int status) { 57 | if (WIFSIGNALED(status)) { 58 | char *name = signame(WTERMSIG(status)); 59 | if (WCOREDUMP(status)) 60 | name = str("%s+core", name); 61 | return name; 62 | } 63 | return str("%d", WEXITSTATUS(status)); 64 | } 65 | 66 | /* printstatus -- print the status if we should */ 67 | extern void printstatus(int pid, int status) { 68 | if (WIFSIGNALED(status)) { 69 | const char *msg = sigmessage(WTERMSIG(status)), *tail = ""; 70 | if (WCOREDUMP(status)) { 71 | tail = "--core dumped"; 72 | if (*msg == '\0') 73 | tail += (sizeof "--") - 1; 74 | } 75 | if (*msg != '\0' || *tail != '\0') { 76 | if (pid == 0) 77 | eprint("%s%s\n", msg, tail); 78 | else 79 | eprint("%d: %s%s\n", pid, msg, tail); 80 | } 81 | } 82 | } 83 | -------------------------------------------------------------------------------- /str.c: -------------------------------------------------------------------------------- 1 | /* str.c -- es string operations ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | #include "print.h" 6 | 7 | /* grow -- buffer grow function for str() */ 8 | static int str_grow(Format *f, size_t more) { 9 | Buffer *buf = expandbuffer(f->u.p, more); 10 | f->u.p = buf; 11 | f->buf = buf->str + (f->buf - f->bufbegin); 12 | f->bufbegin = buf->str; 13 | f->bufend = buf->str + buf->len; 14 | return 0; 15 | } 16 | 17 | /* strv -- print a formatted string into gc space */ 18 | static char *sstrv(char *(*seal)(Buffer *), const char *fmt, va_list args) { 19 | Buffer *buf; 20 | Format format; 21 | 22 | gcdisable(); 23 | buf = openbuffer(0); 24 | format.u.p = buf; 25 | #if NO_VA_LIST_ASSIGN 26 | memcpy(format.args, args, sizeof(va_list)); 27 | #else 28 | format.args = args; 29 | #endif 30 | format.buf = buf->str; 31 | format.bufbegin = buf->str; 32 | format.bufend = buf->str + buf->len; 33 | format.grow = str_grow; 34 | format.flushed = 0; 35 | 36 | printfmt(&format, fmt); 37 | fmtputc(&format, '\0'); 38 | gcenable(); 39 | 40 | return seal(format.u.p); 41 | } 42 | 43 | extern char *strv(const char *fmt, va_list args) { 44 | return sstrv(sealbuffer, fmt, args); 45 | } 46 | 47 | /* str -- create a string (in garbage collection space) by printing to it */ 48 | extern char *str VARARGS1(const char *, fmt) { 49 | char *s; 50 | va_list args; 51 | VA_START(args, fmt); 52 | s = strv(fmt, args); 53 | va_end(args); 54 | return s; 55 | } 56 | 57 | /* pstr -- create a string (in pspace) by printing to it */ 58 | extern char *pstr VARARGS1(const char *, fmt) { 59 | char *s; 60 | va_list args; 61 | VA_START(args, fmt); 62 | s = sstrv(psealbuffer, fmt, args); 63 | va_end(args); 64 | return s; 65 | } 66 | 67 | 68 | #define PRINT_ALLOCSIZE 64 69 | 70 | /* mprint_grow -- buffer grow function for mprint() */ 71 | static int mprint_grow(Format *format, size_t more) { 72 | char *buf; 73 | size_t len = format->bufend - format->bufbegin + 1; 74 | len = (len >= more) 75 | ? len * 2 76 | : ((len + more) + PRINT_ALLOCSIZE) &~ (PRINT_ALLOCSIZE - 1); 77 | buf = erealloc(format->bufbegin, len); 78 | format->buf = buf + (format->buf - format->bufbegin); 79 | format->bufbegin = buf; 80 | format->bufend = buf + len - 1; 81 | return 0; 82 | } 83 | 84 | /* mprint -- create a string in ealloc space by printing to it */ 85 | extern char *mprint VARARGS1(const char *, fmt) { 86 | Format format; 87 | format.u.n = 1; 88 | VA_START(format.args, fmt); 89 | 90 | format.buf = ealloc(PRINT_ALLOCSIZE); 91 | format.bufbegin = format.buf; 92 | format.bufend = format.buf + PRINT_ALLOCSIZE - 1; 93 | format.grow = mprint_grow; 94 | format.flushed = 0; 95 | 96 | printfmt(&format, fmt); 97 | *format.buf = '\0'; 98 | va_end(format.args); 99 | return format.bufbegin; 100 | } 101 | 102 | 103 | /* 104 | * StrList -- lists of strings 105 | * to even include these is probably a premature optimization 106 | */ 107 | 108 | DefineTag(StrList, static); 109 | 110 | extern StrList *mkstrlist(char *str, StrList *next) { 111 | gcdisable(); 112 | assert(str != NULL); 113 | Ref(StrList *, list, gcnew(StrList)); 114 | list->str = str; 115 | list->next = next; 116 | gcenable(); 117 | RefReturn(list); 118 | } 119 | 120 | static void *StrListCopy(void *op) { 121 | void *np = gcnew(StrList); 122 | memcpy(np, op, sizeof (StrList)); 123 | return np; 124 | } 125 | 126 | static size_t StrListScan(void *p) { 127 | StrList *list = p; 128 | list->str = forward(list->str); 129 | list->next = forward(list->next); 130 | return sizeof (StrList); 131 | } 132 | 133 | -------------------------------------------------------------------------------- /syntax.h: -------------------------------------------------------------------------------- 1 | /* syntax.h -- abstract syntax tree interface ($Revision: 1.1.1.1 $) */ 2 | 3 | #define CAR u[0].p 4 | #define CDR u[1].p 5 | 6 | 7 | /* tree.c */ 8 | 9 | extern Tree *mk(NodeKind VARARGS); /* palloc a tree node */ 10 | 11 | 12 | /* syntax.c */ 13 | 14 | extern Tree errornode; 15 | 16 | extern Tree *treecons(Tree *car, Tree *cdr); 17 | extern Tree *treeconsend(Tree *p, Tree *q); 18 | extern Tree *treeappend(Tree *head, Tree *tail); 19 | extern Tree *thunkify(Tree *tree); 20 | 21 | extern Tree *prefix(char *s, Tree *t); 22 | extern Tree *backquote(Tree *ifs, Tree *body); 23 | extern Tree *flatten(Tree *t, char *sep); 24 | extern Tree *fnassign(Tree *name, Tree *defn); 25 | extern Tree *mklambda(Tree *params, Tree *body); 26 | extern Tree *mkseq(char *op, Tree *t1, Tree *t2); 27 | extern Tree *mkpipe(Tree *t1, int outfd, int infd, Tree *t2); 28 | 29 | extern Tree *mkclose(int fd); 30 | extern Tree *mkdup(int fd0, int fd1); 31 | extern Tree *redirect(Tree *t); 32 | extern Tree *mkredir(Tree *cmd, Tree *file); 33 | extern Tree *mkredircmd(char *cmd, int fd); 34 | extern Tree *redirappend(Tree *t, Tree *r); 35 | extern Tree *firstprepend(Tree *first, Tree *args); 36 | 37 | extern Tree *mkmatch(Tree *subj, Tree *cases); 38 | 39 | /* str.c */ 40 | 41 | extern char *pstr(const char *fmt VARARGS); 42 | 43 | /* heredoc.c */ 44 | 45 | extern Boolean readheredocs(Boolean endfile); 46 | extern Boolean queueheredoc(Tree *t); 47 | -------------------------------------------------------------------------------- /term.c: -------------------------------------------------------------------------------- 1 | /* term.c -- operations on terms ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | #include "term.h" 6 | 7 | DefineTag(Term, static); 8 | 9 | extern Term *mkterm(char *str, Closure *closure) { 10 | gcdisable(); 11 | Ref(Term *, term, gcnew(Term)); 12 | term->str = str; 13 | term->closure = closure; 14 | gcenable(); 15 | RefReturn(term); 16 | } 17 | 18 | extern Term *mkstr(char *str) { 19 | Term *term; 20 | Ref(char *, string, str); 21 | term = gcnew(Term); 22 | term->str = string; 23 | term->closure = NULL; 24 | RefEnd(string); 25 | return term; 26 | } 27 | 28 | extern Closure *getclosure(Term *term) { 29 | if (term->closure == NULL) { 30 | char *s = term->str; 31 | assert(s != NULL); 32 | if ( 33 | ((*s == '{' || *s == '@') && s[strlen(s) - 1] == '}') 34 | || (*s == '$' && s[1] == '&') 35 | || hasprefix(s, "%closure") 36 | ) { 37 | Ref(Term *, tp, term); 38 | Ref(Tree *, np, parsestring(s)); 39 | if (np == NULL) { 40 | RefPop2(np, tp); 41 | return NULL; 42 | } 43 | tp->closure = extractbindings(np); 44 | tp->str = NULL; 45 | term = tp; 46 | RefEnd2(np, tp); 47 | } 48 | } 49 | return term->closure; 50 | } 51 | 52 | extern char *getstr(Term *term) { 53 | char *s = term->str; 54 | Closure *closure = term->closure; 55 | assert((s == NULL) != (closure == NULL)); 56 | if (s != NULL) 57 | return s; 58 | 59 | #if 0 /* TODO: decide whether getstr() leaves term in closure or string form */ 60 | Ref(Term *, tp, term); 61 | s = str("%C", closure); 62 | tp->str = s; 63 | tp->closure = NULL; 64 | RefEnd(tp); 65 | return s; 66 | #else 67 | return str("%C", closure); 68 | #endif 69 | } 70 | 71 | extern Term *termcat(Term *t1, Term *t2) { 72 | if (t1 == NULL) 73 | return t2; 74 | if (t2 == NULL) 75 | return t1; 76 | 77 | Ref(Term *, term, mkstr(NULL)); 78 | Ref(char *, str1, getstr(t1)); 79 | Ref(char *, str2, getstr(t2)); 80 | term->str = str("%s%s", str1, str2); 81 | RefEnd2(str2, str1); 82 | RefReturn(term); 83 | } 84 | 85 | 86 | static void *TermCopy(void *op) { 87 | void *np = gcnew(Term); 88 | memcpy(np, op, sizeof (Term)); 89 | return np; 90 | } 91 | 92 | static size_t TermScan(void *p) { 93 | Term *term = p; 94 | term->closure = forward(term->closure); 95 | term->str = forward(term->str); 96 | return sizeof (Term); 97 | } 98 | 99 | extern Boolean termeq(Term *term, const char *s) { 100 | assert(term != NULL); 101 | if (term->str == NULL) 102 | return FALSE; 103 | return streq(term->str, s); 104 | } 105 | 106 | extern Boolean isclosure(Term *term) { 107 | assert(term != NULL); 108 | return term->closure != NULL; 109 | } 110 | -------------------------------------------------------------------------------- /term.h: -------------------------------------------------------------------------------- 1 | /* term.h -- definition of term structure ($Revision: 1.1.1.1 $) */ 2 | 3 | struct Term { 4 | char *str; 5 | Closure *closure; 6 | }; 7 | -------------------------------------------------------------------------------- /test/test.es: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/es 2 | 3 | # test.es -- The entry point for es tests. 4 | 5 | # Invoke like: 6 | # ; /path/to/es -s < test.es (--junit) (tests/test1.es tests/test2.es ...) 7 | # 8 | # --junit makes test.es report test results in junit xml compatible with 9 | # circleci. Don't use it if you're planning on using human eyes to parse the 10 | # results. 11 | 12 | # Test state tracking variables. Once the test finishes running, the `report` 13 | # function uses these to print the results of the test. 14 | let ( 15 | name = () 16 | cases = () 17 | passed-cases = () 18 | failed-cases = () 19 | failure-msgs = () 20 | test-execution-failure = () 21 | ) 22 | # xml-escape is necessary to smush arbitrary text coming from es into junit XML. 23 | let ( 24 | fn xml-escape { 25 | let (result = ()) { 26 | for (string = $*) { 27 | string = <={%flatten '&' <={%fsplit '&' $string}} 28 | string = <={%flatten '"' <={%fsplit " $string}} 29 | string = <={%flatten ''' <={%fsplit '''' $string}} 30 | string = <={%flatten '<' <={%fsplit '<' $string}} 31 | result = $result <={%flatten '>' <={%fsplit '>' $string}} 32 | } 33 | result $result 34 | } 35 | } 36 | ) 37 | # These functions manage the test state variables. report prints out the 38 | # results of the test, and returns false if any cases failed. 39 | let ( 40 | fn new-test title { 41 | name = $title 42 | cases = () 43 | passed-cases = () 44 | failed-cases = () 45 | failure-msgs = () 46 | test-execution-failure = () 47 | } 48 | 49 | fn fail-case test-name cmd msg { 50 | cases = $cases $^cmd 51 | failed-cases = $failed-cases $^cmd 52 | failure-msgs = $failure-msgs $^msg 53 | } 54 | 55 | fn pass-case test-name cmd { 56 | cases = $cases $^cmd 57 | passed-cases = $passed-cases $^cmd 58 | } 59 | 60 | fn report { 61 | if $junit { 62 | echo <={%flatten '' \ 63 | ' '} 67 | 68 | for (case = $cases) { 69 | echo -n <={%flatten '' ' ' 72 | for (fcase = $failed-cases; msg = $failure-msgs) 73 | if {~ $case $fcase} { 74 | echo <={%flatten '' ' '} 76 | echo <={xml-escape $msg} 77 | echo ' ' 78 | echo ' ' 79 | } 80 | } { 81 | echo '/>' 82 | } 83 | } 84 | 85 | echo ' ' 86 | } { 87 | if {~ $failed-cases ()} { 88 | echo -n $^name^': ' 89 | } { 90 | echo $name 91 | for (case = $failed-cases; msg = $failure-msgs) 92 | echo - $case failed $msg 93 | } 94 | if {!~ $test-execution-failure ()} { 95 | echo test execution failure: $test-execution-failure 96 | } {~ $#failed-cases 0} { 97 | echo passed! 98 | } { 99 | echo - $#passed-cases cases passed, $#failed-cases failed. 100 | } 101 | } 102 | result $#failed-cases 103 | } 104 | ) 105 | # test is the function which can be called in the test files to actually run 106 | # tests. It locally defines an assert function, which is invoked within the 107 | # test body to make up each test case. after the test body is done executing, 108 | # test will call report to print the results of the test. 109 | let (status = ()) { 110 | fn test title testbody { 111 | local ( 112 | fn assert cmd message { 113 | let (result = ()) { 114 | if {~ $message ()} { 115 | message = $^cmd 116 | } { 117 | message = $^message 118 | } 119 | catch @ e { 120 | fail-case $title $message $e 121 | return 122 | } { 123 | result = <={$cmd} 124 | } 125 | if {result $result} { 126 | pass-case $title $message 127 | } { 128 | fail-case $title $message 129 | } 130 | } 131 | } 132 | ) { 133 | new-test $title 134 | catch @ e { 135 | test-execution-failure = $e 136 | } { 137 | $testbody 138 | } 139 | status = $status <=report 140 | } 141 | } 142 | 143 | fn report-testfile { 144 | let (s = $status) { 145 | status = () 146 | result $s 147 | } 148 | } 149 | } 150 | 151 | noexport = $noexport fn-assert fn-test fn-report-testfile 152 | 153 | # $es contains the path to es which the tests can use to refer to "the es binary 154 | # under test". 155 | es = $0 156 | junit = false 157 | 158 | if {~ $1 --junit} { 159 | junit = true 160 | * = $*(2 ...) 161 | } 162 | 163 | if $junit { 164 | echo '' 165 | echo '' 166 | } 167 | 168 | # The status variable tracks the successes/failures of all the test files being 169 | # invoked so that test.es can correctly exit true or false based on whether all 170 | # the tests passed. 171 | let (status = ()) { 172 | for (testfile = $*) { 173 | . $testfile 174 | status = $status <=report-testfile 175 | } 176 | 177 | if $junit { 178 | echo '' 179 | } 180 | 181 | result $status 182 | } 183 | -------------------------------------------------------------------------------- /test/testrun.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | /* Print an es script with a \0 in the middle. 6 | * Blatant ripoff of rc's version. */ 7 | static int print0(void) { 8 | putchar('r'); putchar('e'); 9 | putchar('\0'); 10 | putchar('s'); putchar('u'); 11 | putchar('l'); putchar('t'); 12 | putchar(' '); putchar('6'); 13 | putchar('\n'); 14 | return 0; 15 | } 16 | 17 | /* Sleep for a while. */ 18 | static int dosleep(void) { 19 | return sleep(5); 20 | } 21 | 22 | int main(int argc, char **argv) { 23 | if (argc < 2 || argv[1][0] == '\0') { 24 | fprintf(stderr, "give testrun a command\n"); 25 | exit(2); 26 | } 27 | switch (argv[1][0]) { 28 | case '0': 29 | return print0(); 30 | case 's': 31 | return dosleep(); 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /test/tests/access.es: -------------------------------------------------------------------------------- 1 | # tests/access.es -- verify $&access behaviors are correct 2 | 3 | # these need improvement 4 | # TODO: add tests for "search" behavior 5 | 6 | test 'file permissions' { 7 | assert {access -x $es} 8 | } 9 | 10 | test 'file types' { 11 | assert {access -d /} 12 | assert {!access -d $es} 13 | touch regular 14 | ln -s regular symbolic 15 | unwind-protect { 16 | assert {access -f regular} 17 | assert {access -l symbolic} 18 | assert {!access -l regular} 19 | assert {access -f symbolic} 20 | } { 21 | rm -f symbolic regular 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /test/tests/example.es: -------------------------------------------------------------------------------- 1 | # tests/example.es -- verify the test harness, and demonstrate how it works. 2 | 3 | # 4 | # The basic structure of a test: `test NAME BLOCK` 5 | # 6 | # The test block should (if you want the test to actually be useful) contain one 7 | # or more `assert` commands. 8 | # 9 | # Note that if an exception is thrown and not handled in the test block, the 10 | # entire test will automatically be considered failed. 11 | # 12 | 13 | test 'matches match' { 14 | # Usage: assert CMD NAME 15 | assert {~ x (x y z)} 16 | 17 | # It can be used within more complicated code as well. 18 | let (list = `{echo a b c d}) 19 | assert {~ $list(2) b} 20 | 21 | # An assert can be passed a name, which can be useful for diagnostics. 22 | assert {~ $undefined-variable ()} 'undefined variable produces an empty list' 23 | } 24 | 25 | test 'redirects redirect' { 26 | # Here's a more complex test where we actually do some setup and the test cases 27 | # build upon each other. 28 | let (test-file = `{mktemp redirect-file.XXXXXX}) 29 | unwind-protect { 30 | assert {~ `{cat <<< $test-file} $test-file} 'herestring herestrings' 31 | 32 | echo 'hi' > $test-file 33 | assert {~ `` () {cat $test-file} 'hi'\n} 'write writes' 34 | echo 'hello' >> $test-file 35 | assert {~ `` () {cat $test-file} 'hi'\n'hello'\n} 'append appends' 36 | echo 'overwrite' > $test-file 37 | assert {~ `` () {cat $test-file} 'overwrite'\n} 'write overwrites' 38 | } { 39 | rm -f $test-file 40 | assert {!access -f $test-file} 'file is deleted after test' 41 | } 42 | } 43 | -------------------------------------------------------------------------------- /test/tests/glob.es: -------------------------------------------------------------------------------- 1 | # tests/glob.es -- verify basic filesystem globbing works 2 | 3 | test 'file globbing' { 4 | let (dir = `{mktemp -d glob-dir.XXXXXX}) 5 | let (files = $dir^/^(aa bb cc)) { 6 | touch $files $dir/.hidden 7 | unwind-protect { 8 | for (want = $files; got = $dir/*) assert {~ $got $want} 9 | for (want = $files; got = $dir/??) assert {~ $got $want} 10 | let (bogus = $dir/???) assert {~ $bogus $dir^'/???'} 11 | let (got = $dir/?b) assert {~ $#got 1 && ~ $got $dir/bb} 12 | for (want = $dir/. $dir/.. $dir/.hidden; got = $dir/.*) 13 | assert {~ $got $want} 14 | let (quoted = $dir/'??') assert {~ $quoted $dir^'/??'} 15 | } { 16 | rm -rf $dir 17 | } 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /test/tests/match.es: -------------------------------------------------------------------------------- 1 | # tests/match.es -- verify the match command works 2 | 3 | # This is migrated from trip.es, but the match section is big enough that it 4 | # deserves its own file. 5 | 6 | test 'match/if equivalence' { 7 | for (subjstr = ( '()' 'foo' )) { 8 | subj = <={eval result $subjstr} 9 | for ( 10 | exp = ( 11 | <={} 12 | <={if {~ $subj}{result CMD}} 13 | <={if {~ $subj}{result CMD1}{result CMD2}} 14 | <={if {~ $subj *}{result CMD1}{result CMD2}} 15 | ) 16 | rc = ( 17 | <={match $subj ()} 18 | <={match $subj (() {result CMD})} 19 | <={match $subj ( 20 | () {result CMD1}; * {result CMD2} 21 | )} 22 | <={match $subj ( * {result CMD1} 23 | * {result CMD2};)} 24 | ) 25 | ) { 26 | assert {~ $exp $rc} 'match1 '^$subjstr^' -- '^$rc^' matches '^$exp 27 | } 28 | } 29 | } 30 | 31 | test 'subjects' { 32 | let ( 33 | subjects = ( 34 | # ??zz -- wildcards can be used in patterns to match subjects 35 | '(fizz buzz)' 36 | # [1-9] -- cases are evaluated in order of appearance, 37 | # and [1-9] comes before ??zz 38 | '(buzz 4 fizz 2 1)' 39 | # a* c* -- 'case patt1 patt2' matches like '~ $subj patt1 patt2' 40 | '(he ate it all)' 41 | '(bravo charlie)' 42 | # list.o -- wildcards are expanded in subjects 43 | 'l*.o' 44 | # *.o -- wildcards are not expanded in patterns 45 | 'nonexistent.o' 46 | # * -- catch-all for subjects that did not match any preceding patterns 47 | # 48 | # 'case *' should be last in every switch, but ensuring that would make 49 | # parsing more complicated and adding a 'default' keyword would just be 50 | # one more keyword to break existing scripts. 51 | '(20 fizzy ''think up different'' match.c)' 52 | ) 53 | if-block = ' 54 | if {~ $subj list.o} { 55 | result list 56 | } {~ $subj *.o} { 57 | result object 58 | } {~ $subj [1-9]} { 59 | result digit 60 | } {~ $subj ??zz} { 61 | result fizz/buzz 62 | } {~ $subj a* c*} { 63 | result AC_OUTPUT 64 | } { 65 | result other 66 | }' 67 | match-block = 'match $subj ( 68 | list.o {result list} 69 | *.o {result object} 70 | [1-9] {result digit} 71 | ??zz {result fizz/buzz} 72 | (a* c*) {result AC_OUTPUT} 73 | * {result other} 74 | )' 75 | ) 76 | for (subjstr = $subjects) { 77 | let ( 78 | subj = <={eval result $subjstr} 79 | exp = <={eval $if-block} 80 | rc = <={eval $match-block} 81 | ) 82 | assert {~ $exp $rc} 'match2 '^$subjstr^' -- '^$rc^' matches '^$exp 83 | } 84 | } 85 | 86 | # The following ensures that the body of a case does not require 87 | # braces and that 'match' has no special handling for 'break'. 88 | test 'error handling' { 89 | let (stderr = `{mktemp match-stderr.XXXXXX}) 90 | unwind-protect { 91 | $es -c 'match () (* break)' >[2] $stderr 92 | assert {~ `^{cat $stderr} *'uncaught exception'*} 93 | } { 94 | rm -f $stderr 95 | } 96 | } 97 | -------------------------------------------------------------------------------- /test/tests/option.es: -------------------------------------------------------------------------------- 1 | # tests/option.es -- verify that es handles command line arguments correctly 2 | 3 | test 'es -c' { 4 | assert {!$es -c >[2] /dev/null} 'bad flags produce a bad exit status' 5 | assert {~ `` \n {$es -c 'echo $0 $2 $#*' a b c d e f} <={%flatten ' ' $es b 6}} 'shell positional args represented correctly' 6 | assert {~ `` \n {$es -c 'echo command # comment'} 'command'} 'comments in command strings ignored correctly' 7 | } 8 | 9 | test 'es -e' { 10 | let (temp = `{mktemp es-e-script.XXXXXX}) 11 | unwind-protect { 12 | for ( (command continue) = ( 13 | # commands 14 | 'false' false 15 | 'if {false} {true}' true 16 | 'if {true} {false}' false 17 | 'if {false; true} {true}' true 18 | 'if {true} {false; true}' false 19 | 'if {false} {true} {false; true}' false 20 | '{true; {true; {false; true}}}' false 21 | 22 | # assignments 23 | 'x = false' false 24 | 'fn x {false}' false 25 | '{true; {true; {x = false}; true}}' false 26 | 'let (x = false) true' true 27 | 'local (x = false) true' true 28 | )) { 29 | cat > $temp << EOF 30 | echo -n one 31 | $command 32 | echo two 33 | EOF 34 | let (want = <={if $continue {result 'onetwo'} {result 'one'}}) 35 | assert {~ `` \n {$es -e $temp} $want} -e handles $command 36 | } 37 | } { 38 | rm -f $temp 39 | } 40 | 41 | let (output = ()) { 42 | local (fn %batch-loop {false; $&batchloop $*}) 43 | output = `` \n {$es -ec 'echo okay'} 44 | assert {~ $output 'okay'} es -e does not stop execution outside of %dispatch 45 | } 46 | } 47 | 48 | test 'es -p' { 49 | local ( 50 | variable = value 51 | fn-function = echo -n body 52 | ) { 53 | assert {~ `` \n {$es -c '$fn-function; echo $variable'} 'bodyvalue'} 54 | assert {~ `` \n {$es -pc '$fn-function; echo $variable'} 'value'} 55 | } 56 | } 57 | 58 | test 'es -i' { 59 | local ( 60 | fn %batch-loop {echo 'batch loop'} 61 | fn %interactive-loop {echo 'interactive loop'} 62 | ) { 63 | assert {~ `` \n {$es -c 'echo fail'} 'batch loop'} 'es -c is non-interactive by default' 64 | assert {~ `` \n {$es -ic 'echo fail'} 'interactive loop'} 'es -i forces interactive' 65 | } 66 | } 67 | -------------------------------------------------------------------------------- /test/tests/regression.es: -------------------------------------------------------------------------------- 1 | # regression.es -- regression tests for previous bugs 2 | 3 | # these may be redundant with other tests, but what's the harm in having a 4 | # little redundancy? 5 | 6 | # These tests are based on bug reports and PRs on github. 7 | # TODO not all tagged bugs have been covered. Some are hard to repro. 8 | test 'regressions' { 9 | # https://github.com/wryun/es-shell/issues/5 10 | assert {~ `` \n {$&a. >[2=1]} 'invalid primitive name: $&a^.'} 11 | 12 | # https://github.com/wryun/es-shell/issues/7 13 | # slow and busy, but we're testing for a race condition 14 | assert {!{{ 15 | for (i = `{awk 'BEGIN {for (i=1;i<=100;i++)print i}'}) 16 | $es -c 'signals = sigterm; kill $pid' 17 | } |[2] grep child}} 18 | 19 | # https://github.com/wryun/es-shell/issues/8 20 | let (fd = <=%newfd) { 21 | catch @ {} { 22 | %open $fd /dev/null { 23 | throw blah 24 | } 25 | } 26 | let (exception = ()) { 27 | catch @ e {exception = $e} {%dup 1 $fd {}} 28 | assert {!~ $exception ()} 29 | } 30 | } 31 | 32 | # https://github.com/wryun/es-shell/issues/57 33 | assert {~ `` \n {let (n = '%closure (x = y) echo $x') {$n}} y} 34 | 35 | # https://github.com/wryun/es-shell/issues/63 36 | assert {~ `` \n {() echo success} success} 37 | 38 | # https://github.com/wryun/es-shell/issues/68 39 | assert {$es -c {catch @ {} {'%closure ()'}}} 40 | 41 | # https://github.com/wryun/es-shell/issues/78 42 | # this one requires GCDEBUG=1 43 | assert {$es '-cresult'} 44 | 45 | # https://github.com/wryun/es-shell/issues/85 46 | assert {$es -c { 47 | set-foo = result 48 | catch @ {} { 49 | local (foo = !) { 50 | throw whatever 51 | } 52 | } 53 | }} 54 | 55 | # https://github.com/wryun/es-shell/issues/87 56 | assert {$es -c { 57 | catch @ {} { 58 | local (var = !) { 59 | set-var = {throw something} 60 | } 61 | } 62 | }} 63 | 64 | # https://github.com/wryun/es-shell/issues/93 65 | assert {./testrun 0 | {catch @ {} {%read}}} 66 | 67 | # https://github.com/wryun/es-shell/issues/99 68 | assert {$es -c {catch @ {} {echo >[1=]}}} 69 | 70 | # https://github.com/wryun/es-shell/issues/104 71 | assert {$es -c 'eval {}'} 72 | 73 | # https://github.com/wryun/es-shell/issues/150 74 | assert {!$es >[2] /dev/null << EOF 75 | %read << EOM 76 | hello 77 | EOM 78 | wait 79 | EOF 80 | } 81 | 82 | # https://github.com/wryun/es-shell/issues/180 83 | assert {!$es -ec 'if {false} {true} {false; true}'} 84 | 85 | # https://github.com/wryun/es-shell/issues/191 86 | # this one actually would hang before the fix on systems with 87 | # unsigned chars 88 | assert {!$es -c 'echo hi |[2' >[2] /dev/null} 89 | 90 | # https://github.com/wryun/es-shell/issues/199 91 | assert {~ `` \n {echo 'fn-%write-history = $&collect'^\n^'cat << eof' | $es -i >[2=1]} *'incomplete here document'*} 92 | 93 | # https://github.com/wryun/es-shell/issues/206 94 | assert {~ `` \n {$es -c 'let (a=<=true) echo $a'} <=true} 'concatenated assignment+call syntax works' 95 | } 96 | 97 | # These tests are based on notes in the CHANGES file from the pre-git days. 98 | test 'old regressions' { 99 | # TODO variable export/import deserves much more testing 100 | local ('x=y' = very good stuff) 101 | assert {~ `` \n {$es -c 'echo $''x=y'''} 'very good stuff'} \ 102 | '''='' in exported variable names works' 103 | 104 | local (x = y) { 105 | assert {~ `` \n {env | grep '^x='} 'x=y'} 106 | local (x = '') 107 | assert {~ `` \n {env | grep '^x='} 'x='} 108 | local (x = ()) 109 | assert {~ `` \n {env | grep '^x='} ()} 110 | } 111 | 112 | let (exception = ()) { 113 | catch @ e {exception = $e} { 114 | for (a = <={break; result b}) { 115 | assert {false} 'break in binder escapes for loop' 116 | } 117 | } 118 | assert {~ $exception(1) break} 'for does not catch break in binder' 119 | } 120 | 121 | let (a = b) { 122 | {a = c} >[1=2] 123 | assert {~ $a c} 124 | {a = d} >[1=] 125 | assert {~ $a d} 126 | {a = e} < /dev/null 127 | assert {~ $a e} 128 | } 129 | 130 | assert {!~ '-' [a-z]} 131 | assert {~ q [a-z]} 132 | assert {~ '-' [a'-'z]} 133 | assert {!~ q [a'-'z]} 134 | assert {~ '-' [-az]} 135 | assert {~ '-' [az-]} 136 | } 137 | -------------------------------------------------------------------------------- /test/tests/syntax.es: -------------------------------------------------------------------------------- 1 | # tests/syntax.es -- verify that basic syntax handling is correct 2 | 3 | # Note the awkward-looking '{' and '}' around commands here. This prevents 4 | # capturing lexical bindings, so that 5 | # 6 | # {want} 7 | # 8 | # doesn't turn into 9 | # 10 | # %closure(have='garbage text';want='essentially line noise'){want} 11 | # 12 | # which would make tests unnecessarily annoying to write. 13 | 14 | test 'syntactic sugar' { 15 | for ( (have want) = ( 16 | # Control Flow 17 | '! cmd' '%not {cmd}' 18 | 'cmd &' '%background {cmd}' 19 | 'cmd1 ; cmd2' '%seq {cmd1} {cmd2}' 20 | 'cmd1 && cmd2' '%and {cmd1} {cmd2}' 21 | 'cmd1 || cmd2' '%or {cmd1} {cmd2}' 22 | # NOTE: different whitespace from the man page 23 | 'fn name args { cmd }' 'fn-^name=@ args{cmd}' 24 | # added case for * which is handled separately 25 | 'fn name { cmd }' 'fn-^name=@ *{cmd}' 26 | 27 | # Input/Output Commands 28 | # NOTE: the <={%one file} part of these is not mentioned in the man page 29 | 'cmd < file' '%open 0 <={%one file} {cmd}' 30 | 'cmd > file' '%create 1 <={%one file} {cmd}' 31 | 'cmd >[6] file' '%create 6 <={%one file} {cmd}' 32 | 'cmd >> file' '%append 1 <={%one file} {cmd}' 33 | 'cmd <> file' '%open-write 0 <={%one file} {cmd}' 34 | 'cmd <>> file' '%open-append 0 <={%one file} {cmd}' 35 | 'cmd >< file' '%open-create 1 <={%one file} {cmd}' 36 | 'cmd >>< file' '%open-append 1 <={%one file} {cmd}' 37 | 'cmd >[7=]' '%close 7 {cmd}' 38 | 'cmd >[8=9]' '%dup 8 9 {cmd}' 39 | 'cmd <<< string' '%here 0 string {cmd}' 40 | 'cmd1 | cmd2' '%pipe {cmd1} 1 0 {cmd2}' 41 | 'cmd1 |[10=11] cmd2' '%pipe {cmd1} 10 11 {cmd2}' 42 | # readfrom/writeto handled specially below 43 | 44 | # Expressions 45 | '$#var' '<={%count $var}' 46 | '$^var' '<={%flatten '' '' $var}' 47 | '`{cmd args}' '<={%backquote <={%flatten '''' $ifs} {cmd args}}' 48 | '``ifs {cmd args}' '<={%backquote <={%flatten '''' ifs} {cmd args}}' 49 | # NOTE: these lines are missing from this section of the man page! 50 | '`^{cmd args}' '<={%flatten '' '' <={%backquote <={%flatten '''' $ifs} {cmd args}}}' 51 | '``^ifs {cmd args}' '<={%flatten '' '' <={%backquote <={%flatten '''' ifs} {cmd args}}}' 52 | )) { 53 | assert {~ `` \n {eval echo '{'$have'}'} '{'$want'}'} $have 'is rewritten to' $want 54 | } 55 | } 56 | 57 | test 'readfrom/writeto sugar' { 58 | for ((have want) = ( 59 | 'cmd1 >{ cmd2 }' '%writeto _devfd0 {cmd2} {cmd1 $_devfd0}' 60 | 'cmd1 <{ cmd2 }' '%readfrom _devfd0 {cmd2} {cmd1 $_devfd0}' 61 | )) { 62 | # using a totally new es forces _devfd0 specifically 63 | assert {~ `` \n {$es -c 'echo {'$have'}'} '{'$want'}'} 64 | } 65 | } 66 | 67 | test 'heredoc sugar' { 68 | let ( 69 | # NOTE: is it a bug that this only works with the closing newline? 70 | have = 'cmd << tag 71 | input 72 | tag 73 | ' 74 | want = '%here 0 ''input''^\n {cmd}' 75 | ) { 76 | assert {~ `` \n {eval echo '{'$have'}'} '{'$want'}'} 77 | } 78 | } 79 | 80 | test 'match sugar' { 81 | let ( 82 | have = 'match $sound ( 83 | $bc {result 3} 84 | ($bp $bw *ow) {} 85 | * { 86 | false 87 | } 88 | )' 89 | 90 | # bit awkward 91 | want = 'local(matchexpr=$sound){'^\ 92 | 'if {~ $matchexpr $bc} {result 3} '^\ 93 | '{~ $matchexpr $bp $bw *ow} {} '^\ 94 | '{~ $matchexpr *} {false}'^\ 95 | '}' 96 | ) { 97 | assert {~ `` \n {eval echo '{'$have'}'} '{'$want'}'} 98 | } 99 | } 100 | 101 | test 'complex variables' { 102 | for (syntax = ( 103 | '$()' 104 | '$foo' 105 | '$(foo bar)' 106 | '$(foo^$bar)' 107 | '$(<={foo})' 108 | )) { 109 | assert {~ `` \n {eval echo '{'$syntax'}'} '{'^$syntax^'}'} 110 | } 111 | } 112 | 113 | test 'precedence' { 114 | for ((have want) = ( 115 | 'a || b | c' '%or {a} {%pipe {b} 1 0 {c}}' 116 | 'a | b || c' '%or {%pipe {a} 1 0 {b}} {c}' 117 | '!a && b' '%and {%not {a}} {b}' 118 | '!a || b' '%or {%not {a}} {b}' 119 | '!a & b' '%seq {%background {%not {a}}} {b}' 120 | '!a | b' '%not {%pipe {a} 1 0 {b}}' 121 | 'let (a=b) x && y' 'let(a=b)%and {x} {y}' 122 | 'let (a=b) x || y' 'let(a=b)%or {x} {y}' 123 | 'let (a=b) x & y' '%seq {%background {let(a=b)x}} {y}' 124 | 'let (a=b) x | y' 'let(a=b)%pipe {x} 1 0 {y}' 125 | 'a && b > c' '%and {a} {%create 1 <={%one c} {b}}' 126 | 'a | b > c' '%pipe {a} 1 0 {%create 1 <={%one c} {b}}' 127 | 'let (a=b) c > d' 'let(a=b)%create 1 <={%one d} {c}' 128 | )) { 129 | assert {~ `` \n {eval echo '{'$have'}'} '{'$want'}'} 130 | } 131 | } 132 | -------------------------------------------------------------------------------- /test/tests/wait.es: -------------------------------------------------------------------------------- 1 | # tests/wait.es -- verify behaviors around backgrounding and wait are correct 2 | 3 | test 'exit status' { 4 | let (pid = <={$&background {result 3}}) { 5 | let (status = <={wait $pid >[2] /dev/null}) 6 | assert {~ $status 3} 7 | } 8 | 9 | let (pid = <={$&background {./testrun s}}) { 10 | kill -TERM $pid 11 | let (status = <={wait $pid >[2] /dev/null}) 12 | assert {~ $status sigterm} 13 | } 14 | 15 | # let (pid = <={$&background {./testrun s}}) { 16 | # kill -QUIT $pid 17 | # # TODO: clean up core file? 18 | # let (status = <={wait $pid >[2] /dev/null}) 19 | # assert {~ $status sigquit+core} 20 | # } 21 | } 22 | 23 | test 'wait is precise' { 24 | let (pid = <={$&background {result 99}}) { 25 | assert {~ <=%apids $pid} 26 | assert {~ <=%apids $pid} 'apids is stable' 27 | fork {} 28 | assert {~ <=%apids $pid} 'waiting is precise' 29 | assert {~ <={wait $pid} 99} 'exit status is available' 30 | } 31 | } 32 | 33 | test 'setpgid' { 34 | let (pid = <={$&background {./testrun s}}) { 35 | assert {ps -o pid | grep $pid > /dev/null} 'background process appears in ps' 36 | kill $pid 37 | wait $pid >[2] /dev/null 38 | assert {!{ps -o pid | grep $pid}} 39 | } 40 | } 41 | -------------------------------------------------------------------------------- /tree.c: -------------------------------------------------------------------------------- 1 | /* tree.c -- functions for manipulating parse-trees. (create, copy, scan) ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | 6 | DefineTag(Tree1, static); 7 | DefineTag(Tree2, static); 8 | 9 | /* gmk -- make a new node; used to generate the parse tree */ 10 | static Tree *gmk(void *(*alloc)(size_t, Tag *), NodeKind t, va_list ap) { 11 | Tree *n; 12 | 13 | gcdisable(); 14 | switch (t) { 15 | default: 16 | panic("mk: bad node kind %d", t); 17 | case nWord: case nQword: case nPrim: 18 | n = alloc(offsetof(Tree, u[1]), &Tree1Tag); 19 | n->u[0].s = va_arg(ap, char *); 20 | break; 21 | case nCall: case nThunk: case nVar: 22 | n = alloc(offsetof(Tree, u[1]), &Tree1Tag); 23 | n->u[0].p = va_arg(ap, Tree *); 24 | break; 25 | case nAssign: case nConcat: case nClosure: case nFor: 26 | case nLambda: case nLet: case nList: case nLocal: 27 | case nVarsub: case nMatch: case nExtract: 28 | n = alloc(offsetof(Tree, u[2]), &Tree2Tag); 29 | n->u[0].p = va_arg(ap, Tree *); 30 | n->u[1].p = va_arg(ap, Tree *); 31 | break; 32 | case nRedir: 33 | n = alloc(offsetof(Tree, u[2]), NULL); 34 | n->u[0].p = va_arg(ap, Tree *); 35 | n->u[1].p = va_arg(ap, Tree *); 36 | break; 37 | case nPipe: 38 | n = alloc(offsetof(Tree, u[2]), NULL); 39 | n->u[0].i = va_arg(ap, int); 40 | n->u[1].i = va_arg(ap, int); 41 | break; 42 | } 43 | n->kind = t; 44 | 45 | Ref(Tree *, tree, n); 46 | gcenable(); 47 | RefReturn(tree); 48 | } 49 | 50 | extern Tree *mk VARARGS1(NodeKind, t) { 51 | va_list ap; 52 | Tree *tree = NULL; 53 | VA_START(ap, t); 54 | tree = gmk(palloc, t, ap); 55 | va_end(ap); 56 | return tree; 57 | } 58 | 59 | extern Tree *gcmk VARARGS1(NodeKind, t) { 60 | va_list ap; 61 | Ref(Tree *, tree, NULL); 62 | VA_START(ap, t); 63 | tree = gmk(gcalloc, t, ap); 64 | va_end(ap); 65 | RefReturn(tree); 66 | } 67 | 68 | 69 | /* 70 | * garbage collection functions 71 | * these are segregated by size so copy doesn't have to check 72 | * the type to figure out size. 73 | */ 74 | 75 | static void *Tree1Copy(void *op) { 76 | void *np = gcalloc(offsetof(Tree, u[1]), &Tree1Tag); 77 | memcpy(np, op, offsetof(Tree, u[1])); 78 | return np; 79 | } 80 | 81 | static void *Tree2Copy(void *op) { 82 | void *np = gcalloc(offsetof(Tree, u[2]), &Tree2Tag); 83 | memcpy(np, op, offsetof(Tree, u[2])); 84 | return np; 85 | } 86 | 87 | static size_t Tree1Scan(void *p) { 88 | Tree *n = p; 89 | switch (n->kind) { 90 | default: 91 | panic("Tree1Scan: bad node kind %d", n->kind); 92 | case nPrim: case nWord: case nQword: 93 | n->u[0].s = forward(n->u[0].s); 94 | break; 95 | case nCall: case nThunk: case nVar: 96 | n->u[0].p = forward(n->u[0].p); 97 | break; 98 | } 99 | return offsetof(Tree, u[1]); 100 | } 101 | 102 | static size_t Tree2Scan(void *p) { 103 | Tree *n = p; 104 | switch (n->kind) { 105 | case nAssign: case nConcat: case nClosure: case nFor: 106 | case nLambda: case nLet: case nList: case nLocal: 107 | case nVarsub: case nMatch: case nExtract: 108 | n->u[0].p = forward(n->u[0].p); 109 | n->u[1].p = forward(n->u[1].p); 110 | break; 111 | default: 112 | panic("Tree2Scan: bad node kind %d", n->kind); 113 | } 114 | return offsetof(Tree, u[2]); 115 | } 116 | -------------------------------------------------------------------------------- /util.c: -------------------------------------------------------------------------------- 1 | /* util.c -- the kitchen sink ($Revision: 1.2 $) */ 2 | 3 | #include "es.h" 4 | 5 | #if !HAVE_STRERROR 6 | /* strerror -- turn an error code into a string */ 7 | static char *strerror(int n) { 8 | extern int sys_nerr; 9 | extern char *sys_errlist[]; 10 | if (n > sys_nerr) 11 | return NULL; 12 | return sys_errlist[n]; 13 | } 14 | 15 | #endif 16 | 17 | /* esstrerror -- a wrapper around sterror(3) */ 18 | extern char *esstrerror(int n) { 19 | char *error = strerror(n); 20 | 21 | if (error == NULL) 22 | return "unknown error"; 23 | return error; 24 | } 25 | 26 | 27 | 28 | /* uerror -- print a unix error, our version of perror */ 29 | extern void uerror(char *s) { 30 | if (s != NULL) 31 | eprint("%s: %s\n", s, esstrerror(errno)); 32 | else 33 | eprint("%s\n", esstrerror(errno)); 34 | } 35 | 36 | /* isabsolute -- test to see if pathname begins with "/", "./", or "../" */ 37 | extern Boolean isabsolute(char *path) { 38 | return path[0] == '/' 39 | || (path[0] == '.' && (path[1] == '/' 40 | || (path[1] == '.' && path[2] == '/'))); 41 | } 42 | 43 | /* streq2 -- is a string equal to the concatenation of two strings? */ 44 | extern Boolean streq2(const char *s, const char *t1, const char *t2) { 45 | int c; 46 | assert(s != NULL && t1 != NULL && t2 != NULL); 47 | while ((c = *t1++) != '\0') 48 | if (c != *s++) 49 | return FALSE; 50 | while ((c = *t2++) != '\0') 51 | if (c != *s++) 52 | return FALSE; 53 | return *s == '\0'; 54 | } 55 | 56 | 57 | /* 58 | * safe interface to malloc and friends 59 | */ 60 | 61 | /* ealloc -- error checked malloc */ 62 | extern void *ealloc(size_t n) { 63 | extern void *malloc(size_t n); 64 | void *p = malloc(n); 65 | if (p == NULL) { 66 | uerror("malloc"); 67 | esexit(1); 68 | } 69 | return p; 70 | } 71 | 72 | /* erealloc -- error checked realloc */ 73 | extern void *erealloc(void *p, size_t n) { 74 | extern void *realloc(void *, size_t); 75 | if (p == NULL) 76 | return ealloc(n); 77 | p = realloc(p, n); 78 | if (p == NULL) { 79 | uerror("realloc"); 80 | esexit(1); 81 | } 82 | return p; 83 | } 84 | 85 | /* efree -- error checked free */ 86 | extern void efree(void *p) { 87 | extern void free(void *); 88 | assert(p != NULL); 89 | free(p); 90 | } 91 | 92 | 93 | /* 94 | * private interfaces to system calls 95 | */ 96 | 97 | extern void ewrite(int fd, const char *buf, size_t n) { 98 | volatile long i, remain; 99 | const char *volatile bufp = buf; 100 | for (i = 0, remain = n; remain > 0; bufp += i, remain -= i) { 101 | interrupted = FALSE; 102 | if (!setjmp(slowlabel)) { 103 | slow = TRUE; 104 | if (interrupted) 105 | break; 106 | else if ((i = write(fd, bufp, remain)) <= 0) 107 | break; /* abort silently on errors in write() */ 108 | } else 109 | break; 110 | slow = FALSE; 111 | } 112 | slow = FALSE; 113 | } 114 | 115 | extern long eread(int fd, char *buf, size_t n) { 116 | long r; 117 | interrupted = FALSE; 118 | if (!setjmp(slowlabel)) { 119 | slow = TRUE; 120 | if (!interrupted) 121 | r = read(fd, buf, n); 122 | else 123 | r = -2; 124 | } else 125 | r = -2; 126 | slow = FALSE; 127 | if (r == -2) { 128 | errno = EINTR; 129 | r = -1; 130 | } 131 | return r; 132 | } 133 | -------------------------------------------------------------------------------- /var.h: -------------------------------------------------------------------------------- 1 | /* var.h -- es variables ($Revision: 1.1.1.1 $) */ 2 | 3 | typedef struct Var Var; 4 | struct Var { 5 | List *defn; 6 | char *env; 7 | int flags; 8 | }; 9 | 10 | #define var_hasbindings 1 11 | #define var_isinternal 2 12 | 13 | extern Dict *vars; 14 | -------------------------------------------------------------------------------- /vec.c: -------------------------------------------------------------------------------- 1 | /* vec.c -- argv[] and envp[] vectors ($Revision: 1.1.1.1 $) */ 2 | 3 | #include "es.h" 4 | #include "gc.h" 5 | 6 | DefineTag(Vector, static); 7 | 8 | extern Vector *mkvector(int n) { 9 | int i; 10 | Vector *v = gcalloc(offsetof(Vector, vector[n + 1]), &VectorTag); 11 | v->alloclen = n; 12 | v->count = 0; 13 | for (i = 0; i <= n; i++) 14 | v->vector[i] = NULL; 15 | return v; 16 | } 17 | 18 | static void *VectorCopy(void *ov) { 19 | size_t n = offsetof(Vector, vector[((Vector *) ov)->alloclen + 1]); 20 | void *nv = gcalloc(n, &VectorTag); 21 | memcpy(nv, ov, n); 22 | return nv; 23 | } 24 | 25 | static size_t VectorScan(void *p) { 26 | Vector *v = p; 27 | int i, n = v->count; 28 | for (i = 0; i <= n; i++) 29 | v->vector[i] = forward(v->vector[i]); 30 | return offsetof(Vector, vector[v->alloclen + 1]); 31 | } 32 | 33 | 34 | extern Vector *vectorize(List *list) { 35 | int i, n = length(list); 36 | 37 | Ref(Vector *, v, NULL); 38 | Ref(List *, lp, list); 39 | v = mkvector(n); 40 | v->count = n; 41 | 42 | for (i = 0; lp != NULL; lp = lp->next, i++) { 43 | char *s = getstr(lp->term); /* must evaluate before v->vector[i] */ 44 | v->vector[i] = s; 45 | } 46 | 47 | RefEnd(lp); 48 | RefReturn(v); 49 | } 50 | 51 | /* qstrcmp -- a strcmp wrapper for qsort */ 52 | extern int qstrcmp(const void *s1, const void *s2) { 53 | return strcmp(*(const char **)s1, *(const char **)s2); 54 | } 55 | 56 | /* sortvector */ 57 | extern void sortvector(Vector *v) { 58 | assert(v->vector[v->count] == NULL); 59 | qsort(v->vector, v->count, sizeof (char *), qstrcmp); 60 | } 61 | -------------------------------------------------------------------------------- /version.c: -------------------------------------------------------------------------------- 1 | #include "es.h" 2 | static const char id[] = "@(#)es version 0.9.2 2-Mar-2022"; 3 | const char * const version = id + (sizeof "@(#)" - 1); 4 | --------------------------------------------------------------------------------